(*
  File:    Hoeffding.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Hoeffding's Lemma and Hoeffding's Inequality\<close>
theory Hoeffding
  imports Product_PMF Independent_Family
begin

text \<open>
  Hoeffding's inequality shows that a sum of bounded independent random variables is concentrated
  around its mean, with an exponential decay of the tail probabilities.
\<close>

subsection \<open>Hoeffding's Lemma\<close>

lemma convex_on_exp:
  fixes l :: real
  assumes "l \<ge> 0"
  shows   "convex_on UNIV (\<lambda>x. exp(l*x))"
  using assms
  by (intro convex_on_realI[where f' = "\<lambda>x. l * exp (l * x)"])
     (auto intro!: derivative_eq_intros mult_left_mono)

lemma mult_const_minus_self_real_le:
  fixes x :: real
  shows "x * (c - x) \<le> c\<^sup>2 / 4"
proof -
  have "x * (c - x) = -(x - c / 2)\<^sup>2 + c\<^sup>2 / 4"
    by (simp add: field_simps power2_eq_square)
  also have "\<dots> \<le> 0 + c\<^sup>2 / 4"
    by (intro add_mono) auto
  finally show ?thesis by simp
qed

lemma Hoeffdings_lemma_aux:
  fixes h p :: real
  assumes "h \<ge> 0" and "p \<ge> 0"
  defines "L \<equiv> (\<lambda>h. -h * p + ln (1 + p * (exp h - 1)))"
  shows   "L h \<le> h\<^sup>2 / 8"
proof (cases "h = 0")
  case False
  hence h: "h > 0"
    using \<open>h \<ge> 0\<close> by simp
  define L' where "L' = (\<lambda>h. -p + p * exp h / (1 + p * (exp h - 1)))"
  define L'' where "L'' = (\<lambda>h. -(p\<^sup>2) * exp h * exp h / (1 + p * (exp h - 1))\<^sup>2 +
                              p * exp h / (1 + p * (exp h - 1)))"
  define Ls where "Ls = (\<lambda>n. [L, L', L''] ! n)"

  have [simp]: "L 0 = 0" "L' 0 = 0"
    by (auto simp: L_def L'_def)

  have L': "(L has_real_derivative L' x) (at x)" if "x \<in> {0..h}" for x
  proof -
    have "1 + p * (exp x - 1) > 0"
      using \<open>p \<ge> 0\<close> that by (intro add_pos_nonneg mult_nonneg_nonneg) auto
    thus ?thesis
      unfolding L_def L'_def by (auto intro!: derivative_eq_intros)
  qed

  have L'': "(L' has_real_derivative L'' x) (at x)" if "x \<in> {0..h}" for x
  proof -
    have *: "1 + p * (exp x - 1) > 0"
      using \<open>p \<ge> 0\<close> that by (intro add_pos_nonneg mult_nonneg_nonneg) auto
    show ?thesis
      unfolding L'_def L''_def
      by (insert *, (rule derivative_eq_intros refl | simp)+) (auto simp: divide_simps; algebra)
  qed

  have diff: "\<forall>m t. m < 2 \<and> 0 \<le> t \<and> t \<le> h \<longrightarrow> (Ls m has_real_derivative Ls (Suc m) t) (at t)"
    using L' L'' by (auto simp: Ls_def nth_Cons split: nat.splits)
  from Taylor[of 2 Ls L 0 h 0 h, OF _ _ diff]
    obtain t where t: "t \<in> {0<..<h}" "L h = L'' t * h\<^sup>2 / 2"
      using \<open>h > 0\<close> by (auto simp: Ls_def lessThan_nat_numeral)
  define u where "u = p * exp t / (1 + p * (exp t - 1))"

  have "L'' t = u * (1 - u)"
    by (simp add: L''_def u_def divide_simps; algebra)
  also have "\<dots> \<le> 1 / 4"
    using mult_const_minus_self_real_le[of u 1] by simp
  finally have "L'' t \<le> 1 / 4" .

  note t(2)
  also have "L'' t * h\<^sup>2 / 2 \<le> (1 / 4) * h\<^sup>2 / 2"
    using \<open>L'' t \<le> 1 / 4\<close> by (intro mult_right_mono divide_right_mono) auto
  finally show "L h \<le> h\<^sup>2 / 8" by simp
qed (auto simp: L_def)

locale interval_bounded_random_variable = prob_space +
  fixes f :: "'a \<Rightarrow> real" and a b :: real
  assumes random_variable [measurable]: "random_variable borel f"
  assumes AE_in_interval: "AE x in M. f x \<in> {a..b}"
begin

lemma integrable [intro]: "integrable M f"
proof (rule integrable_const_bound)
  show "AE x in M. norm (f x) \<le> max \<bar>a\<bar> \<bar>b\<bar>"
    by (intro eventually_mono[OF AE_in_interval]) auto
qed (fact random_variable)

text \<open>
  We first show Hoeffding's lemma for distributions whose expectation is 0. The general
  case will easily follow from this later.
\<close>
lemma Hoeffdings_lemma_nn_integral_0:
  assumes "l > 0" and E0: "expectation f = 0"
  shows   "nn_integral M (\<lambda>x. exp (l * f x)) \<le> ennreal (exp (l\<^sup>2 * (b - a)\<^sup>2 / 8))"
proof (cases "AE x in M. f x = 0")
  case True
  hence "nn_integral M (\<lambda>x. exp (l * f x)) = nn_integral M (\<lambda>x. ennreal 1)"
    by (intro nn_integral_cong_AE) auto
  also have "\<dots> = ennreal (expectation (\<lambda>_. 1))"
    by (intro nn_integral_eq_integral) auto
  finally show ?thesis by (simp add: prob_space)
next
  case False
  have "a < 0"
  proof (rule ccontr)
    assume a: "\<not>(a < 0)"
    have "AE x in M. f x = 0"
    proof (subst integral_nonneg_eq_0_iff_AE [symmetric])
      show "AE x in M. f x \<ge> 0"
        using AE_in_interval by eventually_elim (use a in auto)
    qed (use E0 in \<open>auto simp: id_def integrable\<close>)
    with False show False by contradiction
  qed

  have "b > 0"
  proof (rule ccontr)
    assume b: "\<not>(b > 0)"
    have "AE x in M. -f x = 0"
    proof (subst integral_nonneg_eq_0_iff_AE [symmetric])
      show "AE x in M. -f x \<ge> 0"
        using AE_in_interval by eventually_elim (use b in auto)
    qed (use E0 in \<open>auto simp: id_def integrable\<close>)
    with False show False by simp
  qed

  have "a < b"
    using \<open>a < 0\<close> \<open>b > 0\<close> by linarith

  define p where "p = -a / (b - a)"
  define L where "L = (\<lambda>t. -t* p + ln (1 - p + p * exp t))"
  define z where "z = l * (b - a)"
  have "z > 0"
    unfolding z_def using \<open>a < b\<close> \<open>l > 0\<close> by auto
  have "p > 0"
    using \<open>a < 0\<close> \<open>a < b\<close> unfolding p_def by (intro divide_pos_pos) auto

  have "(\<integral>\<^sup>+x. exp (l * f x) \<partial>M) \<le>
        (\<integral>\<^sup>+x. (b - f x) / (b - a) * exp (l * a) + (f x - a) / (b - a) * exp (l * b) \<partial>M)"
  proof (intro nn_integral_mono_AE eventually_mono[OF AE_in_interval] ennreal_leI)
    fix x assume x: "f x \<in> {a..b}"
    define y where "y = (b - f x) / (b-a)"
    have y: "y \<in> {0..1}"
      using x \<open>a < b\<close> by (auto simp: y_def)
    have conv: "convex_on UNIV (\<lambda>x. exp(l*x))"
      using \<open>l > 0\<close> by (intro convex_on_exp) auto
    have "exp (l * ((1 - y) *\<^sub>R b + y *\<^sub>R a)) \<le> (1 - y) * exp (l * b) + y * exp (l * a)"
      using y \<open>l > 0\<close> by (intro convex_onD[OF convex_on_exp]) auto
    also have "(1 - y) *\<^sub>R b + y *\<^sub>R a = f x"
      using \<open>a < b\<close> by (simp add: y_def divide_simps) (simp add: algebra_simps)?
    also have "1 - y = (f x - a) / (b - a)"
      using \<open>a < b\<close> by (simp add: field_simps y_def)
    finally show "exp (l * f x) \<le> (b - f x) / (b - a) * exp (l*a) + (f x - a)/(b-a) * exp (l*b)"
      by (simp add: y_def)
  qed
  also have "\<dots> = (\<integral>\<^sup>+x. ennreal (b - f x) * exp (l * a) / (b - a) +
                        ennreal (f x - a) * exp (l * b) / (b - a) \<partial>M)"
    using \<open>a < 0\<close> \<open>b > 0\<close>
    by (intro nn_integral_cong_AE eventually_mono[OF AE_in_interval])
       (simp add: ennreal_plus ennreal_mult flip: divide_ennreal)
  also have "\<dots> = ((\<integral>\<^sup>+ x. ennreal (b - f x) \<partial>M) * ennreal (exp (l * a)) +
                   (\<integral>\<^sup>+ x. ennreal (f x - a) \<partial>M) * ennreal (exp (l * b))) / ennreal (b - a)"
    by (simp add: nn_integral_add nn_integral_divide nn_integral_multc add_divide_distrib_ennreal)
  also have "(\<integral>\<^sup>+ x. ennreal (b - f x) \<partial>M) = ennreal (expectation (\<lambda>x. b - f x))"
    by (intro nn_integral_eq_integral Bochner_Integration.integrable_diff
              eventually_mono[OF AE_in_interval] integrable_const integrable) auto
  also have "expectation (\<lambda>x. b - f x) = b"
    using assms by (subst Bochner_Integration.integral_diff) (auto simp: prob_space)
  also have "(\<integral>\<^sup>+ x. ennreal (f x - a) \<partial>M) = ennreal (expectation (\<lambda>x. f x - a))"
    by (intro nn_integral_eq_integral Bochner_Integration.integrable_diff
              eventually_mono[OF AE_in_interval] integrable_const integrable) auto
  also have "expectation (\<lambda>x. f x - a) = (-a)"
    using assms by (subst Bochner_Integration.integral_diff) (auto simp: prob_space)
  also have "(ennreal b * (exp (l * a)) + ennreal (-a) * (exp (l * b))) / (b - a) =
             ennreal (b * exp (l * a) - a * exp (l * b)) / ennreal (b - a)"
    using \<open>a < 0\<close> \<open>b > 0\<close>
    by (simp flip: ennreal_mult ennreal_plus add: mult_nonpos_nonneg divide_ennreal mult_mono)
  also have "b * exp (l * a) - a * exp (l * b) = exp (L z) * (b - a)"
  proof -
    have pos: "1 - p + p * exp z > 0"
    proof -
      have "exp z > 1" using \<open>l > 0\<close> and \<open>a < b\<close>
        by (subst one_less_exp_iff) (auto simp: z_def intro!: mult_pos_pos)
      hence "(exp z - 1) * p \<ge> 0"
        unfolding p_def using \<open>a < 0\<close> and \<open>a < b\<close>
        by (intro mult_nonneg_nonneg divide_nonneg_pos) auto
      thus ?thesis
        by (simp add: algebra_simps)
    qed

    have "exp (L z) * (b - a) = exp (-z * p) * (1 - p + p * exp z) * (b - a)"
      using pos by (simp add: exp_add L_def exp_diff exp_minus divide_simps)
    also have "\<dots> = b * exp (l * a) - a * exp (l * b)" using \<open>a < b\<close>
      by (simp add: p_def z_def divide_simps) (simp add:  exp_diff algebra_simps)?
    finally show ?thesis by simp
  qed
  also have "ennreal (exp (L z) * (b - a)) / ennreal (b - a) = ennreal (exp (L z))"
    using \<open>a < b\<close> by (simp add: divide_ennreal)
  also have "L z = -z * p + ln (1 + p * (exp z - 1))"
    by (simp add: L_def algebra_simps)
  also have "\<dots> \<le> z\<^sup>2 / 8"
    unfolding L_def by (rule Hoeffdings_lemma_aux[where p = p]) (use \<open>z > 0\<close> \<open>p > 0\<close> in simp_all)
  hence "ennreal (exp (-z * p + ln (1 + p * (exp z - 1)))) \<le> ennreal (exp (z\<^sup>2 / 8))"
    by (intro ennreal_leI) auto
  finally show ?thesis
    by (simp add: z_def power_mult_distrib)
qed

context
begin

interpretation shift: interval_bounded_random_variable M "\<lambda>x. f x - \<mu>" "a - \<mu>" "b - \<mu>"
  rewrites "b - \<mu> - (a - \<mu>) \<equiv> b - a"
  by unfold_locales (auto intro!: eventually_mono[OF AE_in_interval])

lemma expectation_shift: "expectation (\<lambda>x. f x - expectation f) = 0"
  by (subst Bochner_Integration.integral_diff) (auto simp: integrable prob_space)

lemmas Hoeffdings_lemma_nn_integral = shift.Hoeffdings_lemma_nn_integral_0[OF _ expectation_shift]

end

end

subsection \<open>Hoeffding's Inequality\<close>

text \<open>
  Consider \<open>n\<close> independent real random variables $X_1, \ldots, X_n$ that each almost surely lie
  in a compact interval $[a_i, b_i]$. Hoeffding's inequality states that the distribution of the
  sum of the $X_i$ is tightly concentrated around the sum of the expected values: the probability
  of it being above or below the sum of the expected values by more than some \<open>\<epsilon>\<close> decreases
  exponentially with \<open>\<epsilon>\<close>.
\<close>

locale indep_interval_bounded_random_variables = prob_space +
  fixes I :: "'b set" and X :: "'b \<Rightarrow> 'a \<Rightarrow> real"
  fixes a b :: "'b \<Rightarrow> real"
  assumes fin: "finite I"
  assumes indep: "indep_vars (\<lambda>_. borel) X I"
  assumes AE_in_interval: "\<And>i. i \<in> I \<Longrightarrow> AE x in M. X i x \<in> {a i..b i}"
begin

lemma random_variable [measurable]:
  assumes i: "i \<in> I"
  shows "random_variable borel (X i)"
  using i indep unfolding indep_vars_def by blast

lemma bounded_random_variable [intro]:
  assumes i: "i \<in> I"
  shows   "interval_bounded_random_variable M (X i) (a i) (b i)"
  by unfold_locales (use AE_in_interval[OF i] i in auto)

end

locale Hoeffding_ineq = indep_interval_bounded_random_variables +
  fixes \<mu> :: real
  defines "\<mu> \<equiv> (\<Sum>i\<in>I. expectation (X i))"
begin

theorem%important Hoeffding_ineq_ge:
  assumes "\<epsilon> \<ge> 0"
  assumes "(\<Sum>i\<in>I. (b i - a i)\<^sup>2) > 0"
  shows   "prob {x\<in>space M. (\<Sum>i\<in>I. X i x) \<ge> \<mu> + \<epsilon>} \<le> exp (-2 * \<epsilon>\<^sup>2 / (\<Sum>i\<in>I. (b i - a i)\<^sup>2))"
proof (cases "\<epsilon> = 0")
  case [simp]: True
  have "prob {x\<in>space M. (\<Sum>i\<in>I. X i x) \<ge> \<mu> + \<epsilon>} \<le> 1"
    by simp
  thus ?thesis by simp
next
  case False
  with \<open>\<epsilon> \<ge> 0\<close> have \<epsilon>: "\<epsilon> > 0"
    by auto

  define d where "d = (\<Sum>i\<in>I. (b i - a i)\<^sup>2)"
  define l :: real where "l = 4 * \<epsilon> / d"
  have d: "d > 0"
    using assms by (simp add: d_def)
  have l: "l > 0"
    using \<epsilon> d by (simp add: l_def)
  define \<mu>' where "\<mu>' = (\<lambda>i. expectation (X i))"

  have "{x\<in>space M. (\<Sum>i\<in>I. X i x) \<ge> \<mu> + \<epsilon>} = {x\<in>space M. (\<Sum>i\<in>I. X i x) - \<mu> \<ge> \<epsilon>}"
    by (simp add: algebra_simps)
  hence "ennreal (prob {x\<in>space M. (\<Sum>i\<in>I. X i x) \<ge> \<mu> + \<epsilon>}) = emeasure M \<dots>"
    by (simp add: emeasure_eq_measure)
  also have "\<dots> \<le> ennreal (exp (-l*\<epsilon>)) * (\<integral>\<^sup>+x\<in>space M. exp (l * ((\<Sum>i\<in>I. X i x) - \<mu>)) \<partial>M)"
    by (intro Chernoff_ineq_nn_integral_ge l) auto
  also have "(\<lambda>x. (\<Sum>i\<in>I. X i x) - \<mu>) = (\<lambda>x. (\<Sum>i\<in>I. X i x - \<mu>' i))"
    by (simp add: \<mu>_def sum_subtractf \<mu>'_def)
  also have "(\<integral>\<^sup>+x\<in>space M. exp (l * ((\<Sum>i\<in>I. X i x - \<mu>' i))) \<partial>M) =
             (\<integral>\<^sup>+x. (\<Prod>i\<in>I. ennreal (exp (l * (X i x - \<mu>' i)))) \<partial>M)"
    by (intro nn_integral_cong)
       (simp_all add: sum_distrib_left ring_distribs exp_diff exp_sum fin prod_ennreal)
  also have "\<dots> = (\<Prod>i\<in>I. \<integral>\<^sup>+x. ennreal (exp (l * (X i x - \<mu>' i))) \<partial>M)"
    by (intro indep_vars_nn_integral fin indep_vars_compose2[OF indep]) auto
  also have "ennreal (exp (-l * \<epsilon>)) * \<dots> \<le>
               ennreal (exp (-l * \<epsilon>)) * (\<Prod>i\<in>I. ennreal (exp (l\<^sup>2 * (b i - a i)\<^sup>2 / 8)))"
  proof (intro mult_left_mono prod_mono_ennreal)
    fix i assume i: "i \<in> I"
    from i interpret interval_bounded_random_variable M "X i" "a i" "b i" ..
    show "(\<integral>\<^sup>+x. ennreal (exp (l * (X i x - \<mu>' i))) \<partial>M) \<le> ennreal (exp (l\<^sup>2 * (b i - a i)\<^sup>2 / 8))"
      unfolding \<mu>'_def by (rule Hoeffdings_lemma_nn_integral) fact+
  qed auto
  also have "\<dots> = ennreal (exp (-l*\<epsilon>) * (\<Prod>i\<in>I. exp (l\<^sup>2 * (b i - a i)\<^sup>2 / 8)))"
    by (simp add: prod_ennreal prod_nonneg flip: ennreal_mult)
  also have "exp (-l*\<epsilon>) * (\<Prod>i\<in>I. exp (l\<^sup>2 * (b i - a i)\<^sup>2 / 8)) = exp (d * l\<^sup>2 / 8 - l * \<epsilon>)"
    by (simp add: exp_diff exp_minus sum_divide_distrib sum_distrib_left
                  sum_distrib_right exp_sum fin divide_simps mult_ac d_def)
  also have "d * l\<^sup>2 / 8 - l * \<epsilon> = -2 * \<epsilon>\<^sup>2 / d"
    using d by (simp add: l_def field_simps power2_eq_square)
  finally show ?thesis
    by (subst (asm) ennreal_le_iff) (simp_all add: d_def)
qed

corollary Hoeffding_ineq_le:
  assumes \<epsilon>: "\<epsilon> \<ge> 0"
  assumes "(\<Sum>i\<in>I. (b i - a i)\<^sup>2) > 0"
  shows   "prob {x\<in>space M. (\<Sum>i\<in>I. X i x) \<le> \<mu> - \<epsilon>} \<le> exp (-2 * \<epsilon>\<^sup>2 / (\<Sum>i\<in>I. (b i - a i)\<^sup>2))"
proof -
  interpret flip: Hoeffding_ineq M I "\<lambda>i x. -X i x" "\<lambda>i. -b i" "\<lambda>i. -a i" "-\<mu>"
  proof unfold_locales
    fix i assume "i \<in> I"
    then interpret interval_bounded_random_variable M "X i" "a i" "b i" ..
    show "AE x in M. - X i x \<in> {- b i..- a i}"
      by (intro eventually_mono[OF AE_in_interval]) auto
  qed (auto simp: fin \<mu>_def sum_negf intro: indep_vars_compose2[OF indep])

  have "prob {x\<in>space M. (\<Sum>i\<in>I. X i x) \<le> \<mu> - \<epsilon>} = prob {x\<in>space M. (\<Sum>i\<in>I. -X i x) \<ge> -\<mu> + \<epsilon>}"
    by (simp add: sum_negf algebra_simps)
  also have "\<dots> \<le> exp (- 2 * \<epsilon>\<^sup>2 / (\<Sum>i\<in>I. (b i - a i)\<^sup>2))"
    using flip.Hoeffding_ineq_ge[OF \<epsilon>] assms(2) by simp
  finally show ?thesis .
qed

corollary Hoeffding_ineq_abs_ge:
  assumes \<epsilon>: "\<epsilon> \<ge> 0"
  assumes "(\<Sum>i\<in>I. (b i - a i)\<^sup>2) > 0"
  shows   "prob {x\<in>space M. \<bar>(\<Sum>i\<in>I. X i x) - \<mu>\<bar> \<ge> \<epsilon>} \<le> 2 * exp (-2 * \<epsilon>\<^sup>2 / (\<Sum>i\<in>I. (b i - a i)\<^sup>2))"
proof -
  have "{x\<in>space M. \<bar>(\<Sum>i\<in>I. X i x) - \<mu>\<bar> \<ge> \<epsilon>} =
        {x\<in>space M. (\<Sum>i\<in>I. X i x) \<ge> \<mu> + \<epsilon>} \<union> {x\<in>space M. (\<Sum>i\<in>I. X i x) \<le> \<mu> - \<epsilon>}"
    by auto
  also have "prob \<dots> \<le> prob {x\<in>space M. (\<Sum>i\<in>I. X i x) \<ge> \<mu> + \<epsilon>} +
                       prob {x\<in>space M. (\<Sum>i\<in>I. X i x) \<le> \<mu> - \<epsilon>}"
    by (intro measure_Un_le) auto
  also have "\<dots> \<le> exp (-2 * \<epsilon>\<^sup>2 / (\<Sum>i\<in>I. (b i - a i)\<^sup>2)) + exp (-2 * \<epsilon>\<^sup>2 / (\<Sum>i\<in>I. (b i - a i)\<^sup>2))"
    by (intro add_mono Hoeffding_ineq_ge Hoeffding_ineq_le assms)
  finally show ?thesis by simp
qed

end

subsection \<open>Hoeffding's inequality for i.i.d. bounded random variables\<close>

text \<open>
  If we have \<open>n\<close> even identically-distributed random variables, the statement of Hoeffding's
  lemma simplifies a bit more: it shows that the probability that the average of the $X_i$
  is more than \<open>\<epsilon>\<close> above the expected value is no greater than $e^{\frac{-2ny^2}{(b-a)^2}}$.

  This essentially gives us a more concrete version of the weak law of large numbers: the law
  states that the probability vanishes for \<open>n \<rightarrow> \<infinity>\<close> for any \<open>\<epsilon> > 0\<close>. Unlike Hoeffding's inequality,
  it does not assume the variables to have bounded support, but it does not provide concrete bounds.
\<close>

locale iid_interval_bounded_random_variables = prob_space +
  fixes I :: "'b set" and X :: "'b \<Rightarrow> 'a \<Rightarrow> real" and Y :: "'a \<Rightarrow> real"
  fixes a b :: real
  assumes fin: "finite I"
  assumes indep: "indep_vars (\<lambda>_. borel) X I"
  assumes distr_X: "i \<in> I \<Longrightarrow> distr M borel (X i) = distr M borel Y"
  assumes rv_Y [measurable]: "random_variable borel Y"
  assumes AE_in_interval: "AE x in M. Y x \<in> {a..b}"
begin

lemma random_variable [measurable]:
  assumes i: "i \<in> I"
  shows "random_variable borel (X i)"
  using i indep unfolding indep_vars_def by blast

sublocale X: indep_interval_bounded_random_variables M I X "\<lambda>_. a" "\<lambda>_. b"
proof
  fix i assume i: "i \<in> I"
  have "AE x in M. Y x \<in> {a..b}"
    by (fact AE_in_interval)
  also have "?this \<longleftrightarrow> (AE x in distr M borel Y. x \<in> {a..b})"
    by (subst AE_distr_iff) auto
  also have "distr M borel Y = distr M borel (X i)"
    using i by (simp add: distr_X)
  also have "(AE x in \<dots>. x \<in> {a..b}) \<longleftrightarrow> (AE x in M. X i x \<in> {a..b})"
    using i by (subst AE_distr_iff) auto
  finally show "AE x in M. X i x \<in> {a..b}" .
qed (simp_all add: fin indep)

lemma expectation_X [simp]:
  assumes i: "i \<in> I"
  shows "expectation (X i) = expectation Y"
proof -
  have "expectation (X i) = lebesgue_integral (distr M borel (X i)) (\<lambda>x. x)"
    using i by (intro integral_distr [symmetric]) auto
  also have "distr M borel (X i) = distr M borel Y"
    using i by (rule distr_X)
  also have "lebesgue_integral \<dots> (\<lambda>x. x) = expectation Y"
    by (rule integral_distr) auto
  finally show "expectation (X i) = expectation Y" .
qed

end

locale Hoeffding_ineq_iid = iid_interval_bounded_random_variables +
  fixes \<mu> :: real
  defines "\<mu> \<equiv> expectation Y"
begin

sublocale X: Hoeffding_ineq M I X "\<lambda>_. a" "\<lambda>_. b" "real (card I) * \<mu>"
  by unfold_locales (simp_all add: \<mu>_def)

corollary
  assumes \<epsilon>: "\<epsilon> \<ge> 0"
  assumes "a < b" "I \<noteq> {}"
  defines "n \<equiv> card I"
  shows   Hoeffding_ineq_ge:
            "prob {x\<in>space M. (\<Sum>i\<in>I. X i x) \<ge> n * \<mu> + \<epsilon>} \<le>
               exp (-2 * \<epsilon>\<^sup>2 / (n * (b - a)\<^sup>2))" (is ?le)
    and   Hoeffding_ineq_le:
            "prob {x\<in>space M. (\<Sum>i\<in>I. X i x) \<le> n * \<mu> - \<epsilon>} \<le>
               exp (-2 * \<epsilon>\<^sup>2 / (n * (b - a)\<^sup>2))" (is ?ge)
    and   Hoeffding_ineq_abs_ge:
            "prob {x\<in>space M. \<bar>(\<Sum>i\<in>I. X i x) - n * \<mu>\<bar> \<ge> \<epsilon>} \<le>
               2 * exp (-2 * \<epsilon>\<^sup>2 / (n * (b - a)\<^sup>2))" (is ?abs_ge)
proof -
  have pos: "(\<Sum>i\<in>I. (b - a)\<^sup>2) > 0"
    using \<open>a < b\<close> \<open>I \<noteq> {}\<close> fin by (intro sum_pos) auto
  show ?le
    using X.Hoeffding_ineq_ge[OF \<epsilon> pos] by (simp add: n_def)
  show ?ge
    using X.Hoeffding_ineq_le[OF \<epsilon> pos] by (simp add: n_def)
  show ?abs_ge
    using X.Hoeffding_ineq_abs_ge[OF \<epsilon> pos] by (simp add: n_def)
qed

lemma
  assumes \<epsilon>: "\<epsilon> \<ge> 0"
  assumes "a < b" "I \<noteq> {}"
  defines "n \<equiv> card I"
  shows   Hoeffding_ineq_ge':
            "prob {x\<in>space M. (\<Sum>i\<in>I. X i x) / n \<ge> \<mu> + \<epsilon>} \<le>
               exp (-2 * n * \<epsilon>\<^sup>2 / (b - a)\<^sup>2)" (is ?ge)
    and   Hoeffding_ineq_le':
            "prob {x\<in>space M. (\<Sum>i\<in>I. X i x) / n \<le> \<mu> - \<epsilon>} \<le>
               exp (-2 * n * \<epsilon>\<^sup>2 / (b - a)\<^sup>2)" (is ?le)
    and   Hoeffding_ineq_abs_ge':
            "prob {x\<in>space M. \<bar>(\<Sum>i\<in>I. X i x) / n - \<mu>\<bar> \<ge> \<epsilon>} \<le>
               2 * exp (-2 * n * \<epsilon>\<^sup>2 / (b - a)\<^sup>2)" (is ?abs_ge)
proof -
  have "n > 0"
    using assms fin by (auto simp: field_simps)
  have \<epsilon>': "\<epsilon> * n \<ge> 0"
    using \<open>n > 0\<close> \<open>\<epsilon> \<ge> 0\<close> by auto
  have eq: "- (2 * (\<epsilon> * real n)\<^sup>2 / (real (card I) * (b - a)\<^sup>2)) =
            - (2 * real n * \<epsilon>\<^sup>2 / (b - a)\<^sup>2)"
    using \<open>n > 0\<close> by (simp add: power2_eq_square divide_simps n_def)

  have "{x\<in>space M. (\<Sum>i\<in>I. X i x) / n \<ge> \<mu> + \<epsilon>} =
        {x\<in>space M. (\<Sum>i\<in>I. X i x) \<ge> \<mu> * n + \<epsilon> * n}"
    using \<open>n > 0\<close> by (intro Collect_cong conj_cong refl) (auto simp: field_simps)
  with Hoeffding_ineq_ge[OF \<epsilon>' \<open>a < b\<close> \<open>I \<noteq> {}\<close>] \<open>n > 0\<close> eq show ?ge
    by (simp add: n_def mult_ac)

  have "{x\<in>space M. (\<Sum>i\<in>I. X i x) / n \<le> \<mu> - \<epsilon>} =
        {x\<in>space M. (\<Sum>i\<in>I. X i x) \<le> \<mu> * n - \<epsilon> * n}"
    using \<open>n > 0\<close> by (intro Collect_cong conj_cong refl) (auto simp: field_simps)
  with Hoeffding_ineq_le[OF \<epsilon>' \<open>a < b\<close> \<open>I \<noteq> {}\<close>] \<open>n > 0\<close> eq show ?le
    by (simp add: n_def mult_ac)

  have "{x\<in>space M. \<bar>(\<Sum>i\<in>I. X i x) / n - \<mu>\<bar> \<ge> \<epsilon>} =
        {x\<in>space M. \<bar>(\<Sum>i\<in>I. X i x) - \<mu> * n\<bar> \<ge> \<epsilon> * n}"
    using \<open>n > 0\<close> by (intro Collect_cong conj_cong refl) (auto simp: field_simps)
  with Hoeffding_ineq_abs_ge[OF \<epsilon>' \<open>a < b\<close> \<open>I \<noteq> {}\<close>] \<open>n > 0\<close> eq show ?abs_ge
    by (simp add: n_def mult_ac)
qed

end

subsection \<open>Hoeffding's Inequality for the Binomial distribution\<close>

text \<open>
  We can now apply Hoeffding's inequality to the Binomial distribution, which can be seen
  as the sum of \<open>n\<close> i.i.d. coin flips (the support of each of which is contained in $[0,1]$).
\<close>

locale binomial_distribution =
  fixes n :: nat and p :: real
  assumes p: "p \<in> {0..1}"
begin

context
  fixes coins :: "(nat \<Rightarrow> bool) pmf" and \<mu>
  assumes n: "n > 0"
  defines "coins \<equiv> Pi_pmf {..<n} False (\<lambda>_. bernoulli_pmf p)"
begin

lemma coins_component:
  assumes i: "i < n"
  shows   "distr (measure_pmf coins) borel (\<lambda>f. if f i then 1 else 0) =
             distr (measure_pmf (bernoulli_pmf p)) borel (\<lambda>b. if b then 1 else 0)"
proof -
  have "distr (measure_pmf coins) borel (\<lambda>f. if f i then 1 else 0) =
        distr (measure_pmf (map_pmf (\<lambda>f. f i) coins)) borel (\<lambda>b. if b then 1 else 0)"
    unfolding map_pmf_rep_eq by (subst distr_distr) (auto simp: o_def)
  also have "map_pmf (\<lambda>f. f i) coins = bernoulli_pmf p"
    unfolding coins_def using i by (subst Pi_pmf_component) auto
  finally show ?thesis
    unfolding map_pmf_rep_eq .
qed

lemma prob_binomial_pmf_conv_coins:
  "measure_pmf.prob (binomial_pmf n p) {x. P (real x)} =
   measure_pmf.prob coins {x. P (\<Sum>i<n. if x i then 1 else 0)}"
proof -
  have eq1: "(\<Sum>i<n. if x i then 1 else 0) = real (card {i\<in>{..<n}. x i})" for x
  proof -
    have "(\<Sum>i<n. if x i then 1 else (0::real)) = (\<Sum>i\<in>{i\<in>{..<n}. x i}. 1)"
      by (intro sum.mono_neutral_cong_right) auto
    thus ?thesis by simp
  qed
  have eq2: "binomial_pmf n p = map_pmf (\<lambda>v. card {i\<in>{..<n}. v i}) coins"
    unfolding coins_def by (rule binomial_pmf_altdef') (use p in auto)
  show ?thesis
    by (subst eq2) (simp_all add: eq1)
qed

interpretation Hoeffding_ineq_iid
  coins "{..<n}" "\<lambda>i f. if f i then 1 else 0" "\<lambda>f. if f 0 then 1 else 0" 0 1 p
proof unfold_locales
  show "prob_space.indep_vars (measure_pmf coins) (\<lambda>_. borel) (\<lambda>i f. if f i then 1 else 0) {..<n}"
    unfolding coins_def
    by (intro prob_space.indep_vars_compose2[OF _ indep_vars_Pi_pmf])
       (auto simp: measure_pmf.prob_space_axioms)
next
  have "measure_pmf.expectation coins (\<lambda>f. if f 0 then 1 else 0 :: real) =
        measure_pmf.expectation (map_pmf (\<lambda>f. f 0) coins) (\<lambda>b. if b then 1 else 0 :: real)"
    by (simp add: coins_def)
  also have "map_pmf (\<lambda>f. f 0) coins = bernoulli_pmf p"
    using n by (simp add: coins_def Pi_pmf_component)
  also have "measure_pmf.expectation \<dots> (\<lambda>b. if b then 1 else 0) = p"
    using p by simp
  finally show "p \<equiv> measure_pmf.expectation coins (\<lambda>f. if f 0 then 1 else 0)" by simp
qed (auto simp: coins_component)

corollary
  fixes \<epsilon> :: real
  assumes \<epsilon>: "\<epsilon> \<ge> 0"
  shows prob_ge: "measure_pmf.prob (binomial_pmf n p) {x. x \<ge> n * p + \<epsilon>} \<le> exp (-2 * \<epsilon>\<^sup>2 / n)"
    and prob_le: "measure_pmf.prob (binomial_pmf n p) {x. x \<le> n * p - \<epsilon>} \<le> exp (-2 * \<epsilon>\<^sup>2 / n)"
    and prob_abs_ge:
          "measure_pmf.prob (binomial_pmf n p) {x. \<bar>x - n * p\<bar> \<ge> \<epsilon>} \<le> 2 * exp (-2 * \<epsilon>\<^sup>2 / n)"
proof -
  have [simp]: "{..<n} \<noteq> {}"
    using n by auto
  show "measure_pmf.prob (binomial_pmf n p) {x. x \<ge> n * p + \<epsilon>} \<le> exp (-2 * \<epsilon>\<^sup>2 / n)"
    using Hoeffding_ineq_ge[of \<epsilon>] by (subst prob_binomial_pmf_conv_coins) (use assms in simp_all)
  show "measure_pmf.prob (binomial_pmf n p) {x. x \<le> n * p - \<epsilon>} \<le> exp (-2 * \<epsilon>\<^sup>2 / n)"
    using Hoeffding_ineq_le[of \<epsilon>] by (subst prob_binomial_pmf_conv_coins) (use assms in simp_all)
  show "measure_pmf.prob (binomial_pmf n p) {x. \<bar>x - n * p\<bar> \<ge> \<epsilon>} \<le> 2 *  exp (-2 * \<epsilon>\<^sup>2 / n)"
    using Hoeffding_ineq_abs_ge[of \<epsilon>]
    by (subst prob_binomial_pmf_conv_coins) (use assms in simp_all)
qed

corollary
  fixes \<epsilon> :: real
  assumes \<epsilon>: "\<epsilon> \<ge> 0"
  shows prob_ge': "measure_pmf.prob (binomial_pmf n p) {x. x / n \<ge> p + \<epsilon>} \<le> exp (-2 * n * \<epsilon>\<^sup>2)"
    and prob_le': "measure_pmf.prob (binomial_pmf n p) {x. x / n \<le> p - \<epsilon>} \<le> exp (-2 * n * \<epsilon>\<^sup>2)"
    and prob_abs_ge':
          "measure_pmf.prob (binomial_pmf n p) {x. \<bar>x / n - p\<bar> \<ge> \<epsilon>} \<le> 2 * exp (-2 * n * \<epsilon>\<^sup>2)"
proof -
  have [simp]: "{..<n} \<noteq> {}"
    using n by auto
  show "measure_pmf.prob (binomial_pmf n p) {x. x / n \<ge> p + \<epsilon>} \<le> exp (-2 * n * \<epsilon>\<^sup>2)"
    using Hoeffding_ineq_ge'[of \<epsilon>] by (subst prob_binomial_pmf_conv_coins) (use assms in simp_all)
  show "measure_pmf.prob (binomial_pmf n p) {x. x / n \<le> p - \<epsilon>} \<le> exp (-2 * n * \<epsilon>\<^sup>2)"
    using Hoeffding_ineq_le'[of \<epsilon>] by (subst prob_binomial_pmf_conv_coins) (use assms in simp_all)
  show "measure_pmf.prob (binomial_pmf n p) {x. \<bar>x / n - p\<bar> \<ge> \<epsilon>} \<le> 2 * exp (-2 * n * \<epsilon>\<^sup>2)"
    using Hoeffding_ineq_abs_ge'[of \<epsilon>]
    by (subst prob_binomial_pmf_conv_coins) (use assms in simp_all)
qed

end

end

subsection \<open>Tail bounds for the negative binomial distribution\<close>

text \<open>
  Since the tail probabilities of a negative Binomial distribution are equal to the
  tail probabilities of some Binomial distribution, we can obtain tail bounds for the
  negative Binomial distribution through the Hoeffding tail bounds for the Binomial
  distribution.
\<close>

context
  fixes p q :: real
  assumes p: "p \<in> {0<..<1}"
  defines "q \<equiv> 1 - p"
begin

lemma prob_neg_binomial_pmf_ge_bound:
  fixes n :: nat and k :: real
  defines "\<mu> \<equiv> real n * q / p"
  assumes k: "k \<ge> 0"
  shows "measure_pmf.prob (neg_binomial_pmf n p) {x. real x \<ge> \<mu> + k}
         \<le> exp (- 2 * p ^ 3 * k\<^sup>2 / (n + p * k))"
proof -
  consider "n = 0" | "p = 1" | "n > 0" "p \<noteq> 1"
    by blast
  thus ?thesis
  proof cases
    assume [simp]: "n = 0"
    show ?thesis using k
      by (simp add: indicator_def \<mu>_def)
  next
    assume [simp]: "p = 1"
    show ?thesis using k
      by (auto simp add: indicator_def \<mu>_def q_def)
  next
    assume n: "n > 0" and "p \<noteq> 1"
    from \<open>p \<noteq> 1\<close> and p have p: "p \<in> {0<..<1}"
      by auto
    from p have q: "q \<in> {0<..<1}"
      by (auto simp: q_def)

    define k1 where "k1 = \<mu> + k"
    have k1: "k1 \<ge> \<mu>"
      using k by (simp add: k1_def)
    have "k1 > 0"
      by (rule less_le_trans[OF _ k1]) (use p n in \<open>auto simp: q_def \<mu>_def\<close>)

    define k1' where "k1' = nat (ceiling k1)"
    have "\<mu> \<ge> 0" using p
      by (auto simp: \<mu>_def q_def)
    have "\<not>(x < k1') \<longleftrightarrow> real x \<ge> k1" for x
      unfolding k1'_def by linarith
    hence eq: "UNIV - {..<k1'} = {x. x \<ge> k1}"
      by auto
    hence "measure_pmf.prob (neg_binomial_pmf n p) {n. n \<ge> k1} =
          1 - measure_pmf.prob (neg_binomial_pmf n p) {..<k1'}"
      using measure_pmf.prob_compl[of "{..<k1'}" "neg_binomial_pmf n p"] by simp
    also have "measure_pmf.prob (neg_binomial_pmf n p) {..<k1'} =
               measure_pmf.prob (binomial_pmf (n + k1' - 1) q) {..<k1'}"
      unfolding q_def using p by (intro prob_neg_binomial_pmf_lessThan) auto
    also have "1 - \<dots> = measure_pmf.prob (binomial_pmf (n + k1' - 1) q) {n. n \<ge> k1}"
      using measure_pmf.prob_compl[of "{..<k1'}" "binomial_pmf (n + k1' - 1) q"] eq by simp
    also have "{x. real x \<ge> k1} = {x. x \<ge> real (n + k1' - 1) * q + (k1 - real (n + k1' - 1) * q)}"
      by simp
    also have "measure_pmf.prob (binomial_pmf (n + k1' - 1) q) \<dots> \<le>
                 exp (-2 * (k1 - real (n + k1' - 1) * q)\<^sup>2 / real (n + k1' - 1))"
    proof (rule binomial_distribution.prob_ge)
      show "binomial_distribution q"
        by unfold_locales (use q in auto)
    next
      show "n + k1' - 1 > 0"
        using \<open>k1 > 0\<close> n unfolding k1'_def by linarith
    next
      have "real (n + nat \<lceil>k1\<rceil> - 1) \<le> real n + k1"
        using \<open>k1 > 0\<close> by linarith
      hence "real (n + k1' - 1) * q  \<le> (real n + k1) * q"
        unfolding k1'_def by (intro mult_right_mono) (use p in \<open>simp_all add: q_def\<close>)
      also have "\<dots> \<le> k1"
        using k1 p by (simp add: q_def field_simps \<mu>_def)
      finally show "0 \<le> k1 - real (n + k1' - 1) * q"
        by simp
    qed
    also have "{x. real (n + k1' - 1) * q + (k1 - real (n + k1' - 1) * q) \<le> real x} = {x. real x \<ge> k1}"
      by simp
    also have "exp (-2 * (k1 - real (n + k1' - 1) * q)\<^sup>2 / real (n + k1' - 1)) \<le>
               exp (-2 * (k1 - (n + k1) * q)\<^sup>2 / (n + k1))"
    proof -
      have "real (n + k1' - Suc 0) \<le> real n + k1"
        unfolding k1'_def using \<open>k1 > 0\<close> by linarith
      moreover have "(real n + k1) * q \<le> k1"
        using k1 p by (auto simp: q_def field_simps \<mu>_def)
      moreover have "1 < n + k1'"
        using n \<open>k1 > 0\<close> unfolding k1'_def by linarith
      ultimately have "2 * (k1 - real (n + k1' - 1) * q)\<^sup>2 / real (n + k1' - 1) \<ge>
                       2 * (k1 - (n + k1) * q)\<^sup>2 / (n + k1)"
        by (intro frac_le mult_left_mono power_mono mult_nonneg_nonneg mult_right_mono diff_mono)
           (use q in simp_all)
      thus ?thesis
        by simp
    qed
    also have "\<dots> = exp (-2 * (p * k1 - q * n)\<^sup>2 / (k1 + n))"
      by (simp add: q_def algebra_simps)
    also have "-2 * (p * k1 - q * n)\<^sup>2 = -2 * p\<^sup>2 * (k1 - \<mu>)\<^sup>2"
      using p by (auto simp: field_simps \<mu>_def)
    also have "k1 - \<mu> = k"
      by (simp add: k1_def \<mu>_def)
    also note k1_def
    also have "\<mu> + k + real n = real n / p + k"
      using p by (simp add: \<mu>_def q_def field_simps)
    also have "- 2 * p\<^sup>2 * k\<^sup>2 / (real n / p + k) = - 2 * p ^ 3 * k\<^sup>2 / (p * k + n)"
      using p by (simp add: field_simps power3_eq_cube power2_eq_square)
    finally show ?thesis by (simp add: add_ac)
  qed
qed

lemma prob_neg_binomial_pmf_le_bound:
  fixes n :: nat and k :: real
  defines "\<mu> \<equiv> real n * q / p"
  assumes k: "k \<ge> 0"
  shows "measure_pmf.prob (neg_binomial_pmf n p) {x. real x \<le> \<mu> - k}
         \<le> exp (-2 * p ^ 3 * k\<^sup>2 / (n - p * k))"
proof -
  consider "n = 0" | "p = 1" | "k > \<mu>" | "n > 0" "p \<noteq> 1" "k \<le> \<mu>"
    by force
  thus ?thesis
  proof cases
    assume [simp]: "n = 0"
    show ?thesis using k
      by (simp add: indicator_def \<mu>_def)
  next
    assume [simp]: "p = 1"
    show ?thesis using k
      by (auto simp add: indicator_def \<mu>_def q_def)
  next
    assume "k > \<mu>"
    hence "{x. real x \<le> \<mu> - k} = {}"
      by auto
    thus ?thesis by simp
  next
    assume n: "n > 0" and "p \<noteq> 1" and "k \<le> \<mu>"
    from \<open>p \<noteq> 1\<close> and p have p: "p \<in> {0<..<1}"
      by auto
    from p have q: "q \<in> {0<..<1}"
      by (auto simp: q_def)

    define f :: "real \<Rightarrow> real" where "f = (\<lambda>x. (p * x - q * n)\<^sup>2 / (x + n))"
    have f_mono: "f x \<ge> f y" if "x \<ge> 0" "y \<le> n * q / p" "x \<le> y" for x y :: real
      using that(3)
    proof (rule DERIV_nonpos_imp_nonincreasing)
      fix t assume t: "t \<ge> x" "t \<le> y"
      have "x > -n"
        using n \<open>x \<ge> 0\<close> by linarith
      hence "(f has_field_derivative ((p * t - q * n) * (n * (1 + p) + p * t) / (n + t) ^ 2)) (at t)"
        unfolding f_def using t
        by (auto intro!: derivative_eq_intros simp: algebra_simps q_def power2_eq_square)
      moreover {
        have "p * t \<le> p * y"
          using p by (intro mult_left_mono t) auto
        also have "p * y \<le> q * n"
          using \<open>y \<le> n * q / p\<close> p by (simp add: field_simps)
        finally have "p * t \<le> q * n" .
      }
      hence "(p * t - q * n) * (n * (1 + p) + p * t) / (n + t) ^ 2 \<le> 0"
        using p \<open>x \<ge> 0\<close> t
        by (intro mult_nonpos_nonneg divide_nonpos_nonneg add_nonneg_nonneg mult_nonneg_nonneg) auto
      ultimately show "\<exists>y. (f has_real_derivative y) (at t) \<and> y \<le> 0"
        by blast
    qed

    define k1 where "k1 = \<mu> - k"
    have k1: "k1 \<le> real n * q / p"
      using assms by (simp add: \<mu>_def k1_def)
    have "k1 \<ge> 0"
      using k \<open>k \<le> \<mu>\<close> by (simp add: \<mu>_def k1_def)

    define k1' where "k1' = nat (floor k1)"
    have "\<mu> \<ge> 0" using p
      by (auto simp: \<mu>_def q_def)
    have "(x \<le> k1') \<longleftrightarrow> real x \<le> k1" for x
      unfolding k1'_def not_less using \<open>k1 \<ge> 0\<close> by linarith
    hence eq: "{n. n \<le> k1}  = {..k1'}"
      by auto
    hence "measure_pmf.prob (neg_binomial_pmf n p) {n. n \<le> k1} =
           measure_pmf.prob (neg_binomial_pmf n p) {..k1'}"
      by simp
    also have "measure_pmf.prob (neg_binomial_pmf n p) {..k1'} =
               measure_pmf.prob (binomial_pmf (n + k1') q) {..k1'}"
      unfolding q_def using p by (intro prob_neg_binomial_pmf_atMost) auto
    also note eq [symmetric]
    also have "{x. real x \<le> k1} = {x. x \<le> real (n + k1') * q - (real (n + k1') * q - real k1')}"
      using eq by auto
    also have "measure_pmf.prob (binomial_pmf (n + k1') q) \<dots> \<le>
                 exp (-2 * (real (n + k1') * q - real k1')\<^sup>2 / real (n + k1'))"
    proof (rule binomial_distribution.prob_le)
      show "binomial_distribution q"
        by unfold_locales (use q in auto)
    next
      show "n + k1' > 0"
        using \<open>k1 \<ge> 0\<close> n unfolding k1'_def by linarith
    next
      have "p * k1' \<le> p * k1"
        using p \<open>k1 \<ge> 0\<close> by (intro mult_left_mono) (auto simp: k1'_def)
      also have "\<dots> \<le> q * n"
        using k1 p by (simp add: field_simps)
      finally show "0 \<le> real (n + k1') * q - real k1'"
        by (simp add: algebra_simps q_def)
    qed
    also have "{x. real x \<le> real (n + k1') * q - (real (n + k1') * q - k1')} = {..k1'}"
      by auto
    also have "real (n + k1') * q - k1' = -(p * k1' - q * n)"
      by (simp add: q_def algebra_simps)
    also have "\<dots> ^ 2 = (p * k1' - q * n) ^ 2"
      by algebra
    also have "- 2 * (p * real k1' - q * real n)\<^sup>2 / real (n + k1') = -2 * f (real k1')"
      by (simp add: f_def)
    also have "f (real k1') \<ge> f k1"
      by (rule f_mono) (use \<open>k1 \<ge> 0\<close> k1 in \<open>auto simp: k1'_def\<close>)
    hence "exp (-2 * f (real k1')) \<le> exp (-2 * f k1)"
      by simp
    also have "\<dots> = exp (-2 * (p * k1 - q * n)\<^sup>2 / (k1 + n))"
      by (simp add: f_def)

    also have "-2 * (p * k1 - q * n)\<^sup>2 = -2 * p\<^sup>2 * (k1 - \<mu>)\<^sup>2"
      using p by (auto simp: field_simps \<mu>_def)
    also have "(k1 - \<mu>) ^ 2 = k ^ 2"
      by (simp add: k1_def \<mu>_def)
    also note k1_def
    also have "\<mu> - k + real n = real n / p - k"
      using p by (simp add: \<mu>_def q_def field_simps)
    also have "- 2 * p\<^sup>2 * k\<^sup>2 / (real n / p - k) = - 2 * p ^ 3 * k\<^sup>2 / (n - p * k)"
      using p by (simp add: field_simps power3_eq_cube power2_eq_square)
    also have "{..k1'} = {x. real x \<le> \<mu> - k}"
      using eq by (simp add: k1_def)
    finally show ?thesis .
  qed
qed

text \<open>
  Due to the function $exp(-l/x)$ being concave for $x \geq \frac{l}{2}$, the above two
  bounds can be combined into the following one for moderate values of \<open>k\<close>.
  (cf. \<^url>\<open>https://math.stackexchange.com/questions/1565559\<close>)
\<close>
lemma prob_neg_binomial_pmf_abs_ge_bound:
  fixes n :: nat and k :: real
  defines "\<mu> \<equiv> real n * q / p"
  assumes "k \<ge> 0" and n_ge: "n \<ge> p * k * (p\<^sup>2 * k + 1)"
  shows "measure_pmf.prob (neg_binomial_pmf n p) {x. \<bar>real x - \<mu>\<bar> \<ge> k} \<le>
           2 * exp (-2 * p ^ 3 * k ^ 2 / n)"
proof (cases "k = 0")
  case False
  with \<open>k \<ge> 0\<close> have k: "k > 0"
    by auto
  define l :: real where "l = 2 * p ^ 3 * k ^ 2"
  have l: "l > 0"
    using p k by (auto simp: l_def)
  define f :: "real \<Rightarrow> real" where "f = (\<lambda>x. exp (-l / x))"
  define f' where "f' = (\<lambda>x. -l * exp (-l / x) / x ^ 2)"

  have f'_mono: "f' x \<le> f' y" if "x \<ge> l / 2" "x \<le> y" for x y :: real
    using that(2)
  proof (rule DERIV_nonneg_imp_nondecreasing)
    fix t assume t: "x \<le> t" "t \<le> y"
    have "t > 0"
      using that l t by auto
    have "(f' has_field_derivative (l * (2 * t - l) / (exp (l / t) * t ^ 4))) (at t)"
      unfolding f'_def using t that \<open>t > 0\<close>
      by (auto intro!: derivative_eq_intros simp: field_simps exp_minus simp flip: power_Suc)
    moreover have "l * (2 * t - l) / (exp (l / t) * t ^ 4) \<ge> 0"
      using that t l by (intro divide_nonneg_pos mult_nonneg_nonneg) auto
    ultimately show "\<exists>y. (f' has_real_derivative y) (at t) \<and> 0 \<le> y" by blast
  qed

  have convex: "convex_on {l/2..} (\<lambda>x. -f x)" unfolding f_def
  proof (intro convex_on_realI[where f' = f'])
    show "((\<lambda>x. - exp (- l / x)) has_real_derivative f' x) (at x)" if "x \<in> {l/2..}" for x
      using that l
      by (auto intro!: derivative_eq_intros simp: f'_def power2_eq_square algebra_simps)
  qed (use l in \<open>auto intro!: f'_mono\<close>)

  have eq: "{x. \<bar>real x - \<mu>\<bar> \<ge> k} = {x. real x \<le> \<mu> - k} \<union> {x. real x \<ge> \<mu> + k}"
    by auto
  have "measure_pmf.prob (neg_binomial_pmf n p) {x. \<bar>real x - \<mu>\<bar> \<ge> k} \<le>
        measure_pmf.prob (neg_binomial_pmf n p) {x. real x \<le> \<mu> - k} +
        measure_pmf.prob (neg_binomial_pmf n p) {x. real x \<ge> \<mu> + k}"
    by (subst eq, rule measure_Un_le) auto
  also have "\<dots> \<le> exp (-2 * p ^ 3 * k\<^sup>2 / (n - p * k)) + exp (-2 * p ^ 3 * k\<^sup>2 / (n + p * k))"
    unfolding \<mu>_def
    by (intro prob_neg_binomial_pmf_le_bound prob_neg_binomial_pmf_ge_bound add_mono \<open>k \<ge> 0\<close>)
  also have "\<dots> = 2 * (1/2 * f (n - p * k) + 1/2 * f (n + p * k))"
    by (simp add: f_def l_def)
  also have "1/2 * f (n - p * k) + 1/2 * f (n + p * k) \<le> f (1/2 * (n - p * k) + 1/2 * (n + p * k))"
  proof -
    let ?x = "n - p * k" and ?y = "n + p * k"
    have le1: "l / 2 \<le> ?x" using n_ge
      by (simp add: l_def power2_eq_square power3_eq_cube algebra_simps)
    also have "\<dots> \<le> ?y"
      using p k by simp
    finally have le2: "l / 2 \<le> ?y" .
    have "-f ((1 - 1 / 2) *\<^sub>R ?x + (1 / 2) *\<^sub>R ?y) \<le> (1 - 1 / 2) * - f ?x + 1 / 2 * - f ?y"
      using le1 le2 by (intro convex_onD[OF convex]) auto
    thus ?thesis by simp
  qed
  also have "1/2 * (n - p * k) + 1/2 * (n + p * k) = n"
    by (simp add: algebra_simps)
  also have "2 * f n = 2 * exp (-l / n)"
    by (simp add: f_def)
  finally show ?thesis
    by (simp add: l_def)
qed auto

end

end


theory Ex4_5
  imports Main
begin

(*
By: Vadim Zaliva <vzaliva@cmu.edu>
From: T. Nipkow and G. Klein, Concrete Semantics with Isabelle/HOL. Springer, 2014.
Exercise 4.5:

by: Vadim Zaliva with help from Jeremy Johnson
*)

(* terminals *)
datatype alpha = a | b

(* empty word defintion.
NB: This is syntactic sugar. We might as well used [] in the contexts where the type of [] could be derived automaticlaly *)
definition \<epsilon> :: "alpha list" where "\<epsilon>=[]"

inductive S :: "(alpha list) \<Rightarrow> bool" where
  empty: "S \<epsilon>"
  | paren: "S w \<Longrightarrow> S (a # w @ [b])"
  | repeat: "\<lbrakk>S x; S y \<rbrakk> \<Longrightarrow> S (x@y)"

inductive T :: "(alpha list) \<Rightarrow> bool" where
  empty: "T \<epsilon>"
  | interleave: "\<lbrakk>T x; T y \<rbrakk> \<Longrightarrow> T (x@[a]@y@[b])"

lemma TS : "T w \<Longrightarrow> S w "
  apply(induction rule: T.induct)
  apply(rule S.empty)
  apply(rule S.repeat)
  apply(simp)
  apply(simp)
  apply(rule S.paren)
  apply(simp)
done

lemma T01: "T (a#w@[b]) = T (\<epsilon> @ [a] @ w @ [b])"
  apply(simp add: \<epsilon>_def)
done

lemma simpTI : "T (x @ a # y @ [b]) = T (x @ [a] @ y @ [b])"
  apply(auto)
done

lemma Tgroup : "T(x1 @ x2 @ [a] @ y @ [b]) = T((x1 @ x2) @ [a] @ y @ [b])"
apply (auto)
done

lemma Tconcat : "\<lbrakk>T w2; T w1 \<rbrakk> \<Longrightarrow> T (w1 @ w2)"
apply (induction rule: T.induct)
apply(simp add: \<epsilon>_def)
apply (simp only: Tgroup)
apply (rule T.interleave)
apply (auto)
done

lemma ST : "S w \<Longrightarrow> T w"
apply (induction rule: S.induct)
apply (rule T.empty)
apply (simp only: T01)
apply (rule T.interleave)
apply (rule T.empty)
apply(simp add: \<epsilon>_def)
apply (simp only: Tconcat)
done

theorem eqST : "S w = T w "
  apply(auto)
  apply(rule ST)
  apply(simp)
  apply(rule TS)
  apply(simp)
done

end


section {* \isaheader{Example for Foreach-Loops} *}
theory Foreach_Refine
imports
  "../../Refine_Dflt_Only_ICF"
begin

text {*
  This example presents the usage of the foreach loop.
  We define a simple foreach loop that looks for the largest element with
  a given property. Ordered loops are used to be sure to find the largest one.
*}

subsection {* Definition *}

definition find_max_invar where
  "find_max_invar P S it \<sigma> =
     (case \<sigma> of None \<Rightarrow> (\<forall>x \<in> S - it. \<not>(P x))
             | Some y \<Rightarrow> (P y \<and> y \<in> S-it \<and> (\<forall>x \<in> S - it - {y}. \<not>(P x))))"

definition find_max :: "('a::{linorder} \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> ('a option) nres" where
  "find_max P S \<equiv>
   FOREACHoci (op\<ge>) (find_max_invar P S) S
     (\<lambda>\<sigma>. \<sigma> = None) (\<lambda>x _. RETURN (if P x then Some x else None)) None"

subsection {* Correctness *}
text {* As simple correctness property, we show:
  If the algorithm returns the maximal element satisfying @{text "P"}.
*}
lemma find_max_correct:
  fixes S:: "'a::{linorder} set"
  assumes "finite S"
  shows "find_max P S \<le> SPEC (\<lambda>\<sigma>. case \<sigma> of None \<Rightarrow> \<forall>x\<in>S. \<not>(P x)
                                          | Some y \<Rightarrow> (P y \<and> y \<in> S \<and> (\<forall>x\<in>S. P x \<longrightarrow> y \<ge> x)))"
  unfolding find_max_def
proof (rule FOREACHoci_rule)
  show "finite S" by fact
next
  show "find_max_invar P S S None"
  unfolding find_max_invar_def by simp
next
  fix x it \<sigma>
  assume "\<sigma> = None"
         "x \<in> it"
         "it \<subseteq> S"
         "find_max_invar P S it \<sigma>"
         "\<forall>y\<in>it - {x}. y \<le> x"
         "\<forall>y\<in>S - it. x \<le> y"

  from `find_max_invar P S it \<sigma>` `\<sigma> = None`
  have not_P_others: "\<forall>x\<in>S - it. \<not> P x"
    by (simp add: find_max_invar_def)

  from `x \<in> it` `it \<subseteq> S` have "x \<in> S" by blast

  show "RETURN (if P x then Some x else None) \<le> SPEC (find_max_invar P S (it - {x}))"
    using not_P_others `x \<in> S`
    by (auto simp add: find_max_invar_def)
next
  fix \<sigma>
  assume "find_max_invar P S {} \<sigma>"
  thus "case \<sigma> of None \<Rightarrow> \<forall>x\<in>S. \<not> P x
        | Some y \<Rightarrow> P y \<and> y \<in> S \<and> (\<forall>x\<in>S. P x \<longrightarrow> x \<le> y)"
    by (cases \<sigma>, auto simp add: find_max_invar_def)
next
  fix it \<sigma>
  assume "it \<noteq> {}"
         "it \<subseteq> S"
         "find_max_invar P S it \<sigma>"
         "\<sigma> \<noteq> None"
         "\<forall>x\<in>it. \<forall>y\<in>S - it. x \<le> y"

  from `\<sigma> \<noteq> None` obtain y where \<sigma>_eq[simp]: "\<sigma> = Some y" by auto
  from `find_max_invar P S it \<sigma>`
    have y_props[simp]: "P y" "y \<in> S" "y \<notin> it" and not_P: "\<forall>x\<in>S - it - {y}. \<not> P x"
    by (simp_all add: find_max_invar_def)

  { fix x
    assume "x \<in> S" "P x"
    with not_P have "x \<in> it \<or> x = y" by auto
    with `\<forall>x\<in>it. \<forall>y\<in>S - it. x \<le> y` y_props have "x \<le> y" by auto
  } note less_eq_y = this

  show "case \<sigma> of None \<Rightarrow> \<forall>x\<in>S. \<not> P x
        | Some y \<Rightarrow> P y \<and> y \<in> S \<and> (\<forall>x\<in>S. P x \<longrightarrow> x \<le> y)"
   by (simp add: find_max_invar_def Ball_def less_eq_y)
qed

subsection {* Data Refinement and Determinization *}
text {*
  Next, we use automatic data refinement and transfer to generate an
  executable algorithm using a red-black-tree.
*}
schematic_goal find_max_impl_refine_aux:
  assumes invar_S: "rs.invar S"
  shows "RETURN (?f) \<le> (find_max P (rs.\<alpha> S))"
  unfolding find_max_def
  by (refine_transfer
    RBTSetImpl.rs.rev_iterateoi_correct[unfolded set_iterator_rev_linord_def,
    OF invar_S])

concrete_definition find_max_impl for P S uses find_max_impl_refine_aux

lemma find_max_impl_refine:
  assumes invar_S: "rs.invar S"
  shows "RETURN (find_max_impl P S) \<le> (find_max P (rs.\<alpha> S))"
  using assms by (rule find_max_impl.refine)

subsubsection {* Executable Code *}

lemma find_max_impl_correct :
assumes invar_S: "rs.invar S"
shows "case find_max_impl P S of None \<Rightarrow> \<forall>x\<in>rs.\<alpha> S. \<not>(P x)
                               | Some y \<Rightarrow> (P y \<and> y \<in> (rs.\<alpha> S)
                                 \<and> (\<forall>x\<in>rs.\<alpha> S. P x \<longrightarrow> y \<ge> x))"
proof -
  note find_max_impl_refine [of S P, OF invar_S]
  also note find_max_correct [OF RBTSetImpl.rs.finite[of S, OF invar_S], of P]
  finally show ?thesis by simp
qed

text {* Finally, we can generate code *}
export_code find_max_impl in SML
export_code find_max_impl in OCaml
export_code find_max_impl in Haskell
export_code find_max_impl in Scala

end


chapter \<open>Set and bool as a pointed cpo.\<close>

theory SetPcpo
imports HOLCF LNat
begin

text \<open>PCPO on sets and bools. The \<open>\<sqsubseteq>\<close> operator of the order is defined as the \<open>\<subseteq>\<close> operator on sets
  and as \<open>\<longrightarrow>\<close> on booleans.
\<close>

(* ----------------------------------------------------------------------- *)
section \<open>Order on sets.\<close>
(* ----------------------------------------------------------------------- *)

text \<open>{text "\<sqsubseteq>"} operator as the \<open>\<subseteq>\<close> operator on sets -> partial order.\<close>
instantiation set :: (type) po
begin
  definition less_set_def: "(\<sqsubseteq>) = (\<subseteq>)"
instance
apply intro_classes
apply (simp add: less_set_def)
apply (simp add: less_set_def)
apply (simp add: less_set_def)
done
end

text \<open>The least upper bound on sets corresponds to the \<open>Union\<close> operator.\<close>
lemma Union_is_lub: "A <<| \<Union>A"
apply (simp add: is_lub_def)
apply (simp add: is_ub_def)
apply (simp add: less_set_def Union_upper)
apply (simp add: Sup_least)
done

text \<open>Another needed variant of the fact that lub on sets corresponds to union.\<close>
lemma lub_eq_Union: "lub = Union"
apply (rule ext)
apply (rule lub_eqI [OF Union_is_lub])
done

text \<open>The partial order on sets is complete.\<close>
instance set :: (type) cpo
apply intro_classes
using Union_is_lub
apply auto
done

text \<open>Sets are also pcpo`s, pointed with \<open>{}\<close> as minimal element.\<close>
instance set :: (type) pcpo
apply intro_classes
apply (rule_tac x= "{}" in exI)
apply (simp add: less_set_def)
done

text \<open>For sets, the minimal element is the empty set.\<close>
lemma UU_eq_empty: "\<bottom> = {}"
apply (simp add: less_set_def bottomI)
done

text \<open>We group the following lemmas in order to simplify future proofs.\<close>
lemmas set_cpo_simps = less_set_def lub_eq_Union UU_eq_empty

(* ----------------------------------------------------------------------- *)
section \<open>Order on booleans.\<close>
(* ----------------------------------------------------------------------- *)

text \<open>If one defines the \<open>\<sqsubseteq>\<close> operator as the \<open>\<longrightarrow>\<close> operator on booleans,
  one obtains a partial order.\<close>
instantiation bool :: po
begin
  definition less_bool_def: "(\<sqsubseteq>) = (\<longrightarrow>)"
instance
apply intro_classes
apply (simp add: less_bool_def)
apply (simp add: less_bool_def)
apply (simp add: less_bool_def)
apply (simp add: less_bool_def)
apply auto
done
end

text \<open>Chains of bools are always finite. This is needed to prove that bool is a cpo.\<close>
instance bool :: chfin
proof
  fix S:: "nat \<Rightarrow> bool"
  assume S: "chain S"
  then have "finite (range S)"
  apply simp
  done
  from S and this
  have "finite_chain S"
  apply (rule finite_range_imp_finch)
  done
  thus "\<exists> n. max_in_chain n S"
  apply (unfold finite_chain_def, simp)
  done
qed

text \<open>The partial order on bools is complete.\<close>
instance bool :: cpo ..

text \<open>Bools are also pointed with \<open>False\<close> as minimal element.\<close>
instance bool :: pcpo
proof
  have "\<forall>y::bool. False \<sqsubseteq> y"
  unfolding less_bool_def
  apply simp
  done
  thus "\<exists>x::bool. \<forall>y. x \<sqsubseteq> y" ..
qed

(* ----------------------------------------------------------------------- *)
section \<open>Properties\<close>
(* ----------------------------------------------------------------------- *)

(* ----------------------------------------------------------------------- *)
subsection \<open>Admissibility of set predicates\<close>
(* ----------------------------------------------------------------------- *)

text \<open>The predicate "\<lambda>A. \<exists>x. x \<in> A" is admissible.\<close>
lemma adm_nonempty: "adm (\<lambda>A. \<exists>x. x \<in> A)"
apply (rule admI)
apply (simp add: lub_eq_Union)
apply force
done

text \<open>The predicate "\<lambda>A. x \<in> A" is admissible.\<close>
lemma adm_in: "adm (\<lambda>A. x \<in> A)"
apply (rule admI)
apply (simp add: lub_eq_Union)
done

text \<open>The predicate "\<lambda>A. x \<notin> A" is admissible.\<close>
lemma adm_not_in: "adm (\<lambda>A. x \<notin> A)"
apply (rule admI)
apply (simp add: lub_eq_Union)
done

text \<open>If for all x the predicate "\<lambda>A. P A x" is admissible, then so is "\<lambda>A. \<forall>x\<in>A. P A x".\<close>
lemma adm_Ball: "(\<And>x. adm (\<lambda>A. P A x)) \<Longrightarrow> adm (\<lambda>A. \<forall>x\<in>A. P A x)"
apply (simp add: Ball_def)
apply (simp add: adm_not_in)
done

text \<open>The predicate "\<lambda>A. Bex A P", which means "\<lambda>A. \<exists>x. x \<in> A \<and> P x" is admissible.\<close>
lemma adm_Bex: "adm (\<lambda>A. Bex A P)"
apply (rule admI)
apply (simp add: lub_eq_Union)
done

text \<open>The predicate "\<lambda>A. A \<subseteq> B" is admissible.\<close>
lemma adm_subset: "adm (\<lambda>A. A \<subseteq> B)"
apply (rule admI)
apply (simp add: lub_eq_Union)
apply auto
done

text \<open>The predicate "\<lambda>A. B \<subseteq> A" is admissible.\<close>
lemma adm_superset: "adm (\<lambda>A. B \<subseteq> A)"
apply (rule admI)
apply (simp add: lub_eq_Union)
apply auto
done

text \<open>We group the following lemmas in order to simplify future proofs.\<close>
lemmas adm_set_lemmas = adm_nonempty adm_in adm_not_in adm_Bex adm_Ball adm_subset adm_superset

(* ----------------------------------------------------------------------- *)
subsection \<open>Compactness\<close>
(* ----------------------------------------------------------------------- *)

text \<open>The bottom element of the set cpo ist compact.\<close>
lemma compact_empty: "compact {}"
apply (fold UU_eq_empty)
apply simp
done

text \<open>Induction step for compact sets:
If a set is compact and we insert an element into it, then the compactness is preserved.\<close>
lemma compact_insert: "compact A \<Longrightarrow> compact (insert x A)"
apply (simp add: compact_def)
apply (simp add: set_cpo_simps)
apply (simp add: adm_set_lemmas)
done

text \<open>The compactness of finite sets is proven by induction from the lemma above.\<close>
lemma finite_imp_compact: "finite A \<Longrightarrow> compact A"
apply (induct A set: finite)
apply (rule compact_empty)
apply (erule compact_insert)
done

lemma union_cont:"cont (\<lambda>S2. union S1 S2)"
  apply(rule contI)
  unfolding  SetPcpo.less_set_def
  unfolding lub_eq_Union
  by (metis (no_types, lifting) UN_simps(3) Union_is_lub empty_not_UNIV lub_eq lub_eqI)

section \<open>setify\<close>
definition setify_on::"'m set \<Rightarrow> ('m::type \<Rightarrow> ('n::type set)) \<Rightarrow> ('m \<Rightarrow> 'n) set" where
"setify_on Dom \<equiv> \<lambda> f. {g. \<forall>m\<in>Dom. g m \<in> (f m)}"

definition setify::"('m::type \<Rightarrow> ('n::type set)) \<Rightarrow> ('m \<Rightarrow> 'n) set" where
"setify \<equiv> \<lambda> f. {g. \<forall>m. g m \<in> (f m)}"

subsection \<open>setify_on\<close>
thm setify_def
lemma setify_on_mono[simp]: "\<And> Dom. monofun (\<lambda> f. {g. \<forall>m\<in>Dom. g m \<in> (f m)})"
proof (rule monofunI, simp add: less_set_def, rule)
  fix x y::"'m::type \<Rightarrow> ('n::type set)"
  fix Dom::"'m set"
  fix xa:: "'m \<Rightarrow> 'n"
  assume a1:"x \<sqsubseteq> y"
  assume a2: "xa \<in> {g. \<forall>m\<in>Dom. g m \<in> x m}"
  have f0: "\<And>m. x m \<sqsubseteq> y m"
    by (simp add: a1 fun_belowD)
  have f1: "\<And>m. m \<in> Dom \<Longrightarrow> xa m \<in> x m"
    using a2 by blast
  have f2: "\<And>m. m \<in> Dom \<Longrightarrow> xa m \<in> y m"
    by (metis SetPcpo.less_set_def f0 f1 subsetCE)
  show "xa \<in> {g. \<forall>m\<in>Dom. g m \<in> y m}"
    using f2 by blast
qed

lemma setify_on_empty:"\<And> Dom. sbe \<in> Dom \<Longrightarrow> f sbe = {} \<Longrightarrow> setify_on Dom f = {}"
  apply(simp add: setify_on_def)
  by (metis empty_iff)

lemma setify_on_notempty_ex:"setify_on Dom f \<noteq> {} \<Longrightarrow> \<exists>g.(\<forall>m \<in> Dom. g m \<in> (f m))"
  by (metis (no_types, lifting) Collect_empty_eq setify_on_def)

lemma setify_on_notempty:assumes "\<forall>m \<in> Dom. f m \<noteq> {}" shows" setify_on Dom f \<noteq> {}"
proof(simp add: setify_on_def)
  have "\<forall>m \<in> Dom. (\<exists>x. x\<in>((f m)))"
    by (metis all_not_in_conv assms)
  have "\<forall>m \<in> Dom. (\<lambda>e. SOME x. x\<in> (f e)) m \<in> (f m)"
    by (metis assms some_in_eq)
  then show "\<exists>x::'a \<Rightarrow> 'b. \<forall>m::'a \<in> Dom. x m \<in> (f m)"
    by(rule_tac x="(\<lambda>e. SOME x. x\<in> (f e))" in exI, auto)
qed

lemma setify_on_final:assumes "\<forall>m \<in> Dom. f m \<noteq> {}" and "x \<in> (f m)"
  shows"\<exists>g\<in>((setify_on Dom f)). g m = x"
proof(simp add: setify_on_def)
  have "\<exists>g.(\<forall>m \<in> Dom. g m \<in> (f m))"
    by(simp add: setify_on_notempty setify_on_notempty_ex assms(1))
  then obtain g where g_def:"(\<forall>m \<in> Dom. g m \<in> (f m))"
    by auto
  have g2_def:"\<forall>n \<in> Dom. (\<lambda>e. if e = m then x else g e) n \<in> (f n)"
    by (simp add: assms(2) g_def)
  then show "\<exists>g::'a \<Rightarrow> 'b. (\<forall>m::'a \<in> Dom. g m \<in> (f m)) \<and> g m = x"
    by(rule_tac x="(\<lambda>e. if e = m then x else g e)" in exI, auto)
qed

subsection \<open>setify\<close>
lemma setify_mono[simp]:"monofun (\<lambda>f. {g. \<forall>m. g m \<in> (f m)})"
  apply(rule monofunI)
  by (smt Collect_mono SetPcpo.less_set_def below_fun_def subsetCE)

lemma setify_cont[simp]:"cont (\<lambda>f. {g. \<forall>m. g m \<in> ((f m))})"
proof(rule Cont.contI2, simp)
  fix Y::"nat \<Rightarrow> 'a \<Rightarrow> 'b set"
  assume a1:"chain Y"
  assume a2:"chain (\<lambda>i::nat. {g::'a \<Rightarrow> 'b. \<forall>m::'a. g m \<in> (Y i m)})"
  have a3:"\<forall>m. chain (\<lambda>i. Y i m)"
    by (simp add: a1 ch2ch_fun)
  then have "\<forall>m.((\<Squnion>i::nat. Y i) m) = (\<Squnion>i::nat. Y i m)"
    by (simp add: a1 lub_fun)
  show "{g::'a \<Rightarrow> 'b. \<forall>m::'a. g m \<in> ((\<Squnion>i::nat. Y i) m)} \<sqsubseteq> (\<Squnion>i::nat. {g::'a \<Rightarrow> 'b. \<forall>m::'a. g m \<in>  (Y i m)})"
    apply(simp add: lub_eq_Union less_set_def)
    apply auto
    oops

(*
lemma setify_insert:"setify\<cdot>f = Rev {g. \<forall>m. g m \<in> (inv Rev(f m))}"
  by(simp add: setify_def)
  *)
lemma setify_empty:"f m = {} \<Longrightarrow> setify f = {}"
  apply(simp add: setify_def)
  by (metis empty_iff)

lemma setify_notempty:assumes "\<forall>m. f m \<noteq> {}" shows" setify f \<noteq> {}"
proof(simp add: setify_def)
  have "\<forall>m. \<exists>x. x\<in>((f m))"
    by (metis all_not_in_conv assms)
  have "\<forall>m. (\<lambda>e. SOME x. x\<in> (f e)) m \<in> (f m)"
    by (metis assms some_in_eq)
  then show "\<exists>x::'a \<Rightarrow> 'b. \<forall>m::'a. x m \<in> (f m)"
    by(rule_tac x="(\<lambda>e. SOME x. x\<in> (f e))" in exI, auto)
qed

lemma setify_notempty_ex:"setify f \<noteq> {} \<Longrightarrow> \<exists>g.(\<forall>m. g m \<in> (f m))"
  by(simp add: setify_def)

lemma setify_final:assumes "\<forall>m. f m \<noteq> {}" and "x \<in> (f m)" shows"\<exists>g\<in>((setify f)). g m = x"
proof(simp add: setify_def)
  have "\<exists>g.(\<forall>m. g m \<in> (f m))"
    by(simp add: setify_notempty setify_notempty_ex assms(1))
  then obtain g where g_def:"(\<forall>m. g m \<in> (f m))"
    by auto
  have g2_def:"\<forall>n. (\<lambda>e. if e = m then x else g e) n \<in> (f n)"
    by (simp add: assms(2) g_def)
  then show "\<exists>g::'a \<Rightarrow> 'b. (\<forall>m::'a. g m \<in> (f m)) \<and> g m = x"
    by(rule_tac x="(\<lambda>e. if e = m then x else g e)" in exI, auto)
qed

inductive setSize_helper :: "'a set \<Rightarrow> nat \<Rightarrow> bool"
  where
    "setSize_helper {} 0"
  |  "setSize_helper A X \<and> a \<notin> A \<Longrightarrow> setSize_helper (insert a A) (Suc X)"

definition setSize :: "'a set \<Rightarrow> lnat"
  where
  "setSize X \<equiv> if (finite X) then Fin (THE Y. setSize_helper X Y) else \<infinity>"

lemma setSizeEx: assumes "finite X" shows "\<exists> Y. setSize_helper X Y"
  apply (rule finite_induct)
  apply (simp add: assms)
  using setSize_helper.intros(1) apply auto[1]
  by (metis setSize_helper.simps)

lemma setSize_remove: "y \<in> F \<and> setSize_helper (F - {y}) A \<longrightarrow> setSize_helper F (Suc A)"
  by (metis Diff_insert_absorb Set.set_insert setSize_helper.intros(2))

lemma setSizeBack_helper:
  assumes "\<forall>(F::'a set) x::'a. (finite F \<and> setSize_helper (insert x F) (Suc A) \<and> x \<notin> F) \<longrightarrow> setSize_helper F A"
  shows "\<forall>(F::'a set) x::'a. (finite F \<and> setSize_helper (insert x F) (Suc (Suc A)) \<and> x \<notin> F) \<longrightarrow> setSize_helper F (Suc A)"
proof -
have b0: "\<And>A::nat. \<forall>(F::'a set) x::'a. ((setSize_helper (insert x F) (Suc (Suc A)) \<and> x \<notin> F)
  \<longrightarrow> (\<exists> y. y \<in> (insert x F) \<and> setSize_helper ((insert x F) - {y}) (Suc A)))"
    by (metis Diff_insert_absorb add_diff_cancel_left' insertI1 insert_not_empty plus_1_eq_Suc setSize_helper.simps)
have b1: "\<forall>(F::'a set) (x::'a) y::'a. ((finite F \<and> setSize_helper (insert x (F - {y})) (Suc A) \<and> x \<notin> F)
  \<longrightarrow> setSize_helper (F - {y}) A)"
  using assms by auto
have b2: "\<forall>(F::'a set) x::'a. (setSize_helper (insert x F) (Suc (Suc A)) \<and> x \<notin> F)
  \<longrightarrow> ((\<exists> y. (y\<noteq>x \<and> y \<in> F \<and> setSize_helper (insert x (F - {y})) (Suc A))) \<or> setSize_helper F (Suc A))"
  by (metis Diff_insert_absorb b0 empty_iff insert_Diff_if insert_iff)
have b3: "\<forall>(F::'a set) x::'a. (setSize_helper (insert x F) (Suc (Suc A)) \<and> x \<notin> F \<and> finite F)
  \<longrightarrow> ((\<exists> y. (y\<noteq>x \<and> y \<in> F \<and> setSize_helper (F - {y}) A)) \<or> setSize_helper F (Suc A))"
  by (meson b1 b2)
show "\<forall>(F::'a set) x::'a. (finite F \<and> setSize_helper (insert x F) (Suc (Suc A)) \<and> x \<notin> F) \<longrightarrow> setSize_helper F (Suc A)"
  by (meson b3 setSize_remove)
qed

lemma setSizeBack: "\<And> F x. (finite F \<and> setSize_helper (insert x F) (Suc A) \<and> x \<notin> F) \<Longrightarrow> setSize_helper F A"
  apply (induction A)
  apply (metis Suc_inject empty_iff insertI1 insert_eq_iff nat.distinct(1) setSize_helper.simps)
  using setSizeBack_helper by blast

lemma setSizeonlyOne: assumes "finite X" shows "\<exists>! Y. setSize_helper X Y"
  apply (rule finite_induct)
  apply (simp add: assms)
  apply (metis empty_not_insert setSize_helper.simps)
  by (metis insert_not_empty setSizeBack setSize_helper.intros(2) setSize_helper.simps)

lemma setSizeSuc: assumes "finite X" and "z \<notin> X" shows "setSize (insert z X) = lnsuc\<cdot>(setSize X)"
  apply (simp add: setSize_def)
  using assms setSizeonlyOne
  by (metis (mono_tags, lifting) Diff_insert_absorb finite.insertI insertI1 setSize_remove theI_unique)

lemma setSizeEmpty: "setSize {} = Fin 0"
  by (metis finite.emptyI setSize_def setSize_helper.intros(1) setSizeonlyOne theI_unique)

lemma setSizeSingleton: "setSize {x} = lnsuc\<cdot>(Fin 0)"
  by (simp add: setSizeEmpty setSizeSuc)

lemma setsize_union_helper1:
  assumes "finite F"
      and "x \<notin> F"
      and "x \<notin> X"
    shows "setSize (X \<union> F) + setSize (X \<inter> F) = setSize X + setSize F \<Longrightarrow>
       setSize (X \<union> insert x F) + setSize (X \<inter> insert x F) = setSize X + setSize (insert x F)"
proof -
  assume a0: "setSize (X \<union> F) + setSize (X \<inter> F) = setSize X + setSize F"
  have b0: "X \<union> insert x F = insert x (X \<union> F)"
    by simp
  have b1: "setSize (X \<union> insert x F) = lnsuc\<cdot>(setSize (X \<union> F))"
    by (metis Un_iff Un_infinite assms(1) assms(2) assms(3) b0 finite_UnI fold_inf setSizeSuc setSize_def sup_commute)
  have b2: "setSize (X \<inter> insert x F) = setSize (X \<inter> F)"
    by (simp add: assms(3))
  show "setSize (X \<union> insert x F) + setSize (X \<inter> insert x F) = setSize X + setSize (insert x F)"
    by (metis (no_types, lifting) a0 ab_semigroup_add_class.add_ac(1) add.commute assms(1) assms(2)
      b1 b2 lnat_plus_suc setSizeSuc)
qed

lemma setsize_union_helper2:
  assumes "finite F"
      and "x \<notin> F"
      and "x \<in> X"
    shows "setSize (X \<union> F) + setSize (X \<inter> F) = setSize X + setSize F \<Longrightarrow>
       setSize (X \<union> insert x F) + setSize (X \<inter> insert x F) = setSize X + setSize (insert x F)"
proof -
  assume a0: "setSize (X \<union> F) + setSize (X \<inter> F) = setSize X + setSize F"
  have b0: "setSize (X \<union> insert x F) = setSize (X \<union> F)"
    by (metis Un_Diff_cancel assms(3) insert_Diff1)
  have b1: "setSize (X \<inter> insert x F) =  lnsuc\<cdot>(setSize (X \<inter> F))"
    by (simp add: assms(1) assms(2) assms(3) setSizeSuc)
  show "setSize (X \<union> insert x F) + setSize (X \<inter> insert x F) = setSize X + setSize (insert x F)"
    by (metis a0 ab_semigroup_add_class.add_ac(1) assms(1) assms(2) b0 b1 lnat_plus_suc setSizeSuc)
qed

lemma setsize_union_helper3: assumes "finite X" and "finite Y"
  shows "setSize (X \<union> Y) + setSize (X \<inter> Y) = setSize X + setSize Y"
  apply (rule finite_induct)
  apply (simp add: assms)
  apply simp
  by (meson setsize_union_helper1 setsize_union_helper2)

lemma setsize_union_helper4: assumes "infinite X \<or> infinite Y"
  shows "setSize (X \<union> Y) + setSize (X \<inter> Y) = setSize X + setSize Y"
proof -
  have b0: "setSize (X \<union> Y) = \<infinity>"
    by (metis (full_types) assms infinite_Un setSize_def)
  have b1: "setSize X = \<infinity> \<or> setSize Y = \<infinity>"
    by (meson assms setSize_def)
  show ?thesis
    using b0 b1 plus_lnatInf_r by auto
qed

lemma setsize_union: "setSize (X \<union> Y) + setSize (X \<inter> Y) = setSize X + setSize Y"
  by (meson setsize_union_helper3 setsize_union_helper4)

lemma setsize_union_disjoint: assumes "X \<inter> Y = {}"
  shows "setSize (X \<union> Y) = setSize X + setSize Y"
  by (metis Fin_02bot add.left_neutral assms bot_is_0 lnat_plus_commu setSizeEmpty setsize_union)

lemma setsize_subset_union: assumes "X \<subseteq> Y"
  shows "setSize (X \<union> Y) = setSize Y"
  by (simp add: assms sup.absorb2)

lemma set_union_ins: "\<And> F G x. setSize (F \<union> G) \<le> setSize (F \<union> (insert x G))"
  by (metis Fin_Suc Fin_leq_Suc_leq  Un_insert_right finite_insert insert_absorb lnat_po_eq_conv
  setSizeSuc setSize_def)

lemma setsize_mono_union_helper1:
  assumes "finite F" and "finite G"
  shows "setSize F \<le> setSize (F \<union> G)"
proof -
  have b0:  "\<And>P. P = (\<lambda>G. setSize F \<le> setSize (F \<union> G)) \<Longrightarrow> P G"
    by (metis assms(2) finite_induct order_refl set_union_ins sup_bot.right_neutral trans_lnle)
  have b1: "(\<lambda>G. setSize F \<le> setSize (F \<union> G)) G"
    using b0 by auto
  show "setSize F \<le> setSize (F \<union> G)"
    by (simp add: b1)
qed

lemma setsize_mono_union_helper2:
  assumes "infinite F \<or> infinite G"
  shows "setSize F \<le> setSize (F \<union> G)"
proof -
  have b0: "setSize (F \<union> G) = \<infinity>"
    by (meson assms infinite_Un setSize_def)
  show ?thesis
    by (simp add: b0)
qed

lemma setsize_mono_union: "setSize F \<le> setSize (F \<union> G)"
  by (meson setsize_mono_union_helper1 setsize_mono_union_helper2)

lemma setsize_mono:
  assumes "F \<subseteq> G"
  shows "setSize F \<le> setSize G"
  by (metis Un_absorb1 assms setsize_mono_union)

subsection \<open>setflat\<close>

definition setflat :: "'a set set \<rightarrow> 'a set" where
"setflat = (\<Lambda> S. {K  | Z K. K\<in>Z \<and> Z \<in>S} )"

lemma setflat_mono: "monofun (\<lambda> S. {K  | Z K. K\<in>Z \<and> Z \<in>S} )"
  apply(rule monofunI)
  apply auto
  apply (simp add: less_set_def)
  apply (rule subsetI)
  by auto

lemma setflat_cont: "cont (\<lambda> S. {K  | Z K. K\<in>Z \<and> Z \<in>S} )"
  apply(rule contI2)
  using setflat_mono apply simp
  apply auto
  unfolding  SetPcpo.less_set_def
  unfolding lub_eq_Union
  by blast

lemma setflat_insert: "setflat\<cdot>S = {K  | Z K. K\<in>Z \<and> Z \<in>S}"
  unfolding setflat_def
  by (metis (mono_tags, lifting) Abs_cfun_inverse2 setflat_cont)

lemma setflat_empty:"(setflat\<cdot>S = {}) \<longleftrightarrow> (\<forall>x\<in>S. x = {})"
  by(simp add: setflat_insert, auto)

lemma setflat_not_empty:"(setflat\<cdot>S \<noteq> {}) \<longleftrightarrow> (\<exists>x\<in>S. x \<noteq> {})"
  by (simp add: setflat_empty)

lemma setflat_obtain: assumes "f \<in> setflat\<cdot>S"
  shows "\<exists> Z \<in> S. f \<in> Z"
proof -
  have "f \<in> {a. \<exists>A aa. a = aa \<and> aa \<in> A \<and> A \<in> S}"
    by (metis assms setflat_insert)
  then show ?thesis
    by blast
qed

lemma setflat_union: "setflat\<cdot>S = \<Union>S"
  apply (simp add: setflat_insert)
  apply (subst Union_eq)
  by auto

lemma setflatten_mono2: assumes "\<And>b. b\<in>S1 \<Longrightarrow>( \<exists>c. c\<in>S2 \<and> b \<subseteq> c)"
  shows "setflat\<cdot>S1 \<subseteq> setflat\<cdot> S2"
  by (smt Abs_cfun_inverse2 setflat_def setflat_cont assms mem_Collect_eq subsetCE subsetI)

lemma setfilter_easy: "Set.filter (\<lambda>f. True) X = X"
  using member_filter by auto

lemma setfilter_cont: "cont (Set.filter P)"
  by (simp add: Prelude.contI2 SetPcpo.less_set_def lub_eq_Union monofun_def subset_eq)

end


section \<open>Examples\<close>
theory LLVM_Examples
imports
  "../ds/LLVM_DS_Dflt"
  "../ds/LLVM_DS_Array_List"
begin

text \<open>Examples on top of Isabelle-LLVM basic layer.
  For the verification of more complex algorithms, consider using
  Isabelle-LLVM with the Refinement Framework, and the Sepref tool.
  See, e.g., @{file Bin_Search.thy}.
\<close>

(* TODO: Parts of this file are incomplete, the examples could me more elaborate! *)

subsection \<open>Numeric Algorithms\<close>

subsubsection \<open>Exponentiation\<close>

definition exp :: "'a::len word \<Rightarrow> 'b::len word llM" where [llvm_code]: "exp r \<equiv> doM {
  a \<leftarrow> ll_const (unsigned 1);
  (a,r) \<leftarrow> llc_while
    (\<lambda>(a,r). doM { ll_icmp_ult (unsigned 0) r})
    (\<lambda>(a,r). doM {
      return (a*unsigned 2,r-unsigned 1)
    })
    (a,r);
  return a
}"

abbreviation exp32::"32 word \<Rightarrow> 32 word llM" where "exp32 \<equiv> exp"
abbreviation exp64::"64 word \<Rightarrow> 64 word llM" where "exp64 \<equiv> exp"

export_llvm
  exp32 is "uint32_t exp32 (uint32_t)"
  exp64 is "uint64_t exp64 (uint64_t)"
  file "code/exp.ll"

lemma exp_aux1:
  assumes "2 ^ nat k < (N::int)" "t \<le> k" "0 < t"
  shows "2 * 2 ^ nat (k - t) < N"
proof -
  have "\<lbrakk>2 ^ k < N; 0 < t; t \<le> k\<rbrakk> \<Longrightarrow> 2 * 2 ^ (k - t) < (N::int)" for k t :: nat
    by (metis Suc_leI diff_less less_le_trans not_less power.simps(2) power_increasing_iff rel_simps(49) semiring_norm(76))
  with assms show ?thesis
    by (auto simp add: nat_diff_distrib' dest!: nat_mono simp flip: zero_less_nat_eq)
qed

lemma exp_aux2:  "\<lbrakk>t \<le> k; 0 < t\<rbrakk> \<Longrightarrow> nat (1+k-t) = Suc (nat (k-t))" by simp

lemma exp_correct:
  assumes "LENGTH('b::len) \<ge> 2"
  shows "llvm_htriple
    (\<upharpoonleft>uint.assn k (ki::'a::len word) ** \<up>(2^nat k \<in> uints LENGTH('b)))
    (exp ki)
    (\<lambda>r::'b word. \<upharpoonleft>uint.assn (2^nat k) r ** \<upharpoonleft>uint.assn k ki)"
  unfolding exp_def
  apply (rewrite annotate_llc_while[where
    I="\<lambda>(ai,ri) t. EXS a r. \<upharpoonleft>uint.assn a ai ** \<upharpoonleft>uint.assn r ri ** \<up>\<^sub>d( 0\<le>r \<and> r\<le>k \<and> a = 2^nat (k-r) ) ** \<up>\<^sub>!(t = r)"
    and R="measure nat"
    ])
  apply vcg_monadify
  apply (vcg'; (clarsimp simp: algebra_simps)?)
  using assms
  apply (simp_all add: exp_aux1 exp_aux2)
  done

text \<open>Executability of semantics inside Isabelle\<close>
value "run (exp64 32) llvm_empty_memory"

subsubsection \<open>Euclid's Algorithm\<close>

definition [llvm_code]: "euclid (a::'a::len word) b \<equiv> doM {
  (a,b) \<leftarrow> llc_while
    (\<lambda>(a,b) \<Rightarrow> ll_cmp (a \<noteq> b))
    (\<lambda>(a,b) \<Rightarrow> if (a\<le>b) then return (a,b-a) else return (a-b,b))
    (a,b);
  return a
}"

export_llvm (debug) (*no_while*)
  "euclid :: 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word llM" is "uint64_t euclid (uint64_t, uint64_t)"
  file "code/euclid.ll"

lemma gcd_diff1': "gcd (a::int) (b-a) = gcd a b"
  by (metis gcd.commute gcd_diff1)

lemma "llvm_htriple
  (\<upharpoonleft>uint.assn a\<^sub>0 ai ** \<upharpoonleft>uint.assn b\<^sub>0 bi ** \<up>\<^sub>d(0<a\<^sub>0 \<and> 0<b\<^sub>0))
  (euclid ai bi)
  (\<lambda>ri. \<upharpoonleft>uint.assn (gcd a\<^sub>0 b\<^sub>0) ri)"
  unfolding euclid_def
  apply (rewrite annotate_llc_while[where
    I="\<lambda>(ai,bi) t. EXS a b. \<upharpoonleft>uint.assn a ai ** \<upharpoonleft>uint.assn b bi
        ** \<up>\<^sub>a(t=a+b) ** \<up>\<^sub>d(0<a \<and> 0<b \<and> gcd a b = gcd a\<^sub>0 b\<^sub>0)"
    and R="measure nat"
  ])
  apply vcg_monadify
  apply (vcg'; clarsimp?)
  apply (simp_all add: gcd_diff1 gcd_diff1')
  done

subsubsection \<open>Fibonacci Numbers\<close>

definition fib :: "'n::len word \<Rightarrow> 'n word llM" where [llvm_code]: "fib n \<equiv> REC (\<lambda>fib' n.
  if n\<le>unsigned 1 then return n
  else doM {
    n\<^sub>1 \<leftarrow> fib' (n-unsigned 1);
    n\<^sub>2 \<leftarrow> fib' (n-unsigned 2);
    return (n\<^sub>1+n\<^sub>2)
  }) n"

abbreviation fib64 :: "64 word \<Rightarrow> 64 word llM" where "fib64 \<equiv> fib"
export_llvm thms: fib64

(* TODO: Arbitrary fixed-point reasoning not yet supported in VCG!
  set up a rule with pre and post consequence rule,
  and seplogic-assertions

lemma
  assumes MONO: "\<And>x. M.mono_body (\<lambda>fa. F fa x)"
  assumes "P x s m"
  assumes "wf R"
  assumes "\<And>D x s m. \<lbrakk> P x s m; \<And>x' s' m'. \<lbrakk> P x' s' m'; (m',m)\<in>R \<rbrakk> \<Longrightarrow> wp (D x') Q s' \<rbrakk> \<Longrightarrow> wp (F D x) Q s"
  shows "wp (REC F x) Q s"
  using assms(3,2)
  apply (induction m arbitrary: x s rule: wf_induct_rule)
  apply (subst REC_unfold) apply simp apply (rule MONO)
  using assms(4) by simp

lemma "llvm_htriple (\<upharpoonleft>uint.assn n ni) (fib ni) (\<lambda>ri. \<upharpoonleft>uint.assn x ri)"
  unfolding fib_def
  apply vcg_monadify
  apply vcg
  find_theorems wp REC
*)

prepare_code_thms (LLVM) [code] fib_def  (* Set up code equation. Required to execute semantics in Isabelle. *)

value "map (\<lambda>n. run (fib64 n) (LLVM_MEMORY (MEMORY []))) [0,1,2,3]"

(*
lemmas [named_ss llvm_inline cong] = refl[of "numeral _"]
*)

definition test :: "64 word \<Rightarrow> 64 word \<Rightarrow> _ llM"
where [llvm_code]: "test a b \<equiv> doM {

  return (a,b)
}"

ML_val \<open>
  local open LLC_Preprocessor
    val ctxt = @{context}
  in

    val thm = @{thm test_def}
      |> cthm_inline ctxt
      |> cthm_monadify ctxt

  end
\<close>

find_theorems llc_while

lemma "foo (test)"
  unfolding test_def
  apply (simp named_ss llvm_inline:)
  oops

export_llvm test

text \<open>Example and Regression Tests using LLVM-VCG directly,
i.e., without Refinement Framework\<close>

subsection \<open>Regression Tests\<close>
typedef my_pair = "UNIV :: (64 word \<times> 32 word) set" by simp

lemmas my_pair_bij[simp] = Abs_my_pair_inverse[simplified] Rep_my_pair_inverse

instantiation my_pair :: llvm_rep
begin
  definition "from_val_my_pair \<equiv> Abs_my_pair o from_val"
  definition "to_val_my_pair \<equiv> to_val o Rep_my_pair"
  definition [simp]: "struct_of_my_pair (_:: my_pair itself) \<equiv> struct_of TYPE(64 word \<times> 32 word)"
  definition "init_my_pair \<equiv> Abs_my_pair init"

  instance
    apply standard
    unfolding from_val_my_pair_def to_val_my_pair_def struct_of_my_pair_def init_my_pair_def
    apply (auto simp: to_val_word_def)
    done

end

definition my_fst :: "my_pair \<Rightarrow> 64 word llM" where [llvm_inline]: "my_fst \<equiv> ll_extract_fst"
definition my_snd :: "my_pair \<Rightarrow> 32 word llM" where [llvm_inline]: "my_snd \<equiv> ll_extract_snd"
definition my_ins_fst :: "my_pair \<Rightarrow> 64 word \<Rightarrow> my_pair llM" where [llvm_inline]: "my_ins_fst \<equiv> ll_insert_fst"
definition my_ins_snd :: "my_pair \<Rightarrow> 32 word \<Rightarrow> my_pair llM" where [llvm_inline]: "my_ins_snd \<equiv> ll_insert_snd"
definition my_gep_fst :: "my_pair ptr \<Rightarrow> 64 word ptr llM" where [llvm_inline]: "my_gep_fst \<equiv> ll_gep_fst"
definition my_gep_snd :: "my_pair ptr \<Rightarrow> 32 word ptr llM" where [llvm_inline]: "my_gep_snd \<equiv> ll_gep_snd"

definition [llvm_code]: "add_add (a::_ word) \<equiv> doM {
  x \<leftarrow> ll_add a a;
  x \<leftarrow> ll_add x x;
  return x
}"

definition [llvm_code]: "test_named (a::32 word) (b::64 word) \<equiv> doM {
  a \<leftarrow> add_add a;
  b \<leftarrow> add_add b;
  let n = (init::my_pair);
  a \<leftarrow> my_fst n;
  b \<leftarrow> my_snd n;
  n \<leftarrow> my_ins_fst n init;
  n \<leftarrow> my_ins_snd n init;

  p \<leftarrow> ll_malloc TYPE(my_pair) (1::64 word);
  p1 \<leftarrow> my_gep_fst p;
  p2 \<leftarrow> my_gep_snd p;

  return b
}"

lemma [ll_is_pair_type_thms]: "ll_is_pair_type False TYPE(my_pair) TYPE(64 word) TYPE(32 word)"
  unfolding ll_is_pair_type_def
  by auto

export_llvm (debug) test_named file "code/test_named.ll"

subsection \<open>Array List Examples\<close>

definition [llvm_code]: "cr_big_al (n::64 word) \<equiv> doM {
  a \<leftarrow> arl_new TYPE(64 word) TYPE(64);
  (_,a) \<leftarrow> llc_while
    (\<lambda>(n,a). ll_icmp_ult (signed_nat 0) n)
    (\<lambda>(n,a). doM { a \<leftarrow> arl_push_back a n; n \<leftarrow> ll_sub n (signed_nat 1); return (n,a) })
    (n,a);

  (_,s) \<leftarrow> llc_while
    (\<lambda>(n,s). ll_icmp_ult (signed_nat 0) n)
    (\<lambda>(n,s). doM { n \<leftarrow> ll_sub n (signed_nat 1); x \<leftarrow> arl_nth a n; s\<leftarrow>ll_add x s; return (n,s) })
    (n,signed_nat 0);

  return s
}"

declare Let_def[llvm_inline]
export_llvm (debug) cr_big_al is "cr_big_al" file "code/cr_big_al.ll"

subsection \<open>Sorting\<close>

definition [llvm_inline]: "llc_for_range l h c s \<equiv> doM {
  (_,s) \<leftarrow> llc_while (\<lambda>(i,s). ll_cmp (i<h)) (\<lambda>(i,s). doM {
    s\<leftarrow>c i s;
    i \<leftarrow> ll_add i 1;
    return (i,s)}
  ) (l,s);
  return s
}"

lemma llc_for_range_rule:
  assumes [vcg_rules]: "\<And>i ii si. llvm_htripleF F
      (\<upharpoonleft>snat.assn i ii ** \<up>\<^sub>d(lo\<le>i \<and> i<hi) ** I i si)
      (c ii si)
      (\<lambda>si. I (i+1) si)"
  shows "llvm_htripleF F
      (\<upharpoonleft>snat.assn lo loi ** \<upharpoonleft>snat.assn hi hii ** \<up>(lo\<le>hi) ** I lo si)
      (llc_for_range loi hii c si)
      (\<lambda>si. I hi si)"
  unfolding llc_for_range_def
  apply (rewrite at 1 to "signed_nat 1" signed_nat_def[symmetric])
  apply (rewrite annotate_llc_while[where
    I="\<lambda>(ii,si) t. EXS i. \<upharpoonleft>snat.assn i ii ** \<up>(lo\<le>i \<and> i\<le>hi) ** \<up>\<^sub>!(t=hi-i) ** I i si"
    and R="measure id"])
  apply vcg_monadify
  apply vcg'
  done

definition llc_for_range_annot :: "(nat \<Rightarrow> 'b::llvm_rep \<Rightarrow> ll_assn)
  \<Rightarrow> 'a::len word \<Rightarrow> 'a word \<Rightarrow> ('a word \<Rightarrow> 'b \<Rightarrow> 'b llM) \<Rightarrow> 'b \<Rightarrow> 'b llM"
  where [llvm_inline]: "llc_for_range_annot I \<equiv> llc_for_range"
declare [[vcg_const "llc_for_range_annot I"]]

lemmas annotate_llc_for_range = llc_for_range_annot_def[symmetric]

lemmas llc_for_range_annot_rule[vcg_rules]
  = llc_for_range_rule[where I=I, unfolded annotate_llc_for_range[of I]] for I

(* TODO: Move *)
lemma sep_red_idx_setI:
  assumes "\<And>I I'. I\<inter>I'={} \<Longrightarrow> A (I\<union>I') = (A I ** A I')"
  shows "is_sep_red (A (I-I')) (A (I'-I)) (A I) (A I')"
proof -
  define I\<^sub>1 where "I\<^sub>1 \<equiv> I-I'"
  define I\<^sub>2 where "I\<^sub>2 \<equiv> I'-I"
  define C where "C \<equiv> I\<inter>I'"

  have S1: "I = I\<^sub>1 \<union> C" "I'=I\<^sub>2 \<union> C" and S2: "I-I' = I\<^sub>1" "I'-I=I\<^sub>2" and DJ: "I\<^sub>1\<inter>C={}" "I\<^sub>2\<inter>C={}"
    unfolding I\<^sub>1_def I\<^sub>2_def C_def by auto

  show ?thesis
    apply (rule is_sep_redI)
    apply (simp only: S2; simp only: S1)
    apply (auto simp: DJ assms)
    by (simp add: conj_entails_mono sep_conj_left_commute)

qed

lemma sep_set_img_reduce:
  "is_sep_red (\<Union>*i\<in>I-I'. f i) (\<Union>*i\<in>I'-I. f i) (\<Union>*i\<in>I. f i) (\<Union>*i\<in>I'. f i)"
  by (rule sep_red_idx_setI) simp

(* TODO: Move *)

lemma is_sep_red_false[simp]: "is_sep_red P' Q' sep_false Q"
  by (auto simp: is_sep_red_def)

(* TODO: Move *)
lemma entails_pre_pure[sep_algebra_simps]:
  "(\<up>\<Phi> \<turnstile> Q) \<longleftrightarrow> (\<Phi> \<longrightarrow> \<box>\<turnstile>Q)"
  "(\<up>\<Phi>**P \<turnstile> Q) \<longleftrightarrow> (\<Phi> \<longrightarrow> P\<turnstile>Q)"
  by (auto simp: entails_def sep_algebra_simps pred_lift_extract_simps)

definition "lstr_assn A I \<equiv> mk_assn (\<lambda>as cs. \<up>(length cs = length as \<and> (\<forall>i\<in>I. i<length as)) ** (\<Union>*i\<in>I. \<upharpoonleft>A (as!i) (cs!i)))"

lemma lstr_assn_union: "I\<inter>I'={} \<Longrightarrow>
  \<upharpoonleft>(lstr_assn A (I\<union>I')) as cs = (\<upharpoonleft>(lstr_assn A I) as cs ** \<upharpoonleft>(lstr_assn A I') as cs)"
  by (auto simp: lstr_assn_def sep_algebra_simps pred_lift_extract_simps)

lemma lstr_assn_red: "is_sep_red
  (\<upharpoonleft>(lstr_assn A (I-I')) as cs) (\<upharpoonleft>(lstr_assn A (I'-I)) as cs)
  (\<upharpoonleft>(lstr_assn A I) as cs) (\<upharpoonleft>(lstr_assn A I') as cs)"
  by (rule sep_red_idx_setI) (simp add: lstr_assn_union)

lemma lstr_assn_red': "PRECOND (SOLVE_AUTO (I\<inter>I'\<noteq>{})) \<Longrightarrow> is_sep_red
  (\<upharpoonleft>(lstr_assn A (I-I')) as cs) (\<upharpoonleft>(lstr_assn A (I'-I)) as cs)
  (\<upharpoonleft>(lstr_assn A I) as cs) (\<upharpoonleft>(lstr_assn A I') as cs)"
  by (rule sep_red_idx_setI) (simp add: lstr_assn_union)

lemma lstr_assn_singleton: "\<upharpoonleft>(lstr_assn A {i}) as cs = (\<up>(length cs = length as \<and> i<length as) ** \<upharpoonleft>A (as!i) (cs!i))"
  by (auto simp: lstr_assn_def sep_algebra_simps pred_lift_extract_simps)

lemma lstr_assn_empty: "\<upharpoonleft>(lstr_assn A {}) as cs = \<up>(length cs = length as)"
  by (auto simp: lstr_assn_def sep_algebra_simps pred_lift_extract_simps)

lemma lstr_assn_out_of_range:
  "\<not>(length cs = length as \<and> (\<forall>i\<in>I. i<length as)) \<Longrightarrow> \<upharpoonleft>(lstr_assn A I) as cs = sep_false"
  "i\<in>I \<Longrightarrow> \<not>i<length as \<Longrightarrow> \<upharpoonleft>(lstr_assn A I) as cs = sep_false"
  "i\<in>I \<Longrightarrow> \<not>i<length cs \<Longrightarrow> \<upharpoonleft>(lstr_assn A I) as cs = sep_false"
  "length cs \<noteq> length as \<Longrightarrow> \<upharpoonleft>(lstr_assn A I) as cs = sep_false"
  by (auto simp: lstr_assn_def sep_algebra_simps pred_lift_extract_simps)

lemma lstr_assn_idx_left[fri_red_rules]:
  assumes "PRECOND (SOLVE_AUTO (length cs = length as \<and> i\<in>I \<and> i<length as))"
  shows "is_sep_red \<box> (\<upharpoonleft>(lstr_assn A (I-{i})) as cs) (\<upharpoonleft>A ai (cs!i)) (\<upharpoonleft>(lstr_assn A I) (as[i:=ai]) cs)"
proof -

  from assms have [simp]: "{i} - I = {}" "length cs = length as" "i<length as" and "i\<in>I"
    unfolding vcg_tag_defs by auto

  have "(\<Union>*i\<in>I - {i}. \<upharpoonleft>A (as ! i) (cs ! i))
    = (\<Union>*ia\<in>I - {i}. \<upharpoonleft>A (as[i := ai] ! ia) (cs ! ia))"
    by (rule sep_set_img_cong) auto
  then have 1: "\<upharpoonleft>(lstr_assn A (I-{i})) as cs = \<upharpoonleft>(lstr_assn A (I-{i})) (as[i:=ai]) cs"
    by (auto simp: lstr_assn_def sep_algebra_simps pred_lift_extract_simps)

  show ?thesis
    using lstr_assn_red[of A "{i}" I "as[i:=ai]" cs]
    by (simp add: 1 lstr_assn_singleton lstr_assn_empty sep_algebra_simps)

qed

lemma lstr_assn_idx_right[fri_red_rules]:
  assumes "PRECOND (SOLVE_AUTO (i\<in>I))"
  shows "is_sep_red (\<upharpoonleft>(lstr_assn A (I-{i})) as cs) \<box> (\<upharpoonleft>(lstr_assn A I) as cs) (\<upharpoonleft>A (as!i) (cs!i))"
proof -
  from assms have [simp]: "{i} - I = {}" "i\<in>I"
    unfolding vcg_tag_defs by auto

  show ?thesis
    using lstr_assn_red[of A I "{i}" "as" cs]
    apply (cases "length cs = length as \<and> (\<forall>i\<in>I. i<length as )"; simp add: lstr_assn_out_of_range)
    apply (simp add: lstr_assn_singleton lstr_assn_empty sep_algebra_simps)
    done
qed

(* TODO: Move *)
lemma is_pure_lst_assn[is_pure_rule]: "is_pure A \<Longrightarrow> is_pure (lstr_assn A I)"
  unfolding lstr_assn_def is_pure_def
  by (auto simp: sep_is_pure_assn_conjI sep_is_pure_assn_imgI)

lemma vcg_prep_lstr_assn: (* TODO: Need mechanism to recursively prepare pure parts of A! *)
  "pure_part (\<upharpoonleft>(lstr_assn A I) as cs) \<Longrightarrow> length cs = length as \<and> (\<forall>i\<in>I. i<length as)"
  by (auto simp: lstr_assn_def sep_algebra_simps dest: pure_part_split_conj)

(* TODO: Move *)
lemma pure_fri_auto_rule: "PRECOND (SOLVE_AUTO (\<flat>\<^sub>pA a c)) \<Longrightarrow> \<box> \<turnstile> \<upharpoonleft>\<^sub>pA a c"
  using pure_fri_rule
  unfolding vcg_tag_defs .

lemma pure_part_prepD: "pure_part (\<Union>*i\<in>I. f i) \<Longrightarrow> \<forall>i\<in>I. pure_part (f i)"
  by (metis Set.set_insert pure_part_split_conj sep_set_img_insert)

lemma pure_part_imp_pure_assn: "is_pure A \<Longrightarrow> pure_part (\<upharpoonleft>A a c) \<Longrightarrow> \<flat>\<^sub>pA a c"
  by (simp add: extract_pure_assn)

definition "aa_assn A \<equiv> mk_assn (\<lambda>as p. EXS cs.
  \<upharpoonleft>array_assn cs p ** \<up>(is_pure A \<and> list_all2 (\<flat>\<^sub>pA) as cs))"

lemma aa_nth_rule[vcg_rules]: "llvm_htriple
  (\<upharpoonleft>(aa_assn A) as p ** \<upharpoonleft>snat.assn i ii ** \<up>\<^sub>d(i<length as))
  (array_nth p ii)
  (\<lambda>c. \<upharpoonleft>(aa_assn A) as p ** \<upharpoonleft>A (as!i) c)"
  unfolding aa_assn_def
  apply (clarsimp simp: list_all2_conv_all_nth)
  supply pure_fri_auto_rule[fri_rules]
  apply vcg
  done

lemma aa_upd_rule[vcg_rules]: "llvm_htriple
  (\<upharpoonleft>(aa_assn A) as p ** \<upharpoonleft>snat.assn i ii ** \<upharpoonleft>A a c ** \<up>\<^sub>d(i<length as))
  (array_upd p ii c)
  (\<lambda>c. \<upharpoonleft>(aa_assn A) (as[i:=a]) p)"
proof (cases "is_pure A")
  case [is_pure_rule,simp]: True
  (*note thin_dr_pure[vcg_prep_external_drules del]*)
  note [simp] = nth_list_update pure_part_imp_pure_assn

  show ?thesis
    unfolding aa_assn_def list_all2_conv_all_nth
    supply pure_fri_auto_rule[fri_rules]
    apply vcg
    done
qed (clarsimp simp: aa_assn_def)

definition [llvm_inline]: "qs_swap A i j \<equiv> doM {
  llc_if (ll_cmp' (i\<noteq>j)) (doM {
    x \<leftarrow> array_nth A i;
    y \<leftarrow> array_nth A j;
    array_upd A i y;
    array_upd A j x;
    return ()
  }) (return ())
}"

definition [llvm_code]: "qs_partition A lo hi \<equiv> doM {
  hi \<leftarrow> ll_sub hi (signed_nat 1);
  pivot \<leftarrow> array_nth A hi;
  let i = lo;

  i \<leftarrow> llc_for_range lo hi (\<lambda>j i. doM {
    Aj \<leftarrow> array_nth A j;
    if Aj < pivot then doM {
      qs_swap A i j;
      i \<leftarrow> ll_add i (signed_nat 1);
      return i
    } else return i
  }) i;

  qs_swap A i hi;
  return i
}"

definition [llvm_code]: "qs_quicksort A lo hi \<equiv> doM {
  REC (\<lambda>quicksort (lo,hi). doM {
    if lo < hi then doM {
      p \<leftarrow> qs_partition A lo hi;
      quicksort (lo, p-1);
      quicksort (p+1,hi)
    } else
      return ()

  }) (lo,hi);
  return ()
}"

(* TODO: Prepare-code-thms after inlining! *)
(* prepare_code_thms  qs_partition_def[unfolded llc_for_range_def] *)

(*prepare_code_thms [llvm_code] qs_quicksort_def*)

llvm_deps foo: "qs_quicksort :: 64 word ptr \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> unit llM"

export_llvm "qs_quicksort :: 64 word ptr \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> unit llM" is "qs_quicksort"
  file \<open>code/qs_quicksort.ll\<close>

lemma qs_swap_aa_rule[vcg_rules]: "llvm_htriple
  (\<upharpoonleft>(aa_assn A) xs p ** \<upharpoonleft>snat.assn i ii ** \<upharpoonleft>snat.assn j ji ** \<up>\<^sub>d(i<length xs \<and> j<length xs))
  (qs_swap p ii ji)
  (\<lambda>_. \<upharpoonleft>(aa_assn A) (swap xs i j) p)"
  unfolding qs_swap_def swap_def
  apply vcg_monadify
  apply vcg'
  done

lemma qs_swap_rule[vcg_rules]: "llvm_htriple
  (\<upharpoonleft>array_assn xs A ** \<upharpoonleft>snat.assn i ii ** \<upharpoonleft>snat.assn j ji ** \<up>\<^sub>d(i<length xs \<and> j<length xs))
  (qs_swap A ii ji)
  (\<lambda>_. \<upharpoonleft>array_assn (swap xs i j) A)"
  unfolding qs_swap_def swap_def
  apply vcg_monadify
  apply vcg'
  done

fun at_idxs :: "'a list \<Rightarrow> nat list \<Rightarrow> 'a list" (infixl "\<exclamdown>" 100) where
  "at_idxs xs [] = []"
| "at_idxs xs (i#is) = xs!i # at_idxs xs is"

lemma at_idxs_eq_map_nth: "at_idxs xs is = map (nth xs) is"
  by (induction "is") auto

lemma at_idxs_append[simp]: "at_idxs xs (is\<^sub>1@is\<^sub>2) = at_idxs xs is\<^sub>1 @ at_idxs xs is\<^sub>2"
  by (induction is\<^sub>1) auto

lemma at_idxs_ran_zero: "hi\<le>length xs \<Longrightarrow> at_idxs xs [0..<hi] = take hi xs"
  by (induction hi) (auto simp: take_Suc_conv_app_nth)

lemma at_idxs_slice: "hi\<le>length xs \<Longrightarrow> at_idxs xs [lo..<hi] = Misc.slice lo hi xs"
  apply (induction lo)
  apply (auto simp: Misc.slice_def at_idxs_ran_zero)
  by (simp add: at_idxs_eq_map_nth drop_take map_nth_upt_drop_take_conv)

(* TODO: Move *)
lemma pure_part_split_img:
  assumes "pure_part (\<Union>*i\<in>I. f i)"
  shows "(\<forall>i\<in>I. pure_part (f i))"
proof (cases "finite I")
  assume "finite I"
  then show ?thesis using assms
    by (induction) (auto dest: pure_part_split_conj)
next
  assume "infinite I" with assms show ?thesis by simp
qed

lemma "pure_part (\<upharpoonleft>(lstr_assn A I) as cs) \<Longrightarrow> (length cs = length as) \<and> (\<forall>i\<in>I. i<length as \<and> pure_part (\<upharpoonleft>A (as!i) (cs!i)))"
  by (auto simp: lstr_assn_def is_pure_def list_all2_conv_all_nth sep_algebra_simps
    dest!: pure_part_split_conj pure_part_split_img)

(* TODO: Move *)
lemma lstr_assn_insert: "i\<notin>I \<Longrightarrow> \<upharpoonleft>(lstr_assn A (insert i I)) as cs = (\<up>(i < length as) ** \<upharpoonleft>A (as!i) (cs!i) ** \<upharpoonleft>(lstr_assn A I) as cs)"
  by (auto simp: lstr_assn_def sep_algebra_simps pred_lift_extract_simps)

lemma fri_lstr_pure_rl[fri_rules]:
  "PRECOND (SOLVE_ASM (\<flat>\<^sub>p(lstr_assn A I) as cs)) \<Longrightarrow> PRECOND (SOLVE_AUTO (i\<in>I)) \<Longrightarrow> \<box> \<turnstile> \<upharpoonleft>\<^sub>pA (as!i) (cs!i)"
  unfolding vcg_tag_defs
  by (auto simp: dr_assn_pure_asm_prefix_def lstr_assn_insert dr_assn_pure_prefix_def
    simp: sep_algebra_simps
    elim!: Set.set_insert dest!: pure_part_split_conj)

lemma length_swap[simp]: "length (swap xs i j) = length xs"
  by (auto simp: swap_def)

lemma at_idxs_cong:
  assumes "\<And>i. i\<in>List.set I \<Longrightarrow> xs!i = ys!i"
  shows "xs\<exclamdown>I = ys\<exclamdown>I"
  using assms
  apply (induction I)
  apply auto
  done

lemma at_idxs_upd_out[simp]: "i\<notin>List.set I \<Longrightarrow> xs[i:=x] \<exclamdown> I = xs\<exclamdown>I"
  by (auto intro: at_idxs_cong simp: nth_list_update')

lemma at_idxs_swap_out[simp]: "i\<notin>List.set I \<Longrightarrow> j\<notin>List.set I \<Longrightarrow> (swap xs i j)\<exclamdown>I = xs\<exclamdown>I"
  unfolding swap_def
  by auto

lemma mset_swap'[simp]: "\<lbrakk>i<length xs; j<length xs\<rbrakk> \<Longrightarrow> mset (swap xs i j) = mset xs"
  unfolding swap_def
  apply (auto simp: mset_swap)
  done

find_theorems at_idxs Misc.slice
find_theorems mset nth

lemma "llvm_htriple
  (\<upharpoonleft>(aa_assn snat.assn) as A ** \<upharpoonleft>snat.assn lo loi  ** \<upharpoonleft>snat.assn hi hii
    ** \<up>\<^sub>d(lo<hi \<and> hi\<le>length as))
  (qs_partition A loi hii)
  (\<lambda>pi. EXS as' p. \<upharpoonleft>(aa_assn snat.assn) as' A ** \<upharpoonleft>snat.assn p pi
    ** \<up>( lo\<le>p \<and> p<hi
        \<and> length as' = length as
        \<and> as'\<exclamdown>[0..<lo] = as\<exclamdown>[0..<lo]
        \<and> as'\<exclamdown>[hi..<length as] = as\<exclamdown>[hi..<length as]
        \<and> mset (as') = mset (as)
        \<and> (\<forall>i\<in>{lo..<p}. as!i \<le> as!p)
        \<and> (\<forall>i\<in>{p..<hi}. as!p \<le> as!i)
         ))"
  unfolding qs_partition_def
  apply (rewrite annotate_llc_for_range[where
    I="\<lambda>j ii. EXS i as'. \<upharpoonleft>snat.assn i ii ** \<upharpoonleft>(aa_assn snat.assn) as' A
      ** \<up>(length as'=length as
        \<and> lo\<le>i \<and> i<hi
        \<and> as'\<exclamdown>[0..<lo] = as\<exclamdown>[0..<lo]
        \<and> as'\<exclamdown>[hi..<length as] = as\<exclamdown>[hi..<length as]
        \<and> mset (as') = mset (as)
      )

    "])
  apply vcg_monadify
  apply vcg'
  apply clarsimp_all
  apply auto
  prefer 2
  apply (subst at_idxs_swap_out)
  apply simp
  apply simp
  apply linarith
  apply simp
  oops
(*
xxx, ctd here: sharpen invariant!

  xxx, try "arr_assn A \<equiv> array o lst A"
  try to set up rules for nth and upd, using a set of externalized indexes (and their intermediate values).
    supplement frame inference by internalize/externalize rules

  apply vcg_try_solve
  apply vcg_try_solve

  apply vcg_rl back back
  apply vcg_try_solve
  apply (fri_dbg_step) back
  apply vcg_try_solve

  oops
  xxx, ctd here: Intro-trule for pure lstr-assn

  oops
  xxx, ctd here: The array itself contains data, which needs to be abstracted over!
    we will need to relate xs!i to some abstract value!

  oops

  xxx, integrate reduction rules into frame inference!
  xxx: simplify the resulting set differences during frame inference!
    Most important: Elimination of empty sets!

  xxx, ctd here: Integrate into frame inference
    "cut" is a bad name for this concept

  find_theorems sep_set_img

  ML_val \<open>@{term \<open>\<Union>*x\<in>y. p\<close>}\<close>

  lemma
    assumes "\<upharpoonleft>(lstr_assn A (I-I')) as cs \<turnstile> \<upharpoonleft>(lstr_assn A (I'-I)) as cs"
    shows "\<upharpoonleft>(lstr_assn A I) as cs \<turnstile> \<upharpoonleft>(lstr_assn A I') as cs"

    oops
  xxx, ctd here: do list_assn, with index set.

  derive rules to split/join those assertions. also rules for pure-case.
  in practice, let the lstr-assertions fragment, until some rule/frame forces a re-union.

  thm vcg_frame_erules

  apply vcg_rl

term "xs\<exclamdown>[2..<5]"

find_consts "nat \<Rightarrow> nat \<Rightarrow> _ list \<Rightarrow> _ list"

*)

end