theory PAC_Polynomials
  imports PAC_Specification Finite_Map_Multiset
begin

section \<open>Polynomials of strings\<close>

text \<open>

  Isabelle's definition of polynomials only work with variables of type
  \<^typ>\<open>nat\<close>. Therefore, we introduce a version that uses strings by using an injective function
  that converts a string to a natural number. It exists because strings are countable. Remark that
  the whole development is independent of the function.

\<close>

subsection \<open>Polynomials and Variables\<close>

lemma poly_embed_EX:
  \<open>\<exists>\<phi>. bij (\<phi> :: string \<Rightarrow> nat)\<close>
  by (rule countableE_infinite[of \<open>UNIV :: string set\<close>])
     (auto intro!: infinite_UNIV_listI)

text \<open>Using a multiset instead of a list has some advantage from an abstract point of view. First,
  we can have monomials that appear several times  and the coefficient can also be zero. Basically,
  we can represent un-normalised polynomials, which is very useful to talk about intermediate states
  in our program.
\<close>
type_synonym term_poly = \<open>string multiset\<close>
type_synonym mset_polynomial =
  \<open>(term_poly * int) multiset\<close>

definition normalized_poly :: \<open>mset_polynomial \<Rightarrow> bool\<close> where
  \<open>normalized_poly p \<longleftrightarrow>
     distinct_mset (fst `# p) \<and>
     0 \<notin># snd `# p\<close>

lemma normalized_poly_simps[simp]:
  \<open>normalized_poly {#}\<close>
  \<open>normalized_poly (add_mset t p) \<longleftrightarrow> snd t \<noteq> 0 \<and>
    fst t \<notin># fst `# p \<and> normalized_poly p\<close>
  by (auto simp: normalized_poly_def)

lemma normalized_poly_mono:
  \<open>normalized_poly B \<Longrightarrow> A \<subseteq># B \<Longrightarrow> normalized_poly A\<close>
  unfolding normalized_poly_def
  by (auto intro: distinct_mset_mono image_mset_subseteq_mono)

definition mult_poly_by_monom :: \<open>term_poly * int \<Rightarrow> mset_polynomial \<Rightarrow> mset_polynomial\<close> where
  \<open>mult_poly_by_monom  = (\<lambda>ys q. image_mset (\<lambda>xs. (fst xs + fst ys, snd ys * snd xs)) q)\<close>

definition mult_poly_raw :: \<open>mset_polynomial \<Rightarrow> mset_polynomial \<Rightarrow> mset_polynomial\<close> where
  \<open>mult_poly_raw p q =
    (sum_mset ((\<lambda>y. mult_poly_by_monom y q) `# p))\<close>

definition remove_powers :: \<open>mset_polynomial \<Rightarrow> mset_polynomial\<close> where
  \<open>remove_powers xs =  image_mset (apfst remdups_mset) xs\<close>

definition all_vars_mset :: \<open>mset_polynomial \<Rightarrow> string multiset\<close> where
  \<open>all_vars_mset p = \<Sum>\<^sub># (fst `# p)\<close>

abbreviation all_vars :: \<open>mset_polynomial \<Rightarrow> string set\<close> where
  \<open>all_vars p \<equiv> set_mset (all_vars_mset p)\<close>

definition add_to_coefficient :: \<open>_ \<Rightarrow> mset_polynomial \<Rightarrow> mset_polynomial\<close>  where
  \<open>add_to_coefficient = (\<lambda>(a, n) b. {#(a', _) \<in># b. a' \<noteq> a#} +
             (if n + sum_mset (snd `# {#(a', _) \<in># b. a' = a#}) = 0 then {#}
               else {#(a, n + sum_mset (snd `# {#(a', _) \<in># b. a' = a#}))#}))\<close>

definition normalize_poly :: \<open>mset_polynomial \<Rightarrow> mset_polynomial\<close> where
  \<open>normalize_poly p = fold_mset add_to_coefficient {#} p\<close>

lemma add_to_coefficient_simps:
  \<open>n + sum_mset (snd `# {#(a', _) \<in># b. a' = a#}) \<noteq> 0 \<Longrightarrow>
    add_to_coefficient (a, n) b = {#(a', _) \<in># b. a' \<noteq> a#} +
             {#(a, n + sum_mset (snd `# {#(a', _) \<in># b. a' = a#}))#}\<close>
  \<open>n + sum_mset (snd `# {#(a', _) \<in># b. a' = a#}) = 0 \<Longrightarrow>
    add_to_coefficient (a, n) b = {#(a', _) \<in># b. a' \<noteq> a#}\<close> and
  add_to_coefficient_simps_If:
  \<open>add_to_coefficient (a, n) b = {#(a', _) \<in># b. a' \<noteq> a#} +
             (if n + sum_mset (snd `# {#(a', _) \<in># b. a' = a#}) = 0 then {#}
               else {#(a, n + sum_mset (snd `# {#(a', _) \<in># b. a' = a#}))#})\<close>
  by (auto simp: add_to_coefficient_def)

interpretation comp_fun_commute \<open>add_to_coefficient\<close>
proof -
  have [iff]:
    \<open>a \<noteq> aa \<Longrightarrow>
    ((case x of (a', _) \<Rightarrow> a' = a) \<and> (case x of (a', _) \<Rightarrow> a' \<noteq> aa)) \<longleftrightarrow>
    (case x of (a', _) \<Rightarrow> a' = a)\<close> for a' aa a x
    by auto
  show \<open>comp_fun_commute add_to_coefficient\<close>
    unfolding add_to_coefficient_def
    by standard
     (auto intro!: ext simp: filter_filter_mset ac_simps add_eq_0_iff)
qed

lemma normalized_poly_normalize_poly[simp]:
  \<open>normalized_poly (normalize_poly p)\<close>
  unfolding normalize_poly_def
  apply (induction p)
  subgoal by auto
  subgoal for x p
    by (cases x)
      (auto simp: add_to_coefficient_simps_If
      intro: normalized_poly_mono)
  done

subsection \<open>Addition\<close>

inductive add_poly_p :: \<open>mset_polynomial \<times> mset_polynomial \<times> mset_polynomial \<Rightarrow> mset_polynomial \<times> mset_polynomial \<times> mset_polynomial \<Rightarrow> bool\<close> where
add_new_coeff_r:
    \<open>add_poly_p (p, add_mset x q, r) (p, q, add_mset x r)\<close> |
add_new_coeff_l:
    \<open>add_poly_p (add_mset x p, q, r) (p, q, add_mset x r)\<close> |
add_same_coeff_l:
    \<open>add_poly_p (add_mset (x, n) p, q, add_mset (x, m) r) (p, q, add_mset (x, n + m) r)\<close> |
add_same_coeff_r:
    \<open>add_poly_p (p, add_mset (x, n) q, add_mset (x, m) r) (p, q, add_mset (x, n + m) r)\<close> |
rem_0_coeff:
    \<open>add_poly_p (p, q, add_mset (x, 0) r) (p, q, r)\<close>

inductive_cases add_poly_pE: \<open>add_poly_p S T\<close>

lemmas add_poly_p_induct =
  add_poly_p.induct[split_format(complete)]

lemma add_poly_p_empty_l:
  \<open>add_poly_p\<^sup>*\<^sup>* (p, q, r) ({#}, q, p + r)\<close>
  apply (induction p arbitrary: r)
  subgoal by auto
  subgoal
    by (metis (no_types, lifting) add_new_coeff_l r_into_rtranclp
      rtranclp_trans union_mset_add_mset_left union_mset_add_mset_right)
  done

lemma add_poly_p_empty_r:
  \<open>add_poly_p\<^sup>*\<^sup>* (p, q, r) (p, {#}, q + r)\<close>
  apply (induction q arbitrary: r)
  subgoal by auto
  subgoal
    by (metis (no_types, lifting) add_new_coeff_r r_into_rtranclp
      rtranclp_trans union_mset_add_mset_left union_mset_add_mset_right)
  done

lemma wf_if_measure_in_wf:
  \<open>wf R \<Longrightarrow> (\<And>a b. (a, b) \<in> S \<Longrightarrow> (\<nu> a, \<nu> b)\<in>R) \<Longrightarrow> wf S\<close>
  by (metis in_inv_image wfE_min wfI_min wf_inv_image)

lemma lexn_n:
  \<open>n > 0 \<Longrightarrow> (x # xs, y # ys) \<in> lexn r n \<longleftrightarrow>
  (length xs = n-1 \<and> length ys = n-1) \<and> ((x, y) \<in> r \<or> (x = y \<and> (xs, ys) \<in> lexn r (n - 1)))\<close>
  apply (cases n)
   apply simp
  by (auto simp: map_prod_def image_iff lex_prod_def)

lemma wf_add_poly_p:
  \<open>wf {(x, y). add_poly_p y x}\<close>
  by (rule wf_if_measure_in_wf[where R = \<open>lexn less_than 3\<close> and
     \<nu> = \<open>\<lambda>(a,b,c). [size a , size b, size c]\<close>])
    (auto simp: add_poly_p.simps wf_lexn
     simp: lexn_n simp del: lexn.simps(2))

lemma mult_poly_by_monom_simps[simp]:
  \<open>mult_poly_by_monom t {#} = {#}\<close>
  \<open>mult_poly_by_monom t (ps + qs) =  mult_poly_by_monom t ps + mult_poly_by_monom t qs\<close>
  \<open>mult_poly_by_monom a (add_mset p ps) = add_mset (fst a + fst p, snd a * snd p) (mult_poly_by_monom a ps)\<close>
proof -
  interpret comp_fun_commute \<open>(\<lambda>xs. add_mset (xs + t))\<close> for t
    by standard auto
  show
    \<open>mult_poly_by_monom t (ps + qs) =  mult_poly_by_monom t ps + mult_poly_by_monom t qs\<close> for t
    by (induction ps)
      (auto simp: mult_poly_by_monom_def)
  show
    \<open>mult_poly_by_monom a (add_mset p ps) = add_mset (fst a + fst p, snd a * snd p) (mult_poly_by_monom a ps)\<close>
    \<open>mult_poly_by_monom t {#} = {#}\<close>for t
    by (auto simp: mult_poly_by_monom_def)
qed

inductive mult_poly_p :: \<open>mset_polynomial \<Rightarrow> mset_polynomial \<times> mset_polynomial \<Rightarrow> mset_polynomial \<times> mset_polynomial \<Rightarrow> bool\<close>
  for q :: mset_polynomial where
mult_step:
    \<open>mult_poly_p q (add_mset (xs, n) p, r) (p, (\<lambda>(ys, m). (remdups_mset (xs + ys), n * m)) `# q + r)\<close>

lemmas mult_poly_p_induct = mult_poly_p.induct[split_format(complete)]

subsection \<open>Normalisation\<close>

inductive normalize_poly_p :: \<open>mset_polynomial \<Rightarrow> mset_polynomial \<Rightarrow> bool\<close>where
rem_0_coeff[simp, intro]:
    \<open>normalize_poly_p p q \<Longrightarrow> normalize_poly_p (add_mset (xs, 0) p) q\<close> |
merge_dup_coeff[simp, intro]:
    \<open>normalize_poly_p p q \<Longrightarrow> normalize_poly_p (add_mset (xs, m) (add_mset (xs, n) p)) (add_mset (xs, m + n) q)\<close> |
same[simp, intro]:
    \<open>normalize_poly_p p p\<close> |
keep_coeff[simp, intro]:
    \<open>normalize_poly_p p q \<Longrightarrow> normalize_poly_p (add_mset x p) (add_mset x q)\<close>

subsection \<open>Correctness\<close>
text \<open>
  This locales maps string polynomials to real polynomials.
\<close>
locale poly_embed =
  fixes \<phi> :: \<open>string \<Rightarrow> nat\<close>
  assumes \<phi>_inj: \<open>inj \<phi>\<close>
begin

definition poly_of_vars :: "term_poly \<Rightarrow> ('a :: {comm_semiring_1}) mpoly" where
  \<open>poly_of_vars xs = fold_mset (\<lambda>a b. Var (\<phi> a) * b) (1 :: 'a mpoly) xs\<close>

lemma poly_of_vars_simps[simp]:
  shows
    \<open>poly_of_vars (add_mset x xs) = Var (\<phi> x) * (poly_of_vars xs :: ('a :: {comm_semiring_1}) mpoly)\<close> (is ?A) and
    \<open>poly_of_vars (xs + ys) = poly_of_vars xs * (poly_of_vars ys :: ('a :: {comm_semiring_1}) mpoly)\<close> (is ?B)
proof -
  interpret comp_fun_commute \<open>(\<lambda>a b. (b :: 'a :: {comm_semiring_1} mpoly) * Var (\<phi> a))\<close>
    by standard
      (auto simp: algebra_simps ac_simps
         Var_def times_monomial_monomial intro!: ext)

  show ?A
    by (auto simp: poly_of_vars_def comp_fun_commute_axioms fold_mset_fusion
      ac_simps)
  show ?B
    apply (auto simp: poly_of_vars_def ac_simps)
    by (simp add: local.comp_fun_commute_axioms local.fold_mset_fusion
      semiring_normalization_rules(18))
qed

definition mononom_of_vars where
  \<open>mononom_of_vars \<equiv> (\<lambda>(xs, n). (+) (Const n * poly_of_vars xs))\<close>

interpretation comp_fun_commute \<open>mononom_of_vars\<close>
  by standard
    (auto simp: algebra_simps ac_simps mononom_of_vars_def
       Var_def times_monomial_monomial intro!: ext)

lemma mononom_of_vars_add[simp]:
  \<open>NO_MATCH 0 b \<Longrightarrow> mononom_of_vars xs b = Const (snd xs) * poly_of_vars (fst xs) + b\<close>
  by (cases xs)
    (auto simp: ac_simps mononom_of_vars_def)

definition polynomial_of_mset :: \<open>mset_polynomial \<Rightarrow> _\<close> where
  \<open>polynomial_of_mset p = sum_mset (mononom_of_vars `# p) 0\<close>

lemma polynomial_of_mset_append[simp]:
  \<open>polynomial_of_mset (xs + ys) = polynomial_of_mset xs + polynomial_of_mset ys\<close>
  by (auto simp: ac_simps Const_def polynomial_of_mset_def)

lemma polynomial_of_mset_Cons[simp]:
  \<open>polynomial_of_mset (add_mset x ys) = Const (snd x) * poly_of_vars (fst x) + polynomial_of_mset ys\<close>
  by (cases x)
    (auto simp: ac_simps polynomial_of_mset_def mononom_of_vars_def)

lemma polynomial_of_mset_empty[simp]:
  \<open>polynomial_of_mset {#} = 0\<close>
  by (auto simp: polynomial_of_mset_def)

lemma polynomial_of_mset_mult_poly_by_monom[simp]:
  \<open>polynomial_of_mset (mult_poly_by_monom x ys) =
       (Const (snd x) * poly_of_vars (fst x) * polynomial_of_mset ys)\<close>
 by (induction ys)
   (auto simp: Const_mult algebra_simps)

lemma polynomial_of_mset_mult_poly_raw[simp]:
  \<open>polynomial_of_mset (mult_poly_raw xs ys) = polynomial_of_mset xs * polynomial_of_mset ys\<close>
  unfolding mult_poly_raw_def
  by (induction xs arbitrary: ys)
   (auto simp: Const_mult algebra_simps)

lemma polynomial_of_mset_uminus:
  \<open>polynomial_of_mset {#case x of (a, b) \<Rightarrow> (a, - b). x \<in># za#} =
    - polynomial_of_mset za\<close>
  by (induction za)
    auto

lemma X2_X_polynomial_bool_mult_in:
  \<open>Var (x1) * (Var (x1) * p) -  Var (x1) * p \<in> More_Modules.ideal polynomial_bool\<close>
  using ideal_mult_right_in[OF  X2_X_in_pac_ideal[of x1 \<open>{}\<close>, unfolded pac_ideal_def], of p]
  by (auto simp: right_diff_distrib ac_simps power2_eq_square)

lemma polynomial_of_list_remove_powers_polynomial_bool:
  \<open>(polynomial_of_mset xs) - polynomial_of_mset (remove_powers xs) \<in> ideal polynomial_bool\<close>
proof (induction xs)
  case empty
  then show \<open>?case\<close> by (auto simp: remove_powers_def ideal.span_zero)
next
  case (add x xs)
  have H1: \<open>x1 \<in># x2 \<Longrightarrow>
       Var (\<phi> x1) * poly_of_vars x2 - p \<in> More_Modules.ideal polynomial_bool \<longleftrightarrow>
       poly_of_vars x2 - p \<in> More_Modules.ideal polynomial_bool
       \<close> for x1 x2 p
    apply (subst (2) ideal.span_add_eq[symmetric,
      of \<open>Var (\<phi> x1) * poly_of_vars x2 - poly_of_vars x2\<close>])
    apply (drule multi_member_split)
    apply (auto simp: X2_X_polynomial_bool_mult_in)
    done

  have diff: \<open>poly_of_vars (x) - poly_of_vars (remdups_mset (x)) \<in> ideal polynomial_bool\<close> for x
    by (induction x)
     (auto simp: remove_powers_def ideal.span_zero H1
      simp flip: right_diff_distrib intro!: ideal.span_scale)
  have [simp]: \<open>polynomial_of_mset xs -
    polynomial_of_mset (apfst remdups_mset `# xs)
    \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
    poly_of_vars ys * poly_of_vars ys -
    poly_of_vars ys * poly_of_vars (remdups_mset ys)
    \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
    polynomial_of_mset xs + Const y * poly_of_vars ys -
    (polynomial_of_mset (apfst remdups_mset `# xs) +
    Const y * poly_of_vars (remdups_mset ys))
    \<in> More_Modules.ideal polynomial_bool\<close> for y ys
    by (metis add_diff_add diff ideal.scale_right_diff_distrib ideal.span_add ideal.span_scale)
  show ?case
    using add
    apply (cases x)
    subgoal for ys y
      using ideal_mult_right_in2[OF diff, of \<open>poly_of_vars ys\<close> ys]
      by (auto simp: remove_powers_def right_diff_distrib
        ideal.span_diff ideal.span_add field_simps)
    done
qed

lemma add_poly_p_polynomial_of_mset:
  \<open>add_poly_p (p, q, r) (p', q', r') \<Longrightarrow>
    polynomial_of_mset r + (polynomial_of_mset p + polynomial_of_mset q) =
    polynomial_of_mset r' + (polynomial_of_mset p' + polynomial_of_mset q')\<close>
  apply (induction rule: add_poly_p_induct)
  subgoal
    by auto
  subgoal
    by auto
  subgoal
    by (auto simp: algebra_simps Const_add)
  subgoal
    by (auto simp: algebra_simps Const_add)
  subgoal
    by (auto simp: algebra_simps Const_add)
  done

lemma rtranclp_add_poly_p_polynomial_of_mset:
  \<open>add_poly_p\<^sup>*\<^sup>* (p, q, r) (p', q', r') \<Longrightarrow>
    polynomial_of_mset r + (polynomial_of_mset p + polynomial_of_mset q) =
    polynomial_of_mset r' + (polynomial_of_mset p' + polynomial_of_mset q')\<close>
  by (induction rule: rtranclp_induct[of add_poly_p \<open>(_, _, _)\<close> \<open>(_, _, _)\<close>, split_format(complete), of for r])
    (auto dest: add_poly_p_polynomial_of_mset)

lemma rtranclp_add_poly_p_polynomial_of_mset_full:
  \<open>add_poly_p\<^sup>*\<^sup>* (p, q, {#}) ({#}, {#}, r') \<Longrightarrow>
    polynomial_of_mset r' = (polynomial_of_mset p + polynomial_of_mset q)\<close>
  by (drule rtranclp_add_poly_p_polynomial_of_mset)
    (auto simp: ac_simps add_eq_0_iff)

lemma poly_of_vars_remdups_mset:
  \<open>poly_of_vars (remdups_mset (xs)) - (poly_of_vars xs)
    \<in> More_Modules.ideal polynomial_bool\<close>
  apply (induction xs)
  subgoal by (auto simp: ideal.span_zero)
  subgoal for x xs
    apply (cases \<open>x \<in># xs\<close>)
     apply (metis (no_types, lifting) X2_X_polynomial_bool_mult_in diff_add_cancel diff_diff_eq2
        ideal.span_diff insert_DiffM poly_of_vars_simps(1) remdups_mset_singleton_sum)
    by (metis (no_types, lifting) ideal.span_scale poly_of_vars_simps(1) remdups_mset_singleton_sum
        right_diff_distrib)
  done

lemma polynomial_of_mset_mult_map:
  \<open>polynomial_of_mset
     {#case x of (ys, n) \<Rightarrow> (remdups_mset (ys + xs), n * m). x \<in># q#} -
    Const m * (poly_of_vars xs * polynomial_of_mset q)
    \<in> More_Modules.ideal polynomial_bool\<close>
  (is \<open>?P q \<in> _\<close>)
proof (induction q)
  case empty
  then show ?case by (auto simp: algebra_simps ideal.span_zero)
next
  case (add x q)
  then have uP:  \<open>-?P q \<in> More_Modules.ideal polynomial_bool\<close>
    using ideal.span_neg by blast
  have \<open> Const b * (Const m * poly_of_vars (remdups_mset (a + xs))) -
           Const b * (Const m * (poly_of_vars a * poly_of_vars xs))
           \<in> More_Modules.ideal polynomial_bool\<close> for a b
    by (auto simp: Const_mult simp flip: right_diff_distrib' poly_of_vars_simps
        intro!: ideal.span_scale poly_of_vars_remdups_mset)
  then show ?case
    apply (subst ideal.span_add_eq2[symmetric, OF uP])
    apply (cases x)
    apply (auto simp: field_simps Const_mult  simp flip:
        intro!: ideal.span_scale poly_of_vars_remdups_mset)
    done
qed

lemma mult_poly_p_mult_ideal:
  \<open>mult_poly_p q (p, r) (p', r') \<Longrightarrow>
     (polynomial_of_mset p' * polynomial_of_mset q + polynomial_of_mset r') - (polynomial_of_mset p * polynomial_of_mset q + polynomial_of_mset r)
       \<in> ideal polynomial_bool\<close>
proof (induction rule: mult_poly_p_induct)
  case (mult_step xs n p r)
  show ?case
    by (auto simp: algebra_simps polynomial_of_mset_mult_map)
qed

lemma rtranclp_mult_poly_p_mult_ideal_final:
  \<open>(mult_poly_p q)\<^sup>*\<^sup>* (p, {#}) ({#}, r) \<Longrightarrow>
    (polynomial_of_mset r) - (polynomial_of_mset p * polynomial_of_mset q)
       \<in> ideal polynomial_bool\<close>
  by (drule rtranclp_mult_poly_p_mult_ideal) auto

lemma normalize_poly_p_poly_of_mset:
  \<open>normalize_poly_p p q \<Longrightarrow> polynomial_of_mset p = polynomial_of_mset q\<close>
  apply (induction rule: normalize_poly_p.induct)
  apply (auto simp: Const_add algebra_simps)
  done

lemma rtranclp_normalize_poly_p_poly_of_mset:
  \<open>normalize_poly_p\<^sup>*\<^sup>* p q \<Longrightarrow> polynomial_of_mset p = polynomial_of_mset q\<close>
  by (induction rule: rtranclp_induct)
    (auto simp: normalize_poly_p_poly_of_mset)

end

text \<open>It would be nice to have the property in the other direction too, but this requires a deep
dive into the definitions of polynomials.\<close>
locale poly_embed_bij = poly_embed +
  fixes V N
  assumes \<phi>_bij: \<open>bij_betw \<phi> V N\<close>
begin

definition \<phi>' :: \<open>nat \<Rightarrow> string\<close> where
  \<open>\<phi>' = the_inv_into V \<phi>\<close>

lemma \<phi>'_\<phi>[simp]:
  \<open>x \<in> V \<Longrightarrow> \<phi>' (\<phi> x) = x\<close>
  using \<phi>_bij unfolding \<phi>'_def
  by (meson bij_betw_imp_inj_on the_inv_into_f_f)

lemma \<phi>_\<phi>'[simp]:
  \<open>x \<in> N \<Longrightarrow> \<phi> (\<phi>' x) = x\<close>
  using \<phi>_bij unfolding \<phi>'_def
  by (meson f_the_inv_into_f_bij_betw)

end

end


theory P02
imports Main
begin

fun p02_1 :: "'a list \<Rightarrow> 'a  \<Rightarrow> 'a" where
"p02_1 [] defa = defa"|
"p02_1 [x] defa = defa"|
"p02_1 [x , y] defa = x"|
"p02_1 (x#xs) defa = p02_1 xs defa"

value "p02_1 [] 5 :: int"

value "(p02_1 [2] 6) :: int"

value "p02_1 [1,2] 3 :: int"

lemma "p02_1 [] defa = defa " by simp

lemma "p02_1 [val] defa = defa" by simp

lemma "p02_1 [val1,val2] defa = val1" by simp

lemma "p02_1 (xs @ [a , b]) def = a"
proof (induct xs)
  show "p02_1 ([] @ [a, b]) def = a" by simp
 next
  fix aa xs
  show "p02_1 (xs @ [a, b]) def = a \<Longrightarrow> p02_1 ((aa # xs) @ [a, b]) def = a "
  proof (cases xs)
    assume "xs = []"
    thus " p02_1 ((aa # xs) @ [a, b]) def = a" by simp
   next
    fix ab list
    assume a:" p02_1 (xs @ [a, b]) def = a"
    assume "xs = ab # list"
    from this and a show "p02_1 ((aa # xs) @ [a, b]) def = a "
    proof (cases list)
      assume " xs = ab # list"
     moreover
      assume " p02_1 (xs @ [a, b]) def = a"
     moreover
      assume "list = []"
     ultimately
      show "p02_1 ((aa # xs) @ [a, b]) def = a" by simp
     next
      fix ac lista
      assume " xs = ab # list"
     moreover
      assume "p02_1 (xs @ [a, b]) def = a"
     moreover
      assume "list = ac # lista"
     ultimately
      show "p02_1 ((aa # xs) @ [a, b]) def = a" by simp
    qed
  qed
qed

lemma "length xs \<ge> 2 \<Longrightarrow> p02_1 xs defa \<in> set xs"
proof (induct xs defa rule :  p02_1.induct)
  case (1 defa)
  then show ?case by simp
next
  case (2 x defa)
  then show ?case by simp
next
  case (3 x y defa)
  then show ?case by simp
next
  case (4 x v vb vc defa)
  then show ?case by simp
qed

lemma "length xs < 2 \<Longrightarrow> p02_1 xs defa = defa" by (induct xs defa rule : p02_1.induct, simp_all)

lemma "\<forall> xs. p02_1 xs defa = defa \<or> p02_1 xs defa \<in> set xs "
proof -
  {
    assume hyp:"\<not>(\<forall> xs. p02_1 xs defa = defa \<or> p02_1 xs defa \<in> set xs)"
    hence a:"\<exists> xs . (p02_1 xs defa \<noteq> defa) \<and> (p02_1 xs defa \<notin> set xs)" by simp
    {
      fix a
      assume hyp2:"(p02_1 a defa \<noteq> defa) \<and> (p02_1 a defa \<notin> set a)"
      hence False by (induct a defa  rule : p02_1.induct, simp_all)
    }
    with a have False by (rule exE)
  }
  thus "\<forall> xs. p02_1 xs defa = defa \<or> p02_1 xs defa \<in> set xs" by auto
qed

lemma "length xs \<ge> 2 \<Longrightarrow> p02_1 xs defa = xs ! ((length xs) -2) " by (induct xs defa rule : p02_1.induct, simp_all)

lemma "length ys = 2 \<Longrightarrow> p02_1 (xs @ ys) defa = hd ys" by  (induct xs defa rule : p02_1.induct; induct ys defa rule : p02_1.induct, simp_all)

fun p02_2 :: "'a list \<Rightarrow> 'a option" where
"p02_2 [] = None"|
"p02_2 [x] = None"|
"p02_2 [x,y] = Some x"|
"p02_2 (x#xs) = p02_2 xs"

value "p02_2 [] :: 'a option"

value "p02_2 [1] :: int option"

value "p02_2 [1,2] :: int option"

lemma "p02_2 [] = None" by simp

lemma "p02_2 [val] = None" by simp

lemma "p02_2 [val1,val2] = Some val1" by simp

lemma "p02_2 (xs @ [val1 , val2]) = Some val1" by (induct xs rule : p02_2.induct, simp_all)

lemma "length xs \<ge> 2 \<Longrightarrow> \<exists>x . p02_2 xs = Some x" by (induct xs rule : p02_2.induct, simp_all)

lemma "length xs \<ge> 2 \<Longrightarrow> the (p02_2 xs)  \<in> set xs" by (induct xs rule : p02_2.induct, simp_all)

lemma "length xs < 2 \<Longrightarrow> p02_2 xs = None" by (induct xs rule : p02_2.induct, simp_all)
find_theorems "\<not>(\<forall>x . ?P x)"

lemma "\<forall> xs:: 'a list . (p02_2 xs  = None) \<or> (the (p02_2 xs)  \<in> set xs) "
proof -
  {
    assume "\<not>(\<forall> xs:: 'a list . p02_2 xs  = None \<or> (the (p02_2 xs)  \<in> set xs ))"
    hence a:"\<exists> xs . ((p02_2 (xs :: 'a list)  \<noteq> None) \<and> (the (p02_2 xs)  \<notin> set xs)) " by simp
    {
      fix as
      assume "(p02_2 (as :: 'a list)  \<noteq> None) \<and> (the (p02_2 as)  \<notin> set as)"
      hence False by (induct as rule : p02_2.induct, simp_all)
    }
    with a have False by (rule exE)
  }
  thus ?thesis by blast
qed

lemma "length ys = 2 \<Longrightarrow> the (p02_2 (xs @ ys)) = hd ys" by (induct xs rule : p02_2.induct; induct ys rule : p02_2.induct, simp_all)

lemma "length xs \<ge> 2 \<Longrightarrow> the (p02_2 xs) = xs ! ((length xs) - 2)" by (induct xs rule : p02_2.induct, simp_all)

lemma "length xs \<ge> 2 \<Longrightarrow> the (p02_2 xs) = p02_1 xs defa" by (induct xs rule : p02_2.induct, simp_all)


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

theory Comparator
  imports "MainRLT"
begin

section \<open>Comparators on linear quasi-orders\<close>

subsection \<open>Basic properties\<close>

datatype comp = Less | Equiv | Greater

locale comparator =
  fixes cmp :: "'a \<Rightarrow> 'a \<Rightarrow> comp"
  assumes refl [simp]: "\<And>a. cmp a a = Equiv"
    and trans_equiv: "\<And>a b c. cmp a b = Equiv \<Longrightarrow> cmp b c = Equiv \<Longrightarrow> cmp a c = Equiv"
  assumes trans_less: "cmp a b = Less \<Longrightarrow> cmp b c = Less \<Longrightarrow> cmp a c = Less"
    and greater_iff_sym_less: "\<And>b a. cmp b a = Greater \<longleftrightarrow> cmp a b = Less"
begin

text \<open>Dual properties\<close>

lemma trans_greater:
  "cmp a c = Greater" if "cmp a b = Greater" "cmp b c = Greater"
  using that greater_iff_sym_less trans_less by blast

lemma less_iff_sym_greater:
  "cmp b a = Less \<longleftrightarrow> cmp a b = Greater"
  by (simp add: greater_iff_sym_less)

text \<open>The equivalence part\<close>

lemma sym:
  "cmp b a = Equiv \<longleftrightarrow> cmp a b = Equiv"
  by (metis (full_types) comp.exhaust greater_iff_sym_less)

lemma reflp:
  "reflp (\<lambda>a b. cmp a b = Equiv)"
  by (rule reflpI) simp

lemma symp:
  "symp (\<lambda>a b. cmp a b = Equiv)"
  by (rule sympI) (simp add: sym)

lemma equivp:
  "equivp (\<lambda>a b. cmp a b = Equiv)"
  using reflp symp transp by (rule equivpI)

text \<open>The strict part\<close>

lemma irreflp_less:
  "irreflp (\<lambda>a b. cmp a b = Less)"
  by (rule irreflpI) simp

lemma irreflp_greater:
  "irreflp (\<lambda>a b. cmp a b = Greater)"
  by (rule irreflpI) simp

lemma asym_less:
  "cmp b a \<noteq> Less" if "cmp a b = Less"
  using that greater_iff_sym_less by force

lemma asym_greater:
  "cmp b a \<noteq> Greater" if "cmp a b = Greater"
  using that greater_iff_sym_less by force

lemma asymp_less:
  "asymp (\<lambda>a b. cmp a b = Less)"
  using irreflp_less by (auto intro: asympI dest: asym_less)

lemma asymp_greater:
  "asymp (\<lambda>a b. cmp a b = Greater)"
  using irreflp_greater by (auto intro!: asympI dest: asym_greater)

lemma trans_equiv_less:
  "cmp a c = Less" if "cmp a b = Equiv" and "cmp b c = Less"
  using that
  by (metis (full_types) comp.exhaust greater_iff_sym_less trans_equiv trans_less)

lemma trans_less_equiv:
  "cmp a c = Less" if "cmp a b = Less" and "cmp b c = Equiv"
  using that
  by (metis (full_types) comp.exhaust greater_iff_sym_less trans_equiv trans_less)

lemma trans_equiv_greater:
  "cmp a c = Greater" if "cmp a b = Equiv" and "cmp b c = Greater"
  using that by (simp add: sym [of a b] greater_iff_sym_less trans_less_equiv)

lemma trans_greater_equiv:
  "cmp a c = Greater" if "cmp a b = Greater" and "cmp b c = Equiv"
  using that by (simp add: sym [of b c] greater_iff_sym_less trans_equiv_less)

lemma transp_less:
  "transp (\<lambda>a b. cmp a b = Less)"
  by (rule transpI) (fact trans_less)

lemma transp_greater:
  "transp (\<lambda>a b. cmp a b = Greater)"
  by (rule transpI) (fact trans_greater)

text \<open>The reflexive part\<close>

lemma reflp_not_less:
  "reflp (\<lambda>a b. cmp a b \<noteq> Less)"
  by (rule reflpI) simp

lemma reflp_not_greater:
  "reflp (\<lambda>a b. cmp a b \<noteq> Greater)"
  by (rule reflpI) simp

lemma quasisym_not_less:
  "cmp a b = Equiv" if "cmp a b \<noteq> Less" and "cmp b a \<noteq> Less"
  using that comp.exhaust greater_iff_sym_less by auto

lemma quasisym_not_greater:
  "cmp a b = Equiv" if "cmp a b \<noteq> Greater" and "cmp b a \<noteq> Greater"
  using that comp.exhaust greater_iff_sym_less by auto

lemma trans_not_less:
  "cmp a c \<noteq> Less" if "cmp a b \<noteq> Less" "cmp b c \<noteq> Less"
  using that by (metis comp.exhaust greater_iff_sym_less trans_equiv trans_less)

lemma trans_not_greater:
  "cmp a c \<noteq> Greater" if "cmp a b \<noteq> Greater" "cmp b c \<noteq> Greater"
  using that greater_iff_sym_less trans_not_less by blast

lemma transp_not_less:
  "transp (\<lambda>a b. cmp a b \<noteq> Less)"
  by (rule transpI) (fact trans_not_less)

lemma transp_not_greater:
  "transp (\<lambda>a b. cmp a b \<noteq> Greater)"
  by (rule transpI) (fact trans_not_greater)

text \<open>Substitution under equivalences\<close>

lemma equiv_subst_left:
  "cmp z y = comp \<longleftrightarrow> cmp x y = comp" if "cmp z x = Equiv" for comp
proof -
  from that have "cmp x z = Equiv"
    by (simp add: sym)
  with that show ?thesis
    by (cases comp) (auto intro: trans_equiv trans_equiv_less trans_equiv_greater)
qed

lemma equiv_subst_right:
  "cmp x z = comp \<longleftrightarrow> cmp x y = comp" if "cmp z y = Equiv" for comp
proof -
  from that have "cmp y z = Equiv"
    by (simp add: sym)
  with that show ?thesis
    by (cases comp) (auto intro: trans_equiv trans_less_equiv trans_greater_equiv)
qed

end

typedef 'a comparator = "{cmp :: 'a \<Rightarrow> 'a \<Rightarrow> comp. comparator cmp}"
  morphisms compare Abs_comparator
proof -
  have "comparator (\<lambda>_ _. Equiv)"
    by standard simp_all
  then show ?thesis
    by auto
qed

setup_lifting type_definition_comparator

global_interpretation compare: comparator "compare cmp"
  using compare [of cmp] by simp

lift_definition flat :: "'a comparator"
  is "\<lambda>_ _. Equiv" by standard simp_all

instantiation comparator :: (linorder) default
begin

lift_definition default_comparator :: "'a comparator"
  is "\<lambda>x y. if x < y then Less else if x > y then Greater else Equiv"
  by standard (auto split: if_splits)

instance ..

end

text \<open>A rudimentary quickcheck setup\<close>

instantiation comparator :: (enum) equal
begin

lift_definition equal_comparator :: "'a comparator \<Rightarrow> 'a comparator \<Rightarrow> bool"
  is "\<lambda>f g. \<forall>x \<in> set Enum.enum. f x = g x" .

instance
  by (standard; transfer) (auto simp add: enum_UNIV)

end

lemma [code nbe]:
  "HOL.equal (cmp :: 'a::enum comparator) cmp \<longleftrightarrow> True"
  by (fact equal_refl)

instantiation comparator :: ("{linorder, typerep}") full_exhaustive
begin

definition full_exhaustive_comparator ::
  "('a comparator \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option)
    \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
  where "full_exhaustive_comparator f s =
    Quickcheck_Exhaustive.orelse
      (f (flat, (\<lambda>u. Code_Evaluation.Const (STR ''Comparator.flat'') TYPEREP('a comparator))))
      (f (default, (\<lambda>u. Code_Evaluation.Const (STR ''HOL.default_class.default'') TYPEREP('a comparator))))"

instance ..

end

subsection \<open>Fundamental comparator combinators\<close>

lift_definition reversed :: "'a comparator \<Rightarrow> 'a comparator"
  is "\<lambda>cmp a b. cmp b a"
proof -
  fix cmp :: "'a \<Rightarrow> 'a \<Rightarrow> comp"
  assume "comparator cmp"
  then interpret comparator cmp .
  show "comparator (\<lambda>a b. cmp b a)"
    by standard (auto intro: trans_equiv trans_less simp: greater_iff_sym_less)
qed

lift_definition key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'a comparator \<Rightarrow> 'b comparator"
  is "\<lambda>f cmp a b. cmp (f a) (f b)"
proof -
  fix cmp :: "'a \<Rightarrow> 'a \<Rightarrow> comp" and f :: "'b \<Rightarrow> 'a"
  assume "comparator cmp"
  then interpret comparator cmp .
  show "comparator (\<lambda>a b. cmp (f a) (f b))"
    by standard (auto intro: trans_equiv trans_less simp: greater_iff_sym_less)
qed

subsection \<open>Direct implementations for linear orders on selected types\<close>

definition comparator_bool :: "bool comparator"
  where [simp, code_abbrev]: "comparator_bool = default"

lemma compare_comparator_bool [code abstract]:
  "compare comparator_bool = (\<lambda>p q.
    if p then if q then Equiv else Greater
    else if q then Less else Equiv)"
  by (auto simp add: fun_eq_iff) (transfer; simp)+

definition raw_comparator_nat :: "nat \<Rightarrow> nat \<Rightarrow> comp"
  where [simp]: "raw_comparator_nat = compare default"

lemma default_comparator_nat [simp, code]:
  "raw_comparator_nat (0::nat) 0 = Equiv"
  "raw_comparator_nat (Suc m) 0 = Greater"
  "raw_comparator_nat 0 (Suc n) = Less"
  "raw_comparator_nat (Suc m) (Suc n) = raw_comparator_nat m n"
  by (transfer; simp)+

definition comparator_nat :: "nat comparator"
  where [simp, code_abbrev]: "comparator_nat = default"

lemma compare_comparator_nat [code abstract]:
  "compare comparator_nat = raw_comparator_nat"
  by simp

definition comparator_linordered_group :: "'a::linordered_ab_group_add comparator"
  where [simp, code_abbrev]: "comparator_linordered_group = default"

lemma comparator_linordered_group [code abstract]:
  "compare comparator_linordered_group = (\<lambda>a b.
    let c = a - b in if c < 0 then Less
    else if c = 0 then Equiv else Greater)"
proof (rule ext)+
  fix a b :: 'a
  show "compare comparator_linordered_group a b =
    (let c = a - b in if c < 0 then Less
       else if c = 0 then Equiv else Greater)"
    by (simp add: Let_def not_less) (transfer; auto)
qed

(**********************)
(* The comparator type has a wide definition *)

(* *)
lemma comparator_aux: "comparator = comparator" ..
local_setup \<open>RLTHM @{binding comparator_rlt_neper_param} @{thm comparator_aux}\<close>
thm comparator_rlt_neper_param

thm comparator_def[no_vars]

lemma comparator_rlt_simp[simp]:
"neper R \<Longrightarrow>
 comparator_rlt R cmp \<longleftrightarrow>
  (\<forall>a. R a a \<longrightarrow> cmp a a = Equiv) \<and>
  (\<forall>a b c. R a a \<and> R b b \<and> R c c \<and> cmp a b = Equiv \<and> cmp b c = Equiv \<longrightarrow> cmp a c = Equiv) \<and>
  (\<forall>a b c. R a a \<and> R b b \<and> R c c \<and> cmp a b = Less \<and> cmp b c = Less \<longrightarrow> cmp a c = Less) \<and>
  (\<forall>b a. R b b \<and> R a a \<longrightarrow> (cmp b a = Greater) = (cmp a b = Less))"
unfolding comparator_rlt_def apply simp unfolding rrel_eq unfolding fun_eq_iff
by (smt (verit, best) Equiv_rlt_eq Greater_rlt_eq Less_rlt_eq)

(* *)

definition gg :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> comp) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> comp"
where "gg R \<equiv> \<lambda>cmp a b. cmp (getRepr' R a) (getRepr' R b)"

lemma getRepr'_refl: "neper R \<Longrightarrow> R (getRepr' R a) (getRepr' R a)"
unfolding getRepr'_def
using getRepr_neper neper_Some neper_classes_eq by fastforce

lemma getRepr': "neper R \<Longrightarrow> R a b \<Longrightarrow> R (getRepr' R a) (getRepr' R b)"
unfolding getRepr'_def by (smt (verit, best) geterRepr_related neper_per per_def)

lemma bij_upto_gg:
assumes R: "neper R"
shows
"bij_upto
 (restr (rel_fun R (rel_fun R (=))) comparator)
 (restr (rel_fun R (rel_fun R (=))) (comparator_rlt R)) (gg R)"
apply(rule bij_uptoI)
  subgoal apply(rule neper_restr)
    subgoal using R by simp
    subgoal apply(rule exI[of _ "\<lambda>a b. Equiv"], safe)
      subgoal using R by simp
      subgoal using R unfolding rel_fun_def by (simp add: neper_Some) . .
  subgoal for f f' unfolding restr_def apply safe
    subgoal using R unfolding rel_fun_def gg_def
    	by (smt (verit, best) getRepr'_def geterRepr_related neper_per per_def)
    subgoal using R unfolding comparator_def[of f]
    unfolding gg_def rel_fun_def
    by (smt (verit, best) comparator_rlt_simp)
    subgoal using R unfolding comparator_def[of f']
    unfolding gg_def rel_fun_def
    by (smt (verit, best) comparator_rlt_simp) .
  subgoal for f f' unfolding restr_def apply safe
    unfolding rel_fun_def gg_def
    by (smt (z3) R getRepr'_def getRepr_neper mem_Collect_eq neper_classes_eq neper_getRepr_eq)
  subgoal for g apply(rule exI[of _ "gg R g"], unfold restr_def, safe)
     subgoal using R unfolding comparator_def gg_def restr_def rel_fun_def
     by (smt (verit, best) getRepr'_def getRepr_neper neper_getRepr_eq neper_per per_def)
     subgoal using R unfolding comparator_def gg_def comparator_rlt_simp[OF R] rel_fun_def
     by (meson getRepr'_refl)+
     subgoal using R unfolding comparator_def gg_def comparator_rlt_simp[OF R] rel_fun_def
     by (meson getRepr'_refl)+
     subgoal using R unfolding rel_fun_def gg_def
     	 by (smt (verit, del_insts) getRepr'_def getReprOn getReprOn_UNIV neper_getRepr_eq
        neper_per per_def)
     subgoal using R unfolding gg_def comparator_rlt_simp[OF R]
     	 by (smt (z3) getRepr'_def getReprOn getReprOn_UNIV geterRepr_related neper_getRepr_eq) . .

definition rel_comparator where
"rel_comparator R = inv_imagep (rel_fun R (rel_fun R (=))) compare"

thm bij_upto_transportFromRaw[OF type_definition_comparator rel_comparator_def bij_upto_gg]

wide_typedef comparator rel: rel_comparator rep: "\<lambda>R. gg R \<circ> compare"
  subgoal for R unfolding rel_comparator_def
  apply(rule neper_inv_imagep[of _ _ "Abs_comparator (\<lambda>a b. Equiv)"])
     subgoal by simp
     subgoal unfolding rel_fun_def  by (metis flat.abs_eq flat.rep_eq) .
  subgoal unfolding rel_comparator_def unfolding inv_imagep_def fun_eq_iff
    by (simp add: compare_inject)
  subgoal using bij_upto_transportFromRaw[OF type_definition_comparator rel_comparator_def bij_upto_gg]
    unfolding comparator_rlt_def rrel_eq .
  subgoal unfolding gg_def fun_eq_iff getRepr'_def by auto .

end


section \<open>The Hadjicostas--Chapman formula\<close>
theory Hadjicostas_Chapman
  imports Zeta_Laurent_Expansion
begin

text \<open>
  In this section, we will derive a formula for the \<open>\<zeta>\<close> function that was conjectured by
  Hadjicostas~\<^cite>\<open>"hadjicostas2004"\<close> and proven shortly afterwards by Chapman~\<^cite>\<open>"chapman2004"\<close>.
  The formula is:
    \begin{align*}
    &\int_0^1 \int_0^1 \frac{(-\ln (xy))^z (1-x)}{1-xy}\ \text{d}x\,\text{d}y\\
      &\quad = \int_0^1 \frac{(-\ln u)^z(-\ln u + u - 1)}{1-u}\ \text{d}u\\
      &\quad = \Gamma(z + 2) \left(\zeta(z + 2) - \frac{1}{z+1}\right)
    \end{align*}
  for any \<open>z\<close> with $\mathfrak{R}(z) > -2$. In particular, setting $z = 1$, we can derive
  the following formula for the Euler--Mascheroni constant \<open>\<gamma>\<close>:
    \[-\int_0^1 \int_0^1 \frac{1-x}{(1-xy) \ln (xy)}\ \text{d}x\,\text{d}y = \gamma\]
  This formula was first proven by Sondow~\<^cite>\<open>"sondow2002"\<close>.
\<close>

subsection \<open>The real case\<close>

text \<open>
  We first define the integral for real \<open>z > -2\<close>. This is then a non-negative integral,
  so that we can ignore the issue of integrability and use the Lebesgue integral on the
  extended non-negative reals

  We first show the equivalence of the single-integral and the double-integral form.
\<close>

definition Hadjicostas_nn_integral :: "real \<Rightarrow> ennreal" where
  "Hadjicostas_nn_integral z =
     set_nn_integral lborel {0<..<1}
       (\<lambda>u. ennreal ((-ln u) powr z / (1 - u) * (-ln u + u - 1)))"

definition Hadjicostas_integral :: "complex \<Rightarrow> complex" where
  "Hadjicostas_integral z =
     (LBINT u=0..1. of_real (-ln u) powr z / of_real (1 - u) * of_real (-ln u + u - 1))"

lemma Hadjicostas_nn_integral_altdef:
  "Hadjicostas_nn_integral z =
     (\<integral>\<^sup>+(x,y)\<in>{0<..<1}\<times>{0<..<1}. ((-ln (x*y)) powr z * (1-x) / (1-x*y)) \<partial>lborel)"
proof -
  define f where "f \<equiv> (\<lambda>u. ((-ln u) powr z / (1 - u) * (-ln u + u - 1)))"
  let ?I = "Gamma (z + 2) * (Re (zeta (z + 2)) - 1 / (z + 1))"
  let ?f = "\<lambda>u. ((-ln u) powr z / (1 - u) * (-ln u + u - 1))"
  define D :: "(real \<times> real) set" where "D = {0<..<1} \<times> {0<..<1}"
  define D1 where "D1 = (SIGMA x:{0<..<1}. {0<..<(x::real)})"
  define D2 where "D2 = (SIGMA u:{0<..<1}. {u<..<(1::real)})"
  have [measurable]: "D1 \<in> sets (lborel \<Otimes>\<^sub>M lborel)"
  proof -
    have "D1 = {x\<in>space (lborel \<Otimes>\<^sub>M lborel). snd x > 0 \<and> fst x > snd x \<and> fst x < 1}"
      by (auto simp: D1_def space_pair_measure)
    also have "\<dots> \<in> sets (lborel \<Otimes>\<^sub>M lborel)"
      by measurable
    finally show ?thesis .
  qed
  have [measurable]: "D2 \<in> sets (lborel \<Otimes>\<^sub>M lborel)"
  proof -
    have "D2 = {x\<in>space (lborel \<Otimes>\<^sub>M lborel). fst x > 0 \<and> fst x < snd x \<and> snd x < 1}"
      by (auto simp: D2_def space_pair_measure)
    also have "\<dots> \<in> sets (lborel \<Otimes>\<^sub>M lborel)"
      by measurable
    finally show ?thesis .
  qed

  have "(\<integral>\<^sup>+(x,y)\<in>D. ((-ln (x*y)) powr z * (1-x) / (1-x*y)) \<partial>lborel) =
          (\<integral>\<^sup>+x\<in>{0<..<1}. (\<integral>\<^sup>+y\<in>{0<..<1}. ((-ln (x*y)) powr z / (1-x*y) * (1-x)) \<partial>lborel) \<partial>lborel)"
    unfolding lborel_prod [symmetric] case_prod_unfold D_def
    by (subst lborel.nn_integral_fst[symmetric])
       (auto intro!: nn_integral_cong simp: indicator_def)
  also have "\<dots> = (\<integral>\<^sup>+x\<in>{0<..<1}. (\<integral>\<^sup>+u\<in>{0<..<x}. ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel) \<partial>lborel)"
  proof (rule set_nn_integral_cong)
    fix x :: real assume x: "x \<in> space lborel \<inter> {0<..<1}"
    show "(\<integral>\<^sup>+y\<in>{0<..<1}. ((-ln (x*y)) powr z / (1-x*y) * (1-x)) \<partial>lborel) =
            (\<integral>\<^sup>+u\<in>{0<..<x}. ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel)" using x
      by (subst lborel_distr_mult'[of "1/x"])
         (auto simp: nn_integral_density nn_integral_distr indicator_def field_simps
               simp flip: ennreal_mult' intro!: nn_integral_cong)
  qed auto
  also have "\<dots> = (\<integral>\<^sup>+(x,u)\<in>D1. ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel)"
    unfolding lborel_prod [symmetric] case_prod_unfold D_def
    by (subst lborel.nn_integral_fst[symmetric], measurable)
       (auto intro!: nn_integral_cong simp: indicator_def D1_def)
  also have "\<dots> = (\<integral>\<^sup>+(x,u). indicator D2 (u,x) * ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel)"
    by (intro nn_integral_cong)  (auto simp: D1_def D2_def indicator_def split: if_splits)
  also have "\<dots> = (\<integral>\<^sup>+u\<in>{0<..<1}. (\<integral>\<^sup>+x\<in>{u<..<1}. ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel) \<partial>lborel)"
    unfolding case_prod_unfold lborel_prod [symmetric]
    by (subst lborel_pair.nn_integral_snd [symmetric], measurable)
       (auto intro!: nn_integral_cong simp: D2_def indicator_def)
  also have "\<dots> = (\<integral>\<^sup>+u\<in>{0<..<1}. ((-ln u) powr z / (1 - u) * (-ln u + u - 1)) \<partial>lborel)"
  proof (intro set_nn_integral_cong refl)
    fix u :: real assume u: "u \<in> space lborel \<inter> {0<..<1}"
    let ?F = "\<lambda>x. (- ln u) powr z / (1 - u) * (ln x - x)"
    have "(\<integral>\<^sup>+x\<in>{u<..<1}. ennreal ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel) =
            (\<integral>\<^sup>+x\<in>{u..1}. ennreal ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel)"
      by (rule nn_integral_cong_AE, rule AE_I[of _ _ "{u,1}"])
         (auto simp: emeasure_lborel_countable indicator_def)
    also have "\<dots> = ennreal (?F 1 - ?F u)"
      using u by (intro nn_integral_FTC_Icc) (auto intro!: derivative_eq_intros simp: divide_simps)
    also have "?F 1 - ?F u = (-ln u) powr z / (1 - u) * (-ln u + u - 1)"
      using u by (simp add: divide_simps) (simp add: algebra_simps)?
    finally show "(\<integral>\<^sup>+x\<in>{u<..<1}. ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel) = ennreal \<dots>" .
  qed
  also have "\<dots> = Hadjicostas_nn_integral z"
    by (simp add: Hadjicostas_nn_integral_def)
  finally show ?thesis by (simp add: D_def)
qed

text \<open>
  We now solve the single integral for real \<open>z > -1\<close>.
\<close>
lemma Hadjicostas_Chapman_aux:
  fixes z :: real
  assumes z: "z > -1"
  defines "f \<equiv> (\<lambda>u. ((-ln u) powr z / (1 - u) * (-ln u + u - 1)))"
  shows   "(f has_integral (Gamma (z + 2) * (Re (zeta (z + 2)) - 1 / (z + 1)))) {0<..<1}"
proof -
  let ?I = "Gamma (z + 2) * (Re (zeta (z + 2)) - 1 / (z + 1))"
  have nonneg: "1 \<le> x + exp (- x)" if "x \<ge> 0" for x :: real
  proof -
    have "x + (1 + (-x)) \<le> x + exp (-x)"
      by (intro add_left_mono exp_ge_add_one_self)
    thus ?thesis by simp
  qed

  have eq: "((\<lambda>t::real. exp (-t)) ` {0<..}) = {0<..<1}"
  proof safe
    fix x :: real assume x: "x \<in> {0<..<1}"
    hence "x = exp (-(-ln x))" and "-ln x \<in> {0<..}"
      by auto
    thus "x \<in> (\<lambda>t. exp (-t)) ` {0<..}" by blast
  qed auto

  have I: "((\<lambda>x. x powr (z+1) / (exp x - 1) - x powr z / exp x) has_integral ?I) {0<..}"
  proof -
    from z have "z + 1 \<notin> \<real>\<^sub>\<le>\<^sub>0"
      by (auto simp: nonpos_Reals_def)
    hence z': "z + 1 \<notin> \<int>\<^sub>\<le>\<^sub>0"
      using nonpos_Ints_subset_nonpos_Reals by blast
    have "((\<lambda>x. x powr (z + 2 - 1) / (exp x - 1) - x powr (z + 1 - 1) / exp x)
            has_integral (Gamma (z + 2) * Re (zeta (z + 2)) - Gamma (z + 1))) {0<..}" using z
      by (intro has_integral_diff Gamma_integral_real' Gamma_times_zeta_has_integral_real) auto
    also have "Gamma (z + 2) * Re (zeta (z + 2)) - Gamma (z + 1) =
                 Gamma (z + 2) * (Re (zeta (z + 2)) - 1 / (z + 1))"
      using Gamma_plus1[of "z+1"] z z' by (auto simp: field_simps)
    finally show ?thesis
      by (simp add: add_ac)
  qed
  also have "?this \<longleftrightarrow> ((\<lambda>x. \<bar>-exp (-x)\<bar> * f (exp (-x))) has_integral ?I) {0<..}"
    unfolding f_def
    apply (intro has_integral_cong)
    apply (auto simp: field_simps powr_add powr_def exp_add)
    apply (simp flip: exp_add)
    done
  finally have *: "((\<lambda>x. \<bar>-exp (-x)\<bar> * f (exp (-x))) has_integral ?I) {0<..}" .

  have "((\<lambda>x. \<bar>-exp (-x)\<bar> *\<^sub>R f (exp (-x))) absolutely_integrable_on {0<..}) \<and>
                  integral {0<..} (\<lambda>x. \<bar>-exp (-x)\<bar> *\<^sub>R f (exp (-x))) = ?I"
  proof (intro conjI nonnegative_absolutely_integrable_1)
    fix x :: real assume x: "x \<in> {0<..}"
    thus "\<bar>-exp (-x)\<bar> *\<^sub>R f (exp (-x)) \<ge> 0"
      unfolding f_def using nonneg
      by (intro scaleR_nonneg_nonneg mult_nonneg_nonneg divide_nonneg_nonneg) auto
  qed (use * in \<open>simp_all add: has_integral_iff\<close>)

  also have "?this \<longleftrightarrow> f absolutely_integrable_on (\<lambda>x. exp (- x)) ` {0<..} \<and>
                       integral ((\<lambda>x. exp (- x)) ` {0<..}) f = ?I"
    by (intro has_absolute_integral_change_of_variables_1')
       (auto intro!: derivative_eq_intros inj_onI)
  also have "(\<lambda>x::real. exp (- x)) ` {0<..} = {0<..<1}"
    by (fact eq)
  finally show "(f has_integral ?I) {0<..<1}"
    by (auto simp: has_integral_iff dest: set_lebesgue_integral_eq_integral)
qed

lemma real_zeta_ge_one_over_minus_one:
  fixes z :: real
  assumes z: "z > 1"
  shows "Re (zeta (complex_of_real z)) \<ge> 1 / (z - 1)"
proof -
  have ineq: "1 \<le> x - ln x" if "x \<in> {0<..<1}" for x :: real
    using ln_le_minus_one[of x] that by simp
  have *: "((\<lambda>u. (- ln u) powr (z - 2) * (u - ln u - 1) / (1 - u)) has_integral
           Gamma z * (Re (zeta (complex_of_real z)) - 1 / (z - 1))) {0<..<1}"
    using Hadjicostas_Chapman_aux[of "z - 2"] z by simp
  from ineq have "Gamma z * (Re (zeta (complex_of_real z)) - 1 / (z - 1)) \<ge> 0"
    by (intro has_integral_nonneg[OF *] z mult_nonneg_nonneg divide_nonneg_nonneg) auto
  moreover have "Gamma z > 0"
    using assms by (intro Gamma_real_pos) auto
  ultimately show "Re (zeta (complex_of_real z)) \<ge> 1 / (z - 1)"
    by (subst (asm) zero_le_mult_iff) auto
qed

text \<open>
  We now have the formula for real \<open>z > -1\<close>.
\<close>
lemma Hadjicostas_Chapman_formula_real:
  fixes z :: real
  assumes z: "z > -1"
  shows   "Hadjicostas_nn_integral z =
             ennreal (Gamma (z + 2) * (Re (zeta (z + 2)) - 1 / (z + 1)))"
proof -
  have nonneg: "1 \<le> x - ln x" if "x > 0" "x < 1" for x :: real
  proof -
    have "ln x + (1 + ln x) \<le> ln x + exp (ln x)"
      by (intro add_left_mono exp_ge_add_one_self)
    thus ?thesis using that by (simp add: exp_minus)
  qed
  show ?thesis
    unfolding Hadjicostas_nn_integral_def using nonneg Hadjicostas_Chapman_aux[OF z]
    by (intro nn_integral_has_integral_lebesgue' mult_nonneg_nonneg divide_nonneg_nonneg) auto
qed

subsection \<open>Analyticity of the integral\<close>

text \<open>
  To extend the formula to its full domain of validity (any complex \<open>z\<close> with
  $\mathfrak{R}(z)>-2$), we will use analytic continuation. To do this, we first
  have to show that the integral is an analytic function of \<open>z\<close> on that domain.
  This is unfortunately somewhat involved, since the integral is an improper one
  and we first need to show uniform convergence so that we can pull the derivative
  inside the integral sign.

  We will use the single-integral form so that we only have to deal with one integral
  and not two.
\<close>

context
  fixes f :: "complex \<Rightarrow> real \<Rightarrow> complex"
  defines "f \<equiv> (\<lambda>z u. of_real (-ln u) powr z / of_real (1 - u) * of_real (-ln u + u - 1))"
begin

context
  fixes x y :: real and g1 g2 :: "real \<Rightarrow> real"
  assumes "x > -2"
  defines "g1 \<equiv> (\<lambda>x. (- ln x) powr y * (x - ln x - 1) / (1 - x))"
  defines "g2 \<equiv> (\<lambda>u. (-ln u) powr x * (u - ln u - 1) / (1 - u))"
begin

lemma integrable_bound1:
  "interval_lebesgue_integrable lborel 0 (ereal (exp (- 1))) g1"
  unfolding zero_ereal_def
proof (rule interval_lebesgue_integrable_bigo_left)
  show "g1 \<in> O[at_right 0](\<lambda>u. u powr (-1/2))"
    unfolding g1_def by real_asymp
  show "continuous_on {0<..exp(-1)} g1"
    unfolding g1_def by (auto intro!: continuous_intros)
  have "set_integrable lborel (einterval 0 (exp (-1))) (\<lambda>u. u powr (-1/2))"
  proof (rule interval_integral_FTC_nonneg)
    fix u :: real assume u: "0 < ereal u" "ereal u < ereal (exp (-1))"
    show "((\<lambda>u. 2 * u powr (1/2)) has_field_derivative (u powr (-1/2))) (at u)"
      using u by (auto intro!: derivative_eq_intros simp: power2_eq_square)
    show "isCont (\<lambda>u. u powr (-1/2)) u"
      using u by (auto intro!: continuous_intros)
  next
    show "(((\<lambda>u. 2 * u powr (1/2)) \<circ> real_of_ereal) \<longlongrightarrow> 2 * exp (-1) powr (1/2))
            (at_left (ereal (exp (- 1))))"
      unfolding ereal_tendsto_simps by real_asymp
    show "(((\<lambda>u. 2 * u powr (1/2)) \<circ> real_of_ereal) \<longlongrightarrow> 0) (at_right 0)"
      unfolding zero_ereal_def unfolding ereal_tendsto_simps by real_asymp
  qed auto
  thus "interval_lebesgue_integrable lborel (ereal 0) (ereal (exp (- 1)))
          (\<lambda>u. u powr (-1/2))"
    by (simp add: interval_lebesgue_integrable_def zero_ereal_def)
qed (auto simp add: g1_def set_borel_measurable_def)

lemma integrable_bound2:
  "interval_lebesgue_integrable lborel (exp (-1)) 1 g2"
      unfolding one_ereal_def
proof (rule interval_lebesgue_integrable_bigo_right)
  show "g2 \<in> O[at_left 1](\<lambda>u. (1 - u) powr (x + 1))"
    unfolding g2_def by real_asymp
  have "ln x \<noteq> 0" if "x \<in> {exp (-1)..<1}" for x :: real
  proof -
    have "0 < exp (-1 :: real)" by simp
    also have "\<dots> \<le> x" using that by auto
    finally have "x > 0" .
    from that \<open>x > 0\<close> have "ln x < ln 1"
      by (subst ln_less_cancel_iff) auto
    thus "ln x \<noteq> 0" by simp
  qed
  thus "continuous_on {exp (- 1)..<1} g2"
    unfolding g2_def by (auto intro!: continuous_intros)
  let ?F = "(\<lambda>u. -1 / (x + 2) * (1 - u) powr (x + 2))"
  have "set_integrable lborel (einterval (exp (-1)) 1) (\<lambda>u. (1 - u) powr (x + 1))"
  proof (rule interval_integral_FTC_nonneg[where F = ?F])
    fix u :: real assume u: "ereal (exp (-1)) < ereal u" "ereal u < 1"
    show "(?F has_field_derivative (1 - u) powr (x + 1)) (at u)"
      using u \<open>x > -2\<close> by (auto intro!: derivative_eq_intros simp: one_ereal_def add_ac)
    show "isCont (\<lambda>u. (1 - u) powr (x + 1)) u"
      using u by (auto intro!: continuous_intros)
  next
    show "(((\<lambda>u. - 1 / (x + 2) * (1 - u) powr (x + 2)) \<circ> real_of_ereal) \<longlongrightarrow>
            - 1 / (x + 2) * (1 - exp (-1)) powr (x + 2)) (at_right (ereal (exp (- 1))))"
      unfolding ereal_tendsto_simps by real_asymp
    show "(((\<lambda>u. - 1 / (x + 2) * (1 - u) powr (x + 2)) \<circ> real_of_ereal) \<longlongrightarrow> 0) (at_left 1)"
      unfolding one_ereal_def unfolding ereal_tendsto_simps
      using \<open>x > -2\<close> by real_asymp
  qed auto
  thus "interval_lebesgue_integrable lborel (ereal (exp (- 1)))
          (ereal 1) (\<lambda>u. (1 - u) powr (x + 1))"
    by (simp add: interval_lebesgue_integrable_def one_ereal_def)
qed (auto simp add: g2_def set_borel_measurable_def)

lemma bound2:
  "norm (f z u) \<le> g2 u" if z: "Re z \<in> {x..y}" and u: "u \<in> {exp (-1)<..<1}" for z u
proof -
  have "0 < exp (-1::real)" by simp
  also have "\<dots> \<le> u" using u by (simp add: einterval_def)
  finally have "u > 0" .

  from u \<open>u > 0\<close> have ln_u: "ln u > ln (exp (-1))"
    by (subst ln_less_cancel_iff) (auto simp: einterval_def)
  from z u \<open>u > 0\<close> have "norm (f z u) = (- ln u) powr Re z * \<bar>u - ln u - 1\<bar> / (1 - u)"
    unfolding f_def norm_mult norm_divide norm_of_real
    by (simp add: norm_powr_real_powr einterval_def)
  also have "\<bar>u - ln u - 1\<bar> = u - ln u - 1"
    using u \<open>u > 0\<close> ln_add_one_self_le_self2[of "u - 1"] by (simp add: einterval_def)
  also have "(- ln u) powr Re z * (u - ln u - 1) / (1 - u) \<le>
               (- ln u) powr x * (u - ln u - 1) / (1 - u)"
    using z u \<open>u > 0\<close> ln_u ln_add_one_self_le_self2[of "u - 1"]
    by (intro mult_right_mono divide_right_mono powr_mono') (auto simp: einterval_def)
  finally show "norm (f z u) \<le> g2 u" by (simp add: g2_def)
qed

lemma integrable2_aux: "interval_lebesgue_integrable lborel (exp (-1)) 1 (f z)"
    if z: "Re z \<in> {x..y}" for z
proof -
  have "set_integrable lborel {exp (-1)<..<1} (f z)"
  proof (rule set_integrable_bound[OF _ _ AE_I2[OF impI]])
    fix u :: real assume "u \<in> {exp (-1)<..<1}"
    hence "norm (f z u) \<le> g2 u" using z by (intro bound2) auto
    also have "\<dots> \<le> norm (g2 u)" by simp
    finally show "norm (f z u) \<le> norm (g2 u)" .
  qed (use integrable_bound2 in \<open>simp_all add: interval_lebesgue_integrable_def
         one_ereal_def set_borel_measurable_def f_def\<close>)
  thus ?thesis by (simp add: interval_lebesgue_integrable_def one_ereal_def)
qed

lemma uniform_limit2:
  "uniform_limit {z. Re z \<in> {x..y}}
        (\<lambda>a z. LBINT u=exp (-1)..a. f z u)
        (\<lambda>z. LBINT u=exp (-1)..1. f z u) (at_left 1)"
  by (intro uniform_limit_interval_integral_right[of _ _ g2] AE_I2 impI)
     (use bound2 integrable_bound2 in \<open>simp_all add: einterval_def f_def set_borel_measurable_def\<close>)

lemma uniform_limit2':
    "uniform_limit {z. Re z \<in> {x..y}}
          (\<lambda>n z. LBINT u=exp (-1)..ereal (1-(1/2)^Suc n). f z u)
          (\<lambda>z. LBINT u=exp (-1)..1. f z u) sequentially"
proof (rule filterlim_compose[OF uniform_limit2])
  have "filterlim (\<lambda>n. 1 - (1/2)^Suc n :: real) (at_left 1) sequentially"
    by real_asymp
  hence "filtermap ereal (filtermap (\<lambda>n. (1 - (1 / 2) ^ Suc n)) sequentially) \<le>
        filtermap ereal (at_left 1)"
    unfolding filterlim_def by (rule filtermap_mono)
  thus "filterlim (\<lambda>n. ereal (1 - (1/2)^Suc n)) (at_left 1) sequentially"
    unfolding one_ereal_def at_left_ereal by (simp add: filterlim_def filtermap_filtermap)
qed

lemma bound1: "norm (f z u) \<le> g1 u" if z: "Re z \<in> {x..y}" and u: "u \<in> {0<..<exp (-1)}" for z u
proof -
  from u have "u \<le> exp (-1)" by (simp add: einterval_def)
  also have "exp (-1) < exp (0::real)"
    by (subst exp_less_cancel_iff) auto
  also have "exp (0::real) = 1" by simp
  finally have "u < 1" .
  from u have "ln u < ln (exp (-1))"
    by (subst ln_less_cancel_iff) (auto simp: einterval_def)
  hence ln_u: "ln u < -1" by simp
  from z u \<open>u < 1\<close> have "norm (f z u) = (- ln u) powr Re z * \<bar>u - ln u - 1\<bar> / (1 - u)"
    unfolding f_def norm_mult norm_divide norm_of_real
    by (simp add: norm_powr_real_powr einterval_def)
  also have "\<bar>u - ln u - 1\<bar> = u - ln u - 1"
    using u ln_add_one_self_le_self2[of "u - 1"] by (simp add: einterval_def)
  also have "(- ln u) powr Re z * (u - ln u - 1) / (1 - u) \<le>
               (- ln u) powr y * (u - ln u - 1) / (1 - u)"
    using z u ln_u \<open>u < 1\<close>
    by (intro mult_right_mono divide_right_mono powr_mono) (auto simp: einterval_def)
  finally show "norm (f z u) \<le> g1 u" by (simp add: g1_def)
qed

lemma integrable1_aux: "interval_lebesgue_integrable lborel 0 (exp (-1)) (f z)"
  if z: "Re z \<in> {x..y}" for z
proof -
  have "set_integrable lborel {0<..<exp (-1)} (f z)"
  proof (rule set_integrable_bound[OF _ _ AE_I2[OF impI]])
    fix u :: real assume "u \<in> {0<..<exp (-1)}"
    hence "norm (f z u) \<le> g1 u" using z by (intro bound1) auto
    also have "\<dots> \<le> norm (g1 u)" by simp
    finally show "norm (f z u) \<le> norm (g1 u)" .
  qed (use integrable_bound1 in \<open>simp_all add: interval_lebesgue_integrable_def
         zero_ereal_def set_borel_measurable_def f_def\<close>)
  thus ?thesis by (simp add: interval_lebesgue_integrable_def zero_ereal_def)
qed

lemma uniform_limit1:
  "uniform_limit {z. Re z \<in> {x..y}}
        (\<lambda>a z. LBINT u=a..exp (-1). f z u)
        (\<lambda>z. LBINT u=0..exp (-1). f z u) (at_right 0)"
  by (intro uniform_limit_interval_integral_left[of _ _ g1] AE_I2 impI)
     (use bound1 integrable_bound1 in \<open>simp_all add: einterval_def f_def set_borel_measurable_def\<close>)

lemma uniform_limit1':
    "uniform_limit {z. Re z \<in> {x..y}}
          (\<lambda>n z. LBINT u=ereal ((1/2)^Suc n)..exp (-1). f z u)
          (\<lambda>z. LBINT u=0..exp (-1). f z u) sequentially"
proof (rule filterlim_compose[OF uniform_limit1])
  have "filterlim (\<lambda>n. (1/2)^Suc n :: real) (at_right 0) sequentially"
    by real_asymp
  hence "filtermap ereal (filtermap (\<lambda>n. ((1 / 2) ^ Suc n)) sequentially) \<le>
        filtermap ereal (at_right 0)"
    unfolding filterlim_def by (rule filtermap_mono)
  thus "filterlim (\<lambda>n. ereal ((1/2)^Suc n)) (at_right 0) sequentially"
    unfolding zero_ereal_def at_right_ereal by (simp add: filterlim_def filtermap_filtermap)
qed

end

text \<open>
  With all of the above bounds, we have shown that the integral exists for any
  \<open>z\<close> with $\mathfrak{R}(z) > -2$.
\<close>
theorem Hadjicostas_integral_integrable: "interval_lebesgue_integrable lborel 0 1 (f z)"
  if z: "Re z > -2"
proof -
  from dense[OF z] obtain x where x: "x > -2" "Re z > x" by blast
  have "interval_lebesgue_integrable lborel 0 (exp(-1)) (f z)"
    by (rule integrable1_aux[of x _ "Re z + 1"]) (use x in auto)
  moreover have "interval_lebesgue_integrable lborel (exp(-1)) 1 (f z)"
    by (rule integrable2_aux[of x _ "Re z + 1"]) (use x in auto)
  ultimately show "interval_lebesgue_integrable lborel 0 1 (f z)"
    by (rule interval_lebesgue_integrable_combine) (auto simp: f_def set_borel_measurable_def)
qed

lemma integral_holo_aux:
  assumes ab: "a > 0" "a \<le> b" "b < 1"
  shows "(\<lambda>z. LBINT u=ereal a..ereal b. f z u) holomorphic_on A"
proof -
  define f' :: "complex \<Rightarrow> real \<Rightarrow> complex"
    where "f' \<equiv> (\<lambda>z u. ln (-ln u) * f z u)"
  note [derivative_intros] = has_field_derivative_complex_powr_right'

  have "(\<lambda>z. integral (cbox a b) (f z)) holomorphic_on UNIV"
  proof (rule leibniz_rule_holomorphic[of _ _ _ _ f'], goal_cases)
    case (1 z t)
    show ?case unfolding f_def
      apply (insert 1 ab)
      apply (rule derivative_eq_intros refl | simp)+
      apply (auto simp: f'_def field_simps f_def Ln_of_real)
      done
  next
    from ab show "continuous_on (UNIV \<times> cbox a b) (\<lambda>(z, t). f' z t)"
      by (auto simp: case_prod_unfold f'_def f_def Ln_of_real intro!: continuous_intros)
  next
    fix z :: complex
    show "f z integrable_on cbox a b"
      unfolding f_def f'_def using ab
      by (intro integrable_continuous continuous_intros) auto
  qed (auto simp: convex_halfspace_Re_gt)
  also have "(\<lambda>z. integral (cbox a b) (f z)) = (\<lambda>z. \<integral>u\<in>cbox a b. f z u \<partial>lborel)"
  proof (intro ext set_borel_integral_eq_integral(2) [symmetric])
    fix z :: complex
    show "complex_set_integrable lborel (cbox a b) (f z)"
      unfolding f_def using ab
      by (intro continuous_on_imp_set_integrable_cbox continuous_intros) (auto simp: Ln_of_real)
  qed
  also have "\<dots> = (\<lambda>z. LBINT u=a..b. f z u)"
    using ab by (simp add: interval_integral_Icc)
  finally show ?thesis by (rule holomorphic_on_subset) auto
qed

lemma integral_holo:
  assumes ab: "min a b > 0" "max a b < 1"
  shows "(\<lambda>z. LBINT u=ereal a..ereal b. f z u) holomorphic_on A"
proof (cases "a \<le> b")
  case True
  thus ?thesis using assms integral_holo_aux[of a b] by auto
next
  case False
  have "(\<lambda>z. -(LBINT u=ereal b..ereal a. f z u)) holomorphic_on A"
    using False assms by (intro holomorphic_intros integral_holo_aux) auto
  thus ?thesis by (subst interval_integral_endpoints_reverse)
qed

lemma holo1: "(\<lambda>z. LBINT u=0..exp (-1). f z u) holomorphic_on {z. Re z > -2}"
proof (rule holomorphic_uniform_sequence
    [where f = "(\<lambda>n z. LBINT u=ereal ((1/2)^Suc n)..exp (-1). f z u)"], goal_cases)
  case (3 z)
  define \<epsilon> where "\<epsilon> = (Re z + 2) / 2"
  from 3 have "\<epsilon> > 0" by (auto simp: \<epsilon>_def)
  have subset: "cball z \<epsilon> \<subseteq> {s. Re s \<in> {Re z - \<epsilon>..Re z + \<epsilon>}}"
  proof safe
    fix s assume s: "s \<in> cball z \<epsilon>"
    have "\<bar>Re (s - z)\<bar> \<le> norm (s - z)" by (rule abs_Re_le_cmod)
    also have "\<dots> \<le> \<epsilon>" using s by (simp add: dist_norm norm_minus_commute)
    finally show "Re s \<in> {Re z - \<epsilon>..Re z + \<epsilon>}" by auto
  qed

  show ?case
  proof (rule exI[of _ \<epsilon>], intro conjI)
    have "cball z \<epsilon> \<subseteq> {s. Re s \<in> {Re z - \<epsilon>..Re z + \<epsilon>}}" by fact
    also have "\<dots> \<subseteq> {s. Re s > -2}"
      using 3 by (auto simp: \<epsilon>_def field_simps)
    finally show "cball z \<epsilon> \<subseteq> {s. Re s > -2}" .
  next
    from 3 have "Re z - \<epsilon> > -2" by (simp add: \<epsilon>_def field_simps)
    thus "uniform_limit (cball z \<epsilon>) (\<lambda>n z. LBINT u=ereal ((1 / 2) ^ Suc n)..ereal (exp (- 1)). f z u)
            (\<lambda>z. LBINT u=0..ereal (exp(-1)). f z u) sequentially"
      using uniform_limit_on_subset[OF uniform_limit1' subset] by simp
  qed fact+
next
  fix n :: nat
  have "(1 / 2) ^ Suc n < (1 / 2 :: real) ^ 0"
    by (subst power_strict_decreasing_iff) auto
  thus "(\<lambda>z. LBINT u=ereal ((1 / 2) ^ Suc n)..ereal (exp (- 1)). f z u) holomorphic_on {z. Re z > -2}"
    by (intro integral_holo) auto
qed (auto simp: open_halfspace_Re_gt)

lemma holo2: "(\<lambda>z. LBINT u=exp (-1)..1. f z u) holomorphic_on {z. Re z > -2}"
proof (rule holomorphic_uniform_sequence
    [where f = "(\<lambda>n z. LBINT u=exp (-1)..ereal (1-(1/2)^Suc n). f z u)"], goal_cases)
  case (3 z)
  define \<epsilon> where "\<epsilon> = (Re z + 2) / 2"
  from 3 have "\<epsilon> > 0" by (auto simp: \<epsilon>_def)
  have subset: "cball z \<epsilon> \<subseteq> {s. Re s \<in> {Re z - \<epsilon>..Re z + \<epsilon>}}"
  proof safe
    fix s assume s: "s \<in> cball z \<epsilon>"
    have "\<bar>Re (s - z)\<bar> \<le> norm (s - z)" by (rule abs_Re_le_cmod)
    also have "\<dots> \<le> \<epsilon>" using s by (simp add: dist_norm norm_minus_commute)
    finally show "Re s \<in> {Re z - \<epsilon>..Re z + \<epsilon>}" by auto
  qed

  show ?case
  proof (rule exI[of _ \<epsilon>], intro conjI)
    have "cball z \<epsilon> \<subseteq> {s. Re s \<in> {Re z - \<epsilon>..Re z + \<epsilon>}}" by fact
    also have "\<dots> \<subseteq> {s. Re s > -2}"
      using 3 by (auto simp: \<epsilon>_def field_simps)
    finally show "cball z \<epsilon> \<subseteq> {s. Re s > -2}" .
  next
    from 3 have "Re z - \<epsilon> > -2" by (simp add: \<epsilon>_def field_simps)
    thus "uniform_limit (cball z \<epsilon>) (\<lambda>n z. LBINT u=ereal (exp (- 1))..ereal (1-(1/2)^Suc n). f z u)
            (\<lambda>z. LBINT u=ereal (exp(-1))..1. f z u) sequentially"
      using uniform_limit_on_subset[OF uniform_limit2' subset] by simp
  qed fact+
next
  fix n :: nat
  have "(1 / 2) ^ Suc n < (1 / 2 :: real) ^ 0"
    by (subst power_strict_decreasing_iff) auto
  thus "(\<lambda>z. LBINT u=ereal (exp (-1))..ereal (1-(1/2)^Suc n). f z u) holomorphic_on {z. Re z > -2}"
    by (intro integral_holo) auto
qed (auto simp: open_halfspace_Re_gt)

text \<open>
  Finally, we have shown that Hadjicostas's integral is an analytic function
  of \<open>z\<close> in the domain $\mathfrak{R}(z) > -2$.
\<close>
lemma holomorphic_Hadjicostas_integral:
  "Hadjicostas_integral holomorphic_on {z. Re z > -2}"
proof -
  have "(\<lambda>z. (LBINT u=0..exp(-1). f z u) + (LBINT u=exp(-1)..1. f z u))
          holomorphic_on {z. Re z > -2}"
    by (intro holomorphic_intros holo1 holo2)
  also have "?this \<longleftrightarrow> (\<lambda>z. LBINT u=0..1. f z u) holomorphic_on {z. Re z > -2}"
    using Hadjicostas_integral_integrable
    by (intro holomorphic_cong interval_integral_sum)
       (simp_all add: zero_ereal_def one_ereal_def min_def max_def)
  also have "(\<lambda>z. LBINT u=0..1. f z u) = Hadjicostas_integral"
    by (simp add: Hadjicostas_integral_def[abs_def] f_def)
  finally show ?thesis .
qed

lemma analytic_Hadjicostas_integral:
  "Hadjicostas_integral analytic_on {z. Re z > -2}"
  by (simp add: analytic_on_open open_halfspace_Re_gt holomorphic_Hadjicostas_integral)

end

subsection \<open>Analytic continuation and main result\<close>

text \<open>
  Since we have already shown the formula for any real \<open>z > -1\<close> and e.\,g.\ 0 is a limit
  point of that set, it extends to the full domain by analytic continuation.

  As a caveat, note that $\zeta(s)$ is \<^emph>\<open>not\<close> analytic at \<open>z = 1\<close>, so that we use
  an analytic continuation of $\zeta(z) - \frac{1}{z-1}$ to state the formula. This
  continuation is @{term "pre_zeta 1"}.
\<close>
lemma Hadjicostas_Chapman_formula_aux:
  assumes z: "Re z > -2"
  shows   "Hadjicostas_integral z = Gamma (z + 2) * pre_zeta 1 (z + 2)"
    (is "_ z = ?f z")
proof (rule analytic_continuation'[of Hadjicostas_integral])
  show "Hadjicostas_integral holomorphic_on {z. Re z > -2}"
    by (rule holomorphic_Hadjicostas_integral)
  show "connected {z. Re z > -2}"
    by (intro convex_connected convex_halfspace_Re_gt)
  show "open {z. Re z > -2}"
    by (auto simp: open_halfspace_Re_gt)
  show "{z. Re z > -1 \<and> Im z = 0} \<subseteq> {z. Re z > -2}" and "0 \<in> {z. Re z > -2}"
    by auto
  have "\<forall>n. 1 / (of_nat (Suc n)) \<in> {z. Re z > -1 \<and> Im z = 0} - {0}"
    by (auto simp: field_simps simp flip: of_nat_Suc)
  moreover have "(\<lambda>n. 1 / of_nat (Suc n) :: complex) \<longlonglongrightarrow> 0"
    by (rule tendsto_divide_0[OF tendsto_const] filterlim_compose[OF tendsto_of_nat] filterlim_Suc)+
  ultimately show "0 islimpt {z. Re z > -1 \<and> Im z = 0}"
    unfolding islimpt_sequential
    by (intro exI[of _ "\<lambda>n. 1 / of_nat (Suc n) :: complex"]) simp
  show "?f holomorphic_on {z. - 2 < Re z}"
  proof (intro holomorphic_intros)
    fix z assume z: "z \<in> {z. Re z > -2}"
    hence "z + 2 \<notin> \<real>\<^sub>\<le>\<^sub>0" by (auto elim!: nonpos_Reals_cases simp: complex_eq_iff)
    thus "z + 2 \<notin> \<int>\<^sub>\<le>\<^sub>0" using nonpos_Ints_subset_nonpos_Reals by blast
  qed auto
next
  fix s assume s: "s \<in> {z. - 1 < Re z \<and> Im z = 0}"
  hence "s + 2 \<noteq> 1" by (simp add: algebra_simps complex_eq_iff)
  have ineq: "x - ln x \<ge> 1" if "x \<in> {0<..<1}" for x :: real
    using ln_le_minus_one[of x] that by (simp add: algebra_simps)
  define x where "x = Re s"
  from s have x: "x > -1" and [simp]: "s = of_real x"
    by (auto simp: x_def complex_eq_iff)
  have "Hadjicostas_integral s = (LBINT u=0..1. of_real ((-ln u) powr x / (1-u) * (-ln u + u - 1)))"
    unfolding Hadjicostas_integral_def
    by (intro interval_lebesgue_integral_cong) (auto simp: einterval_def powr_Reals_eq)
  also have "\<dots> = of_real (LBINT u=0..1. (-ln u) powr x / (1-u) * (-ln u + u - 1))"
    by (subst interval_lebesgue_integral_of_real) auto
  also have "(LBINT u=0..1. (- ln u) powr x / (1 - u) * (- ln u + u - 1)) =
             (\<integral>u. (- ln u) powr x / (1-u) * (- ln u + u - 1) * indicator {0<..<1} u \<partial>lborel)"
    by (simp add: interval_integral_Ioo zero_ereal_def one_ereal_def set_lebesgue_integral_def mult_ac)
  also have "\<dots> = enn2real (Hadjicostas_nn_integral x)"
    unfolding Hadjicostas_nn_integral_def using ineq
    by (subst integral_eq_nn_integral)
       (auto intro!: AE_I2 divide_nonneg_nonneg mult_nonneg_nonneg arg_cong[where f = enn2real]
               nn_integral_cong simp: indicator_def)
  also have "\<dots> = enn2real (ennreal (Gamma (x + 2) * (Re (zeta (x + 2)) - 1 / (x + 1))))"
    using x by (subst Hadjicostas_Chapman_formula_real) auto
  also have "\<dots> = Gamma (x + 2) * (Re (zeta (x + 2)) - 1 / (x + 1))"
    using x real_zeta_ge_one_over_minus_one[of "x + 2"]
    by (intro enn2real_ennreal mult_nonneg_nonneg Gamma_real_nonneg) (auto simp: add_ac)
  also have "complex_of_real \<dots> = Gamma (s + 2) * (zeta (s + 2) -  1 / (s + 1))"
    using x Gamma_complex_of_real[of "x + 2"] by (simp add: zeta_real')
  also have "(zeta (s + 2) -  1 / (s + 1)) = pre_zeta 1 (s + 2)"
    using \<open>s + 2 \<noteq> 1\<close> by (subst zeta_minus_pole_eq [symmetric]) (auto simp flip: of_nat_Suc)
  finally show "Hadjicostas_integral s = Gamma (s + 2) * pre_zeta 1 (s + 2)" .
qed (use assms in auto)

text \<open>
  The following form and the corollary are perhaps a bit nicer to read.
\<close>
theorem Hadjicostas_Chapman_formula:
  assumes z: "Re z > -2" "z \<noteq> -1"
  shows   "Hadjicostas_integral z = Gamma (z + 2) * (zeta (z + 2) - 1 / (z + 1))"
proof -
  from z have "z + 1 \<noteq> 0"
    by (auto simp: complex_eq_iff)
  thus ?thesis using Hadjicostas_Chapman_formula_aux[of z] assms
    by (subst (asm) zeta_minus_pole_eq [symmetric]) (auto simp: add_ac)
qed

corollary euler_mascheroni_integral_form:
  "Hadjicostas_integral (-1) = euler_mascheroni"
  using Hadjicostas_Chapman_formula_aux[of "-1"] by simp

end


(*  Title:      HOL/SMT_Examples/SMT_Word_Examples.thy
    Author:     Sascha Boehme, TU Muenchen
*)

section \<open>Word examples for for SMT binding\<close>

theory SMT_Word_Examples
imports "HOL-Library.Word"
begin

declare [[smt_oracle = true]]
declare [[z3_extensions = true]]
declare [[smt_certificates = "SMT_Word_Examples.certs"]]
declare [[smt_read_only_certificates = true]]

text \<open>
Currently, there is no proof reconstruction for words.
All lemmas are proved using the oracle mechanism.
\<close>

section \<open>Bitvector numbers\<close>

lemma "(27 :: 4 word) = -5" by smt
lemma "(27 :: 4 word) = 11" by smt
lemma "23 < (27::8 word)" by smt
lemma "27 + 11 = (6::5 word)" by smt
lemma "7 * 3 = (21::8 word)" by smt
lemma "11 - 27 = (-16::8 word)" by smt
lemma "- (- 11) = (11::5 word)" by smt
lemma "-40 + 1 = (-39::7 word)" by smt
lemma "a + 2 * b + c - b = (b + c) + (a :: 32 word)" by smt
lemma "x = (5 :: 4 word) \<Longrightarrow> 4 * x = 4" by smt

section \<open>Bit-level logic\<close>

lemma "0b110 AND 0b101 = (0b100 :: 32 word)" by smt
lemma "0b110 OR 0b011 = (0b111 :: 8 word)" by smt
lemma "0xF0 XOR 0xFF = (0x0F :: 8 word)" by smt
lemma "NOT (0xF0 :: 16 word) = 0xFF0F" by smt
lemma "word_cat (27::4 word) (27::8 word) = (2843::12 word)" by smt
lemma "word_cat (0b0011::4 word) (0b1111::6word) = (0b0011001111 :: 10 word)" by smt
lemma "slice 1 (0b10110 :: 4 word) = (0b11 :: 2 word)" by smt
lemma "ucast (0b1010 :: 4 word) = (0b1010 :: 10 word)" by smt
lemma "scast (0b1010 :: 4 word) = (0b111010 :: 6 word)" by smt
lemma "push_bit 2 0b10011 = (0b1001100::8 word)" by smt
lemma "drop_bit 2 0b11001 = (0b110::8 word)" by smt
lemma "signed_drop_bit 2 0b10011 = (0b100::8 word)" by smt
lemma "word_rotr 2 0b0110 = (0b1001::4 word)" by smt
lemma "word_rotl 1 0b1110 = (0b1101::4 word)" by smt
lemma "(x AND 0xff00) OR (x AND 0x00ff) = (x::16 word)" by smt
lemma "w < 256 \<Longrightarrow> (w :: 16 word) AND 0x00FF = w" by smt

section \<open>Combined integer-bitvector properties\<close>

lemma
  assumes "bv2int 0 = 0"
      and "bv2int 1 = 1"
      and "bv2int 2 = 2"
      and "bv2int 3 = 3"
      and "\<forall>x::2 word. bv2int x > 0"
  shows "\<forall>i::int. i < 0 \<longrightarrow> (\<forall>x::2 word. bv2int x > i)"
  using assms by smt

lemma "P (0 \<le> (a :: 4 word)) = P True" by smt

end


theory Chap3_3ex10
  imports
Main
Chap3_1
Chap3_2
"HOL-Library.Monad_Syntax"
begin

datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk = Some (n#stk)"
| "exec1 (LOAD x) s stk = Some ((s x)#stk)"
| "exec1 ADD s (x#y#stk) = Some ((y+x)#stk)"
| "exec1 ADD _ _ = None"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some stk"
| "exec (i#is) s stk = (case exec1 i s stk of
  None \<Rightarrow> None
  | Some stk' \<Rightarrow> exec is s stk'
)"

definition exec' :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec' is s stk = fold (\<lambda>i stko. stko \<bind> exec1 i s) is (Some stk)"

lemma exec_None: "None = fold (\<lambda>i stko. stko \<bind> exec1 i s) is None"
  apply (induction "is")
  using [[simp_trace]]
  by simp+

lemma "exec is s stk = exec' is s stk"
  apply (induction "is" arbitrary: stk)
  unfolding exec'_def using exec_None
  by (auto split: option.split)

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]"
| "comp (V x) = [LOAD x]"
| "comp (Plus e1 e2) = comp e1 @ comp e2 @ [ADD]"

lemma comp_concat:
"exec (is1 @ is2) s stk = exec is1 s stk \<bind> exec is2 s"
  apply (induction is1 arbitrary: stk)
  by (auto split: option.split)

lemma "exec (comp a) s stk = Some stk \<bind> Some \<circ> ((#) (aval a s))"
  apply (induction a arbitrary: stk)
  using comp_concat by auto

end


theory "AList-Utils-HOLCF"
imports "../Launchbury/HOLCF-Utils" "../Launchbury/HOLCF-Join-Classes" "../Launchbury/AList-Utils"
begin

syntax
  "_BLubMap" :: "[pttrn, pttrn, 'a \<rightharpoonup> 'b, 'b] \<Rightarrow> 'b" ("(3\<Squnion>/_/\<mapsto>/_/\<in>/_/./ _)" [0,0,0, 10] 10)

translations
  "\<Squnion> k\<mapsto>v\<in>m. e" == "CONST lub (CONST mapCollect (\<lambda>k v . e) m)"

lemma below_lubmapI[intro]:
  "m k = Some v \<Longrightarrow> (e k v::'a::Join_cpo) \<sqsubseteq> (\<Squnion> k\<mapsto>v\<in>m. e k v)"
unfolding mapCollect_def by auto

lemma lubmap_belowI[intro]:
  "(\<And> k v . m k = Some v \<Longrightarrow> (e k v::'a::Join_cpo) \<sqsubseteq> u) \<Longrightarrow> (\<Squnion> k\<mapsto>v\<in>m. e k v) \<sqsubseteq> u"
unfolding mapCollect_def by auto

lemma lubmap_const_bottom[simp]:
  "(\<Squnion> k\<mapsto>v\<in>m. \<bottom>) = (\<bottom>::'a::Join_cpo)"
  by (cases "m = empty") auto

lemma lubmap_map_upd[simp]:
  fixes e :: "'a \<Rightarrow> 'b \<Rightarrow> ('c :: Join_cpo)"
  shows "(\<Squnion>k\<mapsto>v\<in>m(k' \<mapsto> v'). e k v) = e k' v' \<squnion> (\<Squnion>k\<mapsto>v\<in>m(k':=None). e k v)"
  by simp

lemma lubmap_below_cong:
  assumes "\<And> k v. m k = Some v \<Longrightarrow> f1 k v \<sqsubseteq> (f2 k v :: 'a :: Join_cpo)"
  shows "(\<Squnion> k\<mapsto>v\<in>m. f1 k v) \<sqsubseteq> (\<Squnion> k\<mapsto>v\<in>m. f2 k v)"
  apply (rule lubmap_belowI)
  apply (rule below_trans[OF assms], assumption)
  apply (rule below_lubmapI, assumption)
  done

lemma cont2cont_lubmap[simp, cont2cont]:
  assumes "(\<And>k v . cont (f k v))"
  shows "cont (\<lambda>x. \<Squnion> k\<mapsto>v\<in>m. (f k v x) :: 'a :: Join_cpo)"
proof (rule contI2)
  show "monofun (\<lambda>x. \<Squnion>k\<mapsto>v\<in>m. f k v x)"
    apply (rule monofunI)
    apply (rule lubmap_below_cong)
    apply (erule cont2monofunE[OF assms])
    done
next
  fix Y :: "nat \<Rightarrow> 'd"
  assume "chain Y"
  assume "chain (\<lambda>i. \<Squnion>k\<mapsto>v\<in>m. f k v (Y i))"

  show "(\<Squnion>k\<mapsto>v\<in>m. f k v (\<Squnion> i. Y i)) \<sqsubseteq> (\<Squnion> i. \<Squnion>k\<mapsto>v\<in>m. f k v (Y i))"
    apply (subst cont2contlubE[OF assms `chain Y`])
    apply (rule lubmap_belowI)
    apply (rule lub_mono[OF ch2ch_cont[OF assms `chain Y`] `chain (\<lambda>i. \<Squnion>k\<mapsto>v\<in>m. f k v (Y i))`])
    apply (erule below_lubmapI)
    done
qed

(*
syntax
  "_BLubMapFilter" :: "[pttrn, pttrn, 'a \<rightharpoonup> 'b, 'b, bool] \<Rightarrow> 'b" ("(3\<Squnion>/_/\<mapsto>/_/\<in>/_/./ _/ |/ _)" [0,0,0,10,10] 10)

translations
  "\<Squnion> k\<mapsto>v\<in>m. e | P" == "CONST lub (CONST mapCollectFilter (\<lambda>k v. (P,e)) m)"
*)

end


theory relaxedprefix_correct
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

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

datatype It = A | B | C

fun removeOne2 :: "It => (It list) list => (It list) list" where
"removeOne2 x (Nil2) = Nil2"
| "removeOne2 x (Cons2 z x2) = Cons2 (Cons2 x z) (removeOne2 x x2)"

fun removeOne :: "It list => (It list) list" where
"removeOne (Nil2) = Nil2"
| "removeOne (Cons2 y xs) = Cons2 xs (removeOne2 y (removeOne xs))"

fun or2 :: "bool list => bool" where
"or2 (Nil2) = False"
| "or2 (Cons2 True z) = True"
| "or2 (Cons2 False z) = or2 z"

fun eq :: "It => It => bool" where
"eq (A) y =
   case y of
     | other => False
     | A => True
   end"
| "eq (B) y =
     case y of
       | other => False
       | B => True
     end"
| "eq (C) y =
     case y of
       | other => False
       | C => True
     end"

fun isPrefix :: "It list => It list => bool" where
"isPrefix (Nil2) y = True"
| "isPrefix (Cons2 z x2) (Nil2) = False"
| "isPrefix (Cons2 z x2) (Cons2 x3 x4) =
     (if eq z x3 then isPrefix x2 x4 else False)"

fun spec2 :: "It list => (It list) list => bool list" where
"spec2 ys (Nil2) = Nil2"
| "spec2 ys (Cons2 y z) = Cons2 (isPrefix y ys) (spec2 ys z)"

fun spec :: "It list => It list => bool" where
"spec x y = or2 (spec2 y (Cons2 x (removeOne x)))"

fun isRelaxedPrefix :: "It list => It list => bool" where
"isRelaxedPrefix (Nil2) y = True"
| "isRelaxedPrefix (Cons2 z (Nil2)) y = True"
| "isRelaxedPrefix (Cons2 z (Cons2 x3 x4)) (Nil2) = False"
| "isRelaxedPrefix (Cons2 z (Cons2 x3 x4)) (Cons2 x5 x6) =
     (if eq z x5 then isRelaxedPrefix (Cons2 x3 x4) x6 else
        isPrefix (Cons2 x3 x4) (Cons2 x5 x6))"

(*hipster removeOne2
          removeOne
          or2
          eq
          isPrefix
          spec2
          spec
          isRelaxedPrefix *)

theorem x0 :
  "!! (xs :: It list) (ys :: It list) .
     (isRelaxedPrefix xs ys) = (spec xs ys)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


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


(*  Title:      HOL/MicroJava/BV/Semilat.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Semilattices.
*)

header {*
  \chapter{Bytecode Verifier}\label{cha:bv}
  \isaheader{Semilattices}
*}

theory Semilat
imports Main "~~/src/HOL/Library/While_Combinator"
begin

type_synonym 'a ord    = "'a \<Rightarrow> 'a \<Rightarrow> bool"
type_synonym 'a binop  = "'a \<Rightarrow> 'a \<Rightarrow> 'a"
type_synonym 'a sl     = "'a set \<times> 'a ord \<times> 'a binop"

consts
  "lesub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool"
  "lesssub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool"
  "plussub" :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c"
(*<*)
notation
  "lesub"  ("(_ /<='__ _)" [50, 1000, 51] 50) and
  "lesssub"  ("(_ /<'__ _)" [50, 1000, 51] 50) and
  "plussub"  ("(_ /+'__ _)" [65, 1000, 66] 65)
(*>*)
notation (xsymbols)
  "lesub"  ("(_ /\<sqsubseteq>\<^bsub>_\<^esub> _)" [50, 0, 51] 50) and
  "lesssub"  ("(_ /\<sqsubset>\<^bsub>_\<^esub> _)" [50, 0, 51] 50) and
  "plussub"  ("(_ /\<squnion>\<^bsub>_\<^esub> _)" [65, 0, 66] 65)
(*<*)
(* allow \<sub> instead of \<bsub>..\<esub> *)

abbreviation (input)
  lesub1 :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubseteq>\<^sub>_ _)" [50, 1000, 51] 50)
  where "x \<sqsubseteq>\<^sub>r y == x \<sqsubseteq>\<^bsub>r\<^esub> y"

abbreviation (input)
  lesssub1 :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubset>\<^sub>_ _)" [50, 1000, 51] 50)
  where "x \<sqsubset>\<^sub>r y == x \<sqsubset>\<^bsub>r\<^esub> y"

abbreviation (input)
  plussub1 :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /\<squnion>\<^sub>_ _)" [65, 1000, 66] 65)
  where "x \<squnion>\<^sub>f y == x \<squnion>\<^bsub>f\<^esub> y"
(*>*)

defs
  lesub_def:   "x \<sqsubseteq>\<^sub>r y \<equiv> r x y"
  lesssub_def: "x \<sqsubset>\<^sub>r y \<equiv> x \<sqsubseteq>\<^sub>r y \<and> x \<noteq> y"
  plussub_def: "x \<squnion>\<^sub>f y \<equiv> f x y"

definition ord :: "('a \<times> 'a) set \<Rightarrow> 'a ord"
where
  "ord r = (\<lambda>x y. (x,y) \<in> r)"

definition order :: "'a ord \<Rightarrow> bool"
where
  "order r \<longleftrightarrow> (\<forall>x. x \<sqsubseteq>\<^sub>r x) \<and> (\<forall>x y. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r x \<longrightarrow> x=y) \<and> (\<forall>x y z. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<sqsubseteq>\<^sub>r z)"

definition top :: "'a ord \<Rightarrow> 'a \<Rightarrow> bool"
where
  "top r T \<longleftrightarrow> (\<forall>x. x \<sqsubseteq>\<^sub>r T)"

definition acc :: "'a ord \<Rightarrow> bool"
where
  "acc r \<longleftrightarrow> wf {(y,x). x \<sqsubset>\<^sub>r y}"

definition closed :: "'a set \<Rightarrow> 'a binop \<Rightarrow> bool"
where
  "closed A f \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. x \<squnion>\<^sub>f y \<in> A)"

definition semilat :: "'a sl \<Rightarrow> bool"
where
  "semilat = (\<lambda>(A,r,f). order r \<and> closed A f \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z))"

definition is_ub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "is_ub r x y u \<longleftrightarrow> (x,u)\<in>r \<and> (y,u)\<in>r"

definition is_lub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "is_lub r x y u \<longleftrightarrow> is_ub r x y u \<and> (\<forall>z. is_ub r x y z \<longrightarrow> (u,z)\<in>r)"

definition some_lub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
where
  "some_lub r x y = (SOME z. is_lub r x y z)"

locale Semilat =
  fixes A :: "'a set"
  fixes r :: "'a ord"
  fixes f :: "'a binop"
  assumes semilat: "semilat (A, r, f)"

lemma order_refl [simp, intro]: "order r \<Longrightarrow> x \<sqsubseteq>\<^sub>r x"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_antisym: "\<lbrakk> order r; x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r x \<rbrakk> \<Longrightarrow> x = y"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_trans: "\<lbrakk> order r; x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r z \<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r z"
  (*<*) by (unfold order_def) blast (*>*)

lemma order_less_irrefl [intro, simp]: "order r \<Longrightarrow> \<not> x \<sqsubset>\<^sub>r x"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma order_less_trans: "\<lbrakk> order r; x \<sqsubset>\<^sub>r y; y \<sqsubset>\<^sub>r z \<rbrakk> \<Longrightarrow> x \<sqsubset>\<^sub>r z"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma topD [simp, intro]: "top r T \<Longrightarrow> x \<sqsubseteq>\<^sub>r T"
  (*<*) by (simp add: top_def) (*>*)

lemma top_le_conv [simp]: "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T \<sqsubseteq>\<^sub>r x) = (x = T)"
  (*<*) by (blast intro: order_antisym) (*>*)

lemma semilat_Def:
"semilat(A,r,f) \<longleftrightarrow> order r \<and> closed A f \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z)"
  (*<*) by (unfold semilat_def) clarsimp (*>*)

lemma (in Semilat) orderI [simp, intro]: "order r"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma (in Semilat) closedI [simp, intro]: "closed A f"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma closedD: "\<lbrakk> closed A f; x\<in>A; y\<in>A \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<in> A"
  (*<*) by (unfold closed_def) blast (*>*)

lemma closed_UNIV [simp]: "closed UNIV f"
  (*<*) by (simp add: closed_def) (*>*)

lemma (in Semilat) closed_f [simp, intro]: "\<lbrakk>x \<in> A; y \<in> A\<rbrakk>  \<Longrightarrow> x \<squnion>\<^sub>f y \<in> A"
  (*<*) by (simp add: closedD [OF closedI]) (*>*)

lemma (in Semilat) refl_r [intro, simp]: "x \<sqsubseteq>\<^sub>r x" by simp

lemma (in Semilat) antisym_r [intro?]: "\<lbrakk> x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r x \<rbrakk> \<Longrightarrow> x = y"
  (*<*) by (rule order_antisym) auto (*>*)

lemma (in Semilat) trans_r [trans, intro?]: "\<lbrakk>x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r z\<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r z"
  (*<*) by (auto intro: order_trans) (*>*)

lemma (in Semilat) ub1 [simp, intro?]: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) ub2 [simp, intro?]: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) lub [simp, intro?]:
  "\<lbrakk> x \<sqsubseteq>\<^sub>r z; y \<sqsubseteq>\<^sub>r z; x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) plus_le_conv [simp]:
  "\<lbrakk> x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> (x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z) = (x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z)"
  (*<*) by (blast intro: ub1 ub2 lub order_trans) (*>*)

lemma (in Semilat) le_iff_plus_unchanged:
  assumes "x \<in> A" and "y \<in> A"
  shows "x \<sqsubseteq>\<^sub>r y \<longleftrightarrow> x \<squnion>\<^sub>f y = y" (is "?P \<longleftrightarrow> ?Q")
(*<*)
proof
  assume ?P
  with assms show ?Q by (blast intro: antisym_r lub ub2)
next
  assume ?Q
  then have "y = x \<squnion>\<^bsub>f\<^esub> y" by simp
  moreover from assms have "x \<sqsubseteq>\<^bsub>r\<^esub> x \<squnion>\<^bsub>f\<^esub> y" by simp
  ultimately show ?P by simp
qed
(*>*)

lemma (in Semilat) le_iff_plus_unchanged2:
  assumes "x \<in> A" and "y \<in> A"
  shows "x \<sqsubseteq>\<^sub>r y \<longleftrightarrow> y \<squnion>\<^sub>f x = y" (is "?P \<longleftrightarrow> ?Q")
(*<*)
proof
  assume ?P
  with assms show ?Q by (blast intro: antisym_r lub ub1)
next
  assume ?Q
  then have "y = y \<squnion>\<^bsub>f\<^esub> x" by simp
  moreover from assms have "x \<sqsubseteq>\<^bsub>r\<^esub> y \<squnion>\<^bsub>f\<^esub> x" by simp
  ultimately show ?P by simp
qed
(*>*)

lemma (in Semilat) plus_assoc [simp]:
  assumes a: "a \<in> A" and b: "b \<in> A" and c: "c \<in> A"
  shows "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) = a \<squnion>\<^sub>f b \<squnion>\<^sub>f c"
(*<*)
proof -
  from a b have ab: "a \<squnion>\<^sub>f b \<in> A" ..
  from this c have abc: "(a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c \<in> A" ..
  from b c have bc: "b \<squnion>\<^sub>f c \<in> A" ..
  from a this have abc': "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) \<in> A" ..

  show ?thesis
  proof
    show "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c"
    proof -
      from a b have "a \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f b" ..
      also from ab c have "\<dots> \<sqsubseteq>\<^sub>r \<dots> \<squnion>\<^sub>f c" ..
      finally have "a<": "a \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" .
      from a b have "b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f b" ..
      also from ab c have "\<dots> \<sqsubseteq>\<^sub>r \<dots> \<squnion>\<^sub>f c" ..
      finally have "b<": "b \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" .
      from ab c have "c<": "c \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" ..
      from "b<" "c<" b c abc have "b \<squnion>\<^sub>f c \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" ..
      from "a<" this a bc abc show ?thesis ..
    qed
    show "(a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)"
    proof -
      from b c have "b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f c" ..
      also from a bc have "\<dots> \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f \<dots>" ..
      finally have "b<": "b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" .
      from b c have "c \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f c" ..
      also from a bc have "\<dots> \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f \<dots>" ..
      finally have "c<": "c \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" .
      from a bc have "a<": "a \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" ..
      from "a<" "b<" a b abc' have "a \<squnion>\<^sub>f b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" ..
      from this "c<" ab c abc' show ?thesis ..
    qed
  qed
qed
(*>*)

lemma (in Semilat) plus_com_lemma:
  "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>f b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a"
(*<*)
proof -
  assume a: "a \<in> A" and b: "b \<in> A"
  from b a have "a \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a" ..
  moreover from b a have "b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a" ..
  moreover note a b
  moreover from b a have "b \<squnion>\<^sub>f a \<in> A" ..
  ultimately show ?thesis ..
qed
(*>*)

lemma (in Semilat) plus_commutative:
  "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>f b = b \<squnion>\<^sub>f a"
  (*<*) by(blast intro: order_antisym plus_com_lemma) (*>*)

lemma is_lubD:
  "is_lub r x y u \<Longrightarrow> is_ub r x y u \<and> (\<forall>z. is_ub r x y z \<longrightarrow> (u,z) \<in> r)"
  (*<*) by (simp add: is_lub_def) (*>*)

lemma is_ubI:
  "\<lbrakk> (x,u) \<in> r; (y,u) \<in> r \<rbrakk> \<Longrightarrow> is_ub r x y u"
  (*<*) by (simp add: is_ub_def) (*>*)

lemma is_ubD:
  "is_ub r x y u \<Longrightarrow> (x,u) \<in> r \<and> (y,u) \<in> r"
  (*<*) by (simp add: is_ub_def) (*>*)

lemma is_lub_bigger1 [iff]:
  "is_lub (r^* ) x y y = ((x,y)\<in>r^* )"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply blast
done
(*>*)

lemma is_lub_bigger2 [iff]:
  "is_lub (r^* ) x y x = ((y,x)\<in>r^* )"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply blast
done
(*>*)

lemma extend_lub:
  "\<lbrakk> single_valued r; is_lub (r^* ) x y u; (x',x) \<in> r \<rbrakk>
  \<Longrightarrow> EX v. is_lub (r^* ) x' y v"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply (case_tac "(y,x) \<in> r^*")
 apply (case_tac "(y,x') \<in> r^*")
  apply blast
 apply (blast elim: converse_rtranclE dest: single_valuedD)
apply (rule exI)
apply (rule conjI)
 apply (blast intro: converse_rtrancl_into_rtrancl dest: single_valuedD)
apply (blast intro: rtrancl_into_rtrancl converse_rtrancl_into_rtrancl
             elim: converse_rtranclE dest: single_valuedD)
done
(*>*)

lemma single_valued_has_lubs [rule_format]:
  "\<lbrakk> single_valued r; (x,u) \<in> r^* \<rbrakk> \<Longrightarrow> (\<forall>y. (y,u) \<in> r^* \<longrightarrow>
  (EX z. is_lub (r^* ) x y z))"
(*<*)
apply (erule converse_rtrancl_induct)
 apply clarify
 apply (erule converse_rtrancl_induct)
  apply blast
 apply (blast intro: converse_rtrancl_into_rtrancl)
apply (blast intro: extend_lub)
done
(*>*)

lemma some_lub_conv:
  "\<lbrakk> acyclic r; is_lub (r^* ) x y u \<rbrakk> \<Longrightarrow> some_lub (r^* ) x y = u"
(*<*)
apply (unfold some_lub_def is_lub_def)
apply (rule someI2)
 apply (unfold is_lub_def)
 apply assumption
apply (blast intro: antisymD dest!: acyclic_impl_antisym_rtrancl)
done
(*>*)

lemma is_lub_some_lub:
  "\<lbrakk> single_valued r; acyclic r; (x,u)\<in>r^*; (y,u)\<in>r^* \<rbrakk>
  \<Longrightarrow> is_lub (r^* ) x y (some_lub (r^* ) x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: some_lub_conv) (*>*)

subsection{*An executable lub-finder*}

definition exec_lub :: "('a * 'a) set \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a binop"
where
  "exec_lub r f x y = while (\<lambda>z. (x,z) \<notin> r\<^sup>*) f y"

lemma exec_lub_refl: "exec_lub r f T T = T"
by (simp add: exec_lub_def while_unfold)

lemma acyclic_single_valued_finite:
 "\<lbrakk>acyclic r; single_valued r; (x,y) \<in> r\<^sup>*\<rbrakk>
  \<Longrightarrow> finite (r \<inter> {a. (x, a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})"
(*<*)
apply(erule converse_rtrancl_induct)
 apply(rule_tac B = "{}" in finite_subset)
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply simp
apply(rename_tac x x')
apply(subgoal_tac "r \<inter> {a. (x,a) \<in> r\<^sup>*} \<times> {b. (b,y) \<in> r\<^sup>*} =
                   insert (x,x') (r \<inter> {a. (x', a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})")
 apply simp
apply(blast intro:converse_rtrancl_into_rtrancl
            elim:converse_rtranclE dest:single_valuedD)
done
(*>*)

lemma exec_lub_conv:
  "\<lbrakk> acyclic r; \<forall>x y. (x,y) \<in> r \<longrightarrow> f x = y; is_lub (r\<^sup>*) x y u \<rbrakk> \<Longrightarrow>
  exec_lub r f x y = u"
(*<*)
apply(unfold exec_lub_def)
apply(rule_tac P = "\<lambda>z. (y,z) \<in> r\<^sup>* \<and> (z,u) \<in> r\<^sup>*" and
               r = "(r \<inter> {(a,b). (y,a) \<in> r\<^sup>* \<and> (b,u) \<in> r\<^sup>*})^-1" in while_rule)
    apply(blast dest: is_lubD is_ubD)
   apply(erule conjE)
   apply(erule_tac z = u in converse_rtranclE)
    apply(blast dest: is_lubD is_ubD)
   apply(blast dest:rtrancl_into_rtrancl)
  apply(rename_tac s)
  apply(subgoal_tac "is_ub (r\<^sup>*) x y s")
   prefer 2 apply(simp add:is_ub_def)
  apply(subgoal_tac "(u, s) \<in> r\<^sup>*")
   prefer 2 apply(blast dest:is_lubD)
  apply(erule converse_rtranclE)
   apply blast
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply(rule finite_acyclic_wf)
  apply simp
  apply(erule acyclic_single_valued_finite)
   apply(blast intro:single_valuedI)
  apply(simp add:is_lub_def is_ub_def)
 apply simp
 apply(erule acyclic_subset)
 apply blast
apply simp
apply(erule conjE)
apply(erule_tac z = u in converse_rtranclE)
 apply(blast dest: is_lubD is_ubD)
apply(blast dest:rtrancl_into_rtrancl)
done
(*>*)

lemma is_lub_exec_lub:
  "\<lbrakk> single_valued r; acyclic r; (x,u):r^*; (y,u):r^*; \<forall>x y. (x,y) \<in> r \<longrightarrow> f x = y \<rbrakk>
  \<Longrightarrow> is_lub (r^* ) x y (exec_lub r f x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: exec_lub_conv) (*>*)

end