diff --git a/thys/Akra_Bazzi/Akra_Bazzi_Library.thy b/thys/Akra_Bazzi/Akra_Bazzi_Library.thy
--- a/thys/Akra_Bazzi/Akra_Bazzi_Library.thy
+++ b/thys/Akra_Bazzi/Akra_Bazzi_Library.thy
@@ -1,285 +1,286 @@
 (*
   File:   Akra_Bazzi_Library.thy
   Author: Manuel Eberl <eberlm@in.tum.de>
 
   Lemma bucket for the Akra-Bazzi theorem.
 *)
 
 section \<open>Auxiliary lemmas\<close>
 theory Akra_Bazzi_Library
 imports 
   Complex_Main
   "Landau_Symbols.Landau_More"
+  "Pure-ex.Guess"
 begin
 
 (* TODO: Move? *)
 
 lemma ln_mono: "0 < x \<Longrightarrow> 0 < y \<Longrightarrow> x \<le> y \<Longrightarrow> ln (x::real) \<le> ln y"
   by (subst ln_le_cancel_iff) simp_all
 
 lemma ln_mono_strict: "0 < x \<Longrightarrow> 0 < y \<Longrightarrow> x < y \<Longrightarrow> ln (x::real) < ln y"
   by (subst ln_less_cancel_iff) simp_all
 
 declare DERIV_powr[THEN DERIV_chain2, derivative_intros]
 
 lemma sum_pos':
   assumes "finite I"
   assumes "\<exists>x\<in>I. f x > (0 :: _ :: linordered_ab_group_add)"
   assumes "\<And>x. x \<in> I \<Longrightarrow> f x \<ge> 0"
   shows   "sum f I > 0"
 proof-
   from assms(2) guess x by (elim bexE) note x = this
   from x have "I = insert x I" by blast
   also from assms(1) have "sum f ... = f x + sum f (I - {x})" by (rule sum.insert_remove)
   also from x assms have "... > 0" by (intro add_pos_nonneg sum_nonneg) simp_all
   finally show ?thesis .
 qed
 
 
 lemma min_mult_left:
   assumes "(x::real) > 0"
   shows   "x * min y z = min (x*y) (x*z)"
   using assms by (auto simp add: min_def algebra_simps)
 
 lemma max_mult_left:
   assumes "(x::real) > 0"
   shows   "x * max y z = max (x*y) (x*z)"
   using assms by (auto simp add: max_def algebra_simps)
 
 lemma DERIV_nonneg_imp_mono:
   assumes "\<And>t. t\<in>{x..y} \<Longrightarrow> (f has_field_derivative f' t) (at t)"
   assumes "\<And>t. t\<in>{x..y} \<Longrightarrow> f' t \<ge> 0"
   assumes "(x::real) \<le> y"
   shows   "(f x :: real) \<le> f y"
 proof (cases x y rule: linorder_cases)
   assume xy: "x < y"
   hence "\<exists>z. x < z \<and> z < y \<and> f y - f x = (y - x) * f' z"
     by (rule MVT2) (insert assms(1), simp)
   then guess z by (elim exE conjE) note z = this
   from z(1,2) assms(2) xy have "0 \<le> (y - x) * f' z" by (intro mult_nonneg_nonneg) simp_all
   also note z(3)[symmetric]
   finally show "f x \<le> f y" by simp
 qed (insert assms(3), simp_all)
 
 lemma eventually_conjE: "eventually (\<lambda>x. P x \<and> Q x) F \<Longrightarrow> (eventually P F \<Longrightarrow> eventually Q F \<Longrightarrow> R) \<Longrightarrow> R"
   apply (frule eventually_rev_mp[of _ _ P], simp)
   apply (drule eventually_rev_mp[of _ _ Q], simp)
   apply assumption
   done
 
 lemma real_natfloor_nat: "x \<in> \<nat> \<Longrightarrow> real (nat \<lfloor>x\<rfloor>) = x" by (elim Nats_cases) simp
 
 lemma eventually_natfloor:
   assumes "eventually P (at_top :: nat filter)"
   shows   "eventually (\<lambda>x. P (nat \<lfloor>x\<rfloor>)) (at_top :: real filter)"
 proof-
   from assms obtain N where N: "\<And>n. n \<ge> N \<Longrightarrow> P n" using eventually_at_top_linorder by blast
   have "\<forall>n\<ge>real N. P (nat \<lfloor>n\<rfloor>)" by (intro allI impI N le_nat_floor) simp_all
   thus ?thesis using eventually_at_top_linorder by blast
 qed
 
 lemma tendsto_0_smallo_1: "f \<in> o(\<lambda>x. 1 :: real) \<Longrightarrow> (f \<longlongrightarrow> 0) at_top"
   by (drule smalloD_tendsto) simp
 
 lemma smallo_1_tendsto_0: "(f \<longlongrightarrow> 0) at_top \<Longrightarrow> f \<in> o(\<lambda>x. 1 :: real)"
   by (rule smalloI_tendsto) simp_all
 
 lemma filterlim_at_top_smallomega_1: 
   assumes "f \<in> \<omega>[F](\<lambda>x. 1 :: real)" "eventually (\<lambda>x. f x > 0) F"
   shows   "filterlim f at_top F"
 proof -
   from assms have "filterlim (\<lambda>x. norm (f x / 1)) at_top F"
     by (intro smallomegaD_filterlim_at_top_norm) (auto elim: eventually_mono)
   also have "?this \<longleftrightarrow> ?thesis"
     using assms by (intro filterlim_cong refl) (auto elim!: eventually_mono)
   finally show ?thesis .
 qed
 
 lemma smallo_imp_abs_less_real:
   assumes "f \<in> o[F](g)" "eventually (\<lambda>x. g x > (0::real)) F"
   shows   "eventually (\<lambda>x. \<bar>f x\<bar> < g x) F"
 proof -
   have "1/2 > (0::real)" by simp
   from landau_o.smallD[OF assms(1) this] assms(2) show ?thesis
     by eventually_elim auto
 qed
 
 lemma smallo_imp_less_real:
   assumes "f \<in> o[F](g)" "eventually (\<lambda>x. g x > (0::real)) F"
   shows   "eventually (\<lambda>x. f x < g x) F"
   using smallo_imp_abs_less_real[OF assms] by eventually_elim simp
 
 lemma smallo_imp_le_real: 
   assumes "f \<in> o[F](g)" "eventually (\<lambda>x. g x \<ge> (0::real)) F"
   shows   "eventually (\<lambda>x. f x \<le> g x) F"
   using landau_o.smallD[OF assms(1) zero_less_one] assms(2) by eventually_elim simp
 
 (* TODO MOVE *)
 lemma filterlim_at_right: 
   "filterlim f (at_right a) F \<longleftrightarrow> eventually (\<lambda>x. f x > a) F \<and> filterlim f (nhds a) F"
   by (subst filterlim_at) (auto elim!: eventually_mono)
 (* END TODO *)
 
 lemma one_plus_x_powr_approx_ex:
   assumes x: "abs (x::real) \<le> 1/2"
   obtains t where "abs t < 1/2" "(1 + x) powr p = 
     1 + p * x + p * (p - 1) * (1 + t) powr (p - 2) / 2 * x ^ 2"
 proof (cases "x = 0")
   assume x': "x \<noteq> 0"
   let ?f = "\<lambda>x. (1 + x) powr p"
   let ?f' = "\<lambda>x. p * (1 + x) powr (p - 1)"
   let ?f'' = "\<lambda>x. p * (p - 1) * (1 + x) powr (p - 2)"
   let ?fs = "(!) [?f, ?f', ?f'']"
  
   have A: "\<forall>m t. m < 2 \<and> t \<ge> -0.5 \<and> t \<le> 0.5 \<longrightarrow> (?fs m has_real_derivative ?fs (Suc m) t) (at t)"
   proof (clarify)
     fix m :: nat and t :: real assume m: "m < 2" and t: "t \<ge> -0.5" "t \<le> 0.5"
     thus "(?fs m has_real_derivative ?fs (Suc m) t) (at t)"
       using m by (cases m) (force intro: derivative_eq_intros algebra_simps)+
   qed
   have "\<exists>t. (if x < 0 then x < t \<and> t < 0 else 0 < t \<and> t < x) \<and>
               (1 + x) powr p = (\<Sum>m<2. ?fs m 0 / (fact m) * (x - 0)^m) + 
               ?fs 2 t / (fact 2) * (x - 0)\<^sup>2"
     using assms x' by (intro Taylor[OF _ _ A]) simp_all
   then guess t by (elim exE conjE)
   note t = this
   with assms have "abs t < 1/2" by (auto split: if_split_asm)
   moreover from t(2) have "(1 + x) powr p = 1 + p * x + p * (p - 1) * (1 + t) powr (p - 2) / 2 * x ^ 2"
     by (simp add: numeral_2_eq_2 of_nat_Suc)
   ultimately show ?thesis by (rule that)
 next
   assume "x = 0"
   with that[of 0] show ?thesis by simp
 qed
 
 lemma powr_lower_bound: "\<lbrakk>(l::real) > 0; l \<le> x; x \<le> u\<rbrakk> \<Longrightarrow> min (l powr z) (u powr z) \<le> x powr z"
 apply (cases "z \<ge> 0")
 apply (rule order.trans[OF min.cobounded1 powr_mono2], simp_all) []
 apply (rule order.trans[OF min.cobounded2 powr_mono2'], simp_all) []
 done
 
 lemma powr_upper_bound: "\<lbrakk>(l::real) > 0; l \<le> x; x \<le> u\<rbrakk> \<Longrightarrow> max (l powr z) (u powr z) \<ge> x powr z"
 apply (cases "z \<ge> 0")
 apply (rule order.trans[OF powr_mono2 max.cobounded2], simp_all) []
 apply (rule order.trans[OF powr_mono2' max.cobounded1], simp_all) []
 done
 
 lemma one_plus_x_powr_Taylor2:
   obtains k where "\<And>x. abs (x::real) \<le> 1/2 \<Longrightarrow> abs ((1 + x) powr p - 1 - p*x) \<le> k*x^2"
 proof-
   define k where "k = \<bar>p*(p - 1)\<bar> * max ((1/2) powr (p - 2)) ((3/2) powr (p - 2)) / 2"
   show ?thesis
   proof (rule that[of k])
     fix x :: real assume "abs x \<le> 1/2"
     from one_plus_x_powr_approx_ex[OF this, of p] guess t . note t = this
     from t have "abs ((1 + x) powr p - 1 - p*x) = \<bar>p*(p - 1)\<bar> * (1 + t) powr (p - 2)/2 * x\<^sup>2"
       by (simp add: abs_mult)
     also from t(1) have "(1 + t) powr (p - 2) \<le> max ((1/2) powr (p - 2)) ((3/2) powr (p - 2))"
       by (intro powr_upper_bound) simp_all
     finally show "abs ((1 + x) powr p - 1 - p*x) \<le> k*x^2" 
       by (simp add: mult_left_mono mult_right_mono k_def)
   qed
 qed
 
 lemma one_plus_x_powr_Taylor2_bigo:
   assumes lim: "(f \<longlongrightarrow> 0) F"
   shows   "(\<lambda>x. (1 + f x) powr (p::real) - 1 - p * f x) \<in> O[F](\<lambda>x. f x ^ 2)"
 proof -
   from one_plus_x_powr_Taylor2[of p] guess k .
   moreover from tendstoD[OF lim, of "1/2"] 
     have "eventually (\<lambda>x. abs (f x) < 1/2) F" by (simp add: dist_real_def)
   ultimately have "eventually (\<lambda>x. norm ((1 + f x) powr p - 1 - p * f x) \<le> k * norm (f x ^ 2)) F"
     by (auto elim!: eventually_mono)
   thus ?thesis by (rule bigoI)
 qed
 
 lemma one_plus_x_powr_Taylor1_bigo:
   assumes lim: "(f \<longlongrightarrow> 0) F"
   shows   "(\<lambda>x. (1 + f x) powr (p::real) - 1) \<in> O[F](\<lambda>x. f x)"
 proof -
   from assms have "(\<lambda>x. (1 + f x) powr p - 1 - p * f x) \<in> O[F](\<lambda>x. (f x)\<^sup>2)"
     by (rule one_plus_x_powr_Taylor2_bigo)
   also from assms have "f \<in> O[F](\<lambda>_. 1)" by (intro bigoI_tendsto) simp_all
   from landau_o.big.mult[of f F f, OF _ this] have "(\<lambda>x. (f x)^2) \<in> O[F](\<lambda>x. f x)"
     by (simp add: power2_eq_square)
   finally have A: "(\<lambda>x. (1 + f x) powr p - 1 - p * f x) \<in> O[F](f)" .
   have B: "(\<lambda>x. p * f x) \<in> O[F](f)" by simp
   from sum_in_bigo(1)[OF A B] show ?thesis by simp
 qed
 
 lemma x_times_x_minus_1_nonneg: "x \<le> 0 \<or> x \<ge> 1 \<Longrightarrow> (x::_::linordered_idom) * (x - 1) \<ge> 0"
 proof (elim disjE)
   assume x: "x \<le> 0"
   also have "0 \<le> x^2" by simp
   finally show "x * (x - 1) \<ge> 0" by (simp add: power2_eq_square algebra_simps)
 qed simp
 
 lemma x_times_x_minus_1_nonpos: "x \<ge> 0 \<Longrightarrow> x \<le> 1 \<Longrightarrow> (x::_::linordered_idom) * (x - 1) \<le> 0"
   by (intro mult_nonneg_nonpos) simp_all
 
 lemma powr_mono':
   assumes "(x::real) > 0" "x \<le> 1" "a \<le> b"
   shows   "x powr b \<le> x powr a"
 proof-
   have "inverse x powr a \<le> inverse x powr b" using assms
     by (intro powr_mono) (simp_all add: field_simps)
   hence "inverse (x powr a) \<le> inverse (x powr b)" using assms by simp
   with assms show ?thesis by (simp add: field_simps)
 qed
 
 lemma powr_less_mono':
   assumes "(x::real) > 0" "x < 1" "a < b"
   shows   "x powr b < x powr a"
 proof-
   have "inverse x powr a < inverse x powr b" using assms
     by (intro powr_less_mono) (simp_all add: field_simps)
   hence "inverse (x powr a) < inverse (x powr b)" using assms by simp
   with assms show ?thesis by (simp add: field_simps)
 qed
 
 lemma real_powr_at_bot:
   assumes "(a::real) > 1"
   shows   "((\<lambda>x. a powr x) \<longlongrightarrow> 0) at_bot"
 proof-
   from assms have "filterlim (\<lambda>x. ln a * x) at_bot at_bot"
     by (intro filterlim_tendsto_pos_mult_at_bot[OF tendsto_const _ filterlim_ident]) auto
   hence "((\<lambda>x. exp (x * ln a)) \<longlongrightarrow> 0) at_bot"
     by (intro filterlim_compose[OF exp_at_bot]) (simp add: algebra_simps)
   thus ?thesis using assms unfolding powr_def by simp
 qed
 
 lemma real_powr_at_bot_neg:
   assumes "(a::real) > 0" "a < 1"
   shows   "filterlim (\<lambda>x. a powr x) at_top at_bot"
 proof-
   from assms have "LIM x at_bot. ln (inverse a) * -x :> at_top"
     by (intro filterlim_tendsto_pos_mult_at_top[OF tendsto_const] filterlim_uminus_at_top_at_bot)
        (simp_all add: ln_inverse)
   with assms have "LIM x at_bot. x * ln a :> at_top" 
     by (subst (asm) ln_inverse) (simp_all add: mult.commute)
   hence "LIM x at_bot. exp (x * ln a) :> at_top"
     by (intro filterlim_compose[OF exp_at_top]) simp
   thus ?thesis using assms unfolding powr_def by simp
 qed
 
 lemma real_powr_at_top_neg: 
   assumes "(a::real) > 0" "a < 1"
   shows   "((\<lambda>x. a powr x) \<longlongrightarrow> 0) at_top"
 proof-
   from assms have "LIM x at_top. ln (inverse a) * x :> at_top"
     by (intro filterlim_tendsto_pos_mult_at_top[OF tendsto_const])
        (simp_all add: filterlim_ident field_simps)
   with assms have "LIM x at_top. ln a * x :> at_bot"
     by (subst filterlim_uminus_at_bot) (simp add: ln_inverse)
   hence "((\<lambda>x. exp (x * ln a)) \<longlongrightarrow> 0) at_top"
     by (intro filterlim_compose[OF exp_at_bot]) (simp_all add: mult.commute)
   with assms show ?thesis unfolding powr_def by simp
 qed
 
 lemma eventually_nat_real:
   assumes "eventually P (at_top :: real filter)"
   shows   "eventually (\<lambda>x. P (real x)) (at_top :: nat filter)"
   using assms filterlim_real_sequentially
   unfolding filterlim_def le_filter_def eventually_filtermap by auto
 
 end
diff --git a/thys/Akra_Bazzi/ROOT b/thys/Akra_Bazzi/ROOT
--- a/thys/Akra_Bazzi/ROOT
+++ b/thys/Akra_Bazzi/ROOT
@@ -1,16 +1,17 @@
 chapter AFP
 
 session Akra_Bazzi (AFP) = "HOL-Analysis" +
   options [timeout = 600]
   sessions
+    "Pure-ex"
     "HOL-Decision_Procs"
     Landau_Symbols
   theories
     Akra_Bazzi
     Master_Theorem
     Akra_Bazzi_Method
     Akra_Bazzi_Approximation
     Master_Theorem_Examples
   document_files
     "root.tex"
     "root.bib"
diff --git a/thys/Automatic_Refinement/Lib/Misc.thy b/thys/Automatic_Refinement/Lib/Misc.thy
--- a/thys/Automatic_Refinement/Lib/Misc.thy
+++ b/thys/Automatic_Refinement/Lib/Misc.thy
@@ -1,4507 +1,4507 @@
 (*  Title:       Miscellaneous Definitions and Lemmas
     Author:      Peter Lammich <peter.lammich@uni-muenster.de>
     Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
                  Thomas Tuerk <tuerk@in.tum.de>
 *)
 
 (*
   CHANGELOG:
     2010-05-09: Removed AC, AI locales, they are superseeded by concepts
                   from OrderedGroups
     2010-09-22: Merges with ext/Aux
     2017-06-12: Added a bunch of lemmas from various other projects
 
 *)
 
 section \<open>Miscellaneous Definitions and Lemmas\<close>
 
 theory Misc
 imports Main
   "HOL-Library.Multiset"
   "HOL-ex.Quicksort"
   "HOL-Library.Option_ord"
   "HOL-Library.Infinite_Set"
   "HOL-Eisbach.Eisbach"
 begin
 text_raw \<open>\label{thy:Misc}\<close>
 
   
 subsection \<open>Isabelle Distribution Move Proposals\<close>  
 
 subsubsection \<open>Pure\<close>  
 lemma TERMI: "TERM x" unfolding Pure.term_def .
   
   
 subsubsection \<open>HOL\<close>  
 (* Stronger disjunction elimination rules. *)
 lemma disjE1: "\<lbrakk> P \<or> Q; P \<Longrightarrow> R; \<lbrakk>\<not>P;Q\<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
   by metis
 lemma disjE2: "\<lbrakk> P \<or> Q; \<lbrakk>P; \<not>Q\<rbrakk> \<Longrightarrow> R; Q \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
   by blast
 
 lemma imp_mp_iff[simp]: 
   "a \<and> (a \<longrightarrow> b) \<longleftrightarrow> a \<and> b" 
   "(a \<longrightarrow> b) \<and> a \<longleftrightarrow> a \<and> b" (* is Inductive.imp_conj_iff, but not in simpset by default *)
   by blast+
     
 lemma atomize_Trueprop_eq[atomize]: "(Trueprop x \<equiv> Trueprop y) \<equiv> Trueprop (x=y)"
   apply rule
   apply (rule)
   apply (erule equal_elim_rule1)
   apply assumption
   apply (erule equal_elim_rule2)
   apply assumption
   apply simp
   done
   
 subsubsection \<open>Set\<close>    
 lemma inter_compl_diff_conv[simp]: "A \<inter> -B = A - B" by auto
 lemma pair_set_inverse[simp]: "{(a,b). P a b}\<inverse> = {(b,a). P a b}"
   by auto
 
 lemma card_doubleton_eq_2_iff[simp]: "card {a,b} = 2 \<longleftrightarrow> a\<noteq>b" by auto
 
     
 subsubsection \<open>List\<close>  
 (* TODO: Move, analogous to List.length_greater_0_conv *) 
 thm List.length_greater_0_conv  
 lemma length_ge_1_conv[iff]: "Suc 0 \<le> length l \<longleftrightarrow> l\<noteq>[]"
   by (cases l) auto
   
 \<comment> \<open>Obtains a list from the pointwise characterization of its elements\<close>
 lemma obtain_list_from_elements:
   assumes A: "\<forall>i<n. (\<exists>li. P li i)"
   obtains l where
     "length l = n"
     "\<forall>i<n. P (l!i) i"
 proof -
   from A have "\<exists>l. length l=n \<and> (\<forall>i<n. P (l!i) i)"
   proof (induct n)
     case 0 thus ?case by simp
   next
     case (Suc n)
     then obtain l where IH: "length l = n" "(\<forall>i<n. P(l!i) i)" by auto
     moreover from Suc.prems obtain ln where "P ln n" by auto
     ultimately have "length (l@[ln]) = Suc n" "(\<forall>i<Suc n. P((l@[ln])!i) i)"
       by (auto simp add: nth_append dest: less_antisym)
     thus ?case by blast
   qed
   thus ?thesis using that by (blast)
 qed
   
 lemma distinct_sorted_mono:
   assumes S: "sorted l"
   assumes D: "distinct l"
   assumes B: "i<j" "j<length l"
   shows "l!i < l!j"
 proof -
   from S B have "l!i \<le> l!j"
     by (simp add: sorted_iff_nth_mono)
   also from nth_eq_iff_index_eq[OF D] B have "l!i \<noteq> l!j"
     by auto
   finally show ?thesis .
 qed
 
 lemma distinct_sorted_strict_mono_iff:
   assumes "distinct l" "sorted l"
   assumes "i<length l" "j<length l"
   shows "l!i<l!j \<longleftrightarrow> i<j"
   using assms
   by (metis distinct_sorted_mono leI less_le_not_le
     order.strict_iff_order)
 
 lemma distinct_sorted_mono_iff:
   assumes "distinct l" "sorted l"
   assumes "i<length l" "j<length l"
   shows "l!i\<le>l!j \<longleftrightarrow> i\<le>j"
   by (metis assms distinct_sorted_strict_mono_iff leD le_less_linear)
   
     
 (* List.thy has:
  declare map_eq_Cons_D [dest!]  Cons_eq_map_D [dest!] 
 
   We could, analogously, declare rules for "map _ _ = _@_" as dest!,
   or use elim!, or declare the _conv-rule as simp
 *)  
    
 lemma map_eq_appendE: 
   assumes "map f ls = fl@fl'"
   obtains l l' where "ls=l@l'" and "map f l=fl" and  "map f l' = fl'"
   using assms  
 proof (induction fl arbitrary: ls thesis)
   case (Cons x xs)
     then obtain l ls' where [simp]: "ls = l#ls'" "f l = x" by force
     with Cons.prems(2) have "map f ls' = xs @ fl'" by simp
-    from Cons.IH[OF _ this] guess ll ll' .
+    from Cons.IH[OF _ this] obtain ll ll' where "ls' = ll @ ll'" "map f ll = xs" "map f ll' = fl'" .
     with Cons.prems(1)[of "l#ll" ll'] show thesis by simp
 qed simp
 
 lemma map_eq_append_conv: "map f ls = fl@fl' \<longleftrightarrow> (\<exists>l l'. ls = l@l' \<and> map f l = fl \<and> map f l' = fl')"
   by (auto elim!: map_eq_appendE)
   
 lemmas append_eq_mapE = map_eq_appendE[OF sym]
   
 lemma append_eq_map_conv: "fl@fl' = map f ls \<longleftrightarrow> (\<exists>l l'. ls = l@l' \<and> map f l = fl \<and> map f l' = fl')"
   by (auto elim!: append_eq_mapE)
   
   
 lemma distinct_mapI: "distinct (map f l) \<Longrightarrow> distinct l"
   by (induct l) auto
     
 lemma map_distinct_upd_conv: 
   "\<lbrakk>i<length l; distinct l\<rbrakk> \<Longrightarrow> (map f l)[i := x] = map (f(l!i := x)) l"
   \<comment> \<open>Updating a mapped distinct list is equal to updating the 
     mapping function\<close>
   by (auto simp: nth_eq_iff_index_eq intro: nth_equalityI)
 
     
 lemma zip_inj: "\<lbrakk>length a = length b; length a' = length b'; zip a b = zip a' b'\<rbrakk> \<Longrightarrow> a=a' \<and> b=b'"
 proof (induct a b arbitrary: a' b' rule: list_induct2)
   case Nil
   then show ?case by (cases a'; cases b'; auto)
 next
   case (Cons x xs y ys)
   then show ?case by (cases a'; cases b'; auto)
 qed
 
 lemma zip_eq_zip_same_len[simp]:
   "\<lbrakk> length a = length b; length a' = length b' \<rbrakk> \<Longrightarrow>
   zip a b = zip a' b' \<longleftrightarrow> a=a' \<and> b=b'"
   by (auto dest: zip_inj)
     
     
 lemma upt_merge[simp]: "i\<le>j \<and> j\<le>k \<Longrightarrow> [i..<j]@[j..<k] = [i..<k]"
   by (metis le_Suc_ex upt_add_eq_append)
   
 (* Maybe this should go into List.thy, next to snoc_eq_iff_butlast *)
 lemma snoc_eq_iff_butlast':
   "(ys = xs @ [x]) \<longleftrightarrow> (ys \<noteq> [] \<and> butlast ys = xs \<and> last ys = x)"
   by auto
 
 (* Case distinction how two elements of a list can be related to each other *)
 lemma list_match_lel_lel:
   assumes "c1 @ qs # c2 = c1' @ qs' # c2'"
   obtains
     (left) c21' where "c1 = c1' @ qs' # c21'" "c2' = c21' @ qs # c2"
   | (center) "c1' = c1" "qs' = qs" "c2' = c2"
   | (right) c21 where "c1' = c1 @ qs # c21" "c2 = c21 @ qs' # c2'"
   using assms  
   apply (clarsimp simp: append_eq_append_conv2)  
   subgoal for us by (cases us) auto
   done    
     
 lemma xy_in_set_cases[consumes 2, case_names EQ XY YX]:
   assumes A: "x\<in>set l" "y\<in>set l"
   and C:
   "!!l1 l2. \<lbrakk> x=y; l=l1@y#l2 \<rbrakk> \<Longrightarrow> P"
   "!!l1 l2 l3. \<lbrakk> x\<noteq>y; l=l1@x#l2@y#l3 \<rbrakk> \<Longrightarrow> P"
   "!!l1 l2 l3. \<lbrakk> x\<noteq>y; l=l1@y#l2@x#l3 \<rbrakk> \<Longrightarrow> P"
   shows P
 proof (cases "x=y")
   case True with A(1) obtain l1 l2 where "l=l1@y#l2" by (blast dest: split_list)
   with C(1) True show ?thesis by blast
 next
   case False
   from A(1) obtain l1 l2 where S1: "l=l1@x#l2" by (blast dest: split_list)
   from A(2) obtain l1' l2' where S2: "l=l1'@y#l2'" by (blast dest: split_list)
   from S1 S2 have M: "l1@x#l2 = l1'@y#l2'" by simp
   thus P proof (cases rule: list_match_lel_lel[consumes 1, case_names 1 2 3])
     case (1 c) with S1 have "l=l1'@y#c@x#l2" by simp
     with C(3) False show ?thesis by blast
   next
     case 2 with False have False by blast
     thus ?thesis ..
   next
     case (3 c) with S1 have "l=l1@x#c@y#l2'" by simp
     with C(2) False show ?thesis by blast
   qed
 qed
     
     
 lemma list_e_eq_lel[simp]:
   "[e] = l1@e'#l2 \<longleftrightarrow> l1=[] \<and> e'=e \<and> l2=[]"
   "l1@e'#l2 = [e] \<longleftrightarrow> l1=[] \<and> e'=e \<and> l2=[]"
   apply (cases l1, auto) []
   apply (cases l1, auto) []
   done
 
 lemma list_ee_eq_leel[simp]:
   "([e1,e2] = l1@e1'#e2'#l2) \<longleftrightarrow> (l1=[] \<and> e1=e1' \<and> e2=e2' \<and> l2=[])"
   "(l1@e1'#e2'#l2 = [e1,e2]) \<longleftrightarrow> (l1=[] \<and> e1=e1' \<and> e2=e2' \<and> l2=[])"
   apply (cases l1, auto) []
   apply (cases l1, auto) []
   done
 
 
 subsubsection \<open>Transitive Closure\<close>
 
 text \<open>A point-free induction rule for elements reachable from an initial set\<close>
 lemma rtrancl_reachable_induct[consumes 0, case_names base step]:
   assumes I0: "I \<subseteq> INV"
   assumes IS: "E``INV \<subseteq> INV"
   shows "E\<^sup>*``I \<subseteq> INV"
   by (metis I0 IS Image_closed_trancl Image_mono subset_refl)
   
 
 lemma acyclic_empty[simp, intro!]: "acyclic {}" by (unfold acyclic_def) auto
 
 lemma acyclic_union:
   "acyclic (A\<union>B) \<Longrightarrow> acyclic A"
   "acyclic (A\<union>B) \<Longrightarrow> acyclic B"
   by (metis Un_upper1 Un_upper2 acyclic_subset)+
     
    
 text \<open>Here we provide a collection of miscellaneous definitions and helper lemmas\<close>
 
 subsection "Miscellaneous (1)"
 
 text \<open>This stuff is used in this theory itself, and thus occurs in first place or is simply not sorted into any other section of this theory.\<close>
 
 lemma IdD: "(a,b)\<in>Id \<Longrightarrow> a=b" by simp
 
 text \<open>Conversion Tag\<close>    
 definition [simp]: "CNV x y \<equiv> x=y"
 lemma CNV_I: "CNV x x" by simp
 lemma CNV_eqD: "CNV x y \<Longrightarrow> x=y" by simp
 lemma CNV_meqD: "CNV x y \<Longrightarrow> x\<equiv>y" by simp
    
 (* TODO: Move. Shouldn't this be detected by simproc? *)
 lemma ex_b_b_and_simp[simp]: "(\<exists>b. b \<and> Q b) \<longleftrightarrow> Q True" by auto
 lemma ex_b_not_b_and_simp[simp]: "(\<exists>b. \<not>b \<and> Q b) \<longleftrightarrow> Q False" by auto
     
 method repeat_all_new methods m = m;(repeat_all_new \<open>m\<close>)?
     
     
 subsubsection "AC-operators"
 
 text \<open>Locale to declare AC-laws as simplification rules\<close>
 locale Assoc =
   fixes f
   assumes assoc[simp]: "f (f x y) z = f x (f y z)"
 
 locale AC = Assoc +
   assumes commute[simp]: "f x y = f y x"
 
 lemma (in AC) left_commute[simp]: "f x (f y z) = f y (f x z)"
   by (simp only: assoc[symmetric]) simp
 
 lemmas (in AC) AC_simps = commute assoc left_commute
 
 text \<open>Locale to define functions from surjective, unique relations\<close>
 locale su_rel_fun =
   fixes F and f
   assumes unique: "\<lbrakk>(A,B)\<in>F; (A,B')\<in>F\<rbrakk> \<Longrightarrow> B=B'"
   assumes surjective: "\<lbrakk>!!B. (A,B)\<in>F \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   assumes f_def: "f A == THE B. (A,B)\<in>F"
 
 lemma (in su_rel_fun) repr1: "(A,f A)\<in>F" proof (unfold f_def)
   obtain B where "(A,B)\<in>F" by (rule surjective)
   with theI[where P="\<lambda>B. (A,B)\<in>F", OF this] show "(A, THE x. (A, x) \<in> F) \<in> F" by (blast intro: unique)
 qed
 
 lemma (in su_rel_fun) repr2: "(A,B)\<in>F \<Longrightarrow> B=f A" using repr1
   by (blast intro: unique)
 
 lemma (in su_rel_fun) repr: "(f A = B) = ((A,B)\<in>F)" using repr1 repr2
   by (blast)
 
     \<comment> \<open>Contract quantification over two variables to pair\<close>
 lemma Ex_prod_contract: "(\<exists>a b. P a b) \<longleftrightarrow> (\<exists>z. P (fst z) (snd z))"
   by auto
 
 lemma All_prod_contract: "(\<forall>a b. P a b) \<longleftrightarrow> (\<forall>z. P (fst z) (snd z))"
   by auto
 
 
 lemma nat_geq_1_eq_neqz: "x\<ge>1 \<longleftrightarrow> x\<noteq>(0::nat)"
   by auto
 
 lemma nat_in_between_eq:
   "(a<b \<and> b\<le>Suc a) \<longleftrightarrow> b = Suc a"
   "(a\<le>b \<and> b<Suc a) \<longleftrightarrow> b = a"
   by auto
 
 lemma Suc_n_minus_m_eq: "\<lbrakk> n\<ge>m; m>1 \<rbrakk> \<Longrightarrow> Suc (n - m) = n - (m - 1)"
   by simp
 
 lemma Suc_to_right: "Suc n = m \<Longrightarrow> n = m - Suc 0" by simp
 lemma Suc_diff[simp]: "\<And>n m. n\<ge>m \<Longrightarrow> m\<ge>1 \<Longrightarrow> Suc (n - m) = n - (m - 1)"
   by simp
 
 lemma if_not_swap[simp]: "(if \<not>c then a else b) = (if c then b else a)" by auto
 lemma all_to_meta: "Trueprop (\<forall>a. P a) \<equiv> (\<And>a. P a)"
   apply rule
   by auto
 
 lemma imp_to_meta: "Trueprop (P\<longrightarrow>Q) \<equiv> (P\<Longrightarrow>Q)"
   apply rule
   by auto
 
 
 (* for some reason, there is no such rule in HOL *)
 lemma iffI2: "\<lbrakk>P \<Longrightarrow> Q; \<not> P \<Longrightarrow> \<not> Q\<rbrakk> \<Longrightarrow> P \<longleftrightarrow> Q"
 by metis
 
 lemma iffExI:
   "\<lbrakk> \<And>x. P x \<Longrightarrow> Q x; \<And>x. Q x \<Longrightarrow> P x \<rbrakk> \<Longrightarrow> (\<exists>x. P x) \<longleftrightarrow> (\<exists>x. Q x)"
 by metis
 
 lemma bex2I[intro?]: "\<lbrakk> (a,b)\<in>S; (a,b)\<in>S \<Longrightarrow> P a b \<rbrakk> \<Longrightarrow> \<exists>a b. (a,b)\<in>S \<and> P a b"
   by blast
 
     
 (* TODO: Move lemma to HOL! *)  
 lemma cnv_conj_to_meta: "(P \<and> Q \<Longrightarrow> PROP X) \<equiv> (\<lbrakk>P;Q\<rbrakk> \<Longrightarrow> PROP X)"
   by (rule BNF_Fixpoint_Base.conj_imp_eq_imp_imp)
     
     
 
 subsection \<open>Sets\<close>
   lemma remove_subset: "x\<in>S \<Longrightarrow> S-{x} \<subset> S" by auto
 
   lemma subset_minus_empty: "A\<subseteq>B \<Longrightarrow> A-B = {}" by auto
 
   lemma insert_minus_eq: "x\<noteq>y \<Longrightarrow> insert x A - {y} = insert x (A - {y})" by auto
       
   lemma set_notEmptyE: "\<lbrakk>S\<noteq>{}; !!x. x\<in>S \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
     by (metis equals0I)
 
   lemma subset_Collect_conv: "S \<subseteq> Collect P \<longleftrightarrow> (\<forall>x\<in>S. P x)"
     by auto
 
   lemma memb_imp_not_empty: "x\<in>S \<Longrightarrow> S\<noteq>{}"
     by auto
 
   lemma disjoint_mono: "\<lbrakk> a\<subseteq>a'; b\<subseteq>b'; a'\<inter>b'={} \<rbrakk> \<Longrightarrow> a\<inter>b={}" by auto
 
   lemma disjoint_alt_simp1: "A-B = A \<longleftrightarrow> A\<inter>B = {}" by auto
   lemma disjoint_alt_simp2: "A-B \<noteq> A \<longleftrightarrow> A\<inter>B \<noteq> {}" by auto
   lemma disjoint_alt_simp3: "A-B \<subset> A \<longleftrightarrow> A\<inter>B \<noteq> {}" by auto
 
   lemma disjointI[intro?]: "\<lbrakk> \<And>x. \<lbrakk>x\<in>a; x\<in>b\<rbrakk> \<Longrightarrow> False \<rbrakk> \<Longrightarrow> a\<inter>b={}"
     by auto
 
 
   lemmas set_simps = subset_minus_empty disjoint_alt_simp1 disjoint_alt_simp2 disjoint_alt_simp3 Un_absorb1 Un_absorb2
 
   lemma set_minus_singleton_eq: "x\<notin>X \<Longrightarrow> X-{x} = X"
     by auto
 
   lemma set_diff_diff_left: "A-B-C = A-(B\<union>C)"
     by auto
 
 
   lemma image_update[simp]: "x\<notin>A \<Longrightarrow> f(x:=n)`A = f`A"
     by auto
 
   lemma eq_or_mem_image_simp[simp]: "{f l |l. l = a \<or> l\<in>B} = insert (f a) {f l|l. l\<in>B}" by blast
       
   lemma set_union_code [code_unfold]:
     "set xs \<union> set ys = set (xs @ ys)"
     by auto
 
   lemma in_fst_imageE:
     assumes "x \<in> fst`S"
     obtains y where "(x,y)\<in>S"
     using assms by auto
 
   lemma in_snd_imageE:
     assumes "y \<in> snd`S"
     obtains x where "(x,y)\<in>S"
     using assms by auto
 
   lemma fst_image_mp: "\<lbrakk>fst`A \<subseteq> B; (x,y)\<in>A \<rbrakk> \<Longrightarrow> x\<in>B"
     by (metis Domain.DomainI fst_eq_Domain in_mono)
 
   lemma snd_image_mp: "\<lbrakk>snd`A \<subseteq> B; (x,y)\<in>A \<rbrakk> \<Longrightarrow> y\<in>B"
     by (metis Range.intros rev_subsetD snd_eq_Range)
 
   lemma inter_eq_subsetI: "\<lbrakk> S\<subseteq>S'; A\<inter>S' = B\<inter>S' \<rbrakk> \<Longrightarrow> A\<inter>S = B\<inter>S"
     by auto
 
 text \<open>
   Decompose general union over sum types.
 \<close>
 lemma Union_plus:
   "(\<Union> x \<in> A <+> B. f x) = (\<Union> a \<in> A. f (Inl a)) \<union> (\<Union>b \<in> B. f (Inr b))"
 by auto
 
 lemma Union_sum:
   "(\<Union>x. f (x::'a+'b)) = (\<Union>l. f (Inl l)) \<union> (\<Union>r. f (Inr r))"
   (is "?lhs = ?rhs")
 proof -
   have "?lhs = (\<Union>x \<in> UNIV <+> UNIV. f x)"
     by simp
   thus ?thesis
     by (simp only: Union_plus)
 qed
 
   
 
 
   subsubsection \<open>Finite Sets\<close>
 
   lemma card_1_singletonI: "\<lbrakk>finite S; card S = 1; x\<in>S\<rbrakk> \<Longrightarrow> S={x}"
   proof (safe, rule ccontr, goal_cases)
     case prems: (1 x')
     hence "finite (S-{x})" "S-{x} \<noteq> {}" by auto
     hence "card (S-{x}) \<noteq> 0" by auto
     moreover from prems(1-3) have "card (S-{x}) = 0" by auto
     ultimately have False by simp
     thus ?case ..
   qed
 
   lemma card_insert_disjoint': "\<lbrakk>finite A; x \<notin> A\<rbrakk> \<Longrightarrow> card (insert x A) - Suc 0 = card A"
     by (drule (1) card_insert_disjoint) auto
 
   lemma card_eq_UNIV[simp]: "card (S::'a::finite set) = card (UNIV::'a set) \<longleftrightarrow> S=UNIV"
   proof (auto)
     fix x
     assume A: "card S = card (UNIV::'a set)"
     show "x\<in>S" proof (rule ccontr)
       assume "x\<notin>S" hence "S\<subset>UNIV" by auto
       with psubset_card_mono[of UNIV S] have "card S < card (UNIV::'a set)" by auto
       with A show False by simp
     qed
   qed
 
   lemma card_eq_UNIV2[simp]: "card (UNIV::'a set) = card (S::'a::finite set) \<longleftrightarrow> S=UNIV"
     using card_eq_UNIV[of S] by metis
 
   lemma card_ge_UNIV[simp]: "card (UNIV::'a::finite set) \<le> card (S::'a set) \<longleftrightarrow> S=UNIV"
     using card_mono[of "UNIV::'a::finite set" S, simplified]
     by auto
 
   lemmas length_remdups_card = length_remdups_concat[of "[l]", simplified] for l
 
   lemma fs_contract: "fst ` { p | p. f (fst p) (snd p) \<in> S } = { a . \<exists>b. f a b \<in> S }"
     by (simp add: image_Collect)
 
 lemma finite_Collect: "finite S \<Longrightarrow> inj f \<Longrightarrow> finite {a. f a : S}"
 by(simp add: finite_vimageI vimage_def[symmetric])
 
   \<comment> \<open>Finite sets have an injective mapping to an initial segments of the
       natural numbers\<close>
   (* This lemma is also in the standard library (from Isabelle2009-1 on)
       as @{thm [source] Finite_Set.finite_imp_inj_to_nat_seg}. However, it is formulated with HOL's
       \<exists> there rather then with the meta-logic obtain *)
   lemma finite_imp_inj_to_nat_seg':
     fixes A :: "'a set"
     assumes A: "finite A"
     obtains f::"'a \<Rightarrow> nat" and n::"nat" where
       "f`A = {i. i<n}"
       "inj_on f A"
     by (metis A finite_imp_inj_to_nat_seg)
 
   lemma lists_of_len_fin1: "finite P \<Longrightarrow> finite (lists P \<inter> { l. length l = n })"
   proof (induct n)
     case 0 thus ?case by auto
   next
     case (Suc n)
     have "lists P \<inter> { l. length l = Suc n }
           = (\<lambda>(a,l). a#l) ` (P \<times> (lists P \<inter> {l. length l = n}))"
       apply auto
       apply (case_tac x)
       apply auto
       done
     moreover from Suc have "finite \<dots>" by auto
     ultimately show ?case by simp
   qed
 
   lemma lists_of_len_fin2: "finite P \<Longrightarrow> finite (lists P \<inter> { l. n = length l })"
   proof -
     assume A: "finite P"
     have S: "{ l. n = length l } = { l. length l = n }" by auto
     have "finite (lists P \<inter> { l. n = length l })
       \<longleftrightarrow> finite (lists P \<inter> { l. length l = n })"
       by (subst S) simp
 
     thus ?thesis using lists_of_len_fin1[OF A] by auto
   qed
 
   lemmas lists_of_len_fin = lists_of_len_fin1 lists_of_len_fin2
 
 
   (* Try (simp only: cset_fin_simps, fastforce intro: cset_fin_intros) when reasoning about finiteness of collected sets *)
   lemmas cset_fin_simps = Ex_prod_contract fs_contract[symmetric] image_Collect[symmetric]
   lemmas cset_fin_intros = finite_imageI finite_Collect inj_onI
 
 
 lemma Un_interval:
   fixes b1 :: "'a::linorder"
   assumes "b1\<le>b2" and "b2\<le>b3"
   shows "{ f i | i. b1\<le>i \<and> i<b2 } \<union> { f i | i. b2\<le>i \<and> i<b3 }
     = {f i | i. b1\<le>i \<and> i<b3}"
   using assms
   apply -
   apply rule
   apply safe []
   apply (rule_tac x=i in exI, auto) []
   apply (rule_tac x=i in exI, auto) []
   apply rule
   apply simp
   apply (elim exE, simp)
   apply (case_tac "i<b2")
   apply (rule disjI1)
   apply (rule_tac x=i in exI, auto) []
   apply (rule disjI2)
   apply (rule_tac x=i in exI, auto) []
   done
 
 text \<open>
   The standard library proves that a generalized union is finite
   if the index set is finite and if for every index the component
   set is itself finite. Conversely, we show that every component
   set must be finite when the union is finite.
 \<close>
 lemma finite_UNION_then_finite:
   "finite (\<Union>(B ` A)) \<Longrightarrow> a \<in> A \<Longrightarrow> finite (B a)"
 by (metis Set.set_insert UN_insert Un_infinite)
 
 lemma finite_if_eq_beyond_finite: "finite S \<Longrightarrow> finite {s. s - S = s' - S}"
 proof (rule finite_subset[where B="(\<lambda>s. s \<union> (s' - S)) ` Pow S"], clarsimp)
   fix s
   have "s = (s \<inter> S) \<union> (s - S)"
     by auto
   also assume "s - S = s' - S"
   finally show "s \<in> (\<lambda>s. s \<union> (s' - S)) ` Pow S" by blast
 qed blast
 
 lemma distinct_finite_subset:
   assumes "finite x"
   shows "finite {ys. set ys \<subseteq> x \<and> distinct ys}" (is "finite ?S")
 proof (rule finite_subset)
   from assms show "?S \<subseteq> {ys. set ys \<subseteq> x \<and> length ys \<le> card x}"
     by clarsimp (metis distinct_card card_mono)
   from assms show "finite ..." by (rule finite_lists_length_le)
 qed
 
 lemma distinct_finite_set:
   shows "finite {ys. set ys = x \<and> distinct ys}" (is "finite ?S")
 proof (cases "finite x")
   case False hence "{ys. set ys = x} = {}" by auto
   thus ?thesis by simp
 next
   case True show ?thesis
   proof (rule finite_subset)
     show "?S \<subseteq> {ys. set ys \<subseteq> x \<and> length ys \<le> card x}"
       using distinct_card by force
     from True show "finite ..." by (rule finite_lists_length_le)
   qed
 qed
 
 lemma finite_set_image:
   assumes f: "finite (set ` A)"
   and dist: "\<And>xs. xs \<in> A \<Longrightarrow> distinct xs"
   shows "finite A"
 proof (rule finite_subset)
   from f show "finite (set -` (set ` A) \<inter> {xs. distinct xs})"
   proof (induct rule: finite_induct)
     case (insert x F)
     have "finite (set -` {x} \<inter> {xs. distinct xs})"
       apply (simp add: vimage_def)
       by (metis Collect_conj_eq distinct_finite_set)
     with insert show ?case
       apply (subst vimage_insert)
       apply (subst Int_Un_distrib2)
       apply (rule finite_UnI)
         apply simp_all
       done
   qed simp
   moreover from dist show "A \<subseteq> ..."
     by (auto simp add: vimage_image_eq)
 qed
 
 
 subsubsection \<open>Infinite Set\<close>
 lemma INFM_nat_inductI:
   assumes P0: "P (0::nat)"
   assumes PS: "\<And>i. P i \<Longrightarrow> \<exists>j>i. P j \<and> Q j"
   shows "\<exists>\<^sub>\<infinity>i. Q i"
 proof -
   have "\<forall>i. \<exists>j>i. P j \<and> Q j" proof
     fix i
     show "\<exists>j>i. P j \<and> Q j"
       apply (induction i)
       using PS[OF P0] apply auto []
       by (metis PS Suc_lessI)
   qed
   thus ?thesis unfolding INFM_nat by blast
 qed
 
 subsection \<open>Functions\<close>
 
 lemma fun_neq_ext_iff: "m\<noteq>m' \<longleftrightarrow> (\<exists>x. m x \<noteq> m' x)" by auto  
 
 definition "inv_on f A x == SOME y. y\<in>A \<and> f y = x"
 
 lemma inv_on_f_f[simp]: "\<lbrakk>inj_on f A; x\<in>A\<rbrakk> \<Longrightarrow> inv_on f A (f x) = x"
   by (auto simp add: inv_on_def inj_on_def)
 
 lemma f_inv_on_f: "\<lbrakk> y\<in>f`A \<rbrakk> \<Longrightarrow> f (inv_on f A y) = y"
   by (auto simp add: inv_on_def intro: someI2)
 
 lemma inv_on_f_range: "\<lbrakk> y \<in> f`A \<rbrakk> \<Longrightarrow> inv_on f A y \<in> A"
   by (auto simp add: inv_on_def intro: someI2)
 
 lemma inj_on_map_inv_f [simp]: "\<lbrakk>set l \<subseteq> A; inj_on f A\<rbrakk> \<Longrightarrow> map (inv_on f A) (map f l) = l"
   apply (simp)
   apply (induct l)
   apply auto
   done
 
 lemma comp_cong_right: "x = y \<Longrightarrow> f o x = f o y" by (simp)
 lemma comp_cong_left: "x = y \<Longrightarrow> x o f = y o f" by (simp)
 
 lemma fun_comp_eq_conv: "f o g = fg \<longleftrightarrow> (\<forall>x. f (g x) = fg x)"
   by auto
 
 abbreviation comp2 (infixl "oo" 55) where "f oo g \<equiv> \<lambda>x. f o (g x)"
 abbreviation comp3 (infixl "ooo" 55) where "f ooo g \<equiv> \<lambda>x. f oo (g x)"
 
 notation
   comp2  (infixl "\<circ>\<circ>" 55) and
   comp3  (infixl "\<circ>\<circ>\<circ>" 55)
 
 definition [code_unfold, simp]: "swap_args2 f x y \<equiv> f y x"
   
 
 subsection \<open>Multisets\<close>
 
 (*
   The following is a syntax extension for multisets. Unfortunately, it depends on a change in the Library/Multiset.thy, so it is commented out here, until it will be incorporated
   into Library/Multiset.thy by its maintainers.
 
   The required change in Library/Multiset.thy is removing the syntax for single:
      - single :: "'a => 'a multiset"    ("{#_#}")
      + single :: "'a => 'a multiset"
 
   And adding the following translations instead:
 
      + syntax
      + "_multiset" :: "args \<Rightarrow> 'a multiset" ("{#(_)#}")
 
      + translations
      +   "{#x, xs#}" == "{#x#} + {#xs#}"
      +   "{# x #}" == "single x"
 
   This translates "{# \<dots> #}" into a sum of singletons, that is parenthesized to the right. ?? Can we also achieve left-parenthesizing ??
 
 *)
 
 
   (* Let's try what happens if declaring AC-rules for multiset union as simp-rules *)
 (*declare union_ac[simp] -- don't do it !*)
 
 
 lemma count_mset_set_finite_iff:
   "finite S \<Longrightarrow> count (mset_set S) a = (if a \<in> S then 1 else 0)"
   by simp
 
 lemma ex_Melem_conv: "(\<exists>x. x \<in># A) = (A \<noteq> {#})"
   by (simp add: ex_in_conv)
 
 subsubsection \<open>Count\<close>
         lemma count_ne_remove: "\<lbrakk> x ~= t\<rbrakk> \<Longrightarrow> count S x = count (S-{#t#}) x"
           by (auto)
   lemma mset_empty_count[simp]: "(\<forall>p. count M p = 0) = (M={#})"
     by (auto simp add: multiset_eq_iff)
 
 subsubsection \<open>Union, difference and intersection\<close>
 
   lemma size_diff_se: "t \<in># S \<Longrightarrow> size S = size (S - {#t#}) + 1" proof (unfold size_multiset_overloaded_eq)
                 let ?SIZE = "sum (count S) (set_mset S)"
                 assume A: "t \<in># S"
                 from A have SPLITPRE: "finite (set_mset S) & {t}\<subseteq>(set_mset S)" by auto
                 hence "?SIZE = sum (count S) (set_mset S - {t}) + sum (count S) {t}" by (blast dest: sum.subset_diff)
                 hence "?SIZE = sum (count S) (set_mset S - {t}) + count (S) t" by auto
                 moreover with A have "count S t = count (S-{#t#}) t + 1" by auto
                 ultimately have D: "?SIZE = sum (count S) (set_mset S - {t}) + count (S-{#t#}) t + 1" by (arith)
                 moreover have "sum (count S) (set_mset S - {t}) = sum (count (S-{#t#})) (set_mset S - {t})" proof -
                         have "\<forall>x\<in>(set_mset S - {t}). count S x = count (S-{#t#}) x" by (auto iff add: count_ne_remove)
                         thus ?thesis by simp
                 qed
                 ultimately have D: "?SIZE = sum (count (S-{#t#})) (set_mset S - {t}) + count (S-{#t#}) t + 1" by (simp)
                 moreover
                 { assume CASE: "t \<notin># S - {#t#}"
                         from CASE have "set_mset S - {t} = set_mset (S - {#t#})"
                           by (auto simp add: in_diff_count split: if_splits)
                         with CASE D have "?SIZE = sum (count (S-{#t#})) (set_mset (S - {#t#})) + 1"
                           by (simp add: not_in_iff)
                 }
                 moreover
                 { assume CASE: "t \<in># S - {#t#}"
                         from CASE have "t \<in># S" by (rule in_diffD)
                         with CASE have 1: "set_mset S = set_mset (S-{#t#})"
                           by (auto simp add: in_diff_count split: if_splits)
                         moreover from D have "?SIZE = sum (count (S-{#t#})) (set_mset S - {t}) + sum (count (S-{#t#})) {t} + 1" by simp
                         moreover from SPLITPRE sum.subset_diff have "sum (count (S-{#t#})) (set_mset S) = sum (count (S-{#t#})) (set_mset S - {t}) + sum (count (S-{#t#})) {t}" by (blast)
                         ultimately have "?SIZE = sum (count (S-{#t#})) (set_mset (S-{#t#})) + 1" by simp
                 }
                 ultimately show "?SIZE = sum (count (S-{#t#})) (set_mset (S - {#t#})) + 1" by blast
         qed
 
   (* TODO: Check whether this proof can be done simpler *)
   lemma mset_union_diff_comm: "t \<in># S \<Longrightarrow> T + (S - {#t#}) = (T + S) - {#t#}" proof -
     assume "t \<in># S"
     then obtain S' where S: "S = add_mset t S'"
       by (metis insert_DiffM)
     then show ?thesis
       by auto
   qed
 
 (*  lemma mset_diff_diff_left: "A-B-C = A-((B::'a multiset)+C)" proof -
     have "\<forall>e . count (A-B-C) e = count (A-(B+C)) e" by auto
     thus ?thesis by (simp add: multiset_eq_conv_count_eq)
   qed
 
   lemma mset_diff_commute: "A-B-C = A-C-(B::'a multiset)" proof -
     have "A-B-C = A-(B+C)" by (simp add: mset_diff_diff_left)
     also have "\<dots> = A-(C+B)" by (simp add: union_commute)
     thus ?thesis by (simp add: mset_diff_diff_left)
   qed
 
   lemma mset_diff_same_empty[simp]: "(S::'a multiset) - S = {#}"
   proof -
     have "\<forall>e . count (S-S) e = 0" by auto
     hence "\<forall>e . ~ (e : set_mset (S-S))" by auto
     hence "set_mset (S-S) = {}" by blast
     thus ?thesis by (auto)
   qed
 *)
     
   lemma mset_right_cancel_union: "\<lbrakk>a \<in># A+B; ~(a \<in># B)\<rbrakk> \<Longrightarrow> a\<in>#A"
     by (simp)
   lemma mset_left_cancel_union: "\<lbrakk>a \<in># A+B; ~(a \<in># A)\<rbrakk> \<Longrightarrow> a\<in>#B"
     by (simp)
 
   lemmas mset_cancel_union = mset_right_cancel_union mset_left_cancel_union
 
   lemma mset_right_cancel_elem: "\<lbrakk>a \<in># A+{#b#}; a~=b\<rbrakk> \<Longrightarrow> a\<in>#A"
     by simp
 
   lemma mset_left_cancel_elem: "\<lbrakk>a \<in># {#b#}+A; a~=b\<rbrakk> \<Longrightarrow> a\<in>#A"
     by simp
 
   lemmas mset_cancel_elem = mset_right_cancel_elem mset_left_cancel_elem
 
   lemma mset_diff_cancel1elem[simp]: "~(a \<in># B) \<Longrightarrow> {#a#}-B = {#a#}"
     by (auto simp add: not_in_iff intro!: multiset_eqI)
 
 (*  lemma diff_union_inverse[simp]: "A + B - B = (A::'a multiset)"
     by (auto iff add: multiset_eq_conv_count_eq)
 
   lemma diff_union_inverse2[simp]: "B + A - B = (A::'a multiset)"
     by (auto iff add: multiset_eq_conv_count_eq)
 *)
   (*lemma union_diff_assoc_se2: "t \<in># A \<Longrightarrow> (A+B)-{#t#} = (A-{#t#}) + B"
     by (auto iff add: multiset_eq_conv_count_eq)
   lemmas union_diff_assoc_se = union_diff_assoc_se1 union_diff_assoc_se2*)
 
         lemma union_diff_assoc: "C-B={#} \<Longrightarrow> (A+B)-C = A + (B-C)"
           by (simp add: multiset_eq_iff)
 
   lemmas mset_neutral_cancel1 = union_left_cancel[where N="{#}", simplified] union_right_cancel[where N="{#}", simplified]
   declare mset_neutral_cancel1[simp]
 
   lemma mset_union_2_elem: "{#a, b#} = add_mset c M \<Longrightarrow> {#a#}=M & b=c | a=c & {#b#}=M"
     by (auto simp: add_eq_conv_diff)
 
   lemma mset_un_cases[cases set, case_names left right]:
     "\<lbrakk>a \<in># A + B; a \<in># A \<Longrightarrow> P; a \<in># B \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
     by (auto)
 
   lemma mset_unplusm_dist_cases[cases set, case_names left right]:
     assumes A: "{#s#}+A = B+C"
     assumes L: "\<lbrakk>B={#s#}+(B-{#s#}); A=(B-{#s#})+C\<rbrakk> \<Longrightarrow> P"
     assumes R: "\<lbrakk>C={#s#}+(C-{#s#}); A=B+(C-{#s#})\<rbrakk> \<Longrightarrow> P"
     shows P
   proof -
     from A[symmetric] have "s \<in># B+C" by simp
     thus ?thesis proof (cases rule: mset_un_cases)
       case left hence 1: "B={#s#}+(B-{#s#})" by simp
       with A have "{#s#}+A = {#s#}+((B-{#s#})+C)" by (simp add: union_ac)
       hence 2: "A = (B-{#s#})+C" by (simp)
       from L[OF 1 2] show ?thesis .
     next
       case right hence 1: "C={#s#}+(C-{#s#})" by simp
       with A have "{#s#}+A = {#s#}+(B+(C-{#s#}))" by (simp add: union_ac)
       hence 2: "A = B+(C-{#s#})" by (simp)
       from R[OF 1 2] show ?thesis .
     qed
   qed
 
   lemma mset_unplusm_dist_cases2[cases set, case_names left right]:
     assumes A: "B+C = {#s#}+A"
     assumes L: "\<lbrakk>B={#s#}+(B-{#s#}); A=(B-{#s#})+C\<rbrakk> \<Longrightarrow> P"
     assumes R: "\<lbrakk>C={#s#}+(C-{#s#}); A=B+(C-{#s#})\<rbrakk> \<Longrightarrow> P"
     shows P
     using mset_unplusm_dist_cases[OF A[symmetric]] L R by blast
 
   lemma mset_single_cases[cases set, case_names loc env]:
     assumes A: "add_mset s c = add_mset r' c'"
     assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "\<lbrakk>c'={#s#}+(c'-{#s#}); c={#r'#}+(c-{#r'#}); c-{#r'#} = c'-{#s#} \<rbrakk> \<Longrightarrow> P"
     shows "P"
   proof -
     { assume CASE: "s=r'"
       with A have "c=c'" by simp
       with CASE CASES have ?thesis by auto
     } moreover {
       assume CASE: "s\<noteq>r'"
       have "s \<in># {#s#}+c" by simp
       with A have "s \<in># {#r'#}+c'" by simp
       with CASE have "s \<in># c'" by simp
       hence 1: "c' = {#s#} + (c' - {#s#})" by simp
       with A have "{#s#}+c = {#s#}+({#r'#}+(c' - {#s#}))" by (auto simp add: union_ac)
       hence 2: "c={#r'#}+(c' - {#s#})" by (auto)
       hence 3: "c-{#r'#} = (c' - {#s#})" by auto
       from 1 2 3 CASES have ?thesis by auto
     } ultimately show ?thesis by blast
   qed
 
   lemma mset_single_cases'[cases set, case_names loc env]:
     assumes A: "add_mset s c = add_mset r' c'"
     assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "!!cc. \<lbrakk>c'={#s#}+cc; c={#r'#}+cc; c'-{#s#}=cc; c-{#r'#}=cc\<rbrakk> \<Longrightarrow> P"
     shows "P"
     using A  CASES by (auto elim!: mset_single_cases)
 
   lemma mset_single_cases2[cases set, case_names loc env]:
     assumes A: "add_mset s c = add_mset r' c'"
     assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "\<lbrakk>c'=(c'-{#s#})+{#s#}; c=(c-{#r'#})+{#r'#}; c-{#r'#} = c'-{#s#} \<rbrakk> \<Longrightarrow> P"
     shows "P"
   proof -
     from A have "add_mset s c = add_mset r' c'" by (simp add: union_ac)
     thus ?thesis using CASES by (cases rule: mset_single_cases) simp_all
   qed
 
   lemma mset_single_cases2'[cases set, case_names loc env]:
     assumes A: "add_mset s c = add_mset r' c'"
     assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "!!cc. \<lbrakk>c'=cc+{#s#}; c=cc+{#r'#}; c'-{#s#}=cc; c-{#r'#}=cc\<rbrakk> \<Longrightarrow> P"
     shows "P"
     using A  CASES by (auto elim!: mset_single_cases2)
 
   lemma mset_un_single_un_cases [consumes 1, case_names left right]:
     assumes A: "add_mset a A = B + C"
       and CASES: "a \<in># B \<Longrightarrow> A = (B - {#a#}) + C \<Longrightarrow> P"
         "a \<in># C \<Longrightarrow> A = B + (C - {#a#}) \<Longrightarrow> P" shows "P"
   proof -
     have "a \<in># A+{#a#}" by simp
     with A have "a \<in># B+C" by auto
     thus ?thesis proof (cases rule: mset_un_cases)
       case left hence "B=B-{#a#}+{#a#}" by auto
       with A have "A+{#a#} = (B-{#a#})+C+{#a#}" by (auto simp add: union_ac)
       hence "A=(B-{#a#})+C" by simp
       with CASES(1)[OF left] show ?thesis by blast
     next
       case right hence "C=C-{#a#}+{#a#}" by auto
       with A have "A+{#a#} = B+(C-{#a#})+{#a#}" by (auto simp add: union_ac)
       hence "A=B+(C-{#a#})" by simp
       with CASES(2)[OF right] show ?thesis by blast
     qed
   qed
 
       (* TODO: Can this proof be done more automatically ? *)
   lemma mset_distrib[consumes 1, case_names dist]: assumes A: "(A::'a multiset)+B = M+N" "!!Am An Bm Bn. \<lbrakk>A=Am+An; B=Bm+Bn; M=Am+Bm; N=An+Bn\<rbrakk> \<Longrightarrow> P" shows "P"
   proof -
     have BN_MA: "B - N = M - A"
       by (metis (no_types) add_diff_cancel_right assms(1) union_commute)
     have H: "A = A\<inter># C + (A - C) \<inter># D" if "A + B = C + D" for A B C D :: "'a multiset"
       by (metis add.commute diff_intersect_left_idem mset_subset_eq_add_left subset_eq_diff_conv
           subset_mset.add_diff_inverse subset_mset.inf_absorb1 subset_mset.inf_le1 that)
     have A': "A = A\<inter># M + (A - M) \<inter># N"
       using A(1) H by blast
     moreover have B': "B = (B - N) \<inter># M + B\<inter># N"
       using A(1) H[of B A N M] by (auto simp: ac_simps)
     moreover have "M = A \<inter># M + (B - N) \<inter># M"
       using H[of M N A B] BN_MA[symmetric] A(1) by (metis (no_types) diff_intersect_left_idem
           diff_union_cancelR multiset_inter_commute subset_mset.diff_add subset_mset.inf.cobounded1
           union_commute)
     moreover have "N = (A - M) \<inter># N + B \<inter># N"
       by (metis A' assms(1) diff_union_cancelL inter_union_distrib_left inter_union_distrib_right
           mset_subset_eq_multiset_union_diff_commute subset_mset.inf.cobounded1 subset_mset.inf.commute)
     ultimately show P
       using A(2) by blast
   qed
 
 
 subsubsection \<open>Singleton multisets\<close>
 
 lemma mset_size_le1_cases[case_names empty singleton,consumes 1]: "\<lbrakk> size M \<le> Suc 0; M={#} \<Longrightarrow> P; !!m. M={#m#} \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
   by (cases M) auto
 
 lemma diff_union_single_conv2: "a \<in># J \<Longrightarrow> J + I - {#a#} = (J - {#a#}) + I"
   by simp
 
 lemmas diff_union_single_convs = diff_union_single_conv diff_union_single_conv2
 
 lemma mset_contains_eq: "(m \<in># M) = ({#m#}+(M-{#m#})=M)"
   using diff_single_trivial by fastforce
 
 
 subsubsection \<open>Pointwise ordering\<close>
 
 
   (*declare mset_le_trans[trans] Seems to be in there now. Why is this not done in Multiset.thy or order-class ? *)
 
   lemma mset_le_incr_right1: "a\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#b+c" using mset_subset_eq_mono_add[of a b "{#}" c, simplified] .
   lemma mset_le_incr_right2: "a\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#c+b" using mset_le_incr_right1
     by (auto simp add: union_commute)
   lemmas mset_le_incr_right = mset_le_incr_right1 mset_le_incr_right2
 
   lemma mset_le_decr_left1: "a+c\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#b" using mset_le_incr_right1 mset_subset_eq_mono_add_right_cancel
     by blast
   lemma mset_le_decr_left2: "c+a\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#b" using mset_le_decr_left1
     by (auto simp add: union_ac)
   lemma mset_le_add_mset_decr_left1: "add_mset c a\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#b"
     by (simp add: mset_subset_eq_insertD subset_mset.dual_order.strict_implies_order)
   lemma mset_le_add_mset_decr_left2: "add_mset c a\<subseteq>#(b::'a multiset) \<Longrightarrow> {#c#}\<subseteq>#b"
     by (simp add: mset_subset_eq_insertD subset_mset.dual_order.strict_implies_order)
 
   lemmas mset_le_decr_left = mset_le_decr_left1 mset_le_decr_left2 mset_le_add_mset_decr_left1
     mset_le_add_mset_decr_left2
 
   lemma mset_le_subtract: "A\<subseteq>#B \<Longrightarrow> A-C \<subseteq># B-(C::'a multiset)"
     apply (unfold subseteq_mset_def count_diff)
     apply clarify
     apply (subgoal_tac "count A a \<le> count B a")
     apply arith
     apply simp
     done
 
   lemma mset_union_subset: "A+B \<subseteq># C \<Longrightarrow> A\<subseteq>#C \<and> B\<subseteq>#(C::'a multiset)"
     by (auto dest: mset_le_decr_left)
 
   lemma mset_le_add_mset: "add_mset x B \<subseteq># C \<Longrightarrow> {#x#}\<subseteq>#C \<and> B\<subseteq>#(C::'a multiset)"
     by (auto dest: mset_le_decr_left)
 
   lemma mset_le_subtract_left: "A+B \<subseteq># (X::'a multiset) \<Longrightarrow> B \<subseteq># X-A \<and> A\<subseteq>#X"
     by (auto dest: mset_le_subtract[of "A+B" "X" "A"] mset_union_subset)
   lemma mset_le_subtract_right: "A+B \<subseteq># (X::'a multiset) \<Longrightarrow> A \<subseteq># X-B \<and> B\<subseteq>#X"
     by (auto dest: mset_le_subtract[of "A+B" "X" "B"] mset_union_subset)
 
   lemma mset_le_subtract_add_mset_left: "add_mset x B \<subseteq># (X::'a multiset) \<Longrightarrow> B \<subseteq># X-{#x#} \<and> {#x#}\<subseteq>#X"
     by (auto dest: mset_le_subtract[of "add_mset x B" "X" "{#x#}"] mset_le_add_mset)
 
   lemma mset_le_subtract_add_mset_right: "add_mset x B \<subseteq># (X::'a multiset) \<Longrightarrow> {#x#} \<subseteq># X-B \<and> B\<subseteq>#X"
     by (auto dest: mset_le_subtract[of "add_mset x B" "X" "B"] mset_le_add_mset)
 
   lemma mset_le_addE: "\<lbrakk> xs \<subseteq># (ys::'a multiset); !!zs. ys=xs+zs \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P" using mset_subset_eq_exists_conv
     by blast
 
   declare subset_mset.diff_add[simp, intro]
 
   lemma mset_2dist2_cases:
     assumes A: "{#a#}+{#b#} \<subseteq># A+B"
     assumes CASES: "{#a#}+{#b#} \<subseteq># A \<Longrightarrow> P" "{#a#}+{#b#} \<subseteq># B \<Longrightarrow> P" "\<lbrakk>a \<in># A; b \<in># B\<rbrakk> \<Longrightarrow> P" "\<lbrakk>a \<in># B; b \<in># A\<rbrakk> \<Longrightarrow> P"
     shows "P"
   proof -
     { assume C: "a \<in># A" "b \<in># A-{#a#}"
       with mset_subset_eq_mono_add[of "{#a#}" "{#a#}" "{#b#}" "A-{#a#}"] have "{#a#}+{#b#} \<subseteq># A" by auto
     } moreover {
       assume C: "a \<in># A" "\<not> (b \<in># A-{#a#})"
       with A have "b \<in># B"
         by (metis diff_union_single_conv2 mset_le_subtract_left mset_subset_eq_insertD mset_un_cases)
     } moreover {
       assume C: "\<not> (a \<in># A)" "b \<in># B-{#a#}"
       with A have "a \<in># B"
         by (auto dest: mset_subset_eqD)
        with C mset_subset_eq_mono_add[of "{#a#}" "{#a#}" "{#b#}" "B-{#a#}"] have "{#a#}+{#b#} \<subseteq># B" by auto
     } moreover {
       assume C: "\<not> (a \<in># A)" "\<not> (b \<in># B-{#a#})"
       with A have "a \<in># B \<and> b \<in># A"
         apply (intro conjI)
          apply (auto dest!: mset_subset_eq_insertD simp: insert_union_subset_iff; fail)[]
         by (metis mset_diff_cancel1elem mset_le_subtract_left multiset_diff_union_assoc
             single_subset_iff subset_eq_diff_conv)
     } ultimately show P using CASES by blast
   qed
 
 
   lemma mset_union_subset_s: "{#a#}+B \<subseteq># C \<Longrightarrow> a \<in># C \<and> B \<subseteq># C"
     by (drule mset_union_subset) simp
 
   (* TODO: Check which of these lemmas are already introduced by order-classes ! *)
 
 
   lemma mset_le_single_cases[consumes 1, case_names empty singleton]: "\<lbrakk>M\<subseteq>#{#a#}; M={#} \<Longrightarrow> P; M={#a#} \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
     by (induct M) auto
 
   lemma mset_le_distrib[consumes 1, case_names dist]: "\<lbrakk>(X::'a multiset)\<subseteq>#A+B; !!Xa Xb. \<lbrakk>X=Xa+Xb; Xa\<subseteq>#A; Xb\<subseteq>#B\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (auto elim!: mset_le_addE mset_distrib)
 
 lemma mset_le_mono_add_single: "\<lbrakk>a \<in># ys; b \<in># ws\<rbrakk> \<Longrightarrow> {#a#} + {#b#} \<subseteq># ys + ws"
   by (meson mset_subset_eq_mono_add single_subset_iff)
 
   lemma mset_size1elem: "\<lbrakk>size P \<le> 1; q \<in># P\<rbrakk> \<Longrightarrow> P={#q#}"
     by (auto elim: mset_size_le1_cases)
   lemma mset_size2elem: "\<lbrakk>size P \<le> 2; {#q#}+{#q'#} \<subseteq># P\<rbrakk> \<Longrightarrow> P={#q#}+{#q'#}"
     by (auto elim: mset_le_addE)
 
 
 subsubsection \<open>Image under function\<close>
 
 notation image_mset (infixr "`#" 90)
 
 lemma mset_map_split_orig: "!!M1 M2. \<lbrakk>f `# P = M1+M2; !!P1 P2. \<lbrakk>P=P1+P2; f `# P1 = M1; f `# P2 = M2\<rbrakk> \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
   by (induct P) (force elim!: mset_un_single_un_cases)+
 
 lemma mset_map_id: "\<lbrakk>!!x. f (g x) = x\<rbrakk> \<Longrightarrow> f `# g `# X = X"
   by (induct X) auto
 
 text \<open>The following is a very specialized lemma. Intuitively, it splits the original multiset
   by a splitting of some pointwise supermultiset of its image.
 
   Application:
   This lemma came in handy when proving the correctness of a constraint system that collects at most k sized submultisets of the sets of spawned threads.
 \<close>
 lemma mset_map_split_orig_le: assumes A: "f `# P \<subseteq># M1+M2" and EX: "!!P1 P2. \<lbrakk>P=P1+P2; f `# P1 \<subseteq># M1; f `# P2 \<subseteq># M2\<rbrakk> \<Longrightarrow> Q" shows "Q"
   using A EX by (auto elim: mset_le_distrib mset_map_split_orig)
 
 
 subsection \<open>Lists\<close>
 
 
 lemma len_greater_imp_nonempty[simp]: "length l > x \<Longrightarrow> l\<noteq>[]"
   by auto
 
 lemma list_take_induct_tl2:
   "\<lbrakk>length xs = length ys; \<forall>n<length xs. P (ys ! n) (xs ! n)\<rbrakk>
     \<Longrightarrow> \<forall>n < length (tl xs). P ((tl ys) ! n) ((tl xs) ! n)"
 by (induct xs ys rule: list_induct2) auto
 
 lemma not_distinct_split_distinct:
   assumes "\<not> distinct xs"
   obtains y ys zs where "distinct ys" "y \<in> set ys" "xs = ys@[y]@zs"
 using assms
 proof (induct xs rule: rev_induct)
   case Nil thus ?case by simp
 next
   case (snoc x xs) thus ?case by (cases "distinct xs") auto
 qed
 
 lemma distinct_length_le:
   assumes d: "distinct ys"
   and eq: "set ys = set xs"
   shows "length ys \<le> length xs"
 proof -
   from d have "length ys = card (set ys)" by (simp add: distinct_card)
   also from eq List.card_set have "card (set ys) = length (remdups xs)" by simp
   also have "... \<le> length xs" by simp
   finally show ?thesis .
 qed
 
 lemma find_SomeD:
   "List.find P xs = Some x \<Longrightarrow> P x"
   "List.find P xs = Some x \<Longrightarrow> x\<in>set xs"
   by (auto simp add: find_Some_iff)
 
 lemma in_hd_or_tl_conv[simp]: "l\<noteq>[] \<Longrightarrow> x=hd l \<or> x\<in>set (tl l) \<longleftrightarrow> x\<in>set l"
   by (cases l) auto
 
 lemma length_dropWhile_takeWhile:
   assumes "x < length (dropWhile P xs)"
   shows "x + length (takeWhile P xs) < length xs"
   using assms
   by (induct xs) auto
 
 text \<open>Elim-version of @{thm neq_Nil_conv}.\<close>  
 lemma neq_NilE: 
   assumes "l\<noteq>[]"
   obtains x xs where "l=x#xs" 
   using assms by (metis list.exhaust)
 
     
 lemma length_Suc_rev_conv: "length xs = Suc n \<longleftrightarrow> (\<exists>ys y. xs=ys@[y] \<and> length ys = n)"
   by (cases xs rule: rev_cases) auto
 
     
 subsubsection \<open>List Destructors\<close>
 lemma not_hd_in_tl:
   "x \<noteq> hd xs \<Longrightarrow> x \<in> set xs \<Longrightarrow> x \<in> set (tl xs)"
 by (induct xs) simp_all
 
 lemma distinct_hd_tl:
   "distinct xs \<Longrightarrow> x = hd xs \<Longrightarrow> x \<notin> set (tl (xs))"
 by (induct xs) simp_all
 
 lemma in_set_tlD: "x \<in> set (tl xs) \<Longrightarrow> x \<in> set xs"
 by (induct xs) simp_all
 
 lemma nth_tl: "xs \<noteq> [] \<Longrightarrow> tl xs ! n = xs ! Suc n"
 by (induct xs) simp_all
 
 lemma tl_subset:
   "xs \<noteq> [] \<Longrightarrow> set xs \<subseteq> A \<Longrightarrow> set (tl xs) \<subseteq> A"
 by (metis in_set_tlD rev_subsetD subsetI)
 
 lemma tl_last:
   "tl xs \<noteq> [] \<Longrightarrow> last xs = last (tl xs)"
 by (induct xs) simp_all
 
 lemma tl_obtain_elem:
   assumes "xs \<noteq> []" "tl xs = []"
   obtains e where "xs = [e]"
 using assms
 by (induct xs rule: list_nonempty_induct) simp_all
 
 lemma butlast_subset:
   "xs \<noteq> [] \<Longrightarrow> set xs \<subseteq> A \<Longrightarrow> set (butlast xs) \<subseteq> A"
 by (metis in_set_butlastD rev_subsetD subsetI)
 
 lemma butlast_rev_tl:
   "xs \<noteq> [] \<Longrightarrow> butlast (rev xs) = rev (tl xs)"
 by (induct xs rule: rev_induct) simp_all
 
 lemma hd_butlast:
   "length xs > 1 \<Longrightarrow> hd (butlast xs) = hd xs"
 by (induct xs) simp_all
 
 lemma butlast_upd_last_eq[simp]: "length l \<ge> 2 \<Longrightarrow>
   (butlast l) [ length l - 2 := x ] = take (length l - 2) l @ [x]"
   apply (case_tac l rule: rev_cases)
   apply simp
   apply simp
   apply (case_tac ys rule: rev_cases)
   apply simp
   apply simp
   done
 
 lemma distinct_butlast_swap[simp]: 
   "distinct pq \<Longrightarrow> distinct (butlast (pq[i := last pq]))"
   apply (cases pq rule: rev_cases)
   apply (auto simp: list_update_append distinct_list_update split: nat.split)
   done
 
 subsubsection \<open>Splitting list according to structure of other list\<close>
 context begin
 private definition "SPLIT_ACCORDING m l \<equiv> length l = length m"
 
 private lemma SPLIT_ACCORDINGE: 
   assumes "length m = length l"
   obtains "SPLIT_ACCORDING m l"
   unfolding SPLIT_ACCORDING_def using assms by auto
 
 private lemma SPLIT_ACCORDING_simp:
   "SPLIT_ACCORDING m (l1@l2) \<longleftrightarrow> (\<exists>m1 m2. m=m1@m2 \<and> SPLIT_ACCORDING m1 l1 \<and> SPLIT_ACCORDING m2 l2)"
   "SPLIT_ACCORDING m (x#l') \<longleftrightarrow> (\<exists>y m'. m=y#m' \<and> SPLIT_ACCORDING m' l')"
   apply (fastforce simp: SPLIT_ACCORDING_def intro: exI[where x = "take (length l1) m"] exI[where x = "drop (length l1) m"])
   apply (cases m;auto simp: SPLIT_ACCORDING_def)
   done
 
 text \<open>Split structure of list @{term m} according to structure of list @{term l}.\<close>
 method split_list_according for m :: "'a list" and l :: "'b list" =
   (rule SPLIT_ACCORDINGE[of m l],
     (simp; fail),
     ( simp only: SPLIT_ACCORDING_simp,
       elim exE conjE, 
       simp only: SPLIT_ACCORDING_def
     )
   ) 
 end
   
     
     
 subsubsection \<open>\<open>list_all2\<close>\<close>
 lemma list_all2_induct[consumes 1, case_names Nil Cons]:
   assumes "list_all2 P l l'"
   assumes "Q [] []"
   assumes "\<And>x x' ls ls'. \<lbrakk> P x x'; list_all2 P ls ls'; Q ls ls' \<rbrakk>
     \<Longrightarrow> Q (x#ls) (x'#ls')"
   shows "Q l l'"
   using list_all2_lengthD[OF assms(1)] assms
   apply (induct rule: list_induct2)
   apply auto
   done
 
 
 subsubsection \<open>Indexing\<close>    
 
 lemma ran_nth_set_encoding_conv[simp]: 
   "ran (\<lambda>i. if i<length l then Some (l!i) else None) = set l"
   apply safe
   apply (auto simp: ran_def split: if_split_asm) []
   apply (auto simp: in_set_conv_nth intro: ranI) []
   done
 
 lemma nth_image_indices[simp]: "(!) l ` {0..<length l} = set l"
   by (auto simp: in_set_conv_nth)
 
 lemma nth_update_invalid[simp]:"\<not>i<length l \<Longrightarrow> l[j:=x]!i = l!i"  
   apply (induction l arbitrary: i j)
   apply (auto split: nat.splits)
   done
 
 lemma nth_list_update': "l[i:=x]!j = (if i=j \<and> i<length l then x else l!j)"  
   by auto
 
 lemma last_take_nth_conv: "n \<le> length l \<Longrightarrow> n\<noteq>0 \<Longrightarrow> last (take n l) = l!(n - 1)"
   apply (induction l arbitrary: n)
   apply (auto simp: take_Cons split: nat.split)
   done
 
 lemma nth_append_first[simp]: "i<length l \<Longrightarrow> (l@l')!i = l!i"
   by (simp add: nth_append) 
     
 lemma in_set_image_conv_nth: "f x \<in> f`set l \<longleftrightarrow> (\<exists>i<length l. f (l!i) = f x)"
   by (auto simp: in_set_conv_nth) (metis image_eqI nth_mem)
 
 lemma set_image_eq_pointwiseI: 
   assumes "length l = length l'"
   assumes "\<And>i. i<length l \<Longrightarrow> f (l!i) = f (l'!i)"  
   shows "f`set l = f`set l'"
   using assms
   by (fastforce simp: in_set_conv_nth in_set_image_conv_nth)
   
 lemma insert_swap_set_eq: "i<length l \<Longrightarrow> insert (l!i) (set (l[i:=x])) = insert x (set l)"
   by (auto simp: in_set_conv_nth nth_list_update split: if_split_asm)
     
     
 subsubsection \<open>Reverse lists\<close>
   lemma neq_Nil_revE: 
     assumes "l\<noteq>[]" 
     obtains ll e  where "l = ll@[e]"
     using assms by (cases l rule: rev_cases) auto
       
   lemma neq_Nil_rev_conv: "l\<noteq>[] \<longleftrightarrow> (\<exists>xs x. l = xs@[x])"
     by (cases l rule: rev_cases) auto
 
   text \<open>Caution: Same order of case variables in snoc-case as @{thm [source] rev_exhaust}, the other way round than @{thm [source] rev_induct} !\<close>
   lemma length_compl_rev_induct[case_names Nil snoc]: "\<lbrakk>P []; !! l e . \<lbrakk>!! ll . length ll <= length l \<Longrightarrow> P ll\<rbrakk> \<Longrightarrow> P (l@[e])\<rbrakk> \<Longrightarrow> P l"
     apply(induct_tac l rule: length_induct)
     apply(case_tac "xs" rule: rev_cases)
     apply(auto)
   done
 
   lemma list_append_eq_Cons_cases[consumes 1]: "\<lbrakk>ys@zs = x#xs; \<lbrakk>ys=[]; zs=x#xs\<rbrakk> \<Longrightarrow> P; !!ys'. \<lbrakk> ys=x#ys'; ys'@zs=xs \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (auto iff add: append_eq_Cons_conv)
   lemma list_Cons_eq_append_cases[consumes 1]: "\<lbrakk>x#xs = ys@zs; \<lbrakk>ys=[]; zs=x#xs\<rbrakk> \<Longrightarrow> P; !!ys'. \<lbrakk> ys=x#ys'; ys'@zs=xs \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (auto iff add: Cons_eq_append_conv)
 
 lemma map_of_rev_distinct[simp]:
   "distinct (map fst m) \<Longrightarrow> map_of (rev m) = map_of m"
   apply (induct m)
     apply simp
 
     apply simp
     apply (subst map_add_comm)
       apply force
       apply simp
   done
 
 
 \<comment> \<open>Tail-recursive, generalized @{const rev}. May also be used for
       tail-recursively getting a list with all elements of the two
       operands, if the order does not matter, e.g. when implementing
       sets by lists.\<close>
 fun revg where
   "revg [] b = b" |
   "revg (a#as) b = revg as (a#b)"
 
 lemma revg_fun[simp]: "revg a b = rev a @ b"
   by (induct a arbitrary: b)
       auto
 
 lemma rev_split_conv[simp]:
   "l \<noteq> [] \<Longrightarrow> rev (tl l) @ [hd l] = rev l"
 by (induct l) simp_all
 
 lemma rev_butlast_is_tl_rev: "rev (butlast l) = tl (rev l)"
   by (induct l) auto
 
 lemma hd_last_singletonI:
   "\<lbrakk>xs \<noteq> []; hd xs = last xs; distinct xs\<rbrakk> \<Longrightarrow> xs = [hd xs]"
   by (induct xs rule: list_nonempty_induct) auto
 
 lemma last_filter:
   "\<lbrakk>xs \<noteq> []; P (last xs)\<rbrakk> \<Longrightarrow> last (filter P xs) = last xs"
   by (induct xs rule: rev_nonempty_induct) simp_all
 
 (* As the following two rules are similar in nature to list_induct2',
    they are named accordingly. *)
 lemma rev_induct2' [case_names empty snocl snocr snoclr]:
   assumes empty: "P [] []"
   and snocl: "\<And>x xs. P (xs@[x]) []"
   and snocr: "\<And>y ys. P [] (ys@[y])"
   and snoclr: "\<And>x xs y ys.  P xs ys  \<Longrightarrow> P (xs@[x]) (ys@[y])"
   shows "P xs ys"
 proof (induct xs arbitrary: ys rule: rev_induct)
   case Nil thus ?case using empty snocr
     by (cases ys rule: rev_exhaust) simp_all
 next
   case snoc thus ?case using snocl snoclr
     by (cases ys rule: rev_exhaust) simp_all
 qed
 
 lemma rev_nonempty_induct2' [case_names single snocl snocr snoclr, consumes 2]:
   assumes "xs \<noteq> []" "ys \<noteq> []"
   assumes single': "\<And>x y. P [x] [y]"
   and snocl: "\<And>x xs y. xs \<noteq> [] \<Longrightarrow> P (xs@[x]) [y]"
   and snocr: "\<And>x y ys. ys \<noteq> [] \<Longrightarrow> P [x] (ys@[y])"
   and snoclr: "\<And>x xs y ys. \<lbrakk>P xs ys; xs \<noteq> []; ys\<noteq>[]\<rbrakk>  \<Longrightarrow> P (xs@[x]) (ys@[y])"
   shows "P xs ys"
   using assms(1,2)
 proof (induct xs arbitrary: ys rule: rev_nonempty_induct)
   case single then obtain z zs where "ys = zs@[z]" by (metis rev_exhaust)
   thus ?case using single' snocr
     by (cases "zs = []") simp_all
 next
   case (snoc x xs) then obtain z zs where zs: "ys = zs@[z]" by (metis rev_exhaust)
   thus ?case using snocl snoclr snoc
     by (cases "zs = []") simp_all
 qed
 
 
 subsubsection "Folding"
 
 text "Ugly lemma about foldl over associative operator with left and right neutral element"
 lemma foldl_A1_eq: "!!i. \<lbrakk> !! e. f n e = e; !! e. f e n = e; !!a b c. f a (f b c) = f (f a b) c \<rbrakk> \<Longrightarrow> foldl f i ww = f i (foldl f n ww)"
 proof (induct ww)
   case Nil thus ?case by simp
 next
   case (Cons a ww i) note IHP[simplified]=this
   have "foldl f i (a # ww) = foldl f (f i a) ww" by simp
   also from IHP have "\<dots> = f (f i a) (foldl f n ww)" by blast
   also from IHP(4) have "\<dots> = f i (f a (foldl f n ww))" by simp
   also from IHP(1)[OF IHP(2,3,4), where i=a] have "\<dots> = f i (foldl f a ww)" by simp
   also from IHP(2)[of a] have "\<dots> = f i (foldl f (f n a) ww)" by simp
   also have "\<dots> = f i (foldl f n (a#ww))" by simp
   finally show ?case .
 qed
 
 
 lemmas foldl_conc_empty_eq = foldl_A1_eq[of "(@)" "[]", simplified]
 lemmas foldl_un_empty_eq = foldl_A1_eq[of "(\<union>)" "{}", simplified, OF Un_assoc[symmetric]]
 
 lemma foldl_set: "foldl (\<union>) {} l = \<Union>{x. x\<in>set l}"
   apply (induct l)
   apply simp_all
   apply (subst foldl_un_empty_eq)
   apply auto
   done
 
 lemma (in monoid_mult) foldl_absorb1: "x*foldl (*) 1 zs = foldl (*) x zs"
   apply (rule sym)
   apply (rule foldl_A1_eq)
   apply (auto simp add: mult.assoc)
 done
 
 text \<open>Towards an invariant rule for foldl\<close>
 lemma foldl_rule_aux:
   fixes I :: "'\<sigma> \<Rightarrow> 'a list \<Rightarrow> bool"
   assumes initial: "I \<sigma>0 l0"
   assumes step: "!!l1 l2 x \<sigma>. \<lbrakk> l0=l1@x#l2; I \<sigma> (x#l2) \<rbrakk> \<Longrightarrow> I (f \<sigma> x) l2"
   shows "I (foldl f \<sigma>0 l0) []"
   using initial step
   apply (induct l0 arbitrary: \<sigma>0)
   apply auto
   done
 
 lemma foldl_rule_aux_P:
   fixes I :: "'\<sigma> \<Rightarrow> 'a list \<Rightarrow> bool"
   assumes initial: "I \<sigma>0 l0"
   assumes step: "!!l1 l2 x \<sigma>. \<lbrakk> l0=l1@x#l2; I \<sigma> (x#l2) \<rbrakk> \<Longrightarrow> I (f \<sigma> x) l2"
   assumes final: "!!\<sigma>. I \<sigma> [] \<Longrightarrow> P \<sigma>"
   shows "P (foldl f \<sigma>0 l0)"
 using foldl_rule_aux[of I \<sigma>0 l0, OF initial, OF step] final
 by simp
 
 
 lemma foldl_rule:
   fixes I :: "'\<sigma> \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
   assumes initial: "I \<sigma>0 [] l0"
   assumes step: "!!l1 l2 x \<sigma>. \<lbrakk> l0=l1@x#l2; I \<sigma> l1 (x#l2) \<rbrakk> \<Longrightarrow> I (f \<sigma> x) (l1@[x]) l2"
   shows "I (foldl f \<sigma>0 l0) l0 []"
   using initial step
   apply (rule_tac I="\<lambda>\<sigma> lr. \<exists>ll. l0=ll@lr \<and> I \<sigma> ll lr" in foldl_rule_aux_P)
   apply auto
   done
 
 text \<open>
   Invariant rule for foldl. The invariant is parameterized with
   the state, the list of items that have already been processed and
   the list of items that still have to be processed.
 \<close>
 lemma foldl_rule_P:
   fixes I :: "'\<sigma> \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
   \<comment> \<open>The invariant holds for the initial state, no items processed yet and all items to be processed:\<close>
   assumes initial: "I \<sigma>0 [] l0"
   \<comment> \<open>The invariant remains valid if one item from the list is processed\<close>
   assumes step: "!!l1 l2 x \<sigma>. \<lbrakk> l0=l1@x#l2; I \<sigma> l1 (x#l2) \<rbrakk> \<Longrightarrow> I (f \<sigma> x) (l1@[x]) l2"
   \<comment> \<open>The proposition follows from the invariant in the final state, i.e. all items processed and nothing to be processed\<close>
   assumes final: "!!\<sigma>. I \<sigma> l0 [] \<Longrightarrow> P \<sigma>"
   shows "P (foldl f \<sigma>0 l0)"
   using foldl_rule[of I, OF initial step] by (simp add: final)
 
 
 text \<open>Invariant reasoning over @{const foldl} for distinct lists. Invariant rule makes no
   assumptions about ordering.\<close>
 lemma distinct_foldl_invar:
   "\<lbrakk> distinct S; I (set S) \<sigma>0;
      \<And>x it \<sigma>. \<lbrakk>x \<in> it; it \<subseteq> set S; I it \<sigma>\<rbrakk> \<Longrightarrow> I (it - {x}) (f \<sigma> x)
    \<rbrakk> \<Longrightarrow> I {} (foldl f \<sigma>0 S)"
 proof (induct S arbitrary: \<sigma>0)
   case Nil thus ?case by auto
 next
   case (Cons x S)
 
   note [simp] = Cons.prems(1)[simplified]
 
   show ?case
     apply simp
     apply (rule Cons.hyps)
   proof -
     from Cons.prems(1) show "distinct S" by simp
     from Cons.prems(3)[of x "set (x#S)", simplified,
                        OF Cons.prems(2)[simplified]]
     show "I (set S) (f \<sigma>0 x)" .
     fix xx it \<sigma>
     assume A: "xx\<in>it" "it \<subseteq> set S" "I it \<sigma>"
     show "I (it - {xx}) (f \<sigma> xx)" using A(2)
       apply (rule_tac Cons.prems(3))
       apply (simp_all add: A(1,3))
       apply blast
       done
   qed
 qed
 
 lemma foldl_length_aux: "foldl (\<lambda>i x. Suc i) a l = a + length l"
   by (induct l arbitrary: a) auto
 
 lemmas foldl_length[simp] = foldl_length_aux[where a=0, simplified]
 
 lemma foldr_length_aux: "foldr (\<lambda>x i. Suc i) l a = a + length l"
   by (induct l arbitrary: a rule: rev_induct) auto
 
 lemmas foldr_length[simp] = foldr_length_aux[where a=0, simplified]
 
 context comp_fun_commute begin
 
 lemma foldl_f_commute: "f a (foldl (\<lambda>a b. f b a) b xs) = foldl (\<lambda>a b. f b a) (f a b) xs"
 by(induct xs arbitrary: b)(simp_all add: fun_left_comm)
 
 lemma foldr_conv_foldl: "foldr f xs a = foldl (\<lambda>a b. f b a) a xs"
 by(induct xs arbitrary: a)(simp_all add: foldl_f_commute)
 
 end
 
 lemma filter_conv_foldr:
   "filter P xs = foldr (\<lambda>x xs. if P x then x # xs else xs) xs []"
 by(induct xs) simp_all
 
 lemma foldr_Cons: "foldr Cons xs [] = xs"
 by(induct xs) simp_all
 
 lemma foldr_snd_zip:
   "length xs \<ge> length ys \<Longrightarrow> foldr (\<lambda>(x, y). f y) (zip xs ys) b = foldr f ys b"
 proof(induct ys arbitrary: xs)
   case (Cons y ys) thus ?case by(cases xs) simp_all
 qed simp
 
 lemma foldl_snd_zip:
   "length xs \<ge> length ys \<Longrightarrow> foldl (\<lambda>b (x, y). f b y) b (zip xs ys) = foldl f b ys"
 proof(induct ys arbitrary: xs b)
   case (Cons y ys) thus ?case by(cases xs) simp_all
 qed simp
 
 lemma fst_foldl: "fst (foldl (\<lambda>(a, b) x. (f a x, g a b x)) (a, b) xs) = foldl f a xs"
 by(induct xs arbitrary: a b) simp_all
 
 lemma foldl_foldl_conv_concat: "foldl (foldl f) a xs = foldl f a (concat xs)"
 by(induct xs arbitrary: a) simp_all
 
 lemma foldl_list_update:
   "n < length xs \<Longrightarrow> foldl f a (xs[n := x]) = foldl f (f (foldl f a (take n xs)) x) (drop (Suc n) xs)"
 by(simp add: upd_conv_take_nth_drop)
 
 lemma map_by_foldl:
   fixes l :: "'a list" and f :: "'a \<Rightarrow> 'b"
   shows "foldl (\<lambda>l x. l@[f x]) [] l = map f l"
 proof -
   {
     fix l'
     have "foldl (\<lambda>l x. l@[f x]) l' l = l'@map f l"
       by (induct l arbitrary: l') auto
   } thus ?thesis by simp
 qed
 
 
 subsubsection \<open>Sorting\<close>
 
 lemma sorted_in_between:
   assumes A: "0\<le>i" "i<j" "j<length l"
   assumes S: "sorted l"
   assumes E: "l!i \<le> x" "x<l!j"
   obtains k where "i\<le>k" and "k<j" and "l!k\<le>x" and "x<l!(k+1)"
 proof -
   from A E have "\<exists>k. i\<le>k \<and> k<j \<and> l!k\<le>x \<and> x<l!(k+1)"
   proof (induct "j-i" arbitrary: i j)
     case (Suc d)
     show ?case proof (cases "l!(i+1) \<le> x")
       case True
       from True Suc.hyps have "d = j - (i + 1)" by simp
       moreover from True have "i+1 < j"
         by (metis Suc.prems Suc_eq_plus1 Suc_lessI not_less)
       moreover from True have "0\<le>i+1" by simp
       ultimately obtain k where
         "i+1\<le>k" "k<j" "l!k \<le> x" "x<l!(k+1)"
         using Suc.hyps(1)[of j "i+1"] Suc.prems True
         by auto
       thus ?thesis by (auto dest: Suc_leD)
     next
       case False
       show ?thesis proof (cases "x<(l!(j - 1))")
         case True
         from True Suc.hyps have "d = j - (i + 1)" by simp
         moreover from True Suc.prems have "i < j - 1"
           by (metis Suc_eq_plus1 Suc_lessI diff_Suc_1 less_diff_conv not_le)
         moreover from True Suc.prems have "j - 1 < length l" by simp
         ultimately obtain k where
           "i\<le>k" "k<j - 1" "l!k \<le> x" "x<l!(k+1)"
           using Suc.hyps(1)[of "j - 1" i] Suc.prems True
           by auto
         thus ?thesis by (auto dest: Suc_leD)
       next
         case False thus ?thesis using Suc
           apply clarsimp
           by (metis Suc_leI add_0_iff add_diff_inverse diff_Suc_1 le_add2 lessI
               not0_implies_Suc not_less)
       qed
     qed
   qed simp
   thus ?thesis by (blast intro: that)
 qed
 
 lemma sorted_hd_last:
   "\<lbrakk>sorted l; l\<noteq>[]\<rbrakk> \<Longrightarrow> hd l \<le> last l"
 by (metis eq_iff hd_Cons_tl last_in_set not_hd_in_tl sorted_wrt.simps(2))
 
 lemma (in linorder) sorted_hd_min:
   "\<lbrakk>xs \<noteq> []; sorted xs\<rbrakk> \<Longrightarrow> \<forall>x \<in> set xs. hd xs \<le> x"
 by (induct xs, auto)
 
 lemma sorted_append_bigger:
   "\<lbrakk>sorted xs; \<forall>x \<in> set xs. x \<le> y\<rbrakk> \<Longrightarrow> sorted (xs @ [y])"
 proof (induct xs)
   case Nil
   then show ?case by simp
 next
   case (Cons x xs)
   then have s: "sorted xs" by (cases xs) simp_all
   from Cons have a: "\<forall>x\<in>set xs. x \<le> y" by simp
   from Cons(1)[OF s a] Cons(2-) show ?case by (cases xs) simp_all
 qed
 
 lemma sorted_filter':
   "sorted l \<Longrightarrow> sorted (filter P l)"
   using sorted_filter[where f=id, simplified] .
 
 subsubsection \<open>Map\<close>
 (* List.thy has:
  declare map_eq_Cons_D [dest!]  Cons_eq_map_D [dest!] *)  
 lemma map_eq_consE: "\<lbrakk>map f ls = fa#fl; !!a l. \<lbrakk> ls=a#l; f a=fa; map f l = fl \<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   by auto
 
 lemma map_fst_mk_snd[simp]: "map fst (map (\<lambda>x. (x,k)) l) = l" by (induct l) auto
 lemma map_snd_mk_fst[simp]: "map snd (map (\<lambda>x. (k,x)) l) = l" by (induct l) auto
 lemma map_fst_mk_fst[simp]: "map fst (map (\<lambda>x. (k,x)) l) = replicate (length l) k" by (induct l) auto
 lemma map_snd_mk_snd[simp]: "map snd (map (\<lambda>x. (x,k)) l) = replicate (length l) k" by (induct l) auto
 
 lemma map_zip1: "map (\<lambda>x. (x,k)) l = zip l (replicate (length l) k)" by (induct l) auto
 lemma map_zip2: "map (\<lambda>x. (k,x)) l = zip (replicate (length l) k) l" by (induct l) auto
 lemmas map_zip=map_zip1 map_zip2
 
 (* TODO/FIXME: hope nobody changes nth to be underdefined! *)
 lemma map_eq_nth_eq:
   assumes A: "map f l = map f l'"
   shows "f (l!i) = f (l'!i)"
 proof -
   from A have "length l = length l'"
     by (metis length_map)
   thus ?thesis using A
     apply (induct arbitrary: i rule: list_induct2)
     apply simp
     apply (simp add: nth_def split: nat.split)
     done
 qed
 
 lemma map_upd_eq:
   "\<lbrakk>i<length l \<Longrightarrow> f (l!i) = f x\<rbrakk> \<Longrightarrow> map f (l[i:=x]) = map f l"
   by (metis list_update_beyond list_update_id map_update not_le_imp_less)
 
 
 
 
 lemma inj_map_inv_f [simp]: "inj f \<Longrightarrow> map (inv f) (map f l) = l"
   by (simp)
 
 lemma inj_on_map_the: "\<lbrakk>D \<subseteq> dom m; inj_on m D\<rbrakk> \<Longrightarrow> inj_on (the\<circ>m) D"
   apply (rule inj_onI)
   apply simp
   apply (case_tac "m x")
   apply (case_tac "m y")
   apply (auto intro: inj_onD) [1]
   apply (auto intro: inj_onD) [1]
   apply (case_tac "m y")
   apply (auto intro: inj_onD) [1]
   apply simp
   apply (rule inj_onD)
   apply assumption
   apply auto
   done
 
     
 
 lemma map_consI:
   "w=map f ww \<Longrightarrow> f a#w = map f (a#ww)"
   "w@l=map f ww@l \<Longrightarrow> f a#w@l = map f (a#ww)@l"
   by auto
 
 
 lemma restrict_map_subset_eq:
   fixes R
   shows "\<lbrakk>m |` R = m'; R'\<subseteq>R\<rbrakk> \<Longrightarrow> m|` R' = m' |` R'"
   by (auto simp add: Int_absorb1)
 
 lemma restrict_map_self[simp]: "m |` dom m = m"
   apply (rule ext)
   apply (case_tac "m x")
   apply (auto simp add: restrict_map_def)
   done
 
 lemma restrict_map_UNIV[simp]: "f |` UNIV = f"
   by (auto simp add: restrict_map_def)
 
 lemma restrict_map_inv[simp]: "f |` (- dom f) = Map.empty"
   by (auto simp add: restrict_map_def intro: ext)
 
 lemma restrict_map_upd: "(f |` S)(k \<mapsto> v) = f(k\<mapsto>v) |` (insert k S)"
   by (auto simp add: restrict_map_def intro: ext)
 
 lemma map_upd_eq_restrict: "m (x:=None) = m |` (-{x})"
   by (auto intro: ext)
 
 declare Map.finite_dom_map_of [simp, intro!]
 
 lemma dom_const'[simp]: "dom (\<lambda>x. Some (f x)) = UNIV"
   by auto
 
 lemma restrict_map_eq :
   "((m |` A) k = None) \<longleftrightarrow> (k \<notin> dom m \<inter> A)"
   "((m |` A) k = Some v) \<longleftrightarrow> (m k = Some v \<and> k \<in> A)"
 unfolding restrict_map_def
 by (simp_all add: dom_def)
 
 
 definition "rel_of m P == {(k,v). m k = Some v \<and> P (k, v)}"
 lemma rel_of_empty[simp]: "rel_of Map.empty P = {}"
     by (auto simp add: rel_of_def)
 
 lemma remove1_tl: "xs \<noteq> [] \<Longrightarrow> remove1 (hd xs) xs = tl xs"
   by (cases xs) auto
 
 lemma set_oo_map_alt: "(set \<circ>\<circ> map) f = (\<lambda>l. f ` set l)" by auto
     
 subsubsection "Filter and Revert"
 primrec filter_rev_aux where
   "filter_rev_aux a P [] = a"
 | "filter_rev_aux a P (x#xs) = (
      if P x then filter_rev_aux (x#a) P xs else filter_rev_aux a P xs)"
 
 lemma filter_rev_aux_alt: "filter_rev_aux a P l = filter P (rev l) @ a"
   by (induct l arbitrary: a) auto
 
 definition "filter_rev == filter_rev_aux []"
 lemma filter_rev_alt: "filter_rev P l = filter P (rev l)"
   unfolding filter_rev_def by (simp add: filter_rev_aux_alt)
 
 definition "remove_rev x == filter_rev (Not o (=) x)"
 lemma remove_rev_alt_def :
   "remove_rev x xs = (filter (\<lambda>y. y \<noteq> x) (rev xs))"
   unfolding remove_rev_def
   apply (simp add: filter_rev_alt comp_def)
   by metis
 
 subsubsection "zip"
 
 declare zip_map_fst_snd[simp]  
 
 lemma pair_list_split: "\<lbrakk> !!l1 l2. \<lbrakk> l = zip l1 l2; length l1=length l2; length l=length l2 \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
 proof (induct l arbitrary: P)
   case Nil thus ?case by auto
 next
   case (Cons a l) from Cons.hyps obtain l1 l2 where IHAPP: "l=zip l1 l2" "length l1 = length l2" "length l=length l2" .
   obtain a1 a2 where [simp]: "a=(a1,a2)" by (cases a) auto
   from IHAPP have "a#l = zip (a1#l1) (a2#l2)" "length (a1#l1) = length (a2#l2)" "length (a#l) = length (a2#l2)"
     by (simp_all only:) (simp_all (no_asm_use))
   with Cons.prems show ?case by blast
 qed
 
 lemma set_zip_cart: "x\<in>set (zip l l') \<Longrightarrow> x\<in>set l \<times> set l'"
   by (auto simp add: set_zip)
 
 
 lemma map_prod_fun_zip: "map (\<lambda>(x, y). (f x, g y)) (zip xs ys) = zip (map f xs) (map g ys)"
 proof(induct xs arbitrary: ys)
   case Nil thus ?case by simp
 next
   case (Cons x xs) thus ?case by(cases ys) simp_all
 qed
 
 
 subsubsection \<open>Generalized Zip\<close>
 text \<open>Zip two lists element-wise, where the combination of two elements is specified by a function. Note that this function is underdefined for lists of different length.\<close>
 fun zipf :: "('a\<Rightarrow>'b\<Rightarrow>'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list" where
   "zipf f [] [] = []" |
   "zipf f (a#as) (b#bs) = f a b # zipf f as bs"
 
 
 lemma zipf_zip: "\<lbrakk>length l1 = length l2\<rbrakk> \<Longrightarrow> zipf Pair l1 l2 = zip l1 l2"
   apply (induct l1 arbitrary: l2)
   apply auto
   apply (case_tac l2)
   apply auto
   done
 
   \<comment> \<open>All quantification over zipped lists\<close>
 fun list_all_zip where
   "list_all_zip P [] [] \<longleftrightarrow> True" |
   "list_all_zip P (a#as) (b#bs) \<longleftrightarrow> P a b \<and> list_all_zip P as bs" |
   "list_all_zip P _ _ \<longleftrightarrow> False"
 
 lemma list_all_zip_alt: "list_all_zip P as bs \<longleftrightarrow> length as = length bs \<and> (\<forall>i<length as. P (as!i) (bs!i))"
   apply (induct P\<equiv>P as bs rule: list_all_zip.induct)
   apply auto
   apply (case_tac i)
   apply auto
   done
 
 lemma list_all_zip_map1: "list_all_zip P (List.map f as) bs \<longleftrightarrow> list_all_zip (\<lambda>a b. P (f a) b) as bs"
   apply (induct as arbitrary: bs)
   apply (case_tac bs)
   apply auto [2]
   apply (case_tac bs)
   apply auto [2]
   done
 
 lemma list_all_zip_map2: "list_all_zip P as (List.map f bs) \<longleftrightarrow> list_all_zip (\<lambda>a b. P a (f b)) as bs"
   apply (induct as arbitrary: bs)
   apply (case_tac bs)
   apply auto [2]
   apply (case_tac bs)
   apply auto [2]
   done
 
 declare list_all_zip_alt[mono]
 
 lemma lazI[intro?]: "\<lbrakk> length a = length b; !!i. i<length b \<Longrightarrow> P (a!i) (b!i) \<rbrakk>
   \<Longrightarrow> list_all_zip P a b"
   by (auto simp add: list_all_zip_alt)
 
 lemma laz_conj[simp]: "list_all_zip (\<lambda>x y. P x y \<and> Q x y) a b
                        \<longleftrightarrow> list_all_zip P a b \<and> list_all_zip Q a b"
   by (auto simp add: list_all_zip_alt)
 
 lemma laz_len: "list_all_zip P a b \<Longrightarrow> length a = length b"
   by (simp add: list_all_zip_alt)
 
 lemma laz_eq: "list_all_zip (=) a b \<longleftrightarrow> a=b"
   apply (induct a arbitrary: b)
   apply (case_tac b)
   apply simp
   apply simp
   apply (case_tac b)
   apply simp
   apply simp
   done
 
 
 lemma laz_swap_ex:
   assumes A: "list_all_zip (\<lambda>a b. \<exists>c. P a b c) A B"
   obtains C where
     "list_all_zip (\<lambda>a c. \<exists>b. P a b c) A C"
     "list_all_zip (\<lambda>b c. \<exists>a. P a b c) B C"
 proof -
   from A have
     [simp]: "length A = length B" and
     IC: "\<forall>i<length B. \<exists>ci. P (A!i) (B!i) ci"
     by (auto simp add: list_all_zip_alt)
   from obtain_list_from_elements[OF IC] obtain C where
     "length C = length B"
     "\<forall>i<length B. P (A!i) (B!i) (C!i)" .
   thus ?thesis
     by (rule_tac that) (auto simp add: list_all_zip_alt)
 qed
 
 lemma laz_weak_Pa[simp]:
   "list_all_zip (\<lambda>a b. P a) A B \<longleftrightarrow> (length A = length B) \<and> (\<forall>a\<in>set A. P a)"
   by (auto simp add: list_all_zip_alt set_conv_nth)
 
 lemma laz_weak_Pb[simp]:
   "list_all_zip (\<lambda>a b. P b) A B \<longleftrightarrow> (length A = length B) \<and> (\<forall>b\<in>set B. P b)"
   by (force simp add: list_all_zip_alt set_conv_nth)
 
 
 
 subsubsection "Collecting Sets over Lists"
 
 definition "list_collect_set f l == \<Union>{ f a | a. a\<in>set l }"
 lemma list_collect_set_simps[simp]:
   "list_collect_set f [] = {}"
   "list_collect_set f [a] = f a"
   "list_collect_set f (a#l) = f a \<union> list_collect_set f l"
   "list_collect_set f (l@l') = list_collect_set f l \<union> list_collect_set f l'"
 by (unfold list_collect_set_def) auto
 
 lemma list_collect_set_map_simps[simp]:
   "list_collect_set f (map x []) = {}"
   "list_collect_set f (map x [a]) = f (x a)"
   "list_collect_set f (map x (a#l)) = f (x a) \<union> list_collect_set f (map x l)"
   "list_collect_set f (map x (l@l')) = list_collect_set f (map x l) \<union> list_collect_set f (map x l')"
 by simp_all
 
 lemma list_collect_set_alt: "list_collect_set f l = \<Union>{ f (l!i) | i. i<length l }"
   apply (induct l)
   apply simp
   apply safe
   apply auto
   apply (rule_tac x="f (l!i)" in exI)
   apply simp
   apply (rule_tac x="Suc i" in exI)
   apply simp
   apply (case_tac i)
   apply auto
   done
 
 lemma list_collect_set_as_map: "list_collect_set f l = \<Union>(set (map f l))"
   by (unfold list_collect_set_def) auto
 
 subsubsection \<open>Sorted List with arbitrary Relations\<close>
 
 lemma (in linorder) sorted_wrt_rev_linord [simp] :
   "sorted_wrt (\<ge>) l \<longleftrightarrow> sorted (rev l)"
 by (simp add: sorted_wrt_rev)
 
 lemma (in linorder) sorted_wrt_map_linord [simp] :
   "sorted_wrt (\<lambda>(x::'a \<times> 'b) y. fst x \<le> fst y) l
   \<longleftrightarrow> sorted (map fst l)"
 by (simp add: sorted_wrt_map)
 
 lemma (in linorder) sorted_wrt_map_rev_linord [simp] :
   "sorted_wrt (\<lambda>(x::'a \<times> 'b) y. fst x \<ge> fst y) l
   \<longleftrightarrow> sorted (rev (map fst l))"
 by (induct l) (auto simp add: sorted_append)
 
     
 subsubsection \<open>Take and Drop\<close>
   lemma take_update[simp]: "take n (l[i:=x]) = (take n l)[i:=x]"
     apply (induct l arbitrary: n i)
     apply (auto split: nat.split)
     apply (case_tac n)
     apply simp_all
     apply (case_tac n)
     apply simp_all
     done
 
   lemma take_update_last: "length list>n \<Longrightarrow> (take (Suc n) list) [n:=x] = take n list @ [x]"
     by (induct list arbitrary: n)
        (auto split: nat.split)
 
   lemma drop_upd_irrelevant: "m < n \<Longrightarrow> drop n (l[m:=x]) = drop n l"
     apply (induct n arbitrary: l m)
     apply simp
     apply (case_tac l)
     apply (auto split: nat.split)
     done
 
 lemma set_drop_conv:
   "set (drop n l) =  { l!i | i. n\<le>i \<and> i < length l }" (is "?L=?R")
 proof (intro equalityI subsetI)
   fix x
   assume "x\<in>?L"
   then obtain i where L: "i<length l - n" and X: "x = drop n l!i"
     by (auto simp add: in_set_conv_nth)
   note X
   also have "\<dots> = l!(n+i)" using L by simp
   finally show "x\<in>?R" using L by auto
 next
   fix x
   assume "x\<in>?R"
   then obtain i where L: "n\<le>i" "i<length l" and X: "x=l!i" by blast
   note X
   moreover have "l!i = drop n l ! (i - n)" and "(i-n) < length l - n" using L
     by (auto)
   ultimately show "x\<in>?L"
     by (auto simp add: in_set_conv_nth)
 qed
 
 lemma filter_upt_take_conv:
   "[i\<leftarrow>[n..<m]. P (take m l ! i) ] = [i\<leftarrow>[n..<m]. P (l ! i) ]"
   by (rule filter_cong) (simp_all)
 
 lemma in_set_drop_conv_nth: "x\<in>set (drop n l) \<longleftrightarrow> (\<exists>i. n\<le>i \<and> i<length l \<and> x = l!i)"
   apply (clarsimp simp: in_set_conv_nth)
   apply safe
   apply simp
   apply (metis le_add2 less_diff_conv add.commute)
   apply (rule_tac x="i-n" in exI)
   apply auto []
   done
 
 lemma Union_take_drop_id: "\<Union>(set (drop n l)) \<union> \<Union>(set (take n l)) = \<Union>(set l)"
   by (metis Union_Un_distrib append_take_drop_id set_union_code sup_commute)
 
 
 lemma Un_set_drop_extend: "\<lbrakk>j\<ge>Suc 0; j < length l\<rbrakk>
   \<Longrightarrow> l ! (j - Suc 0) \<union> \<Union>(set (drop j l)) = \<Union>(set (drop (j - Suc 0) l))"
   apply safe
   apply simp_all
   apply (metis diff_Suc_Suc diff_zero gr0_implies_Suc in_set_drop_conv_nth
     le_refl less_eq_Suc_le order.strict_iff_order)
   apply (metis Nat.diff_le_self set_drop_subset_set_drop subset_code(1))
   by (metis diff_Suc_Suc gr0_implies_Suc in_set_drop_conv_nth
     less_eq_Suc_le order.strict_iff_order minus_nat.diff_0)
 
 lemma drop_take_drop_unsplit:
   "i\<le>j \<Longrightarrow> drop i (take j l) @ drop j l = drop i l"
 proof -
   assume "i \<le> j"
   then obtain skf where "i + skf = j"
     by (metis le_iff_add)
   thus "drop i (take j l) @ drop j l = drop i l"
     by (metis append_take_drop_id diff_add_inverse drop_drop drop_take
       add.commute)
 qed
 
 lemma drop_last_conv[simp]: "l\<noteq>[] \<Longrightarrow> drop (length l - Suc 0) l = [last l]"
   by (cases l rule: rev_cases) auto
 
 lemma take_butlast_conv[simp]: "take (length l - Suc 0) l = butlast l"
   by (cases l rule: rev_cases) auto
 
   lemma drop_takeWhile:
     assumes "i\<le>length (takeWhile P l)"
     shows "drop i (takeWhile P l) = takeWhile P (drop i l)"  
     using assms
   proof (induction l arbitrary: i)
     case Nil thus ?case by auto
   next
     case (Cons x l) thus ?case  
       by (cases i) auto
   qed    
   
 lemma less_length_takeWhile_conv: "i < length (takeWhile P l) \<longleftrightarrow> (i<length l \<and> (\<forall>j\<le>i. P (l!j)))"  
   apply safe
   subgoal using length_takeWhile_le less_le_trans by blast
   subgoal by (metis dual_order.strict_trans2 nth_mem set_takeWhileD takeWhile_nth)
   subgoal by (meson less_le_trans not_le_imp_less nth_length_takeWhile)
   done
   
 lemma eq_len_takeWhile_conv: "i=length (takeWhile P l) 
   \<longleftrightarrow> i\<le>length l \<and> (\<forall>j<i. P (l!j)) \<and> (i<length l \<longrightarrow> \<not>P (l!i))"  
   apply safe
   subgoal using length_takeWhile_le less_le_trans by blast
   subgoal by (auto simp: less_length_takeWhile_conv)
   subgoal using nth_length_takeWhile by blast 
   subgoal by (metis length_takeWhile_le nth_length_takeWhile order.order_iff_strict) 
   subgoal by (metis dual_order.strict_trans2 leI less_length_takeWhile_conv linorder_neqE_nat nth_length_takeWhile) 
   done
     
     
 subsubsection \<open>Up-to\<close>
 
 lemma upt_eq_append_conv: "i\<le>j \<Longrightarrow> [i..<j] = xs@ys \<longleftrightarrow> (\<exists>k. i\<le>k \<and> k\<le>j \<and> [i..<k] = xs \<and> [k..<j] = ys)"
 proof (rule iffI)
   assume "[i..<j] = xs @ ys"  
   and "i\<le>j"
   thus "\<exists>k\<ge>i. k \<le> j \<and> [i..<k] = xs \<and> [k..<j] = ys"
     apply (induction xs arbitrary: i)
     apply (auto; fail)
     apply (clarsimp simp: upt_eq_Cons_conv)
     by (meson Suc_le_eq less_imp_le_nat)
 qed auto
   
 lemma map_nth_upt_drop_take_conv: "N \<le> length l \<Longrightarrow> map (nth l) [M..<N] = drop M (take N l)"
   by (induction N) (auto simp: take_Suc_conv_app_nth)
     
 lemma upt_eq_lel_conv:
   "[l..<h] = is1@i#is2 \<longleftrightarrow> is1 = [l..<i] \<and> is2 = [Suc i..<h] \<and> l\<le>i \<and> i<h"
   apply (rule)
   subgoal
     apply (induction is1 arbitrary: l)
     apply (auto simp: upt_eq_Cons_conv) []
     apply (clarsimp simp: upt_eq_Cons_conv)
     using Suc_le_eq upt_rec by auto
   subgoal by (auto simp: upt_conv_Cons[symmetric])
   done
 
    
 lemma map_add_upt': "map (\<lambda>i. i + ofs) [a..<b] = [a+ofs..<b + ofs]"
   by (induct b) simp_all
     
     
 subsubsection \<open>Last and butlast\<close>
 lemma butlast_upt: "butlast [m..<n] = [m..<n - 1]"
   apply (cases "m<n")
     apply (cases n)
       apply simp
     apply simp
   apply simp
   done
 
 (*lemma butlast_upt: "n<m \<Longrightarrow> butlast [n..<m] = [n..<m - 1]"
   apply (cases "[n..<m]" rule: rev_cases)
   apply simp
   apply (cases m)
   apply simp
   apply simp
   done*)
 
 lemma butlast_update': "(butlast l) [i:=x] = butlast (l[i:=x])"
   by (metis butlast_conv_take butlast_list_update length_butlast take_update)
 
 
 lemma take_minus_one_conv_butlast:
   "n\<le>length l \<Longrightarrow> take (n - Suc 0) l = butlast (take n l)"
   by (simp add: butlast_take)
 
 lemma butlast_eq_cons_conv: "butlast l = x#xs \<longleftrightarrow> (\<exists>xl. l=x#xs@[xl])"
   by (metis Cons_eq_appendI append_butlast_last_id butlast.simps
     butlast_snoc eq_Nil_appendI)
 
 lemma butlast_eq_consE:
   assumes "butlast l = x#xs"
   obtains xl where "l=x#xs@[xl]"
   using assms
   by (auto simp: butlast_eq_cons_conv)
 
 lemma drop_eq_ConsD: "drop n xs = x # xs' \<Longrightarrow> drop (Suc n) xs = xs'"
 by(induct xs arbitrary: n)(simp_all add: drop_Cons split: nat.split_asm)
 
 subsubsection \<open>List Slices\<close>  
   text \<open>Based on Lars Hupel's code.\<close>  
 definition slice :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "slice from to list = take (to - from) (drop from list)"
 
 lemma slice_len[simp]: "\<lbrakk> from \<le> to; to \<le> length xs \<rbrakk> \<Longrightarrow> length (slice from to xs) = to - from"
 unfolding slice_def
 by simp
 
 lemma slice_head: "\<lbrakk> from < to; to \<le> length xs \<rbrakk> \<Longrightarrow> hd (slice from to xs) = xs ! from"
 unfolding slice_def
 proof -
   assume a1: "from < to"
   assume "to \<le> length xs"
   then have "\<And>n. to - (to - n) \<le> length (take to xs)"
     by (metis (no_types) slice_def diff_le_self drop_take length_drop slice_len)
   then show "hd (take (to - from) (drop from xs)) = xs ! from"
     using a1 by (metis diff_diff_cancel drop_take hd_drop_conv_nth leI le_antisym less_or_eq_imp_le nth_take)
 qed
 
 lemma slice_eq_bounds_empty[simp]: "slice i i xs = []"
 unfolding slice_def by auto
 
 lemma slice_nth: "\<lbrakk> from < to; to \<le> length xs; i < to - from \<rbrakk> \<Longrightarrow> slice from to xs ! i = xs ! (from + i)"
 unfolding slice_def
 by (induction "to - from" arbitrary: "from" to i) simp+
 
 lemma slice_prepend: "\<lbrakk> i \<le> k; k \<le> length xs \<rbrakk> \<Longrightarrow> let p = length ys in slice i k xs = slice (i + p) (k + p) (ys @ xs)"
 unfolding slice_def Let_def
 by force
 
 lemma slice_Nil[simp]: "slice begin end [] = []"  
   unfolding slice_def by auto
   
 lemma slice_Cons: "slice begin end (x#xs) 
   = (if begin=0 \<and> end>0 then x#slice begin (end-1) xs else slice (begin - 1) (end - 1) xs)"
   unfolding slice_def
   by (auto simp: take_Cons' drop_Cons')
 
 lemma slice_complete[simp]: "slice 0 (length xs) xs = xs"
   unfolding slice_def
   by simp
 
   
   
 subsubsection \<open>Miscellaneous\<close>
   lemma length_compl_induct[case_names Nil Cons]: "\<lbrakk>P []; !! e l . \<lbrakk>!! ll . length ll <= length l \<Longrightarrow> P ll\<rbrakk> \<Longrightarrow> P (e#l)\<rbrakk> \<Longrightarrow> P l"
     apply(induct_tac l rule: length_induct)
     apply(case_tac "xs")
     apply(auto)
   done
 
   lemma in_set_list_format: "\<lbrakk> e\<in>set l; !!l1 l2. l=l1@e#l2 \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
   proof (induct l arbitrary: P)
     case Nil thus ?case by auto
   next
     case (Cons a l) show ?case proof (cases "a=e")
       case True with Cons show ?thesis by force
     next
       case False with Cons.prems(1) have "e\<in>set l" by auto
       with Cons.hyps obtain l1 l2 where "l=l1@e#l2" by blast
       hence "a#l = (a#l1)@e#l2" by simp
       with Cons.prems(2) show P by blast
     qed
   qed
 
 lemma in_set_upd_cases:
   assumes "x\<in>set (l[i:=y])"
   obtains "i<length l" and "x=y" | "x\<in>set l"
   by (metis assms in_set_conv_nth length_list_update nth_list_update_eq
     nth_list_update_neq)
 
 lemma in_set_upd_eq_aux:
   assumes "i<length l"
   shows "x\<in>set (l[i:=y]) \<longleftrightarrow> x=y \<or> (\<forall>y. x\<in>set (l[i:=y]))"
   by (metis in_set_upd_cases assms list_update_overwrite
     set_update_memI)
 
 lemma in_set_upd_eq:
   assumes "i<length l"
   shows "x\<in>set (l[i:=y]) \<longleftrightarrow> x=y \<or> (x\<in>set l \<and> (\<forall>y. x\<in>set (l[i:=y])))"
   by (metis in_set_upd_cases in_set_upd_eq_aux assms)
 
 
   text \<open>Simultaneous induction over two lists, prepending an element to one of the lists in each step\<close>
   lemma list_2pre_induct[case_names base left right]: assumes BASE: "P [] []" and LEFT: "!!e w1' w2. P w1' w2 \<Longrightarrow> P (e#w1') w2" and RIGHT: "!!e w1 w2'. P w1 w2' \<Longrightarrow> P w1 (e#w2')" shows "P w1 w2"
   proof -
     { \<comment> \<open>The proof is done by induction over the sum of the lengths of the lists\<close>
       fix n
       have "!!w1 w2. \<lbrakk>length w1 + length w2 = n; P [] []; !!e w1' w2. P w1' w2 \<Longrightarrow> P (e#w1') w2; !!e w1 w2'. P w1 w2' \<Longrightarrow> P w1 (e#w2') \<rbrakk> \<Longrightarrow> P w1 w2 "
         apply (induct n)
         apply simp
         apply (case_tac w1)
         apply auto
         apply (case_tac w2)
         apply auto
         done
     } from this[OF _ BASE LEFT RIGHT] show ?thesis by blast
   qed
 
 
   lemma list_decomp_1: "length l=1 \<Longrightarrow> \<exists>a. l=[a]"
     by (case_tac l, auto)
 
   lemma list_decomp_2: "length l=2 \<Longrightarrow> \<exists>a b. l=[a,b]"
     by (case_tac l, auto simp add: list_decomp_1)
 
 
 
   lemma list_rest_coinc: "\<lbrakk>length s2 \<le> length s1; s1@r1 = s2@r2\<rbrakk> \<Longrightarrow> \<exists>r1p. r2=r1p@r1"
     by (metis append_eq_append_conv_if)
 
   lemma list_tail_coinc: "n1#r1 = n2#r2 \<Longrightarrow> n1=n2 & r1=r2"
     by (auto)
 
 
   lemma last_in_set[intro]: "\<lbrakk>l\<noteq>[]\<rbrakk> \<Longrightarrow> last l \<in> set l"
     by (induct l) auto
 
   lemma empty_append_eq_id[simp]: "(@) [] = (\<lambda>x. x)" by auto
       
   lemma op_conc_empty_img_id[simp]: "((@) [] ` L) = L" by auto
 
 
   lemma distinct_match: "\<lbrakk> distinct (al@e#bl) \<rbrakk> \<Longrightarrow> (al@e#bl = al'@e#bl') \<longleftrightarrow> (al=al' \<and> bl=bl')"
   proof (rule iffI, induct al arbitrary: al')
     case Nil thus ?case by (cases al') auto
   next
     case (Cons a al) note Cprems=Cons.prems note Chyps=Cons.hyps
     show ?case proof (cases al')
       case Nil with Cprems have False by auto
       thus ?thesis ..
     next
       case [simp]: (Cons a' all')
       with Cprems have [simp]: "a=a'" and P: "al@e#bl = all'@e#bl'" by auto
       from Cprems(1) have D: "distinct (al@e#bl)" by auto
       from Chyps[OF D P] have [simp]: "al=all'" "bl=bl'" by auto
       show ?thesis by simp
     qed
   qed simp
 
 
   lemma prop_match: "\<lbrakk> list_all P al; \<not>P e; \<not>P e'; list_all P bl \<rbrakk> \<Longrightarrow> (al@e#bl = al'@e'#bl') \<longleftrightarrow> (al=al' \<and> e=e' \<and> bl=bl')"
     apply (rule iffI, induct al arbitrary: al')
     apply (case_tac al', fastforce, fastforce)+
     done
 
   lemmas prop_matchD = rev_iffD1[OF _ prop_match[where P=P]] for P
 
   declare distinct_tl[simp]
 
 
 lemma list_se_match[simp]:
   "l1 \<noteq> [] \<Longrightarrow> l1@l2 = [a] \<longleftrightarrow> l1 = [a] \<and> l2 = []"
   "l2 \<noteq> [] \<Longrightarrow> l1@l2 = [a] \<longleftrightarrow> l1 = [] \<and> l2 = [a]"
   "l1 \<noteq> [] \<Longrightarrow> [a] = l1@l2 \<longleftrightarrow> l1 = [a] \<and> l2 = []"
   "l2 \<noteq> [] \<Longrightarrow> [a] = l1@l2 \<longleftrightarrow> l1 = [] \<and> l2 = [a]"
   apply (cases l1, simp_all)
   apply (cases l1, simp_all)
   apply (cases l1, auto) []
   apply (cases l1, auto) []
   done
 
 
 
 
 
     (* Placed here because it depends on xy_in_set_cases *)
 lemma distinct_map_eq: "\<lbrakk> distinct (List.map f l); f x = f y; x\<in>set l; y\<in>set l \<rbrakk> \<Longrightarrow> x=y"
   by (erule (2) xy_in_set_cases) auto
 
 
 
 lemma upt_append:
   assumes "i<j"
   shows "[0..<i]@[i..<j] = [0..<j]"
   using assms
   apply (induct j)
   apply simp
   apply (case_tac "i=j")
   apply auto
   done
 
 
 
 lemma upt_filter_extend:
   assumes LE: "u\<le>u'"
   assumes NP: "\<forall>i. u\<le>i \<and> i<u' \<longrightarrow> \<not>P i"
   shows "[i\<leftarrow>[0..<u]. P i] = [i\<leftarrow>[0..<u']. P i]"
 proof (cases "u=u'")
   case True thus ?thesis by simp
 next
   case False hence "u<u'" using LE by simp
   hence "[0..<u'] = [0..<u]@[u ..<u']"
     by (simp add: upt_append)
   hence "[i\<leftarrow>[0..<u']. P i] = [i\<leftarrow>[0..<u]. P i] @ [i\<leftarrow>[u..<u']. P i]"
     by simp
   also have "[i\<leftarrow>[u..<u']. P i] = []" using NP
     by (auto simp: filter_empty_conv)
   finally show ?thesis by simp
 qed
 
 
 lemma filter_upt_last:
   assumes E: "[k\<leftarrow>[0..<length l] . P (l!k)] = js @ [j]"
   assumes "j<i" and "i<length l"
   shows "\<not> P (l!i)"
 proof
   assume A: "P (l!i)"
   have "[0..<length l] = [0..<i]@[i..<length l]" using \<open>i<length l\<close>
     by (simp add: upt_append)
   also have "[i..<length l] = i#[Suc i..<length l]" using \<open>i<length l\<close>
     by (auto simp: upt_conv_Cons)
   finally
   have "[k\<leftarrow>[0..<i] . P (l!k)]@i#[k\<leftarrow>[Suc i..<length l] . P (l!k)] = js@[j]"
     unfolding E[symmetric]
     using \<open>P (l!i)\<close> by simp
   hence "j = last (i#[k\<leftarrow>[Suc i..<length l] . P (l!k)])"
     by (metis last_appendR last_snoc list.distinct(1))
   also have "\<dots> \<ge> i"
   proof -
     have "sorted (i#[k\<leftarrow>[Suc i..<length l] . P (l!k)])" (is "sorted ?l")
       by (simp add: sorted_filter[where f=id, simplified])
     hence "hd ?l \<le> last ?l"
       by (rule sorted_hd_last) simp
     thus ?thesis by simp
   qed
   finally have "i\<le>j" . thus False using \<open>j<i\<close> by simp
 qed
 
 lemma all_set_conv_nth: "(\<forall>x\<in>set l. P x) \<longleftrightarrow> (\<forall>i<length l. P (l!i))"
   by (auto intro: all_nth_imp_all_set)
 
 (* TODO: Special case of upt_eq_Nil_conv. Find cases where the latter does not work \<dots>
 *)    
 lemma upt_0_eq_Nil_conv[simp]: "[0..<j] = [] \<longleftrightarrow> j=0"
   by auto
 
 lemma filter_eq_snocD: "filter P l = l'@[x] \<Longrightarrow> x\<in>set l \<and> P x"
 proof -
   assume A: "filter P l = l'@[x]"
   hence "x\<in>set (filter P l)" by simp
   thus ?thesis by simp
 qed
 
 lemma lists_image_witness:
   assumes A: "x\<in>lists (f`Q)"
   obtains xo where "xo\<in>lists Q" "x=map f xo"
 proof -
   have "\<lbrakk> x\<in>lists (f`Q) \<rbrakk> \<Longrightarrow> \<exists>xo\<in>lists Q. x=map f xo"
   proof (induct x)
     case Nil thus ?case by auto
   next
     case (Cons x xs)
     then obtain xos where "xos\<in>lists Q" "xs=map f xos" by force
     moreover from Cons.prems have "x\<in>f`Q" by auto
     then obtain xo where "xo\<in>Q" "x=f xo" by auto
     ultimately show ?case
       by (rule_tac x="xo#xos" in bexI) auto
   qed
   thus ?thesis
     apply (simp_all add: A)
     apply (erule_tac bexE)
     apply (rule_tac that)
     apply assumption+
     done
 qed
 
 
 lemma map_of_None_filterD:
   "map_of xs x = None \<Longrightarrow> map_of (filter P xs) x = None"
 by(induct xs) auto
 
 lemma map_of_concat: "map_of (concat xss) = foldr (\<lambda>xs f. f ++ map_of xs) xss Map.empty"
 by(induct xss) simp_all
 
 lemma map_of_Some_split:
   "map_of xs k = Some v \<Longrightarrow> \<exists>ys zs. xs = ys @ (k, v) # zs \<and> map_of ys k = None"
 proof(induct xs)
   case (Cons x xs)
   obtain k' v' where x: "x = (k', v')" by(cases x)
   show ?case
   proof(cases "k' = k")
     case True
     with \<open>map_of (x # xs) k = Some v\<close> x have "x # xs = [] @ (k, v) # xs" "map_of [] k = None" by simp_all
     thus ?thesis by blast
   next
     case False
     with \<open>map_of (x # xs) k = Some v\<close> x
     have "map_of xs k = Some v" by simp
     from \<open>map_of xs k = Some v \<Longrightarrow> \<exists>ys zs. xs = ys @ (k, v) # zs \<and> map_of ys k = None\<close>[OF this]
     obtain ys zs where "xs = ys @ (k, v) # zs" "map_of ys k = None" by blast
     with False x have "x # xs = (x # ys) @ (k, v) # zs" "map_of (x # ys) k = None" by simp_all
     thus ?thesis by blast
   qed
 qed simp
 
 lemma map_add_find_left:
   "g k = None \<Longrightarrow> (f ++ g) k = f k"
 by(simp add: map_add_def)
 
 lemma map_add_left_None:
   "f k = None \<Longrightarrow> (f ++ g) k = g k"
 by(simp add: map_add_def split: option.split)
 
 lemma map_of_Some_filter_not_in:
   "\<lbrakk> map_of xs k = Some v; \<not> P (k, v); distinct (map fst xs) \<rbrakk> \<Longrightarrow> map_of (filter P xs) k = None"
 apply(induct xs)
 apply(auto)
 apply(auto simp add: map_of_eq_None_iff)
 done
 
 lemma distinct_map_fst_filterI: "distinct (map fst xs) \<Longrightarrow> distinct (map fst (filter P xs))"
 by(induct xs) auto
 
 lemma distinct_map_fstD: "\<lbrakk> distinct (map fst xs); (x, y) \<in> set xs; (x, z) \<in> set xs \<rbrakk> \<Longrightarrow> y = z"
 by(induct xs)(fastforce elim: notE rev_image_eqI)+
 
 
 
 lemma concat_filter_neq_Nil:
   "concat [ys\<leftarrow>xs. ys \<noteq> Nil] = concat xs"
 by(induct xs) simp_all
 
 lemma distinct_concat':
   "\<lbrakk>distinct [ys\<leftarrow>xs. ys \<noteq> Nil]; \<And>ys. ys \<in> set xs \<Longrightarrow> distinct ys;
    \<And>ys zs. \<lbrakk>ys \<in> set xs; zs \<in> set xs; ys \<noteq> zs\<rbrakk> \<Longrightarrow> set ys \<inter> set zs = {}\<rbrakk>
   \<Longrightarrow> distinct (concat xs)"
 by(erule distinct_concat[of "[ys\<leftarrow>xs. ys \<noteq> Nil]", unfolded concat_filter_neq_Nil]) auto
 
 lemma distinct_idx:
   assumes "distinct (map f l)"
   assumes "i<length l"
   assumes "j<length l"
   assumes "f (l!i) = f (l!j)"
   shows "i=j"
   by (metis assms distinct_conv_nth length_map nth_map)
 
 lemma replicate_Suc_conv_snoc:
   "replicate (Suc n) x = replicate n x @ [x]"
 by (metis replicate_Suc replicate_append_same)
 
 
 lemma filter_nth_ex_nth:
   assumes "n < length (filter P xs)"
   shows "\<exists>m. n \<le> m \<and> m < length xs \<and> filter P xs ! n = xs ! m \<and> filter P (take m xs) = take n (filter P xs)"
 using assms
 proof(induct xs rule: rev_induct)
   case Nil thus ?case by simp
 next
   case (snoc x xs)
   show ?case
   proof(cases "P x")
     case [simp]: False
     from \<open>n < length (filter P (xs @ [x]))\<close> have "n < length (filter P xs)" by simp
     hence "\<exists>m\<ge>n. m < length xs \<and> filter P xs ! n = xs ! m \<and> filter P (take m xs) = take n (filter P xs)" by(rule snoc)
     thus ?thesis by(auto simp add: nth_append)
   next
     case [simp]: True
     show ?thesis
     proof(cases "n = length (filter P xs)")
       case False
       with \<open>n < length (filter P (xs @ [x]))\<close> have "n < length (filter P xs)" by simp
       moreover hence "\<exists>m\<ge>n. m < length xs \<and> filter P xs ! n = xs ! m \<and> filter P (take m xs) = take n (filter P xs)"
         by(rule snoc)
       ultimately show ?thesis by(auto simp add: nth_append)
     next
       case [simp]: True
       hence "filter P (xs @ [x]) ! n = (xs @ [x]) ! length xs" by simp
       moreover have "length xs < length (xs @ [x])" by simp
       moreover have "length xs \<ge> n" by simp
       moreover have "filter P (take (length xs) (xs @ [x])) = take n (filter P (xs @ [x]))" by simp
       ultimately show ?thesis by blast
     qed
   qed
 qed
 
 lemma set_map_filter:
   "set (List.map_filter g xs) = {y. \<exists>x. x \<in> set xs \<and> g x = Some y}"
   by (induct xs) (auto simp add: List.map_filter_def set_eq_iff)
 
     
     
     
     
 
 subsection \<open>Quicksort by Relation\<close>
 
 text \<open>A functional implementation of quicksort on lists. It it similar to the
 one in Isabelle/HOL's example directory. However, it uses tail-recursion for append and arbitrary
 relations.\<close>
 
 fun partition_rev :: "('a \<Rightarrow> bool) \<Rightarrow> ('a list \<times> 'a list) \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> 'a list)" where
    "partition_rev P (yes, no) [] = (yes, no)"
  | "partition_rev P (yes, no) (x # xs) =
       partition_rev P (if P x then (x # yes, no) else (yes, x # no)) xs"
 
 lemma partition_rev_filter_conv :
   "partition_rev P (yes, no) xs = (rev (filter P xs) @ yes,  rev (filter (Not \<circ> P) xs) @ no)"
 by (induct xs arbitrary: yes no) (simp_all)
 
 function quicksort_by_rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "quicksort_by_rel R sl [] = sl"
 | "quicksort_by_rel R sl (x#xs) =
    (let (xs_s, xs_b) = partition_rev (\<lambda>y. R y x) ([],[]) xs in
     quicksort_by_rel R (x # (quicksort_by_rel R sl xs_b)) xs_s)"
 by pat_completeness simp_all
 termination
 by (relation "measure (\<lambda>(_, _, xs). length xs)")
    (simp_all add: partition_rev_filter_conv less_Suc_eq_le)
 
 lemma quicksort_by_rel_remove_acc :
   "quicksort_by_rel R sl xs = (quicksort_by_rel R [] xs @ sl)"
 proof (induct xs arbitrary: sl rule: measure_induct_rule[of "length"])
   case (less xs)
   note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x xs') note xs_eq[simp] = this
 
     obtain xs1 xs2 where part_rev_eq[simp]: "partition_rev (\<lambda>y. R y x) ([], []) xs' = (xs1, xs2)"
       by (rule prod.exhaust)
 
     from part_rev_eq[symmetric]
     have length_le: "length xs1 < length xs" "length xs2 < length xs"
       unfolding partition_rev_filter_conv by (simp_all add: less_Suc_eq_le)
 
     note ind_hyp1a = ind_hyp[OF length_le(1), of "x # quicksort_by_rel R [] xs2"]
     note ind_hyp1b = ind_hyp[OF length_le(1), of "x # quicksort_by_rel R [] xs2 @ sl"]
     note ind_hyp2 = ind_hyp[OF length_le(2), of sl]
 
     show ?thesis by (simp add: ind_hyp1a ind_hyp1b ind_hyp2)
   qed
 qed
 
 lemma quicksort_by_rel_remove_acc_guared :
   "sl \<noteq> [] \<Longrightarrow> quicksort_by_rel R sl xs = (quicksort_by_rel R [] xs @ sl)"
 by (metis quicksort_by_rel_remove_acc)
 
 lemma quicksort_by_rel_permutes [simp]:
   "mset (quicksort_by_rel R sl xs) = mset (xs @ sl)"
 proof (induct xs arbitrary: sl rule: measure_induct_rule[of "length"])
   case (less xs)
   note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x xs') note xs_eq[simp] = this
 
     obtain xs1 xs2 where part_rev_eq[simp]: "partition_rev (\<lambda>y. R y x) ([], []) xs' = (xs1, xs2)"
       by (rule prod.exhaust)
 
     from part_rev_eq[symmetric] have xs'_multi_eq : "mset xs' = mset xs1 + mset xs2"
       unfolding partition_rev_filter_conv
       by (simp add: mset_filter)
 
     from part_rev_eq[symmetric]
     have length_le: "length xs1 < length xs" "length xs2 < length xs"
       unfolding partition_rev_filter_conv by (simp_all add: less_Suc_eq_le)
 
     note ind_hyp[OF length_le(1)] ind_hyp[OF length_le(2)]
     thus ?thesis by (simp add: xs'_multi_eq union_assoc)
   qed
 qed
 
 lemma set_quicksort_by_rel [simp]: "set (quicksort_by_rel R sl xs) = set (xs @ sl)"
   unfolding set_mset_comp_mset [symmetric] o_apply by simp
 
 lemma sorted_wrt_quicksort_by_rel:
   fixes R:: "'x \<Rightarrow> 'x \<Rightarrow> bool"
   assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
       and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
   shows "sorted_wrt R (quicksort_by_rel R [] xs)"
 proof (induct xs rule: measure_induct_rule[of "length"])
   case (less xs)
   note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x xs') note xs_eq[simp] = this
 
     obtain xs1 xs2 where part_rev_eq[simp]: "partition_rev (\<lambda>y. R y x) ([], []) xs' = (xs1, xs2)"
       by (rule prod.exhaust)
 
     from part_rev_eq[symmetric] have xs1_props: "\<And>y. y \<in> set xs1 \<Longrightarrow> (R y x)" and
                                      xs2_props: "\<And>y. y \<in> set xs2 \<Longrightarrow> \<not>(R y x)"
       unfolding partition_rev_filter_conv
       by simp_all
 
     from xs2_props lin have xs2_props': "\<And>y. y \<in> set xs2 \<Longrightarrow> (R x y)" by blast
     from xs2_props' xs1_props trans_R have xs1_props':
       "\<And>y1 y2. y1 \<in> set xs1 \<Longrightarrow> y2 \<in> set xs2 \<Longrightarrow> (R y1 y2)"
       by metis
 
     from part_rev_eq[symmetric]
     have length_le: "length xs1 < length xs" "length xs2 < length xs"
       unfolding partition_rev_filter_conv by (simp_all add: less_Suc_eq_le)
 
     note ind_hyps = ind_hyp[OF length_le(1)] ind_hyp[OF length_le(2)]
     thus ?thesis
       by (simp add: quicksort_by_rel_remove_acc_guared sorted_wrt_append Ball_def
                     xs1_props xs2_props' xs1_props')
   qed
 qed
 
 lemma sorted_quicksort_by_rel:
   "sorted (quicksort_by_rel (\<le>) [] xs)"
   by (rule sorted_wrt_quicksort_by_rel) auto
 
 lemma sort_quicksort_by_rel:
   "sort = quicksort_by_rel (\<le>) []"
   apply (rule ext, rule properties_for_sort)
   apply(simp_all add: sorted_quicksort_by_rel)
 done
 
 lemma [code]: "quicksort = quicksort_by_rel (\<le>) []"
   apply (subst sort_quicksort[symmetric])
   by (rule sort_quicksort_by_rel)
 
 subsection \<open>Mergesort by Relation\<close>
 
 text \<open>A functional implementation of mergesort on lists. It it similar to the
 one in Isabelle/HOL's example directory. However, it uses tail-recursion for append and arbitrary
 relations.\<close>
 
 fun mergesort_by_rel_split :: "('a list \<times> 'a list) \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> 'a list)" where
    "mergesort_by_rel_split (xs1, xs2) [] = (xs1, xs2)"
  | "mergesort_by_rel_split (xs1, xs2) [x] = (x # xs1, xs2)"
  | "mergesort_by_rel_split (xs1, xs2) (x1 # x2 # xs) =
     mergesort_by_rel_split (x1 # xs1, x2 # xs2) xs"
 
 lemma list_induct_first2 [consumes 0, case_names Nil Sing Cons2]:
 assumes "P []" "\<And>x. P [x]" "\<And>x1 x2 xs. P xs \<Longrightarrow> P (x1 # x2 #xs)"
 shows "P xs"
 proof (induct xs rule: length_induct)
   case (1 xs) note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis using assms(1) by simp
   next
     case (Cons x1 xs') note xs_eq[simp] = this
     thus ?thesis
     proof (cases xs')
       case Nil thus ?thesis using assms(2) by simp
     next
       case (Cons x2 xs'') note xs'_eq[simp] = this
       show ?thesis
         by (simp add: ind_hyp assms(3))
     qed
   qed
 qed
 
 lemma mergesort_by_rel_split_length :
   "length (fst (mergesort_by_rel_split (xs1, xs2) xs)) = length xs1 + (length xs div 2) + (length xs mod 2) \<and>
    length (snd (mergesort_by_rel_split (xs1, xs2) xs)) = length xs2 + (length xs div 2)"
 by (induct xs arbitrary: xs1 xs2 rule: list_induct_first2)
    (simp_all)
 
 lemma mset_mergesort_by_rel_split [simp]:
   "mset (fst (mergesort_by_rel_split (xs1, xs2) xs)) +
    mset (snd (mergesort_by_rel_split (xs1, xs2) xs)) =
    mset xs + mset xs1 + mset xs2"
   apply (induct xs arbitrary: xs1 xs2 rule: list_induct_first2)
   apply (simp_all add: ac_simps)
 done
 
 fun mergesort_by_rel_merge :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
   "mergesort_by_rel_merge R (x#xs) (y#ys) =
      (if R x y then x # mergesort_by_rel_merge R xs (y#ys) else y # mergesort_by_rel_merge R (x#xs) ys)"
 | "mergesort_by_rel_merge R xs [] = xs"
 | "mergesort_by_rel_merge R [] ys = ys"
 
 declare mergesort_by_rel_merge.simps [simp del]
 
 lemma mergesort_by_rel_merge_simps[simp] :
   "mergesort_by_rel_merge R (x#xs) (y#ys) =
      (if R x y then x # mergesort_by_rel_merge R xs (y#ys) else y # mergesort_by_rel_merge R (x#xs) ys)"
   "mergesort_by_rel_merge R xs [] = xs"
   "mergesort_by_rel_merge R [] ys = ys"
   apply (simp_all add: mergesort_by_rel_merge.simps)
   apply (cases ys)
   apply (simp_all add: mergesort_by_rel_merge.simps)
 done
 
 lemma mergesort_by_rel_merge_induct [consumes 0, case_names Nil1 Nil2 Cons1 Cons2]:
 assumes "\<And>xs::'a list. P xs []" "\<And>ys::'b list. P [] ys"
         "\<And>x xs y ys. R x y \<Longrightarrow> P xs (y # ys) \<Longrightarrow> P (x # xs) (y # ys)"
         "\<And>x xs y ys. \<not>(R x y) \<Longrightarrow> P (x # xs) ys \<Longrightarrow> P (x # xs) (y # ys)"
 shows "P xs ys"
 proof (induct xs arbitrary: ys)
   case Nil thus ?case using assms(2) by simp
 next
   case (Cons x xs) note P_xs = this
   show ?case
   proof (induct ys)
     case Nil thus ?case using assms(1) by simp
   next
     case (Cons y ys) note P_x_xs_ys = this
     show ?case using assms(3,4)[of x y xs ys] P_x_xs_ys P_xs by metis
   qed
 qed
 
 lemma mset_mergesort_by_rel_merge [simp]:
   "mset (mergesort_by_rel_merge R xs ys) = mset xs + mset ys"
 by (induct R xs ys rule: mergesort_by_rel_merge.induct) (simp_all add: ac_simps)
 
 lemma set_mergesort_by_rel_merge [simp]:
   "set (mergesort_by_rel_merge R xs ys) = set xs \<union> set ys"
   by (induct R xs ys rule: mergesort_by_rel_merge.induct) auto
 
 lemma sorted_wrt_mergesort_by_rel_merge [simp]:
   assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
       and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
   shows  "sorted_wrt R (mergesort_by_rel_merge R xs ys) \<longleftrightarrow>
           sorted_wrt R xs \<and> sorted_wrt R ys"
 proof (induct xs ys rule: mergesort_by_rel_merge_induct[where R = R])
   case Nil1 thus ?case by simp
 next
   case Nil2 thus ?case by simp
 next
   case (Cons1 x xs y ys) thus ?case
     by (simp add: Ball_def) (metis trans_R)
 next
   case (Cons2 x xs y ys) thus ?case
     apply (auto simp add: Ball_def)
     apply (metis lin)
     apply (metis lin trans_R)
   done
 qed
 
 function mergesort_by_rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
   "mergesort_by_rel R xs =
     (if length xs < 2 then xs else
      (mergesort_by_rel_merge R
        (mergesort_by_rel R (fst (mergesort_by_rel_split ([], []) xs)))
        (mergesort_by_rel R (snd (mergesort_by_rel_split ([], []) xs)))))"
 by auto
 termination
 by (relation "measure (\<lambda>(_, xs). length xs)")
   (simp_all add: mergesort_by_rel_split_length not_less minus_div_mult_eq_mod [symmetric])
 
 declare mergesort_by_rel.simps [simp del]
 
 lemma mergesort_by_rel_simps [simp, code] :
   "mergesort_by_rel R [] = []"
   "mergesort_by_rel R [x] = [x]"
   "mergesort_by_rel R (x1 # x2 # xs) =
    (let (xs1, xs2) = (mergesort_by_rel_split ([x1], [x2]) xs) in
    mergesort_by_rel_merge R (mergesort_by_rel R xs1) (mergesort_by_rel R xs2))"
 apply (simp add: mergesort_by_rel.simps)
 apply (simp add: mergesort_by_rel.simps)
 apply (simp add: mergesort_by_rel.simps[of _ "x1 # x2 # xs"] split: prod.splits)
 done
 
 lemma mergesort_by_rel_permutes [simp]:
   "mset (mergesort_by_rel R xs) = mset xs"
 proof (induct xs rule: length_induct)
   case (1 xs) note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x1 xs') note xs_eq[simp] = this
     show ?thesis
     proof (cases xs')
       case Nil thus ?thesis by simp
     next
       case (Cons x2 xs'') note xs'_eq[simp] = this
 
       have "length (fst (mergesort_by_rel_split ([], []) xs)) < length xs"
            "length (snd (mergesort_by_rel_split ([], []) xs)) < length xs"
         by (simp_all add: mergesort_by_rel_split_length)
       with ind_hyp show ?thesis
         unfolding mergesort_by_rel.simps[of _ xs]
         by (simp add: ac_simps)
     qed
   qed
 qed
 
 lemma set_mergesort_by_rel [simp]: "set (mergesort_by_rel R xs) = set xs"
   unfolding set_mset_comp_mset [symmetric] o_apply by simp
 
 lemma sorted_wrt_mergesort_by_rel:
   fixes R:: "'x \<Rightarrow> 'x \<Rightarrow> bool"
   assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
       and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
   shows "sorted_wrt R (mergesort_by_rel R xs)"
 proof (induct xs rule: measure_induct_rule[of "length"])
   case (less xs)
   note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x xs') note xs_eq[simp] = this
     thus ?thesis
     proof (cases xs')
       case Nil thus ?thesis by simp
     next
       case (Cons x2 xs'') note xs'_eq[simp] = this
 
       have "length (fst (mergesort_by_rel_split ([], []) xs)) < length xs"
            "length (snd (mergesort_by_rel_split ([], []) xs)) < length xs"
         by (simp_all add: mergesort_by_rel_split_length)
       with ind_hyp show ?thesis
         unfolding mergesort_by_rel.simps[of _ xs]
         by (simp add: sorted_wrt_mergesort_by_rel_merge[OF lin trans_R])
     qed
   qed
 qed
 
 lemma sorted_mergesort_by_rel:
   "sorted (mergesort_by_rel (\<le>) xs)"
 by (rule sorted_wrt_mergesort_by_rel) auto
 
 lemma sort_mergesort_by_rel:
   "sort = mergesort_by_rel (\<le>)"
   apply (rule ext, rule properties_for_sort)
   apply(simp_all add: sorted_mergesort_by_rel)
 done
 
 definition "mergesort = mergesort_by_rel (\<le>)"
 
 lemma sort_mergesort: "sort = mergesort"
   unfolding mergesort_def by (rule sort_mergesort_by_rel)
 
 subsubsection \<open>Mergesort with Remdup\<close>
 term merge
 
 fun merge :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    "merge [] l2 = l2"
  | "merge l1 [] = l1"
  | "merge (x1 # l1) (x2 # l2) =
     (if (x1 < x2) then x1 # (merge l1 (x2 # l2)) else
      (if (x1 = x2) then x1 # (merge l1 l2) else x2 # (merge (x1 # l1) l2)))"
 
 lemma merge_correct :
 assumes l1_OK: "distinct l1 \<and> sorted l1"
 assumes l2_OK: "distinct l2 \<and> sorted l2"
 shows "distinct (merge l1 l2) \<and> sorted (merge l1 l2) \<and> set (merge l1 l2) = set l1 \<union> set l2"
 using assms
 proof (induct l1 arbitrary: l2)
   case Nil thus ?case by simp
 next
   case (Cons x1 l1 l2)
   note x1_l1_props = Cons(2)
   note l2_props = Cons(3)
 
   from x1_l1_props have l1_props: "distinct l1 \<and> sorted l1"
                     and x1_nin_l1: "x1 \<notin> set l1"
                     and x1_le: "\<And>x. x \<in> set l1 \<Longrightarrow> x1 \<le> x"
     by (simp_all add: Ball_def)
 
   note ind_hyp_l1 = Cons(1)[OF l1_props]
 
   show ?case
   using l2_props
   proof (induct l2)
     case Nil with x1_l1_props show ?case by simp
   next
     case (Cons x2 l2)
     note x2_l2_props = Cons(2)
     from x2_l2_props have l2_props: "distinct l2 \<and> sorted l2"
                     and x2_nin_l2: "x2 \<notin> set l2"
                     and x2_le: "\<And>x. x \<in> set l2 \<Longrightarrow> x2 \<le> x"
     by (simp_all add: Ball_def)
 
     note ind_hyp_l2 = Cons(1)[OF l2_props]
     show ?case
     proof (cases "x1 < x2")
       case True note x1_less_x2 = this
 
       from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
       show ?thesis
         apply (auto simp add: Ball_def)
         apply (metis linorder_not_le)
         apply (metis linorder_not_less xt1(6) xt1(9))
       done
     next
       case False note x2_le_x1 = this
 
       show ?thesis
       proof (cases "x1 = x2")
         case True note x1_eq_x2 = this
 
         from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
         show ?thesis by (simp add: x1_eq_x2 Ball_def)
       next
         case False note x1_neq_x2 = this
         with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto
 
         from ind_hyp_l2 x2_le_x1 x1_neq_x2 x2_le x2_nin_l2 x1_le
         show ?thesis
           apply (simp add: x2_less_x1 Ball_def)
           apply (metis linorder_not_le x2_less_x1 xt1(7))
         done
       qed
     qed
   qed
 qed
 
 function merge_list :: "'a::{linorder} list list \<Rightarrow> 'a list list \<Rightarrow> 'a list" where
    "merge_list [] [] = []"
  | "merge_list [] [l] = l"
  | "merge_list (la # acc2) [] = merge_list [] (la # acc2)"
  | "merge_list (la # acc2) [l] = merge_list [] (l # la # acc2)"
  | "merge_list acc2 (l1 # l2 # ls) =
     merge_list ((merge l1 l2) # acc2) ls"
 by pat_completeness simp_all
 termination
 by (relation "measure (\<lambda>(acc, ls). 3 * length acc + 2 * length ls)") (simp_all)
 
 lemma merge_list_correct :
 assumes ls_OK: "\<And>l. l \<in> set ls \<Longrightarrow> distinct l \<and> sorted l"
 assumes as_OK: "\<And>l. l \<in> set as \<Longrightarrow> distinct l \<and> sorted l"
 shows "distinct (merge_list as ls) \<and> sorted (merge_list as ls) \<and>
        set (merge_list as ls) = set (concat (as @ ls))"
 using assms
 proof (induct as ls rule: merge_list.induct)
   case 1 thus ?case by simp
 next
   case 2 thus ?case by simp
 next
   case 3 thus ?case by simp
 next
   case 4 thus ?case by auto
 next
   case (5 acc l1 l2 ls)
   note ind_hyp = 5(1)
   note l12_l_OK = 5(2)
   note acc_OK = 5(3)
 
   from l12_l_OK acc_OK merge_correct[of l1 l2]
     have set_merge_eq: "set (merge l1 l2) = set l1 \<union> set l2" by auto
 
   from l12_l_OK acc_OK merge_correct[of l1 l2]
   have "distinct (merge_list (merge l1 l2 # acc) ls) \<and>
         sorted (merge_list (merge l1 l2 # acc) ls) \<and>
         set (merge_list (merge l1 l2 # acc) ls) =
         set (concat ((merge l1 l2 # acc) @ ls))"
     by (rule_tac ind_hyp) auto
   with set_merge_eq show ?case by auto
 qed
 
 
 definition mergesort_remdups where
   "mergesort_remdups xs = merge_list [] (map (\<lambda>x. [x]) xs)"
 
 lemma mergesort_remdups_correct :
   "distinct (mergesort_remdups l)
   \<and> sorted (mergesort_remdups l)
   \<and> (set (mergesort_remdups l) = set l)"
 proof -
   let ?l' = "map (\<lambda>x. [x]) l"
 
   { fix xs
     assume "xs \<in> set ?l'"
     then obtain x where xs_eq: "xs = [x]" by auto
     hence "distinct xs \<and> sorted xs" by simp
   } note l'_OK = this
 
   from merge_list_correct[of "?l'" "[]", OF l'_OK]
   show ?thesis unfolding mergesort_remdups_def by simp
 qed
 
 (* TODO: Move *)
 lemma ex1_eqI: "\<lbrakk>\<exists>!x. P x; P a; P b\<rbrakk> \<Longrightarrow> a=b"
   by blast
 
 lemma remdup_sort_mergesort_remdups:
   "remdups o sort = mergesort_remdups" (is "?lhs=?rhs")
 proof
   fix l
   have "set (?lhs l) = set l" and "sorted (?lhs l)" and "distinct (?lhs l)"
     by simp_all
   moreover note mergesort_remdups_correct
   ultimately show "?lhs l = ?rhs l"
     by (auto intro!: ex1_eqI[OF finite_sorted_distinct_unique[OF finite_set]])
 qed
 
 subsection \<open>Native Integers\<close>  
 lemma int_of_integer_less_iff: "int_of_integer x < int_of_integer y \<longleftrightarrow> x<y"
   by (simp add: less_integer_def)
 
 lemma nat_of_integer_less_iff: "x\<ge>0 \<Longrightarrow> y\<ge>0 \<Longrightarrow> nat_of_integer x < nat_of_integer y \<longleftrightarrow> x<y"
   unfolding nat_of_integer.rep_eq
   by (auto simp: int_of_integer_less_iff nat_less_eq_zless int_of_integer_less_iff[of 0, simplified])
   
   
 subsection "Natural Numbers"
 lemma exists_leI:
   assumes hyp: "(\<forall>n' < n. \<not> P n') \<Longrightarrow> P (n::nat)"
   shows "\<exists>n' \<le> n. P n'"
 proof (rule classical)
   assume contra: "\<not> (\<exists>n'\<le>n. P n')"
   hence "\<forall>n' < n. \<not> P n'" by auto
   hence "P n" by (rule hyp)
   thus "\<exists>n'\<le>n. P n'" by auto
 qed
 
 subsubsection \<open>Induction on nat\<close>
   lemma nat_compl_induct[case_names 0 Suc]: "\<lbrakk>P 0; \<And>n . \<forall>nn. nn \<le> n \<longrightarrow> P nn \<Longrightarrow> P (Suc n)\<rbrakk> \<Longrightarrow> P n"
     apply(induct_tac n rule: nat_less_induct)
     apply(case_tac n)
     apply(auto)
   done
 
   lemma nat_compl_induct'[case_names 0 Suc]: "\<lbrakk>P 0; !! n . \<lbrakk>!! nn . nn \<le> n \<Longrightarrow> P nn\<rbrakk> \<Longrightarrow> P (Suc n)\<rbrakk> \<Longrightarrow> P n"
     apply(induct_tac n rule: nat_less_induct)
     apply(case_tac n)
     apply(auto)
   done
 
   lemma nz_le_conv_less: "0<k \<Longrightarrow> k \<le> m \<Longrightarrow> k - Suc 0 < m"
     by auto
       
   lemma min_Suc_gt[simp]: 
     "a<b \<Longrightarrow> min (Suc a) b = Suc a"  
     "a<b \<Longrightarrow> min b (Suc a) = Suc a"  
     by auto
     
     
 subsection \<open>Integer\<close>
 
 text \<open>Some setup from \<open>int\<close> transferred to \<open>integer\<close>\<close>
 
 lemma atLeastLessThanPlusOne_atLeastAtMost_integer: "{l..<u+1} = {l..(u::integer)}"
   apply (auto simp add: atLeastAtMost_def atLeastLessThan_def)
   including integer.lifting
   apply transfer
   apply simp
   done
 
 lemma atLeastPlusOneAtMost_greaterThanAtMost_integer: "{l+1..u} = {l<..(u::integer)}"
   including integer.lifting
   by (auto simp add: atLeastAtMost_def greaterThanAtMost_def, transfer, simp)
 
 lemma atLeastPlusOneLessThan_greaterThanLessThan_integer:
     "{l+1..<u} = {l<..<u::integer}"
   including integer.lifting
   by (auto simp add: atLeastLessThan_def greaterThanLessThan_def, transfer, simp)
 
 lemma image_atLeastZeroLessThan_integer: "0 \<le> u \<Longrightarrow>
     {(0::integer)..<u} = of_nat ` {..<nat_of_integer u}"
   including integer.lifting
   apply (unfold image_def lessThan_def)
   apply auto
   apply (rule_tac x = "nat_of_integer x" in exI)
   apply transfer
   apply (auto simp add: zless_nat_eq_int_zless [THEN sym])
   apply transfer
   apply simp
   done
 
 lemma image_add_integer_atLeastLessThan:
     "(%x. x + (l::integer)) ` {0..<u-l} = {l..<u}"
   apply (auto simp add: image_def)
   apply (rule_tac x = "x - l" in bexI)
   apply auto
   done
 
 lemma finite_atLeastZeroLessThan_integer: "finite {(0::integer)..<u}"
   apply (cases "0 \<le> u")
   apply (subst image_atLeastZeroLessThan_integer, assumption)
   apply (rule finite_imageI)
   apply auto
   done
 
 lemma finite_atLeastLessThan_integer [iff]: "finite {l..<u::integer}"
   apply (subgoal_tac "(%x. x + l) ` {0..<u-l} = {l..<u}")
   apply (erule subst)
   apply (rule finite_imageI)
   apply (rule finite_atLeastZeroLessThan_integer)
   apply (rule image_add_integer_atLeastLessThan)
   done
 
 lemma finite_atLeastAtMost_integer [iff]: "finite {l..(u::integer)}"
   by (subst atLeastLessThanPlusOne_atLeastAtMost_integer [THEN sym], simp)
 
 lemma finite_greaterThanAtMost_integer [iff]: "finite {l<..(u::integer)}"
   by (subst atLeastPlusOneAtMost_greaterThanAtMost_integer [THEN sym], simp)
 
 lemma finite_greaterThanLessThan_integer [iff]: "finite {l<..<u::integer}"
   by (subst atLeastPlusOneLessThan_greaterThanLessThan_integer [THEN sym], simp)
 
 
 subsection \<open>Functions of type @{typ "bool\<Rightarrow>bool"}\<close>
   lemma boolfun_cases_helper: "g=(\<lambda>x. False) | g=(\<lambda>x. x) | g=(\<lambda>x. True) | g= (\<lambda>x. \<not>x)"
   proof -
     { assume "g False" "g True"
       hence "g = (\<lambda>x. True)" by (rule_tac ext, case_tac x, auto)
     } moreover {
       assume "g False" "\<not>g True"
       hence "g = (\<lambda>x. \<not>x)" by (rule_tac ext, case_tac x, auto)
     } moreover {
       assume "\<not>g False" "g True"
       hence "g = (\<lambda>x. x)" by (rule_tac ext, case_tac x, auto)
     } moreover {
       assume "\<not>g False" "\<not>g True"
       hence "g = (\<lambda>x. False)" by (rule_tac ext, case_tac x, auto)
     } ultimately show ?thesis by fast
   qed
 
   lemma boolfun_cases[case_names False Id True Neg]: "\<lbrakk>g=(\<lambda>x. False) \<Longrightarrow> P; g=(\<lambda>x. x) \<Longrightarrow> P; g=(\<lambda>x. True) \<Longrightarrow> P; g=(\<lambda>x. \<not>x) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   proof -
     note boolfun_cases_helper[of g]
     moreover assume "g=(\<lambda>x. False) \<Longrightarrow> P" "g=(\<lambda>x. x) \<Longrightarrow> P" "g=(\<lambda>x. True) \<Longrightarrow> P" "g=(\<lambda>x. \<not>x) \<Longrightarrow> P"
     ultimately show ?thesis by fast
   qed
 
 
 subsection \<open>Definite and indefinite description\<close>
         text "Combined definite and indefinite description for binary predicate"
   lemma some_theI: assumes EX: "\<exists>a b . P a b" and BUN: "!! b1 b2 . \<lbrakk>\<exists>a . P a b1; \<exists>a . P a b2\<rbrakk> \<Longrightarrow> b1=b2"
     shows "P (SOME a . \<exists>b . P a b) (THE b . \<exists>a . P a b)"
   proof -
                 from EX have "\<exists>b. P (SOME a. \<exists>b. P a b) b" by (rule someI_ex)
                 moreover from EX have "\<exists>b. \<exists>a. P a b" by blast
     with BUN theI'[of "\<lambda>b. \<exists>a. P a b"] have "\<exists>a. P a (THE b. \<exists>a. P a b)" by (unfold Ex1_def, blast)
                 moreover note BUN
                 ultimately show ?thesis by (fast)
         qed
 
   lemma some_insert_self[simp]: "S\<noteq>{} \<Longrightarrow> insert (SOME x. x\<in>S) S = S"
     by (auto intro: someI)
 
   lemma some_elem[simp]: "S\<noteq>{} \<Longrightarrow> (SOME x. x\<in>S) \<in> S"
     by (auto intro: someI)
 
 subsubsection\<open>Hilbert Choice with option\<close>
 
 definition Eps_Opt where
   "Eps_Opt P = (if (\<exists>x. P x) then Some (SOME x. P x) else None)"
 
 lemma some_opt_eq_trivial[simp] :
   "Eps_Opt (\<lambda>y. y = x) = Some x"
 unfolding Eps_Opt_def by simp
 
 lemma some_opt_sym_eq_trivial[simp] :
   "Eps_Opt ((=) x) = Some x"
 unfolding Eps_Opt_def by simp
 
 lemma some_opt_false_trivial[simp] :
   "Eps_Opt (\<lambda>_. False) = None"
 unfolding Eps_Opt_def by simp
 
 lemma Eps_Opt_eq_None[simp] :
   "Eps_Opt P = None \<longleftrightarrow> \<not>(Ex P)"
 unfolding Eps_Opt_def by simp
 
 lemma Eps_Opt_eq_Some_implies :
   "Eps_Opt P = Some x \<Longrightarrow> P x"
 unfolding Eps_Opt_def
 by (metis option.inject option.simps(2) someI_ex)
 
 lemma Eps_Opt_eq_Some :
 assumes P_prop: "\<And>x'. P x \<Longrightarrow> P x' \<Longrightarrow> x' = x"
 shows "Eps_Opt P = Some x \<longleftrightarrow> P x"
 using P_prop
 unfolding Eps_Opt_def
 by (metis option.inject option.simps(2) someI_ex)
 
 subsection \<open>Product Type\<close>
 
 lemma nested_case_prod_simp: "(\<lambda>(a,b) c. f a b c) x y =
   (case_prod (\<lambda>a b. f a b y) x)"
   by (auto split: prod.split)
 
 lemma fn_fst_conv: "(\<lambda>x. (f (fst x))) = (\<lambda>(a,_). f a)"
   by auto
 lemma fn_snd_conv: "(\<lambda>x. (f (snd x))) = (\<lambda>(_,b). f b)"
   by auto
 
 fun pairself where
   "pairself f (a,b) = (f a, f b)"
 
 lemma pairself_image_eq[simp]:
   "pairself f ` {(a,b). P a b} = {(f a, f b)| a b. P a b}"
   by force
 
 lemma pairself_image_cart[simp]: "pairself f ` (A\<times>B) = f`A \<times> f`B"
   by (auto simp: image_def)
 
 lemma in_prod_fst_sndI: "fst x \<in> A \<Longrightarrow> snd x \<in> B \<Longrightarrow> x\<in>A\<times>B"
   by (cases x) auto
 
 lemma inj_Pair[simp]:
   "inj_on (\<lambda>x. (x,c x)) S"
   "inj_on (\<lambda>x. (c x,x)) S"
   by (auto intro!: inj_onI)
 
 declare Product_Type.swap_inj_on[simp]
 
 lemma img_fst [intro]:
   assumes "(a,b) \<in> S"
   shows "a \<in> fst ` S"
 by (rule image_eqI[OF _ assms]) simp
 
 lemma img_snd [intro]:
   assumes "(a,b) \<in> S"
   shows "b \<in> snd ` S"
 by (rule image_eqI[OF _ assms]) simp
 
 lemma range_prod:
   "range f \<subseteq> (range (fst \<circ> f)) \<times> (range (snd \<circ> f))"
 proof
   fix y
   assume "y \<in> range f"
   then obtain x where y: "y = f x" by auto
   hence "y = (fst(f x), snd(f x))"
     by simp
   thus "y \<in> (range (fst \<circ> f)) \<times> (range (snd \<circ> f))"
     by (fastforce simp add: image_def)
 qed
 
 lemma finite_range_prod:
   assumes fst: "finite (range (fst \<circ> f))"
   and     snd: "finite (range (snd \<circ> f))"
   shows "finite (range f)"
 proof -
   from fst snd have "finite (range (fst \<circ> f) \<times> range (snd \<circ> f))"
     by (rule finite_SigmaI)
   thus ?thesis
     by (rule finite_subset[OF range_prod])
 qed
 
 lemma fstE:
   "x = (a,b) \<Longrightarrow> P (fst x) \<Longrightarrow> P a"
 by (metis fst_conv)
 
 lemma sndE:
   "x = (a,b) \<Longrightarrow> P (snd x) \<Longrightarrow> P b"
 by (metis snd_conv)
 
 subsubsection \<open>Uncurrying\<close>
 
 (* TODO: Move to HOL/Product_Type? Lars H: "It's equal to case_prod, should use an abbreviation"*)
 definition uncurry :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c" where
   "uncurry f \<equiv> \<lambda>(a,b). f a b"
 
 lemma uncurry_apply[simp]: "uncurry f (a,b) = f a b"
   unfolding uncurry_def
   by simp
 
 lemma curry_uncurry_id[simp]: "curry (uncurry f) = f"
   unfolding uncurry_def
   by simp
 
 lemma uncurry_curry_id[simp]: "uncurry (curry f) = f"
   unfolding uncurry_def
   by simp
 
 lemma do_curry: "f (a,b) = curry f a b" by simp
 lemma do_uncurry: "f a b = uncurry f (a,b)" by simp
   
 subsection \<open>Sum Type\<close>    
 lemma map_sum_Inr_conv: "map_sum fl fr s = Inr y \<longleftrightarrow> (\<exists>x. s=Inr x \<and> y = fr x)"
   by (cases s) auto
 lemma map_sum_Inl_conv: "map_sum fl fr s = Inl y \<longleftrightarrow> (\<exists>x. s=Inl x \<and> y = fl x)"
   by (cases s) auto
   
   
 subsection \<open>Directed Graphs and Relations\<close>
 
   subsubsection "Reflexive-Transitive Closure"
   lemma r_le_rtrancl[simp]: "S\<subseteq>S\<^sup>*" by auto
   lemma rtrancl_mono_rightI: "S\<subseteq>S' \<Longrightarrow> S\<subseteq>S'\<^sup>*" by auto
 
   lemma trancl_sub:
     "R \<subseteq> R\<^sup>+"
   by auto
 
   lemma trancl_single[simp]:
     "{(a,b)}\<^sup>+ = {(a,b)}"
     by (auto simp: trancl_insert)
 
 
   text \<open>Pick first non-reflexive step\<close>
   lemma converse_rtranclE'[consumes 1, case_names base step]:
     assumes "(u,v)\<in>R\<^sup>*"
     obtains "u=v"
     | vh where "u\<noteq>vh" and "(u,vh)\<in>R" and "(vh,v)\<in>R\<^sup>*"
     using assms
     apply (induct rule: converse_rtrancl_induct)
     apply auto []
     apply (case_tac "y=z")
     apply auto
     done
 
   lemma in_rtrancl_insert: "x\<in>R\<^sup>* \<Longrightarrow> x\<in>(insert r R)\<^sup>*"
     by (metis in_mono rtrancl_mono subset_insertI)
 
 
   lemma rtrancl_apply_insert: "R\<^sup>*``(insert x S) = insert x (R\<^sup>*``(S\<union>R``{x}))"
     apply (auto)
     apply (erule converse_rtranclE)
     apply auto [2]
     apply (erule converse_rtranclE)
     apply (auto intro: converse_rtrancl_into_rtrancl) [2]
     done
 
 
 
 
   text \<open>A path in a graph either does not use nodes from S at all, or it has a prefix leading to a node in S and a suffix that does not use nodes in S\<close>
   lemma rtrancl_last_visit[cases set, case_names no_visit last_visit_point]:
     shows
     "\<lbrakk> (q,q')\<in>R\<^sup>*;
        (q,q')\<in>(R-UNIV\<times>S)\<^sup>* \<Longrightarrow> P;
        !!qt. \<lbrakk> qt\<in>S; (q,qt)\<in>R\<^sup>+; (qt,q')\<in>(R-UNIV\<times>S)\<^sup>* \<rbrakk> \<Longrightarrow> P
      \<rbrakk> \<Longrightarrow> P"
   proof (induct rule: converse_rtrancl_induct[case_names refl step])
     case refl thus ?case by auto
   next
     case (step q qh)
     show P proof (rule step.hyps(3))
       assume A: "(qh,q')\<in>(R-UNIV\<times>S)\<^sup>*"
       show P proof (cases "qh\<in>S")
         case False
         with step.hyps(1) A have "(q,q')\<in>(R-UNIV\<times>S)\<^sup>*"
           by (auto intro: converse_rtrancl_into_rtrancl)
         with step.prems(1) show P .
       next
         case True
         from step.hyps(1) have "(q,qh)\<in>R\<^sup>+" by auto
         with step.prems(2) True A show P by blast
       qed
     next
       fix qt
       assume A: "qt\<in>S" "(qh,qt)\<in>R\<^sup>+" "(qt,q')\<in>(R-UNIV\<times>S)\<^sup>*"
       with step.hyps(1) have "(q,qt)\<in>R\<^sup>+" by auto
       with step.prems(2) A(1,3) show P by blast
     qed
   qed
 
   text \<open>Less general version of \<open>rtrancl_last_visit\<close>, but there's a short automatic proof\<close>
   lemma rtrancl_last_visit': "\<lbrakk> (q,q')\<in>R\<^sup>*; (q,q')\<in>(R-UNIV\<times>S)\<^sup>* \<Longrightarrow> P; !!qt. \<lbrakk> qt\<in>S; (q,qt)\<in>R\<^sup>*; (qt,q')\<in>(R-UNIV\<times>S)\<^sup>* \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (induct rule: converse_rtrancl_induct) (auto intro: converse_rtrancl_into_rtrancl)
 
   lemma rtrancl_last_visit_node:
     assumes "(s,s')\<in>R\<^sup>*"
     shows "s\<noteq>sh \<and> (s,s')\<in>(R \<inter> (UNIV \<times> (-{sh})))\<^sup>* \<or>
             (s,sh)\<in>R\<^sup>* \<and> (sh,s')\<in>(R \<inter> (UNIV \<times> (-{sh})))\<^sup>*"
     using assms
   proof (induct rule: converse_rtrancl_induct)
     case base thus ?case by auto
   next
     case (step s st)
     moreover {
       assume P: "(st,s')\<in> (R \<inter> UNIV \<times> - {sh})\<^sup>*"
       {
         assume "st=sh" with step have ?case
           by auto
       } moreover {
         assume "st\<noteq>sh"
         with \<open>(s,st)\<in>R\<close> have "(s,st)\<in>(R \<inter> UNIV \<times> - {sh})\<^sup>*" by auto
         also note P
         finally have ?case by blast
       } ultimately have ?case by blast
     } moreover {
       assume P: "(st, sh) \<in> R\<^sup>* \<and> (sh, s') \<in> (R \<inter> UNIV \<times> - {sh})\<^sup>*"
       with step(1) have ?case
         by (auto dest: converse_rtrancl_into_rtrancl)
     } ultimately show ?case by blast
   qed
 
   text \<open>Find last point where a path touches a set\<close>
   lemma rtrancl_last_touch: "\<lbrakk> (q,q')\<in>R\<^sup>*; q\<in>S; !!qt. \<lbrakk> qt\<in>S; (q,qt)\<in>R\<^sup>*; (qt,q')\<in>(R-UNIV\<times>S)\<^sup>* \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (erule rtrancl_last_visit') auto
 
   text \<open>A path either goes over edge once, or not at all\<close>
   lemma trancl_over_edgeE:
     assumes "(u,w)\<in>(insert (v1,v2) E)\<^sup>+"
     obtains "(u,w)\<in>E\<^sup>+"
     | "(u,v1)\<in>E\<^sup>*" and "(v2,w)\<in>E\<^sup>*"
     using assms
   proof induct
     case (base z) thus ?thesis
       by (metis insertE prod.inject r_into_trancl' rtrancl_eq_or_trancl)
   next
     case (step y z) thus ?thesis
       by (metis (opaque_lifting, no_types)
         Pair_inject insertE rtrancl.simps trancl.simps trancl_into_rtrancl)
   qed
 
   lemma rtrancl_image_advance: "\<lbrakk>q\<in>R\<^sup>* `` Q0; (q,x)\<in>R\<rbrakk> \<Longrightarrow> x\<in>R\<^sup>* `` Q0"
     by (auto intro: rtrancl_into_rtrancl)
 
   lemma trancl_image_by_rtrancl: "(E\<^sup>+)``Vi \<union> Vi = (E\<^sup>*)``Vi"
     by (metis Image_Id Un_Image rtrancl_trancl_reflcl)
 
   lemma reachable_mono: "\<lbrakk>R\<subseteq>R'; X\<subseteq>X'\<rbrakk> \<Longrightarrow> R\<^sup>*``X \<subseteq> R'\<^sup>*``X'"
     by (metis Image_mono rtrancl_mono)
 
   lemma finite_reachable_advance:
     "\<lbrakk> finite (E\<^sup>*``{v0}); (v0,v)\<in>E\<^sup>* \<rbrakk> \<Longrightarrow> finite (E\<^sup>*``{v})"
     by (erule finite_subset[rotated]) auto
 
 lemma rtrancl_mono_mp: "U\<subseteq>V \<Longrightarrow> x\<in>U\<^sup>* \<Longrightarrow> x\<in>V\<^sup>*" by (metis in_mono rtrancl_mono)
 lemma trancl_mono_mp: "U\<subseteq>V \<Longrightarrow> x\<in>U\<^sup>+ \<Longrightarrow> x\<in>V\<^sup>+" by (metis trancl_mono)
 
 lemma rtrancl_mapI: "(a,b)\<in>E\<^sup>* \<Longrightarrow> (f a, f b)\<in>(pairself f `E)\<^sup>*"
   apply (induction rule: rtrancl_induct)
   apply (force intro: rtrancl.intros)+
   done
 
 lemma rtrancl_image_advance_rtrancl:
   assumes "q \<in> R\<^sup>*``Q0"
   assumes "(q,x) \<in> R\<^sup>*"
   shows "x \<in> R\<^sup>*``Q0"
   using assms
   by (metis rtrancl_idemp rtrancl_image_advance)
 
 lemma nth_step_trancl:
   "\<And>n m. \<lbrakk> \<And> n. n < length xs - 1 \<Longrightarrow> (xs ! Suc n, xs ! n) \<in> R \<rbrakk> \<Longrightarrow> n < length xs \<Longrightarrow> m < n \<Longrightarrow> (xs ! n, xs ! m) \<in> R\<^sup>+"
 proof (induction xs)
   case (Cons x xs)
   hence "\<And>n. n < length xs - 1 \<Longrightarrow> (xs ! Suc n, xs ! n) \<in> R"
     apply clarsimp
     by (metis One_nat_def diff_Suc_eq_diff_pred nth_Cons_Suc zero_less_diff)
   note IH = this[THEN Cons.IH]
 
   from Cons obtain n' where n': "Suc n' = n" by (cases n) blast+
 
   show ?case
   proof (cases m)
     case "0" with Cons have "xs \<noteq> []" by auto
     with "0" Cons.prems(1)[of m] have "(xs ! 0, x) \<in> R" by simp
     moreover from IH[where m = 0] have "\<And>n. n < length xs \<Longrightarrow> n > 0 \<Longrightarrow> (xs ! n, xs ! 0) \<in> R\<^sup>+" by simp
     ultimately have "\<And>n. n < length xs \<Longrightarrow> (xs ! n, x) \<in> R\<^sup>+" by (metis trancl_into_trancl gr0I r_into_trancl')
     with Cons "0" show ?thesis by auto
   next
     case (Suc m') with Cons.prems n' have "n' < length xs" "m' < n'" by auto
     with IH have "(xs ! n', xs ! m') \<in> R\<^sup>+" by simp
     with Suc n' show ?thesis by auto
   qed
 qed simp
 
 lemma Image_empty_trancl_Image_empty:
   "R `` {v} = {} \<Longrightarrow> R\<^sup>+ `` {v} = {}"
   unfolding Image_def
   by (auto elim: converse_tranclE)
 
 lemma Image_empty_rtrancl_Image_id:
   "R `` {v} = {} \<Longrightarrow> R\<^sup>* `` {v} = {v}"
   unfolding Image_def
   by (auto elim: converse_rtranclE)
 
 lemma trans_rtrancl_eq_reflcl:
   "trans A \<Longrightarrow> A^* = A^="
   by (simp add: rtrancl_trancl_reflcl)
 
 lemma refl_on_reflcl_Image:
   "refl_on B A \<Longrightarrow> C \<subseteq> B \<Longrightarrow> A^= `` C = A `` C"
   by (auto simp add: Image_def dest: refl_onD)
 
 lemma Image_absorb_rtrancl:
   "\<lbrakk> trans A; refl_on B A; C \<subseteq> B \<rbrakk> \<Longrightarrow> A^* `` C = A `` C"
   by (simp add: trans_rtrancl_eq_reflcl refl_on_reflcl_Image)
 
 lemma trancl_Image_unfold_left: "E\<^sup>+``S = E\<^sup>*``E``S"
   by (auto simp: trancl_unfold_left)
 
 lemma trancl_Image_unfold_right: "E\<^sup>+``S = E``E\<^sup>*``S"
   by (auto simp: trancl_unfold_right)
 
 lemma trancl_Image_advance_ss: "(u,v)\<in>E \<Longrightarrow> E\<^sup>+``{v} \<subseteq> E\<^sup>+``{u}"
   by auto
 
 lemma rtrancl_Image_advance_ss: "(u,v)\<in>E \<Longrightarrow> E\<^sup>*``{v} \<subseteq> E\<^sup>*``{u}"
   by auto
 
 (* FIXME: nicer name *)
 lemma trancl_union_outside:
   assumes "(v,w) \<in> (E\<union>U)\<^sup>+"
   and "(v,w) \<notin> E\<^sup>+"
   shows "\<exists>x y. (v,x) \<in> (E\<union>U)\<^sup>* \<and> (x,y) \<in> U \<and> (y,w) \<in> (E\<union>U)\<^sup>*"
 using assms
 proof (induction)
   case base thus ?case by auto
 next
   case (step w x)
   show ?case
   proof (cases "(v,w)\<in>E\<^sup>+")
     case True
     from step have "(v,w)\<in>(E\<union>U)\<^sup>*" by simp
     moreover from True step have "(w,x) \<in> U" by (metis Un_iff trancl.simps)
     moreover have "(x,x) \<in> (E\<union>U)\<^sup>*" by simp
     ultimately show ?thesis by blast
   next
     case False with step.IH obtain a b where "(v,a) \<in> (E\<union>U)\<^sup>*" "(a,b) \<in> U" "(b,w) \<in> (E\<union>U)\<^sup>*" by blast
     moreover with step have "(b,x) \<in> (E\<union>U)\<^sup>*" by (metis rtrancl_into_rtrancl)
     ultimately show ?thesis by blast
   qed
 qed
 
 lemma trancl_restrict_reachable:
   assumes "(u,v) \<in> E\<^sup>+"
   assumes "E``S \<subseteq> S"
   assumes "u\<in>S"
   shows "(u,v) \<in> (E\<inter>S\<times>S)\<^sup>+"
   using assms
   by (induction rule: converse_trancl_induct)
      (auto intro: trancl_into_trancl2)
 
 lemma rtrancl_image_unfold_right: "E``E\<^sup>*``V \<subseteq> E\<^sup>*``V"
   by (auto intro: rtrancl_into_rtrancl)
 
 
 lemma trancl_Image_in_Range:
   "R\<^sup>+ `` V \<subseteq> Range R"
 by (auto elim: trancl.induct)
 
 lemma rtrancl_Image_in_Field:
   "R\<^sup>* `` V \<subseteq> Field R \<union> V"
 proof -
   from trancl_Image_in_Range have "R\<^sup>+ `` V \<subseteq> Field R"
     unfolding Field_def by fast
   hence "R\<^sup>+ `` V \<union> V \<subseteq> Field R \<union> V" by blast
   with trancl_image_by_rtrancl show ?thesis by metis
 qed
 
 lemma rtrancl_sub_insert_rtrancl:
   "R\<^sup>* \<subseteq> (insert x R)\<^sup>*"
 by (auto elim: rtrancl.induct rtrancl_into_rtrancl)
 
 lemma trancl_sub_insert_trancl:
   "R\<^sup>+ \<subseteq> (insert x R)\<^sup>+"
 by (auto elim: trancl.induct trancl_into_trancl)
 
 lemma Restr_rtrancl_mono:
   "(v,w) \<in> (Restr E U)\<^sup>* \<Longrightarrow> (v,w) \<in> E\<^sup>*"
   by (metis inf_le1 rtrancl_mono subsetCE)
 
 lemma Restr_trancl_mono:
   "(v,w) \<in> (Restr E U)\<^sup>+ \<Longrightarrow> (v,w) \<in> E\<^sup>+"
   by (metis inf_le1 trancl_mono)
 
 
 
 
 
 
 
 
   subsubsection "Converse Relation"
 
   lemmas converse_add_simps = converse_Times trancl_converse[symmetric] converse_Un converse_Int
 
   lemma dom_ran_disj_comp[simp]: "Domain R \<inter> Range R = {} \<Longrightarrow> R O R = {}"
     by auto
 
   lemma below_Id_inv[simp]: "R\<inverse>\<subseteq>Id \<longleftrightarrow> R\<subseteq>Id" by (auto)
     
     
   subsubsection "Cyclicity"
 
   lemma cyclicE: "\<lbrakk>\<not>acyclic g; !!x. (x,x)\<in>g\<^sup>+ \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
     by (unfold acyclic_def) blast
 
   lemma acyclic_insert_cyclic: "\<lbrakk>acyclic g; \<not>acyclic (insert (x,y) g)\<rbrakk> \<Longrightarrow> (y,x)\<in>g\<^sup>*"
     by (unfold acyclic_def) (auto simp add: trancl_insert)
 
 
   text \<open>
     This lemma makes a case distinction about a path in a graph where a couple of edges with the same
     endpoint have been inserted: If there is a path from a to b, then there's such a path in the original graph, or
     there's a path that uses an inserted edge only once.
 
     Originally, this lemma was used to reason about the graph of an updated acquisition history. Any path in
     this graph is either already contained in the original graph, or passes via an
     inserted edge. Because all the inserted edges point to the same target node, in the
     second case, the path can be short-circuited to use exactly one inserted edge.
 \<close>
   lemma trancl_multi_insert[cases set, case_names orig via]:
     "\<lbrakk> (a,b)\<in>(r\<union>X\<times>{m})\<^sup>+;
       (a,b)\<in>r\<^sup>+ \<Longrightarrow> P;
        !!x. \<lbrakk> x\<in>X; (a,x)\<in>r\<^sup>*; (m,b)\<in>r\<^sup>* \<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
   proof (induct arbitrary: P rule: trancl_induct)
     case (base b) thus ?case by auto
   next
     case (step b c) show ?case proof (rule step.hyps(3))
       assume A: "(a,b)\<in>r\<^sup>+"
       note step.hyps(2)
       moreover {
         assume "(b,c)\<in>r"
         with A have "(a,c)\<in>r\<^sup>+" by auto
         with step.prems have P by blast
       } moreover {
         assume "b\<in>X" "c=m"
         with A have P by (rule_tac step.prems(2)) simp+
       } ultimately show P by auto
     next
       fix x
       assume A: "x \<in> X" "(a, x) \<in> r\<^sup>*" "(m, b) \<in> r\<^sup>*"
       note step.hyps(2)
       moreover {
         assume "(b,c)\<in>r"
         with A(3) have "(m,c)\<in>r\<^sup>*" by auto
         with step.prems(2)[OF A(1,2)] have P by blast
       } moreover {
         assume "b\<in>X" "c=m"
         with A have P by (rule_tac step.prems(2)) simp+
       } ultimately show P by auto
     qed
   qed
 
   text \<open>
     Version of @{thm [source] trancl_multi_insert} for inserted edges with the same startpoint.
 \<close>
   lemma trancl_multi_insert2[cases set, case_names orig via]:
     "\<lbrakk>(a,b)\<in>(r\<union>{m}\<times>X)\<^sup>+; (a,b)\<in>r\<^sup>+ \<Longrightarrow> P; !!x. \<lbrakk> x\<in>X; (a,m)\<in>r\<^sup>*; (x,b)\<in>r\<^sup>* \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
   proof goal_cases
     case prems: 1 from prems(1) have "(b,a)\<in>((r\<union>{m}\<times>X)\<^sup>+)\<inverse>" by simp
     also have "((r\<union>{m}\<times>X)\<^sup>+)\<inverse> = (r\<inverse>\<union>X\<times>{m})\<^sup>+" by (simp add: converse_add_simps)
     finally have "(b, a) \<in> (r\<inverse> \<union> X \<times> {m})\<^sup>+" .
     thus ?case
       by (auto elim!: trancl_multi_insert
                intro: prems(2,3)
             simp add: trancl_converse rtrancl_converse
     )
   qed
 
 lemma cyclic_subset:
   "\<lbrakk> \<not> acyclic R; R \<subseteq> S \<rbrakk> \<Longrightarrow> \<not> acyclic S"
   unfolding acyclic_def
   by (blast intro: trancl_mono)
 
 
 
 
 
   subsubsection \<open>Wellfoundedness\<close>
   lemma wf_min: assumes A: "wf R" "R\<noteq>{}" "!!m. m\<in>Domain R - Range R \<Longrightarrow> P" shows P proof -
     have H: "!!x. wf R \<Longrightarrow> \<forall>y. (x,y)\<in>R \<longrightarrow> x\<in>Domain R - Range R \<or> (\<exists>m. m\<in>Domain R - Range R)"
       by (erule_tac wf_induct_rule[where P="\<lambda>x. \<forall>y. (x,y)\<in>R \<longrightarrow> x\<in>Domain R - Range R \<or> (\<exists>m. m\<in>Domain R - Range R)"]) auto
     from A(2) obtain x y where "(x,y)\<in>R" by auto
     with A(1,3) H show ?thesis by blast
   qed
 
   lemma finite_wf_eq_wf_converse: "finite R \<Longrightarrow> wf (R\<inverse>) \<longleftrightarrow> wf R"
     by (metis acyclic_converse finite_acyclic_wf finite_acyclic_wf_converse wf_acyclic)
 
   lemma wf_max: assumes A: "wf (R\<inverse>)" "R\<noteq>{}" and C: "!!m. m\<in>Range R - Domain R \<Longrightarrow> P" shows "P"
   proof -
     from A(2) have NE: "R\<inverse>\<noteq>{}" by auto
     from wf_min[OF A(1) NE] obtain m where "m\<in>Range R - Domain R" by auto
     thus P by (blast intro: C)
   qed
 
     \<comment> \<open>Useful lemma to show well-foundedness of some process approaching a finite upper bound\<close>
   lemma wf_bounded_supset: "finite S \<Longrightarrow> wf {(Q',Q). Q'\<supset>Q \<and> Q'\<subseteq> S}"
   proof -
     assume [simp]: "finite S"
     hence [simp]: "!!x. finite (S-x)" by auto
     have "{(Q',Q). Q\<subset>Q' \<and> Q'\<subseteq> S} \<subseteq> inv_image ({(s'::nat,s). s'<s}) (\<lambda>Q. card (S-Q))"
     proof (intro subsetI, case_tac x, simp)
       fix a b
       assume A: "b\<subset>a \<and> a\<subseteq>S"
       hence "S-a \<subset> S-b" by blast
       thus "card (S-a) < card (S-b)" by (auto simp add: psubset_card_mono)
     qed
     moreover have "wf ({(s'::nat,s). s'<s})" by (rule wf_less)
     ultimately show ?thesis by (blast intro: wf_inv_image wf_subset)
   qed
 
   lemma wf_no_path: "Domain R \<inter> Range R = {} \<Longrightarrow> wf R"
     apply (rule wf_no_loop)
     by simp
 
 text \<open>Extend a wf-relation by a break-condition\<close>
 definition "brk_rel R \<equiv>
     {((False,x),(False,y)) | x y. (x,y)\<in>R}
   \<union> {((True,x),(False,y)) | x y. True}"
 
 lemma brk_rel_wf[simp,intro!]:
   assumes WF[simp]: "wf R"
   shows "wf (brk_rel R)"
 proof -
   have "wf {((False,x),(False,y)) | x y. (x,y)\<in>R}"
   proof -
     have "{((False,x),(False,y)) | x y. (x,y)\<in>R} \<subseteq> inv_image R snd"
       by auto
     from wf_subset[OF wf_inv_image[OF WF] this] show ?thesis .
   qed
   moreover have "wf {((True,x),(False,y)) | x y. True}"
     by (rule wf_no_path) auto
   ultimately show ?thesis
     unfolding brk_rel_def
     apply (subst Un_commute)
     by (blast intro: wf_Un)
 qed
 
 
 subsubsection \<open>Restrict Relation\<close>
 definition rel_restrict :: "('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set"
 where
   "rel_restrict R A \<equiv> {(v,w). (v,w) \<in> R \<and> v \<notin> A \<and> w \<notin> A}"
 
 lemma rel_restrict_alt_def:
   "rel_restrict R A = R \<inter> (-A) \<times> (-A)"
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrict_empty[simp]:
   "rel_restrict R {} = R"
 by (simp add: rel_restrict_def)
 
 lemma rel_restrict_notR:
   assumes "(x,y) \<in> rel_restrict A R"
   shows "x \<notin> R" and "y \<notin> R"
 using assms
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrict_sub:
   "rel_restrict R A \<subseteq> R"
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrict_Int_empty:
   "A \<inter> Field R = {} \<Longrightarrow> rel_restrict R A = R"
 unfolding rel_restrict_def Field_def
 by auto
 
 lemma Domain_rel_restrict:
   "Domain (rel_restrict R A) \<subseteq> Domain R - A"
 unfolding rel_restrict_def
 by auto
 
 lemma Range_rel_restrict:
   "Range (rel_restrict R A) \<subseteq> Range R - A"
 unfolding rel_restrict_def
 by auto
 
 lemma Field_rel_restrict:
   "Field (rel_restrict R A) \<subseteq> Field R - A"
 unfolding rel_restrict_def Field_def
 by auto
 
 lemma rel_restrict_compl:
   "rel_restrict R A \<inter> rel_restrict R (-A) = {}"
 unfolding rel_restrict_def
 by auto
 
 lemma finite_rel_restrict:
   "finite R \<Longrightarrow> finite (rel_restrict R A)"
 by (metis finite_subset rel_restrict_sub)
 
 lemma R_subset_Field: "R \<subseteq> Field R \<times> Field R"
   unfolding Field_def
   by auto
 
 lemma homo_rel_restrict_mono:
   "R \<subseteq> B \<times> B \<Longrightarrow> rel_restrict R A \<subseteq> (B - A) \<times> (B - A)"
 proof -
   assume A: "R \<subseteq> B \<times> B"
   hence "Field R \<subseteq> B" unfolding Field_def by auto
   with Field_rel_restrict have "Field (rel_restrict R A) \<subseteq> B - A"
     by (metis Diff_mono order_refl order_trans)
   with R_subset_Field show ?thesis by blast
 qed
 
 lemma rel_restrict_union:
   "rel_restrict R (A \<union> B) = rel_restrict (rel_restrict R A) B"
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrictI:
   "x \<notin> R \<Longrightarrow> y \<notin> R \<Longrightarrow> (x,y) \<in> E \<Longrightarrow> (x,y) \<in> rel_restrict E R"
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrict_lift:
   "(x,y) \<in> rel_restrict E R \<Longrightarrow> (x,y) \<in> E"
 unfolding rel_restrict_def
 by simp
 
 lemma rel_restrict_trancl_mem:
   "(a,b) \<in> (rel_restrict A R)\<^sup>+ \<Longrightarrow> (a,b) \<in> rel_restrict (A\<^sup>+) R"
 by (induction rule: trancl_induct) (auto simp add: rel_restrict_def)
 
 lemma rel_restrict_trancl_sub:
   "(rel_restrict A R)\<^sup>+ \<subseteq> rel_restrict (A\<^sup>+) R"
 by (metis subrelI rel_restrict_trancl_mem)
 
 lemma rel_restrict_mono:
   "A \<subseteq> B \<Longrightarrow> rel_restrict A R \<subseteq> rel_restrict B R"
 unfolding rel_restrict_def by auto
 
 lemma rel_restrict_mono2:
   "R \<subseteq> S \<Longrightarrow> rel_restrict A S \<subseteq> rel_restrict A R"
 unfolding rel_restrict_def by auto
 
 lemma rel_restrict_Sigma_sub:
   "rel_restrict ((A\<times>A)\<^sup>+) R \<subseteq> ((A - R) \<times> (A - R))\<^sup>+"
 unfolding rel_restrict_def
 by auto (metis DiffI converse_tranclE mem_Sigma_iff r_into_trancl tranclE)
 
 
 lemma finite_reachable_restrictedI:
   assumes F: "finite Q"
   assumes I: "I\<subseteq>Q"
   assumes R: "Range E \<subseteq> Q"
   shows "finite (E\<^sup>*``I)"
 proof -
   from I R have "E\<^sup>*``I \<subseteq> Q"
     by (force elim: rtrancl.cases)
   also note F
   finally (finite_subset) show ?thesis .
 qed
 
 context begin
   private lemma rtrancl_restrictI_aux:
     assumes "(u,v)\<in>(E-UNIV\<times>R)\<^sup>*"
     assumes "u\<notin>R"
     shows "(u,v)\<in>(rel_restrict E R)\<^sup>* \<and> v\<notin>R"
     using assms
     by (induction) (auto simp: rel_restrict_def intro: rtrancl.intros)
 
   corollary rtrancl_restrictI:
     assumes "(u,v)\<in>(E-UNIV\<times>R)\<^sup>*"
     assumes "u\<notin>R"
     shows "(u,v)\<in>(rel_restrict E R)\<^sup>*"
     using rtrancl_restrictI_aux[OF assms] ..
 end
 
 lemma E_closed_restr_reach_cases:
   assumes P: "(u,v)\<in>E\<^sup>*"
   assumes CL: "E``R \<subseteq> R"
   obtains "v\<in>R" | "u\<notin>R" "(u,v)\<in>(rel_restrict E R)\<^sup>*"
   using P
 proof (cases rule: rtrancl_last_visit[where S=R])
   case no_visit
   show ?thesis proof (cases "u\<in>R")
     case True with P have "v\<in>R"
       using rtrancl_reachable_induct[OF _ CL, where I="{u}"]
       by auto
     thus ?thesis ..
   next
     case False with no_visit have "(u,v)\<in>(rel_restrict E R)\<^sup>*"
       by (rule rtrancl_restrictI)
     with False show ?thesis ..
   qed
 next
   case (last_visit_point x)
   from \<open>(x, v) \<in> (E - UNIV \<times> R)\<^sup>*\<close> have "(x,v)\<in>E\<^sup>*"
     by (rule rtrancl_mono_mp[rotated]) auto
   with \<open>x\<in>R\<close> have "v\<in>R"
     using rtrancl_reachable_induct[OF _ CL, where I="{x}"]
     by auto
   thus ?thesis ..
 qed
 
 lemma rel_restrict_trancl_notR:
   assumes "(v,w) \<in> (rel_restrict E R)\<^sup>+"
   shows "v \<notin> R" and "w \<notin> R"
   using assms
   by (metis rel_restrict_trancl_mem rel_restrict_notR)+
 
 lemma rel_restrict_tranclI:
   assumes "(x,y) \<in> E\<^sup>+"
   and "x \<notin> R" "y \<notin> R"
   and "E `` R \<subseteq> R"
   shows "(x,y) \<in> (rel_restrict E R)\<^sup>+"
   using assms
   proof (induct)
     case base thus ?case by (metis r_into_trancl rel_restrictI)
   next
     case (step y z) hence "y \<notin> R" by auto
     with step show ?case by (metis trancl_into_trancl rel_restrictI)
   qed
 
 
 subsubsection \<open>Single-Valued Relations\<close>
 lemma single_valued_inter1: "single_valued R \<Longrightarrow> single_valued (R\<inter>S)"
   by (auto intro: single_valuedI dest: single_valuedD)
 
 lemma single_valued_inter2: "single_valued R \<Longrightarrow> single_valued (S\<inter>R)"
   by (auto intro: single_valuedI dest: single_valuedD)
 
 lemma single_valued_below_Id: "R\<subseteq>Id \<Longrightarrow> single_valued R"
   by (auto intro: single_valuedI)
   
 
 subsubsection \<open>Bijective Relations\<close>
 definition "bijective R \<equiv>
   (\<forall>x y z. (x,y)\<in>R \<and> (x,z)\<in>R \<longrightarrow> y=z) \<and>
   (\<forall>x y z. (x,z)\<in>R \<and> (y,z)\<in>R \<longrightarrow> x=y)"
 
 lemma bijective_alt: "bijective R \<longleftrightarrow> single_valued R \<and> single_valued (R\<inverse>)"
   unfolding bijective_def single_valued_def by blast
 
 lemma bijective_Id[simp, intro!]: "bijective Id"
   by (auto simp: bijective_def)
 
 lemma bijective_Empty[simp, intro!]: "bijective {}"
   by (auto simp: bijective_def)
 
 subsubsection \<open>Miscellaneous\<close>
 
   lemma pair_vimage_is_Image[simp]: "(Pair u -` E) = E``{u}"
     by auto
 
 lemma fst_in_Field: "fst ` R \<subseteq> Field R"
   by (simp add: Field_def fst_eq_Domain)
 
 lemma snd_in_Field: "snd ` R \<subseteq> Field R"
   by (simp add: Field_def snd_eq_Range)
 
 lemma ran_map_of:
   "ran (map_of xs) \<subseteq> snd ` set (xs)"
 by (induct xs) (auto simp add: ran_def)
 
 lemma Image_subset_snd_image:
   "A `` B \<subseteq> snd ` A"
 unfolding Image_def image_def
 by force
 
 lemma finite_Image_subset:
   "finite (A `` B) \<Longrightarrow> C \<subseteq> A \<Longrightarrow> finite (C `` B)"
 by (metis Image_mono order_refl rev_finite_subset)
 
 lemma finite_Field_eq_finite[simp]: "finite (Field R) \<longleftrightarrow> finite R"
   by (metis finite_cartesian_product finite_subset R_subset_Field finite_Field)
 
 
 
 definition "fun_of_rel R x \<equiv> SOME y. (x,y)\<in>R"
 
 lemma for_in_RI(*[intro]*): "x\<in>Domain R \<Longrightarrow> (x,fun_of_rel R x)\<in>R"
   unfolding fun_of_rel_def
   by (auto intro: someI)
 
 lemma Field_not_elem:
   "v \<notin> Field R \<Longrightarrow> \<forall>(x,y) \<in> R. x \<noteq> v \<and> y \<noteq> v"
 unfolding Field_def by auto
 
 lemma Sigma_UNIV_cancel[simp]: "(A \<times> X - A \<times> UNIV) = {}" by auto
 
 lemma same_fst_trancl[simp]: "(same_fst P R)\<^sup>+ = same_fst P (\<lambda>x. (R x)\<^sup>+)"
 proof -
   {
     fix x y
     assume "(x,y)\<in>(same_fst P R)\<^sup>+"
     hence "(x,y)\<in>same_fst P (\<lambda>x. (R x)\<^sup>+)"
       by induction (auto simp: same_fst_def)
   } moreover {
     fix f f' x y
     assume "((f,x),(f',y))\<in>same_fst P (\<lambda>x. (R x)\<^sup>+)"
     hence [simp]: "f'=f" "P f" and 1: "(x,y)\<in>(R f)\<^sup>+" by (auto simp: same_fst_def)
     from 1 have "((f,x),(f',y))\<in>(same_fst P R)\<^sup>+"
       apply induction
       subgoal by (rule r_into_trancl) auto
       subgoal by (erule trancl_into_trancl) auto
       done
   } ultimately show ?thesis by auto
 qed  
     
 
 subsection \<open>\<open>option\<close> Datatype\<close>
 lemma le_some_optE: "\<lbrakk>Some m\<le>x; !!m'. \<lbrakk>x=Some m'; m\<le>m'\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   by (cases x) auto
 
 
 lemma not_Some_eq2[simp]: "(\<forall>x y. v \<noteq> Some (x,y)) = (v = None)"
   by (cases v) auto
 
 
 subsection "Maps"
   primrec the_default where
     "the_default _ (Some x) = x"
   | "the_default x None = x"
 
   declare map_add_dom_app_simps[simp]  
   declare map_add_upd_left[simp]  
 
   lemma ran_add[simp]: "dom f \<inter> dom g = {} \<Longrightarrow> ran (f++g) = ran f \<union> ran g" by (fastforce simp add: ran_def map_add_def split: option.split_asm option.split)
 
   lemma nempty_dom: "\<lbrakk>e\<noteq>Map.empty; !!m. m\<in>dom e \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (subgoal_tac "dom e \<noteq> {}") (blast, auto)
 
 
 
   lemma le_map_dom_mono: "m\<le>m' \<Longrightarrow> dom m \<subseteq> dom m'"
     apply (safe)
     apply (drule_tac x=x in le_funD)
     apply simp
     apply (erule le_some_optE)
     apply simp
     done
 
   lemma map_add_first_le: fixes m::"'a\<rightharpoonup>('b::order)" shows "\<lbrakk> m\<le>m' \<rbrakk> \<Longrightarrow> m++n \<le> m'++n"
     apply (rule le_funI)
     apply (auto simp add: map_add_def split: option.split elim: le_funE)
     done
 
   lemma map_add_distinct_le: shows "\<lbrakk> m\<le>m'; n\<le>n'; dom m' \<inter> dom n' = {} \<rbrakk> \<Longrightarrow> m++n \<le> m'++n'"
     apply (rule le_funI)
     apply (auto simp add: map_add_def split: option.split)
     apply (fastforce elim: le_funE)
     apply (drule le_map_dom_mono)
     apply (drule le_map_dom_mono)
     apply (case_tac "m x")
     apply simp
     apply (force)
     apply (fastforce dest!: le_map_dom_mono)
     apply (erule le_funE)
     apply (erule_tac x=x in le_funE)
     apply simp
     done
 
   lemma map_add_left_comm: assumes A: "dom A \<inter> dom B = {}" shows "A ++ (B ++ C) = B ++ (A ++ C)"
   proof -
     have "A ++ (B ++ C) = (A++B)++C" by simp
     also have "\<dots> = (B++A)++C" by (simp add: map_add_comm[OF A])
     also have "\<dots> = B++(A++C)" by simp
     finally show ?thesis .
   qed
   lemmas map_add_ac = map_add_assoc map_add_comm map_add_left_comm
 
   lemma le_map_restrict[simp]: fixes m :: "'a \<rightharpoonup> ('b::order)" shows "m |` X \<le> m"
     by (rule le_funI) (simp add: restrict_map_def)
 
 lemma map_of_distinct_upd:
   "x \<notin> set (map fst xs) \<Longrightarrow> [x \<mapsto> y] ++ map_of xs = (map_of xs) (x \<mapsto> y)"
   by (induct xs) (auto simp add: fun_upd_twist)
 
 lemma map_of_distinct_upd2:
   assumes "x \<notin> set(map fst xs)"
   "x \<notin> set (map fst ys)"
   shows "map_of (xs @ (x,y) # ys) = (map_of (xs @ ys))(x \<mapsto> y)"
   apply(insert assms)
   apply(induct xs)
   apply (auto intro: ext)
   done
 
 lemma map_of_distinct_upd3:
   assumes "x \<notin> set(map fst xs)"
   "x \<notin> set (map fst ys)"
   shows "map_of (xs @ (x,y) # ys) = (map_of (xs @ (x,y') # ys))(x \<mapsto> y)"
   apply(insert assms)
   apply(induct xs)
   apply (auto intro: ext)
   done
 
 lemma map_of_distinct_upd4:
   assumes "x \<notin> set(map fst xs)"
   "x \<notin> set (map fst ys)"
   shows "map_of (xs @ ys) = (map_of (xs @ (x,y) # ys))(x := None)"
   using assms by (induct xs) (auto simp: map_of_eq_None_iff)
 
 lemma map_of_distinct_lookup:
   assumes "x \<notin> set(map fst xs)"
   "x \<notin> set (map fst ys)"
   shows "map_of (xs @ (x,y) # ys) x = Some y"
 proof -
   have "map_of (xs @ (x,y) # ys) = (map_of (xs @ ys)) (x \<mapsto> y)"
     using assms map_of_distinct_upd2 by simp
   thus ?thesis
     by simp
 qed
 
 lemma ran_distinct:
   assumes dist: "distinct (map fst al)"
   shows "ran (map_of al) = snd ` set al"
 using assms proof (induct al)
   case Nil then show ?case by simp
 next
   case (Cons kv al)
   then have "ran (map_of al) = snd ` set al" by simp
   moreover from Cons.prems have "map_of al (fst kv) = None"
     by (simp add: map_of_eq_None_iff)
   ultimately show ?case by (simp only: map_of.simps ran_map_upd) simp
 qed
 
 lemma ran_is_image:
   "ran M = (the \<circ> M) ` (dom M)"
 unfolding ran_def dom_def image_def
 by auto
 
 lemma map_card_eq_iff:
   assumes finite: "finite (dom M)"
   and card_eq: "card (dom M) = card (ran M)"
   and indom: "x \<in> dom M"
   shows "(M x = M y) \<longleftrightarrow> (x = y)"
 proof -
   from ran_is_image finite card_eq have *: "inj_on (the \<circ> M) (dom M)" using eq_card_imp_inj_on by metis
   thus ?thesis
   proof (cases "y \<in> dom M")
     case False with indom show ?thesis by auto
   next
     case True with indom have "the (M x) = the (M y) \<longleftrightarrow> (x = y)" using inj_on_eq_iff[OF *] by auto
     thus ?thesis by auto
   qed
 qed
 
 lemma map_dom_ran_finite:
   "finite (dom M) \<Longrightarrow> finite (ran M)"
 by (simp add: ran_is_image)
 
 lemma map_update_eta_repair[simp]:
   (* An update operation may get simplified, if it happens to be eta-expanded.
     This lemma tries to repair some common expressions *)
   "dom (\<lambda>x. if x=k then Some v else m x) = insert k (dom m)"
   "m k = None \<Longrightarrow> ran (\<lambda>x. if x=k then Some v else m x) = insert v (ran m)"
   apply auto []
   apply (force simp: ran_def)
   done
 
 lemma map_leI[intro?]: "\<lbrakk>\<And>x v. m1 x = Some v \<Longrightarrow> m2 x = Some v\<rbrakk> \<Longrightarrow> m1\<subseteq>\<^sub>mm2"
   unfolding map_le_def by force
 lemma map_leD: "m1\<subseteq>\<^sub>mm2 \<Longrightarrow> m1 k = Some v \<Longrightarrow> m2 k = Some v"
   unfolding map_le_def by force
     
 lemma map_restrict_insert_none_simp: "m x = None \<Longrightarrow> m|`(-insert x s) = m|`(-s)"
   by (auto intro!: ext simp:restrict_map_def)
 
 (* TODO: Move *)
 lemma eq_f_restr_conv: "s\<subseteq>dom (f A) \<and> A = f A |` (-s) \<longleftrightarrow> A \<subseteq>\<^sub>m f A \<and> s = dom (f A) - dom A"
   apply auto
   subgoal by (metis map_leI restrict_map_eq(2))
   subgoal by (metis ComplD restrict_map_eq(2))
   subgoal by (metis Compl_iff restrict_in)
   subgoal by (force simp: map_le_def restrict_map_def)
   done
   
 corollary eq_f_restr_ss_eq: "\<lbrakk> s\<subseteq>dom (f A) \<rbrakk> \<Longrightarrow> A = f A |` (-s) \<longleftrightarrow> A \<subseteq>\<^sub>m f A \<and> s = dom (f A) - dom A"
   using eq_f_restr_conv by blast
     
     
     
   subsubsection \<open>Simultaneous Map Update\<close>
   definition "map_mmupd m K v k \<equiv> if k\<in>K then Some v else m k"
   lemma map_mmupd_empty[simp]: "map_mmupd m {} v = m"
     by (auto simp: map_mmupd_def)
 
   lemma mmupd_in_upd[simp]: "k\<in>K \<Longrightarrow> map_mmupd m K v k = Some v"
     by (auto simp: map_mmupd_def)
 
   lemma mmupd_notin_upd[simp]: "k\<notin>K \<Longrightarrow> map_mmupd m K v k = m k"
     by (auto simp: map_mmupd_def)
 
   lemma map_mmupdE:
     assumes "map_mmupd m K v k = Some x"
     obtains "k\<notin>K" "m k = Some x"
           | "k\<in>K" "x=v"
     using assms by (auto simp: map_mmupd_def split: if_split_asm)      
 
   lemma dom_mmupd[simp]: "dom (map_mmupd m K v) = dom m \<union> K"  
     by (auto simp: map_mmupd_def split: if_split_asm)      
 
   lemma le_map_mmupd_not_dom[simp, intro!]: "m \<subseteq>\<^sub>m map_mmupd m (K-dom m) v" 
     by (auto simp: map_le_def)
 
   lemma map_mmupd_update_less: "K\<subseteq>K' \<Longrightarrow> map_mmupd m (K - dom m) v \<subseteq>\<^sub>m map_mmupd m (K'-dom m) v"
     by (auto simp: map_le_def map_mmupd_def)
 
     
 
 subsection\<open>Connection between Maps and Sets of Key-Value Pairs\<close>
 
 definition map_to_set where
   "map_to_set m = {(k, v) . m k = Some v}"
 
 definition set_to_map where
   "set_to_map S k = Eps_Opt (\<lambda>v. (k, v) \<in> S)"
 
 lemma set_to_map_simp :
 assumes inj_on_fst: "inj_on fst S"
 shows "(set_to_map S k = Some v) \<longleftrightarrow> (k, v) \<in> S"
 proof (cases "\<exists>v. (k, v) \<in> S")
   case True
   note kv_ex = this
   then obtain v' where kv'_in: "(k, v') \<in> S" by blast
 
   with inj_on_fst have kv''_in: "\<And>v''. (k, v'') \<in> S \<longleftrightarrow> v' = v''"
     unfolding inj_on_def Ball_def
     by auto
 
   show ?thesis
     unfolding set_to_map_def
     by (simp add: kv_ex kv''_in)
 next
   case False
   hence kv''_nin: "\<And>v''. (k, v'') \<notin> S" by simp
   thus ?thesis
     by (simp add: set_to_map_def)
 qed
 
 lemma inj_on_fst_map_to_set :
   "inj_on fst (map_to_set m)"
 unfolding map_to_set_def inj_on_def by simp
 
 lemma map_to_set_inverse :
    "set_to_map (map_to_set m) = m"
 proof
   fix k
   show "set_to_map (map_to_set m) k = m k"
   proof (cases "m k")
     case None note mk_eq = this
     hence "\<And>v. (k, v) \<notin> map_to_set m"
       unfolding map_to_set_def by simp
     with set_to_map_simp [OF inj_on_fst_map_to_set, of m k]
     show ?thesis unfolding mk_eq by auto
   next
     case (Some v) note mk_eq = this
     hence "(k, v) \<in> map_to_set m"
       unfolding map_to_set_def by simp
     with set_to_map_simp [OF inj_on_fst_map_to_set, of m k v]
     show ?thesis unfolding mk_eq by auto
   qed
 qed
 
 lemma set_to_map_inverse :
 assumes inj_on_fst_S: "inj_on fst S"
 shows "map_to_set (set_to_map S) = S"
 proof (rule set_eqI)
   fix kv
   from set_to_map_simp [OF inj_on_fst_S, of "fst kv" "snd kv"]
   show "(kv \<in> map_to_set (set_to_map S)) = (kv \<in> S)"
     unfolding map_to_set_def
     by auto
 qed
 
 lemma map_to_set_empty[simp]: "map_to_set Map.empty = {}"
   unfolding map_to_set_def by simp
 
 lemma set_to_map_empty[simp]: "set_to_map {} = Map.empty"
   unfolding set_to_map_def[abs_def] by simp
 
 lemma map_to_set_empty_iff: "map_to_set m = {} \<longleftrightarrow> m = Map.empty"
                             "{} = map_to_set m \<longleftrightarrow> m = Map.empty"
   unfolding map_to_set_def by auto
 
 lemma set_to_map_empty_iff: "set_to_map S = Map.empty \<longleftrightarrow> S = {}" (is ?T1)
                             "Map.empty = set_to_map S \<longleftrightarrow> S = {}" (is ?T2)
 proof -
   show T1: ?T1
     apply (simp only: set_eq_iff)
     apply (simp only: fun_eq_iff)
     apply (simp add: set_to_map_def)
     apply auto
   done
   from T1 show ?T2 by auto
 qed
 
 lemma map_to_set_upd[simp]: "map_to_set (m (k \<mapsto> v)) = insert (k, v) (map_to_set m - {(k, v') |v'. True})"
   unfolding map_to_set_def
   apply (simp add: set_eq_iff)
   apply metis
 done
 
 lemma set_to_map_insert:
 assumes k_nin: "fst kv \<notin> fst ` S"
 shows "set_to_map (insert kv S) = (set_to_map S) (fst kv \<mapsto> snd kv)"
 proof
   fix k'
   obtain k v where kv_eq[simp]: "kv = (k, v)" by (rule prod.exhaust)
 
   from k_nin have k_nin': "\<And>v'. (k, v') \<notin> S"
     by (auto simp add: image_iff Ball_def)
 
   show "set_to_map (insert kv S) k' = (set_to_map S(fst kv \<mapsto> snd kv)) k'"
     by (simp add: set_to_map_def k_nin')
 qed
 
 lemma map_to_set_dom :
   "dom m = fst ` (map_to_set m)"
 unfolding dom_def map_to_set_def
 by (auto simp add: image_iff)
 
 lemma map_to_set_ran :
   "ran m = snd ` (map_to_set m)"
 unfolding ran_def map_to_set_def
 by (auto simp add: image_iff)
 
 lemma set_to_map_dom :
   "dom (set_to_map S) = fst ` S"
 unfolding set_to_map_def[abs_def] dom_def
 by (auto simp add: image_iff Bex_def)
 
 lemma set_to_map_ran :
   "ran (set_to_map S) \<subseteq> snd ` S"
 unfolding set_to_map_def[abs_def] ran_def subset_iff
 by (auto simp add: image_iff Bex_def)
    (metis Eps_Opt_eq_Some)
 
 lemma finite_map_to_set:
 "finite (map_to_set m) = finite (dom m)"
 unfolding map_to_set_def map_to_set_dom
   apply (intro iffI finite_imageI)
   apply assumption
   apply (rule finite_imageD[of fst])
   apply assumption
   apply (simp add: inj_on_def)
 done
 
 lemma card_map_to_set :
   "card (map_to_set m) = card (dom m)"
 unfolding map_to_set_def map_to_set_dom
   apply (rule card_image[symmetric])
   apply (simp add: inj_on_def)
 done
 
 lemma map_of_map_to_set :
 "distinct (map fst l) \<Longrightarrow>
  map_of l = m \<longleftrightarrow> set l = map_to_set m"
 proof (induct l arbitrary: m)
   case Nil thus ?case by (simp add: map_to_set_empty_iff) blast
 next
   case (Cons kv l m)
   obtain k v where kv_eq[simp]: "kv = (k, v)" by (rule prod.exhaust)
 
   from Cons(2) have dist_l: "distinct (map fst l)" and kv'_nin: "\<And>v'. (k, v') \<notin> set l"
     by (auto simp add: image_iff)
   note ind_hyp = Cons(1)[OF dist_l]
 
   from kv'_nin have l_eq: "set (kv # l) = map_to_set m \<longleftrightarrow> (set l = map_to_set (m (k := None))) \<and> m k = Some v"
     apply (simp add: map_to_set_def restrict_map_def set_eq_iff)
     apply (auto)
     apply (metis)
     apply (metis option.inject)
   done
 
   from kv'_nin have m_eq: "map_of (kv # l) = m \<longleftrightarrow> map_of l = (m (k := None)) \<and> m k = Some v"
     apply (simp add: fun_eq_iff restrict_map_def map_of_eq_None_iff image_iff Ball_def)
     apply metis
   done
 
   show ?case
     unfolding m_eq l_eq
     using ind_hyp[of "m (k := None)"]
     by metis
 qed
 
 lemma map_to_set_map_of :
 "distinct (map fst l) \<Longrightarrow> map_to_set (map_of l) = set l"
 by (metis map_of_map_to_set)
 
 subsubsection \<open>Mapping empty set to None\<close>
 definition "dflt_None_set S \<equiv> if S={} then None else Some S"
 
 lemma the_dflt_None_empty[simp]: "dflt_None_set {} = None"
   unfolding dflt_None_set_def by simp
 
 lemma the_dflt_None_nonempty[simp]: "S\<noteq>{} \<Longrightarrow> dflt_None_set S = Some S"
   unfolding dflt_None_set_def by simp
 
 lemma the_dflt_None_set[simp]: "the_default {} (dflt_None_set x) = x"
   unfolding dflt_None_set_def by auto
 
 subsection \<open>Orderings\<close>
 
   
   
 lemma (in order) min_arg_le[simp]:
   "n \<le> min m n \<longleftrightarrow> min m n = n"
   "m \<le> min m n \<longleftrightarrow> min m n = m"
   by (auto simp: min_def)
 
 lemma (in linorder) min_arg_not_ge[simp]:
   "\<not> min m n < m \<longleftrightarrow> min m n = m"
   "\<not> min m n < n \<longleftrightarrow> min m n = n"
   by (auto simp: min_def)
 
 lemma (in linorder) min_eq_arg[simp]:
   "min m n = m \<longleftrightarrow> m\<le>n"
   "min m n = n \<longleftrightarrow> n\<le>m"
   by (auto simp: min_def)
 
 lemma min_simps[simp]:
   "a<(b::'a::order) \<Longrightarrow> min a b = a"
   "b<(a::'a::order) \<Longrightarrow> min a b = b"
   by (auto simp add: min_def dest: less_imp_le)
 
 lemma (in -) min_less_self_conv[simp]: 
   "min a b < a \<longleftrightarrow> b < (a::_::linorder)" 
   "min a b < b \<longleftrightarrow> a < (b::_::linorder)" 
   by (auto simp: min_def)
     
 lemma ord_eq_le_eq_trans: "\<lbrakk> a=b; b\<le>c; c=d \<rbrakk> \<Longrightarrow> a\<le>d" by auto
 
 lemma zero_comp_diff_simps[simp]: 
   "(0::'a::linordered_idom) \<le> a - b \<longleftrightarrow> b \<le> a" 
   "(0::'a::linordered_idom) < a - b \<longleftrightarrow> b < a" 
   by auto
     
 
 subsubsection \<open>Termination Measures\<close>    
 text \<open>Lexicographic measure, assuming upper bound for second component\<close>
 lemma mlex_fst_decrI:
   fixes a a' b b' N :: nat
   assumes "a<a'"
   assumes "b<N" "b'<N"
   shows "a*N + b < a'*N + b'"
 proof -  
   have "a*N + b + 1 \<le> a*N + N" using \<open>b<N\<close> by linarith 
   also have "\<dots> \<le> a'*N" using \<open>a<a'\<close>
     by (metis Suc_leI ab_semigroup_add_class.add.commute 
       ab_semigroup_mult_class.mult.commute mult_Suc_right mult_le_mono2) 
   also have "\<dots> \<le> a'*N + b'" by auto
   finally show ?thesis by auto
 qed      
   
 lemma mlex_leI:
   fixes a a' b b' N :: nat
   assumes "a\<le>a'"
   assumes "b\<le>b'"
   shows "a*N + b \<le> a'*N + b'"
   using assms
   by (auto intro!: add_mono)
     
 lemma mlex_snd_decrI:
   fixes a a' b b' N :: nat
   assumes "a=a'"
   assumes "b<b'"
   shows "a*N + b < a'*N + b'"
   using assms
   by (auto)
 
 lemma mlex_bound:  
   fixes a b :: nat
   assumes "a<A"
   assumes "b<N"
   shows "a*N + b < A*N"
   using assms
   using mlex_fst_decrI by fastforce
     
 subsection \<open>CCPOs\<close>
 
 context ccpo
 begin
 
 lemma ccpo_Sup_mono:
   assumes C: "Complete_Partial_Order.chain (\<le>) A"
     "Complete_Partial_Order.chain (\<le>) B"
   assumes B: "\<forall>x\<in>A. \<exists>y\<in>B. x\<le>y"
   shows "Sup A \<le> Sup B"
 proof (rule ccpo_Sup_least)
   fix x
   assume "x\<in>A"
   with B obtain y where I: "y\<in>B" and L: "x\<le>y" by blast
   note L
   also from I ccpo_Sup_upper have "y\<le>Sup B" by (blast intro: C)
   finally show "x\<le>Sup B" .
 qed (rule C)
 
 lemma fixp_mono:
   assumes M: "monotone (\<le>) (\<le>) f" "monotone (\<le>) (\<le>) g"
   assumes LE: "\<And>Z. f Z \<le> g Z"
   shows "ccpo_class.fixp f \<le> ccpo_class.fixp g"
   unfolding fixp_def[abs_def]
   apply (rule ccpo_Sup_mono)
   apply (rule chain_iterates M)+
 proof rule
   fix x
   assume "x\<in>ccpo_class.iterates f"
   thus "\<exists>y\<in>ccpo_class.iterates g. x\<le>y"
   proof (induct)
     case (step x)
     then obtain y where I: "y\<in>ccpo_class.iterates g" and L: "x\<le>y" by blast
     hence "g y \<in> ccpo_class.iterates g" and "f x \<le> g y"
       apply -
       apply (erule iterates.step)
       apply (rule order_trans)
       apply (erule monotoneD[OF M(1)])
       apply (rule LE)
       done
     thus "\<exists>y\<in>ccpo_class.iterates g. f x \<le> y" ..
   next
     case (Sup M)
     define N where "N = {SOME y. y\<in>ccpo_class.iterates g \<and> x\<le>y | x. x\<in>M}"
 
     have N1: "\<forall>y\<in>N. y\<in>ccpo_class.iterates g \<and> (\<exists>x\<in>M. x\<le>y)"
       unfolding N_def
       apply auto
       apply (metis (lifting) Sup.hyps(2) tfl_some)
       by (metis (lifting) Sup.hyps(2) tfl_some)
 
     have N2: "\<forall>x\<in>M. \<exists>y\<in>N. x\<le>y"
       unfolding N_def
       apply auto
       by (metis (lifting) Sup.hyps(2) tfl_some)
 
     have "N \<subseteq> ccpo_class.iterates g" using Sup
       using N1 by auto
     hence C_chain: "Complete_Partial_Order.chain (\<le>) N"
       using chain_iterates[OF M(2)]
       unfolding chain_def by auto
 
     have "Sup N \<in> ccpo_class.iterates g" and "Sup M \<le> Sup N"
       apply -
       apply (rule iterates.Sup[OF C_chain])
       using N1 apply blast
       apply (rule ccpo_Sup_mono)
       apply (rule Sup.hyps)
       apply (rule C_chain)
       apply (rule N2)
       done
 
     thus ?case by blast
   qed
 qed
 
 end
 
   
 subsection \<open>Code\<close>  
 text \<open>Constant for code-abort. If that gets executed, an abort-exception is raised.\<close>  
 definition [simp]: "CODE_ABORT f = f ()"
 declare [[code abort: CODE_ABORT]]
   
   
 end
diff --git a/thys/Bertrands_Postulate/Bertrand.thy b/thys/Bertrands_Postulate/Bertrand.thy
--- a/thys/Bertrands_Postulate/Bertrand.thy
+++ b/thys/Bertrands_Postulate/Bertrand.thy
@@ -1,1853 +1,1854 @@
 (*
   File:     Bertrand.thy
   Authors:  Julian Biendarra, Manuel Eberl <eberlm@in.tum.de>, Larry Paulson
 
   A proof of Bertrand's postulate (based on John Harrison's HOL Light proof).
   Uses reflection and the approximation tactic.
 *)
 theory Bertrand
   imports 
     Complex_Main
     "HOL-Number_Theory.Number_Theory"
     "HOL-Library.Discrete"
     "HOL-Decision_Procs.Approximation_Bounds"
     "HOL-Library.Code_Target_Numeral"
     Pratt_Certificate.Pratt_Certificate
 begin
 
 subsection \<open>Auxiliary facts\<close>
  
 lemma ln_2_le: "ln 2 \<le> 355 / (512 :: real)"
 proof -
   have "ln 2 \<le> real_of_float (ub_ln2 12)" by (rule ub_ln2)
   also have "ub_ln2 12 = Float 5680 (- 13)" by code_simp
   finally show ?thesis by simp
 qed
 
 lemma ln_2_ge: "ln 2 \<ge> (5677 / 8192 :: real)"
 proof -
   have "ln 2 \<ge> real_of_float (lb_ln2 12)" by (rule lb_ln2)
   also have "lb_ln2 12 = Float 5677 (-13)" by code_simp
   finally show ?thesis by simp
 qed
 
 lemma ln_2_ge': "ln (2 :: real) \<ge> 2/3" and ln_2_le': "ln (2 :: real) \<le> 16/23"
   using ln_2_le ln_2_ge by simp_all
 
 lemma of_nat_ge_1_iff: "(of_nat x :: 'a :: linordered_semidom) \<ge> 1 \<longleftrightarrow> x \<ge> 1"
   using of_nat_le_iff[of 1 x] by (subst (asm) of_nat_1)
   
 lemma floor_conv_div_nat:
   "of_int (floor (real m / real n)) = real (m div n)"
   by (subst floor_divide_of_nat_eq) simp
 
 lemma frac_conv_mod_nat:
   "frac (real m / real n) = real (m mod n) / real n"
   by (cases "n = 0")
      (simp_all add: frac_def floor_conv_div_nat field_simps of_nat_mult 
         [symmetric] of_nat_add [symmetric] del: of_nat_mult of_nat_add)
 
 lemma of_nat_prod_mset: "prod_mset (image_mset of_nat A) = of_nat (prod_mset A)"
   by (induction A) simp_all
 
 lemma prod_mset_pos: "(\<And>x :: 'a :: linordered_semidom. x \<in># A \<Longrightarrow> x > 0) \<Longrightarrow> prod_mset A > 0"
   by (induction A) simp_all
 
 lemma ln_msetprod:
   assumes "\<And>x. x \<in>#I \<Longrightarrow> x > 0"
   shows "(\<Sum>p::nat\<in>#I. ln p) = ln (\<Prod>p\<in>#I. p)"
   using assms by (induction I) (simp_all add: of_nat_prod_mset ln_mult prod_mset_pos)
 
 lemma ln_fact: "ln (fact n) = (\<Sum>d=1..n. ln d)"
   by (induction n) (simp_all add: ln_mult)
 
 lemma overpower_lemma:
   fixes f g :: "real \<Rightarrow> real"
   assumes "f a \<le> g a"
   assumes "\<And>x. a \<le> x \<Longrightarrow> ((\<lambda>x. g x - f x) has_real_derivative (d x)) (at x)"
   assumes "\<And>x. a \<le> x \<Longrightarrow> d x \<ge> 0"
   assumes "a \<le> x"
   shows   "f x \<le> g x"
 proof (cases "a < x")
   case True
   with assms have "\<exists>z. z > a \<and> z < x \<and> g x - f x - (g a - f a) = (x - a) * d z"
     by (intro MVT2) auto
   then obtain z where z: "z > a" "z < x" "g x - f x - (g a - f a) = (x - a) * d z" by blast
   hence "f x = g x + (f a - g a) + (a - x) * d z" by (simp add: algebra_simps)
   also from assms have "f a - g a \<le> 0" by (simp add: algebra_simps)
   also from assms z have "(a - x) * d z \<le> 0 * d z"
     by (intro mult_right_mono) simp_all
   finally show ?thesis by simp
 qed (insert assms, auto)
 
 
 subsection \<open>Preliminary definitions\<close>
 
 definition primepow_even :: "nat \<Rightarrow> bool" where
   "primepow_even q \<longleftrightarrow> (\<exists> p k. 1 \<le> k \<and> prime p \<and> q = p^(2*k))"
 
 definition primepow_odd :: "nat \<Rightarrow> bool" where
   "primepow_odd q \<longleftrightarrow> (\<exists> p k. 1 \<le> k \<and> prime p \<and> q = p^(2*k+1))"
 
 abbreviation (input) isprimedivisor :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
   "isprimedivisor q p \<equiv> prime p \<and> p dvd q"
 
 definition pre_mangoldt :: "nat \<Rightarrow> nat" where
   "pre_mangoldt d = (if primepow d then aprimedivisor d else 1)"
 
 definition mangoldt_even :: "nat \<Rightarrow> real" where
   "mangoldt_even d = (if primepow_even d then ln (real (aprimedivisor d)) else 0)"
 
 definition mangoldt_odd :: "nat \<Rightarrow> real" where
   "mangoldt_odd d = (if primepow_odd d then ln (real (aprimedivisor d)) else 0)"
 
 definition mangoldt_1 :: "nat \<Rightarrow> real" where
   "mangoldt_1 d = (if prime d then ln d else 0)"
 
 definition psi :: "nat \<Rightarrow> real" where
   "psi n = (\<Sum>d=1..n. mangoldt d)"
 
 definition psi_even :: "nat \<Rightarrow> real" where
   "psi_even n = (\<Sum>d=1..n. mangoldt_even d)"
 
 definition psi_odd :: "nat \<Rightarrow> real" where
   "psi_odd n = (\<Sum>d=1..n. mangoldt_odd d)"
 
 abbreviation (input) psi_even_2 :: "nat \<Rightarrow> real" where
   "psi_even_2 n \<equiv> (\<Sum>d=2..n. mangoldt_even d)"
 
 abbreviation (input) psi_odd_2 :: "nat \<Rightarrow> real" where
   "psi_odd_2 n \<equiv> (\<Sum>d=2..n. mangoldt_odd d)"
 
 definition theta :: "nat \<Rightarrow> real" where
   "theta n = (\<Sum>p=1..n. if prime p then ln (real p) else 0)"
 
 subsection \<open>Properties of prime powers\<close>  
 
 lemma primepow_even_imp_primepow:
   assumes "primepow_even n"
   shows   "primepow n"
 proof -
   from assms obtain p k where "1 \<le> k" "prime p" "n = p ^ (2 * k)"
     unfolding primepow_even_def by blast
   moreover from \<open>1 \<le> k\<close> have "2 * k > 0"
     by simp
   ultimately show ?thesis unfolding primepow_def by blast
 qed
 
 lemma primepow_odd_imp_primepow:
   assumes "primepow_odd n"
   shows   "primepow n"
 proof -
  from assms obtain p k where "1 \<le> k" "prime p" "n = p ^ (2 * k + 1)"
    unfolding primepow_odd_def by blast
   moreover from \<open>1 \<le> k\<close> have "Suc (2 * k) > 0"
     by simp
   ultimately show ?thesis unfolding primepow_def
     by (auto simp del: power_Suc)
 qed
 
 lemma primepow_odd_altdef:
   "primepow_odd n \<longleftrightarrow>
      primepow n \<and> odd (multiplicity (aprimedivisor n) n) \<and> multiplicity (aprimedivisor n) n > 1"
 proof (intro iffI conjI; (elim conjE)?)
   assume "primepow_odd n"
   then obtain p k where n: "k \<ge> 1" "prime p" "n = p ^ (2 * k + 1)"
     by (auto simp: primepow_odd_def)
   thus "odd (multiplicity (aprimedivisor n) n)" "multiplicity (aprimedivisor n) n > 1"
     by (simp_all add: aprimedivisor_primepow prime_elem_multiplicity_mult_distrib)
 next
   assume A: "primepow n" and B: "odd (multiplicity (aprimedivisor n) n)"
      and C: "multiplicity (aprimedivisor n) n > 1"
   from A obtain p k where n: "k \<ge> 1" "prime p" "n = p ^ k"
     by (auto simp: primepow_def Suc_le_eq)
   with B C have "odd k" "k > 1"
     by (simp_all add: aprimedivisor_primepow prime_elem_multiplicity_mult_distrib)
   then obtain j where j: "k = 2 * j + 1" "j > 0" by (auto elim!: oddE)
   with n show "primepow_odd n" by (auto simp: primepow_odd_def intro!: exI[of _ p, OF exI[of _ j]])
 qed (auto dest: primepow_odd_imp_primepow)
 
 lemma primepow_even_altdef:
   "primepow_even n \<longleftrightarrow> primepow n \<and> even (multiplicity (aprimedivisor n) n)"
 proof (intro iffI conjI; (elim conjE)?)
   assume "primepow_even n"
   then obtain p k where n: "k \<ge> 1" "prime p" "n = p ^ (2 * k)"
     by (auto simp: primepow_even_def)
   thus "even (multiplicity (aprimedivisor n) n)"
     by (simp_all add: aprimedivisor_primepow prime_elem_multiplicity_mult_distrib)
 next
   assume A: "primepow n" and B: "even (multiplicity (aprimedivisor n) n)"
   from A obtain p k where n: "k \<ge> 1" "prime p" "n = p ^ k"
     by (auto simp: primepow_def Suc_le_eq)
   with B have "even k"
     by (simp_all add: aprimedivisor_primepow prime_elem_multiplicity_mult_distrib)
   then obtain j where j: "k = 2 * j" by (auto elim!: evenE)
   from j n have "j \<noteq> 0" by (intro notI) simp_all
   with j n show "primepow_even n"
     by (auto simp: primepow_even_def intro!: exI[of _ p, OF exI[of _ j]])
 qed (auto dest: primepow_even_imp_primepow)
 
 lemma primepow_odd_mult:
   assumes "d > Suc 0"
   shows   "primepow_odd (aprimedivisor d * d) \<longleftrightarrow> primepow_even d"
     using assms
     by (auto simp: primepow_odd_altdef primepow_even_altdef primepow_mult_aprimedivisorI
                    aprimedivisor_primepow prime_aprimedivisor' aprimedivisor_dvd'
                    prime_elem_multiplicity_mult_distrib prime_elem_aprimedivisor_nat
              dest!: primepow_multD)
 
 lemma pre_mangoldt_primepow:
   assumes "primepow n" "aprimedivisor n = p"
   shows   "pre_mangoldt n = p"
   using assms by (simp add: pre_mangoldt_def)
 
 lemma pre_mangoldt_notprimepow:
   assumes "\<not>primepow n"
   shows   "pre_mangoldt n = 1"
   using assms by (simp add: pre_mangoldt_def)
 
 lemma primepow_cases:
   "primepow d \<longleftrightarrow>
      (  primepow_even d \<and> \<not> primepow_odd d \<and> \<not> prime d) \<or>
      (\<not> primepow_even d \<and>   primepow_odd d \<and> \<not> prime d) \<or>
      (\<not> primepow_even d \<and> \<not> primepow_odd d \<and>   prime d)"
   by (auto simp: primepow_even_altdef primepow_odd_altdef multiplicity_aprimedivisor_Suc_0_iff
            elim!: oddE intro!: Nat.gr0I)
 
 
 subsection \<open>Deriving a recurrence for the psi function\<close>
   
 lemma ln_fact_bounds:
   assumes "n > 0"
   shows "abs(ln (fact n) - n * ln n + n) \<le> 1 + ln n"
 proof -
   have "\<forall>n\<in>{0<..}. \<exists>z>real n. z < real (n + 1) \<and> real (n + 1) * ln (real (n + 1)) - 
           real n * ln (real n) = (real (n + 1) - real n) * (ln z + 1)"
     by (intro ballI MVT2) (auto intro!: derivative_eq_intros)
   hence "\<forall>n\<in>{0<..}. \<exists>z>real n. z < real (n + 1) \<and> real (n + 1) * ln (real (n + 1)) - 
           real n * ln (real n) = (ln z + 1)" by (simp add: algebra_simps)
   from bchoice[OF this] obtain k :: "nat \<Rightarrow> real"
     where lb: "real n < k n" and ub: "k n < real (n + 1)" and 
           mvt: "real (n+1) * ln (real (n+1)) - real n * ln (real n) = ln (k n) + 1" 
           if "n > 0" for n::nat by blast
   have *: "(n + 1) * ln (n + 1) = (\<Sum>i=1..n. ln(k i) + 1)" for n::nat
   proof (induction n)
     case (Suc n)
     have "(\<Sum>i = 1..n+1. ln (k i) + 1) = (\<Sum>i = 1..n. ln (k i) + 1) + ln (k (n+1)) + 1"
       by simp
     also from Suc.IH have "(\<Sum>i = 1..n. ln (k i) + 1) = real (n+1) * ln (real (n+1))" ..
     also from mvt[of "n+1"] have "\<dots> = real (n+2) * ln (real (n+2)) - ln (k (n+1)) - 1"
       by simp
     finally show ?case
       by simp
   qed simp
   have **: "abs((\<Sum>i=1..n+1. ln i) - ((n+1) * ln (n+1) - (n+1))) \<le> 1 + ln(n+1)" for n::nat
   proof -
     have "(\<Sum>i=1..n+1. ln i) \<le> (\<Sum>i=1..n. ln i) + ln (n+1)"
       by simp
     also have "(\<Sum>i=1..n. ln i) \<le> (\<Sum>i=1..n. ln (k i))"
       by (intro sum_mono, subst ln_le_cancel_iff) (auto simp: Suc_le_eq dest: lb ub)
     also have "\<dots> = (\<Sum>i=1..n. ln (k i) + 1) - n"
       by (simp add: sum.distrib)
     also from * have "\<dots> = (n+1) * ln (n+1) - n"
       by simp
     finally have a_minus_b: "(\<Sum>i=1..n+1. ln i) - ((n+1) * ln (n+1) - (n+1)) \<le> 1 + ln (n+1)"
       by simp
 
     from * have "(n+1) * ln (n+1) - n = (\<Sum>i=1..n. ln (k i) + 1) - n"
       by simp
     also have "\<dots> = (\<Sum>i=1..n. ln (k i))"
       by (simp add: sum.distrib)
     also have "\<dots> \<le> (\<Sum>i=1..n. ln (i+1))"
       by (intro sum_mono, subst ln_le_cancel_iff) (auto simp: Suc_le_eq dest: lb ub)
     also from sum.shift_bounds_cl_nat_ivl[of "ln" 1 1 n] have "\<dots> = (\<Sum>i=1+1..n+1. ln i)" ..
     also have "\<dots> = (\<Sum>i=1..n+1. ln i)"
       by (rule sum.mono_neutral_left) auto
     finally have b_minus_a: "((n+1) * ln (n+1) - (n+1)) - (\<Sum>i=1..n+1. ln i) \<le> 1"
       by simp
     have "0 \<le> ln (n+1)"
       by simp
     with b_minus_a have "((n+1) * ln (n+1) - (n+1)) - (\<Sum>i=1..n+1. ln i) \<le> 1 + ln (n+1)"
       by linarith
     with a_minus_b show ?thesis
       by linarith
   qed
   from \<open>n > 0\<close> have "n \<ge> 1" by simp
   thus ?thesis
   proof (induction n rule: dec_induct)
     case base
     then show ?case by simp
   next
     case (step n)
     from ln_fact[of "n+1"] **[of n] show ?case by simp
   qed
 qed
 
 lemma ln_fact_diff_bounds:
   "abs(ln (fact n) - 2 * ln (fact (n div 2)) - n * ln 2) \<le> 4 * ln (if n = 0 then 1 else n) + 3"
 proof (cases "n div 2 = 0")
   case True
   hence "n \<le> 1" by simp
   with ln_le_minus_one[of "2::real"] show ?thesis by (cases n) simp_all
 next
   case False
   then have "n > 1" by simp
   let ?a = "real n * ln 2"
   let ?b = "4 * ln (real n) + 3"
   let ?l1 = "ln (fact (n div 2))"
   let ?a1 = "real (n div 2) * ln (real (n div 2)) - real (n div 2)"
   let ?b1 = "1 + ln (real (n div 2))"
   let ?l2 = "ln (fact n)"
   let ?a2 = "real n * ln (real n) - real n"
   let ?b2 = "1 + ln (real n)"
   have abs_a: "abs(?a - (?a2 - 2 * ?a1)) \<le> ?b - 2 * ?b1 - ?b2"
   proof (cases "even n")
     case True
     then have "real (2 * (n div 2)) = real n"
       by simp
     then have n_div_2: "real (n div 2) = real n / 2"
       by simp
     from \<open>n > 1\<close> have *: "abs(?a - (?a2 - 2 * ?a1)) = 0"
       by (simp add: n_div_2 ln_div algebra_simps)
     from \<open>even n\<close> and \<open>n > 1\<close> have "0 \<le> ln (real n) - ln (real (n div 2))"
       by (auto elim: evenE)
     also have "2 * \<dots> \<le> 3 * ln (real n) - 2 * ln (real (n div 2))"
       using \<open>n > 1\<close> by (auto intro!: ln_ge_zero)
     also have "\<dots> = ?b - 2 * ?b1 - ?b2" by simp
     finally show ?thesis using * by simp
   next
     case False
     then have "real (2 * (n div 2)) = real (n - 1)"
       by simp
     with \<open>n > 1\<close> have n_div_2: "real (n div 2) = (real n - 1) / 2"
       by simp
     from \<open>odd n\<close> \<open>n div 2 \<noteq> 0\<close> have "n \<ge> 3"
       by presburger
 
     have "?a - (?a2 - 2 * ?a1) = real n * ln 2 - real n * ln (real n) + real n + 
              2 * real (n div 2) * ln (real (n div 2)) - 2* real (n div 2)"
       by (simp add: algebra_simps)
     also from n_div_2 have "2 * real (n div 2) = real n - 1"
       by simp
     also have "real n * ln 2 - real n * ln (real n) + real n + 
                    (real n - 1) * ln (real (n div 2)) - (real n - 1)
                  = real n * (ln (real n - 1) - ln (real n)) - ln (real (n div 2)) + 1"
       using \<open>n > 1\<close> by (simp add: algebra_simps n_div_2 ln_div)
     finally have lhs: "abs(?a - (?a2 - 2 * ?a1)) = 
         abs(real n * (ln (real n - 1) - ln (real n)) - ln (real (n div 2)) + 1)"
       by simp
 
     from \<open>n > 1\<close> have "real n * (ln (real n - 1) - ln (real n)) \<le> 0"
       by (simp add: algebra_simps mult_left_mono)
     moreover from \<open>n > 1\<close> have "ln (real (n div 2)) \<le> ln (real n)" by simp
     moreover {
       have "exp 1 \<le> (3::real)" by (rule exp_le)
       also from \<open>n \<ge> 3\<close> have "\<dots> \<le> exp (ln (real n))" by simp
       finally have "ln (real n) \<ge> 1" by simp
     }
     ultimately have ub: "real n * (ln (real n - 1) - ln (real n)) - ln(real (n div 2)) + 1 \<le> 
                            3 * ln (real n) - 2 * ln(real (n div 2))" by simp
  
     have mon: "real n' * (ln (real n') - ln (real n' - 1)) \<le> 
                  real n * (ln (real n) - ln (real n - 1))" 
       if "n \<ge> 3" "n' \<ge> n" for n n'::nat
     proof (rule DERIV_nonpos_imp_nonincreasing[where f = "\<lambda>x. x * (ln x - ln (x - 1))"])
       fix t assume t: "real n \<le> t" "t \<le> real n'"
       with that have "1 / (t - 1) \<ge> ln (1 + 1/(t - 1))"
         by (intro ln_add_one_self_le_self) simp_all
       also from t that have "ln (1 + 1/(t - 1)) = ln t- ln (t - 1)"
         by (simp add: ln_div [symmetric] field_simps)
       finally have "ln t - ln (t - 1) \<le> 1 / (t - 1)" .
       with that t
       show "\<exists>y. ((\<lambda>x. x * (ln x - ln (x - 1))) has_field_derivative y) (at t) \<and> y \<le> 0"
         by (intro exI[of _ "1 / (1 - t) + ln t - ln (t - 1)"])
           (force intro!: derivative_eq_intros simp: field_simps)+
     qed (use that in simp_all)
 
     from \<open>n > 1\<close> have "ln 2 = ln (real n) - ln (real n / 2)"
       by (simp add: ln_div)
     also from \<open>n > 1\<close> have "\<dots> \<le> ln (real n) - ln (real (n div 2))" 
       by simp
     finally have *: "3*ln 2 + ln(real (n div 2)) \<le> 3* ln(real n) - 2* ln(real (n div 2))"
       by simp
     
     have "- real n * (ln (real n - 1) - ln (real n)) + ln(real (n div 2)) - 1 = 
             real n * (ln (real n) - ln (real n - 1)) - 1 + ln(real (n div 2))"
       by (simp add: algebra_simps)
     also have "real n * (ln (real n) - ln (real n - 1)) \<le> 3 * (ln 3 - ln (3 - 1))"
       using mon[OF _ \<open>n \<ge> 3\<close>] by simp
     also {
       have "Some (Float 3 (-1)) = ub_ln 1 3" by code_simp
       from ub_ln(1)[OF this] have "ln 3 \<le> (1.6 :: real)" by simp
       also have "1.6 - 1 / 3 \<le> 2 * (2/3 :: real)" by simp
       also have "2/3 \<le> ln (2 :: real)" by (rule ln_2_ge')
       finally have "ln 3 - 1 / 3 \<le> 2 * ln (2 :: real)" by simp
     }
     hence "3 * (ln 3 - ln (3 - 1)) - 1 \<le> 3 * ln (2 :: real)" by simp
     also note *
     finally have "- real n * (ln (real n - 1) - ln (real n)) + ln(real (n div 2)) - 1 \<le> 
                     3 * ln (real n) - 2 * ln (real (n div 2))" by simp
     hence lhs': "abs(real n * (ln (real n - 1) - ln (real n)) - ln(real (n div 2)) + 1) \<le> 
                    3 * ln (real n) - 2 * ln (real (n div 2))"
       using ub by simp
     have rhs: "?b - 2 * ?b1 - ?b2 = 3* ln (real n) - 2 * ln (real (n div 2))"
       by simp
     from \<open>n > 1\<close> have "ln (real (n div 2)) \<le> 3* ln (real n) - 2* ln (real (n div 2))"
       by simp
     with rhs lhs lhs' show ?thesis
       by simp
   qed
   then have minus_a: "-?a \<le> ?b - 2 * ?b1 - ?b2 - (?a2 - 2 * ?a1)"
     by simp
   from abs_a have a: "?a \<le> ?b - 2 * ?b1 - ?b2 + ?a2 - 2 * ?a1"
     by (simp)
   from ln_fact_bounds[of "n div 2"] False have abs_l1: "abs(?l1 - ?a1) \<le> ?b1"
     by (simp add: algebra_simps)
   then have minus_l1: "?a1 - ?l1 \<le> ?b1"
     by linarith
   from abs_l1 have l1: "?l1 - ?a1 \<le> ?b1"
     by linarith
   from ln_fact_bounds[of n] False have abs_l2: "abs(?l2 - ?a2) \<le> ?b2"
     by (simp add: algebra_simps)
   then have l2: "?l2 - ?a2 \<le> ?b2"
     by simp
   from abs_l2 have minus_l2: "?a2 - ?l2 \<le> ?b2"
     by simp
   from minus_a minus_l1 l2 have "?l2 - 2 * ?l1 - ?a \<le> ?b"
     by simp
   moreover from a l1 minus_l2 have "- ?l2 + 2 * ?l1 + ?a \<le> ?b"
     by simp
   ultimately have "abs((?l2 - 2*?l1) - ?a) \<le> ?b"
     by simp
   then show ?thesis 
     by simp
 qed  
   
 lemma ln_primefact:
   assumes "n \<noteq> (0::nat)"
   shows   "ln n = (\<Sum>d=1..n. if primepow d \<and> d dvd n then ln (aprimedivisor d) else 0)" 
           (is "?lhs = ?rhs")
 proof -
   have "?rhs = (\<Sum>d\<in>{x \<in> {1..n}. primepow x \<and> x dvd n}. ln (real (aprimedivisor d)))" 
     unfolding primepow_factors_def by (subst sum.inter_filter [symmetric]) simp_all
   also have "{x \<in> {1..n}. primepow x \<and> x dvd n} = primepow_factors n"
     using assms by (auto simp: primepow_factors_def dest: dvd_imp_le primepow_gt_Suc_0)
   finally have *: "(\<Sum>d\<in>primepow_factors n. ln (real (aprimedivisor d))) = ?rhs" ..
   from in_prime_factors_imp_prime prime_gt_0_nat 
     have pf_pos: "\<And>p. p\<in>#prime_factorization n \<Longrightarrow> p > 0"
     by blast
   from ln_msetprod[of "prime_factorization n", OF pf_pos] assms
     have "ln n = (\<Sum>p\<in>#prime_factorization n. ln p)"
       by (simp add: of_nat_prod_mset)
   also from * sum_prime_factorization_conv_sum_primepow_factors[of n ln, OF assms(1)]
     have "\<dots> = ?rhs" by simp
   finally show ?thesis .
 qed
 
 context
 begin
 
 private lemma divisors:
   fixes x d::nat
   assumes "x \<in> {1..n}"
   assumes "d dvd x"
   shows "\<exists>k\<in>{1..n div d}. x = d * k"
 proof -
   from assms have "x \<le> n"
     by simp
   then have ub: "x div d \<le> n div d"
     by (simp add: div_le_mono \<open>x \<le> n\<close>)
   from assms have "1 \<le> x div d" by (auto elim!: dvdE)
   with ub have "x div d \<in> {1..n div d}"
     by simp
   with \<open>d dvd x\<close> show ?thesis by (auto intro!: bexI[of _ "x div d"])
 qed
 
 lemma ln_fact_conv_mangoldt: "ln (fact n) = (\<Sum>d=1..n. mangoldt d * floor (n / d))"
 proof -
   have *: "(\<Sum>da=1..n. if primepow da \<and> da dvd d then ln (aprimedivisor da) else 0) = 
              (\<Sum>(da::nat)=1..d. if primepow da \<and> da dvd d then ln (aprimedivisor da) else 0)" 
     if d: "d \<in> {1..n}" for d
     by (rule sum.mono_neutral_right, insert d) (auto dest: dvd_imp_le)
   have "(\<Sum>d=1..n. \<Sum>da=1..d. if primepow da \<and>
       da dvd d then ln (aprimedivisor da) else 0) = 
       (\<Sum>d=1..n. \<Sum>da=1..n. if primepow da \<and>
       da dvd d then ln (aprimedivisor da) else 0)"
     by (rule sum.cong) (insert *, simp_all)
   also have "\<dots> = (\<Sum>da=1..n. \<Sum>d=1..n. if primepow da \<and>
                      da dvd d then ln (aprimedivisor da) else 0)"
     by (rule sum.swap)
   also have "\<dots> = sum (\<lambda>d. mangoldt d * floor (n/d)) {1..n}"
   proof (rule sum.cong)
     fix d assume d: "d \<in> {1..n}"
     have "(\<Sum>da = 1..n. if primepow d \<and> d dvd da then ln (real (aprimedivisor d)) else 0) =
             (\<Sum>da = 1..n. if d dvd da then mangoldt d else 0)"
       by (intro sum.cong) (simp_all add: mangoldt_def)
     also have "\<dots> = mangoldt d * real (card {x. x \<in> {1..n} \<and> d dvd x})"
       by (subst sum.inter_filter [symmetric]) (simp_all add: algebra_simps)
     also {
       have "{x. x \<in> {1..n} \<and> d dvd x} = {x. \<exists>k \<in>{1..n div d}. x=k*d}"
       proof safe
         fix x assume "x \<in> {1..n}" "d dvd x"
         thus "\<exists>k\<in>{1..n div d}. x = k * d" using divisors[of x n d] by auto
       next
         fix x k assume k: "k \<in> {1..n div d}"
         from k have "k * d \<le> n div d * d" by (intro mult_right_mono) simp_all
         also have "n div d * d \<le> n div d * d + n mod d" by (rule le_add1)
         also have "\<dots> = n" by simp
         finally have "k * d \<le> n" .
         thus "k * d \<in> {1..n}" using d k by auto
       qed auto
       also have "\<dots> = (\<lambda>k. k*d) ` {1..n div d}"
         by fast
       also have "card \<dots> = card {1..n div d}"
         by (rule card_image) (simp add: inj_on_def)
       also have "\<dots> = n div d"
         by simp
       also have "... = \<lfloor>n / d\<rfloor>"
         by (simp add: floor_divide_of_nat_eq)
       finally have "real (card {x. x \<in> {1..n} \<and> d dvd x}) = real_of_int \<lfloor>n / d\<rfloor>"
         by force
     }
     finally show "(\<Sum>da = 1..n. if primepow d \<and> d dvd da then ln (real (aprimedivisor d)) else 0) =
             mangoldt d * real_of_int \<lfloor>real n / real d\<rfloor>" .
   qed simp_all
   finally have "(\<Sum>d=1..n. \<Sum>da=1..d. if primepow da \<and>
       da dvd d then ln (aprimedivisor da) else 0) = 
     sum (\<lambda>d. mangoldt d * floor (n/d)) {1..n}" .
   with ln_primefact have "(\<Sum>d=1..n. ln d) =
     (\<Sum>d=1..n. mangoldt d * floor (n/d))"
     by simp
   with ln_fact show ?thesis
     by simp
 qed
 
 end
 
 context
 begin
 
 private lemma div_2_mult_2_bds:
   fixes n d :: nat
   assumes "d > 0"
   shows "0 \<le> \<lfloor>n / d\<rfloor> - 2 * \<lfloor>(n div 2) / d\<rfloor>" "\<lfloor>n / d\<rfloor> - 2 * \<lfloor>(n div 2) / d\<rfloor> \<le> 1"
 proof -
   have "\<lfloor>2::real\<rfloor> * \<lfloor>(n div 2) / d\<rfloor> \<le> \<lfloor>2 * ((n div 2) / d)\<rfloor>" 
     by (rule le_mult_floor) simp_all
   also from assms have "\<dots> \<le> \<lfloor>n / d\<rfloor>" by (intro floor_mono) (simp_all add: field_simps)
   finally show "0 \<le> \<lfloor>n / d\<rfloor> - 2 * \<lfloor>(n div 2) / d\<rfloor>" by (simp add: algebra_simps)
 next  
   have "real (n div d) \<le> real (2 * ((n div 2) div d) + 1)"
     by (subst div_mult2_eq [symmetric], simp only: mult.commute, subst div_mult2_eq) simp
   thus "\<lfloor>n / d\<rfloor> - 2 * \<lfloor>(n div 2) / d\<rfloor> \<le> 1"
     unfolding of_nat_add of_nat_mult floor_conv_div_nat [symmetric] by simp_all
 qed
 
 private lemma n_div_d_eq_1: "d \<in> {n div 2 + 1..n} \<Longrightarrow> \<lfloor>real n / real d\<rfloor> = 1"
   by (cases "n = d") (auto simp: field_simps intro: floor_eq)
     
 lemma psi_bounds_ln_fact:
   shows "ln (fact n) - 2 * ln (fact (n div 2)) \<le> psi n"
         "psi n - psi (n div 2) \<le> ln (fact n) - 2 * ln (fact (n div 2))"
 proof -
   fix n::nat
   let ?k = "n div 2" and ?d = "n mod 2"
   have *: "\<lfloor>?k / d\<rfloor> = 0" if "d > ?k" for d
   proof -
     from that div_less have "0 = ?k div d" by simp
     also have "\<dots> = \<lfloor>?k / d\<rfloor>" by (rule floor_divide_of_nat_eq [symmetric])
     finally show "\<lfloor>?k / d\<rfloor> = 0" by simp
   qed
   have sum_eq: "(\<Sum>d=1..2*?k+?d. mangoldt d * \<lfloor>?k / d\<rfloor>) = (\<Sum>d=1..?k. mangoldt d * \<lfloor>?k / d\<rfloor>)"
     by (intro sum.mono_neutral_right) (auto simp: *)
   from ln_fact_conv_mangoldt have "ln (fact n) = (\<Sum>d=1..n. mangoldt d * \<lfloor>n / d\<rfloor>)" .
   also have "\<dots> = (\<Sum>d=1..n. mangoldt d * \<lfloor>(2 * (n div 2) + n mod 2) / d\<rfloor>)"
     by simp
   also have "\<dots> \<le> (\<Sum>d=1..n. mangoldt d * (2 * \<lfloor>?k / d\<rfloor> + 1))"
     using div_2_mult_2_bds(2)[of _ n]
     by (intro sum_mono mult_left_mono, subst of_int_le_iff)
        (auto simp: algebra_simps mangoldt_nonneg)
   also have "\<dots> = 2 * (\<Sum>d=1..n. mangoldt d * \<lfloor>(n div 2) / d\<rfloor>) + (\<Sum>d=1..n. mangoldt d)"
     by (simp add: algebra_simps sum.distrib sum_distrib_left)
   also have "\<dots> = 2 * (\<Sum>d=1..2*?k+?d. mangoldt d * \<lfloor>(n div 2) / d\<rfloor>) + (\<Sum>d=1..n. mangoldt d)"
     by presburger
   also from sum_eq have "\<dots> = 2 * (\<Sum>d=1..?k. mangoldt d * \<lfloor>(n div 2) / d\<rfloor>) + (\<Sum>d=1..n. mangoldt d)"
     by presburger
   also from ln_fact_conv_mangoldt psi_def have "\<dots> = 2 * ln (fact ?k) + psi n"
     by presburger
   finally show "ln (fact n) - 2 * ln (fact (n div 2)) \<le> psi n"
     by simp
 next
   fix n::nat
   let ?k = "n div 2" and  ?d = "n mod 2"
   from psi_def have "psi n - psi ?k = (\<Sum>d=1..2*?k+?d. mangoldt d) - (\<Sum>d=1..?k. mangoldt d)"
     by presburger
   also have "\<dots> = sum mangoldt ({1..2 * (n div 2) + n mod 2} - {1..n div 2})"
     by (subst sum_diff) simp_all
   also have "\<dots> = (\<Sum>d\<in>({1..2 * (n div 2) + n mod 2} - {1..n div 2}). 
                     (if d \<le> ?k then 0 else mangoldt d))"
     by (intro sum.cong) simp_all
   also have "\<dots> = (\<Sum>d=1..2*?k+?d. (if d \<le> ?k then 0 else mangoldt d))"
     by (intro sum.mono_neutral_left) auto
   also have "\<dots> = (\<Sum>d=1..n. (if d \<le> ?k then 0 else mangoldt d))"
     by presburger
   also have "\<dots> = (\<Sum>d=1..n. (if d \<le> ?k then mangoldt d * 0 else mangoldt d))"
     by (intro sum.cong) simp_all
   also from div_2_mult_2_bds(1) have "\<dots> \<le> (\<Sum>d=1..n. (if d \<le> ?k then mangoldt d * (\<lfloor>n/d\<rfloor> - 2 * \<lfloor>?k/d\<rfloor>) else mangoldt d))"
     by (intro sum_mono) 
        (auto simp: algebra_simps mangoldt_nonneg intro!: mult_left_mono simp del: of_int_mult)
   also from n_div_d_eq_1 have "\<dots> = (\<Sum>d=1..n. (if d \<le> ?k then mangoldt d * (\<lfloor>n/d\<rfloor> - 2 * \<lfloor>?k/d\<rfloor>) else mangoldt d * \<lfloor>n/d\<rfloor>))"
     by (intro sum.cong refl) auto
   also have "\<dots> = (\<Sum>d=1..n. mangoldt d * real_of_int (\<lfloor>real n / real d\<rfloor>) -
                      (if d \<le> ?k then 2 * mangoldt d * real_of_int \<lfloor>real ?k / real d\<rfloor> else 0))"
     by (intro sum.cong refl) (auto simp: algebra_simps)
   also have "\<dots> = (\<Sum>d=1..n. mangoldt d * real_of_int (\<lfloor>real n / real d\<rfloor>)) - 
                   (\<Sum>d=1..n. (if d \<le> ?k then 2 * mangoldt d * real_of_int \<lfloor>real ?k / real d\<rfloor> else 0))"
     by (rule sum_subtractf)    
   also have "(\<Sum>d=1..n. (if d \<le> ?k then 2 * mangoldt d * real_of_int \<lfloor>real ?k / real d\<rfloor> else 0)) =
                (\<Sum>d=1..?k. (if d \<le> ?k then 2 * mangoldt d * real_of_int \<lfloor>real ?k / real d\<rfloor> else 0))"
     by (intro sum.mono_neutral_right) auto
   also have "\<dots> = (\<Sum>d=1..?k. 2 * mangoldt d * real_of_int \<lfloor>real ?k / real d\<rfloor>)"
     by (intro sum.cong) simp_all
   also have "\<dots> = 2 * (\<Sum>d=1..?k. mangoldt d * real_of_int \<lfloor>real ?k / real d\<rfloor>)"
     by (simp add: sum_distrib_left mult_ac)
   also have "(\<Sum>d = 1..n. mangoldt d * real_of_int \<lfloor>real n / real d\<rfloor>) - \<dots> = 
                ln (fact n) - 2 * ln (fact (n div 2))"
     by (simp add: ln_fact_conv_mangoldt)
   finally show "psi n - psi (n div 2) \<le> ln (fact n) - 2 * ln (fact (n div 2))" .
 qed
 
 end
 
 lemma psi_bounds_induct:
   "real n * ln 2 - (4 * ln (real (if n = 0 then 1 else n)) + 3) \<le> psi n"
   "psi n - psi (n div 2) \<le> real n * ln 2 + (4 * ln (real (if n = 0 then 1 else n)) + 3)"
 proof -
   from le_imp_neg_le[OF ln_fact_diff_bounds]
     have "n * ln 2 - (4 * ln (if n = 0 then 1 else n) + 3)
          \<le> n * ln 2 - abs(ln (fact n) - 2 * ln (fact (n div 2)) - n * ln 2)"
     by simp
   also have "\<dots> \<le> ln (fact n) - 2 * ln (fact (n div 2))"
     by simp
   also from psi_bounds_ln_fact (1) have "\<dots> \<le> psi n"
     by simp
   finally show "real n * ln 2 - (4 * ln (real (if n = 0 then 1 else n)) + 3) \<le> psi n" .
 next
   from psi_bounds_ln_fact (2) have "psi n - psi (n div 2) \<le> ln (fact n) - 2 * ln (fact (n div 2))" .
   also have "\<dots> \<le> n * ln 2 + abs(ln (fact n) - 2 * ln (fact (n div 2)) - n * ln 2)"
     by simp
   also from ln_fact_diff_bounds [of n] 
     have "abs(ln (fact n) - 2 * ln (fact (n div 2)) - n * ln 2)
             \<le> (4 * ln (real (if n = 0 then 1 else n)) + 3)" by simp
   finally show "psi n - psi (n div 2) \<le> real n * ln 2 + (4 * ln (real (if n = 0 then 1 else n)) + 3)"
     by simp
 qed
   
 
 subsection \<open>Bounding the psi function\<close>
 
 text \<open>
   In this section, we will first prove the relatively tight estimate
   @{prop "psi n \<le> 3 / 2 + ln 2 * n"} for @{term "n \<le> 128"} and then use the 
   recurrence we have just derived to extend it to @{prop "psi n \<le> 551 / 256"} for 
   @{term "n \<le> 1024"}, at which point applying the recurrence can be used to prove 
   the same bound for arbitrarily big numbers.
 
   First of all, we will prove the bound for @{term "n <= 128"} using reflection and
   approximation.
 \<close>  
 
 context
 begin
 
 private lemma Ball_insertD:
   assumes "\<forall>x\<in>insert y A. P x"
   shows   "P y" "\<forall>x\<in>A. P x"
   using assms by auto
 
 private lemma meta_eq_TrueE: "PROP A \<equiv> Trueprop True \<Longrightarrow> PROP A"
   by simp
 
 private lemma pre_mangoldt_pos: "pre_mangoldt n > 0"
   unfolding pre_mangoldt_def by (auto simp: primepow_gt_Suc_0)
 
 private lemma psi_conv_pre_mangoldt: "psi n = ln (real (prod pre_mangoldt {1..n}))"
   by (auto simp: psi_def mangoldt_def pre_mangoldt_def ln_prod primepow_gt_Suc_0 intro!: sum.cong)
 
 private lemma eval_psi_aux1: "psi 0 = ln (real (numeral Num.One))"
   by (simp add: psi_def)
 
 private lemma eval_psi_aux2:
   assumes "psi m = ln (real (numeral x))" "pre_mangoldt n = y" "m + 1 = n" "numeral x * y = z"
   shows   "psi n = ln (real z)"
 proof -
   from assms(2) [symmetric] have [simp]: "y > 0" by (simp add: pre_mangoldt_pos)
   have "psi n = psi (Suc m)" by (simp add: assms(3) [symmetric])
   also have "\<dots> = ln (real y * (\<Prod>x = Suc 0..m. real (pre_mangoldt x)))"
     using assms(2,3) [symmetric] by (simp add: psi_conv_pre_mangoldt prod.nat_ivl_Suc' mult_ac)
   also have "\<dots> = ln (real y) + psi m"
     by (subst ln_mult) (simp_all add: pre_mangoldt_pos prod_pos psi_conv_pre_mangoldt)
   also have "psi m = ln (real (numeral x))" by fact
   also have "ln (real y) + \<dots> = ln (real (numeral x * y))" by (simp add: ln_mult)
   finally show ?thesis by (simp add: assms(4) [symmetric])
 qed
 
 private lemma Ball_atLeast0AtMost_doubleton:
   assumes "psi 0 \<le> 3 / 2 * ln 2 * real 0"
   assumes "psi 1 \<le> 3 / 2 * ln 2 * real 1"
   shows   "(\<forall>x\<in>{0..1}. psi x \<le> 3 / 2 * ln 2 * real x)"
   using assms unfolding One_nat_def atLeast0_atMost_Suc ball_simps by auto
 
 private lemma Ball_atLeast0AtMost_insert:
   assumes "(\<forall>x\<in>{0..m}. psi x \<le> 3 / 2 * ln 2 * real x)"
   assumes "psi (numeral n) \<le> 3 / 2 * ln 2 * real (numeral n)" "m = pred_numeral n"
   shows   "(\<forall>x\<in>{0..numeral n}. psi x \<le> 3 / 2 * ln 2 * real x)"
   using assms
   by (subst numeral_eq_Suc[of n], subst atLeast0_atMost_Suc,
       subst ball_simps, simp only: numeral_eq_Suc [symmetric])
 
 private lemma eval_psi_ineq_aux:
   assumes "psi n = x" "x \<le> 3 / 2 * ln 2 * n"
   shows   "psi n \<le> 3 / 2 * ln 2 * n"
   using assms by simp_all
     
 private lemma eval_psi_ineq_aux2:
   assumes "numeral m ^ 2 \<le> (2::nat) ^ (3 * n)"
   shows   "ln (real (numeral m)) \<le> 3 / 2 * ln 2 * real n"
 proof -
   have "ln (real (numeral m)) \<le> 3 / 2 * ln 2 * real n \<longleftrightarrow> 
           2 * log 2 (real (numeral m)) \<le> 3 * real n"
     by (simp add: field_simps log_def)
   also have "2 * log 2 (real (numeral m)) = log 2 (real (numeral m ^ 2))"
     by (subst of_nat_power, subst log_nat_power) simp_all
   also have "\<dots> \<le> 3 * real n \<longleftrightarrow> real ((numeral m) ^ 2) \<le> 2 powr real (3 * n)"
     by (subst Transcendental.log_le_iff) simp_all
   also have "2 powr (3 * n) = real (2 ^ (3 * n))" 
     by (simp add: powr_realpow [symmetric])
   also have "real ((numeral m) ^ 2) \<le> \<dots> \<longleftrightarrow> numeral m ^ 2 \<le> (2::nat) ^ (3 * n)"
     by (rule of_nat_le_iff)
   finally show ?thesis using assms by blast
 qed
 
 private lemma eval_psi_ineq_aux_mono:
   assumes "psi n = x" "psi m = x" "psi n \<le> 3 / 2 * ln 2 * n" "n \<le> m"
   shows   "psi m \<le> 3 / 2 * ln 2 * m"
 proof -
   from assms have "psi m = psi n" by simp
   also have "\<dots> \<le> 3 / 2 * ln 2 * n" by fact
   also from \<open>n \<le> m\<close> have "\<dots> \<le> 3 / 2 * ln 2 * m" by simp
   finally show ?thesis .
 qed
 
 lemma not_primepow_1_nat: "\<not>primepow (1 :: nat)" by auto
                  
 ML_file \<open>bertrand.ML\<close>
 
 (* This should not take more than 1 minute *)
 local_setup \<open>fn ctxt =>
 let
   fun tac {context = ctxt, ...} =
     let
       val psi_cache = Bertrand.prove_psi ctxt 129
       fun prove_psi_ineqs ctxt =
         let
           fun tac {context = ctxt, ...} = 
             HEADGOAL (resolve_tac ctxt @{thms eval_psi_ineq_aux2} THEN' Simplifier.simp_tac ctxt)
           fun prove_by_approx n thm =
             let
               val thm = thm RS @{thm eval_psi_ineq_aux}
               val [prem] = Thm.prems_of thm
               val prem = Goal.prove ctxt [] [] prem tac
             in
               prem RS thm
             end
           fun prove_by_mono last_thm last_thm' thm =
             let
               val thm = @{thm eval_psi_ineq_aux_mono} OF [last_thm, thm, last_thm']
               val [prem] = Thm.prems_of thm
               val prem = Goal.prove ctxt [] [] prem (K (HEADGOAL (Simplifier.simp_tac ctxt)))
             in
               prem RS thm
             end
           fun go _ acc [] = acc
             | go last acc ((n, x, thm) :: xs) =
                 let
                   val thm' =
                     case last of
                       NONE => prove_by_approx n thm
                     | SOME (last_x, last_thm, last_thm') => 
                         if last_x = x then 
                           prove_by_mono last_thm last_thm' thm 
                         else
                           prove_by_approx n thm
                 in
                   go (SOME (x, thm, thm')) (thm' :: acc) xs
                 end
         in
           rev o go NONE []
         end
             
       val psi_ineqs = prove_psi_ineqs ctxt psi_cache
       fun prove_ball ctxt (thm1 :: thm2 :: thms) =
             let
               val thm = @{thm Ball_atLeast0AtMost_doubleton} OF [thm1, thm2]
               fun solve_prem thm =
                 let
                   fun tac {context = ctxt, ...} = HEADGOAL (Simplifier.simp_tac ctxt)
                   val thm' = Goal.prove ctxt [] [] (Thm.cprem_of thm 1 |> Thm.term_of) tac
                 in
                   thm' RS thm
                 end
               fun go thm thm' = (@{thm Ball_atLeast0AtMost_insert} OF [thm', thm]) |> solve_prem
             in
               fold go thms thm
             end
         | prove_ball _ _ = raise Match
     in
       HEADGOAL (resolve_tac ctxt [prove_ball ctxt psi_ineqs])
     end
   val thm = Goal.prove @{context} [] [] @{prop "\<forall>n\<in>{0..128}. psi n \<le> 3 / 2 * ln 2 * n"} tac
 in
   Local_Theory.note ((@{binding psi_ubound_log_128}, []), [thm]) ctxt |> snd
 end
 \<close>
 
 end
 
 
 context
 begin
   
 private lemma psi_ubound_aux:
   defines "f \<equiv> \<lambda>x::real. (4 * ln x + 3) / (ln 2 * x)"
   assumes "x \<ge> 2" "x \<le> y"
   shows   "f x \<ge> f y"
 using assms(3)
 proof (rule DERIV_nonpos_imp_nonincreasing, goal_cases)
   case (1 t)
   define f' where "f' = (\<lambda>x. (1 - 4 * ln x) / x^2 / ln 2 :: real)"
   from 1 assms(2) have "(f has_real_derivative f' t) (at t)" unfolding f_def f'_def
     by (auto intro!: derivative_eq_intros simp: field_simps power2_eq_square)
   moreover {
     from ln_2_ge have "1/4 \<le> ln (2::real)" by simp
     also from assms(2) 1 have "\<dots> \<le> ln t" by simp
     finally have "ln t \<ge> 1/4" .
   }
   with 1 assms(2) have "f' t \<le> 0" by (simp add: f'_def field_simps)
   ultimately show ?case by (intro exI[of _ "f' t"]) simp_all
 qed  
 
 text \<open>
   These next rules are used in combination with @{thm psi_bounds_induct} and 
   @{thm psi_ubound_log_128} to extend the upper bound for @{term "psi"} from values no greater 
   than 128 to values no greater than 1024. The constant factor of the upper bound changes every 
   time, but once we have reached 1024, the recurrence is self-sustaining in the sense that we do 
   not have to adjust the constant factor anymore in order to double the range.
 \<close>
 lemma psi_ubound_log_double_cases':
   assumes "\<And>n. n \<le> m \<Longrightarrow> psi n \<le> c * ln 2 * real n" "n \<le> m'" "m' = 2*m"
           "c \<le> c'" "c \<ge> 0" "m \<ge> 1" "c' \<ge> 1 + c/2 + (4 * ln (m+1) + 3) / (ln 2 * (m+1))"
   shows   "psi n \<le> c' * ln 2 * real n"
 proof (cases "n > m")
   case False
   hence "psi n \<le> c * ln 2 * real n" by (intro assms) simp_all
   also have "c \<le> c'" by fact
   finally show ?thesis by - (simp_all add: mult_right_mono)
 next
   case True
   hence n: "n \<ge> m+1" by simp
   from psi_bounds_induct(2)[of n] True
     have "psi n \<le> real n * ln 2 + 4 * ln (real n) + 3 + psi (n div 2)" by simp
   also from assms have "psi (n div 2) \<le> c * ln 2 * real (n div 2)" 
     by (intro assms) simp_all
   also have "real (n div 2) \<le> real n / 2" by simp
   also have "c * ln 2 * \<dots> = c / 2 * ln 2 * real n" by simp
   also have "real n * ln 2 + 4 * ln (real n) + 3 + \<dots> = 
                (1 + c/2) * ln 2 * real n + (4 * ln (real n) + 3)" by (simp add: field_simps)
   also {
     have "(4 * ln (real n) + 3) / (ln 2 * (real n)) \<le> (4 * ln (m+1) + 3) / (ln 2 * (m+1))"
       using n assms by (intro psi_ubound_aux) simp_all
     also from assms have "(4 * ln (m+1) + 3) / (ln 2 * (m+1)) \<le> c' - 1 - c/2" 
       by (simp add: algebra_simps)
     finally have "4 * ln (real n) + 3 \<le> (c' - 1 - c/2) * ln 2 * real n" 
       using n by (simp add: field_simps)
   }
   also have "(1 + c / 2) * ln 2 * real n + (c' - 1 - c / 2) * ln 2 * real n = c' * ln 2 * real n"
     by (simp add: field_simps)
   finally show ?thesis using \<open>c \<ge> 0\<close> by (simp_all add: mult_left_mono)
 qed
 
 end  
 
 lemma psi_ubound_log_double_cases:
   assumes "\<forall>n\<le>m. psi n \<le> c * ln 2 * real n"
           "c' \<ge> 1 + c/2 + (4 * ln (m+1) + 3) / (ln 2 * (m+1))"
           "m' = 2*m" "c \<le> c'" "c \<ge> 0" "m \<ge> 1" 
   shows   "\<forall>n\<le>m'. psi n \<le> c' * ln 2 * real n"
   using assms(1) by (intro allI impI assms psi_ubound_log_double_cases'[of m c _ m' c']) auto
 
 lemma psi_ubound_log_1024:
   "\<forall>n\<le>1024. psi n \<le> 551 / 256 * ln 2 * real n"
 proof -
   from psi_ubound_log_128 have "\<forall>n\<le>128. psi n \<le> 3 / 2 * ln 2 * real n" by simp
   hence "\<forall>n\<le>256. psi n \<le> 1025 / 512 * ln 2 * real n"
   proof (rule psi_ubound_log_double_cases, goal_cases)
     case 1
     have "Some (Float 624 (- 7)) = ub_ln 9 129" by code_simp
     from ub_ln(1)[OF this] and ln_2_ge show ?case by (simp add: field_simps)
   qed simp_all
   hence "\<forall>n\<le>512. psi n \<le> 549 / 256 * ln 2 * real n"
   proof (rule psi_ubound_log_double_cases, goal_cases)
     case 1
     have "Some (Float 180 (- 5)) = ub_ln 7 257" by code_simp
     from ub_ln(1)[OF this] and ln_2_ge show ?case by (simp add: field_simps)
   qed simp_all
   thus "\<forall>n\<le>1024. psi n \<le> 551 / 256 * ln 2 * real n"
   proof (rule psi_ubound_log_double_cases, goal_cases)
     case 1
     have "Some (Float 203 (- 5)) = ub_ln 7 513" by code_simp
     from ub_ln(1)[OF this] and ln_2_ge show ?case by (simp add: field_simps)
   qed simp_all
 qed
   
 lemma psi_bounds_sustained_induct:
   assumes "4 * ln (1 + 2 ^ j) + 3 \<le> d * ln 2 * (1 + 2^j)"
   assumes "4 / (1 + 2^j) \<le> d * ln 2"
   assumes "0 \<le> c"
   assumes "c / 2 + d + 1 \<le> c"
   assumes "j \<le> k"
   assumes "\<And>n. n \<le> 2^k \<Longrightarrow> psi n \<le> c * ln 2 * n"
   assumes "n \<le> 2^(Suc k)"
   shows "psi n \<le> c * ln 2 * n"
 proof (cases "n \<le> 2^k")
   case True
   with assms(6) show ?thesis .
 next
   case False
   from psi_bounds_induct(2) 
     have "psi n - psi (n div 2) \<le> real n * ln 2 + (4 * ln (real (if n = 0 then 1 else n)) + 3)" .
   also from False have "(if n = 0 then 1 else n) = n"
     by simp
   finally have "psi n \<le> real n * ln 2 + (4 * ln (real n) + 3) + psi (n div 2)"
     by simp
   also from assms(6,7) have "psi (n div 2) \<le> c * ln 2 * (n div 2)"
     by simp
   also have "real (n div 2) \<le> real n / 2"
     by simp
   also have "real n * ln 2 + (4 * ln (real n) + 3) + c * ln 2 * (n / 2) \<le> c * ln 2 * real n"
     proof (rule overpower_lemma[of
             "\<lambda>x. x * ln 2 + (4 * ln x + 3) + c * ln 2 * (x / 2)" "1+2^j"
             "\<lambda>x. c * ln 2 * x" "\<lambda>x. c * ln 2 - ln 2 - 4 / x - c / 2 * ln 2"
             "real n"])
       from assms(1) have "4 * ln (1 + 2^j) + 3 \<le> d * ln 2 * (1 + 2^j)" .
       also from assms(4) have "d \<le> c - c/2 - 1"
         by simp
       also have "(\<dots>) * ln 2 * (1 + 2 ^ j) = c * ln 2 * (1 + 2 ^ j) - c / 2 * ln 2 * (1 + 2 ^ j)
           - (1 + 2 ^ j) * ln 2"
         by (simp add: left_diff_distrib)
       finally have "4 * ln (1 + 2^j) + 3 \<le> c * ln 2 * (1 + 2 ^ j) - c / 2 * ln 2 * (1 + 2 ^ j)
           - (1 + 2 ^ j) * ln 2"
         by (simp add: add_pos_pos)
       then show "(1 + 2 ^ j) * ln 2 + (4 * ln (1 + 2 ^ j) + 3)
                     + c * ln 2 * ((1 + 2 ^ j) / 2) \<le> c * ln 2 * (1 + 2 ^ j)"
         by simp
     next
       fix x::real
       assume x: "1 + 2^j \<le> x"
       moreover have "1 + 2 ^ j > (0::real)" by (simp add: add_pos_pos)
       ultimately have x_pos: "x > 0" by linarith
       show "((\<lambda>x. c * ln 2 * x - (x * ln 2 + (4 * ln x + 3) + c * ln 2 * (x / 2)))
               has_real_derivative c * ln 2 - ln 2 - 4 / x - c / 2 * ln 2) (at x)"
         by (rule derivative_eq_intros refl | simp add: \<open>0 < x\<close>)+
       from \<open>0 < x\<close> \<open>0 < 1 + 2^j\<close> have "0 < x * (1 + 2^j)"
         by (rule mult_pos_pos)
       have "4 / x \<le> 4 / (1 + 2^j)"
         by (intro divide_left_mono mult_pos_pos add_pos_pos x x_pos) simp_all
       also from assms(2) have "4 / (1 + 2^j) \<le> d * ln 2" .
       also from assms(4) have "d \<le> c - c/2 - 1" by simp
       also have "\<dots> * ln 2 = c * ln 2 - c/2 * ln 2 - ln 2" by (simp add: algebra_simps)
       finally show "0 \<le> c * ln 2 - ln 2 - 4 / x - c / 2 * ln 2" by simp
     next
       have "1 + 2^j = real (1 + 2^j)" by simp
       also from assms(5) have "\<dots> \<le> real (1 + 2^k)" by simp
       also from False have "2^k \<le> n - 1" by simp
       finally show "1 + 2^j \<le> real n" using False by simp 
     qed
     finally show ?thesis using assms by - (simp_all add: mult_left_mono)
 qed
 
 lemma psi_bounds_sustained:
   assumes "\<And>n. n \<le> 2^k \<Longrightarrow> psi n \<le> c * ln 2 * n"
   assumes "4 * ln (1 + 2^k) + 3 \<le> (c/2 - 1) * ln 2 * (1 + 2^k)"
   assumes "4 / (1 + 2^k) \<le> (c/2 - 1) * ln 2"
   assumes "c \<ge> 0"
   shows "psi n \<le> c * ln 2 * n"
 proof -
   have "psi n \<le> c * ln 2 * n" if "n \<le> 2^j" for j n
   using that
   proof (induction j arbitrary: n)
     case 0
     with assms(4) 0 show ?case unfolding psi_def mangoldt_def by (cases n) auto
   next
     case (Suc j)
     show ?case
       proof (cases "k \<le> j")
         case True
         from assms(4) have c_div_2: "c/2 + (c/2 - 1) + 1 \<le> c"
           by simp
         from psi_bounds_sustained_induct[of k "c/2 -1" c j,
              OF assms(2) assms(3) assms(4) c_div_2 True Suc.IH Suc.prems]
           show ?thesis by simp
       next
         case False
         then have j_lt_k: "Suc j \<le> k" by simp
         from Suc.prems have "n \<le> 2 ^ Suc j" .
         also have "(2::nat) ^ Suc j \<le> 2 ^ k"
           using power_increasing[of "Suc j" k "2::nat", OF j_lt_k]
           by simp
         finally show ?thesis using assms(1) by simp
       qed
     qed
     from less_exp this [of n n] show ?thesis by simp
 qed
 
 lemma psi_ubound_log: "psi n \<le> 551 / 256 * ln 2 * n"
 proof (rule psi_bounds_sustained)
   show "0 \<le> 551 / (256 :: real)" by simp
 next
   fix n :: nat assume "n \<le> 2 ^ 10"
   with psi_ubound_log_1024 show "psi n \<le> 551 / 256 * ln 2 * real n" by auto
 next
   have "4 / (1 + 2 ^ 10) \<le> (551 / 256 / 2 - 1) * (2/3 :: real)"
     by simp
   also have "\<dots> \<le> (551 / 256 / 2 - 1) * ln 2"
     by (intro mult_left_mono ln_2_ge') simp_all
   finally show "4 / (1 + 2 ^ 10) \<le> (551 / 256 / 2 - 1) * ln (2 :: real)" .
 next
   have "Some (Float 16 (-1)) = ub_ln 3 1025" by code_simp
   from ub_ln(1)[OF this] and ln_2_ge 
     have "2048 * ln 1025 + 1536 \<le> 39975 * (ln 2::real)" by simp
   thus "4 * ln (1 + 2 ^ 10) + 3 \<le> (551 / 256 / 2 - 1) * ln 2 * (1 + 2 ^ 10 :: real)"
     by simp
 qed
 
 lemma psi_ubound_3_2: "psi n \<le> 3/2 * n"
 proof -
   have "(551 / 256) * ln 2 \<le> (551 / 256) * (16/23 :: real)" 
     by (intro mult_left_mono ln_2_le') auto
   also have "\<dots> \<le> 3 / 2" by simp
   finally have "551 / 256 * ln 2 \<le> 3/(2::real)" .
   with of_nat_0_le_iff mult_right_mono have "551 / 256 * ln 2 * n \<le> 3/2 * n"
     by blast
   with psi_ubound_log[of "n"] show ?thesis
     by linarith
 qed
 
 
 subsection \<open>Doubling psi and theta\<close>  
 
 lemma psi_residues_compare_2:
   "psi_odd_2 n \<le> psi_even_2 n"
 proof -
   have "psi_odd_2 n = (\<Sum>d\<in>{d. d \<in> {2..n} \<and> primepow_odd d}. mangoldt_odd d)"
     unfolding mangoldt_odd_def by (rule sum.mono_neutral_right) auto
   also have "\<dots> = (\<Sum>d\<in>{d. d \<in> {2..n} \<and> primepow_odd d}. ln (real (aprimedivisor d)))"
     by (intro sum.cong refl) (simp add: mangoldt_odd_def)
   also have "\<dots> \<le> (\<Sum>d\<in>{d. d \<in> {2..n} \<and> primepow_even d}. ln (real (aprimedivisor d)))"
   proof (rule sum_le_included [where i = "\<lambda>y. y * aprimedivisor y"]; clarify?)
     fix d :: nat assume "d \<in> {2..n}" "primepow_odd d"
     note d = this
     then obtain p k where d': "k \<ge> 1" "prime p" "d = p ^ (2*k+1)" 
       by (auto simp: primepow_odd_def)
     from d' have "p ^ (2 * k) \<le> p ^ (2 * k + 1)" 
       by (subst power_increasing_iff) (auto simp: prime_gt_Suc_0_nat)
     also from d d' have "\<dots> \<le> n" by simp
     finally have "p ^ (2 * k) \<le> n" .
     moreover from d' have "p ^ (2 * k) > 1" 
       by (intro one_less_power) (simp_all add: prime_gt_Suc_0_nat)
     ultimately have "p ^ (2 * k) \<in> {2..n}" by simp
     moreover from d' have "primepow_even (p ^ (2 * k))"
       by (auto simp: primepow_even_def)
     ultimately show "\<exists>y\<in>{d \<in> {2..n}. primepow_even d}. y * aprimedivisor y = d \<and>
                        ln (real (aprimedivisor d)) \<le> ln (real (aprimedivisor y))" using d'
       by (intro bexI[of _ "p ^ (2 * k)"])
          (auto simp: aprimedivisor_prime_power aprimedivisor_primepow)
   qed (simp_all add: of_nat_ge_1_iff Suc_le_eq)
   also have "\<dots> = (\<Sum>d\<in>{d. d \<in> {2..n} \<and> primepow_even d}. mangoldt_even d)"
     by (intro sum.cong refl) (simp add: mangoldt_even_def)
   also have "\<dots> = psi_even_2 n"
     unfolding mangoldt_even_def by (rule sum.mono_neutral_left) auto
   finally show ?thesis .
 qed
 
 lemma psi_residues_compare:
   "psi_odd n \<le> psi_even n"
 proof -
   have "\<not> primepow_odd 1" by (simp add: primepow_odd_def)
   hence *: "mangoldt_odd 1 = 0" by (simp add: mangoldt_odd_def)
   have "\<not> primepow_even 1"
     using primepow_gt_Suc_0[OF primepow_even_imp_primepow, of 1] by auto
   with mangoldt_even_def have **: "mangoldt_even 1 = 0"
     by simp
   from psi_odd_def have "psi_odd n = (\<Sum>d=1..n. mangoldt_odd d)"
     by simp
   also from * have "\<dots> = psi_odd_2 n"
     by (cases "n \<ge> 1") (simp_all add: eval_nat_numeral sum.atLeast_Suc_atMost)
   also from psi_residues_compare_2 have "\<dots> \<le> psi_even_2 n" .
   also from ** have "\<dots> = psi_even n"
     by (cases "n \<ge> 1") (simp_all add: eval_nat_numeral sum.atLeast_Suc_atMost psi_even_def)
   finally show ?thesis .
 qed
 
 lemma primepow_iff_even_sqr:
   "primepow n \<longleftrightarrow> primepow_even (n^2)"
   by (cases "n = 0")
      (auto simp: primepow_even_altdef aprimedivisor_primepow_power primepow_power_iff_nat
                  prime_elem_multiplicity_power_distrib prime_aprimedivisor' prime_imp_prime_elem
                  unit_factor_nat_def primepow_gt_0_nat dest: primepow_gt_Suc_0)
 
 lemma psi_sqrt: "psi (Discrete.sqrt n) = psi_even n"
 proof (induction n)
   case 0
   with psi_def psi_even_def show ?case by simp
 next
   case (Suc n)
   then show ?case
     proof cases
       assume asm: "\<exists> m. Suc n = m^2"
       with sqrt_Suc have sqrt_seq: "Discrete.sqrt(Suc n) = Suc(Discrete.sqrt n)"
         by simp
       from asm obtain "m" where "   Suc n = m^2"
         by blast
       with sqrt_seq have "Suc(Discrete.sqrt n) = m"
         by simp
       with \<open>Suc n = m^2\<close> have suc_sqrt_n_sqrt: "(Suc(Discrete.sqrt n))^2 = Suc n"
         by simp
       from sqrt_seq have "psi (Discrete.sqrt (Suc n)) = psi (Suc (Discrete.sqrt n))"
         by simp
       also from psi_def have "\<dots> = psi (Discrete.sqrt n) + mangoldt (Suc (Discrete.sqrt n))"
         by simp
       also from Suc.IH have "psi (Discrete.sqrt n) = psi_even n" .
       also have "mangoldt (Suc (Discrete.sqrt n)) = mangoldt_even (Suc n)"
       proof (cases "primepow (Suc(Discrete.sqrt n))")
         case True
         with primepow_iff_even_sqr have True2: "primepow_even ((Suc(Discrete.sqrt n))^2)"
           by simp
         from suc_sqrt_n_sqrt have "mangoldt_even (Suc n) = mangoldt_even ((Suc(Discrete.sqrt n))^2)"
           by simp
         also from mangoldt_even_def True2
           have "\<dots> = ln (aprimedivisor ((Suc (Discrete.sqrt n))^2))"
           by simp
         also from True have "aprimedivisor ((Suc (Discrete.sqrt n))^2) = aprimedivisor (Suc (Discrete.sqrt n))"
           by (simp add: aprimedivisor_primepow_power)
         also from True have "ln (\<dots>) = mangoldt (Suc (Discrete.sqrt n))"
           by (simp add: mangoldt_def)
         finally show ?thesis ..
       next
         case False
         with primepow_iff_even_sqr
           have False2: "\<not> primepow_even ((Suc(Discrete.sqrt n))^2)"
           by simp
         from suc_sqrt_n_sqrt have "mangoldt_even (Suc n) = mangoldt_even ((Suc(Discrete.sqrt n))^2)"
           by simp
         also from mangoldt_even_def False2
           have "\<dots> = 0"
           by simp
         also from False have "\<dots> = mangoldt (Suc (Discrete.sqrt n))"
           by (simp add: mangoldt_def)
         finally show ?thesis ..
       qed  
       also from psi_even_def have "psi_even n + mangoldt_even (Suc n) = psi_even (Suc n)"
         by simp
       finally show ?case .
     next
       assume asm: "\<not>(\<exists>m. Suc n = m^2)"
       with sqrt_Suc have sqrt_eq: "Discrete.sqrt (Suc n) = Discrete.sqrt n"
         by simp
       then have lhs: "psi (Discrete.sqrt (Suc n)) = psi (Discrete.sqrt n)"
         by simp
       have "\<not> primepow_even (Suc n)"
         proof
           assume "primepow_even (Suc n)"
           with primepow_even_def obtain "p" "k"
             where "1 \<le> k \<and> prime p \<and> Suc n = p ^ (2 * k)" 
             by blast
           with power_even_eq have "Suc n = (p ^ k)^2"
             by simp
           with asm show False by blast
         qed
       with psi_even_def mangoldt_even_def
         have rhs: "psi_even (Suc n) = psi_even n"
         by simp
       from Suc.IH lhs rhs show ?case
         by simp
     qed
 qed
 
 lemma mangoldt_split:
   "mangoldt d = mangoldt_1 d + mangoldt_even d + mangoldt_odd d"
 proof (cases "primepow d")
   case False
   thus ?thesis
     by (auto simp: mangoldt_def mangoldt_1_def mangoldt_even_def mangoldt_odd_def
              dest: primepow_even_imp_primepow primepow_odd_imp_primepow)
 next
   case True
   thus ?thesis
     by (auto simp: mangoldt_def mangoldt_1_def mangoldt_even_def mangoldt_odd_def primepow_cases)
 qed
 
 lemma psi_split: "psi n = theta n + psi_even n + psi_odd n"
   by (induction n) 
      (simp_all add: psi_def theta_def psi_even_def psi_odd_def mangoldt_1_def mangoldt_split)
 
 lemma psi_mono: "m \<le> n \<Longrightarrow> psi m \<le> psi n" unfolding psi_def
   by (intro sum_mono2 mangoldt_nonneg) auto
 
 lemma psi_pos: "0 \<le> psi n"
   by (auto simp: psi_def intro!: sum_nonneg mangoldt_nonneg)
 
 lemma mangoldt_odd_pos: "0 \<le> mangoldt_odd d"
   using aprimedivisor_gt_Suc_0[of d]
   by (auto simp: mangoldt_odd_def of_nat_le_iff[of 1, unfolded of_nat_1] Suc_le_eq
            intro!: ln_ge_zero dest!: primepow_odd_imp_primepow primepow_gt_Suc_0)
 
 lemma psi_odd_mono: "m \<le> n \<Longrightarrow> psi_odd m \<le> psi_odd n"
   using mangoldt_odd_pos sum_mono2[of "{1..n}" "{1..m}" "mangoldt_odd"] 
   by (simp add: psi_odd_def)
 
 lemma psi_odd_pos: "0 \<le> psi_odd n"
   by (auto simp: psi_odd_def intro!: sum_nonneg mangoldt_odd_pos)
 
 lemma psi_theta:
   "theta n + psi (Discrete.sqrt n) \<le> psi n" "psi n \<le> theta n + 2 * psi (Discrete.sqrt n)"
   using psi_odd_pos[of n] psi_residues_compare[of n] psi_sqrt[of n] psi_split[of n]
   by simp_all
 
 context
 begin
 
 private lemma sum_minus_one: 
   "(\<Sum>x \<in> {1..y}. (- 1 :: real) ^ (x + 1)) = (if odd y then 1 else 0)"
   by (induction y) simp_all
   
 private lemma div_invert:
   fixes x y n :: nat
   assumes "x > 0" "y > 0" "y \<le> n div x"
   shows "x \<le> n div y"
 proof -
   from assms(1,3) have "y * x \<le> (n div x) * x"
     by simp
   also have "\<dots> \<le> n"
     by (simp add: minus_mod_eq_div_mult[symmetric])
   finally have "y * x \<le> n" .
   with assms(2) show ?thesis
     using div_le_mono[of "y*x" n y] by simp
 qed
 
 lemma sum_expand_lemma:
   "(\<Sum>d=1..n. (-1) ^ (d + 1) * psi (n div d)) = 
      (\<Sum>d = 1..n. (if odd (n div d) then 1 else 0) * mangoldt d)"
 proof -
   have **: "x \<le> n" if "x \<le> n div y" for x y
     using div_le_dividend order_trans that by blast
   have "(\<Sum>d=1..n. (-1)^(d+1) * psi (n div d)) = 
           (\<Sum>d=1..n. (-1)^(d+1) * (\<Sum>e=1..n div d. mangoldt e))"
     by (simp add: psi_def)
   also have "\<dots> = (\<Sum>d = 1..n. \<Sum>e = 1..n div d. (-1)^(d+1) * mangoldt e)"
     by (simp add: sum_distrib_left)
   also from ** have "\<dots> = (\<Sum>d = 1..n. \<Sum>e\<in>{y\<in>{1..n}. y \<le> n div d}. (-1)^(d+1) * mangoldt e)"
     by (intro sum.cong) auto
   also have "\<dots> = (\<Sum>y = 1..n. \<Sum>x | x \<in> {1..n} \<and> y \<le> n div x. (- 1) ^ (x + 1) * mangoldt y)"
     by (rule sum.swap_restrict) simp_all
   also have "\<dots> = (\<Sum>y = 1..n. \<Sum>x | x \<in> {1..n} \<and> x \<le> n div y. (- 1) ^ (x + 1) * mangoldt y)"
     by (intro sum.cong) (auto intro: div_invert)
   also from ** have "\<dots> = (\<Sum>y = 1..n. \<Sum>x \<in> {1..n div y}. (- 1) ^ (x + 1) * mangoldt y)"
     by (intro sum.cong) auto
   also have "\<dots> = (\<Sum>y = 1..n. (\<Sum>x \<in> {1..n div y}. (- 1) ^ (x + 1)) * mangoldt y)"
     by (intro sum.cong) (simp_all add: sum_distrib_right)
   also have "\<dots> = (\<Sum>y = 1..n. (if odd (n div y) then 1 else 0) * mangoldt y)"
     by (intro sum.cong refl) (simp_all only: sum_minus_one)
   finally show ?thesis .
 qed
 
 private lemma floor_half_interval:
   fixes n d :: nat
   assumes "d \<noteq> 0"
   shows "real (n div d) - real (2 * ((n div 2) div d)) = (if odd (n div d) then 1 else 0)"
 proof -
   have "((n div 2) div d) = (n div (2 * d))"
     by (rule div_mult2_eq[symmetric])
   also have "\<dots> = ((n div d) div 2)"
     by (simp add: mult_ac div_mult2_eq)
   also have "real (n div d) - real (2 * \<dots>) = (if odd (n div d) then 1 else 0)"
     by (cases "odd (n div d)", cases "n div d = 0 ", simp_all)
   finally show ?thesis by simp
 qed
 
 lemma fact_expand_psi:
   "ln (fact n) - 2 * ln (fact (n div 2)) = (\<Sum>d=1..n. (-1)^(d+1) * psi (n div d))"
 proof -
   have "ln (fact n) - 2 * ln (fact (n div 2)) =
     (\<Sum>d=1..n. mangoldt d * \<lfloor>n / d\<rfloor>) - 2 * (\<Sum>d=1..n div 2. mangoldt d * \<lfloor>(n div 2) / d\<rfloor>)"
     by (simp add:  ln_fact_conv_mangoldt)
   also have "(\<Sum>d=1..n div 2. mangoldt d * \<lfloor>real (n div 2) / d\<rfloor>) =
                (\<Sum>d=1..n. mangoldt d * \<lfloor>real (n div 2) / d\<rfloor>)"
     by (rule sum.mono_neutral_left) (auto simp: floor_unique[of 0])
   also have "2 * \<dots> = (\<Sum>d=1..n. mangoldt d * 2 * \<lfloor>real (n div 2) / d\<rfloor>)"
     by (simp add: sum_distrib_left mult_ac)
   also have "(\<Sum>d=1..n. mangoldt d * \<lfloor>n / d\<rfloor>) - \<dots> = 
                (\<Sum>d=1..n. (mangoldt d * \<lfloor>n / d\<rfloor> - mangoldt d * 2 * \<lfloor>real (n div 2) / d\<rfloor>))"
     by (simp add: sum_subtractf)
   also have "\<dots> = (\<Sum>d=1..n. mangoldt d * (\<lfloor>n / d\<rfloor> - 2 * \<lfloor>real (n div 2) / d\<rfloor>))"
     by (simp add: algebra_simps)
   also have "\<dots> = (\<Sum>d=1..n. mangoldt d * (if odd(n div d) then 1 else 0))"
     by (intro sum.cong refl)
        (simp_all add: floor_conv_div_nat [symmetric] floor_half_interval [symmetric])
   also have "\<dots> = (\<Sum>d=1..n. (if odd(n div d) then 1 else 0) * mangoldt d)"
     by (simp add: mult_ac)
   also from sum_expand_lemma[symmetric] have "\<dots> = (\<Sum>d=1..n. (-1)^(d+1) * psi (n div d))" .  
   finally show ?thesis .
 qed
   
 end
 
 lemma psi_expansion_cutoff:
   assumes "m \<le> p"
   shows   "(\<Sum>d=1..2*m. (-1)^(d+1) * psi (n div d)) \<le> (\<Sum>d=1..2*p. (-1)^(d+1) * psi (n div d))"
           "(\<Sum>d=1..2*p+1. (-1)^(d+1) * psi (n div d)) \<le> (\<Sum>d=1..2*m+1. (-1)^(d+1) * psi (n div d))"
 using assms
 proof (induction m rule: inc_induct)
   case (step k)
   have "(\<Sum>d = 1..2 * k. (-1)^(d + 1) * psi (n div d)) \<le> 
           (\<Sum>d = 1..2 * Suc k. (-1)^(d + 1) * psi (n div d))"
     by (simp add: psi_mono div_le_mono2)
   with step.IH(1)
     show "(\<Sum>d = 1..2 * k. (-1)^(d + 1) * psi (n div d))
       \<le> (\<Sum>d = 1..2 * p. (-1)^(d + 1) * psi (n div d))"
       by simp
   from step.IH(2)
     have "(\<Sum>d = 1..2 * p + 1. (-1)^(d + 1) * psi (n div d))
       \<le> (\<Sum>d = 1..2 * Suc k + 1. (-1)^(d + 1) * psi (n div d))" .
   also have "\<dots> \<le> (\<Sum>d = 1..2 * k + 1. (-1)^(d + 1) * psi (n div d))"
     by (simp add: psi_mono div_le_mono2)
   finally show "(\<Sum>d = 1..2 * p + 1. (-1)^(d + 1) * psi (n div d))
        \<le> (\<Sum>d = 1..2 * k + 1. (-1)^(d + 1) * psi (n div d))" .
 qed simp_all
 
 lemma fact_psi_bound_even:
   assumes "even k"
   shows   "(\<Sum>d=1..k. (-1)^(d+1) * psi (n div d)) \<le> ln (fact n) - 2 * ln (fact (n div 2))"
 proof -
   have "(\<Sum>d=1..k. (-1)^(d+1) * psi (n div d)) \<le> (\<Sum>d = 1..n. (- 1) ^ (d + 1) * psi (n div d))"
   proof (cases "k \<le> n")
     case True
     with psi_expansion_cutoff(1)[of "k div 2" "n div 2" n]
       have "(\<Sum>d=1..2*(k div 2). (-1)^(d+1) * psi (n div d))
         \<le> (\<Sum>d = 1..2*(n div 2). (- 1) ^ (d + 1) * psi (n div d))"
       by simp
     also from assms have "2*(k div 2) = k"
       by simp
     also have "(\<Sum>d = 1..2*(n div 2). (- 1) ^ (d + 1) * psi (n div d))
       \<le> (\<Sum>d = 1..n. (- 1) ^ (d + 1) * psi (n div d))"
     proof (cases "even n")
       case True
       then show ?thesis
         by simp
     next
       case False
       from psi_pos have "(\<Sum>d = 1..2*(n div 2). (- 1) ^ (d + 1) * psi (n div d))
           \<le> (\<Sum>d = 1..2*(n div 2) + 1. (- 1) ^ (d + 1) * psi (n div d))"
         by simp
       with False show ?thesis
         by simp
     qed
     finally show ?thesis .
   next
     case False
     hence *: "n div 2 \<le> (k-1) div 2"
       by simp
     have "(\<Sum>d=1..k. (-1)^(d+1) * psi (n div d)) \<le>
             (\<Sum>d=1..2*((k-1) div 2) + 1. (-1)^(d+1) * psi (n div d))"
     proof (cases "k = 0")
       case True
       with psi_pos show ?thesis by simp
     next
       case False
       with sum.cl_ivl_Suc[of "\<lambda>d. (-1)^(d+1) * psi (n div d)" 1 "k-1"]
       have "(\<Sum>d=1..k. (-1)^(d+1) * psi (n div d)) = (\<Sum>d=1..k-1. (-1)^(d+1) * psi (n div d))
           + (-1)^(k+1) * psi (n div k)"
         by simp
       also from assms psi_pos have "(-1)^(k+1) * psi (n div k) \<le> 0"
         by simp
       also from assms False have "k-1 = 2*((k-1) div 2) + 1"
         by presburger
       finally show ?thesis by simp
     qed
     also from * psi_expansion_cutoff(2)[of "n div 2" "(k-1) div 2" n]
       have "\<dots> \<le> (\<Sum>d=1..2*(n div 2) + 1. (-1)^(d+1) * psi (n div d))" by blast
     also have "\<dots> \<le> (\<Sum>d = 1..n. (- 1) ^ (d + 1) * psi (n div d))"
       by (cases "even n") (simp_all add: psi_def)
     finally show ?thesis .
   qed
   also from fact_expand_psi have "\<dots> = ln (fact n) - 2 * ln (fact (n div 2))" ..
   finally show ?thesis .
 qed
 
 lemma fact_psi_bound_odd:
   assumes "odd k"
   shows "ln (fact n) - 2 * ln (fact (n div 2)) \<le> (\<Sum>d=1..k. (-1)^(d+1) * psi (n div d))"
 proof -
   from fact_expand_psi 
     have "ln (fact n) - 2 * ln (fact (n div 2)) = (\<Sum>d = 1..n. (- 1) ^ (d + 1) * psi (n div d))" .
   also have "\<dots> \<le> (\<Sum>d=1..k. (-1)^(d+1) * psi (n div d))"
   proof (cases "k \<le> n")
     case True
     have "(\<Sum>d=1..n. (-1)^(d+1) * psi (n div d)) \<le> (
              \<Sum>d=1..2*(n div 2)+1. (-1)^(d+1) * psi (n div d))"
       by (cases "even n") (simp_all add: psi_pos)
     also from True assms psi_expansion_cutoff(2)[of "k div 2" "n div 2" n]
       have "\<dots> \<le> (\<Sum>d=1..k. (-1)^(d+1) * psi (n div d))"
         by simp
     finally show ?thesis .
   next
     case False
     have "(\<Sum>d=1..n. (-1)^(d+1) * psi (n div d)) \<le> (\<Sum>d=1..2*((n+1) div 2). (-1)^(d+1) * psi (n div d))"
       by (cases "even n") (simp_all add: psi_def)
     also from False assms psi_expansion_cutoff(1)[of "(n+1) div 2" "k div 2" n]
       have "(\<Sum>d=1..2*((n+1) div 2). (-1)^(d+1) * psi (n div d)) \<le> (\<Sum>d=1..2*(k div 2). (-1)^(d+1) * psi (n div d))"
         by simp
     also from assms have "\<dots> \<le> (\<Sum>d=1..k. (-1)^(d+1) * psi (n div d))"
       by (auto elim: oddE simp: psi_pos)
     finally show ?thesis .
   qed
   finally show ?thesis .
 qed
 
 lemma fact_psi_bound_2_3:
   "psi n - psi (n div 2) \<le> ln (fact n) - 2 * ln (fact (n div 2))"
   "ln (fact n) - 2 * ln (fact (n div 2)) \<le> psi n - psi (n div 2) + psi (n div 3)"
 proof -
   show "psi n - psi (n div 2) \<le> ln (fact n) - 2 * ln (fact (n div 2))" 
     by (rule psi_bounds_ln_fact (2))
 next
   from fact_psi_bound_odd[of 3 n] have "ln (fact n) - 2 * ln (fact (n div 2))
   \<le> (\<Sum>d = 1..3. (- 1) ^ (d + 1) * psi (n div d))"
     by simp
   also have "\<dots> = psi n - psi (n div 2) + psi (n div 3)"
     by (simp add: sum.atLeast_Suc_atMost numeral_2_eq_2)
   finally show "ln (fact n) - 2 * ln (fact (n div 2)) \<le> psi n - psi (n div 2) + psi (n div 3)" .
 qed
 
 lemma ub_ln_1200: "ln 1200 \<le> 57 / (8 :: real)"
 proof -
   have "Some (Float 57 (-3)) = ub_ln 8 1200" by code_simp
   from ub_ln(1)[OF this] show ?thesis by simp
 qed
   
 lemma psi_double_lemma:
   assumes "n \<ge> 1200"
   shows "real n / 6 \<le> psi n - psi (n div 2)"
 proof -
   from ln_fact_diff_bounds
     have "\<bar>ln (fact n) - 2 * ln (fact (n div 2)) - real n * ln 2\<bar>
         \<le> 4 * ln (real (if n = 0 then 1 else n)) + 3" .
   with assms have "ln (fact n) - 2 * ln (fact (n div 2))
         \<ge> real n * ln 2 - 4 * ln (real n) - 3"
     by simp
   moreover have "real n * ln 2 - 4 * ln (real n) - 3 \<ge> 2 / 3 * n"
   proof (rule overpower_lemma[of "\<lambda>n. 2/3 * n" 1200])
     show "2 / 3 * 1200 \<le> 1200 * ln 2 - 4 * ln 1200 - (3::real)"
         using ub_ln_1200 ln_2_ge by linarith
   next
     fix x::real
     assume "1200 \<le> x"
     then have "0 < x"
       by simp
     show "((\<lambda>x. x * ln 2 - 4 * ln x - 3 - 2 / 3 * x)
         has_real_derivative ln 2 - 4 / x - 2 / 3) (at x)"
       by (rule derivative_eq_intros refl | simp add: \<open>0 < x\<close>)+
   next
     fix x::real
     assume "1200 \<le> x"
     then have "12 / x \<le> 12 / 1200" by simp
     then have "0 \<le> 0.67 - 4 / x - 2 / 3" by simp
     also have "0.67 \<le> ln (2::real)" using ln_2_ge by simp
     finally show "0 \<le> ln 2 - 4 / x - 2 / 3" by simp
   next
     from assms show "1200 \<le> real n"
       by simp
   qed
   ultimately have "2 / 3 * real n \<le> ln (fact n) - 2 * ln (fact (n div 2))"
     by simp
   with psi_ubound_3_2[of "n div 3"]
     have "n/6 + psi (n div 3) \<le> ln (fact n) - 2 * ln (fact (n div 2))"
     by simp
   with fact_psi_bound_2_3[of "n"] show ?thesis
     by simp
 qed
 
 lemma theta_double_lemma:
   assumes "n \<ge> 1200"
   shows "theta (n div 2) < theta n"
 proof -
   from psi_theta[of "n div 2"] psi_pos[of "Discrete.sqrt (n div 2)"]
     have theta_le_psi_n_2: "theta (n div 2) \<le> psi (n div 2)"
     by simp
   have "(Discrete.sqrt n * 18)^2 \<le> 324 * n"
     by simp
   from mult_less_cancel2[of "324" "n" "n"] assms have "324 * n < n^2"
     by (simp add: power2_eq_square)
   with \<open>(Discrete.sqrt n * 18)^2 \<le> 324 * n\<close> have "(Discrete.sqrt n*18)^2 < n^2"
     by presburger
   with power2_less_imp_less assms have "Discrete.sqrt n * 18 < n"
     by blast
   with psi_ubound_3_2[of "Discrete.sqrt n"] have "2 * psi (Discrete.sqrt n) < n / 6"
     by simp
   with psi_theta[of "n"] have psi_lt_theta_n: "psi n - n / 6 < theta n"
     by simp
   from psi_double_lemma[OF assms(1)] have "psi (n div 2) \<le> psi n - n / 6"
     by simp
   with theta_le_psi_n_2 psi_lt_theta_n show ?thesis
     by simp
 qed
   
 
 subsection \<open>Proof of the main result\<close>
 
 lemma theta_mono: "mono theta"
   by (auto simp: theta_def [abs_def] intro!: monoI sum_mono2)
   
 lemma theta_lessE:
   assumes "theta m < theta n" "m \<ge> 1"
   obtains p where "p \<in> {m<..n}" "prime p"
 proof -
   from mono_invE[OF theta_mono assms(1)] have "m \<le> n" by blast
   hence "theta n = theta m + (\<Sum>p\<in>{m<..n}. if prime p then ln (real p) else 0)"
     unfolding theta_def using assms(2)
     by (subst sum.union_disjoint [symmetric]) (auto simp: ivl_disj_un)
   also note assms(1)
   finally have "(\<Sum>p\<in>{m<..n}. if prime p then ln (real p) else 0) \<noteq> 0" by simp
-  from sum.not_neutral_contains_not_neutral [OF this] guess p .
+  then obtain p where "p \<in> {m<..n}" "(if prime p then ln (real p) else 0) \<noteq> 0"
+    by (rule sum.not_neutral_contains_not_neutral)
   thus ?thesis using that[of p] by (auto intro!: exI[of _ p] split: if_splits)
 qed
 
 theorem bertrand:
   fixes   n :: nat
   assumes "n > 1"
   shows   "\<exists>p\<in>{n<..<2*n}. prime p"
 proof cases
   assume n_less: "n < 600"
   define prime_constants
     where "prime_constants = {2, 3, 5, 7, 13, 23, 43, 83, 163, 317, 631::nat}"
   from \<open>n > 1\<close> n_less have "\<exists>p \<in> prime_constants. n < p \<and> p < 2 * n"
     unfolding bex_simps greaterThanLessThan_iff prime_constants_def by presburger
   moreover have "\<forall>p\<in>prime_constants. prime p" 
     unfolding prime_constants_def ball_simps HOL.simp_thms
     by (intro conjI; pratt (silent))
   ultimately show ?thesis
     unfolding greaterThanLessThan_def greaterThan_def lessThan_def by blast
 next
   assume n: "\<not>(n < 600)"
   from n have "theta n < theta (2 * n)" using theta_double_lemma[of "2 * n"] by simp
   with assms obtain p where "p \<in> {n<..2*n}" "prime p" by (auto elim!: theta_lessE)
   moreover from assms have "\<not>prime (2*n)" by (auto dest!: prime_product)
   with \<open>prime p\<close> have "p \<noteq> 2 * n" by auto
   ultimately show ?thesis
     by auto
 qed
   
   
 subsection \<open>Proof of Mertens' first theorem\<close>
 
 text \<open>
   The following proof of Mertens' first theorem was ported from John Harrison's HOL Light
   proof by Larry Paulson:
 \<close>
 
 lemma sum_integral_ubound_decreasing':
   fixes f :: "real \<Rightarrow> real"
   assumes "m \<le> n"
       and der: "\<And>x. x \<in> {of_nat m - 1..of_nat n} \<Longrightarrow> (g has_field_derivative f x) (at x)"
       and le:  "\<And>x y. \<lbrakk>real m - 1 \<le> x; x \<le> y; y \<le> real n\<rbrakk> \<Longrightarrow> f y \<le> f x"
     shows "(\<Sum>k = m..n. f (of_nat k)) \<le> g (of_nat n) - g (of_nat m - 1)"
 proof -
   have "(\<Sum>k = m..n. f (of_nat k)) \<le> (\<Sum>k = m..n. g (of_nat(Suc k) - 1) - g (of_nat k - 1))"
   proof (rule sum_mono, clarsimp)
     fix r
     assume r: "m \<le> r" "r \<le> n"
     hence "\<exists>z>real r - 1. z < real r \<and> g (real r) - g (real r - 1) = (real r - (real r - 1)) * f z"
       using assms by (intro MVT2) auto
     hence "\<exists>z\<in>{of_nat r - 1..of_nat r}. g (real r) - g (real r - 1) = f z" by auto
     then obtain u::real where u: "u \<in> {of_nat r - 1..of_nat r}"
                         and eq: "g r - g (of_nat r - 1) = f u" by blast
     have "real m \<le> u + 1"
       using r u by auto
     then have "f (of_nat r) \<le> f u"
       using r(2) and u by (intro le) auto
     then show "f (of_nat r) \<le> g r - g (of_nat r - 1)"
       by (simp add: eq)
   qed
   also have "\<dots> \<le> g (of_nat n) - g (of_nat m - 1)"
     using \<open>m \<le> n\<close> by (subst sum_Suc_diff) auto
   finally show ?thesis .
 qed
 
 lemma Mertens_lemma:
   assumes "n \<noteq> 0"
     shows "\<bar>(\<Sum>d = 1..n. mangoldt d / real d) - ln n\<bar> \<le> 4"
 proof -
   have *: "\<lbrakk>abs(s' - nl + n) \<le> a; abs(s' - s) \<le> (k - 1) * n - a\<rbrakk>
         \<Longrightarrow> abs(s - nl) \<le> n * k" for s' s k nl a::real
     by (auto simp: algebra_simps abs_if split: if_split_asm)
   have le: "\<bar>(\<Sum>d=1..n. mangoldt d * floor (n / d)) - n * ln n + n\<bar> \<le> 1 + ln n"
     using ln_fact_bounds ln_fact_conv_mangoldt assms by simp
   have "\<bar>real n * ((\<Sum>d = 1..n. mangoldt d / real d) - ln n)\<bar> =
         \<bar>((\<Sum>d = 1..n. real n * mangoldt d / real d) - n * ln n)\<bar>"
     by (simp add: algebra_simps sum_distrib_left)
   also have "\<dots> \<le> real n * 4"
   proof (rule * [OF le])
     have "\<bar>(\<Sum>d = 1..n. mangoldt d * \<lfloor>n / d\<rfloor>) - (\<Sum>d = 1..n. n * mangoldt d / d)\<bar>
         = \<bar>\<Sum>d = 1..n. mangoldt d * (\<lfloor>n / d\<rfloor> - n / d)\<bar>"
       by (simp add: sum_subtractf algebra_simps)
     also have "\<dots> \<le> psi n" (is "\<bar>?sm\<bar> \<le> ?rhs")
     proof -
       have "-?sm = (\<Sum>d = 1..n. mangoldt d * (n/d - \<lfloor>n/d\<rfloor>))"
         by (simp add: sum_subtractf algebra_simps)
       also have "\<dots> \<le> (\<Sum>d = 1..n. mangoldt d * 1)"
         by (intro sum_mono mult_left_mono mangoldt_nonneg) linarith+
       finally have "-?sm \<le> ?rhs" by (simp add: psi_def)
       moreover
       have "?sm \<le> 0"
         using mangoldt_nonneg by (simp add: mult_le_0_iff sum_nonpos)
       ultimately show ?thesis by (simp add: abs_if)
     qed
     also have "\<dots> \<le> 3/2 * real n"
       by (rule psi_ubound_3_2)
     also have "\<dots>\<le> (4 - 1) * real n - (1 + ln n)"
       using ln_le_minus_one [of n] assms by (simp add: divide_simps)
     finally
     show "\<bar>(\<Sum>d = 1..n. mangoldt d * real_of_int \<lfloor>real n / real d\<rfloor>) -
            (\<Sum>d = 1..n. real n * mangoldt d / real d)\<bar>
           \<le> (4 - 1) * real n - (1 + ln n)" .
   qed
   finally have "\<bar>real n * ((\<Sum>d = 1..n. mangoldt d / real d) - ln n)\<bar> \<le> real n * 4" .
   then show ?thesis
     using assms mult_le_cancel_left_pos by (simp add: abs_mult)
 qed
 
 lemma Mertens_mangoldt_versus_ln:
   assumes "I \<subseteq> {1..n}"
   shows "\<bar>(\<Sum>i\<in>I. mangoldt i / i) - (\<Sum>p | prime p \<and> p \<in> I. ln p / p)\<bar> \<le> 3"
         (is "\<bar>?lhs\<bar> \<le> 3")
 proof (cases "n = 0")
   case True
   with assms show ?thesis by simp
 next
   case False
     have "finite I"
       using assms finite_subset by blast
     have "0 \<le> (\<Sum>i\<in>I. mangoldt i / i - (if prime i then ln i / i else 0))"
       using mangoldt_nonneg by (intro sum_nonneg) simp_all
     moreover have "\<dots> \<le> (\<Sum>i = 1..n. mangoldt i / i - (if prime i then ln i / i else 0))"
       using assms by (intro sum_mono2) (auto simp: mangoldt_nonneg)
     ultimately have *: "\<bar>\<Sum>i\<in>I. mangoldt i / i - (if prime i then ln i / i else 0)\<bar>
                       \<le> \<bar>\<Sum>i = 1..n. mangoldt i / i - (if prime i then ln i / i else 0)\<bar>"
       by linarith
     moreover have "?lhs = (\<Sum>i\<in>I. mangoldt i / i - (if prime i then ln i / i else 0))"
                   "(\<Sum>i = 1..n. mangoldt i / i - (if prime i then ln i / i else 0))
                         = (\<Sum>d = 1..n. mangoldt d / d) - (\<Sum>p | prime p \<and> p \<in> {1..n}. ln p / p)"
       using sum.inter_restrict [of _ "\<lambda>i. ln (real i) / i" "Collect prime", symmetric]  
        by (force simp: sum_subtractf \<open>finite I\<close> intro: sum.cong)+
     ultimately have "\<bar>?lhs\<bar> \<le> \<bar>(\<Sum>d = 1..n. mangoldt d / d) - 
                           (\<Sum>p | prime p \<and> p \<in> {1..n}. ln p / p)\<bar>" by linarith
     also have "\<dots> \<le> 3"
     proof -
       have eq_sm: "(\<Sum>i = 1..n. mangoldt i / i) = 
                      (\<Sum>i \<in> {p^k |p k. prime p \<and> p^k \<le> n \<and> k \<ge> 1}. mangoldt i / i)"
       proof (intro sum.mono_neutral_right ballI, goal_cases)
         case (3 i)
         hence "\<not>primepow i" by (auto simp: primepow_def Suc_le_eq)
         thus ?case by (simp add: mangoldt_def)
       qed (auto simp: Suc_le_eq prime_gt_0_nat)
       have "(\<Sum>i = 1..n. mangoldt i / i) - (\<Sum>p | prime p \<and> p \<in> {1..n}. ln p / p) =
             (\<Sum>i \<in> {p^k |p k. prime p \<and> p^k \<le> n \<and> k \<ge> 2}. mangoldt i / i)"
       proof -
         have eq: "{p ^ k |p k. prime p \<and> p ^ k \<le> n \<and> 1 \<le> k} =
                   {p ^ k |p k. prime p \<and> p ^ k \<le> n \<and> 2 \<le> k} \<union> {p. prime p \<and> p \<in> {1..n}}"
           (is "?A = ?B \<union> ?C")
         proof (intro equalityI subsetI; (elim UnE)?)
           fix x assume "x \<in> ?A"
           then obtain p k where "x = p ^ k" "prime p" "p ^ k \<le> n" "k \<ge> 1" by auto
           thus "x \<in> ?B \<union> ?C"
             by (cases "k \<ge> 2") (auto simp: prime_power_iff Suc_le_eq)
         next
           fix x assume "x \<in> ?B"
           then obtain p k where "x = p ^ k" "prime p" "p ^ k \<le> n" "k \<ge> 1" by auto
           thus "x \<in> ?A" by (auto simp: prime_power_iff Suc_le_eq)
         next
           fix x assume "x \<in> ?C"
           then obtain p where "x = p ^ 1" "1 \<ge> (1::nat)" "prime p" "p ^ 1 \<le> n" by auto
           thus "x \<in> ?A" by blast
         qed
         have eqln: "(\<Sum>p | prime p \<and> p \<in> {1..n}. ln p / p) = 
                       (\<Sum>p | prime p \<and> p \<in> {1..n}. mangoldt p / p)"
           by (rule sum.cong) auto
         have "(\<Sum>i \<in> {p^k |p k. prime p \<and> p^k \<le> n \<and> k \<ge> 1}. mangoldt i / i) = 
                 (\<Sum>i \<in> {p ^ k |p k. prime p \<and> p ^ k \<le> n \<and> 2 \<le> k} \<union> 
                 {p. prime p \<and> p \<in> {1..n}}. mangoldt i / i)" by (subst eq) simp_all
         also have "\<dots> = (\<Sum>i \<in> {p^k |p k. prime p \<and> p^k \<le> n \<and> k \<ge> 2}. mangoldt i / i)
                        + (\<Sum>p | prime p \<and> p \<in> {1..n}. mangoldt p / p)"
           by (intro sum.union_disjoint) (auto simp: prime_power_iff finite_nat_set_iff_bounded_le)
         also have "\<dots> = (\<Sum>i \<in> {p^k |p k. prime p \<and> p^k \<le> n \<and> k \<ge> 2}. mangoldt i / i)
                        + (\<Sum>p | prime p \<and> p \<in> {1..n}. ln p / p)" by (simp only: eqln)
         finally show ?thesis
           using eq_sm by auto
       qed
       have "(\<Sum>p | prime p \<and> p \<in> {1..n}. ln p / p) \<le> (\<Sum>p | prime p \<and> p \<in> {1..n}. mangoldt p / p)"
         using mangoldt_nonneg by (auto intro: sum_mono)
       also have "\<dots> \<le> (\<Sum>i = Suc 0..n. mangoldt i / i)"
         by (intro sum_mono2) (auto simp: mangoldt_nonneg)
       finally have "0 \<le> (\<Sum>i = 1..n. mangoldt i / i) - (\<Sum>p | prime p \<and> p \<in> {1..n}. ln p / p)"
         by simp
       moreover have "(\<Sum>i = 1..n. mangoldt i / i) - (\<Sum>p | prime p \<and> p \<in> {1..n}. ln p / p) \<le> 3"
                      (is "?M - ?L \<le> 3")
       proof -
         have *: "\<exists>q. \<exists>j\<in>{1..n}. prime q \<and> 1 \<le> q \<and> q \<le> n \<and>
                   (q ^ j = p ^ k \<and> mangoldt (p ^ k) / real p ^ k \<le> ln (real q) / real q ^ j)"
           if "prime p" "p ^ k \<le> n" "1 \<le> k" for p k
         proof -
           have "mangoldt (p ^ k) / real p ^ k \<le> ln p / p ^ k"
             using that by (simp add: divide_simps)
           moreover have "p \<le> n"
             using that self_le_power[of p k] by (simp add: prime_ge_Suc_0_nat)
           moreover have "k \<le> n"
           proof -
             have "k < 2^k"
               using of_nat_less_two_power of_nat_less_numeral_power_cancel_iff by blast
             also have "\<dots> \<le> p^k"
               by (simp add: power_mono prime_ge_2_nat that)
             also have "\<dots> \<le> n"
               by (simp add: that)
             finally show ?thesis by (simp add: that)
           qed
           ultimately show ?thesis
             using prime_ge_1_nat that by auto (use atLeastAtMost_iff in blast)
         qed
         have finite: "finite {p ^ k |p k. prime p \<and> p ^ k \<le> n \<and> 1 \<le> k}"
           by (rule finite_subset[of _ "{..n}"]) auto
         have "?M \<le> (\<Sum>(x, k)\<in>{p. prime p \<and> p \<in> {1..n}} \<times> {1..n}. ln (real x) / real x ^ k)"
           by (subst eq_sm, intro sum_le_included [where i = "\<lambda>(p,k). p^k"])
              (insert * finite, auto)
         also have "\<dots> = (\<Sum>p | prime p \<and> p \<in> {1..n}. (\<Sum>k = 1..n. ln p / p^k))"
           by (subst sum.Sigma) auto
         also have "\<dots> = ?L + (\<Sum>p | prime p \<and> p \<in> {1..n}. (\<Sum>k = 2..n. ln p / p^k))"
           by (simp add: comm_monoid_add_class.sum.distrib sum.atLeast_Suc_atMost numeral_2_eq_2)
         finally have "?M - ?L \<le> (\<Sum>p | prime p \<and> p \<in> {1..n}. (\<Sum>k = 2..n. ln p / p^k))"
           by (simp add: algebra_simps)
         also have "\<dots> = (\<Sum>p | prime p \<and> p \<in> {1..n}. ln p * (\<Sum>k = 2..n. inverse p ^ k))"
           by (simp add: field_simps sum_distrib_left)
         also have "\<dots> = (\<Sum>p | prime p \<and> p \<in> {1..n}. 
                           ln p * (((inverse p)\<^sup>2 - inverse p ^ Suc n) / (1 - inverse p)))"
           by (intro sum.cong refl) (simp add: sum_gp)
         also have "\<dots> \<le> (\<Sum>p | prime p \<and> p \<in> {1..n}. ln p * inverse (real (p * (p - 1))))"
           by (intro sum_mono mult_left_mono)
              (auto simp: divide_simps power2_eq_square of_nat_diff mult_less_0_iff)
         also have "\<dots> \<le> (\<Sum>p = 2..n. ln p * inverse (real (p * (p - 1))))"
           by (rule sum_mono2) (use prime_ge_2_nat in auto)
         also have "\<dots> \<le> (\<Sum>i = 2..n. ln i / (i - 1)\<^sup>2)"
           unfolding divide_inverse power2_eq_square mult.assoc
           by (auto intro: sum_mono mult_left_mono mult_right_mono)
         also have "\<dots> \<le> 3"
         proof (cases "n \<ge> 3")
           case False then show ?thesis
           proof (cases "n \<ge> 2")
             case False then show ?thesis by simp
           next
             case True
             then have "n = 2" using False by linarith
             with ln_le_minus_one [of 2] show ?thesis by simp
           qed
         next
           case True
           have "(\<Sum>i = 3..n. ln (real i) / (real (i - Suc 0))\<^sup>2)
                 \<le> (ln (of_nat n - 1)) - (ln (of_nat n)) - (ln (of_nat n) / (of_nat n - 1)) + 2 * ln 2"
           proof -
             have 1: "((\<lambda>z. ln (z - 1) - ln z - ln z / (z - 1)) has_field_derivative ln x / (x - 1)\<^sup>2) (at x)"
               if x: "x \<in> {2..real n}" for x
               by (rule derivative_eq_intros | rule refl | 
                    (use x in \<open>force simp: power2_eq_square divide_simps\<close>))+
             have 2: "ln y / (y - 1)\<^sup>2 \<le> ln x / (x - 1)\<^sup>2" if xy: "2 \<le> x" "x \<le> y" "y \<le> real n" for x y
             proof (cases "x = y")
               case False
               define f' :: "real \<Rightarrow> real"
                 where "f' = (\<lambda>u. ((u - 1)\<^sup>2 / u - ln u * (2 * u - 2)) / (u - 1) ^ 4)"
               have f'_altdef: "f' u = inverse u * inverse ((u - 1)\<^sup>2) - 2 * ln u / (u - 1) ^ 3" 
                 if u: "u \<in> {x..y}" for u::real unfolding f'_def using u (* TODO ugly *)
                 by (simp add: eval_nat_numeral divide_simps) (simp add: algebra_simps)?
               have deriv: "((\<lambda>z. ln z / (z - 1)\<^sup>2) has_field_derivative f' u) (at u)"
                 if u: "u \<in> {x..y}" for u::real unfolding f'_def
                 by (rule derivative_eq_intros refl | (use u xy in \<open>force simp: divide_simps\<close>))+
               hence "\<exists>z>x. z < y \<and> ln y / (y - 1)\<^sup>2 - ln x / (x - 1)\<^sup>2 = (y - x) * f' z"
                 using xy and \<open>x \<noteq> y\<close> by (intro MVT2) auto
               then obtain \<xi>::real where "x < \<xi>" "\<xi> < y"
                 and \<xi>: "ln y / (y - 1)\<^sup>2 - ln x / (x - 1)\<^sup>2 = (y - x) * f' \<xi>" by blast
               have "f' \<xi> \<le> 0"
               proof -
                 have "2/3 \<le> ln (2::real)" by (fact ln_2_ge')
                 also have "\<dots> \<le> ln \<xi>"
                   using \<open>x < \<xi>\<close> xy by auto
                 finally have "1 \<le> 2 * ln \<xi>" by simp
                 then have *: "\<xi> \<le> \<xi> * (2 * ln \<xi>)"
                   using \<open>x < \<xi>\<close> xy by auto
                 hence "\<xi> - 1 \<le> ln \<xi> * 2 * \<xi>" by (simp add: algebra_simps)
                 hence "1 / (\<xi> * (\<xi> - 1)\<^sup>2) \<le> ln \<xi> * 2 / (\<xi> - 1) ^ 3"
                   using xy \<open>x < \<xi>\<close> by (simp add: divide_simps power_eq_if)
                 thus ?thesis using xy \<open>x < \<xi>\<close> \<open>\<xi> < y\<close> by (subst f'_altdef) (auto simp: divide_simps)
               qed
               then have "(ln y / (y - 1)\<^sup>2 - ln x / (x - 1)\<^sup>2) \<le> 0"
                 using \<open>x \<le> y\<close> by (simp add: mult_le_0_iff \<xi>)
               then show ?thesis by simp
             qed simp_all
             show ?thesis
               using sum_integral_ubound_decreasing'
                 [OF \<open>3 \<le> n\<close>, of "\<lambda>z. ln(z-1) - ln z - ln z / (z - 1)" "\<lambda>z. ln z / (z-1)\<^sup>2"]
                 1 2 \<open>3 \<le> n\<close>
               by (auto simp: in_Reals_norm of_nat_diff)
           qed
           also have "\<dots> \<le> 2"
           proof -
             have "ln (real n - 1) - ln n \<le> 0"  "0 \<le> ln n / (real n - 1)"
               using \<open>3 \<le> n\<close> by auto
             then have "ln (real n - 1) - ln n - ln n / (real n - 1) \<le> 0"
               by linarith
             with ln_2_less_1 show ?thesis by linarith
           qed
           also have "\<dots> \<le> 3 - ln 2"
             using ln_2_less_1 by (simp add: algebra_simps)
         finally show ?thesis
           using True by (simp add: algebra_simps sum.atLeast_Suc_atMost [of 2 n])
       qed
         finally show ?thesis .
       qed
       ultimately show ?thesis
         by linarith
     qed
   finally show ?thesis .
 qed
 
 proposition Mertens:
   assumes "n \<noteq> 0"
   shows "\<bar>(\<Sum>p | prime p \<and> p \<le> n. ln p / of_nat p) - ln n\<bar> \<le> 7"
 proof -
   have "\<bar>(\<Sum>d = 1..n. mangoldt d / real d) - (\<Sum>p | prime p \<and> p \<in> {1..n}. ln (real p) / real p)\<bar>
              \<le> 7 - 4" using Mertens_mangoldt_versus_ln [of "{1..n}" n] by simp_all
   also have "{p. prime p \<and> p \<in> {1..n}} = {p. prime p \<and> p \<le> n}"
     using atLeastAtMost_iff prime_ge_1_nat by blast
   finally have "\<bar>(\<Sum>d = 1..n. mangoldt d / real d) - (\<Sum>p\<in>\<dots>. ln (real p) / real p)\<bar> \<le> 7 - 4" .
   moreover from assms have "\<bar>(\<Sum>d = 1..n. mangoldt d / real d) - ln n\<bar> \<le> 4"
     by (rule Mertens_lemma)
   ultimately show ?thesis by linarith
 qed
 
 end
diff --git a/thys/DFS_Framework/Examples/Tarjan.thy b/thys/DFS_Framework/Examples/Tarjan.thy
--- a/thys/DFS_Framework/Examples/Tarjan.thy
+++ b/thys/DFS_Framework/Examples/Tarjan.thy
@@ -1,1365 +1,1365 @@
 section \<open>Tarjan's Algorithm\<close>
 theory Tarjan
 imports 
   Tarjan_LowLink
 begin
 text \<open>We use the DFS Framework to implement Tarjan's algorithm.
   Note that, currently, we only provide an abstract version, and no refinement to 
   efficient code.
 \<close>
 
 subsection \<open>Preliminaries\<close>
 (* Though this is a general lemma about dropWhile/takeWhile, it is probably only of use for this algorithm. *)
 lemma tjs_union:
   fixes tjs u
   defines "dw \<equiv> dropWhile ((\<noteq>) u) tjs"
   defines "tw \<equiv> takeWhile ((\<noteq>) u) tjs"
   assumes "u \<in> set tjs"
   shows "set tjs = set (tl dw) \<union> insert u (set tw)"
 proof -
   from takeWhile_dropWhile_id have "set tjs = set (tw@dw)" by (auto simp: dw_def tw_def)
   hence "set tjs = set tw \<union> set dw" by (metis set_append)
   moreover from \<open>u \<in> set tjs\<close> dropWhile_eq_Nil_conv have "dw \<noteq> []" by (auto simp: dw_def)
   from hd_dropWhile[OF this[unfolded dw_def]] have "hd dw = u" by (simp add: dw_def)
   with \<open>dw \<noteq> []\<close> have "set dw = insert u (set (tl dw))" by (cases "dw") auto
   ultimately show ?thesis by blast
 qed
 
 subsection \<open>Instantiation of the DFS-Framework\<close>
 record 'v tarjan_state = "'v state" +
   sccs :: "'v set set"
   lowlink :: "'v \<rightharpoonup> nat"
   tj_stack :: "'v list"
 
 type_synonym 'v tarjan_param = "('v, ('v,unit) tarjan_state_ext) parameterization"
 
 abbreviation "the_lowlink s v \<equiv> the (lowlink s v)"
 
 context timing_syntax
 begin
   notation the_lowlink ("\<zeta>")
 end
 
 locale Tarjan_def = graph_defs G
   for G :: "('v, 'more) graph_rec_scheme"
 begin
   context begin interpretation timing_syntax .
 
   definition tarjan_disc :: "'v \<Rightarrow> 'v tarjan_state \<Rightarrow> ('v,unit) tarjan_state_ext nres" where
     "tarjan_disc v s = RETURN \<lparr> sccs = sccs s, 
                                  lowlink = (lowlink s)(v \<mapsto> \<delta> s v),
                                  tj_stack = v#tj_stack s\<rparr>"
 
   definition tj_stack_pop :: "'v list \<Rightarrow> 'v \<Rightarrow> ('v list \<times> 'v set) nres" where
     "tj_stack_pop tjs u = RETURN (tl (dropWhile ((\<noteq>) u) tjs), insert u (set (takeWhile ((\<noteq>) u) tjs)))"
 
   lemma tj_stack_pop_set:
     "tj_stack_pop tjs u \<le> SPEC (\<lambda>(tjs',scc). u \<in> set tjs \<longrightarrow> set tjs = set tjs' \<union> scc \<and> u \<in> scc)"
   proof -
     from tjs_union[of u tjs] show ?thesis
       unfolding tj_stack_pop_def
       by (refine_vcg) auto
   qed
 
   lemmas tj_stack_pop_set_leof_rule = weaken_SPEC[OF tj_stack_pop_set, THEN leof_lift]
 
   definition tarjan_fin :: "'v \<Rightarrow> 'v tarjan_state \<Rightarrow> ('v,unit) tarjan_state_ext nres" where
     "tarjan_fin v s = do {
            let ll = (if stack s = [] then lowlink s 
                      else let u = hd (stack s) in
                           (lowlink s)(u \<mapsto> min (\<zeta> s u) (\<zeta> s v)));
            let s' = s\<lparr> lowlink := ll \<rparr>;
 
            ASSERT (v \<in> set (tj_stack s));
            ASSERT (distinct (tj_stack s));
            if \<zeta> s v = \<delta> s v then do {
                 ASSERT (scc_root' E s v (scc_of E v));
                 (tjs,scc) \<leftarrow> tj_stack_pop (tj_stack s) v;
                 RETURN (state.more (s'\<lparr> tj_stack := tjs, sccs := insert scc (sccs s)\<rparr>))
            } else do {
                 ASSERT (\<not> scc_root' E s v (scc_of E v));
                 RETURN (state.more s')
            }}"
 
   definition tarjan_back :: "'v \<Rightarrow> 'v \<Rightarrow> 'v tarjan_state \<Rightarrow> ('v,unit) tarjan_state_ext nres" where
     "tarjan_back u v s = (
        if \<delta> s v < \<delta> s u \<and> v \<in> set (tj_stack s) then
          let ul' = min (\<zeta> s u) (\<delta> s v)
          in RETURN (state.more (s\<lparr> lowlink := (lowlink s)(u\<mapsto>ul') \<rparr>))
        else NOOP s)"
 end (* end timing syntax *)
 
   definition tarjan_params :: "'v tarjan_param" where
     "tarjan_params = \<lparr>
       on_init = RETURN \<lparr> sccs = {}, lowlink = Map.empty, tj_stack = [] \<rparr>,
       on_new_root = tarjan_disc,
       on_discover = \<lambda>u. tarjan_disc,
       on_finish = tarjan_fin,
       on_back_edge = tarjan_back,
       on_cross_edge = tarjan_back,
       is_break = \<lambda>s. False \<rparr>"
 
   schematic_goal tarjan_params_simps[simp]:
     "on_init tarjan_params = ?OI"
     "on_new_root tarjan_params = ?ONR"
     "on_discover tarjan_params = ?OD"
     "on_finish tarjan_params = ?OF"
     "on_back_edge tarjan_params = ?OBE"
     "on_cross_edge tarjan_params = ?OCE"
     "is_break tarjan_params = ?IB"
     unfolding tarjan_params_def gen_parameterization.simps
     by (rule refl)+
 
   sublocale param_DFS_defs G tarjan_params .
 end
 
 locale Tarjan = Tarjan_def G +
                 param_DFS G tarjan_params
   for G :: "('v, 'more) graph_rec_scheme"
 begin
 
   lemma [simp]: 
     "sccs (empty_state \<lparr>sccs = s, lowlink = l, tj_stack = t\<rparr>) = s"
     "lowlink (empty_state \<lparr>sccs = s, lowlink = l, tj_stack = t\<rparr>) = l"
     "tj_stack (empty_state \<lparr>sccs = s, lowlink = l, tj_stack = t\<rparr>) = t"
     by (simp_all add: empty_state_def)
 
   lemma sccs_more_cong[cong]:"state.more s = state.more s' \<Longrightarrow> sccs s = sccs s'"
     by (cases s, cases s') simp
   lemma lowlink_more_cong[cong]:"state.more s = state.more s' \<Longrightarrow> lowlink s = lowlink s'"
     by (cases s, cases s') simp
   lemma tj_stack_more_cong[cong]:"state.more s = state.more s' \<Longrightarrow> tj_stack s = tj_stack s'"
     by (cases s, cases s') simp
 
    lemma [simp]: 
      "s\<lparr> state.more := \<lparr>sccs = sc, lowlink = l, tj_stack = t\<rparr>\<rparr>
       = s\<lparr> sccs := sc, lowlink := l, tj_stack := t\<rparr>"                  
     by (cases s) simp
 end
 
 locale Tarjan_invar = Tarjan +
   DFS_invar where param = tarjan_params
 
 context Tarjan_def begin
   lemma Tarjan_invar_eq[simp]:
     "DFS_invar G tarjan_params s \<longleftrightarrow> Tarjan_invar G s" (is "?D \<longleftrightarrow> ?T")
   proof
     assume ?D then interpret DFS_invar where param=tarjan_params .
     show ?T ..
   next
     assume ?T then interpret Tarjan_invar .
     show ?D ..
   qed
 end
 
 subsection \<open>Correctness Proof\<close>
 context Tarjan begin
   lemma i_tj_stack_discovered:
     "is_invar (\<lambda>s. set (tj_stack s) \<subseteq> dom (discovered s))"
   proof (induct rule: establish_invarI)
     case (finish s)
     from finish show ?case
       apply simp
       unfolding tarjan_fin_def
       apply (refine_vcg tj_stack_pop_set_leof_rule)
       apply auto
       done
   qed (auto simp add: tarjan_disc_def tarjan_back_def)
 
   lemmas (in Tarjan_invar) tj_stack_discovered =
     i_tj_stack_discovered[THEN make_invar_thm]
 
   lemma i_tj_stack_distinct:
     "is_invar (\<lambda>s. distinct (tj_stack s))"
   proof (induct rule: establish_invarI_ND)
     case (new_discover s s' v) then interpret Tarjan_invar where s=s by simp
     from new_discover tj_stack_discovered have "v \<notin> set (tj_stack s)" by auto
     with new_discover show ?case by (simp add: tarjan_disc_def)
   next
     case (finish s) thus ?case
       apply simp
       unfolding tarjan_fin_def tj_stack_pop_def
       apply (refine_vcg)
       apply (auto intro: distinct_tl)
       done
   qed (simp_all add: tarjan_back_def)
 
   lemmas (in Tarjan_invar) tj_stack_distinct =
     i_tj_stack_distinct[THEN make_invar_thm]
 
   context begin interpretation timing_syntax .
   lemma i_tj_stack_incr_disc:
     "is_invar (\<lambda>s. \<forall>k<length (tj_stack s). \<forall>j<k. \<delta> s (tj_stack s ! j) > \<delta> s (tj_stack s ! k))"
   proof (induct rule: establish_invarI_ND)
     case (new_discover s s' v) then interpret Tarjan_invar where s=s by simp
 
     from new_discover tj_stack_discovered have "v \<notin> set (tj_stack s)" by auto
     moreover {
       fix k j
       assume "k < Suc (length (tj_stack s))" "j < k"
       hence "k - Suc 0 < length (tj_stack s)" by simp
       hence "tj_stack s ! (k - Suc 0) \<in> set (tj_stack s)" using nth_mem by metis
       with tj_stack_discovered timing_less_counter have "\<delta> s (tj_stack s ! (k - Suc 0)) < counter s" by blast
     }
     moreover {
       fix k j
       define k' where "k' = k - Suc 0"
       define j' where "j' = j - Suc 0"
 
       assume A: "k < Suc (length (tj_stack s))" "j < k" "(v#tj_stack s) ! j \<noteq> v"
       hence gt_0: "j > 0 \<and> k>0" by (cases "j=0") simp_all
       moreover with \<open>j < k\<close> have "j' < k'" by (simp add: j'_def k'_def)
       moreover from A have "k' < length (tj_stack s)" by (simp add: k'_def)
       ultimately have "\<delta> s (tj_stack s ! j') > \<delta> s (tj_stack s ! k')"
         using new_discover by blast
       with gt_0 have "\<delta> s ((v#tj_stack s) ! j) > \<delta> s (tj_stack s ! k')"
         unfolding j'_def
         by (simp add: nth_Cons')
     }
 
     ultimately show ?case 
       using new_discover
       by (auto simp add: tarjan_disc_def)
   next
     case (finish s s' u)
 
     {
       let ?dw = "dropWhile ((\<noteq>) u) (tj_stack s)"
       let ?tw = "takeWhile ((\<noteq>) u) (tj_stack s)"
 
       fix a k j
       assume A: "a = tl ?dw" "k < length a" "j < k"
       and "u \<in> set (tj_stack s)"
       hence "?dw \<noteq> []" by auto
 
       define j' k' where "j' = Suc j + length ?tw" and "k' = Suc k + length ?tw"
       with \<open>j < k\<close> have "j' < k'" by simp
       
       have "length (tj_stack s) = length ?tw + length ?dw"
         by (simp add: length_append[symmetric])
       moreover from A have *: "Suc k < length ?dw" and **: "Suc j < length ?dw" by auto
       ultimately have "k' < length (tj_stack s)" by (simp add: k'_def)
 
       with finish \<open>j'<k'\<close> have "\<delta> s (tj_stack s ! k') < \<delta> s (tj_stack s ! j')" by simp
       also from dropWhile_nth[OF *] have "tj_stack s ! k' = ?dw ! Suc k"
         by (simp add: k'_def)
       also from dropWhile_nth[OF **] have "tj_stack s ! j' = ?dw ! Suc j"
         by (simp add: j'_def)
       also from nth_tl[OF \<open>?dw \<noteq> []\<close>] have "?dw ! Suc k = a ! k" by (simp add: A)
       also from nth_tl[OF \<open>?dw \<noteq> []\<close>] have "?dw ! Suc j = a ! j" by (simp add: A)
       finally have "\<delta> s (a ! k) < \<delta> s (a ! j)" .
     } note aux = this
 
     from finish show ?case
       apply simp
       unfolding tarjan_fin_def tj_stack_pop_def
       apply refine_vcg
       apply (auto intro!: aux)
       done
   qed (simp_all add: tarjan_back_def)
 end end
 
 context Tarjan_invar begin context begin interpretation timing_syntax .
   lemma tj_stack_incr_disc:
     assumes "k < length (tj_stack s)"
     and "j < k"
     shows "\<delta> s (tj_stack s ! j) > \<delta> s (tj_stack s ! k)"
     using assms i_tj_stack_incr_disc[THEN make_invar_thm]
     by blast
 
   lemma tjs_disc_dw_tw:
     fixes u
     defines "dw \<equiv> dropWhile ((\<noteq>) u) (tj_stack s)"
     defines "tw \<equiv> takeWhile ((\<noteq>) u) (tj_stack s)"
     assumes "x \<in> set dw" "y \<in> set tw"
     shows "\<delta> s x < \<delta> s y"
   proof -
     from assms obtain k where k: "dw ! k = x" "k < length dw" by (metis in_set_conv_nth)
     from assms obtain j where j: "tw ! j = y" "j < length tw" by (metis in_set_conv_nth)
 
     have "length (tj_stack s) = length tw + length dw"
         by (simp add: length_append[symmetric] tw_def dw_def)
     with k j have "\<delta> s (tj_stack s ! (k + length tw)) < \<delta> s (tj_stack s ! j)"
       by (simp add: tj_stack_incr_disc)
     also from j takeWhile_nth have "tj_stack s ! j = y" by (metis tw_def)
     also from dropWhile_nth k have "tj_stack s ! (k + length tw) = x" by (metis tw_def dw_def)
     finally show ?thesis .
   qed
 end end
 
 context Tarjan begin context begin interpretation timing_syntax .
   lemma i_sccs_finished_stack_ss_tj_stack:
     "is_invar (\<lambda>s. \<Union>(sccs s) \<subseteq> dom (finished s) \<and> set (stack s) \<subseteq> set (tj_stack s))"
   proof (induct rule: establish_invarI)
     case (finish s s' u) then interpret Tarjan_invar where s=s by simp
 
     let ?tw = "takeWhile ((\<noteq>) u) (tj_stack s)"
     let ?dw = "dropWhile ((\<noteq>) u) (tj_stack s)"
 
     {
       fix x
       assume A: "x \<noteq> u" "x \<in> set ?tw" "u \<in> set (tj_stack s)"
       hence x_tj: "x \<in> set (tj_stack s)" by (auto dest: set_takeWhileD)
 
       have "x \<in> dom (finished s)"
       proof (rule ccontr)
         assume "x \<notin> dom (finished s)"
         with x_tj tj_stack_discovered discovered_eq_finished_un_stack have "x \<in> set (stack s)" by blast
         with \<open>x\<noteq>u\<close> finish have "x \<in> set (tl (stack s))" by (cases "stack s") auto
         with tl_lt_stack_hd_discover finish have *: "\<delta> s x < \<delta> s u" by simp
 
         from A have "?dw \<noteq> []" by simp
         with hd_dropWhile[OF this] hd_in_set have "u \<in> set ?dw" by metis
         with tjs_disc_dw_tw \<open>x \<in> set ?tw\<close> have "\<delta> s u < \<delta> s x" by simp
 
         with * show False by force
       qed
       hence "\<exists>y. finished s x = Some y" by blast
     } note aux_scc = this
 
     {
       fix  x
       assume A: "x \<in> set (tl (stack s))" "u \<in> set (tj_stack s)"
       with finish stack_distinct have "x \<noteq> u" by (cases "stack s") auto
 
       moreover
       from A have "x \<in> set (stack s)" by (metis in_set_tlD)
       with stack_not_finished have "x \<notin> dom (finished s)" by simp
       with A aux_scc[OF \<open>x \<noteq> u\<close>] have "x \<notin> set ?tw" by blast
 
       moreover 
       from finish \<open>x \<in> set (stack s)\<close> have "x \<in> set (tj_stack s)" by auto
 
       moreover note tjs_union[OF \<open>u \<in> set (tj_stack s)\<close>]
 
       ultimately have "x \<in> set (tl ?dw)" by blast
     } note aux_tj = this
       
     from finish show ?case
       apply simp
       unfolding tarjan_fin_def tj_stack_pop_def
       apply (refine_vcg)
       using aux_scc aux_tj apply (auto dest: in_set_tlD)
       done
   qed (auto simp add: tarjan_disc_def tarjan_back_def)
 
   lemma i_tj_stack_ss_stack_finished:
     "is_invar (\<lambda>s. set (tj_stack s) \<subseteq> set (stack s) \<union> dom (finished s))"
   proof (induct rule: establish_invarI)
     case (finish s) thus ?case
       apply simp
       unfolding tarjan_fin_def
       apply (refine_vcg tj_stack_pop_set_leof_rule)
       apply ((simp, cases "stack s", simp_all)[])+
       done
   qed (auto simp add: tarjan_disc_def tarjan_back_def)
 
   lemma i_finished_ss_sccs_tj_stack:
     "is_invar (\<lambda>s. dom (finished s) \<subseteq> \<Union>(sccs s) \<union> set (tj_stack s))"
   proof (induction rule: establish_invarI_ND)
     case (new_discover s s' v) then interpret Tarjan_invar where s=s by simp
     from new_discover finished_discovered have "v \<notin> dom (finished s)" by auto
     with new_discover show ?case
       by (auto simp add: tarjan_disc_def)
   next
     case (finish s s' u) then interpret Tarjan_invar where s=s by simp
     from finish show ?case
       apply simp
       unfolding tarjan_fin_def
       apply (refine_vcg tj_stack_pop_set_leof_rule)
       apply auto
       done
   qed (simp_all add: tarjan_back_def)
 end end
 
 context Tarjan_invar begin
   lemmas finished_ss_sccs_tj_stack =
     i_finished_ss_sccs_tj_stack[THEN make_invar_thm]
   
   lemmas tj_stack_ss_stack_finished =
     i_tj_stack_ss_stack_finished[THEN make_invar_thm]
 
   lemma sccs_finished:
     "\<Union>(sccs s) \<subseteq> dom (finished s)"
     using i_sccs_finished_stack_ss_tj_stack[THEN make_invar_thm]
     by blast
 
   lemma stack_ss_tj_stack:
     "set (stack s) \<subseteq> set (tj_stack s)"
     using i_sccs_finished_stack_ss_tj_stack[THEN make_invar_thm]
     by blast
   
   lemma hd_stack_in_tj_stack:
     "stack s \<noteq> [] \<Longrightarrow> hd (stack s) \<in> set (tj_stack s)"
     using stack_ss_tj_stack hd_in_set
     by auto
 end
 
 context Tarjan begin context begin interpretation timing_syntax .
   lemma i_no_finished_root:
     "is_invar (\<lambda>s. scc_root s r scc \<and> r \<in> dom (finished s) \<longrightarrow> (\<forall>x \<in> scc. x \<notin> set (tj_stack s)))"
   proof (induct rule: establish_invarI_ND_CB)
     case (new_discover s s' v) then interpret Tarjan_invar where s=s by simp
     {
       fix x
       let ?s = "s'\<lparr>state.more := x\<rparr>"
 
       assume TRANS: "\<And>\<Psi>. tarjan_disc v s' \<le>\<^sub>n SPEC \<Psi> \<Longrightarrow> \<Psi> x"
       and inv': "DFS_invar G tarjan_params (s'\<lparr>state.more := x\<rparr>)"
       and r: "scc_root ?s r scc" "r \<in> dom (finished s')"
 
       from inv' interpret s': Tarjan_invar where s="?s" by simp
 
       have "tj_stack ?s = v#tj_stack s"
         by (rule TRANS) (simp add: new_discover tarjan_disc_def)
       
       moreover
       from r s'.scc_root_finished_impl_scc_finished have "scc \<subseteq> dom (finished ?s)" by auto
       with new_discover finished_discovered have "v \<notin> scc" by force
 
       moreover
       from r finished_discovered new_discover have "r \<in> dom (discovered s)" by auto
       with r inv' new_discover have "scc_root s r scc"
         apply (intro scc_root_transfer[where s'="?s", THEN iffD2])
         apply clarsimp_all
         done
       with new_discover r have "\<forall>x \<in> scc. x \<notin> set (tj_stack s')" by simp
 
       ultimately have "\<forall>x\<in>scc. x \<notin> set (tj_stack ?s)" by (auto simp: new_discover)
     }
     with new_discover show ?case by (simp add: pw_leof_iff)
   next
     case (cross_back_edge s s' u v) then interpret Tarjan_invar where s=s by simp
     { 
       fix x
       let ?s = "s'\<lparr>state.more := x\<rparr>"
       assume TRANS: "\<And>\<Psi>. tarjan_back u v s' \<le>\<^sub>n SPEC \<Psi> \<Longrightarrow> \<Psi> x"
       and r: "scc_root ?s r scc" "r \<in> dom (finished s')"
       with cross_back_edge have "scc_root s r scc"
         by (simp add: scc_root_transfer'[where s'="?s"])
 
       moreover
       have "tj_stack ?s = tj_stack s" by (rule TRANS) (simp add: cross_back_edge tarjan_back_def)
 
       ultimately  have "\<forall>x\<in>scc. x \<notin> set (tj_stack ?s)"
         using cross_back_edge r by simp
     }
     with cross_back_edge show ?case by (simp add: pw_leof_iff)
   next
     case (finish s s' u) then interpret Tarjan_invar where s=s by simp
     
     {
       fix x
       let ?s = "s'\<lparr>state.more := x\<rparr>"
       assume TRANS:  "\<And>\<Psi>. tarjan_fin u s' \<le>\<^sub>n SPEC \<Psi> \<Longrightarrow> \<Psi> x"
       and inv': "DFS_invar G tarjan_params (s'\<lparr>state.more := x\<rparr>)"
       and r: "scc_root ?s r scc" "r \<in> dom (finished s')"
 
       from inv' interpret s': Tarjan_invar where s="?s" by simp
 
       have "\<forall>x\<in>scc. x \<notin> set (tj_stack ?s)"
       proof (cases "r = u")
         case False with finish r have "\<forall>x\<in>scc. x \<notin> set (tj_stack s)"
           using scc_root_transfer'[where s'="?s"]
           by simp
         moreover have "set (tj_stack ?s) \<subseteq> set (tj_stack s)"
           apply (rule TRANS)
           unfolding tarjan_fin_def
           apply (refine_vcg tj_stack_pop_set_leof_rule)
           apply (simp_all add: finish)
           done
         ultimately show ?thesis by blast
       next
         case True with r s'.scc_root_unique_is_scc have "scc_root ?s u (scc_of E u)" by simp
         with s'.scc_root_transfer'[where s'=s'] finish have "scc_root s' u (scc_of E u)" by simp
 
         moreover
         hence [simp]: "tj_stack ?s = tl (dropWhile ((\<noteq>) u) (tj_stack s))"
           apply (rule_tac TRANS)
           unfolding tarjan_fin_def tj_stack_pop_def
           apply (refine_vcg)
           apply (simp_all add: finish)
           done
 
         {
           let ?dw = "dropWhile ((\<noteq>) u) (tj_stack s)"
           let ?tw = "takeWhile ((\<noteq>) u) (tj_stack s)"
           fix x
           define j::nat where "j = 0"
           
           assume x: "x \<in> set (tj_stack ?s)"
           then obtain i where i: "i < length (tj_stack ?s)" "tj_stack ?s ! i = x"
             by (metis in_set_conv_nth)
 
           have "length (tj_stack s) = length ?tw + length ?dw"
             by (simp add: length_append[symmetric])
           with i have "\<delta> s (tj_stack s ! (Suc i + length ?tw)) < \<delta> s (tj_stack s ! length ?tw)"
             by (simp add: tj_stack_incr_disc)
 
           also from hd_stack_in_tj_stack finish have ne: "?dw \<noteq> []" and "length ?dw > 0" by simp_all
           from hd_dropWhile[OF ne] hd_conv_nth[OF ne] have "?dw ! 0 = u" by simp
           with dropWhile_nth[OF \<open>length ?dw > 0\<close>] have "tj_stack s ! length ?tw = u" by simp
 
           also from i have "?dw ! Suc i = x" "Suc i < length ?dw" by (simp_all add: nth_tl[OF ne])
           with dropWhile_nth[OF this(2)] have "tj_stack s ! (Suc i + length ?tw) = x" by simp
 
           finally have "\<delta> ?s x < \<delta> ?s u" by (simp add: finish)
 
           moreover from x s'.tj_stack_discovered have "x \<in> dom (discovered ?s)" by auto
           ultimately have "x \<notin> scc" using s'.scc_root_disc_le r True by force
         } thus ?thesis by metis
       qed
     }
     with finish show ?case by (simp add: pw_leof_iff)
   qed simp_all
 end end
 
 context Tarjan_invar begin
   lemma no_finished_root:
     assumes "scc_root s r scc"
     and "r \<in> dom (finished s)"
     and "x \<in> scc"
     shows "x \<notin> set (tj_stack s)"
     using assms
     using i_no_finished_root[THEN make_invar_thm]
     by blast
 
   context begin interpretation timing_syntax .
 
   lemma tj_stack_reach_stack:
     assumes "u \<in> set (tj_stack s)"
     shows "\<exists>v \<in> set (stack s). (u,v) \<in> E\<^sup>* \<and> \<delta> s v \<le> \<delta> s u"
   proof -
     have u_scc: "u \<in> scc_of E u" by simp
 
     from assms tj_stack_discovered have u_disc: "u \<in> dom (discovered s)" by auto
     with scc_root_of_node_exists obtain r where r: "scc_root s r (scc_of E u)" by blast
     have "r \<in> set (stack s)"
     proof (rule ccontr)
       assume "r \<notin> set (stack s)"
       with r[unfolded scc_root_def] stack_set_def have "r \<in> dom (finished s)" by simp
       with u_scc have "u \<notin> set (tj_stack s)" using no_finished_root r by blast
       with assms show False by contradiction
     qed
     moreover from r scc_reach_scc_root u_scc u_disc have "(u,r) \<in> E\<^sup>*" by blast
     moreover from r scc_root_disc_le u_scc u_disc have "\<delta> s r \<le> \<delta> s u" by blast
     ultimately show ?thesis by metis
   qed
 
   lemma tj_stack_reach_hd_stack:
     assumes "v \<in> set (tj_stack s)"
     shows "(v, hd (stack s)) \<in> E\<^sup>*"
   proof -
     from tj_stack_reach_stack assms obtain r where r: "r \<in> set (stack s)" "(v,r) \<in> E\<^sup>*" by blast
     hence "r = hd (stack s) \<or> r \<in> set (tl (stack s))" by (cases "stack s") auto
     thus ?thesis
     proof
       assume "r = hd (stack s)" with r show ?thesis by simp
     next
       from r have ne :"stack s \<noteq> []" by auto
 
       assume "r \<in> set (tl (stack s))"
       with tl_stack_hd_tree_path ne have "(r,hd (stack s)) \<in> (tree_edges s)\<^sup>+" by simp
       with trancl_mono_mp tree_edges_ssE have "(r,hd (stack s))\<in>E\<^sup>*" by (metis rtrancl_eq_or_trancl)
       with \<open>(v,r)\<in>E\<^sup>*\<close> show ?thesis by (metis rtrancl_trans)
     qed
   qed
   
   lemma empty_stack_imp_empty_tj_stack: 
     assumes "stack s = []"
     shows "tj_stack s = []"
   proof (rule ccontr)
     assume ne: "tj_stack s \<noteq> []"
     then obtain x where x: "x \<in> set (tj_stack s)" by auto
     with tj_stack_reach_stack obtain r where "r \<in> set (stack s)" by auto
     with assms show False by simp
   qed
   
   lemma stacks_eq_iff: "stack s = [] \<longleftrightarrow> tj_stack s = []"
     using empty_stack_imp_empty_tj_stack stack_ss_tj_stack
     by auto
 end end
 
 context Tarjan begin context begin interpretation timing_syntax .
   lemma i_sccs_are_sccs:
     "is_invar (\<lambda>s. \<forall>scc \<in> sccs s. is_scc E scc)"
   proof (induction rule: establish_invarI)
     case (finish s s' u) then interpret Tarjan_invar where s=s by simp
     from finish have EQ[simp]:
       "finished s' = (finished s)(u \<mapsto> counter s)"
       "discovered s' = discovered s"
       "tree_edges s' = tree_edges s"
       "sccs s' = sccs s"
       "tj_stack s' = tj_stack s"
       by simp_all
 
     {
       fix x
 
       let ?s = "s'\<lparr>state.more := x\<rparr>"
       assume TRANS: "\<And>\<Psi>. tarjan_fin u s' \<le>\<^sub>n SPEC \<Psi> \<Longrightarrow> \<Psi> x"
       and inv': "DFS_invar G tarjan_params (s'\<lparr>state.more := x\<rparr>)"
       then interpret s': Tarjan_invar where s="?s" by simp
       
       from finish hd_in_set stack_set_def have 
         u_disc: "u \<in> dom (discovered s)" 
         and u_n_fin: "u \<notin> dom (finished s)" by blast+
 
       have "\<forall>scc \<in> sccs ?s. is_scc E scc"
       proof (cases "scc_root s' u (scc_of E u)")
         case False
         have "sccs ?s = sccs s"
           apply (rule TRANS)
           unfolding tarjan_fin_def tj_stack_pop_def
           by (refine_vcg) (simp_all add: False)
         thus ?thesis by (simp add: finish)
       next
         case True
         let ?dw = "dropWhile ((\<noteq>) u) (tj_stack s)"
         let ?tw = "takeWhile ((\<noteq>) u) (tj_stack s)"
         let ?tw' = "insert u (set ?tw)"
 
         have [simp]: "sccs ?s = insert ?tw' (sccs s)"
           apply (rule TRANS)
           unfolding tarjan_fin_def tj_stack_pop_def
           by (refine_vcg) (simp_all add: True)
 
         have [simp]: "tj_stack ?s = tl ?dw"
           apply (rule TRANS)
           unfolding tarjan_fin_def tj_stack_pop_def
           by (refine_vcg) (simp_all add: True)
 
         from True scc_root_transfer'[where s'=s'] have "scc_root s u (scc_of E u)" by simp
         with inv' scc_root_transfer[where s'="?s"] u_disc have u_root: "scc_root ?s u (scc_of E u)" by simp
 
         have "?tw' \<subseteq> scc_of E u"
         proof
           fix v assume v: "v \<in> ?tw'"
           show "v \<in> scc_of E u"
           proof cases
             assume "v \<noteq> u" with v have v: "v \<in> set ?tw" by auto
             hence v_tj: "v \<in> set (tj_stack s)" by (auto dest: set_takeWhileD)
             with tj_stack_discovered have v_disc: "v \<in> dom (discovered s)" by auto
 
             from hd_stack_in_tj_stack finish  have "?dw \<noteq> []" by simp
             with hd_dropWhile[OF this] hd_in_set have "u \<in> set ?dw" by metis
             with v have "\<delta> s v > \<delta> s u" using tjs_disc_dw_tw by blast
            
             moreover have "v \<in> dom (finished s)"
             proof (rule ccontr)
               assume "v \<notin> dom (finished s)" 
               with v_disc stack_set_def have "v \<in> set (stack s)" by auto
               with \<open>v\<noteq>u\<close> finish have "v \<in> set (tl (stack s))" by (cases "stack s") auto
               with tl_lt_stack_hd_discover finish have "\<delta> s v < \<delta> s u" by simp
               with \<open>\<delta> s v > \<delta> s u\<close> show False by force
             qed
 
             ultimately have "(u,v) \<in> (tree_edges s)\<^sup>+" 
               using parenthesis_impl_tree_path_not_finished[OF u_disc] u_n_fin
               by force
             with trancl_mono_mp tree_edges_ssE have "(u,v)\<in>E\<^sup>*" by (metis rtrancl_eq_or_trancl)
 
             moreover
             from tj_stack_reach_hd_stack v_tj finish have "(v,u)\<in>E\<^sup>*" by simp 
 
             moreover have "is_scc E (scc_of E u)" "u \<in> scc_of E u" by simp_all
             ultimately show ?thesis using is_scc_closed by metis
           qed simp
         qed
         moreover have "scc_of E u \<subseteq> ?tw'"
         proof
           fix v assume v: "v \<in> scc_of E u"
           moreover note u_root
           moreover have "u \<in> dom (finished ?s)" by simp
           ultimately have "v \<in> dom (finished ?s)" "v \<notin> set (tj_stack ?s)" 
             using s'.scc_root_finished_impl_scc_finished s'.no_finished_root
             by auto
           with s'.finished_ss_sccs_tj_stack have "v \<in> \<Union>(sccs ?s)" by blast
           hence "v \<in> \<Union>(sccs s) \<or> v \<in> ?tw'" by auto
           thus "v \<in> ?tw'"
           proof
             assume "v \<in> \<Union>(sccs s)"
             then obtain scc where scc: "v \<in> scc" "scc \<in> sccs s" by auto
             moreover with finish have "is_scc E scc" by simp
             moreover have "is_scc E (scc_of E u)" by simp
             moreover note v
             ultimately have "scc = scc_of E u" using is_scc_unique by metis
             hence "u \<in> scc" by simp
             with scc sccs_finished have "u \<in> dom (finished s)" by auto
             with u_n_fin show ?thesis by contradiction
           qed simp
         qed
         ultimately have "?tw' = scc_of E u" by auto
         hence "is_scc E ?tw'" by simp
         with finish show ?thesis by auto
       qed
     }   
     thus ?case by (auto simp: pw_leof_iff finish)
   qed (simp_all add: tarjan_back_def tarjan_disc_def)
 end
 
   lemmas (in Tarjan_invar) sccs_are_sccs =
     i_sccs_are_sccs[THEN make_invar_thm]
 
 context begin interpretation timing_syntax .
 
   lemma i_lowlink_eq_LowLink:
     "is_invar (\<lambda>s. \<forall>x \<in> dom (discovered s). \<zeta> s x = LowLink s x)"
   proof -
     {
       fix s s' :: "'v tarjan_state"
       fix v w
       fix x
 
       let ?s = "s'\<lparr>state.more := x\<rparr>"
 
       assume pre_ll_sub_rev: "\<And>w. \<lbrakk>Tarjan_invar G ?s; w \<in> dom (discovered ?s); w \<noteq> v\<rbrakk> \<Longrightarrow> lowlink_set ?s w \<subseteq> lowlink_set s w \<union> {v}"
       assume tree_sub : "tree_edges s' = tree_edges s \<or> (\<exists>u. u \<noteq> v \<and> tree_edges s' = tree_edges s \<union> {(u,v)})"
 
       assume "Tarjan_invar G s"
       assume [simp]: "discovered s' = (discovered s)(v \<mapsto> counter s)"
                      "finished s' = finished s"
                      "lowlink s' = lowlink s"
                      "cross_edges s' = cross_edges s" "back_edges s' = back_edges s"
       assume v_n_disc: "v \<notin> dom (discovered s)"
       assume IH: "\<And>w. w\<in>dom (discovered s) \<Longrightarrow> \<zeta> s w = LowLink s w"
 
       assume TRANS: "\<And>\<Psi>. tarjan_disc v s' \<le>\<^sub>n SPEC \<Psi> \<Longrightarrow> \<Psi> x"
       and INV: "DFS_invar G tarjan_params ?s"
       and w_disc: "w \<in> dom (discovered ?s)"
 
       interpret Tarjan_invar where s=s by fact
       from INV interpret s':Tarjan_invar where s="?s" by simp
 
       have [simp]: "lowlink ?s = (lowlink s)(v \<mapsto> counter s)"
         by (rule TRANS) (auto simp: tarjan_disc_def)
 
       from v_n_disc edge_imp_discovered have "edges s `` {v} = {}" by auto
       with tree_sub tree_edge_imp_discovered have "edges ?s `` {v} = {}" by auto
       with s'.no_path_imp_no_lowlink_path have "\<And>w. \<not>(\<exists>p. lowlink_path ?s v p w)" by metis
       hence ll_v: "lowlink_set ?s v = {v}"
           unfolding lowlink_set_def by auto
 
       have "\<zeta> ?s w = LowLink ?s w"
       proof (cases "w=v")
         case True with ll_v show ?thesis by simp 
       next
         case False hence "\<zeta> ?s w = \<zeta> s w" by simp
         also from IH have "\<zeta> s w = LowLink s w" using w_disc False by simp
         also have "LowLink s w = LowLink ?s w"
         proof (rule LowLink_eqI[OF INV])
           from v_n_disc show "discovered s \<subseteq>\<^sub>m discovered ?s" by (simp add: map_le_def)
           
           from tree_sub show "lowlink_set s w \<subseteq> lowlink_set ?s w"
             unfolding lowlink_set_def lowlink_path_def
             by auto
 
           show "lowlink_set ?s w \<subseteq> lowlink_set s w \<union> {v}"
           proof (cases "w = v")
             case True with ll_v show ?thesis by auto
           next
             case False thus ?thesis
               using pre_ll_sub_rev w_disc INV
               by simp
           qed
           
           show "w \<in> dom (discovered s)" using w_disc False by simp
 
           fix ll assume "ll \<in> {v}" with timing_less_counter lowlink_set_discovered have 
             "\<And>x. x\<in>\<delta> s`lowlink_set s w \<Longrightarrow> x < \<delta> ?s ll" by simp force
           moreover from Min_in lowlink_set_finite lowlink_set_not_empty w_disc False have 
             "LowLink s w \<in> \<delta> s`lowlink_set s w " by auto
           ultimately show "LowLink s w \<le> \<delta> ?s ll" by force
         qed
         finally show ?thesis .
       qed
     } note tarjan_disc_aux = this
 
     show ?thesis
     proof (induct rule: establish_invarI_CB)
       case (new_root s s' v0)
       {
         fix w x
         let ?s = "new_root v0 s\<lparr>state.more := x\<rparr>"
         have "lowlink_set ?s w \<subseteq> lowlink_set s w \<union> {v0}"
           unfolding lowlink_set_def lowlink_path_def
           by auto
       } note * = this
 
       from new_root show ?case
         using tarjan_disc_aux[OF *]
         by (auto simp add: pw_leof_iff)
     next
       case (discover s s' u v) then interpret Tarjan_invar where s=s by simp
       let ?s' = "discover (hd (stack s)) v (s\<lparr>pending := pending s - {(hd (stack s),v)}\<rparr>)"
       {
         fix w x
         let ?s = "?s'\<lparr>state.more := x\<rparr>"
         assume INV: "Tarjan_invar G ?s"
           and d: "w \<in> dom (discovered ?s')"
           and "w\<noteq>v"
 
         interpret s': Tarjan_invar where s="?s" by fact
 
         have "lowlink_set ?s w \<subseteq> lowlink_set s w \<union> {v}"
         proof
           fix ll
           assume ll: "ll \<in> lowlink_set ?s w"
           hence "ll = w \<or> (\<exists>p. lowlink_path ?s w p ll)" by (auto simp add: lowlink_set_def)
           thus "ll \<in> lowlink_set s w \<union> {v}" (is "ll \<in> ?L")
           proof
             assume "ll = w" with d show ?thesis by (auto simp add: lowlink_set_def)
           next
             assume "\<exists>p. lowlink_path ?s w p ll"
-            then guess p .. note p = this
+            then obtain p where p: "lowlink_path ?s w p ll" ..
 
             hence [simp]: "p\<noteq>[]" by (simp add: lowlink_path_def)
     
             from p have "hd p = w" by (auto simp add: lowlink_path_def path_hd)
             
             show ?thesis
             proof (rule tri_caseE)
               assume "v\<noteq>ll" "v \<notin> set p" hence "lowlink_path s w p ll"
                 using p by (auto simp add: lowlink_path_def)
               with ll show ?thesis by (auto simp add: lowlink_set_def)
             next
               assume "v = ll" thus ?thesis by simp
             next
               assume "v \<in> set p" "v \<noteq> ll"
               then obtain i where i: "i < length p" "p!i = v"
                 by (metis in_set_conv_nth)
               have "False"
               proof (cases i)
                 case "0" with i have "hd p = v" by (simp add: hd_conv_nth)
                 with \<open>hd p = w\<close> \<open>w \<noteq> v\<close> show False by simp
               next
                 case (Suc n) with i s'.lowlink_path_finished[OF p, where j=i] have 
                   "v \<in> dom (finished ?s)" by simp
                 with finished_discovered discover show False by auto
               qed
               thus ?thesis ..
             qed
           qed
         qed
       } note * = this
       
       from discover hd_in_set stack_set_def have "v \<noteq> u" by auto
       with discover have **: "tree_edges ?s' = tree_edges s \<or> (\<exists>u. u \<noteq> v \<and> tree_edges ?s' = tree_edges s \<union> {(u,v)})" by auto
 
       from discover show ?case
         using tarjan_disc_aux[OF * **]
         by (auto simp: pw_leof_iff)
     next
       case (cross_back_edge s s' u v) then interpret Tarjan_invar where s=s by simp
       from cross_back_edge have [simp]:
         "discovered s' = discovered s"
         "finished s' = finished s"
         "tree_edges s' = tree_edges s"
         "lowlink s' = lowlink s"
         by simp_all
       {
         fix w :: "'v"
         fix x
 
         let ?s = "s'\<lparr>state.more := x\<rparr>"
         let ?L = "\<delta> s ` lowlink_set s w"
         let ?L' = "\<delta> ?s ` lowlink_set ?s w"
 
         assume TRANS: "\<And>\<Psi>. tarjan_back u v s' \<le>\<^sub>n SPEC \<Psi> \<Longrightarrow> \<Psi> x"
           and inv': "DFS_invar G tarjan_params ?s"
           and w_disc': "w \<in> dom (discovered ?s)"
         
         from inv' interpret s':Tarjan_invar where s="?s" by simp
    
         have ll_sub: "lowlink_set s w \<subseteq> lowlink_set ?s w"
           unfolding lowlink_set_def lowlink_path_def
           by (auto simp: cross_back_edge)
       
         have ll_sub_rev: "lowlink_set ?s w \<subseteq> lowlink_set s w \<union> {v}"
           unfolding lowlink_set_def lowlink_path_def
           by (auto simp: cross_back_edge)
 
         from w_disc' have w_disc: "w \<in> dom (discovered s)" by simp
         with LowLink_le_disc have LLw: "LowLink s w \<le> \<delta> s w" by simp
 
         from cross_back_edge hd_in_set have u_n_fin: "u \<notin> dom (finished s)" 
           using stack_not_finished by auto
 
         {
           assume *: "v \<in> lowlink_set ?s w \<Longrightarrow> LowLink s w \<le> \<delta> ?s v"
           have "LowLink s w = LowLink ?s w"
           proof (rule LowLink_eqI[OF inv' _ ll_sub ll_sub_rev w_disc])
             show "discovered s \<subseteq>\<^sub>m discovered ?s" by simp
             
             fix ll assume "ll \<in> {v}" "ll \<in> lowlink_set ?s w"
             with * show "LowLink s w \<le> \<delta> ?s ll" by simp
           qed
         } note LL_eqI = this
 
         have "\<zeta> ?s w = LowLink ?s w"
         proof (cases "w=u")
           case True show ?thesis
           proof (cases "(\<delta> s v < \<delta> s w \<and> v \<in> set (tj_stack s) \<and> \<delta> s v < \<zeta> s w)")
             case False note all_False = this
             with \<open>w = u\<close> have "\<zeta> ?s w = \<zeta> s w"
               by (rule_tac TRANS) (auto simp add: tarjan_back_def cross_back_edge)
             also from cross_back_edge w_disc have \<zeta>w: "... = LowLink s w" by simp
             also have "LowLink s w = LowLink ?s w"
             proof (rule LL_eqI)
               assume v: "v \<in> lowlink_set ?s w"
               show "LowLink s w \<le> \<delta> ?s v"
               proof (cases "\<delta> s v < \<delta> s w \<and> \<delta> s v < \<zeta> s w")
                 case False with \<open>LowLink s w \<le> \<delta> s w\<close> \<zeta>w show ?thesis by auto
               next
                 case True with all_False have v_n_tj: "v \<notin> set (tj_stack s)" by simp
                 from v have e: "(v,u) \<in> E\<^sup>*" "(u,v) \<in> E\<^sup>*" 
                   unfolding lowlink_set_def by (auto simp add: \<open>w=u\<close>)
                 
                 from v_n_tj have "v \<notin> set (stack s)" using stack_ss_tj_stack by auto
                 with cross_back_edge have "v \<in> dom (finished s)" by (auto simp add: stack_set_def)
                 with finished_ss_sccs_tj_stack v_n_tj sccs_are_sccs obtain scc 
                   where scc: "v \<in> scc" "scc \<in> sccs s" "is_scc E scc" by blast
                 with is_scc_closed e have "u \<in> scc" by metis
                 with scc sccs_finished u_n_fin have False by blast
                 thus ?thesis ..
               qed
             qed
             finally show ?thesis .
           next
             case True note all_True = this
             with \<open>w=u\<close> have "\<zeta> ?s w = \<delta> s v"
               by (rule_tac TRANS) (simp add: tarjan_back_def cross_back_edge)
 
             also from True cross_back_edge w_disc have "\<delta> s v < LowLink s w" by simp
             with lowlink_set_finite lowlink_set_not_empty w_disc have "\<delta> s v = Min (?L \<union> {\<delta> s v})" by simp
             also have "v \<in> lowlink_set ?s w"
             proof -
               have cb: "(u,v) \<in> cross_edges ?s \<union> back_edges ?s" by (simp add: cross_back_edge)
               with s'.lowlink_path_single have "lowlink_path ?s u [u] v" by auto
               moreover from cb s'.cross_edges_ssE s'.back_edges_ssE have "(u,v) \<in> E" by blast
               hence "(u,v) \<in> E\<^sup>*" ..
               moreover from all_True tj_stack_reach_hd_stack have "(v,u) \<in> E\<^sup>*" by (simp add: cross_back_edge)
               moreover note \<open>v \<in> dom (discovered s)\<close>
               ultimately show ?thesis by (auto intro: s'.lowlink_setI simp: \<open>w=u\<close>)
             qed
             with ll_sub ll_sub_rev have "lowlink_set ?s w = lowlink_set s w \<union> {v}" by auto
             hence "Min (?L \<union> {\<delta> s v}) = LowLink ?s w" by simp
             finally show ?thesis .
           qed
         next
           case False \<comment> \<open>\<open>w \<noteq> u\<close>\<close>
           hence "\<zeta> ?s w = \<zeta> s w"
             by (rule_tac TRANS) (simp add: tarjan_back_def cross_back_edge)
           also have "\<zeta> s w = LowLink s w" using w_disc False by (simp add: cross_back_edge)
           also have "LowLink s w = LowLink ?s w"
           proof (rule LL_eqI)
             assume v: "v \<in> lowlink_set ?s w"
             thus "LowLink s w \<le> \<delta> ?s v" using LLw
             proof cases
               assume "v \<noteq> w"
               with v obtain p where p: "lowlink_path ?s w p v" "p\<noteq>[]" 
                 by (auto simp add: lowlink_set_def lowlink_path_def)
               hence "hd p = w" by (auto simp add: lowlink_path_def path_hd)
 
               show ?thesis
               proof (cases "u \<in> set p")
                 case False with last_in_set p cross_back_edge have "last p \<noteq> hd (stack s)" by force
                 with p have "lowlink_path s w p v"
                   by (auto simp: cross_back_edge lowlink_path_def)
                 with v have "v \<in> lowlink_set s w" 
                   by (auto intro: lowlink_setI simp: lowlink_set_def cross_back_edge)
                 thus ?thesis by simp
               next
                 case True then obtain i where i: "i < length p" "p!i = u"
                   by (metis in_set_conv_nth)
                 have "False"
                 proof (cases i)
                   case "0" with i have "hd p = u" by (simp add: hd_conv_nth)
                   with \<open>hd p = w\<close> \<open>w \<noteq> u\<close> show False by simp
                 next
                   case (Suc n) with i s'.lowlink_path_finished[OF p(1), where j=i] have 
                     "u \<in> dom (finished ?s)" by simp
                   with u_n_fin show ?thesis by simp
                 qed
                 thus ?thesis ..
               qed
             qed simp
           qed
           finally show ?thesis .
         qed
       } note aux = this
       
       with cross_back_edge show ?case by (auto simp: pw_leof_iff)
     next
       case (finish s s' u) then interpret Tarjan_invar where s=s by simp
       from finish have [simp]:
         "discovered s' = discovered s"
         "finished s' = (finished s)(u\<mapsto>counter s)"
         "tree_edges s' = tree_edges s"
         "back_edges s' = back_edges s"
         "cross_edges s' = cross_edges s"
         "lowlink s' = lowlink s" "tj_stack s' = tj_stack s"
         by simp_all
 
       from finish hd_in_set stack_discovered have u_disc: "u \<in> dom (discovered s)" by blast
 
       {
         fix w :: "'v"
         fix x
 
         let ?s = "s'\<lparr>state.more := x\<rparr>"
         let ?L = "\<delta> s ` lowlink_set s w"
         let ?Lu = "\<delta> s ` lowlink_set s u"
         let ?L' = "\<delta> s ` lowlink_set ?s w"
 
         assume TRANS: "\<And>\<Psi>. tarjan_fin u s' \<le>\<^sub>n SPEC \<Psi> \<Longrightarrow> \<Psi> x"
           and inv': "DFS_invar G tarjan_params ?s"
           and w_disc: "w \<in> dom (discovered ?s)"
 
         from inv' interpret s':Tarjan_invar where s="?s" by simp
      
         have ll_sub: "lowlink_set s w \<subseteq> lowlink_set ?s w"
           unfolding lowlink_set_def lowlink_path_def
           by auto
       
         have ll_sub_rev: "lowlink_set ?s w \<subseteq> lowlink_set s w \<union> lowlink_set s u"
         proof
           fix ll
           assume ll: "ll \<in> lowlink_set ?s w"
           hence "ll = w \<or> (\<exists>p. lowlink_path ?s w p ll)" by (auto simp add: lowlink_set_def)
           thus "ll \<in> lowlink_set s w \<union> lowlink_set s u" 
           proof (rule disjE1)
             assume "ll = w" with w_disc show ?thesis by (auto simp add: lowlink_set_def)
           next
             assume "ll \<noteq> w"
             assume "\<exists>p. lowlink_path ?s w p ll"
-            then guess p .. note p = this
+            then obtain p where p: "lowlink_path ?s w p ll" ..
 
             hence [simp]: "p\<noteq>[]" by (simp add: lowlink_path_def)
     
             from p have "hd p = w" by (auto simp add: lowlink_path_def path_hd)
             
             show ?thesis
             proof (cases "u \<in> set p")
               case False hence "lowlink_path s w p ll"
                 using p by (auto simp add: lowlink_path_def)
               with ll show ?thesis by (auto simp add: lowlink_set_def)
             next
               case True
               then obtain i where i: "i < length p" "p!i = u"
                 by (metis in_set_conv_nth)
               moreover
               let ?dp = "drop i p"
 
               from i have "?dp \<noteq> []" by simp
 
               from i have "hd ?dp = u" by (simp add: hd_drop_conv_nth)
               moreover from i have "last ?dp = last p" by simp
               moreover {
                 fix k
                 assume "1 < length ?dp"
                 and  "k < length ?dp - 1"
 
                 hence l: "1 < length p" "k+i < length p - 1" by (auto)
                 with p have "(p!(k+i), p!Suc (k+i)) \<in> tree_edges s" by (auto simp add: lowlink_path_def)
                 moreover from l have i: "i+k \<le> length p" "i+Suc k \<le> length p" by simp_all
                 ultimately have  "(?dp!k,?dp!Suc k) \<in> tree_edges s" by (simp add: add.commute)
               } note aux = this
               moreover {
                 assume *: "1 < length ?dp"
                 hence l: "1 + i < length p" by simp
                 with s'.lowlink_path_finished[OF p] have "p ! (1+i) \<in> dom (finished ?s)" by auto
                 moreover from l have "i+1\<le>length p" by simp
                 ultimately have "?dp!1 \<in> dom (finished ?s)" by simp
                 moreover from aux[of 0] * have "(?dp!0,?dp!Suc 0) \<in> tree_edges s" by simp
                 with \<open>hd ?dp = u\<close> hd_conv_nth[of "?dp"] * have "(u,?dp!Suc 0) \<in> tree_edges s" by simp
                 with no_self_loop_in_tree have "?dp!1 \<noteq> u" by auto
                 ultimately have "?dp!1 \<in> dom (finished s)" by simp
               }
               moreover 
                 from p have P: "path E w p ll" by (simp add: lowlink_path_def)
 
                 have "p = (take i p)@?dp" by simp
                 with P path_conc_conv obtain x where p': "path E x ?dp ll" "path E w (take i p) x" by metis
                 with \<open>?dp \<noteq> []\<close> path_hd have "hd ?dp = x" by metis
                 with \<open>hd ?dp = u\<close> p' have u_path: "path E u ?dp ll" and path_u: "path E w (take i p) u" by metis+
 
               ultimately have "lowlink_path s u ?dp ll" using p by (simp add: lowlink_path_def)
               moreover from u_path path_is_trancl \<open>?dp \<noteq> []\<close> have "(u,ll) \<in> E\<^sup>+" by force
               moreover { from ll \<open>ll \<noteq> w\<close> have "(ll,w) \<in> E\<^sup>+" by (auto simp add: lowlink_set_def)
                 also from path_u path_is_rtrancl have "(w,u) \<in> E\<^sup>*" by metis
                 finally have "(ll,u)\<in>E\<^sup>+" .
               }
               moreover note ll u_disc
               ultimately have "ll \<in> lowlink_set s u" unfolding lowlink_set_def by auto
               thus ?thesis by auto
             qed
           qed
         qed
         hence ll_sub_rev': "?L' \<subseteq> ?L \<union> ?Lu" by auto
 
         have ref_ne: "stack ?s \<noteq> [] \<Longrightarrow> 
              lowlink ?s = (lowlink s)(hd (stack ?s) \<mapsto> min (\<zeta> s (hd (stack ?s))) (\<zeta> s u))"
           apply (rule TRANS)
           unfolding tarjan_fin_def tj_stack_pop_def
           by refine_vcg simp_all
         
         have ref_e: "stack ?s = [] \<Longrightarrow> lowlink ?s = lowlink s"
           apply (rule TRANS)
           unfolding tarjan_fin_def tj_stack_pop_def
           by refine_vcg simp_all
 
         have ref_tj: "\<zeta> s u \<noteq> \<delta> s u \<Longrightarrow> tj_stack ?s = tj_stack s"
           apply (rule TRANS)
           unfolding tarjan_fin_def tj_stack_pop_def
           by refine_vcg simp_all
 
         have "\<zeta> ?s w = LowLink ?s w"
         proof (cases "w = hd (stack ?s) \<and> stack ?s \<noteq> []")
           case True note all_True = this
           with ref_ne have *: "\<zeta> ?s w = min (\<zeta> s w) (\<zeta> s u)" by simp
           show ?thesis
           proof (cases "\<zeta> s u < \<zeta> s w")
             case False with * finish w_disc have "\<zeta> ?s w = LowLink s w" by simp
             also have "LowLink s w = LowLink ?s w"
             proof (rule LowLink_eqI[OF inv' _ ll_sub ll_sub_rev])
               from w_disc show "w \<in> dom (discovered s)" by simp
               fix ll assume "ll \<in> lowlink_set s u" 
               hence "LowLink s u \<le> \<delta> s ll" by simp
               moreover from False finish w_disc u_disc have "LowLink s w \<le> LowLink s u" by simp
               ultimately show "LowLink s w \<le> \<delta> ?s ll" by simp
             qed simp
             finally show ?thesis .
           next
             case True note \<zeta>rel = this
             have "LowLink s u \<in> ?L'"
             proof -
               from all_True finish have w_tl: "w\<in>set (tl (stack s))" by auto
 
               obtain ll where ll: "ll \<in> lowlink_set s u" "\<delta> s ll = LowLink s u"
                 using Min_in[of ?Lu] lowlink_set_finite lowlink_set_not_empty u_disc
                 by fastforce
               have "ll \<in> lowlink_set ?s w"
               proof (cases "\<delta> s u = \<zeta> s u")
                 case True
                 moreover from w_tl finish tl_lt_stack_hd_discover have "\<delta> s w < \<delta> s u" by simp
                 moreover from w_disc have "LowLink s w \<le> \<delta> s w" by (simp add: LowLink_le_disc)
                 with w_disc finish have "\<zeta> s w \<le> \<delta> s w" by simp
                 moreover note \<zeta>rel
                 ultimately have False by force
                 thus ?thesis ..
               next
                 case False with u_disc finish ll have "u \<noteq> ll" by auto
                 with ll have
                   e: "(ll,u) \<in> E\<^sup>+" "(u,ll) \<in> E\<^sup>+" and
                   p: "\<exists>p. lowlink_path s u p ll" and
                   ll_disc: "ll \<in> dom (discovered s)"
                   by (auto simp: lowlink_set_def)
 
                 from p have p': "\<exists>p. lowlink_path ?s u p ll"
                   unfolding lowlink_path_def
                   by auto
                 from w_tl tl_stack_hd_tree_path finish have T: "(w,u) \<in> (tree_edges ?s)\<^sup>+" by simp
                 with s'.lowlink_path_tree_prepend all_True p' have "\<exists>p. lowlink_path ?s w p ll" by blast
                 moreover from T trancl_mono_mp[OF s'.tree_edges_ssE] have "(w,u) \<in> E\<^sup>+" by blast
                 with e have "(w,ll) \<in> E\<^sup>+" by simp
                 moreover {
                   note e(1)
                   also from finish False ref_tj have "tj_stack ?s = tj_stack s" by simp
                   with hd_in_set finish stack_ss_tj_stack have "u \<in> set (tj_stack ?s)" by auto
                   with s'.tj_stack_reach_stack obtain x where x: "x \<in> set (stack ?s)" "(u,x) \<in> E\<^sup>*" by blast
                   note this(2)
                   also have "(x,w) \<in> E\<^sup>*"
                   proof (rule rtrancl_eq_or_trancl[THEN iffD2], safe)
                     assume "x \<noteq> w" with all_True x have "x \<in> set (tl (stack ?s))" by (cases "stack ?s") auto
                     with s'.tl_stack_hd_tree_path all_True have "(x,w) \<in> (tree_edges s)\<^sup>+" by auto
                     with trancl_mono_mp[OF tree_edges_ssE] show "(x,w) \<in> E\<^sup>+" by simp
                   qed
                   finally have "(ll,w) \<in> E\<^sup>+" .
                 }
                 moreover note ll_disc
                 ultimately show ?thesis by (simp add: lowlink_set_def)
               qed               
               hence "\<delta> s ll \<in> ?L'" by auto
               with ll show ?thesis by simp
             qed
             hence "LowLink ?s w \<le> LowLink s u" 
               using Min_le_iff[of ?L'] s'.lowlink_set_not_empty w_disc s'.lowlink_set_finite
               by fastforce
             also from True u_disc w_disc finish have "LowLink s u < LowLink s w" by simp
             hence "Min (?L \<union> ?Lu) = LowLink s u" 
               using Min_Un[of ?L ?Lu] lowlink_set_finite lowlink_set_not_empty u_disc w_disc
               by simp
             hence "LowLink s u \<le> LowLink ?s w" 
               using Min_antimono[OF ll_sub_rev'] lowlink_set_finite s'.lowlink_set_not_empty w_disc
               by auto
             also from True u_disc finish * have "LowLink s u = \<zeta> ?s w" by simp
             finally show ?thesis ..
           qed
         next
           case False note all_False = this
           have "\<zeta> ?s w = \<zeta> s w"
           proof (cases "stack ?s = []")
             case True with ref_e show ?thesis by simp
           next
             case False with all_False have "w \<noteq> hd (stack ?s)" by simp
             with False ref_ne show ?thesis by simp
           qed
           also from finish have "\<zeta> s w = LowLink s w" using w_disc by simp
           also {
             fix v
             assume "v \<in> lowlink_set s u"
               and *: "v \<notin> lowlink_set s w"
             hence "v \<noteq> w" "w\<noteq>u" by (auto simp add: lowlink_set_def)
             have "v \<notin> lowlink_set ?s w"
             proof (rule notI)
               assume v: "v \<in> lowlink_set ?s w"
               hence e: "(v,w) \<in> E\<^sup>*" "(w,v) \<in> E\<^sup>*"
                 and v_disc: "v \<in> dom (discovered s)" by (auto simp add: lowlink_set_def)
               
               from v \<open>v\<noteq>w\<close> obtain p where p: "lowlink_path ?s w p v" by (auto simp add: lowlink_set_def)
               hence [simp]: "p\<noteq>[]" by (simp add: lowlink_path_def)
               
               from p have "hd p = w" by (auto simp add: lowlink_path_def path_hd)
               
               show False
               proof (cases "u \<in> set p")
                 case False hence "lowlink_path s w p v"
                   using p by (auto simp add: lowlink_path_def)
                 with e v_disc have "v \<in> lowlink_set s w" by (auto intro: lowlink_setI)
                 with * show False ..
               next
                 case True
                 then obtain i where i: "i < length p" "p!i = u"
                   by (metis in_set_conv_nth)
                 show "False"
                 proof (cases i)
                   case "0" with i have "hd p = u" by (simp add: hd_conv_nth)
                   with \<open>hd p = w\<close> \<open>w \<noteq> u\<close> show False by simp
                 next
                   case (Suc n) with i p have *: "(p!n,u) \<in> tree_edges s" "n < length p"
                     unfolding lowlink_path_def
                     by auto
                   with tree_edge_imp_discovered have "p!n \<in> dom (discovered s)" by auto
                   moreover from finish hd_in_set stack_not_finished have "u \<notin> dom (finished s)" by auto
                   with * have pn_n_fin: "p!n \<notin> dom (finished s)" by (metis tree_edge_impl_parenthesis)
                   moreover from * no_self_loop_in_tree have "p!n \<noteq> u" by blast
                   ultimately have "p!n \<in> set (stack ?s)" using stack_set_def finish by (cases "stack s") auto
                   hence s_ne: "stack ?s \<noteq> []" by auto
                   with all_False have "w \<noteq> hd (stack ?s)" by simp
                   from stack_is_tree_path finish obtain v0 where
                     "path (tree_edges s) v0 (rev (stack ?s)) u"
                     by auto
                   with s_ne have "(hd (stack ?s), u) \<in> tree_edges s" by (auto simp: neq_Nil_conv path_simps)
                   with * tree_eq_rule have **: "hd (stack ?s) = p!n" by simp
                   show ?thesis
                   proof (cases n)
                     case "0" with * have "hd p = p!n" by (simp add: hd_conv_nth)
                     with \<open>hd p = w\<close> ** have "w = hd (stack ?s)" by simp
                     with \<open>w\<noteq>hd (stack ?s)\<close> show False ..
                   next
                     case (Suc m) with * ** s'.lowlink_path_finished[OF p, where j=n] have 
                       "hd (stack ?s) \<in> dom (finished ?s)" by simp
                     with hd_in_set[OF s_ne] s'.stack_not_finished show ?thesis by blast
                   qed
                 qed
               qed
             qed
           } with ll_sub ll_sub_rev have "lowlink_set ?s w = lowlink_set s w" by auto
           hence "LowLink s w = LowLink ?s w" by simp
           finally show ?thesis .
         qed
       }
 
       with finish show ?case by (auto simp: pw_leof_iff)
     qed simp_all
   qed
 end end
 
 context Tarjan_invar begin context begin interpretation timing_syntax .
 
   lemmas lowlink_eq_LowLink =
     i_lowlink_eq_LowLink[THEN make_invar_thm, rule_format]
 
   lemma lowlink_eq_disc_iff_scc_root:
     assumes "v \<in> dom (finished s) \<or> (stack s \<noteq> [] \<and> v = hd (stack s) \<and> pending s `` {v} = {})"
     shows "\<zeta> s v = \<delta> s v \<longleftrightarrow> scc_root s v (scc_of E v)"
   proof -
     from assms have "v \<in> dom (discovered s)" using finished_discovered hd_in_set stack_discovered by blast
     hence "\<zeta> s v = LowLink s v" using lowlink_eq_LowLink by simp
     with LowLink_eq_disc_iff_scc_root[OF assms] show ?thesis by simp
   qed
 
   lemma nc_sccs_eq_reachable:
     assumes NC: "\<not> cond s"
     shows "reachable = \<Union>(sccs s)"
   proof
     from nc_finished_eq_reachable NC have [simp]: "reachable = dom (finished s)" by simp
     with sccs_finished show "\<Union>(sccs s) \<subseteq> reachable" by simp
 
     from NC have "stack s = []" by (simp add: cond_alt)
     with stacks_eq_iff have "tj_stack s = []" by simp
     with finished_ss_sccs_tj_stack show "reachable \<subseteq> \<Union>(sccs s)" by simp
   qed
 end end
 
 context Tarjan begin
   lemma tarjan_fin_nofail:
     assumes "pre_on_finish u s'"
     shows "nofail (tarjan_fin u s')"
   proof -
     from assms obtain s where s: "DFS_invar G tarjan_params s" "stack s \<noteq> []"  "u = hd (stack s)" "s' = finish u s"  "cond s" "pending s `` {u} = {}"
       by (auto simp: pre_on_finish_def)
     then interpret Tarjan_invar where s=s by simp
 
     from s hd_stack_in_tj_stack have "u \<in> set (tj_stack s')" by simp
 
     moreover from s tj_stack_distinct have "distinct (tj_stack s')" by simp
     moreover have "the (lowlink s' u) = the (discovered s' u) \<longleftrightarrow> scc_root s' u (scc_of E u)"
     proof -
       from s have "the (lowlink s' u) = the (discovered s' u) \<longleftrightarrow> the (lowlink s u) = the (discovered s u)" by simp
       also from s lowlink_eq_disc_iff_scc_root have "... \<longleftrightarrow> scc_root s u (scc_of E u)" by blast
       also from s scc_root_transfer'[where s'=s'] have "... \<longleftrightarrow> scc_root s' u (scc_of E u)" by simp
       finally show ?thesis .
     qed
     ultimately show ?thesis 
       unfolding tarjan_fin_def tj_stack_pop_def
       by simp
   qed
 
   sublocale DFS G tarjan_params
     by unfold_locales (simp_all add: tarjan_disc_def tarjan_back_def tarjan_fin_nofail)
 end
 
 interpretation tarjan: Tarjan_def for G .
 
 subsection \<open>Interface\<close>
 definition "tarjan G \<equiv> do {
   ASSERT (fb_graph G);
   s \<leftarrow> tarjan.it_dfs TYPE('a) G;
   RETURN (sccs s) }"
 
 definition "tarjan_spec G \<equiv> do {
   ASSERT (fb_graph G); 
   SPEC (\<lambda>sccs.  (\<forall>scc \<in> sccs. is_scc (g_E G) scc)
               \<and> \<Union>sccs = tarjan.reachable TYPE('a) G)}"
 
 lemma tarjan_correct:
   "tarjan G \<le> tarjan_spec G"
   unfolding tarjan_def tarjan_spec_def
 proof (refine_vcg le_ASSERTI order_trans[OF DFS.it_dfs_correct])
   assume "fb_graph G"
   then interpret fb_graph G .
   interpret Tarjan ..
   show "DFS G (tarjan.tarjan_params TYPE('b) G)" ..
 next
   fix s
   assume C: "DFS_invar G (tarjan.tarjan_params TYPE('b) G) s \<and> \<not> tarjan.cond TYPE('b) G s"
   then interpret Tarjan_invar G s by simp
 
   from sccs_are_sccs show "\<forall>scc\<in>sccs s. is_scc (g_E G) scc" .
   
   from nc_sccs_eq_reachable C show "\<Union>(sccs s) = tarjan.reachable TYPE('b) G" by simp
 qed
 
 end
diff --git a/thys/Dirichlet_Series/Dirichlet_Misc.thy b/thys/Dirichlet_Series/Dirichlet_Misc.thy
--- a/thys/Dirichlet_Series/Dirichlet_Misc.thy
+++ b/thys/Dirichlet_Series/Dirichlet_Misc.thy
@@ -1,158 +1,159 @@
 (*
     File:      Dirichlet_Misc.thy
     Author:    Manuel Eberl, TU München
 *)
 section \<open>Miscellaneous auxiliary facts\<close>
 theory Dirichlet_Misc
   imports 
     Main 
     "HOL-Number_Theory.Number_Theory"
 begin
 
 lemma
   fixes a k :: nat
   assumes "a > 1" "k > 0"
   shows geometric_sum_nat_aux: "(a - 1) * (\<Sum>i<k. a ^ i) = a ^ k - 1"
     and geometric_sum_nat_dvd: "a - 1 dvd a ^ k - 1"
     and geometric_sum_nat:     "(\<Sum>i<k. a ^ i) = (a ^ k - 1) div (a - 1)"
 proof -
   have "(real a - 1) * (\<Sum>i<k. real a ^ i) = real a ^ k - 1"
     using assms by (subst geometric_sum) auto
   also have "(real a - 1) * (\<Sum>i<k. real a ^ i) = real ((a - 1) * (\<Sum>i<k. a ^ i))" 
     using assms by (simp add: of_nat_diff)
   also have "real a ^ k - 1 = real (a ^ k - 1)" using assms by (subst of_nat_diff) auto
   finally show *: "(a - 1) * (\<Sum>i<k. a ^ i) = a ^ k - 1" by (subst (asm) of_nat_eq_iff)
   show "a - 1 dvd a ^ k - 1" by (subst * [symmetric]) simp
   from assms show "(\<Sum>i<k. a ^ i) = (a ^ k - 1) div (a - 1)" 
     by (subst * [symmetric]) simp
 qed
 
 lemma dvd_div_gt0: "d dvd n \<Longrightarrow> n > 0 \<Longrightarrow> n div d > (0::nat)"
   by (auto elim: dvdE)
 
 lemma Set_filter_insert: 
   "Set.filter P (insert x A) = (if P x then insert x (Set.filter P A) else Set.filter P A)"
   by (auto simp: Set.filter_def)
     
 lemma Set_filter_union: "Set.filter P (A \<union> B) = Set.filter P A \<union> Set.filter P B"
   by (auto simp: Set.filter_def)
 
 lemma Set_filter_empty [simp]: "Set.filter P {} = {}"
   by (auto simp: Set.filter_def)
     
 lemma Set_filter_image: "Set.filter P (f ` A) = f ` Set.filter (P \<circ> f) A"
   by (auto simp: Set.filter_def)
 
 lemma Set_filter_cong [cong]:
     "(\<And>x. x \<in> A \<Longrightarrow> P x \<longleftrightarrow> Q x) \<Longrightarrow> A = B \<Longrightarrow>  Set.filter P A = Set.filter Q B"
   by (auto simp: Set.filter_def)
     
 lemma finite_Set_filter: "finite A \<Longrightarrow> finite (Set.filter P A)"
   by (auto simp: Set.filter_def)
 
 lemma inj_on_insert': "(\<And>B. B \<in> A \<Longrightarrow> x \<notin> B) \<Longrightarrow> inj_on (insert x) A"
   by (auto simp: inj_on_def insert_eq_iff)
 
 lemma
   assumes "finite A" "A \<noteq> {}"
   shows   card_even_subset_aux: "card {B. B \<subseteq> A \<and> even (card B)} = 2 ^ (card A - 1)"
     and   card_odd_subset_aux:  "card {B. B \<subseteq> A \<and> odd (card B)} = 2 ^ (card A - 1)"
     and   card_even_odd_subset: "card {B. B \<subseteq> A \<and> even (card B)} = card {B. B \<subseteq> A \<and> odd (card B)}"
 proof -
   from assms have *: "2 * card (Set.filter (even \<circ> card) (Pow A)) = 2 ^ card A"
   proof (induction A rule: finite_ne_induct)
     case (singleton x)
     hence "Pow {x} = {{}, {x}}" by auto
     thus ?case by (simp add: Set_filter_insert)
   next
     case (insert x A)
     note fin = finite_subset[OF _ \<open>finite A\<close>]
     have "Pow (insert x A) = Pow A \<union> insert x ` Pow A" by (rule Pow_insert)
     have "Set.filter (even \<circ> card) (Pow (insert x A)) = 
             Set.filter (even \<circ> card) (Pow A) \<union> 
             insert x ` Set.filter (even \<circ> card \<circ> insert x) (Pow A)"
       unfolding Pow_insert Set_filter_union Set_filter_image by blast
     also have "Set.filter (even \<circ> card \<circ> insert x) (Pow A) = Set.filter (odd \<circ> card) (Pow A)"
       unfolding o_def
       by (intro Set_filter_cong refl, subst card_insert_disjoint) 
          (insert insert.hyps, auto dest: finite_subset)
     also have "card (Set.filter (even \<circ> card) (Pow A) \<union> insert x ` \<dots>) = 
                  card (Set.filter (even \<circ> card) (Pow A)) + card (insert x ` \<dots>)"
       (is "card (?A \<union> ?B) = _")
       by (intro card_Un_disjoint finite_Set_filter finite_imageI) (auto simp:  insert.hyps)
     also have "card ?B = card (Set.filter (odd \<circ> card) (Pow A))"
       using insert.hyps by (intro card_image inj_on_insert') auto
     also have "Set.filter (odd \<circ> card) (Pow A) = Pow A - Set.filter (even \<circ> card) (Pow A)"
       by auto
     also have "card \<dots> = card (Pow A) - card (Set.filter (even \<circ> card) (Pow A))"
       using insert.hyps by (subst card_Diff_subset) (auto simp: finite_Set_filter)
     also have "card (Set.filter (even \<circ> card) (Pow A)) + \<dots> = card (Pow A)"
       by (intro add_diff_inverse_nat, subst not_less, rule card_mono) (insert insert.hyps, auto)  
     also have "2 * \<dots> = 2 ^ card (insert x A)"
       using insert.hyps by (simp add: card_Pow)
     finally show ?case .
   qed
   from * show A: "card {B. B \<subseteq> A \<and> even (card B)} = 2 ^ (card A - 1)"
     by (cases "card A") (simp_all add: Set.filter_def)
 
   have "Set.filter (odd \<circ> card) (Pow A) = Pow A - Set.filter (even \<circ> card) (Pow A)" by auto
   also have "2 * card \<dots> = 2 * 2 ^ card A - 2 * card (Set.filter (even \<circ> card) (Pow A))"
     using assms by (subst card_Diff_subset) (auto intro!: finite_Set_filter simp: card_Pow)
   also note *
   also have "2 * 2 ^ card A - 2 ^ card A = (2 ^ card A :: nat)" by simp
   finally show B: "card {B. B \<subseteq> A \<and> odd (card B)} = 2 ^ (card A - 1)"
     by (cases "card A") (simp_all add: Set.filter_def)
 
   from A and B show "card {B. B \<subseteq> A \<and> even (card B)} = card {B. B \<subseteq> A \<and> odd (card B)}" by simp
 qed
   
 lemma bij_betw_prod_divisors_coprime:
   assumes "coprime a (b :: nat)"
   shows   "bij_betw (\<lambda>x. fst x * snd x) ({d. d dvd a} \<times> {d. d dvd b}) {k. k dvd a * b}"
   unfolding bij_betw_def
 proof
   from assms show "inj_on (\<lambda>x. fst x * snd x) ({d. d dvd a} \<times> {d. d dvd b})"
     by (auto simp: inj_on_def coprime_crossproduct_nat coprime_divisors)
   show "(\<lambda>x. fst x * snd x) ` ({d. d dvd a} \<times> {d. d dvd b}) = {k. k dvd a * b}"
   proof safe
     fix x assume "x dvd a * b"
-    from division_decomp[OF this] guess b' c' by (elim exE conjE)
+    then obtain b' c' where "x = b' * c'" "b' dvd a" "c' dvd b"
+      using division_decomp by blast
     thus "x \<in> (\<lambda>x. fst x * snd x) ` ({d. d dvd a} \<times> {d. d dvd b})" by force
   qed (insert assms, auto intro: mult_dvd_mono)
 qed
 
 lemma bij_betw_prime_power_divisors:
   assumes "prime (p :: nat)"
   shows   "bij_betw ((^) p) {..k} {d. d dvd p ^ k}"
   unfolding bij_betw_def
 proof 
   from assms have *: "p > 1" by (simp add: prime_gt_Suc_0_nat)
   show "inj_on ((^) p) {..k}" using assms
     by (auto simp: inj_on_def prime_gt_Suc_0_nat power_inject_exp[OF *])
   show "(^) p ` {..k} = {d. d dvd p ^ k}"
     using assms by (auto simp: le_imp_power_dvd divides_primepow_nat)
 qed
 
 lemma power_diff':
   assumes "m \<ge> n" "x \<noteq> 0"
   shows   "x ^ (m - n) = (x ^ m div x ^ n :: 'a :: unique_euclidean_semiring)"
 proof -
   from assms have "x ^ m = x ^ (m - n) * x ^ n"
     by (subst power_add [symmetric]) simp
   also from assms have "\<dots> div x ^ n = x ^ (m - n)" by simp
   finally show ?thesis ..
 qed
   
 lemma sum_divisors_coprime_mult:
   assumes "coprime a (b :: nat)"
   shows   "(\<Sum>d | d dvd a * b. f d) = (\<Sum>r | r dvd a. \<Sum>s | s dvd b. f (r * s))"
 proof -
   have "(\<Sum>r | r dvd a. \<Sum>s | s dvd b. f (r * s)) =
           (\<Sum>z\<in>{r. r dvd a} \<times> {s. s dvd b}. f (fst z * snd z))"
     by (subst sum.cartesian_product) (simp add: case_prod_unfold)
   also have "\<dots> = (\<Sum>d | d dvd a * b. f d)"
     by (intro sum.reindex_bij_betw bij_betw_prod_divisors_coprime assms)
   finally show ?thesis ..
 qed
 
 end
diff --git a/thys/E_Transcendental/E_Transcendental.thy b/thys/E_Transcendental/E_Transcendental.thy
--- a/thys/E_Transcendental/E_Transcendental.thy
+++ b/thys/E_Transcendental/E_Transcendental.thy
@@ -1,687 +1,687 @@
 (*
   File:       E_Transcendental.thy
   Author:     Manuel Eberl <eberlm@in.tum.de>
 
   A proof that e (Euler's number) is transcendental.
   Could possibly be extended to a transcendence proof for pi or
   the very general Lindemann-Weierstrass theorem.
 *)
 section \<open>Proof of the Transcendence of $e$\<close>
 theory E_Transcendental
   imports
     "HOL-Complex_Analysis.Complex_Analysis"
     "HOL-Number_Theory.Number_Theory"
     "HOL-Computational_Algebra.Polynomial"
 begin
 
 (* TODO: Lots of stuff to move to the distribution *)
   
 subsection \<open>Various auxiliary facts\<close>
 
 lemma fact_dvd_pochhammer:
   assumes "m \<le> n + 1"
   shows   "fact m dvd pochhammer (int n - int m + 1) m"
 proof -
   have "(real n gchoose m) * fact m = of_int (pochhammer (int n - int m + 1) m)"
     by (simp add: gbinomial_pochhammer' pochhammer_of_int [symmetric])
   also have "(real n gchoose m) * fact m = of_int (int (n choose m) * fact m)"
     by (simp add: binomial_gbinomial)
   finally have "int (n choose m) * fact m = pochhammer (int n - int m + 1) m"
     by (subst (asm) of_int_eq_iff)
   from this [symmetric] show ?thesis by simp
 qed
 
 lemma of_nat_eq_1_iff [simp]: "of_nat x = (1 :: 'a :: semiring_char_0) \<longleftrightarrow> x = 1"
   by (fact of_nat_eq_1_iff)
 
 lemma prime_elem_int_not_dvd_neg1_power:
   "prime_elem (p :: int) \<Longrightarrow> \<not>p dvd (-1) ^ n"
   by (rule notI, frule (1) prime_elem_dvd_power, cases "p \<ge> 0") (auto simp: prime_elem_def)
 
 lemma nat_fact [simp]: "nat (fact n) = fact n"
   by (subst of_nat_fact [symmetric]) (rule nat_int)
 
 lemma prime_dvd_fact_iff_int:
   "p dvd fact n \<longleftrightarrow> p \<le> int n" if "prime p"
   using that prime_dvd_fact_iff [of "nat \<bar>p\<bar>" n]
   by auto (simp add: prime_ge_0_int)
 
 lemma filterlim_minus_nat_at_top:
   "filterlim (\<lambda>n. n - k :: nat) at_top at_top"
 proof -
   have "sequentially = filtermap (\<lambda>n. n + k) at_top"
     by (auto simp: filter_eq_iff eventually_filtermap)
   also have "filterlim (\<lambda>n. n - k :: nat) at_top \<dots>"
     by (simp add: filterlim_filtermap filterlim_ident)
   finally show ?thesis .
 qed
 
 lemma power_over_fact_tendsto_0:
   "(\<lambda>n. (x :: real) ^ n / fact n) \<longlonglongrightarrow> 0"
   using summable_exp[of x] by (intro summable_LIMSEQ_zero) (simp add: sums_iff field_simps)
 
 lemma power_over_fact_tendsto_0':
   "(\<lambda>n. c * (x :: real) ^ n / fact n) \<longlonglongrightarrow> 0"
   using tendsto_mult[OF tendsto_const[of c] power_over_fact_tendsto_0[of x]] by simp
 
 
 subsection \<open>Lifting integer polynomials\<close>
 
 lift_definition of_int_poly :: "int poly \<Rightarrow> 'a :: comm_ring_1 poly" is "\<lambda>g x. of_int (g x)"
   by (auto elim: eventually_mono)
 
 lemma coeff_of_int_poly [simp]: "coeff (of_int_poly p) n = of_int (coeff p n)"
   by transfer' simp
 
 lemma of_int_poly_0 [simp]: "of_int_poly 0 = 0"
   by transfer (simp add: fun_eq_iff)
 
 lemma of_int_poly_pCons [simp]: "of_int_poly (pCons c p) = pCons (of_int c) (of_int_poly p)"
   by transfer' (simp add: fun_eq_iff split: nat.splits)
 
 lemma of_int_poly_smult [simp]: "of_int_poly (smult c p) = smult (of_int c) (of_int_poly p)"
   by transfer simp
 
 lemma of_int_poly_1 [simp]: "of_int_poly 1 = 1"
   by (simp add: one_pCons)
 
 lemma of_int_poly_add [simp]: "of_int_poly (p + q) = of_int_poly p + of_int_poly q"
   by transfer' (simp add: fun_eq_iff)
 
 lemma of_int_poly_mult [simp]: "of_int_poly (p * q) = (of_int_poly p * of_int_poly q)"
   by (induction p) simp_all
 
 lemma of_int_poly_sum [simp]: "of_int_poly (sum f A) = sum (\<lambda>x. of_int_poly (f x)) A"
   by (induction A rule: infinite_finite_induct) simp_all
 
 lemma of_int_poly_prod [simp]: "of_int_poly (prod f A) = prod (\<lambda>x. of_int_poly (f x)) A"
   by (induction A rule: infinite_finite_induct) simp_all
 
 lemma of_int_poly_power [simp]: "of_int_poly (p ^ n) = of_int_poly p ^ n"
   by (induction n) simp_all
 
 lemma of_int_poly_monom [simp]: "of_int_poly (monom c n) = monom (of_int c) n"
   by transfer (simp add: fun_eq_iff)
 
 lemma poly_of_int_poly [simp]: "poly (of_int_poly p) (of_int x) = of_int (poly p x)"
   by (induction p) simp_all
 
 lemma poly_of_int_poly_of_nat [simp]: "poly (of_int_poly p) (of_nat x) = of_int (poly p (int x))"
   by (induction p) simp_all
 
 lemma poly_of_int_poly_0 [simp]: "poly (of_int_poly p) 0 = of_int (poly p 0)"
   by (induction p) simp_all
 
 lemma poly_of_int_poly_1 [simp]: "poly (of_int_poly p) 1 = of_int (poly p 1)"
   by (induction p) simp_all
 
 lemma poly_of_int_poly_of_real [simp]:
     "poly (of_int_poly p) (of_real x) = of_real (poly (of_int_poly p) x)"
   by (induction p) simp_all
 
 lemma of_int_poly_eq_iff [simp]:
   "of_int_poly p = (of_int_poly q :: 'a :: {comm_ring_1, ring_char_0} poly) \<longleftrightarrow> p = q"
   by (simp add: poly_eq_iff)
 
 lemma of_int_poly_eq_0_iff [simp]:
   "of_int_poly p = (0 :: 'a :: {comm_ring_1, ring_char_0} poly) \<longleftrightarrow> p = 0"
   using of_int_poly_eq_iff[of p 0] by (simp del: of_int_poly_eq_iff)
 
 lemma degree_of_int_poly [simp]:
   "degree (of_int_poly p :: 'a :: {comm_ring_1, ring_char_0} poly) = degree p"
   by (simp add: degree_def)
 
 lemma pderiv_of_int_poly [simp]: "pderiv (of_int_poly p) = of_int_poly (pderiv p)"
   by (induction p) (simp_all add: pderiv_pCons)
 
 lemma higher_pderiv_of_int_poly [simp]:
   "(pderiv ^^ n) (of_int_poly p) = of_int_poly ((pderiv ^^ n) p)"
   by (induction n) simp_all
 
 lemma int_polyE:
   assumes "\<And>n. coeff (p :: 'a :: {comm_ring_1, ring_char_0} poly) n \<in> \<int>"
   obtains p' where "p = of_int_poly p'"
 proof -
   from assms have "\<forall>n. \<exists>c. coeff p n = of_int c" by (auto simp: Ints_def)
   hence "\<exists>c. \<forall>n. of_int (c n) = coeff p n" by (simp add: choice_iff eq_commute)
   then obtain c where c: "of_int (c n) = coeff p n" for n by blast
   have [simp]: "coeff (Abs_poly c) = c"
   proof (rule poly.Abs_poly_inverse, clarify)
     have "eventually (\<lambda>n. n > degree p) at_top" by (rule eventually_gt_at_top)
     hence "eventually (\<lambda>n. coeff p n = 0) at_top"
       by eventually_elim (simp add: coeff_eq_0)
     thus "eventually (\<lambda>n. c n = 0) cofinite"
       by (simp add: c [symmetric] cofinite_eq_sequentially)
   qed
   have "p = of_int_poly (Abs_poly c)"
     by (rule poly_eqI) (simp add: c)
   thus ?thesis by (rule that)
 qed
 
 
 subsection \<open>General facts about polynomials\<close>
 
 lemma pderiv_power:
   "pderiv (p ^ n) = smult (of_nat n) (p ^ (n - 1) * pderiv p)"
   by (cases n) (simp_all add: pderiv_power_Suc del: power_Suc)
 
 lemma degree_prod_sum_eq:
   "(\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> 0) \<Longrightarrow>
      degree (prod f A :: 'a :: idom poly) = (\<Sum>x\<in>A. degree (f x))"
   by (induction A rule: infinite_finite_induct) (auto simp: degree_mult_eq)
 
 lemma pderiv_monom:
   "pderiv (monom c n) = monom (of_nat n * c) (n - 1)"
   by (cases n)
      (simp_all add: monom_altdef pderiv_power_Suc pderiv_smult pderiv_pCons mult_ac del: power_Suc)
 
 lemma power_poly_const [simp]: "[:c:] ^ n = [:c ^ n:]"
   by (induction n) (simp_all add: power_commutes)
 
 lemma monom_power: "monom c n ^ k = monom (c ^ k) (n * k)"
   by (induction k) (simp_all add: mult_monom)
 
 lemma coeff_higher_pderiv:
   "coeff ((pderiv ^^ m) f) n = pochhammer (of_nat (Suc n)) m * coeff f (n + m)"
   by (induction m arbitrary: n) (simp_all add: coeff_pderiv pochhammer_rec algebra_simps)
 
 lemma higher_pderiv_add: "(pderiv ^^ n) (p + q) = (pderiv ^^ n) p + (pderiv ^^ n) q"
   by (induction n arbitrary: p q) (simp_all del: funpow.simps add: funpow_Suc_right pderiv_add)
 
 lemma higher_pderiv_smult: "(pderiv ^^ n) (smult c p) = smult c ((pderiv ^^ n) p)"
   by (induction n arbitrary: p) (simp_all del: funpow.simps add: funpow_Suc_right pderiv_smult)
 
 lemma higher_pderiv_0 [simp]: "(pderiv ^^ n) 0 = 0"
   by (induction n) simp_all
 
 lemma higher_pderiv_monom:
   "m \<le> n + 1 \<Longrightarrow> (pderiv ^^ m) (monom c n) = monom (pochhammer (int n - int m + 1) m * c) (n - m)"
 proof (induction m arbitrary: c n)
   case (Suc m)
   thus ?case
     by (cases n)
        (simp_all del: funpow.simps add: funpow_Suc_right pderiv_monom pochhammer_rec' Suc.IH)
 qed simp_all
 
 lemma higher_pderiv_monom_eq_zero:
   "m > n + 1 \<Longrightarrow> (pderiv ^^ m) (monom c n) = 0"
 proof (induction m arbitrary: c n)
   case (Suc m)
   thus ?case
     by (cases n)
        (simp_all del: funpow.simps add: funpow_Suc_right pderiv_monom pochhammer_rec' Suc.IH)
 qed simp_all
 
 lemma higher_pderiv_sum: "(pderiv ^^ n) (sum f A) = (\<Sum>x\<in>A. (pderiv ^^ n) (f x))"
   by (induction A rule: infinite_finite_induct) (simp_all add: higher_pderiv_add)
 
 lemma fact_dvd_higher_pderiv:
   "[:fact n :: int:] dvd (pderiv ^^ n) p"
 proof -
   have "[:fact n:] dvd (pderiv ^^ n) (monom c k)" for c :: int and k :: nat
     by (cases "n \<le> k + 1")
        (simp_all add: higher_pderiv_monom higher_pderiv_monom_eq_zero
           fact_dvd_pochhammer const_poly_dvd_iff)
   hence "[:fact n:] dvd (pderiv ^^ n) (\<Sum>k\<le>degree p. monom (coeff p k) k)"
     by (simp_all add: higher_pderiv_sum dvd_sum)
   thus ?thesis by (simp add: poly_as_sum_of_monoms)
 qed
 
 lemma fact_dvd_poly_higher_pderiv_aux:
   "(fact n :: int) dvd poly ((pderiv ^^ n) p) x"
 proof -
   have "[:fact n:] dvd (pderiv ^^ n) p" by (rule fact_dvd_higher_pderiv)
   then obtain q where "(pderiv ^^ n) p = [:fact n:] * q" by (erule dvdE)
   thus ?thesis by simp
 qed
 
 lemma fact_dvd_poly_higher_pderiv_aux':
   "m \<le> n \<Longrightarrow> (fact m :: int) dvd poly ((pderiv ^^ n) p) x"
   by (rule dvd_trans[OF fact_dvd fact_dvd_poly_higher_pderiv_aux]) simp_all
 
 lemma algebraicE':
   assumes "algebraic (x :: 'a :: field_char_0)"
   obtains p where "p \<noteq> 0" "poly (of_int_poly p) x = 0"
 proof -
   from assms obtain q where "\<And>i. coeff q i \<in> \<int>" "q \<noteq> 0" "poly q x = 0"
     by (erule algebraicE)
   moreover from this(1) obtain q' where "q = of_int_poly q'" by (erule int_polyE)
   ultimately show ?thesis by (intro that[of q']) simp_all
 qed
 
 lemma algebraicE'_nonzero:
   assumes "algebraic (x :: 'a :: field_char_0)" "x \<noteq> 0"
   obtains p where "p \<noteq> 0" "coeff p 0 \<noteq> 0" "poly (of_int_poly p) x = 0"
 proof -
   from assms(1) obtain p where p: "p \<noteq> 0" "poly (of_int_poly p) x = 0"
     by (erule algebraicE')
   define n :: nat where "n = order 0 p"
   have "monom 1 n dvd p" by (simp add: monom_1_dvd_iff p n_def)
   then obtain q where q: "p = monom 1 n * q" by (erule dvdE)
   from p have "q \<noteq> 0" "poly (of_int_poly q) x = 0" by (auto simp: q poly_monom assms(2))
   moreover from this have "order 0 p = n + order 0 q" by (simp add: q order_mult)
   hence "order 0 q = 0" by (simp add: n_def)
   with \<open>q \<noteq> 0\<close> have "poly q 0 \<noteq> 0" by (simp add: order_root)
   ultimately show ?thesis using that[of q] by (auto simp: poly_0_coeff_0)
 qed
 
 lemma algebraic_of_real_iff [simp]:
    "algebraic (of_real x :: 'a :: {real_algebra_1,field_char_0}) \<longleftrightarrow> algebraic x"
 proof
   assume "algebraic (of_real x :: 'a)"
   then obtain p where "p \<noteq> 0" "poly (of_int_poly p) (of_real x :: 'a) = 0"
     by (erule algebraicE')
   hence "(of_int_poly p :: real poly) \<noteq> 0"
         "poly (of_int_poly p :: real poly) x = 0" by simp_all
   thus "algebraic x" by (intro algebraicI[of "of_int_poly p"]) simp_all
 next
   assume "algebraic x"
   then obtain p where "p \<noteq> 0" "poly (of_int_poly p) x = 0" by (erule algebraicE')
   hence "of_int_poly p \<noteq> (0 :: 'a poly)" "poly (of_int_poly p) (of_real x :: 'a) = 0"
     by simp_all
   thus "algebraic (of_real x)" by (intro algebraicI[of "of_int_poly p"]) simp_all
 qed
 
 
 subsection \<open>Main proof\<close>
 
 lemma lindemann_weierstrass_integral:
   fixes u :: complex and f :: "complex poly"
   defines "df \<equiv> \<lambda>n. (pderiv ^^ n) f"
   defines "m \<equiv> degree f"
   defines "I \<equiv> \<lambda>f u. exp u * (\<Sum>j\<le>degree f. poly ((pderiv ^^ j) f) 0) -
                        (\<Sum>j\<le>degree f. poly ((pderiv ^^ j) f) u)"
   shows "((\<lambda>t. exp (u - t) * poly f t) has_contour_integral I f u) (linepath 0 u)"
 proof -
   note [derivative_intros] =
     exp_scaleR_has_vector_derivative_right vector_diff_chain_within
   let ?g = "\<lambda>t. 1 - t" and ?f = "\<lambda>t. -exp (t *\<^sub>R u)"
   have "((\<lambda>t. exp ((1 - t) *\<^sub>R u) * u) has_integral
           (?f \<circ> ?g) 1 - (?f \<circ> ?g) 0) {0..1}"
     by (rule fundamental_theorem_of_calculus)
        (auto intro!: derivative_eq_intros simp del: o_apply)
   hence aux_integral: "((\<lambda>t. exp (u - t *\<^sub>R u) * u) has_integral exp u - 1) {0..1}"
     by (simp add: algebra_simps)
 
   have "((\<lambda>t. exp (u - t *\<^sub>R u) * u * poly f (t *\<^sub>R u)) has_integral I f u) {0..1}"
     unfolding df_def m_def
   proof (induction "degree f" arbitrary: f)
     case 0
     then obtain c where c: "f = [:c:]" by (auto elim: degree_eq_zeroE)
     have "((\<lambda>t. c * (exp (u - t *\<^sub>R u) * u)) has_integral c * (exp u - 1)) {0..1}"
       using aux_integral by (rule has_integral_mult_right)
     with c show ?case by (simp add: algebra_simps I_def)
   next
     case (Suc m)
     define df where "df = (\<lambda>j. (pderiv ^^ j) f)"
     show ?case
     proof (rule integration_by_parts[OF bounded_bilinear_mult])
       fix t :: real assume "t \<in> {0..1}"
       have "((?f \<circ> ?g) has_vector_derivative exp (u - t *\<^sub>R u) * u) (at t)"
         by (auto intro!: derivative_eq_intros simp: algebra_simps simp del: o_apply)
       thus "((\<lambda>t. -exp (u - t *\<^sub>R u)) has_vector_derivative exp (u - t *\<^sub>R u) * u) (at t)"
         by (simp add: algebra_simps o_def)
     next
       fix t :: real assume "t \<in> {0..1}"
       have "(poly f \<circ> (\<lambda>t. t *\<^sub>R u) has_vector_derivative u * poly (pderiv f) (t *\<^sub>R u)) (at t)"
         by (rule field_vector_diff_chain_at) (auto intro!: derivative_eq_intros)
       thus "((\<lambda>t. poly f (t *\<^sub>R u)) has_vector_derivative u * poly (pderiv f) (t *\<^sub>R u)) (at t)"
         by (simp add: o_def)
     next
       from Suc(2) have m: "m = degree (pderiv f)" by (simp add: degree_pderiv)
       from Suc(1)[OF this] this
         have "((\<lambda>t. exp (u - t *\<^sub>R u) * u * poly (pderiv f) (t *\<^sub>R u)) has_integral
                 exp u * (\<Sum>j=0..m. poly (df (Suc j)) 0) - (\<Sum>j=0..m. poly (df (Suc j)) u)) {0..1}"
         by (simp add: df_def funpow_swap1 atMost_atLeast0 I_def)
       also have "(\<Sum>j=0..m. poly (df (Suc j)) 0) = (\<Sum>j=Suc 0..Suc m. poly (df j) 0)"
         by (rule sum.shift_bounds_cl_Suc_ivl [symmetric])
       also have "\<dots> = (\<Sum>j=0..Suc m. poly (df j) 0) - poly f 0"
         by (subst (2) sum.atLeast_Suc_atMost) (simp_all add: df_def)
       also have "(\<Sum>j=0..m. poly (df (Suc j)) u) = (\<Sum>j=Suc 0..Suc m. poly (df j) u)"
         by (rule sum.shift_bounds_cl_Suc_ivl [symmetric])
       also have "\<dots> = (\<Sum>j=0..Suc m. poly (df j) u) - poly f u"
         by (subst (2) sum.atLeast_Suc_atMost) (simp_all add: df_def)
       finally have "((\<lambda>t. - (exp (u - t *\<^sub>R u) * u * poly (pderiv f) (t *\<^sub>R u))) has_integral
                         -(exp u * ((\<Sum>j = 0..Suc m. poly (df j) 0) - poly f 0) -
                                   ((\<Sum>j = 0..Suc m. poly (df j) u) - poly f u))) {0..1}"
           (is "(_ has_integral ?I) _") by (rule has_integral_neg)
       also have "?I = - exp (u - 1 *\<^sub>R u) * poly f (1 *\<^sub>R u) -
                        - exp (u - 0 *\<^sub>R u) * poly f (0 *\<^sub>R u) - I f u"
         by (simp add: df_def algebra_simps Suc(2) atMost_atLeast0 I_def)
       finally show "((\<lambda>t. - exp (u - t *\<^sub>R u) * (u * poly (pderiv f) (t *\<^sub>R u)))
                         has_integral \<dots>) {0..1}" by (simp add: algebra_simps)
     qed (auto intro!: continuous_intros)
   qed
   thus ?thesis by (simp add: has_contour_integral_linepath algebra_simps)
 qed
 
 locale lindemann_weierstrass_aux =
   fixes f :: "complex poly"
 begin
 
 definition I :: "complex \<Rightarrow> complex" where
   "I u = exp u * (\<Sum>j\<le>degree f. poly ((pderiv ^^ j) f) 0) -
                        (\<Sum>j\<le>degree f. poly ((pderiv ^^ j) f) u)"
 
 lemma lindemann_weierstrass_integral_bound:
   fixes u :: complex
   assumes "C \<ge> 0" "\<And>t. t \<in> closed_segment 0 u \<Longrightarrow> norm (poly f t) \<le> C"
   shows "norm (I u) \<le> norm u * exp (norm u) * C"
 proof -
   have "I u = contour_integral (linepath 0 u) (\<lambda>t. exp (u - t) * poly f t)"
     using contour_integral_unique[OF lindemann_weierstrass_integral[of u f]] unfolding I_def ..
   also have "norm \<dots> \<le> exp (norm u) * C * norm (u - 0)"
   proof (intro contour_integral_bound_linepath)
     fix t assume t: "t \<in> closed_segment 0 u"
     then obtain s where s: "s \<in> {0..1}" "t = s *\<^sub>R u" by (auto simp: closed_segment_def)
     hence "s * norm u \<le> 1 * norm u" by (intro mult_right_mono) simp_all
     with s have norm_t: "norm t \<le> norm u" by auto
 
     from s have "Re u - Re t = (1 - s) * Re u" by (simp add: algebra_simps)
     also have "\<dots> \<le> norm u"
     proof (cases "Re u \<ge> 0")
       case True
       with \<open>s \<in> {0..1}\<close> have "(1 - s) * Re u \<le> 1 * Re u" by (intro mult_right_mono) simp_all
       also have "Re u \<le> norm u" by (rule complex_Re_le_cmod)
       finally show ?thesis by simp
     next
       case False
       with \<open>s \<in> {0..1}\<close> have "(1 - s) * Re u \<le> 0" by (intro mult_nonneg_nonpos) simp_all
       also have "\<dots> \<le> norm u" by simp
       finally show ?thesis .
     qed
     finally have "exp (Re u - Re t) \<le> exp (norm u)" by simp
 
     hence "exp (Re u - Re t) * norm (poly f t) \<le> exp (norm u) * C"
       using assms t norm_t by (intro mult_mono) simp_all
     thus "norm (exp (u - t) * poly f t) \<le> exp (norm u) * C"
       by (simp add: norm_mult exp_diff norm_divide field_simps)
   qed (auto simp: intro!: mult_nonneg_nonneg contour_integrable_continuous_linepath
                           continuous_intros assms)
   finally show ?thesis by (simp add: mult_ac)
 qed
 
 end
 
 lemma poly_higher_pderiv_aux1:
   fixes c :: "'a :: idom"
   assumes "k < n"
   shows   "poly ((pderiv ^^ k) ([:-c, 1:] ^ n * p)) c = 0"
   using assms
 proof (induction k arbitrary: n p)
   case (Suc k n p)
   from Suc.prems obtain n' where n: "n = Suc n'" by (cases n) auto
   from Suc.prems n have "k < n'" by simp
   have "(pderiv ^^ Suc k) ([:- c, 1:] ^ n * p) =
           (pderiv ^^ k) ([:- c, 1:] ^ n * pderiv p + [:- c, 1:] ^ n' * smult (of_nat n) p)"
     by (simp only: funpow_Suc_right o_def pderiv_mult n pderiv_power_Suc,
         simp only: n [symmetric]) (simp add: pderiv_pCons mult_ac)
   also from Suc.prems \<open>k < n'\<close> have "poly \<dots> c = 0"
     by (simp add: higher_pderiv_add Suc.IH del: mult_smult_right)
   finally show ?case .
 qed simp_all
 
 lemma poly_higher_pderiv_aux1':
   fixes c :: "'a :: idom"
   assumes "k < n" "[:-c, 1:] ^ n dvd p"
   shows   "poly ((pderiv ^^ k) p) c = 0"
 proof -
   from assms(2) obtain q where "p = [:-c, 1:] ^ n * q" by (elim dvdE)
   also from assms(1) have "poly ((pderiv ^^ k) \<dots>) c = 0"
     by (rule poly_higher_pderiv_aux1)
   finally show ?thesis .
 qed
 
 lemma poly_higher_pderiv_aux2:
   fixes c :: "'a :: {idom, semiring_char_0}"
   shows   "poly ((pderiv ^^ n) ([:-c, 1:] ^ n * p)) c = fact n * poly p c"
 proof (induction n arbitrary: p)
   case (Suc n p)
   have "(pderiv ^^ Suc n) ([:- c, 1:] ^ Suc n * p) =
           (pderiv ^^ n) ([:- c, 1:] ^ Suc n * pderiv p) +
             (pderiv ^^ n) ([:- c, 1:] ^ n * smult (1 + of_nat n) p)"
     by (simp del: funpow.simps power_Suc add: funpow_Suc_right pderiv_mult
           pderiv_power_Suc higher_pderiv_add pderiv_pCons mult_ac)
   also have "[:- c, 1:] ^ Suc n * pderiv p = [:- c, 1:] ^ n * ([:-c, 1:] * pderiv p)"
     by (simp add: algebra_simps)
   finally show ?case by (simp add: Suc.IH del: mult_smult_right power_Suc)
 qed simp_all
 
 lemma poly_higher_pderiv_aux3:
   fixes c :: "'a :: {idom,semiring_char_0}"
   assumes "k \<ge> n"
   shows   "\<exists>q. poly ((pderiv ^^ k) ([:-c, 1:] ^ n * p)) c = fact n * poly q c"
   using assms
 proof (induction k arbitrary: n p)
   case (Suc k n p)
   show ?case
   proof (cases n)
     fix n' assume n: "n = Suc n'"
     have "poly ((pderiv ^^ Suc k) ([:-c, 1:] ^ n * p)) c =
             poly ((pderiv ^^ k) ([:- c, 1:] ^ n * pderiv p)) c +
               of_nat n * poly ((pderiv ^^ k) ([:-c, 1:] ^ n' * p)) c"
       by (simp del: funpow.simps power_Suc add: funpow_Suc_right pderiv_power_Suc
             pderiv_mult n pderiv_pCons higher_pderiv_add mult_ac higher_pderiv_smult)
     also have "\<exists>q1. poly ((pderiv ^^ k) ([:-c, 1:] ^ n * pderiv p)) c = fact n * poly q1 c"
       using Suc.prems Suc.IH[of n "pderiv p"]
       by (cases "n' = k") (auto simp: n poly_higher_pderiv_aux1 simp del: power_Suc of_nat_Suc
                                 intro: exI[of _ "0::'a poly"])
     then obtain q1
       where "poly ((pderiv ^^ k) ([:-c, 1:] ^ n * pderiv p)) c = fact n * poly q1 c" ..
     also from Suc.IH[of n' p] Suc.prems obtain q2
       where "poly ((pderiv ^^ k) ([:-c, 1:] ^ n' * p)) c = fact n' * poly q2 c"
       by (auto simp: n)
     finally show ?case by (auto intro!: exI[of _ "q1 + q2"] simp: n algebra_simps)
   qed auto
 qed auto
 
 lemma poly_higher_pderiv_aux3':
   fixes c :: "'a :: {idom, semiring_char_0}"
   assumes "k \<ge> n" "[:-c, 1:] ^ n dvd p"
   shows   "fact n dvd poly ((pderiv ^^ k) p) c"
 proof -
   from assms(2) obtain q where "p = [:-c, 1:] ^ n * q" by (elim dvdE)
   with poly_higher_pderiv_aux3[OF assms(1), of c q] show ?thesis by auto
 qed
 
 lemma e_transcendental_aux_bound:
   obtains C where "C \<ge> 0"
     "\<And>x. x \<in> closed_segment 0 (of_nat n) \<Longrightarrow>
         norm (\<Prod>k\<in>{1..n}. (x - of_nat k :: complex)) \<le> C"
 proof -
   let ?f = "\<lambda>x. (\<Prod>k\<in>{1..n}. (x - of_nat k))"
   define C where "C = max 0 (Sup (cmod ` ?f ` closed_segment 0 (of_nat n)))"
   have "C \<ge> 0" by (simp add: C_def)
   moreover {
     fix x :: complex assume "x \<in> closed_segment 0 (of_nat n)"
     hence "cmod (?f x) \<le> Sup ((cmod \<circ> ?f) ` closed_segment 0 (of_nat n))"
       by (intro cSup_upper bounded_imp_bdd_above compact_imp_bounded compact_continuous_image)
          (auto intro!: continuous_intros)
     also have "\<dots> \<le> C" by (simp add: C_def image_comp)
     finally have "cmod (?f x) \<le> C" .
   }
   ultimately show ?thesis by (rule that)
 qed
 
 
 theorem e_transcendental_complex: "\<not> algebraic (exp 1 :: complex)"
 proof
   assume "algebraic (exp 1 :: complex)"
   then obtain q :: "int poly"
     where q: "q \<noteq> 0" "coeff q 0 \<noteq> 0" "poly (of_int_poly q) (exp 1 :: complex) = 0"
       by (elim algebraicE'_nonzero) simp_all
 
   define n :: nat where "n = degree q"
   from q have [simp]: "n \<noteq> 0" by (intro notI) (auto simp: n_def elim!: degree_eq_zeroE)
   define qmax where "qmax = Max (insert 0 (abs ` set (coeffs q)))"
   have qmax_nonneg [simp]: "qmax \<ge> 0" by (simp add: qmax_def)
   have qmax: "\<bar>coeff q k\<bar> \<le> qmax" for k
     by (cases "k \<le> degree q")
        (auto simp: qmax_def coeff_eq_0 coeffs_def simp del: upt_Suc intro: Max.coboundedI)
   obtain C where C: "C \<ge> 0"
     "\<And>x. x \<in> closed_segment 0 (of_nat n) \<Longrightarrow> norm (\<Prod>k\<in>{1..n}. (x - of_nat k :: complex)) \<le> C"
     by (erule e_transcendental_aux_bound)
   define E where "E = (1 + real n) * real_of_int qmax * real n * exp (real n) / real n"
   define F where "F = real n * C"
 
   have ineq: "fact (p - 1) \<le> E * F ^ p" if p: "prime p" "p > n" "p > abs (coeff q 0)" for p
   proof -
     from p(1) have p_pos: "p > 0" by (simp add: prime_gt_0_nat)
     define f :: "int poly"
       where "f = monom 1 (p - 1) * (\<Prod>k\<in>{1..n}. [:-of_nat k, 1:] ^ p)"
     have poly_f: "poly (of_int_poly f) x = x ^ (p - 1) * (\<Prod>k\<in>{1..n}. (x - of_nat k)) ^ p"
       for x :: complex by (simp add: f_def poly_prod poly_monom prod_power_distrib)
     define m :: nat where "m = degree f"
     from p_pos have m: "m = (n + 1) * p - 1"
       by (simp add: m_def f_def degree_mult_eq degree_monom_eq degree_prod_sum_eq degree_linear_power)
 
     define M :: int where "M = (- 1) ^ (n * p) * fact n ^ p"
     with p have p_not_dvd_M: "\<not>int p dvd M"
       by (auto simp: M_def prime_elem_int_not_dvd_neg1_power prime_dvd_power_iff
             prime_gt_0_nat prime_dvd_fact_iff_int prime_dvd_mult_iff)
 
     interpret lindemann_weierstrass_aux "of_int_poly f" .
     define J :: complex where "J = (\<Sum>k\<le>n. of_int (coeff q k) * I (of_nat k))"
     define idxs where "idxs = ({..n}\<times>{..m}) - {(0, p - 1)}"
 
     hence "J = (\<Sum>k\<le>n. of_int (coeff q k) * exp 1 ^ k) * (\<Sum>n\<le>m. of_int (poly ((pderiv ^^ n) f) 0)) -
                  of_int (\<Sum>k\<le>n. \<Sum>n\<le>m. coeff q k * poly ((pderiv ^^ n) f) (int k))"
       by (simp add: J_def I_def algebra_simps sum_subtractf sum_distrib_left m_def
                     exp_of_nat_mult [symmetric])
     also have "(\<Sum>k\<le>n. of_int (coeff q k) * exp 1 ^ k) = poly (of_int_poly q) (exp 1 :: complex)"
       by (simp add: poly_altdef n_def)
     also have "\<dots> = 0" by fact
     finally have "J = of_int (-(\<Sum>(k,n)\<in>{..n}\<times>{..m}. coeff q k * poly ((pderiv ^^ n) f) (int k)))"
       by (simp add: sum.cartesian_product)
     also have "{..n}\<times>{..m} = insert (0, p - 1) idxs" by (auto simp: m idxs_def)
     also have "-(\<Sum>(k,n)\<in>\<dots>. coeff q k * poly ((pderiv ^^ n) f) (int k)) =
        - (coeff q 0 * poly ((pderiv ^^ (p - 1)) f) 0) -
          (\<Sum>(k, n)\<in>idxs. coeff q k * poly ((pderiv ^^ n) f) (of_nat k))"
       by (subst sum.insert) (simp_all add: idxs_def)
     also have "coeff q 0 * poly ((pderiv ^^ (p - 1)) f) 0 = coeff q 0 * M * fact (p - 1)"
     proof -
       have "f = [:-0, 1:] ^ (p - 1) * (\<Prod>k = 1..n. [:- of_nat k, 1:] ^ p)"
         by (simp add: f_def monom_altdef)
       also have "poly ((pderiv ^^ (p - 1)) \<dots>) 0 =
                    fact (p - 1) * poly (\<Prod>k = 1..n. [:- of_nat k, 1:] ^ p) 0"
         by (rule poly_higher_pderiv_aux2)
       also have "poly (\<Prod>k = 1..n. [:- of_nat k :: int, 1:] ^ p) 0 = (-1)^(n*p) * fact n ^ p"
         by (induction n) (simp_all add: prod.nat_ivl_Suc' power_mult_distrib mult_ac
                             power_minus' power_add del: of_nat_Suc)
       finally show ?thesis by (simp add: mult_ac M_def)
     qed
-    also have "\<exists>N. (\<Sum>(k, n)\<in>idxs. coeff q k * poly ((pderiv ^^ n) f) (int k)) = fact p * N"
+    also obtain N where "(\<Sum>(k, n)\<in>idxs. coeff q k * poly ((pderiv ^^ n) f) (int k)) = fact p * N"
     proof -
       have "\<forall>(k, n)\<in>idxs. fact p dvd poly ((pderiv ^^ n) f) (of_nat k)"
       proof clarify
         fix k j assume idxs: "(k, j) \<in> idxs"
         then consider "k = 0" "j < p - 1" | "k = 0" "j > p - 1" | "k \<noteq> 0" "j < p" | "k \<noteq> 0" "j \<ge> p"
           by (fastforce simp: idxs_def)
         thus "fact p dvd poly ((pderiv ^^ j) f) (of_nat k)"
         proof cases
           case 1
           thus ?thesis
             by (simp add: f_def poly_higher_pderiv_aux1' monom_altdef)
         next
           case 2
           thus ?thesis
             by (simp add: f_def poly_higher_pderiv_aux3' monom_altdef fact_dvd_poly_higher_pderiv_aux')
         next
           case 3
           thus ?thesis unfolding f_def
             by (subst poly_higher_pderiv_aux1'[of _ p])
                (insert idxs, auto simp: idxs_def intro!: dvd_mult)
         next
           case 4
           thus ?thesis unfolding f_def
             by (intro poly_higher_pderiv_aux3') (insert idxs, auto intro!: dvd_mult simp: idxs_def)
         qed
       qed
       hence "fact p dvd (\<Sum>(k, n)\<in>idxs. coeff q k * poly ((pderiv ^^ n) f) (int k))"
         by (auto intro!: dvd_sum dvd_mult simp del: of_int_fact)
-      thus ?thesis by (blast elim: dvdE)
+      with that show thesis
+        by blast
     qed
-    then guess N .. note N = this
     also from p have "- (coeff q 0 * M * fact (p - 1)) - fact p * N =
                         - fact (p - 1) * (coeff q 0 * M + p * N)"
       by (subst fact_reduce[of p]) (simp_all add: algebra_simps)
     finally have J: "J = -of_int (fact (p - 1) * (coeff q 0 * M + p * N))" by simp
 
     from p q(2) have "\<not>p dvd coeff q 0 * M + p * N"
       by (auto simp: dvd_add_left_iff p_not_dvd_M prime_dvd_fact_iff_int prime_dvd_mult_iff
                dest: dvd_imp_le_int)
     hence "coeff q 0 * M + p * N \<noteq> 0" by (intro notI) simp_all
     hence "abs (coeff q 0 * M + p * N) \<ge> 1" by simp
     hence "norm (of_int (coeff q 0 * M + p * N) :: complex) \<ge> 1" by (simp only: norm_of_int)
     hence "fact (p - 1) * \<dots> \<ge> fact (p - 1) * 1" by (intro mult_left_mono) simp_all
     hence J_lower: "norm J \<ge> fact (p - 1)" unfolding J norm_minus_cancel of_int_mult of_int_fact
       by (simp add: norm_mult)
 
     have "norm J \<le> (\<Sum>k\<le>n. norm (of_int (coeff q k) * I (of_nat k)))"
       unfolding J_def by (rule norm_sum)
     also have "\<dots> \<le> (\<Sum>k\<le>n. of_int qmax * (real n * exp (real n) * real n ^ (p - 1) * C ^ p))"
     proof (intro sum_mono)
       fix k assume k: "k \<in> {..n}"
       have "n > 0" by (rule ccontr) simp
       {
         fix x :: complex assume x: "x \<in> closed_segment 0 (of_nat k)"
         then obtain t where t: "t \<ge> 0" "t \<le> 1" "x = of_real t * of_nat k"
           by (auto simp: closed_segment_def scaleR_conv_of_real)
         hence "norm x = t * real k" by (simp add: norm_mult)
         also from \<open>t \<le> 1\<close> k have *: "\<dots> \<le> 1 * real n" by (intro mult_mono) simp_all
         finally have x': "norm x \<le> real n" by simp
         from t \<open>n > 0\<close> * have x'': "x \<in> closed_segment 0 (of_nat n)"
           by (auto simp: closed_segment_def scaleR_conv_of_real field_simps
                    intro!: exI[of _ "t * real k / real n"] )
         have "norm (poly (of_int_poly f) x) =
                 norm x ^ (p - 1) * cmod (\<Prod>i = 1..n. x - i) ^ p"
           by (simp add: poly_f norm_mult norm_power)
         also from x x' x'' have "\<dots> \<le> of_nat n ^ (p - 1) * C ^ p"
           by (intro mult_mono C power_mono) simp_all
         finally have "norm (poly (of_int_poly f) x) \<le> real n ^ (p - 1) * C ^ p" .
       } note A = this
 
       have "norm (I (of_nat k)) \<le>
                       cmod (of_nat k) * exp (cmod (of_nat k)) * (of_nat n ^ (p - 1) * C ^ p)"
         by (intro lindemann_weierstrass_integral_bound[OF _ A]
               C mult_nonneg_nonneg zero_le_power) auto
       also have "\<dots> \<le> cmod (of_nat n) * exp (cmod (of_nat n)) * (of_nat n ^ (p - 1) * C ^ p)"
         using k by (intro mult_mono zero_le_power mult_nonneg_nonneg C) simp_all
       finally show "cmod (of_int (coeff q k) * I (of_nat k)) \<le>
                       of_int qmax * (real n * exp (real n) * real n ^ (p - 1) * C ^ p)"
         unfolding norm_mult
         by (intro mult_mono) (simp_all add: qmax of_int_abs [symmetric] del: of_int_abs)
     qed
     also have "\<dots> = E * F ^ p" using p_pos
       by (simp add: power_diff power_mult_distrib E_def F_def)
     finally show "fact (p - 1) \<le> E * F ^ p" using J_lower by linarith
   qed
 
   have "(\<lambda>n. E * F * F ^ (n - 1) / fact (n - 1)) \<longlonglongrightarrow> 0" (is ?P)
     by (intro filterlim_compose[OF power_over_fact_tendsto_0' filterlim_minus_nat_at_top])
   also have "?P \<longleftrightarrow> (\<lambda>n. E * F ^ n / fact (n - 1)) \<longlonglongrightarrow> 0"
     by (intro filterlim_cong refl eventually_mono[OF eventually_gt_at_top[of "0::nat"]])
        (auto simp: power_Suc [symmetric] simp del: power_Suc)
   finally have "eventually (\<lambda>n. E * F ^ n / fact (n - 1) < 1) at_top"
     by (rule order_tendstoD) simp_all
   hence "eventually (\<lambda>n. E * F ^ n < fact (n - 1)) at_top" by eventually_elim simp
   then obtain P where P: "\<And>n. n \<ge> P \<Longrightarrow> E * F ^ n < fact (n - 1)"
     by (auto simp: eventually_at_top_linorder)
 
   have "\<exists>p. prime p \<and> p > Max {nat (abs (coeff q 0)), n, P}" by (rule bigger_prime)
   then obtain p where "prime p" "p > Max {nat (abs (coeff q 0)), n, P}" by blast
   hence "int p > abs (coeff q 0)" "p > n" "p \<ge> P" by auto
   with ineq[of p] \<open>prime p\<close> have "fact (p - 1) \<le> E * F ^ p" by simp
   moreover from \<open>p \<ge> P\<close> have "fact (p - 1) > E * F ^ p" by (rule P)
   ultimately show False by linarith
 qed
 
 corollary e_transcendental_real: "\<not> algebraic (exp 1 :: real)"
 proof -
   have "\<not>algebraic (exp 1 :: complex)" by (rule e_transcendental_complex)
   also have "(exp 1 :: complex) = of_real (exp 1)" using exp_of_real[of 1] by simp
   also have "algebraic \<dots> \<longleftrightarrow> algebraic (exp 1 :: real)" by simp
   finally show ?thesis .
 qed
 
 end
diff --git a/thys/Error_Function/Error_Function.thy b/thys/Error_Function/Error_Function.thy
--- a/thys/Error_Function/Error_Function.thy
+++ b/thys/Error_Function/Error_Function.thy
@@ -1,655 +1,657 @@
 (*
   File:     Error_Function.thy
   Author:   Manuel Eberl, TU München
 
   The complex and real error function (most results are on the real error function though)
 *)
 section \<open>The complex and real error function\<close>
 theory Error_Function
   imports "HOL-Complex_Analysis.Complex_Analysis" "HOL-Library.Landau_Symbols"
 begin
 
 subsection \<open>Auxiliary Facts\<close>
 
 lemma tendsto_sandwich_mono:
   assumes "(\<lambda>n. f (real n)) \<longlonglongrightarrow> (c::real)"
   assumes "eventually (\<lambda>x. \<forall>y z. x \<le> y \<and> y \<le> z \<longrightarrow> f y \<le> f z) at_top"
   shows   "(f \<longlongrightarrow> c) at_top"
 proof (rule tendsto_sandwich)
   from assms(2) obtain C where C: "\<And>x y. C \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
     by (auto simp: eventually_at_top_linorder)
   show "eventually (\<lambda>x. f (real (nat \<lfloor>x\<rfloor>)) \<le> f x) at_top"
     using eventually_gt_at_top[of "0::real"] eventually_gt_at_top[of "C+1::real"]
     by eventually_elim (rule C, linarith+)
   show "eventually (\<lambda>x. f (real (Suc (nat \<lfloor>x\<rfloor>))) \<ge> f x) at_top"
     using eventually_gt_at_top[of "0::real"] eventually_gt_at_top[of "C+1::real"]
     by eventually_elim (rule C, linarith+)
 qed (auto intro!: filterlim_compose[OF assms(1)]
                   filterlim_compose[OF filterlim_nat_sequentially]
                   filterlim_compose[OF filterlim_Suc] filterlim_floor_sequentially
           simp del: of_nat_Suc)
 
 lemma tendsto_sandwich_antimono:
   assumes "(\<lambda>n. f (real n)) \<longlonglongrightarrow> (c::real)"
   assumes "eventually (\<lambda>x. \<forall>y z. x \<le> y \<and> y \<le> z \<longrightarrow> f y \<ge> f z) at_top"
   shows   "(f \<longlongrightarrow> c) at_top"
 proof (rule tendsto_sandwich)
   from assms(2) obtain C where C: "\<And>x y. C \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<ge> f y"
     by (auto simp: eventually_at_top_linorder)
   show "eventually (\<lambda>x. f (real (nat \<lfloor>x\<rfloor>)) \<ge> f x) at_top"
     using eventually_gt_at_top[of "0::real"] eventually_gt_at_top[of "C+1::real"]
     by eventually_elim (rule C, linarith+)
   show "eventually (\<lambda>x. f (real (Suc (nat \<lfloor>x\<rfloor>))) \<le> f x) at_top"
     using eventually_gt_at_top[of "0::real"] eventually_gt_at_top[of "C+1::real"]
     by eventually_elim (rule C, linarith+)
 qed (auto intro!: filterlim_compose[OF assms(1)]
                   filterlim_compose[OF filterlim_nat_sequentially]
                   filterlim_compose[OF filterlim_Suc] filterlim_floor_sequentially
           simp del: of_nat_Suc)
 
 lemma has_bochner_integral_completion [intro]:
   fixes f :: "'a \<Rightarrow> 'b::{banach, second_countable_topology}"
   shows "has_bochner_integral M f I \<Longrightarrow> has_bochner_integral (completion M) f I"
   by (auto simp: has_bochner_integral_iff integrable_completion integral_completion 
                  borel_measurable_integrable)
 
 lemma has_bochner_integral_imp_has_integral:
   "has_bochner_integral lebesgue (\<lambda>x. indicator S x *\<^sub>R f x) I \<Longrightarrow> 
      (f has_integral (I :: 'b :: euclidean_space)) S"
   using has_integral_set_lebesgue[of S f] 
   by (simp add: has_bochner_integral_iff set_integrable_def set_lebesgue_integral_def) 
     
 lemma has_bochner_integral_imp_has_integral':
   "has_bochner_integral lborel (\<lambda>x. indicator S x *\<^sub>R f x) I \<Longrightarrow> 
      (f has_integral (I :: 'b :: euclidean_space)) S"
   by (intro has_bochner_integral_imp_has_integral has_bochner_integral_completion)
 
 lemma has_bochner_integral_erf_aux:
   "has_bochner_integral lborel (\<lambda>x. indicator {0..} x *\<^sub>R exp (- x\<^sup>2)) (sqrt pi / 2)"
 proof -
   let ?pI = "\<lambda>f. (\<integral>\<^sup>+s. f (s::real) * indicator {0..} s \<partial>lborel)"
   let ?gauss = "\<lambda>x. exp (- x\<^sup>2)"
   let ?I = "indicator {0<..} :: real \<Rightarrow> real"
   let ?ff= "\<lambda>x s. x * exp (- x\<^sup>2 * (1 + s\<^sup>2)) :: real"
   have *: "?pI ?gauss = (\<integral>\<^sup>+x. ?gauss x * ?I x \<partial>lborel)"
     by (intro nn_integral_cong_AE AE_I[where N="{0}"]) (auto split: split_indicator)
 
   have "?pI ?gauss * ?pI ?gauss = (\<integral>\<^sup>+x. \<integral>\<^sup>+s. ?gauss x * ?gauss s * ?I s * ?I x \<partial>lborel \<partial>lborel)"
     by (auto simp: nn_integral_cmult[symmetric] nn_integral_multc[symmetric] * 
                    ennreal_mult[symmetric] intro!: nn_integral_cong split: split_indicator)
   also have "\<dots> = (\<integral>\<^sup>+x. \<integral>\<^sup>+s. ?ff x s * ?I s * ?I x \<partial>lborel \<partial>lborel)"
   proof (rule nn_integral_cong, cases)
     fix x :: real assume "x \<noteq> 0"
     then show "(\<integral>\<^sup>+s. ?gauss x * ?gauss s * ?I s * ?I x \<partial>lborel) =
                  (\<integral>\<^sup>+s. ?ff x s * ?I s * ?I x \<partial>lborel)"
       by (subst nn_integral_real_affine[where t="0" and c="x"])
          (auto simp: mult_exp_exp nn_integral_cmult[symmetric] field_simps zero_less_mult_iff ennreal_mult[symmetric]
                intro!: nn_integral_cong split: split_indicator)
   qed simp
   also have "... = \<integral>\<^sup>+s. \<integral>\<^sup>+x. ?ff x s * ?I s * ?I x \<partial>lborel \<partial>lborel"
     by (rule lborel_pair.Fubini'[symmetric]) auto
   also have "... = ?pI (\<lambda>s. ?pI (\<lambda>x. ?ff x s))"
     by (rule nn_integral_cong_AE)
        (auto intro!: nn_integral_cong_AE AE_I[where N="{0}"] split: split_indicator_asm)
   also have "\<dots> = ?pI (\<lambda>s. ennreal (1 / (2 * (1 + s\<^sup>2))))"
   proof (intro nn_integral_cong ennreal_mult_right_cong)
     fix s :: real show "?pI (\<lambda>x. ?ff x s) = ennreal (1 / (2 * (1 + s\<^sup>2)))"
     proof (subst nn_integral_FTC_atLeast)
       have "((\<lambda>a. - (exp (- ((1 + s\<^sup>2) * a\<^sup>2)) / (2 + 2 * s\<^sup>2))) \<longlongrightarrow> (- (0 / (2 + 2 * s\<^sup>2)))) at_top"
         by (intro tendsto_intros filterlim_compose[OF exp_at_bot]
                   filterlim_compose[OF filterlim_uminus_at_bot_at_top]
                   filterlim_tendsto_pos_mult_at_top)
            (auto intro!: filterlim_at_top_mult_at_top[OF filterlim_ident filterlim_ident]
                  simp: add_pos_nonneg  power2_eq_square add_nonneg_eq_0_iff)
       then show "((\<lambda>a. - (exp (- a\<^sup>2 - s\<^sup>2 * a\<^sup>2) / (2 + 2 * s\<^sup>2))) \<longlongrightarrow> 0) at_top"
         by (simp add: field_simps)
     qed (auto intro!: derivative_eq_intros simp: field_simps add_nonneg_eq_0_iff)
   qed
   also have "... = ennreal (pi / 4)"
   proof (subst nn_integral_FTC_atLeast)
     show "((\<lambda>a. arctan a / 2) \<longlongrightarrow> (pi / 2) / 2 ) at_top"
       by (intro tendsto_intros) (simp_all add: tendsto_arctan_at_top)
   qed (auto intro!: derivative_eq_intros simp: add_nonneg_eq_0_iff field_simps power2_eq_square)
   finally have "?pI ?gauss^2 = pi / 4"
     by (simp add: power2_eq_square)
   then have "?pI ?gauss = sqrt (pi / 4)"
     using power_eq_iff_eq_base[of 2 "enn2real (?pI ?gauss)" "sqrt (pi / 4)"]
     by (cases "?pI ?gauss") (auto simp: power2_eq_square ennreal_mult[symmetric] ennreal_top_mult)
   also have "?pI ?gauss = (\<integral>\<^sup>+x. indicator {0..} x *\<^sub>R exp (- x\<^sup>2) \<partial>lborel)"
     by (intro nn_integral_cong) (simp split: split_indicator)
   also have "sqrt (pi / 4) = sqrt pi / 2"
     by (simp add: real_sqrt_divide)
   finally show ?thesis
     by (rule has_bochner_integral_nn_integral[rotated 3])
        auto
 qed
 
 lemma has_integral_erf_aux: "((\<lambda>t::real. exp (-t\<^sup>2)) has_integral (sqrt pi / 2)) {0..}"
   by (intro has_bochner_integral_imp_has_integral' has_bochner_integral_erf_aux)
 
 lemma contour_integrable_on_linepath_neg_exp_squared [simp, intro]:
   "(\<lambda>t. exp (-(t^2))) contour_integrable_on linepath 0 z"
   by (auto intro!: contour_integrable_continuous_linepath continuous_intros)
 
 lemma holomorphic_on_chain:
   "g holomorphic_on t \<Longrightarrow> f holomorphic_on s \<Longrightarrow> f ` s \<subseteq> t \<Longrightarrow> 
     (\<lambda>x. g (f x)) holomorphic_on s"
   using holomorphic_on_compose_gen[of f s g t] by (simp add: o_def)
     
 lemma holomorphic_on_chain_UNIV:
   "g holomorphic_on UNIV \<Longrightarrow> f holomorphic_on s\<Longrightarrow> 
     (\<lambda>x. g (f x)) holomorphic_on s"
   using holomorphic_on_compose_gen[of f s g UNIV] by (simp add: o_def)
 
 lemmas holomorphic_on_exp' [holomorphic_intros] = 
   holomorphic_on_exp [THEN holomorphic_on_chain_UNIV]
 
 lemma leibniz_rule_field_derivative_real:
   fixes f::"'a::{real_normed_field, banach} \<Rightarrow> real \<Rightarrow> 'a"
   assumes fx: "\<And>x t. x \<in> U \<Longrightarrow> t \<in> {a..b} \<Longrightarrow> ((\<lambda>x. f x t) has_field_derivative fx x t) (at x within U)"
   assumes integrable_f2: "\<And>x. x \<in> U \<Longrightarrow> (f x) integrable_on {a..b}"
   assumes cont_fx: "continuous_on (U \<times> {a..b}) (\<lambda>(x, t). fx x t)"
   assumes U: "x0 \<in> U" "convex U"
   shows "((\<lambda>x. integral {a..b} (f x)) has_field_derivative integral {a..b} (fx x0)) (at x0 within U)"    
   using leibniz_rule_field_derivative[of U a b f fx x0] assms by simp
 
 lemma has_vector_derivative_linepath_within [derivative_intros]:
   assumes [derivative_intros]: 
     "(f has_vector_derivative f') (at x within S)" "(g has_vector_derivative g') (at x within S)"
     "(h has_real_derivative h') (at x within S)"
   shows "((\<lambda>x. linepath (f x) (g x) (h x)) has_vector_derivative 
            (1 - h x) *\<^sub>R f' + h x *\<^sub>R g' - h' *\<^sub>R (f x - g x)) (at x within S)"
   unfolding linepath_def [abs_def]
   by (auto intro!: derivative_eq_intros simp: field_simps scaleR_diff_right)
     
 lemma has_field_derivative_linepath_within [derivative_intros]:
   assumes [derivative_intros]: 
     "(f has_field_derivative f') (at x within S)" "(g has_field_derivative g') (at x within S)"
     "(h has_real_derivative h') (at x within S)"
   shows "((\<lambda>x. linepath (f x) (g x) (h x)) has_field_derivative 
            (1 - h x) *\<^sub>R f' + h x *\<^sub>R g' - h' *\<^sub>R (f x - g x)) (at x within S)"
   unfolding linepath_def [abs_def]
   by (auto intro!: derivative_eq_intros simp: field_simps scaleR_diff_right)
 
 lemma continuous_on_linepath' [continuous_intros]:
   assumes [continuous_intros]: "continuous_on A f" "continuous_on A g" "continuous_on A h"
   shows   "continuous_on A (\<lambda>x. linepath (f x) (g x) (h x))"
   using assms unfolding linepath_def by (auto intro!: continuous_intros)
     
 lemma contour_integral_has_field_derivative:
   assumes A: "open A" "convex A" "a \<in> A" "z \<in> A"
   assumes integrable: "\<And>z. z \<in> A \<Longrightarrow> f contour_integrable_on linepath a z"
   assumes holo: "f holomorphic_on A"
   shows   "((\<lambda>z. contour_integral (linepath a z) f) has_field_derivative f z) (at z within B)"
 proof -
   have "(f has_field_derivative deriv f z) (at z)" if "z \<in> A" for z
     using that assms by (auto intro!: holomorphic_derivI)
   note [derivative_intros] = DERIV_chain2[OF this]
   note [continuous_intros] = 
     continuous_on_compose2[OF holomorphic_on_imp_continuous_on [OF holo]]
     continuous_on_compose2[OF holomorphic_on_imp_continuous_on [OF holomorphic_deriv[OF holo]]]
   have [derivative_intros]:
       "((\<lambda>x. linepath a x t) has_field_derivative of_real t) (at x within A)" for t x
     by (auto simp: linepath_def scaleR_conv_of_real intro!: derivative_eq_intros)
  
   have *: "linepath a b t \<in> A" if "a \<in> A" "b \<in> A" "t \<in> {0..1}" for a b t
     using that linepath_in_convex_hull[of a A b t] \<open>convex A\<close> by (simp add: hull_same)
     
   have "((\<lambda>z. integral {0..1} (\<lambda>x. f (linepath a z x)) * (z - a)) has_field_derivative 
       integral {0..1} (\<lambda>t. deriv f (linepath a z t) * of_real t) * (z - a) +
       integral {0..1} (\<lambda>x. f (linepath a z x))) (at z within A)" 
       (is "(_ has_field_derivative ?I) _")
     by (rule derivative_eq_intros leibniz_rule_field_derivative_real)+
        (insert assms,
         auto intro!: derivative_eq_intros leibniz_rule_field_derivative_real
                      integrable_continuous_real continuous_intros 
              simp:   split_beta scaleR_conv_of_real *)
   also have "(\<lambda>z. integral {0..1} (\<lambda>x. f (linepath a z x)) * (z - a)) = 
                (\<lambda>z. contour_integral (linepath a z) f)"
     by (simp add: contour_integral_integral)
   also have "?I = integral {0..1} (\<lambda>x. deriv f (linepath a z x) * of_real x * (z - a) + 
                      f (linepath a z x))" (is "_ = integral _ ?g")
     by (subst integral_mult_left [symmetric], subst integral_add [symmetric])
        (insert assms, auto intro!: integrable_continuous_real continuous_intros simp: *)
   also have "(?g has_integral of_real 1 * f (linepath a z 1) - of_real 0 * f (linepath a z 0)) {0..1}"
     using * A
     by (intro fundamental_theorem_of_calculus)
        (auto intro!: derivative_eq_intros has_vector_derivative_real_field 
              simp: linepath_def scaleR_conv_of_real)
   hence "integral {0..1} ?g = f (linepath a z 1)" by (simp add: has_integral_iff)
   also have "linepath a z 1 = z" by (simp add: linepath_def)
   also from \<open>z \<in> A\<close> and \<open>open A\<close> have "at z within A = at z" by (rule at_within_open)
   finally show ?thesis by (rule DERIV_subset) simp_all
 qed
 
 
 subsection \<open>Definition of the error function\<close>
 
 definition erf_coeffs :: "nat \<Rightarrow> real" where
   "erf_coeffs n = 
      (if odd n then 2 / sqrt pi * (-1) ^ (n div 2) / (of_nat n * fact (n div 2)) 
       else 0)"
 
 lemma summable_erf:
   fixes z :: "'a :: {real_normed_div_algebra, banach}"
   shows "summable (\<lambda>n. of_real (erf_coeffs n) * z ^ n)"
 proof -
   define b where "b = (\<lambda>n. 2 / sqrt pi * (if odd n then inverse (fact (n div 2)) else 0))"
   show ?thesis
   proof (rule summable_comparison_test[OF exI[of _ 1]], clarify)
     fix n :: nat assume n: "n \<ge> 1"
     hence "norm (of_real (erf_coeffs n) * z ^ n) \<le> b n * norm z ^ n"
       unfolding norm_mult norm_power erf_coeffs_def b_def
       by (intro mult_right_mono) (auto simp: field_simps norm_divide abs_mult)
     thus "norm (of_real (erf_coeffs n) * z ^ n) \<le> b n * norm z ^ n"
       by (simp add: mult_ac)
   next
     have "summable (\<lambda>n. (norm z * 2 / sqrt pi) * (inverse (fact n) * norm z ^ (2*n)))" 
       (is "summable ?c") unfolding power_mult by (intro summable_mult summable_exp)
     also have "?c = (\<lambda>n. b (2*n+1) * norm z ^ (2*n+1))"
       unfolding b_def by (auto simp: fun_eq_iff b_def)
     also have "summable \<dots> \<longleftrightarrow> summable (\<lambda>n. b n * norm z ^ n)"
       using summable_mono_reindex [of "\<lambda>n. 2*n+1"]
       by (intro summable_mono_reindex [of "\<lambda>n. 2*n+1"]) 
          (auto elim!: oddE simp: strict_mono_def b_def)
     finally show \<dots> .
   qed
 qed
   
 definition erf :: "('a :: {real_normed_field, banach}) \<Rightarrow> 'a" where
   "erf z = (\<Sum>n. of_real (erf_coeffs n) * z ^ n)"
 
 lemma erf_converges: "(\<lambda>n. of_real (erf_coeffs n) * z ^ n) sums erf z"
   using summable_erf by (simp add: sums_iff erf_def)
 
 lemma erf_0 [simp]: "erf 0 = 0"
   unfolding erf_def powser_zero by (simp add: erf_coeffs_def)
 
 lemma erf_minus [simp]: "erf (-z) = - erf z"
   unfolding erf_def
   by (subst suminf_minus [OF summable_erf, symmetric], rule suminf_cong)
      (simp_all add: erf_coeffs_def)
 
 lemma erf_of_real [simp]: "erf (of_real x) = of_real (erf x)"
   unfolding erf_def using summable_erf[of x]
   by (subst suminf_of_real) (simp_all add: summable_erf)
     
 lemma of_real_erf_numeral [simp]: "of_real (erf (numeral n)) = erf (numeral n)"
   by (simp only: erf_of_real [symmetric] of_real_numeral)
 
 lemma of_real_erf_1 [simp]: "of_real (erf 1) = erf 1"
   by (simp only: erf_of_real [symmetric] of_real_1)
 
 
 lemma erf_has_field_derivative:
   "(erf has_field_derivative of_real (2 / sqrt pi) * exp (-(z^2))) (at z within A)"
 proof -
     define a' where "a' = (\<lambda>n. 2 / sqrt pi *
      (if even n then (- 1) ^ (n div 2) / fact (n div 2) else 0))"
 
   have "(erf has_field_derivative
            (\<Sum>n. diffs (\<lambda>n. of_real (erf_coeffs n)) n * z ^ n)) (at z)"
     using summable_erf unfolding erf_def by (rule termdiffs_strong_converges_everywhere)
   also have "diffs (\<lambda>n. of_real (erf_coeffs n)) = (\<lambda>n. of_real (a' n) :: 'a)"
     by (simp add: erf_coeffs_def a'_def diffs_def fun_eq_iff del: of_nat_Suc)
   hence "(\<Sum>n. diffs (\<lambda>n. of_real (erf_coeffs n)) n * z ^ n) = 
            (\<Sum>n. of_real (a' n) * z ^ n)" by simp
   also have "\<dots> = (\<Sum>n. of_real (a' (2*n)) * z ^ (2*n))"
     by (intro suminf_mono_reindex [symmetric]) (auto simp: strict_mono_def a'_def elim!: evenE)
   also have "(\<lambda>n. of_real (a' (2*n)) * z ^ (2*n)) = 
                (\<lambda>n. of_real (2 / sqrt pi) * (inverse (fact n) * (-(z^2))^n))"
     by (simp add: fun_eq_iff power_mult [symmetric] a'_def field_simps power_minus')
   also have "suminf \<dots> = of_real (2 / sqrt pi) * exp (-(z^2))"
     by (subst suminf_mult, intro summable_exp) 
        (auto simp: field_simps scaleR_conv_of_real exp_def)
   finally show ?thesis by (rule DERIV_subset) simp_all
 qed
 
 lemmas erf_has_field_derivative' [derivative_intros] =
   erf_has_field_derivative [THEN DERIV_chain2]
   
 lemma erf_continuous_on: "continuous_on A erf"
   by (rule DERIV_continuous_on erf_has_field_derivative)+
 
 lemma continuous_on_compose2_UNIV:
   "continuous_on UNIV g \<Longrightarrow> continuous_on s f \<Longrightarrow> continuous_on s (\<lambda>x. g (f x))"
   by (rule continuous_on_compose2[of UNIV g s f]) simp_all
     
 lemmas erf_continuous_on' [continuous_intros] = 
   erf_continuous_on [THEN continuous_on_compose2_UNIV]
 
 lemma erf_continuous [continuous_intros]: "continuous (at x within A) erf"
   by (rule continuous_within_subset[OF _ subset_UNIV])
      (insert erf_continuous_on[of UNIV], auto simp: continuous_on_eq_continuous_at)
 
 lemmas erf_continuous' [continuous_intros] = 
   continuous_within_compose2[OF _ erf_continuous]
   
 lemmas tendsto_erf [tendsto_intros] = isCont_tendsto_compose[OF erf_continuous]
 
 lemma erf_cnj [simp]: "erf (cnj z) = cnj (erf z)"
 proof -
   interpret bounded_linear cnj by (rule bounded_linear_cnj)
   from suminf[OF summable_erf] show ?thesis by (simp add: erf_def erf_coeffs_def)
 qed
 
 
 lemma integral_exp_minus_squared_real:
   assumes "a \<le> b"
   shows   "((\<lambda>t. exp (-(t^2))) has_integral (sqrt pi / 2 * (erf b - erf a))) {a..b}"
 proof -
   have "((\<lambda>t. exp (-(t^2))) has_integral (sqrt pi / 2 * erf b - sqrt pi / 2 * erf a)) {a..b}"
     using assms
     by (intro fundamental_theorem_of_calculus)
        (auto intro!: derivative_eq_intros 
              simp: has_field_derivative_iff_has_vector_derivative [symmetric])
   thus ?thesis by (simp add: field_simps)
 qed
 
 lemma erf_real_altdef_nonneg:
   "x \<ge> 0 \<Longrightarrow> erf (x::real) = 2 / sqrt pi * integral {0..x} (\<lambda>t. exp (-(t^2)))"
   using integral_exp_minus_squared_real[of 0 x]
   by (simp add: has_integral_iff field_simps)
     
 lemma erf_real_altdef_nonpos:
   "x \<le> 0 \<Longrightarrow> erf (x::real) = -2 / sqrt pi * integral {0..-x} (\<lambda>t. exp (-(t^2)))"
   using erf_real_altdef_nonneg[of "-x"] by simp
 
 lemma less_imp_erf_real_less:
   assumes "a < (b::real)"
   shows   "erf a < erf b"
 proof -
   from assms have "\<exists>z. z > a \<and> z < b \<and> erf b - erf a = (b - a) * (2 / sqrt pi * exp (- z\<^sup>2))"
     by (intro MVT2) (auto intro!: derivative_eq_intros simp: field_simps)
-  then guess z by (elim exE conjE) note z = this
-  note z(3)
+  then obtain z where z: "a < z" "z < b"
+    and erf: "erf b - erf a = (b - a) * (2 / sqrt pi * exp (- z\<^sup>2))"
+    by blast
+  note erf
   also from assms have "(b - a) * (2 / sqrt pi * exp (- z\<^sup>2)) > 0"
     by (intro mult_pos_pos divide_pos_pos) simp_all
   finally show ?thesis by simp
 qed
   
 lemma le_imp_erf_real_le: "a \<le> (b::real) \<Longrightarrow> erf a \<le> erf b"
   by (cases "a < b") (auto dest: less_imp_erf_real_less)
   
 lemma erf_real_less_cancel [simp]: "(erf (a :: real) < erf b) \<longleftrightarrow> a < b"
   using less_imp_erf_real_less[of a b] less_imp_erf_real_less[of b a]
   by (cases a b rule: linorder_cases) simp_all
 
 lemma erf_real_eq_iff [simp]: "erf (a::real) = erf b \<longleftrightarrow> a = b"
   by (cases a b rule: linorder_cases) (auto dest: less_imp_erf_real_less)
     
 lemma erf_real_le_cancel [simp]: "(erf (a :: real) \<le> erf b) \<longleftrightarrow> a \<le> b"
   by (cases a b rule: linorder_cases) (auto simp: less_eq_real_def)
     
 lemma inj_on_erf_real [intro]: "inj_on (erf :: real \<Rightarrow> real) A"
   by (auto simp: inj_on_def)
     
 lemma strict_mono_erf_real [intro]: "strict_mono (erf :: real \<Rightarrow> real)"
   by (auto simp: strict_mono_def)
     
 lemma mono_erf_real [intro]: "mono (erf :: real \<Rightarrow> real)"
   by (auto simp: mono_def)
 
 lemma erf_real_ge_0_iff [simp]: "erf (x::real) \<ge> 0 \<longleftrightarrow> x \<ge> 0"
   using erf_real_le_cancel[of 0 x] unfolding erf_0 .
 
 lemma erf_real_le_0_iff [simp]: "erf (x::real) \<le> 0 \<longleftrightarrow> x \<le> 0"
   using erf_real_le_cancel[of x 0] unfolding erf_0 .
     
 lemma erf_real_gt_0_iff [simp]: "erf (x::real) > 0 \<longleftrightarrow> x > 0"
   using erf_real_less_cancel[of 0 x] unfolding erf_0 .
 
 lemma erf_real_less_0_iff [simp]: "erf (x::real) < 0 \<longleftrightarrow> x < 0"
   using erf_real_less_cancel[of x 0] unfolding erf_0 .
     
 
 
 lemma erf_at_top [tendsto_intros]: "((erf :: real \<Rightarrow> real) \<longlongrightarrow> 1) at_top"
 proof -
   have *: "(\<Union>n. {0..real n}) = {0..}" by (auto intro!: real_nat_ceiling_ge)
   let ?f = "\<lambda>t::real. exp (-t\<^sup>2)"
   have "(\<lambda>n. set_lebesgue_integral lborel {0..real n} ?f)
           \<longlonglongrightarrow> set_lebesgue_integral lborel (\<Union>n. {0..real n}) ?f"
     using has_bochner_integral_erf_aux     
     by (intro set_integral_cont_up )
        (insert *, auto simp: incseq_def has_bochner_integral_iff set_integrable_def)
   also note *
   also have "(\<lambda>n. set_lebesgue_integral lborel {0..real n} ?f) = (\<lambda>n. integral {0..real n} ?f)"
   proof -
     have "\<And>n. set_integrable lborel {0..real n} (\<lambda>x. exp (- x\<^sup>2))"
       unfolding set_integrable_def
       by (intro borel_integrable_compact) (auto intro!: continuous_intros)
     then show ?thesis
       by (intro set_borel_integral_eq_integral ext)
   qed
   also have "\<dots> = (\<lambda>n. sqrt pi / 2 * erf (real n))" by (simp add: erf_real_altdef_nonneg)
   also have "set_lebesgue_integral lborel {0..} ?f = sqrt pi / 2"
     using has_bochner_integral_erf_aux by (simp add: has_bochner_integral_iff set_lebesgue_integral_def)
   finally have "(\<lambda>n. 2 / sqrt pi * (sqrt pi / 2 * erf (real n))) \<longlonglongrightarrow> 
                   (2 / sqrt pi) * (sqrt pi / 2)" by (intro tendsto_intros)
   hence "(\<lambda>n. erf (real n)) \<longlonglongrightarrow> 1" by simp
   thus ?thesis by (rule tendsto_sandwich_mono) auto
 qed
   
 lemma erf_at_bot [tendsto_intros]: "((erf :: real \<Rightarrow> real) \<longlongrightarrow> -1) at_bot"
   by (simp add: filterlim_at_bot_mirror tendsto_minus_cancel_left erf_at_top)
 
 lemmas tendsto_erf_at_top [tendsto_intros] = filterlim_compose[OF erf_at_top]
 lemmas tendsto_erf_at_bot [tendsto_intros] = filterlim_compose[OF erf_at_bot]
 
 
 subsection \<open>The complimentary error function\<close>  
   
 definition erfc where "erfc z = 1 - erf z"
   
 lemma erf_conv_erfc: "erf z = 1 - erfc z" by (simp add: erfc_def)
 
 lemma erfc_0 [simp]: "erfc 0 = 1"
   by (simp add: erfc_def)
 
 lemma erfc_minus: "erfc (-z) = 2 - erfc z"
   by (simp add: erfc_def)
 
 lemma erfc_of_real [simp]: "erfc (of_real x) = of_real (erfc x)"
   by (simp add: erfc_def)
     
 lemma of_real_erfc_numeral [simp]: "of_real (erfc (numeral n)) = erfc (numeral n)"
   by (simp add: erfc_def)
 
 lemma of_real_erfc_1 [simp]: "of_real (erfc 1) = erfc 1"
   by (simp add: erfc_def)
     
 
 lemma less_imp_erfc_real_less: "a < (b::real) \<Longrightarrow> erfc a > erfc b"
   by (simp add: erfc_def)
   
 lemma le_imp_erfc_real_le: "a \<le> (b::real) \<Longrightarrow> erfc a \<ge> erfc b"
   by (simp add: erfc_def)
   
 lemma erfc_real_less_cancel [simp]: "(erfc (a :: real) < erfc b) \<longleftrightarrow> a > b"
   by (simp add: erfc_def)
 
 lemma erfc_real_eq_iff [simp]: "erfc (a::real) = erfc b \<longleftrightarrow> a = b"
   by (simp add: erfc_def)
     
 lemma erfc_real_le_cancel [simp]: "(erfc (a :: real) \<le> erfc b) \<longleftrightarrow> a \<ge> b"
   by (simp add: erfc_def)
     
 lemma inj_on_erfc_real [intro]: "inj_on (erfc :: real \<Rightarrow> real) A"
   by (auto simp: inj_on_def)
 
 lemma antimono_erfc_real [intro]: "antimono (erfc :: real \<Rightarrow> real)"
   by (auto simp: antimono_def)
 
 lemma erfc_real_ge_0_iff [simp]: "erfc (x::real) \<ge> 1 \<longleftrightarrow> x \<le> 0"
   by (simp add: erfc_def)
 
 lemma erfc_real_le_0_iff [simp]: "erfc (x::real) \<le> 1 \<longleftrightarrow> x \<ge> 0"
   by (simp add: erfc_def)
     
 lemma erfc_real_gt_0_iff [simp]: "erfc (x::real) > 1 \<longleftrightarrow> x < 0"
   by (simp add: erfc_def)
 
 lemma erfc_real_less_0_iff [simp]: "erfc (x::real) < 1 \<longleftrightarrow> x > 0"
   by (simp add: erfc_def)
 
 
 lemma erfc_has_field_derivative:
   "(erfc has_field_derivative -of_real (2 / sqrt pi) * exp (-(z^2))) (at z within A)"
   unfolding erfc_def [abs_def] by (auto intro!: derivative_eq_intros)
 
 lemmas erfc_has_field_derivative' [derivative_intros] =
   erfc_has_field_derivative [THEN DERIV_chain2]
   
 lemma erfc_continuous_on: "continuous_on A erfc"
   by (rule DERIV_continuous_on erfc_has_field_derivative)+
 
 lemmas erfc_continuous_on' [continuous_intros] = 
   erfc_continuous_on [THEN continuous_on_compose2_UNIV]
 
 lemma erfc_continuous [continuous_intros]: "continuous (at x within A) erfc"
   by (rule continuous_within_subset[OF _ subset_UNIV])
      (insert erfc_continuous_on[of UNIV], auto simp: continuous_on_eq_continuous_at)
 
 lemmas erfc_continuous' [continuous_intros] = 
   continuous_within_compose2[OF _ erfc_continuous]
   
 lemmas tendsto_erfc [tendsto_intros] = isCont_tendsto_compose[OF erfc_continuous]
 
   
 lemma erfc_at_top [tendsto_intros]: "((erfc :: real \<Rightarrow> real) \<longlongrightarrow> 0) at_top"
   unfolding erfc_def [abs_def] by (auto intro!: tendsto_eq_intros)
   
 lemma erfc_at_bot [tendsto_intros]: "((erfc :: real \<Rightarrow> real) \<longlongrightarrow> 2) at_bot"
   unfolding erfc_def [abs_def] by (auto intro!: tendsto_eq_intros)
 
 lemmas tendsto_erfc_at_top [tendsto_intros] = filterlim_compose[OF erfc_at_top]
 lemmas tendsto_erfc_at_bot [tendsto_intros] = filterlim_compose[OF erfc_at_bot]  
 
 lemma integrable_exp_minus_squared:
   assumes "A \<subseteq> {0..}" "A \<in> sets lborel"
   shows   "set_integrable lborel A (\<lambda>t::real. exp (-t\<^sup>2))" (is ?thesis1)
     and   "(\<lambda>t::real. exp (-t\<^sup>2)) integrable_on A" (is ?thesis2)
 proof -
   show ?thesis1 
     by (rule set_integrable_subset[of _ "{0..}"]) 
        (insert assms has_bochner_integral_erf_aux, auto simp: has_bochner_integral_iff set_integrable_def)
   thus ?thesis2 by (rule set_borel_integral_eq_integral)
 qed
 
 lemma
   assumes "x \<ge> 0"
   shows   erfc_real_altdef_nonneg: "erfc x = 2 / sqrt pi * integral {x..} (\<lambda>t. exp (-t\<^sup>2))"
     and   has_integral_erfc:       "((\<lambda>t. exp (-t\<^sup>2)) has_integral (sqrt pi / 2 * erfc x)) {x..}"
 proof -
   let ?f = "\<lambda>t::real. exp (-t\<^sup>2)"
   have int: "set_integrable lborel {0..} ?f"
     using has_bochner_integral_erf_aux by (simp add: has_bochner_integral_iff set_integrable_def)
   from assms have *: "{(0::real)..} = {0..x} \<union> {x..}" by auto
   have "set_lebesgue_integral lborel ({0..x} \<union> {x..}) ?f = 
                set_lebesgue_integral lborel {0..x} ?f + set_lebesgue_integral lborel {x..} ?f"
     by (subst set_integral_Un_AE; (rule set_integrable_subset[OF int])?)
        (insert assms AE_lborel_singleton[of x], auto elim!: eventually_mono)
   also note * [symmetric]
   also have "set_lebesgue_integral lborel {0..} ?f = sqrt pi / 2"
     using has_bochner_integral_erf_aux by (simp add: has_bochner_integral_iff set_lebesgue_integral_def)
   also have "set_lebesgue_integral lborel {0..x} ?f = sqrt pi / 2 * erf x"
     by (subst set_borel_integral_eq_integral(2)[OF set_integrable_subset[OF int]])
        (insert assms, auto simp: erf_real_altdef_nonneg)
   also have "set_lebesgue_integral lborel {x..} ?f = integral {x..} ?f"
     by (subst set_borel_integral_eq_integral(2)[OF set_integrable_subset[OF int]])
        (insert assms, auto) 
   finally show "erfc x = 2 / sqrt pi * integral {x..} ?f" by (simp add: field_simps erfc_def)
   with integrable_exp_minus_squared(2)[of "{x..}"] assms
   show "(?f has_integral (sqrt pi / 2 * erfc x)) {x..}"
     by (simp add: has_integral_iff)
 qed
 
 
 lemma erfc_real_gt_0 [simp, intro]: "erfc (x::real) > 0"
 proof (cases "x \<ge> 0")
   case True
   have "0 < integral {x..x+1} (\<lambda>t. exp (-(x+1)\<^sup>2))" by simp
   also from True have "\<dots> \<le> integral {x..x+1} (\<lambda>t. exp (-t\<^sup>2))"
     by (intro integral_le) 
        (auto intro!: integrable_continuous_real continuous_intros power_mono)
   also have "\<dots> \<le> sqrt pi / 2 * erfc x"
     by (rule has_integral_subset_le[OF _ integrable_integral has_integral_erfc])
        (auto intro!: integrable_continuous_real continuous_intros True)
   finally have "sqrt pi / 2 * erfc x > 0" .
   hence "\<dots> * (2 / sqrt pi) > 0" by (rule mult_pos_pos) simp_all
   thus "erfc x > 0" by simp
 next
   case False
   have "0 \<le> (1::real)" by simp
   also from False have "\<dots> < erfc x" by simp
   finally show ?thesis .
 qed
 
 lemma erfc_real_less_2 [intro]: "erfc (x::real) < 2"
   using erfc_real_gt_0[of "-x"] unfolding erfc_minus by simp
     
 lemma erf_real_gt_neg1 [intro]: "erf (x::real) > -1"
   using erfc_real_less_2[of x] unfolding erfc_def by simp
     
 lemma erf_real_less_1 [intro]: "erf (x::real) < 1"
   using erfc_real_gt_0[of x] unfolding erfc_def by simp
 
 lemma erfc_cnj [simp]: "erfc (cnj z) = cnj (erfc z)"
   by (simp add: erfc_def)
 
 
 subsection \<open>Specific facts about the complex case\<close>  
   
 lemma erf_complex_altdef:
   "erf z = of_real (2 / sqrt pi) * contour_integral (linepath 0 z) (\<lambda>t. exp (-(t^2)))"
 proof -
   define A where "A = (\<lambda>z. contour_integral (linepath 0 z) (\<lambda>t. exp (-(t^2))))"
   have [derivative_intros]: "(A has_field_derivative exp (-(z^2))) (at z)" for z :: complex
     unfolding A_def
     by (rule contour_integral_has_field_derivative[where A = UNIV])
        (auto intro!: holomorphic_intros)
   have "erf z - 2 / sqrt pi * A z = erf 0 - 2 / sqrt pi * A 0"
     by (rule has_derivative_zero_unique [where f = "\<lambda>z. erf z - 2 / sqrt pi * A z" and s = UNIV])
        (auto intro!: has_field_derivative_imp_has_derivative derivative_eq_intros)
   also have "A 0 = 0" by (simp only: A_def contour_integral_trivial)
   finally show ?thesis unfolding A_def by (simp add: algebra_simps)
 qed
 
 lemma erf_holomorphic_on: "erf holomorphic_on A"
   by (auto simp: holomorphic_on_def field_differentiable_def intro!: erf_has_field_derivative)
 
 lemmas erf_holomorphic_on' [holomorphic_intros] = 
   erf_holomorphic_on [THEN holomorphic_on_chain_UNIV]
   
 lemma erf_analytic_on: "erf analytic_on A"
   by (auto simp: analytic_on_def) (auto intro!: exI[of _ 1] holomorphic_intros)
 
 lemma erf_analytic_on'  [analytic_intros]:
   assumes "f analytic_on A"
   shows   "(\<lambda>x. erf (f x)) analytic_on A"
 proof -
   from assms and erf_analytic_on have "erf \<circ> f analytic_on A"
     by (rule analytic_on_compose_gen) auto
   thus ?thesis by (simp add: o_def)
 qed
 
 lemma erfc_holomorphic_on: "erfc holomorphic_on A"
   by (auto simp: holomorphic_on_def field_differentiable_def intro!: erfc_has_field_derivative)
 
 lemmas erfc_holomorphic_on' [holomorphic_intros] = 
   erfc_holomorphic_on [THEN holomorphic_on_chain_UNIV]
 
 lemma erfc_analytic_on: "erfc analytic_on A"
   by (auto simp: analytic_on_def) (auto intro!: exI[of _ 1] holomorphic_intros)
 
 lemma erfc_analytic_on' [analytic_intros]:
   assumes "f analytic_on A"
   shows   "(\<lambda>x. erfc (f x)) analytic_on A"
 proof -
   from assms and erfc_analytic_on have "erfc \<circ> f analytic_on A"
     by (rule analytic_on_compose_gen) auto
   thus ?thesis by (simp add: o_def)
 qed
    
 end
diff --git a/thys/Euler_MacLaurin/Euler_MacLaurin.thy b/thys/Euler_MacLaurin/Euler_MacLaurin.thy
--- a/thys/Euler_MacLaurin/Euler_MacLaurin.thy
+++ b/thys/Euler_MacLaurin/Euler_MacLaurin.thy
@@ -1,1617 +1,1617 @@
 section \<open>The Euler--MacLaurin summation formula\<close>
 theory Euler_MacLaurin
 imports 
   "HOL-Complex_Analysis.Complex_Analysis"
   Bernoulli.Periodic_Bernpoly
   Bernoulli.Bernoulli_FPS
 begin
   
 subsection \<open>Auxiliary facts\<close>
 
 (* TODO Move? *)
 lemma pbernpoly_of_int [simp]: "pbernpoly n (of_int a) = bernoulli n"
   by (simp add: pbernpoly_def)
 
 lemma continuous_on_bernpoly' [continuous_intros]:
   assumes "continuous_on A f"
   shows   "continuous_on A (\<lambda>x. bernpoly n (f x) :: 'a :: real_normed_algebra_1)"
   using continuous_on_compose2[OF continuous_on_bernpoly assms, of UNIV n] by auto
 
 lemma sum_atLeastAtMost_int_last:
   assumes "a < (b :: int)"
   shows   "sum f {a..b} = sum f {a..<b} + f b"
 proof -
   from assms have "{a..b} = insert b {a..<b}" by auto
   also have "sum f \<dots> = sum f {a..<b} + f b"
     by (subst sum.insert) (auto simp: add_ac)
   finally show ?thesis .
 qed
 
 lemma sum_atLeastAtMost_int_head:
   assumes "a < (b :: int)"
   shows   "sum f {a..b} = f a + sum f {a<..b}"
 proof -
   from assms have "{a..b} = insert a {a<..b}" by auto
   also have "sum f \<dots> = f a + sum f {a<..b}"
     by (subst sum.insert) auto
   finally show ?thesis .
 qed
 
 lemma not_in_nonpos_Reals_imp_add_nonzero:
   assumes "z \<notin> \<real>\<^sub>\<le>\<^sub>0" "x \<ge> 0"
   shows   "z + of_real x \<noteq> 0"
   using assms by (auto simp: add_eq_0_iff2)
 (* END TODO *)
 
 lemma negligible_atLeastAtMostI: "b \<le> a \<Longrightarrow> negligible {a..(b::real)}"
   by (cases "b < a") auto
     
 lemma integrable_on_negligible: 
  "negligible A \<Longrightarrow> (f :: 'n :: euclidean_space \<Rightarrow> 'a :: banach) integrable_on A"
   by (subst integrable_spike_set_eq[of _ "{}"]) (simp_all add: integrable_on_empty)  
     
 lemma Union_atLeastAtMost_real_of_int:
   assumes "a < b" 
   shows   "(\<Union>n\<in>{a..<b}. {real_of_int n..real_of_int (n + 1)}) = {real_of_int a..real_of_int b}"
 proof (intro equalityI subsetI)
   fix x assume x: "x \<in> {real_of_int a..real_of_int b}"
   thus "x \<in> (\<Union>n\<in>{a..<b}. {real_of_int n..real_of_int (n + 1)})"
   proof (cases "x = real_of_int b")
     case True
     with assms show ?thesis by (auto intro!: bexI[of _ "b - 1"])
   next
     case False
     with x have x: "x \<ge> real_of_int a" "x < real_of_int b" by simp_all
     hence "x \<ge> of_int \<lfloor>x\<rfloor>" "x \<le> of_int \<lfloor>x\<rfloor> + 1" by linarith+
     moreover from x have "\<lfloor>x\<rfloor> \<ge> a" "\<lfloor>x\<rfloor> < b" by linarith+ 
     ultimately have "\<exists>n\<in>{a..<b}. x \<in> {of_int n..of_int (n + 1)}"
       by (intro bexI[of _ "\<lfloor>x\<rfloor>"]) simp_all
     thus ?thesis by blast
   qed
 qed auto
 
 
 subsection \<open>The remainder terms\<close>
 
 text \<open>
   The following describes the remainder term in the classical version of the Euler--MacLaurin
   formula.
 \<close>
 definition EM_remainder' :: "nat \<Rightarrow> (real \<Rightarrow> 'a :: banach) \<Rightarrow> real \<Rightarrow> real \<Rightarrow> 'a" where
   "EM_remainder' n f a b = ((-1) ^ Suc n / fact n) *\<^sub>R integral {a..b} (\<lambda>t. pbernpoly n t *\<^sub>R f t)"
 
 
 text \<open>
   Next, we define the remainder term that occurs when one lets the right bound of summation 
   in the Euler--MacLaurin formula tend to infinity.
 \<close>
 definition EM_remainder_converges :: "nat \<Rightarrow> (real \<Rightarrow> 'a :: banach) \<Rightarrow> int \<Rightarrow> bool" where
   "EM_remainder_converges n f a \<longleftrightarrow> (\<exists>L. ((\<lambda>x. EM_remainder' n f a (of_int x)) \<longlongrightarrow> L) at_top)"
 
 definition EM_remainder :: "nat \<Rightarrow> (real \<Rightarrow> 'a :: banach) \<Rightarrow> int \<Rightarrow> 'a" where
   "EM_remainder n f a = 
      (if EM_remainder_converges n f a then
         Lim at_top (\<lambda>x. EM_remainder' n f a (of_int x)) else 0)"
 
 text \<open>
   The following lemmas are fairly obvious -- but tedious to prove -- 
   properties of the remainder terms.
 \<close>
 
 lemma EM_remainder_eqI: 
   fixes L
   assumes "((\<lambda>x. EM_remainder' n f b (of_int x)) \<longlongrightarrow> L) at_top"
   shows   "EM_remainder n f b = L"
   using assms by (auto simp: EM_remainder_def EM_remainder_converges_def intro!: tendsto_Lim)
 
 lemma integrable_EM_remainder'_int:
   fixes a b :: int and f :: "real \<Rightarrow> 'a :: banach"
   assumes "continuous_on {of_int a..of_int b} f"
   shows   "(\<lambda>t. pbernpoly n t *\<^sub>R f t) integrable_on {a..b}"
 proof -
   have [continuous_intros]: "continuous_on A f" if "A \<subseteq> {of_int a..of_int b}" for A
     using continuous_on_subset[OF assms that] .
   consider "a > b" | "a = b" | "a < b" "n = 1" | "a < b" "n \<noteq> 1"
     by (cases a b rule: linorder_cases) auto
   thus ?thesis
   proof cases
     assume "a < b" and "n \<noteq> 1"
     thus ?thesis by (intro integrable_continuous_real continuous_intros) auto
   next
     assume ab: "a < b" and [simp]: "n = 1"
     let ?A = "(\<lambda>n. {real_of_int n..real_of_int (n+1)}) ` {a..<b}"
     show ?thesis
     proof (rule integrable_combine_division; (intro ballI)?)
       show "?A division_of {of_int a..of_int b}"
         using Union_atLeastAtMost_real_of_int[OF ab] by (simp add: division_of_def)
     next
       fix I assume "I \<in> ?A"
       then obtain i where i: "i \<in> {a..<b}" "I = {of_int i..of_int (i + 1)}" by auto
       show "(\<lambda>t. pbernpoly n t *\<^sub>R f t) integrable_on I"
       proof (rule integrable_spike)
         show "(\<lambda>t. (t - of_int i - 1/2) *\<^sub>R f t) integrable_on I"
           using i by (auto intro!: integrable_continuous_real continuous_intros)
       next
         fix x assume "x \<in> I - {of_int (i + 1)}"
         with i have "of_int i \<le> x" "x < of_int i + 1" by simp_all
         hence "floor x = i" by linarith
         thus "pbernpoly n x *\<^sub>R f x = (x - of_int i - 1 / 2) *\<^sub>R f x"
           by (simp add: pbernpoly_def bernpoly_def frac_def)
       qed simp_all
     qed
   qed (simp_all add: integrable_on_negligible)
 qed
 
 lemma integrable_EM_remainder':
   fixes a b :: real and f :: "real \<Rightarrow> 'a :: banach"
   assumes "continuous_on {a..b} f"
   shows   "(\<lambda>t. pbernpoly n t *\<^sub>R f t) integrable_on {a..b}"
 proof (cases "\<lceil>a\<rceil> \<le> \<lfloor>b\<rfloor>")
   case True
   define a' b' where "a' = \<lceil>a\<rceil>" and "b' = \<lfloor>b\<rfloor>"
   from True have *: "a' \<le> b'" "a' \<ge> a" "b' \<le> b" by (auto simp: a'_def b'_def)
   from * have A: "(\<lambda>t. pbernpoly n t *\<^sub>R f t) integrable_on ({a'..b'})"
     by (intro integrable_EM_remainder'_int continuous_on_subset[OF assms]) auto
   have B: "(\<lambda>t. pbernpoly n t *\<^sub>R f t) integrable_on ({a..a'})"
   proof (rule integrable_spike)
     show "pbernpoly n x *\<^sub>R f x = bernpoly n (x - of_int (floor a)) *\<^sub>R f x" 
          if "x \<in> {a..real_of_int a'} - {real_of_int a'}"for x
     proof -
       have "x \<ge> a" "x <real_of_int a'" using that by auto
       with True have "floor x = floor a" unfolding a'_def
         using ceiling_diff_floor_le_1[of a] by (intro floor_unique; linarith) 
       thus ?thesis by (simp add: pbernpoly_def frac_def)
     qed
   qed (insert *, auto intro!: continuous_intros integrable_continuous_real 
          continuous_on_subset[OF assms])
   have C: "(\<lambda>t. pbernpoly n t *\<^sub>R f t) integrable_on ({b'..b})"
   proof (rule integrable_spike)
     show "pbernpoly n x *\<^sub>R f x = bernpoly n (x - of_int b') *\<^sub>R f x"
          if "x \<in> {real_of_int b'..b} - {real_of_int b'}" for x
     proof -
       have "x \<le> b" "x > real_of_int b'" using that by auto
       with True have "floor x = b'" unfolding b'_def by (intro floor_unique; linarith) 
       thus ?thesis by (simp add: pbernpoly_def frac_def)
     qed
   qed (insert *, auto intro!: continuous_intros integrable_continuous_real 
          continuous_on_subset[OF assms])
   have "(\<lambda>t. pbernpoly n t *\<^sub>R f t) integrable_on ({a..a'} \<union> {a'..b'} \<union> {b'..b})" using * A B C
     by (intro integrable_Un; (subst ivl_disj_un)?)
        (auto simp: ivl_disj_un max_def min_def)
   also have "{a..a'} \<union> {a'..b'} \<union> {b'..b} = {a..b}" using * by auto
   finally show ?thesis .
 next
   assume *: "\<not>ceiling a \<le> floor b"
   show ?thesis
   proof (rule integrable_spike)
     show "(\<lambda>t. bernpoly n (t - floor a) *\<^sub>R f t) integrable_on {a..b}" using *
       by (auto intro!: integrable_continuous_real continuous_intros assms)
   next
     show "pbernpoly n x *\<^sub>R f x = bernpoly n (x - floor a) *\<^sub>R f x"
          if "x \<in> {a..b} - {}" for x
     proof -
       from * have **: "b < floor a + 1" 
         unfolding ceiling_altdef by (auto split: if_splits simp: le_floor_iff)
       from that have x: "x \<ge> a" "x \<le> b" by simp_all
       with * ** have "floor x = floor a" by linarith
       thus ?thesis by (simp add: pbernpoly_def frac_def)
     qed
   qed simp_all
 qed
 
 lemma EM_remainder'_bounded_linear:
   assumes "bounded_linear h"
   assumes "continuous_on {a..b} f"
   shows   "EM_remainder' n (\<lambda>x. h (f x)) a b = h (EM_remainder' n f a b)"
 proof -
   have "integral {a..b} (\<lambda>t. pbernpoly n t *\<^sub>R h (f t)) = 
            integral {a..b} (\<lambda>t. h (pbernpoly n t *\<^sub>R f t))" using assms
     by (simp add: linear_simps)
   also have "\<dots> = h (integral {a..b} (\<lambda>t. pbernpoly n t *\<^sub>R f t))"
     by (subst integral_linear [OF _ assms(1), symmetric])
        (auto intro!: integrable_EM_remainder' assms(2) simp: o_def)
   finally show ?thesis using assms(1)
     by (simp add: EM_remainder'_def linear_simps)
 qed
 
 lemma EM_remainder_converges_of_real:
   assumes "EM_remainder_converges n f a" "continuous_on {of_int a..} f"
   shows   "EM_remainder_converges n (\<lambda>x. of_real (f x)) a"
 proof -
   from assms obtain L 
     where L: "((\<lambda>b. EM_remainder' n f (real_of_int a) (real_of_int b)) \<longlongrightarrow> L) at_top"
     by (auto simp: EM_remainder_converges_def)
   have "((\<lambda>b. EM_remainder' n (\<lambda>x. of_real (f x)) (of_int a) (of_int b)) \<longlongrightarrow> of_real L) at_top"
   proof (rule Lim_transform_eventually)
     show "eventually (\<lambda>b. of_real (EM_remainder' n f (of_int a) (of_int b)) = 
             EM_remainder' n (\<lambda>x. of_real (f x)) (of_int a) (of_int b)) at_top"
       using eventually_ge_at_top[of a]
       by eventually_elim
          (intro EM_remainder'_bounded_linear [OF bounded_linear_of_real, symmetric]
                 continuous_on_subset[OF assms(2)], auto)
   qed (intro tendsto_intros L)
   thus ?thesis unfolding EM_remainder_converges_def ..
 qed
 
 lemma EM_remainder_converges_of_real_iff:
   fixes f :: "real \<Rightarrow> real"
   assumes "continuous_on {of_int a..} f"
   shows   "EM_remainder_converges n (\<lambda>x. of_real (f x) :: 
             'a :: {banach, real_normed_algebra_1, real_inner}) a \<longleftrightarrow> EM_remainder_converges n f a"
 proof
   assume "EM_remainder_converges n (\<lambda>x. of_real (f x) :: 'a) a"
   then obtain L :: 'a
     where L: "((\<lambda>b. EM_remainder' n (\<lambda>x. of_real (f x)) (of_int a) (of_int b)) \<longlongrightarrow> L) at_top"
     by (auto simp: EM_remainder_converges_def)
   have "((\<lambda>b. EM_remainder' n f (of_int a) (of_int b)) \<longlongrightarrow> L \<bullet> 1) at_top"
   proof (rule Lim_transform_eventually)
     show "eventually (\<lambda>b. EM_remainder' n (\<lambda>x. of_real (f x) :: 'a) (of_int a) (of_int b) \<bullet> 1 =
             EM_remainder' n f (of_int a) (of_int b)) at_top" using eventually_ge_at_top[of a]
       by eventually_elim
          (subst EM_remainder'_bounded_linear [OF bounded_linear_of_real],
           auto intro!: continuous_on_subset[OF assms])
   qed (intro tendsto_intros L)
   thus "EM_remainder_converges n f a" unfolding EM_remainder_converges_def ..
 qed (intro EM_remainder_converges_of_real assms)
 
 lemma EM_remainder_of_real:
   assumes "continuous_on {a..} f"
   shows   "EM_remainder n (\<lambda>x. of_real (f x) :: 
              'a :: {banach, real_normed_algebra_1, real_inner}) a = 
              of_real (EM_remainder n f a)"
 proof -
   have eq: "EM_remainder' n (\<lambda>x. of_real (f x) :: 'a) (real_of_int a) = 
               (\<lambda>x::int. of_real (EM_remainder' n f a x))"
       by (intro ext EM_remainder'_bounded_linear[OF bounded_linear_of_real]
             continuous_on_subset[OF assms]) auto
   show ?thesis
   proof (cases "EM_remainder_converges n f a")
     case False
     with EM_remainder_converges_of_real_iff[OF assms, of n] show ?thesis
       by (auto simp: EM_remainder_def)
   next
     case True
     then obtain L where L: "((\<lambda>x. EM_remainder' n f a (real_of_int x)) \<longlongrightarrow> L) at_top" 
       by (auto simp: EM_remainder_converges_def)
     have L': "((\<lambda>x. EM_remainder' n (\<lambda>x. of_real (f x) :: 'a) a 
                 (real_of_int x)) \<longlongrightarrow> of_real L) at_top" unfolding eq by (intro tendsto_of_real L)
     from L L' tendsto_Lim[OF _ L] tendsto_Lim[OF _ L'] show ?thesis
       by (auto simp: EM_remainder_def EM_remainder_converges_def)
   qed
 qed
 
 lemma EM_remainder'_cong:
   assumes "\<And>x. x \<in> {a..b} \<Longrightarrow> f x = g x" "n = n'" "a = a'" "b = b'"
   shows   "EM_remainder' n f a b = EM_remainder' n' g a' b'"
 proof -
   have "integral {a..b} (\<lambda>t. pbernpoly n t *\<^sub>R f t) = integral {a'..b'} (\<lambda>t. pbernpoly n' t *\<^sub>R g t)"
     unfolding assms using assms by (intro integral_cong) auto
   with assms show ?thesis by (simp add: EM_remainder'_def)
 qed
 
 lemma EM_remainder_converges_cong:
   assumes "\<And>x. x \<ge> of_int a \<Longrightarrow> f x = g x" "n = n'" "a = a'"
   shows   "EM_remainder_converges n f a = EM_remainder_converges n' g a'"
   unfolding EM_remainder_converges_def
   by (subst EM_remainder'_cong[OF _ refl refl refl, of _ _ f g]) (use assms in auto)
 
 lemma EM_remainder_cong:
   assumes "\<And>x. x \<ge> of_int a \<Longrightarrow> f x = g x" "n = n'" "a = a'"
   shows   "EM_remainder n f a = EM_remainder n' g a'"
 proof -
   have *: "EM_remainder_converges n f a = EM_remainder_converges n' g a'"
     using assms by (intro EM_remainder_converges_cong) auto
   show ?thesis unfolding EM_remainder_def
     by (subst EM_remainder'_cong[OF _ refl refl refl, of _ _ f g]) (use assms * in auto)
 qed
 
 lemma EM_remainder_converges_cnj: 
   assumes "continuous_on {a..} f" and "EM_remainder_converges n f a"
   shows   "EM_remainder_converges n (\<lambda>x. cnj (f x)) a"
 proof -
   interpret bounded_linear cnj by (rule bounded_linear_cnj)
   obtain L where L: "((\<lambda>x. EM_remainder' n f (real_of_int a) (real_of_int x)) \<longlongrightarrow> L) at_top"
     using assms unfolding EM_remainder_converges_def by blast
   note tendsto_cnj [OF this]
   also have "(\<lambda>x. cnj (EM_remainder' n f (real_of_int a) (real_of_int x))) =
                (\<lambda>x. EM_remainder' n (\<lambda>x. cnj (f x)) (real_of_int a) (real_of_int x))"
     by (subst EM_remainder'_bounded_linear [OF bounded_linear_cnj])
        (rule continuous_on_subset [OF assms(1)], auto)
   finally have L': "(\<dots> \<longlongrightarrow> cnj L) at_top" .
   thus "EM_remainder_converges n (\<lambda>x. cnj (f x)) a"
     by (auto simp: EM_remainder_converges_def)
 qed
 
 lemma EM_remainder_converges_cnj_iff:
   assumes "continuous_on {of_int a..} f"
   shows   "EM_remainder_converges n (\<lambda>x. cnj (f x)) a \<longleftrightarrow> EM_remainder_converges n f a"
 proof
   assume "EM_remainder_converges n (\<lambda>x. cnj (f x)) a"
   hence "EM_remainder_converges n (\<lambda>x. cnj (cnj (f x))) a"
     by (rule EM_remainder_converges_cnj [rotated]) (auto intro: continuous_intros assms)
   thus "EM_remainder_converges n f a" by simp
 qed (intro EM_remainder_converges_cnj assms)
 
 lemma EM_remainder_cnj: 
   assumes "continuous_on {a..} f"
   shows   "EM_remainder n (\<lambda>x. cnj (f x)) a = cnj (EM_remainder n f a)"
 proof (cases "EM_remainder_converges n f a")
   case False
   hence "\<not>EM_remainder_converges n (\<lambda>x. cnj (f x)) a"
     by (subst EM_remainder_converges_cnj_iff [OF assms])
   with False show ?thesis by (simp add: EM_remainder_def)
 next
   case True
   then obtain L where L: "((\<lambda>x. EM_remainder' n f (real_of_int a) (real_of_int x)) \<longlongrightarrow> L) at_top"
     unfolding EM_remainder_converges_def by blast
   note tendsto_cnj [OF this]
   also have "(\<lambda>x. cnj (EM_remainder' n f (real_of_int a) (real_of_int x))) =
                (\<lambda>x. EM_remainder' n (\<lambda>x. cnj (f x)) (real_of_int a) (real_of_int x))"
     by (subst EM_remainder'_bounded_linear [OF bounded_linear_cnj])
        (rule continuous_on_subset [OF assms(1)], auto)
   finally have L': "(\<dots> \<longlongrightarrow> cnj L) at_top" .
   moreover from assms and L have "EM_remainder n f a = L"
     by (intro EM_remainder_eqI)
   ultimately show "EM_remainder n (\<lambda>x. cnj (f x)) a = cnj (EM_remainder n f a)"
     using L' by (intro EM_remainder_eqI) simp_all
 qed
 
 lemma EM_remainder'_combine:
   fixes f :: "real \<Rightarrow> 'a :: banach"
   assumes [continuous_intros]: "continuous_on {a..c} f"
   assumes "a \<le> b" "b \<le> c"
   shows   "EM_remainder' n f a b + EM_remainder' n f b c = EM_remainder' n f a c"
 proof -
   have "integral {a..b} (\<lambda>t. pbernpoly n t *\<^sub>R f t) + integral {b..c} (\<lambda>t. pbernpoly n t *\<^sub>R f t) =
           integral {a..c} (\<lambda>t. pbernpoly n t *\<^sub>R f t)"
     by (intro Henstock_Kurzweil_Integration.integral_combine assms integrable_EM_remainder')
   from this [symmetric] show ?thesis by (simp add: EM_remainder'_def algebra_simps) 
 qed
 
 lemma uniformly_convergent_EM_remainder':
   fixes f :: "'a \<Rightarrow> real \<Rightarrow> 'b :: {banach,real_normed_algebra}"
   assumes deriv: "\<And>y. a \<le> y \<Longrightarrow> (G has_real_derivative g y) (at y within {a..})"
   assumes integrable: "\<And>a' b y. y \<in> A \<Longrightarrow>  a \<le> a' \<Longrightarrow> a' \<le> b \<Longrightarrow> 
                          (\<lambda>t. pbernpoly n t *\<^sub>R f y t) integrable_on {a'..b}"
   assumes conv: "convergent (\<lambda>y. G (real y))"
   assumes bound: "eventually (\<lambda>x. \<forall>y\<in>A. norm (f y x) \<le> g x) at_top"
   shows   "uniformly_convergent_on A (\<lambda>b s. EM_remainder' n (f s) a b)"
 proof -
   interpret bounded_linear "\<lambda>x::'b. ((- 1) ^ Suc n / fact n) *\<^sub>R x"
     by (rule bounded_linear_scaleR_right)
 
-  from bounded_pbernpoly[of n] guess C . note C = this
+  from bounded_pbernpoly obtain C where C: "\<And>x. norm (pbernpoly n x) \<le> C" by auto
   from C[of 0] have [simp]: "C \<ge> 0" by simp
 
   show ?thesis unfolding EM_remainder'_def
   proof (intro uniformly_convergent_on uniformly_convergent_improper_integral')
     fix x assume "x \<ge> a"
     thus "((\<lambda>x. C * G x) has_real_derivative C * g x) (at x within {a..})"
       by (intro DERIV_cmult deriv)
   next
     fix y a' b assume "y \<in> A" "a \<le> a'" "a' \<le> b"
     thus "(\<lambda>t. pbernpoly n t *\<^sub>R f y t) integrable_on {a'..b}"
       by (rule integrable)
   next
     from conv obtain L where "(\<lambda>y. G (real y)) \<longlonglongrightarrow> L"
       by (auto simp: convergent_def)
     from tendsto_mult[OF tendsto_const[of C] this]
       show "convergent (\<lambda>y. C * G (real y))"
         by (auto simp: convergent_def)
   next
     show "\<forall>\<^sub>F x in at_top. \<forall>y\<in>A. norm (pbernpoly n x *\<^sub>R f y x) \<le> C * g x"
       using C unfolding norm_scaleR 
       by (intro eventually_mono[OF bound] ballI mult_mono) auto
   qed
 qed
 
 lemma uniform_limit_EM_remainder:
   fixes f :: "'a \<Rightarrow> real \<Rightarrow> 'b :: {banach,real_normed_algebra}"
   assumes deriv: "\<And>y. a \<le> y \<Longrightarrow> (G has_real_derivative g y) (at y within {a..})"
   assumes integrable: "\<And>a' b y. y \<in> A \<Longrightarrow>  a \<le> a' \<Longrightarrow> a' \<le> b \<Longrightarrow> 
                          (\<lambda>t. pbernpoly n t *\<^sub>R f y t) integrable_on {a'..b}"
   assumes conv: "convergent (\<lambda>y. G (real y))"
   assumes bound: "eventually (\<lambda>x. \<forall>y\<in>A. norm (f y x) \<le> g x) at_top"
   shows   "uniform_limit A (\<lambda>b s. EM_remainder' n (f s) a b) 
              (\<lambda>s. EM_remainder n (f s) a) sequentially"
 proof -
   have *: "uniformly_convergent_on A (\<lambda>b s. EM_remainder' n (f s) a b)"
     by (rule uniformly_convergent_EM_remainder'[OF assms])
   also have "?this \<longleftrightarrow> ?thesis"
     unfolding uniformly_convergent_uniform_limit_iff
   proof (intro uniform_limit_cong refl always_eventually allI ballI)
     fix s assume "s \<in> A"
     with * have **: "convergent (\<lambda>b. EM_remainder' n (f s) a b)"
       by (rule uniformly_convergent_imp_convergent)
     show "lim (\<lambda>b. EM_remainder' n (f s) a b) = EM_remainder n (f s) a"
     proof (rule sym, rule EM_remainder_eqI)
       have "((\<lambda>x. EM_remainder' n (f s) (real_of_int a) (real x)) \<longlongrightarrow>
                lim (\<lambda>x. EM_remainder' n (f s) (real_of_int a) (real x))) at_top"
         (is "(_ \<longlongrightarrow> ?L) _") using ** unfolding convergent_LIMSEQ_iff by blast
       hence "((\<lambda>x. EM_remainder' n (f s) (real_of_int a) (real (nat x))) \<longlongrightarrow> ?L) at_top"
         by (rule filterlim_compose) (fact filterlim_nat_sequentially)
       thus "((\<lambda>x. EM_remainder' n (f s) (real_of_int a) (real_of_int x)) \<longlongrightarrow> ?L) at_top"
         by (rule Lim_transform_eventually)
            (auto intro: eventually_mono[OF eventually_ge_at_top[of 0]])
     qed
   qed
   finally show \<dots> .
 qed
 
 lemma tendsto_EM_remainder:
   fixes f :: "real \<Rightarrow> 'b :: {banach,real_normed_algebra}"
   assumes deriv: "\<And>y. a \<le> y \<Longrightarrow> (G has_real_derivative g y) (at y within {a..})"
   assumes integrable: "\<And>a' b . a \<le> a' \<Longrightarrow> a' \<le> b \<Longrightarrow> 
                          (\<lambda>t. pbernpoly n t *\<^sub>R f t) integrable_on {a'..b}"
   assumes conv: "convergent (\<lambda>y. G (real y))"
   assumes bound: "eventually (\<lambda>x. norm (f x) \<le> g x) at_top"
   shows   "filterlim (\<lambda>b. EM_remainder' n f a b) 
              (nhds (EM_remainder n f a)) sequentially"
 proof -
   have "uniform_limit {()} (\<lambda>b s. EM_remainder' n f a b) 
              (\<lambda>s. EM_remainder n f a) sequentially"
     using assms by (intro uniform_limit_EM_remainder[where G = G and g = g]) auto
   moreover have "() \<in> {()}" by simp
   ultimately show ?thesis by (rule tendsto_uniform_limitI)
 qed
 
 lemma EM_remainder_0 [simp]: "EM_remainder n (\<lambda>x. 0) a = 0"
   by (rule EM_remainder_eqI) (simp add: EM_remainder'_def)
 
 lemma holomorphic_EM_remainder':
   assumes deriv: 
     "\<And>z t. z \<in> U \<Longrightarrow> t \<in> {a..x} \<Longrightarrow> 
        ((\<lambda>z. f z t) has_field_derivative f' z t) (at z within U)"
   assumes int: "\<And>b c z e. a \<le> b \<Longrightarrow> c \<le> x \<Longrightarrow> z \<in> U \<Longrightarrow>
                   (\<lambda>t. of_real (bernpoly n (t - e)) * f z t) integrable_on {b..c}"
   assumes cont: "continuous_on (U \<times> {a..x}) (\<lambda>(z, t). f' z t)"
   assumes "convex U"
   shows "(\<lambda>s. EM_remainder' n (f s) a x) holomorphic_on U"
   unfolding EM_remainder'_def scaleR_conv_of_real
 proof (intro holomorphic_intros)
   have holo: "(\<lambda>z. integral (cbox b c) (\<lambda>t. of_real (bernpoly n (t - e)) * f z t)) holomorphic_on U"
     if "b \<ge> a" "c \<le> x" for b c e :: real
   proof (rule leibniz_rule_holomorphic)
     fix z t assume "z \<in> U" "t \<in> cbox b c"
     thus "((\<lambda>z. complex_of_real (bernpoly n (t - e)) * f z t) has_field_derivative
              complex_of_real (bernpoly n (t - e)) * f' z t) (at z within U)"
       using that by (intro DERIV_cmult deriv) auto
   next
     fix z assume "z \<in> U"
     thus "(\<lambda>t. complex_of_real (bernpoly n (t - e)) * f z t) integrable_on cbox b c"
       using that int[of b c z] by auto
   next
     have "continuous_on (U \<times> {b..c}) (\<lambda>(z, t). f' z t)"
       using cont by (rule continuous_on_subset) (insert that, auto)
     thus "continuous_on (U \<times> cbox b c) (\<lambda>(z, t).
             complex_of_real (bernpoly n (t - e)) * f' z t)"
       by (auto simp: case_prod_unfold intro!: continuous_intros)
   qed fact+
 
   consider "a > x" | "a \<le> x" "floor x \<le> a" | "a \<le> x" "floor x > a" by force
   hence "(\<lambda>z. integral (cbox a x) (\<lambda>t. of_real (pbernpoly n t) * f z t)) holomorphic_on U"
     (is "?f a x holomorphic_on _")
   proof cases
     case 2
     have "(\<lambda>z. integral (cbox a x) (\<lambda>t. of_real (bernpoly n (t - of_int \<lfloor>x\<rfloor>)) * f z t))
                    holomorphic_on U" 
       by (intro holo) auto
     also have "(\<lambda>z. integral (cbox a x) (\<lambda>t. of_real (bernpoly n (t - of_int \<lfloor>x\<rfloor>)) * f z t)) = ?f a x"
     proof (intro ext integral_cong, goal_cases)
       case (1 z t)
       hence "t \<ge> a" "t \<le> x" by auto
       hence "floor t = floor x" using 2 by linarith
       thus ?case by (simp add: pbernpoly_def frac_def)
     qed
     finally show ?thesis .
   next
     case 3
           define N :: "int set" where "N = {\<lceil>a\<rceil>..<\<lfloor>x\<rfloor>}"
     define A where "A = insert {a..of_int \<lceil>a\<rceil>} (insert {of_int \<lfloor>x\<rfloor>..x} 
                           ((\<lambda>n. {of_int n..of_int n + 1}) ` N))"
     {
       fix X assume "X \<in> A"
       then consider "X = {a..of_int \<lceil>a\<rceil>}" | "X = {of_int \<lfloor>x\<rfloor>..x}" |
              n where "X = {of_int n..of_int n + 1}" "n \<in> N" by (auto simp: A_def)
     } note A_cases = this
 
     have division: "A division_of {a..x}"
     proof (rule division_ofI)
       show "finite A" by (auto simp: A_def N_def)
       fix K assume K: "K \<in> A"
       from 3 have "of_int \<lceil>a\<rceil> \<le> x" 
         using ceiling_le[of a "floor x"] by linarith
       moreover from 3 have "of_int \<lfloor>x\<rfloor> \<ge> a" by linarith
       ultimately show "K \<subseteq> {a..x}" using K 3 by (auto simp: A_def N_def) linarith+
       from K show "K \<noteq> {}" and "\<exists>a b. K = cbox a b" by (auto simp: A_def)
     next
       fix K1 K2 assume K: "K1 \<in> A" "K2 \<in> A" "K1 \<noteq> K2"
       have F1: "interior {a..\<lceil>a\<rceil>} \<inter> interior {\<lfloor>x\<rfloor>..x} = {}" using 3 ceiling_le[of a "floor x"]
         by (auto simp: min_def max_def) 
       hence F2: "interior {\<lfloor>x\<rfloor>..x} \<inter> interior {a..\<lceil>a\<rceil>} = {}" by simp
       have F3: "interior {a..\<lceil>a\<rceil>} \<inter> interior {of_int n..of_int n+1} = {}"
                "interior {\<lfloor>x\<rfloor>..x} \<inter> interior {of_int n..of_int n+1} = {}"
                "interior {of_int n..of_int n+1} \<inter> interior {a..\<lceil>a\<rceil>} = {}"
                "interior {of_int n..of_int n+1} \<inter> interior {\<lfloor>x\<rfloor>..x} = {}"if "n \<in> N" for n
         using 3 ceiling_le[of a "floor x"] that by (auto simp: min_def max_def N_def)
       have F4: "interior {real_of_int n..of_int n+1} \<inter> interior {of_int m..of_int m+1} = {}"
         if "{real_of_int n..of_int n+1} \<noteq> {of_int m..of_int m+1}" for m n
       proof -
         from that have "n \<noteq> m" by auto
         thus ?thesis by simp
       qed
       from F1 F2 F3 F4 K show "interior K1 \<inter> interior K2 = {}"
         by (elim A_cases) (simp_all only: not_False_eq_True)
     next
       show "\<Union>A = {a..x}"
       proof (cases "\<lceil>a\<rceil> = \<lfloor>x\<rfloor>")
         case True
         thus ?thesis using 3 by (auto simp: A_def N_def intro: order.trans) linarith+
       next
         case False
         with 3 have *: "\<lceil>a\<rceil> < \<lfloor>x\<rfloor>" by linarith
         have "\<Union>A = {a..of_int \<lceil>a\<rceil>} \<union> (\<Union>n\<in>N. {of_int n..of_int (n + 1)}) \<union> {of_int \<lfloor>x\<rfloor>..x}"
           by (simp add: A_def Un_ac)
         also have "(\<Union>n\<in>N. {of_int n..of_int (n + 1)}) = {of_int \<lceil>a\<rceil>..real_of_int \<lfloor>x\<rfloor>}"
           using * unfolding N_def by (intro Union_atLeastAtMost_real_of_int)
         also have "{a..of_int \<lceil>a\<rceil>} \<union> \<dots> = {a..real_of_int \<lfloor>x\<rfloor>}"
           using 3 * by (intro ivl_disj_un) auto
         also have "\<dots> \<union> {of_int \<lfloor>x\<rfloor>..x} = {a..x}"
           using 3 * by (intro ivl_disj_un) auto
         finally show ?thesis .
       qed
     qed
 
 
     have "(\<lambda>z. \<Sum>X\<in>A. integral X (\<lambda>t. of_real (bernpoly n (t - \<lfloor>Inf X\<rfloor>)) * f z t)) 
             holomorphic_on U"
     proof (intro holomorphic_on_sum holo, goal_cases)
       case (1 X)
       from 1 and division have subset: "X \<subseteq> {a..x}" by (auto simp: division_of_def)
       from 1 obtain b c where [simp]: "X = cbox b c" "b \<le> c" by (auto simp: A_def)
       from subset have "b \<ge> a" "c \<le> x" by auto
       hence "(\<lambda>x. integral (cbox b c) (\<lambda>t. of_real (bernpoly n (t - \<lfloor>Inf {b..c}\<rfloor>)) * f x t)) 
                holomorphic_on U" by (intro holo) auto
       thus ?case by simp
     qed
     also have "?this \<longleftrightarrow> (\<lambda>z. integral {a..x} (\<lambda>t. of_real (pbernpoly n t) * f z t)) 
                            holomorphic_on U"
     proof (intro holomorphic_cong refl, goal_cases)
       case (1 z)
       have "((\<lambda>t. of_real (pbernpoly n t) * f z t) has_integral
               (\<Sum>X\<in>A. integral X (\<lambda>t. of_real (bernpoly n (t - \<lfloor>Inf X\<rfloor>)) * f z t))) {a..x}"
         using division
       proof (rule has_integral_combine_division)
         fix X assume X: "X \<in> A"
         then obtain b c where X': "X = {b..c}" "b \<le> c" by (elim A_cases) auto
         from X and division have "X \<subseteq> {a..x}" by (auto simp: division_of_def)
         with X' have bc: "b \<ge> a" "c \<le> x" by auto
         have "((\<lambda>t. of_real (bernpoly n (t - of_int \<lfloor>Inf X\<rfloor>)) * f z t) has_integral
                  integral X (\<lambda>t. of_real (bernpoly n (t - of_int \<lfloor>Inf X\<rfloor>)) * f z t)) X"
           unfolding X' using \<open>z \<in> U\<close> bc by (intro integrable_integral int)
         also have "?this \<longleftrightarrow> ((\<lambda>t. of_real (pbernpoly n t) * f z t) has_integral
                  integral X (\<lambda>t. of_real (bernpoly n (t - of_int \<lfloor>Inf X\<rfloor>)) * f z t)) X"
         proof (rule has_integral_spike_eq[of "{Sup X}"], goal_cases)
           case (2 t)
           note t = this
           from \<open>X \<in> A\<close> have "\<lfloor>t\<rfloor> = \<lfloor>Inf X\<rfloor>"
           proof (cases rule: A_cases [consumes 1])
             case 1
             with t show ?thesis
               by (intro floor_unique) (auto simp: ceiling_altdef split: if_splits, (linarith+)?)
           next
             case 2
             with t show ?thesis
               by (intro floor_unique) (auto simp: ceiling_altdef split: if_splits, (linarith+)?)
           next
             case 3
             with t show ?thesis
               by (intro floor_unique) (auto simp: ceiling_altdef N_def split: if_splits)
           qed
           thus ?case by (simp add: pbernpoly_def frac_def)
         qed auto
         finally show \<dots> .
       qed
       thus ?case by (simp add: has_integral_iff)
     qed
     finally show ?thesis by simp
   qed auto
   thus "(\<lambda>z. integral {a..x} (\<lambda>t. of_real (pbernpoly n t) * f z t)) holomorphic_on U"
     by simp
 qed
 
 lemma
   assumes deriv: "\<And>y. a \<le> y \<Longrightarrow> (G has_real_derivative g y) (at y within {a..})"
   assumes deriv': 
     "\<And>z t x. z \<in> U \<Longrightarrow> x \<ge> a \<Longrightarrow> t \<in> {a..x} \<Longrightarrow> 
        ((\<lambda>z. f z t) has_field_derivative f' z t) (at z within U)"
   assumes cont: "continuous_on (U \<times> {of_int a..}) (\<lambda>(z, t). f' z t)"
   assumes int: "\<And>b c z e. a \<le> b \<Longrightarrow> z \<in> U \<Longrightarrow>
                   (\<lambda>t. of_real (bernpoly n (t - e)) * f z t) integrable_on {b..c}"
   assumes int': "\<And>a' b y. y \<in> U \<Longrightarrow>  a \<le> a' \<Longrightarrow> a' \<le> b \<Longrightarrow> 
                          (\<lambda>t. pbernpoly n t *\<^sub>R f y t) integrable_on {a'..b}"
   assumes conv: "convergent (\<lambda>y. G (real y))"
   assumes bound: "eventually (\<lambda>x. \<forall>y\<in>U. norm (f y x) \<le> g x) at_top"
   assumes "open U" 
   shows analytic_EM_remainder: "(\<lambda>s::complex. EM_remainder n (f s) a) analytic_on U"
     and holomorphic_EM_remainder: "(\<lambda>s::complex. EM_remainder n (f s) a) holomorphic_on U"
 proof -
   show "(\<lambda>s::complex. EM_remainder n (f s) a) analytic_on U"
   unfolding analytic_on_def
   proof
     fix z assume "z \<in> U"
     from \<open>z \<in> U\<close> and \<open>open U\<close> obtain \<epsilon> where \<epsilon>: "\<epsilon> > 0" "ball z \<epsilon> \<subseteq> U"
       by (auto simp: open_contains_ball)
     have "(\<lambda>s. EM_remainder n (f s) a) holomorphic_on ball z \<epsilon>"
     proof (rule holomorphic_uniform_sequence)
       fix x :: nat
       show "(\<lambda>s. EM_remainder' n (f s) a x) holomorphic_on ball z \<epsilon>"
       proof (rule holomorphic_EM_remainder', goal_cases)
         fix s t assume "s \<in> ball z \<epsilon>" "t \<in> {real_of_int a..real x}"
         thus "((\<lambda>z. f z t) has_field_derivative f' s t) (at s within ball z \<epsilon>)"
           using \<epsilon> by (intro DERIV_subset[OF deriv'[of _ x]]) auto
       next
         case (2 b c s e)
         with \<epsilon> have "s \<in> U" by blast
         with 2 show ?case using \<epsilon> int[of b s e c] by (cases "a \<le> x") auto
       next
         from cont show "continuous_on (ball z \<epsilon> \<times> {real_of_int a..real x}) (\<lambda>(z, t). f' z t)"
           by (rule continuous_on_subset) (insert \<epsilon>, auto)
       qed (auto)
     next
       fix s assume s: "s \<in> ball z \<epsilon>"
       have "open (ball z \<epsilon>)" by simp
       with s obtain \<delta> where \<delta>: "\<delta> > 0" "cball s \<delta> \<subseteq> ball z \<epsilon>" 
         unfolding open_contains_cball by blast
       moreover have bound': "eventually (\<lambda>x. \<forall>y\<in>cball s \<delta>. norm (f y x) \<le> g x) at_top"
         by (intro eventually_mono [OF bound]) (insert \<delta> \<epsilon>, auto)
       have "uniform_limit (cball s \<delta>) (\<lambda>x s. EM_remainder' n (f s) (real_of_int a) (real x))
                         (\<lambda>s. EM_remainder n (f s) a) sequentially"
         by (rule uniform_limit_EM_remainder[OF deriv int' conv bound']) (insert \<delta> \<epsilon> s, auto)
       ultimately show "\<exists>\<delta>>0. cball s \<delta> \<subseteq> ball z \<epsilon> \<and> uniform_limit (cball s \<delta>)
                           (\<lambda>x s. EM_remainder' n (f s) (real_of_int a) (real x))
                           (\<lambda>s. EM_remainder n (f s) a) sequentially" by blast
     qed auto
     with \<epsilon> show "\<exists>\<epsilon>>0. (\<lambda>s. EM_remainder n (f s) a) holomorphic_on ball z \<epsilon>"
       by blast
   qed
   thus "(\<lambda>s::complex. EM_remainder n (f s) a) holomorphic_on U"
     by (rule analytic_imp_holomorphic)
 qed
 
 
 
 text \<open>
   The following lemma is the first step in the proof of the Euler--MacLaurin formula: 
   We show the relationship between the first-order remainder term and the difference of 
   the integral and the sum.
 \<close>
   
 context
   fixes f f' :: "real \<Rightarrow> 'a :: banach"
   fixes a b :: int and I S :: 'a
   fixes Y :: "real set"
   assumes "a \<le> b"
   assumes fin: "finite Y"
   assumes cont: "continuous_on {real_of_int a..real_of_int b} f"
   assumes deriv [derivative_intros]: 
             "\<And>x::real. x \<in> {a..b} - Y \<Longrightarrow> (f has_vector_derivative f' x) (at x)"
   defines S_def: "S \<equiv> (\<Sum>i\<in>{a<..b}. f i)" and I_def: "I \<equiv> integral {a..b} f"
 begin
   
 lemma
   diff_sum_integral_has_integral_int:
     "((\<lambda>t. (frac t - 1/2) *\<^sub>R f' t) has_integral (S - I - (f b - f a) /\<^sub>R 2)) {a..b}"
 proof (cases "a = b")
   case True
   thus ?thesis by (simp_all add: S_def I_def has_integral_refl)
 next
   case False
   with \<open>a \<le> b\<close> have ab: "a < b" by simp
   let ?A = "(\<lambda>n. {real_of_int n..real_of_int (n+1)}) ` {a..<b}"
   have division: "?A division_of {of_int a..of_int b}"
     using Union_atLeastAtMost_real_of_int[OF ab] by (simp add: division_of_def)
   have cont' [continuous_intros]: "continuous_on A f" if "A \<subseteq> {of_int a..of_int b}" for A
     using continuous_on_subset[OF cont that] .
   
   define d where "d = (\<lambda>x. (f x + f (x + 1)) /\<^sub>R 2 - integral {x..x+1} f)"    
   have "((\<lambda>t. (frac t - 1/2) *\<^sub>R f' t) has_integral d i) {of_int i..of_int (i+1)}"
     if i: "i \<in> {a..<b}" for i
   proof (rule has_integral_spike)
     show "(frac x - 1 / 2) *\<^sub>R f' x = (x - of_int i - 1 / 2) *\<^sub>R f' x"
          if "x \<in> {of_int i..of_int (i + 1)} - {of_int (i + 1)}" for x
     proof -
       have "x \<ge> of_int i" "x < of_int (i + 1)" using that by auto
       hence "floor x = of_int i" by (subst floor_unique) auto
       thus ?thesis by (simp add: frac_def)
     qed
   next
     define h where "h = (\<lambda>x::real. (x - of_int i - 1 / 2) *\<^sub>R f' x)"
     define g where "g = (\<lambda>x::real. (x - of_int i - 1/2) *\<^sub>R f x - integral {of_int i..x} f)"
     have *: "((\<lambda>x. integral {real_of_int i..x} f) has_vector_derivative f x) (at x within {i..i+1})"
       if "x \<in> {of_int i<..<of_int i + 1}" for x using that i
       by (intro integral_has_vector_derivative cont') auto
     have "((\<lambda>x. integral {real_of_int i..x} f) has_vector_derivative f x) (at x)" 
       if "x \<in> {of_int i<..<of_int i + 1}" for x 
       using that i at_within_interior[of x "{of_int i..of_int (i + 1)}"] *[of x] by simp
     hence "(h has_integral g (of_int (i + 1)) - g (of_int i)) {of_int i..of_int (i+1)}"
       unfolding g_def h_def using that 
       by (intro fundamental_theorem_of_calculus_interior_strong[OF fin])
          (auto intro!: derivative_eq_intros continuous_intros indefinite_integral_continuous_1
              integrable_continuous_real)
     also have "g (of_int (i + 1)) - g (of_int i) = d i"
       by (simp add: g_def scaleR_add_right [symmetric] d_def)
     finally show "(h has_integral d i) {of_int i..of_int (i + 1)}" .
   qed simp_all
   hence *: "\<And>I. I\<in>?A \<Longrightarrow> ((\<lambda>x. (frac x - 1 / 2) *\<^sub>R f' x) has_integral d (\<lfloor>Inf I\<rfloor>)) I"
     by (auto simp: add_ac)
   have "((\<lambda>x::real. (frac x - 1 / 2) *\<^sub>R f' x) has_integral (\<Sum>I\<in>?A. d (\<lfloor>Inf I\<rfloor>))) (\<Union>?A)"
     by (intro has_integral_Union * finite_imageI) (force intro!: negligible_atLeastAtMostI pairwiseI)+
   also have "\<Union>?A = {of_int a..of_int b}"
     by (intro Union_atLeastAtMost_real_of_int ab)
   also have "(\<Sum>I\<in>?A. d (\<lfloor>Inf I\<rfloor>)) = (\<Sum>i=a..<b. d i)"
     by (subst sum.reindex) (auto simp: inj_on_def)
   also have "\<dots> = (1 / 2) *\<^sub>R ((\<Sum>i = a..<b. f (real_of_int i)) +
                     (\<Sum>i = a..<b. f (real_of_int (i + 1)))) -
                   (\<Sum>i = a..<b. integral {real_of_int i..1 + real_of_int i} f)"
     (is "_ = _ *\<^sub>R (?S1 + ?S2) - ?S3") 
     by (simp add: d_def algebra_simps sum.distrib sum_subtractf scaleR_sum_right)
   also have "?S1 = (\<Sum>i = a..b. f (real_of_int i)) - f b"
     unfolding S_def using ab by (subst sum_atLeastAtMost_int_last) auto
   also have "(\<Sum>i = a..b. f (real_of_int i)) = S + f a"
     unfolding S_def using ab by (subst sum_atLeastAtMost_int_head) auto
   also have "?S2 = S" unfolding S_def
     by (intro sum.reindex_bij_witness[of _ "\<lambda>i. i-1" "\<lambda>i. i+1"]) auto
   also have "(1 / 2) *\<^sub>R (S + f a - f b + S) = 
                 (1/2) *\<^sub>R S + (1/2) *\<^sub>R S - (f b - f a) /\<^sub>R 2"
     by (simp add: algebra_simps)
   also have "(1/2) *\<^sub>R S + (1/2) *\<^sub>R S = S" by (simp add: scaleR_add_right [symmetric])
       
   also have "?S3 = (\<Sum>I\<in>?A. integral I f)"
     by (subst sum.reindex) (auto simp: inj_on_def add_ac)
   also have "\<dots> = I" unfolding I_def
     by (intro integral_combine_division_topdown [symmetric] division integrable_continuous_real 
               continuous_intros) simp_all
   finally show ?thesis by (simp add: algebra_simps)
 qed
 
 lemma diff_sum_integral_has_integral_int':
   "((\<lambda>t. pbernpoly 1 t *\<^sub>R f' t) has_integral (S - I - (f b - f a) /\<^sub>R 2 )) {a..b}"
   using diff_sum_integral_has_integral_int by (simp add: pbernpoly_def bernpoly_def)
   
 lemma EM_remainder'_Suc_0: "EM_remainder' (Suc 0) f' a b = S - I - (f b - f a) /\<^sub>R 2"
   using diff_sum_integral_has_integral_int' by (simp add: has_integral_iff EM_remainder'_def)
 
 end
 
 
 text \<open>
   Next, we show that the $n$-th-order remainder can be expressed in terms of the $n+1$-th-order 
   remainder term. Iterating this essentially yields the Euler--MacLaurin formula.
 \<close>
 
 context
   fixes f f' :: "real \<Rightarrow> 'a :: banach" and a b :: int and n :: nat and A :: "real set"
   assumes ab: "a \<le> b" and n: "n > 0"
   assumes fin:   "finite A"
   assumes cont:  "continuous_on {of_int a..of_int b} f"
   assumes cont': "continuous_on {of_int a..of_int b} f'"
   assumes deriv: "\<And>x. x \<in> {of_int a<..<of_int b} - A \<Longrightarrow> (f has_vector_derivative f' x) (at x)"
 begin
   
 lemma EM_remainder'_integral_conv_Suc:
   shows   "integral {a..b} (\<lambda>t. pbernpoly n t *\<^sub>R f t) =
               (bernoulli (Suc n) / real (Suc n)) *\<^sub>R (f b - f a) -
               integral {a..b} (\<lambda>t. pbernpoly (Suc n) t *\<^sub>R f' t) /\<^sub>R real (Suc n)"
   unfolding EM_remainder'_def
 proof -
   let ?h = "\<lambda>i. (pbernpoly (Suc n) (real_of_int i) / real (Suc n)) *\<^sub>R f (real_of_int i)"
   define T where "T = integral {a..b} (\<lambda>t. (pbernpoly (Suc n) t / real (Suc n)) *\<^sub>R f' t)"
   note [derivative_intros] = has_field_derivative_pbernpoly_Suc'
   let ?A = "real_of_int ` {a..b} \<union> A"
     
   have "((\<lambda>t. pbernpoly n t *\<^sub>R f t) has_integral (-T + (?h b - ?h a))) {a..b}"
   proof (rule integration_by_parts_interior_strong[OF bounded_bilinear_scaleR])
     from fin show "finite ?A" by simp
     from \<open>n > 0\<close> show "continuous_on {of_int a..of_int b} (\<lambda>t. pbernpoly (Suc n) t / real (Suc n))"
       by (intro continuous_intros) auto
     show "continuous_on {of_int a..of_int b} f" by fact
     show "(f has_vector_derivative f' t) (at t)" if "t \<in> {of_int a<..<of_int b} - ?A" for t
       using deriv[of t] that by auto
     have "(\<lambda>t. pbernpoly (Suc n) t *\<^sub>R f' t) integrable_on {a..b}"
       by (intro integrable_EM_remainder' cont')
     hence "(\<lambda>t. (1 / real (Suc n)) *\<^sub>R pbernpoly (Suc n) t *\<^sub>R f' t) integrable_on {a..b}" 
       by (rule integrable_cmul)
     also have "(\<lambda>t. (1 / real (Suc n)) *\<^sub>R pbernpoly (Suc n) t *\<^sub>R f' t) =
                  (\<lambda>t. (pbernpoly (Suc n) t / real (Suc n)) *\<^sub>R f' t)"
       by (rule ext) (simp add: algebra_simps)
     finally show "((\<lambda>t. (pbernpoly (Suc n) t / real (Suc n)) *\<^sub>R f' t) 
                     has_integral ?h b - ?h a - (- T + (?h b - ?h a))) {a..b}"
       using integrable_EM_remainder'[of a b f' "Suc n"]
         by (simp add: has_integral_iff T_def)
     qed (insert ab n, auto intro!: derivative_eq_intros
            simp: has_field_derivative_iff_has_vector_derivative [symmetric] not_le elim!: Ints_cases)
     also have "?h b - ?h a = (bernoulli (Suc n) / real (Suc n)) *\<^sub>R (f b - f a)"
       using n by (simp add: algebra_simps bernoulli'_def)
     finally have "integral {a..b} (\<lambda>t. pbernpoly n t *\<^sub>R f t) = \<dots> - T"
       by (simp add: has_integral_iff)
     also have "T = integral {a..b} (\<lambda>t. (1 / real (Suc n)) *\<^sub>R (pbernpoly (Suc n) t) *\<^sub>R f' t)"
       by (simp add: T_def)
     also have "\<dots> = integral {a..b} (\<lambda>t. pbernpoly (Suc n) t *\<^sub>R f' t) /\<^sub>R real (Suc n)"
       by (subst integral_cmul) (simp_all add: divide_simps)
     finally show ?thesis .
 qed 
 
 lemma EM_remainder'_conv_Suc: 
   "EM_remainder' n f a b = 
      ((-1) ^ Suc n * bernoulli (Suc n) / fact (Suc n)) *\<^sub>R (f b - f a) + 
      EM_remainder' (Suc n) f' a b"
   by (simp add: EM_remainder'_def EM_remainder'_integral_conv_Suc scaleR_diff_right 
                 scaleR_add_right field_simps del: of_nat_Suc)
 
 end
 
 context
   fixes f f' :: "real \<Rightarrow> 'a :: banach" and a :: int and n :: nat and A :: "real set" and C
   assumes n: "n > 0"
   assumes fin:   "finite A"
   assumes cont:  "continuous_on {of_int a..} f"
   assumes cont': "continuous_on {of_int a..} f'"
   assumes lim:   "(f \<longlongrightarrow> C) at_top"
   assumes deriv: "\<And>x. x \<in> {of_int a<..} - A \<Longrightarrow> (f has_vector_derivative f' x) (at x)"
 begin  
   
 lemma
   shows EM_remainder_converges_iff_Suc_converges:
           "EM_remainder_converges n f a \<longleftrightarrow> EM_remainder_converges (Suc n) f' a"
   and   EM_remainder_conv_Suc: 
            "EM_remainder_converges n f a \<Longrightarrow> 
               EM_remainder n f a = 
                   ((-1) ^ Suc n * bernoulli (Suc n) / fact (Suc n)) *\<^sub>R (C - f a) + 
                   EM_remainder (Suc n) f' a"
 proof (rule iffI)
   define g where "g = (\<lambda>x. ((-1) ^ Suc n * bernoulli (Suc n) / fact (Suc n)) *\<^sub>R (f x - f a))"
   define G where "G = ((-1) ^ Suc n * bernoulli (Suc n) / fact (Suc n)) *\<^sub>R (C - f a)"
   have limit_g: "(g \<longlongrightarrow> G) at_top" unfolding g_def G_def by (intro tendsto_intros lim)
   have *: "eventually (\<lambda>x. EM_remainder' n f (real_of_int a) (real_of_int x) = 
               g x + EM_remainder' (Suc n) f' (real_of_int a) (real_of_int x)) at_top"
     using eventually_ge_at_top[of a]
   proof eventually_elim
     case (elim b)
     thus ?case
     using EM_remainder'_conv_Suc[OF elim n fin continuous_on_subset[OF cont] 
             continuous_on_subset[OF cont'] deriv] by (auto simp: g_def)
   qed
   
   {
     assume "EM_remainder_converges n f a"
     then obtain L
       where L: "((\<lambda>b. EM_remainder' n f (real_of_int a) (real_of_int b)) \<longlongrightarrow> L) at_top"
       by (auto simp: EM_remainder_converges_def)
     have *: "((\<lambda>b. EM_remainder' (Suc n) f' (real_of_int a) (real_of_int b)) \<longlongrightarrow> L - G) at_top"
     proof (rule Lim_transform_eventually)
       show "\<forall>\<^sub>F x in at_top. EM_remainder' n f (real_of_int a) (real_of_int x) - g x =
                EM_remainder' (Suc n) f' (real_of_int a) (real_of_int x)"
         using * by (simp add: algebra_simps)
       show "((\<lambda>x. EM_remainder' n f (real_of_int a) (real_of_int x) - g x) \<longlongrightarrow> L - G) at_top"
         by (intro tendsto_intros filterlim_compose[OF limit_g] L)
     qed
     from * show "EM_remainder_converges (Suc n) f' a" unfolding EM_remainder_converges_def ..
     from * have "EM_remainder (Suc n) f' a = L - G" by (rule EM_remainder_eqI)
     moreover from L have "EM_remainder n f a = L" by (rule EM_remainder_eqI)
     ultimately show "EM_remainder n f a = G + EM_remainder (Suc n) f' a" by (simp add: G_def)
   }
   {
     assume "EM_remainder_converges (Suc n) f' a" 
     then obtain L
       where L: "((\<lambda>b. EM_remainder' (Suc n) f' (real_of_int a) (real_of_int b)) \<longlongrightarrow> L) at_top"
       by (auto simp: EM_remainder_converges_def)
     have *: "((\<lambda>b. EM_remainder' n f (real_of_int a) (real_of_int b)) \<longlongrightarrow> G + L) at_top"
     proof (rule Lim_transform_eventually)
       show "\<forall>\<^sub>F x in at_top. g x + EM_remainder' (Suc n) f' (real_of_int a) (real_of_int x) =
                 EM_remainder' n f (real_of_int a) (real_of_int x)"
         using * by (subst eq_commute)
       show "((\<lambda>x. g x + EM_remainder' (Suc n) f' (real_of_int a) (real_of_int x)) \<longlongrightarrow> G + L) at_top"
         by (intro tendsto_intros filterlim_compose[OF limit_g] L)
     qed
     thus "EM_remainder_converges n f a" unfolding EM_remainder_converges_def ..
   }
 qed
 
 end
   
 
 
 subsection \<open>The conventional version of the Euler--MacLaurin formula\<close>
 
 text \<open>
   The following theorems are the classic Euler--MacLaurin formula that can be found,
   with slight variations, in many sources (e.\,g.\ \cite{AS_HMF, apostol99, GKP_CM}).
 \<close>
 
 context
   fixes f :: "real \<Rightarrow> 'a :: banach"
   fixes fs :: "nat \<Rightarrow> real \<Rightarrow> 'a"
   fixes a b :: int assumes ab: "a \<le> b"
   fixes N :: nat assumes N: "N > 0"
   fixes Y :: "real set" assumes fin: "finite Y"
   assumes fs_0 [simp]: "fs 0 = f"
   assumes fs_cont [continuous_intros]:  
     "\<And>k. k \<le> N \<Longrightarrow> continuous_on {real_of_int a..real_of_int b} (fs k)"
   assumes fs_deriv [derivative_intros]: 
     "\<And>k x. k < N \<Longrightarrow> x \<in> {a..b} - Y \<Longrightarrow> (fs k has_vector_derivative fs (Suc k) x) (at x)"
 begin
 
 theorem euler_maclaurin_raw_strong_int:
   defines "S \<equiv> (\<Sum>i\<in>{a<..b}. f (of_int i))"
   defines "I \<equiv> integral {of_int a..of_int b} f"
   defines "c' \<equiv> \<lambda>k. (bernoulli' (Suc k) / fact (Suc k)) *\<^sub>R (fs k b - fs k a)"
   shows   "S - I = (\<Sum>k<N. c' k) + EM_remainder' N (fs N) a b"
 proof -
   define c :: "nat \<Rightarrow> 'a" 
     where "c = (\<lambda>k. ((-1) ^ (Suc k) * bernoulli (Suc k) / fact (Suc k)) *\<^sub>R (fs k b - fs k a))"
   have "S - I = (\<Sum>k<m. c k) + EM_remainder' m (fs m) a b" if "m \<ge> 1" "m \<le> N" for m
   using that
   proof (induction m rule: dec_induct)
     case base
     with ab fin fs_cont[of 0] show ?case using fs_deriv[of 0] N unfolding One_nat_def
       by (subst EM_remainder'_Suc_0[of _ _ Y f]) (simp_all add: algebra_simps S_def I_def c_def)
   next
     case (step n)
     from step.prems have "S - I = (\<Sum>k<n. c k) + EM_remainder' n (fs n) a b"
       by (intro step.IH) simp_all
     also have "(\<Sum>k<n. c k) = (\<Sum>k<Suc n. c k) +
                   (((-1) ^ n * bernoulli (Suc n) / fact (Suc n)) *\<^sub>R (fs n b - fs n a))"
       (is "_ = _ + ?c") by (simp add: EM_remainder'_Suc_0 c_def)
     also have "\<dots> + EM_remainder' n (fs n) a b = (\<Sum>k<Suc n. c k) + (?c + EM_remainder' n (fs n) a b)"
       by (simp add: add.assoc)
     also from step.prems step.hyps ab fin
       have "?c + EM_remainder' n (fs n) a b = EM_remainder' (Suc n) (fs (Suc n)) a b"
       by (subst EM_remainder'_conv_Suc [where A = Y]) 
          (auto intro!: fs_deriv fs_cont)
     finally show ?case .
   qed
   from this[of N] and N 
     have "S - I = sum c {..<N} + EM_remainder' N (fs N) (real_of_int a) (real_of_int b)" by simp
   also have "sum c {..<N} = sum c' {..<N}"
   proof (intro sum.cong refl)
     fix k :: nat
     show "c k = c' k"
       by (cases "even k")
          (auto simp: c_def c'_def bernoulli'_def algebra_simps bernoulli_odd_eq_0)
   qed
   finally show ?thesis .
 qed
 
 end
 
 theorem euler_maclaurin_strong_raw_nat:
   assumes "a \<le> b" "0 < N" "finite Y" "fs 0 = f"
     "(\<And>k. k \<le> N \<Longrightarrow> continuous_on {real a..real b} (fs k))"
     "(\<And>k x. k < N \<Longrightarrow> x \<in> {real a..real b} - Y \<Longrightarrow>
        (fs k has_vector_derivative fs (Suc k) x) (at x))"
   shows "(\<Sum>i\<in>{a<..b}. f (real i)) - integral {real a..real b} f =
            (\<Sum>k<N. (bernoulli' (Suc k) / fact (Suc k)) *\<^sub>R (fs k (real b) - fs k (real a))) +
            EM_remainder' N (fs N) (real a) (real b)"
 proof -
   have "(\<Sum>i\<in>{int a<..int b}. f (real_of_int i)) - 
            integral {real_of_int (int a)..real_of_int (int b)} f =
            (\<Sum>k<N. (bernoulli' (Suc k) / fact (Suc k)) *\<^sub>R 
              (fs k (real_of_int (int b)) - fs k (real_of_int (int a)))) +
            EM_remainder' N (fs N) (real_of_int (int a)) (real_of_int (int b))"
     using assms by (intro euler_maclaurin_raw_strong_int[where Y = Y] assms) simp_all
   also have "(\<Sum>i\<in>{int a<..int b}. f (real_of_int i)) = (\<Sum>i\<in>{a<..b}. f (real i))"
     by (intro sum.reindex_bij_witness[of _ int nat]) auto
   finally show ?thesis by simp
 qed
 
   
 subsection \<open>The ``Concrete Mathematics'' version of the Euler--MacLaurin formula\<close>
 
 text \<open>
   As explained in \textit{Concrete Mathematics}~\cite{GKP_CM}, the above form of the 
   formula has some drawbacks: When applying it to determine the asymptotics of some concrete 
   function, one is usually left with several different unwieldy constant terms that are difficult 
   to get rid of.
 
   There is no general way to determine what these constant terms are, but in concrete applications, 
   they can often be determined or estimated by other means. We can therefore simply group all the 
   constant terms into a single constant and have the user provide a proof of what it is.
 \<close>
 
 locale euler_maclaurin_int =
   fixes F f :: "real \<Rightarrow> 'a :: banach"
   fixes fs :: "nat \<Rightarrow> real \<Rightarrow> 'a"
   fixes a :: int
   fixes N :: nat assumes N: "N > 0"
   fixes C :: 'a
   fixes Y :: "real set" assumes fin: "finite Y"
   assumes fs_0 [simp]: "fs 0 = f"
   assumes fs_cont [continuous_intros]:  
     "\<And>k. k \<le> N \<Longrightarrow> continuous_on {real_of_int a..} (fs k)"
   assumes fs_deriv [derivative_intros]: 
     "\<And>k x. k < N \<Longrightarrow> x \<in> {of_int a..} - Y \<Longrightarrow> (fs k has_vector_derivative fs (Suc k) x) (at x)"
   assumes F_cont [continuous_intros]: "continuous_on {of_int a..} F"
   assumes F_deriv [derivative_intros]: 
     "\<And>x. x \<in> {of_int a..} - Y \<Longrightarrow> (F has_vector_derivative f x) (at x)" 
   assumes limit: 
     "((\<lambda>b. (\<Sum>k=a..b. f k) - F (of_int b) - 
          (\<Sum>i<N. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R fs i (of_int b))) \<longlongrightarrow> C) at_top"
 begin
 
 context
   fixes C' T
   defines "C' \<equiv> -f a + F a + C + (\<Sum>k<N. (bernoulli' (Suc k) / fact (Suc k)) *\<^sub>R (fs k (of_int a)))"
       and "T \<equiv> (\<lambda>x. \<Sum>i<N. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R fs i x)"
 begin
   
 lemma euler_maclaurin_strong_int_aux:
   assumes ab: "a \<le> b"
   defines "S \<equiv> (\<Sum>k=a..b. f (of_int k))"
   shows "S - F (of_int b) - T (of_int b) = EM_remainder' N (fs N) (of_int a) (of_int b) + (C - C')"
 proof (cases "a = b")
   case True
   thus ?thesis unfolding C'_def by (simp add: S_def EM_remainder'_def T_def)
 next
   case False
   with assms have ab: "a < b" by simp
   define T' where "T' = (\<Sum>k<N. (bernoulli' (Suc k) / fact (Suc k)) *\<^sub>R (fs k (of_int a)))"
   have "(\<Sum>i\<in>{a<..b}. f (of_int i)) - integral {of_int a..of_int b} f =
           (\<Sum>k<N. (bernoulli' (Suc k) / fact (Suc k)) *\<^sub>R (fs k (of_int b) - fs k (of_int a))) +
           EM_remainder' N (fs N) (of_int a) (of_int b)" using ab
     by (intro euler_maclaurin_raw_strong_int [where Y = Y] N fin fs_0
               continuous_on_subset[OF fs_cont] fs_deriv) auto
   also have "(f has_integral (F b - F a)) {of_int a..of_int b}" using ab
     by (intro fundamental_theorem_of_calculus_strong[OF fin])
        (auto intro!: continuous_on_subset[OF F_cont] derivative_intros)
   hence "integral {of_int a..of_int b} f = F (of_int b) - F (of_int a)"
     by (simp add: has_integral_iff)
   also have "(\<Sum>k<N. (bernoulli' (Suc k) / fact (Suc k)) *\<^sub>R (fs k (of_int b) - fs k (of_int a))) =
                T (of_int b) - T'"
     by (simp add: T_def T'_def algebra_simps sum_subtractf)
   also have "(\<Sum>i\<in>{a<..b}. f (of_int i)) = S - f (of_int a)"
     unfolding S_def using ab by (subst sum_atLeastAtMost_int_head) auto
   finally show ?thesis by (simp add: algebra_simps C'_def T'_def)  
 qed
 
 lemma EM_remainder_limit:
   assumes ab: "a \<le> b"
   defines "D \<equiv> EM_remainder' N (fs N) (of_int a) (of_int b)"
   shows "EM_remainder N (fs N) b = C' - D"
     and EM_remainder_converges: "EM_remainder_converges N (fs N) b"
 proof -
   note limit
   also have "((\<lambda>b. (\<Sum>k = a..b. f (of_int k)) - F (of_int b) -
                (\<Sum>i<N. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R fs i (of_int b))) \<longlongrightarrow> C) at_top =
              ((\<lambda>b. (\<Sum>k = a..b. f (of_int k)) - F (of_int b) - T (of_int b)) \<longlongrightarrow> C) at_top"
     unfolding T_def ..
   also have "eventually (\<lambda>x. (\<Sum>k=a..x. f k) - F (of_int x) - T (of_int x) = 
                EM_remainder' N (fs N) (of_int a) (of_int x) + (C - C')) at_top"
     (is "eventually (\<lambda>x. ?f x = ?g x) _")
     using eventually_gt_at_top[of b]
     by eventually_elim (rule euler_maclaurin_strong_int_aux, insert ab, simp_all)
   hence "(?f \<longlongrightarrow> C) at_top \<longleftrightarrow> (?g \<longlongrightarrow> C) at_top" by (intro filterlim_cong refl)
   finally have "((\<lambda>x. ?g x - (C - C')) \<longlongrightarrow> (C - (C - C'))) at_top"
     by (rule tendsto_diff[OF _ tendsto_const])
   hence *: "((\<lambda>x. EM_remainder' N (fs N) (of_int a) (of_int x)) \<longlongrightarrow> C') at_top"
     by simp
   
   have "((\<lambda>x. EM_remainder' N (fs N) (of_int a) (of_int x) - D) \<longlongrightarrow> C' - D) at_top"
     by (intro tendsto_intros *)
   also have "eventually (\<lambda>x. EM_remainder' N (fs N) (of_int a) (of_int x) - D = 
                           EM_remainder' N (fs N) (of_int b) (of_int x)) at_top" 
     (is "eventually (\<lambda>x. ?f x = ?g x) _") using eventually_ge_at_top[of b]
   proof eventually_elim
     case (elim x)
     have "EM_remainder' N (fs N) (of_int a) (of_int x) = 
             D + EM_remainder' N (fs N) (of_int b) (of_int x)" 
       using elim ab unfolding D_def
       by (intro EM_remainder'_combine [symmetric] continuous_on_subset[OF fs_cont]) auto
     thus ?case by simp
   qed
   hence "(?f \<longlongrightarrow> C' - D) at_top \<longleftrightarrow> (?g \<longlongrightarrow> C' - D) at_top" by (intro filterlim_cong refl)
   finally have *: \<dots> .
   from * show "EM_remainder_converges N (fs N) b" unfolding EM_remainder_converges_def ..
   from * show "EM_remainder N (fs N) b = C' - D"
     by (rule EM_remainder_eqI)
 qed
 
 theorem euler_maclaurin_strong_int:
   assumes ab: "a \<le> b"
   defines "S \<equiv> (\<Sum>k=a..b. f (of_int k))"
   shows "S = F (of_int b) + C + T (of_int b) - EM_remainder N (fs N) b"
 proof -
   have "S = F (of_int b) + T (of_int b) + - (C' - EM_remainder' N (fs N) (of_int a) (of_int b)) + C"
     using euler_maclaurin_strong_int_aux[OF ab] by (simp add: algebra_simps S_def)
   also have "C' - EM_remainder' N (fs N) (of_int a) (of_int b) = EM_remainder N (fs N) b"
     using ab by (rule EM_remainder_limit(1) [symmetric])
   finally show ?thesis by simp
 qed
   
 end
 end
 
 
 text \<open>
   The following version of the formula removes all the terms where the associated
   Bernoulli numbers vanish. 
 \<close>
 
 locale euler_maclaurin_int' =
   fixes F f :: "real \<Rightarrow> 'a :: banach"
   fixes fs :: "nat \<Rightarrow> real \<Rightarrow> 'a"
   fixes a :: int
   fixes N :: nat
   fixes C :: 'a
   fixes Y :: "real set" assumes fin: "finite Y"
   assumes fs_0 [simp]: "fs 0 = f"
   assumes fs_cont [continuous_intros]:  
     "\<And>k. k \<le> 2*N+1 \<Longrightarrow> continuous_on {real_of_int a..} (fs k)"
   assumes fs_deriv [derivative_intros]: 
     "\<And>k x. k \<le> 2*N \<Longrightarrow> x \<in> {of_int a..} - Y \<Longrightarrow> (fs k has_vector_derivative fs (Suc k) x) (at x)"
   assumes F_cont [continuous_intros]: "continuous_on {of_int a..} F"
   assumes F_deriv [derivative_intros]: 
     "\<And>x. x \<in> {of_int a..} - Y \<Longrightarrow> (F has_vector_derivative f x) (at x)" 
   assumes limit: 
     "((\<lambda>b. (\<Sum>k=a..b. f k) - F (of_int b) -
          (\<Sum>i<2*N+1. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R fs i (of_int b))) \<longlongrightarrow> C) at_top"
 begin
 
 sublocale euler_maclaurin_int F f fs a "2*N+1" C Y
   by standard (insert fin fs_0 fs_cont fs_deriv F_cont F_deriv limit, simp_all)
 
 theorem euler_maclaurin_strong_int':
   assumes "a \<le> b"
   shows   "(\<Sum>k=a..b. f (of_int k)) = 
              F (of_int b) + C + (1 / 2) *\<^sub>R f (of_int b) +
              (\<Sum>i=1..N. (bernoulli (2*i) / fact (2*i)) *\<^sub>R fs (2*i-1) (of_int b)) - 
              EM_remainder (2*N+1) (fs (2*N+1)) b"
 proof -
   have "(\<Sum>k=a..b. f (real_of_int k)) = 
                F (of_int b) + C + (\<Sum>i<2*N+1. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R fs i (of_int b)) - 
                EM_remainder (2*N+1) (fs (2*N+1)) b"
     by (rule euler_maclaurin_strong_int)
        (simp_all only: lessThan_Suc_atMost Suc_eq_plus1 [symmetric] assms)
   also have "{..<2*N+1} = insert 0 {1..2*N}" by auto
   also have "(\<Sum>i\<in>\<dots>. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R fs i (of_int b)) =
                (1 / 2) *\<^sub>R f (of_int b) + 
                (\<Sum>i\<in>{1..2*N}. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R fs i (of_int b))"
     by (subst sum.insert) (auto simp: assms bernoulli'_def)
   also have "(\<Sum>i\<in>{1..2*N}. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R fs i (of_int b)) =
                (\<Sum>i\<in>{1..N}. (bernoulli' (2*i) / fact (2*i)) *\<^sub>R fs (2*i-1) (of_int b))"
   proof (rule sym, rule sum.reindex_bij_witness_not_neutral)
     fix i assume "i \<in> {1..2*N} - {i\<in>{1..2*N}. even i}"
     thus "2 * ((i + 1) div 2) - 1 = i" "(i + 1) div 2 \<in> {1..N} - {}" 
       by (auto elim!: oddE)
   qed (auto simp: bernoulli_odd_eq_0 bernoulli'_def algebra_simps)
   also have "\<dots> = (\<Sum>i\<in>{1..N}. (bernoulli (2*i) / fact (2*i)) *\<^sub>R fs (2*i-1) (of_int b))"
     by (intro sum.cong refl) (auto simp: bernoulli'_def)
   finally show ?thesis by (simp only: add_ac)
 qed
 
 end
 
 
 text \<open>
   For convenience, we also offer a version where the sum ranges over natural numbers
   instead of integers.
 \<close>
 
 lemma sum_atLeastAtMost_of_int_nat_transfer:
   "(\<Sum>k=int a..int b. f (of_int k)) = (\<Sum>k=a..b. f (of_nat k))"
   by (intro sum.reindex_bij_witness[of _ int nat]) auto
   
 lemma euler_maclaurin_nat_int_transfer:
   fixes F and f :: "real \<Rightarrow> 'a :: real_normed_vector"
   assumes "((\<lambda>b. (\<Sum>k=a..b. f (real k)) - F (real b) - T (real b)) \<longlongrightarrow> C) at_top"
   shows   "((\<lambda>b. (\<Sum>k=int a..b. f (of_int k)) - F (of_int b) - T (of_int b)) \<longlongrightarrow> C) at_top"
 proof -
   have *: "((\<lambda>b. (\<Sum>k=int a..int b. f (of_int k)) - F (of_int (int b)) - T (of_int (int b)))
             \<longlongrightarrow> C) at_top" using assms by (subst sum_atLeastAtMost_of_int_nat_transfer) simp
   thus ?thesis by (rule filterlim_int_of_nat_at_topD)
 qed
   
 locale euler_maclaurin_nat =
   fixes F f :: "real \<Rightarrow> 'a :: banach"
   fixes fs :: "nat \<Rightarrow> real \<Rightarrow> 'a"
   fixes a :: nat
   fixes N :: nat assumes N: "N > 0"
   fixes C :: 'a
   fixes Y :: "real set" assumes fin: "finite Y"
   assumes fs_0 [simp]: "fs 0 = f"
   assumes fs_cont [continuous_intros]:  
     "\<And>k. k \<le> N \<Longrightarrow> continuous_on {real a..} (fs k)"
   assumes fs_deriv [derivative_intros]: 
     "\<And>k x. k < N \<Longrightarrow> x \<in> {real a..} - Y \<Longrightarrow> (fs k has_vector_derivative fs (Suc k) x) (at x)"
   assumes F_cont [continuous_intros]: "continuous_on {real a..} F"
   assumes F_deriv [derivative_intros]: 
     "\<And>x. x \<in> {real a..} - Y \<Longrightarrow> (F has_vector_derivative f x) (at x)" 
   assumes limit: 
     "((\<lambda>b. (\<Sum>k=a..b. f k) - F (real b) - 
          (\<Sum>i<N. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R fs i (real b))) \<longlongrightarrow> C) at_top"
 begin
 
 sublocale euler_maclaurin_int F f fs "int a" N C Y
   by standard (insert N fin fs_cont fs_deriv F_cont F_deriv 
                  euler_maclaurin_nat_int_transfer[OF limit], simp_all)
 
 theorem euler_maclaurin_strong_nat:
   assumes ab: "a \<le> b"
   defines "S \<equiv> (\<Sum>k=a..b. f (real k))"
   shows "S = F (real b) + C + (\<Sum>i<N. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R fs i (real b)) - 
                EM_remainder N (fs N) (int b)"
   using euler_maclaurin_strong_int[of "int b"]
   by (simp add: assms sum_atLeastAtMost_of_int_nat_transfer)
 
 end
 
 locale euler_maclaurin_nat' =
   fixes F f :: "real \<Rightarrow> 'a :: banach"
   fixes fs :: "nat \<Rightarrow> real \<Rightarrow> 'a"
   fixes a :: nat
   fixes N :: nat
   fixes C :: 'a
   fixes Y :: "real set" assumes fin: "finite Y"
   assumes fs_0 [simp]: "fs 0 = f"
   assumes fs_cont [continuous_intros]:  
     "\<And>k. k \<le> 2*N+1 \<Longrightarrow> continuous_on {real a..} (fs k)"
   assumes fs_deriv [derivative_intros]: 
     "\<And>k x. k \<le> 2*N \<Longrightarrow> x \<in> {real a..} - Y \<Longrightarrow> (fs k has_vector_derivative fs (Suc k) x) (at x)"
   assumes F_cont [continuous_intros]: "continuous_on {real a..} F"
   assumes F_deriv [derivative_intros]: 
     "\<And>x. x \<in> {real a..} - Y \<Longrightarrow> (F has_vector_derivative f x) (at x)" 
   assumes limit: 
     "((\<lambda>b. (\<Sum>k=a..b. f k) - F (real b) - 
         (\<Sum>i<2*N+1. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R fs i (real b))) \<longlongrightarrow> C) at_top"
 begin
 
 sublocale euler_maclaurin_int' F f fs "int a" N C Y
   by standard (insert fin fs_cont fs_deriv F_cont F_deriv 
                  euler_maclaurin_nat_int_transfer[OF limit], simp_all)
 
 theorem euler_maclaurin_strong_nat':
   assumes "a \<le> b"
   shows   "(\<Sum>k=a..b. f (real k)) = 
              F (real b) + C + (1 / 2) *\<^sub>R f (real b) +
              (\<Sum>i=1..N. (bernoulli (2*i) / fact (2*i)) *\<^sub>R fs (2*i-1) (real b)) - 
              EM_remainder (2*N+1) (fs (2*N+1)) b"
   using euler_maclaurin_strong_int'[of b]
   by (simp add: assms sum_atLeastAtMost_of_int_nat_transfer)
     
 end
 
 
 subsection \<open>Bounds on the remainder term\<close>
 
 text \<open>
   The following theorems provide some simple means to bound the remainder terms.
   In practice, better bounds can often be obtained e.\,g. for the $n$-th remainder term
   by expanding it to the sum of the first discarded term in the expansion and the $n+1$-th 
   remainder term.
 \<close>
 
 lemma
   fixes f :: "real \<Rightarrow> 'a :: {real_normed_field, banach}"
     and g g' :: "real \<Rightarrow> real"
   assumes fin:     "finite Y"
   assumes pbernpoly_bound: "\<forall>x. \<bar>pbernpoly n x\<bar> \<le> D"
   assumes cont_f:  "continuous_on {a..} f"
   assumes cont_g:  "continuous_on {a..} g"
   assumes cont_g': "continuous_on {a..} g'"
   assumes limit_g: "(g \<longlongrightarrow> C) at_top"
   assumes f_bound: "\<And>x. x \<ge> a \<Longrightarrow> norm (f x) \<le> g' x"
   assumes deriv:   "\<And>x. x \<in> {a..} - Y \<Longrightarrow> (g has_field_derivative g' x) (at x)"
   shows   norm_EM_remainder_le_strong_int:
             "\<forall>x. of_int x \<ge> a \<longrightarrow> norm (EM_remainder n f x) \<le> D / fact n * (C - g x)"
   and     norm_EM_remainder_le_strong_nat:
             "\<forall>x. real x \<ge> a \<longrightarrow> norm (EM_remainder n f (int x)) \<le> D / fact n * (C - g x)"
 proof -
   from pbernpoly_bound have D: "norm (pbernpoly n x) \<le> D" for x by auto 
   from this[of 0] have D_nonneg: "D \<ge> 0" by simp
   define D' where "D' = D / fact n"
   from D_nonneg have D'_nonneg: "D' \<ge> 0" by (simp add: D'_def)
 
   have bound: "norm (EM_remainder' n f x y) \<le> D' * (g y - g x)"
     if xy: "x \<ge> a" "x \<le> y" for x y :: real
   proof -
     have "norm (EM_remainder' n f x y) = norm (integral {x..y} (\<lambda>t. pbernpoly n t *\<^sub>R f t)) / fact n"
       by (simp add: EM_remainder'_def)
     also have "(\<lambda>t. D * g' t) integrable_on {x..y}" using xy
       by (intro integrable_continuous_real continuous_intros continuous_on_subset[OF cont_g'])
          auto
     hence "norm (integral {x..y} (\<lambda>t. pbernpoly n t *\<^sub>R f t)) \<le>
             integral {x..y} (\<lambda>t. D * g' t)" using D D_nonneg xy
       by (intro integral_norm_bound_integral integrable_EM_remainder' 
                continuous_on_subset[OF cont_f]) (auto intro!: mult_mono f_bound)
     also have "\<dots> = D * integral {x..y} g'" by simp
     also have "(g' has_integral (g y - g x)) {x..y}" using xy
       by (intro fundamental_theorem_of_calculus_strong[OF fin] continuous_on_subset[OF cont_g])
          (auto simp: has_field_derivative_iff_has_vector_derivative [symmetric] intro!: deriv)
     hence "integral {x..y} g' = g y - g x" by (simp add: has_integral_iff)
     finally show ?thesis by (simp add: D'_def divide_simps)
   qed
   
   have lim: "((\<lambda>y. EM_remainder' n f x (of_int y)) \<longlongrightarrow> EM_remainder n f x) at_top" 
     if x: "x \<ge> a" for x :: int
   proof -
     have "(\<lambda>n. g (real n)) \<longlonglongrightarrow> C" 
       by (rule filterlim_compose[OF limit_g filterlim_real_sequentially])
     hence Cauchy: "Cauchy (\<lambda>n. g (real n))" using convergent_eq_Cauchy by blast
     have "Cauchy (\<lambda>y. EM_remainder' n f x (int y))"
     proof (rule CauchyI', goal_cases)
       case (1 \<epsilon>)
       define \<epsilon>' where "\<epsilon>' = (if D' = 0 then 1 else \<epsilon> / (2*D'))"
       from \<open>\<epsilon> > 0\<close> D'_nonneg have \<epsilon>': "\<epsilon>' > 0" by (simp add: \<epsilon>'_def divide_simps)
       from CauchyD[OF Cauchy this] obtain M 
         where M: "\<And>m n. m \<ge> M \<Longrightarrow> n \<ge> M \<Longrightarrow> norm (g (real m) - g (real n)) < \<epsilon>'" by blast
       show ?case
       proof (intro CauchyI' exI[of _ "max (max 0 M) (nat x)"] allI impI, goal_cases)
         case (1 k l)
         have "EM_remainder' n f x k + EM_remainder' n f k l = EM_remainder' n f x l"
           using 1 x by (intro EM_remainder'_combine continuous_on_subset[OF cont_f]) auto
         hence "EM_remainder' n f x l - EM_remainder' n f x k = EM_remainder' n f k l" 
           by (simp add: algebra_simps)
         also from 1 x have "norm \<dots> \<le> D' * (g l - g k)" by (intro bound) auto
         also have "g l - g k \<le> norm (g l - g k)" by simp
         also from 1 have "\<dots> \<le> \<epsilon>'" using M[of l k] by auto
         also from \<open>\<epsilon> > 0\<close> have "D' * \<epsilon>' \<le> \<epsilon> / 2" by (simp add: \<epsilon>'_def)
         also from \<open>\<epsilon> > 0\<close> have "\<dots> < \<epsilon>" by simp
         finally show ?case by (simp add: D'_nonneg mult_left_mono dist_norm norm_minus_commute)
       qed
     qed
     then obtain L where "(\<lambda>y. EM_remainder' n f x (int y)) \<longlonglongrightarrow> L"
       by (auto simp: Cauchy_convergent_iff convergent_def)
     from filterlim_int_of_nat_at_topD[OF this]
       have "((\<lambda>y. EM_remainder' n f x (of_int y)) \<longlongrightarrow> L) at_top" by simp
     moreover from this have "EM_remainder n f x = L" by (rule EM_remainder_eqI)
     ultimately show "((\<lambda>y. EM_remainder' n f x (of_int y)) \<longlongrightarrow> EM_remainder n f x) at_top"
       by simp
   qed
   
   have *: "norm (EM_remainder n f x) \<le> D' * (C - g x)" if x: "x \<ge> a" for x :: int
   proof (rule tendsto_le)
     show "((\<lambda>y. D' * (g (of_int y) - g (of_int x))) \<longlongrightarrow> D' * (C - g (of_int x))) at_top"
       by (intro tendsto_intros filterlim_compose[OF limit_g])
     show "((\<lambda>y. norm (EM_remainder' n f x (of_int y))) \<longlongrightarrow> norm (EM_remainder n f x)) at_top"
       using x by (intro tendsto_norm lim)
     show "eventually (\<lambda>y. norm (EM_remainder' n f (of_int x) (of_int y))
              \<le> D' * (g (of_int y) - g (of_int x))) at_top" 
       using eventually_ge_at_top[of x] by eventually_elim (rule bound, insert x, simp_all)
   qed simp_all
   thus "\<forall>x. of_int x \<ge> a \<longrightarrow> norm (EM_remainder n f x) \<le> D' * (C - g x)" by blast
   
   have "norm (EM_remainder n f x) \<le> D' * (C - g x)" if x: "x \<ge> a" for x :: nat
     using x *[of "int x"] by simp
   thus "\<forall>x. real x \<ge> a \<longrightarrow> norm (EM_remainder n f (int x)) \<le> D' * (C - g x)" by blast
 qed
 
 lemma
   fixes f :: "real \<Rightarrow> 'a :: {real_normed_field, banach}"
     and g g' :: "real \<Rightarrow> real"
   assumes fin:     "finite Y"
   assumes pbernpoly_bound: "\<forall>x. \<bar>pbernpoly n x\<bar> \<le> D"
   assumes cont_f:  "continuous_on {a..} f"
   assumes cont_g:  "continuous_on {a..} g"
   assumes cont_g': "continuous_on {a..} g'"
   assumes limit_g: "(g \<longlongrightarrow> 0) at_top"
   assumes f_bound: "\<And>x. x \<ge> a \<Longrightarrow> norm (f x) \<le> g' x"
   assumes deriv:   "\<And>x. x \<in> {a..} - Y \<Longrightarrow> (g has_field_derivative -g' x) (at x)"
   shows   norm_EM_remainder_le_strong_int': 
             "\<forall>x. of_int x \<ge> a \<longrightarrow> norm (EM_remainder n f x) \<le> D / fact n * g x"
     and   norm_EM_remainder_le_strong_nat': 
             "\<forall>x. real x \<ge> a \<longrightarrow> norm (EM_remainder n f (int x)) \<le> D / fact n * g x"
 proof -
   have "\<forall>x. of_int x \<ge> a \<longrightarrow> norm (EM_remainder n f x) \<le> D / fact n * (0 - (-g x))" using assms
     by (intro norm_EM_remainder_le_strong_int[OF fin pbernpoly_bound _ _ cont_g'])
        (auto intro!: continuous_intros tendsto_eq_intros derivative_eq_intros)
   thus "\<forall>x. of_int x \<ge> a \<longrightarrow> norm (EM_remainder n f x) \<le> D / fact n * g x" by auto
 next
   have "\<forall>x. real x \<ge> a \<longrightarrow> norm (EM_remainder n f (int x)) \<le> D / fact n * (0 - (-g x))" using assms
     by (intro norm_EM_remainder_le_strong_nat[OF fin pbernpoly_bound _ _ cont_g'])
        (auto intro!: continuous_intros tendsto_eq_intros derivative_eq_intros)
   thus "\<forall>x. real x \<ge> a \<longrightarrow> norm (EM_remainder n f (int x)) \<le> D / fact n * g x" by auto
 qed
 
 lemma norm_EM_remainder'_le:
   fixes f :: "real \<Rightarrow> 'a :: {real_normed_field, banach}"
     and g g' :: "real \<Rightarrow> real"
   assumes cont_f: "continuous_on {a..} f"
   assumes cont_g': "continuous_on {a..} g'"
   assumes f_bigo: "eventually (\<lambda>x. norm (f x) \<le> g' x) at_top"
   assumes deriv:  "eventually (\<lambda>x. (g has_field_derivative g' x) (at x)) at_top"
   obtains C D where
     "eventually (\<lambda>x. norm (EM_remainder' n f a x) \<le> C + D * g x) at_top"
 proof -
   note cont = continuous_on_subset[OF cont_f] continuous_on_subset[OF cont_g']
   from bounded_pbernpoly[of n] obtain D where D: "\<And>x. norm (pbernpoly n x) \<le> D" by blast
   from this[of 0] have D_nonneg: "D \<ge> 0" by simp
   from eventually_conj[OF f_bigo eventually_conj[OF deriv eventually_ge_at_top[of a]]] 
     obtain x0 where x0:
       "x0 \<ge> a" "\<And>x. x \<ge> x0 \<Longrightarrow> norm (f x) \<le> g' x" 
       "\<And>x. x \<ge> x0 \<Longrightarrow> (g has_field_derivative g' x) (at x)"
       by (auto simp: eventually_at_top_linorder)
   define C where "C = (norm (integral {a..x0} (\<lambda>t. pbernpoly n t *\<^sub>R f t)) - D * g x0) / fact n"
       
   have "eventually (\<lambda>x. norm (EM_remainder' n f a x) \<le> C + D / fact n * g x) at_top"
     using eventually_ge_at_top[of x0]
   proof eventually_elim
     case (elim x)
     have "integral {a..x} (\<lambda>t. pbernpoly n t *\<^sub>R f t) =
             integral {a..x0} (\<lambda>t. pbernpoly n t *\<^sub>R f t) +
             integral {x0..x} (\<lambda>t. pbernpoly n t *\<^sub>R f t)" (is "_ = ?I1 + ?I2") using elim x0(1)
       by (intro Henstock_Kurzweil_Integration.integral_combine [symmetric] integrable_EM_remainder' cont) auto
     also have "norm \<dots> \<le> norm ?I1 + norm ?I2" by (rule norm_triangle_ineq)
     also have "norm ?I2 \<le> integral {x0..x} (\<lambda>t. D * g' t)"
       using x0 D D_nonneg
       by (intro integral_norm_bound_integral integrable_EM_remainder')
          (auto intro!: integrable_continuous_real continuous_intros cont mult_mono)
     also have "\<dots> = D * integral {x0..x} g'" by simp
     also from elim have "(g' has_integral (g x - g x0)) {x0..x}"
       by (intro fundamental_theorem_of_calculus) 
          (auto intro!: has_field_derivative_at_within[OF x0(3)] 
                simp: has_field_derivative_iff_has_vector_derivative [symmetric])
     hence "integral {x0..x} g' = g x - g x0" by (simp add: has_integral_iff)
     finally have "norm (integral {a..x} (\<lambda>t. pbernpoly n t *\<^sub>R f t)) \<le> norm ?I1 + D * (g x - g x0)"
       by simp_all
     thus "norm (EM_remainder' n f a x) \<le> C + D / fact n * g x"
       by (simp add: EM_remainder'_def field_simps C_def)
   qed
   thus ?thesis by (rule that)
 qed
 
 
 subsection \<open>Application to harmonic numbers\<close>
 
 text \<open>
   As a first application, we can apply the machinery we have developed to the 
   harmonic numbers.
 \<close>
 
 definition harm_remainder :: "nat \<Rightarrow> nat \<Rightarrow> real" where
   "harm_remainder N n = EM_remainder (2*N+1) (\<lambda>x. -fact (2*N+1) / x ^ (2*N+2)) (int n)"
 
 lemma harm_expansion:
   assumes n: "n > 0" and N: "N > 0"
   shows "harm n = ln n + euler_mascheroni + 1 / (2*n) -
                      (\<Sum>i=1..N. bernoulli (2*i) / ((2*i) * n ^ (2*i))) - harm_remainder N n"
 proof -
   define fs where "fs = (\<lambda>k x. (-1) ^ k * fact k / x ^ (Suc k) :: real)"    
   interpret euler_maclaurin_nat' ln "\<lambda>x. 1/x" fs 1 N euler_mascheroni "{}"
   proof
     fix k x assume "k \<le> 2*N" "x \<in> {real 1..} - {}"
     thus "(fs k has_vector_derivative fs (Suc k) x) (at x)"
       by (cases "k = 0")
          (auto intro!: derivative_eq_intros 
                simp: fs_def has_field_derivative_iff_has_vector_derivative [symmetric] 
                      field_simps power_diff)
   next
     have "(\<lambda>b. harm b - ln (real b) -
                  (\<Sum>i<2*N+1. bernoulli' (Suc i) * (- 1) ^ i / (real (Suc i) * (real b ^ Suc i))))
             \<longlonglongrightarrow> (euler_mascheroni - (\<Sum>i<2*N+1. 0))"
       by (intro tendsto_diff euler_mascheroni_LIMSEQ tendsto_sum 
             real_tendsto_divide_at_top[OF tendsto_const] 
             filterlim_tendsto_pos_mult_at_top[OF tendsto_const] filterlim_pow_at_top
             filterlim_real_sequentially) auto
     thus "(\<lambda>b. (\<Sum>k = 1..b. 1 / real k) - ln (real b) - 
             (\<Sum>i<2*N+1. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R fs i (real b))) \<longlonglongrightarrow> euler_mascheroni"
       by (simp add: harm_def divide_simps fs_def)
   qed (insert n N, auto intro!: continuous_intros derivative_eq_intros
          simp: fs_def has_field_derivative_iff_has_vector_derivative [symmetric])
        
   have "harm n = (\<Sum>k=1..n. 1 / real k)" by (simp add: harm_def divide_simps)
   also have "\<dots> = ln (real n) + euler_mascheroni + (1/2) *\<^sub>R (1 / real n) +
                      (\<Sum>i=1..N. (bernoulli (2*i) / fact (2*i)) *\<^sub>R fs (2*i-1) (real n)) -
                      EM_remainder (2*N+1) (fs (2*N+1)) (int n)" using n N
     using n by (intro euler_maclaurin_strong_nat') simp_all
   also have "(\<Sum>i=1..N. (bernoulli (2*i) / fact (2*i)) *\<^sub>R (fs (2*i-1) (real n))) =
                (\<Sum>i=1..N. -(bernoulli (2*i) / (real (2*i) * real n ^ (2*i))))"
     by (intro sum.cong refl) 
        (simp_all add: fs_def divide_simps fact_reduce del: of_nat_Suc power_Suc)
   also have "\<dots> = -(\<Sum>i=1..N. bernoulli (2*i) / (real (2*i) * real n ^ (2*i)))" 
     by (simp add: sum_negf)
   finally show ?thesis unfolding fs_def by (simp add: harm_remainder_def)
 qed
 
 lemma of_nat_ge_1_iff: "of_nat x \<ge> (1 :: 'a :: linordered_semidom) \<longleftrightarrow> x \<ge> 1"
   using of_nat_le_iff[of 1 x] by (simp del: of_nat_le_iff)
 
 lemma harm_remainder_bound:
   fixes N :: nat
   assumes N: "N > 0"
   shows "\<exists>C. \<forall>n\<ge>1. norm (harm_remainder N n) \<le> C / real n ^ (2*N+1)"
 proof -
   from bounded_pbernpoly[of "2*N+1"] obtain D where D: "\<forall>x. \<bar>pbernpoly (2*N+1) x\<bar> \<le> D" by auto
   have "\<forall>x. 1 \<le> real x \<longrightarrow> norm (harm_remainder N x) \<le>
           D / fact (2*N+1) * (fact (2*N) / x ^ (2*N+1))"
     unfolding harm_remainder_def of_int_of_nat_eq
   proof (rule norm_EM_remainder_le_strong_nat'[of "{}"])
     fix x :: real assume x: "x \<ge> 1"
     show "norm (-fact (2*N+1) / x ^ (2 * N + 2)) \<le> fact (2*N+1) / x ^ (2*N+2)"
       using x by simp
   next
     show "((\<lambda>x::real. fact (2 * N) / x ^ (2 * N + 1)) \<longlongrightarrow> 0) at_top"
       by (intro real_tendsto_divide_at_top[OF tendsto_const] filterlim_pow_at_top filterlim_ident)
          simp_all
   qed (insert N D, auto intro!: derivative_eq_intros continuous_intros simp: field_simps power_diff)
   hence "\<forall>x. 1 \<le> x \<longrightarrow> norm (harm_remainder N x) \<le> D / (2*N+1) / real x ^ (2*N+1)" by simp
   thus ?thesis by blast
 qed
   
 
 subsection \<open>Application to sums of inverse squares\<close>
 
 text \<open>
   In the same vein, we can derive the asymptotics of the partial sum of inverse squares.
 \<close>
 
 lemma sum_inverse_squares_expansion:
   assumes n: "n > 0" and N: "N > 0"
   shows "(\<Sum>k=1..n. 1 / real k ^ 2) = 
             pi ^ 2 / 6 - 1 / real n + 1 / (2 * real n ^ 2) -
                      (\<Sum>i=1..N. bernoulli (2*i) / n ^ (2*i+1)) - 
                     EM_remainder (2*N+1) (\<lambda>x. -fact (2*N+2) / x ^ (2*N+3)) (int n)"
 proof -
   have 3: "3 = Suc (Suc (Suc 0))" by (simp add: eval_nat_numeral)
   define fs where "fs = (\<lambda>k x. (-1) ^ k * fact (Suc k) / x ^ (k+2) :: real)"    
   interpret euler_maclaurin_nat' "\<lambda>x. -1/x" "\<lambda>x. 1/x^2" fs 1 N "pi^2/6" "{}"
   proof
     fix k x assume "k \<le> 2*N" "x \<in> {real 1..} - {}"
     thus "(fs k has_vector_derivative fs (Suc k) x) (at x)"
       by (cases "k = 0")
          (auto intro!: derivative_eq_intros 
                simp: fs_def has_field_derivative_iff_has_vector_derivative [symmetric] 
                      field_simps power_diff)
   next
     from inverse_squares_sums
       have "(\<lambda>n. \<Sum>k<n. 1 / real (Suc k) ^ 2) \<longlonglongrightarrow> pi\<^sup>2 / 6" by (simp add: sums_def)
     also have "(\<lambda>n. \<Sum>k<n. 1 / real (Suc k) ^ 2) = (\<lambda>n. \<Sum>k=1..n. 1 / real k ^ 2)"
       by (intro ext sum.reindex_bij_witness[of _ "\<lambda>n. n - 1" Suc]) auto
     finally have "(\<lambda>b. (\<Sum>k = 1..b. 1 / real k^2) + 1 / real b -
                  (\<Sum>i<2*N+1. bernoulli' (Suc i) * (- 1) ^ i / (real b ^ (i+2))))
             \<longlonglongrightarrow> (pi^2/6 + 0 - (\<Sum>i<2*N+1. 0))"
       by (intro tendsto_diff tendsto_add real_tendsto_divide_at_top[OF tendsto_const] 
             filterlim_tendsto_pos_mult_at_top[OF tendsto_const] filterlim_pow_at_top
             filterlim_real_sequentially tendsto_sum) auto
     thus "(\<lambda>b. (\<Sum>k = 1..b. 1 / real k^2) - (- 1 / real b) - 
             (\<Sum>i<2*N+1. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R fs i (real b))) \<longlonglongrightarrow> pi^2/6"
       by (simp add: harm_def field_simps fs_def del: power_Suc of_nat_Suc)
   qed (insert n N, auto intro!: continuous_intros derivative_eq_intros
          simp: fs_def has_field_derivative_iff_has_vector_derivative [symmetric] power2_eq_square)
 
   have "(\<Sum>k=1..n. 1 / real k ^ 2) = - 1 / real n + pi^2/6 + (1/2) *\<^sub>R (1 / real n^2) +
                (\<Sum>i=1..N. (bernoulli (2*i) / fact (2*i)) *\<^sub>R fs (2*i-1) (real n)) -
                EM_remainder (2*N+1) (fs (2*N+1)) (int n)" using n N
     using n by (intro euler_maclaurin_strong_nat') simp_all
   also have "(\<Sum>i=1..N. (bernoulli (2*i) / fact (2*i)) *\<^sub>R (fs (2*i-1) (real n))) =
                (\<Sum>i=1..N. -(bernoulli (2*i) / (real n ^ (2*i+1))))"
     by (intro sum.cong refl) 
        (simp_all add: fs_def divide_simps fact_reduce del: of_nat_Suc power_Suc)
   also have "\<dots> = -(\<Sum>i=1..N. bernoulli (2*i) / real n ^ (2*i+1))"
     by (simp add: sum_negf)
   finally show ?thesis unfolding fs_def by (simp add: fs_def 3)
 qed
 
 lemma sum_inverse_squares_remainder_bound:
   fixes N :: nat
   assumes N: "N > 0"
   defines "R \<equiv> (\<lambda>n. EM_remainder (2*N+1) (\<lambda>x. -fact (2*N+2) / x ^ (2*N+3)) (int n))"
   shows   "\<exists>C. \<forall>n\<ge>1. norm (R n) \<le> C / real n ^ (2*N+2)"
 proof -
   have 3: "3 = Suc (Suc (Suc 0))" by simp
   from bounded_pbernpoly[of "2*N+1"] obtain D where D: "\<forall>x. \<bar>pbernpoly (2*N+1) x\<bar> \<le> D" by auto
   have "\<forall>x. 1 \<le> real x \<longrightarrow> norm (R x) \<le> D / fact (2*N+1) * (fact (2*N+1) / x ^ (2*N+2))"
     unfolding R_def of_int_of_nat_eq
   proof (rule norm_EM_remainder_le_strong_nat'[of "{}"])
     fix x :: real assume x: "x \<ge> 1"
     show "norm (-fact (2*N+2) / x ^ (2*N+3)) \<le> fact (2*N+2) / x ^ (2*N+3)"
       using x by simp
   next
     show "((\<lambda>x::real. fact (2*N+1) / x ^ (2*N+2)) \<longlongrightarrow> 0) at_top"
       by (intro real_tendsto_divide_at_top[OF tendsto_const] filterlim_pow_at_top filterlim_ident)
          simp_all
   qed (insert N D, auto intro!: derivative_eq_intros continuous_intros simp: field_simps power_diff 3)
   hence "\<forall>x\<ge>1. norm (R x) \<le> D / real x ^ (2 * N + 2)" by simp
   thus ?thesis by blast
 qed
 
 end
diff --git a/thys/Euler_MacLaurin/Euler_MacLaurin_Landau.thy b/thys/Euler_MacLaurin/Euler_MacLaurin_Landau.thy
--- a/thys/Euler_MacLaurin/Euler_MacLaurin_Landau.thy
+++ b/thys/Euler_MacLaurin/Euler_MacLaurin_Landau.thy
@@ -1,170 +1,174 @@
 section \<open>Connection of Euler--MacLaurin summation to Landau symbols\<close>
 theory Euler_MacLaurin_Landau
 imports 
   Euler_MacLaurin
   Landau_Symbols.Landau_More
 begin
 
 subsection \<open>$O$-bound for the remainder term\<close>  
 
 text \<open>
   Landau symbols allow us to state the bounds on the remainder terms 
   from the Euler--MacLaurin formula a bit more nicely.
 \<close>
 
 lemma
   fixes f :: "real \<Rightarrow> 'a :: {real_normed_field, banach}"
     and g g' :: "real \<Rightarrow> real"
   assumes fin:     "finite Y"
   assumes cont_f:  "continuous_on {a..} f"
   assumes cont_g:  "continuous_on {a..} g"
   assumes cont_g': "continuous_on {a..} g'"
   assumes limit_g: "(g \<longlongrightarrow> 0) at_top"
   assumes f_bound: "\<And>x. x \<ge> a \<Longrightarrow> norm (f x) \<le> g' x"
   assumes deriv:   "\<And>x. x \<in> {a..} - Y \<Longrightarrow> (g has_field_derivative -g' x) (at x)"
   shows   EM_remainder_strong_bigo_int: "(\<lambda>x::int. norm (EM_remainder n f x)) \<in> O(g)"
     and   EM_remainder_strong_bigo_nat: "(\<lambda>x::nat. norm (EM_remainder n f x)) \<in> O(g)"
 proof -
   from bounded_pbernpoly[of n] obtain D where D: "\<forall>x. \<bar>pbernpoly n x\<bar> \<le> D" by auto
   from norm_EM_remainder_le_strong_int'[OF fin D assms(2-)]
     have *: "\<And>x. x \<ge> a \<longrightarrow> norm (EM_remainder n f x) \<le> D / fact n * g x" by auto
   have **: "eventually (\<lambda>x::int. norm (EM_remainder n f x) \<le> abs (D / fact n) * abs (g x)) at_top"
     using eventually_ge_at_top[of "ceiling a"]
   proof eventually_elim
     case (elim x)
     with *[of x] have "norm (EM_remainder n f x) \<le> D / fact n * g x" by (simp add: ceiling_le_iff)
     also have "\<dots> \<le> abs (D / fact n * g x)" by (rule abs_ge_self)
     also have "\<dots> = abs (D / fact n) * abs (g x)" by (simp add: abs_mult)
     finally show ?case .
   qed
   thus "(\<lambda>x::int. norm (EM_remainder n f x)) \<in> O(g)"
     by (intro bigoI[of _ "abs D / fact n"]) (auto elim!: eventually_mono)
   hence "(\<lambda>x::nat. norm (EM_remainder n f (int x))) \<in> O(\<lambda>x. g (of_int (int x)))"
     by (rule landau_o.big.compose) (fact filterlim_int_sequentially)
   thus "(\<lambda>x::nat. norm (EM_remainder n f x)) \<in> O(g)" by simp
 qed
 
 
 subsection \<open>Asymptotic expansion of the harmonic numbers\<close>
 
 text \<open>
   We can now show the asymptotic expansion
   \[H_n = \ln n + \gamma + \frac{1}{2n} - \sum_{i=1}^m \frac{B_{2i}}{2i} n^{-2i} + O(n^{-2m-2})\]
 \<close>
 
 lemma harm_remainder_bigo:
   assumes "N > 0"
   shows   "harm_remainder N \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 1))"
 proof -
-  from harm_remainder_bound[OF assms] guess C ..
+  from harm_remainder_bound[OF assms]
+  obtain C where "\<forall>n\<ge>1. norm (harm_remainder N n) \<le> C / real n ^ (2 * N + 1)" ..
   thus ?thesis
     by (intro bigoI[of _ C] eventually_mono[OF eventually_ge_at_top[of 1]]) auto
 qed
 
 lemma harm_expansion_bigo:
   fixes N :: nat
   defines "T \<equiv> \<lambda>n. ln n + euler_mascheroni + 1 / (2*n) -
                      (\<Sum>i=1..N. bernoulli (2*i) / ((2*i) * n ^ (2*i)))"
   defines "S \<equiv> (\<lambda>n. bernoulli (2*(Suc N)) / ((2*Suc N) * real n ^ (2*Suc N)))"
   shows "(\<lambda>n. harm n - T n) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 2))"
 proof -
   have "(\<lambda>n. harm n - T n) \<in> \<Theta>(\<lambda>n. -S n - harm_remainder (Suc N) n)"
     by (intro bigthetaI_cong eventually_mono[OF eventually_gt_at_top[of "0::nat"]]) 
        (auto simp: T_def harm_expansion[of _ "Suc N"] S_def)
   also have "(\<lambda>n. -S n - harm_remainder (Suc N) n) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 2))"
   proof (intro sum_in_bigo)
     show "(\<lambda>x. - S x) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 2))" unfolding S_def
       by (rule landau_o.big.compose[OF _ filterlim_real_sequentially]) simp
     have "harm_remainder (Suc N) \<in> O(\<lambda>n. 1 / real n ^ (2 * Suc N + 1))"
       by (rule harm_remainder_bigo) simp_all
     also have "(\<lambda>n. 1 / real n ^ (2 * Suc N + 1)) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 2))"
       by (rule landau_o.big.compose[OF _ filterlim_real_sequentially]) simp
     finally show "harm_remainder (Suc N) \<in> \<dots>" .
   qed
   finally show ?thesis .
 qed
 
 lemma harm_expansion_bigo_simple1:
   "(\<lambda>n. harm n - (ln n + euler_mascheroni + 1 / (2 * n))) \<in> O(\<lambda>n. 1 / n ^ 2)"
   using harm_expansion_bigo[of 0] by (simp add: power2_eq_square)
 
 lemma harm_expansion_bigo_simple2:
   "(\<lambda>n. harm n - (ln n + euler_mascheroni)) \<in> O(\<lambda>n. 1 / n)"
 proof -
   have "(\<lambda>n. harm n - (ln n + euler_mascheroni + 1 / (2 * n)) + 1 / (2 * n)) \<in> O(\<lambda>n. 1 / n)"
   proof (rule sum_in_bigo)
     have "(\<lambda>n. harm n - (ln n + euler_mascheroni + 1 / (2 * n))) \<in> O(\<lambda>n. 1 / real n ^ 2)"
       using harm_expansion_bigo_simple1 by simp
     also have "(\<lambda>n. 1 / real n ^ 2) \<in> O(\<lambda>n. 1 / real n)"
       by (rule landau_o.big.compose[OF _ filterlim_real_sequentially]) simp_all
     finally show "(\<lambda>n. harm n - (ln n + euler_mascheroni + 1 / (2 * n))) \<in> O(\<lambda>n. 1 / n)" by simp
   qed simp_all
   thus ?thesis by (simp add: algebra_simps)
 qed
 
 lemma harm_expansion_bigo_simple':
   "harm =o (\<lambda>n. ln n + euler_mascheroni + 1 / (2 * n)) +o O(\<lambda>n. 1 / n ^ 2)"
   using harm_expansion_bigo_simple1
   by (subst set_minus_plus [symmetric]) (simp_all add: fun_diff_def)
 
 
 subsection \<open>Asymptotic expansion of the sum of inverse squares\<close>
 
 text \<open>
   Similarly to before, we show
   \[\sum_{i=1}^n \frac{1}{i^2} = \frac{\pi^2}{6} - \frac{1}{n} + \frac{1}{2n^2} - 
      \sum_{i=1}^m B_{2i} n^{-2i-1} + O(n^{-2m-3})\]  
 \<close>
 
 context
   fixes R :: "nat \<Rightarrow> nat \<Rightarrow> real"
   defines "R \<equiv> (\<lambda>N n. EM_remainder (2*N+1) (\<lambda>x. -fact (2*N+2) / x ^ (2*N+3)) (int n))"
 begin
 
 lemma sum_inverse_squares_remainder_bigo:
   assumes "N > 0"
   shows   "R N \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 2))"
 proof -
-  from sum_inverse_squares_remainder_bound[OF assms] guess C ..
+  from sum_inverse_squares_remainder_bound[OF assms]
+  obtain C
+    where "\<forall>n\<ge>1. norm (EM_remainder (2 * N + 1) (\<lambda>x. - fact (2 * N + 2) / x ^ (2 * N + 3)) (int n))
+      \<le> C / real n ^ (2 * N + 2)" ..
   thus ?thesis
     by (intro bigoI[of _ C] eventually_mono[OF eventually_ge_at_top[of 1]]) (auto simp: R_def)
 qed
 
 lemma sum_inverse_squares_expansion_bigo:
   fixes N :: nat
   defines "T \<equiv> \<lambda>n. pi ^ 2 / 6 - 1 / n + 1 / (2*n ^ 2) -
                      (\<Sum>i=1..N. bernoulli (2*i) / (n ^ (2*i+1)))"
   defines "S \<equiv> (\<lambda>n. bernoulli (2*(Suc N)) / (real n ^ (2*N+3)))"
   shows "(\<lambda>n. (\<Sum>i=1..n. 1 / real i ^ 2) - T n) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 3))"
 proof -
   have 3: "3 = Suc (Suc (Suc 0))" by simp
   have "(\<lambda>n. (\<Sum>i=1..n. 1 / real i ^ 2) - T n) \<in> \<Theta>(\<lambda>n. -S n - R (Suc N) n)" unfolding R_def
     by (intro bigthetaI_cong eventually_mono[OF eventually_gt_at_top[of "0::nat"]])
        (auto simp: T_def sum_inverse_squares_expansion[of _ "Suc N"] S_def 3
              simp del: One_nat_def)
   also have "(\<lambda>n. -S n - R (Suc N) n) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 3))"
   proof (intro sum_in_bigo)
     show "(\<lambda>x. - S x) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 3))" unfolding S_def
       by (rule landau_o.big.compose[OF _ filterlim_real_sequentially]) simp
     have "R (Suc N) \<in> O(\<lambda>n. 1 / real n ^ (2 * Suc N + 2))"
       by (rule sum_inverse_squares_remainder_bigo) simp_all
     also have "2 * Suc N + 2 = 2 * N + 4" by simp
     also have "(\<lambda>n. 1 / real n ^ (2 * N + 4)) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 3))"
       by (rule landau_o.big.compose[OF _ filterlim_real_sequentially]) simp
     finally show "R (Suc N) \<in> \<dots>" .
   qed
   finally show ?thesis .
 qed
 
 lemma sum_inverse_squares_expansion_bigo_simple:
   "(\<lambda>n. (\<Sum>i=1..n. 1 / real i ^ 2) - (pi ^ 2 / 6 - 1 / n + 1 / (2*n^2))) \<in> O(\<lambda>n. 1 / n ^ 3)"
   using sum_inverse_squares_expansion_bigo[of 0] by (simp add: power2_eq_square)
 
 lemma sum_inverse_squares_expansion_bigo_simple':
   "(\<lambda>n. (\<Sum>i=1..n. 1 / real i ^ 2)) =o (\<lambda>n. pi ^ 2 / 6 - 1 / n + 1 / (2*n^2)) +o O(\<lambda>n. 1 / n^3)"
   using sum_inverse_squares_expansion_bigo_simple
   by (subst set_minus_plus [symmetric]) (simp_all add: fun_diff_def)
 
 end
 
 end
diff --git a/thys/Fishburn_Impossibility/Fishburn_Impossibility.thy b/thys/Fishburn_Impossibility/Fishburn_Impossibility.thy
--- a/thys/Fishburn_Impossibility/Fishburn_Impossibility.thy
+++ b/thys/Fishburn_Impossibility/Fishburn_Impossibility.thy
@@ -1,346 +1,347 @@
 (*
   File:     Fishburn_Impossibility.thy
   Author:   Manuel Eberl, TU München
   Author:   Christian Saile, TU München
 
   Incompatibility of Pareto Optimality and Fishburn-Strategy-Proofness
 *)
 section \<open>Main impossibility result\<close>
 
 theory Fishburn_Impossibility
 imports
   Social_Choice_Functions
 begin
 
 subsection \<open>Setting of the base case\<close>
 
 text \<open>
   Suppose we have an anonymous, Fishburn-strategyproof, and Pareto-efficient SCF
   for three agents $A1$ to $A3$ and three alternatives $a$, $b$, and $c$. We will derive
   a contradiction from this.
 \<close>
 locale fb_impossibility_3_3 =
   strategyproof_anonymous_scf agents alts scf Fishb +
   pareto_efficient_scf agents alts scf
   for agents :: "'agent set" and alts :: "'alt set" and scf A1 A2 A3 a b c +
   assumes agents_eq: "agents = {A1, A2, A3}"
   assumes alts_eq:    "alts = {a, b, c}"
   assumes distinct_agents: "distinct [A1, A2, A3]"
   assumes distinct_alts: "distinct [a, b, c]"
 begin
 
 text \<open>
   We first give some simple rules that will allow us to break down the strategyproofness
   and support conditions more easily later.
 \<close>
 lemma agents_neq [simp]: "A1 \<noteq> A2" "A2 \<noteq> A1" "A1 \<noteq> A3" "A3 \<noteq> A1" "A2 \<noteq> A3" "A3 \<noteq> A2"
   using distinct_agents by auto
 
 lemma alts_neq [simp]: "a \<noteq> b" "a \<noteq> c" "b \<noteq> c" "b \<noteq> a" "c \<noteq> a" "c \<noteq> b"
   using distinct_alts by auto
 
 lemma agent_in_agents [simp]: "A1 \<in> agents" "A2 \<in> agents" "A3 \<in> agents"
   by (simp_all add: agents_eq)
 
 lemma alt_in_alts [simp]: "a \<in> alts" "b \<in> alts" "c \<in> alts"
   by (simp_all add: alts_eq)
 
 lemma Bex_alts: "(\<exists>x\<in>alts. P x) \<longleftrightarrow> P a \<or> P b \<or> P c"
   by (simp add: alts_eq)
 
 lemma eval_pareto_loser_aux: 
   assumes "is_pref_profile R"
   shows   "x \<in> pareto_losers R \<longleftrightarrow> (\<exists>y\<in>{a,b,c}. x \<prec>[Pareto(R)] y)"
 proof -
   interpret pref_profile_wf agents alts R by fact
   have *: "y \<in> {a,b,c}" if "x \<prec>[Pareto(R)] y" for y
     using Pareto.strict_not_outside[of x y] that by (simp add: alts_eq)
   show ?thesis by (auto simp: pareto_losers_def dest: *)
 qed
 
 lemma eval_Pareto:
   assumes "is_pref_profile R"
   shows   "x \<prec>[Pareto(R)] y \<longleftrightarrow> (\<forall>i\<in>{A1,A2,A3}. x \<preceq>[R i] y) \<and> (\<exists>i\<in>{A1,A2,A3}. \<not>x \<succeq>[R i] y)"
 proof -
   interpret R: pref_profile_wf agents alts by fact
   show ?thesis unfolding R.Pareto_strict_iff by (auto simp: strongly_preferred_def agents_eq)
 qed
 
 lemmas eval_pareto = eval_pareto_loser_aux eval_Pareto
 lemma pareto_efficiency: "is_pref_profile R \<Longrightarrow> x \<in> pareto_losers R \<Longrightarrow> x \<notin> scf R"
   using pareto_efficient[of R] by blast
 
 lemma Ball_scf:
   assumes "is_pref_profile R"
   shows   "(\<forall>x\<in>scf R. P x) \<longleftrightarrow> (a \<notin> scf R \<or> P a) \<and> (b \<notin> scf R \<or> P b) \<and> (c \<notin> scf R \<or> P c)"
   using scf_alts[OF assms] unfolding alts_eq by blast
 
 lemma Ball_scf_diff: 
   assumes "is_pref_profile R1" "is_pref_profile R2"
   shows   "(\<forall>x\<in>scf R1 - scf R2. P x) \<longleftrightarrow> 
              (a \<in> scf R2 \<or> a \<notin> scf R1 \<or> P a) \<and> (b \<in> scf R2 \<or> b \<notin> scf R1 \<or> P b) \<and> 
              (c \<in> scf R2 \<or> c \<notin> scf R1 \<or> P c)"
   using assms[THEN scf_alts] unfolding alts_eq by blast
 
 lemma scf_nonempty':
   assumes "is_pref_profile R"
   shows   "\<exists>x\<in>alts. x \<in> scf R"
   using scf_nonempty[OF assms] scf_alts[OF assms] by blast
 
 
 subsection \<open>Definition of Preference Profiles and Fact Gathering\<close>
 
 text \<open>
   We now define the 21 preference profile that will lead to the impossibility result.
 \<close>
 preference_profile 
   agents: agents
   alts:   alts
 where R1   = A1: [a, c], b    A2: [a, c], b     A3: b, c, a  
   and R2   = A1: c, [a, b]    A2: b, c, a       A3: c, b, a 
   and R3   = A1: [a, c], b    A2: b, c, a       A3: c, b, a   
   and R4   = A1: [a, c], b    A2:  a, b, c      A3: b, c, a
   and R5   = A1: c, [a, b]    A2:  a, b, c      A3: b, c, a
   and R6   = A1: b, [a, c]    A2: c, [a, b]     A3:  b, c, a
   and R7   = A1: [a, c], b    A2: b, [a, c]     A3: b, c, a 
   and R8   = A1: [b, c], a    A2: a, [b, c]     A3: a, c, b
   and R9   = A1: [b, c], a    A2: b, [a, c]     A3: a, b, c
   and R10  = A1: c, [a, b]    A2: a, b, c       A3: c, b, a   
   and R11  = A1: [a, c], b    A2: a, b, c       A3: c, b, a  
   and R12  = A1: c, [a, b]    A2: b, a, c       A3: c, b, a   
   and R13  = A1: [a, c], b    A2: b, a, c       A3: c, b, a  
   and R14  = A1: a, [b, c]    A2: c, [a, b]     A3: a, c, b   
   and R15  = A1: [b, c], a    A2: a, [b, c]     A3: a, b, c  
   and R16  = A1: [a, b], c    A2: c, [a, b]     A3: a, b, c  
   and R17  = A1: a, [b, c]    A2: a, b, c       A3: b, c, a
   and R18  = A1: [a, c], b    A2: b, [a, c]     A3: b, a, c 
   and R19  = A1: a, [b, c]    A2: c, [a, b]     A3: a, b, c
   and R20  = A1: b, [a, c]    A2: a, b, c       A3: b, a, c
   and R21  = A1: [b, c], a    A2: a, b, c       A3: b, c, a
   by (simp_all add: agents_eq alts_eq)
 
 lemmas R_wfs = 
   R1.wf R2.wf R3.wf R4.wf R5.wf R6.wf R7.wf R8.wf R9.wf R10.wf R11.wf R12.wf R13.wf R14.wf R15.wf 
   R16.wf R17.wf R18.wf R19.wf R20.wf R21.wf 
 
 lemmas R_evals =
   R1.eval R2.eval R3.eval R4.eval R5.eval R6.eval R7.eval R8.eval R9.eval R10.eval R11.eval R12.eval  R13.eval 
   R14.eval R15.eval R16.eval R17.eval R18.eval R19.eval R20.eval R21.eval
 
 lemmas nonemptiness = R_wfs [THEN scf_nonempty', unfolded Bex_alts]
 
 text \<open>
   We show the support conditions from Pareto efficiency
 \<close>
 lemma [simp]: "a \<notin> scf R1" by (rule pareto_efficiency) (simp_all add: eval_pareto R1.eval)
 lemma [simp]: "a \<notin> scf R2" by (rule pareto_efficiency) (simp_all add: eval_pareto R2.eval)
 lemma [simp]: "a \<notin> scf R3" by (rule pareto_efficiency) (simp_all add: eval_pareto R3.eval)
 lemma [simp]: "a \<notin> scf R6" by (rule pareto_efficiency) (simp_all add: eval_pareto R6.eval)
 lemma [simp]: "a \<notin> scf R7" by (rule pareto_efficiency) (simp_all add: eval_pareto R7.eval)
 lemma [simp]: "b \<notin> scf R8" by (rule pareto_efficiency) (simp_all add: eval_pareto R8.eval)
 lemma [simp]: "c \<notin> scf R9" by (rule pareto_efficiency) (simp_all add: eval_pareto R9.eval)
 lemma [simp]: "a \<notin> scf R12" by (rule pareto_efficiency) (simp_all add: eval_pareto R12.eval)
 lemma [simp]: "b \<notin> scf R14" by (rule pareto_efficiency) (simp_all add: eval_pareto R14.eval)
 lemma [simp]: "c \<notin> scf R15" by (rule pareto_efficiency) (simp_all add: eval_pareto R15.eval)
 lemma [simp]: "b \<notin> scf R16" by (rule pareto_efficiency) (simp_all add: eval_pareto R16.eval)
 lemma [simp]: "c \<notin> scf R17" by (rule pareto_efficiency) (simp_all add: eval_pareto R17.eval)
 lemma [simp]: "c \<notin> scf R18" by (rule pareto_efficiency) (simp_all add: eval_pareto R18.eval)
 lemma [simp]: "b \<notin> scf R19" by (rule pareto_efficiency) (simp_all add: eval_pareto R19.eval)
 lemma [simp]: "c \<notin> scf R20" by (rule pareto_efficiency) (simp_all add: eval_pareto R20.eval)
 lemma [simp]: "c \<notin> scf R21" by (rule pareto_efficiency) (simp_all add: eval_pareto R21.eval)
 
 text \<open>
   We derive the strategyproofness conditions:
 \<close>
 lemma s41: "\<not> scf R4 \<succ>[Fishb(R1 A2)] scf R1"
     by (intro strategyproof'[where j = A2]) (simp_all add: R4.eval R1.eval)
    
 lemma s32: "\<not> scf R3 \<succ>[Fishb(R2 A1)] scf R2"
     by (intro strategyproof'[where j = A1]) (simp_all add: R3.eval R2.eval)
  
 lemma s122: "\<not> scf R12 \<succ>[Fishb(R2 A2)] scf R2"
     by (intro strategyproof'[where j = A2]) (simp_all add: R12.eval R2.eval)
    
 lemma s133: "\<not> scf R13 \<succ>[Fishb(R3 A2)] scf R3"
     by (intro strategyproof'[where j = A2]) (simp_all add: R13.eval R3.eval)
     
 lemma s102: "\<not> scf R10 \<succ>[Fishb(R2 A2)] scf R2"
     by (intro strategyproof'[where j = A2]) (simp_all add: R10.eval R2.eval)
          
 lemma s13: "\<not> scf R1 \<succ>[Fishb(R3 A3)] scf R3"
     by (intro strategyproof'[where j = A2]) (simp_all add: R1.eval R3.eval)
     
 lemma s54: "\<not> scf R5 \<succ>[Fishb(R4 A1)] scf R4"
     by (intro strategyproof'[where j = A1]) (simp_all add: R5.eval R4.eval)
     
 lemma s174: "\<not> scf R17 \<succ>[Fishb(R4 A1)] scf R4"
     by (intro strategyproof'[where j = A1]) (simp_all add: R17.eval R4.eval)
       
 lemma s74: "\<not> scf R7 \<succ>[Fishb(R4 A2)] scf R4"
     by (intro strategyproof'[where j = A2]) (simp_all add: R7.eval R4.eval)
     
 lemma s114: "\<not> scf R11 \<succ>[Fishb(R4 A3)] scf R4"
     by (intro strategyproof'[where j = A3]) (simp_all add: R11.eval R4.eval)
   
 lemma s45: "\<not> scf R4 \<succ>[Fishb(R5 A1)] scf R5"
     by (intro strategyproof'[where j = A1]) (simp_all add: R4.eval R5.eval)
      
 lemma s65: "\<not> scf R6 \<succ>[Fishb(R5 A2)] scf R5"
     by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute R5.eval R6.eval)
     
 lemma s105: "\<not> scf R10 \<succ>[Fishb(R5 A3)] scf R5"
     by (intro strategyproof'[where j = A3]) (simp_all add:  R10.eval R5.eval)
     
 lemma s67: "\<not> scf R6 \<succ>[Fishb(R7 A1)] scf R7"
     by (intro strategyproof'[where j = A2]) (simp_all add: insert_commute  R6.eval R7.eval)
     
 lemma s187: "\<not> scf R18 \<succ>[Fishb(R7 A3)] scf R7"
     by (intro strategyproof'[where j = A3]) (simp_all add: insert_commute R7.eval R18.eval)
    
 lemma s219: "\<not> scf R21 \<succ>[Fishb(R9 A2)] scf R9"
     by (intro strategyproof'[where j = A3]) (simp_all add: insert_commute R9.eval R21.eval)
    
 lemma s1011: "\<not> scf R10 \<succ>[Fishb(R11 A1)] scf R11"
     by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute R10.eval R11.eval)
     
 lemma s1012: "\<not> scf R10 \<succ>[Fishb(R12 A2)] scf R12"
     by (intro strategyproof'[where j = A2]) (simp_all add: insert_commute R10.eval R12.eval)
     
 lemma s1213: "\<not> scf R12 \<succ>[Fishb(R13 A1)] scf R13"
     by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute R12.eval R13.eval)
     
 lemma s1113: "\<not> scf R11 \<succ>[Fishb(R13 A2)] scf R13"
     by (intro strategyproof'[where j = A2]) (simp_all add: insert_commute R11.eval R13.eval)
     
 lemma s1813: "\<not> scf R18 \<succ>[Fishb(R13 A3)] scf R13"
     by (intro strategyproof'[where j = A2]) (simp_all add: insert_commute R18.eval R13.eval)
     
 lemma s814: "\<not> scf R8 \<succ>[Fishb(R14 A2)] scf R14"
     by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute R8.eval R14.eval)
    
 lemma s1914: "\<not> scf R19 \<succ>[Fishb(R14 A3)] scf R14"
     by (intro strategyproof'[where j = A3]) (simp_all add: insert_commute R19.eval R14.eval)
    
 lemma s1715: "\<not> scf R17 \<succ>[Fishb(R15 A1)] scf R15"
     by (intro strategyproof'[where j = A3]) (simp_all add: insert_commute R17.eval R15.eval)
 
 lemma s815: "\<not> scf R8 \<succ>[Fishb(R15 A3)] scf R15"
     by (intro strategyproof'[where j = A3]) (simp_all add: insert_commute R8.eval R15.eval)
 
 lemma s516: "\<not> scf R5 \<succ>[Fishb(R16 A1)] scf R16"
     by (intro strategyproof'[where j = A3]) (simp_all add: insert_commute R5.eval R16.eval)
   
 lemma s517: "\<not> scf R5 \<succ>[Fishb(R17 A1)] scf R17"
     by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute R5.eval R17.eval)
    
 lemma s1619: "\<not> scf R16 \<succ>[Fishb(R19 A1)] scf R19"
      by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute  R16.eval R19.eval) 
      
 lemma s1820: "\<not> scf R18 \<succ>[Fishb(R20 A2)] scf R20"
     by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute  R18.eval R20.eval)
    
 lemma s920: "\<not> scf R9 \<succ>[Fishb(R20 A3)] scf R20"
     by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute  R20.eval R9.eval)
 
 lemma s521: "\<not> scf R5 \<succ>[Fishb(R21 A1)] scf R21"
     by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute  R21.eval R5.eval)
  
 lemma s421: "\<not> scf R4 \<succ>[Fishb(R21 A1)] scf R21"
     by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute  R21.eval R4.eval)
  
 
 lemmas sp = s41 s32 s122 s102 s133 s13 s54 s174 s54 s74 s114 s45 s65 s105 s67
             s187 s219 s1011 s1012 s1213 s1113 s1813 s814 s1914 s1715 s815 s516
             s517 s1619 s1820 s920 s521 s421 
 
 text \<open>
   We now use the simplifier to break down the strategyproofness conditions into SAT formulae.
   This takes a few seconds, so we use some low-level ML code to at least do the simplification
   in parallel.
 \<close>
 local_setup \<open>fn lthy =>
   let
     val lthy' = lthy addsimps @{thms Fishb_strict_iff Ball_scf Ball_scf_diff R_evals}
     val thms = Par_List.map (Simplifier.asm_full_simplify lthy') @{thms sp}
   in
     Local_Theory.notes [((@{binding sp'}, []), [(thms, [])])] lthy |> snd
   end
 \<close>
 
 text \<open>
   We show that the strategyproofness conditions, the non-emptiness conditions (i.\,e.\ every SCF
   must return at least one winner), and the efficiency conditions are not satisfiable together,
   which means that the SCF whose existence we assumed simply cannot exist.
 \<close>
 theorem absurd: False
   using sp' and nonemptiness [simplified] by satx
 
 end
 
 
 subsection \<open>Lifting to more than 3 agents and alternatives\<close>
 
 text \<open>
   We now employ the standard lifting argument outlined before to lift this impossibility
   from 3 agents and alternatives to any setting with at least 3 agents and alternatives.
 \<close>
 locale fb_impossibility =
   strategyproof_anonymous_scf agents alts scf Fishb +
   pareto_efficient_scf agents alts scf
   for agents :: "'agent set" and alts :: "'alt set" and scf +
   assumes card_agents_ge: "card agents \<ge> 3"
       and card_alts_ge:   "card alts \<ge> 3"
 begin
 
 (* TODO: Move? *)
 lemma finite_list':
   assumes "finite A"
   obtains xs where "A = set xs" "distinct xs" "length xs = card A"
 proof -
   from assms obtain xs where "set xs = A" using finite_list by blast
   thus ?thesis using distinct_card[of "remdups xs"]
     by (intro that[of "remdups xs"]) simp_all
 qed
 
 lemma finite_list_subset:
   assumes "finite A" "card A \<ge> n"
   obtains xs where "set xs \<subseteq> A" "distinct xs" "length xs = n"
 proof -
   obtain xs where "A = set xs" "distinct xs" "length xs = card A"
     using finite_list'[OF assms(1)] by blast
   with assms show ?thesis
     by (intro that[of "take n xs"]) (simp_all add: set_take_subset)
 qed
 
 lemma card_ge_3E:
   assumes "finite A" "card A \<ge> 3"
   obtains a b c where "distinct [a,b,c]" "{a,b,c} \<subseteq> A"
 proof -
-  from finite_list_subset[OF assms] guess xs .
-  moreover then obtain a b c where "xs = [a, b, c]" 
+  from finite_list_subset[OF assms]
+  obtain xs where xs: "set xs \<subseteq> A" "distinct xs" "length xs = 3" by auto
+  then obtain a b c where "xs = [a, b, c]" 
     by (auto simp: eval_nat_numeral length_Suc_conv)
-  ultimately show ?thesis by (intro that[of a b c]) simp_all
+  with xs show ?thesis by (intro that[of a b c]) simp_all
 qed
 
 theorem absurd: False
 proof -
-  from card_ge_3E[OF finite_agents card_agents_ge] guess A1 A2 A3 .
-  note agents = this
+  from card_ge_3E[OF finite_agents card_agents_ge] obtain A1 A2 A3
+    where agents: "distinct [A1, A2, A3]" "{A1, A2, A3} \<subseteq> agents" .
   let ?agents' = "{A1, A2, A3}"
-  from card_ge_3E[OF finite_alts card_alts_ge] guess a b c .
-  note alts = this
+  from card_ge_3E[OF finite_alts card_alts_ge]
+  obtain a b c where alts: "distinct [a, b, c]" "{a, b, c} \<subseteq> alts" .
   let ?alts' = "{a, b, c}"
 
   interpret scf_lowering_anonymous agents alts scf ?agents' ?alts'
     by standard (use agents alts in auto)
   interpret liftable_set_extension ?alts' alts Fishb
     by (intro Fishburn_liftable alts)
   interpret scf_lowering_strategyproof agents alts scf ?agents' ?alts' Fishb ..
   interpret fb_impossibility_3_3 ?agents' ?alts' lowered A1 A2 A3 a b c
     by standard (use agents alts in simp_all)
   from absurd show False .
 qed
 
 end
 
 end
\ No newline at end of file
diff --git a/thys/Fishburn_Impossibility/Social_Choice_Functions.thy b/thys/Fishburn_Impossibility/Social_Choice_Functions.thy
--- a/thys/Fishburn_Impossibility/Social_Choice_Functions.thy
+++ b/thys/Fishburn_Impossibility/Social_Choice_Functions.thy
@@ -1,684 +1,685 @@
 (*  
   Title:    Social_Choice_Functions.thy
   Author:   Manuel Eberl, TU München
 
   Definitions of Social Choice Functions, their properties, and related concepts
 *)
 
 section \<open>Social Choice Functions\<close>
 
 theory Social_Choice_Functions
 imports 
   "Randomised_Social_Choice.Preference_Profile_Cmd"
 begin
 
 subsection \<open>Weighted majority graphs\<close>
 
 definition supporters :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt \<Rightarrow> 'alt \<Rightarrow> 'agent set" where
   supporters_auxdef: "supporters R x y = {i. x \<succeq>[R i] y}" 
 
 definition weighted_majority :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt \<Rightarrow> 'alt \<Rightarrow> int" where
   "weighted_majority R x y = int (card (supporters R x y)) - int (card (supporters R y x))"
   
 lemma weighted_majority_refl [simp]: "weighted_majority R x x = 0"
   by (simp add: weighted_majority_def)
   
 lemma weighted_majority_swap: "weighted_majority R x y = -weighted_majority R y x"
   by (simp add: weighted_majority_def)
 
 lemma eval_set_filter: 
   "Set.filter P {} = {}" 
   "P x \<Longrightarrow> Set.filter P (insert x A) = insert x (Set.filter P A)"
   "\<not>P x \<Longrightarrow> Set.filter P (insert x A) = Set.filter P A"
   unfolding Set.filter_def by auto
   
 context election
 begin
 
 lemma supporters_def: 
   assumes "is_pref_profile R"
   shows   "supporters R x y = {i\<in>agents. x \<succeq>[R i] y}"
 proof -
   interpret pref_profile_wf agents alts R by fact
   show ?thesis using not_outside unfolding supporters_auxdef by blast
 qed
 
 lemma supporters_nonagent1:
   assumes "is_pref_profile R" "x \<notin> alts"
   shows   "supporters R x y = {}"
 proof -
   interpret pref_profile_wf agents alts R by fact
   from assms show ?thesis by (auto simp: supporters_def dest: not_outside)
 qed
 
 lemma supporters_nonagent2:
   assumes "is_pref_profile R" "y \<notin> alts"
   shows   "supporters R x y = {}"
 proof -
   interpret pref_profile_wf agents alts R by fact
   from assms show ?thesis by (auto simp: supporters_def dest: not_outside)
 qed
 
 lemma weighted_majority_nonagent1:
   assumes "is_pref_profile R" "x \<notin> alts"
   shows   "weighted_majority R x y = 0"
   using assms by (simp add: weighted_majority_def supporters_nonagent1 supporters_nonagent2)
 
 lemma weighted_majority_nonagent2:
   assumes "is_pref_profile R" "y \<notin> alts"
   shows   "weighted_majority R x y = 0"
   using assms by (simp add: weighted_majority_def supporters_nonagent1 supporters_nonagent2)
 
 lemma weighted_majority_eq_iff:
   assumes "is_pref_profile R1" "is_pref_profile R2"
   shows   "weighted_majority R1 = weighted_majority R2 \<longleftrightarrow>
              (\<forall>x\<in>alts. \<forall>y\<in>alts. weighted_majority R1 x y = weighted_majority R2 x y)"
 proof (intro iffI ext)
   fix x y :: 'alt
   assume "\<forall>x\<in>alts. \<forall>y\<in>alts. weighted_majority R1 x y = weighted_majority R2 x y"
   with assms show "weighted_majority R1 x y = weighted_majority R2 x y"
     by (cases "x \<in> alts"; cases "y \<in> alts") 
        (auto simp: fun_eq_iff weighted_majority_nonagent1 weighted_majority_nonagent2)
 qed auto
 
 end
 
   
 subsection \<open>Definition of Social Choice Functions\<close>
 
 locale social_choice_function = election agents alts 
   for agents :: "'agent set" and alts :: "'alt set" +
   fixes scf :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt set"
   assumes scf_nonempty: "is_pref_profile R \<Longrightarrow> scf R \<noteq> {}"
   assumes scf_alts: "is_pref_profile R \<Longrightarrow> scf R \<subseteq> alts"
 
 subsection \<open>Anonymity\<close>
 
 text \<open>
   An SCF is anonymous if permuting the agents in the input does not change the result.
 \<close>
 locale anonymous_scf = social_choice_function agents alts scf
   for agents :: "'agent set" and alts :: "'alt set" and scf +
   assumes anonymous: "\<pi> permutes agents \<Longrightarrow> is_pref_profile R \<Longrightarrow> scf (R \<circ> \<pi>) = scf R" 
 begin
 
 lemma anonymous':
   assumes "anonymous_profile R1 = anonymous_profile R2"
   assumes "is_pref_profile R1" "is_pref_profile R2"
   shows   "scf R1 = scf R2"
 proof -
   from anonymous_profile_agent_permutation[OF assms finite_agents]
     obtain \<pi> where "\<pi> permutes agents" "R1 = R2 \<circ> \<pi>" by blast
   with anonymous[of \<pi> R2] assms show ?thesis by simp
 qed
 
 lemma anonymity_prefs_from_table:
   assumes "prefs_from_table_wf agents alts xs" "prefs_from_table_wf agents alts ys"
   assumes "mset (map snd xs) = mset (map snd ys)"
   shows   "scf (prefs_from_table xs) = scf (prefs_from_table ys)"
 proof -
-  from prefs_from_table_agent_permutation[OF assms] guess \<pi> .
+  from assms obtain \<pi> where "\<pi> permutes agents" "prefs_from_table xs \<circ> \<pi> = prefs_from_table ys"
+    by (rule prefs_from_table_agent_permutation)
   with anonymous[of \<pi>, of "prefs_from_table xs"] assms(1) show ?thesis 
     by (simp add: pref_profile_from_tableI)
 qed
 
 context
 begin
 qualified lemma anonymity_prefs_from_table_aux:
   assumes "R1 = prefs_from_table xs" "prefs_from_table_wf agents alts xs"
   assumes "R2 = prefs_from_table ys" "prefs_from_table_wf agents alts ys"
   assumes "mset (map snd xs) = mset (map snd ys)"
   shows   "scf R1 = scf R2" unfolding assms(1,3)
   by (rule anonymity_prefs_from_table) (simp_all add: assms del: mset_map)
 end
 
 end
 
 
 subsection \<open>Neutrality\<close>
 
 text \<open>
   An SCF is neutral if permuting the alternatives in the input does not change the
   result, modulo the equivalent permutation in the output lottery.
 \<close>
 locale neutral_scf = social_choice_function agents alts scf
   for agents :: "'agent set" and alts :: "'alt set" and scf +
   assumes neutral: "\<sigma> permutes alts \<Longrightarrow> is_pref_profile R \<Longrightarrow> 
                         scf (permute_profile \<sigma> R) = \<sigma> ` scf R"
 begin
 
 text \<open>
   Alternative formulation of neutrality that shows that our definition is 
   equivalent to that in the paper.
 \<close>
 lemma neutral':
   assumes "\<sigma> permutes alts"
   assumes "is_pref_profile R"
   assumes "a \<in> alts"
   shows   "\<sigma> a \<in> scf (permute_profile \<sigma> R) \<longleftrightarrow> a \<in> scf R"
 proof -
   have *: "x = y" if "\<sigma> x = \<sigma> y" for x y
     using permutes_inj[OF assms(1)] that by (auto dest: injD)
   from assms show ?thesis by (auto simp: neutral dest!: *)
 qed
 
 end
 
 
 locale an_scf = 
   anonymous_scf agents alts scf + neutral_scf agents alts scf
   for agents :: "'agent set" and alts :: "'alt set" and scf
 begin
 
 lemma scf_anonymous_neutral:
   assumes perm: "\<sigma> permutes alts" and wf: "is_pref_profile R1" "is_pref_profile R2"
   assumes eq: "anonymous_profile R1 = 
                  image_mset (map (\<lambda>A. \<sigma> ` A)) (anonymous_profile R2)"
   shows   "scf R1 = \<sigma> ` scf R2"
 proof -
   interpret R1: pref_profile_wf agents alts R1 by fact
   interpret R2: pref_profile_wf agents alts R2 by fact
   from perm have wf': "is_pref_profile (permute_profile \<sigma> R2)"
     by (rule R2.wf_permute_alts)
   from eq perm have "anonymous_profile R1 = anonymous_profile (permute_profile \<sigma> R2)"
     by (simp add: R2.anonymous_profile_permute)
   from anonymous_profile_agent_permutation[OF this wf(1) wf']
     obtain \<pi> where "\<pi> permutes agents" "permute_profile \<sigma> R2 \<circ> \<pi> = R1" by auto
   have "scf (permute_profile \<sigma> R2 \<circ> \<pi>) = scf (permute_profile \<sigma> R2)"
     by (rule anonymous) fact+
   also have "\<dots> = \<sigma> ` scf R2"
     by (rule neutral) fact+
   also have "permute_profile \<sigma> R2 \<circ> \<pi> = R1" by fact
   finally show ?thesis .
 qed
 
 
 lemma scf_anonymous_neutral':
   assumes perm: "\<sigma> permutes alts" and wf: "is_pref_profile R1" "is_pref_profile R2"
   assumes eq: "anonymous_profile R1 = 
                  image_mset (map (\<lambda>A. \<sigma> ` A)) (anonymous_profile R2)"
   shows   "\<sigma> x \<in> scf R1 \<longleftrightarrow> x \<in> scf R2"
 proof -
   have "scf R1 = \<sigma> ` scf R2" by (intro scf_anonymous_neutral) fact+
   also have "\<sigma> x \<in> \<dots> \<longleftrightarrow> x \<in> scf R2"
     by (blast dest: injD[OF permutes_inj[OF perm]])
   finally show ?thesis .
 qed
 
 lemma scf_automorphism:
   assumes perm: "\<sigma> permutes alts" and wf: "is_pref_profile R"
   assumes eq: "image_mset (map (\<lambda>A. \<sigma> ` A)) (anonymous_profile R) = anonymous_profile R"
   shows   "\<sigma> ` scf R = scf R"
   using scf_anonymous_neutral[OF perm wf wf eq [symmetric]] ..
 
 end
 
 lemma an_scf_automorphism_aux:
   assumes wf: "prefs_from_table_wf agents alts yss" "R \<equiv> prefs_from_table yss"
   assumes an: "an_scf agents alts scf"
   assumes eq: "mset (map ((map (\<lambda>A. permutation_of_list xs ` A)) \<circ> snd) yss) = mset (map snd yss)"
   assumes perm: "set (map fst xs) \<subseteq> alts" "set (map snd xs) = set (map fst xs)" 
                 "distinct (map fst xs)" 
       and x: "x \<in> alts" "y = permutation_of_list xs x"
   shows   "x \<in> scf R \<longleftrightarrow> y \<in> scf R"
 proof -
   note perm = list_permutesI[OF perm]
   let ?\<sigma> = "permutation_of_list xs"
   note perm' = permutation_of_list_permutes [OF perm]
   from wf have wf': "pref_profile_wf agents alts R" by (simp add: pref_profile_from_tableI)
   then interpret R: pref_profile_wf agents alts R .
   from perm' interpret R': pref_profile_wf agents alts "permute_profile ?\<sigma> R"
     by (simp add: R.wf_permute_alts)
   from an interpret an_scf agents alts scf .
 
   from eq wf have eq': "image_mset (map (\<lambda>A. ?\<sigma> ` A)) (anonymous_profile R) = anonymous_profile R"
     by (simp add: anonymise_prefs_from_table mset_map multiset.map_comp)
   have "x \<in> scf R \<longleftrightarrow> ?\<sigma> x \<in> ?\<sigma> ` scf R"
     by (blast dest: injD[OF permutes_inj[OF perm']])
   also from eq' x wf' perm' have "?\<sigma> ` scf R = scf R"
     by (intro scf_automorphism) 
        (simp_all add: R.anonymous_profile_permute pref_profile_from_tableI)
   finally show ?thesis using x by simp
 qed
 
 
 subsection \<open>Weighted-majoritarian SCFs\<close>
 
 locale pairwise_scf = social_choice_function agents alts scf
   for agents :: "'agent set" and alts :: "'alt set" and scf +
   assumes pairwise:
     "is_pref_profile R1 \<Longrightarrow> is_pref_profile R2 \<Longrightarrow> weighted_majority R1 = weighted_majority R2 \<Longrightarrow>
        scf R1 = scf R2"
 
 subsection \<open>Pareto efficiency\<close>
 
 locale pareto_efficient_scf = social_choice_function agents alts scf
   for agents :: "'agent set" and alts :: "'alt set" and scf +
   assumes pareto_efficient: 
     "is_pref_profile R \<Longrightarrow> scf R \<inter> pareto_losers R = {}"
 begin
 
 lemma pareto_efficient':
   assumes "is_pref_profile R" "y \<succ>[Pareto(R)] x"
   shows   "x \<notin> scf R"
   using pareto_efficient[of R] assms 
   by (auto simp: pareto_losers_def)
 
 lemma pareto_efficient'':
   assumes "is_pref_profile R" "i \<in> agents"  "\<forall>i\<in>agents. y \<succeq>[R i] x" "\<not>y \<preceq>[R i] x"
   shows   "x \<notin> scf R"
 proof -
   from assms(1) interpret pref_profile_wf agents alts R .
   from assms(2-) show ?thesis
     by (intro pareto_efficient'[OF assms(1), of _ y])
        (auto simp: Pareto_iff strongly_preferred_def)
 qed
 
 end
 
 
 subsection \<open>Set extensions\<close>
 
 type_synonym 'alt set_extension = "'alt relation \<Rightarrow> 'alt set relation"
 
 definition Kelly :: "'alt set_extension" where
   "A \<succeq>[Kelly(R)] B \<longleftrightarrow> (\<forall>a\<in>A. \<forall>b\<in>B. a \<succeq>[R] b)"
 
 lemma Kelly_strict_iff: "A \<succ>[Kelly(R)] B \<longleftrightarrow> ((\<forall>a\<in>A. \<forall>b\<in>B. R b a) \<and> \<not> (\<forall>a\<in>B. \<forall>b\<in>A. R b a))"
   unfolding strongly_preferred_def Kelly_def ..
 
 lemmas Kelly_eval = Kelly_def Kelly_strict_iff
 
 definition Fishb :: "'alt set_extension" where
   "A \<succeq>[Fishb(R)] B \<longleftrightarrow> (\<forall>a\<in>A. \<forall>b\<in>B-A. a \<succeq>[R] b) \<and> (\<forall>a\<in>A-B. \<forall>b\<in>B. a \<succeq>[R] b)"
 
 lemma Fishb_strict_iff: 
   "A \<succ>[Fishb(R)] B \<longleftrightarrow> 
      ((\<forall>a\<in>A. \<forall>b\<in>B - A. R b a) \<and> (\<forall>a\<in>A - B. \<forall>b\<in>B. R b a)) \<and>
      \<not> ((\<forall>a\<in>B. \<forall>b\<in>A - B. R b a) \<and> (\<forall>a\<in>B - A. \<forall>b\<in>A. R b a))"
   unfolding strongly_preferred_def Fishb_def ..
 
 lemmas Fishb_eval = Fishb_def Fishb_strict_iff
 
 
 subsection \<open>Strategyproofness\<close>
 
 locale strategyproof_scf = 
   social_choice_function agents alts scf
   for agents :: "'agent set" and alts :: "'alt set" and scf +
   fixes set_ext :: "'alt set_extension"
   assumes strategyproof: 
     "is_pref_profile R \<Longrightarrow> total_preorder_on alts Ri' \<Longrightarrow> i \<in> agents \<Longrightarrow>
        \<not> scf (R(i := Ri')) \<succ>[set_ext(R i)] scf R"
 
 locale strategyproof_anonymous_scf =
   anonymous_scf agents alts scf + strategyproof_scf agents alts scf set_ext
   for agents :: "'agent set" and alts :: "'alt set" and scf and set_ext
 begin
 
 lemma strategyproof':
   assumes "is_pref_profile R1" "is_pref_profile R2" "i \<in> agents" "j \<in> agents"
   assumes "anonymous_profile R2 = anonymous_profile R1 - 
              {#weak_ranking (R1 i)#} + {#weak_ranking (R2 j)#}"
   shows   "\<not>scf R2 \<succ>[set_ext (R1 i)] scf R1"
 proof -
   let ?R3 = "R1(i := R2 j)"
   interpret R1: pref_profile_wf agents alts R1 by fact
   interpret R2: pref_profile_wf agents alts R2 by fact
   from \<open>j \<in> agents\<close> have "total_preorder_on alts (R2 j)" by simp
   from strategyproof[OF assms(1) this \<open>i \<in> agents\<close>] 
     have "\<not>scf ?R3 \<succ>[set_ext (R1 i)] scf R1" .
   also from assms have "scf ?R3 = scf R2"
     by (intro anonymous') (simp_all add: R1.anonymous_profile_update)
   finally show ?thesis .
 qed
 
 end
 
 context preorder_on
 begin
 
 lemma strict_not_outside:
   assumes "x \<prec>[le] y"
   shows   "x \<in> carrier" "y \<in> carrier"
   using assms not_outside[of x y] unfolding strongly_preferred_def by blast+
 
 end
 
 
 subsection \<open>Lifting preferences\<close>
 
 text \<open>
   Preference profiles can be lifted to a setting with more agents and alternatives by padding
   them with dummy agents and alternatives in such a way that every original agent prefers and
   original alternative over any dummy alternative and is indifferent between the dummy alternatives.
   Moreover, every dummy agent is completely indifferent.
 \<close>
 
 definition lift_prefs :: 
     "'alt set \<Rightarrow> 'alt set \<Rightarrow> 'alt relation \<Rightarrow> 'alt relation" where
   "lift_prefs alts alts' R = (\<lambda>x y. 
      x \<in> alts' \<and> y \<in> alts' \<and> (x = y \<or> x \<notin> alts \<or> (y \<in> alts \<and> R x y)))"
 
 lemma lift_prefs_wf:
   assumes "total_preorder_on alts R" "alts \<subseteq> alts'"
   shows   "total_preorder_on alts' (lift_prefs alts alts' R)"
 proof -
   interpret R: total_preorder_on alts R by fact
   show ?thesis
     by standard (insert R.total, auto dest: R.trans simp: lift_prefs_def)
 qed
 
 definition lift_pref_profile :: 
     "'agent set \<Rightarrow> 'alt set \<Rightarrow> 'agent set \<Rightarrow> 'alt set \<Rightarrow>
        ('agent, 'alt) pref_profile \<Rightarrow> ('agent, 'alt) pref_profile" where
   "lift_pref_profile agents alts agents' alts' R = (\<lambda>i x y. 
      x \<in> alts' \<and> y \<in> alts' \<and> i \<in> agents' \<and>
      (x = y \<or> x \<notin> alts \<or> i \<notin> agents \<or> (y \<in> alts \<and> R i x y)))"
 
 lemma lift_pref_profile_conv_vector:
   assumes "i \<in> agents" "i \<in> agents'"
   shows   "lift_pref_profile agents alts agents' alts' R i = lift_prefs alts alts' (R i)"
   using assms by (auto simp: lift_pref_profile_def lift_prefs_def)
 
 lemma lift_pref_profile_wf:
   assumes "pref_profile_wf agents alts R"
   assumes "agents \<subseteq> agents'" "alts \<subseteq> alts'" "finite alts'"
   defines "R' \<equiv> lift_pref_profile agents alts agents' alts' R"
   shows   "pref_profile_wf agents' alts' R'"
 proof -
   from assms interpret R: pref_profile_wf agents alts by simp
   have "finite_total_preorder_on alts' (R' i)" 
     if i: "i \<in> agents'" for i
   proof (cases "i \<in> agents")
     case True
     then interpret finite_total_preorder_on alts "R i" by simp
     from True assms show ?thesis
       by unfold_locales (auto simp: lift_pref_profile_def dest: total intro: trans)
   next 
     case False
     with assms i show ?thesis
       by unfold_locales (simp_all add: lift_pref_profile_def)
   qed
   moreover have "R' i = (\<lambda>_ _. False)" if "i \<notin> agents'" for i
     unfolding lift_pref_profile_def R'_def using that by simp
   ultimately show ?thesis unfolding pref_profile_wf_def using assms by auto
 qed
 
 lemma lift_pref_profile_permute_agents:
   assumes "\<pi> permutes agents" "agents \<subseteq> agents'"
   shows   "lift_pref_profile agents alts agents' alts' (R \<circ> \<pi>) = 
              lift_pref_profile agents alts agents' alts' R \<circ> \<pi>"
   using assms permutes_subset[OF assms]
   by (auto simp add: lift_pref_profile_def o_def permutes_in_image)
 
 lemma lift_pref_profile_permute_alts:
   assumes "\<sigma> permutes alts" "alts \<subseteq> alts'"
   shows   "lift_pref_profile agents alts agents' alts' (permute_profile \<sigma> R) = 
              permute_profile \<sigma> (lift_pref_profile agents alts agents' alts' R)"
 proof -
   from assms have inv: "inv \<sigma> permutes alts" by (intro permutes_inv)
   from this assms(2) have "inv \<sigma> permutes alts'" by (rule permutes_subset)
   with inv show ?thesis using assms permutes_inj[OF \<open>inv \<sigma> permutes alts\<close>]
     by (fastforce simp add: lift_pref_profile_def permutes_in_image
           permute_profile_def fun_eq_iff dest: injD)
 qed
 
 
 context
   fixes agents alts R agents' alts' R'
   assumes R_wf: "pref_profile_wf agents alts R"
   assumes election: "agents \<subseteq> agents'" "alts \<subseteq> alts'" "alts \<noteq> {}" "agents \<noteq> {}" "finite alts'"
   defines "R' \<equiv> lift_pref_profile agents alts agents' alts' R"
 begin
 
 interpretation R: pref_profile_wf agents alts R by fact
 interpretation R': pref_profile_wf agents' alts' R' 
   using election R_wf by (simp add: R'_def lift_pref_profile_wf)
 
 lemma lift_pref_profile_strict_iff:
   "x \<prec>[lift_pref_profile agents alts agents' alts' R i] y \<longleftrightarrow>
      i \<in> agents \<and> ((y \<in> alts \<and> x \<in> alts' - alts) \<or> x \<prec>[R i] y)"
 proof (cases "i \<in> agents")
   case True
   then interpret total_preorder_on alts "R i" by simp
   show ?thesis using not_outside election
     by (auto simp: lift_pref_profile_def strongly_preferred_def)
 qed (simp_all add: lift_pref_profile_def strongly_preferred_def)
 
 lemma preferred_alts_lift_pref_profile: 
   assumes i: "i \<in> agents'" and x: "x \<in> alts'"
   shows   "preferred_alts (R' i) x = 
              (if i \<in> agents \<and> x \<in> alts then preferred_alts (R i) x else alts')"
 proof (cases "i \<in> agents")
   assume i: "i \<in> agents"
   then interpret Ri: total_preorder_on alts "R i" by simp
   show ?thesis
   using i x election Ri.not_outside
     by (auto simp: preferred_alts_def R'_def lift_pref_profile_def Ri.refl)
 qed (auto simp: preferred_alts_def R'_def lift_pref_profile_def i x)
 
 lemma lift_pref_profile_Pareto_iff:
   "x \<preceq>[Pareto(R')] y \<longleftrightarrow> x \<in> alts' \<and> y \<in> alts' \<and> (x \<notin> alts \<or> x \<preceq>[Pareto(R)] y)"
 proof -
   from R.nonempty_agents obtain i where i: "i \<in> agents" by blast
   then interpret Ri: finite_total_preorder_on alts "R i" by simp
   show ?thesis unfolding R'.Pareto_iff R.Pareto_iff unfolding R'_def lift_pref_profile_def
     using election i by (auto simp: preorder_on.refl[OF R.in_dom] 
       simp del: R.nonempty_alts R.nonempty_agents  intro: Ri.not_outside)
 qed
 
 lemma lift_pref_profile_Pareto_strict_iff:
   "x \<prec>[Pareto(R')] y \<longleftrightarrow> x \<in> alts' \<and> y \<in> alts' \<and> (x \<notin> alts \<and> y \<in> alts \<or> x \<prec>[Pareto(R)] y)"
   by (auto simp: strongly_preferred_def lift_pref_profile_Pareto_iff R.Pareto.not_outside)
 
 lemma pareto_losers_lift_pref_profile:
   shows   "pareto_losers R' = pareto_losers R \<union> (alts' - alts)"
 proof -
   have A: "x \<in> alts" "y \<in> alts" if "x \<prec>[Pareto(R)] y" for x y
     using that R.Pareto.not_outside unfolding strongly_preferred_def by auto
   have B: "x \<in> alts'" if "x \<in> alts" for x using election that by blast
   from R.nonempty_alts obtain x where x: "x \<in> alts" by blast
   thus ?thesis unfolding pareto_losers_def lift_pref_profile_Pareto_strict_iff [abs_def]
     by (auto dest: A B)
 qed
 
 end
 
 
 subsection \<open>Lowering SCFs\<close>
 
 text \<open>
   Using the preference lifting, we can now \emph{lower} an SCF to a setting with fewer agents
   and alternatives under mild conditions to the original SCF. This preserves many nice properties, 
   such as anonymity, neutrality, and strategyproofness.
 \<close>
 
 locale scf_lowering = 
   pareto_efficient_scf agents alts scf
   for agents :: "'agent set" and alts :: "'alt set" and scf +
   fixes agents' alts' 
   assumes agents'_subset: "agents' \<subseteq> agents" and alts'_subset: "alts' \<subseteq> alts"
       and agents'_nonempty [simp]: "agents' \<noteq> {}" and alts'_nonempty [simp]: "alts' \<noteq> {}"
 begin
 
 lemma finite_agents' [simp]: "finite agents'"
   using agents'_subset finite_agents by (rule finite_subset)
 
 lemma finite_alts' [simp]: "finite alts'"
   using alts'_subset finite_alts by (rule finite_subset)
 
 abbreviation lift :: "('agent, 'alt) pref_profile \<Rightarrow> ('agent, 'alt) pref_profile" where
   "lift \<equiv> lift_pref_profile agents' alts' agents alts"
 
 definition lowered :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt set" where
   "lowered = scf \<circ> lift"
 
 lemma lift_wf [simp, intro]: 
   "pref_profile_wf agents' alts' R \<Longrightarrow> is_pref_profile (lift R)"
   using alts'_subset agents'_subset by (intro lift_pref_profile_wf) simp_all
 
 sublocale lowered: election agents' alts'
   by unfold_locales simp_all
 
 lemma preferred_alts_lift:
   "lowered.is_pref_profile R \<Longrightarrow> i \<in> agents \<Longrightarrow> x \<in> alts \<Longrightarrow>
      preferred_alts (lift R i) x = 
        (if i \<in> agents' \<and> x \<in> alts' then preferred_alts (R i) x else alts)"
   using alts'_subset agents'_subset
   by (intro preferred_alts_lift_pref_profile) simp_all
 
 lemma pareto_losers_lift:
   "lowered.is_pref_profile R \<Longrightarrow> pareto_losers (lift R) = pareto_losers R \<union> (alts - alts')"
   using agents'_subset alts'_subset by (intro pareto_losers_lift_pref_profile) simp_all
 
 
 sublocale lowered: social_choice_function agents' alts' lowered
 proof
   fix R assume R_wf: "pref_profile_wf agents' alts' R"
   from R_wf have R'_wf: "pref_profile_wf agents alts (lift R)" by (rule lift_wf)
   show "lowered R \<subseteq> alts'"
   proof safe
     fix x assume "x \<in> lowered R"
     hence "x \<in> scf (lift R)" by (auto simp: o_def lowered_def)
     moreover have "scf (lift R) \<inter> pareto_losers (lift R) = {}"
       by (intro pareto_efficient R'_wf)
     ultimately show "x \<in> alts'" using scf_alts[of "lift R"]
       by (auto simp: pareto_losers_lift R_wf R'_wf)
   qed
   show "lowered R \<noteq> {}"
     using R'_wf by (auto simp: lowered_def scf_nonempty)
 qed
 
 sublocale lowered: pareto_efficient_scf agents' alts' lowered
 proof
   fix R assume R_wf: "pref_profile_wf agents' alts' R"
   from R_wf have R'_wf: "pref_profile_wf agents alts (lift R)" by (rule lift_wf)
   have "lowered R \<inter> pareto_losers (lift R) = {}" unfolding lowered_def o_def
     by (intro pareto_efficient R'_wf)
   with R_wf show "lowered R \<inter> pareto_losers R = {}"
     by (auto simp: pareto_losers_lift)
 qed
 
 end
 
 
 locale scf_lowering_anonymous = 
   anonymous_scf agents alts scf +
   scf_lowering agents alts scf agents' alts'
   for agents :: "'agent set" and alts :: "'alt set" and scf agents' alts'
 begin
 
 sublocale lowered: anonymous_scf agents' alts' lowered
 proof
   fix \<pi> R
   assume "\<pi> permutes agents'" and "lowered.is_pref_profile R"
   thus "lowered (R \<circ> \<pi>) = lowered R" using agents'_subset
     by (auto simp: lowered_def lift_pref_profile_permute_agents anonymous permutes_subset)
 qed
 
 end
 
 
 locale scf_lowering_neutral = 
   neutral_scf agents alts scf +
   scf_lowering agents alts scf agents' alts'
   for agents :: "'agent set" and alts :: "'alt set" and scf agents' alts'
 begin
 
 sublocale lowered: neutral_scf agents' alts' lowered
 proof
   fix \<sigma> R
   assume "\<sigma> permutes alts'" and "lowered.is_pref_profile R"
   thus "lowered (permute_profile \<sigma> R) = \<sigma> ` lowered R" using alts'_subset
     by (auto simp: lowered_def lift_pref_profile_permute_alts neutral permutes_subset)
 qed
 
 end
 
 text \<open>
   The following is a technical condition that we need from a set extensions in order for
   strategyproofness to survive the lowering. The condition could probably be weakened a bit,
   but it is good enough for our purposes the way it is.
 \<close>
 locale liftable_set_extension =
   fixes alts' alts :: "'alt set" and set_ext :: "'alt relation \<Rightarrow> 'alt set relation"
   assumes set_ext_strong_lift:
     "total_preorder_on alts' R \<Longrightarrow> A \<noteq> {} \<Longrightarrow> B \<noteq> {} \<Longrightarrow> A \<subseteq> alts' \<Longrightarrow> B \<subseteq> alts' \<Longrightarrow>
        A \<prec>[set_ext R] B \<Longrightarrow> A \<prec>[set_ext (lift_prefs alts' alts R)] B"
 
 lemma liftable_set_extensionI_weak:
   assumes "\<And>R A B. total_preorder_on alts' R \<Longrightarrow> A \<noteq> {} \<Longrightarrow> B \<noteq> {} \<Longrightarrow> 
                       A \<subseteq> alts' \<Longrightarrow> B \<subseteq> alts' \<Longrightarrow>
               A \<preceq>[set_ext R] B \<longleftrightarrow> A \<preceq>[set_ext (lift_prefs alts' alts R)] B"
   shows   "liftable_set_extension alts' alts set_ext"
 proof (standard, goal_cases)
   case (1 R A B)
   from assms[of R A B] and assms[of R B A] and 1 show ?case
     by (auto simp: strongly_preferred_def)
 qed
 
 lemma Kelly_liftable:
   assumes "alts' \<subseteq> alts"
   shows   "liftable_set_extension alts' alts Kelly"
 proof (rule liftable_set_extensionI_weak, goal_cases)
   case (1 R A B)
   interpret R: total_preorder_on alts' R by fact
   from 1(2-5) show ?case using assms  R.refl
     by (force simp: Kelly_def lift_prefs_def)
 qed
 
 lemma Fishburn_liftable:
   assumes "alts' \<subseteq> alts"
   shows   "liftable_set_extension alts' alts Fishb"
 proof (rule liftable_set_extensionI_weak, goal_cases)
   case (1 R A B)
   interpret R: total_preorder_on alts' R by fact
   have conj_cong: "P1 \<and> Q1 \<longleftrightarrow> P2 \<and> Q2" if "P1 \<longleftrightarrow> P2" "Q1 \<longleftrightarrow> Q2" for P1 P2 Q1 Q2
     using that by blast
   from 1(2-5) show ?case using assms
     unfolding Fishb_def lift_prefs_def by (intro conj_cong ball_cong refl) auto
 qed
 
 locale scf_lowering_strategyproof =
   strategyproof_scf agents alts scf set_ext +
   liftable_set_extension alts' alts set_ext +
   scf_lowering agents alts scf agents' alts'
   for agents :: "'agent set" and alts :: "'alt set" and scf agents' alts' set_ext
 begin
 
 sublocale lowered: strategyproof_scf agents' alts' lowered
 proof
   fix R Ri' i
   assume R_wf: "lowered.is_pref_profile R" and Ri'_wf: "total_preorder_on alts' Ri'" 
      and i: "i \<in> agents'"
   interpret R: pref_profile_wf agents' alts' R by fact
   interpret Ri': total_preorder_on alts' Ri' by fact
   from R_wf have R'_wf: "is_pref_profile (lift R)" by (rule lift_wf)
 
   \<comment> \<open>We lift the alternative preference for the agent @{term i} in @{term R} to 
       preferences in the lifted profile. \<close>
   define Ri'' where "Ri'' = lift_prefs alts' alts Ri'"
 
   have "\<not>scf (lift R) \<prec>[set_ext (lift R i)] scf ((lift R)(i := Ri''))"
     using i agents'_subset alts'_subset unfolding Ri''_def
     by (intro strategyproof R'_wf Ri'_wf lift_prefs_wf) auto
   also have "(lift R)(i := Ri'') = lift (R(i := Ri'))" using i agents'_subset
     by (auto simp: fun_eq_iff Ri''_def lift_pref_profile_def lift_prefs_def)
   finally have not_less: "\<not>scf (lift R) \<prec>[set_ext (lift R i)] scf (lift (R(i := Ri')))" .
 
   show "\<not>lowered R \<prec>[set_ext (R i)] lowered (R(i := Ri'))"
   proof
     assume "lowered R \<prec>[set_ext (R i)] lowered (R(i := Ri'))"
     hence "lowered R \<prec>[set_ext (lift_prefs alts' alts (R i))] lowered (R(i := Ri'))"
       by (intro set_ext_strong_lift R.prefs_wf'(1) i lowered.scf_nonempty lowered.scf_alts
                 R.wf_update R_wf Ri'_wf)
     also have "lift_prefs alts' alts (R i) = lift R i"
       using agents'_subset i by (subst lift_pref_profile_conv_vector) auto
     finally show False using not_less unfolding lowered_def o_def by contradiction
   qed
 qed
     
 end
 
 end
\ No newline at end of file
diff --git a/thys/Functional-Automata/MaxPrefix.thy b/thys/Functional-Automata/MaxPrefix.thy
--- a/thys/Functional-Automata/MaxPrefix.thy
+++ b/thys/Functional-Automata/MaxPrefix.thy
@@ -1,92 +1,90 @@
 (*  Author:     Tobias Nipkow
     Copyright   1998 TUM
 *)
 
 section "Maximal prefix"
 
 theory MaxPrefix
 imports "HOL-Library.Sublist"
 begin
 
 definition
  is_maxpref :: "('a list \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
 "is_maxpref P xs ys =
  (prefix xs ys \<and> (xs=[] \<or> P xs) \<and> (\<forall>zs. prefix zs ys \<and> P zs \<longrightarrow> prefix zs xs))"
 
 type_synonym 'a splitter = "'a list \<Rightarrow> 'a list * 'a list"
 
 definition
  is_maxsplitter :: "('a list \<Rightarrow> bool) \<Rightarrow> 'a splitter \<Rightarrow> bool" where
 "is_maxsplitter P f =
  (\<forall>xs ps qs. f xs = (ps,qs) = (xs=ps@qs \<and> is_maxpref P ps xs))"
 
 fun maxsplit :: "('a list \<Rightarrow> bool) \<Rightarrow> 'a list * 'a list \<Rightarrow> 'a list \<Rightarrow> 'a splitter" where
 "maxsplit P res ps []     = (if P ps then (ps,[]) else res)" |
 "maxsplit P res ps (q#qs) = maxsplit P (if P ps then (ps,q#qs) else res)
                                      (ps@[q]) qs"
 
 declare if_split[split del]
 
 lemma maxsplit_lemma: "(maxsplit P res ps qs = (xs,ys)) =
   (if \<exists>us. prefix us qs \<and> P(ps@us) then xs@ys=ps@qs \<and> is_maxpref P xs (ps@qs)
    else (xs,ys)=res)"
 proof (induction P res ps qs rule: maxsplit.induct)
   case 1
   thus ?case by (auto simp: is_maxpref_def split: if_splits)
 next
   case (2 P res ps q qs)
   show ?case
   proof (cases "\<exists>us. prefix us qs \<and> P ((ps @ [q]) @ us)")
-    case True
-    note ex1 = this
-    then guess us by (elim exE conjE) note us = this
+    case ex1: True
+    then obtain us where "prefix us qs" "P ((ps @ [q]) @ us)" by blast
     hence ex2: "\<exists>us. prefix us (q # qs) \<and> P (ps @ us)"
       by (intro exI[of _ "q#us"]) auto
     with ex1 and 2 show ?thesis by simp
   next
-    case False
-    note ex1 = this
+    case ex1: False
     show ?thesis
     proof (cases "\<exists>us. prefix us (q#qs) \<and> P (ps @ us)")
       case False
       from 2 show ?thesis
         by (simp only: ex1 False) (insert ex1 False, auto simp: prefix_Cons)
     next
       case True
       note ex2 = this
       show ?thesis
       proof (cases "P ps")
         case True
         with 2 have "(maxsplit P (ps, q # qs) (ps @ [q]) qs = (xs, ys)) \<longleftrightarrow> (xs = ps \<and> ys = q # qs)"
           by (simp only: ex1 ex2) simp_all
         also have "\<dots> \<longleftrightarrow> (xs @ ys = ps @ q # qs \<and> is_maxpref P xs (ps @ q # qs))"
           using ex1 True
           by (auto simp: is_maxpref_def prefix_append prefix_Cons append_eq_append_conv2)
         finally show ?thesis using True by (simp only: ex1 ex2) simp_all
       next
         case False
         with 2 have "(maxsplit P res (ps @ [q]) qs = (xs, ys)) \<longleftrightarrow> ((xs, ys) = res)"
           by (simp only: ex1 ex2) simp
         also have "\<dots> \<longleftrightarrow> (xs @ ys = ps @ q # qs \<and> is_maxpref P xs (ps @ q # qs))"
           using ex1 ex2 False
           by (auto simp: append_eq_append_conv2 is_maxpref_def prefix_Cons)
         finally show ?thesis
           using False by (simp only: ex1 ex2) simp
       qed
     qed
   qed
 qed
 
 declare if_split[split]
 
 lemma is_maxpref_Nil[simp]:
  "\<not>(\<exists>us. prefix us xs \<and> P us) \<Longrightarrow> is_maxpref P ps xs = (ps = [])"
   by (auto simp: is_maxpref_def)
 
 lemma is_maxsplitter_maxsplit:
  "is_maxsplitter P (\<lambda>xs. maxsplit P ([],xs) [] xs)"
   by (auto simp: maxsplit_lemma is_maxsplitter_def)
 
 lemmas maxsplit_eq = is_maxsplitter_maxsplit[simplified is_maxsplitter_def]
 
 end
diff --git a/thys/Goodstein_Lambda/Goodstein_Lambda.thy b/thys/Goodstein_Lambda/Goodstein_Lambda.thy
--- a/thys/Goodstein_Lambda/Goodstein_Lambda.thy
+++ b/thys/Goodstein_Lambda/Goodstein_Lambda.thy
@@ -1,755 +1,756 @@
 section \<open>Specification\<close>
 
 theory Goodstein_Lambda
   imports Main
 begin
 
 subsection \<open>Hereditary base representation\<close>
 
 text \<open>We define a data type of trees and an evaluation function that sums siblings and
   exponentiates with respect to the given base on nesting.\<close>
 
 datatype C = C (unC: "C list")
 
 fun evalC where
   "evalC b (C []) = 0"
 | "evalC b (C (x # xs)) = b^evalC b x + evalC b (C xs)"
 
 value "evalC 2 (C [])" \<comment> \<open>$0$\<close>
 value "evalC 2 (C [C []])" \<comment> \<open>$2^0 = 1$\<close>
 value "evalC 2 (C [C [C []]])" \<comment> \<open>$2^1 = 2$\<close>
 value "evalC 2 (C [C [], C []])" \<comment> \<open>$2^0 + 2^0 = 2^0 \cdot 2 = 2$; not in hereditary base $2$\<close>
 
 text \<open>The hereditary base representation is characterized as trees (i.e., nested lists) whose
   lists have monotonically increasing evaluations, with fewer than @{term "b"} repetitions for
   each value. We will show later that this representation is unique.\<close>
 
 inductive_set hbase for b where
   "C [] \<in> hbase b"
 | "i \<noteq> 0 \<Longrightarrow> i < b \<Longrightarrow> n \<in> hbase b \<Longrightarrow>
    C ms \<in> hbase b \<Longrightarrow> (\<And>m'. m' \<in> set ms \<Longrightarrow> evalC b n < evalC b m') \<Longrightarrow>
    C (replicate i n @ ms) \<in> hbase b"
 
 text \<open>We can convert to and from natural numbers as follows.\<close>
 
 definition H2N where
   "H2N b n = evalC b n"
 
 text \<open>As we will show later, @{term "H2N b"} restricted to @{term "hbase n"} is bijective
   if @{prop "b \<ge> (2 :: nat)"}, so we can convert from natural numbers by taking the inverse.\<close>
 
 definition N2H where
   "N2H b n = inv_into (hbase b) (H2N b) n"
 
 subsection \<open>The Goodstein function\<close>
 
 text \<open>We define a function that computes the length of the Goodstein sequence whose $c$-th element
   is $g_c = n$. Termination will be shown later, thereby establishing Goodstein's theorem.\<close>
 
 function (sequential) goodstein :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
   "goodstein 0 n = 0"
   \<comment> \<open>we start counting at 1; also note that the initial base is @{term "c+1 :: nat"} and\<close>
   \<comment> \<open>hereditary base 1 makes no sense, so we have to avoid this case\<close>
 | "goodstein c 0 = c"
 | "goodstein c n = goodstein (c+1) (H2N (c+2) (N2H (c+1) n) - 1)"
   by pat_completeness auto
 
 abbreviation \<G> where
   "\<G> n \<equiv> goodstein (Suc 0) n"
 
 section \<open>Ordinals\<close>
 
 text \<open>The following type contains countable ordinals, by the usual case distinction into 0,
   successor ordinal, or limit ordinal; limit ordinals are given by their fundamental sequence.
   Hereditary base @{term "b"} representations carry over to such ordinals by replacing each
   occurrence of the base by @{term "\<omega>"}.\<close>
 
 datatype Ord = Z | S Ord | L "nat \<Rightarrow> Ord"
 
 text \<open>Note that the following arithmetic operations are not correct for all ordinals. However, they
   will only be used in cases where they actually correspond to the ordinal arithmetic operations.\<close>
 
 primrec addO where
   "addO n Z = n"
 | "addO n (S m) = S (addO n m)"
 | "addO n (L f) = L (\<lambda>i. addO n (f i))"
 
 primrec mulO where
   "mulO n Z = Z"
 | "mulO n (S m) = addO (mulO n m) n"
 | "mulO n (L f) = L (\<lambda>i. mulO n (f i))"
 
 definition \<omega> where
   "\<omega> = L (\<lambda>n. (S ^^ n) Z)"
 
 primrec exp\<omega> where
   "exp\<omega> Z = S Z"
 | "exp\<omega> (S n) = mulO (exp\<omega> n) \<omega>"
 | "exp\<omega> (L f) = L (\<lambda>i. exp\<omega> (f i))"
 
 subsection \<open>Evaluation\<close>
 
 text \<open>Evaluating an ordinal number at base $b$ is accomplished by taking the $b$-th element of
   all fundamental sequences and interpreting zero and successor over the natural numbers.\<close>
 
 primrec evalO where
   "evalO b Z = 0"
 | "evalO b (S n) = Suc (evalO b n)"
 | "evalO b (L f) = evalO b (f b)"
 
 subsection \<open>Goodstein function and sequence\<close>
 
 text \<open>We can define the Goodstein function very easily, but proving correctness will take a while.\<close>
 
 primrec goodsteinO where
   "goodsteinO c Z = c"
 | "goodsteinO c (S n) = goodsteinO (c+1) n"
 | "goodsteinO c (L f) = goodsteinO c (f (c+2))"
 
 primrec stepO where
   "stepO c Z = Z"
 | "stepO c (S n) = n"
 | "stepO c (L f) = stepO c (f (c+2))"
 
 text \<open>We can compute a few values of the Goodstein sequence starting at $4$.\<close>
 
 definition g4O where
   "g4O n = fold stepO [1..<Suc n] ((exp\<omega> ^^ 3) Z)"
 
 value "map (\<lambda>n. evalO (n+2) (g4O n)) [0..<10]"
 \<comment> \<open>@{value "[4, 26, 41, 60, 83, 109, 139, 173, 211, 253] :: nat list"}\<close>
 
 subsection \<open>Properties of evaluation\<close>
 
 lemma evalO_addO [simp]:
   "evalO b (addO n m) = evalO b n + evalO b m"
   by (induct m) auto
 
 lemma evalO_mulO [simp]:
   "evalO b (mulO n m) = evalO b n * evalO b m"
   by (induct m) auto
 
 lemma evalO_n [simp]:
   "evalO b ((S ^^ n) Z) = n"
   by (induct n) auto
 
 lemma evalO_\<omega> [simp]:
   "evalO b \<omega> = b"
   by (auto simp: \<omega>_def)
 
 lemma evalO_exp\<omega> [simp]:
   "evalO b (exp\<omega> n) = b^(evalO b n)"
   by (induct n) auto
 
 text \<open>Note that evaluation is useful for proving that @{type "Ord"} values are distinct:\<close>
 notepad begin
   have "addO n (exp\<omega> m) \<noteq> n" for n m by (auto dest: arg_cong[of _ _ "evalO 1"])
 end
 
 subsection \<open>Arithmetic properties\<close>
 
 lemma addO_Z [simp]:
   "addO Z n = n"
   by (induct n) auto
 
 lemma addO_assoc [simp]:
   "addO n (addO m p) = addO (addO n m) p"
   by (induct p) auto
 
 lemma mul0_distrib [simp]:
   "mulO n (addO p q) = addO (mulO n p) (mulO n q)"
   by (induct q) auto
 
 lemma mulO_assoc [simp]:
   "mulO n (mulO m p) = mulO (mulO n m) p"
   by (induct p) auto
 
 lemma exp\<omega>_addO [simp]:
   "exp\<omega> (addO n m) = mulO (exp\<omega> n) (exp\<omega> m)"
   by (induct m) auto
 
 
 section \<open>Cantor normal form\<close>
 
 text \<open>The previously introduced tree type @{type C} can be used to represent Cantor normal forms;
   they are trees (evaluated at base @{term \<omega>}) such that siblings are in non-decreasing order.
   One can think of this as hereditary base @{term \<omega>}. The plan is to mirror selected operations on
   ordinals in Cantor normal forms.\<close>
 
 subsection \<open>Conversion to and from the ordinal type @{type Ord}\<close>
 
 fun C2O where
   "C2O (C []) = Z"
 | "C2O (C (n # ns)) = addO (C2O (C ns)) (exp\<omega> (C2O n))"
 
 definition O2C where
   "O2C = inv C2O"
 
 text \<open>We show that @{term C2O} is injective, meaning the inverse is unique.\<close>
 
 lemma addO_exp\<omega>_inj:
   assumes "addO n (exp\<omega> m) = addO n' (exp\<omega> m')"
   shows "n = n'" and "m = m'"
 proof -
   have "addO n (exp\<omega> m) = addO n' (exp\<omega> m') \<Longrightarrow> n = n'"
     by (induct m arbitrary: m'; case_tac m';
       force simp: \<omega>_def dest!: fun_cong[of _ _ 1])
   moreover have "addO n (exp\<omega> m) = addO n (exp\<omega> m') \<Longrightarrow> m = m'"
     apply (induct m arbitrary: n m'; case_tac m')
     apply (auto 0 3 simp: \<omega>_def intro: rangeI
       dest: arg_cong[of _ _ "evalO 1"] fun_cong[of _ _ 0] fun_cong[of _ _ 1])[8] (* 1 left *)
     by simp (meson ext rangeI)
   ultimately show "n = n'" and "m = m'" using assms by simp_all
 qed
 
 lemma C2O_inj:
   "C2O n = C2O m \<Longrightarrow> n = m"
   by (induct n arbitrary: m rule: C2O.induct; case_tac m rule: C2O.cases)
     (auto dest: addO_exp\<omega>_inj arg_cong[of _ _ "evalO 1"])
 
 lemma O2C_C2O [simp]:
   "O2C (C2O n) = n"
   by (auto intro!: inv_f_f simp: O2C_def inj_def C2O_inj)
 
 lemma O2C_Z [simp]:
   "O2C Z = C []"
   using O2C_C2O[of "C []", unfolded C2O.simps] .
 
 lemma C2O_replicate:
   "C2O (C (replicate i n)) = mulO (exp\<omega> (C2O n)) ((S ^^ i) Z)"
   by (induct i) auto
 
 lemma C2O_app:
   "C2O (C (xs @ ys)) = addO (C2O (C ys)) (C2O (C xs))"
   by (induct xs arbitrary: ys) auto
 
 subsection \<open>Evaluation\<close>
 
 lemma evalC_def':
   "evalC b n = evalO b (C2O n)"
   by (induct n rule: C2O.induct) auto
 
 lemma evalC_app [simp]:
   "evalC b (C (ns @ ms)) = evalC b (C ns) + evalC b (C ms)"
   by (induct ns) auto
 
 lemma evalC_replicate [simp]:
   "evalC b (C (replicate c n)) = c * evalC b (C [n])"
   by (induct c) auto
 
 subsection \<open>Transfer of the @{type Ord} induction principle to @{type C}\<close>
 
 fun funC where \<comment> \<open>@{term funC} computes the fundamental sequence on @{type C}\<close>
   "funC (C []) = (\<lambda>i. [C []])"
 | "funC (C (C [] # ns)) = (\<lambda>i. replicate i (C ns))"
 | "funC (C (n # ns)) = (\<lambda>i. [C (funC n i @ ns)])"
 
 lemma C2O_cons:
   "C2O (C (n # ns)) =
     (if n = C [] then S (C2O (C ns)) else L (\<lambda>i. C2O (C (funC n i @ ns))))"
   by (induct n arbitrary: ns rule: funC.induct)
     (simp_all add: \<omega>_def C2O_replicate C2O_app flip: exp\<omega>_addO)
 
 lemma C_Ord_induct:
   assumes "P (C [])"
   and "\<And>ns. P (C ns) \<Longrightarrow> P (C (C [] # ns))"
   and "\<And>n ns ms. (\<And>i. P (C (funC (C (n # ns)) i @ ms))) \<Longrightarrow>
     P (C (C (n # ns) # ms))"
   shows "P n"
 proof -
   have "\<forall>n. C2O n = m \<longrightarrow> P n" for m
     by (induct m; intro allI; case_tac n rule: funC.cases)
       (auto simp: C2O_cons simp del: C2O.simps(2) intro: assms)
   then show ?thesis by simp
 qed
 
 subsection \<open>Goodstein function and sequence on @{type C}\<close>
 
 function (domintros) goodsteinC where
   "goodsteinC c (C []) = c"
 | "goodsteinC c (C (C [] # ns)) = goodsteinC (c+1) (C ns)"
 | "goodsteinC c (C (C (n # ns) # ms)) =
     goodsteinC c (C (funC (C (n # ns)) (c+2) @ ms))"
   by pat_completeness auto
 
 termination
 proof -
   have "goodsteinC_dom (c, n)" for c n
     by (induct n arbitrary: c rule: C_Ord_induct) (auto intro: goodsteinC.domintros)
   then show ?thesis by simp
 qed
 
 lemma goodsteinC_def':
   "goodsteinC c n = goodsteinO c (C2O n)"
   by (induct c n rule: goodsteinC.induct) (simp_all add: C2O_cons del: C2O.simps(2))
 
 function (domintros) stepC where
   "stepC c (C []) = C []"
 | "stepC c (C (C [] # ns)) = C ns"
 | "stepC c (C (C (n # ns) # ms)) =
     stepC c (C (funC (C (n # ns)) (Suc (Suc c)) @ ms))"
   by pat_completeness auto
 
 termination
 proof -
   have "stepC_dom (c, n)" for c n
     by (induct n arbitrary: c rule: C_Ord_induct) (auto intro: stepC.domintros)
   then show ?thesis by simp
 qed
 
 definition g4C where
   "g4C n = fold stepC [1..<Suc n] (C [C [C [C []]]])"
 
 value "map (\<lambda>n. evalC (n+2) (g4C n)) [0..<10]"
 \<comment> \<open>@{value "[4, 26, 41, 60, 83, 109, 139, 173, 211, 253] :: nat list"}\<close>
 
 subsection \<open>Properties\<close>
 
 lemma stepC_def':
   "stepC c n = O2C (stepO c (C2O n))"
   by (induct c n rule: stepC.induct) (simp_all add: C2O_cons del: C2O.simps(2))
 
 lemma funC_ne [simp]:
   "funC m (Suc n) \<noteq> []"
   by (cases m rule: funC.cases) simp_all
 
 lemma evalC_funC [simp]:
   "evalC b (C (funC n b)) = evalC b (C [n])"
   by (induct n rule: funC.induct) simp_all
 
 lemma stepC_app [simp]:
   "n \<noteq> C [] \<Longrightarrow> stepC c (C (unC n @ ns)) = C (unC (stepC c n) @ ns)"
   by (induct n arbitrary: ns rule: stepC.induct) simp_all
 
 lemma stepC_cons [simp]:
   "ns \<noteq> [] \<Longrightarrow> stepC c (C (n # ns)) = C (unC (stepC c (C [n])) @ ns)"
   using stepC_app[of "C[n]" c ns] by simp
 
 lemma stepC_dec:
   "n \<noteq> C [] \<Longrightarrow> Suc (evalC (Suc (Suc c)) (stepC c n)) = evalC (Suc (Suc c)) n"
   by (induct c n rule: stepC.induct) simp_all
 
 lemma stepC_dec':
   "n \<noteq> C [] \<Longrightarrow> evalC (c+3) (stepC c n) < evalC (c+3) n"
 proof (induct c n rule: stepC.induct)
   case (3 c n ns ms)
   have "evalC (c+3) (C (funC (C (n # ns)) (Suc (Suc c)))) \<le>
       (c+3) ^ ((c+3) ^ evalC (c+3) n + evalC (c+3) (C ns))"
     by (induct n rule: funC.induct) (simp_all add: distrib_right)
   then show ?case using 3 by simp
 qed simp_all
 
 
 section \<open>Hereditary base @{term b} representation\<close>
 
 text \<open>We now turn to properties of the @{term "hbase b"} subset of trees.\<close>
 
 subsection \<open>Uniqueness\<close>
 
 text \<open>We show uniqueness of the hereditary base representation by showing that @{term "evalC b"}
   restricted to @{term "hbase b"} is injective.\<close>
 
 lemma hbaseI2:
   "i < b \<Longrightarrow> n \<in> hbase b \<Longrightarrow> C m \<in> hbase b \<Longrightarrow>
     (\<And>m'. m' \<in> set m \<Longrightarrow> evalC b n < evalC b m') \<Longrightarrow>
     C (replicate i n @ m) \<in> hbase b"
   by (cases i) (auto intro: hbase.intros simp del: replicate.simps(2))
 
 lemmas hbase_singletonI =
   hbase.intros(2)[of 1 "Suc (Suc b)" for b, OF _ _ _ hbase.intros(1), simplified]
 
 lemma hbase_hd:
   "C ns \<in> hbase b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> hd ns \<in> hbase b"
   by (cases rule: hbase.cases) auto
 
 lemmas hbase_hd' [dest] = hbase_hd[of "n # ns" for n ns, simplified]
 
 lemma hbase_tl:
   "C ns \<in> hbase b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> C (tl ns) \<in> hbase b"
   by (cases "C ns" b rule: hbase.cases) (auto intro: hbaseI2)
 
 lemmas hbase_tl' [dest] = hbase_tl[of "n # ns" for n ns, simplified]
 
 lemma hbase_elt [dest]:
   "C ns \<in> hbase b \<Longrightarrow> n \<in> set ns \<Longrightarrow> n \<in> hbase b"
   by (induct ns) auto
 
 lemma evalC_sum_list:
   "evalC b (C ns) = sum_list (map (\<lambda>n. b^evalC b n) ns)"
   by (induct ns) auto
 
 lemma sum_list_replicate:
   "sum_list (replicate n x) = n * x"
   by (induct n) auto
 
 lemma base_red:
   fixes b :: nat
   assumes n: "\<And>n'. n' \<in> set ns \<Longrightarrow> n < n'" "i < b" "i \<noteq> 0"
   and m: "\<And>m'. m' \<in> set ms \<Longrightarrow> m < m'" "j < b" "j \<noteq> 0"
   and s: "i * b^n + sum_list (map (\<lambda>n. b^n) ns) = j * b^m + sum_list (map (\<lambda>n. b^n) ms)"
   shows "i = j \<and> n = m"
   using n(1) m(1) s
 proof (induct n arbitrary: m ns ms)
   { fix ns ms :: "nat list" and i j m :: nat
     assume n': "\<And>n'. n' \<in> set ns \<Longrightarrow> 0 < n'" "i < b" "i \<noteq> 0"
     assume m': "\<And>m'. m' \<in> set ms \<Longrightarrow> m < m'" "j < b" "j \<noteq> 0"
     assume s': "i * b^0 + sum_list (map (\<lambda>n. b^n) ns) = j * b^m + sum_list (map (\<lambda>n. b^n) ms)"
     obtain x where [simp]: "sum_list (map ((^) b) ns) = x*b"
       using n'(1)
       by (intro that[of "sum_list (map (\<lambda>n. b^(n-1)) ns)"])
         (simp add: ac_simps flip: sum_list_const_mult power_Suc cong: map_cong)
     obtain y where [simp]: "sum_list (map ((^) b) ms) = y*b"
       using order.strict_trans1[OF le0 m'(1)]
       by (intro that[of "sum_list (map (\<lambda>n. b^(n-1)) ms)"])
         (simp add: ac_simps flip: sum_list_const_mult power_Suc cong: map_cong)
     have [simp]: "m = 0"
       using s' n'(2,3)
       by (cases m, simp_all)
         (metis Groups.mult_ac(2) Groups.mult_ac(3) Suc_pred div_less mod_div_mult_eq
           mod_mult_self2 mod_mult_self2_is_0 mult_zero_right nat.simps(3))
     have "i = j \<and> 0 = m" using s' n'(2,3) m'(2,3)
       by simp (metis div_less mod_div_mult_eq mod_mult_self1)
   } note BASE = this
   {
     case 0 show ?case by (rule BASE; fact)
   next
     case (Suc n m')
     have "j = i \<and> 0 = Suc n" if "m' = 0" using Suc(2-4)
       by (intro BASE[of ms j ns "Suc n" i]) (simp_all add: ac_simps that n(2,3) m(2,3))
     then obtain m where m' [simp]: "m' = Suc m"
       by (cases m') auto
     obtain ns' where [simp]: "ns = map Suc ns'" "\<And>n'. n' \<in> set ns' \<Longrightarrow> n < n'"
       using Suc(2) less_trans[OF zero_less_Suc Suc(2)]
       by (intro that[of "map (\<lambda>n. n-1) ns"]; force cong: map_cong)
     obtain ms' where [simp]: "ms = map Suc ms'" "\<And>m'. m' \<in> set ms' \<Longrightarrow> m < m'"
       using Suc(3)[unfolded m'] less_trans[OF zero_less_Suc Suc(3)[unfolded m']]
       by (intro that[of "map (\<lambda>n. n-1) ms"]; force cong: map_cong)
     have *: "b * x = b * y \<Longrightarrow> x = y" for x y using n(2) by simp
     have "i = j \<and> n = m"
     proof (rule Suc(1)[of "map (\<lambda>n. n-1) ns" "map (\<lambda>n. n-1) ms" m, OF _ _ *], goal_cases)
       case 3 show ?case using Suc(4) unfolding add_mult_distrib2
         by (simp add: comp_def ac_simps flip: sum_list_const_mult)
     qed simp_all
     then show ?case by simp
   }
 qed
 
 lemma evalC_inj_on_hbase:
   "n \<in> hbase b \<Longrightarrow> m \<in> hbase b \<Longrightarrow> evalC b n = evalC b m \<Longrightarrow> n = m"
 proof (induct n arbitrary: m rule: hbase.induct)
   case 1
   then show ?case by (cases m rule: hbase.cases) simp_all
 next
   case (2 i n ns m')
   obtain j m ms where [simp]: "m' = C (replicate j m @ ms)" and
     m: "j \<noteq> 0" "j < b" "m \<in> hbase b" "C ms \<in> hbase b" "\<And>m'. m' \<in> set ms \<Longrightarrow> evalC b m < evalC b m'"
     using 2(8,1,2,9) by (cases m' rule: hbase.cases) simp_all
   have "i = j \<and> evalC b n = evalC b m" using 2(1,2,7,9) m(1,2,5)
     by (intro base_red[of "map (evalC b) ns" _ _ b "map (evalC b) ms"])
       (auto simp: comp_def evalC_sum_list sum_list_replicate)
   then show ?case
     using 2(4)[OF m(3)] 2(6)[OF m(4)] 2(9) by simp
 qed
 
 subsection \<open>Correctness of @{const stepC}\<close>
 
 text \<open>We show that @{term "stepC c"} preserves hereditary base @{term "c + 2 :: nat"}
   representations. In order to cover intermediate results produced by @{const stepC}, we extend
   the hereditary base representation to allow the least significant digit to be equal to @{term b},
   which essentially means that we may have an extra sibling in front on every level.\<close>
 
 inductive_set hbase_ext for b where
   "n \<in> hbase b \<Longrightarrow> n \<in> hbase_ext b"
 | "n \<in> hbase_ext b \<Longrightarrow>
    C m \<in> hbase b \<Longrightarrow> (\<And>m'. m' \<in> set m \<Longrightarrow> evalC b n \<le> evalC b m') \<Longrightarrow>
    C (n # m) \<in> hbase_ext b"
 
 lemma hbase_ext_hd' [dest]:
   "C (n # ns) \<in> hbase_ext b \<Longrightarrow> n \<in> hbase_ext b"
   by (cases rule: hbase_ext.cases) (auto intro: hbase_ext.intros(1))
 
 lemma hbase_ext_tl:
   "C ns \<in> hbase_ext b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> C (tl ns) \<in> hbase b"
   by (cases "C ns" b rule: hbase_ext.cases; cases ns) (simp_all add: hbase_tl')
 
 lemmas hbase_ext_tl' [dest] = hbase_ext_tl[of "n # ns" for n ns, simplified]
 
 lemma hbase_funC:
   "c \<noteq> 0 \<Longrightarrow> C (n # ns) \<in> hbase_ext (Suc c) \<Longrightarrow>
     C (funC n (Suc c) @ ns) \<in> hbase_ext (Suc c)"
 proof (induct n arbitrary: ns rule: funC.induct)
   case (2 ms)
   have [simp]: "evalC (Suc c) (C ms) < evalC (Suc c) m'" if "m' \<in> set ns" for m'
     using 2(2)
   proof (cases rule: hbase_ext.cases)
     case 1 then show ?thesis using that
       by (cases rule: hbase.cases, case_tac i) (auto intro: Suc_lessD)
   qed (auto simp: Suc_le_eq that)
   show ?case using 2
     by (auto 0 4 intro: hbase_ext.intros hbase.intros(2) order.strict_implies_order)
 next
   case (3 m ms ms')
   show ?case
     unfolding funC.simps append_Cons append_Nil
   proof (rule hbase_ext.intros(2), goal_cases 31 32 33)
     case (33 m')
     show ?case using 3(3)
     proof (cases rule: hbase_ext.cases)
       case 1 show ?thesis using 1 3(1,2) 33
         by (cases rule: hbase.cases, case_tac i) (auto intro: less_or_eq_imp_le)
     qed (insert 33, simp)
   qed (insert 3, blast+)
 qed auto
 
 lemma stepC_sound:
   "n \<in> hbase_ext (Suc (Suc c)) \<Longrightarrow> stepC c n \<in> hbase (Suc (Suc c))"
 proof (induct c n rule: stepC.induct)
   case (3 c n ns ms)
   show ?case using 3(2,1)
     by (cases rule: hbase_ext.cases; unfold stepC.simps) (auto intro: hbase_funC)
 qed (auto intro: hbase.intros)
 
 subsection \<open>Surjectivity of @{const evalC}\<close>
 
 text \<open>Note that the base must be at least @{term "2 :: nat"}.\<close>
 
 lemma evalC_surjective:
   "\<exists>n' \<in> hbase (Suc (Suc b)). evalC (Suc (Suc b)) n' = n"
 proof (induct n)
   case 0 then show ?case by (auto intro: bexI[of _ "C []"] hbase.intros)
 next
   have [simp]: "Suc x \<le> Suc (Suc b)^x" for x by (induct x) auto
   case (Suc n)
-  then guess n' by (rule bexE)
+  then obtain n' where "n' \<in> hbase (Suc (Suc b))" "evalC (Suc (Suc b)) n' = n" by blast
   then obtain n' j where n': "Suc n \<le> j" "j = evalC (Suc (Suc b)) n'" "n' \<in> hbase (Suc (Suc b))"
     by (intro that[of _ "C [n']"])
       (auto intro!: intro: hbase.intros(1) dest!: hbaseI2[of 1 "b+2" n' "[]", simplified])
   then show ?case
   proof (induct rule: inc_induct)
     case (step m)
-    guess n' using step(3)[OF step(4,5)] by (rule bexE)
+    obtain n' where "n' \<in> hbase (Suc (Suc b))" "evalC (Suc (Suc b)) n' = Suc m"
+      using step(3)[OF step(4,5)] by blast
     then show ?case using stepC_dec[of n' "b"]
       by (cases n' rule: C2O.cases) (auto intro: stepC_sound hbase_ext.intros(1))
   qed blast
 qed
 
 subsection \<open>Monotonicity of @{const hbase}\<close>
 
 text \<open>Here we show that every hereditary base @{term "b :: nat"} number is also a valid hereditary
   base @{term "b+1 :: nat"} number. This is not immediate because we have to show that monotonicity
   of siblings is preserved.\<close>
 
 lemma hbase_evalC_mono:
   assumes "n \<in> hbase b" "m \<in> hbase b" "evalC b n < evalC b m"
   shows "evalC (Suc b) n < evalC (Suc b) m"
 proof (cases "b < 2")
   case True show ?thesis using assms(2,3) True by (cases rule: hbase.cases) simp_all
 next
   case False
   then obtain b' where [simp]: "b = Suc (Suc b')"
     by (auto simp: numeral_2_eq_2 not_less_eq dest: less_imp_Suc_add)
   show ?thesis using assms(3,1,2)
   proof (induct "evalC b n" "evalC b m" arbitrary: n m rule: less_Suc_induct)
     case 1 then show ?case using stepC_sound[of m b', OF hbase_ext.intros(1)]
       stepC_dec[of m b'] stepC_dec'[of m b'] evalC_inj_on_hbase
       by (cases m rule: C2O.cases) (fastforce simp: eval_nat_numeral)+
   next
     case (2 j) then show ?case
       using evalC_surjective[of b' j] less_trans by fastforce
   qed
 qed
 
 lemma hbase_mono:
   "n \<in> hbase b \<Longrightarrow> n \<in> hbase (Suc b)"
   by (induct n rule: hbase.induct) (auto 0 3 intro: hbase.intros hbase_evalC_mono)
 
 subsection \<open>Conversion to and from @{type nat}\<close>
 
 text \<open>We have previously defined @{term "H2N b = evalC b"} and @{term "N2H b"} as its inverse.
   So we can use the injectivity and surjectivity of @{term "evalC b"} for simplification.\<close>
 
 lemma N2H_inv:
   "n \<in> hbase b \<Longrightarrow> N2H b (H2N b n) = n"
   using evalC_inj_on_hbase
   by (auto simp: N2H_def H2N_def[abs_def] inj_on_def intro!: inv_into_f_f)
 
 lemma H2N_inv:
   "H2N (Suc (Suc b)) (N2H (Suc (Suc b)) n) = n"
   using evalC_surjective[of "b" n]
   by (auto simp: N2H_def H2N_def[abs_def] intro: f_inv_into_f)
 
 lemma N2H_eqI:
   "n \<in> hbase (Suc (Suc b)) \<Longrightarrow>
    H2N (Suc (Suc b)) n = m \<Longrightarrow> N2H (Suc (Suc b)) m = n"
   using N2H_inv by blast
 
 lemma N2H_neI:
   "n \<in> hbase (Suc (Suc b)) \<Longrightarrow>
    H2N (Suc (Suc b)) n \<noteq> m \<Longrightarrow> N2H (Suc (Suc b)) m \<noteq> n"
   using H2N_inv by blast
 
 lemma N2H_0 [simp]:
   "N2H (Suc (Suc c)) 0 = C []"
   using H2N_def N2H_inv hbase.intros(1) by fastforce
 
 lemma N2H_nz [simp]:
   "0 < n \<Longrightarrow> N2H (Suc (Suc c)) n \<noteq> C []"
   by (metis N2H_0 H2N_inv neq0_conv)
 
 
 section \<open>The Goodstein function revisited\<close>
 
 text \<open>We are now ready to prove termination of the Goodstein function @{const goodstein} as well
   as its relation to @{const goodsteinC} and @{const goodsteinO}.\<close>
 
 lemma goodstein_aux:
   "goodsteinC (Suc c) (N2H (Suc (Suc c)) (Suc n)) =
     goodsteinC (c+2) (N2H (c+3) (H2N (c+3) (N2H (c+2) (n+1)) - 1))"
 proof -
   have [simp]: "n \<noteq> C [] \<Longrightarrow> goodsteinC c n = goodsteinC (c+1) (stepC c n)" for c n
     by (induct c n rule: stepC.induct) simp_all
   have [simp]: "stepC (Suc c) (N2H (Suc (Suc c)) (Suc n)) \<in> hbase (Suc (Suc (Suc c)))"
     by (metis H2N_def N2H_inv evalC_surjective hbase_ext.intros(1) hbase_mono stepC_sound)
   show ?thesis
     using arg_cong[OF stepC_dec[of "N2H (c+2) (n+1)" "c+1", folded H2N_def], of "\<lambda>n. N2H (c+3) (n-1)"]
     by (simp add: eval_nat_numeral N2H_inv)
 qed
 
 termination goodstein
 proof (relation "measure (\<lambda>(c, n). goodsteinC c (N2H (c+1) n) - c)", goal_cases _ 1)
   case (1 c n)
   have *: "goodsteinC c n \<ge> c" for c n
     by (induct c n rule: goodsteinC.induct) simp_all
   show ?case by (simp add: goodstein_aux eval_nat_numeral) (meson Suc_le_eq diff_less_mono2 lessI *)
 qed simp
 
 lemma goodstein_def':
   "c \<noteq> 0 \<Longrightarrow> goodstein c n = goodsteinC c (N2H (c+1) n)"
   by (induct c n rule: goodstein.induct) (simp_all add: goodstein_aux eval_nat_numeral)
 
 lemma goodstein_impl:
   "c \<noteq> 0 \<Longrightarrow> goodstein c n = goodsteinO c (C2O (N2H (c+1) n))"
   \<comment> \<open>but note that @{term N2H} is not executable as currently defined\<close>
   using goodstein_def'[unfolded goodsteinC_def'] .
 
 lemma goodstein_16:
   "\<G> 16 = goodsteinO 1 (exp\<omega> (exp\<omega> (exp\<omega> (exp\<omega> Z))))"
 proof -
   have "N2H (Suc (Suc 0)) 16 = C [C [C [C [C []]]]]"
     by (auto simp: H2N_def intro!: N2H_eqI hbase_singletonI hbase.intros(1))
   then show ?thesis by (simp add: goodstein_impl)
 qed
 
 
 section \<open>Translation to $\lambda$-calculus\<close>
 
 text \<open>We define Church encodings for @{type nat} and @{type Ord}. Note that we are basically in a
   Hindley-Milner type system, so we cannot use a proper polymorphic type. We can still express
   Church encodings as folds over values of the original type.\<close>
 
 abbreviation Z\<^sub>N where "Z\<^sub>N \<equiv> (\<lambda>s z. z)"
 abbreviation S\<^sub>N where "S\<^sub>N \<equiv> (\<lambda>n s z. s (n s z))"
 
 primrec fold_nat ("\<langle>_\<rangle>\<^sub>N") where
   "\<langle>0\<rangle>\<^sub>N = Z\<^sub>N"
 | "\<langle>Suc n\<rangle>\<^sub>N = S\<^sub>N \<langle>n\<rangle>\<^sub>N"
 
 lemma one\<^sub>N:
   "\<langle>1\<rangle>\<^sub>N = (\<lambda>x. x)"
   by simp
 
 abbreviation Z\<^sub>O where "Z\<^sub>O \<equiv> (\<lambda>z s l. z)"
 abbreviation S\<^sub>O where "S\<^sub>O \<equiv> (\<lambda>n z s l. s (n z s l))"
 abbreviation L\<^sub>O where "L\<^sub>O \<equiv> (\<lambda>f z s l. l (\<lambda>i. f i z s l))"
 
 primrec fold_Ord ("\<langle>_\<rangle>\<^sub>O") where
   "\<langle>Z\<rangle>\<^sub>O = Z\<^sub>O"
 | "\<langle>S n\<rangle>\<^sub>O = S\<^sub>O \<langle>n\<rangle>\<^sub>O"
 | "\<langle>L f\<rangle>\<^sub>O = L\<^sub>O (\<lambda>i. \<langle>f i\<rangle>\<^sub>O)"
 
 text \<open>The following abbreviations and lemmas show how to implement the arithmetic functions and
   the Goodstein function on a Church-encoded @{type Ord} in lambda calculus.\<close>
 
 abbreviation (input) add\<^sub>O where
   "add\<^sub>O n m \<equiv> (\<lambda>z s l. m (n z s l) s l)"
 
 lemma add\<^sub>O:
   "\<langle>addO n m\<rangle>\<^sub>O = add\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
   by (induct m) simp_all
 
 abbreviation (input) mul\<^sub>O where
   "mul\<^sub>O n m \<equiv> (\<lambda>z s l. m z (\<lambda>m. n m s l) l)"
 
 lemma mul\<^sub>O:
   "\<langle>mulO n m\<rangle>\<^sub>O = mul\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
   by (induct m) (simp_all add: add\<^sub>O)
 
 abbreviation (input) \<omega>\<^sub>O where
   "\<omega>\<^sub>O \<equiv> (\<lambda>z s l. l (\<lambda>n. \<langle>n\<rangle>\<^sub>N s z))"
 
 lemma \<omega>\<^sub>O:
   "\<langle>\<omega>\<rangle>\<^sub>O = \<omega>\<^sub>O"
 proof -
   have [simp]: "\<langle>(S ^^ i) Z\<rangle>\<^sub>O z s l = \<langle>i\<rangle>\<^sub>N s z" for i z s l by (induct i) simp_all
   show ?thesis by (simp add: \<omega>_def)
 qed
 
 abbreviation (input) exp\<omega>\<^sub>O where
   "exp\<omega>\<^sub>O n \<equiv> (\<lambda>z s l. n s (\<lambda>x z. l (\<lambda>n. \<langle>n\<rangle>\<^sub>N x z)) (\<lambda>f z. l (\<lambda>n. f n z)) z)"
 
 lemma exp\<omega>\<^sub>O:
   "\<langle>exp\<omega> n\<rangle>\<^sub>O = exp\<omega>\<^sub>O \<langle>n\<rangle>\<^sub>O"
   by (induct n) (simp_all add: mul\<^sub>O \<omega>\<^sub>O)
 
 abbreviation (input) goodstein\<^sub>O where
   "goodstein\<^sub>O \<equiv> (\<lambda>c n. n (\<lambda>x. x) (\<lambda>n m. n (m + 1)) (\<lambda>f m. f (m + 2) m) c)"
 
 lemma goodstein\<^sub>O:
   "goodsteinO c n = goodstein\<^sub>O c \<langle>n\<rangle>\<^sub>O"
   by (induct n arbitrary: c) simp_all
 
 text \<open>Note that modeling Church encodings with folds is still limited. For example, the meaningful
   expression @{text "\<langle>n\<rangle>\<^sub>N exp\<omega>\<^sub>O Z\<^sub>O"} cannot be typed in Isabelle/HOL, as that would require rank-2
   polymorphism.\<close>
 
 subsection \<open>Alternative: free theorems\<close>
 
 text \<open>The following is essentially the free theorem for Church-encoded @{type Ord} values.\<close>
 
 lemma freeOrd:
   assumes "\<And>n. h (s n) = s' (h n)" and "\<And>f. h (l f) = l' (\<lambda>i. h (f i))"
   shows "h (\<langle>n\<rangle>\<^sub>O z s l) = \<langle>n\<rangle>\<^sub>O (h z) s' l'"
   by (induct n) (simp_all add: assms)
 
 text \<open>Each of the following proofs first states a naive definition of the corresponding function
   (which is proved correct by induction), from which we then derive the optimized version using
   the free theorem, by (conditional) rewriting (without induction).\<close>
 
 lemma add\<^sub>O':
   "\<langle>addO n m\<rangle>\<^sub>O = add\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
 proof -
   have [simp]: "\<langle>addO n m\<rangle>\<^sub>O = \<langle>m\<rangle>\<^sub>O \<langle>n\<rangle>\<^sub>O S\<^sub>O L\<^sub>O"
     by (induct m) simp_all
   show ?thesis
     by (intro ext) (simp add: freeOrd[where h = "\<lambda>n. n _ _ _"])
 qed
 
 lemma mul\<^sub>O':
   "\<langle>mulO n m\<rangle>\<^sub>O = mul\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
 proof -
   have [simp]: "\<langle>mulO n m\<rangle>\<^sub>O = \<langle>m\<rangle>\<^sub>O Z\<^sub>O (\<lambda>m. add\<^sub>O m \<langle>n\<rangle>\<^sub>O) L\<^sub>O"
     by (induct m) (simp_all add: add\<^sub>O)
   show ?thesis
     by (intro ext) (simp add: freeOrd[where h = "\<lambda>n. n _ _ _"])
 qed
 
 lemma exp\<omega>\<^sub>O':
   "\<langle>exp\<omega> n\<rangle>\<^sub>O = exp\<omega>\<^sub>O \<langle>n\<rangle>\<^sub>O"
 proof -
   have [simp]: "\<langle>exp\<omega> n\<rangle>\<^sub>O = \<langle>n\<rangle>\<^sub>O (S\<^sub>O Z\<^sub>O) (\<lambda>m. mul\<^sub>O m \<omega>\<^sub>O) L\<^sub>O"
     by (induct n) (simp_all add: mul\<^sub>O \<omega>\<^sub>O)
   show ?thesis
     by (intro ext) (simp add: fun_cong[OF freeOrd[where h = "\<lambda>n z. n z _ _"]])
 qed
 
 end
\ No newline at end of file
diff --git a/thys/Hoare_Time/SepLogK_VCG.thy b/thys/Hoare_Time/SepLogK_VCG.thy
--- a/thys/Hoare_Time/SepLogK_VCG.thy
+++ b/thys/Hoare_Time/SepLogK_VCG.thy
@@ -1,403 +1,407 @@
 theory SepLogK_VCG 
 imports SepLogK_Hoare
 begin
   
 lemmas conseqS = conseq[where k=1, simplified]
 
 datatype acom =
   Askip                  ("SKIP") |
   Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
   Aseq   acom acom       ("_;;/ _"  [60, 61] 60) | 
   Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
   Awhile assn2 bexp acom  ("({_}/ WHILE _/ DO _)"  [0, 0, 61] 61) 
     
 notation com.SKIP ("SKIP")
   
 fun strip :: "acom \<Rightarrow> com" where
 "strip SKIP = SKIP" |
 "strip (x ::= a) = (x ::= a)" |
 "strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
 "strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
 "strip ({_} WHILE b DO C) = (WHILE b DO strip C)"  
 
 
 fun pre :: "acom \<Rightarrow> assn2 \<Rightarrow> assn2" where
 "pre SKIP Q = ($1 ** Q)" |
 "pre (x ::= a) Q = ((\<lambda>(ps,t). x\<in>dom ps \<and> vars a \<subseteq> dom ps \<and> Q (ps(x\<mapsto>(paval a ps)),t) ) ** $1)" |
 "pre (C\<^sub>1;; C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
 "pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (
    $1 **  (\<lambda>(ps,n). vars b \<subseteq> dom ps \<and> (if pbval b ps then pre C\<^sub>1 Q (ps,n)  else pre C\<^sub>2 Q (ps,n) )))" |
 "pre ({I} WHILE b DO C) Q = (I ** $1)"  
   
   
 fun vc :: "acom \<Rightarrow> assn2 \<Rightarrow> bool" where
 "vc SKIP Q = True" |
 "vc (x ::= a) Q = True" |
 "vc (C\<^sub>1 ;; C\<^sub>2) Q = ((vc C\<^sub>1 (pre C\<^sub>2 Q)) \<and> (vc C\<^sub>2 Q) )" |
 "vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |  
 "vc ({I} WHILE b DO C) Q =  ( (\<forall>s. (I s \<longrightarrow> vars b \<subseteq> dom (fst s) ) \<and> ((\<lambda>(s,n). I (s,n) \<and> lmaps_to_axpr b True s) s \<longrightarrow> pre C (I ** $ 1) s)
          \<and> ( (\<lambda>(s,n). I (s,n) \<and> lmaps_to_axpr b False s) s \<longrightarrow> Q s)) \<and> vc C (I  ** $ 1))" 
 
  
 lemma dollar0_left: "($ 0 \<and>* Q) = Q"  
  apply rule unfolding dollar_def sep_conj_def  
   by force
   
 lemma vc_sound: "vc C Q \<Longrightarrow>  \<turnstile>\<^sub>3\<^sub>' {pre C Q} strip C { Q }"
 proof (induct C arbitrary: Q)
   case Askip
   then show ?case
     apply simp
     apply(rule conseqS[OF Frame[OF Skip]])
         by (auto simp: dollar0_left)  
 next
   case (Aassign x1 x2)
   then show ?case 
     apply simp
     apply(rule conseqS)
       apply(rule Assign4)
       apply auto done
 next
   case (Aseq C1 C2)
   then show ?case   apply (auto intro: Seq)  done
 next
   case (Aif b C1 C2)
   then have Aif1: "\<turnstile>\<^sub>3\<^sub>' {pre C1 Q} strip C1 {Q}"
         and Aif2: "\<turnstile>\<^sub>3\<^sub>' {pre C2 Q} strip C2 {Q}"  by auto
   show ?case apply simp
     apply (rule conseqS) 
       apply(rule If[where P="%(ps,n).  (if pbval b ps then pre C1 Q (ps,n) else pre C2 Q (ps,n))" and Q="Q"])
     subgoal apply simp
       apply (rule conseqS) apply(fact Aif1) by auto 
     subgoal apply simp
       apply (rule conseqS) apply(fact Aif2) by auto 
      apply (auto simp: sep_conj_ac) 
     unfolding sep_conj_def by blast 
 next
   case (Awhile I b C)
   then have
        dom : "\<And>s. (I s \<longrightarrow> vars b \<subseteq> dom (fst s) )"
       and i: "\<And>s.  (\<lambda>(s,n). I (s,n) \<and> lmaps_to_axpr b True s) s \<longrightarrow> pre C (I ** $ 1) s"
       and ii: "\<And>s.  (\<lambda>(s,n). I (s,n) \<and> lmaps_to_axpr b False s) s \<longrightarrow> Q s"
       and C: "\<turnstile>\<^sub>3\<^sub>' {pre C (I ** $ 1)} strip C {I ** $ 1}"
      by fastforce+
     
   show ?case
     apply simp 
     apply(rule conseqS)
        apply(rule While[where P=I])
        apply(rule conseqS)
         apply(rule C)
     subgoal using i by auto
     subgoal apply simp using dom unfolding sep_conj_def by force
     subgoal apply simp using dom unfolding sep_conj_def by force
     subgoal using ii apply auto done
     done
 qed  
   
 lemma vc2valid: "vc C Q \<Longrightarrow> \<forall>s. P s \<longrightarrow> pre C Q s \<Longrightarrow> \<Turnstile>\<^sub>3\<^sub>' {P} strip C { Q}"
   using hoareT_sound2_part weakenpre vc_sound by metis
 
 lemma pre_mono: assumes "\<forall>s. P s \<longrightarrow> Q s" shows "\<And>s. pre C P s \<Longrightarrow> pre C Q s"   
 using assms proof(induct C arbitrary: P Q)
   case Askip
   then show ?case  apply (auto simp: sep_conj_def dollar_def)
     by force
 next
   case (Aassign x1 x2)
   then show ?case by (auto simp: sep_conj_def dollar_def)
 next
   case (Aseq C1 C2)
   then show ?case by auto
 next
   case (Aif b C1 C2)
   then show ?case apply (auto simp: sep_conj_def dollar_def) 
     subgoal for ps n
       apply(rule exI[where x=0]) 
       apply(rule exI[where x=1])
       apply(rule exI[where x=ps]) by auto
     done
 next
   case (Awhile x1 x2 C)
   then show ?case by auto
 qed
   
 lemma vc_mono: assumes "\<forall>s. P s \<longrightarrow> Q s" shows "vc C P \<Longrightarrow> vc C Q"        
 using assms proof(induct C arbitrary: P Q)
   case Askip
   then show ?case by auto
 next
   case (Aassign x1 x2)
   then show ?case  by auto
 next
   case (Aseq C1 C2 P Q)
   then have i: "vc C1 (pre C2 P)" and ii: "vc C2 P" by auto
   from  pre_mono[OF ] Aseq(4) have iii: "\<forall>s. pre C2 P s \<longrightarrow> pre C2 Q s" by blast
   show ?case  apply auto
       using Aseq(1)[OF i  iii] Aseq(2)[OF ii Aseq(4)] by auto
 next
   case (Aif x1 C1 C2)
   then show ?case  by auto
 next
   case (Awhile I b C P Q)
   then show ?case by auto
 qed
 
 
 lemma vc_sound': "vc C Q \<Longrightarrow> (\<And>s n. P' (s, n) \<Longrightarrow> pre C Q (s, k * n)) \<Longrightarrow> (\<And>s n. Q (s, n) \<Longrightarrow> Q' (s, n div k)) \<Longrightarrow> 0 < k \<Longrightarrow> \<turnstile>\<^sub>3\<^sub>' {P'} strip C { Q'}"
   using conseq vc_mono vc_sound by metis
 
 
   
   
         
 lemma pre_Frame: "(\<forall>s. P s \<longrightarrow> pre C Q s) \<Longrightarrow> vc C Q
      \<Longrightarrow> (\<exists>C'. strip C = strip C' \<and>  vc C' (Q ** F) \<and> (\<forall>s. (P ** F) s \<longrightarrow> pre C' (Q ** F) s) )"  
 proof (induct C arbitrary: P Q)
   case Askip
   show ?case 
   proof (rule exI[where x="Askip"], safe)
     fix a b
     assume "(P \<and>* F) (a, b)"
     then obtain ps1 ps2 n1 n2 where A: "ps1##ps2" "a=ps1+ps2" "b=n1+n2"
       and P: "P (ps1,n1)" and F: "F (ps2,n2)" unfolding sep_conj_def by auto
     from P Askip have p: "($ (Suc 0) \<and>* Q) (ps1, n1)" by auto
     
     from p A F
     have "(($ (Suc 0) \<and>* Q) \<and>* F) (a, b)"
       apply(subst (2) sep_conj_def) by auto
     then show "pre SKIP (Q \<and>* F) (a, b)" by (simp add: sep_conj_ac)
   qed simp
 next
   case (Aassign x a)
   show ?case 
   proof (rule exI[where x="Aassign x a"], safe)
     fix ps n
     assume "(P \<and>* F) (ps,n)"
     then obtain ps1 ps2 n1 n2 where o: "ps1##ps2" "ps=ps1+ps2" "n=n1+n2"
       and P: "P (ps1,n1)" and F: "F (ps2,n2)" unfolding sep_conj_def by auto
     from P Aassign(1) have z: "((\<lambda>(ps, t). x \<in> dom ps \<and> vars a \<subseteq> dom ps \<and> Q (ps(x \<mapsto> paval a ps), t))
                                      \<and>* $ (Suc 0)) (ps1, n1)" 
         by auto    
     with o F show " pre (x ::= a) (Q \<and>* F) (ps,n)" apply auto
       unfolding sep_conj_def dollar_def apply (auto)
         subgoal by(simp add: plus_fun_def)  
         subgoal by(auto simp add: plus_fun_def)  
         subgoal
           by (smt add_update_distrib dom_fun_upd domain_conv insert_dom option.simps(3) paval_extend sep_disj_fun_def)
         done
   qed auto
 next
   case (Aseq C1 C2) 
   from Aseq(3) have pre: "\<forall>s. P s \<longrightarrow> pre C1 (pre C2 Q) s" by auto
   from Aseq(4) have vc1: "vc C1 (pre C2 Q)" and vc2: "vc C2 Q" by auto
   from Aseq(1)[OF pre vc1] obtain C1' where S1: "strip C1 = strip C1'"
       and vc1': "vc C1' (pre C2 Q \<and>* F)"
       and I1: "(\<forall>s. (P \<and>* F) s \<longrightarrow> pre C1' (pre C2 Q \<and>* F) s)" by blast
   from Aseq(2)[of "pre C2 Q" Q, OF _ vc2] obtain C2' where S2: "strip C2 = strip C2'"
       and vc2': "vc C2' (Q \<and>* F)"
       and I2: "(\<forall>s. (pre C2 Q \<and>* F) s \<longrightarrow> pre C2' (Q \<and>* F) s) " by blast
    
   show ?case apply(rule exI[where x="Aseq C1' C2'"])    
     apply safe
     subgoal using S1 S2 by auto
     subgoal apply simp apply safe
       subgoal using vc_mono[OF I2 vc1'] .
       subgoal by (fact vc2')
     done
     subgoal using I1 I2 pre_mono
       by force 
     done
 next
   case (Aif b C1 C2)
   from Aif(3) have i: "\<forall>s. P s \<longrightarrow>
           ($ (Suc 0) \<and>*
            (\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then pre C1 Q (ps, n) else pre C2 Q (ps, n))))
            s" by simp  
   from Aif(4) have vc1: "vc C1 Q" and vc2: "vc C2 Q" by auto 
   from Aif(1)[where P="pre C1 Q" and Q="Q", OF _ vc1] obtain C1' where
     s1: "strip C1 = strip C1'" and v1: "vc C1' (Q \<and>* F)"
     and p1: "(\<forall>s. (pre C1 Q \<and>* F) s \<longrightarrow> pre C1' (Q \<and>* F) s)"
     by auto
   from Aif(2)[where P="pre C2 Q" and Q="Q", OF _ vc2] obtain C2' where
     s2: "strip C2 = strip C2'" and v2: "vc C2' (Q \<and>* F)" 
     and p2: "(\<forall>s. (pre C2 Q \<and>* F) s \<longrightarrow> pre C2' (Q \<and>* F) s)"
     by auto
     
   show ?case apply(rule exI[where x="Aif b C1' C2'"])
   proof safe
     fix ps n
     assume "(P \<and>* F) (ps, n)"
     then obtain ps1 ps2 n1 n2 where o: "ps1##ps2" "ps=ps1+ps2" "n=n1+n2"
       and P: "P (ps1,n1)" and F: "F (ps2,n2)" unfolding sep_conj_def by auto
     from P i have P': "($ (Suc 0) \<and>*
          (\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then pre C1 Q (ps, n) else pre C2 Q (ps, n))))
          (ps1,n1)" by auto
     have PF: "(($ (Suc 0) \<and>*
          (\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then pre C1 Q (ps, n) else pre C2 Q (ps, n)))) ** F)
          (ps,n)" apply(subst (2) sep_conj_def)
         apply(rule exI[where x="(ps1,n1)"])
         apply(rule exI[where x="(ps2,n2)"])
       using F P' o by auto 
     from this[simplified sep_conj_assoc] obtain ps1 ps2 n1 n2 where o: "ps1##ps2" "ps=ps1+ps2" "n=n1+n2"
       and P: "($ (Suc 0)) (ps1,n1)" and F: "((\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then pre C1 Q (ps, n) else pre C2 Q (ps, n))) \<and>* F) (ps2,n2)"
       unfolding sep_conj_def apply auto by fast
     then have "((\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then (pre C1 Q  \<and>* F) (ps, n) else (pre C2 Q  \<and>* F) (ps, n)))) (ps2,n2)"    
       unfolding sep_conj_def apply auto
       apply (metis contra_subsetD domD map_add_dom_app_simps(1) plus_fun_conv sep_add_commute)
       using pbval_extend apply auto[1]                                                     
       apply (metis contra_subsetD domD map_add_dom_app_simps(1) plus_fun_conv sep_add_commute) 
       using pbval_extend apply auto[1]    done
     then have "((\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then (pre C1' (Q \<and>* F)) (ps, n) else (pre C2' (Q \<and>* F)) (ps, n)))) (ps2,n2)" 
       using p1 p2  by auto
     with o P 
     show "pre (IF b THEN C1' ELSE C2') (Q \<and>* F) (ps, n)"
       apply auto apply(subst sep_conj_def) by force
   qed (auto simp: s1 s2 v1 v2)
 next
   case (Awhile I b C)
   from Awhile(2) have pre: "\<forall>s. P s \<longrightarrow>  (I ** $1) s"  by auto
   from Awhile(3) have 
     dom:  "\<forall>ps n. I (ps, n) \<longrightarrow> vars b \<subseteq> dom ps" 
   and  tB: "\<forall>s. I s \<and> vars b \<subseteq> dom (fst s) \<and> pbval b (fst s) \<longrightarrow> pre C (I \<and>* $ (Suc 0)) s"
   and  fB: "\<forall>ps n. I (ps, n) \<and> vars b \<subseteq> dom ps \<and> \<not> pbval b ps \<longrightarrow> Q (ps, n)"
   and vcB: "vc C (I \<and>* $(Suc 0))" by auto
   from Awhile(1)[OF tB vcB] obtain C' where st: "strip C = strip C'"
     and vc': "vc C' ((I \<and>* $ (Suc 0)) \<and>* F)"
     and pre': "(\<forall>s. ((\<lambda>a. I a \<and> vars b \<subseteq> dom (fst a) \<and> pbval b (fst a)) \<and>* F) s \<longrightarrow>
             pre C' ((I \<and>* $ (Suc 0)) \<and>* F) s)"
     by auto
   show ?case apply(rule exI[where x="Awhile (I**F) b C'"])
     apply safe
     subgoal using st by simp 
     subgoal apply simp apply safe
         subgoal using dom unfolding sep_conj_def apply auto
           by (metis domD sep_substate_disj_add subState subsetCE) 
         subgoal  using pre' apply(auto simp: sep_conj_ac) 
             apply(subst (asm)  sep_conj_def)
             apply(subst (asm)  sep_conj_def) apply auto
           by (metis dom pbval_extend sep_add_commute sep_disj_commuteI)
         subgoal using fB unfolding sep_conj_def apply auto
           using dom pbval_extend by fastforce
         subgoal using vc' apply(auto simp: sep_conj_ac) done
         done
       subgoal apply simp using pre unfolding sep_conj_def apply auto
         by (smt semiring_normalization_rules(23) sep_add_assoc sep_add_commute sep_add_disjD sep_add_disjI1)
       done
 qed
 
   
   
         
         
         
 lemma vc_complete: "\<turnstile>\<^sub>3\<^sub>a {P} c { Q } \<Longrightarrow> (\<exists>C. vc C Q \<and> (\<forall>s. P s \<longrightarrow> pre C Q s) \<and> strip C = c)"
 proof(induct   rule: hoare3a.induct)
   case Skip
   then show ?case apply(rule exI[where x="Askip"]) by auto
 next
   case (Assign4 x a Q)
   then show ?case apply(rule exI[where x="Aassign x a"]) by auto
 next
   case (If P b c\<^sub>1 Q c\<^sub>2)
   from If(2) obtain C1 where A1: "vc C1 Q" "strip C1 = c\<^sub>1" and 
     A2: "\<And>ps n. (P (ps, n) \<and> lmaps_to_axpr b True ps) \<longrightarrow> pre C1 Q (ps,n)"
     by blast
   from If(4) obtain C2 where B1: "vc C2 Q" "strip C2 = c\<^sub>2" and B2:
     "\<And>ps n. (P (ps, n) \<and> lmaps_to_axpr b False ps) \<longrightarrow> pre C2 Q (ps,n)"
     by blast
       
   show ?case apply(rule exI[where x="Aif b C1 C2"]) using A1 B1 apply auto
     subgoal for ps n
       unfolding sep_conj_def dollar_def apply auto
       apply(rule exI[where x="0"])
       apply(rule exI[where x="1"])
       apply(rule exI[where x="ps"])
       using A2 B2 by auto
   done
 next
   case (Frame P C Q F) 
   then obtain C' where vc: "vc C' Q" and pre: "(\<forall>s. P s \<longrightarrow> pre C' Q s)"
       and strip: "strip C' = C" by auto 
   show ?case using pre_Frame[OF pre vc] strip by metis
 next
   case (Seq P c\<^sub>1 Q c\<^sub>2 R)
   from Seq(2) obtain C1 where A1: "vc C1 Q" "strip C1 = c\<^sub>1" and 
     A2: "\<And>s. P s \<longrightarrow> pre C1 Q s"
     by blast
   from Seq(4) obtain C2 where B1: "vc C2 R" "strip C2 = c\<^sub>2" and 
     B2: "\<And>s. Q s \<longrightarrow> pre C2 R s"
     by blast
   show ?case apply(rule exI[where x="Aseq C1 C2"])
     using B1 A1 apply auto
     subgoal using vc_mono B2 by auto
     subgoal apply(rule pre_mono[where P=Q])  using  B2 apply auto
       using A2 by auto
     done
 next
   case (While I b c)
   then obtain C where 1: "vc C ((\<lambda>(s, n). I (s, n) \<and> vars b \<subseteq> dom s) \<and>* $ 1)"
           "strip C = c" and 2:
          "\<And>ps n. (I (ps, n) \<and> lmaps_to_axpr b True ps) \<longrightarrow>
               pre C ((\<lambda>(s, n). I (s, n) \<and> vars b \<subseteq> dom s) \<and>* $ 1) (ps,n) " by blast
     
   show ?case apply(rule exI[where x="Awhile (\<lambda>(s, n). I (s, n) \<and> vars b \<subseteq> dom s) b C"])
     using 1 2 by auto 
 next
   case (conseqS P c Q P' Q')
   then obtain C' where C': "vc C' Q" "(\<forall>s. P s \<longrightarrow> pre C' Q s)" "strip C' = c"
     by blast
   show ?case apply(rule exI[where x=C'])
       using C' conseqS(3,4) pre_mono vc_mono by force
 qed 
            
    
   
   
 theorem vc_completeness:
   assumes "\<Turnstile>\<^sub>3\<^sub>' {P} c { Q}"
   shows "\<exists>C k. vc C (Q ** sep_true)
           \<and> (\<forall>ps n. P (ps, n) \<longrightarrow> pre C (\<lambda>(ps, n). (Q ** sep_true) (ps, n div k)) (ps, k * n))
           \<and> strip C = c"
 proof - 
   let ?QG = "\<lambda>k (ps,n). (Q ** sep_true) (ps,n div k)"
   from assms obtain k where k[simp]: "k>0" and p: "\<And>ps n. P (ps, n) \<Longrightarrow> wp\<^sub>3\<^sub>' c (\<lambda>(ps, n). (Q ** sep_true) (ps, n div k)) (ps, k * n)" 
     using valid_wp by blast 
       
   from wpT_is_pre  have R: "\<turnstile>\<^sub>3\<^sub>a {wp\<^sub>3\<^sub>' c (?QG k)} c {?QG k}" by auto
   
   have z: "(\<forall>s. (\<lambda>(ps, n). (Q \<and>* (\<lambda>s. True)) (ps, n div k)) s) \<Longrightarrow> (\<forall>s. (\<lambda>(ps, n). (Q \<and>* (\<lambda>s. True)) (ps, n)) s)"
     by (metis (no_types) case_prod_conv k neq0_conv nonzero_mult_div_cancel_left old.prod.exhaust)
   
      
   have z: "\<And>ps n. ((Q \<and>* (\<lambda>s. True)) (ps, n div k) \<Longrightarrow> (Q \<and>* (\<lambda>s. True)) (ps, n))"   
   proof -
     fix ps n
     assume "(Q \<and>* (\<lambda>s. True)) (ps, n div k) "
-    then guess ps1 n1 ps2 n2 unfolding sep_conj_def by auto
-    note o = this
+    then obtain ps1 n1 ps2 n2
+      where o: "ps1 ## ps2" "ps = ps1 + ps2" "Q (ps1, n1)" "n div k = n1 + n2"
+      unfolding sep_conj_def by auto
     from o(4) have nn1: "n\<ge>n1" using k
       by (metis (full_types) add_leE div_le_dividend) 
     show "(Q \<and>* (\<lambda>s. True)) (ps, n)" unfolding sep_conj_def
         apply(rule exI[where x="(ps1, n1)"])
       apply(rule exI[where x="(ps2, n - n1)"])
       using o nn1 by auto   
   qed
   then have z': "\<forall>s. ((Q \<and>* (\<lambda>s. True)) (fst s, (snd s) div k) \<longrightarrow> (Q \<and>* (\<lambda>s. True)) s)"
     by (metis prod.collapse)   
       
-  from vc_complete[OF R]   guess C by auto
-  note o = this
+  from vc_complete[OF R] obtain C
+    where o: "vc C (\<lambda>(ps, n). (Q \<and>* (\<lambda>s. True)) (ps, n div k))"
+      "\<forall>a b. wp\<^sub>3\<^sub>' (strip C) (\<lambda>(ps, n). (Q \<and>* (\<lambda>s. True)) (ps, n div k)) (a, b) \<longrightarrow>
+          pre C (\<lambda>(ps, n). (Q \<and>* (\<lambda>s. True)) (ps, n div k)) (a, b)"
+      "c = strip C" by auto
     
   have y: "\<And>ps n. P (ps, n) \<Longrightarrow>  pre C (\<lambda>(ps, n). (Q \<and>* (\<lambda>s. True)) (ps, n div k)) (ps, k * n)"
     using o p by metis 
     
   show ?thesis apply(rule exI[where x=C])  apply(rule exI[where x=k])
     apply safe
     subgoal apply(rule vc_mono[OF _ o(1)]) using z  by blast
     subgoal using y by blast
     subgoal using o by simp
     done
 qed
 
 end
\ No newline at end of file
diff --git a/thys/IFC_Tracking/IFC.thy b/thys/IFC_Tracking/IFC.thy
--- a/thys/IFC_Tracking/IFC.thy
+++ b/thys/IFC_Tracking/IFC.thy
@@ -1,4580 +1,4578 @@
 section \<open>Definitions\<close>
 
 text \<open>
 This section contains all necessary definitions of this development. Section~\ref{sec:pm} contains 
 the structural definition of our program model which includes the security specification as well 
 as abstractions of control flow and data.  Executions of our program model are defined in 
 section~\ref{sec:ex}.  Additional well-formedness properties are defined in section~\ref{sec:wf}. 
 Our security property is defined in section~\ref{sec:sec}.  Our characterisation of how information
 is propagated by executions of our program model is defined in section~\ref{sec:char-cp}, for which
 the correctness result can be found in section~\ref{sec:cor-cp}.  Section~\ref{sec:char-scp} contains
 an additional approximation of this characterisation whose correctness result can be found in 
 section~\ref{sec:cor-scp}.
 \<close>
 
 
 theory IFC
-imports Main
+  imports Main
 begin
 
 subsection \<open>Program Model\<close>
 text_raw \<open>\label{sec:pm}\<close>
 
 text \<open>Our program model contains all necessary components for the remaining development and consists of:\<close>
 
 record ('n, 'var, 'val, 'obs) ifc_problem =  
 \<comment> \<open>A set of nodes representing program locations:\<close>
   nodes :: \<open>'n set\<close>
 \<comment> \<open>An initial node where all executions start:\<close>
   entry :: \<open>'n\<close>
 \<comment> \<open>A final node where executions can terminate:\<close>
   return :: \<open>'n\<close>
 \<comment> \<open>An abstraction of control flow in the form of an edge relation:\<close>
   edges :: \<open>('n \<times> 'n) set\<close>
 \<comment> \<open>An abstraction of variables written at program locations:\<close>
   writes :: \<open>'n \<Rightarrow> 'var set\<close>
 \<comment> \<open>An abstraction of variables read at program locations:\<close>
   reads :: \<open>'n \<Rightarrow> 'var set\<close>
 \<comment> \<open>A set of variables containing the confidential information in the initial state:\<close>
   hvars :: \<open>'var set\<close>
 \<comment> \<open>A step function on location state pairs:\<close>
   step :: \<open>('n \<times> ('var \<Rightarrow> 'val)) \<Rightarrow> ('n \<times> ('var \<Rightarrow> 'val))\<close>
 \<comment> \<open>An attacker model producing observations based on the reached state at certain locations:\<close>
   att :: \<open>'n \<rightharpoonup> (('var \<Rightarrow> 'val) \<Rightarrow> 'obs)\<close>
 
 text \<open>We fix a program in the following in order to define the central concepts.  
 The necessary well-formedness assumptions will be made in section~\ref{sec:wf}.\<close>
 locale IFC_def =
 fixes prob :: \<open>('n, 'var, 'val, 'obs) ifc_problem\<close>
 begin  
 
 text \<open>Some short hands to the components of the program which we will utilise exclusively in the following.\<close>
 definition nodes where \<open>nodes = ifc_problem.nodes prob\<close>
 definition entry where \<open>entry = ifc_problem.entry prob\<close>
 definition return where \<open>return = ifc_problem.return prob\<close>
 definition edges where \<open>edges = ifc_problem.edges prob\<close>
 definition writes where \<open>writes = ifc_problem.writes prob\<close>
 definition reads where \<open>reads = ifc_problem.reads prob\<close>
 definition hvars where \<open>hvars = ifc_problem.hvars prob\<close>
 definition step where \<open>step = ifc_problem.step prob\<close>
 definition att where \<open>att = ifc_problem.att prob\<close>
 
 text \<open>The components of the step function for convenience.\<close>
 definition suc where \<open>suc n \<sigma> = fst (step (n, \<sigma>))\<close>
 definition sem where \<open>sem n \<sigma> = snd (step (n, \<sigma>))\<close>
 
 lemma step_suc_sem: \<open>step (n,\<sigma>) = (suc n \<sigma>, sem n \<sigma>)\<close> unfolding suc_def sem_def by auto
 
 
 subsubsection \<open>Executions\<close>
 text \<open>\label{sec:ex}\<close>
 text \<open>In order to define what it means for a program to be well-formed, we first require concepts 
 of executions and program paths.\<close>
 
 text \<open>The sequence of nodes visited by the execution corresponding to an input state.\<close>
 definition path where
 \<open>path \<sigma> k= fst ((step^^k) (entry,\<sigma>))\<close>
 
 text \<open>The sequence of states visited by the execution corresponding to an input state.\<close>
 definition kth_state ( \<open>_\<^bsup>_\<^esup>\<close> [111,111] 110) where 
 \<open>\<sigma>\<^bsup>k\<^esup> = snd ((step^^k) (entry,\<sigma>))\<close>
 
 text \<open>A predicate asserting that a sequence of nodes is a valid program path according to the
 control flow graph.\<close>
 
 definition is_path where
 \<open>is_path \<pi> = (\<forall> n. (\<pi> n, \<pi> (Suc n)) \<in> edges)\<close> 
 end
 
 subsubsection \<open>Well-formed Programs\<close>
 text_raw \<open>\label{sec:wf}\<close>
 
 text \<open>The following assumptions define our notion of valid programs.\<close>
 locale IFC = IFC_def \<open>prob\<close> for prob:: \<open>('n, 'var, 'val, 'out) ifc_problem\<close> +
 assumes ret_is_node[simp,intro]: \<open>return \<in> nodes\<close>
 and entry_is_node[simp,intro]: \<open>entry \<in> nodes\<close>
 and writes: \<open>\<And> v n. (\<exists>\<sigma>. \<sigma> v \<noteq> sem n \<sigma> v) \<Longrightarrow> v \<in> writes n\<close>
 and writes_return: \<open>writes return = {}\<close>
 and uses_writes: \<open>\<And> n \<sigma> \<sigma>'. (\<forall> v \<in> reads n. \<sigma> v = \<sigma>' v) \<Longrightarrow> \<forall> v \<in> writes n. sem n \<sigma> v = sem n \<sigma>' v\<close>
 and uses_suc: \<open>\<And> n \<sigma> \<sigma>'. (\<forall> v \<in> reads n. \<sigma> v = \<sigma>' v) \<Longrightarrow> suc n \<sigma> = suc n \<sigma>'\<close>
 and uses_att: \<open>\<And> n f \<sigma> \<sigma>'. att n = Some f \<Longrightarrow> (\<forall> v \<in> reads n. \<sigma> v = \<sigma>' v) \<Longrightarrow> f \<sigma> = f \<sigma>'\<close>
 and edges_complete[intro,simp]: \<open>\<And>m \<sigma>. m \<in> nodes \<Longrightarrow> (m,suc m \<sigma>) \<in> edges\<close>
 and edges_return : \<open>\<And>x. (return,x) \<in> edges \<Longrightarrow> x = return \<close>
 and edges_nodes: \<open>edges \<subseteq> nodes \<times> nodes\<close>    
 and reaching_ret: \<open>\<And> x. x \<in> nodes \<Longrightarrow> \<exists> \<pi> n. is_path \<pi> \<and> \<pi> 0 = x \<and> \<pi> n = return\<close>
 
 
 subsection \<open>Security\<close>
 text_raw \<open>\label{sec:sec}\<close>
 
 text \<open>We define our notion of security, which corresponds to what Bohannon et al.~\cite{Bohannon:2009:RN:1653662.1653673} 
 refer to as indistinguishable security.  In order to do so we require notions of observations made
 by the attacker, termination and equivalence of input states.\<close>
 
 context IFC_def
 begin
 
 subsubsection \<open>Observations\<close>
 text_raw \<open>\label{sec:obs}\<close>
 
 text \<open>The observation made at a given index within an execution.\<close>
 definition obsp where
 \<open>obsp \<sigma> k = (case att(path \<sigma> k) of Some f \<Rightarrow> Some (f (\<sigma>\<^bsup>k\<^esup>)) | None \<Rightarrow> None)\<close>
 
 text \<open>The indices within a path where an observation is made.\<close>
 definition obs_ids :: \<open>(nat \<Rightarrow> 'n) \<Rightarrow> nat set\<close> where
 \<open>obs_ids \<pi> = {k. att (\<pi> k) \<noteq> None}\<close>
 
 text \<open>A predicate relating an observable index to the number of observations made before.\<close>
 definition is_kth_obs :: \<open>(nat \<Rightarrow> 'n) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool\<close>where
 \<open>is_kth_obs \<pi> k i = (card (obs_ids \<pi> \<inter> {..<i}) = k \<and> att (\<pi> i) \<noteq>  None)\<close>
 
 text \<open>The final sequence of observations made for an execution.\<close>
 definition obs where
 \<open>obs \<sigma> k = (if (\<exists>i. is_kth_obs (path \<sigma>) k i) then obsp \<sigma> (THE i. is_kth_obs (path \<sigma>) k i) else None)\<close>
 
 text \<open>Comparability of observations.\<close>
 definition obs_prefix :: \<open>(nat \<Rightarrow> 'obs option) \<Rightarrow> (nat \<Rightarrow> 'obs option) \<Rightarrow> bool\<close> (infix \<open>\<lesssim>\<close> 50) where
 \<open>a \<lesssim> b \<equiv> \<forall> i. a i \<noteq> None \<longrightarrow> a i = b i\<close>
 
 definition obs_comp (infix \<open>\<approx>\<close> 50) where
 \<open>a \<approx> b \<equiv> a \<lesssim> b \<or> b \<lesssim> a\<close>
 
 subsubsection \<open>Low equivalence of input states\<close>
 
 definition restrict (infix \<open>\<restriction>\<close> 100 ) where
 \<open>f\<restriction>U = (\<lambda> n. if n \<in> U then f n else undefined)\<close>
 
 text \<open>Two input states are low equivalent if they coincide on the non high variables.\<close>
 definition loweq (infix \<open>=\<^sub>L\<close> 50) 
 where \<open>\<sigma> =\<^sub>L \<sigma>' = (\<sigma>\<restriction>(-hvars) = \<sigma>'\<restriction>(-hvars))\<close>
 
 subsubsection \<open>Termination\<close>
 
 text \<open>An execution terminates iff it reaches the terminal node at any point.\<close>
 definition terminates where
 \<open>terminates \<sigma> \<equiv> \<exists> i. path \<sigma> i = return\<close>
 
 
 subsubsection \<open>Security Property\<close>
 text \<open>The fixed program is secure if and only if for all pairs of low equivalent inputs the observation
 sequences are comparable and if the execution for an input state terminates then the observation sequence 
 is not missing any observations.\<close>
 
 definition secure where
 \<open>secure \<equiv> \<forall> \<sigma> \<sigma>'. \<sigma> =\<^sub>L \<sigma>' \<longrightarrow> (obs \<sigma> \<approx> obs \<sigma>' \<and> (terminates \<sigma> \<longrightarrow> obs \<sigma>' \<lesssim> obs \<sigma>))\<close>
 
 
 
 subsection \<open>Characterisation of Information Flows\<close>
 text \<open>We now define our characterisation of information flows which tracks data and control dependencies 
 within executions. To do so we first require some additional concepts.\<close>
 
 subsubsection \<open>Post Dominance\<close>
 text \<open>We utilise the post dominance relation in order to define control dependence.\<close>
 
 text \<open>The basic post dominance relation.\<close>
 definition is_pd (infix \<open>pd\<rightarrow>\<close> 50) where 
 \<open>y pd\<rightarrow> x \<longleftrightarrow> x \<in> nodes \<and> (\<forall> \<pi> n. is_path \<pi> \<and> \<pi> (0::nat) = x \<and> \<pi> n = return \<longrightarrow> (\<exists>k\<le>n. \<pi> k = y))\<close>
 
 text \<open>The immediate post dominance relation.\<close>
 definition is_ipd (infix \<open>ipd\<rightarrow>\<close> 50)where
 \<open>y ipd\<rightarrow> x \<longleftrightarrow> x \<noteq> y \<and> y pd\<rightarrow> x \<and> (\<forall> z. z\<noteq>x \<and> z pd\<rightarrow> x \<longrightarrow> z pd\<rightarrow> y)\<close>
 
 definition ipd where 
 \<open>ipd x = (THE y. y ipd\<rightarrow> x)\<close>
 
 text \<open>The post dominance tree.\<close>
 definition pdt where
 \<open>pdt = {(x,y). x\<noteq>y \<and> y pd\<rightarrow> x}\<close>
 
 
 subsubsection \<open>Control Dependence\<close>
 
 text \<open>An index on an execution path is control dependent upon another if the path does not visit
 the immediate post domiator of the node reached by the smaller index.\<close>
 definition is_cdi (\<open>_ cd\<^bsup>_\<^esup>\<rightarrow> _\<close> [51,51,51]50) where
 \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k \<longleftrightarrow> is_path \<pi> \<and> k < i \<and> \<pi> i \<noteq> return \<and> (\<forall> j \<in> {k..i}. \<pi> j \<noteq> ipd (\<pi> k))\<close> 
 
 text \<open>The largest control dependency of an index is the immediate control dependency.\<close>
 definition is_icdi (\<open>_ icd\<^bsup>_\<^esup>\<rightarrow> _\<close> [51,51,51]50) where
 \<open>n icd\<^bsup>\<pi>\<^esup>\<rightarrow> n' \<longleftrightarrow> is_path \<pi> \<and> n cd\<^bsup>\<pi>\<^esup>\<rightarrow> n' \<and> (\<forall> m \<in> {n'<..<n}.\<not> n cd\<^bsup>\<pi>\<^esup>\<rightarrow> m)\<close>
 
 text \<open>For the definition of the control slice, which we will define next, we require the uniqueness 
 of the immediate control dependency.\<close>
 
 lemma icd_uniq: assumes  \<open>m icd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close> \<open> m icd\<^bsup>\<pi>\<^esup>\<rightarrow> n'\<close> shows \<open>n = n'\<close>
 proof - 
   {
     fix n n' assume *: \<open>m icd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close> \<open> m icd\<^bsup>\<pi>\<^esup>\<rightarrow> n'\<close> \<open>n < n'\<close>
     have \<open>n'<m\<close> using * unfolding is_icdi_def is_cdi_def by auto    
     hence \<open>\<not> m cd\<^bsup>\<pi>\<^esup>\<rightarrow> n'\<close> using * unfolding is_icdi_def by auto
     with *(2) have \<open>False\<close> unfolding is_icdi_def by auto
   }
   thus ?thesis using assms by (metis linorder_neqE_nat)
 qed
 
 
 subsubsection \<open>Control Slice\<close>
 text \<open>We utilise the control slice, that is the sequence of nodes visited by the control dependencies 
 of an index, to match indices between executions.\<close>
 
 function cs:: \<open>(nat \<Rightarrow> 'n) \<Rightarrow> nat \<Rightarrow> 'n list\<close> (\<open>cs\<^bsup>_\<^esup> _\<close> [51,70] 71) where
 \<open>cs\<^bsup>\<pi>\<^esup> n = (if (\<exists> m. n icd\<^bsup>\<pi>\<^esup>\<rightarrow> m) then (cs \<pi> (THE m. n icd\<^bsup>\<pi>\<^esup>\<rightarrow> m))@[\<pi> n] else [\<pi> n])\<close> 
 by pat_completeness auto  
 termination \<open>cs\<close> proof
   show \<open>wf (measure snd)\<close> by simp
   fix \<pi> n  
   define m where \<open>m == (The (is_icdi n \<pi>))\<close>
   assume \<open>Ex (is_icdi n \<pi>)\<close> 
   hence \<open>n icd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> unfolding m_def by (metis (full_types) icd_uniq theI')
   hence \<open>m < n\<close> unfolding is_icdi_def is_cdi_def by simp
   thus \<open>((\<pi>, The (is_icdi n \<pi>)), \<pi>, n) \<in> measure snd\<close> by (metis in_measure m_def snd_conv)
 qed
 
 inductive cs_less (infix \<open>\<prec>\<close> 50) where
 \<open>length xs < length ys \<Longrightarrow> take (length xs) ys = xs  \<Longrightarrow> xs \<prec> ys\<close>     
 
 definition cs_select (infix \<open>\<exclamdown>\<close> 50) where
 \<open>\<pi>\<exclamdown>xs = (THE k. cs\<^bsup>\<pi>\<^esup> k = xs)\<close>
 
 
 subsubsection \<open>Data Dependence\<close>
 
 text \<open>Data dependence is defined straight forward. An index is data dependent upon another, 
 if the index reads a variable written by the earlier index and the variable in question has not 
 been written by any index in between.\<close>
 definition is_ddi (\<open>_ dd\<^bsup>_,_\<^esup>\<rightarrow> _\<close> [51,51,51,51] 50) where
 \<open>n dd\<^bsup>\<pi>,v\<^esup>\<rightarrow> m \<longleftrightarrow> is_path \<pi> \<and> m < n \<and> v \<in> reads (\<pi> n) \<inter> (writes (\<pi> m)) \<and> (\<forall> l \<in> {m<..<n}. v \<notin> writes (\<pi> l))\<close>
 
 
 
 subsubsection \<open>Characterisation via Critical Paths\<close>
 text_raw \<open>\label{sec:char-cp}\<close>
 text \<open>With the above we define the set of critical paths which as we will prove characterise the matching
 points in executions where diverging data is read.\<close>
 
 inductive_set cp where
 
 \<comment> \<open>Any pair of low equivalent input states and indices where a diverging high variable is first
 read is critical.\<close>
 
 \<open>\<lbrakk>\<sigma> =\<^sub>L \<sigma>'; 
   cs\<^bsup>path \<sigma>\<^esup> n = cs\<^bsup>path \<sigma>'\<^esup> n'; 
   h \<in> reads(path \<sigma> n); 
   (\<sigma>\<^bsup>n\<^esup>) h \<noteq> (\<sigma>'\<^bsup>n'\<^esup>) h; 
   \<forall> k<n. h\<notin>writes(path \<sigma> k); 
   \<forall> k'<n'. h\<notin>writes(path \<sigma>' k')
  \<rbrakk> \<Longrightarrow> ((\<sigma>,n),(\<sigma>',n')) \<in> cp\<close> |
 
 \<comment> \<open>If from a pair of critical indices in two executions there exist data dependencies from both
 indices to a pair of matching indices where the variable diverges, the later pair of indices is critical.\<close>
 
 \<open>\<lbrakk>((\<sigma>,k),(\<sigma>',k')) \<in> cp; 
   n dd\<^bsup>path \<sigma>,v\<^esup>\<rightarrow> k;
   n' dd\<^bsup>path \<sigma>',v\<^esup>\<rightarrow> k'; 
   cs\<^bsup>path \<sigma>\<^esup> n = cs\<^bsup>path \<sigma>'\<^esup> n'; 
   (\<sigma>\<^bsup>n\<^esup>) v \<noteq> (\<sigma>'\<^bsup>n'\<^esup>) v
  \<rbrakk> \<Longrightarrow> ((\<sigma>,n),(\<sigma>',n')) \<in> cp\<close> |
 
 \<comment> \<open>If from a pair of critical indices the executions take different branches and one of the critical 
 indices is a control dependency of an index that is data dependency of a matched index where diverging 
 data is read and the variable in question is not written by the other execution after the executions
 first reached matching indices again, then the later matching pair of indices is critical.\<close>
 
 \<open>\<lbrakk>((\<sigma>,k),(\<sigma>',k')) \<in> cp; 
   n dd\<^bsup>path \<sigma>,v\<^esup>\<rightarrow> l; 
   l cd\<^bsup>path \<sigma>\<^esup>\<rightarrow> k; 
   cs\<^bsup>path \<sigma>\<^esup> n = cs\<^bsup>path \<sigma>'\<^esup> n'; 
   path \<sigma> (Suc k) \<noteq> path \<sigma>' (Suc k'); 
   (\<sigma>\<^bsup>n\<^esup>) v \<noteq> (\<sigma>'\<^bsup>n'\<^esup>) v; 
   \<forall>j'\<in>{(LEAST i'. k' < i' \<and> (\<exists>i. cs\<^bsup>path \<sigma>\<^esup> i = cs\<^bsup>path \<sigma>'\<^esup> i'))..<n'}. v\<notin>writes (path \<sigma>' j')
  \<rbrakk> \<Longrightarrow> ((\<sigma>,n),(\<sigma>',n')) \<in> cp\<close> | 
 
 \<comment> \<open>The relation is symmetric.\<close>
 
 \<open>\<lbrakk>((\<sigma>,k),(\<sigma>',k')) \<in> cp\<rbrakk> \<Longrightarrow> ((\<sigma>',k'),(\<sigma>,k)) \<in> cp\<close>
 
 
 text \<open>Based on the set of critical paths, the critical observable paths are those that either directly 
 reach observable nodes or are diverging control dependencies of an observable index.\<close>
 
 inductive_set cop where
 \<open>\<lbrakk>((\<sigma>,n),(\<sigma>',n')) \<in> cp;
   path \<sigma> n \<in> dom att
  \<rbrakk> \<Longrightarrow> ((\<sigma>,n),(\<sigma>',n')) \<in> cop\<close> |
 
 \<open>\<lbrakk>((\<sigma>,k),(\<sigma>',k')) \<in> cp; 
   n cd\<^bsup>path \<sigma>\<^esup>\<rightarrow> k; 
   path \<sigma> (Suc k) \<noteq> path \<sigma>' (Suc k'); 
   path \<sigma> n \<in> dom att
  \<rbrakk> \<Longrightarrow> ((\<sigma>,n),(\<sigma>',k')) \<in> cop\<close>
 
 
 
 subsubsection \<open>Approximation via Single Critical Paths\<close>
 text_raw \<open>\label{sec:char-scp}\<close>
 
 text \<open>For applications we also define a single execution approximation.\<close>
 
 definition is_dcdi_via (\<open>_ dcd\<^bsup>_,_\<^esup>\<rightarrow> _ via _ _\<close> [51,51,51,51,51,51] 50) where
 \<open>n dcd\<^bsup>\<pi>,v\<^esup>\<rightarrow> m via \<pi>' m' = (is_path \<pi> \<and> m < n \<and> (\<exists> l' n'. cs\<^bsup>\<pi>\<^esup> m = cs\<^bsup>\<pi>'\<^esup> m' \<and> cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n' \<and> n' dd\<^bsup>\<pi>',v\<^esup>\<rightarrow> l' \<and> l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> m') \<and> (\<forall> l \<in> {m..<n}. v\<notin> writes(\<pi> l)))\<close>
 
 inductive_set scp where
 \<open>\<lbrakk>h \<in> hvars; h \<in> reads (path \<sigma> n); (\<forall> k<n. h\<notin> writes(path \<sigma> k))\<rbrakk> \<Longrightarrow> (path \<sigma>,n) \<in> scp\<close> |
 \<open>\<lbrakk>(\<pi>,m) \<in> scp; n cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<rbrakk> \<Longrightarrow> (\<pi>,n) \<in> scp\<close>|
 \<open>\<lbrakk>(\<pi>,m) \<in> scp; n dd\<^bsup>\<pi>,v\<^esup>\<rightarrow> m\<rbrakk> \<Longrightarrow> (\<pi>,n) \<in> scp\<close>|
 \<open>\<lbrakk>(\<pi>,m) \<in> scp; (\<pi>',m') \<in> scp; n dcd\<^bsup>\<pi>,v\<^esup>\<rightarrow> m via \<pi>' m'\<rbrakk> \<Longrightarrow> (\<pi>,n) \<in> scp\<close>
 
 inductive_set scop where
 \<open>\<lbrakk>(\<pi>,n) \<in> scp; \<pi> n \<in> dom att\<rbrakk> \<Longrightarrow> (\<pi>,n) \<in> scop\<close>
 
 
 
 subsubsection \<open>Further Definitions\<close>
 text \<open>The following concepts are utilised by the proofs.\<close>
 
 inductive contradicts (infix \<open>\<cc>\<close> 50) where
 \<open>\<lbrakk>cs\<^bsup>\<pi>'\<^esup> k' \<prec> cs\<^bsup>\<pi>\<^esup> k ; \<pi> = path \<sigma>;  \<pi>' = path \<sigma>' ; \<pi> (Suc (\<pi>\<exclamdown>cs\<^bsup>\<pi>'\<^esup> k')) \<noteq> \<pi>' (Suc k')\<rbrakk> \<Longrightarrow> (\<sigma>', k') \<cc> (\<sigma>, k)\<close>|
 \<open>\<lbrakk>cs\<^bsup>\<pi>'\<^esup> k' = cs\<^bsup>\<pi>\<^esup> k ; \<pi> = path \<sigma>;  \<pi>' = path \<sigma>' ; \<sigma>\<^bsup>k\<^esup> \<restriction> (reads (\<pi> k)) \<noteq> \<sigma>'\<^bsup>k'\<^esup> \<restriction> (reads (\<pi> k))\<rbrakk> \<Longrightarrow> (\<sigma>',k') \<cc> (\<sigma>,k)\<close>
 
 definition path_shift (infixl \<open>\<guillemotleft>\<close> 51) where 
 [simp]: \<open>\<pi>\<guillemotleft>m = (\<lambda> n. \<pi> (m+n))\<close> 
 
 definition path_append :: \<open>(nat \<Rightarrow> 'n) \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'n) \<Rightarrow> (nat \<Rightarrow> 'n)\<close> (\<open>_ @\<^bsup>_\<^esup> _\<close> [0,0,999] 51) where
 [simp]: \<open>\<pi> @\<^bsup>m\<^esup> \<pi>' = (\<lambda>n.(if n \<le> m then \<pi> n else \<pi>' (n-m)))\<close> 
 
 definition eq_up_to :: \<open>(nat \<Rightarrow> 'n) \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'n) \<Rightarrow> bool\<close> (\<open>_ =\<^bsub>_\<^esub> _\<close> [55,55,55] 50) where
 \<open>\<pi> =\<^bsub>k\<^esub> \<pi>' = (\<forall> i \<le> k. \<pi> i = \<pi>' i)\<close>
 
 end (* End of locale IFC_def *)
 
 
 
 
 section \<open>Proofs\<close>
 text_raw \<open>\label{sec:proofs}\<close>
 
 subsection \<open>Miscellaneous Facts\<close>
 
 lemma option_neq_cases: assumes \<open>x \<noteq> y\<close> obtains (none1) a where \<open>x = None\<close> \<open>y = Some a\<close> | (none2) a where \<open>x = Some a\<close> \<open>y = None\<close> | (some) a b where \<open>x = Some a\<close> \<open>y = Some b\<close> \<open>a \<noteq> b\<close> using assms by fastforce
 
 lemmas nat_sym_cases[case_names less sym eq] = linorder_less_wlog
 
 lemma mod_bound_instance: assumes \<open>j < (i::nat)\<close> obtains j' where \<open>k < j'\<close> and \<open>j' mod i = j\<close>  proof -
   have \<open>k < Suc k * i + j\<close> using assms less_imp_Suc_add by fastforce
   moreover
   have \<open>(Suc k * i + j) mod i = j\<close> by (metis assms mod_less mod_mult_self3) 
   ultimately show \<open>thesis\<close> using that by auto
 qed
 
 lemma list_neq_prefix_cases: assumes \<open>ls \<noteq> ls'\<close> and \<open>ls \<noteq> Nil\<close> and \<open>ls' \<noteq> Nil\<close>
   obtains (diverge) xs x x' ys ys' where \<open>ls = xs@[x]@ys\<close> \<open>ls' = xs@[x']@ys'\<close> \<open>x \<noteq> x'\<close> |
    (prefix1) xs where \<open>ls = ls'@xs\<close> and \<open>xs \<noteq> Nil\<close> |
    (prefix2) xs where \<open>ls@xs = ls'\<close> and \<open>xs \<noteq> Nil\<close> 
 using assms proof (induct \<open>length ls\<close> arbitrary: \<open>ls\<close> \<open>ls'\<close> rule: less_induct)
   case (less ls ls')
   obtain z zs z' zs' where
   lz: \<open>ls = z#zs\<close> \<open>ls' = z'#zs'\<close> by (metis list.exhaust less(6,7))
   show \<open>?case\<close> proof cases
     assume zz: \<open>z = z'\<close>
     hence zsz: \<open>zs \<noteq> zs'\<close> using less(5) lz by auto
     have lenz: \<open>length zs < length ls\<close> using lz by auto    
     show \<open>?case\<close> proof(cases \<open>zs = Nil\<close>)
       assume zs: \<open>zs = Nil\<close>
       hence \<open>zs' \<noteq> Nil\<close> using zsz by auto
       moreover
       have \<open>ls@zs' = ls'\<close> using zs lz zz by auto
       ultimately
       show \<open>thesis\<close> using less(4) by blast
     next
       assume zs: \<open>zs \<noteq> Nil\<close>
       show \<open>thesis\<close> proof (cases \<open>zs' = Nil\<close>)
         assume \<open>zs' = Nil\<close>
         hence \<open>ls = ls'@zs\<close> using lz zz by auto
         thus \<open>thesis\<close> using zs less(3) by blast
       next
         assume zs': \<open>zs' \<noteq> Nil\<close>
         { fix xs x ys x' ys' 
           assume \<open>zs = xs @ [x] @ ys\<close> \<open>zs' = xs @ [x'] @ ys'\<close> and xx: \<open>x \<noteq> x'\<close>
           hence \<open>ls = (z#xs) @ [x] @ ys\<close> \<open>ls' = (z#xs) @ [x'] @ ys'\<close> using lz zz by auto
           hence \<open>thesis\<close> using less(2) xx by blast
         } note * = this
         { fix xs 
           assume \<open>zs = zs' @ xs\<close> and xs: \<open>xs \<noteq> []\<close>
           hence \<open>ls = ls' @ xs\<close> using lz zz by auto
           hence \<open>thesis\<close> using xs less(3) by blast
         } note ** = this
         { fix xs 
           assume \<open>zs@xs = zs'\<close> and xs: \<open>xs \<noteq> []\<close>
           hence \<open>ls@xs = ls'\<close> using lz zz by auto
           hence \<open>thesis\<close> using xs less(4) by blast
         } note *** = this
         have \<open>(\<And>xs x ys x' ys'. zs = xs @ [x] @ ys \<Longrightarrow> zs' = xs @ [x'] @ ys' \<Longrightarrow> x \<noteq> x' \<Longrightarrow> thesis) \<Longrightarrow> 
               (\<And>xs. zs = zs' @ xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> thesis) \<Longrightarrow> 
               (\<And>xs. zs @ xs = zs' \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> 
         using less(1)[OF lenz _ _ _ zsz zs zs' ] .
         thus \<open>thesis\<close> using * ** *** by blast
       qed
     qed 
   next
     assume \<open>z \<noteq> z'\<close>
     moreover
     have \<open>ls = []@[z]@zs\<close> \<open>ls' = []@[z']@zs'\<close> using lz by auto
     ultimately show \<open>thesis\<close> using less(2) by blast
   qed
 qed
 
 lemma three_cases: assumes \<open>A \<or> B \<or> C\<close> obtains \<open>A\<close> | \<open>B\<close> | \<open>C\<close> using assms by auto
 
 lemma insort_greater: \<open>\<forall> x \<in> set ls. x < y \<Longrightarrow> insort y ls = ls@[y]\<close> by (induction \<open>ls\<close>,auto) 
 
 lemma insort_append_first: assumes \<open>\<forall> y \<in> set ys. x \<le> y\<close> shows \<open>insort x (xs@ys) = insort x xs @ ys\<close> using assms by (induction \<open>xs\<close>,auto,metis insort_is_Cons)
 
 lemma sorted_list_of_set_append: assumes \<open>finite xs\<close> \<open>finite ys\<close> \<open>\<forall> x \<in> xs. \<forall> y \<in> ys. x < y\<close> shows \<open>sorted_list_of_set (xs \<union> ys) = sorted_list_of_set xs @ (sorted_list_of_set ys)\<close>
 using assms(1,3) proof (induction \<open>xs\<close>)
   case empty thus \<open>?case\<close> by simp
 next
   case (insert x xs)
   hence iv: \<open>sorted_list_of_set (xs \<union> ys) = sorted_list_of_set xs @ sorted_list_of_set ys\<close> by blast
   have le: \<open>\<forall> y \<in> set (sorted_list_of_set ys). x < y\<close> using insert(4) assms(2) sorted_list_of_set by auto
   have \<open>sorted_list_of_set (insert x xs \<union> ys) = sorted_list_of_set (insert x (xs \<union> ys))\<close> by auto
   also 
   have \<open>\<dots> = insort x (sorted_list_of_set (xs \<union> ys))\<close> by (metis Un_iff assms(2) finite_Un insert.hyps(1) insert.hyps(2) insert.prems insertI1 less_irrefl sorted_list_of_set_insert)
   also 
   have \<open>\<dots> = insort x (sorted_list_of_set xs @ sorted_list_of_set ys)\<close> using iv by simp
   also
   have \<open>\<dots> = insort x (sorted_list_of_set xs) @ sorted_list_of_set ys\<close>  by (metis le insort_append_first less_le_not_le)
   also 
   have \<open>\<dots> = sorted_list_of_set (insert x xs) @ sorted_list_of_set ys\<close> using sorted_list_of_set_insert[OF insert(1),of \<open>x\<close>] insert(2) by auto
   finally  
   show \<open>?case\<close> .
 qed
 
 lemma filter_insort: \<open>sorted xs \<Longrightarrow> filter P (insort x xs) = (if P x then insort x (filter P xs) else filter P xs)\<close> by (induction \<open>xs\<close>, simp) (metis filter_insort filter_insort_triv map_ident) 
 
 lemma filter_sorted_list_of_set: assumes \<open>finite xs\<close> shows \<open>filter P (sorted_list_of_set xs) = sorted_list_of_set {x \<in> xs. P x}\<close> using assms proof(induction \<open>xs\<close>)
   case empty thus \<open>?case\<close> by simp
 next  
   case (insert x xs)
   have *: \<open>set (sorted_list_of_set xs) = xs\<close> \<open>sorted (sorted_list_of_set xs)\<close> \<open>distinct (sorted_list_of_set xs)\<close> by (auto simp add: insert.hyps(1))
   have **: \<open>P x \<Longrightarrow> {y \<in> insert x xs. P y} = insert x {y \<in> xs. P y}\<close> by auto
   have ***: \<open>\<not> P x \<Longrightarrow> {y \<in> insert x xs. P y} = {y \<in> xs. P y}\<close> by auto
   note filter_insort[OF *(2),of \<open>P\<close> \<open>x\<close>] sorted_list_of_set_insert[OF insert(1), of \<open>x\<close>] insert(2,3) ** ***  
   thus \<open>?case\<close> by (metis (mono_tags) "*"(1) List.finite_set distinct_filter distinct_insort distinct_sorted_list_of_set set_filter sorted_list_of_set_insert)
 qed
 
 lemma unbounded_nat_set_infinite: assumes \<open>\<forall> (i::nat). \<exists> j\<ge>i. j \<in> A\<close> shows \<open>\<not> finite A\<close> using assms
 by (metis finite_nat_set_iff_bounded_le not_less_eq_eq)
 
 lemma infinite_ascending: assumes nf: \<open>\<not> finite (A::nat set)\<close> obtains f where \<open>range f = A\<close> \<open>\<forall> i. f i < f (Suc i)\<close> proof 
   let \<open>?f\<close> = \<open>\<lambda> i. (LEAST a. a \<in> A \<and> card (A \<inter> {..<a}) = i)\<close>
   { fix i 
     obtain a where \<open>a \<in> A\<close> \<open>card (A \<inter> {..<a}) = i\<close> 
     proof (induction \<open>i\<close> arbitrary: \<open>thesis\<close>)
       case 0
       let \<open>?a0\<close> = \<open>(LEAST a. a \<in> A)\<close>
       have \<open>?a0 \<in> A\<close> by (metis LeastI empty_iff finite.emptyI nf set_eq_iff)      
       moreover
       have \<open>\<And>b. b \<in> A \<Longrightarrow> ?a0 \<le> b\<close> by (metis Least_le)
       hence \<open>card (A \<inter> {..<?a}) = 0\<close> by force
       ultimately
       show \<open>?case\<close> using 0 by blast
     next
       case (Suc i)
       obtain a where aa: \<open>a \<in> A\<close> and card: \<open>card (A \<inter> {..<a}) = i\<close> using Suc.IH by metis
       have nf': \<open>~ finite (A - {..a})\<close> using nf by auto
       let \<open>?b\<close> = \<open>LEAST b. b \<in> A - {..a}\<close>
       have bin: \<open>?b \<in> A-{..a}\<close> by (metis LeastI empty_iff finite.emptyI nf' set_eq_iff)
       have le: \<open>\<And>c. c \<in> A-{..a} \<Longrightarrow> ?b \<le> c\<close> by (metis Least_le)
       have ab: \<open>a < ?b\<close> using bin by auto
       have \<open>\<And> c. c \<in> A \<Longrightarrow> c < ?b \<Longrightarrow> c \<le> a\<close> using le by force
       hence \<open>A \<inter> {..<?b} = insert a (A \<inter> {..<a})\<close> using bin ab aa by force 
       hence \<open>card (A \<inter>{..<?b}) = Suc i\<close> using card by auto
       thus \<open>?case\<close> using Suc.prems bin by auto
     qed
     note \<open>\<And> thesis. ((\<And>a. a \<in> A \<Longrightarrow> card (A \<inter> {..<a}) = i \<Longrightarrow> thesis) \<Longrightarrow> thesis)\<close>
   }
   note ex = this
     
   {
     fix i
     obtain a where a: \<open>a \<in> A \<and> card (A \<inter>{..<a}) = i\<close>  using ex by blast
     have ina: \<open>?f i \<in> A\<close> and card: \<open>card (A \<inter>{..<?f i}) = i\<close> using LeastI[of \<open>\<lambda> a. a \<in> A \<and> card (A \<inter>{..<a}) = i\<close> \<open>a\<close>, OF a] by auto    
     obtain b where b: \<open>b \<in> A \<and> card (A \<inter>{..<b}) = Suc i\<close>  using ex by blast
     have inab: \<open>?f (Suc i) \<in> A\<close> and cardb: \<open>card (A \<inter>{..<?f (Suc i)}) = Suc i\<close> using LeastI[of \<open>\<lambda> a. a \<in> A \<and> card (A \<inter>{..<a}) = Suc i\<close> \<open>b\<close>, OF b] by auto
     have \<open>?f i < ?f (Suc i)\<close> proof (rule ccontr)
       assume \<open>\<not> ?f i < ?f (Suc i)\<close>
       hence \<open>A \<inter>{..<?f (Suc i)} \<subseteq> A \<inter>{..<?f i}\<close> by auto
       moreover have \<open>finite (A \<inter>{..<?f i})\<close> by auto
       ultimately have \<open>card(A \<inter>{..<?f (Suc i)}) \<le> card (A \<inter>{..<?f i})\<close> by (metis (erased, lifting) card_mono)
       thus \<open>False\<close> using card cardb by auto 
     qed
     note this ina
   }
   note b = this
   thus \<open>\<forall> i. ?f i < ?f (Suc i)\<close> by auto
   have *: \<open>range ?f \<subseteq> A\<close> using b by auto
   moreover
   { 
     fix a assume ina: \<open>a \<in> A\<close>
     let \<open>?i\<close> = \<open>card (A \<inter> {..<a})\<close>
     obtain b where b: \<open>b \<in> A \<and> card (A \<inter>{..<b}) = ?i\<close>  using ex by blast
     have inab: \<open>?f ?i \<in> A\<close> and cardb: \<open>card (A \<inter>{..<?f ?i}) = ?i\<close> using LeastI[of \<open>\<lambda> a. a \<in> A \<and> card (A \<inter>{..<a}) = ?i\<close> \<open>b\<close>, OF b] by auto
     have le: \<open>?f ?i \<le> a\<close> using Least_le[of \<open>\<lambda> a. a \<in> A \<and> card (A \<inter>{..<a}) = ?i\<close> \<open>a\<close>] ina by auto    
     have \<open>a = ?f ?i\<close> proof (rule ccontr)
       have fin: \<open>finite (A \<inter> {..<a})\<close> by auto
       assume \<open>a \<noteq> ?f ?i\<close>
       hence \<open>?f ?i < a\<close> using le by simp
       hence \<open>?f ?i \<in> A \<inter> {..<a}\<close> using inab by auto
       moreover
       have \<open>A \<inter> {..<?f ?i} \<subseteq> A \<inter> {..<a}\<close> using le by auto
       hence \<open>A \<inter> {..<?f ?i} = A \<inter> {..<a}\<close> using cardb card_subset_eq[OF fin] by auto
       ultimately      
       show \<open>False\<close> by auto
     qed
     hence \<open>a \<in> range ?f\<close> by auto
   }
   hence \<open>A \<subseteq> range ?f\<close> by auto 
   ultimately show \<open>range ?f = A\<close> by auto
 qed
 
 lemma mono_ge_id: \<open>\<forall> i. f i < f (Suc i) \<Longrightarrow> i \<le> f i\<close> 
   apply (induction \<open>i\<close>,auto) 
   by (metis not_le not_less_eq_eq order_trans)
 
 lemma insort_map_mono: assumes mono: \<open>\<forall> n m. n < m \<longrightarrow> f n < f m\<close> shows \<open>map f (insort n ns) = insort (f n) (map f ns)\<close>
   apply (induction \<open>ns\<close>)
    apply auto
      apply (metis not_less not_less_iff_gr_or_eq mono)
     apply (metis antisym_conv1 less_imp_le mono)
    apply (metis mono not_less)
   by (metis mono not_less)  
 
 lemma sorted_list_of_set_map_mono: assumes mono: \<open>\<forall> n m. n < m \<longrightarrow> f n < f m\<close> and fin: \<open>finite A\<close>
 shows \<open>map f (sorted_list_of_set A) = sorted_list_of_set (f`A)\<close>
 using fin proof (induction)
   case empty thus \<open>?case\<close> by simp
 next
   case (insert x A)
   have [simp]:\<open>sorted_list_of_set (insert x A) = insort x (sorted_list_of_set A)\<close> using insert sorted_list_of_set_insert by simp
   have \<open>f ` insert x A = insert (f x) (f ` A)\<close> by auto
   moreover
   have \<open>f x \<notin> f`A\<close> apply (rule ccontr) using insert(2) mono apply auto by (metis insert.hyps(2) mono neq_iff)
   ultimately
   have \<open>sorted_list_of_set (f ` insert x A) = insort (f x) (sorted_list_of_set (f`A))\<close> using insert(1) sorted_list_of_set_insert by simp
   also
   have \<open>\<dots> = insort (f x) (map f (sorted_list_of_set A))\<close> using insert.IH by auto
   also have \<open>\<dots> = map f (insort x (sorted_list_of_set A))\<close> using insort_map_mono[OF mono] by auto
   finally  
   show \<open>map f (sorted_list_of_set (insert x A)) = sorted_list_of_set (f ` insert x A)\<close> by simp
 qed
 
 lemma GreatestIB:
 fixes n :: \<open>nat\<close> and P
 assumes a:\<open>\<exists>k\<le>n. P k\<close>
 shows GreatestBI: \<open>P (GREATEST k. k\<le>n \<and> P k)\<close> and GreatestB: \<open>(GREATEST k. k\<le>n \<and> P k) \<le> n\<close> 
 proof -
   show \<open>P (GREATEST k. k\<le>n \<and> P k)\<close> using GreatestI_ex_nat[OF assms] by auto  
   show \<open>(GREATEST k. k\<le>n \<and> P k) \<le> n\<close> using GreatestI_ex_nat[OF assms] by auto
 qed
 
 lemma GreatestB_le:
 fixes n :: \<open>nat\<close>
 assumes \<open>x\<le>n\<close> and \<open>P x\<close>
 shows \<open>x \<le> (GREATEST k. k\<le>n \<and> P k)\<close> 
 proof -
   have *: \<open>\<forall> y. y\<le>n \<and> P y \<longrightarrow> y<Suc n\<close> by auto
   then show \<open>x \<le> (GREATEST k. k\<le>n \<and> P k)\<close> using assms by (blast intro: Greatest_le_nat)
 qed
 
 lemma LeastBI_ex: assumes \<open>\<exists>k \<le> n. P k\<close> shows \<open>P (LEAST k::'c::wellorder. P k)\<close> and \<open>(LEAST k. P k) \<le> n\<close> 
 proof -
-  from assms guess k .. 
-  hence k: \<open>k \<le> n\<close> \<open>P k\<close> by auto     
+  from assms obtain k where k: "k \<le> n" "P k" by blast
   thus \<open>P (LEAST k. P k)\<close> using LeastI[of \<open>P\<close> \<open>k\<close>] by simp
   show \<open>(LEAST k. P k) \<le> n\<close> using Least_le[of \<open>P\<close> \<open>k\<close>] k by auto
 qed
 
 lemma allB_atLeastLessThan_lower:  assumes \<open>(i::nat) \<le> j\<close> \<open>\<forall> x\<in>{i..<n}. P x\<close> shows \<open>\<forall> x\<in>{j..<n}. P x\<close> proof 
   fix x assume \<open>x\<in>{j..<n}\<close> hence \<open>x\<in>{i..<n}\<close> using assms(1) by simp
   thus \<open>P x\<close> using assms(2) by auto
 qed
 
 
 subsection \<open>Facts about Paths\<close>
 
 context IFC
 begin
 
 lemma path0: \<open>path \<sigma> 0 = entry\<close> unfolding path_def by auto
 
 lemma path_in_nodes[intro]: \<open>path \<sigma> k \<in> nodes\<close> proof (induction \<open>k\<close>)
   case (Suc k)
   hence \<open>\<And> \<sigma>'. (path \<sigma> k, suc (path \<sigma> k) \<sigma>') \<in> edges\<close> by auto
   hence \<open>(path \<sigma> k, path \<sigma> (Suc k)) \<in> edges\<close> unfolding path_def 
     by (metis suc_def comp_apply funpow.simps(2) prod.collapse) 
   thus \<open>?case\<close> using edges_nodes by force
 qed (auto simp add: path_def)
 
 lemma path_is_path[simp]: \<open>is_path (path \<sigma>)\<close> unfolding is_path_def path_def using step_suc_sem apply auto
 by (metis path_def suc_def edges_complete path_in_nodes prod.collapse)
 
 lemma term_path_stable: assumes \<open>is_path \<pi>\<close> \<open>\<pi> i = return\<close> and le: \<open>i \<le> j\<close> shows \<open>\<pi> j = return\<close> 
 using le proof (induction \<open>j\<close>)
   case (Suc j) 
   show \<open>?case\<close> proof cases
     assume \<open>i\<le>j\<close>
     hence \<open>\<pi> j = return\<close> using Suc by simp
     hence \<open>(return, \<pi> (Suc j)) \<in> edges\<close> using assms(1) unfolding is_path_def by metis
     thus \<open>\<pi> (Suc j) = return\<close> using edges_return by auto
   next
     assume \<open>\<not> i \<le> j\<close>
     hence \<open>Suc j = i\<close> using Suc by auto
     thus \<open>?thesis\<close> using assms(2) by auto
   qed
 next
   case 0 thus \<open>?case\<close> using assms by simp
 qed 
 
 lemma path_path_shift: assumes \<open>is_path \<pi>\<close> shows \<open>is_path (\<pi>\<guillemotleft>m)\<close> 
 using assms unfolding is_path_def by simp
 
 lemma path_cons: assumes \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> \<open>\<pi> m = \<pi>' 0\<close> shows \<open>is_path (\<pi> @\<^bsup>m\<^esup> \<pi>')\<close> 
 unfolding is_path_def proof(rule,cases)
   fix n assume \<open>m < n\<close> thus \<open>((\<pi> @\<^bsup>m\<^esup> \<pi>') n, (\<pi> @\<^bsup>m\<^esup>  \<pi>') (Suc n)) \<in> edges\<close> 
     using assms(2) unfolding is_path_def path_append_def
     by (auto,metis Suc_diff_Suc diff_Suc_Suc less_SucI) 
 next
   fix n assume *: \<open>\<not> m < n\<close>  thus \<open>((\<pi> @\<^bsup>m\<^esup>  \<pi>') n, (\<pi> @\<^bsup>m\<^esup>  \<pi>') (Suc n)) \<in> edges\<close> proof cases
     assume [simp]: \<open>n = m\<close>
     thus \<open>?thesis\<close> using assms unfolding is_path_def path_append_def by force
   next
     assume \<open>n \<noteq> m\<close>
     hence \<open>Suc n \<le> m\<close> \<open>n\<le> m\<close> using * by auto
     with assms(1) show \<open>?thesis\<close> unfolding is_path_def by auto
   qed
 qed
 
 lemma is_path_loop: assumes \<open>is_path \<pi>\<close> \<open>0 < i\<close> \<open>\<pi> i = \<pi> 0\<close> shows \<open>is_path (\<lambda> n. \<pi> (n mod i))\<close> unfolding is_path_def proof (rule,cases)
   fix n
   assume \<open>0 < Suc n mod i\<close>
   hence \<open>Suc n mod i = Suc (n mod i)\<close> by (metis mod_Suc neq0_conv)
   moreover 
   have \<open>(\<pi> (n mod i), \<pi> (Suc (n mod i))) \<in> edges\<close> using assms(1) unfolding is_path_def by auto
   ultimately
   show \<open>(\<pi> (n mod i), \<pi> (Suc n mod i)) \<in> edges\<close> by simp
   next
   fix n
   assume \<open>\<not> 0 < Suc n mod i\<close>
   hence \<open>Suc n mod i = 0\<close> by auto
   moreover 
   hence \<open>n mod i = i - 1\<close> using assms(2) by (metis Zero_neq_Suc diff_Suc_1 mod_Suc)
   ultimately
   show \<open>(\<pi>(n mod i), \<pi> (Suc n mod i)) \<in> edges\<close> using assms(1) unfolding is_path_def by (metis assms(3) mod_Suc)
 qed
 
 lemma path_nodes: \<open>is_path \<pi> \<Longrightarrow> \<pi> k \<in> nodes\<close> unfolding is_path_def using edges_nodes by force 
 
 lemma direct_path_return': assumes \<open>is_path \<pi> \<close> \<open>\<pi> 0 = x\<close> \<open>x \<noteq> return\<close> \<open>\<pi> n = return\<close>
 obtains \<pi>' n' where \<open>is_path \<pi>'\<close> \<open>\<pi>' 0 = x\<close> \<open>\<pi>' n' = return\<close> \<open>\<forall> i> 0. \<pi>' i \<noteq> x\<close>
 using assms proof (induction \<open>n\<close> arbitrary: \<open>\<pi>\<close>  rule: less_induct)
   case (less n \<pi>) 
   hence ih: \<open>\<And> n' \<pi>'. n' < n \<Longrightarrow> is_path \<pi>' \<Longrightarrow> \<pi>' 0 = x \<Longrightarrow> \<pi>' n' = return \<Longrightarrow> thesis\<close> using assms by auto
   show \<open>thesis\<close> proof cases
     assume \<open>\<forall> i>0. \<pi> i \<noteq> x\<close> thus \<open>thesis\<close> using less by auto
   next
     assume \<open>\<not> (\<forall> i>0. \<pi> i \<noteq> x)\<close>
     then obtain i where \<open>0<i\<close> \<open>\<pi> i = x\<close> by auto
     hence \<open>(\<pi>\<guillemotleft>i) 0 = x\<close> by auto
     moreover
     have \<open>i < n\<close> using less(3,5,6) \<open>\<pi> i = x\<close> by (metis linorder_neqE_nat term_path_stable less_imp_le)    
     hence \<open>(\<pi>\<guillemotleft>i) (n-i) = return\<close> using less(6) by auto
     moreover
     have \<open>is_path (\<pi>\<guillemotleft>i)\<close> using less(3) by (metis path_path_shift)
     moreover
     have \<open>n - i < n\<close> using \<open>0<i\<close> \<open>i < n\<close> by auto    
     ultimately show \<open>thesis\<close> using ih by auto
   qed
 qed
 
 lemma direct_path_return: assumes  \<open>x \<in> nodes\<close> \<open>x \<noteq> return\<close>
 obtains \<pi> n where \<open>is_path \<pi>\<close> \<open>\<pi> 0 = x\<close> \<open>\<pi> n = return\<close> \<open>\<forall> i> 0. \<pi> i \<noteq> x\<close>
 using direct_path_return'[of _ \<open>x\<close>] reaching_ret[OF assms(1)] assms(2) by blast
 
 lemma path_append_eq_up_to: \<open>(\<pi> @\<^bsup>k\<^esup> \<pi>') =\<^bsub>k\<^esub> \<pi>\<close>  unfolding eq_up_to_def by auto
 
 lemma eq_up_to_le: assumes \<open>k \<le> n\<close> \<open>\<pi> =\<^bsub>n\<^esub>  \<pi>'\<close> shows \<open>\<pi> =\<^bsub>k\<^esub> \<pi>'\<close> using assms unfolding eq_up_to_def by auto 
 
 lemma eq_up_to_refl: shows \<open>\<pi> =\<^bsub>k\<^esub> \<pi>\<close> unfolding eq_up_to_def by auto 
 
 lemma eq_up_to_sym: assumes \<open>\<pi> =\<^bsub>k\<^esub> \<pi>'\<close> shows \<open>\<pi>' =\<^bsub>k\<^esub> \<pi>\<close> using assms unfolding eq_up_to_def by auto
 
 lemma eq_up_to_apply: assumes \<open>\<pi> =\<^bsub>k\<^esub> \<pi>'\<close> \<open>j \<le> k\<close> shows \<open>\<pi> j = \<pi>' j\<close> using assms unfolding eq_up_to_def by auto
 
 lemma path_swap_ret: assumes \<open>is_path \<pi>\<close> obtains \<pi>' n where \<open>is_path \<pi>'\<close> \<open>\<pi> =\<^bsub>k\<^esub> \<pi>'\<close> \<open>\<pi>' n = return\<close>
 proof -
   have nd: \<open>\<pi> k \<in> nodes\<close> using assms path_nodes by simp
   obtain \<pi>' n where *: \<open>is_path \<pi>'\<close> \<open>\<pi>' 0 = \<pi> k\<close> \<open>\<pi>' n = return\<close> using reaching_ret[OF nd] by blast
   have \<open>\<pi> =\<^bsub>k\<^esub> (\<pi>@\<^bsup>k\<^esup> \<pi>')\<close> by (metis eq_up_to_sym path_append_eq_up_to)
   moreover
   have \<open>is_path (\<pi>@\<^bsup>k\<^esup> \<pi>')\<close> using assms * path_cons by metis
   moreover
   have \<open>(\<pi>@\<^bsup>k\<^esup> \<pi>') (k + n) = return\<close> using * by auto
   ultimately
   show \<open>thesis\<close> using that by blast
 qed
 
 lemma path_suc: \<open>path \<sigma> (Suc k) = fst (step (path \<sigma> k, \<sigma>\<^bsup>k\<^esup>))\<close> by (induction \<open>k\<close>, auto simp: path_def kth_state_def)
 
 lemma kth_state_suc: \<open>\<sigma>\<^bsup>Suc k\<^esup>  = snd (step (path \<sigma> k, \<sigma>\<^bsup>k\<^esup>))\<close> by (induction \<open>k\<close>, auto simp: path_def kth_state_def)
 
 
 subsection \<open>Facts about Post Dominators\<close>
 
 lemma pd_trans: assumes 1: \<open>y pd\<rightarrow> x\<close> and 2: \<open>z pd\<rightarrow>y\<close> shows \<open>z pd\<rightarrow>x\<close> 
 proof -
   {
     fix \<pi> n
     assume 3[simp]: \<open>is_path \<pi>\<close> \<open>\<pi> 0 = x\<close> \<open>\<pi> n = return\<close>
     then obtain k where \<open>\<pi> k = y\<close> and 7: \<open>k \<le> n\<close> using 1 unfolding is_pd_def by blast
     then have \<open>(\<pi>\<guillemotleft>k) 0 = y\<close> and \<open>(\<pi>\<guillemotleft>k) (n-k) = return\<close> by auto
     moreover have \<open>is_path (\<pi>\<guillemotleft>k)\<close> by(metis 3(1) path_path_shift)
     ultimately obtain k' where 8: \<open>(\<pi>\<guillemotleft>k) k' = z\<close> and \<open>k' \<le> n-k\<close> using 2 unfolding is_pd_def by blast
     hence \<open>k+k'\<le>n\<close> and \<open>\<pi> (k+ k') = z\<close> using 7 by auto
     hence \<open>\<exists>k\<le>n. \<pi> k = z\<close> using path_nodes by auto    
   }
   thus \<open>?thesis\<close> using 1 unfolding is_pd_def by blast
 qed
 
 lemma pd_path: assumes \<open>y pd\<rightarrow> x\<close>
 obtains \<pi> n k where \<open>is_path \<pi>\<close> and \<open>\<pi> 0 = x\<close> and \<open>\<pi> n = return\<close> and \<open>\<pi> k = y\<close> and \<open>k \<le> n\<close>   
 using assms unfolding is_pd_def using reaching_ret[of \<open>x\<close>] by blast
 
 lemma pd_antisym: assumes xpdy: \<open>x pd\<rightarrow> y\<close> and ypdx: \<open>y pd\<rightarrow> x\<close> shows \<open>x = y\<close>
 proof -
   obtain \<pi> n where path: \<open>is_path \<pi>\<close> and \<pi>0: \<open>\<pi> 0 = x\<close> and \<pi>n: \<open>\<pi> n = return\<close> using pd_path[OF ypdx] by metis
   hence kex: \<open>\<exists>k\<le>n. \<pi> k = y\<close> using ypdx unfolding is_pd_def by auto
   obtain k where k: \<open>k = (GREATEST k. k\<le>n \<and> \<pi> k = y)\<close> by simp
   have \<pi>k: \<open>\<pi> k = y\<close> and kn: \<open>k \<le> n\<close> using k kex by (auto intro: GreatestIB)
   
   have kpath: \<open>is_path (\<pi>\<guillemotleft>k)\<close> by (metis path_path_shift path)
   moreover have k0: \<open>(\<pi>\<guillemotleft>k) 0 = y\<close> using \<pi>k by simp
   moreover have kreturn: \<open>(\<pi>\<guillemotleft>k) (n-k) = return\<close> using kn \<pi>n by simp
   ultimately have ky': \<open>\<exists>k'\<le>(n-k).(\<pi>\<guillemotleft>k) k' = x\<close> using xpdy unfolding is_pd_def by simp      
 
   obtain k' where k': \<open>k' = (GREATEST k'. k'\<le>(n-k) \<and> (\<pi>\<guillemotleft>k) k' = x)\<close> by simp
 
   with ky' have \<pi>k': \<open>(\<pi>\<guillemotleft>k) k' = x\<close> and kn': \<open>k' \<le> (n-k)\<close>  by (auto intro: GreatestIB)
   have k'path: \<open>is_path (\<pi>\<guillemotleft>k\<guillemotleft>k')\<close> using kpath by(metis path_path_shift)
   moreover have k'0: \<open>(\<pi>\<guillemotleft>k\<guillemotleft>k') 0 = x\<close> using \<pi>k' by simp
   moreover have k'return: \<open>(\<pi>\<guillemotleft>k\<guillemotleft>k') (n-k-k') = return\<close> using kn' kreturn by (metis path_shift_def le_add_diff_inverse)
   ultimately have ky'': \<open>\<exists>k''\<le>(n-k-k').(\<pi>\<guillemotleft>k\<guillemotleft>k') k'' = y\<close> using ypdx unfolding is_pd_def by blast
 
   obtain k'' where k'': \<open>k''= (GREATEST k''. k''\<le>(n-k-k') \<and> (\<pi>\<guillemotleft>k\<guillemotleft>k') k'' = y)\<close> by simp
   with ky'' have \<pi>k'': \<open>(\<pi>\<guillemotleft>k\<guillemotleft>k') k'' = y\<close> and kn'': \<open>k'' \<le> (n-k-k')\<close>  by (auto intro: GreatestIB)
 
   from this(1) have  \<open>\<pi> (k + k' + k'') = y\<close> by (metis path_shift_def add.commute add.left_commute)
   moreover
   have \<open>k + k' +k'' \<le> n\<close> using kn'' kn' kn by simp
   ultimately have \<open>k + k' + k''\<le> k\<close> using k by(auto simp: GreatestB_le)
   hence \<open>k' = 0\<close> by simp
   with k0 \<pi>k' show \<open>x = y\<close> by simp
 qed
 
 lemma pd_refl[simp]: \<open>x \<in> nodes \<Longrightarrow> x pd\<rightarrow> x\<close> unfolding is_pd_def by blast
 
 lemma pdt_trans_in_pdt: \<open>(x,y) \<in> pdt\<^sup>+ \<Longrightarrow> (x,y) \<in> pdt\<close> 
 proof (induction rule: trancl_induct)
   case base thus \<open>?case\<close> by simp
 next
   case (step y z) show \<open>?case\<close> unfolding pdt_def proof (simp)
     have *: \<open>y pd\<rightarrow> x\<close> \<open>z pd\<rightarrow> y\<close> using step unfolding pdt_def by auto
     hence [simp]: \<open>z pd\<rightarrow> x\<close> using pd_trans[where x=\<open>x\<close> and y=\<open>y\<close> and z=\<open>z\<close>] by simp
     have \<open>x\<noteq>z\<close> proof 
       assume \<open>x = z\<close>
       hence \<open>z pd\<rightarrow> y\<close> \<open>y pd\<rightarrow> z\<close> using * by auto
       hence \<open>z = y\<close> using pd_antisym by auto
       thus \<open>False\<close> using step(2) unfolding pdt_def by simp
     qed
     thus \<open>x \<noteq> z \<and> z pd\<rightarrow> x\<close> by auto
   qed
 qed
 
 lemma pdt_trancl_pdt: \<open>pdt\<^sup>+ = pdt\<close> using pdt_trans_in_pdt by fast
 
 lemma trans_pdt: \<open>trans pdt\<close> by (metis pdt_trancl_pdt trans_trancl)
 
 definition [simp]: \<open>pdt_inv = pdt\<inverse>\<close>
 
 lemma wf_pdt_inv: \<open>wf (pdt_inv)\<close> proof (rule ccontr)
   assume \<open>\<not> wf (pdt_inv)\<close>
   then obtain f where  \<open>\<forall>i. (f (Suc i), f i) \<in> pdt\<inverse>\<close> using wf_iff_no_infinite_down_chain by force
   hence *: \<open>\<forall> i. (f i, f (Suc i)) \<in> pdt\<close> by simp
   have **:\<open>\<forall> i. \<forall> j>i. (f i, f j) \<in> pdt\<close> proof(rule,rule,rule)
     fix i j assume  \<open>i < (j::nat)\<close> thus \<open>(f i, f j) \<in> pdt\<close> proof (induction \<open>j\<close> rule: less_induct)
       case (less k)
       show \<open>?case\<close> proof (cases \<open>Suc i < k\<close>)
         case True
         hence k:\<open>k-1 < k\<close> \<open>i < k-1\<close> and sk: \<open>Suc (k-1) = k\<close> by auto
         show \<open>?thesis\<close> using less(1)[OF k] *[rule_format,of \<open>k-1\<close>,unfolded sk] trans_pdt[unfolded trans_def] by blast
       next
         case False
         hence \<open>Suc i = k\<close> using less(2) by auto
         then show \<open>?thesis\<close> using * by auto
       qed
     qed
   qed
   hence ***:\<open>\<forall> i. \<forall> j > i. f j pd\<rightarrow> f i\<close> \<open>\<forall> i. \<forall> j > i. f i \<noteq>  f j\<close> unfolding pdt_def by auto
   hence ****:\<open>\<forall> i>0. f i pd\<rightarrow> f 0\<close> by simp
   hence \<open>f 0 \<in> nodes\<close>  using * is_pd_def by fastforce
   then obtain \<pi> n where \<pi>:\<open>is_path \<pi>\<close> \<open>\<pi> 0 = f 0\<close> \<open>\<pi> n = return\<close> using reaching_ret by blast  
   hence \<open>\<forall> i>0. \<exists> k\<le>n. \<pi> k = f i\<close> using ***(1) \<open>f 0 \<in> nodes\<close> unfolding is_pd_def by blast
   hence \<pi>f:\<open>\<forall> i. \<exists> k\<le>n. \<pi> k = f i\<close> using \<pi>(2) by (metis le0 not_gr_zero)
   have \<open>range f \<subseteq> \<pi> ` {..n}\<close> proof(rule subsetI)
     fix x assume \<open>x \<in> range f\<close>
     then obtain i where \<open>x = f i\<close> by auto
     then obtain k where \<open>x = \<pi> k\<close> \<open>k \<le> n\<close> using \<pi>f by metis
     thus \<open>x \<in> \<pi> ` {..n}\<close> by simp
   qed
   hence f:\<open>finite (range f)\<close> using finite_surj by auto
   hence fi:\<open>\<exists> i. infinite {j. f j = f i}\<close>  using pigeonhole_infinite[OF _ f] by auto
   obtain i where \<open>infinite {j. f j = f i}\<close> using fi ..    
   thus \<open>False\<close> 
     by (metis (mono_tags, lifting) "***"(2) bounded_nat_set_is_finite gt_ex mem_Collect_eq nat_neq_iff)
 qed
 
 lemma return_pd: assumes \<open>x \<in> nodes\<close> shows \<open>return pd\<rightarrow> x\<close> unfolding is_pd_def using assms by blast
 
 lemma pd_total: assumes xz: \<open>x pd\<rightarrow> z\<close> and yz: \<open>y pd\<rightarrow> z\<close> shows \<open>x pd\<rightarrow> y \<or> y pd\<rightarrow>x\<close> 
 proof -
   obtain \<pi> n where path: \<open>is_path \<pi>\<close> and \<pi>0: \<open>\<pi> 0 = z\<close> and \<pi>n: \<open>\<pi> n = return\<close> using xz reaching_ret unfolding is_pd_def by force
   have *: \<open>\<exists> k\<le>n. (\<pi> k = x \<or> \<pi> k = y)\<close> (is \<open>\<exists> k\<le>n. ?P k\<close>) using path \<pi>0 \<pi>n xz yz unfolding is_pd_def by auto
   obtain k where k: \<open>k = (LEAST k. \<pi> k = x \<or> \<pi> k = y)\<close> by simp
   hence kn: \<open>k\<le>n\<close> and \<pi>k: \<open>\<pi> k = x \<or> \<pi> k = y\<close> using LeastBI_ex[OF *] by auto 
   note k_le = Least_le[where P = \<open>?P\<close>] 
   show \<open>?thesis\<close> proof (cases)
     assume kx: \<open>\<pi> k = x\<close>
     have k_min: \<open>\<And> k'. \<pi> k' = y \<Longrightarrow> k \<le> k'\<close> using k_le unfolding k by auto
     {
       fix \<pi>' 
       and n' :: \<open>nat\<close>
       assume path': \<open>is_path \<pi>'\<close> and \<pi>'0: \<open>\<pi>' 0 = x\<close> and \<pi>'n': \<open>\<pi>' n' = return\<close>
       have path'': \<open>is_path (\<pi> @\<^bsup>k\<^esup> \<pi>')\<close> using path_cons[OF path path'] kx \<pi>'0 by auto
       have \<pi>''0: \<open>(\<pi> @\<^bsup>k\<^esup> \<pi>') 0 = z\<close> using \<pi>0 by simp
       have \<pi>''n: \<open>(\<pi> @\<^bsup>k\<^esup> \<pi>') (k+n') = return\<close> using \<pi>'n' kx \<pi>'0 by auto
       obtain k' where k': \<open>k' \<le> k + n'\<close> \<open>(\<pi> @\<^bsup>k\<^esup> \<pi>') k' = y\<close> using yz path'' \<pi>''0 \<pi>''n unfolding is_pd_def by blast
       have **: \<open>k \<le> k'\<close> proof (rule ccontr)
         assume \<open>\<not> k \<le> k'\<close>
         hence \<open>k' < k\<close> by simp
         moreover 
         hence \<open>\<pi> k' = y\<close> using k' by auto
         ultimately
         show \<open>False\<close> using k_min by force
      qed
      hence \<open>\<pi>' (k' - k) = y\<close> using k' \<pi>'0 kx  by auto
      moreover
      have \<open>(k' - k) \<le> n'\<close> using k' by auto
      ultimately 
      have \<open>\<exists> k\<le> n'. \<pi>' k = y\<close> by auto
    }
    hence \<open>y pd\<rightarrow> x\<close> using kx path_nodes path unfolding is_pd_def by auto
    thus \<open>?thesis\<close> ..
  next \<comment> \<open>This is analogous argument\<close>
    assume kx: \<open>\<pi> k \<noteq> x\<close>
    hence ky: \<open>\<pi> k = y\<close> using \<pi>k by auto
    have k_min: \<open>\<And> k'. \<pi> k' = x \<Longrightarrow> k \<le> k'\<close> using k_le unfolding k by auto
     {
       fix \<pi>' 
       and n' :: \<open>nat\<close>
       assume path': \<open>is_path \<pi>'\<close> and \<pi>'0: \<open>\<pi>' 0 = y\<close> and \<pi>'n': \<open>\<pi>' n' = return\<close>
       have path'': \<open>is_path (\<pi> @\<^bsup>k\<^esup> \<pi>')\<close> using path_cons[OF path path'] ky \<pi>'0 by auto
       have \<pi>''0: \<open>(\<pi> @\<^bsup>k\<^esup> \<pi>') 0 = z\<close> using \<pi>0 by simp
       have \<pi>''n: \<open>(\<pi> @\<^bsup>k\<^esup> \<pi>') (k+n') = return\<close> using \<pi>'n' ky \<pi>'0 by auto
       obtain k' where k': \<open>k' \<le> k + n'\<close> \<open>(\<pi> @\<^bsup>k\<^esup> \<pi>') k' = x\<close> using xz path'' \<pi>''0 \<pi>''n unfolding is_pd_def by blast
       have **: \<open>k \<le> k'\<close> proof (rule ccontr)
         assume \<open>\<not> k \<le> k'\<close>
         hence \<open>k' < k\<close> by simp
         moreover 
         hence \<open>\<pi> k' = x\<close> using k' by auto
         ultimately
         show \<open>False\<close> using k_min by force
      qed
      hence \<open>\<pi>' (k' - k) = x\<close> using k' \<pi>'0 ky  by auto
      moreover
      have \<open>(k' - k) \<le> n'\<close> using k' by auto
      ultimately 
      have \<open>\<exists> k\<le> n'. \<pi>' k = x\<close> by auto
    }
    hence \<open>x pd\<rightarrow> y\<close> using ky path_nodes path unfolding is_pd_def by auto
    thus \<open>?thesis\<close> ..
   qed
 qed    
 
 lemma pds_finite: \<open>finite {y . (x,y) \<in> pdt}\<close> proof cases 
   assume \<open>x \<in> nodes\<close>
   then obtain \<pi> n where \<pi>:\<open>is_path \<pi>\<close> \<open>\<pi> 0 = x\<close> \<open>\<pi> n = return\<close> using reaching_ret by blast
   have *: \<open>\<forall> y \<in> {y. (x,y)\<in> pdt}. y pd\<rightarrow> x\<close> using pdt_def by auto
   have \<open>\<forall> y \<in> {y. (x,y)\<in> pdt}. \<exists> k \<le> n. \<pi> k = y\<close>  using * \<pi> is_pd_def by blast
   hence \<open>{y. (x,y)\<in> pdt} \<subseteq> \<pi> ` {..n}\<close>  by auto
   then show \<open>?thesis\<close> using finite_surj by blast
 next
   assume \<open>\<not> x\<in> nodes\<close>
   hence \<open>{y. (x,y)\<in>pdt} = {}\<close> unfolding pdt_def is_pd_def using path_nodes reaching_ret by fastforce
   then show \<open>?thesis\<close> by simp
 qed
 
 lemma ipd_exists: assumes node: \<open>x \<in> nodes\<close> and not_ret: \<open>x\<noteq>return\<close> shows \<open>\<exists>y. y ipd\<rightarrow> x\<close> 
 proof -
   let \<open>?Q\<close> = \<open>{y. x\<noteq>y \<and> y pd\<rightarrow> x}\<close>
   have *: \<open>return \<in> ?Q\<close> using assms return_pd by simp    
   hence **: \<open>\<exists> x. x\<in> ?Q\<close> by auto
   have fin: \<open>finite ?Q\<close> using pds_finite unfolding pdt_def by auto
   have tot: \<open>\<forall> y z. y\<in>?Q \<and> z \<in> ?Q \<longrightarrow> z pd\<rightarrow> y \<or> y pd\<rightarrow> z\<close> using pd_total by auto
   obtain y where ymax: \<open>y\<in> ?Q\<close> \<open>\<forall> z\<in>?Q. z = y \<or> z pd\<rightarrow> y\<close> using fin ** tot proof (induct)
     case empty
     then show \<open>?case\<close> by auto
   next
     case (insert x F) show \<open>thesis\<close> proof (cases \<open>F = {}\<close>)
       assume \<open>F = {}\<close>
       thus \<open>thesis\<close> using insert(4)[of \<open>x\<close>] by auto
     next  
       assume \<open>F \<noteq> {}\<close>
       hence \<open>\<exists> x. x\<in> F\<close> by auto
       have \<open>\<And>y. y \<in> F \<Longrightarrow> \<forall>z\<in>F. z = y \<or> z pd\<rightarrow> y \<Longrightarrow> thesis\<close> proof -
         fix y assume a: \<open>y \<in> F\<close> \<open>\<forall>z\<in>F. z = y \<or> z pd\<rightarrow> y\<close>
         have \<open>x \<noteq> y\<close> using insert a by auto
         have \<open>x pd\<rightarrow> y \<or> y pd\<rightarrow> x\<close> using insert(6) a(1) by auto
         thus \<open>thesis\<close> proof 
           assume \<open>x pd\<rightarrow> y\<close>
           hence \<open>\<forall>z\<in>insert x F. z = y \<or> z pd\<rightarrow> y\<close> using a(2) by blast
           thus \<open>thesis\<close> using a(1) insert(4) by blast
         next
           assume \<open>y pd\<rightarrow> x\<close>
           have \<open>\<forall>z\<in>insert x F. z = x \<or> z pd\<rightarrow> x\<close> proof
             fix z assume \<open>z\<in> insert x F\<close> thus \<open>z = x \<or> z pd\<rightarrow> x\<close> proof(rule,simp)
               assume \<open>z\<in>F\<close>
               hence \<open>z = y \<or> z pd\<rightarrow> y\<close> using a(2) by auto
               thus \<open>z = x \<or> z pd\<rightarrow> x\<close> proof(rule,simp add: \<open>y pd\<rightarrow> x\<close>)
                 assume \<open>z pd\<rightarrow> y\<close>
                 show \<open>z = x \<or> z pd\<rightarrow> x\<close> using \<open>y pd\<rightarrow> x\<close> \<open>z pd\<rightarrow> y\<close> pd_trans by blast
               qed 
             qed
           qed 
           then show \<open>thesis\<close> using insert by blast
         qed
       qed
       then show \<open>thesis\<close> using insert by blast
     qed
   qed    
   hence ***: \<open>y pd\<rightarrow> x\<close> \<open>x\<noteq>y\<close> by auto
   have \<open>\<forall> z. z \<noteq> x \<and> z pd\<rightarrow> x \<longrightarrow> z pd\<rightarrow> y\<close> proof (rule,rule)
     fix z 
     assume a: \<open> z \<noteq> x \<and> z pd\<rightarrow> x\<close>
     hence b: \<open>z \<in> ?Q\<close> by auto
     have \<open>y pd\<rightarrow> z \<or> z pd\<rightarrow> y\<close> using pd_total ***(1) a by auto
     thus \<open>z pd\<rightarrow> y\<close> proof
       assume c: \<open>y pd\<rightarrow> z\<close>
       hence \<open>y = z\<close> using b ymax pdt_def pd_antisym by auto
       thus \<open>z pd\<rightarrow> y\<close> using c by simp
     qed simp
   qed
   with *** have  \<open>y ipd\<rightarrow> x\<close> unfolding is_ipd_def by simp
   thus \<open>?thesis\<close> by blast
 qed
 
 lemma ipd_unique: assumes yipd: \<open>y ipd\<rightarrow> x\<close> and y'ipd: \<open>y' ipd\<rightarrow> x\<close> shows \<open>y = y'\<close> 
 proof -  
   have 1: \<open>y pd\<rightarrow> y'\<close> and  2: \<open>y' pd\<rightarrow> y\<close> using yipd y'ipd unfolding is_ipd_def by auto
   show \<open>?thesis\<close> using pd_antisym[OF 1 2] .
 qed
 
 lemma ipd_is_ipd: assumes \<open>x \<in> nodes\<close> and \<open>x\<noteq>return\<close> shows \<open>ipd x ipd\<rightarrow> x\<close> proof -
   from assms obtain y where \<open>y ipd\<rightarrow> x\<close> using ipd_exists by auto
   moreover
   hence \<open>\<And> z. z ipd\<rightarrow>x \<Longrightarrow> z = y\<close> using ipd_unique by simp
   ultimately show \<open>?thesis\<close> unfolding ipd_def by (auto intro: theI2)
 qed
 
 lemma is_ipd_in_pdt: \<open>y ipd\<rightarrow> x \<Longrightarrow> (x,y) \<in> pdt\<close> unfolding is_ipd_def pdt_def by auto
 
 lemma ipd_in_pdt: \<open>x \<in> nodes \<Longrightarrow> x\<noteq>return \<Longrightarrow> (x,ipd x) \<in> pdt\<close> by (metis ipd_is_ipd is_ipd_in_pdt)
 
 lemma no_pd_path: assumes \<open>x \<in> nodes\<close> and \<open>\<not> y pd\<rightarrow> x\<close>
 obtains \<pi> n where \<open>is_path \<pi>\<close> and \<open>\<pi> 0 = x\<close> and \<open>\<pi> n = return\<close> and \<open>\<forall> k \<le> n. \<pi> k \<noteq> y\<close>
 proof (rule ccontr)
   assume \<open>\<not> thesis\<close>
   hence \<open>\<forall> \<pi> n.  is_path \<pi> \<and> \<pi> 0 = x \<and> \<pi> n = return \<longrightarrow> (\<exists> k\<le>n . \<pi> k = y)\<close> using that by force
   thus \<open>False\<close> using assms unfolding is_pd_def by auto
 qed
 
 lemma pd_pd_ipd: assumes \<open>x \<in> nodes\<close> \<open>x\<noteq>return\<close> \<open>y\<noteq>x\<close> \<open>y pd\<rightarrow> x\<close> shows \<open>y pd\<rightarrow> ipd x\<close> 
 proof -
   have \<open>ipd x pd\<rightarrow> x\<close> by (metis assms(1,2) ipd_is_ipd is_ipd_def)
   hence \<open>y pd\<rightarrow> ipd x \<or> ipd x pd\<rightarrow> y\<close> by (metis assms(4) pd_total)
   thus \<open>?thesis\<close> proof
     have 1: \<open>ipd x ipd\<rightarrow> x\<close> by (metis assms(1,2) ipd_is_ipd)
     moreover
     assume \<open>ipd x pd\<rightarrow> y\<close>
     ultimately
     show \<open>y pd\<rightarrow> ipd x\<close> unfolding is_ipd_def using assms(3,4) by auto
   qed auto
 qed
 
 lemma pd_nodes: assumes \<open>y pd\<rightarrow> x\<close> shows pd_node1: \<open>y \<in> nodes\<close> and pd_node2: \<open>x \<in> nodes\<close>
 proof -
   obtain \<pi> k where \<open>is_path \<pi>\<close> \<open>\<pi> k = y\<close> using assms unfolding is_pd_def using reaching_ret by force
   thus \<open>y \<in> nodes\<close> using path_nodes by auto
   show \<open>x \<in> nodes\<close> using assms unfolding is_pd_def by simp
 qed
 
 lemma pd_ret_is_ret: \<open>x pd\<rightarrow> return \<Longrightarrow> x = return\<close> by (metis pd_antisym pd_node1 return_pd)
 
 lemma ret_path_none_pd: assumes \<open>x \<in> nodes\<close> \<open>x\<noteq>return\<close> 
 obtains \<pi> n where \<open>is_path \<pi>\<close>  \<open>\<pi> 0 = x\<close> \<open>\<pi> n = return\<close>  \<open>\<forall> i>0. \<not> x pd\<rightarrow> \<pi> i\<close>
 proof(rule ccontr)
   assume \<open>\<not>thesis\<close>
   hence *: \<open>\<And> \<pi> n. \<lbrakk>is_path \<pi>; \<pi> 0 = x; \<pi> n = return\<rbrakk> \<Longrightarrow> \<exists>i>0. x pd\<rightarrow> \<pi> i\<close> using that by blast
   obtain \<pi> n where **: \<open>is_path \<pi>\<close>  \<open>\<pi> 0 = x\<close> \<open>\<pi> n = return\<close> \<open>\<forall> i>0. \<pi> i \<noteq> x\<close> using direct_path_return[OF assms] by metis
   then obtain i where ***: \<open>i>0\<close> \<open>x pd\<rightarrow> \<pi> i\<close> using * by blast
   hence \<open>\<pi> i \<noteq> return\<close> using pd_ret_is_ret assms(2) by auto
   hence \<open>i < n\<close> using assms(2) term_path_stable ** by (metis linorder_neqE_nat less_imp_le)
   hence \<open>(\<pi>\<guillemotleft>i)(n-i) = return\<close> using **(3) by auto
   moreover
   have \<open>(\<pi>\<guillemotleft>i) (0) = \<pi> i\<close> by simp
   moreover 
   have \<open>is_path (\<pi>\<guillemotleft>i)\<close> using **(1) path_path_shift by metis
   ultimately
   obtain k where \<open>(\<pi>\<guillemotleft>i) k = x\<close> using ***(2) unfolding is_pd_def by metis
   hence \<open>\<pi> (i + k) = x\<close> by auto
   thus \<open>False\<close> using **(4) \<open>i>0\<close> by auto
 qed
 
 lemma path_pd_ipd0': assumes \<open>is_path \<pi>\<close> and \<open>\<pi> n \<noteq> return\<close> \<open>\<pi> n \<noteq> \<pi> 0\<close> and \<open>\<pi> n pd\<rightarrow> \<pi> 0\<close> 
 obtains k where \<open>k \<le> n\<close> and \<open>\<pi> k = ipd(\<pi> 0)\<close> 
 proof(rule ccontr)  
   have *: \<open>\<pi> n pd\<rightarrow> ipd (\<pi> 0)\<close> by (metis is_pd_def assms(3,4) pd_pd_ipd pd_ret_is_ret)  
   obtain \<pi>' n' where **: \<open>is_path \<pi>'\<close> \<open>\<pi>' 0 = \<pi> n\<close> \<open>\<pi>' n' = return\<close> \<open>\<forall> i>0. \<not> \<pi> n pd\<rightarrow> \<pi>' i\<close>  by (metis assms(2) assms(4) pd_node1 ret_path_none_pd)
   hence \<open>\<forall> i>0. \<pi>' i \<noteq> ipd (\<pi> 0)\<close> using * by metis
   moreover
   assume \<open>\<not> thesis\<close>
   hence \<open>\<forall> k\<le>n. \<pi> k \<noteq> ipd (\<pi> 0)\<close> using that by blast
   ultimately
   have \<open>\<forall> i. (\<pi>@\<^bsup>n\<^esup>  \<pi>') i \<noteq> ipd (\<pi> 0)\<close> by (metis diff_is_0_eq neq0_conv path_append_def)
   moreover
   have \<open>(\<pi>@\<^bsup>n\<^esup>  \<pi>') (n + n') = return\<close> 
     by (metis \<open>\<pi>' 0 = \<pi> n\<close> \<open>\<pi>' n' = return\<close> add_diff_cancel_left' assms(2) diff_is_0_eq path_append_def)
   moreover
   have \<open>(\<pi>@\<^bsup>n\<^esup>  \<pi>') 0 = \<pi> 0\<close> by (metis le0 path_append_def)
   moreover
   have \<open>is_path (\<pi>@\<^bsup>n\<^esup>  \<pi>')\<close> by (metis \<open>\<pi>' 0 = \<pi> n\<close> \<open>is_path \<pi>'\<close> assms(1) path_cons)
   moreover  
   have \<open>ipd (\<pi> 0) pd\<rightarrow> \<pi> 0\<close> by (metis **(2,3,4) assms(2) assms(4) ipd_is_ipd is_ipd_def neq0_conv pd_node2)
   moreover
   have \<open>\<pi> 0 \<in> nodes\<close> by (metis assms(1) path_nodes)
   ultimately
   show \<open>False\<close> unfolding is_pd_def by blast
 qed
 
 lemma path_pd_ipd0: assumes \<open>is_path \<pi>\<close> and \<open>\<pi> 0 \<noteq> return\<close> \<open>\<pi> n \<noteq> \<pi> 0\<close> and \<open>\<pi> n pd\<rightarrow> \<pi> 0\<close> 
 obtains k where \<open>k \<le> n\<close> and \<open>\<pi> k = ipd(\<pi> 0)\<close> 
 proof cases 
   assume *: \<open>\<pi> n = return\<close>
   have \<open>ipd (\<pi> 0) pd\<rightarrow> (\<pi> 0)\<close> by (metis is_ipd_def is_pd_def assms(2,4) ipd_is_ipd)
   with assms(1,2,3) * show \<open>thesis\<close> unfolding is_pd_def by (metis that)
 next
   assume \<open>\<pi> n \<noteq> return\<close> 
   from path_pd_ipd0' [OF assms(1) this assms(3,4)] that show \<open>thesis\<close> by auto
 qed
 
 lemma path_pd_ipd: assumes \<open>is_path \<pi>\<close> and \<open>\<pi> k \<noteq> return\<close> \<open>\<pi> n \<noteq> \<pi> k\<close> and \<open>\<pi> n pd\<rightarrow> \<pi> k\<close> and kn: \<open>k < n\<close> 
 obtains l where \<open>k < l\<close> and \<open>l \<le> n\<close> and \<open>\<pi> l = ipd(\<pi> k)\<close> 
 proof -
   have \<open>is_path (\<pi> \<guillemotleft> k)\<close> \<open>(\<pi> \<guillemotleft> k) 0 \<noteq> return\<close> \<open>(\<pi> \<guillemotleft> k) (n - k) \<noteq> (\<pi> \<guillemotleft> k) 0\<close> \<open>(\<pi> \<guillemotleft> k) (n - k) pd\<rightarrow> (\<pi> \<guillemotleft> k) 0\<close> 
   using assms path_path_shift by auto 
   with path_pd_ipd0[of \<open>\<pi>\<guillemotleft>k\<close> \<open>n-k\<close>]
   obtain ka where \<open>ka \<le> n - k\<close> \<open>(\<pi> \<guillemotleft> k) ka = ipd ((\<pi> \<guillemotleft> k) 0)\<close> .
   hence \<open>k + ka \<le> n\<close> \<open>\<pi> (k + ka) = ipd (\<pi> k)\<close> using kn by auto
   moreover 
   hence \<open>\<pi> (k + ka) ipd\<rightarrow> \<pi> k\<close> by (metis assms(1) assms(2) ipd_is_ipd path_nodes)
   hence \<open>k < k + ka\<close> unfolding is_ipd_def by (metis nat_neq_iff not_add_less1)
   ultimately
   show \<open>thesis\<close> using that[of \<open>k+ka\<close>] by auto
 qed
 
 lemma path_ret_ipd: assumes \<open>is_path \<pi>\<close> and \<open>\<pi> k \<noteq> return\<close> \<open>\<pi> n = return\<close> 
 obtains l where \<open>k < l\<close> and \<open>l \<le> n\<close> and \<open>\<pi> l = ipd(\<pi> k)\<close> 
 proof -
   have \<open>\<pi> n \<noteq> \<pi> k\<close> using assms by auto
   moreover
   have \<open>k \<le> n\<close> apply (rule ccontr) using term_path_stable assms by auto
   hence \<open>k < n\<close> by (metis assms(2,3) dual_order.order_iff_strict)
   moreover
   have \<open>\<pi> n pd\<rightarrow> \<pi> k\<close> by (metis assms(1,3) path_nodes return_pd)
   ultimately
   obtain l where \<open>k < l\<close> \<open>l \<le> n\<close> \<open>\<pi> l = ipd (\<pi> k)\<close> using assms path_pd_ipd by blast
   thus \<open>thesis\<close> using that by auto
 qed
 
 lemma pd_intro: assumes \<open>l pd\<rightarrow> k\<close> \<open>is_path \<pi>\<close> \<open>\<pi> 0 = k\<close> \<open>\<pi> n = return\<close> 
 obtains i where \<open>i \<le> n\<close> \<open>\<pi> i = l\<close> using assms unfolding is_pd_def by metis
 
 lemma path_pd_pd0: assumes path:  \<open>is_path \<pi>\<close> and lpdn: \<open>\<pi> l pd\<rightarrow> n\<close> and npd0: \<open>n pd\<rightarrow> \<pi> 0\<close> 
 obtains k where \<open>k \<le> l\<close> \<open>\<pi> k = n\<close>
 proof (rule ccontr)
   assume \<open>\<not> thesis\<close>
   hence notn: \<open>\<And> k. k \<le> l \<Longrightarrow> \<pi> k \<noteq> n\<close> using that by blast
   have nret: \<open>\<pi> l \<noteq> return\<close> by (metis is_pd_def assms(1,3) notn)
   
   obtain \<pi>' n' where path': \<open>is_path \<pi>'\<close> and \<pi>0': \<open>\<pi>' 0 = \<pi> l\<close> and \<pi>n': \<open>\<pi>' n' = return\<close> and nonepd: \<open>\<forall> i>0. \<not> \<pi> l pd\<rightarrow> \<pi>' i\<close>
   using nret path path_nodes ret_path_none_pd by metis
   
   have \<open>\<pi> l \<noteq> n\<close> using notn by simp
   hence \<open>\<forall> i. \<pi>' i \<noteq> n\<close> using nonepd \<pi>0' lpdn by (metis neq0_conv)
   
   hence notn': \<open>\<forall> i. (\<pi>@\<^bsup>l\<^esup> \<pi>') i \<noteq> n\<close> using notn \<pi>0' by auto
 
   have \<open>is_path (\<pi>@\<^bsup>l\<^esup> \<pi>')\<close> using path path' by (metis \<pi>0' path_cons)
   moreover
   have \<open>(\<pi>@\<^bsup>l\<^esup> \<pi>') 0 = \<pi> 0\<close> by simp
   moreover
   have \<open>(\<pi>@\<^bsup>l\<^esup> \<pi>') (n' + l) = return\<close> using \<pi>0' \<pi>n' by auto
   ultimately
   show \<open>False\<close> using notn' npd0 unfolding is_pd_def by blast
 qed
 
 
 subsection \<open>Facts about Control Dependencies\<close>
 
 lemma icd_imp_cd: \<open>n icd\<^bsup>\<pi>\<^esup>\<rightarrow> k \<Longrightarrow> n cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> by (metis is_icdi_def)
 
 lemma ipd_impl_not_cd:  assumes \<open>j \<in> {k..i}\<close> and \<open>\<pi> j = ipd (\<pi> k)\<close> shows \<open>\<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> 
   by (metis assms(1) assms(2) is_cdi_def)
 
 lemma cd_not_ret: assumes \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k \<close> shows \<open>\<pi> k \<noteq> return\<close> by (metis is_cdi_def assms nat_less_le term_path_stable)
 
 lemma cd_path_shift: assumes \<open>j \<le> k\<close> \<open>is_path \<pi> \<close> shows \<open>(i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k) = (i - j cd\<^bsup>\<pi>\<guillemotleft>j\<^esup>\<rightarrow> k-j)\<close> proof 
   assume a: \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close>
   hence b: \<open>k < i\<close> by (metis is_cdi_def)
   hence \<open>is_path (\<pi> \<guillemotleft> j)\<close> \<open>k - j < i - j\<close> using assms apply (metis path_path_shift) 
   by (metis assms(1) b diff_less_mono)  
   moreover 
   have c: \<open>\<forall> j \<in> {k..i}. \<pi> j \<noteq> ipd (\<pi> k)\<close> by (metis a ipd_impl_not_cd)
   hence \<open>\<forall> ja \<in> {k - j..i - j}. (\<pi> \<guillemotleft> j) ja \<noteq> ipd ((\<pi> \<guillemotleft> j) (k - j))\<close> using b assms by auto fastforce
   moreover 
   have \<open>j < i\<close> using assms(1) b by auto
   hence \<open>(\<pi>\<guillemotleft>j) (i - j) \<noteq> return\<close> using a unfolding is_cdi_def by auto 
   ultimately
   show \<open>i - j cd\<^bsup>\<pi>\<guillemotleft>j\<^esup>\<rightarrow> k-j\<close> unfolding is_cdi_def by simp
 next
   assume a: \<open>i - j cd\<^bsup>\<pi>\<guillemotleft>j\<^esup>\<rightarrow> k-j\<close>
   hence b: \<open>k - j < i-j\<close> by (metis is_cdi_def)
   moreover
   have c: \<open>\<forall> ja \<in> {k - j..i - j}. (\<pi> \<guillemotleft> j) ja \<noteq> ipd ((\<pi> \<guillemotleft> j) (k - j))\<close> by (metis a ipd_impl_not_cd)
   have \<open>\<forall> j \<in> {k..i}. \<pi> j \<noteq> ipd (\<pi> k)\<close> proof (rule,goal_cases) case (1 n)
     hence \<open>n-j \<in> {k-j..i-j}\<close> using assms by auto
     hence \<open>\<pi> (j + (n-j)) \<noteq> ipd(\<pi> (j + (k-j)))\<close> by (metis c path_shift_def)
     thus \<open>?case\<close> using 1 assms(1) by auto
   qed
   moreover
   have \<open>j < i\<close> using assms(1) b by auto
   hence \<open>\<pi> i \<noteq> return\<close> using a unfolding is_cdi_def by auto
   ultimately
   show \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow>k\<close> unfolding is_cdi_def by (metis assms(1) assms(2) diff_is_0_eq' le_diff_iff nat_le_linear nat_less_le)
 qed 
 
 lemma cd_path_shift0: assumes \<open>is_path \<pi>\<close> shows \<open>(i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k) = (i-k cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow>0)\<close>
   using cd_path_shift[OF _ assms] by (metis diff_self_eq_0 le_refl)
 
 lemma icd_path_shift: assumes \<open>l \<le> k\<close> \<open>is_path \<pi>\<close> shows \<open>(i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k) = (i - l icd\<^bsup>\<pi>\<guillemotleft>l\<^esup>\<rightarrow> k - l)\<close> 
 proof -
   have \<open>is_path (\<pi>\<guillemotleft>l)\<close> using path_path_shift assms(2) by auto
   moreover
   have \<open>(i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k) = (i - l cd\<^bsup>\<pi>\<guillemotleft>l\<^esup>\<rightarrow> k - l)\<close> using assms cd_path_shift by auto
   moreover 
   have \<open>(\<forall> m \<in> {k<..<i}. \<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> m) = (\<forall> m \<in> {k - l<..<i - l}. \<not> i - l cd\<^bsup>\<pi> \<guillemotleft> l\<^esup>\<rightarrow> m)\<close> 
   proof -
     {fix m assume *: \<open>\<forall> m \<in> {k - l<..<i - l}. \<not> i - l cd\<^bsup>\<pi> \<guillemotleft> l\<^esup>\<rightarrow> m\<close> \<open>m \<in> {k<..<i}\<close> 
       hence \<open>m-l \<in> {k-l<..<i-l}\<close> using assms(1) by auto
       hence \<open>\<not> i - l cd\<^bsup>\<pi>\<guillemotleft>l\<^esup>\<rightarrow>(m-l)\<close> using * by blast
       moreover
       have \<open>l \<le> m\<close> using * assms by auto
       ultimately have \<open>\<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow>m\<close> using assms(2) cd_path_shift by blast
     }
     moreover
     {fix m assume *: \<open>\<forall> m \<in> {k<..<i}. \<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> \<open>m-l \<in> {k-l<..<i-l}\<close> 
       hence \<open>m \<in> {k<..<i}\<close> using assms(1) by auto
       hence \<open>\<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow>m\<close> using * by blast
       moreover
       have \<open>l \<le> m\<close> using * assms by auto
       ultimately have \<open>\<not> i - l cd\<^bsup>\<pi>\<guillemotleft>l\<^esup>\<rightarrow>(m-l)\<close> using assms(2) cd_path_shift by blast
     }
     ultimately show \<open>?thesis\<close> by auto (metis diff_add_inverse)
   qed
   ultimately
   show \<open>?thesis\<close> unfolding is_icdi_def using assms by blast
 qed
 
 lemma icd_path_shift0: assumes \<open>is_path \<pi>\<close> shows \<open>(i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k) = (i-k icd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow>0)\<close>
   using icd_path_shift[OF _ assms] by (metis diff_self_eq_0 le_refl)
 
 lemma cdi_path_swap: assumes \<open>is_path \<pi>'\<close> \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow>k\<close> \<open>\<pi> =\<^bsub>j\<^esub>  \<pi>'\<close> shows \<open>j cd\<^bsup>\<pi>'\<^esup>\<rightarrow>k\<close> using assms unfolding eq_up_to_def is_cdi_def by auto
 
 lemma cdi_path_swap_le: assumes \<open>is_path \<pi>'\<close> \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow>k\<close> \<open>\<pi> =\<^bsub>n\<^esub>  \<pi>'\<close> \<open>j \<le> n\<close> shows \<open>j cd\<^bsup>\<pi>'\<^esup>\<rightarrow>k\<close> by (metis assms cdi_path_swap eq_up_to_le)
 
 lemma not_cd_impl_ipd:  assumes \<open>is_path \<pi>\<close> and \<open>k < i\<close> and \<open>\<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> and \<open>\<pi> i \<noteq> return\<close> obtains j where \<open>j \<in> {k..i}\<close> and \<open>\<pi> j = ipd (\<pi> k)\<close>
 by (metis assms(1) assms(2) assms(3) assms(4) is_cdi_def)
 
 lemma icd_is_the_icd: assumes \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> shows \<open>k = (THE k. i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k)\<close> using assms icd_uniq 
   by (metis the1_equality)
 
 lemma all_ipd_imp_ret: assumes \<open>is_path \<pi>\<close> and \<open>\<forall> i. \<pi> i \<noteq> return \<longrightarrow> (\<exists> j>i. \<pi> j = ipd (\<pi> i))\<close> shows \<open>\<exists>j. \<pi> j = return\<close>
 proof - 
   { fix x assume *: \<open>\<pi> 0 = x\<close>
     have \<open>?thesis\<close> using wf_pdt_inv * assms  
     proof(induction \<open>x\<close> arbitrary: \<open>\<pi>\<close> rule: wf_induct_rule )
     case (less x \<pi>) show \<open>?case\<close> proof (cases \<open>x = return\<close>)
       case True thus \<open>?thesis\<close> using less(2) by auto
     next
       assume not_ret: \<open>x \<noteq> return\<close>
       moreover
       then obtain k where k_ipd: \<open>\<pi> k = ipd x\<close> using less(2,4) by auto
       moreover  
       have \<open>x \<in> nodes\<close> using less(2,3) by (metis path_nodes)
       ultimately 
       have \<open>(x, \<pi> k) \<in> pdt\<close> by (metis ipd_in_pdt)
       hence a: \<open>(\<pi> k, x) \<in> pdt_inv\<close> unfolding pdt_inv_def by simp     
       have b: \<open>is_path (\<pi> \<guillemotleft> k)\<close> by (metis less.prems(2) path_path_shift)    
       have c: \<open>\<forall> i. (\<pi>\<guillemotleft>k) i \<noteq> return \<longrightarrow> (\<exists>j>i. (\<pi>\<guillemotleft>k) j = ipd ((\<pi>\<guillemotleft>k) i))\<close> using less(4) apply auto
         by (metis (full_types) ab_semigroup_add_class.add_ac(1) less_add_same_cancel1 less_imp_add_positive)
       from less(1)[OF a _ b c]
       have \<open>\<exists>j. (\<pi>\<guillemotleft>k) j = return\<close> by auto    
       thus \<open>\<exists>j. \<pi> j = return\<close> by auto
     qed
     qed
   }
   thus \<open>?thesis\<close> by simp
 qed
 
 lemma loop_has_cd: assumes \<open>is_path \<pi>\<close> \<open>0 < i\<close> \<open>\<pi> i = \<pi> 0\<close> \<open>\<pi> 0 \<noteq> return\<close> shows \<open>\<exists> k < i. i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> proof (rule ccontr)
   let \<open>?\<pi>\<close> = \<open>(\<lambda> n. \<pi> (n mod i))\<close>  
   assume \<open>\<not> (\<exists>k<i. i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k)\<close>
   hence \<open>\<forall> k <i. \<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> by blast
   hence *: \<open>\<forall> k<i. (\<exists>j \<in> {k..i}. \<pi> j = ipd (\<pi> k))\<close> using assms(1,3,4) not_cd_impl_ipd by metis
   have \<open>\<forall> k. (\<exists> j > k. ?\<pi> j = ipd (?\<pi> k))\<close> proof 
     fix k
     have \<open>k mod i < i\<close> using assms(2) by auto
     with * obtain j where \<open>j \<in> {(k mod i)..i}\<close> \<open>\<pi> j = ipd (\<pi> (k mod i))\<close> by auto
     then obtain j' where 1: \<open>j' < i\<close> \<open>\<pi> j' = ipd (\<pi> (k mod i))\<close> 
       by (cases \<open>j = i\<close>, auto ,metis assms(2) assms(3),metis le_neq_implies_less)
     then obtain j'' where 2: \<open>j'' > k\<close> \<open>j'' mod i = j'\<close> by (metis mod_bound_instance)
     hence \<open>?\<pi> j'' = ipd (?\<pi> k)\<close> using 1 by auto
     with 2(1)
     show \<open>\<exists> j > k. ?\<pi> j = ipd (?\<pi> k)\<close> by auto
   qed
   moreover 
   have \<open>is_path ?\<pi>\<close> by (metis assms(1) assms(2) assms(3) is_path_loop)
   ultimately 
   obtain k where \<open>?\<pi> k = return\<close> by (metis (lifting) all_ipd_imp_ret)
   moreover 
   have \<open>k mod i < i\<close> by (simp add: assms(2)) 
   ultimately
   have \<open>\<pi> i = return\<close> by (metis assms(1) term_path_stable less_imp_le)
   thus \<open>False\<close> by (metis assms(3) assms(4))
 qed
 
 lemma loop_has_cd': assumes \<open>is_path \<pi>\<close> \<open>j < i\<close> \<open>\<pi> i = \<pi> j\<close> \<open>\<pi> j \<noteq> return\<close> shows \<open>\<exists> k \<in> {j..<i}. i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> 
 proof -
   have \<open>\<exists> k'< i-j. i-j cd\<^bsup>\<pi>\<guillemotleft>j\<^esup>\<rightarrow>k'\<close> 
     apply(rule loop_has_cd) 
     apply (metis assms(1) path_path_shift)
     apply (auto simp add: assms less_imp_le)
     done
   then obtain k where k: \<open>k<i-j\<close> \<open>i-j cd\<^bsup>\<pi>\<guillemotleft>j\<^esup>\<rightarrow>k\<close> by auto
   hence k': \<open>(k+j) < i\<close>  \<open>i-j cd\<^bsup>\<pi>\<guillemotleft>j\<^esup>\<rightarrow> (k+j)-j\<close>  by auto
   note cd_path_shift[OF _ assms(1)]
   hence \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k+j\<close> using k'(2) by (metis le_add1 add.commute)
   with k'(1) show \<open>?thesis\<close> by force
 qed  
 
 lemma claim'': assumes path\<pi>: \<open>is_path \<pi>\<close> and path\<pi>': \<open>is_path \<pi>'\<close> 
 and \<pi>i: \<open>\<pi> i = \<pi>' i'\<close> and \<pi>j: \<open>\<pi> j = \<pi>' j'\<close> 
 and not_cd:  \<open>\<forall> k. \<not> j cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close>  \<open>\<forall> k. \<not> i' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> k\<close> 
 and nret: \<open>\<pi> i \<noteq> return\<close>
 and ilj: \<open>i < j\<close>
 shows \<open>i' < j'\<close> proof (rule ccontr)
   assume \<open>\<not> i' < j'\<close>  
   hence jlei: \<open>j' \<le> i'\<close> by auto
   show \<open>False\<close> proof (cases)
   assume j'li': \<open>j' < i'\<close> 
   define \<pi>'' where \<open>\<pi>'' \<equiv> (\<pi>@\<^bsup>j\<^esup>(\<pi>'\<guillemotleft>j'))\<guillemotleft>i\<close>
   note \<pi>''_def[simp]
   have \<open>\<pi> j = (\<pi>' \<guillemotleft> j') 0\<close> by (metis path_shift_def Nat.add_0_right \<pi>j)
   hence \<open>is_path \<pi>''\<close> using path\<pi> path\<pi>' \<pi>''_def path_path_shift path_cons by presburger
   moreover 
   have \<open>\<pi>'' (j-i+(i'-j')) = \<pi>'' 0\<close>  using ilj jlei \<pi>i \<pi>j 
     by (auto, metis add_diff_cancel_left' le_antisym le_diff_conv le_eq_less_or_eq)
   moreover
   have \<open>\<pi>'' 0 \<noteq> return\<close> by (simp add: ilj less_or_eq_imp_le nret)
   moreover
   have \<open>0 < j-i+(i'-j')\<close> by (metis add_is_0 ilj neq0_conv zero_less_diff)
   ultimately obtain k where k: \<open>k < j-i+(i'-j')\<close> \<open>j-i+(i'-j') cd\<^bsup>\<pi>''\<^esup>\<rightarrow> k\<close>   by (metis loop_has_cd)
   hence *: \<open>\<forall> l \<in> {k..j-i+(i'-j')}. \<pi>'' l \<noteq> ipd (\<pi>'' k)\<close> by (metis is_cdi_def)
   show \<open>False\<close> proof (cases \<open>k < j-i\<close>)
     assume a: \<open>k < j - i\<close>
     hence b: \<open>\<pi>'' k = \<pi> (i + k)\<close> by auto
     have \<open>\<forall> l \<in> {i+k..j}. \<pi> l \<noteq> ipd (\<pi> (i+k))\<close> proof
       fix l assume l: \<open>l \<in> {i + k..j}\<close>
       hence \<open>\<pi> l = \<pi>'' (l - i)\<close> by auto
       moreover 
       from a l have \<open>l-i \<in> {k .. j-i + (i'-j')}\<close> by force
       ultimately show \<open>\<pi> l \<noteq> ipd (\<pi> (i + k))\<close> using * b by auto
     qed
     moreover 
     have \<open>i + k < j\<close> using a by simp
     moreover
     have \<open>\<pi> j \<noteq> return\<close> by (metis \<pi>i \<pi>j j'li' nret path\<pi>' term_path_stable less_imp_le) 
     ultimately
     have \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i+k\<close>  by (metis not_cd_impl_ipd path\<pi>)
     thus \<open>False\<close> by (metis not_cd(1))
   next
     assume \<open>\<not> k < j - i\<close>
     hence a: \<open>j - i \<le> k\<close> by simp
     hence b: \<open>\<pi>'' k = \<pi>' (j' + (i + k) - j)\<close> unfolding \<pi>''_def path_shift_def path_append_def using ilj 
       by(auto,metis \<pi>j add_diff_cancel_left' le_antisym le_diff_conv add.commute)
     have \<open>\<forall> l \<in> {j' + (i+k) - j..i'}. \<pi>' l \<noteq> ipd (\<pi>' (j' + (i+k) - j))\<close> proof
       fix l assume l: \<open>l \<in> {j' + (i+k) - j..i'}\<close>
       hence \<open>\<pi>' l = \<pi>'' (j + l - i - j')\<close> unfolding \<pi>''_def path_shift_def path_append_def using ilj
         by (auto, metis Nat.diff_add_assoc \<pi>j a add.commute add_diff_cancel_left' add_leD1 le_antisym le_diff_conv)
       moreover 
       from a l have \<open>j + l - i - j' \<in> {k .. j-i + (i'-j')}\<close> by force
       ultimately show \<open>\<pi>' l \<noteq> ipd (\<pi>' (j' + (i + k) - j))\<close> using * b by auto
     qed
     moreover 
     have \<open>j' + (i+k) - j < i'\<close> using a  j'li' ilj k(1) by linarith      
     moreover 
     have \<open>\<pi>' i' \<noteq> return\<close> by (metis \<pi>i nret)
     ultimately    
     have \<open>i' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j' + (i+k) - j\<close> by (metis not_cd_impl_ipd path\<pi>')
     thus \<open>False\<close> by (metis not_cd(2))
   qed
   next
   assume \<open>\<not> j' < i'\<close>
   hence \<open>j' = i'\<close> by (metis \<open>\<not> i' < j'\<close> linorder_cases)
   hence \<open>\<pi> i = \<pi> j\<close> by (metis \<pi>i \<pi>j)
   thus \<open>False\<close> by (metis ilj loop_has_cd' not_cd(1) nret path\<pi>)
 qed
 qed
 
 lemma other_claim': assumes path: \<open>is_path \<pi>\<close> and eq: \<open>\<pi> i = \<pi> j\<close> and \<open>\<pi> i \<noteq> return\<close> 
 and icd: \<open>\<forall> k. \<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> and \<open>\<forall> k. \<not> j cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> shows \<open>i = j\<close>  
 proof (rule ccontr,cases)
   assume \<open>i < j\<close> thus \<open>False\<close> using assms claim'' by blast
 next
   assume \<open>\<not> i < j\<close> \<open>i \<noteq> j\<close> 
   hence \<open>j < i\<close> by auto
   thus \<open>False\<close> using assms claim'' by (metis loop_has_cd')
 qed  
 
 lemma icd_no_cd_path_shift: assumes \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> 0\<close> shows \<open>(\<forall> k. \<not> i - 1 cd\<^bsup>\<pi>\<guillemotleft>1\<^esup>\<rightarrow> k)\<close> 
 proof (rule,rule ccontr,goal_cases)
   case (1 k)
   hence *: \<open>i - 1 cd\<^bsup>\<pi> \<guillemotleft> 1\<^esup>\<rightarrow> k\<close> by simp
   have **: \<open>1 \<le> k + 1\<close> by simp
   have ***: \<open>is_path \<pi>\<close> by (metis assms is_icdi_def)
   hence \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k+1\<close> using cd_path_shift[OF ** ***] * by auto
   moreover 
   hence \<open>k+1 < i\<close> unfolding is_cdi_def by simp
   moreover
   have \<open>0 < k + 1\<close> by simp
   ultimately show \<open>False\<close> using assms[unfolded is_icdi_def] by auto
 qed
 
 lemma claim': assumes path\<pi>: \<open>is_path \<pi>\<close> and path\<pi>': \<open>is_path \<pi>'\<close> and
   \<pi>i: \<open>\<pi> i = \<pi>' i'\<close> and \<pi>j: \<open>\<pi> j = \<pi>' j'\<close> and not_cd:
   \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> 0\<close> \<open>j icd\<^bsup>\<pi>\<^esup>\<rightarrow> 0\<close>
   \<open>i' icd\<^bsup>\<pi>'\<^esup>\<rightarrow> 0\<close> \<open>j' icd\<^bsup>\<pi>'\<^esup>\<rightarrow> 0\<close>
    and ilj: \<open>i < j\<close>
    and nret: \<open>\<pi> i \<noteq> return\<close>
   shows \<open>i' < j'\<close> 
 proof -
   have g0: \<open>0 < i\<close> \<open>0 < j\<close> \<open>0 < i'\<close> \<open>0 < j'\<close>using not_cd[unfolded is_icdi_def is_cdi_def] by auto
   have  \<open>(\<pi> \<guillemotleft> 1) (i - 1) = (\<pi>' \<guillemotleft> 1) (i' - 1)\<close> \<open>(\<pi> \<guillemotleft> 1) (j - 1) = (\<pi>' \<guillemotleft> 1) (j' - 1)\<close> using \<pi>i \<pi>j g0 by auto
   moreover
   have \<open>\<forall> k. \<not> (j - 1) cd\<^bsup>\<pi>\<guillemotleft>1\<^esup>\<rightarrow> k\<close> \<open>\<forall> k. \<not> (i' - 1) cd\<^bsup>\<pi>'\<guillemotleft>1\<^esup>\<rightarrow> k\<close> 
     by (metis icd_no_cd_path_shift not_cd(2)) (metis icd_no_cd_path_shift not_cd(3))
   moreover
   have \<open>is_path (\<pi>\<guillemotleft>1)\<close> \<open>is_path (\<pi>'\<guillemotleft>1)\<close> using path\<pi> path\<pi>' path_path_shift by blast+
   moreover 
   have \<open>(\<pi>\<guillemotleft>1) (i - 1) \<noteq> return\<close> using g0 nret by auto
   moreover 
   have \<open>i - 1 < j - 1\<close> using g0 ilj by auto
   ultimately have \<open>i' - 1 < j' - 1\<close> using claim'' by blast
   thus \<open>i'<j'\<close> by auto
 qed
 
 lemma other_claim: assumes path: \<open>is_path \<pi>\<close> and eq: \<open>\<pi> i = \<pi> j\<close> and \<open>\<pi> i \<noteq> return\<close> 
 and icd: \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> 0\<close> and \<open>j icd\<^bsup>\<pi>\<^esup>\<rightarrow> 0\<close> shows \<open>i = j\<close>  proof (rule ccontr,cases)
   assume \<open>i < j\<close> thus \<open>False\<close> using assms claim' by blast
 next
   assume \<open>\<not> i < j\<close> \<open>i \<noteq> j\<close> 
   hence \<open>j < i\<close> by auto
   thus \<open>False\<close> using assms claim' by (metis less_not_refl)
 qed
 
 lemma cd_trans0: assumes \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow> 0\<close> and \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow>j\<close> shows \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> 0\<close> proof (rule ccontr)    
   have path: \<open>is_path \<pi>\<close> and ij: \<open>0 < j\<close> and jk: \<open>j < k\<close> 
   and nret: \<open>\<pi> j \<noteq> return\<close> \<open>\<pi> k \<noteq> return\<close>
   and noipdi: \<open>\<forall> l \<in> {0..j}. \<pi> l \<noteq> ipd (\<pi> 0)\<close>
   and noipdj: \<open>\<forall> l \<in> {j..k}. \<pi> l \<noteq> ipd (\<pi> j)\<close>
   using assms unfolding is_cdi_def by auto
   assume \<open>\<not> k cd\<^bsup>\<pi>\<^esup>\<rightarrow> 0\<close>
   hence \<open>\<exists>l \<in> {0..k}. \<pi> l = ipd (\<pi> 0)\<close> unfolding is_cdi_def using path ij jk nret by force
   then obtain l where \<open>l \<in> {0..k}\<close> and l: \<open>\<pi> l = ipd (\<pi> 0)\<close> by auto
   hence jl: \<open>j<l\<close> and lk: \<open>l\<le>k\<close> using noipdi ij by auto
   have pdj: \<open>ipd (\<pi> 0) pd\<rightarrow> \<pi> j\<close> proof (rule ccontr)    
     have \<open>\<pi> j \<in> nodes\<close> using path by (metis path_nodes)
     moreover 
     assume \<open>\<not> ipd (\<pi> 0) pd\<rightarrow> \<pi> j\<close>
     ultimately
     obtain \<pi>' n where *: \<open>is_path \<pi>'\<close> \<open>\<pi>' 0 = \<pi> j\<close> \<open>\<pi>' n = return\<close> \<open>\<forall> k\<le>n. \<pi>' k \<noteq> ipd(\<pi> 0)\<close> using no_pd_path by metis
     hence path': \<open>is_path (\<pi> @\<^bsup>j\<^esup>  \<pi>')\<close> by (metis path path_cons) 
     moreover
     have \<open>\<forall> k \<le> j + n. (\<pi>@\<^bsup>j\<^esup>  \<pi>') k \<noteq> ipd (\<pi> 0)\<close> using noipdi *(4) by auto
     moreover 
     have \<open>(\<pi>@\<^bsup>j\<^esup>  \<pi>') 0 = \<pi> 0\<close> by auto
     moreover
     have \<open>(\<pi>@\<^bsup>j\<^esup>  \<pi>') (j + n) = return\<close> using *(2,3) by auto
     ultimately
     have \<open>\<not> ipd (\<pi> 0) pd\<rightarrow> \<pi> 0\<close> unfolding is_pd_def by metis
     thus \<open>False\<close> by (metis is_ipd_def ij ipd_is_ipd nret(1) path path_nodes term_path_stable less_imp_le)
   qed
   hence \<open>(\<pi>\<guillemotleft>j) (l-j) pd\<rightarrow> (\<pi>\<guillemotleft>j) 0\<close> using jl l by auto
   moreover
   have \<open>is_path (\<pi>\<guillemotleft>j)\<close> by (metis path path_path_shift)
   moreover
   have \<open>\<pi> l \<noteq> return\<close> by (metis lk nret(2) path term_path_stable)
   hence \<open>(\<pi>\<guillemotleft>j) (l-j) \<noteq> return\<close> using jl by auto
   moreover 
   have \<open>\<pi> j \<noteq> ipd (\<pi> 0)\<close> using noipdi by force
   hence \<open>(\<pi>\<guillemotleft>j) (l-j) \<noteq> (\<pi>\<guillemotleft>j) 0\<close> using jl l by auto
   ultimately
   obtain k' where \<open>k' \<le> l-j\<close> and \<open>(\<pi>\<guillemotleft>j) k' = ipd ((\<pi>\<guillemotleft>j) 0)\<close> using path_pd_ipd0' by blast
   hence \<open>j + k' \<in> {j..k}\<close> \<open>\<pi> (j+k') = ipd (\<pi> j)\<close> using jl lk by auto
   thus \<open>False\<close> using noipdj by auto
 qed
 
 lemma cd_trans: assumes \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i\<close> and \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow>j\<close> shows \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i\<close> proof -
   have path: \<open>is_path \<pi>\<close> using assms is_cdi_def by auto
   have ij: \<open>i<j\<close> using assms is_cdi_def by auto
   let \<open>?\<pi>\<close> = \<open>\<pi>\<guillemotleft>i\<close>
   have \<open>j-i cd\<^bsup>?\<pi>\<^esup>\<rightarrow> 0\<close> using assms(1) cd_path_shift0 path by auto
   moreover
   have \<open>k-i cd\<^bsup>?\<pi>\<^esup>\<rightarrow>j-i\<close> by (metis assms(2) cd_path_shift is_cdi_def ij less_imp_le_nat)
   ultimately
   have \<open>k-i cd\<^bsup>?\<pi>\<^esup>\<rightarrow> 0\<close> using cd_trans0 by auto
   thus \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i\<close> using path cd_path_shift0 by auto
 qed
 
 lemma excd_impl_exicd: assumes \<open>\<exists> k. i cd\<^bsup>\<pi>\<^esup>\<rightarrow>k\<close> shows \<open>\<exists> k. i icd\<^bsup>\<pi>\<^esup>\<rightarrow>k\<close> 
 using assms proof(induction \<open>i\<close> arbitrary: \<open>\<pi>\<close> rule: less_induct)
   case (less i) 
   then obtain k where k: \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow>k\<close> by auto
   hence ip: \<open>is_path \<pi>\<close> unfolding is_cdi_def by auto
   show \<open>?case\<close> proof (cases)
     assume *: \<open>\<forall> m \<in> {k<..<i}. \<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close>
     hence \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow>k\<close> using k ip unfolding is_icdi_def by auto
     thus \<open>?case\<close> by auto
   next
     assume \<open>\<not> (\<forall> m \<in> {k<..<i}. \<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> m)\<close>
     then obtain m where m: \<open>m \<in> {k<..<i}\<close> \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> by blast
     hence \<open>i - m cd\<^bsup>\<pi>\<guillemotleft>m\<^esup>\<rightarrow> 0\<close> by (metis cd_path_shift0 is_cdi_def)
     moreover 
     have \<open>i - m < i\<close> using m by auto
     ultimately
     obtain k' where k': \<open>i - m icd\<^bsup>\<pi>\<guillemotleft>m\<^esup>\<rightarrow> k'\<close> using less(1) by blast
     hence \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k' + m\<close> using ip 
     by (metis add.commute add_diff_cancel_right' icd_path_shift le_add1)
     thus \<open>?case\<close> by auto
   qed
 qed
 
 lemma cd_split: assumes \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> and \<open>\<not> i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> obtains m where \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> and \<open>m cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> 
 proof -
   have ki: \<open>k < i\<close> using assms is_cdi_def by auto
   obtain m where m: \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> using assms(1) by (metis excd_impl_exicd)
   hence \<open>k \<le> m\<close> unfolding is_icdi_def using ki assms(1) by force
   hence km: \<open>k < m\<close>using m assms(2) by (metis le_eq_less_or_eq)
   moreover have \<open>\<pi> m \<noteq> return\<close> using m unfolding is_icdi_def is_cdi_def by (simp, metis term_path_stable less_imp_le)
   moreover have \<open>m<i\<close> using m unfolding is_cdi_def is_icdi_def by auto
   ultimately 
   have \<open>m cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> using assms(1) unfolding is_cdi_def by auto
   with m that show \<open>thesis\<close> by auto
 qed
 
 lemma cd_induct[consumes 1, case_names base IS]: assumes prem: \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> and base: \<open>\<And> i. i icd\<^bsup>\<pi>\<^esup>\<rightarrow>k \<Longrightarrow> P i\<close> 
 and IH: \<open>\<And> k' i'. k' cd\<^bsup>\<pi>\<^esup>\<rightarrow> k \<Longrightarrow> P k' \<Longrightarrow> i' icd\<^bsup>\<pi>\<^esup>\<rightarrow> k' \<Longrightarrow> P i'\<close> shows \<open>P i\<close> 
 using prem IH proof (induction \<open>i\<close> rule: less_induct,cases)
   case (less i) 
   assume \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close>
   thus \<open>P i\<close> using base by simp
 next
   case (less i')
   assume \<open>\<not> i' icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close>
   then obtain k' where k': \<open> i' icd\<^bsup>\<pi>\<^esup>\<rightarrow> k'\<close> \<open>k' cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> using less cd_split by blast
   hence icdk: \<open>i' cd\<^bsup>\<pi>\<^esup>\<rightarrow> k'\<close> using is_icdi_def by auto
   note ih=less(3)[OF k'(2)  _ k'(1)]
   have ki: \<open>k' < i'\<close> using k' is_icdi_def is_cdi_def by auto
   have \<open>P k'\<close> using less(1)[OF ki k'(2) ] less(3) by auto
   thus \<open>P i'\<close> using ih by simp
 qed
 
 lemma cdi_prefix: \<open>n cd\<^bsup>\<pi>\<^esup>\<rightarrow> m \<Longrightarrow> m < n' \<Longrightarrow> n' \<le> n \<Longrightarrow> n' cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close>  unfolding is_cdi_def 
   by (simp, metis term_path_stable)
 
 lemma cr_wn': assumes 1: \<open>n cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> and nc: \<open>\<not> m' cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> and 3: \<open>m < m'\<close> shows \<open>n < m'\<close>
 proof (rule ccontr)
   assume \<open>\<not> n < m'\<close>
   hence \<open>m' \<le> n\<close> by simp  
   hence \<open>m' cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> by (metis 1 3 cdi_prefix)
   thus \<open>False\<close> using nc by simp
 qed
 
 lemma cr_wn'': assumes \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> and \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close> and \<open>\<not> m cd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close> and  \<open>i \<le> j\<close> shows \<open>m \<le> n\<close> proof (rule ccontr) 
   assume \<open>\<not>m\<le>n\<close>
   hence nm: \<open>n < m\<close> by auto
   moreover 
   have \<open>m<j\<close> using assms(1) assms(4) unfolding is_cdi_def by auto
   ultimately 
   have \<open>m cd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close> using assms(2) cdi_prefix by auto
   thus \<open>False\<close> using assms(3) by auto
 qed
 
 lemma ret_no_cd: assumes \<open>\<pi> n = return\<close> shows \<open>\<not> n cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> by (metis assms is_cdi_def)
 
 lemma ipd_not_self: assumes \<open>x \<in> nodes\<close> \<open>x\<noteq> return\<close> shows \<open>x \<noteq> ipd x\<close> by (metis is_ipd_def assms ipd_is_ipd)
 
 lemma icd_cs: assumes \<open>l icd\<^bsup>\<pi>\<^esup>\<rightarrow>k\<close> shows \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>\<^esup> k @ [\<pi> l]\<close>
 proof -
   from assms have \<open>k = (THE k. l icd\<^bsup>\<pi>\<^esup>\<rightarrow> k)\<close> by (metis icd_is_the_icd)
   with assms show \<open>?thesis\<close> by auto
 qed
 
 lemma cd_not_pd: assumes \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> \<open>\<pi> l \<noteq> \<pi> k\<close> shows \<open>\<not> \<pi> l pd\<rightarrow> \<pi> k\<close> proof
   assume pd: \<open>\<pi> l pd\<rightarrow> \<pi> k\<close>
   have nret: \<open>\<pi> k \<noteq> return\<close> by (metis assms(1) pd pd_ret_is_ret ret_no_cd)
   have kl: \<open>k < l\<close> by (metis is_cdi_def assms(1))
   have path: \<open>is_path \<pi>\<close> by (metis is_cdi_def assms(1))
   from path_pd_ipd[OF path nret assms(2) pd kl]
   obtain n where \<open>k < n\<close> \<open>n \<le> l\<close> \<open>\<pi> n = ipd (\<pi> k)\<close> .
   thus \<open>False\<close> using assms(1) unfolding is_cdi_def by auto
 qed
 
 lemma cd_ipd_is_cd: assumes \<open>k<m\<close> \<open>\<pi> m = ipd (\<pi> k)\<close> \<open>\<forall> n \<in> {k..<m}. \<pi> n \<noteq> ipd (\<pi> k)\<close> and mcdj: \<open>m cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> shows \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> proof cases
   assume \<open>j < k\<close> thus \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> by (metis mcdj assms(1) cdi_prefix less_imp_le_nat)
 next
   assume \<open>\<not> j < k\<close>
   hence kj: \<open>k \<le> j\<close> by simp 
   have \<open>k < j\<close> apply (rule ccontr) using kj assms mcdj by (auto, metis is_cdi_def is_ipd_def cd_not_pd ipd_is_ipd path_nodes term_path_stable less_imp_le)
   moreover 
   have \<open>j < m\<close> using mcdj is_cdi_def by auto
   hence \<open>\<forall> n \<in> {k..j}. \<pi> n \<noteq> ipd(\<pi> k)\<close> using assms(3) by force
   ultimately
   have \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> by (metis mcdj is_cdi_def term_path_stable less_imp_le)
   hence \<open>m cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> by (metis mcdj cd_trans)
   hence \<open>False\<close> by (metis is_cdi_def is_ipd_def assms(2) cd_not_pd ipd_is_ipd path_nodes term_path_stable less_imp_le)
   thus \<open>?thesis\<close> by simp
 qed
 
 lemma ipd_pd_cd0: assumes lcd: \<open>n cd\<^bsup>\<pi>\<^esup>\<rightarrow> 0\<close> shows \<open>ipd (\<pi> 0) pd\<rightarrow> (\<pi> n)\<close> 
 proof -
   obtain k l where \<pi>0: \<open>\<pi> 0 = k\<close> and \<pi>n: \<open>\<pi> n = l\<close> and cdi: \<open>n cd\<^bsup>\<pi>\<^esup>\<rightarrow> 0\<close> using lcd unfolding is_cdi_def by blast
   have nret: \<open>k \<noteq> return\<close> by (metis is_cdi_def \<pi>0 cdi term_path_stable less_imp_le)
   have  path: \<open>is_path \<pi>\<close> and ipd: \<open>\<forall> i\<le>n. \<pi> i \<noteq> ipd k\<close> using cdi unfolding is_cdi_def \<pi>0 by auto
   {
     fix \<pi>' n'
     assume path': \<open>is_path \<pi>'\<close>
     and \<pi>'0: \<open>\<pi>' 0 = l\<close>
     and ret: \<open>\<pi>' n' = return\<close>
     have \<open>is_path (\<pi> @\<^bsup>n\<^esup>  \<pi>')\<close> using path path' \<pi>n \<pi>'0 by (metis path_cons)
     moreover
     have \<open>(\<pi> @\<^bsup>n\<^esup>  \<pi>') (n+n') = return\<close> using ret \<pi>n \<pi>'0 by auto
     moreover
     have \<open>(\<pi> @\<^bsup>n\<^esup>  \<pi>') 0 = k\<close> using \<pi>0 by auto
     moreover    
     have \<open>ipd k pd\<rightarrow> k\<close> by (metis is_ipd_def path \<pi>0 ipd_is_ipd nret path_nodes)
     ultimately
     obtain k' where k': \<open>k' \<le> n+n'\<close> \<open>(\<pi> @\<^bsup>n\<^esup>  \<pi>') k' = ipd k\<close> by (metis pd_intro)
     have \<open>\<not> k'\<le> n\<close> proof 
       assume \<open>k' \<le> n\<close> 
       hence \<open>(\<pi> @\<^bsup>n\<^esup>  \<pi>') k' = \<pi> k'\<close> by auto
       thus \<open>False\<close> using k'(2) ipd by (metis \<open>k' \<le> n\<close>)
     qed
     hence \<open>(\<pi> @\<^bsup>n\<^esup>  \<pi>') k' = \<pi>' (k' - n)\<close> by auto
     moreover 
     have \<open>(k' - n) \<le> n'\<close> using k' by simp
     ultimately
     have \<open>\<exists> k'\<le>n'. \<pi>' k' = ipd k\<close> unfolding k' by auto
   }
   moreover
   have \<open>l \<in> nodes\<close> by (metis \<pi>n path path_nodes)
   ultimately show \<open>ipd (\<pi> 0) pd\<rightarrow> (\<pi> n)\<close> unfolding is_pd_def  by (simp add: \<pi>0 \<pi>n) 
 qed
 
 lemma ipd_pd_cd: assumes lcd: \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> shows \<open>ipd (\<pi> k) pd\<rightarrow> (\<pi> l)\<close> 
 proof - 
   have \<open>l-k cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow>0\<close> using lcd cd_path_shift0 is_cdi_def by blast 
   moreover
   note ipd_pd_cd0[OF this]
   moreover 
   have \<open>(\<pi> \<guillemotleft> k) 0 = \<pi> k\<close> by auto
   moreover
   have \<open>k < l\<close> using lcd unfolding is_cdi_def by simp
   then have \<open>(\<pi> \<guillemotleft> k) (l - k) = \<pi> l\<close> by simp 
   ultimately show \<open>?thesis\<close> by simp
 qed
 
 lemma cd_is_cd_ipd: assumes km: \<open>k<m\<close> and ipd: \<open>\<pi> m = ipd (\<pi> k)\<close> \<open>\<forall> n \<in> {k..<m}. \<pi> n \<noteq> ipd (\<pi> k)\<close> and cdj: \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> and nipdj: \<open>ipd (\<pi> j) \<noteq> \<pi> m\<close> shows \<open>m cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> proof -
   have path: \<open>is_path \<pi>\<close> 
   and jk: \<open>j < k\<close> 
   and nretj: \<open>\<pi> k \<noteq> return\<close> 
   and nipd: \<open>\<forall> l \<in> {j..k}. \<pi> l \<noteq> ipd (\<pi> j)\<close> using  cdj is_cdi_def by auto
   have pd: \<open>ipd (\<pi> j) pd\<rightarrow> \<pi> m\<close> by (metis atLeastAtMost_iff cdj ipd(1) ipd_pd_cd jk le_refl less_imp_le nipd nretj path path_nodes pd_pd_ipd)  
   have nretm: \<open>\<pi> m \<noteq> return\<close> by (metis nipdj pd pd_ret_is_ret)
   have jm: \<open>j < m\<close> using jk km by simp
   show \<open>m cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> proof (rule ccontr)
     assume ncdj: \<open>\<not> m cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close>     
     hence \<open>\<exists> l \<in> {j..m}. \<pi> l = ipd (\<pi> j)\<close> unfolding is_cdi_def by (metis jm nretm path)
     then obtain l 
     where jl: \<open>j \<le> l\<close> and \<open>l \<le> m\<close> 
     and lipd: \<open>\<pi> l = ipd (\<pi> j)\<close> by force
     hence lm: \<open>l < m\<close> using nipdj by (metis le_eq_less_or_eq)
     have npd: \<open>\<not> ipd (\<pi> k) pd\<rightarrow> \<pi> l\<close> by (metis ipd(1) lipd nipdj pd pd_antisym)
     have nd: \<open>\<pi> l \<in> nodes\<close> using path path_nodes by simp
     from no_pd_path[OF nd npd]
     obtain \<pi>' n where path': \<open>is_path \<pi>'\<close> and \<pi>'0: \<open>\<pi>' 0 = \<pi> l\<close> and \<pi>'n: \<open>\<pi>' n = return\<close> and nipd: \<open>\<forall> ka\<le>n. \<pi>' ka \<noteq> ipd (\<pi> k)\<close> .
     let \<open>?\<pi>\<close> = \<open>(\<pi>@\<^bsup>l\<^esup> \<pi>') \<guillemotleft> k\<close>
     have path'': \<open>is_path ?\<pi>\<close> by (metis \<pi>'0 path path' path_cons path_path_shift)
     moreover
     have kl: \<open>k < l\<close> using lipd cdj jl unfolding is_cdi_def by fastforce    
     have \<open>?\<pi> 0 = \<pi> k\<close> using kl by auto
     moreover
     have \<open>?\<pi> (l + n - k) = return\<close> using \<pi>'n \<pi>'0 kl by auto
     moreover
     have \<open>ipd (\<pi> k) pd\<rightarrow> \<pi> k\<close> by (metis is_ipd_def ipd_is_ipd nretj path path_nodes)
     ultimately
     obtain l' where l': \<open>l' \<le> (l + n - k)\<close> \<open>?\<pi> l' = ipd (\<pi> k)\<close> unfolding is_pd_def by blast
     show \<open>False\<close> proof (cases )
       assume *: \<open>k + l' \<le> l\<close>
       hence \<open>\<pi> (k + l') = ipd (\<pi> k)\<close> using l' by auto
       moreover 
       have \<open>k + l' < m\<close> by (metis "*" dual_order.strict_trans2 lm)
       ultimately
       show \<open>False\<close> using ipd(2) by simp
     next
       assume \<open>\<not> k + l' \<le> l\<close>
       hence \<open>\<pi>' (k + l' - l) = ipd (\<pi> k)\<close> using l' by auto
       moreover
       have \<open>k + l' - l \<le> n\<close> using l' kl by linarith  
       ultimately 
       show \<open>False\<close> using nipd by auto
     qed
   qed
 qed
 
 lemma ipd_icd_greatest_cd_not_ipd: assumes ipd: \<open>\<pi> m = ipd (\<pi> k)\<close> \<open>\<forall> n \<in> {k..<m}. \<pi> n \<noteq> ipd (\<pi> k)\<close>
 and km: \<open>k < m\<close> and icdj: \<open>m icd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> shows \<open>j = (GREATEST j. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> ipd (\<pi> j) \<noteq> \<pi> m)\<close>
 proof -
   let \<open>?j\<close> = \<open>GREATEST j. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> ipd (\<pi> j) \<noteq> \<pi> m\<close>
   have kcdj: \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> using assms cd_ipd_is_cd is_icdi_def by blast   
   have nipd: \<open>ipd (\<pi> j) \<noteq> \<pi> m\<close> using icdj unfolding is_icdi_def is_cdi_def by auto
   have bound: \<open>\<And> j. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> ipd (\<pi> j) \<noteq> \<pi> m \<Longrightarrow> j \<le> k\<close> unfolding is_cdi_def by simp
   have exists: \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> ipd (\<pi> j) \<noteq> \<pi> m\<close> (is \<open>?P j\<close>) using kcdj nipd by auto
   note GreatestI_nat[of \<open>?P\<close> _ \<open>k\<close>, OF exists] Greatest_le_nat[of \<open>?P\<close> \<open>j\<close> \<open>k\<close>, OF exists]
   hence kcdj': \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> ?j\<close> and ipd': \<open>ipd (\<pi> ?j) \<noteq> \<pi> m\<close> and jj: \<open>j \<le> ?j\<close> using bound by auto
   hence mcdj': \<open>m cd\<^bsup>\<pi>\<^esup>\<rightarrow> ?j\<close> using ipd km cd_is_cd_ipd by auto
   show \<open>j = ?j\<close> proof (rule ccontr)
     assume \<open>j \<noteq> ?j\<close>
     hence jlj: \<open>j < ?j\<close> using jj by simp
     moreover 
     have \<open>?j < m\<close> using kcdj' km unfolding is_cdi_def by auto
     ultimately
     show \<open>False\<close> using icdj mcdj' unfolding is_icdi_def by auto
   qed
 qed
 
 lemma cd_impl_icd_cd: assumes \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> l\<close> and \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> and \<open>\<not> i icd\<^bsup>\<pi>\<^esup>\<rightarrow> l\<close> shows \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> l\<close>
   using assms cd_split icd_uniq by metis
 
 lemma cdi_is_cd_icdi: assumes \<open>k icd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> shows \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<longleftrightarrow> j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<or> i = j\<close> 
   by (metis assms cd_impl_icd_cd cd_trans icd_imp_cd icd_uniq)
 
 lemma same_ipd_stable: assumes \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i\<close> \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> \<open>i<j\<close> \<open>ipd (\<pi> i) = ipd (\<pi> k)\<close> shows \<open>ipd (\<pi> j) = ipd (\<pi> k)\<close>
 proof -
   have jcdi: \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i\<close> by (metis is_cdi_def assms(1,2,3) cr_wn' le_antisym less_imp_le_nat)
   have 1: \<open>ipd (\<pi> j) pd\<rightarrow> \<pi> k \<close> by (metis assms(2) ipd_pd_cd)
   have 2: \<open>ipd (\<pi> k) pd\<rightarrow> \<pi> j \<close> by (metis assms(4) ipd_pd_cd jcdi)
   have 3: \<open>ipd (\<pi> k) pd\<rightarrow> (ipd (\<pi> j))\<close>  by (metis 2 IFC_def.is_cdi_def assms(1,2,4) atLeastAtMost_iff jcdi less_imp_le pd_node2 pd_pd_ipd) 
   have 4: \<open>ipd (\<pi> j) pd\<rightarrow> (ipd (\<pi> k))\<close> by (metis 1 2 IFC_def.is_ipd_def assms(2) cd_not_pd ipd_is_ipd jcdi pd_node2 ret_no_cd) 
   show \<open>?thesis\<close> using 3 4 pd_antisym by simp
 qed
 
 lemma icd_pd_intermediate': assumes icd: \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close>  and j: \<open>k < j\<close> \<open>j < i\<close> shows \<open>\<pi> i pd\<rightarrow> (\<pi> j)\<close>
 using j proof (induction \<open>i - j\<close> arbitrary: \<open>j\<close> rule: less_induct)
   case (less j)
   have \<open>\<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> using less.prems icd unfolding is_icdi_def by force
   moreover 
   have \<open>is_path \<pi>\<close> using icd by (metis is_icdi_def)
   moreover 
   have \<open>\<pi> i \<noteq> return\<close> using icd by (metis is_icdi_def ret_no_cd)
   ultimately
   have \<open>\<exists> l. j \<le> l \<and> l \<le> i \<and> \<pi> l = ipd (\<pi> j)\<close> unfolding is_cdi_def using less.prems by auto
   then obtain l where l: \<open>j \<le> l\<close> \<open>l \<le> i\<close> \<open>\<pi> l = ipd (\<pi> j)\<close> by blast
   hence lpd: \<open>\<pi> l pd\<rightarrow> (\<pi> j)\<close> by (metis is_ipd_def \<open>\<pi> i \<noteq> return\<close> \<open>is_path \<pi>\<close> ipd_is_ipd path_nodes term_path_stable)
   show \<open>?case\<close> proof (cases)
     assume \<open>l = i\<close>
     thus \<open>?case\<close> using lpd by auto
   next
     assume \<open>l \<noteq> i\<close>
     hence \<open>l < i\<close> using l by simp
     moreover
     have \<open>j \<noteq> l\<close> using l by (metis is_ipd_def \<open>\<pi> i \<noteq> return\<close> \<open>is_path \<pi>\<close> ipd_is_ipd path_nodes term_path_stable)
     hence \<open>j < l\<close> using l by simp
     moreover 
     hence \<open>i - l < i - j\<close> by (metis diff_less_mono2 less.prems(2))
     moreover
     have \<open>k < l\<close> by (metis l(1) less.prems(1) linorder_neqE_nat not_le order.strict_trans)
     ultimately
     have \<open>\<pi> i pd\<rightarrow> (\<pi> l)\<close> using less.hyps by auto
     thus \<open>?case\<close> using lpd by (metis pd_trans)
   qed
 qed
 
 lemma icd_pd_intermediate: assumes icd: \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close>  and j: \<open>k < j\<close> \<open>j \<le> i\<close> shows \<open>\<pi> i pd\<rightarrow> (\<pi> j)\<close> 
 using assms icd_pd_intermediate'[OF assms(1,2)] apply (cases \<open>j < i\<close>,metis) by (metis is_icdi_def le_neq_trans path_nodes pd_refl)
 
 lemma no_icd_pd: assumes path: \<open>is_path \<pi>\<close> and noicd: \<open>\<forall> l\<ge>n. \<not> k icd\<^bsup>\<pi>\<^esup>\<rightarrow> l\<close> and nk: \<open>n \<le> k\<close> shows \<open>\<pi> k pd\<rightarrow> \<pi> n\<close>
 proof cases
   assume \<open>\<pi> k = return\<close> thus \<open>?thesis\<close> by (metis path path_nodes return_pd)  
 next
   assume nret: \<open>\<pi> k \<noteq> return\<close>
   have nocd: \<open>\<And> l. n\<le>l \<Longrightarrow> \<not> k cd\<^bsup>\<pi>\<^esup>\<rightarrow> l\<close> proof 
     fix l assume kcd: \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> l\<close> and nl: \<open>n \<le> l\<close>
     hence \<open>(k - n) cd\<^bsup>\<pi>\<guillemotleft>n\<^esup>\<rightarrow> (l - n)\<close> using cd_path_shift[OF nl path] by simp
     hence \<open>\<exists> l. (k - n) icd\<^bsup>\<pi>\<guillemotleft>n\<^esup>\<rightarrow> l\<close> using excd_impl_exicd by blast
-    then guess l' ..
+    then obtain l' where "k - n icd\<^bsup>\<pi> \<guillemotleft> n\<^esup>\<rightarrow> l'" ..
     hence \<open>k icd\<^bsup>\<pi>\<^esup>\<rightarrow> (l' + n)\<close> using icd_path_shift[of \<open>n\<close> \<open>l' + n\<close> \<open>\<pi>\<close> \<open>k\<close>] path by auto
     thus \<open>False\<close> using noicd by auto
   qed    
   hence \<open>\<And>l. n \<le> l \<Longrightarrow> l<k \<Longrightarrow> \<exists> j \<in> {l..k}. \<pi> j = ipd (\<pi> l)\<close> using path nret unfolding is_cdi_def by auto 
   thus \<open>?thesis\<close> using nk proof (induction \<open>k - n\<close> arbitrary: \<open>n\<close> rule: less_induct,cases)
     case (less n) 
     assume \<open>n = k\<close>
     thus \<open>?case\<close> using pd_refl path path_nodes by auto
   next
     case (less n)
     assume \<open>n \<noteq> k\<close>
     hence nk: \<open>n < k\<close> using less(3) by auto
     with less(2) obtain j where jnk: \<open>j \<in> {n..k}\<close> and ipdj: \<open>\<pi> j = ipd (\<pi> n)\<close> by blast
     have nretn: \<open>\<pi> n \<noteq> return\<close> using nk nret term_path_stable path by auto
     with ipd_is_ipd path path_nodes is_ipd_def ipdj
     have jpdn: \<open>\<pi> j pd\<rightarrow> \<pi> n\<close> by auto
     show \<open>?case\<close> proof cases
       assume \<open>j = k\<close> thus \<open>?case\<close> using jpdn by simp
     next
       assume \<open>j \<noteq> k\<close>
       hence jk: \<open>j < k\<close> using jnk by auto
       have \<open>j \<noteq> n\<close> using ipdj by (metis ipd_not_self nretn path path_nodes)
       hence nj: \<open>n < j\<close> using jnk by auto
       have *: \<open>k - j < k - n\<close> using jk nj by auto
       
       with less(1)[OF *] less(2) jk nj
       have \<open>\<pi> k pd\<rightarrow> \<pi> j\<close> by auto
 
       thus \<open>?thesis\<close> using jpdn pd_trans by metis
     qed
   qed
 qed
 
 
 lemma first_pd_no_cd: assumes path: \<open>is_path \<pi>\<close> and pd: \<open>\<pi> n pd\<rightarrow> \<pi> 0\<close> and first: \<open>\<forall> l < n. \<pi> l \<noteq> \<pi> n\<close> shows \<open>\<forall> l. \<not> n cd\<^bsup>\<pi>\<^esup>\<rightarrow> l\<close> 
 proof (rule ccontr, goal_cases)
   case 1
   then obtain l where ncdl: \<open>n cd\<^bsup>\<pi>\<^esup>\<rightarrow> l\<close> by blast
   hence ln: \<open>l < n\<close> using is_cdi_def by auto
   have \<open>\<not> \<pi> n pd\<rightarrow> \<pi> l\<close> using ncdl cd_not_pd by (metis ln first)
   then obtain \<pi>' n' where path': \<open>is_path \<pi>'\<close> and \<pi>0: \<open>\<pi>' 0 = \<pi> l\<close> and \<pi>n: \<open>\<pi>' n' = return\<close> and not\<pi>n: \<open>\<forall> j\<le> n'. \<pi>' j \<noteq> \<pi> n\<close> unfolding is_pd_def using path path_nodes by auto
   let \<open>?\<pi>\<close> = \<open>\<pi>@\<^bsup>l\<^esup> \<pi>'\<close>
   
   have \<open>is_path ?\<pi>\<close> by (metis \<pi>0 path path' path_cons)
   moreover
   have \<open>?\<pi> 0 = \<pi> 0\<close> by auto
   moreover
   have \<open>?\<pi> (n' + l) = return\<close> using \<pi>0 \<pi>n by auto
   ultimately
   obtain j where j: \<open>j \<le> n' + l\<close> and jn: \<open>?\<pi> j = \<pi> n\<close> using pd unfolding is_pd_def by blast
   show \<open>False\<close> proof cases
     assume \<open>j \<le> l\<close> thus \<open>False\<close> using jn first ln by auto
   next
     assume \<open>\<not> j \<le> l\<close> thus \<open>False\<close> using j jn not\<pi>n by auto
   qed
 qed
 
 lemma first_pd_no_icd: assumes path: \<open>is_path \<pi>\<close> and pd: \<open>\<pi> n pd\<rightarrow> \<pi> 0\<close> and first: \<open>\<forall> l < n. \<pi> l \<noteq> \<pi> n\<close> shows \<open>\<forall> l. \<not> n icd\<^bsup>\<pi>\<^esup>\<rightarrow> l\<close>
   by (metis first first_pd_no_cd icd_imp_cd path pd)
 
 lemma path_nret_ex_nipd: assumes \<open>is_path \<pi>\<close> \<open>\<forall> i. \<pi> i \<noteq> return\<close> shows \<open>\<forall> i. (\<exists> j\<ge>i. (\<forall> k>j. \<pi> k \<noteq> ipd (\<pi> j)))\<close> proof(rule, rule ccontr)
   fix i
   assume \<open>\<not> (\<exists>j\<ge>i. \<forall> k>j. \<pi> k \<noteq> ipd (\<pi> j))\<close>
   hence *: \<open>\<forall> j\<ge>i. (\<exists>k>j. \<pi> k = ipd (\<pi> j))\<close> by blast
   have \<open>\<forall> j. (\<exists>k>j. (\<pi>\<guillemotleft>i) k = ipd ((\<pi>\<guillemotleft>i) j))\<close> proof
     fix j
     have \<open>i + j \<ge> i\<close> by auto
     then obtain k where k: \<open>k>i+j\<close> \<open>\<pi> k = ipd (\<pi> (i+j))\<close> using * by blast
     hence \<open>(\<pi>\<guillemotleft>i) (k - i) = ipd ((\<pi>\<guillemotleft>i) j)\<close> by auto
     moreover  
     have \<open>k - i > j\<close> using k by auto
     ultimately
     show \<open>\<exists>k>j. (\<pi>\<guillemotleft>i) k = ipd ((\<pi>\<guillemotleft>i) j)\<close> by auto
   qed
   moreover
   have \<open>is_path (\<pi>\<guillemotleft>i)\<close> using assms(1) path_path_shift by simp
   ultimately
   obtain k where \<open>(\<pi>\<guillemotleft>i) k = return\<close> using all_ipd_imp_ret by blast
   thus \<open>False\<close> using assms(2) by auto
 qed
 
 lemma path_nret_ex_all_cd: assumes \<open>is_path \<pi>\<close> \<open>\<forall> i. \<pi> i \<noteq> return\<close> shows \<open>\<forall> i. (\<exists> j\<ge>i. (\<forall> k>j. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j))\<close>
 unfolding is_cdi_def using assms path_nret_ex_nipd[OF assms] by (metis atLeastAtMost_iff ipd_not_self linorder_neqE_nat not_le path_nodes)
 
 
 lemma path_nret_inf_all_cd: assumes \<open>is_path \<pi>\<close> \<open>\<forall> i. \<pi> i \<noteq> return\<close> shows \<open>\<not> finite {j. \<forall> k>j. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j}\<close> 
 using unbounded_nat_set_infinite path_nret_ex_all_cd[OF assms] by auto
 
 lemma path_nret_inf_icd_seq: assumes path: \<open>is_path \<pi>\<close> and nret: \<open>\<forall> i. \<pi> i \<noteq> return\<close> 
 obtains f where \<open>\<forall> i. f (Suc i) icd\<^bsup>\<pi>\<^esup>\<rightarrow> f i\<close> \<open>range f = {i. \<forall> j>i. j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i}\<close> \<open>\<not> (\<exists>i. f 0 cd\<^bsup>\<pi>\<^esup>\<rightarrow> i)\<close>
 proof -
   note path_nret_inf_all_cd[OF assms]
   then obtain f where ran: \<open>range f = {j. \<forall> k>j. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j}\<close> and asc: \<open>\<forall> i. f i < f (Suc i)\<close> using infinite_ascending by blast
   have mono: \<open>\<forall> i j. i < j \<longrightarrow> f i < f j\<close> using asc by (metis lift_Suc_mono_less)
   {
     fix i
     have cd: \<open>f (Suc i) cd\<^bsup>\<pi>\<^esup>\<rightarrow> f i\<close> using ran asc by auto
     have \<open>f (Suc i) icd\<^bsup>\<pi>\<^esup>\<rightarrow> f i\<close> proof (rule ccontr)
       assume \<open>\<not> f (Suc i) icd\<^bsup>\<pi>\<^esup>\<rightarrow> f i\<close>
       then obtain m where  im: \<open>f i < m\<close> and mi: \<open> m < f (Suc i)\<close> and cdm: \<open>f (Suc i) cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> unfolding is_icdi_def using assms(1) cd by auto
       have \<open>\<forall> k>m. k cd\<^bsup>\<pi>\<^esup>\<rightarrow>m\<close> proof (rule,rule,cases)
         fix k assume \<open>f (Suc i) < k\<close>
         hence \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> f (Suc i)\<close> using ran by auto
         thus \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> using cdm cd_trans by metis
       next
         fix k assume mk: \<open>m < k\<close> and \<open>\<not> f (Suc i) < k\<close>
         hence ik: \<open>k \<le> f (Suc i)\<close> by simp
         thus \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> using cdm by (metis cdi_prefix mk)
       qed
       hence \<open>m \<in> range f\<close> using ran by blast
       then obtain j where m: \<open>m = f j\<close> by blast
       show \<open>False\<close> using im mi mono unfolding m by (metis Suc_lessI le_less not_le)
     qed
   }
   moreover  
   {
     fix m
     assume cdm: \<open>f 0 cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close>
     have \<open>\<forall> k>m. k cd\<^bsup>\<pi>\<^esup>\<rightarrow>m\<close> proof (rule,rule,cases)
       fix k assume \<open>f 0 < k\<close>
       hence \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> f 0\<close> using ran by auto
       thus \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> using cdm cd_trans by metis
     next
       fix k assume mk: \<open>m < k\<close> and \<open>\<not> f 0 < k\<close>
       hence ik: \<open>k \<le> f 0\<close> by simp
       thus \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> using cdm by (metis cdi_prefix mk)
     qed
     hence \<open>m \<in> range f\<close> using ran by blast
     then obtain j where m: \<open>m = f j\<close> by blast
     hence fj0: \<open>f j < f 0\<close>  using cdm m is_cdi_def by auto
     hence \<open>0 < j\<close> by (metis less_irrefl neq0_conv)
     hence \<open>False\<close> using fj0 mono by fastforce
   }
   ultimately show \<open>thesis\<close> using that ran by blast
 qed
 
 lemma cdi_iff_no_strict_pd: \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k \<longleftrightarrow> is_path \<pi> \<and> k < i \<and> \<pi> i \<noteq> return \<and> (\<forall> j \<in> {k..i}. \<not> (\<pi> k, \<pi> j) \<in> pdt)\<close>
 proof
   assume cd:\<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close>
   have 1: \<open>is_path \<pi> \<and> k < i \<and> \<pi> i \<noteq> return\<close> using cd unfolding is_cdi_def by auto
   have 2: \<open>\<forall> j \<in> {k..i}. \<not> (\<pi> k, \<pi> j) \<in> pdt\<close> proof (rule ccontr)
     assume \<open> \<not> (\<forall>j\<in>{k..i}. (\<pi> k, \<pi> j) \<notin> pdt)\<close>
     then obtain j where \<open>j \<in> {k..i}\<close> and \<open>(\<pi> k, \<pi> j) \<in> pdt\<close> by auto
     hence \<open>\<pi> j \<noteq> \<pi> k\<close> and \<open>\<pi> j pd\<rightarrow> \<pi> k\<close> unfolding pdt_def by auto
     thus \<open>False\<close> using path_pd_ipd by (metis \<open>j \<in> {k..i}\<close> atLeastAtMost_iff cd cd_not_pd cdi_prefix le_eq_less_or_eq) 
   qed
   show \<open>is_path \<pi> \<and> k < i \<and> \<pi> i \<noteq> return \<and> (\<forall> j \<in> {k..i}. \<not> (\<pi> k, \<pi> j) \<in> pdt)\<close> using 1 2 by simp
 next
   assume \<open>is_path \<pi> \<and> k < i \<and> \<pi> i \<noteq> return \<and> (\<forall> j \<in> {k..i}. \<not> (\<pi> k, \<pi> j) \<in> pdt)\<close>
   thus \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> by (metis ipd_in_pdt term_path_stable less_or_eq_imp_le not_cd_impl_ipd path_nodes)
 qed
 
 
 subsection \<open>Facts about Control Slices\<close>
 
 lemma last_cs: \<open>last (cs\<^bsup>\<pi>\<^esup> i) = \<pi> i\<close> by auto
 
 lemma cs_not_nil: \<open>cs\<^bsup>\<pi>\<^esup> n \<noteq> []\<close> by (auto)
 
 lemma cs_return: assumes \<open>\<pi> n = return\<close> shows \<open>cs\<^bsup>\<pi>\<^esup> n = [\<pi> n]\<close> by (metis assms cs.elims icd_imp_cd ret_no_cd)
 
 lemma cs_0[simp]: \<open>cs\<^bsup>\<pi>\<^esup> 0 = [\<pi> 0]\<close> using is_icdi_def is_cdi_def by auto
 
 lemma cs_inj: assumes \<open>is_path \<pi>\<close> \<open>\<pi> n \<noteq> return\<close> \<open>cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>\<^esup> n'\<close> shows \<open>n = n'\<close> 
 using assms proof (induction \<open>cs\<^bsup>\<pi>\<^esup> n\<close> arbitrary: \<open>\<pi>\<close> \<open>n\<close> \<open>n'\<close> rule:rev_induct)
   case Nil hence \<open>False\<close> using cs_not_nil by metis thus \<open>?case\<close> by simp
 next
   case (snoc x xs \<pi> n n') show \<open>?case\<close> proof (cases \<open>xs\<close>)
   case Nil 
   hence *: \<open>\<not> (\<exists> k. n icd\<^bsup>\<pi>\<^esup>\<rightarrow>k)\<close> using snoc(2) cs_not_nil 
     by (auto,metis append1_eq_conv append_Nil cs_not_nil)
   moreover
   have \<open>[x] = cs\<^bsup>\<pi>\<^esup> n'\<close> using Nil snoc by auto
   hence **: \<open>\<not> (\<exists> k. n' icd\<^bsup>\<pi>\<^esup>\<rightarrow>k)\<close> using cs_not_nil
     by (auto,metis append1_eq_conv append_Nil cs_not_nil)
   ultimately
   have \<open>\<forall> k. \<not> n cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> \<open>\<forall> k. \<not> n' cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> using excd_impl_exicd by auto blast+
   moreover 
   hence  \<open>\<pi> n = \<pi> n'\<close> using snoc(5,2) by auto (metis * ** list.inject)
   ultimately
   show \<open>n = n'\<close> using other_claim' snoc by blast
 next
   case (Cons y ys)
   hence *: \<open>\<exists> k. n icd\<^bsup>\<pi>\<^esup>\<rightarrow>k\<close> using snoc(2) by auto (metis append_is_Nil_conv list.distinct(1) list.inject)
   then obtain k where k: \<open>n icd\<^bsup>\<pi>\<^esup>\<rightarrow>k\<close> by auto
   have \<open>k = (THE k . n icd\<^bsup>\<pi>\<^esup>\<rightarrow> k)\<close> using k by (metis icd_is_the_icd)
   hence xsk: \<open>xs = cs\<^bsup>\<pi>\<^esup> k\<close> using * k snoc(2) unfolding cs.simps[of \<open>\<pi>\<close> \<open>n\<close>] by auto
   have **: \<open>\<exists> k. n' icd\<^bsup>\<pi>\<^esup>\<rightarrow>k\<close> using snoc(2)[unfolded snoc(5)] by auto (metis Cons append1_eq_conv append_Nil list.distinct(1))
   then obtain k' where k': \<open>n' icd\<^bsup>\<pi>\<^esup>\<rightarrow> k'\<close> by auto
   hence \<open>k' = (THE k . n' icd\<^bsup>\<pi>\<^esup>\<rightarrow> k)\<close> using k' by (metis icd_is_the_icd)
   hence xsk': \<open>xs = cs\<^bsup>\<pi>\<^esup> k'\<close> using ** k' snoc(5,2) unfolding cs.simps[of \<open>\<pi>\<close> \<open>n'\<close>] by auto
   hence \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>\<^esup> k'\<close> using xsk by simp
   moreover
   have kn: \<open>k < n\<close> using k by (metis is_icdi_def is_cdi_def)
   hence \<open>\<pi> k \<noteq> return\<close> using snoc by (metis term_path_stable less_imp_le)
   ultimately
   have kk'[simp]: \<open>k' = k\<close> using snoc(1) xsk snoc(3) by metis
   have nk0: \<open>n - k icd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> 0\<close> \<open>n' - k icd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> 0\<close> using k k' icd_path_shift0 snoc(3) by auto
   moreover 
   have nkr: \<open>(\<pi>\<guillemotleft>k)(n-k) \<noteq> return\<close> using snoc(4) kn by auto
   moreover 
   have \<open>is_path (\<pi>\<guillemotleft>k)\<close> by (metis path_path_shift snoc.prems(1))
   moreover 
   have kn': \<open>k < n'\<close> using k' kk' by (metis is_icdi_def is_cdi_def)
   have \<open>\<pi> n = \<pi> n'\<close> using snoc(5) * ** by auto
   hence \<open>(\<pi>\<guillemotleft>k)(n-k) = (\<pi>\<guillemotleft>k)(n'-k)\<close> using kn kn' by auto 
   ultimately  
   have \<open>n - k = n' - k\<close> using other_claim  by auto
   thus \<open>n = n'\<close> using kn kn' by auto
 qed
 qed
 
 lemma cs_cases: fixes \<pi> i 
 obtains (base) \<open>cs\<^bsup>\<pi>\<^esup> i = [\<pi> i]\<close> and \<open>\<forall> k. \<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> | 
 (depend) k where  \<open>cs\<^bsup>\<pi>\<^esup> i = (cs\<^bsup>\<pi>\<^esup> k)@[\<pi> i]\<close> and \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> 
 proof cases
   assume *: \<open>\<exists> k. i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close>
   then obtain k where k: \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> ..
   hence \<open>k = (THE k. i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k)\<close>  by (metis icd_is_the_icd)
   hence \<open>cs\<^bsup>\<pi>\<^esup> i = (cs\<^bsup>\<pi>\<^esup> k)@[\<pi> i]\<close> using * by auto
   with k that show \<open>thesis\<close> by simp
 next
   assume *: \<open>\<not> (\<exists> k. i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k)\<close>
   hence \<open>\<forall> k. \<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> by (metis excd_impl_exicd)
   moreover 
   have \<open>cs\<^bsup>\<pi>\<^esup> i = [\<pi> i]\<close> using * by auto
   ultimately
   show \<open>thesis\<close> using that by simp
 qed
 
 lemma cs_length_one: assumes \<open>length (cs\<^bsup>\<pi>\<^esup> i) = 1\<close> shows  \<open>cs\<^bsup>\<pi>\<^esup> i = [\<pi> i]\<close> and \<open>\<forall> k. \<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close>
   apply (cases \<open>i\<close> \<open>\<pi>\<close> rule: cs_cases)
   using assms cs_not_nil 
     apply auto 
   apply (cases \<open>i\<close> \<open>\<pi>\<close> rule: cs_cases) 
   using assms cs_not_nil 
   by auto
 
 lemma cs_length_g_one: assumes \<open>length (cs\<^bsup>\<pi>\<^esup> i) \<noteq> 1\<close> obtains k where  \<open>cs\<^bsup>\<pi>\<^esup> i = (cs\<^bsup>\<pi>\<^esup> k)@[\<pi> i]\<close> and \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> 
   apply (cases \<open>i\<close> \<open>\<pi>\<close> rule: cs_cases) 
   using assms cs_not_nil by auto
 
 lemma claim: assumes  path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and  ii: \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'\<close> and jj: \<open>cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j'\<close> 
 and bl: \<open>butlast (cs\<^bsup>\<pi>\<^esup> i) = butlast (cs\<^bsup>\<pi>\<^esup> j)\<close> and nret: \<open>\<pi> i \<noteq> return\<close> and ilj: \<open>i < j\<close> 
 shows \<open>i' < j'\<close>
 proof (cases )
   assume *: \<open>length (cs\<^bsup>\<pi>\<^esup> i) = 1\<close>
   hence **: \<open>length (cs\<^bsup>\<pi>\<^esup> i) = 1\<close> \<open>length (cs\<^bsup>\<pi>\<^esup> j) = 1\<close> \<open>length (cs\<^bsup>\<pi>'\<^esup> i') = 1\<close> \<open>length (cs\<^bsup>\<pi>'\<^esup> j') = 1\<close>  
     apply metis
     apply (metis "*" bl butlast.simps(2) butlast_snoc cs_length_g_one cs_length_one(1) cs_not_nil) 
     apply (metis "*" ii)
     by (metis "*" bl butlast.simps(2) butlast_snoc cs_length_g_one cs_length_one(1) cs_not_nil jj)
   then obtain \<open>cs\<^bsup>\<pi>\<^esup> i = [\<pi> i]\<close> \<open>cs\<^bsup>\<pi>\<^esup> j = [\<pi> j]\<close> \<open>cs\<^bsup>\<pi>'\<^esup> j' = [\<pi>' j']\<close> \<open>cs\<^bsup>\<pi>'\<^esup> i'= [\<pi>' i']\<close> 
     \<open>\<forall> k. \<not> j cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> \<open>\<forall> k. \<not> i' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> k\<close> \<open>\<forall> k. \<not> j' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> k\<close>
   by (metis cs_length_one ** )
   moreover 
   hence \<open>\<pi> i = \<pi>' i'\<close> \<open>\<pi> j = \<pi>' j'\<close> using  assms by auto
   ultimately
   show \<open>i' < j'\<close> using nret ilj path claim'' by blast
 next
   assume *: \<open>length (cs\<^bsup>\<pi>\<^esup> i) \<noteq> 1\<close>
   hence **: \<open>length (cs\<^bsup>\<pi>\<^esup> i) \<noteq> 1\<close> \<open>length (cs\<^bsup>\<pi>\<^esup> j) \<noteq> 1\<close> \<open>length (cs\<^bsup>\<pi>'\<^esup> i') \<noteq> 1\<close> \<open>length (cs\<^bsup>\<pi>'\<^esup> j') \<noteq> 1\<close>  
     apply metis
     apply (metis "*" bl butlast.simps(2) butlast_snoc cs_length_g_one cs_length_one(1) cs_not_nil)
     apply (metis "*" ii)
     by (metis "*" bl butlast.simps(2) butlast_snoc cs_length_g_one cs_length_one(1) cs_not_nil jj)
   obtain k l k' l' where ***:
     \<open>cs\<^bsup>\<pi>\<^esup> i = (cs\<^bsup>\<pi>\<^esup> k)@[\<pi> i]\<close> \<open>cs\<^bsup>\<pi>\<^esup> j = (cs\<^bsup>\<pi>\<^esup> l)@[\<pi> j]\<close>  \<open>cs\<^bsup>\<pi>'\<^esup> i' = (cs\<^bsup>\<pi>'\<^esup> k')@[\<pi>' i']\<close> \<open>cs\<^bsup>\<pi>'\<^esup> j' = (cs\<^bsup>\<pi>'\<^esup> l')@[\<pi>' j']\<close> and
     icds: \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> \<open>j icd\<^bsup>\<pi>\<^esup>\<rightarrow> l\<close> \<open>i' icd\<^bsup>\<pi>'\<^esup>\<rightarrow> k'\<close> \<open>j' icd\<^bsup>\<pi>'\<^esup>\<rightarrow> l'\<close>
     by (metis ** cs_length_g_one)
   hence \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>\<^esup> l\<close> \<open>cs\<^bsup>\<pi>'\<^esup> k' = cs\<^bsup>\<pi>'\<^esup> l'\<close> using assms by auto
   moreover
   have \<open>\<pi> k \<noteq> return\<close> \<open>\<pi>' k' \<noteq> return\<close> using nret 
     apply (metis is_icdi_def icds(1) is_cdi_def term_path_stable less_imp_le) 
     by (metis is_cdi_def is_icdi_def icds(3) term_path_stable less_imp_le)
   ultimately  
   have lk[simp]: \<open>l = k\<close> \<open>l' = k'\<close> using path cs_inj by auto
   let \<open>?\<pi>\<close> = \<open>\<pi> \<guillemotleft> k\<close> 
   let \<open>?\<pi>'\<close> = \<open>\<pi>'\<guillemotleft>k'\<close>
   have \<open>i-k icd\<^bsup>?\<pi>\<^esup>\<rightarrow> 0\<close> \<open>j-k icd\<^bsup>?\<pi>\<^esup>\<rightarrow> 0\<close> \<open>i'-k' icd\<^bsup>?\<pi>'\<^esup>\<rightarrow> 0\<close> \<open>j'-k' icd\<^bsup>?\<pi>'\<^esup>\<rightarrow> 0\<close> using icd_path_shift0 path icds by auto
   moreover
   have ki: \<open>k < i\<close> using icds by (metis is_icdi_def is_cdi_def)
   hence \<open>i-k < j-k\<close> by (metis diff_is_0_eq diff_less_mono ilj nat_le_linear order.strict_trans)
   moreover
   have \<pi>i: \<open>\<pi> i = \<pi>' i'\<close> \<open>\<pi> j = \<pi>' j'\<close> using assms *** by auto
   have \<open>k' < i'\<close> \<open>k' < j'\<close> using icds unfolding lk by (metis is_cdi_def is_icdi_def)+ 
   hence \<open>?\<pi> (i-k) = ?\<pi>' (i'-k')\<close> \<open>?\<pi> (j-k) = ?\<pi>' (j'-k')\<close> using \<pi>i ki ilj by auto
   moreover 
   have \<open>?\<pi> (i-k) \<noteq> return\<close> using nret ki by auto
   moreover
   have \<open>is_path ?\<pi>\<close> \<open>is_path ?\<pi>'\<close> using path path_path_shift by auto
   ultimately
   have \<open>i'-k' < j' - k'\<close> using claim' by blast
   thus \<open>i' < j'\<close> by (metis diff_is_0_eq diff_less_mono less_nat_zero_code linorder_neqE_nat nat_le_linear)
 qed
 
 lemma cs_split': assumes \<open>cs\<^bsup>\<pi>\<^esup> i = xs@[x,x']@ys\<close>  shows \<open>\<exists> m. cs\<^bsup>\<pi>\<^esup> m = xs@[x] \<and> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> 
 using assms proof (induction \<open>ys\<close> arbitrary: \<open>i\<close> rule:rev_induct ) 
   case (snoc y ys)
   hence \<open>length (cs\<^bsup>\<pi>\<^esup> i) \<noteq> 1\<close> by auto
   then obtain i' where \<open>cs\<^bsup>\<pi>\<^esup> i = (cs\<^bsup>\<pi>\<^esup> i') @ [\<pi> i]\<close> and *: \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> i'\<close> using cs_length_g_one[of \<open>\<pi>\<close> \<open>i\<close>] by metis
   hence \<open>cs\<^bsup>\<pi>\<^esup> i' = xs@[x,x']@ys\<close> using snoc(2) by (metis append1_eq_conv append_assoc)
   then obtain m where **: \<open>cs\<^bsup>\<pi>\<^esup> m = xs @ [x]\<close> and \<open>i' cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> using snoc(1) by blast
   hence \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> using * cd_trans by (metis is_icdi_def)
   with ** show \<open>?case\<close> by blast
 next
   case Nil
   hence \<open>length (cs\<^bsup>\<pi>\<^esup> i) \<noteq> 1\<close> by auto
   then obtain i' where a: \<open>cs\<^bsup>\<pi>\<^esup> i = (cs\<^bsup>\<pi>\<^esup> i') @ [\<pi> i]\<close> and *: \<open>i icd\<^bsup>\<pi>\<^esup>\<rightarrow> i'\<close> using cs_length_g_one[of \<open>\<pi>\<close> \<open>i\<close>] by metis
   have \<open>cs\<^bsup>\<pi>\<^esup> i = (xs@[x])@[x']\<close> using Nil by auto
   hence \<open>cs\<^bsup>\<pi>\<^esup> i' = xs@[x]\<close> using append1_eq_conv a by metis  
   thus \<open>?case\<close> using * unfolding is_icdi_def by blast
 qed
 
 lemma cs_split: assumes \<open>cs\<^bsup>\<pi>\<^esup> i = xs@[x]@ys@[\<pi> i]\<close>  shows \<open>\<exists> m. cs\<^bsup>\<pi>\<^esup> m = xs@[x] \<and> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> proof -
   obtain x' ys' where \<open>ys@[\<pi> i] = [x']@ys'\<close> by (metis append_Cons append_Nil neq_Nil_conv)
   thus \<open>?thesis\<close> using cs_split'[of \<open>\<pi>\<close> \<open>i\<close> \<open>xs\<close> \<open>x\<close> \<open>x'\<close> \<open>ys'\<close>] assms by auto
 qed
 
 lemma cs_less_split: assumes \<open>xs \<prec> ys\<close> obtains a as where \<open>ys = xs@a#as\<close>
   using assms unfolding cs_less.simps apply auto
 by (metis Cons_nth_drop_Suc append_take_drop_id)
 
 lemma cs_select_is_cs: assumes \<open>is_path \<pi>\<close> \<open>xs \<noteq> Nil\<close> \<open>xs \<prec> cs\<^bsup>\<pi>\<^esup> k\<close> shows \<open>cs\<^bsup>\<pi>\<^esup> (\<pi>\<exclamdown>xs) = xs\<close> \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> (\<pi>\<exclamdown>xs)\<close>proof -
   obtain b bs where b: \<open>cs\<^bsup>\<pi>\<^esup> k = xs@b#bs\<close> using assms cs_less_split by blast
   obtain a as where a: \<open>xs = as@[a]\<close> using assms by (metis rev_exhaust)
   have \<open>cs\<^bsup>\<pi>\<^esup> k = as@[a,b]@bs\<close> using a b by auto
   then obtain k' where csk: \<open>cs\<^bsup>\<pi>\<^esup> k' = xs\<close> and is_cd: \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> k'\<close> using cs_split' a by blast
   hence nret: \<open>\<pi> k' \<noteq> return\<close> by (metis is_cdi_def term_path_stable less_imp_le)
   show a: \<open>cs\<^bsup>\<pi>\<^esup> (\<pi>\<exclamdown>xs) = xs\<close> unfolding cs_select_def using cs_inj[OF assms(1) nret] csk the_equality[of _ \<open>k'\<close>]
     by (metis (mono_tags))
   show \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> (\<pi>\<exclamdown>xs)\<close> unfolding cs_select_def by (metis a assms(1) cs_inj cs_select_def csk is_cd nret)
 qed
 
 lemma cd_in_cs: assumes \<open>n cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> shows \<open>\<exists> ns. cs\<^bsup>\<pi>\<^esup> n = (cs\<^bsup>\<pi>\<^esup> m) @ ns @[\<pi> n]\<close> 
 using assms proof (induction rule: cd_induct)
   case (base  n) thus \<open>?case\<close> by (metis append_Nil cs.simps icd_is_the_icd)
 next
   case (IS k n)
   hence \<open>cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>\<^esup> k @ [\<pi> n]\<close> by (metis cs.simps icd_is_the_icd)  
   thus \<open>?case\<close> using IS by force
 qed
 
 lemma butlast_cs_not_cd: assumes \<open>butlast (cs\<^bsup>\<pi>\<^esup> m) = butlast (cs\<^bsup>\<pi>\<^esup> n)\<close> shows \<open>\<not> m cd\<^bsup>\<pi>\<^esup>\<rightarrow>n\<close>
 by (metis append_Cons append_Nil append_assoc assms cd_in_cs cs_not_nil list.distinct(1) self_append_conv snoc_eq_iff_butlast)
 
 lemma wn_cs_butlast: assumes \<open>butlast (cs\<^bsup>\<pi>\<^esup> m) = butlast (cs\<^bsup>\<pi>\<^esup> n)\<close> \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close> \<open>m<n\<close> shows \<open>i<j\<close>
 proof (rule ccontr)
   assume \<open>\<not> i < j\<close>
   moreover
   have \<open>\<not> n cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> by (metis assms(1) butlast_cs_not_cd)
   ultimately
   have \<open>n \<le> m\<close> using assms(2,3) cr_wn'' by auto
   thus \<open>False\<close> using assms(4) by auto
 qed
 
 
 text \<open>This is the central theorem making the control slice suitable for matching indices between executions.\<close>
 
 theorem cs_order: assumes path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and csi: \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'\<close> 
 and csj: \<open>cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j'\<close> and nret: \<open>\<pi> i \<noteq> return\<close> and ilj: \<open>i < j\<close>   
 shows \<open>i'<j'\<close>
 proof -
   have \<open>cs\<^bsup>\<pi>\<^esup> i \<noteq> cs\<^bsup>\<pi>\<^esup> j\<close> using cs_inj[OF path(1) nret] ilj by blast
   moreover 
   have \<open>cs\<^bsup>\<pi>\<^esup> i \<noteq> Nil\<close> \<open>cs\<^bsup>\<pi>\<^esup> j \<noteq> Nil\<close> by (metis cs_not_nil)+
   ultimately show \<open>?thesis\<close> proof (cases rule: list_neq_prefix_cases)
     case (diverge xs x x' ys ys')
     note csx = \<open>cs\<^bsup>\<pi>\<^esup> i = xs @ [x] @ ys\<close>
     note csx' = \<open>cs\<^bsup>\<pi>\<^esup> j = xs @ [x'] @ ys'\<close>
     note xx = \<open>x \<noteq> x'\<close>
     show \<open>i' < j'\<close> proof (cases \<open>ys\<close>) 
       assume ys: \<open>ys = Nil\<close>
       show \<open>?thesis\<close> proof (cases \<open>ys'\<close>)
         assume ys': \<open>ys' = Nil\<close>
         have cs: \<open>cs\<^bsup>\<pi>\<^esup> i = xs @ [x]\<close> \<open>cs\<^bsup>\<pi>\<^esup> j = xs @ [x']\<close> by (metis append_Nil2 csx ys, metis append_Nil2 csx' ys')
         hence bl: \<open>butlast (cs\<^bsup>\<pi>\<^esup> i) = butlast (cs\<^bsup>\<pi>\<^esup> j)\<close> by auto        
         show \<open>i' < j'\<close> using claim[OF path csi csj bl nret ilj] .
       next
         fix y' zs'
         assume ys': \<open>ys' = y'#zs'\<close>
         have cs: \<open>cs\<^bsup>\<pi>\<^esup> i = xs @ [x]\<close> \<open>cs\<^bsup>\<pi>\<^esup> j = xs @ [x',y']@ zs'\<close> by (metis append_Nil2 csx ys, metis append_Cons append_Nil csx' ys')         
         obtain n where n: \<open>cs\<^bsup>\<pi>\<^esup> n = xs@[x']\<close> and jn: \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close> using cs cs_split' by blast
         obtain n' where n': \<open>cs\<^bsup>\<pi>'\<^esup> n' = xs@[x']\<close> and jn': \<open>j' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n'\<close> using cs cs_split' unfolding csj by blast
         have csn : \<open>cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n'\<close> and bl: \<open>butlast (cs\<^bsup>\<pi>\<^esup> i) = butlast (cs\<^bsup>\<pi>\<^esup> n)\<close> using n n' cs by auto
         hence bl': \<open>butlast (cs\<^bsup>\<pi>'\<^esup> i') = butlast (cs\<^bsup>\<pi>'\<^esup> n')\<close> using csi by auto
         have notcd: \<open>\<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close> by (metis butlast_cs_not_cd bl)
         have nin: \<open>i \<noteq> n\<close> using cs n xx by auto
         have iln: \<open>i < n\<close> apply (rule ccontr) using cr_wn'[OF jn notcd] nin ilj by auto
         note claim[OF path csi csn bl nret iln]
         hence \<open>i' < n'\<close> .
         thus \<open>i' < j'\<close> using jn' unfolding is_cdi_def by auto
       qed
     next
       fix y zs
       assume ys: \<open>ys = y#zs\<close>
       show \<open>?thesis\<close> proof (cases \<open>ys'\<close>)
         assume ys' : \<open>ys' = Nil\<close>
         have cs: \<open>cs\<^bsup>\<pi>\<^esup> i = xs @ [x,y]@zs\<close> \<open>cs\<^bsup>\<pi>\<^esup> j = xs @ [x']\<close> by (metis append_Cons append_Nil csx ys, metis append_Nil2 csx' ys')
         obtain n where n: \<open>cs\<^bsup>\<pi>\<^esup> n = xs@[x]\<close> and jn: \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close> using cs cs_split' by blast
         obtain n' where n': \<open>cs\<^bsup>\<pi>'\<^esup> n' = xs@[x]\<close> and jn': \<open>i' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n'\<close> using cs cs_split' unfolding csi by blast
         have csn : \<open>cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n'\<close> and bl: \<open>butlast (cs\<^bsup>\<pi>\<^esup> n) = butlast (cs\<^bsup>\<pi>\<^esup> j)\<close> using n n' cs by auto
         hence bl': \<open>butlast (cs\<^bsup>\<pi>'\<^esup> j') = butlast (cs\<^bsup>\<pi>'\<^esup> n')\<close> using csj by auto
         have notcd: \<open>\<not> j' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n'\<close> by (metis butlast_cs_not_cd bl')
         have nin: \<open>n < i\<close> using jn unfolding is_cdi_def by auto
         have nlj: \<open>n < j\<close> using nin ilj by auto
         note claim[OF path csn csj bl _ nlj]
         hence nj': \<open>n' < j'\<close> using term_path_stable[OF path(1) _] less_imp_le nin nret by auto
         show \<open>i' < j'\<close> apply(rule ccontr) using cdi_prefix[OF jn' nj'] notcd by auto
       next
         fix y' zs'
         assume ys' : \<open>ys' = y'#zs'\<close>
         have cs: \<open>cs\<^bsup>\<pi>\<^esup> i = xs@[x,y]@zs\<close> \<open>cs\<^bsup>\<pi>\<^esup> j = xs@[x',y']@zs'\<close> by (metis append_Cons append_Nil csx ys,metis append_Cons append_Nil csx' ys')
         have neq: \<open>cs\<^bsup>\<pi>\<^esup> i \<noteq> cs\<^bsup>\<pi>\<^esup> j\<close> using cs_inj path nret ilj by blast
         obtain m where m: \<open>cs\<^bsup>\<pi>\<^esup> m = xs@[x]\<close> and im: \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> using cs cs_split' by blast
         obtain n where n: \<open>cs\<^bsup>\<pi>\<^esup> n = xs@[x']\<close> and jn: \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close> using cs cs_split' by blast
         obtain m' where m': \<open>cs\<^bsup>\<pi>'\<^esup> m' = xs@[x]\<close> and im': \<open>i' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> m'\<close> using cs cs_split' unfolding csi by blast
         obtain n' where n': \<open>cs\<^bsup>\<pi>'\<^esup> n' = xs@[x']\<close> and jn': \<open>j' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n'\<close> using cs cs_split' unfolding csj by blast
         have \<open>m \<le> n\<close> using ilj m n wn_cs_butlast[OF _ jn im] by force
         moreover
         have \<open>m \<noteq> n\<close> using m n xx by (metis last_snoc)
         ultimately 
         have mn: \<open>m < n\<close> by auto
         moreover 
         have \<open>\<pi> m \<noteq> return\<close> by (metis last_cs last_snoc m mn n path(1) term_path_stable xx less_imp_le)
         moreover  
         have \<open>butlast (cs\<^bsup>\<pi>\<^esup> m) = butlast (cs\<^bsup>\<pi>\<^esup> n)\<close> \<open>cs\<^bsup>\<pi>\<^esup> m = cs\<^bsup>\<pi>'\<^esup> m'\<close> \<open>cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n'\<close> using m n n' m' by auto
         ultimately
         have \<open>m' < n'\<close> using claim path by blast
         thus \<open>i' < j'\<close> using m' n' im' jn' wn_cs_butlast by (metis butlast_snoc)        
       qed
     qed
   next
     case (prefix1 xs)
     note pfx = \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>\<^esup> j @ xs\<close>
     note xs = \<open>xs \<noteq> []\<close>
     obtain a as where \<open>xs = a#as\<close> using xs by (metis list.exhaust)
     moreover
     obtain bs b where bj: \<open>cs\<^bsup>\<pi>\<^esup> j = bs@[b]\<close> using cs_not_nil by (metis rev_exhaust)
     ultimately
     have \<open>cs\<^bsup>\<pi>\<^esup> i = bs@[b,a]@as\<close> using pfx by auto
     then obtain m where \<open>cs\<^bsup>\<pi>\<^esup> m = bs@[b]\<close> and cdep:  \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> m\<close> using cs_split' by blast
     hence mi: \<open>m = j\<close> using bj cs_inj by (metis is_cdi_def term_path_stable less_imp_le)
     hence \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> using cdep by auto
     hence \<open>False\<close> using ilj unfolding is_cdi_def by auto
     thus \<open>i' < j'\<close> ..
   next
     case (prefix2 xs)
     have pfx : \<open>cs\<^bsup>\<pi>'\<^esup> i' @ xs = cs\<^bsup>\<pi>'\<^esup> j'\<close> using prefix2 csi csj by auto
     note xs = \<open>xs \<noteq> []\<close>
      obtain a as where \<open>xs = a#as\<close> using xs by (metis list.exhaust)
     moreover
     obtain bs b where bj: \<open>cs\<^bsup>\<pi>'\<^esup> i'  = bs@[b]\<close> using cs_not_nil by (metis rev_exhaust)
     ultimately
     have \<open>cs\<^bsup>\<pi>'\<^esup> j' = bs@[b,a]@as\<close> using pfx by auto
     then obtain m where \<open>cs\<^bsup>\<pi>'\<^esup> m = bs@[b]\<close> and cdep:  \<open>j' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> m\<close> using cs_split' by blast
     hence mi: \<open>m = i'\<close> using bj cs_inj by (metis is_cdi_def term_path_stable less_imp_le)
     hence \<open>j' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> i'\<close> using cdep by auto
     thus \<open>i' < j'\<close> unfolding is_cdi_def by auto  
   qed
 qed
 
 lemma cs_order_le: assumes path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and csi: \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'\<close> 
 and csj: \<open>cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j'\<close> and nret: \<open>\<pi> i \<noteq> return\<close> and ilj: \<open>i \<le> j\<close>   
 shows \<open>i'\<le>j'\<close> proof cases
   assume \<open>i < j\<close> with cs_order[OF assms(1,2,3,4,5)] show \<open>?thesis\<close> by simp
 next
   assume \<open>\<not> i < j\<close>
   hence \<open>i = j\<close> using ilj by simp
   hence csij: \<open>cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>'\<^esup> j'\<close> using csi csj by simp  
   have nret': \<open>\<pi>' i' \<noteq> return\<close> using nret last_cs csi by metis
   show \<open>?thesis\<close> using cs_inj[OF path(2) nret' csij] by simp
 qed
 
 lemmas cs_induct[case_names cs] = cs.induct
 
 lemma icdi_path_swap: assumes \<open>is_path \<pi>'\<close> \<open>j icd\<^bsup>\<pi>\<^esup>\<rightarrow>k\<close> \<open>\<pi> =\<^bsub>j\<^esub>  \<pi>'\<close> shows \<open>j icd\<^bsup>\<pi>'\<^esup>\<rightarrow>k\<close> using assms unfolding eq_up_to_def is_icdi_def is_cdi_def by auto
 
 lemma icdi_path_swap_le: assumes \<open>is_path \<pi>'\<close> \<open>j icd\<^bsup>\<pi>\<^esup>\<rightarrow>k\<close> \<open>\<pi> =\<^bsub>n\<^esub>  \<pi>'\<close> \<open>j \<le> n\<close> shows \<open>j icd\<^bsup>\<pi>'\<^esup>\<rightarrow>k\<close> by (metis assms icdi_path_swap eq_up_to_le)
 
 lemma cs_path_swap: assumes \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> \<open>\<pi> =\<^bsub>k\<^esub> \<pi>'\<close> shows \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k\<close> using assms(1,3) proof (induction \<open>\<pi>\<close> \<open>k\<close> rule:cs_induct,cases)
   case (cs \<pi> k)     
   let \<open>?l\<close> = \<open>(THE l. k icd\<^bsup>\<pi>\<^esup>\<rightarrow> l)\<close>
   assume *: \<open>\<exists>l. k icd\<^bsup>\<pi>\<^esup>\<rightarrow> l\<close>
   have kicd: \<open>k icd\<^bsup>\<pi>\<^esup>\<rightarrow> ?l\<close> by (metis "*" icd_is_the_icd)
   hence \<open>?l < k\<close> unfolding is_cdi_def[of \<open>k\<close> \<open>\<pi>\<close> \<open>?l\<close>] is_icdi_def[of \<open>k\<close> \<open>\<pi>\<close> \<open>?l\<close>] by auto
   hence \<open>\<forall> i\<le>?l. \<pi> i = \<pi>' i\<close> using cs(2,3) unfolding eq_up_to_def by auto
   hence csl: \<open>cs\<^bsup>\<pi>\<^esup> ?l = cs\<^bsup>\<pi>'\<^esup> ?l\<close> using cs(1,2) * unfolding eq_up_to_def by auto 
   have kicd: \<open>k icd\<^bsup>\<pi>\<^esup>\<rightarrow> ?l\<close> by (metis "*" icd_is_the_icd)
   hence csk: \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>\<^esup> ?l @ [\<pi> k]\<close> using kicd by auto
   have kicd': \<open>k icd\<^bsup>\<pi>'\<^esup>\<rightarrow> ?l\<close> using kicd icdi_path_swap[OF assms(2) _ cs(3)] by simp
   hence \<open>?l = (THE l. k icd\<^bsup>\<pi>'\<^esup>\<rightarrow> l)\<close> by (metis icd_is_the_icd)
   hence csk': \<open>cs\<^bsup>\<pi>'\<^esup> k = cs\<^bsup>\<pi>'\<^esup> ?l @ [\<pi>' k]\<close> using kicd' by auto
   have \<open>\<pi>' k = \<pi> k\<close> using cs(3) unfolding eq_up_to_def by auto
   with csl csk csk'  
   show \<open>?case\<close> by auto
 next
   case (cs \<pi> k)
   assume *: \<open>\<not> (\<exists>l. k icd\<^bsup>\<pi>\<^esup>\<rightarrow> l)\<close>
   hence csk: \<open>cs\<^bsup>\<pi>\<^esup> k = [\<pi> k]\<close> by auto
   have \<open>\<not> (\<exists>l. k icd\<^bsup>\<pi>'\<^esup>\<rightarrow> l)\<close> apply (rule ccontr) using * icdi_path_swap_le[OF cs(2) _, of \<open>k\<close> \<open>\<pi>'\<close>] cs(3) by (metis eq_up_to_sym le_refl)
   hence csk': \<open>cs\<^bsup>\<pi>'\<^esup> k = [\<pi>' k]\<close> by auto
   with csk show \<open>?case\<close> using cs(3) eq_up_to_apply by auto
 qed
 
 lemma cs_path_swap_le: assumes \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> \<open>\<pi> =\<^bsub>n\<^esub>  \<pi>'\<close> \<open>k \<le> n\<close> shows \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k\<close> by (metis assms cs_path_swap eq_up_to_le)
 
 lemma cs_path_swap_cd: assumes \<open>is_path \<pi>\<close> and \<open>is_path \<pi>'\<close> and \<open>cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n'\<close> and \<open>n cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> 
 obtains k' where \<open>n' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> k'\<close> and \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k'\<close>
 proof -
   from cd_in_cs[OF assms(4)]
   obtain ns where *: \<open>cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>\<^esup> k @ ns @ [\<pi> n]\<close> by blast
   obtain xs x where csk: \<open>cs\<^bsup>\<pi>\<^esup> k = xs @ [x]\<close> by (metis cs_not_nil rev_exhaust)
   have \<open>\<pi> n = \<pi>' n'\<close> using assms(3) last_cs by metis
   hence **: \<open>cs\<^bsup>\<pi>'\<^esup> n' = xs@[x]@ns@[\<pi>' n']\<close> using * assms(3) csk by auto
   from cs_split[OF **]
   obtain k' where \<open>cs\<^bsup>\<pi>'\<^esup> k' = xs @ [x]\<close> \<open>n' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> k'\<close> by blast
   thus \<open>thesis\<close> using that csk by auto
 qed
 
 lemma path_ipd_swap: assumes \<open>is_path \<pi>\<close> \<open>\<pi> k \<noteq> return\<close> \<open>k < n\<close> 
 obtains \<pi>' m where \<open>is_path \<pi>'\<close> \<open>\<pi> =\<^bsub>n\<^esub>  \<pi>'\<close> \<open>k < m\<close> \<open>\<pi>' m = ipd (\<pi>' k)\<close> \<open>\<forall> l \<in> {k..<m}. \<pi>' l \<noteq> ipd (\<pi>' k)\<close>
 proof -
   obtain \<pi>' r where *: \<open>\<pi>' 0 = \<pi> n\<close> \<open>is_path \<pi>'\<close> \<open>\<pi>' r = return\<close> by (metis assms(1) path_nodes reaching_ret)
   let \<open>?\<pi>\<close> = \<open>\<pi>@\<^bsup>n\<^esup>  \<pi>'\<close>
   have path: \<open>is_path ?\<pi>\<close> and ret: \<open>?\<pi> (n + r) = return\<close> and equpto:  \<open>?\<pi> =\<^bsub>n\<^esub>  \<pi>\<close> using assms path_cons * path_append_eq_up_to by auto
   have \<pi>k: \<open>?\<pi> k = \<pi> k\<close> by (metis assms(3) less_imp_le_nat path_append_def)
   obtain j where j: \<open>k < j \<and> j \<le> (n + r) \<and> ?\<pi> j = ipd (\<pi> k)\<close> (is \<open>?P j\<close> )by (metis \<pi>k assms(2) path path_ret_ipd ret)
   define m where m: \<open>m \<equiv> LEAST m . ?P m\<close>
   have Pm: \<open>?P m\<close> using LeastI[of \<open>?P\<close> \<open>j\<close>] j m by auto
   hence km: \<open>k < m\<close> \<open>m \<le> (n + r)\<close> \<open>?\<pi> m = ipd (\<pi> k)\<close> by auto
   have le: \<open>\<And>l. ?P l \<Longrightarrow> m \<le> l\<close> using Least_le[of \<open>?P\<close>] m by blast
   have \<pi>knipd: \<open>?\<pi> k \<noteq> ipd (\<pi> k)\<close> by (metis \<pi>k assms(1) assms(2) ipd_not_self path_nodes)
   have nipd': \<open>\<And>l. k < l \<Longrightarrow> l < m \<Longrightarrow> ?\<pi> l \<noteq> ipd (\<pi> k)\<close> apply (rule ccontr) using le km(2) by force
   have \<open>\<forall> l \<in> {k..<m}. ?\<pi> l \<noteq> ipd(\<pi> k)\<close> using \<pi>knipd nipd' by(auto, metis le_eq_less_or_eq,metis le_eq_less_or_eq)
   thus \<open>thesis\<close> using that by (metis \<pi>k eq_up_to_sym km(1) km(3) path path_append_eq_up_to)
 qed
 
 lemma cs_sorted_list_of_cd': \<open>cs\<^bsup>\<pi>\<^esup> k = map \<pi> (sorted_list_of_set { i . k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i}) @ [\<pi> k]\<close> 
 proof (induction \<open>\<pi>\<close> \<open>k\<close> rule: cs.induct, cases)
   case (1 \<pi> k)
   assume \<open>\<exists> j. k icd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close>
-  then guess j ..
-  note j = this
+  then obtain j where j: "k icd\<^bsup>\<pi>\<^esup>\<rightarrow> j" ..
   hence csj: \<open>cs\<^bsup>\<pi>\<^esup> j = map \<pi> (sorted_list_of_set {i. j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i}) @ [\<pi> j]\<close> by (metis "1.IH" icd_is_the_icd)
   have \<open>{i. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} = insert j {i. j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i}\<close> using cdi_is_cd_icdi[OF j] by auto
   moreover
   have f: \<open>finite {i. j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i}\<close> unfolding is_cdi_def by auto
   moreover
   have \<open>j \<notin> {i. j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i}\<close> unfolding is_cdi_def by auto
   ultimately
   have \<open>sorted_list_of_set { i . k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} = insort j (sorted_list_of_set { i . j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i})\<close> using sorted_list_of_set_insert by auto
   moreover
   have \<open>\<forall> x \<in>  {i. j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i}. x < j\<close> unfolding is_cdi_def by auto
   hence \<open>\<forall> x \<in> set (sorted_list_of_set {i. j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i}). x < j\<close> by (simp add: f) 
   ultimately
   have \<open>sorted_list_of_set { i . k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} = (sorted_list_of_set { i . j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i})@[j]\<close>  using insort_greater by auto
   hence \<open>cs\<^bsup>\<pi>\<^esup> j = map \<pi> (sorted_list_of_set { i . k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i})\<close> using csj by auto
   thus \<open>?case\<close> by (metis icd_cs j)
 next
   case (1 \<pi> k)
   assume *: \<open>\<not> (\<exists> j. k icd\<^bsup>\<pi>\<^esup>\<rightarrow> j)\<close>
   hence \<open>cs\<^bsup>\<pi>\<^esup> k = [\<pi> k]\<close> by (metis cs_cases)
   moreover 
   have \<open>{ i . k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} = {}\<close> by (auto, metis * excd_impl_exicd)
   ultimately 
   show \<open>?case\<close> by (metis append_Nil list.simps(8) sorted_list_of_set_empty)
 qed
 
 lemma cs_sorted_list_of_cd: \<open>cs\<^bsup>\<pi>\<^esup> k = map \<pi> (sorted_list_of_set ({ i . k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} \<union> {k}))\<close> proof -
   have le: \<open>\<forall> x \<in> {i. k cd\<^bsup>\<pi>\<^esup>\<rightarrow>i}.\<forall> y \<in> {k}. x < y\<close> unfolding is_cdi_def by auto
   have fin: \<open>finite {i. k cd\<^bsup>\<pi>\<^esup>\<rightarrow>i}\<close> \<open>finite {k}\<close> unfolding is_cdi_def by auto  
   show \<open>?thesis\<close> unfolding cs_sorted_list_of_cd'[of \<open>\<pi>\<close> \<open>k\<close>] sorted_list_of_set_append[OF fin le] by auto
 qed
 
 lemma cs_not_ipd: assumes \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> ipd (\<pi> j) \<noteq> ipd (\<pi> k)\<close> (is \<open>?Q j\<close>)
 shows \<open>cs\<^bsup>\<pi>\<^esup> (GREATEST j. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> ipd (\<pi> j) \<noteq> ipd (\<pi> k)) = [n\<leftarrow>cs\<^bsup>\<pi>\<^esup> k . ipd n \<noteq> ipd (\<pi> k)]\<close>
 (is \<open>cs\<^bsup>\<pi>\<^esup> ?j = filter ?P _\<close>) 
 proof -  
   have csk: \<open>cs\<^bsup>\<pi>\<^esup> k = map \<pi> (sorted_list_of_set ({ i . k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i } \<union> {k}))\<close> by (metis cs_sorted_list_of_cd)
   have csj: \<open>cs\<^bsup>\<pi>\<^esup> ?j = map \<pi> (sorted_list_of_set ({i. ?j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i } \<union> {?j}))\<close> by (metis cs_sorted_list_of_cd)
   
   have bound: \<open>\<forall> j. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> ipd (\<pi> j) \<noteq> ipd(\<pi> k) \<longrightarrow> j \<le> k\<close> unfolding is_cdi_def by simp
     
   have kcdj: \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> ?j\<close> and ipd': \<open>ipd (\<pi> ?j) \<noteq> ipd(\<pi> k)\<close> using GreatestI_nat[of \<open>?Q\<close> \<open>j\<close> \<open>k\<close>, OF assms] bound by auto
    
   have greatest: \<open>\<And> j. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<Longrightarrow> ipd (\<pi> j) \<noteq> ipd (\<pi> k) \<Longrightarrow> j \<le> ?j\<close> using Greatest_le_nat[of \<open>?Q\<close>  _ \<open>k\<close>] bound by auto
   have less_not_ipdk: \<open>\<And> j. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<Longrightarrow> j < ?j \<Longrightarrow> ipd (\<pi> j) \<noteq> ipd (\<pi> k)\<close>   by (metis (lifting) ipd' kcdj same_ipd_stable)
   hence le_not_ipdk: \<open>\<And> j. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<Longrightarrow> j \<le> ?j \<Longrightarrow> ipd (\<pi> j) \<noteq> ipd (\<pi> k)\<close> using kcdj ipd' by (case_tac \<open>j = ?j\<close>,auto)
   have *: \<open>{j \<in> {i. k cd\<^bsup>\<pi>\<^esup>\<rightarrow>i} \<union> {k}. ?P (\<pi> j)} = insert ?j { i . ?j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} \<close> 
     apply auto  
     apply (metis (lifting, no_types) greatest cr_wn'' kcdj le_antisym le_refl)
     apply (metis kcdj)
     apply (metis ipd')
     apply (metis (full_types) cd_trans kcdj)
     apply (subgoal_tac \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> x\<close>)
     apply (metis (lifting, no_types) is_cdi_def less_not_ipdk)
     by (metis (full_types) cd_trans kcdj)
   have \<open>finite ({i . k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} \<union> {k})\<close> unfolding is_cdi_def by auto
   note filter_sorted_list_of_set[OF this, of \<open>?P o \<pi>\<close>]
   hence \<open>[n\<leftarrow>cs\<^bsup>\<pi>\<^esup> k . ipd n \<noteq> ipd(\<pi> k)] = map \<pi> (sorted_list_of_set {j \<in> {i. k cd\<^bsup>\<pi>\<^esup>\<rightarrow>i} \<union> {k}. ?P (\<pi> j)})\<close> unfolding csk filter_map by auto 
   also 
   have \<open>\<dots> =  map \<pi> (sorted_list_of_set (insert ?j { i . ?j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i}))\<close> unfolding * by auto
   also 
   have \<open>\<dots> = cs\<^bsup>\<pi>\<^esup> ?j\<close> using csj by auto
   finally 
   show \<open>?thesis\<close> by metis
 qed
 
 lemma cs_ipd: assumes ipd: \<open>\<pi> m = ipd (\<pi> k)\<close> \<open>\<forall> n \<in> {k..<m}. \<pi> n \<noteq> ipd (\<pi> k)\<close>
 and km: \<open>k < m\<close> shows \<open>cs\<^bsup>\<pi>\<^esup> m = [n\<leftarrow>cs\<^bsup>\<pi>\<^esup> k . ipd n \<noteq> \<pi> m] @ [\<pi> m]\<close>
 proof cases
   assume \<open>\<exists> j. m icd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close>  
   then obtain j where jicd: \<open>m icd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> by blast
   hence *: \<open>cs\<^bsup>\<pi>\<^esup> m = cs\<^bsup>\<pi>\<^esup> j @ [\<pi> m]\<close> by (metis icd_cs)
   have j: \<open>j = (GREATEST j. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> ipd (\<pi> j) \<noteq> \<pi> m)\<close> using jicd assms ipd_icd_greatest_cd_not_ipd by blast
   moreover
   have \<open>ipd (\<pi> j) \<noteq> ipd (\<pi> k)\<close> by (metis is_cdi_def is_icdi_def is_ipd_def cd_not_pd ipd(1) ipd_is_ipd jicd path_nodes less_imp_le term_path_stable)
   moreover
   have \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> unfolding j by (metis (lifting, no_types) assms(3) cd_ipd_is_cd icd_imp_cd ipd(1) ipd(2) j jicd)
   ultimately
   have \<open>cs\<^bsup>\<pi>\<^esup> j = [n\<leftarrow>cs\<^bsup>\<pi>\<^esup> k . ipd n \<noteq> \<pi> m]\<close> using cs_not_ipd[of \<open>k\<close> \<open>\<pi>\<close> \<open>j\<close>] ipd(1) by metis
   thus \<open>?thesis\<close> using * by metis
 next
   assume noicd: \<open>\<not> (\<exists> j. m icd\<^bsup>\<pi>\<^esup>\<rightarrow> j)\<close>  
   hence csm: \<open>cs\<^bsup>\<pi>\<^esup> m = [\<pi> m]\<close> by auto
   have \<open>\<And>j. k cd\<^bsup>\<pi>\<^esup>\<rightarrow>j \<Longrightarrow> ipd(\<pi> j) = \<pi> m\<close> using cd_is_cd_ipd[OF km ipd] by (metis excd_impl_exicd noicd)
   hence *: \<open>{j \<in> {i. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} \<union> {k}. ipd (\<pi> j) \<noteq> \<pi> m} = {}\<close> using ipd(1) by auto
   have **: \<open>((\<lambda>n. ipd n \<noteq> \<pi> m) o \<pi>) = (\<lambda>n. ipd (\<pi> n) \<noteq> \<pi> m)\<close> by auto
   have fin: \<open>finite ({i. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} \<union> {k})\<close> unfolding is_cdi_def by auto
   note csk = cs_sorted_list_of_cd[of \<open>\<pi>\<close> \<open>k\<close>]
   hence \<open>[n\<leftarrow>cs\<^bsup>\<pi>\<^esup> k . ipd n \<noteq> \<pi> m] = [n\<leftarrow> (map \<pi> (sorted_list_of_set ({i. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} \<union> {k}))) . ipd n \<noteq> \<pi> m]\<close> by simp
   also
   have \<open>\<dots> = map \<pi> [n <- sorted_list_of_set ({i. k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} \<union> {k}). ipd (\<pi> n) \<noteq> \<pi> m]\<close>  by (auto simp add: filter_map **) 
   also 
   have \<open>\<dots> = []\<close> unfolding * filter_sorted_list_of_set[OF fin, of \<open>\<lambda>n. ipd (\<pi> n) \<noteq> \<pi> m\<close>] by auto
   finally
   show \<open>?thesis\<close> using csm by (metis append_Nil)
 qed
 
 lemma converged_ipd_same_icd: assumes path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and  converge: \<open>l < m\<close> \<open>cs\<^bsup>\<pi>\<^esup> m = cs\<^bsup>\<pi>'\<^esup> m'\<close> 
 and csk: \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k'\<close> and icd: \<open>l icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> and suc: \<open>\<pi> (Suc k) = \<pi>' (Suc k')\<close>
 and ipd: \<open>\<pi>' m' = ipd (\<pi> k)\<close> \<open>\<forall> n \<in> {k'..<m'}. \<pi>' n \<noteq> ipd (\<pi> k)\<close>
 shows \<open>\<exists>l'. cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l'\<close>
 proof cases
   assume l: \<open>l = Suc k\<close>
   hence \<open>Suc k cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> using icd by (metis is_icdi_def)
   hence \<open>\<pi> (Suc k) \<noteq> ipd (\<pi> k)\<close> unfolding is_cdi_def by auto
   hence \<open>\<pi>' (Suc k') \<noteq> ipd (\<pi>' k')\<close> by (metis csk last_cs suc)
   moreover 
   have \<open>\<pi>' (Suc k') \<noteq> return\<close> by (metis \<open>Suc k cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> ret_no_cd suc)
   ultimately
   have \<open>Suc k' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> k'\<close> unfolding is_cdi_def using path(2) apply auto 
   by (metis ipd_not_self le_Suc_eq le_antisym path_nodes term_path_stable)
   hence \<open>Suc k' icd\<^bsup>\<pi>'\<^esup>\<rightarrow> k'\<close> unfolding is_icdi_def using path(2) by fastforce  
   hence \<open>cs\<^bsup>\<pi>'\<^esup> (Suc k') = cs\<^bsup>\<pi>'\<^esup> k' @[\<pi>' (Suc k')]\<close> using icd_cs by auto 
   moreover
   have \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>\<^esup> k @ [\<pi> l]\<close> using icd icd_cs by auto
   ultimately 
   have \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> (Suc k')\<close> by (metis csk l suc)
   thus \<open>?thesis\<close> by blast
 next
   assume nsuck: \<open>l \<noteq> Suc k\<close>
   have kk'[simp]: \<open>\<pi>' k' = \<pi> k\<close> by (metis csk last_cs)
   have kl: \<open>k < l\<close> using icd unfolding is_icdi_def is_cdi_def by auto
   hence skl: \<open>Suc k < l\<close> by (metis Suc_lessI nsuck)
   hence lpd: \<open>\<pi> l pd\<rightarrow> \<pi> (Suc k)\<close> using icd icd_pd_intermediate by auto
   have km: \<open>k < m\<close> by (metis converge(1) kl order.strict_trans)  
   have lcd: \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> using icd is_icdi_def by auto
   hence ipdk_pdl: \<open>ipd (\<pi> k) pd\<rightarrow> (\<pi> l)\<close> by (metis ipd_pd_cd)
   have *: \<open>ipd (\<pi> k) \<in> nodes\<close> by (metis ipdk_pdl pd_node1)
   have nretk: \<open>\<pi> k \<noteq> return\<close> by (metis kl lcd path(1) ret_no_cd term_path_stable less_imp_le)
   have **: \<open>\<not> (\<pi> l) pd\<rightarrow> ipd (\<pi> k)\<close> proof 
     assume a: \<open>\<pi> l pd\<rightarrow> ipd (\<pi> k)\<close>
     hence \<open>\<pi> l pd\<rightarrow> (\<pi> k)\<close> by (metis is_ipd_def \<open>k < l\<close> ipd_is_ipd ipdk_pdl path(1) path_nodes pd_antisym term_path_stable less_imp_le)
     moreover 
     have \<open>\<pi> l \<noteq> (\<pi> k)\<close> by (metis "*" a ipd_not_self ipdk_pdl lcd pd_antisym ret_no_cd)
     ultimately
     show \<open>False\<close> using lcd cd_not_pd by auto
   qed
 
   have km': \<open>k' < m'\<close> using cs_order[OF path csk converge(2) nretk km] . 
 
   obtain \<pi>'' n'' where path'': \<open>is_path \<pi>''\<close>  and \<pi>''0: \<open>\<pi>'' 0 = ipd (\<pi> k)\<close> and \<pi>''n: \<open>\<pi>'' n'' = return\<close> and not\<pi>l: \<open>\<forall> i\<le>n''. \<pi>'' i \<noteq> \<pi> l\<close> using no_pd_path[OF * **] .
   let \<open>?\<pi>'\<close> = \<open>(\<pi>' @\<^bsup>m'\<^esup> \<pi>'') \<guillemotleft> Suc k'\<close>
   have \<open>is_path ?\<pi>'\<close> by (metis \<pi>''0 ipd(1) path'' path(2) path_cons path_path_shift)
   moreover 
   have \<open>?\<pi>' 0 = \<pi> (Suc k)\<close> using km' suc by auto
   moreover
   have \<open>?\<pi>' (m' - Suc k' + n'') = return\<close> using \<pi>''n km' \<pi>''0 ipd(1) by auto  
   ultimately
   obtain l'' where l'': \<open>l'' \<le> m' - Suc k' + n''\<close> \<open>?\<pi>' l'' = \<pi> l\<close> using lpd unfolding is_pd_def by blast
   have l''m: \<open>l'' \<le> m' - Suc k'\<close> apply (rule ccontr) using l'' not\<pi>l km' by (cases \<open>Suc (k' + l'') \<le> m'\<close>, auto)
   let \<open>?l'\<close> = \<open>Suc ( k' + l'')\<close>
   have lm': \<open>?l' \<le> m'\<close> using l''m km' by auto
   
   \<comment> \<open>Now we have found our desired l'\<close>
   have 1: \<open>\<pi>' ?l' = \<pi> l\<close> using  l'' l''m lm' by auto
   have 2: \<open>k' < ?l'\<close> by simp  
   have 3: \<open>?l' < m'\<close> apply (rule ccontr) using lm' by (simp, metis "**" 1 ipd(1) ipdk_pdl)  
   
   \<comment> \<open>Need the least such l'\<close>
 
   let \<open>?P\<close> = \<open>\<lambda> l'. \<pi>' l' = \<pi> l \<and> k' < l' \<and> l' < m'\<close>
 
   have *: \<open>?P ?l'\<close> using 1 2 3 by blast
 
   define l' where l': \<open>l' == LEAST l'. ?P l'\<close>
   
   have \<pi>l': \<open>\<pi>' l' = \<pi> l\<close> using l' 1 2 3 LeastI[of \<open>?P\<close>] by blast  
   have kl': \<open>k' < l'\<close> using l' 1 2 3 LeastI[of \<open>?P\<close>] by blast
   have lm': \<open>l' < m'\<close> using l' 1 2 3 LeastI[of \<open>?P\<close>] by blast  
 
   have nretl': \<open>\<pi>' l' \<noteq> return\<close> by (metis \<pi>''n \<pi>l' le_refl not\<pi>l)
  
   have nipd': \<open>\<forall> j \<in> {k'..l'}. \<pi>' j \<noteq> ipd (\<pi>' k')\<close> using lm' kk' ipd(2) kl' by force
  
   have lcd': \<open>l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> k'\<close> by (metis is_cdi_def kl' nipd' nretl' path(2))
 
   have licd: \<open>l' icd\<^bsup>\<pi>'\<^esup>\<rightarrow> k'\<close> proof -
     have \<open>\<forall> m \<in> {k'<..<l'}. \<not> l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> m\<close> proof (rule ccontr)
       assume \<open>\<not> (\<forall> m \<in> {k'<..<l'}. \<not> l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> m)\<close>
       then obtain j' where kj': \<open>k' < j'\<close> and jl': \<open>j' < l'\<close> and lcdj': \<open>l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j'\<close> by force
       have jm': \<open>j'<m'\<close> by (metis jl' lm' order.strict_trans)
       have \<open>\<pi>' j' \<noteq> \<pi> l\<close> apply (rule ccontr) using l' kj' jm' jl' Least_le[of \<open>?P\<close> \<open>j'\<close>] by auto       
       hence \<open>\<not> \<pi>' l' pd\<rightarrow> \<pi>' j'\<close> using cd_not_pd lcdj' \<pi>l' by metis
       moreover have \<open>\<pi>' j' \<in> nodes\<close> using path(2) path_nodes by auto
       ultimately
       obtain \<pi>\<^sub>1 n\<^sub>1 where path\<^sub>1: \<open>is_path \<pi>\<^sub>1\<close> and \<pi>0\<^sub>1: \<open>\<pi>\<^sub>1 0 = \<pi>' j'\<close> and \<pi>n\<^sub>1: \<open>\<pi>\<^sub>1 n\<^sub>1 = return\<close> and nl': \<open>\<forall> l \<le>n\<^sub>1. \<pi>\<^sub>1 l \<noteq> \<pi>' l'\<close> unfolding is_pd_def by blast
       let \<open>?\<pi>''\<close> = \<open>(\<pi>'@\<^bsup>j'\<^esup> \<pi>\<^sub>1) \<guillemotleft> Suc k'\<close>
       have \<open>is_path ?\<pi>''\<close> by (metis \<pi>0\<^sub>1 path(2) path\<^sub>1 path_cons path_path_shift)
       moreover
       have \<open>?\<pi>'' 0 = \<pi> (Suc k)\<close> by (simp, metis kj' less_eq_Suc_le suc)
       moreover
       have kj': \<open>Suc k' \<le> j'\<close> by (metis kj' less_eq_Suc_le)
       hence \<open>?\<pi>'' (j' - Suc k' + n\<^sub>1) = return\<close> by (simp, metis \<pi>0\<^sub>1 \<pi>n\<^sub>1)
       ultimately
       obtain l'' where *: \<open>?\<pi>'' l'' = \<pi> l\<close> and **: \<open>l'' \<le>j' - Suc k' + n\<^sub>1\<close> using lpd is_pd_def by blast      
       show \<open>False\<close> proof (cases)
         assume a: \<open>l'' \<le> j' - Suc k'\<close>        
         hence \<open>\<pi>' (l'' + Suc k') = \<pi> l\<close> using * kj' by(simp, metis Nat.le_diff_conv2 add_Suc diff_add_inverse le_add1 le_add_diff_inverse2)
         moreover 
         have \<open>l'' + Suc k' < l'\<close> by (metis a jl' add_diff_cancel_right' kj' le_add_diff_inverse less_imp_diff_less ordered_cancel_comm_monoid_diff_class.le_diff_conv2)
         moreover
         have \<open>l'' + Suc k' < m'\<close> by (metis Suc_lessD calculation(2) less_trans_Suc lm')
         moreover 
         have \<open>k' < l'' + Suc k'\<close> by simp
         ultimately
         show \<open>False\<close> using Least_le[of \<open>?P\<close> \<open>l'' + Suc k'\<close>] l' by auto
       next
         assume a: \<open>\<not> l'' \<le> j' - Suc k'\<close>
         hence \<open>\<not> Suc (k' + l'') \<le> j'\<close> by simp
         hence \<open>\<pi>\<^sub>1 (Suc (k' + l'') - j') = \<pi> l\<close> using * kj' by simp 
         moreover 
         have \<open>Suc (k' + l'') - j' \<le> n\<^sub>1\<close> using ** kj' by simp
         ultimately
         show \<open>False\<close> using nl' by (metis \<pi>l')
       qed
     qed
     thus \<open>?thesis\<close> unfolding is_icdi_def using lcd' path(2) by simp
   qed
   hence \<open>cs\<^bsup>\<pi>'\<^esup> l' = cs\<^bsup>\<pi>'\<^esup> k' @ [\<pi>' l']\<close> by (metis icd_cs)
   hence \<open>cs\<^bsup>\<pi>'\<^esup> l' = cs\<^bsup>\<pi>\<^esup> l\<close> by (metis \<pi>l' csk icd icd_cs)
   thus \<open>?thesis\<close> by metis
 qed
 
 lemma converged_same_icd: assumes path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and converge: \<open>l < n\<close> \<open>cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n'\<close> 
 and csk: \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k'\<close> and icd: \<open>l icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> and suc: \<open>\<pi> (Suc k) = \<pi>' (Suc k')\<close>
 shows \<open>\<exists>l'. cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l'\<close> proof -
   
   have nret: \<open>\<pi> k \<noteq> return\<close> using icd unfolding is_icdi_def is_cdi_def using term_path_stable less_imp_le by metis 
   have kl: \<open>k < l\<close> using icd unfolding is_icdi_def is_cdi_def by auto
   have kn: \<open>k < n\<close> using converge kl by simp
   from path_ipd_swap[OF path(1) nret kn]
   obtain \<rho> m where path\<rho>: \<open>is_path \<rho>\<close> and \<pi>\<rho>: \<open>\<pi> =\<^bsub>n\<^esub>  \<rho>\<close> and km: \<open>k < m\<close> and ipd: \<open>\<rho> m = ipd (\<rho> k)\<close> \<open>\<forall> l \<in> {k..<m}. \<rho> l \<noteq> ipd (\<rho> k)\<close> .
   have csk1: \<open>cs\<^bsup>\<rho>\<^esup> k = cs\<^bsup>\<pi>\<^esup> k\<close> using cs_path_swap_le path path\<rho> \<pi>\<rho> kn by auto
   have suc\<rho>: \<open>\<rho> (Suc k) = \<pi> (Suc k)\<close> by (metis \<pi>\<rho> eq_up_to_def kn less_eq_Suc_le)
 
   have nret': \<open>\<pi>' k' \<noteq> return\<close> by (metis csk last_cs nret)
   have kn': \<open>k' < n'\<close> using cs_order[OF path csk converge(2) nret kn] .
   from path_ipd_swap[OF path(2) nret' kn']
   obtain \<rho>' m' where path\<rho>': \<open>is_path \<rho>'\<close> and \<pi>\<rho>': \<open>\<pi>' =\<^bsub>n'\<^esub> \<rho>'\<close> and km': \<open>k' < m'\<close> and ipd': \<open>\<rho>' m' = ipd (\<rho>' k')\<close> \<open>\<forall> l \<in> {k'..<m'}. \<rho>' l \<noteq> ipd (\<rho>' k')\<close> .
   have csk1': \<open>cs\<^bsup>\<rho>'\<^esup> k' = cs\<^bsup>\<pi>'\<^esup> k'\<close> using cs_path_swap_le path path\<rho>' \<pi>\<rho>' kn' by auto
   have suc\<rho>': \<open>\<rho>' (Suc k') = \<pi>' (Suc k')\<close> by (metis \<pi>\<rho>' eq_up_to_def kn' less_eq_Suc_le)
   
   have icd\<rho>: \<open>l icd\<^bsup>\<rho>\<^esup>\<rightarrow> k\<close> using icdi_path_swap_le[OF path\<rho> icd \<pi>\<rho>] converge by simp
 
   have lm: \<open>l < m\<close> using ipd(1) icd\<rho> km unfolding is_icdi_def is_cdi_def by auto
 
   have csk': \<open>cs\<^bsup>\<rho>\<^esup> k = cs\<^bsup>\<rho>'\<^esup> k'\<close> using csk1 csk1' csk by auto
 
   hence kk': \<open>\<rho>' k' = \<rho> k\<close> using last_cs by metis
 
   have suc': \<open>\<rho> (Suc k) = \<rho>' (Suc k')\<close> using suc suc\<rho> suc\<rho>' by auto
 
   have mm': \<open>\<rho>' m' = \<rho> m\<close> using ipd(1) ipd'(1) kk' by auto
 
   from cs_ipd[OF ipd km] cs_ipd[OF ipd' km',unfolded mm', folded csk']  
   have csm: \<open>cs\<^bsup>\<rho>\<^esup> m = cs\<^bsup>\<rho>'\<^esup> m'\<close> by metis
 
   from converged_ipd_same_icd[OF path\<rho> path\<rho>' lm  csm csk' icd\<rho> suc' ipd'[unfolded kk']]
   obtain l' where csl: \<open>cs\<^bsup>\<rho>\<^esup> l = cs\<^bsup>\<rho>'\<^esup> l'\<close> by blast
   
   have csl\<rho>: \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<rho>\<^esup> l\<close> using \<pi>\<rho> converge(1) cs_path_swap_le less_imp_le_nat path(1) path\<rho> by blast 
 
   have nretl: \<open>\<rho> l \<noteq> return\<close> by (metis icd\<rho> icd_imp_cd ret_no_cd)
 
   have csn': \<open>cs\<^bsup>\<rho>\<^esup> n = cs\<^bsup>\<rho>'\<^esup> n'\<close> using converge(2) cs_path_swap path path\<rho> path\<rho>' \<pi>\<rho> \<pi>\<rho>' by auto
   
   have ln': \<open>l' < n'\<close> using cs_order[OF path\<rho> path\<rho>' csl csn' nretl converge(1)] .
     
   have csl\<rho>': \<open>cs\<^bsup>\<pi>'\<^esup> l' = cs\<^bsup>\<rho>'\<^esup> l'\<close> using cs_path_swap_le[OF path(2) path\<rho>' \<pi>\<rho>'] ln' by auto
 
   have csl': \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l'\<close> using csl\<rho> csl\<rho>' csl by auto
   thus \<open>?thesis\<close> by blast
 qed
 
 lemma cd_is_cs_less: assumes \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> shows \<open>cs\<^bsup>\<pi>\<^esup> k \<prec> cs\<^bsup>\<pi>\<^esup> l\<close> proof -
   obtain xs where csl: \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>\<^esup> k @ xs @[\<pi> l]\<close> using cd_in_cs[OF assms] by blast
   hence len: \<open>length(cs\<^bsup>\<pi>\<^esup> k) < length (cs\<^bsup>\<pi>\<^esup> l)\<close> by auto
   have take: \<open>take (length (cs\<^bsup>\<pi>\<^esup> k)) (cs\<^bsup>\<pi>\<^esup> l) = cs\<^bsup>\<pi>\<^esup> k\<close> using csl by auto
   show \<open>?thesis\<close> using cs_less.intros[OF len take] . 
 qed
 
 lemma cs_select_id: assumes \<open>is_path \<pi>\<close> \<open>\<pi> k \<noteq> return\<close> shows \<open>\<pi>\<exclamdown>cs\<^bsup>\<pi>\<^esup> k = k\<close> (is \<open>?k = k\<close>) proof -
   have *: \<open>\<And> i . cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>\<^esup> k  \<Longrightarrow> i = k\<close> using cs_inj[OF assms] by metis  
   hence \<open>cs\<^bsup>\<pi>\<^esup> ?k = cs\<^bsup>\<pi>\<^esup> k\<close> unfolding cs_select_def using theI[of \<open>\<lambda> i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>\<^esup> k\<close> \<open>k\<close>] by auto
   thus \<open>?k = k\<close> using * by auto
 qed
 
 lemma cs_single_nocd: assumes \<open>cs\<^bsup>\<pi>\<^esup> i = [x]\<close> shows \<open>\<forall> k. \<not> i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> proof -
   have \<open>\<not> (\<exists> k. i icd\<^bsup>\<pi>\<^esup>\<rightarrow> k)\<close> apply (rule ccontr) using assms cs_not_nil by auto
   hence \<open>\<not> (\<exists> k. i cd\<^bsup>\<pi>\<^esup>\<rightarrow> k)\<close> by (metis excd_impl_exicd)
   thus \<open>?thesis\<close> by blast
 qed
 
 lemma cs_single_pd_intermed: assumes \<open>is_path \<pi>\<close> \<open>cs\<^bsup>\<pi>\<^esup> n = [\<pi> n]\<close> \<open>k \<le> n\<close> shows \<open>\<pi> n pd\<rightarrow> \<pi> k\<close> proof -
   have \<open>\<forall> l. \<not> n icd\<^bsup>\<pi>\<^esup>\<rightarrow> l\<close> by (metis assms(2) cs_single_nocd icd_imp_cd)
   thus \<open>?thesis\<close> by (metis assms(1) assms(3) no_icd_pd)
 qed
 
 
 lemma cs_first_pd:  assumes path: \<open>is_path \<pi>\<close> and pd: \<open>\<pi> n pd\<rightarrow> \<pi> 0\<close> and first: \<open>\<forall> l < n. \<pi> l \<noteq> \<pi> n\<close> shows \<open>cs\<^bsup>\<pi>\<^esup> n = [\<pi> n]\<close> 
 by (metis cs_cases first first_pd_no_cd icd_imp_cd path pd)
 
 lemma converged_pd_cs_single: assumes path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and  converge: \<open>l < m\<close> \<open>cs\<^bsup>\<pi>\<^esup> m = cs\<^bsup>\<pi>'\<^esup> m'\<close> 
 and \<pi>0: \<open>\<pi> 0 = \<pi>' 0\<close> and mpdl: \<open>\<pi> m pd\<rightarrow> \<pi> l\<close> and csl: \<open>cs\<^bsup>\<pi>\<^esup> l = [\<pi> l]\<close>
 shows \<open>\<exists>l'. cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l'\<close> proof -
   have *: \<open>\<pi> l pd\<rightarrow> \<pi>' 0\<close> using cs_single_pd_intermed[OF path(1) csl] \<pi>0[symmetric] by auto
   have \<pi>m: \<open>\<pi> m = \<pi>' m'\<close> by (metis converge(2) last_cs)
   hence **: \<open>\<pi>' m' pd\<rightarrow> \<pi> l\<close> using mpdl by metis
   
   obtain l' where lm': \<open>l' \<le> m'\<close> and \<pi>l:  \<open>\<pi>' l' = \<pi> l\<close> (is \<open>?P l'\<close>) using path_pd_pd0[OF path(2) ** *] .
   
   let \<open>?l\<close> = \<open>(LEAST l'. \<pi>' l' = \<pi> l)\<close>
   
   have \<pi>l': \<open>\<pi>' ?l = \<pi> l\<close> using LeastI[of \<open>?P\<close>,OF \<pi>l] .
   moreover
   have \<open>\<forall> i <?l. \<pi>' i \<noteq> \<pi> l\<close> using Least_le[of \<open>?P\<close>] by (metis not_less)
   hence \<open>\<forall> i <?l. \<pi>' i \<noteq> \<pi>' ?l\<close> using \<pi>l' by metis
   moreover
   have \<open>\<pi>' ?l pd\<rightarrow> \<pi>' 0\<close> using * \<pi>l' by metis
   ultimately
   have \<open>cs\<^bsup>\<pi>'\<^esup> ?l = [\<pi>' ?l]\<close> using cs_first_pd[OF path(2)] by metis
   thus \<open>?thesis\<close> using csl \<pi>l' by metis
 qed
 
 lemma converged_cs_single: assumes path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and  converge: \<open>l < m\<close> \<open>cs\<^bsup>\<pi>\<^esup> m = cs\<^bsup>\<pi>'\<^esup> m'\<close> 
 and \<pi>0: \<open>\<pi> 0 = \<pi>' 0\<close> and csl: \<open>cs\<^bsup>\<pi>\<^esup> l = [\<pi> l]\<close>
 shows \<open>\<exists>l'. cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l'\<close> proof cases
   assume *: \<open>\<pi> l = return\<close>  
   hence \<open>\<pi> m = return\<close> by (metis converge(1) path(1) term_path_stable less_imp_le)
   hence \<open>cs\<^bsup>\<pi>\<^esup> m = [return]\<close> using cs_return by auto
   hence \<open>cs\<^bsup>\<pi>'\<^esup> m' = [return]\<close> using converge by simp
   moreover
   have \<open>cs\<^bsup>\<pi>\<^esup> l = [return]\<close> using * cs_return by auto
   ultimately show \<open>?thesis\<close> by metis
 next
   assume nret: \<open>\<pi> l \<noteq> return\<close>
   have \<pi>m: \<open>\<pi> m = \<pi>' m'\<close> by (metis converge(2) last_cs)
   
   obtain \<pi>\<^sub>1 n where path1: \<open>is_path \<pi>\<^sub>1\<close> and upto: \<open>\<pi> =\<^bsub>m\<^esub> \<pi>\<^sub>1\<close> and \<pi>n: \<open>\<pi>\<^sub>1 n = return\<close> using path(1) path_swap_ret by blast
 
   obtain \<pi>\<^sub>1' n' where path1': \<open>is_path \<pi>\<^sub>1'\<close> and upto': \<open>\<pi>' =\<^bsub>m'\<^esub>  \<pi>\<^sub>1'\<close> and \<pi>n': \<open>\<pi>\<^sub>1' n' = return\<close> using path(2) path_swap_ret by blast
 
   have \<pi>1l: \<open>\<pi>\<^sub>1 l = \<pi> l\<close> using upto converge(1) by (metis eq_up_to_def nat_less_le)
 
   have cs1l: \<open>cs\<^bsup>\<pi>\<^sub>1\<^esup> l = cs\<^bsup>\<pi>\<^esup> l\<close> using cs_path_swap_le upto path1 path(1) converge(1) by auto
 
   have csl1: \<open>cs\<^bsup>\<pi>\<^sub>1\<^esup> l = [\<pi>\<^sub>1 l]\<close> by (metis \<pi>1l cs1l csl)
   
   have converge1: \<open>cs\<^bsup>\<pi>\<^sub>1\<^esup> n = cs\<^bsup>\<pi>\<^sub>1'\<^esup> n'\<close> using \<pi>n \<pi>n' cs_return by auto
   
   have ln: \<open>l < n\<close> using nret \<pi>n \<pi>1l term_path_stable[OF path1 \<pi>n] by (auto, metis linorder_neqE_nat less_imp_le)
 
   have \<pi>01: \<open>\<pi>\<^sub>1 0 = \<pi>\<^sub>1' 0\<close> using \<pi>0 eq_up_to_apply[OF upto] eq_up_to_apply[OF upto'] by auto
 
   have pd: \<open>\<pi>\<^sub>1 n pd\<rightarrow> \<pi>\<^sub>1 l\<close> using \<pi>n by (metis path1 path_nodes return_pd)
   
   obtain l' where csl: \<open>cs\<^bsup>\<pi>\<^sub>1\<^esup> l = cs\<^bsup>\<pi>\<^sub>1'\<^esup> l'\<close> using converged_pd_cs_single[OF path1 path1' ln converge1 \<pi>01 pd csl1] by blast
 
   have cs1m: \<open>cs\<^bsup>\<pi>\<^sub>1\<^esup> m = cs\<^bsup>\<pi>\<^esup> m\<close> using cs_path_swap upto path1 path(1) by auto
   have cs1m': \<open>cs\<^bsup>\<pi>\<^sub>1'\<^esup> m' = cs\<^bsup>\<pi>'\<^esup> m'\<close> using cs_path_swap upto' path1' path(2) by auto
   hence converge1: \<open>cs\<^bsup>\<pi>\<^sub>1\<^esup> m = cs\<^bsup>\<pi>\<^sub>1'\<^esup> m'\<close> using converge(2) cs1m by metis
   
   have nret1: \<open>\<pi>\<^sub>1 l \<noteq> return\<close> using nret \<pi>1l by auto
   
   have lm': \<open>l' < m'\<close> using cs_order[OF path1 path1' csl converge1 nret1 converge(1)] .
   
   have \<open>cs\<^bsup>\<pi>'\<^esup> l' = cs\<^bsup>\<pi>\<^sub>1'\<^esup> l'\<close> using cs_path_swap_le[OF path(2) path1' upto'] lm' by auto
   moreover
   have \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>\<^sub>1\<^esup> l\<close> using cs_path_swap_le[OF path(1) path1 upto] converge(1) by auto
   ultimately
   have \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l'\<close> using csl by auto
   thus \<open>?thesis\<close> by blast
 qed
 
 lemma converged_cd_same_suc: assumes path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and init: \<open>\<pi> 0 = \<pi>' 0\<close> 
 and cd_suc: \<open>\<forall> k k'. cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k' \<and> l cd\<^bsup>\<pi>\<^esup>\<rightarrow> k \<longrightarrow> \<pi> (Suc k) = \<pi>' (Suc k')\<close> and converge: \<open>l < m\<close> \<open>cs\<^bsup>\<pi>\<^esup> m = cs\<^bsup>\<pi>'\<^esup> m'\<close> 
 shows  \<open>\<exists>l'. cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l'\<close>
 using path init cd_suc converge proof (induction \<open>\<pi>\<close> \<open>l\<close> rule: cs_induct,cases)
   case (cs \<pi> l)
   assume *: \<open>\<exists>k. l icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close>
   let \<open>?k\<close> = \<open>THE k. l icd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close>
   have icd: \<open>l icd\<^bsup>\<pi>\<^esup>\<rightarrow> ?k\<close> by (metis "*" icd_is_the_icd)
   hence lcdk: \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> ?k\<close> by (metis is_icdi_def)
   hence kl: \<open>?k<l\<close> using is_cdi_def by metis
   
   have \<open>\<And> j. ?k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<Longrightarrow> l cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> using icd cd_trans is_icdi_def by fast
   hence suc': \<open>\<forall> j j'. cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j' \<and> ?k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<longrightarrow> \<pi> (Suc j) = \<pi>' (Suc j')\<close> using cs.prems(4) by blast
 
   from cs.IH[OF * cs(2) path(2) cs(4) suc'] cs.prems kl 
   have \<open>\<exists>k'. cs\<^bsup>\<pi>\<^esup> (THE k. l icd\<^bsup>\<pi>\<^esup>\<rightarrow> k) = cs\<^bsup>\<pi>'\<^esup> k'\<close> by (metis Suc_lessD less_trans_Suc)
   then obtain k' where csk: \<open>cs\<^bsup>\<pi>\<^esup> ?k = cs\<^bsup>\<pi>'\<^esup> k'\<close> by blast
   
   have suc2: \<open>\<pi> (Suc ?k) = \<pi>' (Suc k')\<close> using cs.prems(4) lcdk csk by auto
 
   have km: \<open>?k < m\<close> using kl cs.prems(5) by simp
   
   from converged_same_icd[OF cs(2) path(2) cs.prems(5) cs.prems(6) csk icd suc2]  
   show \<open>?case\<close> .
 next
   case (cs \<pi> l)
   assume \<open>\<not> (\<exists>k. l icd\<^bsup>\<pi>\<^esup>\<rightarrow> k)\<close>
   hence \<open>cs\<^bsup>\<pi>\<^esup> l = [\<pi> l]\<close> by auto
   with cs converged_cs_single
   show \<open>?case\<close> by metis
 qed
 
 lemma converged_cd_diverge: 
 assumes path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and init: \<open>\<pi> 0 = \<pi>' 0\<close> and notin: \<open>\<not> (\<exists>l'. cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l')\<close> and converge: \<open>l < m\<close> \<open>cs\<^bsup>\<pi>\<^esup> m = cs\<^bsup>\<pi>'\<^esup> m'\<close> 
 obtains k k' where \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k'\<close> \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> \<open>\<pi> (Suc k) \<noteq> \<pi>' (Suc k')\<close>
 using assms converged_cd_same_suc by blast
 
 
 
 lemma converged_cd_same_suc_return: assumes path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and \<pi>0: \<open>\<pi> 0 = \<pi>' 0\<close> 
 and cd_suc: \<open>\<forall> k k'. cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k' \<and> l cd\<^bsup>\<pi>\<^esup>\<rightarrow> k \<longrightarrow> \<pi> (Suc k) = \<pi>' (Suc k')\<close> and ret: \<open>\<pi>' n' = return\<close> 
 shows  \<open>\<exists>l'. cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l'\<close>proof cases
   assume \<open>\<pi> l = return\<close>
   hence \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> n'\<close> using ret cs_return by presburger
   thus \<open>?thesis\<close> by blast
 next
   assume nretl: \<open>\<pi> l \<noteq> return\<close>
   have \<open>\<pi> l \<in> nodes\<close> using path path_nodes by auto
   then obtain \<pi>l n where ipl: \<open>is_path \<pi>l\<close> and \<pi>l:  \<open>\<pi> l = \<pi>l 0\<close> and retn: \<open>\<pi>l n = return\<close> and notl: \<open>\<forall> i>0. \<pi>l i \<noteq> \<pi> l\<close> by (metis direct_path_return nretl)
   hence ip: \<open>is_path (\<pi>@\<^bsup>l\<^esup> \<pi>l)\<close> and l: \<open>(\<pi>@\<^bsup>l\<^esup> \<pi>l) l = \<pi> l\<close> and retl: \<open>(\<pi>@\<^bsup>l\<^esup> \<pi>l) (l + n) = return\<close> and nl: \<open>\<forall> i>l. (\<pi>@\<^bsup>l\<^esup> \<pi>l) i \<noteq> \<pi> l\<close> using path_cons[OF path(1) ipl \<pi>l] by auto
   
   have \<pi>0': \<open>(\<pi>@\<^bsup>l\<^esup> \<pi>l) 0 = \<pi>' 0\<close>  unfolding cs_0 using  \<pi>l \<pi>0  by auto
 
   have csn: \<open>cs\<^bsup>\<pi>@\<^bsup>l\<^esup> \<pi>l\<^esup>  (l+n) = cs\<^bsup>\<pi>'\<^esup> n'\<close> using ret retl cs_return by metis
 
   have eql: \<open>(\<pi>@\<^bsup>l\<^esup> \<pi>l) =\<^bsub>l\<^esub> \<pi>\<close> by (metis path_append_eq_up_to)    
 
   have csl': \<open>cs\<^bsup>\<pi>@\<^bsup>l\<^esup> \<pi>l\<^esup>  l = cs\<^bsup>\<pi>\<^esup> l\<close> using eql cs_path_swap ip path(1) by metis
   
   have \<open>0 < n\<close> using nretl[unfolded \<pi>l] retn by (metis neq0_conv)
   hence ln: \<open>l < l + n\<close> by simp
 
   have *: \<open>\<forall> k k'. cs\<^bsup>\<pi> @\<^bsup>l\<^esup> \<pi>l\<^esup>  k = cs\<^bsup>\<pi>'\<^esup> k' \<and> l cd\<^bsup>\<pi> @\<^bsup>l\<^esup> \<pi>l\<^esup>\<rightarrow> k \<longrightarrow> (\<pi> @\<^bsup>l\<^esup> \<pi>l) (Suc k) = \<pi>' (Suc k')\<close> proof (rule,rule,rule)  
     fix k k' assume *: \<open>cs\<^bsup>\<pi> @\<^bsup>l\<^esup> \<pi>l\<^esup>  k = cs\<^bsup>\<pi>'\<^esup> k' \<and> l cd\<^bsup>\<pi> @\<^bsup>l\<^esup> \<pi>l\<^esup>\<rightarrow> k\<close>
     hence kl: \<open>k < l\<close> using is_cdi_def by auto
     hence \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k' \<and> l cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> using eql * cs_path_swap_le[OF ip path(1) eql,of \<open>k\<close>] cdi_path_swap_le[OF path(1) _ eql,of \<open>l\<close> \<open>k\<close>] by auto
     hence \<open>\<pi> (Suc k) = \<pi>' (Suc k')\<close> using cd_suc by blast
     then show \<open>(\<pi> @\<^bsup>l\<^esup> \<pi>l) (Suc k) = \<pi>' (Suc k')\<close> using cs_path_swap_le[OF ip path(1) eql,of \<open>Suc k\<close>] kl by auto
   qed 
   obtain l' where \<open>cs\<^bsup>\<pi> @\<^bsup>l\<^esup> \<pi>l\<^esup>  l = cs\<^bsup>\<pi>'\<^esup> l'\<close> using converged_cd_same_suc[OF ip path(2) \<pi>0' * ln csn]  by blast
   moreover
   have \<open>cs\<^bsup>\<pi>@\<^bsup>l\<^esup> \<pi>l\<^esup>  l = cs\<^bsup>\<pi>\<^esup> l\<close> using eql by (metis cs_path_swap ip path(1))
   ultimately
   show \<open>?thesis\<close> by metis
 qed
 
 lemma converged_cd_diverge_return: assumes path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and init: \<open>\<pi> 0 = \<pi>' 0\<close> 
 and notin: \<open>\<not> (\<exists>l'. cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l')\<close> and ret: \<open>\<pi>' m' = return\<close> 
 obtains k k' where \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k'\<close> \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> \<open>\<pi> (Suc k) \<noteq> \<pi>' (Suc k')\<close> using converged_cd_same_suc_return[OF path init _ ret, of \<open>l\<close>] notin by blast
 
 lemma returned_missing_cd_or_loop: assumes path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and \<pi>0: \<open>\<pi> 0 = \<pi>' 0\<close> 
 and notin': \<open>\<not>(\<exists> k'. cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k')\<close> and nret: \<open>\<forall> n'. \<pi>' n' \<noteq> return\<close> and ret: \<open>\<pi> n = return\<close> 
 obtains i i' where \<open>i<k\<close> \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'\<close> \<open>\<pi> (Suc i) \<noteq> \<pi>' (Suc i')\<close> \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<or> (\<forall> j'> i'. j' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> i')\<close>
 proof -  
   obtain f where icdf: \<open>\<forall> i'. f (Suc i') icd\<^bsup>\<pi>'\<^esup>\<rightarrow> f i'\<close> and ran: \<open>range f = {i'. \<forall> j'>i'. j' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> i'}\<close> and icdf0: \<open>\<not> (\<exists>i'. f 0 cd\<^bsup>\<pi>'\<^esup>\<rightarrow> i')\<close> using path(2) path_nret_inf_icd_seq nret by blast
   show \<open>thesis\<close> proof cases
     assume \<open>\<exists> j. \<not> (\<exists> i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> (f j))\<close>
     then obtain j where ni\<pi>: \<open>\<not> (\<exists> i. cs\<^bsup>\<pi>'\<^esup> (f j) = cs\<^bsup>\<pi>\<^esup> i)\<close> by metis
     note converged_cd_diverge_return[OF path(2,1) \<pi>0[symmetric] ni\<pi> ret] that
     then obtain i k' where csk: \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> k'\<close> and cdj: \<open>f j cd\<^bsup>\<pi>'\<^esup>\<rightarrow> k'\<close> and div:  \<open>\<pi> (Suc i) \<noteq> \<pi>' (Suc k')\<close> by metis
     have \<open>k' \<in> range f\<close> using cdj proof (induction \<open>j\<close>)
       case 0 thus \<open>?case\<close> using icdf0 by blast
     next
       case (Suc j)
       have icdfj: \<open>f (Suc j) icd\<^bsup>\<pi>'\<^esup>\<rightarrow> f j\<close> using icdf by auto
       show \<open>?case\<close> proof cases
         assume \<open>f (Suc j) icd\<^bsup>\<pi>'\<^esup>\<rightarrow> k'\<close>
         hence \<open>k' = f j\<close> using icdfj  by (metis icd_uniq)
         thus \<open>?case\<close> by auto
       next
         assume \<open>\<not> f (Suc j) icd\<^bsup>\<pi>'\<^esup>\<rightarrow> k'\<close>
         hence \<open>f j cd\<^bsup>\<pi>'\<^esup>\<rightarrow> k'\<close> using cd_impl_icd_cd[OF Suc.prems icdfj] by auto
         thus \<open>?case\<close> using Suc.IH by auto
       qed
     qed
     hence alldep: \<open>\<forall> i'>k'. i' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> k'\<close> using ran by auto
     show \<open>thesis\<close> proof cases
       assume \<open>i < k\<close> with alldep that[OF _ csk div] show \<open>thesis\<close> by blast
     next
       assume \<open>\<not> i < k\<close>
       hence ki: \<open>k\<le>i\<close> by auto
       have \<open>k \<noteq> i\<close> using notin' csk by auto
       hence ki': \<open>k<i\<close> using ki by auto
       obtain ka k' where \<open>cs\<^bsup>\<pi>\<^esup> ka = cs\<^bsup>\<pi>'\<^esup> k'\<close> \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> ka\<close> \<open>\<pi> (Suc ka) \<noteq> \<pi>' (Suc k')\<close>
       using converged_cd_diverge[OF path \<pi>0 notin' ki' csk] by blast
       moreover
       hence \<open>ka < k\<close> unfolding is_cdi_def by auto
       ultimately
       show \<open>?thesis\<close> using that by blast
     qed
   next
     assume \<open>\<not>(\<exists> j. \<not> (\<exists> i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> (f j)))\<close>
     hence allin: \<open>\<forall> j. (\<exists> i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> (f j))\<close> by blast
     define f' where f': \<open>f' \<equiv> \<lambda> j. (SOME i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> (f j))\<close>
     have \<open>\<forall> i. f' i < f' (Suc i)\<close> proof
       fix i
       have csi: \<open>cs\<^bsup>\<pi>'\<^esup> (f i) = cs\<^bsup>\<pi>\<^esup> (f' i)\<close> unfolding f' using allin by (metis (mono_tags) someI_ex)
       have cssuci: \<open>cs\<^bsup>\<pi>'\<^esup> (f (Suc i)) = cs\<^bsup>\<pi>\<^esup> (f' (Suc i))\<close> unfolding f' using allin by (metis (mono_tags) someI_ex)
       have fi: \<open>f i < f (Suc i)\<close> using icdf unfolding is_icdi_def is_cdi_def by auto
       have \<open>f (Suc i) cd\<^bsup>\<pi>'\<^esup>\<rightarrow> f i\<close> using icdf unfolding is_icdi_def by blast
       hence nreti: \<open>\<pi>' (f i) \<noteq> return\<close> by (metis cd_not_ret)
       show \<open>f' i < f' (Suc i)\<close> using cs_order[OF path(2,1) csi cssuci nreti fi] .
     qed
     hence kle: \<open>k < f' (Suc k)\<close> using mono_ge_id[of \<open>f'\<close> \<open>Suc k\<close>] by auto
     have cssk: \<open>cs\<^bsup>\<pi>\<^esup> (f' (Suc k)) = cs\<^bsup>\<pi>'\<^esup> (f (Suc k))\<close> unfolding f' using allin by (metis (mono_tags) someI_ex)
     obtain ka k' where \<open>cs\<^bsup>\<pi>\<^esup> ka = cs\<^bsup>\<pi>'\<^esup> k'\<close> \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> ka\<close> \<open>\<pi> (Suc ka) \<noteq> \<pi>' (Suc k')\<close>
     using converged_cd_diverge[OF path \<pi>0 notin' kle cssk] by blast
     moreover
     hence \<open>ka < k\<close> unfolding is_cdi_def by auto
     ultimately
     show \<open>?thesis\<close> using that by blast
   qed
 qed
 
 lemma missing_cd_or_loop: assumes path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and \<pi>0: \<open>\<pi> 0 = \<pi>' 0\<close> and notin': \<open>\<not>(\<exists> k'. cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k')\<close>  
 obtains i i' where \<open>i < k\<close> \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'\<close> \<open>\<pi> (Suc i) \<noteq> \<pi>' (Suc i')\<close> \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<or> (\<forall> j'> i'. j' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> i')\<close>
 proof cases
   assume \<open>\<exists> n'. \<pi>' n' = return\<close>
   then obtain n' where retn: \<open>\<pi>' n' = return\<close> by blast
   note converged_cd_diverge_return[OF path \<pi>0 notin' retn]
   then obtain ka k' where \<open>cs\<^bsup>\<pi>\<^esup> ka = cs\<^bsup>\<pi>'\<^esup> k'\<close> \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> ka\<close> \<open>\<pi> (Suc ka) \<noteq> \<pi>' (Suc k')\<close> by blast
   moreover
   hence \<open>ka < k\<close> unfolding is_cdi_def by auto
   ultimately show \<open>thesis\<close> using that by simp
 next
   assume \<open>\<not> (\<exists> n'. \<pi>' n' = return)\<close>
   hence notret: \<open>\<forall> n'. \<pi>' n' \<noteq> return\<close> by auto
   then obtain \<pi>l n where ipl: \<open>is_path \<pi>l\<close> and \<pi>l:  \<open>\<pi> k = \<pi>l 0\<close> and retn: \<open>\<pi>l n = return\<close> using reaching_ret path(1) path_nodes by metis
   hence ip: \<open>is_path (\<pi>@\<^bsup>k\<^esup>\<pi>l)\<close> and l: \<open>(\<pi>@\<^bsup>k\<^esup>\<pi>l) k = \<pi> k\<close> and retl: \<open>(\<pi>@\<^bsup>k\<^esup>\<pi>l) (k + n) = return\<close> using path_cons[OF path(1) ipl \<pi>l] by auto
   
   have \<pi>0': \<open>(\<pi>@\<^bsup>k\<^esup>\<pi>l) 0 = \<pi>' 0\<close>  unfolding cs_0 using  \<pi>l \<pi>0  by auto
 
   have eql: \<open>(\<pi>@\<^bsup>k\<^esup>\<pi>l) =\<^bsub>k\<^esub> \<pi>\<close> by (metis path_append_eq_up_to)    
 
   have csl': \<open>cs\<^bsup>\<pi>@\<^bsup>k\<^esup>\<pi>l\<^esup>  k = cs\<^bsup>\<pi>\<^esup> k\<close> using eql cs_path_swap ip path(1) by metis
   
   hence notin: \<open>\<not>(\<exists> k'. cs\<^bsup>\<pi>@\<^bsup>k\<^esup>\<pi>l\<^esup>  k = cs\<^bsup>\<pi>'\<^esup> k')\<close> using notin' by auto
 
   obtain i i' where *: \<open>i < k\<close> and csi: \<open>cs\<^bsup>\<pi>@\<^bsup>k\<^esup>\<pi>l\<^esup>  i = cs\<^bsup>\<pi>'\<^esup> i'\<close> and suci: \<open>(\<pi> @\<^bsup>k\<^esup> \<pi>l) (Suc i) \<noteq> \<pi>' (Suc i')\<close>  and cdloop: \<open>k cd\<^bsup>\<pi>@\<^bsup>k\<^esup>\<pi>l\<^esup>\<rightarrow> i \<or> (\<forall> j'>i'. j' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> i')\<close>
   using returned_missing_cd_or_loop[OF ip path(2) \<pi>0' notin notret retl] by blast
 
   have \<open>i \<noteq> k\<close> using notin csi by auto
   hence ik: \<open>i < k\<close> using * by auto
   hence \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'\<close> using csi cs_path_swap_le[OF ip path(1) eql] by auto
   moreover
   have \<open>\<pi> (Suc i) \<noteq> \<pi>' (Suc i')\<close> using ik eq_up_to_apply[OF eql, of \<open>Suc i\<close>] suci by auto
   moreover
   have \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<or> (\<forall> j'>i'. j' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> i')\<close> using cdloop cdi_path_swap_le[OF path(1) _ eql, of \<open>k\<close> \<open>i\<close>] by auto
   ultimately
   show \<open>thesis\<close> using that[OF *] by blast
 qed
 
 
 lemma path_shift_set_cd: assumes \<open>is_path \<pi>\<close> shows \<open>{k + j| j . n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> j } = {i. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i }\<close>
 proof -
   { fix i
     assume \<open>i\<in>{k+j | j . n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> j }\<close>
     then obtain j where \<open>i = k+j\<close> \<open>n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> j\<close> by auto
     hence \<open>k+n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i\<close> using cd_path_shift[OF _ assms, of \<open>k\<close> \<open>k+j\<close> \<open>k+n\<close>] by simp
     hence \<open>i\<in>{ i. k+n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i }\<close> by blast
   }
   moreover
   { fix i
     assume \<open>i\<in>{ i. k+n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i }\<close>
     hence *: \<open>k+n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i\<close> by blast
     then obtain j where i: \<open>i = k+j\<close> by (metis le_Suc_ex)
     hence \<open>k+n cd\<^bsup>\<pi>\<^esup>\<rightarrow> k+j\<close> using * by auto
     hence \<open>n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> j\<close> using cd_path_shift[OF _ assms, of \<open>k\<close> \<open>k+j\<close> \<open>k+n\<close>] by simp
     hence \<open>i\<in>{k+j | j . n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> j }\<close> using i by simp
   }
   ultimately show \<open>?thesis\<close> by blast
 qed
 
 lemma cs_path_shift_set_cd: assumes path: \<open>is_path \<pi>\<close> shows \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> n = map \<pi> (sorted_list_of_set {i. k+n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i }) @ [\<pi> (k+n)]\<close>
 proof -
   have mono:\<open>\<forall>n m. n < m \<longrightarrow> k + n < k + m\<close> by auto
   have fin: \<open>finite {i. n cd\<^bsup>\<pi> \<guillemotleft> k\<^esup>\<rightarrow> i}\<close> unfolding is_cdi_def by auto
   have *: \<open>(\<lambda> x. k+x)`{i. n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> i} = {k + i | i. n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> i}\<close> by auto
   have \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> n = map (\<pi>\<guillemotleft>k) (sorted_list_of_set {i. n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> i}) @ [(\<pi>\<guillemotleft>k) n]\<close> using cs_sorted_list_of_cd' by blast
   also 
   have \<open>\<dots> = map \<pi> (map (\<lambda> x. k+x) (sorted_list_of_set{i. n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> i})) @ [\<pi> (k+n)]\<close> by auto
   also 
   have \<open>\<dots> = map \<pi> (sorted_list_of_set ((\<lambda> x. k+x)`{i. n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> i})) @ [\<pi> (k+n)]\<close> using sorted_list_of_set_map_mono[OF mono fin] by auto
   also 
   have \<open>\<dots> = map \<pi> (sorted_list_of_set ({k + i | i. n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> i})) @ [\<pi> (k+n)]\<close> using * by auto
   also 
   have \<open>\<dots> = map \<pi> (sorted_list_of_set ({i. k+n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i})) @ [\<pi> (k+n)]\<close> using path_shift_set_cd[OF path] by auto
   finally
   show \<open>?thesis\<close> .
 qed
 
 lemma cs_split_shift_cd: assumes \<open>n cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> and \<open>j < k\<close> and \<open>k < n\<close> and \<open>\<forall>j'<k. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> j' \<longrightarrow> j' \<le> j\<close> shows \<open>cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>\<^esup> j @ cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> (n-k)\<close>
 proof -
   have path: \<open>is_path \<pi>\<close> using assms unfolding is_cdi_def by auto
   have 1: \<open>{i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} = {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> i < k} \<union> {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i}\<close> by auto
   have le: \<open>\<forall> i\<in> {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> i < k}. \<forall> j\<in> {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i}. i < j\<close> by auto
   
   have 2: \<open>{i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> i < k} = {i . j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} \<union> {j}\<close> proof - 
     { fix i assume \<open>i\<in>{i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> i < k}\<close> 
       hence cd: \<open>n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i\<close> and ik:\<open>i < k\<close> by auto
       have \<open>i\<in>{i . j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} \<union> {j}\<close> proof cases
         assume \<open>i < j\<close> hence \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i\<close> by (metis is_cdi_def assms(1) cd cdi_prefix nat_less_le)
         thus \<open>?thesis\<close> by simp
       next
         assume \<open>\<not> i < j\<close>
         moreover
         have \<open>i \<le> j\<close> using assms(4) ik cd by auto
         ultimately
         show \<open>?thesis\<close> by auto
       qed
     }
     moreover
     { fix i assume \<open>i\<in>{i . j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} \<union> {j}\<close>
       hence \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<or> i = j\<close> by auto
       hence \<open>i\<in>{i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> i < k}\<close> using assms(1,2) cd_trans[OF _ assms(1)] apply auto unfolding is_cdi_def 
       by (metis (poly_guards_query) diff_diff_cancel diff_is_0_eq le_refl le_trans nat_less_le)
     }
     ultimately show \<open>?thesis\<close> by blast
   qed
   
   have \<open>cs\<^bsup>\<pi>\<^esup> n = map \<pi> (sorted_list_of_set {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i}) @ [\<pi> n]\<close> using cs_sorted_list_of_cd' by simp
   also 
   have \<open>\<dots> = map \<pi> (sorted_list_of_set ({i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> i < k} \<union> {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i})) @ [\<pi> n]\<close> using 1 by metis
   also 
   have \<open>\<dots> = map \<pi> ((sorted_list_of_set {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> i < k}) @ (sorted_list_of_set {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i})) @ [\<pi> n]\<close>
     using sorted_list_of_set_append[OF _ _ le] is_cdi_def by auto
   also 
   have \<open>\<dots> = (map \<pi> (sorted_list_of_set {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> i < k})) @ (map \<pi> (sorted_list_of_set {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i})) @ [\<pi> n]\<close> by auto
   also
   have \<open>\<dots> = cs\<^bsup>\<pi>\<^esup> j @ (map \<pi> (sorted_list_of_set {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i})) @ [\<pi> n]\<close> unfolding 2 using cs_sorted_list_of_cd by auto
   also 
   have \<open>\<dots> = cs\<^bsup>\<pi>\<^esup> j @ cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> (n-k)\<close> using cs_path_shift_set_cd[OF path, of \<open>k\<close> \<open>n-k\<close>] assms(3) by auto
   finally
   show \<open>?thesis\<close> .
 qed
 
 lemma cs_split_shift_nocd: assumes \<open>is_path \<pi>\<close> and \<open>k < n\<close> and \<open>\<forall>j. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<longrightarrow> k \<le> j\<close> shows \<open>cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> (n-k)\<close>
 proof -
   have path: \<open>is_path \<pi>\<close> using assms by auto
   have 1: \<open>{i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i} = {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> i < k} \<union> {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i}\<close> by auto
   have le: \<open>\<forall> i\<in> {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> i < k}. \<forall> j\<in> {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i}. i < j\<close> by auto
   have 2: \<open>{i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> i < k} = {}\<close> using assms by auto
   
   have \<open>cs\<^bsup>\<pi>\<^esup> n = map \<pi> (sorted_list_of_set {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i}) @ [\<pi> n]\<close> using cs_sorted_list_of_cd' by simp
   also 
   have \<open>\<dots> = map \<pi> (sorted_list_of_set ({i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> i < k} \<union> {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i})) @ [\<pi> n]\<close> using 1 by metis
   also 
   have \<open>\<dots> = map \<pi> (sorted_list_of_set {i. n cd\<^bsup>\<pi>\<^esup>\<rightarrow> i \<and> k \<le> i}) @ [\<pi> n]\<close>
     unfolding 2 by auto
   also 
   have \<open>\<dots> = cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> (n-k)\<close> using cs_path_shift_set_cd[OF path, of \<open>k\<close> \<open>n-k\<close>] assms(2)  by auto
   finally show \<open>?thesis\<close> .
 qed
 
 lemma shifted_cs_eq_is_eq: assumes \<open>is_path \<pi>\<close> and \<open>is_path \<pi>'\<close> and \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k'\<close> and \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> n = cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> n'\<close> shows \<open>cs\<^bsup>\<pi>\<^esup> (k+n) = cs\<^bsup>\<pi>'\<^esup> (k'+n')\<close>
 proof (rule ccontr)
   note path = assms(1,2)
   note csk = assms(3)
   note csn = assms(4)
   assume ne: \<open>cs\<^bsup>\<pi>\<^esup> (k+n) \<noteq> cs\<^bsup>\<pi>'\<^esup> (k'+n')\<close>
   have nretkn:\<open>\<pi> (k+n) \<noteq> return\<close> proof 
     assume 1:\<open>\<pi> (k+n) = return\<close>
     hence \<open>(\<pi>\<guillemotleft>k) n = return\<close> by auto
     hence \<open>(\<pi>'\<guillemotleft>k') n' = return\<close> using last_cs assms(4) by metis
     hence \<open>\<pi>' (k' + n') = return\<close> by auto
     thus \<open>False\<close> using ne 1 cs_return by auto
   qed
   hence nretk: \<open>\<pi> k \<noteq> return\<close> using term_path_stable[OF assms(1), of \<open>k\<close> \<open>k +n\<close>] by auto
   have nretkn': \<open>\<pi>' (k'+n') \<noteq> return\<close> proof 
     assume 1:\<open>\<pi>' (k'+n') = return\<close>
     hence \<open>(\<pi>'\<guillemotleft>k') n' = return\<close> by auto
     hence \<open>(\<pi>\<guillemotleft>k) n = return\<close> using last_cs assms(4) by metis
     hence \<open>\<pi> (k + n) = return\<close> by auto
     thus \<open>False\<close> using ne 1 cs_return by auto
   qed
   hence nretk': \<open>\<pi>' k' \<noteq> return\<close> using term_path_stable[OF assms(2), of \<open>k'\<close> \<open>k' +n'\<close>] by auto
   have n0:\<open>n > 0\<close> proof (rule ccontr)
     assume *: \<open>\<not> 0 < n\<close>    
     hence 1:\<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> 0 = cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> n'\<close> using assms(3,4) by auto
     have \<open>(\<pi>\<guillemotleft>k) 0 = (\<pi>'\<guillemotleft>k') 0\<close> using assms(3) last_cs path_shift_def by (metis monoid_add_class.add.right_neutral)
     hence \<open>cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> 0 = cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> n'\<close> using 1 cs_0 by metis
     hence n0': \<open>n' = 0\<close> using cs_inj[of \<open>\<pi>'\<guillemotleft>k'\<close> \<open>0\<close> \<open>n'\<close> ] * assms(2) by (metis path_shift_def assms(4) last_cs nretkn path_path_shift)
     thus \<open>False\<close> using ne * assms(3) by fastforce
   qed
   have n0':\<open>n' > 0\<close> proof (rule ccontr)
     assume *: \<open>\<not> 0 < n'\<close>    
     hence 1:\<open>cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> 0 = cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> n\<close> using assms(3,4) by auto
     have \<open>(\<pi>'\<guillemotleft>k') 0 = (\<pi>\<guillemotleft>k) 0\<close> using assms(3) last_cs path_shift_def by (metis monoid_add_class.add.right_neutral)
     hence \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> 0 = cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> n\<close> using 1 cs_0 by metis
     hence n0: \<open>n = 0\<close> using cs_inj[of \<open>\<pi>\<guillemotleft>k\<close> \<open>0\<close> \<open>n\<close> ] * assms(1) by (metis path_shift_def assms(4) last_cs nretkn path_path_shift)
     thus \<open>False\<close> using ne * assms(3) by fastforce
   qed
   have cdleswap': \<open>\<forall> j'<k'. (k'+n') cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j' \<longrightarrow> (\<exists>j<k. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')\<close> proof (rule,rule,rule, rule ccontr)
     fix j' assume jk': \<open>j'<k'\<close> and ncdj': \<open>(k'+n') cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j'\<close> and ne: \<open>\<not> (\<exists>j<k. k + n cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')\<close>
     hence kcdj': \<open>k' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j'\<close> using cr_wn' by blast 
       
       then obtain j where kcdj: \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> and csj: \<open>cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j'\<close> using csk cs_path_swap_cd path by metis
       hence jk: \<open>j < k\<close> unfolding is_cdi_def by auto
       
       have ncdn: \<open>\<not> (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> using ne csj jk by blast 
       
       obtain l' where lnocd': \<open>l' = n' \<or> n' cd\<^bsup>\<pi>'\<guillemotleft>k'\<^esup>\<rightarrow> l'\<close> and cslsing': \<open>cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> l' = [(\<pi>'\<guillemotleft>k') l']\<close>        
         proof cases
           assume \<open>cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> n' = [(\<pi>'\<guillemotleft>k') n']\<close> thus \<open>thesis\<close> using that[of \<open>n'\<close>] by auto
         next
           assume *: \<open>cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> n' \<noteq> [(\<pi>'\<guillemotleft>k') n']\<close>
           then obtain x ys where \<open>cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> n' = [x]@ys@[(\<pi>'\<guillemotleft>k') n']\<close> by (metis append_Cons append_Nil cs_length_g_one cs_length_one(1) neq_Nil_conv) 
           then obtain l' where \<open>cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> l' = [x]\<close> and cdl': \<open>n' cd\<^bsup>\<pi>'\<guillemotleft>k'\<^esup>\<rightarrow> l'\<close> using cs_split[of \<open>\<pi>'\<guillemotleft>k'\<close> \<open>n'\<close> \<open>Nil\<close> \<open>x\<close> \<open>ys\<close>] by auto
           hence \<open>cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> l' = [(\<pi>'\<guillemotleft>k') l']\<close> using last_cs by (metis last.simps) 
           thus \<open>thesis\<close> using that cdl' by auto
       qed
       hence ln': \<open>l'\<le>n'\<close> unfolding is_cdi_def by auto
       hence lcdj': \<open>k'+l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j'\<close> using jk' ncdj'  by (metis add_le_cancel_left cdi_prefix trans_less_add1)
             
       obtain l where lnocd: \<open>l = n \<or> n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> l\<close> and csl: \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> l = cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> l'\<close> using lnocd' proof
         assume \<open>l' = n'\<close> thus \<open>thesis\<close> using csn that[of \<open>n\<close>] by auto
         next
         assume \<open>n' cd\<^bsup>\<pi>'\<guillemotleft>k'\<^esup>\<rightarrow> l'\<close>
         then obtain l where \<open>n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> l\<close> \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> l = cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> l'\<close> using cs_path_swap_cd path csn by (metis path_path_shift)
         thus \<open>thesis\<close> using that by auto
       qed
       
       have cslsing: \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> l = [(\<pi>\<guillemotleft>k) l]\<close> using cslsing' last_cs csl last.simps by metis
       
       have ln: \<open>l\<le>n\<close> using lnocd unfolding is_cdi_def by auto
       hence nretkl: \<open>\<pi> (k + l) \<noteq> return\<close> using term_path_stable[of \<open>\<pi>\<close> \<open>k+l\<close> \<open>k+n\<close>] nretkn path(1) by auto  
       
       have *: \<open>n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> l \<Longrightarrow> k+n cd\<^bsup>\<pi>\<^esup>\<rightarrow> k+l\<close> using cd_path_shift[of \<open>k\<close> \<open>k+l\<close> \<open>\<pi>\<close> \<open>k+n\<close>] path(1) by auto
       
       have ncdl: \<open>\<not> (k+l) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> apply rule using lnocd apply rule using ncdn apply blast using cd_trans ncdn * by blast      
       
       hence \<open>\<exists> i\<in> {j..k+l}. \<pi> i = ipd (\<pi> j)\<close> unfolding is_cdi_def using path(1) jk nretkl by auto
       hence \<open>\<exists> i\<in> {k<..k+l}. \<pi> i = ipd (\<pi> j)\<close> using kcdj unfolding is_cdi_def by force
       
       then obtain i where ki: \<open>k < i\<close> and il: \<open>i \<le> k+l\<close> and ipdi: \<open>\<pi> i = ipd (\<pi> j)\<close> by force
       
       hence \<open>(\<pi>\<guillemotleft>k) (i-k) = ipd (\<pi> j)\<close> \<open>i-k \<le> l\<close> by auto
       hence pd: \<open>(\<pi>\<guillemotleft>k) l pd\<rightarrow> ipd (\<pi> j)\<close> using cs_single_pd_intermed[OF _ cslsing] path(1) path_path_shift by metis
       moreover
       have \<open>(\<pi>\<guillemotleft>k) l = \<pi>' (k' + l')\<close> using csl last_cs by (metis path_shift_def)
       moreover
       have \<open>\<pi> j = \<pi>' j'\<close> using csj last_cs by metis
       ultimately
       have \<open>\<pi>' (k'+l') pd\<rightarrow> ipd (\<pi>' j')\<close> by simp
       moreover
       have \<open>ipd (\<pi>' j') pd\<rightarrow> \<pi>' (k'+l')\<close> using ipd_pd_cd[OF lcdj'] .
       ultimately
       have \<open>\<pi>' (k'+l') = ipd (\<pi>' j')\<close> using pd_antisym by auto
       thus \<open>False\<close> using lcdj' unfolding is_cdi_def by force
   qed
   
   \<comment> \<open>Symmetric version of the above statement\<close>
   have cdleswap: \<open>\<forall> j<k. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<longrightarrow> (\<exists>j'<k'. (k'+n') cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j' \<and> cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')\<close> proof (rule,rule,rule, rule ccontr)
     fix j assume jk: \<open>j<k\<close> and ncdj: \<open>(k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> and ne: \<open>\<not> (\<exists>j'<k'. k' + n' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j' \<and> cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')\<close>
     hence kcdj: \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> using cr_wn' by blast
       
       then obtain j' where kcdj': \<open>k' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j'\<close> and csj: \<open>cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j'\<close> using csk cs_path_swap_cd path by metis
       hence jk': \<open>j' < k'\<close> unfolding is_cdi_def by auto
       
       have ncdn': \<open>\<not> (k'+n') cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j'\<close> using ne csj jk' by blast 
       
       obtain l where lnocd: \<open>l = n \<or> n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> l\<close> and cslsing: \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> l = [(\<pi>\<guillemotleft>k) l]\<close>        
         proof cases
           assume \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> n = [(\<pi>\<guillemotleft>k) n]\<close> thus \<open>thesis\<close> using that[of \<open>n\<close>] by auto
         next
           assume *: \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> n \<noteq> [(\<pi>\<guillemotleft>k) n]\<close>
           then obtain x ys where \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> n = [x]@ys@[(\<pi>\<guillemotleft>k) n]\<close> by (metis append_Cons append_Nil cs_length_g_one cs_length_one(1) neq_Nil_conv) 
           then obtain l where \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> l = [x]\<close> and cdl: \<open>n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> l\<close> using cs_split[of \<open>\<pi>\<guillemotleft>k\<close> \<open>n\<close> \<open>Nil\<close> \<open>x\<close> \<open>ys\<close>] by auto
           hence \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> l = [(\<pi>\<guillemotleft>k) l]\<close> using last_cs by (metis last.simps) 
           thus \<open>thesis\<close> using that cdl by auto
       qed
       hence ln: \<open>l\<le>n\<close> unfolding is_cdi_def by auto
       hence lcdj: \<open>k+l cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> using jk ncdj  by (metis add_le_cancel_left cdi_prefix trans_less_add1)
             
       obtain l' where lnocd': \<open>l' = n' \<or> n' cd\<^bsup>\<pi>'\<guillemotleft>k'\<^esup>\<rightarrow> l'\<close> and csl: \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> l = cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> l'\<close> using lnocd proof
         assume \<open>l = n\<close> thus \<open>thesis\<close> using csn that[of \<open>n'\<close>] by auto
         next
         assume \<open>n cd\<^bsup>\<pi>\<guillemotleft>k\<^esup>\<rightarrow> l\<close>
         then obtain l' where \<open>n' cd\<^bsup>\<pi>'\<guillemotleft>k'\<^esup>\<rightarrow> l'\<close> \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> l = cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> l'\<close> using cs_path_swap_cd path csn by (metis path_path_shift)
         thus \<open>thesis\<close> using that by auto
       qed
       
       have cslsing': \<open>cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> l' = [(\<pi>'\<guillemotleft>k') l']\<close> using cslsing last_cs csl last.simps by metis
       
       have ln': \<open>l'\<le>n'\<close> using lnocd' unfolding is_cdi_def by auto
       hence nretkl': \<open>\<pi>' (k' + l') \<noteq> return\<close> using term_path_stable[of \<open>\<pi>'\<close> \<open>k'+l'\<close> \<open>k'+n'\<close>] nretkn' path(2) by auto  
       
       have *: \<open>n' cd\<^bsup>\<pi>'\<guillemotleft>k'\<^esup>\<rightarrow> l' \<Longrightarrow> k'+n' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> k'+l'\<close> using cd_path_shift[of \<open>k'\<close> \<open>k'+l'\<close> \<open>\<pi>'\<close> \<open>k'+n'\<close>] path(2) by auto
       
       have ncdl': \<open>\<not> (k'+l') cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j'\<close> apply rule using lnocd' apply rule using ncdn' apply blast using cd_trans ncdn' * by blast      
       
       hence \<open>\<exists> i'\<in> {j'..k'+l'}. \<pi>' i' = ipd (\<pi>' j')\<close> unfolding is_cdi_def using path(2) jk' nretkl' by auto
       hence \<open>\<exists> i'\<in> {k'<..k'+l'}. \<pi>' i' = ipd (\<pi>' j')\<close> using kcdj' unfolding is_cdi_def by force
       
       then obtain i' where ki': \<open>k' < i'\<close> and il': \<open>i' \<le> k'+l'\<close> and ipdi: \<open>\<pi>' i' = ipd (\<pi>' j')\<close> by force
       
       hence \<open>(\<pi>'\<guillemotleft>k') (i'-k') = ipd (\<pi>' j')\<close> \<open>i'-k' \<le> l'\<close> by auto
       hence pd: \<open>(\<pi>'\<guillemotleft>k') l' pd\<rightarrow> ipd (\<pi>' j')\<close> using cs_single_pd_intermed[OF _ cslsing'] path(2) path_path_shift by metis
       moreover
       have \<open>(\<pi>'\<guillemotleft>k') l' = \<pi> (k + l)\<close> using csl last_cs by (metis path_shift_def)
       moreover
       have \<open>\<pi>' j' = \<pi> j\<close> using csj last_cs by metis
       ultimately
       have \<open>\<pi> (k+l) pd\<rightarrow> ipd (\<pi> j)\<close> by simp
       moreover
       have \<open>ipd (\<pi> j) pd\<rightarrow> \<pi> (k+l)\<close> using ipd_pd_cd[OF lcdj] .
       ultimately
       have \<open>\<pi> (k+l) = ipd (\<pi> j)\<close> using pd_antisym by auto
       thus \<open>False\<close> using lcdj unfolding is_cdi_def by force
   qed
   
   have cdle: \<open>\<exists>j. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> j < k\<close> (is \<open>\<exists> j. ?P j\<close>) proof (rule ccontr)
     assume \<open>\<not> (\<exists>j. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> j < k)\<close>
     hence allge: \<open>\<forall>j. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<longrightarrow> k \<le> j\<close> by auto
     have allge': \<open>\<forall>j'. (k'+n') cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j' \<longrightarrow> k' \<le> j'\<close> proof (rule, rule, rule ccontr)
       fix j' 
       assume *: \<open>k' + n' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j'\<close> and \<open>\<not> k' \<le> j'\<close>
       then obtain j where \<open>j<k\<close> \<open>(k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> using cdleswap' by (metis le_neq_implies_less nat_le_linear)
       thus \<open>False\<close> using allge by auto
     qed
     have \<open>cs\<^bsup>\<pi>\<^esup> (k + n) = cs\<^bsup>\<pi> \<guillemotleft> k\<^esup> n\<close> using cs_split_shift_nocd[OF assms(1) _ allge] n0 by auto
     moreover
     have \<open>cs\<^bsup>\<pi>'\<^esup> (k' + n') = cs\<^bsup>\<pi>' \<guillemotleft> k'\<^esup> n'\<close> using cs_split_shift_nocd[OF assms(2) _ allge'] n0' by auto
     ultimately
     show \<open>False\<close> using ne assms(4) by auto
   qed
   
   define j where  \<open>j == GREATEST j. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> j < k\<close>  
   have cdj:\<open>(k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> and jk: \<open>j < k\<close> and jge:\<open>\<forall> j'< k. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j' \<longrightarrow> j' \<le> j\<close> proof -
     have bound: \<open>\<forall> y. ?P y \<longrightarrow> y \<le> k\<close> by auto
     show \<open>(k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> using GreatestI_nat[of \<open>?P\<close>] j_def bound cdle by blast
     show \<open>j < k\<close> using GreatestI_nat[of \<open>?P\<close>] bound j_def cdle by blast
     show \<open>\<forall> j'< k. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j' \<longrightarrow> j' \<le> j\<close> using Greatest_le_nat[of \<open>?P\<close>] bound j_def by blast
   qed
     
   obtain j' where cdj':\<open>(k'+n') cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j'\<close> and csj: \<open>cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j'\<close>  and jk': \<open>j' < k'\<close> using cdleswap cdj jk by blast
   have jge':\<open>\<forall> i'< k'. (k'+n') cd\<^bsup>\<pi>'\<^esup>\<rightarrow> i' \<longrightarrow> i' \<le> j'\<close> proof(rule,rule,rule)
     fix i'
     assume ik': \<open>i' < k'\<close> and cdi': \<open>k' + n' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> i'\<close>
     then obtain i where cdi:\<open>(k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> i\<close> and csi: \<open> cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> i\<close> and ik: \<open>i<k\<close> using cdleswap' by force 
     have ij: \<open>i \<le> j\<close> using jge cdi ik by auto
     show \<open>i' \<le> j'\<close> using cs_order_le[OF assms(1,2) csi[symmetric] csj _ ij] cd_not_ret[OF cdi] by simp
   qed
   have \<open>cs\<^bsup>\<pi>\<^esup> (k + n) = cs\<^bsup>\<pi>\<^esup> j @ cs\<^bsup>\<pi> \<guillemotleft> k\<^esup> n\<close> using  cs_split_shift_cd[OF cdj jk _ jge] n0 by auto
   moreover
   have \<open>cs\<^bsup>\<pi>'\<^esup> (k' + n') = cs\<^bsup>\<pi>'\<^esup> j' @ cs\<^bsup>\<pi>' \<guillemotleft> k'\<^esup> n'\<close> using  cs_split_shift_cd[OF cdj' jk' _ jge'] n0' by auto
   ultimately
   have \<open>cs\<^bsup>\<pi>\<^esup> (k+n) = cs\<^bsup>\<pi>'\<^esup> (k'+n')\<close> using csj assms(4) by auto
   thus \<open>False\<close> using ne by simp
 qed
 
 lemma cs_eq_is_eq_shifted: assumes \<open>is_path \<pi>\<close> and \<open>is_path \<pi>'\<close> and \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k'\<close> and \<open>cs\<^bsup>\<pi>\<^esup> (k+n) = cs\<^bsup>\<pi>'\<^esup> (k'+n')\<close> shows \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> n = cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> n'\<close>
 proof (rule ccontr)
   assume ne: \<open>cs\<^bsup>\<pi> \<guillemotleft> k\<^esup> n \<noteq> cs\<^bsup>\<pi>' \<guillemotleft> k'\<^esup> n'\<close>
   have nretkn:\<open>\<pi> (k+n) \<noteq> return\<close> proof 
     assume 1:\<open>\<pi> (k+n) = return\<close>
     hence 2:\<open>\<pi>' (k'+n') = return\<close> using assms(4) last_cs by metis
     hence \<open>(\<pi>\<guillemotleft>k) n = return\<close> \<open>(\<pi>'\<guillemotleft>k') n' = return\<close> using 1 by auto
     hence \<open>cs\<^bsup>\<pi> \<guillemotleft> k\<^esup> n = cs\<^bsup>\<pi>' \<guillemotleft> k'\<^esup> n'\<close> using cs_return by metis 
     thus \<open>False\<close> using ne by simp
   qed
   hence nretk: \<open>\<pi> k \<noteq> return\<close> using term_path_stable[OF assms(1), of \<open>k\<close> \<open>k +n\<close>] by auto
   have nretkn': \<open>\<pi>' (k'+n') \<noteq> return\<close> proof 
     assume 1:\<open>\<pi>' (k'+n') = return\<close>
     hence 2:\<open>\<pi> (k+n) = return\<close> using assms(4) last_cs by metis
     hence \<open>(\<pi>\<guillemotleft>k) n = return\<close> \<open>(\<pi>'\<guillemotleft>k') n' = return\<close> using 1 by auto
     hence \<open>cs\<^bsup>\<pi> \<guillemotleft> k\<^esup> n = cs\<^bsup>\<pi>' \<guillemotleft> k'\<^esup> n'\<close> using cs_return by metis 
     thus \<open>False\<close> using ne by simp
   qed
   hence nretk': \<open>\<pi>' k' \<noteq> return\<close> using term_path_stable[OF assms(2), of \<open>k'\<close> \<open>k' +n'\<close>] by auto
   have n0:\<open>n > 0\<close> proof (rule ccontr)
     assume *: \<open>\<not> 0 < n\<close>    
     hence \<open>cs\<^bsup>\<pi>'\<^esup> k' = cs\<^bsup>\<pi>'\<^esup> (k'+ n')\<close> using assms(3,4) by auto
     hence n0: \<open>n = 0\<close> \<open>n' = 0\<close> using cs_inj[OF assms(2) nretkn', of \<open>k'\<close>] * by auto
     have \<open>cs\<^bsup>\<pi> \<guillemotleft> k\<^esup> n = cs\<^bsup>\<pi>' \<guillemotleft> k'\<^esup> n'\<close> unfolding n0 cs_0 by (auto , metis last_cs assms(3))
     thus \<open>False\<close> using ne by simp
   qed
   have n0':\<open>n' > 0\<close> proof (rule ccontr)
     assume *: \<open>\<not> 0 < n'\<close>    
     hence \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>\<^esup> (k+ n)\<close> using assms(3,4) by auto
     hence n0: \<open>n = 0\<close> \<open>n' = 0\<close> using cs_inj[OF assms(1) nretkn, of \<open>k\<close>] * by auto
     have \<open>cs\<^bsup>\<pi> \<guillemotleft> k\<^esup> n = cs\<^bsup>\<pi>' \<guillemotleft> k'\<^esup> n'\<close> unfolding n0 cs_0 by (auto , metis last_cs assms(3))
     thus \<open>False\<close> using ne by simp
   qed
   have cdle: \<open>\<exists>j. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> j < k\<close> (is \<open>\<exists> j. ?P j\<close>) proof (rule ccontr)
     assume \<open>\<not> (\<exists>j. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> j < k)\<close>
     hence allge: \<open>\<forall>j. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<longrightarrow> k \<le> j\<close> by auto
     have allge': \<open>\<forall>j'. (k'+n') cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j' \<longrightarrow> k' \<le> j'\<close> proof (rule, rule)
       fix j' 
       assume *: \<open>k' + n' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j'\<close>
       obtain j where cdj: \<open>k+n cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> and csj: \<open>cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j'\<close> using cs_path_swap_cd[OF assms(2,1) assms(4)[symmetric] *] by metis
       hence kj:\<open>k \<le> j\<close> using allge by auto
       thus kj': \<open>k' \<le> j'\<close> using cs_order_le[OF assms(1,2,3) csj nretk] by simp
     qed
     have \<open>cs\<^bsup>\<pi>\<^esup> (k + n) = cs\<^bsup>\<pi> \<guillemotleft> k\<^esup> n\<close> using cs_split_shift_nocd[OF assms(1) _ allge] n0 by auto
     moreover
     have \<open>cs\<^bsup>\<pi>'\<^esup> (k' + n') = cs\<^bsup>\<pi>' \<guillemotleft> k'\<^esup> n'\<close> using cs_split_shift_nocd[OF assms(2) _ allge'] n0' by auto
     ultimately
     show \<open>False\<close> using ne assms(4) by auto
   qed
   define j where  \<open>j == GREATEST j. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j \<and> j < k\<close>  
   have cdj:\<open>(k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> and jk: \<open>j < k\<close> and jge:\<open>\<forall> j'< k. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j' \<longrightarrow> j' \<le> j\<close> proof -
     have bound: \<open>\<forall> y. ?P y \<longrightarrow> y \<le> k\<close> by auto
     show \<open>(k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> using GreatestI_nat[of \<open>?P\<close>] bound j_def cdle by blast
     show \<open>j < k\<close> using GreatestI_nat[of \<open>?P\<close>] bound j_def cdle by blast
     show \<open>\<forall> j'< k. (k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> j' \<longrightarrow> j' \<le> j\<close> using Greatest_le_nat[of \<open>?P\<close>] bound j_def by blast
   qed
   obtain j' where cdj':\<open>(k'+n') cd\<^bsup>\<pi>'\<^esup>\<rightarrow> j'\<close> and csj: \<open>cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j'\<close> using cs_path_swap_cd assms cdj by blast
   have jge':\<open>\<forall> i'< k'. (k'+n') cd\<^bsup>\<pi>'\<^esup>\<rightarrow> i' \<longrightarrow> i' \<le> j'\<close> proof(rule,rule,rule)
     fix i'
     assume ik': \<open>i' < k'\<close> and cdi': \<open>k' + n' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> i'\<close>
     then obtain i where cdi:\<open>(k+n) cd\<^bsup>\<pi>\<^esup>\<rightarrow> i\<close> and csi: \<open> cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> i\<close> using cs_path_swap_cd[OF assms(2,1) assms(4)[symmetric]] by blast
     have nreti': \<open>\<pi>' i' \<noteq> return\<close> by (metis cd_not_ret cdi')
     have ik: \<open>i < k\<close> using cs_order[OF assms(2,1) csi _ nreti' ik'] assms(3) by auto
     have ij: \<open>i \<le> j\<close> using jge cdi ik by auto
     show \<open>i' \<le> j'\<close> using cs_order_le[OF assms(1,2) csi[symmetric] csj _ ij] cd_not_ret[OF cdi] by simp
   qed
   have jk': \<open>j' < k'\<close> using cs_order[OF assms(1,2) csj assms(3) cd_not_ret[OF cdj] jk] .
   have \<open>cs\<^bsup>\<pi>\<^esup> (k + n) = cs\<^bsup>\<pi>\<^esup> j @ cs\<^bsup>\<pi> \<guillemotleft> k\<^esup> n\<close> using  cs_split_shift_cd[OF cdj jk _ jge] n0 by auto
   moreover
   have \<open>cs\<^bsup>\<pi>'\<^esup> (k' + n') = cs\<^bsup>\<pi>'\<^esup> j' @ cs\<^bsup>\<pi>' \<guillemotleft> k'\<^esup> n'\<close> using  cs_split_shift_cd[OF cdj' jk' _ jge'] n0' by auto
   ultimately
   have \<open>cs\<^bsup>\<pi>\<guillemotleft>k\<^esup> n = cs\<^bsup>\<pi>'\<guillemotleft>k'\<^esup> n'\<close> using csj assms(4) by auto
   thus \<open>False\<close> using ne by simp
 qed
 
 lemma converged_cd_diverge_cs: assumes \<open>is_path \<pi>\<close> and \<open>is_path \<pi>'\<close> and \<open>cs\<^bsup>\<pi>\<^esup> j  = cs\<^bsup>\<pi>'\<^esup> j'\<close> and \<open>j<l\<close> and \<open>\<not> (\<exists>l'. cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l')\<close> and \<open>l < m\<close> and \<open>cs\<^bsup>\<pi>\<^esup> m = cs\<^bsup>\<pi>'\<^esup> m'\<close>
 obtains k k' where \<open>j\<le>k\<close> \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k'\<close> and \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> and \<open>\<pi> (Suc k) \<noteq> \<pi>' (Suc k')\<close>
   proof -  
   have \<open>is_path (\<pi>\<guillemotleft>j)\<close> \<open>is_path (\<pi>'\<guillemotleft>j')\<close> using assms(1,2) path_path_shift by auto
   moreover
   have \<open>(\<pi>\<guillemotleft>j) 0 = (\<pi>'\<guillemotleft>j') 0\<close> using assms(3) last_cs by (metis path_shift_def add.right_neutral)
   moreover
   have \<open>\<not>(\<exists>l'. cs\<^bsup>\<pi>\<guillemotleft>j\<^esup> (l-j) = cs\<^bsup>\<pi>'\<guillemotleft>j'\<^esup> l')\<close> proof 
     assume \<open>\<exists>l'. cs\<^bsup>\<pi> \<guillemotleft> j\<^esup> (l - j) = cs\<^bsup>\<pi>' \<guillemotleft> j'\<^esup> l'\<close>
     then obtain l' where csl: \<open>cs\<^bsup>\<pi>\<guillemotleft>j\<^esup> (l - j) = cs\<^bsup>\<pi>'\<guillemotleft>j'\<^esup> l'\<close> by blast
       
     have \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> (j' + l')\<close> using shifted_cs_eq_is_eq[OF assms(1,2,3) csl] assms(4) by auto
     thus \<open>False\<close> using assms(5) by blast
   qed
   moreover
   have \<open>l-j < m-j\<close> using assms by auto
   moreover
   have \<open>\<pi> j \<noteq> return\<close> using cs_return assms(1-5) term_path_stable by (metis nat_less_le) 
   hence \<open>j'<m'\<close> using cs_order[OF assms(1,2,3,7)] assms by auto
   hence \<open>cs\<^bsup>\<pi>\<guillemotleft>j\<^esup> (m-j) = cs\<^bsup>\<pi>'\<guillemotleft>j'\<^esup> (m'-j')\<close> using cs_eq_is_eq_shifted[OF assms(1,2,3),of \<open>m-j\<close> \<open>m'-j'\<close>] assms(4,6,7) by auto
   ultimately
   obtain k k' where csk: \<open>cs\<^bsup>\<pi>\<guillemotleft>j\<^esup> k = cs\<^bsup>\<pi>'\<guillemotleft>j'\<^esup> k'\<close> and lcdk: \<open>l-j cd\<^bsup>\<pi>\<guillemotleft>j\<^esup>\<rightarrow> k\<close> and suc:\<open>(\<pi>\<guillemotleft>j) (Suc k) \<noteq> (\<pi>'\<guillemotleft>j') (Suc k')\<close> using converged_cd_diverge by blast
   
   have \<open>cs\<^bsup>\<pi>\<^esup> (j+k) = cs\<^bsup>\<pi>'\<^esup> (j'+k')\<close> using shifted_cs_eq_is_eq[OF assms(1-3) csk] .
   moreover
   have \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> j+k\<close> using lcdk assms(1,2,4) by (metis add.commute add_diff_cancel_right' cd_path_shift le_add1)
   moreover
   have \<open>\<pi> (Suc (j+k)) \<noteq> \<pi>' (Suc (j'+ k'))\<close> using suc by auto
   moreover
   have \<open>j \<le> j+k\<close> by auto
   ultimately
   show \<open>thesis\<close> using that[of \<open>j+k\<close> \<open>j'+k'\<close>] by auto
 qed
 
 
 lemma cs_ipd_conv: assumes csk: \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k'\<close> and ipd: \<open>\<pi> l = ipd (\<pi> k)\<close> \<open>\<pi>' l' = ipd(\<pi>' k')\<close> 
   and nipd: \<open>\<forall>n\<in>{k..<l}. \<pi> n \<noteq> ipd (\<pi> k)\<close> \<open>\<forall>n'\<in>{k'..<l'}. \<pi>' n' \<noteq> ipd (\<pi>' k')\<close> and kl: \<open>k < l\<close> \<open>k' < l'\<close> 
 shows \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l'\<close> using cs_ipd[OF ipd(1) nipd(1) kl(1)] cs_ipd[OF ipd(2) nipd(2) kl(2)] csk ipd by (metis (no_types) last_cs)
 
 lemma cp_eq_cs: assumes \<open>((\<sigma>,k),(\<sigma>',k'))\<in>cp\<close> shows \<open>cs\<^bsup>path \<sigma>\<^esup> k = cs\<^bsup>path \<sigma>'\<^esup> k'\<close> 
   using assms 
   apply(induction rule: cp.induct) 
      apply blast+ 
   apply simp 
   done 
 
 lemma cd_cs_swap: assumes \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> k\<close> \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l'\<close> \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k'\<close> shows \<open>l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> k'\<close> proof -
   have \<open>\<exists> i. l icd\<^bsup>\<pi>\<^esup>\<rightarrow> i\<close> using assms(1) excd_impl_exicd by blast
   hence \<open>cs\<^bsup>\<pi>\<^esup> l \<noteq> [\<pi> l]\<close> by auto
   hence \<open>cs\<^bsup>\<pi>'\<^esup> l' \<noteq> [\<pi>' l']\<close> using assms last_cs by metis
   hence \<open>\<exists> i'. l' icd\<^bsup>\<pi>'\<^esup>\<rightarrow> i'\<close> by (metis cs_cases)
   hence path': \<open>is_path \<pi>'\<close> unfolding is_icdi_def is_cdi_def by auto
   from cd_in_cs[OF assms(1)]
   obtain ys where csl: \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>\<^esup> k @ ys @ [\<pi> l]\<close> by blast
   obtain xs where csk: \<open>cs\<^bsup>\<pi>\<^esup> k = xs@[\<pi> k]\<close> by (metis append_butlast_last_id cs_not_nil last_cs)
   have \<pi>l: \<open>\<pi> l = \<pi>' l'\<close> using assms last_cs by metis
   have csl': \<open>cs\<^bsup>\<pi>'\<^esup> l' = xs@[\<pi> k]@ys@[\<pi>' l']\<close> by (metis \<pi>l append_eq_appendI assms(2) csk csl)
   from cs_split[of \<open>\<pi>'\<close> \<open>l'\<close> \<open>xs\<close> \<open>\<pi> k\<close> \<open>ys\<close>]
   obtain m where csm: \<open>cs\<^bsup>\<pi>'\<^esup> m = xs @ [\<pi> k]\<close> and lcdm: \<open>l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> m\<close> using csl' by metis 
   have csm': \<open>cs\<^bsup>\<pi>'\<^esup> m = cs\<^bsup>\<pi>'\<^esup> k'\<close> by (metis assms(3) csk csm)
   have \<open>\<pi>' m \<noteq> return\<close> using lcdm unfolding is_cdi_def using term_path_stable by (metis nat_less_le)
   hence \<open>m = k'\<close> using cs_inj path' csm' by auto
   thus \<open>?thesis\<close> using lcdm by auto
 qed
 
 
 subsection \<open>Facts about Observations\<close>
 lemma kth_obs_not_none: assumes \<open>is_kth_obs (path \<sigma>) k i\<close> obtains a where \<open>obsp \<sigma> i = Some a\<close> using assms unfolding is_kth_obs_def obsp_def by auto
 
 lemma kth_obs_unique: \<open>is_kth_obs \<pi> k i \<Longrightarrow> is_kth_obs \<pi> k j \<Longrightarrow> i = j\<close> proof (induction \<open>i\<close> \<open>j\<close> rule: nat_sym_cases)
   case sym thus \<open>?case\<close> by simp
 next
   case eq thus \<open>?case\<close> by simp
 next
   case (less i j) 
   have \<open>obs_ids \<pi> \<inter> {..<i} \<subseteq> obs_ids \<pi> \<inter> {..<j}\<close> using less(1) by auto
   moreover
   have \<open>i \<in> obs_ids \<pi> \<inter> {..<j}\<close> using less unfolding is_kth_obs_def obs_ids_def by auto
   moreover  
   have \<open>i \<notin> obs_ids \<pi> \<inter> {..<i}\<close> by auto
   moreover 
   have \<open>card (obs_ids \<pi> \<inter> {..<i}) = card (obs_ids \<pi> \<inter> {..<j})\<close> using less.prems unfolding is_kth_obs_def by auto
   moreover
   have \<open>finite (obs_ids \<pi> \<inter> {..<i})\<close> \<open>finite (obs_ids \<pi> \<inter> {..<j})\<close> by auto
   ultimately 
   have \<open>False\<close> by (metis card_subset_eq)
   thus \<open>?case\<close> ..
 qed
 
 lemma obs_none_no_kth_obs: assumes \<open>obs \<sigma> k = None\<close> shows \<open>\<not> (\<exists> i. is_kth_obs (path \<sigma>) k i)\<close> 
   apply rule
   using assms 
   unfolding obs_def obsp_def 
   apply (auto split: option.split_asm)  
   by (metis assms kth_obs_not_none kth_obs_unique obs_def option.distinct(2) the_equality)
 
 lemma obs_some_kth_obs : assumes \<open>obs \<sigma> k \<noteq> None\<close> obtains i where \<open>is_kth_obs (path \<sigma>) k i\<close> by (metis obs_def assms)
 
 lemma not_none_is_obs: assumes \<open>att(\<pi> i) \<noteq> None\<close> shows \<open>is_kth_obs \<pi> (card (obs_ids \<pi> \<inter> {..<i})) i\<close>  unfolding is_kth_obs_def using assms by auto
 
 lemma in_obs_ids_is_kth_obs: assumes \<open>i \<in> obs_ids \<pi>\<close> obtains k where \<open>is_kth_obs \<pi> k i\<close> proof 
   have \<open>att (\<pi> i) \<noteq> None\<close> using assms obs_ids_def by auto 
   thus \<open>is_kth_obs \<pi> (card (obs_ids \<pi> \<inter> {..<i})) i\<close> using not_none_is_obs by auto
 qed
 
 lemma kth_obs_stable: assumes \<open>is_kth_obs \<pi> l j\<close> \<open>k < l\<close> shows \<open>\<exists> i. is_kth_obs \<pi> k i\<close> using assms proof (induction \<open>l\<close> arbitrary: \<open>j\<close> rule: less_induct )
   case (less l j)
   have cardl: \<open>card (obs_ids \<pi> \<inter> {..<j}) = l\<close> using less is_kth_obs_def by auto
   then obtain i where  ex: \<open>i \<in> obs_ids \<pi> \<inter> {..<j}\<close> (is \<open>?P i\<close>) using less(3) by (metis card.empty empty_iff less_irrefl subsetI subset_antisym zero_diff zero_less_diff)
   have bound: \<open>\<forall> i. i \<in> obs_ids \<pi> \<inter> {..<j} \<longrightarrow> i \<le> j\<close> by auto
   let \<open>?i\<close> = \<open>GREATEST i. i \<in> obs_ids \<pi> \<inter> {..<j}\<close>
   have *: \<open>?i < j\<close> \<open>?i \<in> obs_ids \<pi>\<close> using GreatestI_nat[of \<open>?P\<close> \<open>i\<close> \<open>j\<close>] ex bound by auto
   have **: \<open>\<forall> i. i \<in> obs_ids \<pi> \<and> i<j \<longrightarrow> i \<le> ?i\<close> using Greatest_le_nat[of \<open>?P\<close> _ \<open>j\<close>] ex bound by auto
   have \<open>(obs_ids \<pi> \<inter> {..<?i}) \<union> {?i} = obs_ids \<pi> \<inter> {..<j}\<close> apply rule apply auto using *[simplified] apply simp+ using **[simplified] by auto
   moreover
   have \<open>?i \<notin> (obs_ids \<pi> \<inter> {..<?i})\<close> by auto
   ultimately
   have \<open>Suc (card (obs_ids \<pi> \<inter> {..<?i})) = l\<close> using cardl by (metis Un_empty_right Un_insert_right card_insert_disjoint finite_Int finite_lessThan)
   hence \<open>card (obs_ids \<pi> \<inter> {..<?i}) = l - 1\<close> by auto
   hence iko: \<open>is_kth_obs \<pi> (l - 1) ?i\<close> using *(2) unfolding is_kth_obs_def obs_ids_def by auto
   have ll: \<open>l - 1 < l\<close> by (metis One_nat_def diff_Suc_less less.prems(2) not_gr0 not_less0)
   note IV=less(1)[OF ll iko]
   show \<open>?thesis\<close> proof cases
     assume \<open>k < l - 1\<close> thus \<open>?thesis\<close> using IV by simp
   next
     assume \<open>\<not> k < l - 1\<close>
     hence \<open>k = l - 1\<close> using less by auto
     thus \<open>?thesis\<close> using iko by blast
   qed
 qed
 
 lemma kth_obs_mono: assumes \<open>is_kth_obs \<pi> k i\<close> \<open>is_kth_obs \<pi> l j\<close> \<open>k < l\<close> shows \<open>i < j\<close> proof (rule ccontr)
   assume \<open>\<not> i < j\<close>
   hence \<open>{..<j} \<subseteq> {..<i}\<close> by auto
   hence \<open>obs_ids \<pi> \<inter> {..<j} \<subseteq> obs_ids \<pi> \<inter> {..<i}\<close> by auto
   moreover 
   have \<open>finite (obs_ids \<pi> \<inter> {..<i})\<close> by auto
   ultimately
   have \<open>card (obs_ids \<pi> \<inter> {..<j}) \<le> card (obs_ids \<pi> \<inter> {..<i})\<close> by (metis card_mono)
   thus \<open>False\<close> using assms unfolding is_kth_obs_def by auto
 qed
 
 lemma kth_obs_le_iff: assumes \<open>is_kth_obs \<pi> k i\<close> \<open>is_kth_obs \<pi> l j\<close>  shows \<open>k < l \<longleftrightarrow> i < j\<close> by (metis assms kth_obs_unique kth_obs_mono not_less_iff_gr_or_eq)
 
 lemma ret_obs_all_obs: assumes path: \<open>is_path \<pi>\<close> and iki: \<open>is_kth_obs \<pi> k i\<close> and ret: \<open>\<pi> i = return\<close> and kl: \<open>k < l\<close> obtains j where \<open>is_kth_obs \<pi> l j\<close>
 proof-
   show \<open>thesis\<close>
   using kl iki ret proof (induction \<open>l - k\<close> arbitrary: \<open>k\<close> \<open>i\<close> rule: less_induct)
     case (less k i)
     note kl = \<open>k < l\<close>
     note iki = \<open>is_kth_obs \<pi> k i\<close>
     note ret = \<open>\<pi> i = return\<close>  
     have card: \<open>card (obs_ids \<pi> \<inter> {..<i}) = k\<close> and att_ret: \<open>att return \<noteq> None\<close>using iki ret unfolding is_kth_obs_def by auto
     have rets: \<open>\<pi> (Suc i) = return\<close> using path ret term_path_stable by auto
     hence attsuc: \<open>att (\<pi> (Suc i)) \<noteq> None\<close> using att_ret by auto
     hence *: \<open>i \<in> obs_ids \<pi>\<close> using att_ret ret unfolding obs_ids_def by auto
     have \<open>{..< Suc i} = insert i {..<i}\<close> by auto
     hence a: \<open>obs_ids \<pi> \<inter> {..< Suc i} = insert i (obs_ids \<pi> \<inter> {..<i})\<close> using * by auto
     have b: \<open>i \<notin> obs_ids \<pi> \<inter> {..<i}\<close> by auto
     have \<open>finite (obs_ids \<pi> \<inter> {..<i})\<close> by auto
     hence \<open>card (obs_ids \<pi> \<inter> {..<Suc i}) = Suc k\<close> by (metis card card_insert_disjoint a b)
     hence iksuc: \<open>is_kth_obs \<pi> (Suc k) (Suc i)\<close> using attsuc unfolding is_kth_obs_def by auto
     have suckl: \<open>Suc k \<le> l\<close> using kl by auto
     note less
     thus \<open>thesis\<close> proof (cases \<open>Suc k < l\<close>) 
       assume skl: \<open>Suc k < l\<close> 
       from less(1)[OF _ skl iksuc rets] skl
       show \<open>thesis\<close> by auto
     next
       assume \<open>\<not> Suc k < l\<close>
       hence \<open>Suc k = l\<close> using suckl by auto
       thus \<open>thesis\<close> using iksuc that by auto
     qed
   qed
 qed
 
 lemma no_kth_obs_missing_cs: assumes path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and iki: \<open>is_kth_obs \<pi> k i\<close> and not_in_\<pi>': \<open>\<not>(\<exists>i'. is_kth_obs \<pi>' k i')\<close>  obtains  l j where \<open>is_kth_obs \<pi> l j\<close> \<open>\<not> (\<exists> j'. cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')\<close>
 proof (rule ccontr)
   assume \<open>\<not> thesis\<close>
   hence all_in_\<pi>': \<open>\<forall> l j. is_kth_obs \<pi> l j \<longrightarrow> (\<exists> j' . cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')\<close> using that by blast
   then obtain i' where csi: \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'\<close> using assms by blast    
   hence \<open>att(\<pi>' i') \<noteq> None\<close> using iki by (metis is_kth_obs_def last_cs)
   then obtain k' where ik': \<open>is_kth_obs \<pi>' k' i'\<close> by (metis not_none_is_obs)
   hence kk': \<open>k' < k\<close> using not_in_\<pi>' kth_obs_stable by (auto, metis not_less_iff_gr_or_eq)
   show \<open>False\<close> proof (cases \<open>\<pi> i = return\<close>)
     assume \<open>\<pi> i \<noteq> return\<close>
     thus \<open>False\<close> using kk' ik' csi iki proof (induction \<open>k\<close> arbitrary: \<open>i\<close> \<open>i'\<close> \<open>k'\<close> )
       case 0 thus \<open>?case\<close> by simp
     next
       case (Suc k i i' k')      
       then obtain j where ikj: \<open>is_kth_obs \<pi> k j\<close> by (metis kth_obs_stable lessI)
       then obtain j' where csj: \<open>cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j'\<close> using all_in_\<pi>' by blast    
       hence \<open>att(\<pi>' j') \<noteq> None\<close> using ikj by (metis is_kth_obs_def last_cs)
       then obtain k2 where ik2: \<open>is_kth_obs \<pi>' k2 j'\<close> by (metis not_none_is_obs)
       have ji: \<open>j < i\<close> using kth_obs_mono [OF ikj \<open>is_kth_obs \<pi> (Suc k) i\<close>] by auto
       hence nretj: \<open>\<pi> j \<noteq> return\<close> using Suc(2) term_path_stable less_imp_le path(1) by metis    
       have ji': \<open>j' < i'\<close> using cs_order[OF path _ _ nretj, of \<open>j'\<close> \<open>i\<close> \<open>i'\<close>] csj \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'\<close>  ji by auto
       have \<open>k2 \<noteq> k'\<close> using ik2 Suc(4) ji' kth_obs_unique[of \<open>\<pi>'\<close> \<open>k'\<close> \<open>i'\<close> \<open>j'\<close>] by (metis less_irrefl)
       hence k2k': \<open>k2 < k'\<close> using kth_obs_mono[OF \<open>is_kth_obs \<pi>' k' i'\<close> ik2] ji' by (metis not_less_iff_gr_or_eq)
       hence k2k: \<open>k2 < k\<close> using Suc by auto
       from Suc.IH[OF nretj k2k ik2 csj ikj] show \<open>False\<close> .
     qed
   next
     assume \<open>\<pi> i = return\<close>
     hence reti': \<open>\<pi>' i' = return\<close> by (metis csi last_cs)
     from ret_obs_all_obs[OF path(2) ik' reti' kk', of \<open>False\<close>] not_in_\<pi>'
     show \<open>False\<close> by blast
   qed
 qed
 
 lemma kth_obs_cs_missing_cs:  assumes path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> and iki: \<open>is_kth_obs \<pi> k i\<close> and iki': \<open>is_kth_obs \<pi>' k i'\<close> and csi: \<open>cs\<^bsup>\<pi>\<^esup> i \<noteq> cs\<^bsup>\<pi>'\<^esup> i'\<close> 
 obtains l j where \<open>j \<le> i\<close> \<open>is_kth_obs \<pi> l j\<close> \<open>\<not> (\<exists> j'. cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')\<close> | l' j' where \<open>j' \<le> i'\<close> \<open>is_kth_obs \<pi>' l' j'\<close> \<open>\<not> (\<exists> j. cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')\<close>
 proof (rule ccontr)
   assume nt: \<open>\<not> thesis\<close> 
   show \<open>False\<close> using iki iki' csi that proof (induction \<open>k\<close> arbitrary: \<open>i\<close> \<open>i'\<close> rule: less_induct)
     case (less k i i')
     hence all_in_\<pi>': \<open>\<forall> l j. j\<le>i \<and> is_kth_obs \<pi> l j \<longrightarrow> (\<exists> j' . cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')\<close> 
     and all_in_\<pi>: \<open>\<forall> l' j'. j' \<le> i' \<and> is_kth_obs \<pi>' l' j' \<longrightarrow> (\<exists> j . cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')\<close> by (metis nt) (metis nt less(6))
     obtain j j' where csji: \<open>cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> i'\<close> and csij: \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> j'\<close> using all_in_\<pi> all_in_\<pi>' less by blast 
     then obtain l l' where ilj: \<open>is_kth_obs \<pi> l j\<close> and ilj': \<open>is_kth_obs \<pi>' l' j'\<close> by (metis is_kth_obs_def last_cs less.prems(1,2))
     have lnk: \<open>l \<noteq> k\<close> using ilj csji less(2) less(4) kth_obs_unique by auto
     have lnk': \<open>l' \<noteq> k\<close> using ilj' csij less(3) less(4) kth_obs_unique by auto
     have cseq: \<open>\<forall> l j j'. l < k \<and>  is_kth_obs \<pi> l j \<and> is_kth_obs \<pi>' l j' \<longrightarrow> cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j'\<close> proof - 
       { fix t p p' assume tk: \<open>t < k\<close> and ikp: \<open>is_kth_obs \<pi> t p\<close> and ikp': \<open>is_kth_obs \<pi>' t p'\<close> 
         hence pi: \<open>p < i\<close> and pi': \<open>p' < i'\<close> by (metis kth_obs_mono less.prems(1)) (metis kth_obs_mono less.prems(2) tk ikp') 
         have *: \<open>\<And>j l. j \<le> p \<Longrightarrow> is_kth_obs \<pi> l j \<Longrightarrow> \<exists>j'. cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j'\<close> using pi all_in_\<pi>' by auto
         have **: \<open>\<And>j' l'. j' \<le> p' \<Longrightarrow> is_kth_obs \<pi>' l' j' \<Longrightarrow> \<exists>j. cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j'\<close> using pi' all_in_\<pi> by auto
         have \<open>cs\<^bsup>\<pi>\<^esup> p = cs\<^bsup>\<pi>'\<^esup> p'\<close> apply(rule ccontr) using less(1)[OF tk ikp ikp'] * ** by blast
       }
       thus \<open>?thesis\<close> by blast
     qed
     have ii'nret: \<open>\<pi> i \<noteq> return \<or> \<pi>' i' \<noteq> return\<close> using less cs_return by auto
     have a: \<open>k < l \<or> k < l'\<close> proof (rule ccontr)
       assume \<open>\<not>(k < l \<or> k < l')\<close> 
       hence *: \<open>l < k\<close> \<open>l' < k\<close> using lnk lnk' by auto
       hence ji: \<open>j < i\<close> and ji': \<open>j' < i'\<close> using ilj ilj' less(2,3) kth_obs_mono by auto      
       show \<open>False\<close> using ii'nret proof
         assume nreti: \<open>\<pi> i \<noteq> return\<close>
         hence nretj': \<open>\<pi>' j' \<noteq> return\<close> using last_cs csij by metis
         show \<open>False\<close> using cs_order[OF path(2,1) csij[symmetric] csji[symmetric] nretj' ji'] ji by simp
       next
         assume nreti': \<open>\<pi>' i' \<noteq> return\<close>
         hence nretj': \<open>\<pi> j \<noteq> return\<close> using last_cs csji by metis
         show \<open>False\<close> using cs_order[OF path csji csij nretj' ji] ji' by simp
       qed
     qed
     have \<open>l < k \<or> l' < k\<close> proof (rule ccontr)
       assume \<open>\<not> (l< k \<or> l' < k)\<close>
       hence \<open>k < l\<close> \<open>k < l'\<close> using lnk lnk' by auto
       hence ji: \<open>i < j\<close> and ji': \<open>i' < j'\<close> using ilj ilj' less(2,3) kth_obs_mono by auto
       show \<open>False\<close> using ii'nret proof
         assume nreti: \<open>\<pi> i \<noteq> return\<close>
         show \<open>False\<close> using cs_order[OF path csij csji nreti ji]  ji' by simp
       next
         assume nreti': \<open>\<pi>' i' \<noteq> return\<close>
         show \<open>False\<close> using cs_order[OF path(2,1) csji[symmetric] csij[symmetric] nreti' ji'] ji by simp
       qed
     qed    
     hence \<open>k < l \<and> l' < k \<or> k < l' \<and> l < k\<close> using a by auto
     thus \<open>False\<close> proof
       assume \<open>k < l \<and> l' < k\<close>
       hence kl: \<open>k < l\<close> and lk': \<open>l' < k\<close> by auto    
       hence ij: \<open>i < j\<close> and ji': \<open>j' < i'\<close> using less(2,3) ilj ilj' kth_obs_mono by auto      
       have nreti: \<open>\<pi> i \<noteq> return\<close> by (metis csji ii'nret ij last_cs path(1) term_path_stable less_imp_le)
       obtain h where ilh: \<open>is_kth_obs \<pi> l' h\<close> using ji' all_in_\<pi> ilj' no_kth_obs_missing_cs path(1) path(2) by (metis kl lk' ilj kth_obs_stable)
       hence \<open>cs\<^bsup>\<pi>\<^esup> h = cs\<^bsup>\<pi>'\<^esup> j'\<close> using cseq lk' ilj' by blast
       hence \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>\<^esup> h\<close> using csij by auto
       hence hi: \<open>h = i\<close> using cs_inj nreti path(1) by metis      
       have \<open>l' = k\<close> using less(2) ilh unfolding hi by (metis is_kth_obs_def)      
       thus \<open>False\<close> using lk' by simp
     next
       assume \<open>k < l' \<and> l < k\<close>
       hence kl': \<open>k < l'\<close> and lk: \<open>l < k\<close> by auto    
       hence ij': \<open>i' < j'\<close> and ji: \<open>j < i\<close> using less(2,3) ilj ilj' kth_obs_mono by auto      
       have nreti': \<open>\<pi>' i' \<noteq> return\<close> by (metis csij ii'nret ij' last_cs path(2) term_path_stable less_imp_le)
       obtain h' where ilh': \<open>is_kth_obs \<pi>' l h'\<close> using all_in_\<pi>' ilj no_kth_obs_missing_cs path(1) path(2) kl' lk ilj' kth_obs_stable by metis
       hence \<open>cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> h'\<close> using cseq lk ilj by blast
       hence \<open>cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>'\<^esup> h'\<close> using csji by auto
       hence hi: \<open>h' = i'\<close> using cs_inj nreti' path(2) by metis      
       have \<open>l = k\<close> using less(3) ilh' unfolding hi by (metis is_kth_obs_def)      
       thus \<open>False\<close> using lk by simp
     qed
   qed
 qed
 
 
 subsection \<open>Facts about Data\<close>
 
 lemma reads_restrict1: \<open>\<sigma> \<restriction> (reads n) = \<sigma>' \<restriction> (reads n) \<Longrightarrow> \<forall> x \<in> reads n. \<sigma> x = \<sigma>' x\<close> by (metis restrict_def)
 
 lemma reads_restrict2: \<open>\<forall> x \<in> reads n. \<sigma> x = \<sigma>' x \<Longrightarrow> \<sigma> \<restriction> (reads n) = \<sigma>' \<restriction> (reads n)\<close>  unfolding restrict_def by auto
 
 lemma reads_restrict: \<open>(\<sigma> \<restriction> (reads n) = \<sigma>' \<restriction> (reads n)) = (\<forall> x \<in> reads n. \<sigma> x = \<sigma>' x)\<close> using reads_restrict1 reads_restrict2 by metis
 
 lemma reads_restr_suc: \<open>\<sigma> \<restriction> (reads n) = \<sigma>' \<restriction> (reads n) \<Longrightarrow> suc n \<sigma> = suc n \<sigma>'\<close> by (metis reads_restrict uses_suc)
 
 lemma reads_restr_sem: \<open>\<sigma> \<restriction> (reads n) = \<sigma>' \<restriction> (reads n) \<Longrightarrow> \<forall> v \<in> writes n. sem n \<sigma> v = sem n \<sigma>' v\<close> by (metis reads_restrict1 uses_writes)
 
 lemma reads_obsp: assumes \<open>path \<sigma> k = path \<sigma>' k'\<close> \<open>\<sigma>\<^bsup>k\<^esup> \<restriction> (reads (path \<sigma> k)) = \<sigma>'\<^bsup>k'\<^esup> \<restriction> (reads (path \<sigma> k))\<close> shows \<open>obsp \<sigma> k = obsp \<sigma>' k'\<close> 
   using assms(2) uses_att 
   unfolding obsp_def assms(1) reads_restrict 
   apply (cases \<open>att (path \<sigma>' k')\<close>)  
   by auto
 
 lemma no_writes_unchanged0: assumes \<open>\<forall> l<k. v\<notin> writes(path \<sigma> l)\<close> shows \<open>(\<sigma>\<^bsup>k\<^esup>) v = \<sigma> v\<close> using assms 
 proof (induction \<open>k\<close>)
   case 0 thus \<open>?case\<close> by(auto simp add: kth_state_def) 
 next
   case (Suc k)
   hence \<open>(\<sigma>\<^bsup>k\<^esup>) v = \<sigma> v\<close> by auto
   moreover 
   have \<open>\<sigma>\<^bsup>Suc k\<^esup>  = snd ( step (path \<sigma> k,\<sigma>\<^bsup>k\<^esup>))\<close> by (metis kth_state_suc)
   hence \<open>\<sigma>\<^bsup>Suc k\<^esup>  = sem (path \<sigma> k) (\<sigma>\<^bsup>k\<^esup>)\<close> by (metis step_suc_sem snd_conv)
   moreover
   have \<open>v \<notin> writes (path \<sigma> k)\<close> using Suc.prems by blast
   ultimately 
   show \<open>?case\<close> using writes by metis
 qed
 
 lemma written_read_dd: assumes \<open>is_path \<pi>\<close> \<open>v \<in> reads (\<pi> k) \<close> \<open>v \<in> writes (\<pi> j)\<close> \<open>j<k\<close> obtains l where \<open>k dd\<^bsup>\<pi>,v\<^esup>\<rightarrow> l\<close> 
 proof -
   let \<open>?l\<close> = \<open>GREATEST l. l < k \<and> v \<in> writes (\<pi> l)\<close>
   have \<open>?l < k\<close> by (metis (no_types, lifting) GreatestI_ex_nat assms(3) assms(4) less_or_eq_imp_le)
   moreover
   have \<open>v \<in> writes (\<pi> ?l)\<close> by (metis (no_types, lifting) GreatestI_nat assms(3) assms(4) less_or_eq_imp_le) 
   hence \<open>v \<in> reads (\<pi> k) \<inter> writes (\<pi> ?l)\<close> using assms(2) by auto
   moreover
   note is_ddi_def
   have \<open>\<forall> l \<in> {?l<..<k}. v \<notin> writes (\<pi> l)\<close> by (auto, metis (lifting, no_types) Greatest_le_nat le_antisym nat_less_le)
   ultimately 
   have \<open>k dd\<^bsup>\<pi>,v\<^esup>\<rightarrow> ?l\<close> using assms(1) unfolding is_ddi_def by blast
   thus \<open>thesis\<close> using that by simp
 qed
 
 lemma no_writes_unchanged: assumes \<open>k \<le> l\<close> \<open>\<forall> j \<in> {k..<l}. v\<notin> writes(path \<sigma> j)\<close> shows \<open>(\<sigma>\<^bsup>l\<^esup>) v = (\<sigma>\<^bsup>k\<^esup>) v\<close> using assms
 proof (induction \<open>l - k\<close> arbitrary: \<open>l\<close>)
   case 0 thus \<open>?case\<close> by(auto) 
 next
   case (Suc lk l)
   hence kl: \<open>k < l\<close> by auto
   then obtain l' where lsuc: \<open>l = Suc l'\<close> using lessE by blast
   hence \<open>lk = l' - k\<close> using Suc by auto
   moreover 
   have \<open>\<forall> j \<in> {k..<l'}. v \<notin> writes (path \<sigma> j)\<close> using Suc(4) lsuc by auto
   ultimately  
   have \<open>(\<sigma>\<^bsup>l'\<^esup>) v = (\<sigma>\<^bsup>k\<^esup>) v\<close> using Suc(1)[of \<open>l'\<close>] lsuc kl by fastforce
   moreover 
   have \<open>\<sigma>\<^bsup>l\<^esup> = snd ( step (path \<sigma> l',\<sigma>\<^bsup>l'\<^esup>))\<close> by (metis kth_state_suc lsuc)
   hence \<open>\<sigma>\<^bsup>l\<^esup> = sem (path \<sigma> l') (\<sigma>\<^bsup>l'\<^esup>)\<close> by (metis step_suc_sem snd_conv)
   moreover
   have \<open>l' < l\<close> \<open>k \<le> l'\<close> using kl lsuc by auto
   hence \<open>v \<notin> writes (path \<sigma> l')\<close> using Suc.prems(2) by auto
   ultimately 
   show \<open>?case\<close> using writes by metis
 qed
 
 lemma ddi_value: assumes \<open>l dd\<^bsup>(path \<sigma>),v\<^esup>\<rightarrow> k\<close> shows \<open>(\<sigma>\<^bsup>l\<^esup>) v = (\<sigma>\<^bsup>Suc k\<^esup> ) v\<close>
 using assms no_writes_unchanged[of \<open>Suc k\<close> \<open>l\<close> \<open>v\<close> \<open>\<sigma>\<close>] unfolding is_ddi_def by auto
 
 lemma written_value: assumes \<open>path \<sigma> l = path \<sigma>' l'\<close> \<open>\<sigma>\<^bsup>l\<^esup> \<restriction> reads (path \<sigma> l) = \<sigma>'\<^bsup>l'\<^esup> \<restriction> reads (path \<sigma> l)\<close> \<open>v \<in> writes (path \<sigma> l)\<close> 
 shows \<open>(\<sigma>\<^bsup>Suc l\<^esup> ) v = (\<sigma>'\<^bsup>Suc l'\<^esup> ) v\<close> 
 by (metis assms reads_restr_sem snd_conv step_suc_sem kth_state_suc) 
 
 
 subsection \<open>Facts about Contradicting Paths\<close>
 
 lemma obsp_contradict: assumes csk: \<open>cs\<^bsup>path \<sigma>\<^esup> k = cs\<^bsup>path \<sigma>'\<^esup> k'\<close> and obs: \<open>obsp \<sigma> k \<noteq> obsp \<sigma>' k'\<close> shows \<open>(\<sigma>', k') \<cc> (\<sigma>, k)\<close>
 proof -
   have pk: \<open>path \<sigma> k = path \<sigma>' k'\<close> using assms last_cs by metis
   hence \<open>\<sigma>\<^bsup>k\<^esup>\<restriction>(reads (path \<sigma> k)) \<noteq> \<sigma>'\<^bsup>k'\<^esup>\<restriction>(reads (path \<sigma> k))\<close> using obs reads_obsp[OF pk] by auto
   thus \<open>(\<sigma>',k') \<cc> (\<sigma>,k)\<close> using contradicts.intros(2)[OF csk[symmetric]] by auto
 qed
 
 lemma missing_cs_contradicts: assumes notin: \<open>\<not>(\<exists> k'. cs\<^bsup>path \<sigma>\<^esup> k = cs\<^bsup>path \<sigma>'\<^esup> k')\<close> and converge: \<open>k<n\<close> \<open>cs\<^bsup>path \<sigma>\<^esup> n = cs\<^bsup>path \<sigma>'\<^esup> n'\<close> shows \<open>\<exists> j'. (\<sigma>', j') \<cc> (\<sigma>, k)\<close>
 proof -
   let \<open>?\<pi>\<close> = \<open>path \<sigma>\<close>
   let \<open>?\<pi>'\<close> = \<open>path \<sigma>'\<close>
   have init: \<open>?\<pi> 0 = ?\<pi>' 0\<close> unfolding path_def by auto
   have path: \<open>is_path ?\<pi>\<close> \<open>is_path ?\<pi>'\<close> using path_is_path by auto
   obtain j j' where csj: \<open>cs\<^bsup>?\<pi>\<^esup> j = cs\<^bsup>?\<pi>'\<^esup> j'\<close> and cd: \<open>k cd\<^bsup>?\<pi>\<^esup>\<rightarrow>j\<close> and suc: \<open>?\<pi> (Suc j) \<noteq> ?\<pi>' (Suc j')\<close> using converged_cd_diverge[OF path init notin converge] .
   have less: \<open>cs\<^bsup>?\<pi>\<^esup> j \<prec> cs\<^bsup>?\<pi>\<^esup> k\<close> using cd cd_is_cs_less by auto
   have nretj: \<open>?\<pi> j \<noteq> return\<close> by (metis cd is_cdi_def term_path_stable less_imp_le)
   have cs: \<open>?\<pi> \<exclamdown> cs\<^bsup>?\<pi>'\<^esup> j' = j\<close> using csj cs_select_id nretj path_is_path by metis
   have \<open>(\<sigma>',j') \<cc> (\<sigma>,k)\<close> using contradicts.intros(1)[of \<open>?\<pi>'\<close> \<open>j'\<close> \<open>?\<pi>\<close> \<open>k\<close> \<open>\<sigma>\<close> \<open>\<sigma>'\<close>,unfolded cs] less suc csj by metis
   thus \<open>?thesis\<close> by blast
 qed
 
 theorem obs_neq_contradicts_term: fixes \<sigma> \<sigma>' defines \<pi>: \<open>\<pi> \<equiv> path \<sigma>\<close> and \<pi>': \<open>\<pi>' \<equiv> path \<sigma>'\<close> assumes ret: \<open>\<pi> n = return\<close> \<open>\<pi>' n' = return\<close> and obsne: \<open>obs \<sigma> \<noteq> obs \<sigma>'\<close> 
 shows \<open>\<exists> k k'. ((\<sigma>', k') \<cc> (\<sigma> ,k) \<and> \<pi> k \<in> dom (att)) \<or> ((\<sigma>, k) \<cc> (\<sigma>' ,k') \<and> \<pi>' k' \<in> dom (att))\<close>
 proof - 
   have path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> using \<pi> \<pi>' path_is_path by auto
   obtain k1 where neq: \<open>obs \<sigma> k1 \<noteq> obs \<sigma>' k1\<close> using obsne ext[of \<open>obs \<sigma>\<close> \<open>obs \<sigma>'\<close>] by blast  
   hence \<open>(\<exists>k i i'. is_kth_obs \<pi> k i \<and> is_kth_obs \<pi>' k i' \<and> obsp \<sigma> i \<noteq> obsp \<sigma>' i' \<and> cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i') 
   \<or> (\<exists> k i. is_kth_obs \<pi> k i \<and> \<not> (\<exists> i'. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i')) 
   \<or> (\<exists> k i'. is_kth_obs \<pi>' k i' \<and> \<not> (\<exists> i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'))\<close>
   proof(cases rule: option_neq_cases)
     case (none2 x)
     have notin\<pi>': \<open>\<not> (\<exists> l. is_kth_obs \<pi>' k1 l)\<close> using none2(2) \<pi>' obs_none_no_kth_obs by auto
     obtain i where in\<pi>: \<open>is_kth_obs \<pi> k1 i\<close> using obs_some_kth_obs[of \<open>\<sigma>\<close> \<open>k1\<close>] none2(1) \<pi> by auto            
     obtain l j where \<open>is_kth_obs \<pi> l j\<close> \<open>\<not> (\<exists> j'. cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')\<close> using path in\<pi> notin\<pi>' by (metis no_kth_obs_missing_cs)
     thus \<open>?thesis\<close> by blast
   next
     case (none1 x)
     have notin\<pi>: \<open>\<not> (\<exists> l. is_kth_obs \<pi> k1 l)\<close> using none1(1) \<pi> obs_none_no_kth_obs by auto
     obtain i' where in\<pi>': \<open>is_kth_obs \<pi>' k1 i'\<close> using obs_some_kth_obs[of \<open>\<sigma>'\<close> \<open>k1\<close>] none1(2) \<pi>' by auto            
     obtain l j where \<open>is_kth_obs \<pi>' l j\<close> \<open>\<not> (\<exists> j'. cs\<^bsup>\<pi>\<^esup> j' = cs\<^bsup>\<pi>'\<^esup> j)\<close> using path in\<pi>' notin\<pi> by (metis no_kth_obs_missing_cs)
     thus \<open>?thesis\<close> by blast
   next  
     case (some x y)
     obtain i where in\<pi>: \<open>is_kth_obs \<pi> k1 i\<close> using obs_some_kth_obs[of \<open>\<sigma>\<close> \<open>k1\<close>] some \<pi> by auto
     obtain i' where in\<pi>': \<open>is_kth_obs \<pi>' k1 i'\<close> using obs_some_kth_obs[of \<open>\<sigma>'\<close> \<open>k1\<close>] some \<pi>' by auto
     show \<open>?thesis\<close> proof (cases)
       assume *: \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'\<close>
       have \<open>obsp \<sigma> i = obs \<sigma> k1\<close> by (metis obs_def \<pi> in\<pi> kth_obs_unique the_equality)
       moreover
       have \<open>obsp \<sigma>' i' = obs \<sigma>' k1\<close> by (metis obs_def \<pi>' in\<pi>' kth_obs_unique the_equality)
       ultimately
       have \<open>obsp \<sigma> i \<noteq> obsp \<sigma>' i'\<close> using neq by auto
       thus \<open>?thesis\<close> using * in\<pi> in\<pi>' by blast
     next
       assume *: \<open>cs\<^bsup>\<pi>\<^esup> i \<noteq> cs\<^bsup>\<pi>'\<^esup> i'\<close>
       note kth_obs_cs_missing_cs[OF path in\<pi> in\<pi>' *]
       thus \<open>?thesis\<close> by metis
     qed
   qed
   thus \<open>?thesis\<close> proof (cases rule: three_cases)
     case 1
     then obtain k i i' where iki: \<open>is_kth_obs \<pi> k i\<close> \<open>is_kth_obs \<pi>' k i'\<close> and obsne: \<open>obsp \<sigma> i \<noteq> obsp \<sigma>' i'\<close> and csi: \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'\<close> by auto
     note obsp_contradict[OF csi[unfolded \<pi> \<pi>'] obsne]
     moreover
     have \<open>\<pi> i \<in> dom att\<close> using iki unfolding is_kth_obs_def by auto
     ultimately
     show \<open>?thesis\<close> by blast
   next
     case 2
     then obtain k i where iki: \<open>is_kth_obs \<pi> k i\<close> and notin\<pi>': \<open>\<not> (\<exists>i'. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i')\<close> by auto
     let \<open>?n\<close> = \<open>Suc (max n i)\<close>
     have nn: \<open>n < ?n\<close> by auto
     have iln: \<open>i < ?n\<close> by auto
     have retn: \<open>\<pi> ?n = return\<close> using ret term_path_stable path by auto
     hence \<open>cs\<^bsup>\<pi>\<^esup> ?n = cs\<^bsup>\<pi>'\<^esup> n'\<close> using ret(2) cs_return by auto
     then obtain i' where \<open>(\<sigma>',i') \<cc> (\<sigma>,i)\<close> using missing_cs_contradicts[OF notin\<pi>'[unfolded \<pi> \<pi>'] iln] \<pi> \<pi>' by auto
     moreover
     have \<open>\<pi> i \<in> dom att\<close> using iki is_kth_obs_def by auto
     ultimately
     show \<open>?thesis\<close> by blast
   next
     case 3
     then obtain k i' where iki: \<open>is_kth_obs \<pi>' k i'\<close> and notin\<pi>': \<open>\<not> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i')\<close> by auto
     let \<open>?n\<close> = \<open>Suc (max n' i')\<close>
     have nn: \<open>n' < ?n\<close> by auto
     have iln: \<open>i' < ?n\<close> by auto
     have retn: \<open>\<pi>' ?n = return\<close> using ret term_path_stable path by auto
     hence \<open>cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> ?n\<close> using ret(1) cs_return by auto
     then obtain i where \<open>(\<sigma>,i) \<cc> (\<sigma>',i')\<close> using missing_cs_contradicts notin\<pi>' iln \<pi> \<pi>' by metis
     moreover
     have \<open>\<pi>' i' \<in> dom att\<close> using iki is_kth_obs_def by auto
     ultimately
     show \<open>?thesis\<close> by blast
   qed
 qed
 
 lemma obs_neq_some_contradicts': fixes \<sigma> \<sigma>' defines \<pi>: \<open>\<pi> \<equiv> path \<sigma>\<close> and \<pi>': \<open>\<pi>' \<equiv> path \<sigma>'\<close> 
 assumes obsnecs: \<open>obsp \<sigma> i \<noteq> obsp \<sigma>' i' \<or> cs\<^bsup>\<pi>\<^esup> i \<noteq> cs\<^bsup>\<pi>'\<^esup> i'\<close>
 and iki: \<open>is_kth_obs \<pi> k i\<close> and iki': \<open>is_kth_obs \<pi>' k i'\<close>
 shows \<open>\<exists> k k'. ((\<sigma>', k') \<cc> (\<sigma> ,k) \<and> \<pi> k \<in> dom att) \<or> ((\<sigma>, k) \<cc> (\<sigma>' ,k') \<and> \<pi>' k' \<in> dom att)\<close>
 using obsnecs iki iki' proof (induction \<open>k\<close> arbitrary: \<open>i\<close> \<open>i'\<close> rule: less_induct )
   case (less k i i')  
   note iki = \<open>is_kth_obs \<pi> k i\<close>
   and iki' = \<open>is_kth_obs \<pi>' k i'\<close>
   have domi: \<open>\<pi> i \<in> dom att\<close> by (metis is_kth_obs_def domIff iki)
   have domi': \<open>\<pi>' i' \<in> dom att\<close> by (metis is_kth_obs_def domIff iki')
   note obsnecs = \<open>obsp \<sigma> i \<noteq> obsp \<sigma>' i' \<or> cs\<^bsup>\<pi>\<^esup> i \<noteq> cs\<^bsup>\<pi>'\<^esup> i'\<close>  
   show \<open>?thesis\<close> proof cases
     assume csi: \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'\<close>
     hence *: \<open>obsp \<sigma> i \<noteq> obsp \<sigma>' i'\<close> using obsnecs by auto
     note obsp_contradict[OF _ *] csi domi \<pi> \<pi>'
     thus \<open>?thesis\<close> by blast    
   next      
     assume ncsi: \<open>cs\<^bsup>\<pi>\<^esup> i \<noteq> cs\<^bsup>\<pi>'\<^esup> i'\<close>  
     have path: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> using \<pi> \<pi>' path_is_path by auto
     have \<pi>0: \<open>\<pi> 0 = \<pi>' 0\<close> unfolding \<pi> \<pi>' path_def by auto
     note kth_obs_cs_missing_cs[of \<open>\<pi>\<close> \<open>\<pi>'\<close> \<open>k\<close> \<open>i\<close> \<open>i'\<close>] \<pi> \<pi>' path_is_path iki iki' ncsi 
     hence \<open>(\<exists> l j .j \<le> i \<and> is_kth_obs \<pi> l j \<and> \<not> (\<exists> j'. cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')) \<or> (\<exists> l' j'. j' \<le> i' \<and> is_kth_obs \<pi>' l' j' \<and> \<not> (\<exists> j. cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j'))\<close> by metis
     thus \<open>?thesis\<close> proof
       assume \<open>\<exists>l j. j \<le> i \<and> is_kth_obs \<pi> l j \<and> \<not> (\<exists>j'. cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')\<close>
       then obtain l j where ji: \<open>j\<le>i\<close> and iobs: \<open>is_kth_obs \<pi> l j\<close> and notin: \<open>\<not> (\<exists>j'. cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')\<close> by blast
       have dom: \<open>\<pi> j \<in> dom att\<close> using iobs is_kth_obs_def by auto
       obtain n n' where nj: \<open>n < j\<close> and csn: \<open>cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n'\<close> and sucn:  \<open>\<pi> (Suc n) \<noteq> \<pi>' (Suc n')\<close> and cdloop: \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow> n \<or> (\<forall> j'> n'. j' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n')\<close>
       using missing_cd_or_loop[OF path \<pi>0 notin] by blast
       show \<open>?thesis\<close> using cdloop proof
         assume cdjn: \<open>j cd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close>
         hence csnj: \<open>cs\<^bsup>\<pi>'\<^esup> n' \<prec> cs\<^bsup>\<pi>\<^esup> j\<close> using csn by (metis cd_is_cs_less)
         have cssel: \<open>\<pi> (Suc (\<pi> \<exclamdown> cs\<^bsup>\<pi>'\<^esup> n')) = \<pi> (Suc n)\<close> using csn by (metis cdjn cd_not_ret cs_select_id path(1))
         have \<open>(\<sigma>',n') \<cc> (\<sigma>,j)\<close> using csnj apply(rule contradicts.intros(1)) using cssel \<pi> \<pi>' sucn by auto 
         thus \<open>?thesis\<close> using dom by auto
       next
         assume loop: \<open>\<forall> j'>n'. j' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n'\<close>
         show \<open>?thesis\<close> proof cases
           assume in': \<open>i' \<le> n'\<close>
           have nreti': \<open>\<pi>' i' \<noteq> return\<close> by( metis le_eq_less_or_eq lessI loop not_le path(2) ret_no_cd term_path_stable)
           show \<open>?thesis\<close> proof cases
             assume \<open>\<exists> \<iota>. cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> \<iota>\<close>
             then obtain \<iota> where cs\<iota>: \<open>cs\<^bsup>\<pi>\<^esup> \<iota> = cs\<^bsup>\<pi>'\<^esup> i'\<close> by metis            
             have \<iota>n: \<open>\<iota> \<le> n\<close> using cs_order_le[OF path(2,1) cs\<iota>[symmetric] csn[symmetric] nreti' in'] .
             hence \<iota>i: \<open>\<iota> < i\<close> using nj ji by auto 
             have dom\<iota>: \<open>\<pi> \<iota> \<in> dom att\<close> using domi' cs\<iota> last_cs by metis
             obtain \<kappa> where i\<kappa>\<iota>: \<open>is_kth_obs \<pi> \<kappa> \<iota>\<close> using dom\<iota> by (metis is_kth_obs_def domIff)
             hence \<kappa>k: \<open>\<kappa> < k\<close> using \<iota>i iki by (metis kth_obs_le_iff)
             obtain \<iota>' where i\<kappa>\<iota>': \<open>is_kth_obs \<pi>' \<kappa> \<iota>'\<close> using \<kappa>k iki' by (metis kth_obs_stable)
             have \<open>\<iota>' < i'\<close> using \<kappa>k iki' i\<kappa>\<iota>' by (metis kth_obs_le_iff)
             hence cs\<iota>': \<open>cs\<^bsup>\<pi>\<^esup> \<iota> \<noteq> cs\<^bsup>\<pi>'\<^esup> \<iota>'\<close> unfolding cs\<iota> using cs_inj[OF path(2) nreti', of \<open>\<iota>'\<close>] by blast           
             thus \<open>?thesis\<close> using less(1)[OF \<kappa>k _ i\<kappa>\<iota> i\<kappa>\<iota>'] by auto
           next
             assume notin'': \<open>\<not>(\<exists> \<iota>. cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> \<iota>)\<close>
             obtain \<iota> \<iota>' where \<iota>i': \<open>\<iota>' < i'\<close> and cs\<iota>: \<open>cs\<^bsup>\<pi>\<^esup> \<iota> = cs\<^bsup>\<pi>'\<^esup> \<iota>'\<close> and suc\<iota>: \<open>\<pi> (Suc \<iota>) \<noteq> \<pi>' (Suc \<iota>')\<close> and cdloop': \<open>i' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> \<iota>' \<or> (\<forall> j>\<iota>. j cd\<^bsup>\<pi>\<^esup>\<rightarrow> \<iota>)\<close>
             using missing_cd_or_loop[OF path(2,1) \<pi>0[symmetric] notin''] by metis
             show \<open>?thesis\<close> using cdloop' proof
               assume cdjn: \<open>i' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> \<iota>'\<close>
               hence csnj: \<open>cs\<^bsup>\<pi>\<^esup> \<iota> \<prec> cs\<^bsup>\<pi>'\<^esup> i'\<close> using cs\<iota> by (metis cd_is_cs_less)
               have cssel: \<open>\<pi>' (Suc (\<pi>' \<exclamdown> cs\<^bsup>\<pi>\<^esup> \<iota>)) = \<pi>' (Suc \<iota>')\<close> using cs\<iota> by (metis cdjn cd_not_ret cs_select_id path(2))
               have \<open>(\<sigma>,\<iota>) \<cc> (\<sigma>',i')\<close> using csnj apply(rule contradicts.intros(1)) using cssel \<pi> \<pi>' suc\<iota> by auto 
               thus \<open>?thesis\<close> using domi' by auto
             next
               assume loop': \<open>\<forall> j>\<iota>. j cd\<^bsup>\<pi>\<^esup>\<rightarrow> \<iota>\<close>
               have \<iota>n': \<open>\<iota>' < n'\<close> using in' \<iota>i' by auto
               have nret\<iota>': \<open>\<pi>' \<iota>' \<noteq> return\<close> by (metis cs\<iota> last_cs le_eq_less_or_eq lessI path(1) path(2) suc\<iota> term_path_stable)
               have \<open>\<iota> < n\<close> using cs_order[OF path(2,1) cs\<iota>[symmetric] csn[symmetric] nret\<iota>' \<iota>n'] .
               hence \<open>\<iota> < i\<close> using nj ji by auto
               hence cdi\<iota>: \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> \<iota>\<close> using loop' by auto
               hence cs\<iota>i: \<open>cs\<^bsup>\<pi>'\<^esup> \<iota>' \<prec> cs\<^bsup>\<pi>\<^esup> i\<close> using cs\<iota> by (metis cd_is_cs_less)
               have cssel: \<open>\<pi> (Suc (\<pi> \<exclamdown> cs\<^bsup>\<pi>'\<^esup> \<iota>')) = \<pi> (Suc \<iota>)\<close> using cs\<iota> by (metis cdi\<iota> cd_not_ret cs_select_id path(1))
               have \<open>(\<sigma>',\<iota>') \<cc> (\<sigma>,i)\<close> using cs\<iota>i apply(rule contradicts.intros(1)) using cssel \<pi> \<pi>' suc\<iota> by auto 
               thus \<open>?thesis\<close> using domi by auto
             qed
           qed
         next
           assume \<open>\<not> i' \<le> n'\<close>
           hence ni': \<open>n'< i'\<close> by simp
           hence cdin: \<open>i' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n'\<close> using loop by auto
           hence csni: \<open>cs\<^bsup>\<pi>\<^esup> n \<prec> cs\<^bsup>\<pi>'\<^esup> i'\<close> using csn by (metis cd_is_cs_less)
           have cssel: \<open>\<pi>' (Suc (\<pi>' \<exclamdown> cs\<^bsup>\<pi>\<^esup> n)) = \<pi>' (Suc n')\<close> using csn by (metis cdin cd_not_ret cs_select_id path(2))
           have \<open>(\<sigma>,n) \<cc> (\<sigma>',i')\<close> using csni apply(rule contradicts.intros(1)) using cssel \<pi> \<pi>' sucn by auto 
           thus \<open>?thesis\<close> using domi' by auto
         qed
       qed
     next
       \<comment> \<open>Symmetric case as above, indices might be messy.\<close>
       assume \<open>\<exists>l j. j \<le> i' \<and> is_kth_obs \<pi>' l j \<and> \<not> (\<exists>j'. cs\<^bsup>\<pi>\<^esup> j' = cs\<^bsup>\<pi>'\<^esup> j)\<close>
       then obtain l j where ji': \<open>j\<le>i'\<close> and iobs: \<open>is_kth_obs \<pi>' l j\<close> and notin: \<open>\<not> (\<exists>j'. cs\<^bsup>\<pi>'\<^esup> j = cs\<^bsup>\<pi>\<^esup> j')\<close> by metis
       have dom: \<open>\<pi>' j \<in> dom att\<close> using iobs is_kth_obs_def by auto
       obtain n n' where nj: \<open>n < j\<close> and csn: \<open>cs\<^bsup>\<pi>'\<^esup> n = cs\<^bsup>\<pi>\<^esup> n'\<close> and sucn:  \<open>\<pi>' (Suc n) \<noteq> \<pi> (Suc n')\<close> and cdloop: \<open>j cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n \<or> (\<forall> j'> n'. j' cd\<^bsup>\<pi>\<^esup>\<rightarrow> n')\<close>
       using missing_cd_or_loop[OF path(2,1) \<pi>0[symmetric] ] notin by metis
       show \<open>?thesis\<close> using cdloop proof
         assume cdjn: \<open>j cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n\<close>
         hence csnj: \<open>cs\<^bsup>\<pi>\<^esup> n' \<prec> cs\<^bsup>\<pi>'\<^esup> j\<close> using csn by (metis cd_is_cs_less)
         have cssel: \<open>\<pi>' (Suc (\<pi>' \<exclamdown> cs\<^bsup>\<pi>\<^esup> n')) = \<pi>' (Suc n)\<close> using csn by (metis cdjn cd_not_ret cs_select_id path(2))
         have \<open>(\<sigma>,n') \<cc> (\<sigma>',j)\<close> using csnj apply(rule contradicts.intros(1)) using cssel \<pi>' \<pi> sucn by auto 
         thus \<open>?thesis\<close> using dom by auto
       next
         assume loop: \<open>\<forall> j'>n'. j' cd\<^bsup>\<pi>\<^esup>\<rightarrow> n'\<close>
         show \<open>?thesis\<close> proof cases
           assume in': \<open>i \<le> n'\<close>
           have nreti: \<open>\<pi> i \<noteq> return\<close> by (metis le_eq_less_or_eq lessI loop not_le path(1) ret_no_cd term_path_stable)
           show \<open>?thesis\<close> proof cases
             assume \<open>\<exists> \<iota>. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> \<iota>\<close>
             then obtain \<iota> where cs\<iota>: \<open>cs\<^bsup>\<pi>'\<^esup> \<iota> = cs\<^bsup>\<pi>\<^esup> i\<close> by metis            
             have \<iota>n: \<open>\<iota> \<le> n\<close> using cs_order_le[OF path cs\<iota>[symmetric] csn[symmetric] nreti in'] .
             hence \<iota>i': \<open>\<iota> < i'\<close> using nj ji' by auto 
             have dom\<iota>: \<open>\<pi>' \<iota> \<in> dom att\<close> using domi cs\<iota> last_cs by metis
             obtain \<kappa> where i\<kappa>\<iota>: \<open>is_kth_obs \<pi>' \<kappa> \<iota>\<close> using dom\<iota> by (metis is_kth_obs_def domIff)
             hence \<kappa>k: \<open>\<kappa> < k\<close> using \<iota>i' iki' by (metis kth_obs_le_iff)
             obtain \<iota>' where i\<kappa>\<iota>': \<open>is_kth_obs \<pi> \<kappa> \<iota>'\<close> using \<kappa>k iki by (metis kth_obs_stable)
             have \<open>\<iota>' < i\<close> using \<kappa>k iki i\<kappa>\<iota>' by (metis kth_obs_le_iff)
             hence cs\<iota>': \<open>cs\<^bsup>\<pi>'\<^esup> \<iota> \<noteq> cs\<^bsup>\<pi>\<^esup> \<iota>'\<close> unfolding cs\<iota> using cs_inj[OF path(1) nreti, of \<open>\<iota>'\<close>] by blast           
             thus \<open>?thesis\<close> using less(1)[OF \<kappa>k _ i\<kappa>\<iota>' i\<kappa>\<iota>] by auto
           next
             assume notin'': \<open>\<not>(\<exists> \<iota>. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> \<iota>)\<close>
             obtain \<iota> \<iota>' where \<iota>i: \<open>\<iota>' < i\<close> and cs\<iota>: \<open>cs\<^bsup>\<pi>'\<^esup> \<iota> = cs\<^bsup>\<pi>\<^esup> \<iota>'\<close> and suc\<iota>: \<open>\<pi>' (Suc \<iota>) \<noteq> \<pi> (Suc \<iota>')\<close> and cdloop': \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> \<iota>' \<or> (\<forall> j>\<iota>. j cd\<^bsup>\<pi>'\<^esup>\<rightarrow> \<iota>)\<close>
             using missing_cd_or_loop[OF path \<pi>0 notin''] by metis
             show \<open>?thesis\<close> using cdloop' proof
               assume cdjn: \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> \<iota>'\<close>
               hence csnj: \<open>cs\<^bsup>\<pi>'\<^esup> \<iota> \<prec> cs\<^bsup>\<pi>\<^esup> i\<close> using cs\<iota> by (metis cd_is_cs_less)
               have cssel: \<open>\<pi> (Suc (\<pi> \<exclamdown> cs\<^bsup>\<pi>'\<^esup> \<iota>)) = \<pi> (Suc \<iota>')\<close> using cs\<iota> by (metis cdjn cd_not_ret cs_select_id path(1))
               have \<open>(\<sigma>',\<iota>) \<cc> (\<sigma>,i)\<close> using csnj apply(rule contradicts.intros(1)) using cssel \<pi>' \<pi> suc\<iota> by auto 
               thus \<open>?thesis\<close> using domi by auto
             next
               assume loop': \<open>\<forall> j>\<iota>. j cd\<^bsup>\<pi>'\<^esup>\<rightarrow> \<iota>\<close>
               have \<iota>n': \<open>\<iota>' < n'\<close> using in' \<iota>i by auto
               have nret\<iota>': \<open>\<pi> \<iota>' \<noteq> return\<close> by (metis cs\<iota> last_cs le_eq_less_or_eq lessI path(1) path(2) suc\<iota> term_path_stable)
               have \<open>\<iota> < n\<close> using cs_order[OF path cs\<iota>[symmetric] csn[symmetric] nret\<iota>' \<iota>n'] .
               hence \<open>\<iota> < i'\<close> using nj ji' by auto
               hence cdi\<iota>: \<open>i' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> \<iota>\<close> using loop' by auto
               hence cs\<iota>i': \<open>cs\<^bsup>\<pi>\<^esup> \<iota>' \<prec> cs\<^bsup>\<pi>'\<^esup> i'\<close> using cs\<iota> by (metis cd_is_cs_less)
               have cssel: \<open>\<pi>' (Suc (\<pi>' \<exclamdown> cs\<^bsup>\<pi>\<^esup> \<iota>')) = \<pi>' (Suc \<iota>)\<close> using cs\<iota> by (metis cdi\<iota> cd_not_ret cs_select_id path(2))
               have \<open>(\<sigma>,\<iota>') \<cc> (\<sigma>',i')\<close> using cs\<iota>i' apply(rule contradicts.intros(1)) using cssel \<pi>' \<pi> suc\<iota> by auto 
               thus \<open>?thesis\<close> using domi' by auto
             qed
           qed
         next
           assume \<open>\<not> i \<le> n'\<close>
           hence ni: \<open>n'< i\<close> by simp
           hence cdin: \<open>i cd\<^bsup>\<pi>\<^esup>\<rightarrow> n'\<close> using loop by auto
           hence csni': \<open>cs\<^bsup>\<pi>'\<^esup> n \<prec> cs\<^bsup>\<pi>\<^esup> i\<close> using csn by (metis cd_is_cs_less)
           have cssel: \<open>\<pi> (Suc (\<pi> \<exclamdown> cs\<^bsup>\<pi>'\<^esup> n)) = \<pi> (Suc n')\<close> using csn by (metis cdin cd_not_ret cs_select_id path(1))
           have \<open>(\<sigma>',n) \<cc> (\<sigma>,i)\<close> using csni' apply(rule contradicts.intros(1)) using cssel \<pi>' \<pi> sucn by auto 
           thus \<open>?thesis\<close> using domi by auto
         qed
       qed
     qed
   qed
 qed
 
 theorem obs_neq_some_contradicts: fixes \<sigma> \<sigma>' defines \<pi>: \<open>\<pi> \<equiv> path \<sigma>\<close> and \<pi>': \<open>\<pi>' \<equiv> path \<sigma>'\<close> 
 assumes obsne: \<open>obs \<sigma> k \<noteq> obs \<sigma>' k\<close> and not_none: \<open>obs \<sigma> k \<noteq> None\<close> \<open>obs \<sigma>' k \<noteq> None\<close> 
 shows \<open>\<exists> k k'. ((\<sigma>', k') \<cc> (\<sigma> ,k) \<and> \<pi> k \<in> dom att) \<or> ((\<sigma>, k) \<cc> (\<sigma>' ,k') \<and> \<pi>' k' \<in> dom att)\<close>
 proof -
   obtain i where iki: \<open>is_kth_obs \<pi> k i\<close> using not_none(1) by (metis \<pi> obs_some_kth_obs)
   obtain i' where iki': \<open>is_kth_obs \<pi>' k i'\<close> using not_none(2) by (metis \<pi>' obs_some_kth_obs)
   have \<open>obsp \<sigma> i = obs \<sigma> k\<close> by (metis \<pi> iki kth_obs_unique obs_def the_equality)
   moreover
   have \<open>obsp \<sigma>' i' = obs \<sigma>' k\<close> by (metis \<pi>' iki' kth_obs_unique obs_def the_equality)
   ultimately
   have obspne: \<open>obsp \<sigma> i \<noteq> obsp \<sigma>' i'\<close> using obsne by auto
   show \<open>?thesis\<close> using obs_neq_some_contradicts'[OF _ iki[unfolded \<pi>] iki'[unfolded \<pi>']] using obspne \<pi> \<pi>' by metis
 qed
 
 theorem obs_neq_ret_contradicts: fixes \<sigma> \<sigma>' defines \<pi>: \<open>\<pi> \<equiv> path \<sigma>\<close> and \<pi>': \<open>\<pi>' \<equiv> path \<sigma>'\<close> 
 assumes ret: \<open>\<pi> n = return\<close> and obsne: \<open>obs \<sigma>' i \<noteq> obs \<sigma> i\<close> and obs:\<open>obs \<sigma>' i \<noteq> None\<close>
 shows \<open>\<exists> k k'. ((\<sigma>', k') \<cc> (\<sigma> ,k) \<and> \<pi> k \<in> dom (att)) \<or> ((\<sigma>, k) \<cc> (\<sigma>' ,k') \<and> \<pi>' k' \<in> dom (att))\<close>
 proof (cases \<open>\<exists> j k'. is_kth_obs \<pi>' j k' \<and> (\<nexists> k. cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k')\<close>)
   case True
   obtain l k' where jk': \<open>is_kth_obs \<pi>' l k'\<close> and unmatched: \<open>(\<nexists> k. cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k')\<close> using True by blast
   have \<pi>0: \<open>\<pi> 0 = \<pi>' 0\<close> using \<pi> \<pi>' path0 by auto
   obtain j j' where csj: \<open>cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j'\<close> and cd: \<open>k' cd\<^bsup>\<pi>'\<^esup>\<rightarrow>j'\<close> and suc: \<open>\<pi> (Suc j) \<noteq> \<pi>' (Suc j')\<close>
     using converged_cd_diverge_return[of \<open>\<pi>'\<close> \<open>\<pi>\<close> \<open>k'\<close> \<open>n\<close>] ret unmatched path_is_path \<pi> \<pi>' \<pi>0 by metis 
   hence *: \<open>(\<sigma>, j) \<cc> (\<sigma>' ,k')\<close> using contradicts.intros(1)[of \<open>\<pi>\<close> \<open>j\<close> \<open>\<pi>'\<close> \<open>k'\<close> \<open>\<sigma>'\<close> \<open>\<sigma>\<close>, unfolded csj] \<pi> \<pi>'
     using cd_is_cs_less cd_not_ret cs_select_id by auto 
   have \<open>\<pi>' k' \<in> dom(att)\<close> using jk' by (meson domIff is_kth_obs_def) 
   thus \<open>?thesis\<close> using * by blast
 next
   case False
   hence *: \<open>\<And> j k'. is_kth_obs \<pi>' j k' \<Longrightarrow> \<exists> k. cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k'\<close> by auto
   obtain k' where k': \<open>is_kth_obs \<pi>' i k'\<close> using obs \<pi>' obs_some_kth_obs by blast
   obtain l where \<open>is_kth_obs \<pi> i l\<close> using * \<pi> \<pi>' k' no_kth_obs_missing_cs path_is_path by metis
   thus \<open>?thesis\<close> using \<pi> \<pi>' obs obs_neq_some_contradicts obs_none_no_kth_obs obsne by metis
 qed
 
 
 subsection \<open>Facts about Critical Observable Paths\<close>
 
 lemma contradicting_in_cp: assumes leq:\<open>\<sigma> =\<^sub>L \<sigma>'\<close> and cseq: \<open>cs\<^bsup>path \<sigma>\<^esup> k = cs\<^bsup>path \<sigma>'\<^esup> k'\<close> 
 and readv: \<open>v\<in>reads(path \<sigma> k)\<close> and vneq: \<open>(\<sigma>\<^bsup>k\<^esup>) v \<noteq> (\<sigma>'\<^bsup>k'\<^esup>) v\<close> shows \<open>((\<sigma>,k),(\<sigma>',k')) \<in> cp\<close>
   using cseq readv vneq proof(induction \<open>k+k'\<close> arbitrary: \<open>k\<close> \<open>k'\<close> \<open>v\<close> rule: less_induct)
   fix k k' v     
   assume csk: \<open>cs\<^bsup>path \<sigma>\<^esup> k = cs\<^bsup>path \<sigma>'\<^esup> k'\<close>
   assume vread: \<open>v \<in> reads (path \<sigma> k)\<close>
   assume vneq: \<open>(\<sigma>\<^bsup>k\<^esup>) v \<noteq> (\<sigma>'\<^bsup>k'\<^esup>) v\<close>
   assume IH: \<open>\<And>ka k'a v. ka + k'a < k + k' \<Longrightarrow> cs\<^bsup>path \<sigma>\<^esup> ka = cs\<^bsup>path \<sigma>'\<^esup> k'a \<Longrightarrow> v \<in> reads (path \<sigma> ka) \<Longrightarrow> (\<sigma>\<^bsup>ka\<^esup>) v \<noteq> (\<sigma>'\<^bsup>k'a\<^esup>) v \<Longrightarrow> ((\<sigma>, ka), \<sigma>', k'a) \<in> cp\<close> 
   
   define \<pi> where  \<open>\<pi> \<equiv> path \<sigma>\<close> 
   define \<pi>' where \<open>\<pi>' \<equiv> path \<sigma>'\<close> 
   have path: \<open>\<pi> = path \<sigma>\<close> \<open>\<pi>' = path \<sigma>'\<close> using \<pi>_def \<pi>'_def path_is_path by auto  
   have ip: \<open>is_path \<pi>\<close> \<open>is_path \<pi>'\<close> using path path_is_path by auto
             
   have \<pi>0: \<open>\<pi>' 0 = \<pi> 0\<close> unfolding path path_def by auto
   have vread': \<open>v \<in> reads (path \<sigma>' k')\<close> using csk vread by (metis last_cs)
   have cseq: \<open>cs\<^bsup>\<pi>'\<^esup> k' = cs\<^bsup>\<pi>\<^esup> k\<close> using csk path by simp
   
   show \<open>((\<sigma>, k), \<sigma>', k') \<in> cp\<close> proof cases
     assume vnw: \<open>\<forall> l < k. v\<notin>writes (\<pi> l)\<close>
     hence \<sigma>v: \<open>(\<sigma>\<^bsup>k\<^esup>) v = \<sigma> v\<close> by (metis no_writes_unchanged0 path(1))
     show \<open>?thesis\<close> proof cases
       assume vnw': \<open>\<forall> l < k'. v\<notin>writes (\<pi>' l)\<close>
       hence \<sigma>v': \<open>(\<sigma>'\<^bsup>k'\<^esup>) v = \<sigma>' v\<close> by (metis no_writes_unchanged0 path(2))
       with \<sigma>v vneq have \<open>\<sigma> v \<noteq> \<sigma>' v\<close> by auto
       hence vhigh: \<open>v \<in> hvars\<close> using leq unfolding loweq_def restrict_def by (auto,metis)
       thus \<open>?thesis\<close> using cp.intros(1)[OF leq csk vread vneq] vnw vnw' path by simp
     next
       assume \<open>\<not>(\<forall> l < k'. v\<notin>writes (\<pi>' l))\<close>
       then obtain l' where kddl': \<open>k' dd\<^bsup>\<pi>',v\<^esup>\<rightarrow> l'\<close> using path(2) path_is_path written_read_dd vread' by blast
       hence lv': \<open>v \<in> writes (\<pi>' l')\<close> unfolding is_ddi_def by auto
       have lk': \<open>l' < k'\<close> by (metis is_ddi_def kddl')
       have nret: \<open>\<pi>' l' \<noteq> return\<close> using lv' writes_return by auto
       
       have notin\<pi>: \<open>\<not> (\<exists>l. cs\<^bsup>\<pi>'\<^esup> l' = cs\<^bsup>\<pi>\<^esup> l)\<close> proof
         assume \<open>\<exists>l. cs\<^bsup>\<pi>'\<^esup> l' = cs\<^bsup>\<pi>\<^esup> l\<close>
-        then guess l ..
+        then obtain l where "cs\<^bsup>\<pi>'\<^esup> l' = cs\<^bsup>\<pi>\<^esup> l" ..
         note csl = \<open>cs\<^bsup>\<pi>'\<^esup> l' = cs\<^bsup>\<pi>\<^esup> l\<close>
         have lk: \<open>l < k\<close> using lk' cseq ip cs_order[of \<open>\<pi>'\<close> \<open>\<pi>\<close> \<open>l'\<close> \<open>l\<close> \<open>k'\<close> \<open>k\<close>] csl nret path by force
                   
         have \<open>v \<in> writes (\<pi> l)\<close> using csl lv' last_cs by metis
         thus \<open>False\<close> using lk vnw by blast
       qed
 
       from converged_cd_diverge[OF ip(2,1) \<pi>0 notin\<pi> lk' cseq]
       obtain i i' where  csi: \<open>cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> i\<close> and lcdi: \<open>l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> i'\<close>  and div: \<open>\<pi>' (Suc i') \<noteq> \<pi> (Suc i)\<close> .
       
       have 1: \<open>\<pi> (Suc i) = suc (\<pi> i) (\<sigma>\<^bsup>i\<^esup>)\<close> by (metis step_suc_sem fst_conv path(1) path_suc)
       have 2: \<open>\<pi>' (Suc i') = suc (\<pi>' i') (\<sigma>'\<^bsup>i'\<^esup>)\<close> by (metis step_suc_sem fst_conv path(2) path_suc)
       have 3: \<open>\<pi>' i' = \<pi> i\<close> using csi last_cs by metis
       have nreads: \<open>\<sigma>\<^bsup>i\<^esup> \<restriction> reads (\<pi> i) \<noteq> \<sigma>'\<^bsup>i'\<^esup> \<restriction> reads (\<pi> i)\<close> by (metis 1 2 3 div reads_restr_suc)
       then obtain v' where v'read: \<open>v'\<in> reads(path \<sigma> i)\<close> \<open>(\<sigma>\<^bsup>i\<^esup>) v' \<noteq> (\<sigma>'\<^bsup>i'\<^esup>) v'\<close> unfolding path by (metis reads_restrict)
       
       have nreti: \<open>\<pi>' i' \<noteq> return\<close> by (metis csi div ip(1) ip(2) last_cs lessI term_path_stable less_imp_le)
       have ik': \<open>i' < k'\<close> using lcdi lk' is_cdi_def by auto            
       have ik: \<open>i < k\<close> using cs_order[OF ip(2,1) csi cseq nreti ik'] .
       
       have cpi: \<open>((\<sigma>, i), (\<sigma>', i')) \<in> cp\<close> using IH[of \<open>i\<close> \<open>i'\<close>] v'read csi ik ik' path by auto 
       hence cpi': \<open>((\<sigma>', i'), (\<sigma>, i)) \<in> cp\<close> using cp.intros(4) by blast
       
       have nwvi: \<open>\<forall>j'\<in>{LEAST i'. i < i' \<and> (\<exists>i. cs\<^bsup>path \<sigma>'\<^esup> i = cs\<^bsup>path \<sigma>\<^esup> i')..<k}. v \<notin> writes (path \<sigma> j')\<close> using vnw[unfolded path] 
         by (metis (poly_guards_query) atLeastLessThan_iff)
       
       from cp.intros(3)[OF cpi' kddl'[unfolded path] lcdi[unfolded path] csk[symmetric] div[unfolded path] vneq[symmetric] nwvi] 
       
       show \<open>?thesis\<close> using cp.intros(4) by simp 
     qed
   next
     assume wv: \<open>\<not> (\<forall> l<k. v \<notin> writes (\<pi> l))\<close> 
     then obtain l where kddl: \<open>k dd\<^bsup>\<pi>,v\<^esup>\<rightarrow> l\<close> using path(1) path_is_path written_read_dd vread by blast
     hence lv: \<open>v \<in> writes (\<pi> l)\<close> unfolding is_ddi_def by auto
     have lk: \<open>l < k\<close> by (metis is_ddi_def kddl)
     have nret: \<open>\<pi> l \<noteq> return\<close> using lv writes_return by auto
     have nwb: \<open>\<forall> i \<in> {Suc l..< k}. v\<notin>writes(\<pi> i)\<close> using kddl unfolding is_ddi_def by auto
     have \<sigma>vk: \<open>(\<sigma>\<^bsup>k\<^esup>) v = (\<sigma>\<^bsup>Suc l\<^esup> ) v\<close> using kddl ddi_value path(1) by auto
 
     show \<open>?thesis\<close> proof cases
       assume vnw': \<open>\<forall> l < k'. v\<notin>writes (\<pi>' l)\<close>
       hence \<sigma>v': \<open>(\<sigma>'\<^bsup>k'\<^esup>) v = \<sigma>' v\<close> by (metis no_writes_unchanged0 path(2))
 
       have notin\<pi>': \<open>\<not> (\<exists>l'. cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l')\<close> proof
         assume \<open>\<exists>l'. cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l'\<close>
-        then guess l' ..
+        then obtain l' where "cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l'" ..
         note csl = \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l'\<close>
         have lk: \<open>l' < k'\<close> using lk cseq ip cs_order[of \<open>\<pi>\<close> \<open>\<pi>'\<close> \<open>l\<close> \<open>l'\<close> \<open>k\<close> \<open>k'\<close>] csl nret by metis
                   
         have \<open>v \<in> writes (\<pi>' l')\<close> using csl lv last_cs by metis
         thus \<open>False\<close> using lk vnw' by blast
       qed
 
       from converged_cd_diverge[OF ip(1,2) \<pi>0[symmetric] notin\<pi>' lk cseq[symmetric]]
       obtain i i' where  csi: \<open>cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> i\<close> and lcdi: \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> i\<close>  and div: \<open>\<pi> (Suc i) \<noteq> \<pi>' (Suc i')\<close> by metis
       
       have 1: \<open>\<pi> (Suc i) = suc (\<pi> i) (\<sigma>\<^bsup>i\<^esup>)\<close> by (metis step_suc_sem fst_conv path(1) path_suc)
       have 2: \<open>\<pi>' (Suc i') = suc (\<pi>' i') (\<sigma>'\<^bsup>i'\<^esup>)\<close> by (metis step_suc_sem fst_conv path(2) path_suc)
       have 3: \<open>\<pi>' i' = \<pi> i\<close> using csi last_cs by metis
       have nreads: \<open>\<sigma>\<^bsup>i\<^esup> \<restriction> reads (\<pi> i) \<noteq> \<sigma>'\<^bsup>i'\<^esup> \<restriction> reads (\<pi> i)\<close> by (metis 1 2 3 div reads_restr_suc)
       have contri: \<open>(\<sigma>',i') \<cc> (\<sigma>,i)\<close> using contradicts.intros(2)[OF csi path nreads] .
       
       have nreti: \<open>\<pi> i \<noteq> return\<close> by (metis csi div ip(1) ip(2) last_cs lessI term_path_stable less_imp_le)
       have ik: \<open>i < k\<close> using lcdi lk is_cdi_def by auto            
       have ik': \<open>i' < k'\<close> using cs_order[OF ip(1,2) csi[symmetric] cseq[symmetric] nreti ik] .
       have nreads: \<open>\<sigma>\<^bsup>i\<^esup> \<restriction> reads (\<pi> i) \<noteq> \<sigma>'\<^bsup>i'\<^esup> \<restriction> reads (\<pi> i)\<close> by (metis 1 2 3 div reads_restr_suc)
       then obtain v' where v'read: \<open>v'\<in> reads(path \<sigma> i)\<close> \<open>(\<sigma>\<^bsup>i\<^esup>) v' \<noteq> (\<sigma>'\<^bsup>i'\<^esup>) v'\<close> unfolding path by (metis reads_restrict)
       
       
       have cpi: \<open>((\<sigma>, i), (\<sigma>', i')) \<in> cp\<close> using IH[of \<open>i\<close> \<open>i'\<close>] v'read csi ik ik' path by auto 
       hence cpi': \<open>((\<sigma>', i'), (\<sigma>, i)) \<in> cp\<close> using cp.intros(4) by blast
       
       have vnwi: \<open>\<forall>j'\<in>{LEAST i'a. i' < i'a \<and> (\<exists>i. cs\<^bsup>path \<sigma>\<^esup> i = cs\<^bsup>path \<sigma>'\<^esup> i'a)..<k'}. v \<notin> writes (path \<sigma>' j')\<close> using vnw'[unfolded path]
         by (metis (poly_guards_query) atLeastLessThan_iff)
         
       from cp.intros(3)[OF cpi kddl[unfolded path] lcdi[unfolded path] csk div[unfolded path] vneq vnwi]   
       
       show \<open>?thesis\<close> using cp.intros(4) by simp
     next
       assume \<open>\<not> (\<forall> l<k'. v \<notin> writes (\<pi>' l))\<close>
       then obtain l' where kddl': \<open>k' dd\<^bsup>\<pi>',v\<^esup>\<rightarrow> l'\<close> using path(2) path_is_path written_read_dd vread' by blast
       hence lv': \<open>v \<in> writes (\<pi>' l')\<close> unfolding is_ddi_def by auto
       have lk': \<open>l' < k'\<close> by (metis is_ddi_def kddl')            
       have nretl': \<open>\<pi>' l' \<noteq> return\<close> using lv' writes_return by auto
       have nwb': \<open>\<forall> i' \<in> {Suc l'..< k'}. v\<notin>writes(\<pi>' i')\<close> using kddl' unfolding is_ddi_def by auto
       have \<sigma>vk': \<open>(\<sigma>'\<^bsup>k'\<^esup>) v = (\<sigma>'\<^bsup>Suc l'\<^esup> ) v\<close> using kddl' ddi_value path(2) by auto
 
       show \<open>?thesis\<close> proof cases 
         assume csl: \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> l'\<close>
         hence \<pi>l: \<open>\<pi> l = \<pi>' l'\<close> by (metis last_cs)
         have \<sigma>vls: \<open>(\<sigma>\<^bsup>Suc l\<^esup> ) v \<noteq> (\<sigma>'\<^bsup>Suc l'\<^esup> ) v\<close> by (metis \<sigma>vk \<sigma>vk' vneq)
         have r\<sigma>: \<open>\<sigma>\<^bsup>l\<^esup> \<restriction> reads (\<pi> l) \<noteq> \<sigma>'\<^bsup>l'\<^esup> \<restriction> reads (\<pi> l)\<close> using path \<pi>l \<sigma>vls written_value lv by blast
         then obtain v' where v'read: \<open>v'\<in> reads(path \<sigma> l)\<close> \<open>(\<sigma>\<^bsup>l\<^esup>) v' \<noteq> (\<sigma>'\<^bsup>l'\<^esup>) v'\<close> unfolding path by (metis reads_restrict)
       
       
         have cpl: \<open>((\<sigma>, l), (\<sigma>', l')) \<in> cp\<close> using IH[of \<open>l\<close> \<open>l'\<close>] v'read csl lk lk' path by auto 
         show \<open>((\<sigma>, k), (\<sigma>', k')) \<in> cp\<close> using cp.intros(2)[OF cpl kddl[unfolded path] kddl'[unfolded path] csk vneq] .        
       next
         assume csl: \<open>cs\<^bsup>\<pi>\<^esup> l \<noteq> cs\<^bsup>\<pi>'\<^esup> l'\<close>
         show \<open>?thesis\<close> proof cases
           assume \<open>\<exists> i'. cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> i'\<close>
           then obtain i' where csli': \<open>cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> i'\<close> by blast
           have ilne': \<open>i' \<noteq> l'\<close> using csl csli' by auto
           have ij': \<open>i' < k'\<close> using cs_order[OF ip csli' cseq[symmetric] nret lk] .
           have iv': \<open>v \<in> writes(\<pi>' i')\<close> using lv csli' last_cs by metis
           have il': \<open>i' < l'\<close> using kddl' ilne' ij' iv' unfolding is_ddi_def by auto
           have nreti': \<open>\<pi>' i' \<noteq> return\<close> using csli' nret last_cs by metis
 
           have l'notin\<pi>: \<open>\<not>(\<exists>i. cs\<^bsup>\<pi>'\<^esup> l' = cs\<^bsup>\<pi>\<^esup> i )\<close> proof
             assume \<open>\<exists>i. cs\<^bsup>\<pi>'\<^esup> l' = cs\<^bsup>\<pi>\<^esup> i\<close>
             then obtain i where csil: \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> l'\<close> by metis
             have ik: \<open>i < k\<close> using cs_order[OF ip(2,1) csil[symmetric] cseq nretl' lk'] .
             have li: \<open>l < i\<close> using cs_order[OF ip(2,1) csli'[symmetric] csil[symmetric] nreti' il'] .
             have iv: \<open>v \<in> writes(\<pi> i)\<close> using lv' csil last_cs by metis
             show \<open>False\<close> using kddl ik li iv is_ddi_def by auto
           qed
           
           obtain n n' where csn: \<open>cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n'\<close> and lcdn': \<open>l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n'\<close>  and sucn: \<open>\<pi> (Suc n) \<noteq> \<pi>' (Suc n')\<close> and in': \<open>i' \<le> n'\<close>
           using converged_cd_diverge_cs [OF ip(2,1) csli'[symmetric] il' l'notin\<pi> lk' cseq] by metis 
           
           \<comment> \<open>Can apply the IH to n and n'\<close>
           
           have 1: \<open>\<pi> (Suc n) = suc (\<pi> n) (\<sigma>\<^bsup>n\<^esup>)\<close> by (metis step_suc_sem fst_conv path(1) path_suc)
           have 2: \<open>\<pi>' (Suc n') = suc (\<pi>' n') (\<sigma>'\<^bsup>n'\<^esup>)\<close> by (metis step_suc_sem fst_conv path(2) path_suc)
           have 3: \<open>\<pi>' n' = \<pi> n\<close> using csn last_cs by metis
           have nreads: \<open>\<sigma>\<^bsup>n\<^esup> \<restriction> reads (\<pi> n) \<noteq> \<sigma>'\<^bsup>n'\<^esup> \<restriction> reads (\<pi> n)\<close> by (metis 1 2 3 sucn reads_restr_suc)
           then obtain v' where v'read: \<open>v'\<in>reads (path \<sigma> n)\<close> \<open>(\<sigma>\<^bsup>n\<^esup>) v' \<noteq> (\<sigma>'\<^bsup>n'\<^esup>) v'\<close> by (metis path(1) reads_restrict)
           moreover
           have nl': \<open>n' < l'\<close> using lcdn' is_cdi_def by auto
           have nk': \<open>n' < k'\<close> using nl' lk' by simp
           have nretn': \<open>\<pi>' n' \<noteq> return\<close> by (metis ip(2) nl' nretl' term_path_stable less_imp_le)
           have nk: \<open>n < k\<close> using cs_order[OF ip(2,1) csn[symmetric] cseq nretn' nk'] .
           hence lenn: \<open>n+n' < k+k'\<close> using nk' by auto
           ultimately  
           have \<open>((\<sigma>, n), (\<sigma>', n')) \<in> cp\<close> using IH csn path by auto
           hence ncp: \<open>((\<sigma>', n'), (\<sigma>, n)) \<in> cp\<close> using cp.intros(4) by auto
           
           have nles: \<open>n < (LEAST i'. n < i' \<and> (\<exists>i. cs\<^bsup>\<pi>'\<^esup> i = cs\<^bsup>\<pi>\<^esup> i'))\<close> (is \<open>_ < (LEAST i. ?P i)\<close>) using nk cseq LeastI[of \<open>?P\<close> \<open>k\<close>] by metis
           moreover
           have ln: \<open>l \<le> n\<close> using cs_order_le[OF ip(2,1) csli'[symmetric] csn[symmetric] nreti' in'] .
           ultimately 
           have lles: \<open>Suc l \<le> (LEAST i'. n < i' \<and> (\<exists>i. cs\<^bsup>\<pi>'\<^esup> i = cs\<^bsup>\<pi>\<^esup> i'))\<close> by auto
           
           have nwcseq: \<open>\<forall>j'\<in>{LEAST i'. n < i' \<and> (\<exists>i. cs\<^bsup>\<pi>'\<^esup> i = cs\<^bsup>\<pi>\<^esup> i')..<k}. v \<notin> writes (\<pi> j')\<close> proof 
             fix j' assume *: \<open>j' \<in> {LEAST i'. n < i' \<and> (\<exists>i. cs\<^bsup>\<pi>'\<^esup> i = cs\<^bsup>\<pi>\<^esup> i')..<k}\<close>
             hence \<open>(LEAST i'. n < i' \<and> (\<exists>i. cs\<^bsup>\<pi>'\<^esup> i = cs\<^bsup>\<pi>\<^esup> i')) \<le> j'\<close> by (metis (poly_guards_query) atLeastLessThan_iff)
             hence \<open>Suc l \<le> j'\<close> using lles by auto
             moreover
             have \<open>j' < k\<close> using * by (metis (poly_guards_query) atLeastLessThan_iff) 
             ultimately have \<open>j'\<in> {Suc l..<k}\<close> by (metis (poly_guards_query) atLeastLessThan_iff)
             thus \<open>v\<notin>writes (\<pi> j')\<close> using nwb by auto
           qed
           
           from cp.intros(3)[OF ncp,folded path,OF kddl' lcdn' cseq sucn[symmetric] vneq[symmetric] nwcseq]
           have \<open>((\<sigma>', k'), \<sigma>, k) \<in> cp\<close> .
           thus \<open>((\<sigma>, k), (\<sigma>', k')) \<in> cp\<close> using cp.intros(4) by auto
         next
           assume lnotin\<pi>': \<open>\<not> (\<exists>i'. cs\<^bsup>\<pi>\<^esup> l = cs\<^bsup>\<pi>'\<^esup> i')\<close>
           show \<open>?thesis\<close> proof cases
             assume \<open>\<exists> i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> l'\<close>
             then obtain i where csli: \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> l'\<close> by blast
             have ilne: \<open>i \<noteq> l\<close> using csl csli by auto
             have ij: \<open>i < k\<close> using cs_order[OF ip(2,1) csli[symmetric] cseq nretl' lk'] .
             have iv: \<open>v \<in> writes(\<pi> i)\<close> using lv' csli last_cs by metis
             have il: \<open>i < l\<close> using kddl ilne ij iv unfolding is_ddi_def by auto
             have nreti: \<open>\<pi> i \<noteq> return\<close> using csli nretl' last_cs by metis
 
             obtain n n' where csn: \<open>cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n'\<close> and lcdn: \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close>  and sucn: \<open>\<pi> (Suc n) \<noteq> \<pi>' (Suc n')\<close> and ilen: \<open>i \<le> n\<close>
             using converged_cd_diverge_cs [OF ip csli il lnotin\<pi>' lk cseq[symmetric]] by metis 
           
             \<comment> \<open>Can apply the IH to n and n'\<close>
           
             have 1: \<open>\<pi> (Suc n) = suc (\<pi> n) (\<sigma>\<^bsup>n\<^esup>)\<close> by (metis step_suc_sem fst_conv path(1) path_suc)
             have 2: \<open>\<pi>' (Suc n') = suc (\<pi>' n') (\<sigma>'\<^bsup>n'\<^esup>)\<close> by (metis step_suc_sem fst_conv path(2) path_suc)
             have 3: \<open>\<pi>' n' = \<pi> n\<close> using csn last_cs by metis
             have nreads: \<open>\<sigma>\<^bsup>n\<^esup> \<restriction> reads (\<pi> n) \<noteq> \<sigma>'\<^bsup>n'\<^esup> \<restriction> reads (\<pi> n)\<close> by (metis 1 2 3 sucn reads_restr_suc)
             then obtain v' where v'read: \<open>v'\<in>reads (path \<sigma> n)\<close> \<open>(\<sigma>\<^bsup>n\<^esup>) v' \<noteq> (\<sigma>'\<^bsup>n'\<^esup>) v'\<close> by (metis path(1) reads_restrict)
             moreover  
             have nl: \<open>n < l\<close> using lcdn is_cdi_def by auto
             have nk: \<open>n < k\<close> using nl lk by simp
             have nretn: \<open>\<pi> n \<noteq> return\<close> by (metis ip(1) nl nret term_path_stable less_imp_le)
             have nk': \<open>n' < k'\<close> using cs_order[OF ip csn cseq[symmetric] nretn nk] .
             hence lenn: \<open>n+n' < k+k'\<close> using nk by auto
             ultimately  
             have ncp: \<open>((\<sigma>, n), (\<sigma>', n')) \<in> cp\<close> using IH csn path by auto
             
             have nles': \<open>n' < (LEAST i'. n' < i' \<and> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'))\<close> (is \<open>_ < (LEAST i. ?P i)\<close>) using nk' cseq LeastI[of \<open>?P\<close> \<open>k'\<close>] by metis
             moreover
             have ln': \<open>l' \<le> n'\<close> using cs_order_le[OF ip csli csn nreti ilen] .
             ultimately 
             have lles': \<open>Suc l' \<le> (LEAST i'. n' < i' \<and> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'))\<close> by auto
           
             have nwcseq': \<open>\<forall>j'\<in>{(LEAST i'. n' < i' \<and> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'))..<k'}. v \<notin> writes (\<pi>' j')\<close> proof 
               fix j' assume *: \<open>j' \<in> {(LEAST i'. n' < i' \<and> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'))..<k'}\<close>
               hence \<open>(LEAST i'. n' < i' \<and> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i')) \<le> j'\<close> by (metis (poly_guards_query) atLeastLessThan_iff)
               hence \<open>Suc l' \<le> j'\<close> using lles' by auto
               moreover
               have \<open>j' < k'\<close> using * by (metis (poly_guards_query) atLeastLessThan_iff) 
               ultimately have \<open>j'\<in> {Suc l'..<k'}\<close> by (metis (poly_guards_query) atLeastLessThan_iff)
               thus \<open>v\<notin>writes (\<pi>' j')\<close> using nwb' by auto
               qed
             
             from cp.intros(3)[OF ncp,folded path, OF kddl lcdn cseq[symmetric] sucn vneq nwcseq']
             
             show \<open>((\<sigma>, k), (\<sigma>', k')) \<in> cp\<close> .
           next
             assume l'notin\<pi>: \<open>\<not> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> l')\<close>
             define m where \<open>m \<equiv> 0::nat\<close>
             define m' where \<open>m' \<equiv> 0::nat\<close>
             have csm: \<open>cs\<^bsup>\<pi>\<^esup> m = cs\<^bsup>\<pi>'\<^esup> m'\<close> unfolding m_def m'_def cs_0 by (metis \<pi>0)
             have ml: \<open>m<l \<or> m'<l'\<close> using csm csl unfolding m_def m'_def by (metis neq0_conv)
             have \<open>\<exists> n n'. cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n' \<and> \<pi> (Suc n) \<noteq> \<pi>' (Suc n') \<and> 
             (l cd\<^bsup>\<pi>\<^esup>\<rightarrow> n \<and> (\<forall>j'\<in>{(LEAST i'. n' < i' \<and> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'))..<k'}. v\<notin>writes (\<pi>' j'))
             \<or> l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n' \<and> (\<forall>j\<in>{(LEAST i. n < i \<and> (\<exists>i'. cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> i))..<k}. v\<notin>writes (\<pi> j)))\<close>
             using csm ml proof (induction \<open>k+k'-(m+m')\<close> arbitrary: \<open>m\<close> \<open>m'\<close> rule: less_induct)
               case (less m m')
               note csm = \<open>cs\<^bsup>\<pi>\<^esup> m = cs\<^bsup>\<pi>'\<^esup> m'\<close>
               note lm = \<open>m < l \<or> m' < l'\<close>
               note IH = \<open>\<And> n n'. 
                 k + k' - (n + n') < k + k' - (m + m') \<Longrightarrow>
                 cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n' \<Longrightarrow>
                 n < l \<or> n' < l' \<Longrightarrow> ?thesis\<close>
               show \<open>?thesis\<close> using lm proof
                 assume ml: \<open>m < l\<close>
                 obtain n n' where mn: \<open>m \<le> n\<close> and csn: \<open> cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n'\<close> and lcdn: \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close> and suc: \<open>\<pi> (Suc n) \<noteq> \<pi>' (Suc n')\<close>
                   using  converged_cd_diverge_cs[OF ip csm ml lnotin\<pi>' lk cseq[symmetric]] .
                 have nl: \<open>n < l\<close> using lcdn is_cdi_def by auto
                 hence nk: \<open>n<k\<close> using lk by auto
                 have nretn: \<open>\<pi> n \<noteq> return\<close> using lcdn by (metis cd_not_ret)
                 have nk': \<open>n'<k'\<close> using cs_order[OF ip csn cseq[symmetric] nretn nk] .
                 show \<open>?thesis\<close> proof cases
                   assume \<open>\<forall>j'\<in>{(LEAST i'. n' < i' \<and> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'))..<k'}. v\<notin>writes (\<pi>' j')\<close>
                   thus \<open>?thesis\<close> using lcdn csn suc by blast
                 next
                   assume \<open>\<not>(\<forall>j'\<in>{(LEAST i'. n' < i' \<and> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'))..<k'}. v\<notin>writes (\<pi>' j'))\<close>
                   then obtain j' where jin': \<open>j'\<in>{(LEAST i'. n' < i' \<and> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'))..<k'}\<close> and vwrite: \<open>v\<in>writes (\<pi>' j')\<close> by blast
                   define i' where \<open>i' \<equiv> LEAST i'. n' < i' \<and> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i')\<close>
                   have Pk': \<open>n' < k' \<and> (\<exists> k. cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k')\<close> (is \<open>?P k'\<close>) using nk' cseq[symmetric] by blast
                   have ni': \<open>n' < i'\<close> using LeastI[of \<open>?P\<close>, OF Pk'] i'_def by auto
                   obtain i where csi: \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'\<close> using LeastI[of \<open>?P\<close>, OF Pk'] i'_def by blast
                   have ij': \<open>i'\<le>j'\<close> using jin'[folded i'_def] by auto
                   have jk': \<open>j'<k'\<close> using jin'[folded i'_def] by auto
                   have jl': \<open>j' \<le> l'\<close> using kddl' jk' vwrite unfolding is_ddi_def by auto
                   have nretn': \<open>\<pi>' n' \<noteq> return\<close> using nretn csn last_cs by metis
                   have iln: \<open>n<i\<close> using cs_order[OF ip(2,1) csn[symmetric] csi[symmetric] nretn' ni'] .
                   hence mi: \<open>m < i\<close> using mn by auto
                   have nretm: \<open>\<pi> m \<noteq> return\<close> by (metis ip(1) mn nretn term_path_stable)
                   have mi': \<open>m'<i'\<close> using cs_order[OF ip csm csi nretm mi] .
                   have ik': \<open>i' < k'\<close> using ij' jk' by auto
                   have nreti': \<open>\<pi>' i' \<noteq> return\<close> by (metis ij' jl' nretl' ip(2) term_path_stable)
                   have ik: \<open>i < k\<close> using cs_order[OF ip(2,1) csi[symmetric] cseq nreti' ik'] .
                   show \<open>?thesis\<close> proof cases
                     assume il:\<open>i < l\<close>
                     have le: \<open>k + k' - (i +i') < k+k' - (m+m')\<close> using mi mi' ik ik' by auto
                     show \<open>?thesis\<close> using IH[OF le] using csi il by blast
                   next
                     assume \<open>\<not> i < l\<close>
                     hence li: \<open>l \<le> i\<close> by auto
                     have \<open>i' \<le> l'\<close> using ij' jl' by auto
                     hence il': \<open>i' < l'\<close> using  csi l'notin\<pi> by fastforce 
                     obtain n n' where in': \<open>i' \<le> n'\<close> and csn: \<open> cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n'\<close> and lcdn': \<open>l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n'\<close> and suc: \<open>\<pi> (Suc n) \<noteq> \<pi>' (Suc n')\<close>
                       using  converged_cd_diverge_cs[OF ip(2,1) csi[symmetric] il' _ lk' cseq] l'notin\<pi> by metis
                     have nk': \<open>n' < k'\<close> using lcdn' is_cdi_def lk' by auto
                     have nretn': \<open>\<pi>' n' \<noteq> return\<close> by (metis cd_not_ret lcdn')
                     have nk: \<open>n < k\<close> using cs_order[OF ip(2,1) csn[symmetric] cseq nretn' nk'] . 
                     define j where \<open>j \<equiv> LEAST j. n < j \<and> (\<exists>j'. cs\<^bsup>\<pi>'\<^esup> j' = cs\<^bsup>\<pi>\<^esup> j)\<close>
                     have Pk: \<open>n < k \<and> (\<exists>j'. cs\<^bsup>\<pi>'\<^esup> j' = cs\<^bsup>\<pi>\<^esup> k)\<close> (is \<open>?P k\<close>) using nk cseq by blast
                     have nj: \<open>n<j\<close> using LeastI[of \<open>?P\<close>, OF Pk] j_def by auto
                     have ilen: \<open>i \<le> n\<close> using cs_order_le[OF ip(2,1) csi[symmetric] csn[symmetric] nreti' in'] . 
                     hence lj: \<open>l<j\<close> using li nj by simp
                     have \<open>\<forall>l\<in>{l<..<k}. v \<notin> writes (\<pi> l)\<close> using  kddl unfolding is_ddi_def by simp
                     hence nw: \<open>\<forall>l\<in>{j..<k}. v \<notin> writes (\<pi> l)\<close> using lj by auto
                     show \<open>?thesis\<close> using csn lcdn' suc nw[unfolded j_def] by blast
                   qed
                 qed
               next
                 assume ml': \<open>m' < l'\<close>
                 obtain n n' where mn': \<open>m' \<le> n'\<close> and csn: \<open> cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n'\<close> and lcdn': \<open>l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n'\<close> and suc: \<open>\<pi> (Suc n) \<noteq> \<pi>' (Suc n')\<close>
                   using  converged_cd_diverge_cs[OF ip(2,1) csm[symmetric] ml' _ lk' cseq] l'notin\<pi> by metis
                 have nl': \<open>n' < l'\<close> using lcdn' is_cdi_def by auto
                 hence nk': \<open>n'<k'\<close> using lk' by auto
                 have nretn': \<open>\<pi>' n' \<noteq> return\<close> using lcdn' by (metis cd_not_ret)
                 have nk: \<open>n<k\<close> using cs_order[OF ip(2,1) csn[symmetric] cseq nretn' nk'] .
                 show \<open>?thesis\<close> proof cases
                   assume \<open>\<forall>j\<in>{(LEAST i. n < i \<and> (\<exists>i'. cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> i))..<k}. v\<notin>writes (\<pi> j)\<close>
                   thus \<open>?thesis\<close> using lcdn' csn suc by blast
                 next
                   assume \<open>\<not>(\<forall>j\<in>{(LEAST i. n < i \<and> (\<exists>i'. cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> i))..<k}. v\<notin>writes (\<pi> j))\<close>
                   then obtain j where jin: \<open>j\<in>{(LEAST i. n < i \<and> (\<exists>i'. cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> i))..<k}\<close> and vwrite: \<open>v\<in>writes (\<pi> j)\<close> by blast
                   define i where \<open>i \<equiv> LEAST i. n < i \<and> (\<exists>i'. cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> i)\<close>
                   have Pk: \<open>n < k \<and> (\<exists> k'. cs\<^bsup>\<pi>'\<^esup> k' = cs\<^bsup>\<pi>\<^esup> k)\<close> (is \<open>?P k\<close>) using nk cseq by blast
                   have ni: \<open>n < i\<close> using LeastI[of \<open>?P\<close>, OF Pk] i_def by auto
                   obtain i' where csi: \<open>cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'\<close> using LeastI[of \<open>?P\<close>, OF Pk] i_def by metis
                   have ij: \<open>i\<le>j\<close> using jin[folded i_def] by auto
                   have jk: \<open>j<k\<close> using jin[folded i_def] by auto
                   have jl: \<open>j \<le> l\<close> using kddl jk vwrite unfolding is_ddi_def by auto
                   have nretn: \<open>\<pi> n \<noteq> return\<close> using nretn' csn last_cs by metis
                   have iln': \<open>n'<i'\<close> using cs_order[OF ip csn csi nretn ni] .
                   hence mi': \<open>m' < i'\<close> using mn' by auto
                   have nretm': \<open>\<pi>' m' \<noteq> return\<close> by (metis ip(2) mn' nretn' term_path_stable)
                   have mi: \<open>m<i\<close> using cs_order[OF ip(2,1) csm[symmetric] csi[symmetric] nretm' mi'] .
                   have ik: \<open>i < k\<close> using ij jk by auto
                   have nreti: \<open>\<pi> i \<noteq> return\<close> by (metis ij ip(1) jl nret term_path_stable)
                   have ik': \<open>i' < k'\<close> using cs_order[OF ip csi cseq[symmetric] nreti ik] .
                   show \<open>?thesis\<close> proof cases
                     assume il':\<open>i' < l'\<close>
                     have le: \<open>k + k' - (i +i') < k+k' - (m+m')\<close> using mi mi' ik ik' by auto
                     show \<open>?thesis\<close> using IH[OF le] using csi il' by blast
                   next
                     assume \<open>\<not> i' < l'\<close>
                     hence li': \<open>l' \<le> i'\<close> by auto
                     have \<open>i \<le> l\<close> using ij jl by auto
                     hence il: \<open>i < l\<close> using  csi lnotin\<pi>' by fastforce 
                     obtain n n' where ilen: \<open>i \<le> n\<close> and csn: \<open> cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n'\<close> and lcdn: \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close> and suc: \<open>\<pi> (Suc n) \<noteq> \<pi>' (Suc n')\<close>
                       using  converged_cd_diverge_cs[OF ip csi il _ lk cseq[symmetric]] lnotin\<pi>' by metis
                     have nk: \<open>n < k\<close> using lcdn is_cdi_def lk by auto
                     have nretn: \<open>\<pi> n \<noteq> return\<close> by (metis cd_not_ret lcdn)
                     have nk': \<open>n' < k'\<close> using cs_order[OF ip csn cseq[symmetric] nretn nk] . 
                     define j' where \<open>j' \<equiv> LEAST j'. n' < j' \<and> (\<exists>j. cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> j')\<close>
                     have Pk': \<open>n' < k' \<and> (\<exists>j. cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> k')\<close> (is \<open>?P k'\<close>) using nk' cseq[symmetric] by blast
                     have nj': \<open>n'<j'\<close> using LeastI[of \<open>?P\<close>, OF Pk'] j'_def by auto
                     have in': \<open>i' \<le> n'\<close> using cs_order_le[OF ip csi csn nreti ilen] . 
                     hence lj': \<open>l'<j'\<close> using li' nj' by simp
                     have \<open>\<forall>l\<in>{l'<..<k'}. v \<notin> writes (\<pi>' l)\<close> using  kddl' unfolding is_ddi_def by simp
                     hence nw': \<open>\<forall>l\<in>{j'..<k'}. v \<notin> writes (\<pi>' l)\<close> using lj' by auto
                     show \<open>?thesis\<close> using csn lcdn suc nw'[unfolded j'_def] by blast
                   qed
                 qed
               qed
             qed
             then obtain n n' where csn: \<open> cs\<^bsup>\<pi>\<^esup> n = cs\<^bsup>\<pi>'\<^esup> n'\<close> and suc: \<open>\<pi> (Suc n) \<noteq> \<pi>' (Suc n')\<close>
             and cdor: 
             \<open>(l cd\<^bsup>\<pi>\<^esup>\<rightarrow> n \<and> (\<forall>j'\<in>{(LEAST i'. n' < i' \<and> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i'))..<k'}. v\<notin>writes (\<pi>' j'))
             \<or> l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n' \<and> (\<forall>j\<in>{(LEAST i. n < i \<and> (\<exists>i'. cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> i))..<k}. v\<notin>writes (\<pi> j)))\<close> 
             by blast
             show \<open>?thesis\<close> using cdor proof
               assume *: \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> n \<and> (\<forall>j'\<in>{LEAST i'. n' < i' \<and> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i')..<k'}. v \<notin> local.writes (\<pi>' j'))\<close>
               hence lcdn: \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close> by blast 
               have nowrite: \<open>\<forall>j'\<in>{LEAST i'. n' < i' \<and> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i')..<k'}. v \<notin> local.writes (\<pi>' j')\<close> using * by blast
               show \<open>?thesis\<close> proof (rule cp.intros(3)[of \<open>\<sigma>\<close> \<open>n\<close> \<open>\<sigma>'\<close> \<open>n'\<close>,folded path])
                 show \<open>l cd\<^bsup>\<pi>\<^esup>\<rightarrow> n\<close> using lcdn .
                 show \<open>k dd\<^bsup>\<pi>,v\<^esup>\<rightarrow> l\<close> using kddl .
                 show \<open>cs\<^bsup>\<pi>\<^esup> k = cs\<^bsup>\<pi>'\<^esup> k'\<close> using cseq by simp
                 show \<open>\<pi> (Suc n) \<noteq> \<pi>' (Suc n')\<close> using suc by simp
                 show \<open>\<forall>j'\<in>{LEAST i'. n' < i' \<and> (\<exists>i. cs\<^bsup>\<pi>\<^esup> i = cs\<^bsup>\<pi>'\<^esup> i')..<k'}. v \<notin> local.writes (\<pi>' j')\<close> using nowrite .
                 show \<open>(\<sigma>\<^bsup>k\<^esup>) v \<noteq> (\<sigma>'\<^bsup>k'\<^esup>) v\<close> using vneq .
                 have nk: \<open>n < k\<close> using lcdn lk is_cdi_def by auto
                 have nretn: \<open>\<pi> n \<noteq> return\<close> using cd_not_ret lcdn by metis
                 have nk': \<open>n' < k'\<close> using cs_order[OF ip csn cseq[symmetric] nretn nk] .
                 hence le: \<open>n + n' < k + k'\<close> using nk by auto
                 moreover
                 have 1: \<open>\<pi> (Suc n) = suc (\<pi> n) (\<sigma>\<^bsup>n\<^esup>)\<close> by (metis step_suc_sem fst_conv path(1) path_suc)
                 have 2: \<open>\<pi>' (Suc n') = suc (\<pi>' n') (\<sigma>'\<^bsup>n'\<^esup>)\<close> by (metis step_suc_sem fst_conv path(2) path_suc)
                 have 3: \<open>\<pi>' n' = \<pi> n\<close> using csn last_cs by metis
                 have nreads: \<open>\<sigma>\<^bsup>n\<^esup> \<restriction> reads (\<pi> n) \<noteq> \<sigma>'\<^bsup>n'\<^esup> \<restriction> reads (\<pi> n)\<close> by (metis 1 2 3 suc reads_restr_suc)
                 then obtain v' where v'read: \<open>v'\<in>reads (path \<sigma> n)\<close> \<open>(\<sigma>\<^bsup>n\<^esup>) v' \<noteq> (\<sigma>'\<^bsup>n'\<^esup>) v'\<close> by (metis path(1) reads_restrict)
                 ultimately  
                 show \<open>((\<sigma>, n), (\<sigma>', n')) \<in> cp\<close> using IH csn path by auto
               qed
             next
               assume *: \<open>l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n' \<and> (\<forall>j\<in>{(LEAST i. n < i \<and> (\<exists>i'. cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> i))..<k}. v\<notin>writes (\<pi> j))\<close>
               hence lcdn': \<open>l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n'\<close> by blast 
               have nowrite: \<open>\<forall>j\<in>{(LEAST i. n < i \<and> (\<exists>i'. cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> i))..<k}. v\<notin>writes (\<pi> j)\<close> using * by blast
               show \<open>?thesis\<close> proof (rule cp.intros(4), rule cp.intros(3)[of \<open>\<sigma>'\<close> \<open>n'\<close> \<open>\<sigma>\<close> \<open>n\<close>,folded path])
                 show \<open>l' cd\<^bsup>\<pi>'\<^esup>\<rightarrow> n'\<close> using lcdn' .
                 show \<open>k' dd\<^bsup>\<pi>',v\<^esup>\<rightarrow> l'\<close> using kddl' .
                 show \<open>cs\<^bsup>\<pi>'\<^esup> k' = cs\<^bsup>\<pi>\<^esup> k\<close> using cseq .
                 show \<open>\<pi>' (Suc n') \<noteq> \<pi> (Suc n)\<close> using suc by simp
                 show \<open>\<forall>j\<in>{(LEAST i. n < i \<and> (\<exists>i'. cs\<^bsup>\<pi>'\<^esup> i' = cs\<^bsup>\<pi>\<^esup> i))..<k}. v\<notin>writes (\<pi> j)\<close> using nowrite .
                 show \<open>(\<sigma>'\<^bsup>k'\<^esup>) v \<noteq> (\<sigma>\<^bsup>k\<^esup>) v\<close> using vneq by simp
                 have nk': \<open>n' < k'\<close> using lcdn' lk' is_cdi_def by auto
                 have nretn': \<open>\<pi>' n' \<noteq> return\<close> using cd_not_ret lcdn' by metis
                 have nk: \<open>n < k\<close> using cs_order[OF ip(2,1) csn[symmetric] cseq nretn' nk'] .
                 hence le: \<open>n + n' < k + k'\<close> using nk' by auto
                 moreover
                 have 1: \<open>\<pi> (Suc n) = suc (\<pi> n) (\<sigma>\<^bsup>n\<^esup>)\<close> by (metis step_suc_sem fst_conv path(1) path_suc)
                 have 2: \<open>\<pi>' (Suc n') = suc (\<pi>' n') (\<sigma>'\<^bsup>n'\<^esup>)\<close> by (metis step_suc_sem fst_conv path(2) path_suc)
                 have 3: \<open>\<pi>' n' = \<pi> n\<close> using csn last_cs by metis
                 have nreads: \<open>\<sigma>\<^bsup>n\<^esup> \<restriction> reads (\<pi> n) \<noteq> \<sigma>'\<^bsup>n'\<^esup> \<restriction> reads (\<pi> n)\<close> by (metis 1 2 3 suc reads_restr_suc)
                 then obtain v' where v'read: \<open>v'\<in>reads (path \<sigma> n)\<close> \<open>(\<sigma>\<^bsup>n\<^esup>) v' \<noteq> (\<sigma>'\<^bsup>n'\<^esup>) v'\<close> by (metis path(1) reads_restrict)
                 ultimately  
                 have \<open>((\<sigma>, n), (\<sigma>', n')) \<in> cp\<close> using IH csn path by auto
                 thus \<open>((\<sigma>', n'), \<sigma>, n) \<in> cp\<close> using cp.intros(4) by simp                
               qed
             qed
           qed
         qed
       qed
     qed
   qed
 qed
 
 
 theorem contradicting_in_cop: assumes \<open>\<sigma> =\<^sub>L \<sigma>'\<close> and \<open>(\<sigma>',k') \<cc> (\<sigma>,k)\<close> and \<open>path \<sigma> k \<in> dom att\<close> 
 shows \<open>((\<sigma>,k),\<sigma>',k') \<in> cop\<close> using assms(2) proof(cases) 
   case (1 \<pi>' \<pi>) 
   define j where \<open>j \<equiv> \<pi> \<exclamdown> cs\<^bsup>\<pi>'\<^esup> k'\<close>
   have csj: \<open>cs\<^bsup>\<pi>\<^esup> j = cs\<^bsup>\<pi>'\<^esup> k'\<close> unfolding j_def using 1 by (metis cs_not_nil cs_select_is_cs(1) path_is_path)
   have suc: \<open>\<pi> (Suc j) \<noteq> \<pi>' (Suc k')\<close> using 1 j_def by simp
   have kcdj: \<open>k cd\<^bsup>\<pi>\<^esup>\<rightarrow> j\<close> by (metis cs_not_nil cs_select_is_cs(2) 1(1,2) j_def path_is_path)
   obtain v where readv: \<open>v\<in>reads(path \<sigma> j)\<close> and vneq: \<open>(\<sigma>\<^bsup>j\<^esup>) v \<noteq> (\<sigma>'\<^bsup>k'\<^esup>) v\<close> using suc csj unfolding 1 by (metis IFC_def.suc_def 1(2) 1(3) last_cs path_suc reads_restr_suc reads_restrict)
   have \<open>((\<sigma>,j),\<sigma>',k') \<in> cp\<close> apply (rule contradicting_in_cp[OF assms(1)]) using readv vneq csj 1 by auto
   thus \<open>((\<sigma>,k),\<sigma>',k') \<in> cop\<close> using kcdj suc assms(3) cop.intros(2) unfolding 1 by auto
   next
   case (2 \<pi>' \<pi>)
   obtain v where readv: \<open>v\<in>reads(path \<sigma> k)\<close> and vneq: \<open>(\<sigma>\<^bsup>k\<^esup>) v \<noteq> (\<sigma>'\<^bsup>k'\<^esup>) v\<close> using 2(2-4) by (metis reads_restrict)
   have \<open>((\<sigma>,k),\<sigma>',k') \<in> cp\<close> apply (rule contradicting_in_cp[OF assms(1)]) using readv vneq 2 by auto
   thus \<open>((\<sigma>,k),\<sigma>',k') \<in> cop\<close> using assms(3) cop.intros(1) unfolding 2 by auto
 qed
 
 
 theorem cop_correct_term: fixes \<sigma> \<sigma>' defines \<pi>: \<open>\<pi> \<equiv> path \<sigma>\<close> and \<pi>': \<open>\<pi>' \<equiv> path \<sigma>'\<close> 
 assumes ret: \<open>\<pi> n = return\<close> \<open>\<pi>' n' = return\<close> and obsne: \<open>obs \<sigma> \<noteq> obs \<sigma>'\<close> and leq: \<open>\<sigma> =\<^sub>L \<sigma>'\<close>
 shows \<open>\<exists> k k'. ((\<sigma>,k),\<sigma>',k')\<in> cop \<or> ((\<sigma>',k'),\<sigma>,k)\<in> cop\<close>
 proof -
   have *: \<open>\<exists> k k'. ((\<sigma>', k') \<cc> (\<sigma> ,k) \<and> \<pi> k \<in> dom (att)) \<or> ((\<sigma>, k) \<cc> (\<sigma>' ,k') \<and> \<pi>' k' \<in> dom (att))\<close> using  obs_neq_contradicts_term ret obsne \<pi> \<pi>' by auto
   have leq' :\<open>\<sigma>' =\<^sub>L \<sigma>\<close> using leq unfolding loweq_def by auto
   from * contradicting_in_cop[OF leq] contradicting_in_cop[OF leq'] show \<open>?thesis\<close> unfolding \<pi> \<pi>' by metis
 qed
 
 
 theorem cop_correct_ret: fixes \<sigma> \<sigma>' defines \<pi>: \<open>\<pi> \<equiv> path \<sigma>\<close> and \<pi>': \<open>\<pi>' \<equiv> path \<sigma>'\<close> 
 assumes ret: \<open>\<pi> n = return\<close> and obsne: \<open>obs \<sigma> i \<noteq> obs \<sigma>' i\<close> and obs: \<open>obs \<sigma>' i \<noteq> None\<close> and leq: \<open>\<sigma> =\<^sub>L \<sigma>'\<close>
 shows \<open>\<exists> k k'. ((\<sigma>,k),\<sigma>',k')\<in> cop \<or> ((\<sigma>',k'),\<sigma>,k)\<in> cop\<close>
 proof -
   have *: \<open>\<exists> k k'. ((\<sigma>', k') \<cc> (\<sigma> ,k) \<and> \<pi> k \<in> dom (att)) \<or> ((\<sigma>, k) \<cc> (\<sigma>' ,k') \<and> \<pi>' k' \<in> dom (att))\<close>
     by (metis (no_types, lifting) \<pi> \<pi>' obs obs_neq_ret_contradicts obsne ret) 
   have leq' :\<open>\<sigma>' =\<^sub>L \<sigma>\<close> using leq unfolding loweq_def by auto
   from * contradicting_in_cop[OF leq] contradicting_in_cop[OF leq'] show \<open>?thesis\<close> unfolding \<pi> \<pi>' by metis
 qed
 
 
 theorem cop_correct_nterm: assumes obsne: \<open>obs \<sigma> k \<noteq> obs \<sigma>' k\<close> \<open>obs \<sigma> k \<noteq> None\<close> \<open>obs \<sigma>' k \<noteq> None\<close> 
 and leq: \<open>\<sigma> =\<^sub>L \<sigma>'\<close>
 shows \<open>\<exists> k k'. ((\<sigma>,k),\<sigma>',k')\<in> cop \<or> ((\<sigma>',k'),\<sigma>,k)\<in> cop\<close>
 proof -
   obtain k k' where \<open>((\<sigma>', k') \<cc> (\<sigma> ,k) \<and> path \<sigma> k \<in> dom att) \<or> ((\<sigma>, k) \<cc> (\<sigma>' ,k') \<and> path \<sigma>' k' \<in> dom att)\<close> 
   using obs_neq_some_contradicts[OF obsne] by metis
   thus \<open>?thesis\<close> proof
     assume *: \<open>(\<sigma>', k') \<cc> (\<sigma> ,k) \<and> path \<sigma> k \<in> dom att\<close>
     hence \<open>((\<sigma>,k),\<sigma>',k') \<in> cop\<close> using leq by (metis contradicting_in_cop)
     thus \<open>?thesis\<close> using * by blast
   next 
     assume *: \<open>(\<sigma>, k) \<cc> (\<sigma>' ,k') \<and> path \<sigma>' k' \<in> dom att\<close>
     hence \<open>((\<sigma>',k'),\<sigma>,k) \<in> cop\<close> using leq by (metis contradicting_in_cop loweq_def)
     thus \<open>?thesis\<close> using * by blast
   qed
 qed
 
 
 subsection \<open>Correctness of the Characterisation\<close>
 text_raw \<open>\label{sec:cor-cp}\<close>
 
 text \<open>The following is our main correctness result. If there exist no critical observable paths,
 then the program is secure.\<close>
 
 theorem cop_correct: assumes \<open>cop = empty\<close> shows \<open>secure\<close> proof (rule ccontr)
   assume \<open>\<not> secure\<close>
   then obtain \<sigma> \<sigma>' where leq: \<open> \<sigma> =\<^sub>L \<sigma>'\<close> 
     and **: \<open>\<not> obs \<sigma> \<approx> obs \<sigma>' \<or> (terminates \<sigma> \<and> \<not> obs \<sigma>' \<lesssim> obs \<sigma>)\<close>
     unfolding secure_def by blast
   show \<open>False\<close> using ** proof
     assume \<open>\<not> obs \<sigma> \<approx> obs \<sigma>'\<close>
     then obtain k where \<open>obs \<sigma> k \<noteq> obs \<sigma>' k \<and> obs \<sigma> k \<noteq> None \<and> obs \<sigma>' k \<noteq> None\<close> 
       unfolding obs_comp_def obs_prefix_def
       by (metis kth_obs_stable linorder_neqE_nat obs_none_no_kth_obs obs_some_kth_obs) 
     thus \<open>False\<close> using cop_correct_nterm leq assms by auto
   next
     assume *: \<open>terminates \<sigma> \<and> \<not> obs \<sigma>' \<lesssim> obs \<sigma>\<close>
     then obtain n where ret: \<open>path \<sigma> n = return\<close>  
       unfolding terminates_def by auto
     obtain k where \<open>obs \<sigma> k \<noteq> obs \<sigma>' k \<and> obs \<sigma>' k \<noteq> None\<close> using * unfolding obs_prefix_def by metis 
     thus \<open>False\<close> using cop_correct_ret ret leq assms by (metis empty_iff) 
   qed
 qed
 
 
 text \<open>Our characterisation is not only correct, it is also precise in the way that \<open>cp\<close> characterises 
 exactly the matching indices in executions for low equivalent input states where diverging data is read. 
 This follows easily as the inverse implication to lemma \<open>contradicting_in_cp\<close> can be shown by simple induction.\<close>
 
 theorem cp_iff_reads_contradict: \<open>((\<sigma>,k),(\<sigma>',k')) \<in> cp \<longleftrightarrow> \<sigma> =\<^sub>L \<sigma>' \<and> cs\<^bsup>path \<sigma>\<^esup> k = cs\<^bsup>path \<sigma>'\<^esup> k' \<and> (\<exists> v\<in>reads(path \<sigma> k). (\<sigma>\<^bsup>k\<^esup>) v \<noteq> (\<sigma>'\<^bsup>k'\<^esup>) v)\<close> 
 proof
   assume \<open>\<sigma> =\<^sub>L \<sigma>' \<and> cs\<^bsup>path \<sigma>\<^esup> k = cs\<^bsup>path \<sigma>'\<^esup> k' \<and> (\<exists>v\<in>reads (path \<sigma> k). (\<sigma>\<^bsup>k\<^esup>) v \<noteq> (\<sigma>'\<^bsup>k'\<^esup>) v)\<close>
   thus \<open>((\<sigma>, k), \<sigma>', k') \<in> cp\<close> using contradicting_in_cp by blast 
 next
   assume \<open>((\<sigma>, k), \<sigma>', k') \<in> cp\<close> 
   thus \<open>\<sigma> =\<^sub>L \<sigma>' \<and> cs\<^bsup>path \<sigma>\<^esup> k = cs\<^bsup>path \<sigma>'\<^esup> k' \<and> (\<exists>v\<in>reads (path \<sigma> k). (\<sigma>\<^bsup>k\<^esup>) v \<noteq> (\<sigma>'\<^bsup>k'\<^esup>) v)\<close>
   proof (induction)
     case (1 \<sigma> \<sigma>' n n' h)
     then show \<open>?case\<close> by blast 
   next
     case (2 \<sigma> k \<sigma>' k' n v n')
     have \<open>v\<in>reads (path \<sigma> n)\<close> using 2(2) unfolding is_ddi_def by auto
     then show \<open>?case\<close> using 2 by auto
   next
     case (3 \<sigma> k \<sigma>' k' n v l n')
     have \<open>v\<in>reads (path \<sigma> n)\<close> using 3(2) unfolding is_ddi_def by auto
     then show \<open>?case\<close> using 3(4,6,8) by auto
   next
     case (4 \<sigma> k \<sigma>' k')
     hence \<open>cs\<^bsup>path \<sigma>\<^esup> k = cs\<^bsup>path \<sigma>'\<^esup> k'\<close> by simp
     hence \<open>path \<sigma>' k' = path \<sigma> k\<close> by (metis last_cs) 
     moreover have \<open>\<sigma>' =\<^sub>L \<sigma>\<close> using 4(2) unfolding loweq_def by simp
     ultimately show \<open>?case\<close> using 4 by metis
   qed
 qed
 
 
 text \<open>In the same way the inverse implication to \<open>contradicting_in_cop\<close> follows easily 
 such that we obtain the following characterisation of \<open>cop\<close>.\<close>
 
 theorem cop_iff_contradicting: \<open>((\<sigma>,k),(\<sigma>',k')) \<in> cop \<longleftrightarrow> \<sigma> =\<^sub>L \<sigma>' \<and> (\<sigma>',k') \<cc> (\<sigma>,k) \<and> path \<sigma> k \<in> dom att\<close> 
 proof
   assume \<open>\<sigma> =\<^sub>L \<sigma>' \<and> (\<sigma>', k') \<cc> (\<sigma>, k) \<and> path \<sigma> k \<in> dom att\<close> thus \<open>((\<sigma>,k),(\<sigma>',k')) \<in> cop\<close> using contradicting_in_cop by simp
 next
   assume \<open>((\<sigma>,k),(\<sigma>',k')) \<in> cop\<close> 
   thus \<open> \<sigma> =\<^sub>L \<sigma>' \<and> (\<sigma>',k') \<cc> (\<sigma>,k) \<and> path \<sigma> k \<in> dom att\<close> proof (cases rule: cop.cases)
     case 1
     then show \<open>?thesis\<close> using cp_iff_reads_contradict contradicts.simps by (metis (full_types) reads_restrict1)
   next
     case (2 k)
     then show \<open>?thesis\<close> using cp_iff_reads_contradict contradicts.simps
       by (metis cd_is_cs_less cd_not_ret contradicts.intros(1) cs_select_id path_is_path) 
   qed
 qed
 
 
 subsection \<open>Correctness of the Single Path Approximation\<close>
 text_raw \<open>\label{sec:cor-scp}\<close>
 
 theorem cp_in_scp: assumes \<open>((\<sigma>,k),(\<sigma>',k'))\<in>cp\<close> shows \<open>(path \<sigma>,k)\<in>scp \<and> (path \<sigma>',k')\<in>scp\<close> 
 using assms proof(induction \<open>\<sigma>\<close> \<open>k\<close> \<open>\<sigma>'\<close> \<open>k'\<close> rule:cp.induct[case_names read_high dd dcd sym])
   case (read_high \<sigma> \<sigma>' k k' h) 
   have \<open>\<sigma> h = (\<sigma>\<^bsup>k\<^esup>) h\<close> using read_high(5) by (simp add: no_writes_unchanged0)
   moreover have \<open>\<sigma>' h = (\<sigma>'\<^bsup>k'\<^esup>) h\<close> using read_high(6) by (simp add: no_writes_unchanged0)
   ultimately have \<open>\<sigma> h \<noteq> \<sigma>' h\<close> using read_high(4) by simp 
   hence *: \<open>h\<in>hvars\<close> using read_high(1) unfolding loweq_def by (metis Compl_iff IFC_def.restrict_def)
   have 1: \<open>(path \<sigma>,k)\<in>scp\<close> using scp.intros(1) read_high(3,5) * by auto
   have \<open>path \<sigma> k = path \<sigma>' k'\<close> using read_high(2) by (metis last_cs)
   hence \<open>(path \<sigma>',k')\<in>scp\<close> using scp.intros(1) read_high(3,6) * by auto
   thus \<open>?case\<close> using 1 by auto
 next
   case dd show \<open>?case\<close> using scp.intros(3) dd by auto  
 next 
   case sym thus \<open>?case\<close> by blast
 next
   case (dcd \<sigma> k \<sigma>' k' n v l n')   
   note scp.intros(4) is_dcdi_via_def cd_cs_swap cs_ipd
   have 1: \<open>(path \<sigma>, n)\<in>scp\<close> using dcd.IH dcd.hyps(2) dcd.hyps(3) scp.intros(2) scp.intros(3) by blast 
   have csk: \<open>cs\<^bsup>path \<sigma>\<^esup> k = cs\<^bsup>path \<sigma>'\<^esup> k'\<close> using cp_eq_cs[OF dcd(1)] .
   have kn: \<open>k<n\<close> and kl: \<open>k<l\<close> and ln: \<open>l<n\<close> using dcd(2,3) unfolding is_ddi_def is_cdi_def by auto
   have nret: \<open>path \<sigma> k \<noteq> return\<close> using cd_not_ret dcd.hyps(3) by auto
   have \<open>k' < n'\<close> using kn csk dcd(4) cs_order nret path_is_path last_cs by blast
   have 2: \<open>(path \<sigma>', n')\<in>scp\<close> proof cases    
     assume j'ex: \<open>\<exists>j'\<in>{k'..<n'}. v \<in> writes (path \<sigma>' j')\<close>
     hence \<open>\<exists>j'. j'\<in>{k'..<n'} \<and> v \<in> writes (path \<sigma>' j')\<close> by auto
     note * = GreatestI_ex_nat[OF this]
     define j' where \<open>j' == GREATEST j'. j'\<in>{k'..<n'} \<and> v \<in> writes (path \<sigma>' j')\<close>
     note ** = *[of \<open>j'\<close>,folded j'_def]  
     have \<open>k' \<le> j'\<close> \<open>j'<n'\<close> and j'write: \<open>v \<in> writes (path \<sigma>' j')\<close>
       using "*" atLeastLessThan_iff j'_def nat_less_le by auto
     have nowrite: \<open>\<forall> i'\<in>{j'<..<n'}. v \<notin> writes(path \<sigma>' i')\<close> proof (rule, rule ccontr)
       fix i' assume \<open>i' \<in> {j'<..<n'}\<close> \<open>\<not> v \<notin> local.writes (path \<sigma>' i')\<close>
       hence \<open>i' \<in> {k'..<n'} \<and> v \<in> local.writes (path \<sigma>' i')\<close> using \<open>k' \<le> j'\<close> by auto
       hence \<open>i' \<le> j'\<close> using Greatest_le_nat
         by (metis (no_types, lifting) atLeastLessThan_iff j'_def nat_less_le)
       thus \<open>False\<close> using \<open>i' \<in> {j'<..<n'}\<close> by auto
     qed
     have \<open>path \<sigma>' n' = path \<sigma> n\<close> using dcd(4) last_cs by metis
     hence \<open>v\<in>reads(path \<sigma>' n')\<close> using dcd(2) unfolding is_ddi_def by auto    
     hence nddj': \<open>n' dd\<^bsup>path \<sigma>',v\<^esup>\<rightarrow> j'\<close> using dcd(2) unfolding is_ddi_def using nowrite \<open>j'<n'\<close> j'write by auto 
     show \<open>?thesis\<close> proof cases
       assume \<open>j' cd\<^bsup>path \<sigma>'\<^esup>\<rightarrow> k'\<close>
       thus \<open>(path \<sigma>',n') \<in> scp\<close> using scp.intros(2) scp.intros(3) dcd.IH nddj' by fast
     next
       assume jcdk': \<open>\<not> j' cd\<^bsup>path \<sigma>'\<^esup>\<rightarrow> k'\<close>
       show \<open>?thesis\<close> proof cases
         assume \<open>j' = k'\<close>
         thus \<open>?thesis\<close> using scp.intros(3) dcd.IH nddj' by fastforce 
       next
         assume \<open>j' \<noteq> k'\<close> hence \<open>k' < j'\<close> using \<open>k' \<le> j'\<close> by auto
         have \<open>path \<sigma>' j' \<noteq> return\<close> using j'write writes_return by auto
         hence ipdex':\<open>\<exists>j. j \<in>{k'..j'} \<and> path \<sigma>' j = ipd (path \<sigma>' k') \<close> using path_is_path \<open>k' < j'\<close> jcdk' is_cdi_def by blast
         define i' where \<open>i' == LEAST j. j\<in> {k'..j'} \<and> path \<sigma>' j = ipd (path \<sigma>' k')\<close>        
         have iipd': \<open>i'\<in> {k'..j'}\<close> \<open>path \<sigma>' i' = ipd (path \<sigma>' k')\<close> unfolding i'_def using LeastI_ex[OF ipdex'] by simp_all
         have *:\<open>\<forall> i \<in> {k'..<i'}. path \<sigma>' i \<noteq> ipd (path \<sigma>' k')\<close> proof (rule, rule ccontr)
           fix i assume  *: \<open>i \<in> {k'..<i'}\<close> \<open>\<not> path \<sigma>' i \<noteq> ipd (path \<sigma>' k')\<close>
           hence **: \<open>i \<in>{k'..j'} \<and> path \<sigma>' i = ipd (path \<sigma>' k')\<close> (is \<open>?P i\<close>) using iipd'(1) by auto
           thus \<open>False\<close> using Least_le[of \<open>?P\<close> \<open>i\<close>] i'_def * by auto
         qed
         have \<open>i' \<noteq> k'\<close> using iipd'(2) by (metis csk last_cs nret path_in_nodes ipd_not_self)
         hence \<open>k'<i'\<close> using iipd'(1) by simp
         hence csi': \<open>cs\<^bsup>path \<sigma>'\<^esup> i' = [n\<leftarrow>cs\<^bsup>path \<sigma>'\<^esup> k' . ipd n \<noteq> path \<sigma>' i'] @ [path \<sigma>' i']\<close>using cs_ipd[OF iipd'(2) *] by fast 
         
         have ncdk': \<open>\<not> n' cd\<^bsup>path \<sigma>'\<^esup>\<rightarrow> k'\<close> using \<open>j' < n'\<close> \<open>k' < j'\<close> cdi_prefix jcdk' less_imp_le_nat by blast
         hence ncdk: \<open>\<not> n cd\<^bsup>path \<sigma>\<^esup>\<rightarrow> k\<close> using cd_cs_swap csk dcd(4) by blast        
         have ipdex: \<open>\<exists>i. i\<in>{k..n} \<and> path \<sigma> i = ipd (path \<sigma> k)\<close> (is \<open>\<exists>i. ?P i\<close>) proof cases
           assume *:\<open>path \<sigma> n = return\<close> 
           from path_ret_ipd[of \<open>path \<sigma>\<close> \<open>k\<close> \<open>n\<close>,OF path_is_path nret *]          
           obtain i where \<open>?P i\<close> by fastforce thus \<open>?thesis\<close> by auto
         next
           assume *:\<open>path \<sigma> n \<noteq> return\<close>           
           show \<open>?thesis\<close> using not_cd_impl_ipd [of \<open>path \<sigma>\<close> \<open>k\<close> \<open>n\<close>, OF path_is_path \<open>k<n\<close> ncdk *] by auto
         qed
         
         define i where  \<open>i == LEAST j. j\<in> {k..n} \<and> path \<sigma> j = ipd (path \<sigma> k)\<close>        
         have iipd: \<open>i\<in> {k..n}\<close> \<open>path \<sigma> i = ipd (path \<sigma> k)\<close> unfolding i_def using LeastI_ex[OF ipdex] by simp_all
         have **:\<open>\<forall> i' \<in> {k..<i}. path \<sigma> i' \<noteq> ipd (path \<sigma> k)\<close> proof (rule, rule ccontr)
           fix i' assume  *: \<open>i' \<in> {k..<i}\<close> \<open>\<not> path \<sigma> i' \<noteq> ipd (path \<sigma> k)\<close>
           hence **: \<open>i' \<in>{k..n} \<and> path \<sigma> i' = ipd (path \<sigma> k)\<close> (is \<open>?P i'\<close>) using iipd(1) by auto
           thus \<open>False\<close> using Least_le[of \<open>?P\<close> \<open>i'\<close>] i_def * by auto
         qed
         have \<open>i \<noteq> k\<close> using iipd(2) by (metis nret path_in_nodes ipd_not_self)
         hence \<open>k<i\<close> using iipd(1) by simp
         hence \<open>cs\<^bsup>path \<sigma>\<^esup> i = [n\<leftarrow>cs\<^bsup>path \<sigma>\<^esup> k . ipd n \<noteq> path \<sigma> i] @ [path \<sigma> i]\<close>using cs_ipd[OF iipd(2) **] by fast 
         hence csi: \<open>cs\<^bsup>path \<sigma>\<^esup> i = cs\<^bsup>path \<sigma>'\<^esup> i'\<close> using csi' csk unfolding iipd'(2) iipd(2) by (metis last_cs)
         hence \<open>(LEAST i'. k' < i' \<and> (\<exists>i. cs\<^bsup>path \<sigma>\<^esup> i = cs\<^bsup>path \<sigma>'\<^esup> i')) \<le> i'\<close> (is \<open>(LEAST x. ?P x) \<le> _\<close>) 
           using \<open>k' < i'\<close> Least_le[of \<open>?P\<close> \<open>i'\<close>] by blast
         hence nw: \<open>\<forall>j'\<in>{i'..<n'}. v \<notin> writes (path \<sigma>' j')\<close> using dcd(7) allB_atLeastLessThan_lower by blast  
         moreover have \<open>v \<in> writes (path \<sigma>' j')\<close> using nddj' unfolding is_ddi_def by auto
         moreover have \<open>i' \<le> j'\<close> using iipd'(1) by auto
         ultimately have \<open>False\<close>  using \<open>j' < n'\<close> by auto
         thus \<open>?thesis\<close> ..
       qed
     qed
   next
     assume \<open>\<not> (\<exists>j'\<in>{k'..<n'}. v \<in> writes (path \<sigma>' j'))\<close>
     
     hence \<open>n' dcd\<^bsup>path \<sigma>',v\<^esup>\<rightarrow> k' via (path \<sigma>) k\<close> unfolding is_dcdi_via_def using dcd(2-4) csk \<open>k'<n'\<close> path_is_path by metis    
     thus \<open>?thesis\<close> using dcd.IH scp.intros(4) by blast 
   qed
   with 1 show \<open>?case\<close> ..
 qed   
 
 
 theorem cop_in_scop: assumes \<open>((\<sigma>,k),(\<sigma>',k'))\<in>cop\<close> shows \<open>(path \<sigma>,k)\<in>scop \<and> (path \<sigma>',k')\<in>scp\<close>
   using assms 
   apply (induct rule: cop.induct)
    apply (simp add: cp_in_scp)
   using cp_in_scp scop.intros scp.intros(2)
    apply blast
   using cp_in_scp scop.intros scp.intros(2)
   apply blast
   done
 
 text \<open>The main correctness result for out single execution approximation follows directly.\<close>
 
 theorem scop_correct: assumes \<open>scop = empty\<close> shows \<open>secure\<close> 
   using cop_correct assms cop_in_scop by fast 
 
 end
 
 end
\ No newline at end of file
diff --git a/thys/IMP2/doc/Examples.thy b/thys/IMP2/doc/Examples.thy
--- a/thys/IMP2/doc/Examples.thy
+++ b/thys/IMP2/doc/Examples.thy
@@ -1,1872 +1,1873 @@
 theory Examples
 imports "../IMP2" "../lib/IMP2_Aux_Lemmas"
 begin
 
 section \<open>Examples\<close>  
 lemmas nat_distribs = nat_add_distrib nat_diff_distrib Suc_diff_le nat_mult_distrib nat_div_distrib
 
 subsection \<open>Common Loop Patterns\<close>
 
 subsubsection \<open>Count Up\<close>
 text \<open>
   Counter \<open>c\<close> counts from \<open>0\<close> to \<open>n\<close>, such that loop is executed \<open>n\<close> times. 
   The result is computed in an accumulator \<open>a\<close>.
 \<close>
 text \<open>The invariant states that we have computed the function for the counter value \<open>c\<close>\<close>  
 text \<open>The variant is the difference between \<open>n\<close> and \<open>c\<close>, i.e., the number of 
   loop iterations that we still have to do\<close>  
 
 
 program_spec exp_count_up
   assumes "0\<le>n"
   ensures "a = 2^nat n\<^sub>0"
   defines \<open>
     a = 1;
     c = 0;
     while (c<n) 
       @variant \<open>n-c\<close> 
       @invariant \<open>0\<le>c \<and> c\<le>n \<and> a=2^nat c\<close>
     {
       G_par = a;   scope { a = G_par; a=2*a; G_ret = a }; a = G_ret;
       c=c+1
     }
   \<close>
   apply vcg
   by (auto simp: algebra_simps nat_distribs)
 
 program_spec sum_prog
   assumes "n \<ge> 0" ensures "s = \<Sum>{0..n\<^sub>0}"
   defines \<open>
     s = 0;
     i = 0;
     while (i < n)
       @variant \<open>n\<^sub>0 - i\<close>
       @invariant \<open>n\<^sub>0 = n \<and> 0 \<le> i \<and> i \<le> n \<and> s = \<Sum>{0..i}\<close>
     {
       i = i + 1;
       s = s + i
     }
   \<close>
   apply vcg_cs
   by (simp_all add: intvs_incdec)
   
 program_spec sq_prog
   assumes "n \<ge> 0" ensures "a = n\<^sub>0 * n\<^sub>0"
   defines \<open>
     a = 0;
     z = 1;
     i = 0;
     while (i < n)
       @variant \<open>n\<^sub>0 - i\<close>
       @invariant \<open>n\<^sub>0 = n \<and> 0 \<le> i \<and> i \<le> n \<and> a = i * i \<and> z = 2 * i + 1\<close>
     {
       a = a + z;
       z = z + 2;
       i = i + 1
     }
   \<close>
   by vcg_cs (simp add: algebra_simps)
   
 fun factorial :: "int \<Rightarrow> int" where
   "factorial i = (if i \<le> 0 then 1 else i * factorial (i - 1))"
   
 program_spec factorial_prog
   assumes "n \<ge> 0" ensures "a = factorial n\<^sub>0"
   defines \<open>
     a = 1;
     i = 1;
     while (i \<le> n)
       @variant \<open>n\<^sub>0 + 1 - i\<close>
       @invariant \<open>n\<^sub>0 = n \<and> 1 \<le> i \<and> i \<le> n + 1 \<and> a = factorial (i - 1)\<close>
     {
       a = a * i;
       i = i + 1
     }
   \<close>
   by vcg (simp add: antisym_conv)+
 
   
 fun fib :: "int \<Rightarrow> int" where
   "fib i = (if i \<le> 0 then 0 else if i = 1 then 1 else fib (i - 2) + fib (i - 1))"
 
 lemma fib_simps[simp]:
   "i \<le> 0 \<Longrightarrow> fib i = 0"
   "i = 1 \<Longrightarrow> fib i = 1"
   "i > 1 \<Longrightarrow> fib i = fib (i - 2) + fib (i - 1)"
   by simp+
 
 lemmas [simp del] = fib.simps
 
 text \<open>With precondition\<close>
 program_spec fib_prog
   assumes "n \<ge> 0" ensures "a = fib n"
   defines \<open>
     a = 0; b = 1;
     i = 0;
     while (i < n) 
       @variant \<open>n\<^sub>0 - i\<close>
       @invariant \<open>n = n\<^sub>0 \<and> 0 \<le> i \<and> i \<le> n \<and> a = fib i \<and> b = fib (i + 1)\<close>    
     {
       c = b;
       b = a + b;
       a = c;
       i = i + 1
     }
   \<close>
   by vcg_cs (simp add: algebra_simps)
 
 text \<open>Without precondition, returning \<open>0\<close> for negative numbers\<close>
 program_spec fib_prog'
   assumes True ensures "a = fib n\<^sub>0"
   defines \<open>
     a = 0; b = 1;
     i = 0;
     while (i < n) 
       @variant \<open>n\<^sub>0 - i\<close>
       @invariant \<open>n = n\<^sub>0 \<and> (0 \<le> i \<and> i \<le> n \<or> n\<^sub>0 < 0 \<and> i = 0) \<and> a = fib i \<and> b = fib (i+ 1)\<close>    
     {
       c = b;
       b = a + b;
       a = c;
       i = i + 1
     }
   \<close>
   by vcg_cs (auto simp: algebra_simps)
 
 
 
 subsubsection \<open>Count down\<close>  
 text \<open>Essentially the same as count up, but we (ab)use the input variable as a counter.\<close>
   
 text \<open>The invariant is the same as for count-up. 
   Only that we have to compute the actual number
   of loop iterations by \<open>n\<^sub>0 - n\<close>. We locally introduce the name \<open>c\<close> for that.
 \<close>  
   
 
 program_spec exp_count_down
   assumes "0\<le>n"
   ensures "a = 2^nat n\<^sub>0"
   defines \<open>
     a = 1;
     while (n>0) 
       @variant \<open>n\<close> 
       @invariant \<open>let c = n\<^sub>0-n in 0\<le>n \<and> n\<le>n\<^sub>0 \<and> a=2^nat c\<close>    
     {
       a=2*a;
       n=n-1
     }
   \<close>
   apply vcg_cs
   by (auto simp: algebra_simps nat_distribs)
 
   
 subsubsection \<open>Approximate from Below\<close>
 text \<open>Used to invert a monotonic function. 
   We count up, until we overshoot the desired result, 
   then we subtract one. 
 \<close>  
 text \<open>The invariant states that the \<open>r-1\<close> is not too big.
   When the loop terminates, \<open>r-1\<close> is not too big, but \<open>r\<close> is already too big,
   so \<open>r-1\<close> is the desired value (rounding down).
 \<close>
 text \<open>The variant measures the gap that we have to the correct result.
   Note that the loop will do a final iteration, when the result has been reached 
   exactly. We account for that by adding one, such that the measure also decreases in this case.
 \<close>
 
 program_spec sqr_approx_below
   assumes "0\<le>n"  
   ensures "0\<le>r \<and> r\<^sup>2 \<le> n\<^sub>0 \<and> n\<^sub>0 < (r+1)\<^sup>2"
   defines \<open>
     r=1;
     while (r*r \<le> n)
       @variant \<open>n + 1 - r*r\<close> 
       @invariant \<open>0\<le>r \<and> (r-1)\<^sup>2 \<le> n\<^sub>0\<close>    
       { r = r + 1 };
     r = r - 1
   \<close>
   apply vcg
   by (auto simp: algebra_simps power2_eq_square)
 
 
 subsubsection \<open>Bisection\<close>
 text \<open>A more efficient way of inverting monotonic functions is by bisection,
   that is, one keeps track of a possible interval for the solution, and halfs the 
   interval in each step. The program will need $O(\log n)$ iterations, and is
   thus very efficient in practice.
 
   Although the final algorithm looks quite simple, getting it right can be
   quite tricky.
 \<close>
 text \<open>The invariant is surprisingly easy, just stating that the solution 
   is in the interval \<open>l..<h\<close>. \<close>  
 
 lemma "\<And>h l n\<^sub>0 :: int.
        \<lbrakk>\<paragraph>''invar-final''; 0 \<le> n\<^sub>0; \<not> 1 + l < h; 0 \<le> l; l < h; l * l \<le> n\<^sub>0;
         n\<^sub>0 < h * h\<rbrakk>
        \<Longrightarrow> n\<^sub>0 < 1 + (l * l + l * 2)"  
   by (smt mult.commute semiring_normalization_rules(3))
 
 program_spec sqr_bisect
   assumes "0\<le>n" ensures "r\<^sup>2\<le>n\<^sub>0 \<and> n\<^sub>0<(r+1)\<^sup>2"
   defines \<open>
     l=0; h=n+1;
     while (l+1 < h) 
       @variant \<open>h-l\<close>
       @invariant \<open>0\<le>l \<and> l<h \<and> l\<^sup>2\<le>n \<and> n < h\<^sup>2\<close>    
     {
       m = (l + h) / 2;
       if (m*m \<le> n) l=m else h=m
     };
     r=l
   \<close>
   apply vcg
   text \<open>We use quick-and-dirty apply style proof to discharge the VCs\<close>
         apply (auto simp: power2_eq_square algebra_simps add_pos_pos)
    apply (smt not_sum_squares_lt_zero)
   by (smt mult.commute semiring_normalization_rules(3))
 
   
   
 subsection \<open>Debugging\<close>
 
 subsubsection \<open>Testing Programs\<close>
 
 text \<open>Stepwise\<close>
 schematic_goal "Map.empty: (sqr_approx_below,<''n'':=\<lambda>_. 4>) \<Rightarrow> ?s"
   unfolding sqr_approx_below_def
   apply big_step'
    apply big_step'
   apply big_step'
    apply big_step'
     apply big_step'
    apply big_step'
     apply big_step'
    apply big_step'
   apply big_step'
   done
 
 text \<open>Or all steps at once\<close>
 schematic_goal "Map.empty: (sqr_bisect,<''n'':=\<lambda>_. 4900000001>) \<Rightarrow> ?s"
   unfolding sqr_bisect_def
   by big_step
   
   
 subsection \<open>More Numeric Algorithms\<close>  
 
 subsubsection \<open>Euclid's Algorithm (with subtraction)\<close>
 
 (* Crucial Lemmas *)
 thm gcd.commute gcd_diff1
 
 program_spec euclid1
   assumes "a>0 \<and> b>0"
   ensures "a = gcd a\<^sub>0 b\<^sub>0"
   defines \<open>
     while (a\<noteq>b) 
       @invariant \<open>gcd a b = gcd a\<^sub>0 b\<^sub>0 \<and> (a>0 \<and> b>0)\<close>
       @variant \<open>a+b\<close>
     {
       if (a<b) b = b-a
       else a = a-b
     }
   \<close>
   apply vcg_cs
    apply (metis gcd.commute gcd_diff1)
   apply (metis gcd_diff1)
   done
 
 
 subsubsection \<open>Euclid's Algorithm (with mod)\<close>
 
 (* Crucial Lemmas *)
 thm gcd_red_int[symmetric]
 
 program_spec euclid2
   assumes "a>0 \<and> b>0"
   ensures "a = gcd a\<^sub>0 b\<^sub>0"
   defines \<open>
     while (b\<noteq>0) 
       @invariant \<open>gcd a b = gcd a\<^sub>0 b\<^sub>0 \<and> b\<ge>0 \<and> a>0\<close>
       @variant \<open>b\<close>
     {
       t = a;
       a = b;
       b = t mod b
     }
   \<close>
   apply vcg_cs
   by (simp add: gcd_red_int[symmetric])
   
 subsubsection \<open>Extended Euclid's Algorithm\<close>
 (* Provided by Simon Wimmer. *)
 
 locale extended_euclid_aux_lemmas begin
 
 lemma aux2:
   fixes a b :: int
   assumes "b = t * b\<^sub>0 + s * a\<^sub>0" "q = a div b" "gcd a b = gcd a\<^sub>0 b\<^sub>0"
   shows "gcd b (a - (a\<^sub>0 * (s * q) + b\<^sub>0 * (t * q))) = gcd a\<^sub>0 b\<^sub>0"
 proof -
   have "a - (a\<^sub>0 * (s * q) + b\<^sub>0 * (t * q)) = a - b * q"
     unfolding \<open>b = _\<close> by (simp add: algebra_simps)
   also have "a - b * q = a mod b"
     unfolding \<open>q = _\<close> by (simp add: algebra_simps)
   finally show ?thesis
     unfolding \<open>gcd a b = _\<close>[symmetric] by (simp add: gcd_red_int[symmetric])
 qed
 
 lemma aux3:
   fixes a b :: int
   assumes "b = t * b\<^sub>0 + s * a\<^sub>0" "q = a div b" "b > 0"
   shows "t * (b\<^sub>0 * q) + s * (a\<^sub>0 * q) \<le> a"
 proof -
   have "t * (b\<^sub>0 * q) + s * (a\<^sub>0 * q) = q * b"
     unfolding \<open>b = _\<close> by (simp add: algebra_simps)
   then show ?thesis
     using \<open>b > 0\<close>
     by (simp add: algebra_simps \<open>q = _\<close>)
        (smt Euclidean_Division.pos_mod_sign cancel_div_mod_rules(1) mult.commute)
 qed
 
 end
 
 
 text \<open>The following is a direct translation of the pseudocode for the Extended Euclidean algorithm
 as described by the English version of Wikipedia
 (\<^url>\<open>https://en.wikipedia.org/wiki/Extended_Euclidean_algorithm\<close>):
 \<close>
 program_spec euclid_extended
   assumes "a>0 \<and> b>0"
   ensures "old_r = gcd a\<^sub>0 b\<^sub>0 \<and> gcd a\<^sub>0 b\<^sub>0 = a\<^sub>0 * old_s + b\<^sub>0 * old_t"
 defines \<open>
     s = 0;    old_s = 1;
     t = 1;    old_t = 0;
     r = b;    old_r = a;
     while (r\<noteq>0) 
       @invariant \<open>
         gcd old_r r = gcd a\<^sub>0 b\<^sub>0 \<and> r\<ge>0 \<and> old_r>0
       \<and> a\<^sub>0 * old_s + b\<^sub>0 * old_t = old_r \<and> a\<^sub>0 * s + b\<^sub>0 * t = r
       \<close>
       @variant \<open>r\<close>
     {
       quotient = old_r / r;
       temp = old_r;
       old_r = r;
       r = temp - quotient * r;
       temp = old_s;
       old_s = s;
       s = temp - quotient * s;
       temp = old_t;
       old_t = t;
       t = temp - quotient * t
     }
   \<close>
 proof -
   interpret extended_euclid_aux_lemmas .
   show ?thesis
     apply vcg_cs
      apply (simp add: algebra_simps)
      apply (simp add: aux2 aux3 minus_div_mult_eq_mod)+
     done  
     
 qed
 
 
 text \<open>Non-Wikipedia version\<close>
 context extended_euclid_aux_lemmas begin
   lemma aux:
     fixes a b q x y:: int
     assumes "a = old_y * b\<^sub>0 + old_x * a\<^sub>0" "b = y * b\<^sub>0 + x * a\<^sub>0" "q = a div b"
     shows
     "a mod b + (a\<^sub>0 * (x * q) + b\<^sub>0 * (y * q)) = a"
   proof -
     have *: "a\<^sub>0 * (x * q) + b\<^sub>0 * (y * q) = q * b"
       unfolding \<open>b = _\<close> by (simp add: algebra_simps)
     show ?thesis
       unfolding * unfolding \<open>q = _\<close> by simp
   qed
 end
 
 program_spec euclid_extended'
   assumes "a>0 \<and> b>0"
   ensures "a = gcd a\<^sub>0 b\<^sub>0 \<and> gcd a\<^sub>0 b\<^sub>0 = a\<^sub>0 * x + b\<^sub>0 * y"
 defines \<open>
     x = 0;
     y = 1;
     old_x = 1;
     old_y = 0;
     while (b\<noteq>0) 
       @invariant \<open>
         gcd a b = gcd a\<^sub>0 b\<^sub>0 \<and> b\<ge>0 \<and> a>0 \<and> a = a\<^sub>0 * old_x + b\<^sub>0 * old_y \<and> b = a\<^sub>0 * x + b\<^sub>0 * y
       \<close>
       @variant \<open>b\<close>
     {
       q = a / b;
       t = a;
       a = b;
       b = t mod b;
       t = x;
       x = old_x - q * x;
       old_x = t;
       t = y;
       y = old_y - q * y;
       old_y = t
     };
     x = old_x;
     y = old_y
   \<close>
 proof -
   interpret extended_euclid_aux_lemmas .
   show ?thesis
     apply vcg_cs
     apply (simp add: gcd_red_int[symmetric])
     apply (simp add: algebra_simps)
     apply (rule aux; simp add: algebra_simps)
     done
 qed
   
 subsubsection \<open>Exponentiation by Squaring\<close>
 (* Contributed by Simon Wimmer *)
 
 lemma ex_by_sq_aux:
   fixes x :: int and n :: nat
   assumes "n mod 2 = 1"
   shows "x * (x * x) ^ (n div 2) = x ^ n"
 proof -
   have "n > 0"
     using assms by presburger
   have "2 * (n div 2) = n - 1"
     using assms by presburger
   then have "(x * x) ^ (n div 2) = x ^ (n - 1)"
     by (simp add: semiring_normalization_rules)
   with \<open>0 < n\<close> show ?thesis
     by simp (metis Suc_pred power.simps(2))
 qed
 
 text \<open>A classic algorithm for computing \<open>x\<^sup>n\<close> works by repeated squaring,
 using the following recurrence:
   \<^item> \<open>x\<^sup>n = x * x\<^bsup>(n-1)/2\<^esup>\<close> if \<open>n\<close> is odd
   \<^item> \<open>x\<^sup>n = x\<^bsup>n/2\<^esup>\<close> if \<open>n\<close> is even
 
 \<close>
 program_spec ex_by_sq
   assumes "n\<ge>0"
   ensures "r = x\<^sub>0 ^ nat n\<^sub>0"
 defines \<open>
     r = 1;
     while (n\<noteq>0) 
       @invariant \<open>
         n \<ge> 0 \<and> r * x ^ nat n = x\<^sub>0 ^ nat n\<^sub>0
       \<close>
       @variant \<open>n\<close>
     {
       if (n mod 2 == 1) {
         r = r * x
       };
       x = x * x;
       n = n / 2
     }
   \<close>
   apply vcg_cs
   subgoal
     apply (subst (asm) ex_by_sq_aux[symmetric])
      apply (smt Suc_1 nat_1 nat_2 nat_mod_distrib nat_one_as_int)
     by (simp add: div_int_pos_iff int_div_less_self nat_div_distrib)
    apply (simp add: algebra_simps semiring_normalization_rules nat_mult_distrib; fail)
   apply (simp add: algebra_simps semiring_normalization_rules nat_mult_distrib; fail)
   done
 
 
 
 subsubsection \<open>Power-Tower of 2s\<close>
 
 fun tower2 where
   "tower2 0 = 1"
 | "tower2 (Suc n) = 2 ^ tower2 n"  
 
 definition "tower2' n = int (tower2 (nat n))"
 
 program_spec tower2_imp
   assumes \<open>m>0\<close>
   ensures \<open>a = tower2' m\<^sub>0\<close>
   defines \<open>
     a=1;
     while (m>0) 
       @variant \<open>m\<close>
       @invariant \<open>0\<le>m \<and> m\<le>m\<^sub>0 \<and> a = tower2' (m\<^sub>0-m)\<close>
     {
       n=a;
       
       a = 1;
       while (n>0) 
         @variant \<open>n\<close> 
         @invariant \<open>True\<close> \<comment> \<open>This will get ugly, there is no \<open>n\<^sub>0\<close> that we could use!\<close>   
       {
         a=2*a;
         n=n-1
       };
       
       m=m-1
     }
   \<close>
   oops
 
 text \<open>We prove the inner loop separately instead! 
   (It happens to be exactly our \<^const>\<open>exp_count_down\<close> program.)
 \<close>  
   
 program_spec tower2_imp
   assumes \<open>m>0\<close>
   ensures \<open>a = tower2' m\<^sub>0\<close>
   defines \<open>
     a=1;
     while (m>0) 
       @variant \<open>m\<close>
       @invariant \<open>0\<le>m \<and> m\<le>m\<^sub>0 \<and> a = tower2' (m\<^sub>0-m)\<close>
     {
       n=a;
       inline exp_count_down;
       m=m-1
     }
   \<close>
   apply vcg_cs
   by (auto simp: algebra_simps tower2'_def nat_distribs)
 
 
 
 subsection \<open>Array Algorithms\<close>  
   
 (*
   Presentation in lecture:
 
   introduce array syntax and semantics
     CONVENTIONS: 
       * Every variable is an array. 
       * Arrays are modeled as int\<Rightarrow>int. Negative indexes allowed.
       * Syntactic sugar to use it at index 0 by default
       
     V vname \<mapsto> Vidx vname aexp  Syntax: x[i]
     abbreviation "V x = Vidx x 0"
   
     Assign vname aexp \<mapsto> AssignIdx vname aexp aexp  Syntax: x[i] = a
     abbreviation: Assign x a = AssignIdx x 0 a
   
     NEW COMMAND: ArrayCpy vname vname Syntax: x[] = y
       copy two arrays as a whole. Assign x (V y) only copies index 0
   
   semantics: Obvious
     aval (Vidx x i) s = s x (aval i s)
     
     (x[i] = a, s) \<Rightarrow> s(x := (s x)(aval i s := aval a s))
     
     (x[] = y, s) \<Rightarrow> s(x := s y)
     
   weakest preconditions: Also obvious
     \<dots>
     
 Reasoning with arrays:    
     
   Usually: Model as int\<Rightarrow>int is appropriate.
   
   Common idioms: 
     * {l..<h} the set of indexes i, l\<le>i<h
     * a`{l..<h} the set of values in range {l..<h}
   
     * ran_sorted a l h = \<dots>
     
     Warning: Sledgehammer does not perform well on these!
 
 Data Refinement    
   Sometimes, abstraction to list may be useful.
   
   Idea: Model an algorithm on lists first. Prove it correct.
     Then implement algorithm. Show that it implements the model.
     By transitivity, get: Algorithm is correct!
 
   
     
   Sometimes, abstraction to list may be useful    
     
 *)
 
 
   
   
 subsubsection \<open>Summation\<close>
 
 program_spec array_sum
   assumes "l\<le>h"
   ensures "r = (\<Sum>i=l\<^sub>0..<h\<^sub>0. a\<^sub>0 i)"
   defines \<open>
     r = 0;
     while (l<h) 
       @invariant \<open>l\<^sub>0\<le>l \<and> l\<le>h \<and> r = (\<Sum>i=l\<^sub>0..<l. a\<^sub>0 i)\<close>
       @variant \<open>h-l\<close>
     {
       r = r + a[l];
       l=l+1
     }
   \<close>
   apply vcg_cs
   by (auto simp: intvs_incdec)
   
 (* Exercise: Remove l\<le>h precondition! *)  
 
 subsubsection \<open>Finding Least Index of Element\<close>  
   
 program_spec find_least_idx
   assumes \<open>l\<le>h\<close>
   ensures \<open>if l=h\<^sub>0 then x\<^sub>0 \<notin> a\<^sub>0`{l\<^sub>0..<h\<^sub>0} else l\<in>{l\<^sub>0..<h\<^sub>0} \<and> a\<^sub>0 l = x\<^sub>0 \<and> x\<^sub>0\<notin>a\<^sub>0`{l\<^sub>0..<l} \<close>
   defines \<open>
     while (l<h \<and> a[l] \<noteq> x) 
       @variant \<open>h-l\<close>
       @invariant \<open>l\<^sub>0\<le>l \<and> l\<le>h \<and> x\<notin>a`{l\<^sub>0..<l}\<close>
       l=l+1
   \<close>
   apply vcg_cs
   by (smt atLeastLessThan_iff imageI)
   
 
 
   
 
 subsubsection \<open>Check for Sortedness\<close>  
   
 term ran_sorted
 
 program_spec check_sorted
   assumes \<open>l\<le>h\<close>
   ensures \<open>r\<noteq>0 \<longleftrightarrow> ran_sorted a\<^sub>0 l\<^sub>0 h\<^sub>0\<close>
   defines \<open>
     if (l==h) r=1
     else {
       l=l+1;
       while (l<h \<and> a[l-1] \<le> a[l]) 
         @variant \<open>h-l\<close>
         @invariant \<open>l\<^sub>0<l \<and> l\<le>h \<and> ran_sorted a l\<^sub>0 l\<close>
         l=l+1;
         
       if (l==h) r=1 else r=0
     }
   \<close>
   apply vcg_cs
    apply (auto simp: ran_sorted_def) 
   by (smt atLeastLessThan_iff) 
 
   
 subsubsection \<open>Find Equilibrium Index\<close>  
   
 definition "is_equil a l h i \<equiv> l\<le>i \<and> i<h \<and> (\<Sum>j=l..<i. a j) = (\<Sum>j=i..<h. a j)"
 
 program_spec equilibrium
   assumes \<open>l\<le>h\<close>
   ensures \<open>is_equil a l h i \<or> i=h \<and> (\<nexists>i. is_equil a l h i)\<close>
   defines \<open>
     usum=0; i=l;
     while (i<h) 
       @variant \<open>h-i\<close>
       @invariant \<open>l\<le>i \<and> i\<le>h \<and> usum = (\<Sum>j=l..<i. a j)\<close>
     { 
       usum = usum + a[i]; i=i+1 
     };
     i=l; lsum=0;
     while (usum \<noteq> lsum \<and> i<h) 
       @variant \<open>h-i\<close>
       @invariant \<open>l\<le>i \<and> i\<le>h 
         \<and> lsum=(\<Sum>j=l..<i. a j) 
         \<and> usum=(\<Sum>j=i..<h. a j) 
         \<and> (\<forall>j<i. \<not>is_equil a l h j)
       \<close>
     {
       lsum = lsum + a[i];
       usum = usum - a[i];
       i=i+1
     }
   \<close>
   apply vcg_cs
      apply (auto simp: intvs_incdec is_equil_def)
     apply (metis atLeastLessThan_iff eq_iff finite_atLeastLessThan_int sum_diff1)
    apply force
   by force
 
   
 subsubsection \<open>Rotate Right\<close>
 program_spec rotate_right
   assumes "0<n"
   ensures "\<forall>i\<in>{0..<n}. a i = a\<^sub>0 ((i-1) mod n)"
   defines \<open>
     i = 0;
     prev = a[n - 1];
     while (i < n)
       @invariant \<open>
         0 \<le> i \<and> i \<le> n 
         \<and> (\<forall>j\<in>{0..<i}. a j = a\<^sub>0 ((j-1) mod n))
         \<and> (\<forall>j\<in>{i..<n}. a j = a\<^sub>0 j)
         \<and> prev = a\<^sub>0 ((i-1) mod n)
       \<close>
       @variant \<open>n - i\<close>
     {
       temp = a[i];
       a[i] = prev;
       prev = temp;
       i = i + 1
     }
     \<close>
   apply vcg_cs
   by (simp add: zmod_minus1)
 
   
 subsubsection \<open>Binary Search, Leftmost Element\<close>  
   
 text \<open>We first specify the pre- and postcondition\<close>
 definition "bin_search_pre a l h \<longleftrightarrow> l\<le>h \<and> ran_sorted a l h"
 
 definition "bin_search_post a l h x i \<longleftrightarrow> 
   l\<le>i \<and> i\<le>h \<and> (\<forall>i\<in>{l..<i}. a i < x) \<and> (\<forall>i\<in>{i..<h}. x \<le> a i)"    
   
 text \<open>Then we prove that the program is correct\<close>  
 program_spec binsearch 
   assumes \<open>bin_search_pre a l h\<close>
   ensures \<open>bin_search_post a\<^sub>0 l\<^sub>0 h\<^sub>0 x\<^sub>0 l\<close>
   defines \<open>
     while (l < h) 
       @variant \<open>h-l\<close>
       @invariant \<open>l\<^sub>0\<le>l \<and> l\<le>h \<and> h\<le>h\<^sub>0 \<and> (\<forall>i\<in>{l\<^sub>0..<l}. a i < x) \<and> (\<forall>i\<in>{h..<h\<^sub>0}. x \<le> a i)\<close>
     {
         m = (l + h) / 2;
         if (a[m] < x) l = m + 1 
         else h = m
     }
   \<close>
   apply vcg_cs
        apply (auto simp: algebra_simps bin_search_pre_def bin_search_post_def)
   txt \<open>Driving sledgehammer to its limits ...\<close>
    apply (smt div_add_self1 even_succ_div_two odd_two_times_div_two_succ ran_sorted_alt)
   by (smt div_add_self1 even_succ_div_two odd_two_times_div_two_succ ran_sorted_alt)
 
 text \<open>Next, we show that our postcondition (which was easy to prove)
   implies the expected properties of the algorithm.
 \<close>
 lemma
   assumes "bin_search_pre a l h" "bin_search_post a l h x i"
   shows bin_search_decide_membership: "x\<in>a`{l..<h} \<longleftrightarrow> (i<h \<and> x = a i)"
     and bin_search_leftmost: "x\<notin>a`{l..<i}"
   using assms apply -
    apply (auto simp: bin_search_post_def bin_search_pre_def)
   apply (smt atLeastLessThan_iff ran_sorted_alt)
   done  
   
 subsubsection \<open>Naive String Search\<close>  
 (* By Simon Wimmer *)
 
 program_spec match_string
   assumes "l1 \<le> h1"
   ensures "(\<forall>j \<in> {0..<i}. a (l + j) = b (l1 + j)) \<and> (i < h1 - l1 \<longrightarrow> a (l + i) \<noteq> b (l1 + i))
     \<and> 0 \<le> i \<and> i \<le> h1 - l1"
   defines \<open>
   i = 0;
   while (l1 + i < h1 \<and> a[l + i] == b[l1 + i])
     @invariant \<open>(\<forall>j \<in> {0..<i}. a (l + j) = b (l1 + j)) \<and> 0 \<le> i \<and> i \<le> h1 - l1\<close>
     @variant \<open>(h1 - (l1 + i))\<close>
   {
     i = i + 1
   }
 \<close>
   by vcg_cs auto
 
 lemma lran_eq_iff': "lran a l1 (l1 + (h - l)) = lran a' l h
   \<longleftrightarrow> (\<forall>i. 0 \<le> i \<and> i < h - l \<longrightarrow> a (l1 + i) = a' (l + i))" if "l \<le> h"
   using that
 proof (induction "nat (h - l)" arbitrary: h)
   case 0
   then show ?case
     by auto
 next
   case (Suc x)
   then have *: "x = nat (h - 1 - l)" "l \<le> h - 1"
     by auto
   note IH = Suc.hyps(1)[OF *]
   from * have 1:
     "lran a l1 (l1 + (h - l)) = lran a l1 (l1 + (h - 1 - l)) @ [a (l1 + (h - 1 - l))]"
     "lran a' l h = lran a' l (h - 1) @ [a' (h - 1)]"
     by (auto simp: lran_bwd_simp algebra_simps lran_butlast[symmetric])
   from IH * Suc.hyps(2) Suc.prems show ?case
     unfolding 1
     apply auto
     subgoal for i
       by (cases "i = h - 1 - l") auto
     done
 qed
 
 program_spec match_string'
   assumes "l1 \<le> h1"
 ensures "i = h1 - l1 \<longleftrightarrow> lran a l (l + (h1 - l1)) = lran b l1 h1"
 for i h1 l1 l a[] b[]
 defines \<open>inline match_string\<close>
   by vcg_cs (auto simp: lran_eq_iff')
 
 program_spec substring
   assumes "l \<le> h \<and> l1 \<le> h1"
   ensures "match = 1 \<longleftrightarrow> (\<exists> j \<in> {l\<^sub>0..<h\<^sub>0}. lran a j (j + (h1 - l1)) = lran b l1 h1)"
   for a[] b[]
   defines \<open>
   match = 0;
   while (l < h \<and> match == 0)
     @invariant\<open>l\<^sub>0 \<le> l \<and> l \<le> h \<and> match \<in> {0,1} \<and>
     (if match = 1
      then lran a l (l + (h1 - l1)) = lran b l1 h1 \<and> l < h
      else (\<forall>j \<in> {l\<^sub>0..<l}. lran a j (j + (h1 - l1)) \<noteq> lran b l1 h1))\<close>
     @variant\<open>(h - l) * (1 - match)\<close>
   {
     inline match_string';
     if (i == h1 - l1) {match = 1}
     else {l = l + 1}
   }
 \<close>
   by vcg_cs auto
 
 program_spec substring'
   assumes "l \<le> h \<and> l1 \<le> h1"
   ensures "match = 1 \<longleftrightarrow> (\<exists> j \<in> {l\<^sub>0..h\<^sub>0-(h1 - l1)}. lran a j (j + (h1 - l1)) = lran b l1 h1)"
   for a[] b[]
   defines \<open>
   match = 0;
   if (l + (h1 - l1) \<le> h) {
     h = h - (h1 - l1) + 1;
     inline substring
   }
 \<close>
   by vcg_cs auto
 
 (* Or combined: *)
 program_spec substring''
   assumes "l \<le> h \<and> l1 \<le> h1"
   ensures "match = 1 \<longleftrightarrow> (\<exists> j \<in> {l\<^sub>0..<h\<^sub>0-(h1 - l1)}. lran a j (j + (h1 - l1)) = lran b l1 h1)"
   for a[] b[]
   defines \<open>
   match = 0;
   if (l + (h1 - l1) \<le> h) {
     while (l + (h1 - l1) < h \<and> match == 0)
       @invariant\<open>l\<^sub>0 \<le> l \<and> l \<le> h - (h1 - l1) \<and> match \<in> {0,1} \<and>
       (if match = 1
        then lran a l (l + (h1 - l1)) = lran b l1 h1 \<and> l < h - (h1 - l1)
        else (\<forall>j \<in> {l\<^sub>0..<l}. lran a j (j + (h1 - l1)) \<noteq> lran b l1 h1))\<close>
       @variant\<open>(h - l) * (1 - match)\<close>
     {
       inline match_string';
       if (i == h1 - l1) {match = 1}
       else {l = l + 1}
     }
   }
 \<close>
   by vcg_cs auto
 
 lemma lran_split:
   "lran a l h = lran a l p @ lran a p h" if "l \<le> p" "p \<le> h"
   using that by (induction p; simp; simp add: lran.simps)
 
 lemma lran_eq_append_iff:
   "lran a l h = as @ bs \<longleftrightarrow> (\<exists> i. l \<le> i \<and> i \<le> h \<and> as = lran a l i \<and> bs = lran a i h)" if "l \<le> h"
   apply safe
   subgoal
     using that
   proof (induction as arbitrary: l)
     case Nil
     then show ?case
       by auto
   next
     case (Cons x as)
     from this(2-) have "lran a (l + 1) h = as @ bs" "a l = x" "l + 1 \<le> h"
         apply -
       subgoal
         by simp
       subgoal
         by (smt append_Cons list.inject lran.simps lran_append1)
       subgoal
         using add1_zle_eq by fastforce
       done
-    from Cons.IH[OF this(1,3)] guess i by safe
-    note IH = this
+    from Cons.IH[OF this(1,3)] obtain i
+      where IH: "l + 1 \<le> i" "i \<le> h" "as = lran a (l + 1) i" "bs = lran a i h"
+      by auto
     with \<open>a l = x\<close> show ?case
       apply (intro exI[where x = i])
       apply auto
       by (smt IH(3) lran_prepend1)
   qed
   apply (subst lran_split; simp)
   done
 
 lemma lran_split':
   "(\<exists>j\<in>{l..h - (h1 - l1)}. lran a j (j + (h1 - l1)) = lran b l1 h1)
  = (\<exists>as bs. lran a l h = as @ lran b l1 h1 @ bs)" if "l \<le> h" "l1 \<le> h1"
 proof safe
   fix j
   assume j: "j \<in> {l..h - (h1 - l1)}" and match: "lran a j (j + (h1 - l1)) = lran b l1 h1"
   with \<open>l1 \<le> h1\<close> have "lran a l h = lran a l j @ lran a j (j + (h1 - l1)) @ lran a (j + (h1 - l1)) h"
     apply (subst lran_split[where p = j], simp, simp)
     apply (subst (2) lran_split[where p = "j + (h1 - l1)"]; simp)
     done
   then show "\<exists>as bs. lran a l h = as @ lran b l1 h1 @ bs"
     by (auto simp: match)
 next
   fix as bs
   assume "lran a l h = as @ lran b l1 h1 @ bs"
   with that lran_eq_append_iff[of l h a as "lran b l1 h1 @ bs"] obtain i where
     "as = lran a l i" "lran a i h = lran b l1 h1 @ bs" "l \<le> i" "i \<le> h"
     by auto
   with lran_eq_append_iff[of i h a "lran b l1 h1" bs] obtain j where j:
     "lran b l1 h1 = lran a i j" "bs = lran a j h" "i \<le> j" "j \<le> h"
     by auto
   moreover have "j = i + (h1 - l1)"
   proof -
     have "length (lran b l1 h1) = nat (h1 - l1)" "length (lran a i j) = nat (j - i)"
       by auto
     with j(1,3) that show ?thesis
       by auto
   qed
   ultimately show "\<exists>j\<in>{l..h - (h1 - l1)}. lran a j (j + (h1 - l1)) = lran b l1 h1"
     using \<open>l \<le> i\<close> by auto
 qed
 
 program_spec substring_final
   assumes "l \<le> h \<and> 0 \<le> len"
   ensures "match = 1 \<longleftrightarrow> (\<exists>as bs. lran a l\<^sub>0 h\<^sub>0 = as @ lran b 0 len @ bs)"
   for l h len match a[] b[]
   defines \<open>l1 = 0; h1 = len; inline substring'\<close>
   supply [simp] = lran_split'[symmetric]
   apply vcg_cs
   done
 
 
   
   
 subsubsection \<open>Insertion Sort\<close>
     
 text \<open>
   We first prove the inner loop. 
   The specification here specifies what the algorithm does as closely as possible,
   such that it becomes easier to prove. In this case, sortedness is not a precondition
   for the inner loop to move the key element backwards over all greater elements.
 \<close>
 definition "insort_insert_post l j a\<^sub>0 a i
   \<longleftrightarrow> (let key = a\<^sub>0 j in
       i\<in>{l-1..<j}            \<comment> \<open>\<open>i\<close> is in range\<close>
     \<comment> \<open>Content of new array\<close>
     \<and> (\<forall>k\<in>{l..i}. a k = a\<^sub>0 k) 
     \<and> a (i+1) = key
     \<and> (\<forall>k\<in>{i+2..j}. a k = a\<^sub>0 (k-1))
     \<and> a = a\<^sub>0 on -{l..j}
     \<comment> \<open>Placement of \<open>key\<close>\<close>  
     \<and> (i\<ge>l \<longrightarrow> a i \<le> key)  \<comment> \<open>Element at \<open>i\<close> smaller than \<open>key\<close>, if it exists \<close>
     \<and> (\<forall>k\<in>{i+2..j}. a k > key) \<comment> \<open>Elements \<open>\<ge>i+2\<close> greater than \<open>key\<close>\<close>
     )
     "
   for l j i :: int and a\<^sub>0 a :: "int \<Rightarrow> int"
   
 program_spec insort_insert 
   assumes "l<j"
   ensures "insort_insert_post l j a\<^sub>0 a i"
   defines \<open>
     key = a[j];
     i = j-1;
     while (i\<ge>l \<and> a[i]>key) 
       @variant \<open>i-l+1\<close>
       @invariant \<open>l-1\<le>i \<and> i<j 
         \<and> (\<forall>k\<in>{l..i}. a k = a\<^sub>0 k) 
         \<and> (\<forall>k\<in>{i+2..j}. a k > key \<and> a k = a\<^sub>0 (k-1))
         \<and> a = a\<^sub>0 on -{l..j}
         \<close>
     {
       a[i+1] = a[i];
       i=i-1
     };
     a[i+1] = key
   \<close>
   unfolding insort_insert_post_def Let_def
   apply vcg
       apply auto
   by (smt atLeastAtMost_iff)
   
 text \<open>Next, we show that our specification that was easy to prove implies the 
   specification that the outer loop expects:\<close>
 
 text \<open>Invoking \<open>insort_insert\<close> will sort in the element\<close>
 lemma insort_insert_sorted:
   assumes "l<j"
   assumes "insort_insert_post l j a a' i'"
   assumes "ran_sorted a l j"
   shows "ran_sorted a' l (j + 1)"
   using assms unfolding insort_insert_post_def Let_def
   apply auto
   subgoal
     by (smt atLeastAtMost_iff ran_sorted_alt)
   subgoal 
     unfolding ran_sorted_alt Ball_def
     apply auto
     by smt
   done  
   
 text \<open>Invoking \<open>insort_insert\<close> will only mutate the elements\<close>
 lemma insort_insert_ran1:
   assumes "l<j"
   assumes "insort_insert_post l j a a' i"
   shows "mset_ran a' {l..j} = mset_ran a {l..j}"
 proof -
   from assms have EQS:
     "a' = a on {l..i}"
     "a' (i+1) = a j"
     "a' = (a o (+)(-1)) on {i+2..j}"
     unfolding insort_insert_post_def eq_on_def Let_def by auto
 
   from assms have "l\<le>i+1" "i+1\<le>j" unfolding insort_insert_post_def Let_def by auto
     
   have ranshift: "mset_ran (a o (+)(-1)) {i+2..j} = mset_ran a {i+1..j-1}"  
     by (simp add: mset_ran_shift algebra_simps)
     
       
   have "mset_ran a' {l..j} = mset_ran a' {l..i} + {# a' (i+1) #} + mset_ran a' {i+2..j}"  
     using \<open>l<j\<close> \<open>l\<le>i+1\<close> \<open>i+1\<le>j\<close>
     apply (simp add: mset_ran_combine)
     by (auto intro: arg_cong[where f="mset_ran a'"])
   also have "\<dots> = mset_ran a {l..i} + {# a j #} + mset_ran (a o (+)(-1)) {i+2..j}"
     using EQS(1,3)[THEN mset_ran_cong] EQS(2) by simp
   also have "\<dots> = mset_ran a {l..i} + mset_ran a {i+1..j-1} + {# a j #}"
     by (simp add: mset_ran_shift algebra_simps) 
   also have "\<dots> = mset_ran a {l..j}"
     using \<open>l<j\<close> \<open>l\<le>i+1\<close> \<open>i+1\<le>j\<close>
     apply (simp add: mset_ran_combine)
     by (auto intro: arg_cong[where f="mset_ran a"])
   finally show ?thesis .
 qed  
 
 text \<open>The property @{thm insort_insert_ran1} extends to the whole array to be sorted\<close>
 lemma insort_insert_ran2:
   assumes "l<j" "j<h"
   assumes "insort_insert_post l j a a' i"
   shows "mset_ran a' {l..<h} = mset_ran a {l..<h}" (is ?thesis1)
     and "a'=a on -{l..<h}" (is ?thesis2)
 proof -
   from insort_insert_ran1 assms have "mset_ran a' {l..j} = mset_ran a {l..j}" by blast
   also from \<open>insort_insert_post l j a a' i\<close> have "a' = a on {j<..<h}"
     unfolding insort_insert_post_def Let_def by (auto simp: eq_on_def)
   hence "mset_ran a' {j<..<h} = mset_ran a {j<..<h}" by (rule mset_ran_cong)
   finally (mset_ran_combine_eqs) show ?thesis1
     by (simp add: assms ivl_disj_int_two(4) ivl_disj_un_two(4) le_less)
     
   from assms show ?thesis2   
     unfolding insort_insert_post_def Let_def eq_on_def 
     by auto
     
 qed  
 
 text \<open>Finally, we specify and prove correct the outer loop\<close>
 program_spec insort
   assumes "l<h" 
   ensures "ran_sorted a l h \<and> mset_ran a {l..<h} = mset_ran a\<^sub>0 {l..<h} \<and> a=a\<^sub>0 on -{l..<h}"
   for a[]
   defines \<open>
     j = l + 1;
     while (j<h) 
       @variant \<open>h-j\<close>
       @invariant \<open>
           l<j \<and> j\<le>h           \<comment> \<open>\<open>j\<close> in range\<close>
         \<and> ran_sorted a l j     \<comment> \<open>Array is sorted up to \<open>j\<close>\<close>
         \<and> mset_ran a {l..<h} = mset_ran a\<^sub>0 {l..<h} \<comment> \<open>Elements in range only permuted\<close>
         \<and> a=a\<^sub>0 on -{l..<h}
       \<close>
     {
       inline insort_insert;
       j=j+1
     }
   \<close>
   apply vcg_cs
   apply (intro conjI)
   subgoal by (rule insort_insert_sorted)
   subgoal using insort_insert_ran2(1) by auto
   subgoal apply (frule (2) insort_insert_ran2(2)) by (auto simp: eq_on_def)
   done    
   
 
   
 subsubsection \<open>Quicksort\<close>
 
 procedure_spec partition_aux(a,l,h,p) returns (a,i)
   assumes "l\<le>h"
   ensures "mset_ran a\<^sub>0 {l\<^sub>0..<h\<^sub>0} = mset_ran a {l\<^sub>0..<h\<^sub>0}
          \<and> (\<forall>j\<in>{l\<^sub>0..<i}. a j < p\<^sub>0)
          \<and> (\<forall>j\<in>{i..<h\<^sub>0}. a j \<ge> p\<^sub>0)
          \<and> l\<^sub>0\<le>i \<and> i\<le>h\<^sub>0
          \<and> a\<^sub>0 = a on -{l\<^sub>0..<h\<^sub>0}
          "
   defines \<open>
   i=l; j=l;
   while (j<h) 
     @invariant \<open> 
         l\<le>i \<and> i\<le>j \<and> j\<le>h     
       \<and> mset_ran a\<^sub>0 {l\<^sub>0..<h\<^sub>0} = mset_ran a {l\<^sub>0..<h\<^sub>0}
       \<and> (\<forall>k\<in>{l..<i}. a k < p)  
       \<and> (\<forall>k\<in>{i..<j}. a k \<ge> p)  
       \<and> (\<forall>k\<in>{j..<h}. a\<^sub>0 k = a k)  
       \<and> a\<^sub>0 = a on -{l\<^sub>0..<h\<^sub>0}
     \<close>
     @variant \<open>(h-j)\<close>
   {
     if (a[j]<p) {temp = a[i]; a[i] = a[j]; a[j] = temp; i=i+1};
     j=j+1
   }
   \<close>
   supply lran_eq_iff[simp] lran_tail[simp del]
   apply vcg_cs
   subgoal by (simp add: mset_ran_swap[unfolded swap_def])
   subgoal by auto
   done
   
 
 procedure_spec partition(a,l,h,p) returns (a,i)
   assumes "l<h"
   ensures "mset_ran a\<^sub>0 {l\<^sub>0..<h\<^sub>0} = mset_ran a {l\<^sub>0..<h\<^sub>0}
          \<and> (\<forall>j\<in>{l\<^sub>0..<i}. a j < a i) 
          \<and> (\<forall>j\<in>{i..<h\<^sub>0}. a j \<ge> a i)
          \<and> l\<^sub>0\<le>i \<and> i<h\<^sub>0 \<and> a\<^sub>0 (h\<^sub>0-1) = a i
          \<and> a\<^sub>0 = a on -{l\<^sub>0..<h\<^sub>0}
          "
   defines \<open>
     p = a[h-1];
     (a,i) = partition_aux(a,l,h-1,p);
     a[h-1] = a[i];
     a[i] = p
   \<close>
   apply vcg_cs
   apply (auto simp: eq_on_def mset_ran_swap[unfolded swap_def] intvs_incdec intro: mset_ran_combine_eq_diff)
   done
     
   
   
 lemma quicksort_sorted_aux:  
   assumes BOUNDS: "l \<le> i" "i < h"
   
   assumes LESS: "\<forall>j\<in>{l..<i}. a\<^sub>1 j < a\<^sub>1 i" 
   assumes GEQ: "\<forall>j\<in>{i..<h}. a\<^sub>1 i \<le> a\<^sub>1 j"
   
   assumes R1: "mset_ran a\<^sub>1 {l..<i} = mset_ran a\<^sub>2 {l..<i}"
   assumes E1: "a\<^sub>1 = a\<^sub>2 on - {l..<i}"
   
   assumes SL: "ran_sorted a\<^sub>2 l i"
   
   assumes R2: "mset_ran a\<^sub>2 {i + 1..<h} = mset_ran a\<^sub>3 {i + 1..<h}"
   assumes E2: "a\<^sub>2 = a\<^sub>3 on - {i + 1..<h}"
 
   assumes SH: "ran_sorted a\<^sub>3 (i + 1) h"
   
   shows "ran_sorted a\<^sub>3 l h"
 proof -
   have [simp]: "{l..<i} \<subseteq> - {i + 1..<h}" by auto
   have [simp]: "a\<^sub>1 i = a\<^sub>3 i" using E1 E2 by (auto simp: eq_on_def)
   
   note X1 = mset_ran_xfer_pointwise[where P = \<open>\<lambda>x. x < p\<close> for p, OF R1, simplified]
   note X2 = eq_on_xfer_pointwise[where P = \<open>\<lambda>x. x < p\<close> for p, OF E2, of "{l..<i}", simplified]
   from LESS have LESS': "\<forall>j\<in>{l..<i}. a\<^sub>3 j < a\<^sub>3 i"
     by (simp add: X1 X2)
     
   
   from GEQ have GEQ1: "\<forall>j\<in>{i+1..<h}. a\<^sub>1 i \<le> a\<^sub>1 j" by auto
   have [simp]: "{i + 1..<h} \<subseteq> - {l..<i}" by auto
   note X3 = eq_on_xfer_pointwise[where P = \<open>\<lambda>x. x \<ge> p\<close> for p, OF E1, of "{i+1..<h}", simplified]
   note X4 = mset_ran_xfer_pointwise[where P = \<open>\<lambda>x. x \<ge> p\<close> for p, OF R2, simplified]  
   from GEQ1 have GEQ': "\<forall>j\<in>{i+1..<h}. a\<^sub>3 i \<le> a\<^sub>3 j" by (simp add: X3 X4)
 
   
   from SL eq_on_xfer_ran_sorted[OF E2, of l i] have SL': "ran_sorted a\<^sub>3 l i" by simp
   
   show ?thesis using combine_sorted_pivot[OF BOUNDS SL' SH LESS' GEQ'] .
 qed  
   
 lemma quicksort_mset_aux:
   assumes B: "l\<^sub>0\<le>i" "i<h\<^sub>0"
   assumes R1: "mset_ran a {l\<^sub>0..<i} = mset_ran aa {l\<^sub>0..<i}"
   assumes E1: "a = aa on - {l\<^sub>0..<i}"
   assumes R2: "mset_ran aa {i + 1..<h\<^sub>0} = mset_ran ab {i + 1..<h\<^sub>0}"
   assumes E2: "aa = ab on - {i + 1..<h\<^sub>0}"
   shows "mset_ran a {l\<^sub>0..<h\<^sub>0} = mset_ran ab {l\<^sub>0..<h\<^sub>0}"
   apply (rule trans)
    apply (rule mset_ran_eq_extend[OF R1 E1])
   using B apply auto [2]
   apply (rule mset_ran_eq_extend[OF R2 E2])
   using B apply auto [2]
   done 
   
   
 recursive_spec quicksort(a,l,h) returns a 
   assumes "True"
   ensures "ran_sorted a l\<^sub>0 h\<^sub>0 \<and> mset_ran a\<^sub>0 {l\<^sub>0..<h\<^sub>0} = mset_ran a {l\<^sub>0..<h\<^sub>0} \<and> a\<^sub>0=a on -{l\<^sub>0..<h\<^sub>0}"
   variant "h-l"
   defines \<open>
     if (l<h) {
       (a,i) = partition(a,l,h,a[l]);
       a = rec quicksort(a,l,i);
       a = rec quicksort(a,i+1,h)
     }
   \<close>
   apply (vcg_cs; (intro conjI)?)
   subgoal using quicksort_sorted_aux by metis
   subgoal using quicksort_mset_aux by metis
   subgoal by (smt ComplD ComplI atLeastLessThan_iff eq_on_def)
   subgoal by (auto simp: ran_sorted_def)
   done
   
   
 subsection \<open>Data Refinement\<close>
 
 subsubsection \<open>Filtering\<close>
 
 program_spec array_filter_negative
   assumes "l\<le>h"
   ensures "lran a l\<^sub>0 i = filter (\<lambda>x. x\<ge>0) (lran a\<^sub>0 l\<^sub>0 h\<^sub>0)"
   defines \<open>
     i=l; j=l;
     while (j<h) 
       @invariant \<open> 
           l\<le>i \<and> i\<le>j \<and> j\<le>h     
         \<and> lran a l i = filter (\<lambda>x. x\<ge>0) (lran a\<^sub>0 l j)
         \<and> lran a j h = lran a\<^sub>0 j h
       \<close>
       @variant \<open>h-j\<close>
     {
       if (a[j]\<ge>0) {a[i] = a[j]; i=i+1};
       j=j+1
     }
   \<close>
   supply lran_eq_iff[simp] lran_tail[simp del]
   apply vcg_cs
   done
   
   (* Exercise: Use swap to modify this algorithm to partitioning! *)
   
 
   
 subsubsection \<open>Merge Two Sorted Lists\<close>
 
 text \<open>
   We define the merge function abstractly first, as a functional program on lists.
 \<close>
 
 fun merge where
   "merge [] ys = ys"
 | "merge xs [] = xs"
 | "merge (x#xs) (y#ys) = (if x<y then x#merge xs (y#ys) else y#merge (x#xs) ys)"   
 
 lemma merge_add_simp[simp]: "merge xs [] = xs" by (cases xs) auto
 
 text \<open>It's straightforward to show that this produces a sorted list with the same elements.\<close>
 lemma merge_sorted:
   assumes "sorted xs" "sorted ys" 
   shows "sorted (merge xs ys) \<and> set (merge xs ys) = set xs \<union> set ys"
   using assms
   apply (induction xs ys rule: merge.induct)
     apply auto
   done
   
 lemma merge_mset: "mset (merge xs ys) = mset xs + mset ys"  
   by (induction xs ys rule: merge.induct) auto
   
   
   
 text \<open>Next, we prove an equation that characterizes one step of the while loop,
   on the list level.\<close>
 lemma merge_eq: "xs\<noteq>[] \<or> ys\<noteq>[] \<Longrightarrow> merge xs ys = (
   if ys=[] \<or> (xs\<noteq>[] \<and> hd xs < hd ys) then hd xs # merge (tl xs) ys
   else hd ys # merge xs (tl ys)
   )"
   by (cases xs; cases ys; simp)
 
 text \<open>
   We do a first proof that our merge implementation on the arrays and indexes
   behaves like the functional merge on the corresponding lists.
   
   The annotations use the @{const lran} function to map from the implementation level 
   to the list level. Moreover, the invariant of the implementation, \<open>l\<le>h\<close>, is carried 
   through explicitly.
 \<close>
 program_spec merge_imp' 
   assumes "l1\<le>h1 \<and> l2\<le>h2"
   ensures "let ms = lran m 0 j; xs\<^sub>0 = lran a1\<^sub>0 l1\<^sub>0 h1\<^sub>0; ys\<^sub>0 = lran a2\<^sub>0 l2\<^sub>0 h2\<^sub>0 in  
     j\<ge>0 \<and> ms = merge xs\<^sub>0 ys\<^sub>0"
   defines \<open>
     j=0;
     while (l1\<noteq>h1 \<or> l2\<noteq>h2) 
       @variant \<open>h1 + h2 - l1 - l2\<close>
       @invariant \<open>let 
           xs=lran a1 l1 h1; ys = lran a2 l2 h2; ms = lran m 0 j;
           xs\<^sub>0 = lran a1\<^sub>0 l1\<^sub>0 h1\<^sub>0; ys\<^sub>0 = lran a2\<^sub>0 l2\<^sub>0 h2\<^sub>0
         in 
           l1\<le>h1 \<and> l2\<le>h2 \<and> 0\<le>j \<and>
           merge xs\<^sub>0 ys\<^sub>0 = ms@merge xs ys
       \<close>
     {
       if (l2==h2 \<or> (l1\<noteq>h1 \<and> a1[l1] < a2[l2])) {
         m[j] = a1[l1];
         l1=l1+1
       } else {
         m[j] = a2[l2];
         l2=l2+1
       };
       j=j+1
     }
   \<close>
   text \<open>Given the @{thm [source] merge_eq} theorem, which captures the essence of a loop step,
     and the theorems @{thm lran_append1}, @{thm lran_tail}, and @{thm hd_lran}, which
     convert from the operations on arrays and indexes to operations on lists,
     the proof is straightforward
   \<close>
   apply vcg_cs
   subgoal apply (subst merge_eq) by auto
   subgoal by linarith
   subgoal apply (subst merge_eq) by auto
   done
 
 text \<open>
   In a next step, we refine our proof to 
   combine it with the abstract properties we have proved about merge.
   The program does not change (we simply inline the original one here).
 \<close>
   
 procedure_spec merge_imp (a1,l1,h1,a2,l2,h2) returns (m,j)
   assumes "l1\<le>h1 \<and> l2\<le>h2 \<and> sorted (lran a1 l1 h1) \<and> sorted (lran a2 l2 h2)"
   ensures "let ms = lran m 0 j in 
       j\<ge>0 
     \<and> sorted ms 
     \<and> mset ms = mset (lran a1\<^sub>0 l1\<^sub>0 h1\<^sub>0) + mset (lran a2\<^sub>0 l2\<^sub>0 h2\<^sub>0)"
   for l1 h1 l2 h2 a1[] a2[] m[] j
   defines \<open>inline merge_imp'\<close>
   apply vcg_cs
   apply (auto simp: Let_def merge_mset dest: merge_sorted)
   done
   
 thm merge_imp_spec  
 thm merge_imp_def
   
 lemma [named_ss vcg_bb]:
   "UNIV \<union> a = UNIV"  
   "a \<union> UNIV = UNIV"  
   by auto
   
   
 lemma merge_msets_aux: "\<lbrakk>l\<le>m; m\<le>h\<rbrakk> \<Longrightarrow> mset (lran a l m) + mset (lran a m h) = mset (lran a l h)"  
   by (auto simp: mset_lran mset_ran_combine ivl_disj_un_two)
   
   
   
   
 recursive_spec mergesort (a,l,h) returns (b,j)
   assumes "l\<le>h"
   ensures \<open>0\<le>j \<and> sorted (lran b 0 j) \<and> mset (lran b 0 j) = mset (lran a\<^sub>0 l\<^sub>0 h\<^sub>0)\<close>
   variant \<open>h-l\<close>
   for a[] b[]
   defines \<open>
     if (l==h) j=0
     else if (l+1==h) {
       b[0] = a[l];
       j=1
     } else {
       m = (h+l) / 2;
       (a1,h1) = rec mergesort (a,l,m);
       (a2,h2) = rec mergesort (a,m,h);
       (b,j) = merge_imp (a1,0,h1,a2,0,h2) 
     }
   \<close>
   apply vcg
        apply auto []
       apply (auto simp: lran.simps) []
      apply auto []
     apply auto []
    apply auto []
   apply (auto simp: Let_def merge_msets_aux) []
   done
 print_theorems    
   
   
 subsubsection \<open>Remove Duplicates from Array, using Bitvector Set\<close>  
   
 text \<open>We use an array to represent a set of integers.
 
   If we only insert elements in range \<open>{0..<n}\<close>, this representation
   is called bit-vector (storing a single bit per index is enough).
 \<close>
 
 definition set_of :: "(int \<Rightarrow> int) \<Rightarrow> int set" where "set_of a \<equiv> {i. a i \<noteq> 0}"
 
 context notes [simp] = set_of_def begin
   lemma set_of_empty[simp]: "set_of (\<lambda>_. 0) = {}" by auto
   lemma set_of_insert[simp]: "x\<noteq>0 \<Longrightarrow> set_of (a(i:=x)) = insert i (set_of a)" by auto
   lemma set_of_remove[simp]: "set_of (a(i:=0)) = set_of a - {i}" by auto
   lemma set_of_mem[simp]: "i\<in>set_of a \<longleftrightarrow> a i \<noteq> 0" by auto
 end
 
 program_spec dedup
   assumes \<open>l\<le>h\<close>
   ensures \<open>set (lran a l i) = set (lran a\<^sub>0 l h) \<and> distinct (lran a l i)\<close>
   defines \<open>
     i=l; j=l;
     clear b[];
     while (j<h) 
       @variant \<open>h-j\<close>
       @invariant \<open>l\<le>i \<and> i\<le>j \<and> j\<le>h 
         \<and> set (lran a l i) = set (lran a\<^sub>0 l j)
         \<and> distinct (lran a l i)
         \<and> lran a j h = lran a\<^sub>0 j h
         \<and> set_of b = set (lran a l i)
        \<close>
     {
       if (b[a[j]] == 0) {
         a[i] = a[j]; i=i+1; b[a[j]] = 1
       };
       j=j+1
     }
   \<close>
   apply vcg_cs
    apply (auto simp: lran_eq_iff lran_upd_inside intro: arg_cong[where f=tl]) []
   apply (auto simp: lran_eq_iff) []
   done
   
   
 procedure_spec bv_init () returns b 
   assumes True ensures \<open>set_of b = {}\<close> 
   defines \<open>clear b[]\<close>
   by vcg_cs
   
 procedure_spec bv_insert (x, b) returns b 
   assumes True ensures \<open>set_of b = insert x\<^sub>0 (set_of b\<^sub>0)\<close>
   defines \<open>b[x] = 1\<close>
   by vcg_cs
   
 procedure_spec bv_remove (x, b) returns b
   assumes True ensures \<open>set_of b = set_of b\<^sub>0 - {x\<^sub>0}\<close>
   defines \<open>b[x] = 0\<close>
   by vcg_cs
   
 procedure_spec bv_elem (x,b) returns r  
   assumes True ensures \<open>r\<noteq>0 \<longleftrightarrow> x\<^sub>0\<in>set_of b\<^sub>0\<close>
   defines \<open>r = b[x]\<close>
   by vcg_cs
   
   
 procedure_spec dedup' (a,l,h) returns (a,l,i)
   assumes \<open>l\<le>h\<close> ensures \<open>set (lran a l i) = set (lran a\<^sub>0 l\<^sub>0 h\<^sub>0) \<and> distinct (lran a l i) \<close>
   for b[]
   defines \<open>
     b = bv_init();
   
     i=l; j=l;
     
     while (j<h) 
       @variant \<open>h-j\<close>
       @invariant \<open>l\<le>i \<and> i\<le>j \<and> j\<le>h 
         \<and> set (lran a l i) = set (lran a\<^sub>0 l j)
         \<and> distinct (lran a l i)
         \<and> lran a j h = lran a\<^sub>0 j h
         \<and> set_of b = set (lran a l i)
        \<close>
     {
       mem = bv_elem (a[j],b);
       if (mem == 0) {
         a[i] = a[j]; i=i+1; b = bv_insert(a[j],b)
       };
       j=j+1
     }
   \<close>
   apply vcg_cs
    apply (auto simp: lran_eq_iff lran_upd_inside intro: arg_cong[where f=tl])
   done
   
 subsection \<open>Recursion\<close>  
 
 subsubsection \<open>Recursive Fibonacci\<close>
 
 recursive_spec fib_imp (i) returns r assumes True ensures \<open>r = fib i\<^sub>0\<close> variant \<open>i\<close>
   defines \<open>
     if (i\<le>0) r=0
     else if (i==1) r=1
     else {
       r1=rec fib_imp (i-2);
       r2=rec fib_imp (i-1);
       r = r1+r2
     }
   \<close>
   by vcg_cs    
     
 subsubsection \<open>Homeier's Cycling Termination\<close>  
 
 text \<open>A contrived example from Homeier's thesis. 
   Only the termination proof is done.\<close>
 (* TODO: Also show correctness: pedal (a,b) will multiply its arguments!
   correctness proof may be a good test how to handle specs with logical vars!
 *)  
   
 recursive_spec 
   pedal (n,m) returns () assumes \<open>n\<ge>0 \<and> m\<ge>0\<close> ensures True variant \<open>n+m\<close>
   defines \<open>
     if (n\<noteq>0 \<and> m\<noteq>0) {
       G = G + m;
       if (n<m) rec coast (n-1,m-1) else rec pedal(n-1,m)
     }
   \<close>
 and
   coast (n,m) returns () assumes \<open>n\<ge>0 \<and> m\<ge>0\<close> ensures True variant \<open>n+m+1\<close>
   defines \<open>
     G = G + n;
     if (n<m) rec coast (n,m-1) else rec pedal (n,m)
   \<close>
   by vcg_cs  
   
   
 subsubsection \<open>Ackermann\<close>  
   
 fun ack :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
   "ack 0 n = n+1"
 | "ack m 0 = ack (m-1) 1"
 | "ack m n = ack (m-1) (ack m (n-1))"
   
 lemma ack_add_simps[simp]: 
   "m\<noteq>0 \<Longrightarrow> ack m 0 = ack (m-1) 1"
   "\<lbrakk>m\<noteq>0; n\<noteq>0\<rbrakk> \<Longrightarrow> ack m n = ack (m-1) (ack m (n-1))"
   subgoal by (cases m) auto
   subgoal by (cases "(m,n)" rule: ack.cases) (auto)
   done
 
 recursive_spec relation "less_than <*lex*> less_than"
   ack_imp (m,n) returns r
     assumes "m\<ge>0 \<and> n\<ge>0" ensures "r=int (ack (nat m\<^sub>0) (nat n\<^sub>0))"
     variant "(nat m, nat n)" 
     defines \<open>
       if (m==0) r = n+1
       else if (n==0) r = rec ack_imp (m-1,1)
       else {
         t = rec ack_imp (m,n-1);
         r = rec ack_imp (m-1,t)
       }
     \<close>
   supply nat_distribs[simp]
   by vcg_cs
   
   
 subsubsection \<open>McCarthy's 91 Function\<close>
 text \<open>A standard benchmark for verification of recursive functions.
   We use Homeier's version with a global variable.\<close>
   
 recursive_spec p91(y) assumes True ensures "if 100<y\<^sub>0 then G = y\<^sub>0-10 else G = 91" variant "101-y" 
   for G
   defines \<open>
     if (100<y) G=y-10
     else {
       rec p91 (y+11);
       rec p91 (G)
     }
   \<close>
   apply vcg_cs
    apply (auto split: if_splits)
   done
   
 subsubsection \<open>Odd/Even\<close>  
   
 recursive_spec 
   odd_imp (a) returns b 
     assumes True
     ensures "b\<noteq>0 \<longleftrightarrow> odd a\<^sub>0"
     variant "\<bar>a\<bar>"
     defines \<open>
       if (a==0) b=0
       else if (a<0) b = rec even_imp (a+1)
       else b = rec even_imp (a-1)
     \<close>
   and
   even_imp (a) returns b
     assumes True
     ensures "b\<noteq>0 \<longleftrightarrow> even a\<^sub>0"
     variant "\<bar>a\<bar>"
     defines \<open>
       if (a==0) b=1
       else if (a<0) b = rec odd_imp (a+1)
       else b = rec odd_imp (a-1)
     \<close>
   apply vcg  
            apply auto
   done  
 
 thm even_imp_spec
 
   
 subsubsection \<open>Pandya and Joseph's Product Producers\<close>
 text \<open>Again, taking the version from Homeier's thesis, but with a 
   modification to also terminate for negative \<open>y\<close>.
   \<close>
   
 recursive_spec relation \<open>measure nat <*lex*> less_than\<close>
   product () assumes True ensures \<open>GZ = GZ\<^sub>0 + GX\<^sub>0*GY\<^sub>0\<close> variant "(\<bar>GY\<bar>,1::nat)" 
   for GX GY GZ
   defines
   \<open>
     e = even_imp (GY);
     if (e\<noteq>0) rec evenproduct() else rec oddproduct()
   \<close>
 and
   oddproduct() assumes \<open>odd GY\<close> ensures \<open>GZ = GZ\<^sub>0 + GX\<^sub>0*GY\<^sub>0\<close> variant "(\<bar>GY\<bar>,0::nat)" 
   for GX GY GZ
   defines
   \<open>
     if (GY<0) {
       GY = GY + 1;
       GZ = GZ - GX
     } else {
       GY = GY - 1;
       GZ = GZ + GX
     };
     rec evenproduct()
   \<close>
 and
   evenproduct() assumes \<open>even GY\<close> ensures \<open>GZ = GZ\<^sub>0 + GX\<^sub>0*GY\<^sub>0\<close> variant "(\<bar>GY\<bar>,0::nat)" 
   for GX GY GZ
   defines
   \<open>
     if (GY\<noteq>0) {
       GX = 2*GX;
       GY = GY / 2;
       rec product()
     }
   \<close>
   apply vcg_cs
      apply (auto simp: algebra_simps)
    apply presburger+
   done
   
   
 (*
   TODO: 
     * Infrastructure to prove different specification for same program
       (DONE) We can use inline, and just give program a new name.
 
     * ghost variables. Keep them existentially qualified, with naming tag.
         ABS_GHOST ''name'' (\<lambda>x. P x) \<equiv> \<exists>x. P x
         GHOST ''name'' value = True
         
         assumes ABS_GHOST name (\<lambda>x. P x) 
         obtains x where "GHOST name x" "P x"
         
         assumes "GHOST name x" and "P x"
         shows "ABS_GHOST name (\<lambda>x. P x)"
         
         Let_Ghost name (\<lambda>x s. C x s) = skip
         
         assumes "\<exists>x. C x s"
         assumes "\<And>x. \<lbrakk> GHOST name x; C x s \<rbrakk> \<Longrightarrow> Q s"
         shows "wp (Let_Ghost name (\<lambda>x s. C x s)) Q s"
         
       Let specification command also abstract over ghost variables in program.
         
 *)  
   
 (* IDEAS: 
   
   Extend arrays to multiple dimensions: int list \<Rightarrow> int
     Vidx vname "aexp list"
     AssignIdx vname "aexp list" aexp
     ArrayCpy vname vname  -- copy all dimensions (it's simpler)
     ArrayInit vname       -- Init all dimensions
     
     plain values on dimension []!
 
     then we can easily encode matrices and adjacency lists!
     
 *)  
 
 subsection \<open>Graph Algorithms\<close>
 
 subsubsection \<open>DFS\<close>
 (* By Simon Wimmer *)
 
 text \<open>A graph is stored as an array of integers. 
   Each node is an index into this array, pointing to a size-prefixed list of successors.
 
   Example for node \<open>i\<close>, which has successors \<open>s1... sn\<close>:
   \<^verbatim>\<open>
    Indexes: ... |  i  | i+1 | ... | i+n | ...
    Data:    ... |  n  | s1  | ... | sn  | ...
   \<close>
 \<close>
 
 definition succs where
   "succs a i \<equiv> a ` {i+1..<a i}" for a :: "int \<Rightarrow> int"
 
 definition Edges where
   "Edges a \<equiv> {(i, j). j \<in> succs a i}"
 
 procedure_spec push' (x, stack, ptr) returns (stack, ptr)
   assumes "ptr \<ge> 0" ensures \<open>lran stack 0 ptr = lran stack\<^sub>0 0 ptr\<^sub>0 @ [x\<^sub>0] \<and> ptr = ptr\<^sub>0 + 1\<close>
   defines \<open>stack[ptr] = x; ptr = ptr + 1\<close>
   by vcg_cs
 
 procedure_spec push (x, stack, ptr) returns (stack, ptr)
   assumes "ptr \<ge> 0" ensures \<open>stack ` {0..<ptr} = {x\<^sub>0} \<union> stack\<^sub>0 ` {0..<ptr\<^sub>0} \<and> ptr = ptr\<^sub>0 + 1\<close>
   for stack[]
   defines \<open>stack[ptr] = x; ptr = ptr + 1\<close>
   by vcg_cs (auto simp: fun_upd_image)
 
 program_spec get_succs
   assumes "j \<le> stop \<and> stop = a (j - 1) \<and> 0 \<le> i"
   ensures "
     stack ` {0..<i} = {x. (j\<^sub>0 - 1, x) \<in> Edges a \<and> x \<notin> set_of visited} \<union> stack\<^sub>0 ` {0..<i\<^sub>0}
     \<and> i \<ge> i\<^sub>0"
 for i j stop stack[] a[] visited[]
 defines
 \<open>
   while (j < stop)
   @invariant \<open>stack ` {0..<i} = {x. x \<in> a ` {j\<^sub>0..<j} \<and> x \<notin> set_of visited} \<union> stack\<^sub>0 ` {0..<i\<^sub>0}
     \<and> j \<le> stop \<and> i\<^sub>0 \<le> i \<and> j\<^sub>0 \<le> j
   \<close>
   @variant \<open>(stop - j)\<close>
   {
     succ = a[j];
     is_elem = bv_elem(succ,visited);
     if (is_elem == 0) {
       (stack, i) = push (succ, stack, i)
     };
     j = j + 1
   }
 \<close>
   by vcg_cs (auto simp: intvs_incr_h Edges_def succs_def)
 
 procedure_spec pop (stack, ptr) returns (x, ptr)
   assumes "ptr \<ge> 1" ensures \<open>stack\<^sub>0 ` {0..<ptr\<^sub>0} = stack\<^sub>0 ` {0..<ptr} \<union> {x} \<and> ptr\<^sub>0 = ptr + 1\<close>
   for stack[]
   defines \<open>ptr = ptr - 1; x = stack[ptr]\<close>
   by vcg_cs (simp add: intvs_upper_decr)
 
 procedure_spec stack_init () returns i
   assumes True ensures \<open>i = 0\<close> 
   defines \<open>i = 0\<close>
   by vcg_cs
 
 lemma Edges_empty:
   "Edges a `` {i} = {}" if "i + 1 \<ge> a i"
   using that unfolding Edges_def succs_def by auto
 
 text \<open>This is one of the main insights of the algorithm: if a set of visited states is
 closed w.r.t.\ to the edge relation, then it is guaranteed to contain all the states that
 are reachable from any state within the set.\<close>
 lemma reachability_invariant:
   assumes reachable: "(s, x) \<in> (Edges a)\<^sup>*"
       and closed: "\<forall>v\<in>visited. Edges a `` {v} \<subseteq> visited"
       and start: "s \<in> visited"
   shows "x \<in> visited"
   using reachable start closed by induction auto
 
 program_spec (partial) dfs
   assumes "0 \<le> x \<and> 0 \<le> s"
   ensures "b = 1 \<longleftrightarrow> x \<in> (Edges a)\<^sup>* `` {s}" defines \<open>
   b = 0;
   clear stack[];
   i = stack_init();
   (stack, i) = push (s, stack, i);
   clear visited[];
   while (b == 0 \<and> i \<noteq> 0)
     @invariant \<open>0 \<le> i \<and> (s \<in> stack ` {0..<i} \<or> s \<in> set_of visited) \<and> (b = 0 \<or> b = 1) \<and> (
     if b = 0 then
       stack ` {0..<i} \<subseteq> (Edges a)\<^sup>* `` {s}
       \<and> (\<forall>v \<in> set_of visited. (Edges a) `` {v} \<subseteq> set_of visited \<union> stack ` {0..<i})
       \<and> (x \<notin> set_of visited)
     else x \<in> (Edges a)\<^sup>* `` {s})
   \<close>
   {
     (next, i) = pop(stack, i); \<comment>\<open>Take the top most element from the stack.\<close>
     visited = bv_insert(next, visited); \<comment>\<open>Mark it as visited,\<close>
     if (next == x) {
       b = 1 \<comment>\<open>If it is the target, we are done.\<close>
     } else {
       \<comment>\<open>Else, put its successors on the stack if they are not yet visited.\<close>
       stop = a[next];
       j = next + 1;
       if (j \<le> stop) {
         inline get_succs
       }
     }
   }
 \<close>
   apply vcg_cs
   subgoal by (auto simp: set_of_def)
   subgoal using intvs_lower_incr by (auto simp: Edges_empty)
   subgoal by auto (fastforce simp: set_of_def dest!: reachability_invariant)
   done
 
 
 text \<open>Assuming that the input graph is finite, we can also prove that the algorithm terminates.
 We will thus use an \<open>Isabelle context\<close> to fix a certain finite graph and a start state:
 \<close>
 
 context
   fixes start :: int and edges
   assumes finite_graph[intro!]: "finite ((Edges edges)\<^sup>* `` {start})"
 begin
 
 lemma sub_insert_same_iff: "s \<subset> insert x s \<longleftrightarrow> x\<notin>s" by auto
 
 program_spec dfs1
   assumes "0 \<le> x \<and> 0 \<le> s \<and> start = s \<and> edges = a"
   ensures "b = 1 \<longleftrightarrow> x \<in> (Edges a)\<^sup>* `` {s}"
   for visited[]
   defines
 \<open>
   b = 0;
   \<comment>\<open>\<open>i\<close> will point to the next free space in the stack (i.e. it is the size of the stack)\<close>
   i = 1;
   \<comment>\<open>Initially, we put \<open>s\<close> on the stack.\<close>
   stack[0] = s;
   visited = bv_init();
   while (b == 0 \<and> i \<noteq> 0)
     @invariant \<open>
     0 \<le> i \<and> (s \<in> stack ` {0..<i} \<or> s \<in> set_of visited) \<and> (b = 0 \<or> b = 1) \<and>
     set_of visited \<subseteq> (Edges edges)\<^sup>* `` {start} \<and> (
     if b = 0 then
       stack ` {0..<i} \<subseteq> (Edges a)\<^sup>* `` {s}
       \<and> (\<forall>v \<in> set_of visited. (Edges a) `` {v} \<subseteq> set_of visited \<union> stack ` {0..<i})
       \<and> (x \<notin> set_of visited)
     else x \<in> (Edges a)\<^sup>* `` {s})
     \<close>
     @relation \<open>finite_psupset ((Edges edges)\<^sup>* `` {start}) <*lex*> less_than\<close>
     @variant \<open> (set_of visited, nat i)\<close>
   {
     \<comment>\<open>Take the top most element from the stack.\<close>
     (next, i) = pop(stack, i);
     if (next == x) {
       \<comment>\<open>If it is the target, we are done.\<close>
       visited = bv_insert(next, visited);
       b = 1
     } else {
       is_elem = bv_elem(next, visited);
       if (is_elem == 0) {
         visited = bv_insert(next, visited);
         \<comment>\<open>Else, put its successors on the stack if they are not yet visited.\<close>
         stop = a[next];
         j = next + 1;
         if (j \<le> stop) {
           inline get_succs
         }
       }
     }
   }
 \<close>
   apply vcg_cs
   subgoal by auto
   subgoal by (auto simp add: image_constant_conv)
   subgoal by (clarsimp simp: finite_psupset_def sub_insert_same_iff)
   subgoal by (auto simp: set_of_def)
   subgoal by (clarsimp simp: finite_psupset_def sub_insert_same_iff)
   subgoal by (auto simp: Edges_empty)
   subgoal by (clarsimp simp: finite_psupset_def sub_insert_same_iff)
   subgoal by (auto simp: set_of_def)
   subgoal by auto (fastforce simp: set_of_def dest!: reachability_invariant)
   done
 
 end
 
 
 end
\ No newline at end of file
diff --git a/thys/LOFT/LinuxRouter_OpenFlow_Translation.thy b/thys/LOFT/LinuxRouter_OpenFlow_Translation.thy
--- a/thys/LOFT/LinuxRouter_OpenFlow_Translation.thy
+++ b/thys/LOFT/LinuxRouter_OpenFlow_Translation.thy
@@ -1,1056 +1,1057 @@
 theory LinuxRouter_OpenFlow_Translation
 imports IP_Addresses.CIDR_Split
   Automatic_Refinement.Misc (*TODO@Peter: rename and make available at better place :)*)
 	Simple_Firewall.Generic_SimpleFw 
 	Semantics_OpenFlow
 	OpenFlow_Matches
 	OpenFlow_Action
 	Routing.Linux_Router
+	"Pure-ex.Guess"
 begin
 hide_const Misc.uncurry
 hide_fact Misc.uncurry_def
   
 (* For reference:
 iiface :: "iface" --"in-interface"
 oiface :: "iface" --"out-interface"
 src :: "(ipv4addr \<times> nat) " --"source IP address"
 dst :: "(ipv4addr \<times> nat) " --"destination"
 proto :: "protocol"
 sports :: "(16 word \<times> 16 word)" --"source-port first:last"
 dports :: "(16 word \<times> 16 word)" --"destination-port first:last"
 
 p_iiface :: string
 p_oiface :: string
 p_src :: ipv4addr
 p_dst :: ipv4addr
 p_proto :: primitive_protocol
 p_sport :: "16 word"
 p_dport :: "16 word"
 p_tcp_flags :: "tcp_flag set"
 p_payload :: string
 *)
 
 definition "route2match r =
 	\<lparr>iiface = ifaceAny, oiface = ifaceAny, 
 	src = (0,0), dst=(pfxm_prefix (routing_match r),pfxm_length (routing_match r)), 
 	proto=ProtoAny, sports=(0,- 1), ports=(0,- 1)\<rparr>"
 
 definition toprefixmatch where
 "toprefixmatch m \<equiv> (let pm = PrefixMatch (fst m) (snd m) in if pm = PrefixMatch 0 0 then None else Some pm)"
 lemma prefix_match_semantics_simple_match: 
   assumes some: "toprefixmatch m = Some pm"
 	assumes vld: "valid_prefix pm"
 	shows "prefix_match_semantics pm = simple_match_ip m"
 using some
   by(cases m)
 	  (clarsimp 
 	   simp add: toprefixmatch_def ipset_from_cidr_def pfxm_mask_def fun_eq_iff
 	            prefix_match_semantics_ipset_from_netmask[OF vld] NOT_mask_shifted_lenword[symmetric]
 	   split: if_splits)
 
 definition simple_match_to_of_match_single ::
     "(32, 'a) simple_match_scheme
      \<Rightarrow> char list option \<Rightarrow> protocol \<Rightarrow> (16 word \<times> 16 word) option \<Rightarrow> (16 word \<times> 16 word) option \<Rightarrow> of_match_field set" 
     where
 "simple_match_to_of_match_single m iif prot sport dport \<equiv>
 	   uncurry L4Src ` option2set sport \<union> uncurry L4Dst ` option2set dport
 	 \<union> IPv4Proto ` (case prot of ProtoAny \<Rightarrow> {} | Proto p \<Rightarrow> {p}) \<comment> \<open>protocol is an 8 word option anyway...\<close>
 	 \<union> IngressPort ` option2set iif
 	 \<union> IPv4Src ` option2set (toprefixmatch (src m)) \<union> IPv4Dst ` option2set (toprefixmatch (dst m))
 	 \<union> {EtherType 0x0800}"
 (* okay, we need to make sure that no packets are output on the interface they were input on. So for rules that don't have an input interface, we'd need to do a product over all interfaces, if we stay naive.
    The more smart way would be to insert a rule with the same match condition that additionally matches the input interface and drops. However, I'm afraid this is going to be very tricky to verify\<dots> *)
 definition simple_match_to_of_match :: "32 simple_match \<Rightarrow> string list \<Rightarrow> of_match_field set list" where
 "simple_match_to_of_match m ifs \<equiv> (let
 	npm = (\<lambda>p. fst p = 0 \<and> snd p = - 1);
 	sb = (\<lambda>p. (if npm p then [None] else if fst p \<le> snd p
   then map (Some \<circ> (\<lambda>pfx. (pfxm_prefix pfx, NOT (pfxm_mask pfx)))) (wordinterval_CIDR_split_prefixmatch (WordInterval (fst p) (snd p))) else []))
 	in [simple_match_to_of_match_single m iif (proto m) sport dport.
 		iif \<leftarrow> (if iiface m = ifaceAny then [None] else [Some i. i \<leftarrow> ifs, match_iface (iiface m) i]),
 		sport \<leftarrow> sb (sports m),
 		dport \<leftarrow> sb (dports m)]
 )"
 (* I wonder\<dots> should I check whether list_all (match_iface (iiface m)) ifs instead of iiface m = ifaceAny? It would be pretty stupid if that wasn't the same, but you know\<dots> *)
 
 lemma smtoms_eq_hlp: "simple_match_to_of_match_single r a b c d = simple_match_to_of_match_single r f g h i \<longleftrightarrow> (a = f \<and> b = g \<and> c = h \<and> d = i)"
 (* In case this proof breaks: there are two alternate proofs in the repo. They are of similar quality, though. Good luck. *)
 proof(rule iffI,goal_cases)
   case 1
   thus ?case proof(intro conjI)
     have *: "\<And>P z x. \<lbrakk>\<forall>x :: of_match_field. P x; z = Some x\<rbrakk> \<Longrightarrow> P (IngressPort x)" by simp
     show "a = f" using 1 by(cases a; cases f)
         (simp add: option2set_None simple_match_to_of_match_single_def toprefixmatch_def option2set_def;
         subst(asm) set_eq_iff; drule (1) *; simp split: option.splits uncurry_splits protocol.splits)+
   next
     have *: "\<And>P z x. \<lbrakk>\<forall>x :: of_match_field. P x; z = Proto x\<rbrakk> \<Longrightarrow> P (IPv4Proto x)" by simp
     show "b = g" using 1 by(cases b; cases g) 
         (simp add: option2set_None simple_match_to_of_match_single_def toprefixmatch_def option2set_def;
         subst(asm) set_eq_iff; drule (1) *; simp split: option.splits uncurry_splits protocol.splits)+
   next
     have *: "\<And>P z x. \<lbrakk>\<forall>x :: of_match_field. P x; z = Some x\<rbrakk> \<Longrightarrow> P (uncurry L4Src x)" by simp
     show "c = h" using 1 by(cases c; cases h)
         (simp add: option2set_None simple_match_to_of_match_single_def toprefixmatch_def option2set_def;
         subst(asm) set_eq_iff; drule (1) *; simp split: option.splits uncurry_splits protocol.splits)+
   next
     have *: "\<And>P z x. \<lbrakk>\<forall>x :: of_match_field. P x; z = Some x\<rbrakk> \<Longrightarrow> P (uncurry L4Dst x)" by simp
     show "d = i" using 1 by(cases d; cases i)
         (simp add: option2set_None simple_match_to_of_match_single_def toprefixmatch_def option2set_def;
         subst(asm) set_eq_iff; drule (1) *; simp split: option.splits uncurry_splits protocol.splits)+
   qed
 qed simp
 
 lemma simple_match_to_of_match_generates_prereqs: "simple_match_valid m \<Longrightarrow> r \<in> set (simple_match_to_of_match m ifs) \<Longrightarrow> all_prerequisites r"
 unfolding simple_match_to_of_match_def Let_def
 proof(clarsimp, goal_cases)
   case (1 xiface xsrcp xdstp)
   note o = this
   show ?case unfolding simple_match_to_of_match_single_def all_prerequisites_def
     unfolding ball_Un
   proof((intro conjI; ((simp;fail)| - )), goal_cases)
     case 1
     have e: "(fst (sports m) = 0 \<and> snd (sports m) = - 1) \<or> proto m = Proto TCP \<or> proto m = Proto UDP \<or> proto m = Proto L4_Protocol.SCTP"
       using o(1)
       unfolding simple_match_valid_alt Let_def
       by(clarsimp split: if_splits)
     show ?case
       using o(3) e
       by(elim disjE; simp add: option2set_def split: if_splits prod.splits uncurry_splits)
   next
     case 2
     have e: "(fst (dports m) = 0 \<and> snd (dports m) = - 1) \<or> proto m = Proto TCP \<or> proto m = Proto UDP \<or> proto m = Proto L4_Protocol.SCTP"
       using o(1)
       unfolding simple_match_valid_alt Let_def
       by(clarsimp split: if_splits)
     show ?case
       using o(4) e
       by(elim disjE; simp add: option2set_def split: if_splits prod.splits uncurry_splits)
   qed
 qed
 
 lemma and_assoc: "a \<and> b \<and> c \<longleftrightarrow> (a \<and> b) \<and> c" by simp
 
 lemmas custom_simpset = Let_def set_concat set_map map_map comp_def concat_map_maps set_maps UN_iff fun_app_def Set.image_iff
 
 abbreviation "simple_fw_prefix_to_wordinterval \<equiv> prefix_to_wordinterval \<circ> uncurry PrefixMatch"
 
 lemma simple_match_port_alt: "simple_match_port m p \<longleftrightarrow> p \<in> wordinterval_to_set (uncurry WordInterval m)" by(simp split: uncurry_splits)
 
 lemma simple_match_src_alt: "simple_match_valid r \<Longrightarrow> 
 	simple_match_ip (src r) p \<longleftrightarrow> prefix_match_semantics (PrefixMatch (fst (src r)) (snd (src r))) p"
 by(cases "(src r)") (simp add: prefix_match_semantics_ipset_from_netmask2 prefix_to_wordset_ipset_from_cidr simple_match_valid_def valid_prefix_fw_def)
 lemma simple_match_dst_alt: "simple_match_valid r \<Longrightarrow> 
 	simple_match_ip (dst r) p \<longleftrightarrow> prefix_match_semantics (PrefixMatch (fst (dst r)) (snd (dst r))) p"
 by(cases "(dst r)") (simp add: prefix_match_semantics_ipset_from_netmask2 prefix_to_wordset_ipset_from_cidr simple_match_valid_def valid_prefix_fw_def)
 
 lemma "x \<in> set (wordinterval_CIDR_split_prefixmatch w) \<Longrightarrow> valid_prefix x"
 using wordinterval_CIDR_split_prefixmatch_all_valid_Ball[THEN bspec, THEN conjunct1] .
 
 lemma simple_match_to_of_matchI: 
 	assumes mv: "simple_match_valid r"
 	assumes mm: "simple_matches r p"
 	assumes ii: "p_iiface p \<in> set ifs"
 	assumes ippkt: "p_l2type p = 0x800"
 	shows eq: "\<exists>gr \<in> set (simple_match_to_of_match r ifs). OF_match_fields gr p = Some True"
 proof -
 	let ?npm = "\<lambda>p. fst p = 0 \<and> snd p = - 1"
 	let ?sb = "\<lambda>p r. (if ?npm p then None else Some r)"
 	obtain si where si: "case si of Some ssi \<Rightarrow> p_sport p \<in> prefix_to_wordset ssi | None \<Rightarrow> True"
 		"case si of None \<Rightarrow> True | Some ssi \<Rightarrow> ssi \<in> set (
 		wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r)))"
 		"si = None \<longleftrightarrow> ?npm (sports r)"
 	proof(cases "?npm (sports r)", goal_cases)
 		case 1 (* True *)
 		hence "(case None of None \<Rightarrow> True | Some ssi \<Rightarrow> p_sport p \<in> prefix_to_wordset ssi) \<and>
             (case None of None \<Rightarrow> True
             | Some ssi \<Rightarrow> ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r))))" by simp
         with 1 show ?thesis by blast
 	next
 		case 2 (* False *)
 		from mm have "p_sport p \<in> wordinterval_to_set (uncurry WordInterval (sports r))"
 			by(simp only: simple_matches.simps simple_match_port_alt)
 		then obtain ssi where ssi:
 			"ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r)))"
 			"p_sport p \<in> prefix_to_wordset ssi" 
 			using wordinterval_CIDR_split_existential by fast
 		hence "(case Some ssi of None \<Rightarrow> True | Some ssi \<Rightarrow> p_sport p \<in> prefix_to_wordset ssi) \<and>
             (case Some ssi of None \<Rightarrow> True
             | Some ssi \<Rightarrow> ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r))))" by simp
         with 2 show ?thesis by blast
     qed				
 	obtain di where di: "case di of Some ddi \<Rightarrow> p_dport p \<in> prefix_to_wordset ddi | None \<Rightarrow> True"
 		"case di of None \<Rightarrow> True | Some ddi \<Rightarrow> ddi \<in> set (
 		wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r)))"
 		"di = None \<longleftrightarrow> ?npm (dports r)"
 	proof(cases "?npm (dports r)", goal_cases)
 		case 1
 		hence "(case None of None \<Rightarrow> True | Some ssi \<Rightarrow> p_dport p \<in> prefix_to_wordset ssi) \<and>
             (case None of None \<Rightarrow> True
             | Some ssi \<Rightarrow> ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r))))" by simp
         with 1 show ?thesis by blast
 	next
 		case 2
 		from mm have "p_dport p \<in> wordinterval_to_set (uncurry WordInterval (dports r))"
 			by(simp only: simple_matches.simps simple_match_port_alt)
 		then obtain ddi where ddi:
 			"ddi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r)))"
 			"p_dport p \<in> prefix_to_wordset ddi" 
 			using wordinterval_CIDR_split_existential by fast
 		hence "(case Some ddi of None \<Rightarrow> True | Some ssi \<Rightarrow> p_dport p \<in> prefix_to_wordset ssi) \<and>
             (case Some ddi of None \<Rightarrow> True
             | Some ssi \<Rightarrow> ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r))))" by simp
         with 2 show ?thesis by blast
     qed
     show ?thesis
 	proof
 		let ?mf = "map_option (apsnd (wordNOT \<circ> mask \<circ> (-) 16) \<circ> prefix_match_dtor)"
 		let ?gr = "simple_match_to_of_match_single r
 			(if iiface r = ifaceAny then None else Some (p_iiface p)) 
 			(if proto r = ProtoAny then ProtoAny else Proto (p_proto p))
 			(?mf si) (?mf di)"
 		note mfu = simple_match_port.simps[of "fst (sports r)" "snd (sports r)", unfolded surjective_pairing[of "sports r",symmetric]]
 				   simple_match_port.simps[of "fst (dports r)" "snd (dports r)", unfolded surjective_pairing[of "dports r",symmetric]]
 		note u = mm[unfolded simple_matches.simps mfu ord_class.atLeastAtMost_iff simple_packet_unext_def simple_packet.simps]
 		note of_safe_unsafe_match_eq[OF simple_match_to_of_match_generates_prereqs]
 		from u have ple: "fst (sports r) \<le> snd (sports r)" "fst (dports r) \<le> snd (dports r)" by force+
 		show eg: "?gr \<in> set (simple_match_to_of_match r ifs)"
 			unfolding simple_match_to_of_match_def
 			unfolding custom_simpset
 			unfolding smtoms_eq_hlp
 			proof(intro bexI, (intro conjI; ((rule refl)?)), goal_cases)
 				case 2 thus ?case using ple(2) di
 					apply(simp add: pfxm_mask_def prefix_match_dtor_def Set.image_iff 
 					           split: option.splits prod.splits uncurry_splits)
 					apply(erule bexI[rotated])
 					apply(simp split: prefix_match.splits)
 				done
 			next
 				case 3 thus ?case using ple(1) si
 					apply(simp add: pfxm_mask_def prefix_match_dtor_def Set.image_iff 
 					           split: option.splits prod.splits uncurry_splits)
 					apply(erule bexI[rotated])
 					apply(simp split: prefix_match.splits)
 				done
 			next
 				case 4 thus ?case
 				  using u ii by(clarsimp simp: set_maps split: if_splits)
 			next
 				case 1 thus ?case using ii u by simp_all (metis match_proto.elims(2))  
 			qed
 		have dpm: "di = Some (PrefixMatch x1 x2) \<Longrightarrow> p_dport p && ~~ (mask (16 - x2)) = x1" for x1 x2
     proof -
       have *: "di = Some (PrefixMatch x1 x2) \<Longrightarrow> prefix_match_semantics (the di) (p_dport p) \<Longrightarrow> p_dport p && ~~ (mask (16 - x2)) = x1"
         by(clarsimp simp: prefix_match_semantics_def pfxm_mask_def word_bw_comms;fail)
       have **: "pfx \<in> set (wordinterval_CIDR_split_prefixmatch ra) \<Longrightarrow> prefix_match_semantics pfx a = (a \<in> prefix_to_wordset pfx)" for pfx ra and a :: "16 word"
         by (fact prefix_match_semantics_wordset[OF wordinterval_CIDR_split_prefixmatch_all_valid_Ball[THEN bspec, THEN conjunct1]])
       have "\<lbrakk>di = Some (PrefixMatch x1 x2); p_dport p \<in> prefix_to_wordset (PrefixMatch x1 x2); PrefixMatch x1 x2 \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r)))\<rbrakk>
              \<Longrightarrow> p_dport p && ~~ (mask (16 - x2)) = x1"
       using di(1,2)
         using * ** by auto
       thus "di = Some (PrefixMatch x1 x2) \<Longrightarrow> p_dport p && ~~ (mask (16 - x2)) = x1"  using di(1,2) by auto
     qed
 		have spm: "si = Some (PrefixMatch x1 x2) \<Longrightarrow> p_sport p && ~~ (mask (16 - x2)) = x1" for x1 x2
     using si
     proof -
       have *: "si = Some (PrefixMatch x1 x2) \<Longrightarrow> prefix_match_semantics (the si) (p_sport p) \<Longrightarrow> p_sport p && ~~ (mask (16 - x2)) = x1"
         by(clarsimp simp: prefix_match_semantics_def pfxm_mask_def word_bw_comms;fail)
       have **: "pfx \<in> set (wordinterval_CIDR_split_prefixmatch ra) \<Longrightarrow> prefix_match_semantics pfx a = (a \<in> prefix_to_wordset pfx)" for pfx ra and a :: "16 word"
         by (fact prefix_match_semantics_wordset[OF wordinterval_CIDR_split_prefixmatch_all_valid_Ball[THEN bspec, THEN conjunct1]])
       have "\<lbrakk>si = Some (PrefixMatch x1 x2); p_sport p \<in> prefix_to_wordset (PrefixMatch x1 x2); PrefixMatch x1 x2 \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r)))\<rbrakk>
              \<Longrightarrow> p_sport p && ~~ (mask (16 - x2)) = x1"
       using si(1,2)
         using * ** by auto
       thus "si = Some (PrefixMatch x1 x2) \<Longrightarrow> p_sport p && ~~ (mask (16 - x2)) = x1"  using si(1,2) by auto
     qed
 		show "OF_match_fields ?gr p = Some True"
 		unfolding of_safe_unsafe_match_eq[OF simple_match_to_of_match_generates_prereqs[OF mv eg]]
 		  by(cases si; cases di)
         (simp_all
 					add: simple_match_to_of_match_single_def OF_match_fields_unsafe_def spm
 					     option2set_def u ippkt prefix_match_dtor_def toprefixmatch_def dpm
 					     simple_match_dst_alt[OF mv, symmetric] simple_match_src_alt[OF mv, symmetric]
 					split: prefix_match.splits)
 	qed
 qed
 
 lemma prefix_match_00[simp,intro!]: "prefix_match_semantics (PrefixMatch 0 0) p"
   by (simp add: valid_prefix_def zero_prefix_match_all)
 
 lemma simple_match_to_of_matchD:
 	assumes eg: "gr \<in> set (simple_match_to_of_match r ifs)"
 	assumes mo: "OF_match_fields gr p = Some True"
 	assumes me: "match_iface (oiface r) (p_oiface p)"
 	assumes mv: "simple_match_valid r"
 	shows "simple_matches r p"
 proof -
 	from mv have validpfx: 
 		"valid_prefix (uncurry PrefixMatch (src r))" "valid_prefix (uncurry PrefixMatch (dst r))"
 		"\<And>pm. toprefixmatch (src r) = Some pm \<Longrightarrow> valid_prefix pm"
 		"\<And>pm. toprefixmatch (dst r) = Some pm \<Longrightarrow> valid_prefix pm"
 		unfolding simple_match_valid_def valid_prefix_fw_def toprefixmatch_def 
 		  by(simp_all split: uncurry_splits if_splits)
 	from mo have mo: "OF_match_fields_unsafe gr p" 
 		unfolding of_safe_unsafe_match_eq[OF simple_match_to_of_match_generates_prereqs[OF mv eg]]
 		by simp
 	note this[unfolded OF_match_fields_unsafe_def]
 	note eg[unfolded simple_match_to_of_match_def simple_match_to_of_match_single_def  custom_simpset option2set_def]
 	then guess x ..	moreover from this(2) guess xa ..	moreover from this(2) guess xb ..
 	note xx = calculation(1,3) this
 
   { fix a b xc xa
       fix pp :: "16 word"
 	  have "\<lbrakk>pp && ~~ (pfxm_mask xc) = pfxm_prefix xc\<rbrakk>
               \<Longrightarrow> prefix_match_semantics xc (pp)" for xc
       by(simp add: prefix_match_semantics_def word_bw_comms;fail)
     moreover have "pp \<in> wordinterval_to_set (WordInterval a b) \<Longrightarrow> a \<le> pp \<and> pp \<le> b" by simp
     moreover have "xc \<in> set (wordinterval_CIDR_split_prefixmatch (WordInterval a b)) \<Longrightarrow> pp \<in> prefix_to_wordset xc  \<Longrightarrow> pp \<in> wordinterval_to_set (WordInterval a b)"
 			by(subst wordinterval_CIDR_split_prefixmatch) blast
 	  moreover have "\<lbrakk>xc \<in> set (wordinterval_CIDR_split_prefixmatch (WordInterval a b)); xa = Some (pfxm_prefix xc, ~~ (pfxm_mask xc)); prefix_match_semantics xc (pp)\<rbrakk> \<Longrightarrow> pp \<in> prefix_to_wordset xc"
 			apply(subst(asm)(1) prefix_match_semantics_wordset)
 			apply(erule wordinterval_CIDR_split_prefixmatch_all_valid_Ball[THEN bspec, THEN conjunct1];fail)
 			apply assumption
 	  done
 	  ultimately have "\<lbrakk>xc \<in> set (wordinterval_CIDR_split_prefixmatch (WordInterval a b)); xa = Some (pfxm_prefix xc, ~~ (pfxm_mask xc));
                pp && ~~ (pfxm_mask xc) = pfxm_prefix xc\<rbrakk>
               \<Longrightarrow> a \<le> pp \<and> pp \<le> b"
      by metis
 	} note l4port_logic = this
 
 	show ?thesis unfolding simple_matches.simps
 	proof(unfold and_assoc, (rule)+)
 		show "match_iface (iiface r) (p_iiface p)"
 			apply(cases "iiface r = ifaceAny")
 			 apply (simp add: match_ifaceAny) 
 			using xx(1) mo unfolding xx(4) OF_match_fields_unsafe_def
 			apply(simp only: if_False set_maps UN_iff)
 			apply(clarify)
 			apply(rename_tac a; subgoal_tac "match_iface (iiface r) a")
 			 apply(clarsimp simp add: option2set_def;fail)
 			apply(rule ccontr,simp;fail)
 		done
 	next
 		show "match_iface (oiface r) (p_oiface p)" using me .
 	next
 		show "simple_match_ip (src r) (p_src p)"
 			using mo unfolding xx(4) OF_match_fields_unsafe_def toprefixmatch_def
 			by(clarsimp
 			  simp add: simple_packet_unext_def option2set_def validpfx simple_match_src_alt[OF mv] toprefixmatch_def 
 			  split: if_splits)
 	next
 		show "simple_match_ip (dst r) (p_dst p)"
 			using mo unfolding xx(4) OF_match_fields_unsafe_def toprefixmatch_def
 			by(clarsimp
 			  simp add: simple_packet_unext_def option2set_def validpfx simple_match_dst_alt[OF mv] toprefixmatch_def 
 			  split: if_splits)
  	next
 		show "match_proto (proto r) (p_proto p)"
 			using mo unfolding xx(4) OF_match_fields_unsafe_def
 			using xx(1) by(clarsimp 
 				simp add: singleton_iff simple_packet_unext_def option2set_def prefix_match_semantics_simple_match ball_Un 
 				split: if_splits protocol.splits)
 	next
 		show "simple_match_port (sports r) (p_sport p)"
 			using mo xx(2) unfolding xx(4) OF_match_fields_unsafe_def
 			by(cases "sports r") (clarsimp simp add: l4port_logic simple_packet_unext_def option2set_def prefix_match_semantics_simple_match split: if_splits)
 	next
 		show "simple_match_port (dports r) (p_dport p)" 
 		  using mo xx(3) unfolding xx(4) OF_match_fields_unsafe_def
 			by(cases "dports r") (clarsimp simp add: l4port_logic simple_packet_unext_def option2set_def prefix_match_semantics_simple_match split: if_splits)
     qed
 qed
 
 primrec annotate_rlen where
 "annotate_rlen [] = []" |
 "annotate_rlen (a#as) = (length as, a) # annotate_rlen as"
 lemma "annotate_rlen ''asdf'' = [(3, CHR ''a''), (2, CHR ''s''), (1, CHR ''d''), (0, CHR ''f'')]" by simp
 
 lemma fst_annotate_rlen_le: "(k, a) \<in> set (annotate_rlen l) \<Longrightarrow> k < length l"
 	by(induction l arbitrary: k; simp; force)
 
 lemma distinct_fst_annotate_rlen: "distinct (map fst (annotate_rlen l))"
 	using fst_annotate_rlen_le by(induction l) (simp, fastforce)
 lemma distinct_annotate_rlen: "distinct (annotate_rlen l)"
 	using distinct_fst_annotate_rlen unfolding distinct_map by blast
 lemma in_annotate_rlen: "(a,x) \<in> set (annotate_rlen l) \<Longrightarrow> x \<in> set l" 
   by(induction l) (simp_all, blast)
 lemma map_snd_annotate_rlen: "map snd (annotate_rlen l) = l"
   by(induction l) simp_all
 lemma "sorted_descending (map fst (annotate_rlen l))"
   by(induction l; clarsimp) (force dest: fst_annotate_rlen_le)
 lemma "annotate_rlen l = zip (rev [0..<length l]) l"
   by(induction l; simp) (* It would probably have been better to just use the zip, but oh well\<dots> *)
 
 primrec annotate_rlen_code where
 "annotate_rlen_code [] = (0,[])" |
 "annotate_rlen_code (a#as) = (case annotate_rlen_code as of (r,aas) \<Rightarrow> (Suc r, (r, a) # aas))"
 lemma annotate_rlen_len: "fst (annotate_rlen_code r) = length r"
 by(induction r) (clarsimp split: prod.splits)+
 lemma annotate_rlen_code[code]: "annotate_rlen s = snd (annotate_rlen_code s)"
 proof(induction s)
   case (Cons s ss) thus ?case using annotate_rlen_len[of ss] by(clarsimp split: prod.split)
 qed simp
 
 lemma suc2plus_inj_on: "inj_on (of_nat :: nat \<Rightarrow> ('l :: len) word) {0..unat (max_word :: 'l word)}"
 proof(rule inj_onI)
    let ?mmw = "(max_word :: 'l word)"
    let ?mstp = "(of_nat :: nat \<Rightarrow> 'l word)"
    fix x y :: nat
    assume "x \<in> {0..unat ?mmw}" "y \<in> {0..unat ?mmw}"
    hence se: "x \<le> unat ?mmw" "y \<le> unat ?mmw" by simp_all
    assume eq: "?mstp x = ?mstp y"
    note f = le_unat_uoi[OF se(1)] le_unat_uoi[OF se(2)]
    show "x = y" using eq le_unat_uoi se by metis
 qed
 
 lemma distinct_of_nat_list: (* TODO: Move to CaesarWordLemmaBucket *)
 	"distinct l \<Longrightarrow> \<forall>e \<in> set l. e \<le> unat (max_word :: ('l::len) word) \<Longrightarrow> distinct (map (of_nat :: nat \<Rightarrow> 'l word) l)"
 proof(induction l)
 	let ?mmw = "(max_word :: 'l word)"
 	let ?mstp = "(of_nat :: nat \<Rightarrow> 'l word)"
 	case (Cons a as)
 	have "distinct as" "\<forall>e\<in>set as. e \<le> unat ?mmw" using Cons.prems by simp_all 
 	note mIH = Cons.IH[OF this]
 	moreover have "?mstp a \<notin> ?mstp ` set as"
 	proof 
 		have representable_set: "set as \<subseteq> {0..unat ?mmw}" using \<open>\<forall>e\<in>set (a # as). e \<le> unat max_word\<close> by fastforce
 		have a_reprbl: "a \<in> {0..unat ?mmw}" using \<open>\<forall>e\<in>set (a # as). e \<le> unat max_word\<close> by simp
 		assume "?mstp a \<in> ?mstp ` set as"
 		with inj_on_image_mem_iff[OF suc2plus_inj_on a_reprbl representable_set]
 		have "a \<in> set as" by simp
 		with \<open>distinct (a # as)\<close> show False by simp
 	qed
 	ultimately show ?case by simp
 qed simp
 
 lemma annotate_first_le_hlp:
 	"length l < unat (max_word :: ('l :: len) word) \<Longrightarrow> \<forall>e\<in>set (map fst (annotate_rlen l)). e \<le> unat (max_word :: 'l word)"
 	by(clarsimp) (meson fst_annotate_rlen_le less_trans nat_less_le)
 lemmas distinct_of_prio_hlp = distinct_of_nat_list[OF distinct_fst_annotate_rlen annotate_first_le_hlp]
 (* don't need these right now, but maybe later? *)
                                                   
 lemma fst_annotate_rlen: "map fst (annotate_rlen l) = rev [0..<length l]"
 by(induction l) (simp_all)
 
 lemma sorted_word_upt:
   defines[simp]: "won \<equiv> (of_nat :: nat \<Rightarrow> ('l :: len) word)"
   assumes "length l \<le> unat (max_word :: 'l word)"
   shows "sorted_descending (map won (rev [0..<Suc (length l)]))" 
 using assms
   by(induction l rule: rev_induct;clarsimp)
     (metis (mono_tags, opaque_lifting) le_SucI le_unat_uoi of_nat_Suc order_refl word_le_nat_alt)
     (* This proof is kind of ugly. In case it breaks unfixably, go back to rev a9c4927 and get word_upto.
        The lemmas on word_upto can be used to shows this trivially. *)
 
 lemma sorted_annotated:
 	assumes "length l \<le> unat (max_word :: ('l :: len) word)"
 	shows "sorted_descending (map fst (map (apfst (of_nat :: nat \<Rightarrow> 'l word)) (annotate_rlen l)))"
 proof -
 	let ?won = "(of_nat :: nat \<Rightarrow> 'l word)"
 	have "sorted_descending (map ?won (rev [0..<Suc (length l)]))" 
 		using sorted_word_upt[OF assms] .
 	hence "sorted_descending (map ?won (map fst (annotate_rlen l)))" by(simp add: fst_annotate_rlen)
 	thus "sorted_descending (map fst (map (apfst ?won) (annotate_rlen l)))" by simp
 qed
 
 text\<open>l3 device to l2 forwarding\<close>
 definition "lr_of_tran_s3 ifs ard = (
 	[(p, b, case a of simple_action.Accept \<Rightarrow> [Forward c] | simple_action.Drop \<Rightarrow> []).
 		(p,r,(c,a)) \<leftarrow> ard, b \<leftarrow> simple_match_to_of_match r ifs])"
 
 definition "oif_ne_iif_p1 ifs \<equiv> [(simple_match_any\<lparr>oiface := Iface oif, iiface := Iface iif\<rparr>, simple_action.Accept). oif \<leftarrow> ifs, iif \<leftarrow> ifs, oif \<noteq> iif]"
 definition "oif_ne_iif_p2 ifs = [(simple_match_any\<lparr>oiface := Iface i, iiface := Iface i\<rparr>, simple_action.Drop). i \<leftarrow> ifs]"
 definition "oif_ne_iif ifs = oif_ne_iif_p2 ifs @ oif_ne_iif_p1 ifs" (* order irrelephant *)
 (*value "oif_ne_iif [''a'', ''b'']"*)
 (* I first tried something like "oif_ne_iif ifs \<equiv> [(simple_match_any\<lparr>oiface := Iface oi, iiface := Iface ii\<rparr>, if oi = ii then simple_action.Drop else simple_action.Accept). oi \<leftarrow> ifs, ii \<leftarrow> ifs]", 
    but making the statement I wanted with that was really tricky. Much easier to have the second element constant and do it separately. *)
 definition "lr_of_tran_s4 ard ifs \<equiv> generalized_fw_join ard (oif_ne_iif ifs)"
 
 definition "lr_of_tran_s1 rt = [(route2match r, output_iface (routing_action r)). r \<leftarrow> rt]"
 
 definition "lr_of_tran_fbs rt fw ifs \<equiv> let
 	gfw = map simple_rule_dtor fw; \<comment> \<open>generalized simple fw, hopefully for FORWARD\<close>
 	frt = lr_of_tran_s1 rt; \<comment> \<open>rt as fw\<close>
 	prd = generalized_fw_join frt gfw
 	in prd
 "
 
 definition "pack_OF_entries ifs ard \<equiv> (map (split3 OFEntry) (lr_of_tran_s3 ifs ard))"
 definition "no_oif_match \<equiv> list_all (\<lambda>m. oiface (match_sel m) = ifaceAny)"
 
 definition "lr_of_tran rt fw ifs \<equiv> 
   if \<not> (no_oif_match fw \<and> has_default_policy fw \<and> simple_fw_valid fw	\<and> valid_prefixes rt \<and> has_default_route rt \<and> distinct ifs)
     then Inl ''Error in creating OpenFlow table: prerequisites not satisifed''
     else (
   let	nrd = lr_of_tran_fbs rt fw ifs;
 	ard = map (apfst of_nat) (annotate_rlen nrd) \<comment> \<open>give them a priority\<close>
 	in
 	if length nrd < unat (- 1 :: 16 word)
 	then Inr (pack_OF_entries ifs ard)
 	else Inl ''Error in creating OpenFlow table: priority number space exhausted'')
 "
 
 definition "is_iface_name i \<equiv> i \<noteq> [] \<and> \<not>Iface.iface_name_is_wildcard i"
 definition "is_iface_list ifs \<equiv> distinct ifs \<and> list_all is_iface_name ifs"
 
 lemma max_16_word_max[simp]: "(a :: 16 word) \<le> 0xffff"
 proof -
 	have "0xFFFF = (- 1 :: 16 word)" by simp
 	then show ?thesis by (simp only:) simp
 qed
 
 lemma replicate_FT_hlp: "x \<le> 16 \<and> y \<le> 16 \<Longrightarrow> replicate (16 - x) False @ replicate x True = replicate (16 - y) False @ replicate y True \<Longrightarrow> x = y"
 proof -
 	let ?ns = "{0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16}"
 	assume "x \<le> 16 \<and> y \<le> 16"
 	hence "x \<in> ?ns" "y \<in> ?ns" by(simp; presburger)+
 	moreover assume "replicate (16 - x) False @ replicate x True = replicate (16 - y) False @ replicate y True"
 	ultimately show "x = y" by simp (elim disjE; simp_all add: numeral_eq_Suc) (* that's only 289 subgoals after the elim *)
 qed
 
 lemma mask_inj_hlp1: "inj_on (mask :: nat \<Rightarrow> 16 word) {0..16}"
 proof(intro inj_onI, goal_cases)
   case (1 x y)
   from 1(3)
   have oe: "of_bl (replicate (16 - x) False @ replicate x True) = (of_bl (replicate (16 - y) False @ replicate y True) :: 16 word)"
          unfolding mask_bl of_bl_rep_False .
   have "\<And>z. z \<le> 16 \<Longrightarrow> length (replicate (16 - z) False @ replicate z True) = 16" by auto
   with 1(1,2)
   have ps: "replicate (16 - x) False @ replicate x True \<in> {bl. length bl = LENGTH(16)}" " replicate (16 - y) False @ replicate y True \<in> {bl. length bl = LENGTH(16)}" by simp_all
   from inj_onD[OF word_bl.Abs_inj_on, OF oe ps]
   show ?case using 1(1,2) by(fastforce intro: replicate_FT_hlp)
 qed
 
 lemma distinct_simple_match_to_of_match_portlist_hlp: 
   fixes ps :: "(16 word \<times> 16 word)"
   shows "distinct ifs \<Longrightarrow>
     distinct
      (if fst ps = 0 \<and> snd ps = max_word then [None]
       else if fst ps \<le> snd ps
            then map (Some \<circ> (\<lambda>pfx. (pfxm_prefix pfx, ~~ (pfxm_mask pfx))))
                  (wordinterval_CIDR_split_prefixmatch (WordInterval (fst ps) (snd ps)))
            else [])"
 proof -
   assume di: "distinct ifs"
   { define wis where "wis = set (wordinterval_CIDR_split_prefixmatch (WordInterval (fst ps) (snd ps)))"
     fix x y :: "16 prefix_match"
     obtain xm xn ym yn where xyd[simp]: "x = PrefixMatch xm xn" "y = PrefixMatch ym yn" by(cases x; cases y)
     assume iw: "x \<in> wis" "y \<in> wis" and et: "(pfxm_prefix x, ~~ (pfxm_mask x)) = (pfxm_prefix y, ~~ (pfxm_mask y))"
     hence le16: "xn \<le> 16" "yn \<le> 16" unfolding wis_def using wordinterval_CIDR_split_prefixmatch_all_valid_Ball[unfolded Ball_def, THEN spec, THEN mp] by force+
     with et have "16 - xn = 16 - yn" unfolding pfxm_mask_def by(auto intro: mask_inj_hlp1[THEN inj_onD])
     hence "x = y" using et le16 using diff_diff_cancel by simp
   } note * = this
   show ?thesis 
     apply(clarsimp simp add: smtoms_eq_hlp distinct_map wordinterval_CIDR_split_distinct)
     apply(subst comp_inj_on_iff[symmetric]; intro inj_onI)
   using * by simp_all
 qed
 
 lemma distinct_simple_match_to_of_match: "distinct ifs \<Longrightarrow> distinct (simple_match_to_of_match m ifs)"
   apply(unfold simple_match_to_of_match_def Let_def)
   apply(rule distinct_3lcomprI)
   subgoal by(induction ifs; clarsimp)
   subgoal by(fact distinct_simple_match_to_of_match_portlist_hlp)
   subgoal by(fact distinct_simple_match_to_of_match_portlist_hlp)
   subgoal by(simp_all add: smtoms_eq_hlp)
 done
 
 lemma inj_inj_on: "inj F \<Longrightarrow> inj_on F A" using subset_inj_on by auto (* TODO: include Word_Lib *)
 
 lemma no_overlaps_lroft_hlp2: "distinct (map fst amr) \<Longrightarrow> (\<And>r. distinct (fm r)) \<Longrightarrow>
     distinct (concat (map (\<lambda>(p, r, c, a). map (\<lambda>b. (p, b, fs a c)) (fm r)) amr))"
   by(induction amr; force intro: injI inj_onI simp add: distinct_map split: prod.splits)
 
 lemma distinct_lroft_s3: "\<lbrakk>distinct (map fst amr); distinct ifs\<rbrakk> \<Longrightarrow> distinct (lr_of_tran_s3 ifs amr)"
   unfolding lr_of_tran_s3_def
   by(erule no_overlaps_lroft_hlp2, simp add: distinct_simple_match_to_of_match)
 
 lemma no_overlaps_lroft_hlp3: "distinct (map fst amr) \<Longrightarrow>
 (aa, ab, ac) \<in> set (lr_of_tran_s3 ifs amr) \<Longrightarrow> (ba, bb, bc) \<in> set (lr_of_tran_s3 ifs amr) \<Longrightarrow>
 ac \<noteq> bc \<Longrightarrow> aa \<noteq> ba"
   apply(unfold lr_of_tran_s3_def)
   apply(clarsimp)
   apply(clarsimp split: simple_action.splits)
     apply(metis map_of_eq_Some_iff old.prod.inject option.inject)
    apply(metis map_of_eq_Some_iff old.prod.inject option.inject simple_action.distinct(2))+
 done
 
 lemma no_overlaps_lroft_s3_hlp_hlp: (* I hlps *)
   "\<lbrakk>distinct (map fst amr); OF_match_fields_unsafe ab p; ab \<noteq> ad \<or> ba \<noteq> bb; OF_match_fields_unsafe ad p;
         (ac, ab, ba) \<in> set (lr_of_tran_s3 ifs amr); (ac, ad, bb) \<in> set (lr_of_tran_s3 ifs amr)\<rbrakk>
        \<Longrightarrow> False"
 proof(elim disjE, goal_cases)
   case 1
   have 4: "\<lbrakk>distinct (map fst amr);  (ac, ab, x1, x2) \<in> set amr; (ac, bb, x4, x5) \<in> set amr; ab \<noteq> bb\<rbrakk>
        \<Longrightarrow> False" for ab x1 x2 bb x4 x5
        by (meson distinct_map_fstD old.prod.inject)
   have conjunctSomeProtoAnyD: "Some ProtoAny = simple_proto_conjunct a (Proto b) \<Longrightarrow> False" for a b
     using conjunctProtoD by force
   have 5:
        "\<lbrakk>OF_match_fields_unsafe am p; OF_match_fields_unsafe bm p; am \<noteq> bm; 
         am \<in> set (simple_match_to_of_match ab ifs); bm \<in> set (simple_match_to_of_match bb ifs); \<not> ab \<noteq> bb\<rbrakk>
        \<Longrightarrow> False" for ab bb am bm
       by(clarify | unfold
          simple_match_to_of_match_def smtoms_eq_hlp Let_def set_concat set_map de_Morgan_conj not_False_eq_True)+
         (auto dest: conjunctSomeProtoAnyD cidrsplit_no_overlaps
 	            simp add: OF_match_fields_unsafe_def simple_match_to_of_match_single_def option2set_def comp_def
 	            split: if_splits
 	            cong: smtoms_eq_hlp) (*1min*)
   from 1 show ?case
   using 4 5 by(clarsimp simp add: lr_of_tran_s3_def) blast
 qed(metis no_overlaps_lroft_hlp3)
 
 
 lemma no_overlaps_lroft_s3_hlp: "distinct (map fst amr) \<Longrightarrow> distinct ifs \<Longrightarrow> 
 no_overlaps OF_match_fields_unsafe (map (split3 OFEntry) (lr_of_tran_s3 ifs amr))"
   apply(rule no_overlapsI[rotated])
   apply(subst distinct_map, rule conjI)
   subgoal by(erule (1) distinct_lroft_s3)
   subgoal
     apply(rule inj_inj_on)
     apply(rule injI)
     apply(rename_tac x y, case_tac x, case_tac y)
     apply(simp add: split3_def;fail)
   done
   subgoal
     apply(unfold check_no_overlap_def)
     apply(clarify)
     apply(unfold set_map)
     apply(clarify)
     apply(unfold split3_def prod.simps flow_entry_match.simps flow_entry_match.sel de_Morgan_conj)
     apply(clarsimp simp only:)
     apply(erule (1) no_overlaps_lroft_s3_hlp_hlp)
        apply simp
       apply assumption
      apply assumption
     apply simp
   done
 done
 
 lemma lr_of_tran_no_overlaps: assumes "distinct ifs" shows "Inr t = (lr_of_tran rt fw ifs) \<Longrightarrow> no_overlaps OF_match_fields_unsafe t"
 	apply(unfold lr_of_tran_def Let_def pack_OF_entries_def)
 	apply(simp split: if_splits)
 	apply(thin_tac "t = _")
 	apply(drule distinct_of_prio_hlp)
 	apply(rule no_overlaps_lroft_s3_hlp[rotated])
 	subgoal by(simp add: assms)
 	subgoal by(simp add: o_assoc)
 done
 
 lemma sorted_lr_of_tran_s3_hlp: "\<forall>x\<in>set f. fst x \<le> a \<Longrightarrow> b \<in> set (lr_of_tran_s3 s f) \<Longrightarrow> fst b \<le> a" 
 	by(auto simp add: lr_of_tran_s3_def)
 
 lemma lr_of_tran_s3_Cons: "lr_of_tran_s3 ifs (a#ard) = (
 	[(p, b, case a of simple_action.Accept \<Rightarrow> [Forward c] | simple_action.Drop \<Rightarrow> []).
 		(p,r,(c,a)) \<leftarrow> [a], b \<leftarrow> simple_match_to_of_match r ifs]) @ lr_of_tran_s3 ifs ard"
 	by(clarsimp simp: lr_of_tran_s3_def)
 
 lemma sorted_lr_of_tran_s3: "sorted_descending (map fst f) \<Longrightarrow> sorted_descending (map fst (lr_of_tran_s3 s f))"
 	apply(induction f)
 	 subgoal by(simp add: lr_of_tran_s3_def)
 	apply(clarsimp simp: lr_of_tran_s3_Cons map_concat comp_def)
 	apply(unfold sorted_descending_append)
 	apply(simp add: sorted_descending_alt rev_map sorted_lr_of_tran_s3_hlp sorted_const)
 done
 
 lemma sorted_lr_of_tran_hlp: "(ofe_prio \<circ> split3 OFEntry) = fst" by(simp add: fun_eq_iff comp_def split3_def)
 
 lemma lr_of_tran_sorted_descending: "Inr r = lr_of_tran rt fw ifs \<Longrightarrow> sorted_descending (map ofe_prio r)"
 	apply(unfold lr_of_tran_def Let_def)
 	apply(simp split: if_splits)
 	apply(thin_tac "r = _")
 	apply(unfold sorted_lr_of_tran_hlp pack_OF_entries_def split3_def[abs_def] fun_app_def map_map comp_def prod.case_distrib)
 	apply(simp add: fst_def[symmetric])
 	apply(rule sorted_lr_of_tran_s3)
 	apply(drule sorted_annotated[OF less_or_eq_imp_le, OF disjI1])
 	apply(simp add: o_assoc)
 done
 
 lemma lr_of_tran_s1_split: "lr_of_tran_s1 (a # rt) = (route2match a, output_iface (routing_action a)) # lr_of_tran_s1 rt"
 	by(unfold lr_of_tran_s1_def list.map, rule)
 
 lemma route2match_correct: "valid_prefix (routing_match a) \<Longrightarrow> prefix_match_semantics (routing_match a) (p_dst p) \<longleftrightarrow> simple_matches (route2match a) (p)"
 by(simp add: route2match_def simple_matches.simps match_ifaceAny match_iface_refl ipset_from_cidr_0 prefix_match_semantics_ipset_from_netmask2)
 
 lemma s1_correct: "valid_prefixes rt \<Longrightarrow> has_default_route (rt::('i::len) prefix_routing) \<Longrightarrow> 
   \<exists>rm ra. generalized_sfw (lr_of_tran_s1 rt) p = Some (rm,ra) \<and> ra = output_iface (routing_table_semantics rt (p_dst p))"
 	apply(induction rt)
 	 apply(simp;fail)
 	apply(drule valid_prefixes_split)
 	apply(clarsimp)
 	apply(erule disjE)
 	subgoal for a rt
 	 apply(case_tac a)
 	 apply(rename_tac routing_m metric routing_action)
 	 apply(case_tac routing_m)
 	 apply(simp add: valid_prefix_def pfxm_mask_def prefix_match_semantics_def generalized_sfw_def 
 	       lr_of_tran_s1_def route2match_def simple_matches.simps match_ifaceAny match_iface_refl ipset_from_cidr_0
 	       max_word_mask[where 'a = 'i, symmetric, simplified])
 	done
 	subgoal
     apply(rule conjI)
      apply(simp add: generalized_sfw_def lr_of_tran_s1_def route2match_correct;fail)
     apply(simp add: route2match_def simple_matches.simps prefix_match_semantics_ipset_from_netmask2 
                     lr_of_tran_s1_split generalized_sfw_simps)
   done
 done
 
 definition "to_OF_action a \<equiv> (case a of (p,d) \<Rightarrow> (case d of simple_action.Accept \<Rightarrow> [Forward p] | simple_action.Drop \<Rightarrow> []))"
 definition "from_OF_action a = (case a of [] \<Rightarrow> ('''',simple_action.Drop) | [Forward p] \<Rightarrow> (p, simple_action.Accept))"
 
 lemma OF_match_linear_not_noD: "OF_match_linear \<gamma> oms p \<noteq> NoAction \<Longrightarrow> \<exists>ome. ome \<in> set oms \<and> \<gamma> (ofe_fields ome) p"
 	apply(induction oms)
 	 apply(simp)
 	apply(simp split: if_splits)
 	 apply blast+
 done
 
 lemma s3_noaction_hlp: "\<lbrakk>simple_match_valid ac; \<not>simple_matches ac p; match_iface (oiface ac) (p_oiface p)\<rbrakk> \<Longrightarrow> 
 OF_match_linear OF_match_fields_safe (map (\<lambda>x. split3 OFEntry (x1, x, case ba of simple_action.Accept \<Rightarrow> [Forward ad] | simple_action.Drop \<Rightarrow> [])) (simple_match_to_of_match ac ifs)) p = NoAction"
   apply(rule ccontr)
   apply(drule OF_match_linear_not_noD)
   apply(clarsimp)
   apply(rename_tac x)
   apply(subgoal_tac "all_prerequisites x")
    apply(drule simple_match_to_of_matchD)
       apply(simp add: split3_def)
       apply(subst(asm) of_match_fields_safe_eq2)
       apply(simp;fail)+
   using simple_match_to_of_match_generates_prereqs by blast
 
 lemma aux:
   \<open>v = Some x \<Longrightarrow> the v = x\<close>
   by simp
 
 lemma s3_correct:
 	assumes vsfwm: "list_all simple_match_valid (map (fst \<circ> snd) ard)"
 	assumes ippkt: "p_l2type p = 0x800"
 	assumes iiifs: "p_iiface p \<in> set ifs"
 	assumes oiifs: "list_all (\<lambda>m. oiface (fst (snd m)) = ifaceAny) ard"
 	shows "OF_match_linear OF_match_fields_safe (pack_OF_entries ifs ard) p = Action ao \<longleftrightarrow> (\<exists>r af. generalized_sfw (map snd ard) p = (Some (r,af)) \<and> (if snd af = simple_action.Drop then ao = [] else ao = [Forward (fst af)]))"
 unfolding pack_OF_entries_def lr_of_tran_s3_def fun_app_def
 using vsfwm oiifs
   apply(induction ard)
    subgoal by(simp add: generalized_sfw_simps)
   apply simp
   apply(clarsimp simp add: generalized_sfw_simps split: prod.splits)
   apply(intro conjI) (* make two subgoals from one *)
    subgoal for ard x1 ac ad ba
     apply(clarsimp simp add: OF_match_linear_append split: prod.splits)
     apply(drule simple_match_to_of_matchI[rotated])
        apply(rule iiifs)
       apply(rule ippkt)
      apply blast
     apply(clarsimp simp add: comp_def)
     apply(drule 
        OF_match_linear_match_allsameaction[where
          \<gamma>=OF_match_fields_safe and pri = x1 and
          oms = "simple_match_to_of_match ac ifs" and 
          act = "case ba of simple_action.Accept \<Rightarrow> [Forward ad] | simple_action.Drop \<Rightarrow> []"])
      apply(unfold OF_match_fields_safe_def comp_def)
      apply(erule aux)
     apply(clarsimp)
     apply(intro iffI)
     subgoal
      apply(rule exI[where x = ac])
      apply(rule exI[where x = ad])
      apply(rule exI[where x = ba])
      apply(clarsimp simp: split3_def split: simple_action.splits flowtable_behavior.splits if_splits)
     done
     subgoal
      apply(clarsimp)
      apply(rename_tac b)
      apply(case_tac b)
      apply(simp_all)
    done
   done
   subgoal for ard x1 ac ad ba
    apply(simp add: OF_match_linear_append OF_match_fields_safe_def comp_def)
    apply(clarify)
    apply(subgoal_tac "OF_match_linear OF_match_fields_safe (map (\<lambda>x. split3 OFEntry (x1, x, case ba of simple_action.Accept \<Rightarrow> [Forward ad] | simple_action.Drop \<Rightarrow> [])) (simple_match_to_of_match ac ifs)) p = NoAction")
     apply(simp;fail)
    apply(erule (1) s3_noaction_hlp)
    apply(simp add: match_ifaceAny;fail)
   done
 done
 
 context
   notes valid_prefix_00[simp, intro!]
 begin
   lemma lr_of_tran_s1_valid: "valid_prefixes rt \<Longrightarrow> gsfw_valid (lr_of_tran_s1 rt)"
     unfolding lr_of_tran_s1_def route2match_def gsfw_valid_def list_all_iff
     apply(clarsimp simp: simple_match_valid_def valid_prefix_fw_def)
     apply(intro conjI)
      apply force
     apply(simp add: valid_prefixes_alt_def)
   done
 end
 
 lemma simple_match_valid_fbs_rlen: "\<lbrakk>valid_prefixes rt; simple_fw_valid fw; (a, aa, ab, b) \<in> set (annotate_rlen (lr_of_tran_fbs rt fw ifs))\<rbrakk> \<Longrightarrow> simple_match_valid aa"
 proof(goal_cases)
   case 1
   note 1[unfolded lr_of_tran_fbs_def Let_def]
   have "gsfw_valid (map simple_rule_dtor fw)" using gsfw_validI 1 by blast
   moreover have "gsfw_valid (lr_of_tran_s1 rt)" using 1 lr_of_tran_s1_valid by blast
   ultimately have "gsfw_valid (generalized_fw_join (lr_of_tran_s1 rt) (map simple_rule_dtor fw))" using gsfw_join_valid by blast
   moreover have "(aa, ab, b) \<in> set (lr_of_tran_fbs rt fw ifs)" using 1 using in_annotate_rlen by fast
   ultimately show ?thesis unfolding lr_of_tran_fbs_def Let_def gsfw_valid_def list_all_iff by fastforce
 qed
 
 lemma simple_match_valid_fbs: "\<lbrakk>valid_prefixes rt; simple_fw_valid fw\<rbrakk> \<Longrightarrow> list_all simple_match_valid (map fst (lr_of_tran_fbs rt fw ifs))"
 proof(goal_cases)
   case 1
   note 1[unfolded lr_of_tran_fbs_def Let_def]
   have "gsfw_valid (map simple_rule_dtor fw)" using gsfw_validI 1 by blast
   moreover have "gsfw_valid (lr_of_tran_s1 rt)" using 1 lr_of_tran_s1_valid by blast
   ultimately have "gsfw_valid (generalized_fw_join (lr_of_tran_s1 rt) (map simple_rule_dtor fw))" using gsfw_join_valid by blast
   thus ?thesis unfolding lr_of_tran_fbs_def Let_def gsfw_valid_def list_all_iff by fastforce
 qed
 
 lemma lr_of_tran_prereqs: "valid_prefixes rt \<Longrightarrow> simple_fw_valid fw \<Longrightarrow> lr_of_tran rt fw ifs = Inr oft \<Longrightarrow>
 list_all (all_prerequisites \<circ> ofe_fields) oft"
 unfolding lr_of_tran_def pack_OF_entries_def lr_of_tran_s3_def Let_def
   apply(simp add: map_concat comp_def prod.case_distrib split3_def split: if_splits)
   apply(simp add: list_all_iff)
   apply(clarsimp)
   apply(drule simple_match_valid_fbs_rlen[rotated])
     apply(simp add: list_all_iff;fail)
    apply(simp add: list_all_iff;fail)
   apply(rule simple_match_to_of_match_generates_prereqs; assumption)
 done
 
 (* TODO: move. where? *)
 lemma OF_unsafe_safe_match3_eq: "
   list_all (all_prerequisites \<circ> ofe_fields) oft \<Longrightarrow>
   OF_priority_match OF_match_fields_unsafe oft = OF_priority_match OF_match_fields_safe oft"
 unfolding OF_priority_match_def[abs_def]
 proof(goal_cases)
   case 1
   from 1 have "\<And>packet. [f\<leftarrow>oft . OF_match_fields_unsafe (ofe_fields f) packet] = [f\<leftarrow>oft . OF_match_fields_safe (ofe_fields f) packet]"
     apply(clarsimp simp add: list_all_iff of_match_fields_safe_eq) 
   using of_match_fields_safe_eq by(metis (mono_tags, lifting) filter_cong)
   thus ?case by metis
 qed
 
 lemma OF_unsafe_safe_match_linear_eq: "
   list_all (all_prerequisites \<circ> ofe_fields) oft \<Longrightarrow>
   OF_match_linear OF_match_fields_unsafe oft = OF_match_linear OF_match_fields_safe oft"
 unfolding fun_eq_iff
 by(induction oft) (clarsimp simp add: list_all_iff of_match_fields_safe_eq)+
 
 lemma simple_action_ne[simp]: 
   "b \<noteq> simple_action.Accept \<longleftrightarrow> b = simple_action.Drop"
   "b \<noteq> simple_action.Drop \<longleftrightarrow> b = simple_action.Accept"
 using simple_action.exhaust by blast+
 
 lemma map_snd_apfst: "map snd (map (apfst x) l) = map snd l"
   unfolding map_map comp_def snd_apfst ..
 
 lemma match_ifaceAny_eq: "oiface m = ifaceAny \<Longrightarrow> simple_matches m p = simple_matches m (p\<lparr>p_oiface := any\<rparr>)"
 by(cases m) (simp add: simple_matches.simps match_ifaceAny)
 lemma no_oif_matchD: "no_oif_match fw \<Longrightarrow> simple_fw fw p = simple_fw fw (p\<lparr>p_oiface := any\<rparr>)"
   by(induction fw)
     (auto simp add: no_oif_match_def simple_fw_alt dest: match_ifaceAny_eq)
 
 lemma lr_of_tran_fbs_acceptD:
   assumes s1: "valid_prefixes rt" "has_default_route rt"
   assumes s2: "no_oif_match fw"
   shows "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Accept) \<Longrightarrow>
   simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>)"
 proof(goal_cases)
   case 1
   note 1[unfolded lr_of_tran_fbs_def Let_def, THEN generalized_fw_joinD]
   then guess r1 .. then guess r2 .. note r12 = this
   note s1_correct[OF s1, of p]
   then guess rm .. then guess ra .. note rmra = this
   from r12 rmra have oifra: "oif = ra" by simp
   from r12 have sfw: "simple_fw fw p = Decision FinalAllow" using simple_fw_iff_generalized_fw_accept by blast
   note ifupdateirrel = no_oif_matchD[OF s2, where any = " output_iface (routing_table_semantics rt (p_dst p))" and p = p, symmetric]
   show ?case unfolding simple_linux_router_nol12_def by(simp add: Let_def ifupdateirrel sfw oifra rmra split: Option.bind_splits option.splits) 
 qed
 
 lemma lr_of_tran_fbs_acceptI:
   assumes s1: "valid_prefixes rt" "has_default_route rt"
   assumes s2: "no_oif_match fw" "has_default_policy fw"
   shows "simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>) \<Longrightarrow>
   \<exists>r. generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Accept)"
 proof(goal_cases)
   from s2 have nud: "\<And>p. simple_fw fw p \<noteq> Undecided" by (metis has_default_policy state.distinct(1))
   note ifupdateirrel = no_oif_matchD[OF s2(1), symmetric]
   case 1
   from 1 have "simple_fw fw p = Decision FinalAllow" by(simp add: simple_linux_router_nol12_def Let_def nud ifupdateirrel split: Option.bind_splits state.splits final_decision.splits)
   then obtain r where r: "generalized_sfw (map simple_rule_dtor fw) p = Some (r, simple_action.Accept)" using simple_fw_iff_generalized_fw_accept by blast
   have oif_def: "oif = output_iface (routing_table_semantics rt (p_dst p))" using 1 by(cases p) (simp add: simple_linux_router_nol12_def Let_def nud ifupdateirrel split: Option.bind_splits state.splits final_decision.splits)
   note s1_correct[OF s1, of p] then guess rm .. then guess ra .. note rmra = this
   show ?case unfolding lr_of_tran_fbs_def Let_def
     apply(rule exI)
     apply(rule generalized_fw_joinI)
     unfolding oif_def using rmra apply simp
     apply(rule r)
   done
 qed
 
 lemma lr_of_tran_fbs_dropD:
   assumes s1: "valid_prefixes rt" "has_default_route rt"
   assumes s2: "no_oif_match fw"
   shows "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Drop) \<Longrightarrow>
   simple_linux_router_nol12 rt fw p = None"
 proof(goal_cases)
   note ifupdateirrel = no_oif_matchD[OF s2(1), symmetric]
   case 1
   from 1[unfolded lr_of_tran_fbs_def Let_def, THEN generalized_fw_joinD]
   obtain rr fr where "generalized_sfw (lr_of_tran_s1 rt) p = Some (rr, oif) \<and>
           generalized_sfw (map simple_rule_dtor fw) p = Some (fr, simple_action.Drop) \<and> Some r = simple_match_and rr fr" by presburger
   hence fd: "\<And>u. simple_fw fw (p\<lparr>p_oiface := u\<rparr>) = Decision FinalDeny" unfolding ifupdateirrel
   using simple_fw_iff_generalized_fw_drop by blast
   show ?thesis
     by(clarsimp simp: simple_linux_router_nol12_def Let_def fd split: Option.bind_splits)
 qed
 
 lemma lr_of_tran_fbs_dropI:
   assumes s1: "valid_prefixes rt" "has_default_route rt"
   assumes s2: "no_oif_match fw" "has_default_policy fw"
   shows "simple_linux_router_nol12 rt fw p = None \<Longrightarrow>
   \<exists>r oif. generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Drop)"
 proof(goal_cases)
   from s2 have nud: "\<And>p. simple_fw fw p \<noteq> Undecided" by (metis has_default_policy state.distinct(1))
   note ifupdateirrel = no_oif_matchD[OF s2(1), symmetric]
   case 1
   from 1 have "simple_fw fw p = Decision FinalDeny" by(simp add: simple_linux_router_nol12_def Let_def nud ifupdateirrel split: Option.bind_splits state.splits final_decision.splits)
   then obtain r where r: "generalized_sfw (map simple_rule_dtor fw) p = Some (r, simple_action.Drop)" using simple_fw_iff_generalized_fw_drop by blast
   note s1_correct[OF s1, of p] then guess rm .. then guess ra .. note rmra = this
   show ?case unfolding lr_of_tran_fbs_def Let_def
     apply(rule exI)
     apply(rule exI[where x = ra])
     apply(rule generalized_fw_joinI)
     using rmra apply simp
     apply(rule r)
   done
 qed
 
 
 lemma no_oif_match_fbs:
  "no_oif_match fw \<Longrightarrow> list_all (\<lambda>m. oiface (fst (snd m)) = ifaceAny) (map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs)))"
 proof(goal_cases)
   case 1
   have c: "\<And>mr ar mf af f a. \<lbrakk>(mr, ar) \<in> set (lr_of_tran_s1 rt); (mf, af) \<in> simple_rule_dtor ` set fw; simple_match_and mr mf = Some a\<rbrakk> \<Longrightarrow> oiface a = ifaceAny"
   proof(goal_cases)
     case (1 mr ar mf af f a)
     have "oiface mr = ifaceAny" using 1(1) unfolding lr_of_tran_s1_def route2match_def by(clarsimp simp add: Set.image_iff)
     moreover have "oiface mf = ifaceAny" using 1(2) \<open>no_oif_match fw\<close> unfolding no_oif_match_def simple_rule_dtor_def[abs_def]
       by(clarsimp simp: list_all_iff split: simple_rule.splits) fastforce 
     ultimately show ?case using 1(3) by(cases a; cases mr; cases mf) (simp add: iface_conjunct_ifaceAny split: option.splits)
   qed
   have la: "list_all (\<lambda>m. oiface (fst m) = ifaceAny) (lr_of_tran_fbs rt fw ifs)"
     unfolding lr_of_tran_fbs_def Let_def list_all_iff
     apply(clarify)
     apply(subst(asm) generalized_sfw_join_set)
     apply(clarsimp)
   using c by blast
   thus ?case
   proof(goal_cases)
     case 1
     have *: "(\<lambda>m. oiface (fst (snd m)) = ifaceAny) = (\<lambda>m. oiface (fst m) = ifaceAny) \<circ> snd" unfolding comp_def ..
     show ?case unfolding * list_all_map[symmetric] map_snd_apfst map_snd_annotate_rlen using la .
   qed
 qed
 
 
 lemma lr_of_tran_correct:
 	fixes p :: "(32, 'a) simple_packet_ext_scheme"
 assumes nerr: "lr_of_tran rt fw ifs = Inr oft"
 	 and ippkt: "p_l2type p = 0x800"
 	 and ifvld: "p_iiface p \<in> set ifs"
 	shows "OF_priority_match OF_match_fields_safe oft p = Action [Forward oif] \<longleftrightarrow> simple_linux_router_nol12 rt fw p = (Some (p\<lparr>p_oiface := oif\<rparr>))"
 	      "OF_priority_match OF_match_fields_safe oft p = Action [] \<longleftrightarrow> simple_linux_router_nol12 rt fw p = None"
 	      (* fun stuff: *)
 	      "OF_priority_match OF_match_fields_safe oft p \<noteq> NoAction" "OF_priority_match OF_match_fields_safe oft p \<noteq> Undefined"
 	      "OF_priority_match OF_match_fields_safe oft p = Action ls \<longrightarrow> length ls \<le> 1"
 	      "\<exists>ls. length ls \<le> 1 \<and> OF_priority_match OF_match_fields_safe oft p = Action ls"
 proof -
 	have s1: "valid_prefixes rt" "has_default_route rt" 
    and s2: "has_default_policy fw" "simple_fw_valid fw" "no_oif_match fw"
    and difs: "distinct ifs"
 	  using nerr unfolding lr_of_tran_def by(simp_all split: if_splits)
   have "no_oif_match fw" using nerr unfolding lr_of_tran_def by(simp split: if_splits)
   note s2 = s2 this
   have unsafe_safe_eq: 
     "OF_priority_match OF_match_fields_unsafe oft = OF_priority_match OF_match_fields_safe oft"
     "OF_match_linear OF_match_fields_unsafe oft = OF_match_linear OF_match_fields_safe oft"
     apply(subst OF_unsafe_safe_match3_eq; (rule lr_of_tran_prereqs s1 s2 nerr refl)+)
     apply(subst OF_unsafe_safe_match_linear_eq; (rule lr_of_tran_prereqs s1 s2 nerr refl)+)
   done
   have lin: "OF_priority_match OF_match_fields_safe oft = OF_match_linear OF_match_fields_safe oft"
     using OF_eq[OF lr_of_tran_no_overlaps lr_of_tran_sorted_descending, OF difs nerr[symmetric] nerr[symmetric]] unfolding fun_eq_iff unsafe_safe_eq by metis
   let ?ard = "map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs))"
   have oft_def: "oft = pack_OF_entries ifs ?ard" using nerr unfolding lr_of_tran_def Let_def by(simp split: if_splits)
   have vld: "list_all simple_match_valid (map (fst \<circ> snd) ?ard)"
     unfolding fun_app_def map_map[symmetric] snd_apfst map_snd_apfst map_snd_annotate_rlen using simple_match_valid_fbs[OF s1(1) s2(2)] .
   have *: "list_all (\<lambda>m. oiface (fst (snd m)) = ifaceAny) ?ard" using no_oif_match_fbs[OF s2(3)] .
   have not_undec: "\<And>p. simple_fw fw p \<noteq> Undecided" by (metis has_default_policy s2(1) state.simps(3))
   have w1_1: "\<And>oif. OF_match_linear OF_match_fields_safe oft p = Action [Forward oif] \<Longrightarrow> simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>) 
     \<and> oif = output_iface (routing_table_semantics rt (p_dst p))"
   proof(intro conjI, goal_cases)
     case (1 oif)
     note s3_correct[OF vld ippkt ifvld(1) *, THEN iffD1, unfolded oft_def[symmetric], OF 1]
     hence "\<exists>r. generalized_sfw (map snd (map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs)))) p = Some (r, (oif, simple_action.Accept))"
       by(clarsimp split: if_splits)
     then obtain r where "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, (oif, simple_action.Accept))" 
       unfolding map_map comp_def snd_apfst map_snd_annotate_rlen by blast
     thus ?case using lr_of_tran_fbs_acceptD[OF s1 s2(3)] by metis
     thus "oif = output_iface (routing_table_semantics rt (p_dst p))"
       by(cases p) (clarsimp simp: simple_linux_router_nol12_def Let_def not_undec split: Option.bind_splits state.splits final_decision.splits) 
   qed
   have w1_2: "\<And>oif. simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>) \<Longrightarrow> OF_match_linear OF_match_fields_safe oft p = Action [Forward oif]"
   proof(goal_cases)
     case (1 oif)
     note lr_of_tran_fbs_acceptI[OF s1 s2(3) s2(1) this, of ifs] then guess r .. note r = this
     hence "generalized_sfw (map snd (map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs)))) p = Some (r, (oif, simple_action.Accept))" 
     unfolding map_snd_apfst map_snd_annotate_rlen .
     moreover note s3_correct[OF vld ippkt ifvld(1) *, THEN iffD2, unfolded oft_def[symmetric], of "[Forward oif]"]
     ultimately show ?case by simp
   qed
   show w1: "\<And>oif. (OF_priority_match OF_match_fields_safe oft p = Action [Forward oif]) = (simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>))"
     unfolding lin using w1_1 w1_2 by blast
   show w2: "(OF_priority_match OF_match_fields_safe oft p = Action []) = (simple_linux_router_nol12 rt fw p = None)"
   unfolding lin
   proof(rule iffI, goal_cases)
     case 1
     note s3_correct[OF vld ippkt ifvld(1) *, THEN iffD1, unfolded oft_def[symmetric], OF 1]
     then obtain r oif where roif: "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Drop)"
       unfolding map_snd_apfst map_snd_annotate_rlen by(clarsimp split: if_splits)
     note lr_of_tran_fbs_dropD[OF s1 s2(3) this]
     thus ?case .
   next
     case 2 
     note lr_of_tran_fbs_dropI[OF s1 s2(3) s2(1) this, of ifs] then 
     obtain r oif where "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Drop)" by blast
     hence "generalized_sfw (map snd (map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs)))) p = Some (r, oif, simple_action.Drop)" 
       unfolding map_snd_apfst map_snd_annotate_rlen .
     moreover note s3_correct[OF vld ippkt ifvld(1) *, THEN iffD2, unfolded oft_def[symmetric], of "[]"]
     ultimately show ?case by force
   qed
   have lr_determ: "\<And>a. simple_linux_router_nol12 rt fw p = Some a \<Longrightarrow> a = p\<lparr>p_oiface := output_iface (routing_table_semantics rt (p_dst p))\<rparr>"
     by(clarsimp simp: simple_linux_router_nol12_def Let_def not_undec split: Option.bind_splits state.splits final_decision.splits)
   show notno: "OF_priority_match OF_match_fields_safe oft p \<noteq> NoAction"
     apply(cases "simple_linux_router_nol12 rt fw p")
     using w2 apply(simp)
     using w1[of "output_iface (routing_table_semantics rt (p_dst p))"] apply(simp)
     apply(drule lr_determ)
     apply(simp)
   done
   show notub: "OF_priority_match OF_match_fields_safe oft p \<noteq> Undefined" unfolding lin using OF_match_linear_ne_Undefined .
   show notmult: "\<And>ls. OF_priority_match OF_match_fields_safe oft p = Action ls \<longrightarrow> length ls \<le> 1"
   apply(cases "simple_linux_router_nol12 rt fw p")
     using w2 apply(simp)
     using w1[of "output_iface (routing_table_semantics rt (p_dst p))"] apply(simp)
     apply(drule lr_determ)
     apply(clarsimp)
   done
   show "\<exists>ls. length ls \<le> 1 \<and> OF_priority_match OF_match_fields_safe oft p = Action ls"
     apply(cases "OF_priority_match OF_match_fields_safe oft p")
     using notmult apply blast
     using notno   apply blast
     using notub   apply blast
   done
 qed
 
 end
diff --git a/thys/LOFT/ROOT b/thys/LOFT/ROOT
--- a/thys/LOFT/ROOT
+++ b/thys/LOFT/ROOT
@@ -1,27 +1,29 @@
 chapter AFP
 
 session LOFT (AFP) = Iptables_Semantics +
   options [timeout = 1200]
+  sessions
+    "Pure-ex"
   directories
     "Examples/OF_conv_test"
     "Examples/RFC2544"
   theories [document = false]
     OpenFlow_Helpers (* just some helper lemmas *)
     List_Group
     Sort_Descending
   theories
     OpenFlow_Action
     OpenFlow_Matches
     OpenFlow_Serialize
     Semantics_OpenFlow
     Featherweight_OpenFlow_Comparison
     LinuxRouter_OpenFlow_Translation
     "Examples/OF_conv_test/OF_conv_test"
     "Examples/RFC2544/RFC2544"
     OpenFlow_Documentation
   document_files
     "root.tex"
     "chap3.tex"
     "root.bib"
     "moeptikz.sty"
     "bench.csv"
diff --git a/thys/Landau_Symbols/Landau_Real_Products.thy b/thys/Landau_Symbols/Landau_Real_Products.thy
--- a/thys/Landau_Symbols/Landau_Real_Products.thy
+++ b/thys/Landau_Symbols/Landau_Real_Products.thy
@@ -1,1483 +1,1486 @@
 (*
   File:   Landau_Real_Products.thy
   Author: Manuel Eberl <eberlm@in.tum.de>
 
   Mathematical background and reification for a decision procedure for Landau symbols of
   products of powers of real functions (currently the identity and the natural logarithm)
 
   TODO: more functions (exp?), more preprocessing (log)
 *)
 section \<open>Decision procedure for real functions\<close>
 
 theory Landau_Real_Products
 imports
   Main
   "HOL-Library.Function_Algebras" 
   "HOL-Library.Set_Algebras"
   "HOL-Library.Landau_Symbols"
   Group_Sort
 begin
 
 subsection \<open>Eventual non-negativity/non-zeroness\<close>
 
 text \<open>
   For certain transformations of Landau symbols, it is required that the functions involved 
   are eventually non-negative of non-zero. In the following, we set up a system to guide the 
   simplifier to discharge these requirements during simplification at least in obvious cases.
 \<close>
 
 definition "eventually_nonzero F f \<longleftrightarrow> eventually (\<lambda>x. (f x :: _ :: real_normed_field) \<noteq> 0) F"
 definition "eventually_nonneg F f \<longleftrightarrow> eventually (\<lambda>x. (f x :: _ :: linordered_field) \<ge> 0) F"
 
 named_theorems eventually_nonzero_simps
 
 lemmas [eventually_nonzero_simps] = 
   eventually_nonzero_def [symmetric] eventually_nonneg_def [symmetric]
 
 lemma eventually_nonzeroD: "eventually_nonzero F f \<Longrightarrow> eventually (\<lambda>x. f x \<noteq> 0) F"
   by (simp add: eventually_nonzero_def)
 
 lemma eventually_nonzero_const [eventually_nonzero_simps]:
   "eventually_nonzero F (\<lambda>_::_::linorder. c) \<longleftrightarrow> F = bot \<or> c \<noteq> 0"
   unfolding eventually_nonzero_def by (auto simp add: eventually_False)
 
 lemma eventually_nonzero_inverse [eventually_nonzero_simps]:
   "eventually_nonzero F (\<lambda>x. inverse (f x)) \<longleftrightarrow> eventually_nonzero F f"
   unfolding eventually_nonzero_def by simp
 
 lemma eventually_nonzero_mult [eventually_nonzero_simps]:
   "eventually_nonzero F (\<lambda>x. f x * g x) \<longleftrightarrow> eventually_nonzero F f \<and> eventually_nonzero F g"
   unfolding eventually_nonzero_def by (simp_all add: eventually_conj_iff[symmetric])
 
 lemma eventually_nonzero_pow [eventually_nonzero_simps]:
   "eventually_nonzero F (\<lambda>x::_::linorder. f x ^ n) \<longleftrightarrow> n = 0 \<or> eventually_nonzero F f"
   by (induction n) (auto simp: eventually_nonzero_simps)
 
 lemma eventually_nonzero_divide [eventually_nonzero_simps]:
   "eventually_nonzero F (\<lambda>x. f x / g x) \<longleftrightarrow> eventually_nonzero F f \<and> eventually_nonzero F g"
   unfolding eventually_nonzero_def by (simp_all add: eventually_conj_iff[symmetric])
 
 lemma eventually_nonzero_ident_at_top_linorder [eventually_nonzero_simps]:
   "eventually_nonzero at_top (\<lambda>x::'a::{real_normed_field,linordered_field}. x)"
   unfolding eventually_nonzero_def by simp
 
 lemma eventually_nonzero_ident_nhds [eventually_nonzero_simps]:
   "eventually_nonzero (nhds a) (\<lambda>x. x) \<longleftrightarrow> a \<noteq> 0"
   using eventually_nhds_in_open[of "-{0}" a]
   by (auto elim!: eventually_mono simp: eventually_nonzero_def open_Compl 
            dest: eventually_nhds_x_imp_x)
 
 lemma eventually_nonzero_ident_at_within [eventually_nonzero_simps]:
   "eventually_nonzero (at a within A) (\<lambda>x. x)"
   using eventually_nonzero_ident_nhds[of a]
   by (cases "a = 0") (auto simp: eventually_nonzero_def eventually_at_filter elim!: eventually_mono)
 
 lemma eventually_nonzero_ln_at_top [eventually_nonzero_simps]:
   "eventually_nonzero at_top (\<lambda>x::real. ln x)"
   unfolding eventually_nonzero_def by (auto intro!: eventually_mono[OF eventually_gt_at_top[of 1]])
 
 lemma eventually_nonzero_ln_const_at_top [eventually_nonzero_simps]:
   "b > 0 \<Longrightarrow> eventually_nonzero at_top (\<lambda>x. ln (b * x :: real))"
   unfolding eventually_nonzero_def 
     apply (rule eventually_mono [OF eventually_gt_at_top[of "max 1 (inverse b)"]])
   by (metis exp_ln exp_minus exp_minus_inverse less_numeral_extra(3) ln_gt_zero max_less_iff_conj mult.commute mult_strict_right_mono)
 
 lemma eventually_nonzero_ln_const'_at_top [eventually_nonzero_simps]:
   "b > 0 \<Longrightarrow> eventually_nonzero at_top (\<lambda>x. ln (x * b :: real))"
   using eventually_nonzero_ln_const_at_top[of b] by (simp add: mult.commute)
 
 lemma eventually_nonzero_powr_at_top [eventually_nonzero_simps]:
   "eventually_nonzero at_top (\<lambda>x::real. f x powr p) \<longleftrightarrow> eventually_nonzero at_top f"
   unfolding eventually_nonzero_def by simp
 
 
 
 lemma eventually_nonneg_const [eventually_nonzero_simps]:
   "eventually_nonneg F (\<lambda>_. c) \<longleftrightarrow> F = bot \<or> c \<ge> 0"
   unfolding eventually_nonneg_def by (auto simp: eventually_False)
 
 lemma eventually_nonneg_inverse [eventually_nonzero_simps]:
   "eventually_nonneg F (\<lambda>x. inverse (f x)) \<longleftrightarrow> eventually_nonneg F f"
   unfolding eventually_nonneg_def by (intro eventually_subst) (auto)
 
 lemma eventually_nonneg_add [eventually_nonzero_simps]:
   assumes "eventually_nonneg F f" "eventually_nonneg F g"
   shows   "eventually_nonneg F (\<lambda>x. f x + g x)"
   using assms unfolding eventually_nonneg_def by eventually_elim simp
 
 lemma eventually_nonneg_mult [eventually_nonzero_simps]:
   assumes "eventually_nonneg F f" "eventually_nonneg F g"
   shows   "eventually_nonneg F (\<lambda>x. f x * g x)"
   using assms unfolding eventually_nonneg_def by eventually_elim simp
 
 lemma eventually_nonneg_mult' [eventually_nonzero_simps]:
   assumes "eventually_nonneg F (\<lambda>x. -f x)" "eventually_nonneg F (\<lambda>x. - g x)"
   shows   "eventually_nonneg F (\<lambda>x. f x * g x)"
   using assms unfolding eventually_nonneg_def by eventually_elim (auto intro: mult_nonpos_nonpos)
 
 lemma eventually_nonneg_divide [eventually_nonzero_simps]:
   assumes "eventually_nonneg F f" "eventually_nonneg F g"
   shows   "eventually_nonneg F (\<lambda>x. f x / g x)"
   using assms unfolding eventually_nonneg_def by eventually_elim simp
 
 lemma eventually_nonneg_divide' [eventually_nonzero_simps]:
   assumes "eventually_nonneg F (\<lambda>x. -f x)" "eventually_nonneg F (\<lambda>x. - g x)"
   shows   "eventually_nonneg F (\<lambda>x. f x / g x)"
   using assms unfolding eventually_nonneg_def by eventually_elim (auto intro: divide_nonpos_nonpos)
 
 lemma eventually_nonneg_ident_at_top [eventually_nonzero_simps]:
   "eventually_nonneg at_top (\<lambda>x. x)" unfolding eventually_nonneg_def by (rule eventually_ge_at_top)
 
 lemma eventually_nonneg_ident_nhds [eventually_nonzero_simps]:
   fixes a :: "'a :: {linorder_topology, linordered_field}"
   shows "a > 0 \<Longrightarrow> eventually_nonneg (nhds a) (\<lambda>x. x)" unfolding eventually_nonneg_def
   using eventually_nhds_in_open[of "{0<..}" a]
   by (auto simp: eventually_nonneg_def dest: eventually_nhds_x_imp_x elim!: eventually_mono)
 
 lemma eventually_nonneg_ident_at_within [eventually_nonzero_simps]:
   fixes a :: "'a :: {linorder_topology, linordered_field}"
   shows "a > 0 \<Longrightarrow> eventually_nonneg (at a within A) (\<lambda>x. x)"
   using eventually_nonneg_ident_nhds[of a]
   by (auto simp: eventually_nonneg_def eventually_at_filter elim: eventually_mono)
 
 lemma eventually_nonneg_pow [eventually_nonzero_simps]:
   "eventually_nonneg F f \<Longrightarrow> eventually_nonneg F (\<lambda>x. f x ^ n)"
   by (induction n) (auto simp: eventually_nonzero_simps)
 
 lemma eventually_nonneg_powr [eventually_nonzero_simps]:
   "eventually_nonneg F (\<lambda>x. f x powr y :: real)" by (simp add: eventually_nonneg_def)
 
 lemma eventually_nonneg_ln_at_top [eventually_nonzero_simps]:
   "eventually_nonneg at_top (\<lambda>x. ln x :: real)"
   by (auto intro!: eventually_mono[OF eventually_gt_at_top[of "1::real"]]
            simp: eventually_nonneg_def)
 
 lemma eventually_nonneg_ln_const [eventually_nonzero_simps]:
   "b > 0 \<Longrightarrow> eventually_nonneg at_top (\<lambda>x. ln (b*x) :: real)" 
   unfolding eventually_nonneg_def using eventually_ge_at_top[of "inverse b"]
   by eventually_elim (simp_all add: field_simps)
 
 lemma eventually_nonneg_ln_const' [eventually_nonzero_simps]:
   "b > 0 \<Longrightarrow> eventually_nonneg at_top (\<lambda>x. ln (x*b) :: real)" 
   using eventually_nonneg_ln_const[of b] by (simp add: mult.commute)
 
 lemma eventually_nonzero_bigtheta':
   "f \<in> \<Theta>[F](g) \<Longrightarrow> eventually_nonzero F f \<longleftrightarrow> eventually_nonzero F g"
   unfolding eventually_nonzero_def by (rule eventually_nonzero_bigtheta)
 
 lemma eventually_nonneg_at_top: 
   assumes "filterlim f at_top F"
   shows   "eventually_nonneg F f"
 proof -
   from assms have "eventually (\<lambda>x. f x \<ge> 0) F"
     by (simp add: filterlim_at_top)
   thus ?thesis unfolding eventually_nonneg_def by eventually_elim simp
 qed
 
 lemma eventually_nonzero_at_top: 
   assumes "filterlim (f :: 'a \<Rightarrow> 'b :: {linordered_field, real_normed_field}) at_top F"
   shows   "eventually_nonzero F f"
 proof -
   from assms have "eventually (\<lambda>x. f x \<ge> 1) F"
     by (simp add: filterlim_at_top)
   thus ?thesis unfolding eventually_nonzero_def by eventually_elim auto
 qed
 
 lemma eventually_nonneg_at_top_ASSUMPTION [eventually_nonzero_simps]:
   "ASSUMPTION (filterlim f at_top F) \<Longrightarrow> eventually_nonneg F f"
   by (simp add: ASSUMPTION_def eventually_nonneg_at_top)
 
 lemma eventually_nonzero_at_top_ASSUMPTION [eventually_nonzero_simps]:
   "ASSUMPTION (filterlim f (at_top :: 'a :: {linordered_field, real_normed_field} filter) F) \<Longrightarrow> 
      eventually_nonzero F f"
   using eventually_nonzero_at_top[of f F] by (simp add: ASSUMPTION_def)
 
 lemma filterlim_at_top_iff_smallomega:
   fixes f :: "_ \<Rightarrow> real"
   shows "filterlim f at_top F \<longleftrightarrow> f \<in> \<omega>[F](\<lambda>_. 1) \<and> eventually_nonneg F f"
   unfolding eventually_nonneg_def
 proof safe
   assume A: "filterlim f at_top F"
   thus B: "eventually (\<lambda>x. f x \<ge> 0) F" by (simp add: eventually_nonzero_simps)
   {
     fix c
     from A have "filterlim (\<lambda>x. norm (f x)) at_top F"
       by (intro filterlim_at_infinity_imp_norm_at_top filterlim_at_top_imp_at_infinity) 
     hence "eventually (\<lambda>x. norm (f x) \<ge> c) F" by (auto simp: filterlim_at_top)
   }
   thus "f \<in> \<omega>[F](\<lambda>_. 1)" by (rule landau_omega.smallI)
 next
   assume A: "f \<in> \<omega>[F](\<lambda>_. 1)" and B: "eventually (\<lambda>x. f x \<ge> 0) F"
   {
     fix c :: real assume "c > 0"
     from landau_omega.smallD[OF A this] B 
       have "eventually (\<lambda>x. f x \<ge> c) F" by eventually_elim simp
   }
   thus "filterlim f at_top F"
     by (subst filterlim_at_top_gt[of _ _ 0]) simp_all
 qed
 
 lemma smallomega_1_iff: 
   "eventually_nonneg F f \<Longrightarrow> f \<in> \<omega>[F](\<lambda>_. 1 :: real) \<longleftrightarrow> filterlim f at_top F"
   by (simp add: filterlim_at_top_iff_smallomega)
 
 lemma smallo_1_iff: 
   "eventually_nonneg F f \<Longrightarrow> (\<lambda>_. 1 :: real) \<in> o[F](f) \<longleftrightarrow> filterlim f at_top F"
   by (simp add: filterlim_at_top_iff_smallomega smallomega_iff_smallo)
 
 lemma eventually_nonneg_add1 [eventually_nonzero_simps]:
   assumes "eventually_nonneg F f" "g \<in> o[F](f)"
   shows   "eventually_nonneg F (\<lambda>x. f x + g x :: real)"
   using  landau_o.smallD[OF assms(2) zero_less_one] assms(1) unfolding eventually_nonneg_def
   by eventually_elim simp_all
 
 lemma eventually_nonneg_add2 [eventually_nonzero_simps]:
   assumes "eventually_nonneg F g" "f \<in> o[F](g)"
   shows   "eventually_nonneg F (\<lambda>x. f x + g x :: real)"
   using  landau_o.smallD[OF assms(2) zero_less_one] assms(1) unfolding eventually_nonneg_def
   by eventually_elim simp_all
 
 lemma eventually_nonneg_diff1 [eventually_nonzero_simps]:
   assumes "eventually_nonneg F f" "g \<in> o[F](f)"
   shows   "eventually_nonneg F (\<lambda>x. f x - g x :: real)"
   using  landau_o.smallD[OF assms(2) zero_less_one] assms(1) unfolding eventually_nonneg_def
   by eventually_elim simp_all
 
 lemma eventually_nonneg_diff2 [eventually_nonzero_simps]:
   assumes "eventually_nonneg F (\<lambda>x. - g x)" "f \<in> o[F](g)"
   shows   "eventually_nonneg F (\<lambda>x. f x - g x :: real)"
   using  landau_o.smallD[OF assms(2) zero_less_one] assms(1) unfolding eventually_nonneg_def
   by eventually_elim simp_all
 
 
 subsection \<open>Rewriting Landau symbols\<close>
 
 lemma bigtheta_mult_eq: "\<Theta>[F](\<lambda>x. f x * g x) = \<Theta>[F](f) * \<Theta>[F](g)"
 proof (intro equalityI subsetI)
   fix h assume "h \<in> \<Theta>[F](f) * \<Theta>[F](g)"
   thus "h \<in> \<Theta>[F](\<lambda>x. f x * g x)"
     by (elim set_times_elim, hypsubst, unfold func_times) (erule (1) landau_theta.mult)
 next
   fix h assume "h \<in> \<Theta>[F](\<lambda>x. f x * g x)"
-  then guess c1 c2 :: real unfolding bigtheta_def by (elim landau_o.bigE landau_omega.bigE IntE)
-  note c = this
+  then obtain c1 c2 :: real
+    where c:
+      "c1 > 0" "\<forall>\<^sub>F x in F. norm (h x) \<le> c1 * norm (f x * g x)"
+      "c2 > 0" "\<forall>\<^sub>F x in F. c2 * norm (f x * g x) \<le> norm (h x)"
+    unfolding bigtheta_def by (blast elim: landau_o.bigE)
 
   define h1 h2
     where "h1 x = (if g x = 0 then if f x = 0 then if h x = 0 then h x else 1 else f x else h x / g x)"
       and "h2 x = (if g x = 0 then if f x = 0 then h x else h x / f x else g x)"
     for x
 
   have "h = h1 * h2" by (intro ext) (auto simp: h1_def h2_def field_simps)
   moreover have "h1 \<in> \<Theta>[F](f)"
   proof (rule bigthetaI')
     from c(3) show "min c2 1 > 0" by simp
     from c(1) show "max c1 1 > 0" by simp
     from c(2,4) 
       show "eventually (\<lambda>x. min c2 1 * (norm (f x)) \<le> norm (h1 x) \<and> 
                             norm (h1 x) \<le> max c1 1 * (norm (f x))) F"
       apply eventually_elim
     proof (rule conjI)
       fix x assume A: "(norm (h x)) \<le> c1 * norm (f x * g x)" 
                and B: "(norm (h x)) \<ge> c2 * norm (f x * g x)"
       have m: "min c2 1 * (norm (f x)) \<le> 1 * (norm (f x))" by (rule mult_right_mono) simp_all
       have "min c2 1 * norm (f x * g x) \<le> c2 * norm (f x * g x)" by (intro mult_right_mono) simp_all
       also note B
       finally show "norm (h1 x) \<ge> min c2 1 * (norm (f x))" using m A
         by (cases "g x = 0") (simp_all add: h1_def norm_mult norm_divide field_simps)+
 
       have m: "1 * (norm (f x)) \<le> max c1 1 * (norm (f x))" by (rule mult_right_mono) simp_all
       note A
       also have "c1 * norm (f x * g x) \<le> max c1 1 * norm (f x * g x)" 
         by (intro mult_right_mono) simp_all
       finally show "norm (h1 x) \<le> max c1 1 * (norm (f x))" using m A
         by (cases "g x = 0") (simp_all add: h1_def norm_mult norm_divide field_simps)+
     qed
   qed
   moreover have "h2 \<in> \<Theta>[F](g)"
   proof (rule bigthetaI')
     from c(3) show "min c2 1 > 0" by simp
     from c(1) show "max c1 1 > 0" by simp
     from c(2,4) 
       show "eventually (\<lambda>x. min c2 1 * (norm (g x)) \<le> norm (h2 x) \<and>  
                             norm (h2 x) \<le> max c1 1 * (norm (g x))) F"
       apply eventually_elim
     proof (rule conjI)
       fix x assume A: "(norm (h x)) \<le> c1 * norm (f x * g x)" 
                and B: "(norm (h x)) \<ge> c2 * norm (f x * g x)"
       have m: "min c2 1 * (norm (f x)) \<le> 1 * (norm (f x))" by (rule mult_right_mono) simp_all
       have "min c2 1 * norm (f x * g x) \<le> c2 * norm (f x * g x)" 
         by (intro mult_right_mono) simp_all
       also note B
       finally show "norm (h2 x) \<ge> min c2 1 * (norm (g x))" using m A B
         by (cases "g x = 0") (auto simp: h2_def abs_mult field_simps)+
 
       have m: "1 * (norm (g x)) \<le> max c1 1 * (norm (g x))" by (rule mult_right_mono) simp_all
       note A
       also have "c1 * norm (f x * g x) \<le> max c1 1 * norm (f x * g x)" 
         by (intro mult_right_mono) simp_all
       finally show "norm (h2 x) \<le> max c1 1 * (norm (g x))" using m A
         by (cases "g x = 0") (simp_all add: h2_def abs_mult field_simps)+
     qed
   qed
   ultimately show "h \<in> \<Theta>[F](f) * \<Theta>[F](g)" by blast
 qed
 
 text \<open>
   Since the simplifier does not currently rewriting with relations other than equality,
   but we want to rewrite terms like @{term "\<Theta>(\<lambda>x. log 2 x * x)"} to @{term "\<Theta>(\<lambda>x. ln x * x)"}, 
   we need to bring the term into something that contains @{term "\<Theta>(\<lambda>x. log 2 x)"} and 
   @{term "\<Theta>(\<lambda>x. x)"}, which can then be rewritten individually.
   For this, we introduce the following constants and rewrite rules. The rules are mainly used 
   by the simprocs, but may be useful for manual reasoning occasionally.
 \<close>
 
 definition "set_mult A B = {\<lambda>x. f x * g x |f g. f \<in> A \<and> g \<in> B}"
 definition "set_inverse A = {\<lambda>x. inverse (f x) |f. f \<in> A}"
 definition "set_divide A B = {\<lambda>x. f x / g x |f g. f \<in> A \<and> g \<in> B}"
 definition "set_pow A n = {\<lambda>x. f x ^ n |f. f \<in> A}"
 definition "set_powr A y = {\<lambda>x. f x powr y |f. f \<in> A}"
 
 lemma bigtheta_mult_eq_set_mult:
   shows "\<Theta>[F](\<lambda>x. f x * g x) = set_mult (\<Theta>[F](f)) (\<Theta>[F](g))"
   unfolding bigtheta_mult_eq set_mult_def set_times_def func_times by blast
 
 lemma bigtheta_inverse_eq_set_inverse:
   shows "\<Theta>[F](\<lambda>x. inverse (f x)) = set_inverse (\<Theta>[F](f))"
 proof (intro equalityI subsetI)
   fix g :: "'a \<Rightarrow> 'b" assume "g \<in> \<Theta>[F](\<lambda>x. inverse (f x))"
   hence "(\<lambda>x. inverse (g x)) \<in> \<Theta>[F](\<lambda>x. inverse (inverse (f x)))" by (subst bigtheta_inverse)
   also have "(\<lambda>x. inverse (inverse (f x))) = f" by (rule ext) simp
   finally show "g \<in> set_inverse (\<Theta>[F](f))" unfolding set_inverse_def by force
 next
   fix g :: "'a \<Rightarrow> 'b" assume "g \<in> set_inverse (\<Theta>[F](f))"
   then obtain g' where "g = (\<lambda>x. inverse (g' x))" "g' \<in> \<Theta>[F](f)" unfolding set_inverse_def by blast
   hence "(\<lambda>x. inverse (g' x)) \<in> \<Theta>[F](\<lambda>x. inverse (f x))" by (subst bigtheta_inverse)
   also from \<open>g = (\<lambda>x. inverse (g' x))\<close> have "(\<lambda>x. inverse (g' x)) = g" by (intro ext) simp
   finally show "g \<in> \<Theta>[F](\<lambda>x. inverse (f x))" .
 qed
 
 lemma set_divide_inverse: 
   "set_divide (A :: (_ \<Rightarrow> (_ :: division_ring)) set) B = set_mult A (set_inverse B)"
 proof (intro equalityI subsetI)
   fix f assume "f \<in> set_divide A B"
   then obtain g h where "f = (\<lambda>x. g x / h x)" "g \<in> A" "h \<in> B" unfolding set_divide_def by blast
   hence "f = g * (\<lambda>x. inverse (h x))" "(\<lambda>x. inverse (h x)) \<in> set_inverse B"
     unfolding set_inverse_def by (auto simp: divide_inverse)
   with \<open>g \<in> A\<close> show "f \<in> set_mult A (set_inverse B)" unfolding set_mult_def by force
 next
   fix f assume "f \<in> set_mult A (set_inverse B)"
   then obtain g h where "f = g * (\<lambda>x. inverse (h x))" "g \<in> A" "h \<in> B"
     unfolding set_times_def set_inverse_def set_mult_def by force
   hence "f = (\<lambda>x. g x / h x)" by (intro ext) (simp add: divide_inverse)
   with \<open>g \<in> A\<close> \<open>h \<in> B\<close> show "f \<in> set_divide A B" unfolding set_divide_def by blast
 qed
 
 lemma bigtheta_divide_eq_set_divide:
   shows "\<Theta>[F](\<lambda>x. f x / g x) = set_divide (\<Theta>[F](f)) (\<Theta>[F](g))"
   by (simp only: set_divide_inverse divide_inverse bigtheta_mult_eq_set_mult 
                  bigtheta_inverse_eq_set_inverse)
 
 primrec bigtheta_pow where
   "bigtheta_pow F A 0 = \<Theta>[F](\<lambda>_. 1)"
 | "bigtheta_pow F A (Suc n) = set_mult A (bigtheta_pow F A n)"
 
 lemma bigtheta_pow_eq_set_pow: "\<Theta>[F](\<lambda>x. f x ^ n) = bigtheta_pow F (\<Theta>[F](f)) n"
   by (induction n) (simp_all add: bigtheta_mult_eq_set_mult)
 
 definition bigtheta_powr where
   "bigtheta_powr F A y = (if y = 0 then {f. \<exists>g\<in>A. eventually_nonneg F g \<and> f \<in> \<Theta>[F](\<lambda>x. g x powr y)} 
      else {f. \<exists>g\<in>A. eventually_nonneg F g \<and> (\<forall>x. (norm (f x)) = g x powr y)})"
 
 lemma bigtheta_powr_eq_set_powr: 
   assumes "eventually_nonneg F f"
   shows   "\<Theta>[F](\<lambda>x. f x powr (y::real)) = bigtheta_powr F (\<Theta>[F](f)) y"
 proof (cases "y = 0")
   assume [simp]: "y = 0"
   show ?thesis
   proof (intro equalityI subsetI)
     fix h assume "h \<in> bigtheta_powr F \<Theta>[F](f) y"
     then obtain g where g: "g \<in> \<Theta>[F](f)" "eventually_nonneg F g" "h \<in> \<Theta>[F](\<lambda>x. g x powr 0)"
       unfolding bigtheta_powr_def by force
     note this(3)
     also have "(\<lambda>x. g x powr 0) \<in> \<Theta>[F](\<lambda>x. \<bar>g x\<bar> powr 0)" 
       using assms unfolding eventually_nonneg_def
       by (intro bigthetaI_cong) (auto elim!: eventually_mono)
     also from g(1) have "(\<lambda>x. \<bar>g x\<bar> powr 0) \<in> \<Theta>[F](\<lambda>x. \<bar>f x\<bar> powr 0)" 
       by (rule bigtheta_powr)
     also from g(2) have "(\<lambda>x. f x powr 0) \<in> \<Theta>[F](\<lambda>x. \<bar>f x\<bar> powr 0)" 
       unfolding eventually_nonneg_def
       by (intro bigthetaI_cong) (auto elim!: eventually_mono)
     finally show "h \<in> \<Theta>[F](\<lambda>x. f x powr y)" by simp
   next
     fix h assume "h \<in> \<Theta>[F](\<lambda>x. f x powr y)"
     with assms have "\<exists>g\<in>\<Theta>[F](f). eventually_nonneg F g \<and> h \<in> \<Theta>[F](\<lambda>x. g x powr 0)"
       by (intro bexI[of _ f] conjI) simp_all
     thus "h \<in> bigtheta_powr F \<Theta>[F](f) y" unfolding bigtheta_powr_def by simp
   qed
 next
   assume y: "y \<noteq> 0"
   show ?thesis
   proof (intro equalityI subsetI)
     fix h assume h: "h \<in> \<Theta>[F](\<lambda>x. f x powr y)"
     let ?h' = "\<lambda>x. \<bar>h x\<bar> powr inverse y"
     from bigtheta_powr[OF h, of "inverse y"] y
       have "?h' \<in> \<Theta>[F](\<lambda>x. f x powr 1)" by (simp add: powr_powr)
     also have "(\<lambda>x. f x powr 1) \<in> \<Theta>[F](f)" using assms unfolding eventually_nonneg_def 
       by (intro bigthetaI_cong) (auto elim!: eventually_mono)
     finally have "?h' \<in> \<Theta>[F](f)" .
     with y have "\<exists>g\<in>\<Theta>[F](f). eventually_nonneg F g \<and> (\<forall>x. (norm (h x)) = g x powr y)"
       by (intro bexI[of _ ?h']) (simp_all add: powr_powr eventually_nonneg_def)
     thus "h \<in> bigtheta_powr F \<Theta>[F](f) y" using y unfolding bigtheta_powr_def by simp
   next
     fix h assume "h \<in> bigtheta_powr F (\<Theta>[F](f)) y"
     with y obtain g where A: "g \<in> \<Theta>[F](f)" "\<And>x. \<bar>h x\<bar> = g x powr y" "eventually_nonneg F g"
       unfolding bigtheta_powr_def by force
     from this(3) have "(\<lambda>x. g x powr y) \<in> \<Theta>[F](\<lambda>x. \<bar>g x\<bar> powr y)" unfolding eventually_nonneg_def
       by (intro bigthetaI_cong) (auto elim!: eventually_mono)
     also from A(1) have "(\<lambda>x. \<bar>g x\<bar> powr y) \<in> \<Theta>[F](\<lambda>x. \<bar>f x\<bar> powr y)" by (rule bigtheta_powr)
     also have "(\<lambda>x. \<bar>f x\<bar> powr y) \<in> \<Theta>[F](\<lambda>x. f x powr y)" using assms unfolding eventually_nonneg_def
       by (intro bigthetaI_cong) (auto elim!: eventually_mono)
     finally have "(\<lambda>x. \<bar>h x\<bar>) \<in> \<Theta>[F](\<lambda>x. f x powr y)" by (subst A(2))
     thus "(\<lambda>x. h x) \<in> \<Theta>[F](\<lambda>x. f x powr y)" by simp
   qed
 qed
 
 
 lemmas bigtheta_factors_eq = 
   bigtheta_mult_eq_set_mult bigtheta_inverse_eq_set_inverse bigtheta_divide_eq_set_divide 
   bigtheta_pow_eq_set_pow bigtheta_powr_eq_set_powr
 
 lemmas landau_bigtheta_congs = landau_symbols[THEN landau_symbol.cong_bigtheta]
 
 lemma (in landau_symbol) meta_cong_bigtheta: "\<Theta>[F](f) \<equiv> \<Theta>[F](g) \<Longrightarrow> L F (f) \<equiv> L F (g)"
   using bigtheta_refl[of f] by (intro eq_reflection cong_bigtheta) blast
 
 lemmas landau_bigtheta_meta_congs = landau_symbols[THEN landau_symbol.meta_cong_bigtheta]
 
 
 subsection \<open>Preliminary facts\<close>
 
 lemma real_powr_at_top: 
   assumes "(p::real) > 0"
   shows   "filterlim (\<lambda>x. x powr p) at_top at_top"
 proof (subst filterlim_cong[OF refl refl])
   show "LIM x at_top. exp (p * ln x) :> at_top"
     by (rule filterlim_compose[OF exp_at_top filterlim_tendsto_pos_mult_at_top[OF tendsto_const]])
        (simp_all add: ln_at_top assms)
   show "eventually (\<lambda>x. x powr p = exp (p * ln x)) at_top"
     using eventually_gt_at_top[of 0] by eventually_elim (simp add: powr_def)
 qed
 
 lemma tendsto_ln_over_powr: 
   assumes "(a::real) > 0"
   shows   "((\<lambda>x. ln x / x powr a) \<longlongrightarrow> 0) at_top"
 proof (rule lhospital_at_top_at_top)
   from assms show "LIM x at_top. x powr a :> at_top" by (rule real_powr_at_top)
   show "eventually (\<lambda>x. a * x powr (a - 1) \<noteq> 0) at_top"
     using eventually_gt_at_top[of "0::real"] by eventually_elim (insert assms, simp)
   show "eventually (\<lambda>x::real. (ln has_real_derivative (inverse x)) (at x)) at_top"
     using eventually_gt_at_top[of "0::real"] DERIV_ln by (elim eventually_mono) simp
   show "eventually (\<lambda>x. ((\<lambda>x. x powr a) has_real_derivative a * x powr (a - 1)) (at x)) at_top"
     using eventually_gt_at_top[of "0::real"]
     by eventually_elim (auto intro!: derivative_eq_intros)
   have "eventually (\<lambda>x. inverse a * x powr -a = inverse x / (a*x powr (a-1))) at_top"
     using eventually_gt_at_top[of "0::real"] 
     by (elim eventually_mono) (simp add: field_simps powr_diff powr_minus)
   moreover from assms have "((\<lambda>x. inverse a * x powr -a) \<longlongrightarrow> 0) at_top"
     by (intro tendsto_mult_right_zero tendsto_neg_powr filterlim_ident) simp_all
   ultimately show "((\<lambda>x. inverse x / (a * x powr (a - 1))) \<longlongrightarrow> 0) at_top"
     by (subst (asm) tendsto_cong) simp_all
 qed
 
 lemma tendsto_ln_powr_over_powr: 
   assumes "(a::real) > 0" "b > 0"
   shows   "((\<lambda>x. ln x powr a / x powr b) \<longlongrightarrow> 0) at_top"
 proof-
   have "eventually (\<lambda>x. ln x powr a / x powr b = (ln x / x powr (b/a)) powr a) at_top"
     using assms eventually_gt_at_top[of "1::real"]
     by (elim eventually_mono) (simp add: powr_divide powr_powr)
   moreover have "eventually (\<lambda>x. 0 < ln x / x powr (b / a)) at_top"
     using eventually_gt_at_top[of "1::real"] by (elim eventually_mono) simp
   with assms have "((\<lambda>x. (ln x / x powr (b/a)) powr a) \<longlongrightarrow> 0) at_top"
     by (intro tendsto_zero_powrI tendsto_ln_over_powr) (simp_all add: eventually_mono)
   ultimately show ?thesis by (subst tendsto_cong) simp_all
 qed
 
 lemma tendsto_ln_powr_over_powr': 
   assumes "b > 0"
   shows   "((\<lambda>x::real. ln x powr a / x powr b) \<longlongrightarrow> 0) at_top"
 proof (cases "a \<le> 0")
   assume a: "a \<le> 0"
   show ?thesis
   proof (rule tendsto_sandwich[of "\<lambda>_::real. 0"])
     have "eventually (\<lambda>x. ln x powr a \<le> 1) at_top" unfolding eventually_at_top_linorder
     proof (intro allI exI impI)
       fix x :: real assume x: "x \<ge> exp 1"
       have "0 < exp (1::real)" by simp
       also have "\<dots> \<le> x" by fact
       finally have "ln x \<ge> ln (exp 1)" using x by (subst ln_le_cancel_iff) auto
       hence "ln x powr a \<le> ln (exp 1) powr a" using a by (intro powr_mono2') simp_all
       thus "ln x powr a \<le> 1" by simp
     qed
     thus "eventually (\<lambda>x. ln x powr a / x powr b \<le> x powr -b) at_top"
       by eventually_elim (insert a, simp add: field_simps powr_minus divide_right_mono)
   qed (auto intro!: filterlim_ident tendsto_neg_powr assms)
 qed (intro tendsto_ln_powr_over_powr, simp_all add: assms)
 
 lemma tendsto_ln_over_ln:
   assumes "(a::real) > 0" "c > 0"
   shows   "((\<lambda>x. ln (a*x) / ln (c*x)) \<longlongrightarrow> 1) at_top"
 proof (rule lhospital_at_top_at_top)
   show "LIM x at_top. ln (c*x) :> at_top"
     by (intro filterlim_compose[OF ln_at_top] filterlim_tendsto_pos_mult_at_top[OF tendsto_const] 
               filterlim_ident assms(2))
   show "eventually (\<lambda>x. ((\<lambda>x. ln (a*x)) has_real_derivative (inverse x)) (at x)) at_top"
     using eventually_gt_at_top[of "inverse a"] assms
     by (auto elim!: eventually_mono intro!: derivative_eq_intros simp: field_simps)
   show "eventually (\<lambda>x. ((\<lambda>x. ln (c*x)) has_real_derivative (inverse x)) (at x)) at_top"
     using eventually_gt_at_top[of "inverse c"] assms
     by (auto elim!: eventually_mono intro!: derivative_eq_intros simp: field_simps)
   show "((\<lambda>x::real. inverse x / inverse x) \<longlongrightarrow> 1) at_top"
     by (subst tendsto_cong[of _ "\<lambda>_. 1"]) simp_all
 qed simp_all
 
 lemma tendsto_ln_powr_over_ln_powr:
   assumes "(a::real) > 0" "c > 0"
   shows   "((\<lambda>x. ln (a*x) powr d / ln (c*x) powr d) \<longlongrightarrow> 1) at_top"
 proof-
   have "eventually (\<lambda>x. ln (a*x) powr d / ln (c*x) powr d = (ln (a*x) / ln (c*x)) powr d) at_top"
     using assms eventually_gt_at_top[of "max (inverse a) (inverse c)"]
     by (auto elim!: eventually_mono simp: powr_divide field_simps)
   moreover have "((\<lambda>x. (ln (a*x) / ln (c*x)) powr d) \<longlongrightarrow> 1) at_top" using assms
     by (intro tendsto_eq_rhs[OF tendsto_powr[OF tendsto_ln_over_ln tendsto_const]]) simp_all
   ultimately show ?thesis by (subst tendsto_cong)
 qed
 
 lemma tendsto_ln_powr_over_ln_powr': 
   "c > 0 \<Longrightarrow> ((\<lambda>x::real. ln x powr d / ln (c*x) powr d) \<longlongrightarrow> 1) at_top"
   using tendsto_ln_powr_over_ln_powr[of 1 c d] by simp
 
 lemma tendsto_ln_powr_over_ln_powr'': 
   "a > 0 \<Longrightarrow> ((\<lambda>x::real. ln (a*x) powr d / ln x powr d) \<longlongrightarrow> 1) at_top"
   using tendsto_ln_powr_over_ln_powr[of _ 1] by simp
 
 lemma bigtheta_const_ln_powr [simp]: "a > 0 \<Longrightarrow> (\<lambda>x::real. ln (a*x) powr d) \<in> \<Theta>(\<lambda>x. ln x powr d)"
   by (intro bigthetaI_tendsto[of 1] tendsto_ln_powr_over_ln_powr'') simp
 
 lemma bigtheta_const_ln_pow [simp]: "a > 0 \<Longrightarrow> (\<lambda>x::real. ln (a*x) ^ d) \<in> \<Theta>(\<lambda>x. ln x ^ d)"
 proof-
   assume a: "a > 0"
   have "\<forall>\<^sub>F x in at_top. ln (a * x) ^ d = ln (a * x) powr real d"
     using eventually_gt_at_top[of "1/a"] 
     by eventually_elim (insert a, subst powr_realpow, auto simp: field_simps)
   hence "(\<lambda>x::real. ln (a*x) ^ d) \<in> \<Theta>(\<lambda>x. ln (a*x) powr real d)"
     by (rule bigthetaI_cong)
   also from a have "(\<lambda>x. ln (a*x) powr real d) \<in> \<Theta>(\<lambda>x. ln x powr real d)" by simp
   also have "\<forall>\<^sub>F x in at_top. ln x powr real d = ln x ^ d"
     using eventually_gt_at_top[of 1] 
     by eventually_elim (subst powr_realpow, auto simp: field_simps)
   hence "(\<lambda>x. ln x powr real d) \<in> \<Theta>(\<lambda>x. ln x ^ d)"
     by (rule bigthetaI_cong)
   finally show ?thesis .
 qed
 
 lemma bigtheta_const_ln [simp]: "a > 0 \<Longrightarrow> (\<lambda>x::real. ln (a*x)) \<in> \<Theta>(\<lambda>x. ln x)"
   using tendsto_ln_over_ln[of a 1]  by (intro bigthetaI_tendsto[of 1]) simp_all
 
 
 text \<open>
   If there are two functions @{term "f"} and @{term "g"} where any power of @{term "g"} is
   asymptotically smaller than @{term "f"}, propositions like @{term "(\<lambda>x. f x ^ p1 * g x ^ q1) \<in>
   O(\<lambda>x. f x ^ p2 * g x ^ q2)"} can be decided just by looking at the exponents:
   the proposition is true iff @{term "p1 < p2"} or @{term "p1 = p2 \<and> q1 \<le> q2"}.
 
   The functions @{term "\<lambda>x. x"}, @{term "\<lambda>x. ln x"}, @{term "\<lambda>x. ln (ln x)"}, $\ldots$
   form a chain in which every function dominates all succeeding functions in the above sense,
   allowing to decide propositions involving Landau symbols and functions that are products of
   powers of functions from this chain by reducing the proposition to a statement involving only
   logical connectives and comparisons on the exponents.
 
   We will now give the mathematical background for this and implement reification to bring
   functions from this class into a canonical form, allowing the decision procedure to be
   implemented in a simproc.
 \<close>
 
 subsection \<open>Decision procedure\<close>
 
 definition "powr_closure f \<equiv> {\<lambda>x. f x powr p :: real |p. True}"
 
 lemma powr_closureI [simp]: "(\<lambda>x. f x powr p) \<in> powr_closure f"
   unfolding powr_closure_def by force
 
 lemma powr_closureE:
   assumes "g \<in> powr_closure f"
   obtains p where "g = (\<lambda>x. f x powr p)"
   using assms unfolding powr_closure_def by force
 
 
 locale landau_function_family =
   fixes F :: "'a filter" and H :: "('a \<Rightarrow> real) set"
   assumes F_nontrivial: "F \<noteq> bot"
   assumes pos: "h \<in> H \<Longrightarrow> eventually (\<lambda>x. h x > 0) F"
   assumes linear: "h1 \<in> H \<Longrightarrow> h2 \<in> H \<Longrightarrow> h1 \<in> o[F](h2) \<or> h2 \<in> o[F](h1) \<or> h1 \<in> \<Theta>[F](h2)"
   assumes mult: "h1 \<in> H \<Longrightarrow> h2 \<in> H \<Longrightarrow> (\<lambda>x. h1 x * h2 x) \<in> H"
   assumes inverse: "h \<in> H \<Longrightarrow> (\<lambda>x. inverse (h x)) \<in> H"
 begin
 
 lemma div: "h1 \<in> H \<Longrightarrow> h2 \<in> H \<Longrightarrow> (\<lambda>x. h1 x / h2 x) \<in> H"
   by (subst divide_inverse) (intro mult inverse)
 
 lemma nonzero: "h \<in> H \<Longrightarrow> eventually (\<lambda>x. h x \<noteq> 0) F"
   by (drule pos) (auto elim: eventually_mono)
 
 lemma landau_cases:
   assumes "h1 \<in> H" "h2 \<in> H"
   obtains "h1 \<in> o[F](h2)" | "h2 \<in> o[F](h1)" | "h1 \<in> \<Theta>[F](h2)"
   using linear[OF assms] by blast
 
 lemma small_big_antisym:
   assumes "h1 \<in> H" "h2 \<in> H" "h1 \<in> o[F](h2)" "h2 \<in> O[F](h1)" shows False
 proof-
   from nonzero[OF assms(1)] nonzero[OF assms(2)] landau_o.small_big_asymmetric[OF assms(3,4)]
     have "eventually (\<lambda>_::'a. False) F" by eventually_elim simp
   thus False by (simp add: eventually_False F_nontrivial)
 qed
 
 lemma small_antisym:
   assumes "h1 \<in> H" "h2 \<in> H" "h1 \<in> o[F](h2)" "h2 \<in> o[F](h1)" shows False
   using assms by (blast intro: small_big_antisym landau_o.small_imp_big)
 
 end
 
 locale landau_function_family_pair =
   G: landau_function_family F G + H: landau_function_family F H for F G H +
   fixes g
   assumes gs_dominate: "g1 \<in> G \<Longrightarrow> g2 \<in> G \<Longrightarrow> h1 \<in> H \<Longrightarrow> h2 \<in> H \<Longrightarrow> g1 \<in> o[F](g2) \<Longrightarrow>
      (\<lambda>x. g1 x * h1 x) \<in> o[F](\<lambda>x. g2 x * h2 x)"
   assumes g: "g \<in> G"
   assumes g_dominates: "h \<in> H \<Longrightarrow> h \<in> o[F](g)"
 begin
 
 sublocale GH: landau_function_family F "G * H"
 proof (unfold_locales; (elim set_times_elim; hypsubst)?)
   fix g h assume "g \<in> G" "h \<in> H"
   from G.pos[OF this(1)] H.pos[OF this(2)] show "eventually (\<lambda>x. (g*h) x > 0) F"
     by eventually_elim simp
 next
   fix g h assume A: "g \<in> G" "h \<in> H"
   have "(\<lambda>x. inverse ((g * h) x)) = (\<lambda>x. inverse (g x)) * (\<lambda>x. inverse (h x))" by (rule ext) simp
   also from A have "... \<in> G * H" by (intro G.inverse H.inverse set_times_intro)
   finally show "(\<lambda>x. inverse ((g * h) x)) \<in> G * H" .
 next
   fix g1 g2 h1 h2 assume A: "g1 \<in> G" "g2 \<in> G" "h1 \<in> H" "h2 \<in> H"
   from gs_dominate[OF this] gs_dominate[OF this(2,1,4,3)]
        G.linear[OF this(1,2)] H.linear[OF this(3,4)]
     show "g1 * h1 \<in> o[F](g2 * h2) \<or> g2 * h2 \<in> o[F](g1 * h1) \<or> g1 * h1 \<in> \<Theta>[F](g2 * h2)"
     by (elim disjE) (force simp: func_times bigomega_iff_bigo intro: landau_theta.mult
          landau_o.small.mult landau_o.small_big_mult landau_o.big_small_mult)+
   have B: "(\<lambda>x. (g1 * h1) x * (g2 * h2) x) = (g1 * g2) * (h1 * h2)"
     by (rule ext) (simp add: func_times mult_ac)
   from A show "(\<lambda>x. (g1 * h1) x * (g2 * h2) x) \<in> G * H"
     by (subst B, intro set_times_intro) (auto intro: G.mult H.mult simp: func_times)
 qed (fact G.F_nontrivial)
 
 lemma smallo_iff:
   assumes "g1 \<in> G" "g2 \<in> G" "h1 \<in> H" "h2 \<in> H"
   shows "(\<lambda>x. g1 x * h1 x) \<in> o[F](\<lambda>x. g2 x * h2 x) \<longleftrightarrow>
              g1 \<in> o[F](g2) \<or> (g1 \<in> \<Theta>[F](g2) \<and> h1 \<in> o[F](h2))" (is "?P \<longleftrightarrow> ?Q")
 proof (rule G.landau_cases[OF assms(1,2)])
   assume "g1 \<in> o[F](g2)"
   thus ?thesis by (auto intro!: gs_dominate assms)
 next
   assume A: "g1 \<in> \<Theta>[F](g2)"
   hence B: "g2 \<in> O[F](g1)" by (subst (asm) bigtheta_sym) (rule bigthetaD1)
   hence "g1 \<notin> o[F](g2)" using assms by (auto dest: G.small_big_antisym)
   moreover from A have "o[F](\<lambda>x. g2 x * h2 x) = o[F](\<lambda>x. g1 x * h2 x)"
     by (intro landau_o.small.cong_bigtheta landau_theta.mult_right, subst bigtheta_sym)
   ultimately show ?thesis using G.nonzero[OF assms(1)] A
     by (auto simp add: landau_o.small.mult_cancel_left)
 next
   assume A: "g2 \<in> o[F](g1)"
   from gs_dominate[OF assms(2,1,4,3) this] have B: "g2 * h2 \<in> o[F](g1 * h1)" by (simp add: func_times)
   have "g1 \<notin> o[F](g2)" "g1 \<notin> \<Theta>[F](g2)" using assms A
     by (auto dest: G.small_antisym G.small_big_antisym simp: bigomega_iff_bigo)
   moreover have "\<not>?P"
     by (intro notI GH.small_antisym[OF _ _ B] set_times_intro) (simp_all add: func_times assms)
   ultimately show ?thesis by blast
 qed
 
 lemma bigo_iff:
   assumes "g1 \<in> G" "g2 \<in> G" "h1 \<in> H" "h2 \<in> H"
   shows "(\<lambda>x. g1 x * h1 x) \<in> O[F](\<lambda>x. g2 x * h2 x) \<longleftrightarrow>
              g1 \<in> o[F](g2) \<or> (g1 \<in> \<Theta>[F](g2) \<and> h1 \<in> O[F](h2))" (is "?P \<longleftrightarrow> ?Q")
 proof (rule G.landau_cases[OF assms(1,2)])
   assume "g1 \<in> o[F](g2)"
   thus ?thesis by (auto intro!: gs_dominate assms landau_o.small_imp_big)
 next
   assume A: "g2 \<in> o[F](g1)"
   hence "g1 \<notin> O[F](g2)" using assms by (auto dest: G.small_big_antisym)
   moreover from gs_dominate[OF assms(2,1,4,3) A] have "g2*h2 \<in> o[F](g1*h1)" by (simp add: func_times)
   hence "g1*h1 \<notin> O[F](g2*h2)" by (blast intro: GH.small_big_antisym assms)
   ultimately show ?thesis using A assms
     by (auto simp: func_times dest: landau_o.small_imp_big)
 next
   assume A: "g1 \<in> \<Theta>[F](g2)"
   hence "g1 \<notin> o[F](g2)" unfolding bigtheta_def using assms
     by (auto dest: G.small_big_antisym simp: bigomega_iff_bigo)
   moreover have "O[F](\<lambda>x. g2 x * h2 x) = O[F](\<lambda>x. g1 x * h2 x)"
     by (subst landau_o.big.cong_bigtheta[OF landau_theta.mult_right[OF A]]) (rule refl)
   ultimately show ?thesis using A G.nonzero[OF assms(2)]
     by (auto simp: landau_o.big.mult_cancel_left eventually_nonzero_bigtheta)
 qed
 
 lemma bigtheta_iff:
   "g1 \<in> G \<Longrightarrow> g2 \<in> G \<Longrightarrow> h1 \<in> H \<Longrightarrow> h2 \<in> H \<Longrightarrow>
     (\<lambda>x. g1 x * h1 x) \<in> \<Theta>[F](\<lambda>x. g2 x * h2 x) \<longleftrightarrow> g1 \<in> \<Theta>[F](g2) \<and> h1 \<in> \<Theta>[F](h2)"
   by (auto simp: bigtheta_def bigo_iff bigomega_iff_bigo intro: landau_o.small_imp_big
            dest: G.small_antisym G.small_big_antisym)
 
 end
 
 
 lemma landau_function_family_powr_closure:
   assumes "F \<noteq> bot" "filterlim f at_top F"
   shows   "landau_function_family F (powr_closure f)"
 proof (unfold_locales; (elim powr_closureE; hypsubst)?)
   from assms have "eventually (\<lambda>x. f x \<ge> 1) F" using filterlim_at_top by auto
   hence A: "eventually (\<lambda>x. f x \<noteq> 0) F" by eventually_elim simp
   {
     fix p q :: real
     show "(\<lambda>x. f x powr p) \<in> o[F](\<lambda>x. f x powr q) \<or>
           (\<lambda>x. f x powr q) \<in> o[F](\<lambda>x. f x powr p) \<or>
           (\<lambda>x. f x powr p) \<in> \<Theta>[F](\<lambda>x. f x powr q)"
     by (cases p q rule: linorder_cases)
        (force intro!: smalloI_tendsto tendsto_neg_powr simp: powr_diff [symmetric]  assms A)+
   }
   fix p
   show "eventually (\<lambda>x. f x powr p > 0) F" using A by simp
 qed (auto simp: powr_add[symmetric] powr_minus[symmetric] \<open>F \<noteq> bot\<close> intro: powr_closureI)
 
 lemma landau_function_family_pair_trans:
   assumes "landau_function_family_pair Ftr F G f"
   assumes "landau_function_family_pair Ftr G H g"
   shows   "landau_function_family_pair Ftr F (G*H) f"
 proof-
   interpret FG: landau_function_family_pair Ftr F G f by fact
   interpret GH: landau_function_family_pair Ftr G H g by fact
   show ?thesis
   proof (unfold_locales; (elim set_times_elim)?; (clarify)?;
          (unfold func_times mult.assoc[symmetric])?)
     fix f1 f2 g1 g2 h1 h2
     assume A: "f1 \<in> F" "f2 \<in> F" "g1 \<in> G" "g2 \<in> G" "h1 \<in> H" "h2 \<in> H" "f1 \<in> o[Ftr](f2)"
 
     from A have "(\<lambda>x. f1 x * g1 x * h1 x) \<in> o[Ftr](\<lambda>x. f1 x * g1 x * g x)"
       by (intro landau_o.small.mult_left GH.g_dominates)
     also have "(\<lambda>x. f1 x * g1 x * g x) = (\<lambda>x. f1 x * (g1 x * g x))" by (simp only: mult.assoc)
     also from A have "... \<in> o[Ftr](\<lambda>x. f2 x * (g2 x / g x))"
       by (intro FG.gs_dominate FG.H.mult FG.H.div GH.g)
     also from A have "(\<lambda>x. inverse (h2 x)) \<in> o[Ftr](g)" by (intro GH.g_dominates GH.H.inverse)
     with GH.g A have "(\<lambda>x. f2 x * (g2 x / g x)) \<in> o[Ftr](\<lambda>x. f2 x * (g2 x * h2 x))"
       by (auto simp: FG.H.nonzero GH.H.nonzero divide_inverse
                intro!: landau_o.small.mult_left intro: landau_o.small.inverse_flip)
     also have "... = o[Ftr](\<lambda>x. f2 x * g2 x * h2 x)" by (simp only: mult.assoc)
     finally show "(\<lambda>x. f1 x * g1 x * h1 x) \<in> o[Ftr](\<lambda>x. f2 x * g2 x * h2 x)" .
   next
     fix g1 h1 assume A: "g1 \<in> G" "h1 \<in> H"
     hence "(\<lambda>x. g1 x * h1 x) \<in> o[Ftr](\<lambda>x. g1 x * g x)"
       by (intro landau_o.small.mult_left GH.g_dominates)
     also from A have "(\<lambda>x. g1 x * g x) \<in> o[Ftr](f)" by (intro FG.g_dominates FG.H.mult GH.g)
     finally show "(\<lambda>x. g1 x * h1 x) \<in> o[Ftr](f)" .
   qed (simp_all add: FG.g)
 qed
 
 lemma landau_function_family_pair_trans_powr:
   assumes "landau_function_family_pair F (powr_closure g) H (\<lambda>x. g x powr 1)"
   assumes "filterlim f at_top F"
   assumes "\<And>p. (\<lambda>x. g x powr p) \<in> o[F](f)"
   shows   "landau_function_family_pair F (powr_closure f) (powr_closure g * H) (\<lambda>x. f x powr 1)"
 proof (rule landau_function_family_pair_trans[OF _ assms(1)])
   interpret GH: landau_function_family_pair F "powr_closure g" H "\<lambda>x. g x powr 1" by fact
   interpret F: landau_function_family F "powr_closure f"
     by (rule landau_function_family_powr_closure) (rule GH.G.F_nontrivial, rule assms)
   show "landau_function_family_pair F (powr_closure f) (powr_closure g) (\<lambda>x. f x powr 1)"
   proof (unfold_locales; (elim powr_closureE; hypsubst)?)
     show "(\<lambda>x. f x powr 1) \<in> powr_closure f" by (rule powr_closureI)
   next
     fix p ::real
     note assms(3)[of p]
     also from assms(2) have "eventually (\<lambda>x. f x \<ge> 1) F" by (force simp: filterlim_at_top)
     hence "f \<in> \<Theta>[F](\<lambda>x. f x powr 1)" by (auto intro!: bigthetaI_cong elim!: eventually_mono)
     finally show "(\<lambda>x. g x powr p) \<in> o[F](\<lambda>x. f x powr 1)" .
   next
     fix p p1 p2 p3 :: real
     assume A: "(\<lambda>x. f x powr p) \<in> o[F](\<lambda>x. f x powr p1)"
     have p: "p < p1"
     proof (cases p p1 rule: linorder_cases)
       assume "p > p1"
       moreover from assms(2) have "eventually (\<lambda>x. f x \<ge> 1) F"
         by (force simp: filterlim_at_top)
       hence "eventually (\<lambda>x. f x \<noteq> 0) F" by eventually_elim simp
       ultimately have "(\<lambda>x. f x powr p1) \<in> o[F](\<lambda>x. f x powr p)" using assms
         by (auto intro!: smalloI_tendsto tendsto_neg_powr simp: powr_diff [symmetric] )
       from F.small_antisym[OF _ _ this A] show ?thesis by (auto simp: powr_closureI)
     next
       assume "p = p1"
       hence "(\<lambda>x. f x powr p1) \<in> O[F](\<lambda>x. f x powr p)" by (intro bigthetaD1) simp
       with F.small_big_antisym[OF _ _ A this] show ?thesis by (auto simp: powr_closureI)
     qed
 
     from assms(2) have f_pos: "eventually (\<lambda>x. f x \<ge> 1) F" by (force simp: filterlim_at_top)
     from assms have "(\<lambda>x. g x powr ((p2 - p3)/(p1 - p))) \<in> o[F](f)" by simp
     from smallo_powr[OF this, of "p1 - p"] p
       have "(\<lambda>x. g x powr (p2 - p3)) \<in> o[F](\<lambda>x. \<bar>f x\<bar> powr (p1 - p))" by (simp add: powr_powr)
     hence "(\<lambda>x. \<bar>f x\<bar> powr p * g x powr p2) \<in> o[F](\<lambda>x. \<bar>f x\<bar> powr p1 * g x powr p3)" (is ?P)
       using GH.G.nonzero[OF GH.g] F.nonzero[OF powr_closureI]
       by (simp add: powr_diff landau_o.small.divide_eq1
                     landau_o.small.divide_eq2 mult.commute)
     also have "?P \<longleftrightarrow> (\<lambda>x. f x powr p * g x powr p2) \<in> o[F](\<lambda>x. f x powr p1 * g x powr p3)"
       using f_pos by (intro landau_o.small.cong_ex) (auto elim!: eventually_mono)
     finally show "(\<lambda>x. f x powr p * g x powr p2) \<in> o[F](\<lambda>x. f x powr p1 * g x powr p3)" .
   qed
 qed
 
 
 definition dominates :: "'a filter \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> bool" where
   "dominates F f g = (\<forall>p. (\<lambda>x. g x powr p) \<in> o[F](f))"
 
 lemma dominates_trans:
   assumes "eventually (\<lambda>x. g x > 0) F"
   assumes "dominates F f g" "dominates F g h"
   shows   "dominates F f h"
 unfolding dominates_def
 proof
   fix p :: real
   from assms(3) have "(\<lambda>x. h x powr p) \<in> o[F](g)" unfolding dominates_def by simp
   also from assms(1) have "g \<in> \<Theta>[F](\<lambda>x. g x powr 1)"
     by (intro bigthetaI_cong) (auto elim!: eventually_mono)
   also from assms(2) have "(\<lambda>x. g x powr 1) \<in> o[F](f)" unfolding dominates_def by simp
   finally show "(\<lambda>x. h x powr p) \<in> o[F](f)" .
 qed
 
 fun landau_dominating_chain where
   "landau_dominating_chain F (f # g # gs) \<longleftrightarrow>
     dominates F f g \<and> landau_dominating_chain F (g # gs)"
 | "landau_dominating_chain F [f] \<longleftrightarrow> (\<lambda>x. 1) \<in> o[F](f)"
 | "landau_dominating_chain F [] \<longleftrightarrow> True"
 
 primrec landau_dominating_chain' where
   "landau_dominating_chain' F [] \<longleftrightarrow> True"
 | "landau_dominating_chain' F (f # gs) \<longleftrightarrow>
     landau_function_family_pair F (powr_closure f) (prod_list (map powr_closure gs)) (\<lambda>x. f x powr 1) \<and>
     landau_dominating_chain' F gs"
 
 
 
 primrec nonneg_list where
   "nonneg_list [] \<longleftrightarrow> True"
 | "nonneg_list (x#xs) \<longleftrightarrow> x > 0 \<or> (x = 0 \<and> nonneg_list xs)"
 
 primrec pos_list where
   "pos_list [] \<longleftrightarrow> False"
 | "pos_list (x#xs) \<longleftrightarrow> x > 0 \<or> (x = 0 \<and> pos_list xs)"
 
 
 lemma dominating_chain_imp_dominating_chain':
   "Ftr \<noteq> bot \<Longrightarrow> (\<And>g. g \<in> set gs \<Longrightarrow> filterlim g at_top Ftr) \<Longrightarrow>
      landau_dominating_chain Ftr gs \<Longrightarrow> landau_dominating_chain' Ftr gs"
 proof (induction gs rule: landau_dominating_chain.induct)
   case (1 F f g gs)
   from 1 show ?case
     by (auto intro!: landau_function_family_pair_trans_powr simp add: dominates_def)
 next
   case (2 F f)
   then interpret F: landau_function_family F "powr_closure f"
     by (intro landau_function_family_powr_closure) simp_all
   from 2 have "eventually (\<lambda>x. f x \<ge> 1) F" by (force simp: filterlim_at_top)
   hence "o[F](\<lambda>x. f x powr 1) = o[F](\<lambda>x. f x)"
     by (intro landau_o.small.cong) (auto elim!: eventually_mono)
   with 2 have "landau_function_family_pair F (powr_closure f) {\<lambda>_. 1} (\<lambda>x. f x powr 1)"
     by unfold_locales (auto intro: powr_closureI)
   thus ?case by (simp add: one_fun_def)
 next
   case 3
   then show ?case by simp
 qed
 
 
 locale landau_function_family_chain =
   fixes F :: "'b filter"
   fixes gs :: "'a list"
   fixes get_param :: "'a \<Rightarrow> real"
   fixes get_fun :: "'a \<Rightarrow> ('b \<Rightarrow> real)"
   assumes F_nontrivial: "F \<noteq> bot"
   assumes gs_pos: "g \<in> set (map get_fun gs) \<Longrightarrow> filterlim g at_top F"
   assumes dominating_chain: "landau_dominating_chain F (map get_fun gs)"
 begin
 
 lemma dominating_chain': "landau_dominating_chain' F (map get_fun gs)"
   by (intro dominating_chain_imp_dominating_chain' gs_pos dominating_chain F_nontrivial)
 
 lemma gs_powr_0_eq_one:
   "eventually (\<lambda>x. (\<Prod>g\<leftarrow>gs. get_fun g x powr 0) = 1) F"
 using gs_pos
 proof (induction gs)
   case (Cons g gs)
   from Cons have "eventually (\<lambda>x. get_fun g x > 0) F" by (auto simp: filterlim_at_top_dense)
   moreover from Cons have "eventually (\<lambda>x. (\<Prod>g\<leftarrow>gs. get_fun g x powr 0) = 1) F" by simp
   ultimately show ?case by eventually_elim simp
 qed simp_all
 
 lemma listmap_gs_in_listmap:
   "(\<lambda>x. \<Prod>g\<leftarrow>fs. h g x powr p g) \<in> prod_list (map powr_closure (map h fs))"
 proof-
   have "(\<lambda>x. \<Prod>g\<leftarrow>fs. h g x powr p g) = (\<Prod>g\<leftarrow>fs. (\<lambda>x. h g x powr p g))"
     by (rule ext, induction fs) simp_all
   also have "... \<in> prod_list (map powr_closure (map h fs))"
     apply (induction fs)
     apply (simp add: fun_eq_iff)
     apply (simp only: list.map prod_list.Cons, rule set_times_intro)
     apply simp_all
     done
   finally show ?thesis .
 qed
 
 lemma smallo_iff:
   "(\<lambda>_. 1) \<in> o[F](\<lambda>x. \<Prod>g\<leftarrow>gs. get_fun g x powr get_param g) \<longleftrightarrow> pos_list (map get_param gs)"
 proof-
   have "((\<lambda>_. 1) \<in> o[F](\<lambda>x. \<Prod>g\<leftarrow>gs. get_fun g x powr get_param g)) \<longleftrightarrow>
           ((\<lambda>x. \<Prod>g\<leftarrow>gs. get_fun g x powr 0) \<in> o[F](\<lambda>x. \<Prod>g\<leftarrow>gs. get_fun g x powr get_param g))"
     by (rule sym, intro landau_o.small.in_cong gs_powr_0_eq_one)
   also from gs_pos dominating_chain' have "... \<longleftrightarrow> pos_list (map get_param gs)"
   proof (induction gs)
     case Nil
     have "(\<lambda>x::'b. 1::real) \<notin> o[F](\<lambda>x. 1)" using F_nontrivial
       by (auto dest!: landau_o.small_big_asymmetric)
     thus ?case by simp
   next
     case (Cons g gs)
     then interpret G: landau_function_family_pair F "powr_closure (get_fun g)"
        "prod_list (map powr_closure (map get_fun gs))" "\<lambda>x. get_fun g x powr 1" by simp
     from Cons show ?case using listmap_gs_in_listmap[of get_fun _ gs] F_nontrivial
       by (simp_all add: G.smallo_iff listmap_gs_in_listmap powr_smallo_iff powr_bigtheta_iff
                    del: powr_zero_eq_one)
   qed
   finally show ?thesis .
 qed
 
 lemma bigo_iff:
   "(\<lambda>_. 1) \<in> O[F](\<lambda>x. \<Prod>g\<leftarrow>gs. get_fun g x powr get_param g) \<longleftrightarrow> nonneg_list (map get_param gs)"
 proof-
   have "((\<lambda>_. 1) \<in> O[F](\<lambda>x. \<Prod>g\<leftarrow>gs. get_fun g x powr get_param g)) \<longleftrightarrow>
           ((\<lambda>x. \<Prod>g\<leftarrow>gs. get_fun g x powr 0) \<in> O[F](\<lambda>x. \<Prod>g\<leftarrow>gs. get_fun g x powr get_param g))"
     by (rule sym, intro landau_o.big.in_cong gs_powr_0_eq_one)
   also from gs_pos dominating_chain' have "... \<longleftrightarrow> nonneg_list (map get_param gs)"
   proof (induction gs)
     case Nil
     then show ?case by (simp add: func_one)
   next
     case (Cons g gs)
     then interpret G: landau_function_family_pair F "powr_closure (get_fun g)"
        "prod_list (map powr_closure (map get_fun gs))" "\<lambda>x. get_fun g x powr 1" by simp
     from Cons show ?case using listmap_gs_in_listmap[of get_fun _ gs] F_nontrivial
       by (simp_all add: G.bigo_iff listmap_gs_in_listmap powr_smallo_iff powr_bigtheta_iff
                    del: powr_zero_eq_one)
   qed
   finally show ?thesis .
 qed
 
 lemma bigtheta_iff:
   "(\<lambda>_. 1) \<in> \<Theta>[F](\<lambda>x. \<Prod>g\<leftarrow>gs. get_fun g x powr get_param g) \<longleftrightarrow> list_all ((=) 0) (map get_param gs)"
 proof-
   have "((\<lambda>_. 1) \<in> \<Theta>[F](\<lambda>x. \<Prod>g\<leftarrow>gs. get_fun g x powr get_param g)) \<longleftrightarrow>
           ((\<lambda>x. \<Prod>g\<leftarrow>gs. get_fun g x powr 0) \<in> \<Theta>[F](\<lambda>x. \<Prod>g\<leftarrow>gs. get_fun g x powr get_param g))"
     by (rule sym, intro landau_theta.in_cong gs_powr_0_eq_one)
   also from gs_pos dominating_chain' have "... \<longleftrightarrow> list_all ((=) 0) (map get_param gs)"
   proof (induction gs)
     case Nil
     then show ?case by (simp add: func_one)
   next
     case (Cons g gs)
     then interpret G: landau_function_family_pair F "powr_closure (get_fun g)"
        "prod_list (map powr_closure (map get_fun gs))" "\<lambda>x. get_fun g x powr 1" by simp
     from Cons show ?case using listmap_gs_in_listmap[of get_fun _ gs] F_nontrivial
       by (simp_all add: G.bigtheta_iff listmap_gs_in_listmap powr_smallo_iff powr_bigtheta_iff
                    del: powr_zero_eq_one)
   qed
   finally show ?thesis .
 qed
 
 end
 
 
 
 lemma fun_chain_at_top_at_top:
   assumes "filterlim (f :: ('a::order) \<Rightarrow> 'a) at_top at_top"
   shows   "filterlim (f ^^ n) at_top at_top"
   by (induction n) (auto intro: filterlim_ident filterlim_compose[OF assms])
 
 lemma const_smallo_ln_chain: "(\<lambda>_. 1) \<in> o((ln::real\<Rightarrow>real)^^n)"
 proof (intro smalloI_tendsto)
   show "((\<lambda>x::real. 1 / (ln^^n) x) \<longlongrightarrow> 0) at_top"
     by (rule tendsto_divide_0 tendsto_const filterlim_at_top_imp_at_infinity
              fun_chain_at_top_at_top ln_at_top)+
 next
   from fun_chain_at_top_at_top[OF ln_at_top, of n]
     have "eventually (\<lambda>x::real. (ln^^n) x > 0) at_top" by (simp add: filterlim_at_top_dense)
   thus "eventually (\<lambda>x::real. (ln^^n) x \<noteq> 0) at_top" by eventually_elim simp_all
 qed
 
 lemma ln_fun_in_smallo_fun:
   assumes "filterlim f at_top at_top"
   shows   "(\<lambda>x. ln (f x) powr p :: real) \<in> o(f)"
 proof (rule smalloI_tendsto)
   have "((\<lambda>x. ln x powr p / x powr 1) \<longlongrightarrow> 0) at_top" by (rule tendsto_ln_powr_over_powr') simp
   moreover have "eventually (\<lambda>x. ln x powr p / x powr 1 = ln x powr p / x) at_top"
     using eventually_gt_at_top[of "0::real"] by eventually_elim simp
   ultimately have "((\<lambda>x. ln x powr p / x) \<longlongrightarrow> 0) at_top" by (subst (asm) tendsto_cong)
   from this assms show "((\<lambda>x. ln (f x) powr p / f x) \<longlongrightarrow> 0) at_top"
     by (rule filterlim_compose)
   from assms have "eventually (\<lambda>x. f x \<ge> 1) at_top" by (simp add: filterlim_at_top)
   thus "eventually (\<lambda>x. f x \<noteq> 0) at_top" by eventually_elim simp
 qed
 
 lemma ln_chain_dominates: "m > n \<Longrightarrow> dominates at_top ((ln::real \<Rightarrow> real)^^n) (ln^^m)"
 proof (erule less_Suc_induct)
   fix n show "dominates at_top ((ln::real\<Rightarrow>real)^^n) (ln^^(Suc n))" unfolding dominates_def
     by (force intro: ln_fun_in_smallo_fun fun_chain_at_top_at_top ln_at_top)
 next
   fix k m n
   assume A: "dominates at_top ((ln::real \<Rightarrow> real)^^k) (ln^^m)"
             "dominates at_top ((ln::real \<Rightarrow> real)^^m) (ln^^n)"
   from fun_chain_at_top_at_top[OF ln_at_top, of m]
     have "eventually (\<lambda>x::real. (ln^^m) x > 0) at_top" by (simp add: filterlim_at_top_dense)
   from this A show "dominates at_top ((ln::real \<Rightarrow> real)^^k) ((ln::real \<Rightarrow> real)^^n)"
     by (rule dominates_trans)
 qed
 
 
 
 
 
 
 datatype primfun = LnChain nat
 
 instantiation primfun :: linorder
 begin
 
 fun less_eq_primfun :: "primfun \<Rightarrow> primfun \<Rightarrow> bool" where
   "LnChain x \<le> LnChain y \<longleftrightarrow> x \<le> y"
 
 fun less_primfun :: "primfun \<Rightarrow> primfun \<Rightarrow> bool" where
   "LnChain x < LnChain y \<longleftrightarrow> x < y"
 
 instance
 proof (standard, goal_cases)
   case (1 x y) show ?case by (induction x y rule: less_eq_primfun.induct) auto
 next
   case (2 x) show ?case by (cases x) auto
 next
   case (3 x y z) thus ?case
     by (induction x y rule: less_eq_primfun.induct, cases z) auto
 next
   case (4 x y) thus ?case by (induction x y rule: less_eq_primfun.induct) auto
 next
   case (5 x y) thus ?case by (induction x y rule: less_eq_primfun.induct) auto
 qed
 
 end
 
 
 fun eval_primfun' :: "_ \<Rightarrow> _ \<Rightarrow> real" where
   "eval_primfun' (LnChain n) = (\<lambda>x. (ln^^n) x)"
 
 fun eval_primfun :: "_ \<Rightarrow> _ \<Rightarrow> real" where
   "eval_primfun (f, e) = (\<lambda>x. eval_primfun' f x powr e)"
 
 lemma eval_primfun_altdef: "eval_primfun f x = eval_primfun' (fst f) x powr snd f"
   by (cases f) simp
 
 fun merge_primfun where
   "merge_primfun (x::primfun, a) (y, b) = (x, a + b)"
 
 fun inverse_primfun where
   "inverse_primfun (x::primfun, a) = (x, -a)"
 
 fun powr_primfun where
   "powr_primfun (x::primfun, a) e = (x, e*a)"
 
 lemma primfun_cases:
   assumes "(\<And>n e. P (LnChain n, e))"
   shows   "P x"
 proof (cases x, hypsubst)
   fix a b show "P (a, b)" by (cases a; hypsubst, rule assms)
 qed
 
 
 
 lemma eval_primfun'_at_top: "filterlim (eval_primfun' f) at_top at_top"
   by (cases f) (auto intro!: fun_chain_at_top_at_top ln_at_top)
 
 lemma primfun_dominates:
   "f < g \<Longrightarrow> dominates at_top (eval_primfun' f) (eval_primfun' g)"
   by (elim less_primfun.elims; hypsubst) (simp_all add: ln_chain_dominates)
 
 lemma eval_primfun_pos: "eventually (\<lambda>x::real. eval_primfun f x > 0) at_top"
 proof (cases f, hypsubst)
   fix f e
   from eval_primfun'_at_top have "eventually (\<lambda>x. eval_primfun' f x > 0) at_top"
     by (auto simp: filterlim_at_top_dense)
   thus "eventually (\<lambda>x::real. eval_primfun (f,e) x > 0) at_top" by eventually_elim simp
 qed
 
 lemma eventually_nonneg_primfun: "eventually_nonneg at_top (eval_primfun f)"
   unfolding eventually_nonneg_def using eval_primfun_pos[of f] by eventually_elim simp
 
 lemma eval_primfun_nonzero: "eventually (\<lambda>x. eval_primfun f x \<noteq> 0) at_top"
   using eval_primfun_pos[of f] by eventually_elim simp
 
 lemma eval_merge_primfun:
   "fst f = fst g \<Longrightarrow>
      eval_primfun (merge_primfun f g) x = eval_primfun f x * eval_primfun g x"
   by (induction f g rule: merge_primfun.induct) (simp_all add: powr_add)
 
 lemma eval_inverse_primfun:
   "eval_primfun (inverse_primfun f) x = inverse (eval_primfun f x)"
   by (induction f rule: inverse_primfun.induct) (simp_all add: powr_minus)
 
 lemma eval_powr_primfun:
   "eval_primfun (powr_primfun f e) x = eval_primfun f x powr e"
   by (induction f e rule: powr_primfun.induct) (simp_all add: powr_powr mult.commute)
 
 
 definition eval_primfuns where
   "eval_primfuns fs x = (\<Prod>f\<leftarrow>fs. eval_primfun f x)"
 
 lemma eval_primfuns_pos: "eventually (\<lambda>x. eval_primfuns fs x > 0) at_top"
 proof-
   have prod_list_pos: "(\<And>x::_::linordered_semidom. x \<in> set xs \<Longrightarrow> x > 0) \<Longrightarrow> prod_list xs > 0"
     for xs :: "real list" by (induction xs) auto
   have "eventually (\<lambda>x. \<forall>f\<in>set fs. eval_primfun f x > 0) at_top"
     by (intro eventually_ball_finite ballI eval_primfun_pos finite_set)
   thus ?thesis unfolding eval_primfuns_def by eventually_elim (rule prod_list_pos, auto)
 qed
 
 lemma eval_primfuns_nonzero: "eventually (\<lambda>x. eval_primfuns fs x \<noteq> 0) at_top"
   using eval_primfuns_pos[of fs] by eventually_elim simp
 
 
 
 subsection \<open>Reification\<close>
 
 definition LANDAU_PROD' where
   "LANDAU_PROD' L c f = L(\<lambda>x. c * f x)"
 
 definition LANDAU_PROD where
   "LANDAU_PROD L c1 c2 fs \<longleftrightarrow> (\<lambda>_. c1) \<in> L(\<lambda>x. c2 * eval_primfuns fs x)"
 
 definition BIGTHETA_CONST' where "BIGTHETA_CONST' c = \<Theta>(\<lambda>x. c)"
 definition BIGTHETA_CONST where "BIGTHETA_CONST c A = set_mult \<Theta>(\<lambda>_. c) A"
 definition BIGTHETA_FUN where "BIGTHETA_FUN f = \<Theta>(f)"
 
 lemma BIGTHETA_CONST'_tag: "\<Theta>(\<lambda>x. c) = BIGTHETA_CONST' c" using BIGTHETA_CONST'_def ..
 lemma BIGTHETA_CONST_tag: "\<Theta>(f) = BIGTHETA_CONST 1 \<Theta>(f)"
   by (simp add: BIGTHETA_CONST_def bigtheta_mult_eq_set_mult[symmetric])
 lemma BIGTHETA_FUN_tag: "\<Theta>(f) = BIGTHETA_FUN f"
   by (simp add: BIGTHETA_FUN_def)
 
 lemma set_mult_is_times: "set_mult A B = A * B"
   unfolding set_mult_def set_times_def func_times by blast
 
 lemma set_powr_mult:
   assumes "eventually_nonneg F f" and "eventually_nonneg F g"
   shows   "\<Theta>[F](\<lambda>x. (f x * g x :: real) powr p) = set_mult (\<Theta>[F](\<lambda>x. f x powr p)) (\<Theta>[F](\<lambda>x. g x powr p))"
 proof-
   from assms have "eventually (\<lambda>x. f x \<ge> 0) F" "eventually (\<lambda>x. g x \<ge> 0) F"
     by (simp_all add: eventually_nonneg_def)
   hence "eventually (\<lambda>x. (f x * g x :: real) powr p = f x powr p * g x powr p) F"
     by eventually_elim (simp add: powr_mult)
   hence "\<Theta>[F](\<lambda>x. (f x * g x :: real) powr p) = \<Theta>[F](\<lambda>x. f x powr p * g x powr p)"
     by (rule landau_theta.cong)
   also have "... = set_mult (\<Theta>[F](\<lambda>x. f x powr p)) (\<Theta>[F](\<lambda>x. g x powr p))"
     by (simp add: bigtheta_mult_eq_set_mult)
   finally show ?thesis .
 qed
 
 lemma eventually_nonneg_bigtheta_pow_realpow:
   "\<Theta>(\<lambda>x. eval_primfun f x ^ e) = \<Theta>(\<lambda>x. eval_primfun f x powr real e)"
   using eval_primfun_pos[of f]
   by (auto intro!: landau_theta.cong elim!: eventually_mono simp: powr_realpow)
 
 lemma BIGTHETA_CONST_fold:
   "BIGTHETA_CONST (c::real) (BIGTHETA_CONST d A) = BIGTHETA_CONST (c*d) A"
   "bigtheta_pow at_top (BIGTHETA_CONST c \<Theta>(eval_primfun pf)) k =
      BIGTHETA_CONST (c ^ k) \<Theta>(\<lambda>x. eval_primfun pf x powr k)"
   "set_inverse (BIGTHETA_CONST c \<Theta>(f)) = BIGTHETA_CONST (inverse c) \<Theta>(\<lambda>x. inverse (f x))"
   "set_mult (BIGTHETA_CONST c \<Theta>(f)) (BIGTHETA_CONST d \<Theta>(g)) =
      BIGTHETA_CONST (c*d) \<Theta>(\<lambda>x. f x*g x)"
   "BIGTHETA_CONST' (c::real) = BIGTHETA_CONST c \<Theta>(\<lambda>_. 1)"
   "BIGTHETA_FUN (f::real\<Rightarrow>real) = BIGTHETA_CONST 1 \<Theta>(f)"
   apply (simp add: BIGTHETA_CONST_def set_mult_is_times bigtheta_mult_eq_set_mult mult_ac)
   apply (simp only: BIGTHETA_CONST_def bigtheta_mult_eq_set_mult[symmetric]
            bigtheta_pow_eq_set_pow[symmetric] power_mult_distrib mult_ac)
   apply (simp add: bigtheta_mult_eq_set_mult eventually_nonneg_bigtheta_pow_realpow)
   by (simp_all add: BIGTHETA_CONST_def BIGTHETA_CONST'_def BIGTHETA_FUN_def
         bigtheta_mult_eq_set_mult[symmetric] set_mult_is_times[symmetric]
         bigtheta_pow_eq_set_pow[symmetric] bigtheta_inverse_eq_set_inverse[symmetric]
         mult_ac power_mult_distrib)
 
 
 lemma fold_fun_chain:
   "g x = (g ^^ 1) x" "(g ^^ m) ((g ^^ n) x) = (g ^^ (m+n)) x"
   by (simp_all add: funpow_add)
 
 lemma reify_ln_chain1:
   "\<Theta>(\<lambda>x. (ln ^^ n) x) = \<Theta>(eval_primfun (LnChain n, 1))"
 proof (intro landau_theta.cong)
   have "filterlim ((ln :: real \<Rightarrow> real) ^^ n) at_top at_top"
     by (intro fun_chain_at_top_at_top ln_at_top)
   hence "eventually (\<lambda>x::real. (ln ^^ n) x > 0) at_top" using filterlim_at_top_dense by auto
   thus "eventually (\<lambda>x. (ln ^^ n) x = eval_primfun (LnChain n, 1) x) at_top"
     by eventually_elim simp
 qed
 
 lemma reify_monom1:
   "\<Theta>(\<lambda>x::real. x) = \<Theta>(eval_primfun (LnChain 0, 1))"
 proof (intro landau_theta.cong)
   from eventually_gt_at_top[of "0::real"]
     show "eventually (\<lambda>x. x = eval_primfun (LnChain 0, 1) x) at_top"
     by eventually_elim simp
 qed
 
 lemma reify_monom_pow:
   "\<Theta>(\<lambda>x::real. x ^ e) = \<Theta>(eval_primfun (LnChain 0, real e))"
 proof-
   have "\<Theta>(eval_primfun (LnChain 0, real e)) = \<Theta>(\<lambda>x. x powr (real e))" by simp
   also have "eventually (\<lambda>x. x powr (real e) = x ^ e) at_top"
     using eventually_gt_at_top[of 0] by eventually_elim (simp add: powr_realpow)
   hence "\<Theta>(\<lambda>x. x powr (real e)) = \<Theta>(\<lambda>x. x ^ e)"
     by (rule landau_theta.cong)
   finally show ?thesis ..
 qed
 
 lemma reify_monom_powr:
   "\<Theta>(\<lambda>x::real. x powr e) = \<Theta>(eval_primfun (LnChain 0, e))"
   by (rule landau_theta.cong) simp
 
 lemmas reify_monom = reify_monom1 reify_monom_pow reify_monom_powr
 
 
 lemma reify_ln_chain_pow:
   "\<Theta>(\<lambda>x. (ln ^^ n) x ^ e) = \<Theta>(eval_primfun (LnChain n, real e))"
 proof-
   have "\<Theta>(eval_primfun (LnChain n, real e)) = \<Theta>(\<lambda>x. (ln ^^ n) x powr (real e))" by simp
   also have "eventually (\<lambda>x::real. (ln ^^ n) x > 0) at_top"
     using fun_chain_at_top_at_top[OF ln_at_top] unfolding filterlim_at_top_dense by blast
   hence "eventually (\<lambda>x. (ln ^^ n) x powr (real e) = (ln ^^ n) x ^ e) at_top"
     by eventually_elim (subst powr_realpow, auto)
   hence "\<Theta>(\<lambda>x. (ln ^^ n) x powr (real e)) = \<Theta>(\<lambda>x. (ln ^^ n) x^e)"
     by (rule landau_theta.cong)
   finally show ?thesis ..
 qed
 
 lemma reify_ln_chain_powr:
   "\<Theta>(\<lambda>x. (ln ^^ n) x powr e) = \<Theta>(eval_primfun (LnChain n, e))"
   by (intro landau_theta.cong) simp
 
 lemmas reify_ln_chain = reify_ln_chain1 reify_ln_chain_pow reify_ln_chain_powr
 
 lemma numeral_power_Suc: "numeral n ^ Suc a = numeral n * numeral n ^ a"
   by (rule power.simps)
 
 lemmas landau_product_preprocess =
   one_add_one one_plus_numeral numeral_plus_one arith_simps numeral_power_Suc power_0
   fold_fun_chain[where g = ln] reify_ln_chain reify_monom
 
 
 lemma LANDAU_PROD'_fold:
   "BIGTHETA_CONST e \<Theta>(\<lambda>_. d) = BIGTHETA_CONST (e*d) \<Theta>(eval_primfuns [])"
   "LANDAU_PROD' c (\<lambda>_. 1) = LANDAU_PROD' c (eval_primfuns [])"
   "eval_primfun f = eval_primfuns [f]"
   "eval_primfuns fs x * eval_primfuns gs x = eval_primfuns (fs @ gs) x"
   apply (simp only: BIGTHETA_CONST_def set_mult_is_times eval_primfuns_def[abs_def] bigtheta_mult_eq)
   apply (simp add: bigtheta_mult_eq[symmetric])
   by (simp_all add: eval_primfuns_def[abs_def] BIGTHETA_CONST_def)
 
 
 lemma inverse_prod_list_field:
   "prod_list (map (\<lambda>x. inverse (f x)) xs) = inverse (prod_list (map f xs :: _ :: field list))"
   by (induction xs) simp_all
 
 lemma landau_prod_meta_cong:
   assumes "landau_symbol L L' Lr"
   assumes "\<Theta>(f) \<equiv> BIGTHETA_CONST c1 (\<Theta>(eval_primfuns fs))"
   assumes "\<Theta>(g) \<equiv> BIGTHETA_CONST c2 (\<Theta>(eval_primfuns gs))"
   shows   "f \<in> L at_top (g) \<equiv> LANDAU_PROD (L at_top) c1 c2 (map inverse_primfun fs @ gs)"
 proof-
   interpret landau_symbol L L' Lr by fact
   have "f \<in> L at_top (g) \<longleftrightarrow> (\<lambda>x. c1 * eval_primfuns fs x) \<in> L at_top (\<lambda>x. c2 * eval_primfuns gs x)"
     using assms(2,3)[symmetric] unfolding BIGTHETA_CONST_def
     by (intro cong_ex_bigtheta) (simp_all add: bigtheta_mult_eq_set_mult[symmetric])
   also have "... \<longleftrightarrow> (\<lambda>x. c1) \<in> L at_top (\<lambda>x. c2 * eval_primfuns gs x / eval_primfuns fs x)"
     by (simp_all add: eval_primfuns_nonzero divide_eq1)
   finally show "f \<in> L at_top (g) \<equiv> LANDAU_PROD (L at_top) c1 c2 (map inverse_primfun fs @ gs)"
     by (simp add: LANDAU_PROD_def eval_primfuns_def eval_inverse_primfun
                   divide_inverse o_def inverse_prod_list_field mult_ac)
 qed
 
 fun pos_primfun_list where
   "pos_primfun_list [] \<longleftrightarrow> False"
 | "pos_primfun_list ((_,x)#xs) \<longleftrightarrow> x > 0 \<or> (x = 0 \<and> pos_primfun_list xs)"
 
 fun nonneg_primfun_list where
   "nonneg_primfun_list [] \<longleftrightarrow> True"
 | "nonneg_primfun_list ((_,x)#xs) \<longleftrightarrow> x > 0 \<or> (x = 0 \<and> nonneg_primfun_list xs)"
 
 fun iszero_primfun_list where
   "iszero_primfun_list [] \<longleftrightarrow> True"
 | "iszero_primfun_list ((_,x)#xs) \<longleftrightarrow> x = 0 \<and> iszero_primfun_list xs"
 
 
 definition "group_primfuns \<equiv> groupsort.group_sort fst merge_primfun"
 
 lemma list_ConsCons_induct:
   assumes "P []" "\<And>x. P [x]" "\<And>x y xs. P (y#xs) \<Longrightarrow> P (x#y#xs)"
   shows   "P xs"
 proof (induction xs rule: length_induct)
   case (1 xs)
   show ?case
   proof (cases xs)
     case (Cons x xs')
     note A = this
     from assms 1 show ?thesis
     proof (cases xs')
       case (Cons y xs'')
       with 1 A have "P (y#xs'')" by simp
       with Cons A assms show ?thesis by simp
     qed (simp add: assms A)
   qed (simp add: assms)
 qed
 
 
 lemma landau_function_family_chain_primfuns:
   assumes "sorted (map fst fs)"
   assumes "distinct (map fst fs)"
   shows   "landau_function_family_chain at_top fs (eval_primfun' o fst)"
 proof (standard, goal_cases)
   case 3
   from assms show ?case
   proof (induction fs rule: list_ConsCons_induct)
     case (2 g)
     from eval_primfun'_at_top[of "fst g"]
       have "eval_primfun' (fst g) \<in> \<omega>(\<lambda>_. 1)"
       by (intro smallomegaI_filterlim_at_infinity filterlim_at_top_imp_at_infinity) simp
     thus ?case by (simp add: smallomega_iff_smallo)
   next
     case (3 f g gs)
     thus ?case by (auto simp: primfun_dominates)
   qed simp
 qed (auto simp: eval_primfun'_at_top)
 
 lemma (in monoid_mult) fold_plus_prod_list_rev:
   "fold times xs = times (prod_list (rev xs))"
 proof
   fix x
   have "fold times xs x = prod_list (rev xs @ [x])"
     by (simp add: foldr_conv_fold prod_list.eq_foldr)
   also have "\<dots> = prod_list (rev xs) * x"
     by simp
   finally show "fold times xs x = prod_list (rev xs) * x" .
 qed
 
 interpretation groupsort_primfun: groupsort fst merge_primfun eval_primfuns
 proof (standard, goal_cases)
   case (1 x y)
   thus ?case by (induction x y rule: merge_primfun.induct) simp_all
 next
   case (2 fs gs)
   show ?case
   proof
     fix x
     have "eval_primfuns fs x = fold (*) (map (\<lambda>f. eval_primfun f x) fs) 1"
       unfolding eval_primfuns_def by (simp add: fold_plus_prod_list_rev)
     also have "fold (*) (map (\<lambda>f. eval_primfun f x) fs) = fold (*) (map (\<lambda>f. eval_primfun f x) gs)"
       using 2 by (intro fold_multiset_equiv ext) auto
     also have "... 1 = eval_primfuns gs x"
       unfolding eval_primfuns_def by (simp add: fold_plus_prod_list_rev)
     finally show "eval_primfuns fs x = eval_primfuns gs x" .
   qed
 qed (auto simp: fun_eq_iff eval_merge_primfun eval_primfuns_def)
 
 lemma nonneg_primfun_list_iff: "nonneg_primfun_list fs = nonneg_list (map snd fs)"
   by (induction fs rule: nonneg_primfun_list.induct) simp_all
 
 lemma pos_primfun_list_iff: "pos_primfun_list fs = pos_list (map snd fs)"
   by (induction fs rule: pos_primfun_list.induct) simp_all
 
 lemma iszero_primfun_list_iff: "iszero_primfun_list fs = list_all ((=) 0) (map snd fs)"
   by (induction fs rule: iszero_primfun_list.induct) simp_all
 
 lemma landau_primfuns_iff:
   "((\<lambda>_. 1) \<in> O(eval_primfuns fs)) = nonneg_primfun_list (group_primfuns fs)" (is "?A")
   "((\<lambda>_. 1) \<in> o(eval_primfuns fs)) = pos_primfun_list (group_primfuns fs)" (is "?B")
   "((\<lambda>_. 1) \<in> \<Theta>(eval_primfuns fs)) = iszero_primfun_list (group_primfuns fs)" (is "?C")
 proof-
   interpret landau_function_family_chain at_top "group_primfuns fs" snd "eval_primfun' o fst"
     by (rule landau_function_family_chain_primfuns)
        (simp_all add: group_primfuns_def groupsort_primfun.sorted_group_sort
                       groupsort_primfun.distinct_group_sort)
 
   have "(\<lambda>_. 1) \<in> O(eval_primfuns fs) \<longleftrightarrow> (\<lambda>_. 1) \<in> O(eval_primfuns (group_primfuns fs))"
     by (simp_all add: groupsort_primfun.g_group_sort group_primfuns_def)
   also have "... \<longleftrightarrow> nonneg_list (map snd (group_primfuns fs))" using bigo_iff
     by (simp add: eval_primfuns_def[abs_def] eval_primfun_altdef)
   finally show ?A by (simp add: nonneg_primfun_list_iff)
 
   have "(\<lambda>_. 1) \<in> o(eval_primfuns fs) \<longleftrightarrow> (\<lambda>_. 1) \<in> o(eval_primfuns (group_primfuns fs))"
     by (simp_all add: groupsort_primfun.g_group_sort group_primfuns_def)
   also have "... \<longleftrightarrow> pos_list (map snd (group_primfuns fs))" using smallo_iff
     by (simp add: eval_primfuns_def[abs_def] eval_primfun_altdef)
   finally show ?B by (simp add: pos_primfun_list_iff)
 
   have "(\<lambda>_. 1) \<in> \<Theta>(eval_primfuns fs) \<longleftrightarrow> (\<lambda>_. 1) \<in> \<Theta>(eval_primfuns (group_primfuns fs))"
     by (simp_all add: groupsort_primfun.g_group_sort group_primfuns_def)
   also have "... \<longleftrightarrow> list_all ((=) 0) (map snd (group_primfuns fs))" using bigtheta_iff
     by (simp add: eval_primfuns_def[abs_def] eval_primfun_altdef)
   finally show ?C by (simp add: iszero_primfun_list_iff)
 qed
 
 
 lemma LANDAU_PROD_bigo_iff:
   "LANDAU_PROD (bigo at_top) c1 c2 fs \<longleftrightarrow> c1 = 0 \<or> (c2 \<noteq> 0 \<and> nonneg_primfun_list (group_primfuns fs))"
   unfolding LANDAU_PROD_def
   by (cases "c1 = 0", simp, cases "c2 = 0", simp) (simp_all add: landau_primfuns_iff)
 
 lemma LANDAU_PROD_smallo_iff:
   "LANDAU_PROD (smallo at_top) c1 c2 fs \<longleftrightarrow> c1 = 0 \<or> (c2 \<noteq> 0 \<and> pos_primfun_list (group_primfuns fs))"
   unfolding LANDAU_PROD_def
   by (cases "c1 = 0", simp, cases "c2 = 0", simp) (simp_all add: landau_primfuns_iff)
 
 lemma LANDAU_PROD_bigtheta_iff:
   "LANDAU_PROD (bigtheta at_top) c1 c2 fs \<longleftrightarrow> (c1 = 0 \<and> c2 = 0) \<or> (c1 \<noteq> 0 \<and> c2 \<noteq> 0 \<and>
      iszero_primfun_list (group_primfuns fs))"
 proof-
   have A: "\<And>P x. (x = 0 \<Longrightarrow> P) \<Longrightarrow> (x \<noteq> 0 \<Longrightarrow> P) \<Longrightarrow> P" by blast
   {
     assume "eventually (\<lambda>x. eval_primfuns fs x = 0) at_top"
     with eval_primfuns_nonzero[of fs] have "eventually (\<lambda>x::real. False) at_top"
       by eventually_elim simp
     hence False by simp
   } note B = this
   show ?thesis by (rule A[of c1, case_product A[of c2]])
                   (insert B, auto simp: LANDAU_PROD_def landau_primfuns_iff)
 qed
 
 lemmas LANDAU_PROD_iff = LANDAU_PROD_bigo_iff LANDAU_PROD_smallo_iff LANDAU_PROD_bigtheta_iff
 
 
 lemmas landau_real_prod_simps [simp] =
   groupsort_primfun.group_part_def
   group_primfuns_def groupsort_primfun.group_sort.simps
   groupsort_primfun.group_part_aux.simps pos_primfun_list.simps
   nonneg_primfun_list.simps iszero_primfun_list.simps
 
 end
diff --git a/thys/Linear_Recurrences/RatFPS.thy b/thys/Linear_Recurrences/RatFPS.thy
--- a/thys/Linear_Recurrences/RatFPS.thy
+++ b/thys/Linear_Recurrences/RatFPS.thy
@@ -1,948 +1,966 @@
 (*
   File:    RatFPS.thy
   Author:  Manuel Eberl, TU München
 *)
 section \<open>Rational formal power series\<close>
 theory RatFPS
 imports 
   Complex_Main 
   "HOL-Computational_Algebra.Computational_Algebra"
   "HOL-Computational_Algebra.Polynomial_Factorial"
 begin
 
 subsection \<open>Some auxiliary\<close>
 
 abbreviation constant_term :: "'a poly \<Rightarrow> 'a::zero"
   where "constant_term p \<equiv> coeff p 0"
 
 lemma coeff_0_mult: "coeff (p * q) 0 = coeff p 0 * coeff q 0"
   by (simp add: coeff_mult)
 
 lemma coeff_0_div: 
   assumes "coeff p 0 \<noteq> 0" 
   assumes "(q :: 'a :: field poly) dvd p"
   shows   "coeff (p div q) 0 = coeff p 0 div coeff q 0"
 proof (cases "q = 0")
   case False
   from assms have "p = p div q * q" by simp
   also have "coeff \<dots> 0 = coeff (p div q) 0 * coeff q 0" by (simp add: coeff_0_mult)
   finally show ?thesis using assms by auto
 qed simp_all
 
 lemma coeff_0_add_fract_nonzero:
   assumes "coeff (snd (quot_of_fract x)) 0 \<noteq> 0" "coeff (snd (quot_of_fract y)) 0 \<noteq> 0"
   shows   "coeff (snd (quot_of_fract (x + y))) 0 \<noteq> 0"
 proof -
   define num where "num = fst (quot_of_fract x) * snd (quot_of_fract y) + 
     snd (quot_of_fract x) * fst (quot_of_fract y)"
   define denom where "denom = snd (quot_of_fract x) * snd (quot_of_fract y)"
   define z where "z = (num, denom)"
   from assms have "snd z \<noteq> 0" by (auto simp: denom_def z_def)
-  from normalize_quotE'[OF this] guess d . note d = this
+  then obtain d where d:
+    "fst z = fst (normalize_quot z) * d"
+    "snd z = snd (normalize_quot z) * d"
+    "d dvd fst z"
+    "d dvd snd z"
+    "d \<noteq> 0"
+    by (rule normalize_quotE')
   from assms have z: "coeff (snd z) 0 \<noteq> 0" by (simp add: z_def denom_def coeff_0_mult)
   
   have "coeff (snd (quot_of_fract (x + y))) 0 = coeff (snd (normalize_quot z)) 0"
     by (simp add: quot_of_fract_add Let_def case_prod_unfold z_def num_def denom_def)
   also from z have "\<dots> \<noteq> 0" using d by (simp add: d coeff_0_mult)
   finally show ?thesis .
 qed
 
 lemma coeff_0_normalize_quot_nonzero [simp]:
   assumes "coeff (snd x) 0 \<noteq> 0"
   shows   "coeff (snd (normalize_quot x)) 0 \<noteq> 0"
 proof -
   from assms have "snd x \<noteq> 0" by auto
-  from normalize_quotE'[OF this] guess d .
+  then obtain d where
+      "fst x = fst (normalize_quot x) * d"
+      "snd x = snd (normalize_quot x) * d"
+      "d dvd fst x"
+      "d dvd snd x"
+      "d \<noteq> 0"
+    by (rule normalize_quotE')
   with assms show ?thesis by (auto simp: coeff_0_mult)
 qed
 
 abbreviation numerator :: "'a fract \<Rightarrow> 'a::{ring_gcd,idom_divide,semiring_gcd_mult_normalize}"
   where "numerator x \<equiv> fst (quot_of_fract x)"
 
 abbreviation denominator :: "'a fract \<Rightarrow> 'a::{ring_gcd,idom_divide,semiring_gcd_mult_normalize}"
   where "denominator x \<equiv> snd (quot_of_fract x)"
 
 declare unit_factor_snd_quot_of_fract [simp]
   normalize_snd_quot_of_fract [simp]
 
 lemma constant_term_denominator_nonzero_imp_constant_term_denominator_div_gcd_nonzero:
   "constant_term (denominator x div gcd a (denominator x)) \<noteq> 0"
   if "constant_term (denominator x) \<noteq> 0"
   using that coeff_0_normalize_quot_nonzero [of "(a, denominator x)"]
   normalize_quot_proj(2) [of "denominator x" a]
   by simp
 
 
 subsection \<open>The type of rational formal power series\<close>
 
 typedef (overloaded) 'a :: field_gcd ratfps = 
   "{x :: 'a poly fract. constant_term (denominator x) \<noteq> 0}"
   by (rule exI [of _ 0]) simp
 
 setup_lifting type_definition_ratfps
 
 instantiation ratfps :: (field_gcd) idom
 begin
 
 lift_definition zero_ratfps :: "'a ratfps" is "0" by simp
 
 lift_definition one_ratfps :: "'a ratfps" is "1" by simp
 
 lift_definition uminus_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps" is "uminus" 
   by (simp add: quot_of_fract_uminus case_prod_unfold Let_def)
 
 lift_definition plus_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps \<Rightarrow> 'a ratfps" is "(+)"
   by (rule coeff_0_add_fract_nonzero)
 
 lift_definition minus_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps \<Rightarrow> 'a ratfps" is "(-)"
   by (simp only: diff_conv_add_uminus, rule coeff_0_add_fract_nonzero)
      (simp_all add: quot_of_fract_uminus Let_def case_prod_unfold)
 
 lift_definition times_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps \<Rightarrow> 'a ratfps" is "(*)"
   by (simp add: quot_of_fract_mult Let_def case_prod_unfold coeff_0_mult
     constant_term_denominator_nonzero_imp_constant_term_denominator_div_gcd_nonzero)
  
 instance
   by (standard; transfer) (simp_all add: ring_distribs)
 
 end
 
 fun ratfps_nth_aux :: "('a::field) poly \<Rightarrow> nat \<Rightarrow> 'a"
 where
   "ratfps_nth_aux p 0 = inverse (coeff p 0)"
 | "ratfps_nth_aux p n = 
      - inverse (coeff p 0) * sum (\<lambda>i. coeff p i * ratfps_nth_aux p (n - i)) {1..n}"
 
 lemma ratfps_nth_aux_correct: "ratfps_nth_aux p n = natfun_inverse (fps_of_poly p) n"
   by (induction p n rule: ratfps_nth_aux.induct) simp_all
 
 lift_definition ratfps_nth :: "'a :: field_gcd ratfps \<Rightarrow> nat \<Rightarrow> 'a" is
   "\<lambda>x n. let (a,b) = quot_of_fract x
          in  (\<Sum>i = 0..n. coeff a i * ratfps_nth_aux b (n - i))" .
 
 lift_definition ratfps_subdegree :: "'a :: field_gcd ratfps \<Rightarrow> nat" is
   "\<lambda>x. poly_subdegree (fst (quot_of_fract x))" . 
 
 context
 includes lifting_syntax
 begin
   
 lemma RatFPS_parametric: "(rel_prod (=) (=) ===> (=))
   (\<lambda>(p,q). if coeff q 0 = 0 then 0 else quot_to_fract (p, q))
   (\<lambda>(p,q). if coeff q 0 = 0 then 0 else quot_to_fract (p, q))"
   by transfer_prover
   
 end
 
 
 lemma normalize_quot_quot_of_fract [simp]: 
   "normalize_quot (quot_of_fract x) = quot_of_fract x"
   by (rule normalize_quot_id, rule quot_of_fract_in_normalized_fracts)
 
 context
 assumes "SORT_CONSTRAINT('a::field_gcd)"
 begin
 
 lift_definition quot_of_ratfps :: "'a ratfps \<Rightarrow> ('a poly \<times> 'a poly)" is
   "quot_of_fract :: 'a poly fract \<Rightarrow> ('a poly \<times> 'a poly)" .
 
 lift_definition quot_to_ratfps :: "('a poly \<times> 'a poly) \<Rightarrow> 'a ratfps" is
   "\<lambda>(x,y). let (x',y') = normalize_quot (x,y) 
            in  if coeff y' 0 = 0 then 0 else quot_to_fract (x',y')"
   by (simp add: case_prod_unfold Let_def quot_of_fract_quot_to_fract)
 
 lemma quot_to_ratfps_quot_of_ratfps [code abstype]:
   "quot_to_ratfps (quot_of_ratfps x) = x"
   by transfer (simp add: case_prod_unfold Let_def)
 
 lemma coeff_0_snd_quot_of_ratfps_nonzero [simp]: 
   "coeff (snd (quot_of_ratfps x)) 0 \<noteq> 0"
   by transfer simp
 
 lemma quot_of_ratfps_quot_to_ratfps:
   "coeff (snd x) 0 \<noteq> 0 \<Longrightarrow> x \<in> normalized_fracts \<Longrightarrow> quot_of_ratfps (quot_to_ratfps x) = x"
   by transfer (simp add: Let_def case_prod_unfold coeff_0_normalize_quot_nonzero 
                  quot_of_fract_quot_to_fract normalize_quot_id)
 
 lemma quot_of_ratfps_0 [simp, code abstract]: "quot_of_ratfps 0 = (0, 1)"
   by transfer simp_all
 
 lemma quot_of_ratfps_1 [simp, code abstract]: "quot_of_ratfps 1 = (1, 1)"
   by transfer simp_all
 
 lift_definition ratfps_of_poly :: "'a poly \<Rightarrow> 'a ratfps" is
   "to_fract :: 'a poly \<Rightarrow> _"
   by transfer simp
 
 lemma ratfps_of_poly_code [code abstract]:
   "quot_of_ratfps (ratfps_of_poly p) = (p, 1)"
   by transfer' simp
 
 lemmas zero_ratfps_code = quot_of_ratfps_0
 
 lemmas one_ratfps_code = quot_of_ratfps_1
   
 lemma uminus_ratfps_code [code abstract]: 
   "quot_of_ratfps (- x) = (let (a, b) = quot_of_ratfps x in (-a, b))"
   by transfer (rule quot_of_fract_uminus)
 
 lemma plus_ratfps_code [code abstract]:
   "quot_of_ratfps (x + y) = 
      (let (a,b) = quot_of_ratfps x; (c,d) = quot_of_ratfps y
       in  normalize_quot (a * d + b * c, b * d))"
   by transfer' (rule quot_of_fract_add)
 
 lemma minus_ratfps_code [code abstract]:
   "quot_of_ratfps (x - y) = 
      (let (a,b) = quot_of_ratfps x; (c,d) = quot_of_ratfps y
       in  normalize_quot (a * d - b * c, b * d))"
   by transfer' (rule quot_of_fract_diff) 
 
 definition ratfps_cutoff :: "nat \<Rightarrow> 'a :: field_gcd ratfps \<Rightarrow> 'a poly" where
   "ratfps_cutoff n x = poly_of_list (map (ratfps_nth x) [0..<n])"
 
 definition ratfps_shift :: "nat \<Rightarrow> 'a :: field_gcd ratfps \<Rightarrow> 'a ratfps" where
   "ratfps_shift n x = (let (a, b) = quot_of_ratfps (x - ratfps_of_poly (ratfps_cutoff n x))
                        in  quot_to_ratfps (poly_shift n a, b))"
  
 lemma times_ratfps_code [code abstract]:
   "quot_of_ratfps (x * y) = 
      (let (a,b) = quot_of_ratfps x; (c,d) = quot_of_ratfps y;
           (e,f) = normalize_quot (a,d); (g,h) = normalize_quot (c,b)
       in  (e*g, f*h))"
   by transfer' (rule quot_of_fract_mult)
 
 lemma ratfps_nth_code [code]:
   "ratfps_nth x n = 
     (let (a,b) = quot_of_ratfps x
      in  \<Sum>i = 0..n. coeff a i * ratfps_nth_aux b (n - i))"
   by transfer' simp
 
 lemma ratfps_subdegree_code [code]:
   "ratfps_subdegree x = poly_subdegree (fst (quot_of_ratfps x))"
   by transfer simp
 
 end
 
 instantiation ratfps :: ("field_gcd") inverse
 begin
 
 lift_definition inverse_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps" is
   "\<lambda>x. let (a,b) = quot_of_fract x
        in  if coeff a 0 = 0 then 0 else inverse x"
   by (auto simp: case_prod_unfold Let_def quot_of_fract_inverse)
 
 lift_definition divide_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps \<Rightarrow> 'a ratfps" is
   "\<lambda>f g. (if g = 0 then 0 else 
            let n = ratfps_subdegree g; h = ratfps_shift n g
            in  ratfps_shift n (f * inverse h))" .  
 
 instance ..
 end
 
 lemma ratfps_inverse_code [code abstract]:
   "quot_of_ratfps (inverse x) = 
      (let (a,b) = quot_of_ratfps x
       in  if coeff a 0 = 0 then (0, 1)
           else let u = unit_factor a in (b div u, a div u))"
   by transfer' (simp_all add: Let_def case_prod_unfold quot_of_fract_inverse)
 
 instantiation ratfps :: (equal) equal
 begin
 
 definition equal_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps \<Rightarrow> bool" where
   [simp]: "equal_ratfps x y \<longleftrightarrow> x = y"
 
 instance by standard simp
 
 end
 
 lemma quot_of_fract_eq_iff [simp]: "quot_of_fract x = quot_of_fract y \<longleftrightarrow> x = y"
   by transfer (auto simp: normalize_quot_eq_iff)
 
 lemma equal_ratfps_code [code]: "HOL.equal x y \<longleftrightarrow> quot_of_ratfps x = quot_of_ratfps y"
   unfolding equal_ratfps_def by transfer simp
 
 lemma fps_of_poly_quot_normalize_quot [simp]:
   "fps_of_poly (fst (normalize_quot x)) / fps_of_poly (snd (normalize_quot x)) =
      fps_of_poly (fst x) / fps_of_poly (snd x)"
   if "(snd x :: 'a :: field_gcd poly) \<noteq> 0"
 proof -
   from that obtain d where "fst x = fst (normalize_quot x) * d"
     and "snd x = snd (normalize_quot x) * d" and "d \<noteq> 0"
     by (rule normalize_quotE')
   then show ?thesis
     by (simp add: fps_of_poly_mult)
 qed
 
 lemma fps_of_poly_quot_normalize_quot' [simp]:
   "fps_of_poly (fst (normalize_quot x)) / fps_of_poly (snd (normalize_quot x)) =
      fps_of_poly (fst x) / fps_of_poly (snd x)"
   if "coeff (snd x) 0 \<noteq> (0 :: 'a :: field_gcd)"
   using that by (auto intro: fps_of_poly_quot_normalize_quot)
 
 lift_definition fps_of_ratfps :: "'a :: field_gcd ratfps \<Rightarrow> 'a fps" is
   "\<lambda>x. fps_of_poly (numerator x) / fps_of_poly (denominator x)" .
 
 lemma fps_of_ratfps_altdef: 
   "fps_of_ratfps x = (case quot_of_ratfps x of (a, b) \<Rightarrow> fps_of_poly a / fps_of_poly b)"
   by transfer (simp add: case_prod_unfold)
 
 lemma fps_of_ratfps_ratfps_of_poly [simp]: "fps_of_ratfps (ratfps_of_poly p) = fps_of_poly p"
   by transfer simp
 
 lemma fps_of_ratfps_0 [simp]: "fps_of_ratfps 0 = 0"
   by transfer simp
   
 lemma fps_of_ratfps_1 [simp]: "fps_of_ratfps 1 = 1"
   by transfer simp
 
 lemma fps_of_ratfps_uminus [simp]: "fps_of_ratfps (-x) = - fps_of_ratfps x"
   by transfer (simp add: quot_of_fract_uminus case_prod_unfold Let_def fps_of_poly_simps dvd_neg_div)
   
 lemma fps_of_ratfps_add [simp]: "fps_of_ratfps (x + y) = fps_of_ratfps x + fps_of_ratfps y"
   by transfer (simp add: quot_of_fract_add Let_def case_prod_unfold fps_of_poly_simps)
 
 lemma fps_of_ratfps_diff [simp]: "fps_of_ratfps (x - y) = fps_of_ratfps x - fps_of_ratfps y"
   by transfer (simp add: quot_of_fract_diff Let_def case_prod_unfold fps_of_poly_simps)
 
 lemma is_unit_div_div_commute: "is_unit b \<Longrightarrow> is_unit c \<Longrightarrow> a div b div c = a div c div b"
   by (metis is_unit_div_mult2_eq mult.commute)
 
 lemma fps_of_ratfps_mult [simp]: "fps_of_ratfps (x * y) = fps_of_ratfps x * fps_of_ratfps y"
 proof (transfer, goal_cases)
   case (1 x y)
   moreover define x' y' where "x' = quot_of_fract x" and "y' = quot_of_fract y"
   ultimately have assms: "coeff (snd x') 0 \<noteq> 0" "coeff (snd y') 0 \<noteq> 0"
     by simp_all
   moreover define w z where "w = normalize_quot (fst x', snd y')" and "z = normalize_quot (fst y', snd x')"
   ultimately have unit: "coeff (snd x') 0 \<noteq> 0" "coeff (snd y') 0 \<noteq> 0" 
     "coeff (snd w) 0 \<noteq> 0" "coeff (snd z) 0 \<noteq> 0"
     by (simp_all add: coeff_0_normalize_quot_nonzero)
   have "fps_of_poly (fst w * fst z) / fps_of_poly (snd w * snd z) =
           (fps_of_poly (fst w) / fps_of_poly (snd w)) *
           (fps_of_poly (fst z) / fps_of_poly (snd z))" (is "_ = ?A * ?B")
     by (simp add: is_unit_div_mult2_eq fps_of_poly_mult unit_div_mult_swap unit_div_commute unit)
   also have "\<dots> = (fps_of_poly (fst x') / fps_of_poly (snd x')) * 
                     (fps_of_poly (fst y') / fps_of_poly (snd y'))" using unit 
     by (simp add: w_def z_def unit_div_commute unit_div_mult_swap is_unit_div_div_commute)
   finally show ?case
     by (simp add: w_def z_def x'_def y'_def Let_def case_prod_unfold quot_of_fract_mult mult_ac)
 qed
 
 lemma div_const_unit_poly: "is_unit c \<Longrightarrow> p div [:c:] = smult (1 div c) p"
   by (simp add: is_unit_const_poly_iff unit_eq_div1)
 
 lemma normalize_field: 
   "normalize (x :: 'a :: {normalization_semidom,field}) = (if x = 0 then 0 else 1)"
   by (auto simp: normalize_1_iff dvd_field_iff)
 
 lemma unit_factor_field [simp]:
   "unit_factor (x :: 'a :: {normalization_semidom,field}) = x"
   using unit_factor_mult_normalize[of x] normalize_field[of x]
   by (simp split: if_splits)
 
 lemma fps_of_poly_normalize_field: 
   "fps_of_poly (normalize (p :: 'a :: {field, normalization_semidom} poly)) = 
      fps_of_poly p * fps_const (inverse (lead_coeff p))"
   by (cases "p = 0")
      (simp_all add: normalize_poly_def div_const_unit_poly divide_simps dvd_field_iff)
 
 lemma unit_factor_poly_altdef: "unit_factor p = monom (unit_factor (lead_coeff p)) 0"
   by (simp add: unit_factor_poly_def monom_altdef)
 
 lemma div_const_poly: "p div [:c::'a::field:] = smult (inverse c) p"
   by (cases "c = 0") (simp_all add: unit_eq_div1 is_unit_triv)
 
 lemma fps_of_ratfps_inverse [simp]: "fps_of_ratfps (inverse x) = inverse (fps_of_ratfps x)"
 proof (transfer, goal_cases)
   case (1 x)
   hence "smult (lead_coeff (fst (quot_of_fract x))) (snd (quot_of_fract x)) div
            unit_factor (fst (quot_of_fract x)) = snd (quot_of_fract x)"
     if "fst (quot_of_fract x) \<noteq> 0" using that
     by (simp add: unit_factor_poly_altdef monom_0 div_const_poly)
   with 1 show ?case
     by (auto simp: Let_def case_prod_unfold fps_divide_unit fps_inverse_mult
           quot_of_fract_inverse mult_ac
           fps_of_poly_simps fps_const_inverse
           fps_of_poly_normalize_field div_smult_left [symmetric])
 qed
 
 context
   includes fps_notation
 begin
 
 lemma ratfps_nth_altdef: "ratfps_nth x n = fps_of_ratfps x $ n" 
   by transfer
      (simp_all add: case_prod_unfold fps_divide_unit fps_times_def fps_inverse_def 
         ratfps_nth_aux_correct Let_def)
 
 lemma fps_of_ratfps_is_unit: "fps_of_ratfps a $ 0 \<noteq> 0 \<longleftrightarrow> ratfps_nth a 0 \<noteq> 0"
   by (simp add: ratfps_nth_altdef)
 
 lemma ratfps_nth_0 [simp]: "ratfps_nth 0 n = 0"
   by (simp add: ratfps_nth_altdef)
 
 lemma fps_of_ratfps_cases:
   obtains p q where "coeff q 0 \<noteq> 0" "fps_of_ratfps f = fps_of_poly p / fps_of_poly q"
   by (rule that[of "snd (quot_of_ratfps f)" "fst (quot_of_ratfps f)"])
      (simp_all add: fps_of_ratfps_altdef case_prod_unfold)
 
 lemma fps_of_ratfps_cutoff [simp]:
     "fps_of_poly (ratfps_cutoff n x) = fps_cutoff n (fps_of_ratfps x)"
   by (simp add: fps_eq_iff ratfps_cutoff_def nth_default_def ratfps_nth_altdef)
 
 lemma subdegree_fps_of_ratfps:
   "subdegree (fps_of_ratfps x) = ratfps_subdegree x"
   by transfer (simp_all add: case_prod_unfold subdegree_div_unit poly_subdegree_def)
 
 lemma ratfps_subdegree_altdef:
   "ratfps_subdegree x = subdegree (fps_of_ratfps x)"
   using subdegree_fps_of_ratfps ..
 
 end
 
 
 code_datatype fps_of_ratfps
   
 lemma fps_zero_code [code]: "0 = fps_of_ratfps 0" by simp
   
 lemma fps_one_code [code]: "1 = fps_of_ratfps 1" by simp
 
 lemma fps_const_code [code]: "fps_const c = fps_of_poly [:c:]" by simp
 
 lemma fps_of_poly_code [code]: "fps_of_poly p = fps_of_ratfps (ratfps_of_poly p)" by simp
   
 lemma fps_X_code [code]: "fps_X = fps_of_ratfps (ratfps_of_poly [:0,1:])" by simp
 
 lemma fps_nth_code [code]: "fps_nth (fps_of_ratfps x) n = ratfps_nth x n"
   by (simp add: ratfps_nth_altdef)
      
 lemma fps_uminus_code [code]: "- fps_of_ratfps x = fps_of_ratfps (-x)" by simp
   
 lemma fps_add_code [code]: "fps_of_ratfps x + fps_of_ratfps y = fps_of_ratfps (x + y)" by simp
 
 lemma fps_diff_code [code]: "fps_of_ratfps x - fps_of_ratfps y = fps_of_ratfps (x - y)" by simp
 
 lemma fps_mult_code [code]: "fps_of_ratfps x * fps_of_ratfps y = fps_of_ratfps (x * y)" by simp
 
 lemma fps_inverse_code [code]: "inverse (fps_of_ratfps x) = fps_of_ratfps (inverse x)" 
   by simp
 
 lemma fps_cutoff_code [code]: "fps_cutoff n (fps_of_ratfps x) = fps_of_poly (ratfps_cutoff n x)"
   by simp
   
 lemmas subdegree_code [code] = subdegree_fps_of_ratfps
 
  
 lemma fractrel_normalize_quot:
   "fractrel p p \<Longrightarrow> fractrel q q \<Longrightarrow> 
      fractrel (normalize_quot p) (normalize_quot q) \<longleftrightarrow> fractrel p q"
   by (subst fractrel_normalize_quot_left fractrel_normalize_quot_right, simp)+ (rule refl)
   
 lemma fps_of_ratfps_eq_iff [simp]:
   "fps_of_ratfps p = fps_of_ratfps q \<longleftrightarrow> p = q"
 proof -
   {
     fix p q :: "'a poly fract"
     assume "fractrel (quot_of_fract p) (quot_of_fract q)"
     hence "p = q" by transfer (simp only: fractrel_normalize_quot)
   } note A = this
   show ?thesis        
     by transfer (auto simp: case_prod_unfold unit_eq_div1 unit_eq_div2 unit_div_commute intro: A)
 qed
   
 lemma fps_of_ratfps_eq_zero_iff [simp]:
   "fps_of_ratfps p = 0 \<longleftrightarrow> p = 0" 
   by (simp del: fps_of_ratfps_0 add: fps_of_ratfps_0 [symmetric])
 
 lemma unit_factor_snd_quot_of_ratfps [simp]: 
   "unit_factor (snd (quot_of_ratfps x)) = 1"
   by transfer simp
   
 lemma poly_shift_times_monom_le: 
   "n \<le> m \<Longrightarrow> poly_shift n (monom c m * p) = monom c (m - n) * p"
   by (intro poly_eqI) (auto simp: coeff_monom_mult coeff_poly_shift)
 
 lemma poly_shift_times_monom_ge: 
   "n \<ge> m \<Longrightarrow> poly_shift n (monom c m * p) = smult c (poly_shift (n - m) p)"
   by (intro poly_eqI) (auto simp: coeff_monom_mult coeff_poly_shift)
   
 lemma poly_shift_times_monom:
   "poly_shift n (monom c n * p) = smult c p"
   by (intro poly_eqI) (auto simp: coeff_monom_mult coeff_poly_shift)
 
 lemma monom_times_poly_shift:
   assumes "poly_subdegree p \<ge> n"
   shows   "monom c n * poly_shift n p = smult c p" (is "?lhs = ?rhs")
 proof (intro poly_eqI) 
   fix k
   show "coeff ?lhs k = coeff ?rhs k"
   proof (cases "k < n")
     case True
     with assms have "k < poly_subdegree p" by simp
     hence "coeff p k = 0" by (simp add: coeff_less_poly_subdegree)
     thus ?thesis by (auto simp: coeff_monom_mult coeff_poly_shift)
   qed (auto simp: coeff_monom_mult coeff_poly_shift)
 qed
 
 lemma monom_times_poly_shift':
   assumes "poly_subdegree p \<ge> n"
   shows   "monom (1 :: 'a :: comm_semiring_1) n * poly_shift n p = p"
   by (simp add: monom_times_poly_shift[OF assms])
 
 lemma subdegree_minus_cutoff_ge:
   assumes "f - fps_cutoff n (f :: 'a :: ab_group_add fps) \<noteq> 0"
   shows   "subdegree (f - fps_cutoff n f) \<ge> n"
   using assms by (rule subdegree_geI) simp_all
 
 lemma fps_shift_times_X_power'': "fps_shift n (fps_X ^ n * f :: 'a :: comm_ring_1 fps) = f"
   using fps_shift_times_fps_X_power'[of n f] by (simp add: mult.commute)
   
 lemma 
   ratfps_shift_code [code abstract]:
     "quot_of_ratfps (ratfps_shift n x) = 
        (let (a, b) = quot_of_ratfps (x - ratfps_of_poly (ratfps_cutoff n x))
         in  (poly_shift n a, b))" (is "?lhs1 = ?rhs1") and
   fps_of_ratfps_shift [simp]:
     "fps_of_ratfps (ratfps_shift n x) = fps_shift n (fps_of_ratfps x)"   
 proof -
   include fps_notation
   define x' where "x' = ratfps_of_poly (ratfps_cutoff n x)"
   define y where "y = quot_of_ratfps (x - x')"
   
   have "coprime (fst y) (snd y)" unfolding y_def
     by transfer (rule coprime_quot_of_fract)
   also have fst_y: "fst y = monom 1 n * poly_shift n (fst y)"
   proof (cases "x = x'")
     case False
     have "poly_subdegree (fst y) = subdegree (fps_of_poly (fst y))"
       by (simp add: poly_subdegree_def)
     also have "\<dots> = subdegree (fps_of_poly (fst y) / fps_of_poly (snd y))"
       by (subst subdegree_div_unit) (simp_all add: y_def)
     also have "fps_of_poly (fst y) / fps_of_poly (snd y) = fps_of_ratfps (x - x')"
       unfolding y_def by transfer (simp add: case_prod_unfold)
     also from False have "subdegree \<dots> \<ge> n"
     proof (intro subdegree_geI)
       fix k assume "k < n"
       thus "fps_of_ratfps (x - x') $ k = 0" by (simp add: x'_def)
     qed simp_all
     finally show ?thesis by (rule monom_times_poly_shift' [symmetric])
   qed (simp_all add: y_def)
   finally have coprime: "coprime (poly_shift n (fst y)) (snd y)"
     by simp
   
   have "quot_of_ratfps (ratfps_shift n x) = 
           quot_of_ratfps (quot_to_ratfps (poly_shift n (fst y), snd y))"
     by (simp add: ratfps_shift_def Let_def case_prod_unfold x'_def y_def)
   also from coprime have "\<dots> = (poly_shift n (fst y), snd y)"
     by (intro quot_of_ratfps_quot_to_ratfps) (simp_all add: y_def normalized_fracts_def)
   also have "\<dots> = ?rhs1" by (simp add: case_prod_unfold Let_def y_def x'_def)
   finally show eq: "?lhs1 = ?rhs1" .
   
   have "fps_shift n (fps_of_ratfps x) = fps_shift n (fps_of_ratfps (x - x'))"
     by (intro fps_ext) (simp_all add: x'_def)
   also have "fps_of_ratfps (x - x') = fps_of_poly (fst y) / fps_of_poly (snd y)"
     by (simp add: fps_of_ratfps_altdef y_def case_prod_unfold)
   also have "fps_shift n \<dots> = fps_of_ratfps (ratfps_shift n x)"
     by (subst fst_y, subst fps_of_poly_mult, subst unit_div_mult_swap [symmetric])
        (simp_all add: y_def fps_of_poly_monom fps_shift_times_X_power'' eq 
           fps_of_ratfps_altdef case_prod_unfold Let_def x'_def)
   finally show "fps_of_ratfps (ratfps_shift n x) = fps_shift n (fps_of_ratfps x)" ..
 qed
 
 lemma fps_shift_code [code]: "fps_shift n (fps_of_ratfps x) = fps_of_ratfps (ratfps_shift n x)"
   by simp
 
 instantiation fps :: (equal) equal
 begin
 
 definition equal_fps :: "'a fps \<Rightarrow> 'a fps \<Rightarrow> bool" where
   [simp]: "equal_fps f g \<longleftrightarrow> f = g"
 
 instance by standard simp_all
 
 end
 
 lemma equal_fps_code [code]: "HOL.equal (fps_of_ratfps f) (fps_of_ratfps g) \<longleftrightarrow> f = g"
   by simp
 
 lemma fps_of_ratfps_divide [simp]:
   "fps_of_ratfps (f div g) = fps_of_ratfps f div fps_of_ratfps g"
   unfolding fps_divide_def Let_def by transfer' (simp add: Let_def ratfps_subdegree_altdef)
            
 lemma ratfps_eqI: "fps_of_ratfps x = fps_of_ratfps y \<Longrightarrow> x = y" by simp
 
 instance ratfps :: ("field_gcd") algebraic_semidom
   by standard (auto intro: ratfps_eqI)
 
 lemma fps_of_ratfps_dvd [simp]:
   "fps_of_ratfps x dvd fps_of_ratfps y \<longleftrightarrow> x dvd y"
 proof
   assume "fps_of_ratfps x dvd fps_of_ratfps y"
   hence "fps_of_ratfps y = fps_of_ratfps y div fps_of_ratfps x * fps_of_ratfps x" by simp
   also have "\<dots> = fps_of_ratfps (y div x * x)" by simp
   finally have "y = y div x * x" by (subst (asm) fps_of_ratfps_eq_iff)
   thus "x dvd y" by (intro dvdI[of _ _ "y div x"]) (simp add: mult_ac)
 next
   assume "x dvd y"
   hence "y = y div x * x" by simp
   also have "fps_of_ratfps \<dots> = fps_of_ratfps (y div x) * fps_of_ratfps x" by simp
   finally show "fps_of_ratfps x dvd fps_of_ratfps y" by (simp del: fps_of_ratfps_divide)
 qed
 
 lemma is_unit_ratfps_iff [simp]:
   "is_unit x \<longleftrightarrow> ratfps_nth x 0 \<noteq> 0"
 proof
   assume "is_unit x"
   then obtain y where "1 = x * y" by (auto elim!: dvdE)
   hence "1 = fps_of_ratfps (x * y)" by (simp del: fps_of_ratfps_mult)
   also have "\<dots> = fps_of_ratfps x * fps_of_ratfps y" by simp
   finally have "is_unit (fps_of_ratfps x)" by (rule dvdI[of _ _ "fps_of_ratfps y"])
   thus "ratfps_nth x 0 \<noteq> 0" by (simp add: ratfps_nth_altdef)
 next
   assume "ratfps_nth x 0 \<noteq> 0"
   hence "fps_of_ratfps (x * inverse x) = 1"
     by (simp add: ratfps_nth_altdef inverse_mult_eq_1')
   also have "\<dots> = fps_of_ratfps 1" by simp
   finally have "x * inverse x = 1" by (subst (asm) fps_of_ratfps_eq_iff)
   thus "is_unit x" by (intro dvdI[of _ _ "inverse x"]) simp_all
 qed
 
 instantiation ratfps :: ("field_gcd") normalization_semidom
 begin
 
 definition unit_factor_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps" where
   "unit_factor x = ratfps_shift (ratfps_subdegree x) x"
 
 definition normalize_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps" where
   "normalize x = (if x = 0 then 0 else ratfps_of_poly (monom 1 (ratfps_subdegree x)))"
 
 lemma fps_of_ratfps_unit_factor [simp]: 
   "fps_of_ratfps (unit_factor x) = unit_factor (fps_of_ratfps x)"
   unfolding unit_factor_ratfps_def by (simp add: ratfps_subdegree_altdef)
 
 lemma fps_of_ratfps_normalize [simp]: 
   "fps_of_ratfps (normalize x) = normalize (fps_of_ratfps x)"
   unfolding normalize_ratfps_def by (simp add: fps_of_poly_monom ratfps_subdegree_altdef)
 
 instance proof
   show "unit_factor x * normalize x = x" "normalize (0 :: 'a ratfps) = 0" 
        "unit_factor (0 :: 'a ratfps) = 0" for x :: "'a ratfps"
     by (rule ratfps_eqI, simp add: ratfps_subdegree_code 
           del: fps_of_ratfps_eq_iff fps_unit_factor_def fps_normalize_def)+
   show "is_unit (unit_factor a)" if "a \<noteq> 0" for a :: "'a ratfps"
     using that by (auto simp: ratfps_nth_altdef)
   fix a b :: "'a ratfps"
   assume "is_unit a" 
   thus "unit_factor (a * b) = a * unit_factor b"
     by (intro ratfps_eqI, unfold fps_of_ratfps_unit_factor fps_of_ratfps_mult,
         subst unit_factor_mult_unit_left) (auto simp: ratfps_nth_altdef)
   show "unit_factor a = a" if "is_unit a" for a :: "'a ratfps"
     by (rule ratfps_eqI) (insert that, auto simp: fps_of_ratfps_is_unit)
 qed
 
 end
 
 instance ratfps :: ("field_gcd") normalization_semidom_multiplicative
 proof
   show "unit_factor (a * b) = unit_factor a * unit_factor b" for a b :: "'a ratfps"
     by (rule ratfps_eqI, insert unit_factor_mult[of "fps_of_ratfps a" "fps_of_ratfps b"])
        (simp del: fps_of_ratfps_eq_iff)
 qed
 
 instantiation ratfps :: ("field_gcd") semidom_modulo
 begin
 
 lift_definition modulo_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps \<Rightarrow> 'a ratfps" is
   "\<lambda>f g. if g = 0 then f else 
            let n = ratfps_subdegree g; h = ratfps_shift n g
            in  ratfps_of_poly (ratfps_cutoff n (f * inverse h)) * h" .
 
 lemma fps_of_ratfps_mod [simp]: 
    "fps_of_ratfps (f mod g :: 'a ratfps) = fps_of_ratfps f mod fps_of_ratfps g"
   unfolding fps_mod_def by transfer' (simp add: Let_def ratfps_subdegree_altdef)
 
 instance
   by standard (auto intro: ratfps_eqI)
 
 end
 
 instantiation ratfps :: ("field_gcd") euclidean_ring
 begin
 
 definition euclidean_size_ratfps :: "'a ratfps \<Rightarrow> nat" where
   "euclidean_size_ratfps x = (if x = 0 then 0 else 2 ^ ratfps_subdegree x)"
   
 lemma fps_of_ratfps_euclidean_size [simp]:
   "euclidean_size x = euclidean_size (fps_of_ratfps x)"
   unfolding euclidean_size_ratfps_def fps_euclidean_size_def
   by (simp add: ratfps_subdegree_altdef)
 
 instance proof
   show "euclidean_size (0 :: 'a ratfps) = 0" by simp
   show "euclidean_size (a mod b) < euclidean_size b"
        "euclidean_size a \<le> euclidean_size (a * b)" if "b \<noteq> 0" for a b :: "'a ratfps"
     using that by (simp_all add: mod_size_less size_mult_mono)
 qed
 
 end
 
 instantiation ratfps :: ("field_gcd") euclidean_ring_cancel
 begin
 
 instance
   by standard (auto intro: ratfps_eqI)
 
 end
 
 lemma quot_of_ratfps_eq_iff [simp]: "quot_of_ratfps x = quot_of_ratfps y \<longleftrightarrow> x = y"
   by transfer simp
 
 lemma ratfps_eq_0_code: "x = 0 \<longleftrightarrow> fst (quot_of_ratfps x) = 0"
 proof
   assume "fst (quot_of_ratfps x) = 0"
   moreover have "coprime (fst (quot_of_ratfps x)) (snd (quot_of_ratfps x))"
     by transfer (simp add: coprime_quot_of_fract)
   moreover have "normalize (snd (quot_of_ratfps x)) = snd (quot_of_ratfps x)"
     by (simp add: div_unit_factor [symmetric] del: div_unit_factor)
   ultimately have "quot_of_ratfps x = (0,1)"
     by (simp add: prod_eq_iff normalize_idem_imp_is_unit_iff)
   also have "\<dots> = quot_of_ratfps 0" by simp
   finally show "x = 0" by (subst (asm) quot_of_ratfps_eq_iff)
 qed simp_all
 
 lemma fps_dvd_code [code_unfold]:
   "x dvd y \<longleftrightarrow> y = 0 \<or> ((x::'a::field_gcd fps) \<noteq> 0 \<and> subdegree x \<le> subdegree y)"
   using fps_dvd_iff[of x y] by (cases "x = 0") auto
 
 lemma ratfps_dvd_code [code_unfold]: 
   "x dvd y \<longleftrightarrow> y = 0 \<or> (x \<noteq> 0 \<and> ratfps_subdegree x \<le> ratfps_subdegree y)"
   using fps_dvd_code [of "fps_of_ratfps x" "fps_of_ratfps y"]
   by (simp add: ratfps_subdegree_altdef)
 
 instance ratfps :: ("field_gcd") normalization_euclidean_semiring ..
 
 instantiation ratfps :: ("field_gcd") euclidean_ring_gcd
 begin
 
 definition "gcd_ratfps = (Euclidean_Algorithm.gcd :: 'a ratfps \<Rightarrow> _)"
 definition "lcm_ratfps = (Euclidean_Algorithm.lcm :: 'a ratfps \<Rightarrow> _)"
 definition "Gcd_ratfps = (Euclidean_Algorithm.Gcd :: 'a ratfps set \<Rightarrow> _)"
 definition "Lcm_ratfps = (Euclidean_Algorithm.Lcm:: 'a ratfps set \<Rightarrow> _)"
 
 instance by standard (simp_all add: gcd_ratfps_def lcm_ratfps_def Gcd_ratfps_def Lcm_ratfps_def)
 end
 
 lemma ratfps_eq_0_iff: "x = 0 \<longleftrightarrow> fps_of_ratfps x = 0"
   using fps_of_ratfps_eq_iff[of x 0] unfolding fps_of_ratfps_0 by simp
 
 lemma ratfps_of_poly_eq_0_iff: "ratfps_of_poly x = 0 \<longleftrightarrow> x = 0"
   by (auto simp: ratfps_eq_0_iff)
 
 
 
 lemma ratfps_gcd:
   assumes [simp]: "f \<noteq> 0" "g \<noteq> 0"
   shows   "gcd f g = ratfps_of_poly (monom 1 (min (ratfps_subdegree f) (ratfps_subdegree g)))"
   by (rule sym, rule gcdI)
      (auto simp: ratfps_subdegree_altdef ratfps_dvd_code subdegree_fps_of_poly
          ratfps_of_poly_eq_0_iff normalize_ratfps_def)
 
 lemma ratfps_gcd_altdef: "gcd (f :: 'a :: field_gcd ratfps) g =
   (if f = 0 \<and> g = 0 then 0 else
    if f = 0 then ratfps_of_poly (monom 1 (ratfps_subdegree g)) else
    if g = 0 then ratfps_of_poly (monom 1 (ratfps_subdegree f)) else
      ratfps_of_poly (monom 1 (min (ratfps_subdegree f) (ratfps_subdegree g))))"
   by (simp add: ratfps_gcd normalize_ratfps_def)
 
 lemma ratfps_lcm:
   assumes [simp]: "f \<noteq> 0" "g \<noteq> 0"
   shows   "lcm f g = ratfps_of_poly (monom 1 (max (ratfps_subdegree f) (ratfps_subdegree g)))"
   by (rule sym, rule lcmI)
      (auto simp: ratfps_subdegree_altdef ratfps_dvd_code subdegree_fps_of_poly
          ratfps_of_poly_eq_0_iff normalize_ratfps_def)
 
 lemma ratfps_lcm_altdef: "lcm (f :: 'a :: field_gcd ratfps) g =
   (if f = 0 \<or> g = 0 then 0 else 
      ratfps_of_poly (monom 1 (max (ratfps_subdegree f) (ratfps_subdegree g))))"
   by (simp add: ratfps_lcm)
 
 lemma ratfps_Gcd:
   assumes "A - {0} \<noteq> {}"
   shows   "Gcd A = ratfps_of_poly (monom 1 (INF f\<in>A-{0}. ratfps_subdegree f))"
 proof (rule sym, rule GcdI)
   fix f assume "f \<in> A"
   thus "ratfps_of_poly (monom 1 (INF f\<in>A - {0}. ratfps_subdegree f)) dvd f"
     by (cases "f = 0") (auto simp: ratfps_dvd_code ratfps_of_poly_eq_0_iff ratfps_subdegree_altdef
                           subdegree_fps_of_poly intro!: cINF_lower)
 next
   fix d assume d: "\<And>f. f \<in> A \<Longrightarrow> d dvd f"
   from assms obtain f where "f \<in> A - {0}" by auto
   with d[of f] have [simp]: "d \<noteq> 0" by auto
   from d assms have "ratfps_subdegree d \<le> (INF f\<in>A-{0}. ratfps_subdegree f)"
     by (intro cINF_greatest) (auto simp: ratfps_dvd_code)
   with d assms show "d dvd ratfps_of_poly (monom 1 (INF f\<in>A-{0}. ratfps_subdegree f))" 
     by (simp add: ratfps_dvd_code ratfps_subdegree_altdef subdegree_fps_of_poly)
 qed (simp_all add: ratfps_subdegree_altdef subdegree_fps_of_poly normalize_ratfps_def)
 
 lemma ratfps_Gcd_altdef: "Gcd (A :: 'a :: field_gcd ratfps set) =
   (if A \<subseteq> {0} then 0 else ratfps_of_poly (monom 1 (INF f\<in>A-{0}. ratfps_subdegree f)))"
   using ratfps_Gcd by auto
 
 lemma ratfps_Lcm:
   assumes "A \<noteq> {}" "0 \<notin> A" "bdd_above (ratfps_subdegree`A)"
   shows   "Lcm A = ratfps_of_poly (monom 1 (SUP f\<in>A. ratfps_subdegree f))"
 proof (rule sym, rule LcmI)
   fix f assume "f \<in> A"
   moreover from assms(3) have "bdd_above (ratfps_subdegree ` A)" by auto
   ultimately show "f dvd ratfps_of_poly (monom 1 (SUP f\<in>A. ratfps_subdegree f))" using assms(2)
     by (cases "f = 0") (auto simp: ratfps_dvd_code ratfps_of_poly_eq_0_iff subdegree_fps_of_poly 
                           ratfps_subdegree_altdef [abs_def] intro!: cSUP_upper)
 next
   fix d assume d: "\<And>f. f \<in> A \<Longrightarrow> f dvd d"
   from assms obtain f where f: "f \<in> A" "f \<noteq> 0" by auto
   show "ratfps_of_poly (monom 1 (SUP f\<in>A. ratfps_subdegree f)) dvd d"
   proof (cases "d = 0")
     assume "d \<noteq> 0"
     moreover from d have "\<And>f. f \<in> A \<Longrightarrow> f \<noteq> 0 \<Longrightarrow> f dvd d" by blast
     ultimately have "ratfps_subdegree d \<ge> (SUP f\<in>A. ratfps_subdegree f)" using assms
       by (intro cSUP_least) (auto simp: ratfps_dvd_code)
     with \<open>d \<noteq> 0\<close> show ?thesis by (simp add: ratfps_dvd_code ratfps_of_poly_eq_0_iff 
           ratfps_subdegree_altdef subdegree_fps_of_poly)
   qed simp_all
 qed (simp_all add: ratfps_subdegree_altdef subdegree_fps_of_poly normalize_ratfps_def)
 
 lemma ratfps_Lcm_altdef:
   "Lcm (A :: 'a :: field_gcd ratfps set) =
      (if 0 \<in> A \<or> \<not>bdd_above (ratfps_subdegree`A) then 0 else
       if A = {} then 1 else ratfps_of_poly (monom 1 (SUP f\<in>A. ratfps_subdegree f)))"
 proof (cases "bdd_above (ratfps_subdegree`A)")
   assume unbounded: "\<not>bdd_above (ratfps_subdegree`A)"
   have "Lcm A = 0"
   proof (rule ccontr)
     assume "Lcm A \<noteq> 0"
     from unbounded obtain f where f: "f \<in> A" "ratfps_subdegree (Lcm A) < ratfps_subdegree f"
       unfolding bdd_above_def by (auto simp: not_le)
     moreover from this and \<open>Lcm A \<noteq> 0\<close> have "ratfps_subdegree f \<le> ratfps_subdegree (Lcm A)"
       using dvd_Lcm[of f A] by (auto simp: ratfps_dvd_code)
     ultimately show False by simp
   qed
   with unbounded show ?thesis by simp
 qed (simp_all add: ratfps_Lcm Lcm_eq_0_I)
 
 lemma fps_of_ratfps_quot_to_ratfps:
   "coeff y 0 \<noteq> 0 \<Longrightarrow> fps_of_ratfps (quot_to_ratfps (x,y)) = fps_of_poly x / fps_of_poly y"
 proof (transfer, goal_cases)
   case (1 y x)
   define x' y' where "x' = fst (normalize_quot (x,y))" and "y' = snd (normalize_quot (x,y))"
   from 1 have nz: "y \<noteq> 0" by auto
   have eq: "normalize_quot (x', y') = (x', y')" by (simp add: x'_def y'_def)
-  from normalize_quotE[OF nz, of x] guess d . note d = this [folded x'_def y'_def]
+  from normalize_quotE[OF nz, of x] obtain d where 
+    "x = fst (normalize_quot (x, y)) * d"
+    "y = snd (normalize_quot (x, y)) * d"
+    "d dvd x"
+    "d dvd y"
+    "d \<noteq> 0" .
+  note d [folded x'_def y'_def] = this
   have "(case quot_of_fract (if coeff y' 0 = 0 then 0 else quot_to_fract (x', y')) of
           (a, b) \<Rightarrow> fps_of_poly a / fps_of_poly b) = fps_of_poly x / fps_of_poly y"
     using d eq 1 by (auto simp: case_prod_unfold fps_of_poly_simps quot_of_fract_quot_to_fract 
                                 Let_def coeff_0_mult)
   thus ?case by (auto simp add: Let_def case_prod_unfold x'_def y'_def)
 qed
 
 lemma fps_of_ratfps_quot_to_ratfps_code_post1:
   "fps_of_ratfps (quot_to_ratfps (x,pCons 1 y)) = fps_of_poly x / fps_of_poly (pCons 1 y)"
   "fps_of_ratfps (quot_to_ratfps (x,pCons (-1) y)) = fps_of_poly x / fps_of_poly (pCons (-1) y)"
   by (simp_all add: fps_of_ratfps_quot_to_ratfps)
 
 lemma fps_of_ratfps_quot_to_ratfps_code_post2:
   "fps_of_ratfps (quot_to_ratfps (x'::'a::{field_char_0,field_gcd} poly,pCons (numeral n) y')) = 
      fps_of_poly x' / fps_of_poly (pCons (numeral n) y')"
   "fps_of_ratfps (quot_to_ratfps (x'::'a::{field_char_0,field_gcd} poly,pCons (-numeral n) y')) = 
      fps_of_poly x' / fps_of_poly (pCons (-numeral n) y')"
   by (simp_all add: fps_of_ratfps_quot_to_ratfps)
 
 lemmas fps_of_ratfps_quot_to_ratfps_code_post [code_post] =
   fps_of_ratfps_quot_to_ratfps_code_post1
   fps_of_ratfps_quot_to_ratfps_code_post2
 
 lemma fps_dehorner: 
   fixes a b c :: "'a :: semiring_1 fps" and d e f :: "'b :: ring_1 fps"
   shows
   "(b + c) * fps_X = b * fps_X + c * fps_X" "(a * fps_X) * fps_X = a * fps_X ^ 2" 
   "a * fps_X ^ m * fps_X = a * fps_X ^ (Suc m)" "a * fps_X * fps_X ^ m = a * fps_X ^ (Suc m)" 
   "a * fps_X^m * fps_X^n = a * fps_X^(m+n)" "a + (b + c) = a + b + c" "a * 1 = a" "1 * a = a"
   "d + - e = d - e" "(-d) * e = - (d * e)" "d + (e - f) = d + e - f"
   "(d - e) * fps_X = d * fps_X - e * fps_X" "fps_X * fps_X = fps_X^2" "fps_X * fps_X^m = fps_X^(Suc m)" "fps_X^m * fps_X = fps_X^Suc m"
   "fps_X^m * fps_X^n = fps_X^(m + n)"
   by (simp_all add: algebra_simps power2_eq_square power_add power_commutes)
 
 lemma fps_divide_1: "(a :: 'a :: field fps) / 1 = a" by simp
 
 lemmas fps_of_poly_code_post [code_post] = 
   fps_of_poly_simps fps_const_0_eq_0 fps_const_1_eq_1 numeral_fps_const [symmetric]
   fps_const_neg [symmetric] fps_const_divide [symmetric]
   fps_dehorner Suc_numeral arith_simps fps_divide_1
 
 context
   includes term_syntax
 begin
 
 definition
   valterm_ratfps :: 
     "'a ::{field_gcd, typerep} poly \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> 
      'a poly \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> 'a ratfps \<times> (unit \<Rightarrow> Code_Evaluation.term)" where
   [code_unfold]: "valterm_ratfps k l = 
     Code_Evaluation.valtermify (/) {\<cdot>} 
       (Code_Evaluation.valtermify ratfps_of_poly {\<cdot>} k) {\<cdot>} 
       (Code_Evaluation.valtermify ratfps_of_poly {\<cdot>} l)"
 
 end
 
 instantiation ratfps :: ("{field_gcd,random}") random
 begin
 
 context
   includes state_combinator_syntax term_syntax
 begin
 
 definition
   "Quickcheck_Random.random i = 
      Quickcheck_Random.random i \<circ>\<rightarrow> (\<lambda>num::'a poly \<times> (unit \<Rightarrow> term). 
        Quickcheck_Random.random i \<circ>\<rightarrow> (\<lambda>denom::'a poly \<times> (unit \<Rightarrow> term). 
          Pair (let denom = (if fst denom = 0 then Code_Evaluation.valtermify 1 else denom)
                in  valterm_ratfps num denom)))"
 
 instance ..
 
 end
 
 end
 
 instantiation ratfps :: ("{field,factorial_ring_gcd,exhaustive}") exhaustive
 begin
 
 definition
   "exhaustive_ratfps f d = 
      Quickcheck_Exhaustive.exhaustive (\<lambda>num. 
        Quickcheck_Exhaustive.exhaustive (\<lambda>denom. f (
          let denom = if denom = 0 then 1 else denom
          in  ratfps_of_poly num / ratfps_of_poly denom)) d) d"
 
 instance ..
 
 end
 
 instantiation ratfps :: ("{field_gcd,full_exhaustive}") full_exhaustive
 begin
 
 definition
   "full_exhaustive_ratfps f d = 
      Quickcheck_Exhaustive.full_exhaustive (\<lambda>num::'a poly \<times> (unit \<Rightarrow> term).
        Quickcheck_Exhaustive.full_exhaustive (\<lambda>denom::'a poly \<times> (unit \<Rightarrow> term).
          f (let denom = if fst denom = 0 then Code_Evaluation.valtermify 1 else denom
             in  valterm_ratfps num denom)) d) d"
 
 instance ..
 
 end 
 
 quickcheck_generator fps constructors: fps_of_ratfps
 
 end
diff --git a/thys/Linear_Recurrences/Rational_FPS_Asymptotics.thy b/thys/Linear_Recurrences/Rational_FPS_Asymptotics.thy
--- a/thys/Linear_Recurrences/Rational_FPS_Asymptotics.thy
+++ b/thys/Linear_Recurrences/Rational_FPS_Asymptotics.thy
@@ -1,398 +1,404 @@
 (*
   File:    Rational_FPS_Asymptotics.thy
   Author:  Manuel Eberl, TU München
 *)
 theory Rational_FPS_Asymptotics
 imports
   "HOL-Library.Landau_Symbols"
   "Polynomial_Factorization.Square_Free_Factorization"
   "HOL-Real_Asymp.Real_Asymp"
   "Count_Complex_Roots.Count_Complex_Roots"
   Linear_Homogenous_Recurrences
   Linear_Inhomogenous_Recurrences
   RatFPS
   Rational_FPS_Solver
   "HOL-Library.Code_Target_Numeral"
+
 begin
 
 lemma poly_asymp_equiv:
   assumes "p \<noteq> 0" and "F \<le> at_infinity"
   shows   "poly p \<sim>[F] (\<lambda>x. lead_coeff p * x ^ degree p)"
 proof -
   have poly_pCons': "poly (pCons a q) = (\<lambda>x. a + x * poly q x)" for a :: 'a and q
     by (simp add: fun_eq_iff)
   show ?thesis using assms(1)
   proof (induction p)
     case (pCons a p)
     define n where "n = Suc (degree p)"
     show ?case
     proof (cases "p = 0")
       case [simp]: False
       hence *: "poly p \<sim>[F] (\<lambda>x. lead_coeff p * x ^ degree p)"
         by (intro pCons.IH)
       have "poly (pCons a p) = (\<lambda>x. a + x * poly p x)"
         by (simp add: poly_pCons')
       moreover have "\<dots> \<sim>[F] (\<lambda>x. lead_coeff p * x ^ n)"
       proof (subst asymp_equiv_add_left)
         have "(\<lambda>x. x * poly p x) \<sim>[F] (\<lambda>x. x * (lead_coeff p * x ^ degree p))"
           by (intro asymp_equiv_intros *)
         also have "\<dots> = (\<lambda>x. lead_coeff p * x ^ n)" by (simp add: n_def mult_ac)
         finally show "(\<lambda>x. x * poly p x) \<sim>[F] \<dots>" .
       next
         have "filterlim (\<lambda>x. x) at_infinity F"
           by (simp add: filterlim_def assms)
         hence "(\<lambda>x. x ^ n) \<in> \<omega>[F](\<lambda>_. 1 :: 'a)" unfolding smallomega_1_conv_filterlim
           by (intro Limits.filterlim_power_at_infinity filterlim_ident) (auto simp: n_def)
         hence "(\<lambda>x. a) \<in> o[F](\<lambda>x. x ^ n)" unfolding smallomega_iff_smallo[symmetric]
           by (cases "a = 0") auto
         thus "(\<lambda>x. a) \<in> o[F](\<lambda>x. lead_coeff p * x ^ n)"
           by simp
       qed
       ultimately show ?thesis by (simp add: n_def)
     qed auto
   qed auto
 qed
 
 lemma poly_bigtheta:
   assumes "p \<noteq> 0" and "F \<le> at_infinity"
   shows   "poly p \<in> \<Theta>[F](\<lambda>x. x ^ degree p)"
 proof -
   have "poly p \<sim>[F] (\<lambda>x. lead_coeff p * x ^ degree p)"
     by (intro poly_asymp_equiv assms)
   thus ?thesis using assms by (auto dest!: asymp_equiv_imp_bigtheta)
 qed
 
 lemma poly_bigo:
   assumes "F \<le> at_infinity" and "degree p \<le> k"
   shows   "poly p \<in> O[F](\<lambda>x. x ^ k)"
 proof (cases "p = 0")
   case True
   hence "poly p = (\<lambda>_. 0)" by (auto simp: fun_eq_iff)
   thus ?thesis by simp
 next
   case False
   have *: "(\<lambda>x. x ^ (k - degree p)) \<in> \<Omega>[F](\<lambda>x. 1)"
   proof (cases "k = degree p")
     case False
     hence "(\<lambda>x. x ^ (k - degree p)) \<in> \<omega>[F](\<lambda>_. 1)"
       unfolding smallomega_1_conv_filterlim using assms False
       by (intro Limits.filterlim_power_at_infinity filterlim_ident)
          (auto simp: filterlim_def)
     thus ?thesis by (rule landau_omega.small_imp_big)
   qed auto
 
   have "poly p \<in> \<Theta>[F](\<lambda>x. x ^ degree p * 1)"
     using poly_bigtheta[OF False assms(1)] by simp
   also have "(\<lambda>x. x ^ degree p * 1) \<in> O[F](\<lambda>x. x ^ degree p * x ^ (k - degree p))" using *
     by (intro landau_o.big.mult landau_o.big_refl) (auto simp: bigomega_iff_bigo)
   also have "(\<lambda>x::'a. x ^ degree p * x ^ (k - degree p)) = (\<lambda>x. x ^ k)"
     using assms by (simp add: power_add [symmetric])
   finally show ?thesis .
 qed
 
 lemma reflect_poly_dvdI:
   fixes p q :: "'a::{comm_semiring_1,semiring_no_zero_divisors} poly"
   assumes "p dvd q"
   shows   "reflect_poly p dvd reflect_poly q"
   using assms by (auto simp: reflect_poly_mult)
 
 lemma smult_altdef: "smult c p = [:c:] * p"
   by (induction p) (auto simp: mult_ac)
 
 lemma smult_power: "smult (c ^ n) (p ^ n) = (smult c p) ^ n"
 proof -
   have "smult (c ^ n) (p ^ n) = [:c ^ n:] * p ^ n"
     by simp
   also have "[:c:] ^ n = [:c ^ n:]"
     by (induction n) (auto simp: mult_ac)
   hence "[:c ^ n:] = [:c:] ^ n" ..
   also have "\<dots> * p ^ n = ([:c:] * p) ^ n"
     by (rule power_mult_distrib [symmetric])
   also have "\<dots> = (smult c p) ^ n" by simp
   finally show ?thesis .
 qed
 
 lemma order_reflect_poly_ge:
   fixes c :: "'a :: field"
   assumes "c \<noteq> 0" and "p \<noteq> 0"
   shows   "order c (reflect_poly p) \<ge> order (1 / c) p"
 proof -
   have "reflect_poly ([:-(1 / c), 1:] ^ order (1 / c) p) dvd reflect_poly p"
     by (intro reflect_poly_dvdI, subst order_divides) auto
   also have "reflect_poly ([:-(1 / c), 1:] ^ order (1 / c) p) =
                smult ((-1 / c) ^ order (1 / c) p) ([:-c, 1:] ^ order (1 / c) p)"
     using assms by (simp add: reflect_poly_power reflect_poly_pCons smult_power)
   finally have "([:-c, 1:] ^ order (1 / c) p) dvd reflect_poly p"
     by (rule smult_dvd_cancel)
   with \<open>p \<noteq> 0\<close> show ?thesis by (subst (asm) order_divides) auto
 qed
 
 lemma order_reflect_poly:
   fixes c :: "'a :: field"
   assumes "c \<noteq> 0" and "coeff p 0 \<noteq> 0"
   shows   "order c (reflect_poly p) = order (1 / c) p"
 proof (rule antisym)
   from assms show "order c (reflect_poly p) \<ge> order (1 / c) p"
     by (intro order_reflect_poly_ge) auto
 next
   from assms have "order (1 / (1 / c)) (reflect_poly p) \<le>
                      order (1 / c) (reflect_poly (reflect_poly p))"
     by (intro order_reflect_poly_ge) auto
   with assms show "order c (reflect_poly p) \<le> order (1 / c) p"
     by simp
 qed
 
 lemma poly_reflect_eq_0_iff:
   "poly (reflect_poly p) (x :: 'a :: field) = 0 \<longleftrightarrow> p = 0 \<or> x \<noteq> 0 \<and> poly p (1 / x) = 0"
   by (cases "x = 0") (auto simp: poly_reflect_poly_nz inverse_eq_divide)
   
 
 theorem ratfps_nth_bigo:
   fixes q :: "complex poly"
   assumes "R > 0" 
   assumes roots1: "\<And>z. z \<in> ball 0 (1 / R) \<Longrightarrow> poly q z \<noteq> 0"
   assumes roots2: "\<And>z. z \<in> sphere 0 (1 / R) \<Longrightarrow> poly q z = 0 \<Longrightarrow> order z q \<le> Suc k"
   shows   "fps_nth (fps_of_poly p / fps_of_poly q) \<in> O(\<lambda>n. of_nat n ^ k * of_real R ^ n)"
 proof -
   define q' where "q' = reflect_poly q"
   from roots1[of 0] and \<open>R > 0\<close> have [simp]: "coeff q 0 \<noteq> 0" "q \<noteq> 0"
     by (auto simp: poly_0_coeff_0)
-  from ratfps_closed_form_exists[OF this(1), of p] guess r rs . note closed_form = this
+  from ratfps_closed_form_exists[OF this(1), of p]
+  obtain r rs where closed_form:
+      "\<And>n. (fps_of_poly p / fps_of_poly q) $ n =
+        coeff r n + (\<Sum>c | poly (reflect_poly q) c = 0. poly (rs c) (of_nat n) * c ^ n)"
+      "\<And>z. poly (reflect_poly q) z = 0 \<Longrightarrow> degree (rs z) \<le> order z (reflect_poly q) - 1"
+    by blast
 
   have "fps_nth (fps_of_poly p / fps_of_poly q) =
           (\<lambda>n. coeff r n + (\<Sum>c | poly q' c = 0. poly (rs c) (of_nat n) * c ^ n))"
     by (intro ext, subst closed_form) (simp_all add: q'_def)
   also have "\<dots> \<in> O(\<lambda>n. of_nat n ^ k * of_real R ^ n)"
   proof (intro sum_in_bigo big_sum_in_bigo)
     have "eventually (\<lambda>n. coeff r n = 0) at_top"
       using MOST_nat coeff_eq_0 cofinite_eq_sequentially by force
     hence "coeff r \<in> \<Theta>(\<lambda>_. 0)" by (rule bigthetaI_cong)
     also have "(\<lambda>_. 0 :: complex) \<in> O(\<lambda>n. of_nat n ^ k * of_real R ^ n)"
       by simp
     finally show "coeff r \<in> O(\<lambda>n. of_nat n ^ k * of_real R ^ n)" .
   next
     fix c assume c: "c \<in> {c. poly q' c = 0}"
     hence [simp]: "c \<noteq> 0" by (auto simp: q'_def)
 
     show "(\<lambda>n. poly (rs c) n * c ^ n) \<in> O(\<lambda>n. of_nat n ^ k * of_real R ^ n)"
     proof (cases "norm c = R")
       case True \<comment>\<open>The case of a root at the border of the disc\<close>
       show ?thesis
       proof (intro landau_o.big.mult landau_o.big.compose[OF poly_bigo tendsto_of_nat])
         have "degree (rs c) \<le> order c (reflect_poly q) - 1"
           using c by (intro closed_form(2)) (auto simp: q'_def)
         also have "order c (reflect_poly q) = order (1 / c) q"
           using c by (intro order_reflect_poly) (auto simp: q'_def)
         also {
           have "order (1 / c) q \<le> Suc k" using \<open>R > 0\<close> and True and c
             by (intro roots2) (auto simp: q'_def norm_divide poly_reflect_eq_0_iff)
           moreover have "order (1 / c) q \<noteq> 0"
             using order_root[of q "1 / c"] c by (auto simp: q'_def poly_reflect_eq_0_iff)
           ultimately have "order (1 / c) q - 1 \<le> k" by simp
         }
         finally show "degree (rs c) \<le> k" .
       next
         have "(\<lambda>n. norm (c ^ n)) \<in> O(\<lambda>n. norm (complex_of_real R ^ n))"
           using True and \<open>R > 0\<close> by (simp add: norm_power)
         thus "(\<lambda>n. c ^ n) \<in> O(\<lambda>n. complex_of_real R ^ n)"
           by (subst (asm) landau_o.big.norm_iff)
       qed auto
     next
       case False  \<comment>\<open>The case of a root in the interior of the disc\<close>
       hence "norm c < R" using c and roots1[of "1/c"] and \<open>R > 0\<close>
         by (cases "norm c" R rule: linorder_cases)
            (auto simp: q'_def poly_reflect_eq_0_iff norm_divide field_simps)
       define l where "l = degree (rs c)"
 
       have "(\<lambda>n. poly (rs c) (of_nat n) * c ^ n) \<in> O(\<lambda>n. of_nat n ^ l * c ^ n)"
         by (intro landau_o.big.mult landau_o.big.compose[OF poly_bigo tendsto_of_nat])
            (auto simp: l_def)
       also have "(\<lambda>n. of_nat n ^ l * c ^ n) \<in> O(\<lambda>n. of_nat n ^ k * of_real R ^ n)"
       proof (subst landau_o.big.norm_iff [symmetric])
         have "(\<lambda>n. real n ^ l) \<in> O(\<lambda>n. real n ^ k * (R / norm c) ^ n)"
           using \<open>norm c < R\<close> and \<open>R > 0\<close> by real_asymp
         hence "(\<lambda>n. real n ^ l * norm c ^ n) \<in> O(\<lambda>n. real n ^ k * R ^ n)"
           by (simp add: power_divide landau_o.big.divide_eq1)
         thus "(\<lambda>x. norm (of_nat x ^ l * c ^ x)) \<in> 
                 O(\<lambda>x. norm (of_nat x ^ k * complex_of_real R ^ x))"
           unfolding norm_power norm_mult using \<open>R > 0\<close> by simp
       qed
       finally show ?thesis .
     qed
   qed
   finally show ?thesis .
 qed
 
 lemma order_power: "p \<noteq> 0 \<Longrightarrow> order c (p ^ n) = n * order c p"
   by (induction n) (auto simp: order_mult)
 
 lemma same_root_imp_not_coprime:
   assumes "poly p x = 0" and "poly q (x :: 'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize}) = 0"
   shows   "\<not>coprime p q"
 proof
   assume "coprime p q"
   from assms have "[:-x, 1:] dvd p" and "[:-x, 1:] dvd q"
     by (simp_all add: poly_eq_0_iff_dvd)
   hence "[:-x, 1:] dvd gcd p q" by (simp add: poly_eq_0_iff_dvd)
   also from \<open>coprime p q\<close> have "gcd p q = 1"
     by (rule coprime_imp_gcd_eq_1)
   finally show False by (elim is_unit_polyE) auto
 qed
 
 
 
 lemma ratfps_nth_bigo_square_free_factorization:
   fixes p :: "complex poly"
   assumes "square_free_factorization q (b, cs)"
   assumes "q \<noteq> 0" and "R > 0"
   assumes roots1: "\<And>c l. (c, l) \<in> set cs \<Longrightarrow> \<forall>x\<in>ball 0 (1 / R). poly c x \<noteq> 0"
   assumes roots2: "\<And>c l. (c, l) \<in> set cs \<Longrightarrow> l > k \<Longrightarrow> \<forall>x\<in>sphere 0 (1 / R). poly c x \<noteq> 0"
   shows   "fps_nth (fps_of_poly p / fps_of_poly q) \<in> O(\<lambda>n. of_nat n ^ k * of_real R ^ n)"
 proof -
   from assms(1) have q: "q = smult b (\<Prod>(c, l)\<in>set cs. c ^ Suc l)"
     unfolding square_free_factorization_def prod.case by blast 
   with \<open>q \<noteq> 0\<close> have [simp]: "b \<noteq> 0" by auto
 
   from assms(1) have [simp]: "(0, x) \<notin> set cs" for x
     by (auto simp: square_free_factorization_def)
   from assms(1) have coprime: "c1 = c2" "m = n"
     if "\<not>coprime c1 c2" "(c1, m) \<in> set cs" "(c2, n) \<in> set cs" for c1 c2 m n
     using that by (auto simp: square_free_factorization_def case_prod_unfold)
 
   show ?thesis
   proof (rule ratfps_nth_bigo)
     fix z :: complex assume z: "z \<in> ball 0 (1 / R)"
     show "poly q z \<noteq> 0"
     proof
       assume "poly q z = 0"
       then obtain c l where cl: "(c, l) \<in> set cs" and "poly c z = 0"
         by (auto simp: q poly_prod image_iff)
       with roots1[of c l] and z show False by auto
     qed
   next
     fix z :: complex assume z: "z \<in> sphere 0 (1 / R)"
 
     have order: "order z q = order z (\<Prod>(c, l)\<in>set cs. c ^ Suc l)"
       by (simp add: order_smult q)
     also have "\<dots> = (\<Sum>x\<in>set cs. order z (case x of (c, l) \<Rightarrow> c ^ Suc l))"
       by (subst order_prod) (auto dest: coprime)
     also have "\<dots> = (\<Sum>(c, l)\<in>set cs. Suc l * order z c)"
       unfolding case_prod_unfold by (intro sum.cong refl, subst order_power) auto
     finally have "order z q = \<dots>" .
 
     show "order z q \<le> Suc k"
     proof (cases "\<exists>c0 l0. (c0, l0) \<in> set cs \<and> poly c0 z = 0")
       case False
       have "order z q = (\<Sum>(c, l)\<in>set cs. Suc l * order z c)" by fact
       also have "order z c = 0" if "(c, l) \<in> set cs" for c l
         using False that by (auto simp: order_root)
       hence "(\<Sum>(c, l)\<in>set cs. Suc l * order z c) = 0"
         by (intro sum.neutral) auto
       finally show "order z q \<le> Suc k" by simp
     next
       case True \<comment>\<open>The order of a root is determined by the unique polynomial in the
                    square-free factorisation that contains it.\<close>
       then obtain c0 l0 where cl0: "(c0, l0) \<in> set cs" "poly c0 z = 0"
         by blast
       have "order z q = (\<Sum>(c, l)\<in>set cs. Suc l * order z c)" by fact
       also have "\<dots> = Suc l0 * order z c0 + (\<Sum>(c, l) \<in> set cs - {(c0, l0)}. Suc l * order z c)"
         using cl0 by (subst sum.remove[of _ "(c0, l0)"]) auto
       also have "(\<Sum>(c, l) \<in> set cs - {(c0, l0)}. Suc l * order z c) = 0"
       proof (intro sum.neutral ballI, goal_cases)
         case (1 cl)
         then obtain c l where [simp]: "cl = (c, l)" and cl: "(c, l) \<in> set cs" "(c0, l0) \<noteq> (c, l)"
           by (cases cl) auto
         from cl and cl0 and coprime[of c c0 l l0] have "coprime c c0"
           by auto
         with same_root_imp_not_coprime[of c z c0] and cl0 have "poly c z \<noteq> 0" by auto
         thus ?case by (auto simp: order_root)
       qed
       also have "square_free c0" using cl0 assms(1)
         by (auto simp: square_free_factorization_def)
       hence "rsquarefree c0" by (rule square_free_rsquarefree)
       with cl0 have "order z c0 = 1"
         by (auto simp: rsquarefree_def' order_root intro: antisym)
       finally have "order z q = Suc l0" by simp
 
       also from roots2[of c0 l0] cl0 z have "l0 \<le> k"
         by (cases l0 k rule: linorder_cases) auto
       finally show "order z q \<le> Suc k" by simp
     qed
   qed fact+
 qed
 
 find_consts name:"Count_Complex"
 term proots_ball_card
 term proots_sphere_card
 
 lemma proots_within_card_zero_iff:
   assumes "p \<noteq> (0 :: 'a :: idom poly)"
   shows   "card (proots_within p A) = 0 \<longleftrightarrow> (\<forall>x\<in>A. poly p x \<noteq> 0)"
   using assms by (subst card_0_eq) (auto intro: finite_proots)
 
 
 lemma ratfps_nth_bigo_square_free_factorization':
   fixes p :: "complex poly"
   assumes "square_free_factorization q (b, cs)"
   assumes "q \<noteq> 0" and "R > 0"
   assumes roots1: "list_all (\<lambda>cl. proots_ball_card (fst cl) 0 (1 / R) = 0) cs"
   assumes roots2: "list_all (\<lambda>cl. proots_sphere_card (fst cl) 0 (1 / R) = 0)
                      (filter (\<lambda>cl. snd cl > k) cs)"
   shows   "fps_nth (fps_of_poly p / fps_of_poly q) \<in> O(\<lambda>n. of_nat n ^ k * of_real R ^ n)"
 proof (rule ratfps_nth_bigo_square_free_factorization[OF assms(1)])
   from assms(1) have q: "q = smult b (\<Prod>(c, l)\<in>set cs. c ^ Suc l)"
     unfolding square_free_factorization_def prod.case by blast 
   with \<open>q \<noteq> 0\<close> have [simp]: "b \<noteq> 0" by auto
   from assms(1) have [simp]: "(0, x) \<notin> set cs" for x
     by (auto simp: square_free_factorization_def)
 
   show "\<forall>x\<in>ball 0 (1 / R). poly c x \<noteq> 0" if "(c, l) \<in> set cs" for c l
   proof -
     from roots1 that have "card (proots_within c (ball 0 (1 / R))) = 0"
       by (auto simp: proots_ball_card_def list_all_def)
     with that show ?thesis by (subst (asm) proots_within_card_zero_iff) auto
   qed
 
   show "\<forall>x\<in>sphere 0 (1 / R). poly c x \<noteq> 0" if "(c, l) \<in> set cs" "l > k" for c l
   proof -
     from roots2 that have "card (proots_within c (sphere 0 (1 / R))) = 0"
       by (auto simp: proots_sphere_card_def list_all_def)
     with that show ?thesis by (subst (asm) proots_within_card_zero_iff) auto
   qed
 qed fact+
 
 definition ratfps_has_asymptotics where
   "ratfps_has_asymptotics q k R \<longleftrightarrow> q \<noteq> 0 \<and> R > 0 \<and>
      (let cs = snd (yun_factorization gcd q)
       in  list_all (\<lambda>cl. proots_ball_card (fst cl) 0 (1 / R) = 0) cs \<and>
           list_all (\<lambda>cl. proots_sphere_card (fst cl) 0 (1 / R) = 0) (filter (\<lambda>cl. snd cl > k) cs))"
 
 lemma ratfps_has_asymptotics_correct:
   assumes "ratfps_has_asymptotics q k R"
   shows   "fps_nth (fps_of_poly p / fps_of_poly q) \<in> O(\<lambda>n. of_nat n ^ k * of_real R ^ n)"
 proof (rule ratfps_nth_bigo_square_free_factorization')
   show "square_free_factorization q (fst (yun_factorization gcd q), snd (yun_factorization gcd q))"
     by (rule yun_factorization) simp
 qed (insert assms, auto simp: ratfps_has_asymptotics_def Let_def list_all_def)
 
 
 value "map (fps_nth (fps_of_poly [:0, 1:] / fps_of_poly [:1, -1, -1 :: real:])) [0..<5]"
 
 
 
 
 method ratfps_bigo = (rule ratfps_has_asymptotics_correct; eval)
 
 lemma "fps_nth (fps_of_poly [:0, 1:] / fps_of_poly [:1, -1, -1 :: complex:]) \<in>
          O(\<lambda>n. of_nat n ^ 0 * complex_of_real 1.618034 ^ n)"
   by ratfps_bigo
 
 lemma "fps_nth (fps_of_poly 1 / fps_of_poly [:1, -3, 3, -1 :: complex:]) \<in>
          O(\<lambda>n. of_nat n ^ 2 * complex_of_real 1 ^ n)"
   by ratfps_bigo
 
 lemma "fps_nth (fps_of_poly f / fps_of_poly [:5, 4, 3, 2, 1 :: complex:]) \<in>
          O(\<lambda>n. of_nat n ^ 0 * complex_of_real 0.69202 ^ n)"
   by ratfps_bigo
 
 end
diff --git a/thys/Liouville_Numbers/Liouville_Numbers.thy b/thys/Liouville_Numbers/Liouville_Numbers.thy
--- a/thys/Liouville_Numbers/Liouville_Numbers.thy
+++ b/thys/Liouville_Numbers/Liouville_Numbers.thy
@@ -1,384 +1,388 @@
 (* 
   File:    Liouville_Numbers.thy
   Author:  Manuel Eberl <eberlm@in.tum.de>
 
   The definition of Liouville numbers and their standard construction, plus the proof
   that any Liouville number is transcendental.
 *)
 
 theory Liouville_Numbers
 imports 
   Complex_Main
   "HOL-Computational_Algebra.Polynomial"
   Liouville_Numbers_Misc
 begin
 
 (* 
   TODO: Move definition of algebraic numbers out of Algebraic_Numbers to reduce unnecessary
   dependencies.
 *)
 
 text \<open>
 A Liouville number is a real number that can be approximated well -- but not perfectly -- 
 by a sequence of rational numbers. ``Well``, in this context, means that the error of the
  $n$-th rational in the sequence is bounded by the $n$-th power of its denominator.
 
 Our approach will be the following:
 \begin{itemize}
 \item Liouville numbers cannot be rational.
 \item Any irrational algebraic number cannot be approximated in the Liouville sense
 \item Therefore, all Liouville numbers are transcendental.
 \item The standard construction fulfils all the properties of Liouville numbers.
 \end{itemize}
 \<close>
 
 subsection \<open>Definition of Liouville numbers\<close>
 
 text \<open>
   The following definitions and proofs are largely adapted from those in the Wikipedia
   article on Liouville numbers.~\cite{wikipedia}
 \<close>
 
 text \<open>
   A Liouville number is a real number that can be approximated well -- but not perfectly --
   by a sequence of rational numbers. The error of the $n$-th term $\frac{p_n}{q_n}$ is at most
   $q_n^{-n}$, where $p_n\in\isasymint$ and $q_n \in\isasymint_{\geq 2}$.
 
   We will say that such a number can be approximated in the Liouville sense.
 \<close>
 locale liouville =
   fixes x :: real and p q :: "nat \<Rightarrow> int"
   assumes approx_int_pos: "abs (x - p n / q n) > 0" 
       and denom_gt_1:     "q n > 1"
       and approx_int:     "abs (x - p n / q n) < 1 / of_int (q n) ^ n"
 
 text \<open>
   First, we show that any Liouville number is irrational.
 \<close>
 lemma (in liouville) irrational: "x \<notin> \<rat>"
 proof
   assume "x \<in> \<rat>"
   then obtain c d :: int where d: "x = of_int c / of_int d" "d > 0" 
     by (elim Rats_cases') simp
   define n where "n = Suc (nat \<lceil>log 2 d\<rceil>)"
   note q_gt_1 = denom_gt_1[of n]
 
   have neq: "c * q n \<noteq> d * p n"
   proof
     assume "c * q n = d * p n"
     hence "of_int (c * q n) = of_int (d * p n)" by (simp only: )
     with approx_int_pos[of n] d q_gt_1 show False by (auto simp: field_simps)
   qed
   hence abs_pos: "0 < abs (c * q n - d * p n)" by simp
 
   from q_gt_1 d have "of_int d = 2 powr log 2 d" by (subst powr_log_cancel) simp_all
   also from d have "log 2 (of_int d) \<ge> log 2 1" by (subst log_le_cancel_iff) simp_all
   hence "2 powr log 2 d \<le> 2 powr of_nat (nat \<lceil>log 2 d\<rceil>)" 
     by (intro powr_mono) simp_all
   also have "\<dots> = of_int (2 ^ nat \<lceil>log 2 d\<rceil>)"
     by (subst powr_realpow) simp_all
   finally have "d \<le> 2 ^ nat \<lceil>log 2 (of_int d)\<rceil>" 
     by (subst (asm) of_int_le_iff)
   also have "\<dots> * q n \<le> q n ^ Suc (nat \<lceil>log 2 (of_int d)\<rceil>)" 
     by (subst power_Suc, subst mult.commute, intro mult_left_mono power_mono, 
         insert q_gt_1) simp_all
   also from q_gt_1 have "\<dots> = q n ^ n" by (simp add: n_def)
   finally have "1 / of_int (q n ^ n) \<le> 1 / real_of_int (d * q n)" using q_gt_1 d
     by (intro divide_left_mono Rings.mult_pos_pos of_int_pos, subst of_int_le_iff) simp_all
   also have "\<dots> \<le> of_int (abs (c * q n - d * p n)) / real_of_int (d * q n)" using q_gt_1 d abs_pos
     by (intro divide_right_mono) (linarith, simp)
   also have "\<dots> = abs (x - of_int (p n) / of_int (q n))" using q_gt_1 d(2) 
     by (simp_all add: divide_simps d(1) mult_ac)
   finally show False using approx_int[of n] by simp
 qed
 
 
 text \<open>
   Next, any irrational algebraic number cannot be approximated with rational 
   numbers in the Liouville sense.
 \<close>
 lemma liouville_irrational_algebraic:
   fixes x :: real
   assumes irrationsl: "x \<notin> \<rat>" and "algebraic x"
   obtains c :: real and n :: nat
     where "c > 0" and "\<And>(p::int) (q::int). q > 0 \<Longrightarrow> abs (x - p / q) > c / of_int q ^ n"
 proof -
-  from \<open>algebraic x\<close> guess p by (elim algebraicE) note p = this
+  from \<open>algebraic x\<close> obtain p where p: "\<And>i. coeff p i \<in> \<int>" "p \<noteq> 0" "poly p x = 0"
+    by (elim algebraicE) blast
   define n where "n = degree p"
 
   \<comment> \<open>The derivative of @{term p} is bounded within @{term "{x-1..x+1}"}.\<close>
   let ?f = "\<lambda>t. \<bar>poly (pderiv p) t\<bar>"
   define M where "M = (SUP t\<in>{x-1..x+1}. ?f t)"
   define roots where "roots = {x. poly p x = 0} - {x}"
 
   define A_set where "A_set = {1, 1/M} \<union> {abs (x' - x) |x'. x' \<in> roots}"
   define A' where "A' = Min A_set"
   define A  where "A = A' / 2"
   \<comment> \<open>We define @{term A} to be a positive real number that is less than @{term 1}, 
       @{term "1/M"} and any distance from @{term x} to another root of @{term p}.\<close>
 
   \<comment> \<open>Properties of @{term M}, our upper bound for the derivative of @{term p}:\<close>
   have "\<exists>s\<in>{x-1..x+1}. \<forall>y\<in>{x-1..x+1}. ?f s \<ge> ?f y"
     by (intro continuous_attains_sup) (auto intro!: continuous_intros)
   hence bdd: "bdd_above (?f ` {x-1..x+1})" by auto
   
   have M_pos: "M > 0"
   proof -
     from p have "pderiv p \<noteq> 0" by (auto dest!: pderiv_iszero)
     hence "finite {x. poly (pderiv p) x = 0}" using poly_roots_finite by blast
     moreover have "\<not>finite {x-1..x+1}" by (simp add: infinite_Icc)
     ultimately have "\<not>finite ({x-1..x+1} - {x. poly (pderiv p) x = 0})" by simp
     hence "{x-1..x+1} - {x. poly (pderiv p) x = 0} \<noteq> {}" by (intro notI) simp
     then obtain t where t: "t \<in> {x-1..x+1}" and "poly (pderiv p) t \<noteq> 0" by blast
     hence "0 < ?f t" by simp
     also from t and bdd have "\<dots> \<le> M" unfolding M_def by (rule cSUP_upper)
     finally show "M > 0" .
   qed
 
   have M_sup: "?f t \<le> M" if "t \<in> {x-1..x+1}" for t
   proof -
     from that and bdd show "?f t \<le> M"
       unfolding M_def by (rule cSUP_upper)
   qed
 
 
   \<comment> \<open>Properties of @{term A}:\<close>
   from p poly_roots_finite[of p] have "finite A_set" 
     unfolding A_set_def roots_def by simp
   have "x \<notin> roots" unfolding roots_def by auto
   hence "A' > 0" using Min_gr_iff[OF \<open>finite A_set\<close>, folded A'_def, of 0]
     by (auto simp: A_set_def M_pos)
   hence A_pos: "A > 0" by (simp add: A_def)
   
   from \<open>A' > 0\<close> have "A < A'" by (simp add: A_def)
   moreover from Min_le[OF \<open>finite A_set\<close>, folded A'_def] 
     have "A' \<le> 1" "A' \<le> 1/M" "\<And>x'. x' \<noteq> x \<Longrightarrow> poly p x' = 0 \<Longrightarrow> A' \<le> abs (x' - x)"
     unfolding A_set_def roots_def by auto
   ultimately have A_less: "A < 1" "A < 1/M" "\<And>x'. x' \<noteq> x \<Longrightarrow> poly p x' = 0 \<Longrightarrow> A < abs (x' - x)"
     by fastforce+
 
 
   \<comment> \<open>Finally: no rational number can approximate @{term x} ``well enough''.\<close>
   have "\<forall>(a::int) (b :: int). b > 0 \<longrightarrow> \<bar>x - of_int a / of_int b\<bar> > A / of_int b ^ n"
   proof (intro allI impI, rule ccontr)
     fix a b :: int
     assume b: "b > 0" and "\<not>(A / of_int b ^ n < \<bar>x - of_int a / of_int b\<bar>)"
     hence ab: "abs (x - of_int a / of_int b) \<le> A / of_int b ^ n" by simp
     also from A_pos b have "A / of_int b ^ n \<le> A / 1"
       by (intro divide_left_mono) simp_all
     finally have ab': "abs (x - a / b) \<le> A" by simp
     also have "\<dots> \<le> 1" using A_less by simp
     finally have ab'': "a / b \<in> {x-1..x+1}" by auto
     
     have no_root: "poly p (a / b) \<noteq> 0" 
     proof
       assume "poly p (a / b) = 0"
       moreover from \<open>x \<notin> \<rat>\<close> have "x \<noteq> a / b" by auto
       ultimately have "A < abs (a / b - x)" using A_less(3) by simp
       with ab' show False by simp
     qed
 
     have "\<exists>x0\<in>{x-1..x+1}. poly p (a / b) - poly p x = (a / b - x) * poly (pderiv p) x0"
       using ab'' by (intro poly_MVT') (auto simp: min_def max_def)
     with p obtain x0 :: real where x0:
         "x0 \<in> {x-1..x+1}" "poly p (a / b) = (a / b - x) * poly (pderiv p) x0" by auto
 
     from x0(2) no_root have deriv_pos: "poly (pderiv p) x0 \<noteq> 0" by auto
 
     from b p no_root have p_ab: "abs (poly p (a / b)) \<ge> 1 / of_int b ^ n"
       unfolding n_def by (intro int_poly_rat_no_root_ge)
 
     note ab
     also from A_less b have "A / of_int b ^ n < (1/M) / of_int b ^ n"
       by (intro divide_strict_right_mono) simp_all
     also have "\<dots> = (1 / b ^ n) / M" by simp
     also from M_pos ab p_ab have "\<dots> \<le> abs (poly p (a / b)) / M"
       by (intro divide_right_mono) simp_all
     also from deriv_pos M_pos x0(1)
       have "\<dots> \<le> abs (poly p (a / b)) / abs (poly (pderiv p) x0)"
       by (intro divide_left_mono M_sup) simp_all
     also have "\<bar>poly p (a / b)\<bar> = \<bar>a / b - x\<bar> * \<bar>poly (pderiv p) x0\<bar>"
       by (subst x0(2)) (simp add: abs_mult)
     with deriv_pos have "\<bar>poly p (a / b)\<bar> / \<bar>poly (pderiv p) x0\<bar> = \<bar>x - a / b\<bar>" 
       by (subst nonzero_divide_eq_eq) simp_all
     finally show False by simp 
   qed
   with A_pos show ?thesis using that[of A n] by blast
 qed
 
 
 text \<open>
   Since Liouville numbers are irrational, but can be approximated well by rational 
   numbers in the Liouville sense, they must be transcendental.
 \<close>
 lemma (in liouville) transcendental: "\<not>algebraic x"
 proof
   assume "algebraic x"
-  from liouville_irrational_algebraic[OF irrational this] guess c n . note cn = this
+  from liouville_irrational_algebraic[OF irrational this]
+  obtain c n where cn:
+    "c > 0" "\<And>p q. q > 0 \<Longrightarrow> c / real_of_int q ^ n < \<bar>x - real_of_int p / real_of_int q\<bar>"
+    by auto
   
   define r where "r = nat \<lceil>log 2 (1 / c)\<rceil>"
   define m where "m = n + r"
   from cn(1) have "(1/c) = 2 powr log 2 (1/c)" by (subst powr_log_cancel) simp_all
   also have "log 2 (1/c) \<le> of_nat (nat \<lceil>log 2 (1/c)\<rceil>)" by linarith
   hence "2 powr log 2 (1/c) \<le> 2 powr \<dots>" by (intro powr_mono) simp_all
   also have "\<dots> = 2 ^ r" unfolding r_def by (simp add: powr_realpow)
   finally have "1 / (2^r) \<le> c" using cn(1) by (simp add: field_simps)
 
   have "abs (x - p m / q m) < 1 / of_int (q m) ^ m" by (rule approx_int)
   also have "\<dots> = (1 / of_int (q m) ^ r) * (1 / real_of_int (q m) ^ n)"
     by (simp add: m_def power_add)
   also from denom_gt_1[of m] have "1 / real_of_int (q m) ^ r \<le> 1 / 2 ^ r"
     by (intro divide_left_mono power_mono) simp_all
   also have "\<dots> \<le> c" by fact
   finally have "abs (x - p m / q m) < c / of_int (q m) ^ n"
     using denom_gt_1[of m] by - (simp_all add: divide_right_mono)
   with cn(2)[of "q m" "p m"] denom_gt_1[of m] show False by simp
 qed
 
 
 subsection \<open>Standard construction for Liouville numbers\<close>
 
 text \<open>
   We now define the standard construction for Liouville numbers.
 \<close>
 definition standard_liouville :: "(nat \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> real" where
   "standard_liouville p q = (\<Sum>k. p k / of_int q ^ fact (Suc k))"
 
 lemma standard_liouville_summable:
   fixes p :: "nat \<Rightarrow> int" and q :: int
   assumes "q > 1" "range p \<subseteq> {0..<q}"
   shows   "summable (\<lambda>k. p k / of_int q ^ fact (Suc k))"
 proof (rule summable_comparison_test')
   from assms(1) show "summable (\<lambda>n. (1 / q) ^ n)"
     by (intro summable_geometric) simp_all
 next
   fix n :: nat
   from assms have "p n \<in> {0..<q}" by blast
   with assms(1) have "norm (p n / of_int q ^ fact (Suc n)) \<le> 
                         q / of_int q ^ (fact (Suc n))" by (auto simp: field_simps)
   also from assms(1) have "\<dots> = 1 / of_int q ^ (fact (Suc n) - 1)" 
     by (subst power_diff) (auto simp del: fact_Suc)
   also have "Suc n \<le> fact (Suc n)" by (rule fact_ge_self)
   with assms(1) have "1 / real_of_int q ^ (fact (Suc n) - 1) \<le> 1 / of_int q ^ n"
     by (intro divide_left_mono power_increasing)
        (auto simp del: fact_Suc simp add: algebra_simps)
   finally show "norm (p n / of_int q ^ fact (Suc n)) \<le> (1 / q) ^ n"
     by (simp add: power_divide)
 qed
 
 lemma standard_liouville_sums:
   assumes "q > 1" "range p \<subseteq> {0..<q}"
   shows   "(\<lambda>k. p k / of_int q ^ fact (Suc k)) sums standard_liouville p q"
   using standard_liouville_summable[OF assms] unfolding standard_liouville_def 
   by (simp add: summable_sums)
 
 
 text \<open>
   Now we prove that the standard construction indeed yields Liouville numbers.
 \<close>
 lemma standard_liouville_is_liouville:
   assumes "q > 1" "range p \<subseteq> {0..<q}" "frequently (\<lambda>n. p n \<noteq> 0) sequentially"
   defines "b \<equiv> \<lambda>n. q ^ fact (Suc n)"
   defines "a \<equiv> \<lambda>n. (\<Sum>k\<le>n. p k * q ^ (fact (Suc n) - fact (Suc k)))"
   shows   "liouville (standard_liouville p q) a b"
 proof
   fix n :: nat
   from assms(1) have "1 < q ^ 1" by simp
   also from assms(1) have "\<dots> \<le> b n" unfolding b_def 
     by (intro power_increasing) (simp_all del: fact_Suc)
   finally show "b n > 1" .
 
   note summable = standard_liouville_summable[OF assms(1,2)]
   let ?S = "\<Sum>k. p (k + n + 1) / of_int q ^ (fact (Suc (k + n + 1)))"
   let ?C = "(q - 1) / of_int q ^ (fact (n+2))"
 
   have "a n / b n = (\<Sum>k\<le>n. p k * (of_int q ^ (fact (n+1) - fact (k+1)) / of_int q ^ (fact (n+1))))"
     by (simp add: a_def b_def sum_divide_distrib of_int_sum)
   also have "\<dots> = (\<Sum>k\<le>n. p k / of_int q ^ (fact (Suc k)))"
     by (intro sum.cong refl, subst inverse_divide [symmetric], subst power_diff [symmetric])
        (insert assms(1), simp_all add: divide_simps fact_mono_nat del: fact_Suc)
   also have "standard_liouville p q - \<dots> = ?S" unfolding standard_liouville_def
     by (subst diff_eq_eq) (intro suminf_split_initial_segment' summable)
   finally have "abs (standard_liouville p q - a n / b n) = abs ?S" by (simp only: )
   moreover from assms have "?S \<ge> 0" 
     by (intro suminf_nonneg allI divide_nonneg_pos summable_ignore_initial_segment summable) force+
   ultimately have eq: "abs (standard_liouville p q - a n / b n) = ?S" by simp
 
   also have "?S \<le> (\<Sum>k. ?C * (1 / q) ^ k)"
   proof (intro suminf_le allI summable_ignore_initial_segment summable)
     from assms show "summable (\<lambda>k. ?C * (1 / q) ^ k)"
       by (intro summable_mult summable_geometric) simp_all
   next
     fix k :: nat
     from assms have "p (k + n + 1) \<le> q - 1" by force
     with \<open>q > 1\<close> have "p (k + n + 1) / of_int q ^ fact (Suc (k + n + 1)) \<le> 
                          (q - 1) / of_int q ^ (fact (Suc (k + n + 1)))"
       by (intro divide_right_mono) (simp_all del: fact_Suc)
     also from \<open>q > 1\<close> have "\<dots> \<le> (q - 1) / of_int q ^ (fact (n+2) + k)"
       using fact_ineq[of "n+2" k]
       by (intro divide_left_mono power_increasing) (simp_all add: add_ac)
     also have "\<dots> = ?C * (1 / q) ^ k" 
       by (simp add: field_simps power_add del: fact_Suc)
     finally show "p (k + n + 1) / of_int q ^ fact (Suc (k + n + 1)) \<le> \<dots>" .
   qed
   also from assms have "\<dots> = ?C * (\<Sum>k. (1 / q) ^ k)"
     by (intro suminf_mult summable_geometric) simp_all
   also from assms have "(\<Sum>k. (1 / q) ^ k) = 1 / (1 - 1 / q)"
     by (intro suminf_geometric) simp_all
   also from assms(1) have "?C * \<dots> = of_int q ^ 1 / of_int q ^ fact (n + 2)" 
     by (simp add: field_simps)
   also from assms(1) have "\<dots> \<le> of_int q ^ fact (n + 1) / of_int q ^ fact (n + 2)"
     by (intro divide_right_mono power_increasing) (simp_all add: field_simps del: fact_Suc)
   also from assms(1) have "\<dots> = 1 / (of_int q ^ (fact (n + 2) - fact (n + 1)))" 
     by (subst power_diff) simp_all
   also have "fact (n + 2) - fact (n + 1) = (n + 1) * fact (n + 1)" by (simp add: algebra_simps)
   also from assms(1) have "1 / (of_int q ^ \<dots>) < 1 / (real_of_int q ^ (fact (n + 1) * n))"
     by (intro divide_strict_left_mono power_increasing mult_right_mono) simp_all
   also have "\<dots> = 1 / of_int (b n) ^ n" 
     by (simp add: power_mult b_def power_divide del: fact_Suc)
   finally show "\<bar>standard_liouville p q - a n / b n\<bar> < 1 / of_int (b n) ^ n" .
 
   from assms(3) obtain k where k: "k \<ge> n + 1" "p k \<noteq> 0" 
     by (auto simp: frequently_def eventually_at_top_linorder)
   define k' where "k' = k - n - 1"
   from assms k have "p k \<ge> 0" by force
   with k assms have k': "p (k' + n + 1) > 0" unfolding k'_def by force
   with assms(1,2) have "?S > 0"
     by (intro suminf_pos2[of _ k'] summable_ignore_initial_segment summable) 
        (force intro!: divide_pos_pos divide_nonneg_pos)+
   with eq show "\<bar>standard_liouville p q - a n / b n\<bar> > 0" by (simp only: )
 qed
 
 
 text \<open>
   We can now show our main result: any standard Liouville number is transcendental.
 \<close>
 theorem transcendental_standard_liouville:
   assumes "q > 1" "range p \<subseteq> {0..<q}" "frequently (\<lambda>k. p k \<noteq> 0) sequentially"
   shows   "\<not>algebraic (standard_liouville p q)"
 proof -
   from assms interpret 
     liouville "standard_liouville p q" 
               "\<lambda>n. (\<Sum>k\<le>n. p k * q ^ (fact (Suc n) - fact (Suc k)))" 
               "\<lambda>n. q ^ fact (Suc n)" 
     by (rule standard_liouville_is_liouville)
   from transcendental show ?thesis .
 qed
 
 text \<open>
   In particular: The the standard construction for constant sequences, such as the
   ``classic'' Liouville constant $\sum_{n=1}^\infty 10^{-n!} = 0.11000100\ldots$,
   are transcendental. 
 
   This shows that Liouville numbers exists and therefore gives a concrete and 
   elementary proof that transcendental numbers exist.
 \<close>
 corollary transcendental_standard_standard_liouville:
   "a \<in> {0<..<b} \<Longrightarrow> \<not>algebraic (standard_liouville (\<lambda>_. int a) (int b))"
   by (intro transcendental_standard_liouville) auto
 
 corollary transcendental_liouville_constant:
   "\<not>algebraic (standard_liouville (\<lambda>_. 1) 10)"
   by (intro transcendental_standard_liouville) auto
 
 end
diff --git a/thys/Markov_Models/Classifying_Markov_Chain_States.thy b/thys/Markov_Models/Classifying_Markov_Chain_States.thy
--- a/thys/Markov_Models/Classifying_Markov_Chain_States.thy
+++ b/thys/Markov_Models/Classifying_Markov_Chain_States.thy
@@ -1,2340 +1,2344 @@
 section \<open>Classifying Markov Chain States\<close>
 
 theory Classifying_Markov_Chain_States
   imports
     "HOL-Computational_Algebra.Group_Closure"
     Discrete_Time_Markov_Chain
 begin
 
 lemma eventually_mult_Gcd:
   fixes S :: "nat set"
   assumes S: "\<And>s t. s \<in> S \<Longrightarrow> t \<in> S \<Longrightarrow> s + t \<in> S"
   assumes s: "s \<in> S" "s > 0"
   shows "eventually (\<lambda>m. m * Gcd S \<in> S) sequentially"
 proof -
   define T where "T = insert 0 (int ` S)"
   with s S have "int s \<in> T" "0 \<in> T" and T: "r \<in> T \<Longrightarrow> t \<in> T \<Longrightarrow> r + t \<in> T" for r t
     by (auto simp del: of_nat_add simp add: of_nat_add [symmetric])
   have "Gcd T \<in> group_closure T"
     by (rule Gcd_in_group_closure)
   also have "group_closure T = {s - t | s t. s \<in> T \<and> t \<in> T}"
   proof (auto intro: group_closure.base group_closure.diff)
     fix x assume "x \<in> group_closure T"
     then show "\<exists>s t. x = s - t \<and> s \<in> T \<and> t \<in> T"
     proof induction
       case (base x) with \<open>0 \<in> T\<close> show ?case
         apply (rule_tac x=x in exI)
         apply (rule_tac x=0 in exI)
         apply auto
         done
     next
       case (diff x y)
       then obtain a b c d where
         "a \<in> T" "b \<in> T" "x = a - b"
         "c \<in> T" "d \<in> T" "y = c - d"
         by auto
       then show ?case
         apply (rule_tac x="a + d" in exI)
         apply (rule_tac x="b + c" in exI)
         apply (auto intro: T)
         done
     qed
   qed
   finally obtain s' t' :: int
     where "s' \<in> T" "t' \<in> T" "Gcd T = s' - t'"
     by blast
   moreover define s and t where "s = nat s'" and "t = nat t'"
   moreover have "int (Gcd S) = - int t \<longleftrightarrow> S \<subseteq> {0} \<and> t = 0"
     by auto (metis Gcd_dvd_nat dvd_0_right dvd_antisym nat_int nat_zminus_int) 
   ultimately have 
     st: "s = 0 \<or> s \<in> S" "t = 0 \<or> t \<in> S" and Gcd_S: "Gcd S = s - t"
     using T_def by safe simp_all
   with s
   have "t < s"
     by (rule_tac ccontr) auto
 
   { fix s n have "0 < n \<Longrightarrow> s \<in> S \<Longrightarrow> n * s \<in> S"
     proof (induct n)
       case (Suc n) then show ?case
         by (cases n) (auto intro: S)
     qed simp }
   note cmult_S = this
 
   show ?thesis
     unfolding eventually_sequentially
   proof cases
     assume "s = 0 \<or> t = 0"
     with st Gcd_S s have *: "Gcd S \<in> S"
       by (auto simp: int_eq_iff)
     then show "\<exists>N. \<forall>n\<ge>N. n * Gcd S \<in> S" by (auto intro!: exI[of _ 1] cmult_S)
   next
     assume "\<not> (s = 0 \<or> t = 0)"
     with st have "s \<in> S" "t \<in> S" "t \<noteq> 0" by auto
     then have "Gcd S dvd t" by auto
     then obtain a where a: "t = Gcd S * a" ..
     with \<open>t \<noteq> 0\<close> have "0 < a" by auto
 
     show "\<exists>N. \<forall>n\<ge>N. n * Gcd S \<in> S"
     proof (safe intro!: exI[of _ "a * a"])
       fix n
       define m where "m = (n - a * a) div a"
       define r where "r = (n - a * a) mod a"
       with \<open>0 < a\<close> have "r < a" by simp
       moreover define am where "am = a + m"
       ultimately have "r < am" by simp
       assume "a * a \<le> n" then have n: "n = a * a + (m * a + r)"
         unfolding m_def r_def by simp
       have "n * Gcd S = am * t + r * Gcd S"
         unfolding n a by (simp add: field_simps am_def)
       also have "\<dots> = r * s + (am - r) * t"
         unfolding \<open>Gcd S = s - t\<close>
         using \<open>t < s\<close> \<open>r < am\<close> by (simp add: field_simps diff_mult_distrib2)
       also have "\<dots> \<in> S"
         using \<open>s \<in> S\<close> \<open>t \<in> S\<close> \<open>r < am\<close>
         by (cases "r = 0") (auto intro!: cmult_S S)
       finally show "n * Gcd S \<in> S" .
     qed
   qed
 qed
 
 context MC_syntax
 begin
 
 subsection \<open>Expected number of visits\<close>
 
 definition "G s t = (\<integral>\<^sup>+\<omega>. scount (HLD {t}) (s ## \<omega>) \<partial>T s)"
 
 lemma G_eq: "G s t = (\<integral>\<^sup>+\<omega>. emeasure (count_space UNIV) {i. (s ## \<omega>) !! i = t} \<partial>T s)"
   by (simp add: G_def scount_eq_emeasure HLD_iff)
 
 definition "p s t n = \<P>(\<omega> in T s. (s ## \<omega>) !! n = t)"
 
 definition "gf_G s t z = (\<Sum>n. p s t n *\<^sub>R z ^ n)"
 
 definition "convergence_G s t z \<longleftrightarrow> summable (\<lambda>n. p s t n * norm z ^ n)"
 
 lemma p_nonneg[simp]: "0 \<le> p x y n"
   by (simp add: p_def)
 
 lemma p_le_1: "p x y n \<le> 1"
   by (simp add: p_def)
 
 lemma p_x_x_0[simp]: "p x x 0 = 1"
   by (simp add: p_def T.prob_space del: space_T)
 
 lemma p_0: "p x y 0 = (if x = y then 1 else 0)"
   by (simp add: p_def T.prob_space del: space_T)
 
 lemma p_in_reachable: assumes "(x, y) \<notin> (SIGMA x:UNIV. K x)\<^sup>*" shows "p x y n = 0"
   unfolding p_def
 proof (rule T.prob_eq_0_AE)
   from AE_T_reachable show "AE \<omega> in T x. (x ## \<omega>) !! n \<noteq> y"
   proof eventually_elim
     fix \<omega> assume "alw (HLD ((SIGMA \<omega>:UNIV. K \<omega>)\<^sup>* `` {x})) \<omega>"
     then have "alw (HLD (- {y})) \<omega>"
       using assms by (auto intro: alw_mono simp: HLD_iff)
     then show "(x ## \<omega>) !! n \<noteq> y"
       using assms by (cases n) (auto simp: alw_HLD_iff_streams streams_iff_snth)
   qed
 qed
 
 lemma p_Suc: "ennreal (p x y (Suc n)) = (\<integral>\<^sup>+ w. p w y n \<partial>K x)"
   unfolding p_def T.emeasure_eq_measure[symmetric] by (subst emeasure_Collect_T) simp_all
 
 lemma p_Suc':
   "p x y (Suc n) = (\<integral>x'. p x' y n \<partial>K x)"
   using p_Suc[of x y n]
   by (subst (asm) nn_integral_eq_integral)
      (auto simp: p_le_1 intro!: measure_pmf.integrable_const_bound[where B=1])
 
 lemma p_add: "p x y (n + m) = (\<integral>\<^sup>+ w. p x w n * p w y m \<partial>count_space UNIV)"
 proof (induction n arbitrary: x)
   case 0
   have [simp]: "\<And>w. (if x = w then 1 else 0) * p w y m = ennreal (p x y m) * indicator {x} w"
     by auto
   show ?case
     by (simp add: p_0 one_ennreal_def[symmetric] max_def)
 next
   case (Suc n)
   define X where "X = (SIGMA x:UNIV. K x)\<^sup>* `` K x"
   then have X: "countable X"
     by (blast intro: countable_Image countable_reachable countable_set_pmf)
 
   then interpret X: sigma_finite_measure "count_space X"
     by (rule sigma_finite_measure_count_space_countable)
   interpret XK: pair_sigma_finite "K x" "count_space X"
     by unfold_locales
 
   have "ennreal (p x y (Suc n + m)) = (\<integral>\<^sup>+t. (\<integral>\<^sup>+w. p t w n * p w y m \<partial>count_space UNIV) \<partial>K x)"
     by (simp add: p_Suc Suc)
   also have "\<dots> = (\<integral>\<^sup>+t. (\<integral>\<^sup>+w. ennreal (p t w n * p w y m) * indicator X w \<partial>count_space UNIV) \<partial>K x)"
     by (auto intro!: nn_integral_cong_AE simp: AE_measure_pmf_iff AE_count_space Image_iff p_in_reachable X_def             split: split_indicator)
   also have "\<dots> = (\<integral>\<^sup>+t. (\<integral>\<^sup>+w. p t w n * p w y m \<partial>count_space X) \<partial>K x)"
     by (subst nn_integral_restrict_space[symmetric]) (simp_all add: restrict_count_space)
   also have "\<dots> = (\<integral>\<^sup>+w. (\<integral>\<^sup>+t. p t w n * p w y m \<partial>K x) \<partial>count_space X)"
     apply (rule XK.Fubini'[symmetric])
     unfolding measurable_split_conv
     apply (rule measurable_compose_countable'[OF _ measurable_snd X])
     apply (rule measurable_compose[OF measurable_fst])
     apply simp
     done
   also have "\<dots> = (\<integral>\<^sup>+w. (\<integral>\<^sup>+t. ennreal (p t w n * p w y m) * indicator X w \<partial>K x) \<partial>count_space UNIV)"
     by (simp add: nn_integral_restrict_space[symmetric] restrict_count_space nn_integral_multc)
   also have "\<dots> = (\<integral>\<^sup>+w. (\<integral>\<^sup>+t. ennreal (p t w n * p w y m) \<partial>K x) \<partial>count_space UNIV)"
     by (auto intro!: nn_integral_cong_AE simp: AE_measure_pmf_iff AE_count_space Image_iff p_in_reachable X_def             split: split_indicator)
   also have "\<dots> = (\<integral>\<^sup>+w. (\<integral>\<^sup>+t. p t w n \<partial>K x) * p w y m \<partial>count_space UNIV)"
     by (simp add: nn_integral_multc[symmetric] ennreal_mult)
   finally show ?case
     by (simp add: ennreal_mult p_Suc)
 qed
 
 lemma prob_reachable_le:
   assumes [simp]: "m \<le> n"
   shows "p x y m * p y w (n - m) \<le> p x w n"
 proof -
   have "p x y m * p y w (n - m) = (\<integral>\<^sup>+y'. ennreal (p x y m * p y w (n - m)) * indicator {y} y' \<partial>count_space UNIV)"
     by simp
   also have "\<dots> \<le> p x w (m + (n - m))"
     by (subst p_add)
        (auto intro!: nn_integral_mono split: split_indicator simp del: nn_integral_indicator_singleton)
   finally show ?thesis
     by simp
 qed
 
 lemma G_eq_suminf: "G x y = (\<Sum>i. ennreal (p x y i))"
 proof -
   have *: "\<And>i \<omega>. indicator {\<omega> \<in> space S. (x ## \<omega>) !! i = y} \<omega> = indicator {i. (x ## \<omega>) !! i = y} i"
     by (auto simp: space_stream_space split: split_indicator)
 
   have "G x y = (\<integral>\<^sup>+ \<omega>. (\<Sum>i. indicator {\<omega>\<in>space (T x). (x ## \<omega>) !! i = y} \<omega>) \<partial>T x)"
     unfolding G_eq by (simp add: nn_integral_count_space_nat[symmetric] *)
   also have "\<dots> = (\<Sum>i. ennreal (p x y i))"
     by (simp add: T.emeasure_eq_measure[symmetric] p_def nn_integral_suminf)
   finally show ?thesis .
 qed
 
 lemma G_eq_real_suminf:
   "convergence_G x y (1::real) \<Longrightarrow> G x y = ennreal (\<Sum>i. p x y i)"
   unfolding G_eq_suminf
   by (intro suminf_ennreal ennreal_suminf_neq_top p_nonneg)
      (auto simp: convergence_G_def p_def)
 
 lemma convergence_norm_G:
   "convergence_G x y z \<Longrightarrow> summable (\<lambda>n. p x y n * norm z ^ n)"
   unfolding convergence_G_def .
 
 lemma convergence_G:
   "convergence_G x y (z::'a::{banach, real_normed_div_algebra}) \<Longrightarrow> summable (\<lambda>n. p x y n *\<^sub>R z ^ n)"
   unfolding convergence_G_def
   by (rule summable_norm_cancel) (simp add: abs_mult norm_power)
 
 lemma convergence_G_less_1:
   fixes z :: "_ :: {banach, real_normed_field}"
   assumes z: "norm z < 1" shows "convergence_G x y z"
   unfolding convergence_G_def
 proof (rule summable_comparison_test)
   have "\<And>n. p x y n * norm (z ^ n) \<le> 1 * norm (z ^ n)"
     by (intro mult_right_mono p_le_1) simp_all
   then show "\<exists>N. \<forall>n\<ge>N. norm (p x y n * norm z ^ n) \<le> norm z ^ n"
     by (simp add: norm_power)
 qed (simp add: z summable_geometric)
 
 lemma lim_gf_G: "((\<lambda>z. ennreal (gf_G x y z)) \<longlongrightarrow> G x y) (at_left (1::real))"
   unfolding gf_G_def G_eq_suminf real_scaleR_def
   by (intro power_series_tendsto_at_left p_nonneg p_le_1 summable_power_series)
 
 subsection \<open>Reachability probability\<close>
 
 definition "u x y n = \<P>(\<omega> in T x. ev_at (HLD {y}) n \<omega>)"
 
 definition "U s t = \<P>(\<omega> in T s. ev (HLD {t}) \<omega>)"
 
 definition "gf_U x y z = (\<Sum>n. u x y n *\<^sub>R z ^ Suc n)"
 
 definition "f x y n = \<P>(\<omega> in T x. ev_at (HLD {y}) n (x ## \<omega>))"
 
 definition "F s t = \<P>(\<omega> in T s. ev (HLD {t}) (s ## \<omega>))"
 
 definition "gf_F x y z = (\<Sum>n. f x y n * z ^ n)"
 
 lemma f_Suc: "x \<noteq> y \<Longrightarrow> f x y (Suc n) = u x y n"
   by (simp add: u_def f_def)
 
 lemma f_Suc_eq: "f x x (Suc n) = 0"
   by (simp add: f_def)
 
 lemma f_0: "f x y 0 = (if x = y then 1 else 0)"
   using T.prob_space by (simp add: f_def)
 
 lemma shows u_nonneg: "0 \<le> u x y n" and u_le_1: "u x y n \<le> 1"
   by (simp_all add: u_def)
 
 lemma shows f_nonneg: "0 \<le> f x y n" and f_le_1: "f x y n \<le> 1"
   by (simp_all add: f_def)
 
 lemma U_nonneg[simp]: "0 \<le> U x y"
   by (simp add: U_def)
 
 lemma U_le_1: "U s t \<le> 1"
   by (auto simp add: U_def intro!: antisym)
 
 lemma U_cases: "U s s = 1 \<or> U s s < 1"
   by (auto simp add: U_def intro!: antisym)
 
 lemma u_sums_U: "u x y sums U x y"
   unfolding u_def[abs_def] U_def ev_iff_ev_at by (intro T.prob_sums) (auto intro: ev_at_unique)
 
 lemma gf_U_eq_U: "gf_U x y 1 = U x y"
   using u_sums_U[THEN sums_unique] by (simp add: gf_U_def U_def)
 
 lemma f_sums_F: "f x y sums F x y"
   unfolding f_def[abs_def] F_def ev_iff_ev_at
   by (intro T.prob_sums) (auto intro: ev_at_unique)
 
 lemma F_nonneg[simp]: "0 \<le> F x y"
   by (auto simp: F_def)
 
 lemma F_le_1: "F x y \<le> 1"
   by (simp add: F_def)
 
 lemma gf_F_eq_F: "gf_F x y 1 = F x y"
   using f_sums_F[THEN sums_unique] by (simp add: gf_F_def F_def)
 
 lemma gf_F_le_1:
   fixes z :: real
   assumes z: "0 \<le> z" "z \<le> 1"
   shows "gf_F x y z \<le> 1"
 proof -
   have "gf_F x y z \<le> gf_F x y 1"
     using z unfolding gf_F_def
     by (intro suminf_le[OF _ summable_comparison_test[OF _ sums_summable[OF f_sums_F[of x y]]]] mult_left_mono allI f_nonneg)
        (simp_all add: power_le_one f_nonneg mult_right_le_one_le f_le_1 sums_summable[OF f_sums_F[of x y]])
   also have "\<dots> \<le> 1"
     by (simp add: gf_F_eq_F F_def)
   finally show ?thesis .
 qed
 
 lemma u_le_p: "u x y n \<le> p x y (Suc n)"
   unfolding u_def p_def by (auto intro!: T.finite_measure_mono dest: ev_at_HLD_imp_snth)
 
 lemma f_le_p: "f x y n \<le> p x y n"
   unfolding f_def p_def by (auto intro!: T.finite_measure_mono dest: ev_at_HLD_imp_snth)
 
 lemma convergence_norm_U:
   fixes z :: "_ :: real_normed_div_algebra"
   assumes z: "convergence_G x y z"
   shows "summable (\<lambda>n. u x y n * norm z ^ Suc n)"
   using summable_ignore_initial_segment[OF convergence_norm_G[OF z], of 1]
   by (rule summable_comparison_test[rotated])
      (auto simp add: u_nonneg abs_mult intro!: exI[of _ 0] mult_right_mono u_le_p)
 
 lemma convergence_norm_F:
   fixes z :: "_ :: real_normed_div_algebra"
   assumes z: "convergence_G x y z"
   shows "summable (\<lambda>n. f x y n * norm z ^ n)"
   using convergence_norm_G[OF z]
   by (rule summable_comparison_test[rotated])
      (auto simp add: f_nonneg abs_mult intro!: exI[of _ 0] mult_right_mono f_le_p)
 
 lemma gf_G_nonneg:
   fixes z :: real
   shows "0 \<le> z \<Longrightarrow> z < 1 \<Longrightarrow> 0 \<le> gf_G x y z"
   unfolding gf_G_def
   by (intro suminf_nonneg convergence_G convergence_G_less_1) simp_all
 
 lemma gf_F_nonneg:
   fixes z :: real
   shows "0 \<le> z \<Longrightarrow> z < 1 \<Longrightarrow> 0 \<le> gf_F x y z"
   unfolding gf_F_def
   using convergence_norm_F[OF convergence_G_less_1, of z x y]
   by (intro suminf_nonneg) (simp_all add: f_nonneg)
 
 lemma convergence_U:
   fixes z :: "_ :: banach"
   shows "convergence_G x y z \<Longrightarrow> summable (\<lambda>n. u x y n * z ^ Suc n)"
   by (rule summable_norm_cancel)
      (auto simp add: abs_mult u_nonneg power_abs dest!: convergence_norm_U)
 
 lemma p_eq_sum_p_u: "p x y (Suc n) = (\<Sum>i\<le>n. p y y (n - i) * u x y i)"
 proof -
   have "\<And>\<omega>. \<omega> !! n = y \<Longrightarrow> (\<exists>i. i \<le> n \<and> ev_at (HLD {y}) i \<omega>)"
   proof (induction n)
     case (Suc n)
     then obtain i where "i \<le> n" "ev_at (HLD {y}) i (stl \<omega>)"
       by auto
     then show ?case
       by (auto intro!: exI[of _ "if HLD {y} \<omega> then 0 else Suc i"])
   qed (simp add: HLD_iff)
   then have "p x y (Suc n) = (\<Sum>i\<le>n. \<P>(\<omega> in T x. ev_at (HLD {y}) i \<omega> \<and> \<omega> !! n = y))"
     unfolding p_def by (intro T.prob_sum) (auto intro: ev_at_unique)
   also have "\<dots> = (\<Sum>i\<le>n. p y y (n - i) * u x y i)"
   proof (intro sum.cong refl)
     fix i assume i: "i \<in> {.. n}"
     then have "\<And>\<omega>. (Suc i \<le> n \<longrightarrow> \<omega> !! (n - Suc i) = y) \<longleftrightarrow> ((y ## \<omega>) !! (n - i) = y)"
       by (auto simp: Stream_snth diff_Suc split: nat.split)
     from i have "i \<le> n" by auto
     then have "\<P>(\<omega> in T x. ev_at (HLD {y}) i \<omega> \<and> \<omega> !! n = y) =
       (\<integral>\<omega>'. \<P>(\<omega> in T y. (y ## \<omega>) !! (n - i) = y) *
         indicator {\<omega>'\<in>space (T x). ev_at (HLD {y}) i \<omega>' } \<omega>' \<partial>T x)"
       by (subst prob_T_split[where n="Suc i"])
          (auto simp: ev_at_shift ev_at_HLD_single_imp_snth shift_snth diff_Suc
                split: split_indicator nat.split intro!: Bochner_Integration.integral_cong arg_cong2[where f=measure]
                simp del: stake.simps integral_mult_right_zero)
     then show "\<P>(\<omega> in T x. ev_at (HLD {y}) i \<omega> \<and> \<omega> !! n = y) = p y y (n - i) * u x y i"
       by (simp add: p_def u_def)
   qed
   finally show ?thesis .
 qed
 
 lemma p_eq_sum_p_f: "p x y n = (\<Sum>i\<le>n. p y y (n - i) * f x y i)"
   by (cases n)
      (simp_all del: sum.atMost_Suc
                add: f_0 p_0 p_eq_sum_p_u atMost_Suc_eq_insert_0 zero_notin_Suc_image sum.reindex
                     f_Suc f_Suc_eq)
 
 lemma gf_G_eq_gf_F:
   assumes z: "norm z < 1"
   shows "gf_G x y z = gf_F x y z * gf_G y y z"
 proof -
   have "gf_G x y z = (\<Sum>n. \<Sum>i\<le>n. p y y (n - i) * f x y i * z^n)"
     by (simp add: gf_G_def p_eq_sum_p_f[of x y] sum_distrib_right)
   also have "\<dots> = (\<Sum>n. \<Sum>i\<le>n. (f x y i * z^i) * (p y y (n - i) * z^(n - i)))"
     by (intro arg_cong[where f=suminf] sum.cong ext atLeast0AtMost[symmetric])
        (simp_all add: power_add[symmetric])
   also have "\<dots> = (\<Sum>n. f x y n * z^n) * (\<Sum>n. p y y n * z^n)"
     using convergence_norm_F[OF convergence_G_less_1[OF z]] convergence_norm_G[OF convergence_G_less_1[OF z]]
     by (intro Cauchy_product[symmetric]) (auto simp: f_nonneg abs_mult power_abs)
   also have "\<dots> = gf_F x y z * gf_G y y z"
     by (simp add: gf_F_def gf_G_def)
   finally show ?thesis .
 qed
 
 lemma gf_G_eq_gf_U:
   fixes z :: "'z :: {banach, real_normed_field}"
   assumes z: "convergence_G x x z"
   shows "gf_G x x z = 1 / (1 - gf_U x x z)" "gf_U x x z \<noteq> 1"
 proof -
   { fix n
     have "p x x (Suc n) *\<^sub>R z^Suc n = (\<Sum>i\<le>n. (p x x (n - i) * u x x i) *\<^sub>R z^Suc n)"
       unfolding scaleR_sum_left[symmetric] by (simp add: p_eq_sum_p_u)
     also have "\<dots> = (\<Sum>i\<le>n. (u x x i *\<^sub>R z^Suc i) * (p x x (n - i) *\<^sub>R z^(n - i)))"
       by (intro sum.cong refl) (simp add: field_simps power_diff cong: disj_cong)
     finally have "p x x (Suc n) *\<^sub>R z^(Suc n) = (\<Sum>i\<le>n. (u x x i *\<^sub>R z^Suc i) * (p x x (n - i) *\<^sub>R z^(n - i)))"
       unfolding atLeast0AtMost . }
   note gfs_Suc_eq = this
 
   have "gf_G x x z = 1 + (\<Sum>n. p x x (Suc n) *\<^sub>R z^(Suc n))"
     unfolding gf_G_def
     by (subst suminf_split_initial_segment[OF convergence_G[OF z], of 1]) simp
   also have "\<dots> = 1 + (\<Sum>n. \<Sum>i\<le>n. (u x x i *\<^sub>R z^Suc i) * (p x x (n - i) *\<^sub>R z^(n - i)))"
     unfolding gfs_Suc_eq ..
   also have "\<dots> = 1 + gf_U x x z * gf_G x x z"
     unfolding gf_U_def gf_G_def
     by (subst Cauchy_product)
        (auto simp: u_nonneg norm_power simp del: power_Suc
              intro!: z convergence_norm_G convergence_norm_U)
   finally show "gf_G x x z = 1 / (1 - gf_U x x z)" "gf_U x x z \<noteq> 1"
     apply -
     apply (cases "gf_U x x z = 1")
     apply (auto simp add: field_simps)
     done
 qed
 
 lemma gf_U: "(gf_U x y \<longlongrightarrow> U x y) (at_left 1)"
 proof -
   have "((\<lambda>z. ennreal (\<Sum>n. u x y n * z ^ n)) \<longlongrightarrow> (\<Sum>n. ennreal (u x y n))) (at_left 1)"
     using u_le_1 u_nonneg by (intro power_series_tendsto_at_left summable_power_series)
   also have "(\<Sum>n. ennreal (u x y n)) = ennreal (suminf (u x y))"
     by (intro u_nonneg suminf_ennreal ennreal_suminf_neq_top sums_summable[OF u_sums_U])
   also have "suminf (u x y) = U x y"
     using u_sums_U by (rule sums_unique[symmetric])
   finally have "((\<lambda>z. \<Sum>n. u x y n * z ^ n) \<longlongrightarrow> U x y) (at_left 1)"
     by (rule tendsto_ennrealD)
        (auto simp: u_nonneg u_le_1 intro!: suminf_nonneg summable_power_series eventually_at_left_1)
   then have "((\<lambda>z. z * (\<Sum>n. u x y n * z ^ n)) \<longlongrightarrow> 1 * U x y) (at_left 1)"
     by (intro tendsto_intros) simp
   then have "((\<lambda>z. \<Sum>n. u x y n * z ^ Suc n) \<longlongrightarrow> 1 * U x y) (at_left 1)"
     apply (rule filterlim_cong[OF refl refl, THEN iffD1, rotated])
     apply (rule eventually_at_left_1)
     apply (subst suminf_mult[symmetric])
     apply (auto intro!: summable_power_series u_le_1 u_nonneg)
     apply (simp add: field_simps)
     done
   then show ?thesis
     by (simp add: gf_U_def[abs_def] U_def)
 qed
 
 lemma gf_U_le_1: assumes z: "0 < z" "z < 1" shows "gf_U x y z \<le> (1::real)"
 proof -
   note u = u_sums_U[of x y, THEN sums_summable]
   have "gf_U x y z \<le> gf_U x y 1"
     using z
     unfolding gf_U_def real_scaleR_def
     by (intro suminf_le allI mult_mono power_mono summable_comparison_test_ev[OF _ u] always_eventually)
        (auto simp: u_nonneg intro!: mult_left_le mult_le_one power_le_one)
   also have "\<dots> \<le> 1"
     unfolding gf_U_eq_U by (rule U_le_1)
   finally show ?thesis .
 qed
 
 lemma gf_F: "(gf_F x y \<longlongrightarrow> F x y) (at_left 1)"
 proof -
   have "((\<lambda>z. ennreal (\<Sum>n. f x y n * z ^ n)) \<longlongrightarrow> (\<Sum>n. ennreal (f x y n))) (at_left 1)"
     using f_le_1 f_nonneg by (intro power_series_tendsto_at_left summable_power_series)
   also have "(\<Sum>n. ennreal (f x y n)) = ennreal (suminf (f x y))"
     by (intro f_nonneg suminf_ennreal ennreal_suminf_neq_top sums_summable[OF f_sums_F])
   also have "suminf (f x y) = F x y"
     using f_sums_F by (rule sums_unique[symmetric])
   finally have "((\<lambda>z. \<Sum>n. f x y n * z ^ n) \<longlongrightarrow> F x y) (at_left 1)"
     by (rule tendsto_ennrealD)
        (auto simp: f_nonneg f_le_1 intro!: suminf_nonneg summable_power_series eventually_at_left_1)
   then show ?thesis
     by (simp add: gf_F_def[abs_def] F_def)
 qed
 
 lemma U_bounded: "0 \<le> U x y" "U x y \<le> 1"
   unfolding U_def by simp_all
 
 subsection \<open>Recurrent states\<close>
 
 definition recurrent :: "'s \<Rightarrow> bool" where
   "recurrent s \<longleftrightarrow> (AE \<omega> in T s. ev (HLD {s}) \<omega>)"
 
 lemma recurrent_iff_U_eq_1: "recurrent s \<longleftrightarrow> U s s = 1"
     unfolding recurrent_def U_def by (subst T.prob_Collect_eq_1) simp_all
 
 definition "H s t = \<P>(\<omega> in T s. alw (ev (HLD {t})) \<omega>)"
 
 lemma H_eq:
   "recurrent s \<longleftrightarrow> H s s = 1"
   "\<not> recurrent s \<longleftrightarrow> H s s = 0"
   "H s t = U s t * H t t"
 proof -
   define H' where "H' t n = {\<omega>\<in>space S. enat n \<le> scount (HLD {t::'s}) \<omega>}" for t n
   have [measurable]: "\<And>y n. H' y n \<in> sets S"
     by (simp add: H'_def)
   let ?H' = "\<lambda>s t n. measure (T s) (H' t n)"
   { fix x y :: 's and \<omega>
     have "Suc 0 \<le> scount (HLD {y}) \<omega> \<longleftrightarrow> ev (HLD {y}) \<omega>"
       using scount_eq_0_iff[of "HLD {y}" \<omega>]
       by (cases "scount (HLD {y}) \<omega>" rule: enat_coexhaust)
          (auto simp: not_ev_iff[symmetric] eSuc_enat[symmetric] enat_0 HLD_iff[abs_def]) }
   then have H'_1: "\<And>x y. ?H' x y 1 = U x y"
     unfolding H'_def U_def by simp
 
   { fix n and x y :: 's
     let ?U = "(not (HLD {y}) suntil (HLD {y} aand nxt (\<lambda>\<omega>. enat n \<le> scount (HLD {y}) \<omega>)))"
     { fix \<omega>
       have "enat (Suc n) \<le> scount (HLD {y}) \<omega> \<longleftrightarrow> ?U \<omega>"
       proof
         assume "enat (Suc n) \<le> scount (HLD {y}) \<omega>"
         with scount_eq_0_iff[of "HLD {y}" \<omega>] have "ev (HLD {y}) \<omega>" "enat (Suc n) \<le> scount (HLD {y}) \<omega>"
           by (auto simp add: not_ev_iff[symmetric] eSuc_enat[symmetric])
         then show "?U \<omega>"
           by (induction rule: ev_induct_strong)
              (auto simp: scount_simps eSuc_enat[symmetric] intro: suntil.intros)
       next
         assume "?U \<omega>" then show "enat (Suc n) \<le> scount (HLD {y}) \<omega>"
           by induction (auto simp: scount_simps  eSuc_enat[symmetric])
       qed }
     then have "emeasure (T x) (H' y (Suc n)) = emeasure (T x) {\<omega>\<in>space (T x). ?U \<omega>}"
       by (simp add: H'_def)
     also have "\<dots> = U x y * ?H' y y n"
       by (subst emeasure_suntil_HLD) (simp_all add: T.emeasure_eq_measure U_def H'_def ennreal_mult)
     finally have "?H' x y (Suc n) = U x y * ?H' y y n"
       by (simp add: T.emeasure_eq_measure) }
   note H'_Suc = this
 
   { fix m and x :: 's
     have "?H' x x (Suc m) = U x x^Suc m"
       using H'_1 H'_Suc by (induct m) auto }
   note H'_eq = this
 
   { fix x y
     have "?H' x y \<longlonglongrightarrow> measure (T x) (\<Inter>i. H' y i)"
       apply (rule T.finite_Lim_measure_decseq)
       apply safe
       apply simp
       apply (auto simp add: decseq_Suc_iff subset_eq H'_def eSuc_enat[symmetric]
                   intro: ile_eSuc order_trans)
       done
     also have "(\<Inter>i. H' y i) = {\<omega>\<in>space (T x). alw (ev (HLD {y})) \<omega>}"
       by (auto simp: H'_def scount_infinite_iff[symmetric]) (metis Suc_ile_eq enat.exhaust neq_iff)
     finally have "?H' x y \<longlonglongrightarrow> H x y"
       unfolding H_def . }
   note H'_lim = this
 
   from H'_lim[of s s, THEN LIMSEQ_Suc]
   have "(\<lambda>n. U s s ^ Suc n) \<longlonglongrightarrow> H s s"
     by (simp add: H'_eq)
   then have lim_H: "(\<lambda>n. U s s ^ n) \<longlonglongrightarrow> H s s"
     by (rule LIMSEQ_imp_Suc)
 
   have "U s s < 1 \<Longrightarrow> (\<lambda>n. U s s ^ n) \<longlonglongrightarrow> 0"
     by (rule LIMSEQ_realpow_zero) (simp_all add: U_def)
   with lim_H have "U s s < 1 \<Longrightarrow> H s s = 0"
     by (blast intro: LIMSEQ_unique)
   moreover have "U s s = 1 \<Longrightarrow> (\<lambda>n. U s s ^ n) \<longlonglongrightarrow> 1"
     by simp
   with lim_H have "U s s = 1 \<Longrightarrow> H s s = 1"
     by (blast intro: LIMSEQ_unique)
   moreover note recurrent_iff_U_eq_1 U_cases
   ultimately show "recurrent s \<longleftrightarrow> H s s = 1" "\<not> recurrent s \<longleftrightarrow> H s s = 0"
     by (metis one_neq_zero)+
 
   from H'_lim[of s t, THEN LIMSEQ_Suc] H'_Suc[of s]
   have "(\<lambda>n. U s t * ?H' t t n) \<longlonglongrightarrow> H s t"
     by simp
   moreover have "(\<lambda>n. U s t * ?H' t t n) \<longlonglongrightarrow> U s t * H t t"
     by (intro tendsto_intros H'_lim)
   ultimately show "H s t = U s t * H t t"
     by (blast intro: LIMSEQ_unique)
 qed
 
 lemma recurrent_iff_G_infinite: "recurrent x \<longleftrightarrow> G x x = \<infinity>"
 proof -
   have "((\<lambda>z. ennreal (gf_G x x z)) \<longlongrightarrow> G x x) (at_left 1)"
     by (rule lim_gf_G)
   then have G: "((\<lambda>z. ennreal (1 / (1 - gf_U x x z))) \<longlongrightarrow> G x x) (at_left (1::real))"
     apply (rule filterlim_cong[OF refl refl, THEN iffD1, rotated])
     apply (rule eventually_at_left_1)
     apply (subst gf_G_eq_gf_U)
     apply (rule convergence_G_less_1)
     apply simp
     apply simp
     done
 
   { fix z :: real assume z: "0 < z" "z < 1"
     have 1: "summable (u x x)"
       using u_sums_U by (rule sums_summable)
     have "gf_U x x z \<noteq> 1"
       using gf_G_eq_gf_U[OF convergence_G_less_1[of z]] z by simp
     moreover
     have "gf_U x x z \<le> U x x"
       unfolding gf_U_def gf_U_eq_U[symmetric]
       using z
       by (intro suminf_le)
          (auto simp add: 1 convergence_U convergence_G_less_1 u_nonneg simp del: power_Suc
                intro!: mult_right_le_one_le power_le_one)
     ultimately have "gf_U x x z < 1"
       using U_bounded[of x x] by simp }
   note strict = this
 
   { assume "U x x = 1"
     moreover have "((\<lambda>xa. 1 - gf_U x x xa :: real) \<longlongrightarrow> 1 - U x x) (at_left 1)"
       by (intro tendsto_intros gf_U)
     moreover have "eventually (\<lambda>z. gf_U x x z < 1) (at_left (1::real))"
       by (auto intro!: eventually_at_left_1 strict simp: \<open>U x x = 1\<close> gf_U_eq_U)
     ultimately have "((\<lambda>z. ennreal (1 / (1 - gf_U x x z))) \<longlongrightarrow> top) (at_left 1)"
       unfolding ennreal_tendsto_top_eq_at_top
       by (intro LIM_at_top_divide[where a=1] tendsto_const zero_less_one)
          (auto simp: field_simps)
     with G have "G x x = top"
       by (rule tendsto_unique[rotated]) simp }
   moreover
   { assume "U x x < 1"
     then have "((\<lambda>xa. ennreal (1 / (1 - gf_U x x xa))) \<longlongrightarrow> 1 / (1 - U x x)) (at_left 1)"
       by (intro tendsto_intros gf_U tendsto_ennrealI) simp
     from tendsto_unique[OF _ G this] have "G x x \<noteq> \<infinity>"
       by simp }
   ultimately show ?thesis
     using U_cases recurrent_iff_U_eq_1 by auto
 qed
 
 definition communicating :: "('s \<times> 's) set" where
   "communicating = acc \<inter> acc\<inverse>"
 
 definition essential_class :: "'s set \<Rightarrow> bool" where
   "essential_class C \<longleftrightarrow> C \<in> UNIV // communicating \<and> acc `` C \<subseteq> C"
 
 lemma accI_U:
   assumes "0 < U x y" shows "(x, y) \<in> acc"
 proof (rule ccontr)
   assume *: "(x, y) \<notin> acc"
 
   { fix \<omega> assume "ev (HLD {y}) \<omega>" "alw (HLD (acc `` {x})) \<omega>" from this * have False
       by induction (auto simp: HLD_iff) }
   with AE_T_reachable[of x] have "U x y = 0"
     unfolding U_def by (intro T.prob_eq_0_AE) auto
   with \<open>0 < U x y\<close> show False by auto
 qed
 
 lemma accD_pos:
   assumes "(x, y) \<in> acc"
   shows "\<exists>n. 0 < p x y n"
 using assms proof induction
   case base with T.prob_space[of x] show ?case
     by (auto intro!: exI[of _ 0])
 next
   have [simp]: "\<And>x y. (if x = y then 1 else 0::real) = indicator {y} x"
     by simp
   case (step w y)
   then obtain n where "0 < p x w n" and "0 < pmf (K w) y"
     by (auto simp: set_pmf_iff less_le)
   then have "0 < p x w n * pmf (K w) y"
     by (intro mult_pos_pos)
   also have "\<dots> \<le> p x w n * p w y (Suc 0)"
     by (simp add: p_Suc' p_0 pmf.rep_eq)
   also have "\<dots> \<le> p x y (Suc n)"
     using prob_reachable_le[of n "Suc n" x w y] by simp
   finally show ?case ..
 qed
 
 lemma accI_pos: "0 < p x y n \<Longrightarrow> (x, y) \<in> acc"
 proof (induct n arbitrary: x)
   case (Suc n)
   then have less: "0 < (\<integral>x'. p x' y n \<partial>K x)"
     by (simp add: p_Suc')
   have "\<exists>x'\<in>K x. 0 < p x' y n"
   proof (rule ccontr)
     assume "\<not> ?thesis"
     then have "AE x' in K x. p x' y n = 0"
       by (simp add: AE_measure_pmf_iff less_le)
     then have "(\<integral>x'. p x' y n \<partial>K x) = (\<integral>x'. 0 \<partial>K x)"
       by (intro integral_cong_AE) simp_all
     with less show False by simp
   qed
   with Suc show ?case
     by (auto intro: converse_rtrancl_into_rtrancl)
 qed (simp add: p_0 split: if_split_asm)
 
 lemma recurrent_iffI_communicating:
   assumes "(x, y) \<in> communicating"
   shows "recurrent x \<longleftrightarrow> recurrent y"
 proof -
   from assms obtain n m where "0 < p x y n" "0 < p y x m"
     by (force simp: communicating_def dest: accD_pos)
   moreover
   { fix x y n m assume "0 < p x y n" "0 < p y x m" "G y y = \<infinity>"
     then have "\<infinity> = ennreal (p x y n * p y x m) * G y y"
       by (auto intro: mult_pos_pos simp: ennreal_mult_top)
     also have "ennreal (p x y n * p y x m) * G y y = (\<Sum>i. ennreal (p x y n * p y x m) * p y y i)"
       unfolding G_eq_suminf by (rule ennreal_suminf_cmult[symmetric])
     also have "\<dots> \<le> (\<Sum>i. ennreal (p x x (n + i + m)))"
     proof (intro suminf_le allI)
       fix i
       have "(p x y n * p y y ((n + i) - n)) * p y x ((n + i + m) - (n + i)) \<le> p x y (n + i) * p y x ((n + i + m) - (n + i))"
         by (intro mult_right_mono prob_reachable_le) simp_all
       also have "\<dots> \<le> p x x (n + i + m)"
          by (intro prob_reachable_le) simp_all
       finally show "ennreal (p x y n * p y x m) * p y y i \<le> ennreal (p x x (n + i + m))"
         by (simp add: ac_simps ennreal_mult'[symmetric])
     qed auto
     also have "\<dots> \<le> (\<Sum>i. ennreal (p x x (i + (n + m))))"
       by (simp add: ac_simps)
     also have "\<dots> \<le> (\<Sum>i. ennreal (p x x i))"
       by (subst suminf_offset[of "\<lambda>i. ennreal (p x x i)" "n + m"]) auto
     also have "\<dots> \<le> G x x"
       unfolding G_eq_suminf by (auto intro!: suminf_le_pos)
     finally have "G x x = \<infinity>"
       by (simp add: top_unique) }
   ultimately show ?thesis
     using recurrent_iff_G_infinite by blast
 qed
 
 lemma recurrent_acc:
   assumes "recurrent x" "(x, y) \<in> acc"
   shows "U y x = 1" "H y x = 1" "recurrent y" "(x, y) \<in> communicating"
 proof -
   { fix w y assume step: "(x, w) \<in> acc" "y \<in> K w" "U w x = 1" "H w x = 1" "recurrent w" "x \<noteq> y"
     have "measure (K w) UNIV = U w x"
       using step measure_pmf.prob_space[of "K w"] by simp
     also have "\<dots> = (\<integral>v. indicator {x} v + U v x * indicator (- {x}) v \<partial>K w)"
       unfolding U_def
       by (subst prob_T)
          (auto intro!: Bochner_Integration.integral_cong arg_cong2[where f=measure] AE_I2
                simp: ev_Stream T.prob_eq_1 split: split_indicator)
     also have "\<dots> = measure (K w) {x} + (\<integral>v. U v x * indicator (- {x}) v \<partial>K w)"
       by (subst Bochner_Integration.integral_add)
          (auto intro!: measure_pmf.integrable_const_bound[where B=1]
                simp: abs_mult mult_le_one U_bounded(2) measure_pmf.emeasure_eq_measure)
     finally have "measure (K w) UNIV - measure (K w) {x} = (\<integral>v. U v x * indicator (- {x}) v \<partial>K w)"
       by simp
     also have "measure (K w) UNIV - measure (K w) {x} = measure (K w) (UNIV - {x})"
       by (subst measure_pmf.finite_measure_Diff) auto
     finally have "0 = (\<integral>v. indicator (- {x}) v \<partial>K w) - (\<integral>v. U v x * indicator (- {x}) v \<partial>K w)"
       by (simp add: measure_pmf.emeasure_eq_measure Compl_eq_Diff_UNIV)
     also have "\<dots> = (\<integral>v. (1 - U v x) * indicator (- {x}) v \<partial>K w)"
       by (subst Bochner_Integration.integral_diff[symmetric])
          (auto intro!: measure_pmf.integrable_const_bound[where B=1] Bochner_Integration.integral_cong
                simp: abs_mult mult_le_one U_bounded(2) split: split_indicator)
     also have "\<dots> \<ge> (\<integral>v. (1 - U y x) * indicator {y} v \<partial>K w)" (is "_ \<ge> ?rhs")
       using \<open>recurrent x\<close>
       by (intro integral_mono measure_pmf.integrable_const_bound[where B=1])
          (auto simp: abs_mult mult_le_one U_bounded(2) recurrent_iff_U_eq_1 field_simps
                split: split_indicator)
     also (xtrans) have "?rhs = (1 - U y x) * pmf (K w) y"
       by (simp add: measure_pmf.emeasure_eq_measure pmf.rep_eq)
     finally have "(1 - U y x) * pmf (K w) y = 0"
       by (auto intro!: antisym simp: U_bounded(2) mult_le_0_iff)
     with \<open>y \<in> K w\<close> have "U y x = 1"
       by (simp add: set_pmf_iff)
     then have "U y x = 1" "H y x = 1"
       using H_eq(3)[of y x] H_eq(1)[of x] by (simp_all add: \<open>recurrent x\<close>)
     then have "(y, x) \<in> acc"
       by (intro accI_U) auto
     with step have "(x, y) \<in> communicating"
       by (auto simp add: communicating_def intro: rtrancl_trans)
     with \<open>recurrent x\<close> have "recurrent y"
       by (simp add: recurrent_iffI_communicating)
     note this \<open>U y x = 1\<close> \<open>H y x = 1\<close> \<open>(x, y) \<in> communicating\<close> }
   note enabled = this
 
   from \<open>(x, y) \<in> acc\<close>
   show "U y x = 1" "H y x = 1" "recurrent y" "(x, y) \<in> communicating"
   proof induction
     case base then show "U x x = 1" "H x x = 1" "recurrent x" "(x, x) \<in> communicating"
       using \<open>recurrent x\<close> H_eq(1)[of x] by (auto simp: recurrent_iff_U_eq_1 communicating_def)
   next
     case (step w y)
     with enabled[of w y] \<open>recurrent x\<close> H_eq(1)[of x]
     have "U y x = 1 \<and> H y x = 1 \<and> recurrent y \<and> (x, y) \<in> communicating"
       by (cases "x = y") (auto simp: recurrent_iff_U_eq_1 communicating_def)
     then show "U y x = 1" "H y x = 1" "recurrent y" "(x, y) \<in> communicating"
       by auto
   qed
 qed
 
 lemma equiv_communicating: "equiv UNIV communicating"
   by (auto simp: equiv_def sym_def communicating_def refl_on_def trans_def)
 
 lemma recurrent_class:
   assumes "recurrent x"
   shows "acc `` {x} = communicating `` {x}"
   using recurrent_acc(4)[OF \<open>recurrent x\<close>] by (auto simp: communicating_def)
 
 lemma irreduccible_recurrent_class:
   assumes "recurrent x" shows "acc `` {x} \<in> UNIV // communicating"
   unfolding recurrent_class[OF \<open>recurrent x\<close>] by (rule quotientI) simp
 
 lemma essential_classI:
   assumes C: "C \<in> UNIV // communicating"
   assumes eq: "\<And>x y. x \<in> C \<Longrightarrow> (x, y) \<in> acc \<Longrightarrow> y \<in> C"
   shows "essential_class C"
   by (auto simp: essential_class_def intro: C) (metis eq)
 
 lemma essential_recurrent_class:
   assumes "recurrent x" shows "essential_class (communicating `` {x})"
   unfolding recurrent_class[OF \<open>recurrent x\<close>, symmetric]
   apply (rule essential_classI)
   apply (rule irreduccible_recurrent_class[OF assms])
   apply (auto simp: communicating_def)
   done
 
 lemma essential_classD2:
   "essential_class C \<Longrightarrow> x \<in> C \<Longrightarrow> (x, y) \<in> acc \<Longrightarrow> y \<in> C"
   unfolding essential_class_def by auto
 
 lemma essential_classD3:
   "essential_class C \<Longrightarrow> x \<in> C \<Longrightarrow> y \<in> C \<Longrightarrow> (x, y) \<in> communicating"
   unfolding essential_class_def
   by (auto elim!: quotientE simp: communicating_def)
 
 lemma AE_acc:
   shows "AE \<omega> in T x. \<forall>m. (x, (x ## \<omega>) !! m) \<in> acc"
   using AE_T_reachable
   by eventually_elim (auto simp: alw_HLD_iff_streams streams_iff_snth Stream_snth split: nat.splits)
 
 lemma finite_essential_class_imp_recurrent:
   assumes C: "essential_class C" "finite C" and x: "x \<in> C"
   shows "recurrent x"
 proof -
   have "AE \<omega> in T x. \<exists>y\<in>C. alw (ev (HLD {y})) \<omega>"
     using AE_T_reachable
   proof eventually_elim
     fix \<omega> assume "alw (HLD (acc `` {x})) \<omega>"
     then have "alw (HLD C) \<omega>"
       by (rule alw_mono) (auto simp: HLD_iff intro: assms essential_classD2)
     then show "\<exists>y\<in>C. alw (ev (HLD {y})) \<omega>"
       by (rule pigeonhole_stream) fact
   qed
   then have "1 = \<P>(\<omega> in T x. \<exists>y\<in>C. alw (ev (HLD {y})) \<omega>)"
     by (subst (asm) T.prob_Collect_eq_1[symmetric]) (auto simp: \<open>finite C\<close>)
   also have "\<dots> = measure (T x) (\<Union>y\<in>C. {\<omega>\<in>space (T x). alw (ev (HLD {y})) \<omega>})"
     by (intro arg_cong2[where f=measure]) auto
   also have "\<dots> \<le> (\<Sum>y\<in>C. H x y)"
     unfolding H_def using \<open>finite C\<close> by (rule T.finite_measure_subadditive_finite) auto
   also have "\<dots> = (\<Sum>y\<in>C. U x y * H y y)"
     by (auto intro!: sum.cong H_eq)
   finally have "\<exists>y\<in>C. recurrent y"
     by (rule_tac ccontr) (simp add: H_eq(2))
-  then guess y ..
+  then obtain y where "y \<in> C" "recurrent y" ..
   from essential_classD3[OF C(1) x this(1)] recurrent_acc(3)[OF this(2)]
   show "recurrent x"
     by (simp add: communicating_def)
 qed
 
 lemma irreducibleD:
   "C \<in> UNIV // communicating \<Longrightarrow> a \<in> C \<Longrightarrow> b \<in> C \<Longrightarrow> (a, b) \<in> communicating"
   by (auto elim!: quotientE simp: communicating_def)
 
 lemma irreducibleD2:
   "C \<in> UNIV // communicating \<Longrightarrow> a \<in> C \<Longrightarrow> (a, b) \<in> communicating \<Longrightarrow> b \<in> C"
   by (auto elim!: quotientE simp: communicating_def)
 
 lemma essential_class_iff_recurrent:
   "finite C \<Longrightarrow> C \<in> UNIV // communicating \<Longrightarrow> essential_class C \<longleftrightarrow> (\<forall>x\<in>C. recurrent x)"
   by (metis finite_essential_class_imp_recurrent irreducibleD2 recurrent_acc(4) essential_classI)
 
 definition "U' x y = (\<integral>\<^sup>+\<omega>. eSuc (sfirst (HLD {y}) \<omega>) \<partial>T x)"
 
 lemma U'_neq_zero[simp]: "U' x y \<noteq> 0"
   unfolding U'_def by (simp add: nn_integral_add)
 
 definition "gf_U' x y z = (\<Sum>n. u x y n * Suc n * z ^ n)"
 
 definition "pos_recurrent x \<longleftrightarrow> recurrent x \<and> U' x x \<noteq> \<infinity>"
 
 lemma summable_gf_U':
   assumes z: "norm z < 1"
   shows "summable (\<lambda>n. u x y n * Suc n * z ^ n)"
 proof -
   have "summable (\<lambda>n. n * \<bar>z\<bar> ^ n)"
   proof (rule root_test_convergence)
     have "(\<lambda>n. root n n * \<bar>z\<bar>) \<longlonglongrightarrow> 1 * \<bar>z\<bar>"
       by (intro tendsto_intros LIMSEQ_root)
     then show "(\<lambda>n. root n (norm (n * \<bar>z\<bar> ^ n))) \<longlonglongrightarrow> \<bar>z\<bar>"
       by (rule filterlim_cong[THEN iffD1, rotated 3])
          (auto intro!: exI[of _ 1]
                simp add: abs_mult u_nonneg real_root_mult power_abs eventually_sequentially real_root_power)
   qed (insert z, simp add: abs_less_iff)
   note summable_mult[OF this, of "1 / \<bar>z\<bar>"]
   from summable_ignore_initial_segment[OF this, of 1]
   show "summable (\<lambda>n. u x y n * Suc n * z ^ n)"
     apply (rule summable_comparison_test[rotated])
     using z
     apply (auto intro!: exI[of _ 1]
                 simp: abs_mult u_nonneg power_abs Suc_le_eq gr0_conv_Suc field_simps le_divide_eq u_le_1
                 simp del: of_nat_Suc)
     done
 qed
 
 lemma gf_U'_nonneg[simp]: "0 < z \<Longrightarrow> z < 1 \<Longrightarrow> 0 \<le> gf_U' x y z"
   unfolding gf_U'_def
   by (intro suminf_nonneg summable_gf_U') (auto simp: u_nonneg)
 
 lemma DERIV_gf_U:
   fixes z :: real assumes z: "0 < z" "z < 1"
   shows "DERIV (gf_U x y) z :> gf_U' x y z"
   unfolding gf_U_def[abs_def]  gf_U'_def real_scaleR_def u_def[symmetric]
   using z by (intro DERIV_power_series'[where R=1] summable_gf_U') auto
 
 lemma sfirst_finiteI_recurrent:
   "recurrent x \<Longrightarrow> (x, y) \<in> acc \<Longrightarrow> AE \<omega> in T x. sfirst (HLD {y}) \<omega> < \<infinity>"
   using recurrent_acc(1)[of y x] recurrent_acc[of x y]
     T.AE_prob_1[of x "{\<omega>\<in>space (T x). ev (HLD {y}) \<omega>}"]
   unfolding sfirst_finite U_def by (simp add: space_stream_space communicating_def)
 
 lemma U'_eq_suminf:
   assumes x: "recurrent x" "(x, y) \<in> acc"
   shows "U' x y = (\<Sum>i. ennreal (u x y i * Suc i))"
 proof -
   have "(\<integral>\<^sup>+\<omega>. eSuc (sfirst (HLD {y}) \<omega>) \<partial>T x) =
       (\<integral>\<^sup>+\<omega>. (\<Sum>i. ennreal (Suc i) * indicator {\<omega>\<in>space (T y). ev_at (HLD {y}) i \<omega>} \<omega>) \<partial>T x)"
     using sfirst_finiteI_recurrent[OF x]
   proof (intro nn_integral_cong_AE, eventually_elim)
     fix \<omega> assume "sfirst (HLD {y}) \<omega> < \<infinity>"
     then obtain n :: nat where [simp]: "sfirst (HLD {y}) \<omega> = n"
       by auto
     show "eSuc (sfirst (HLD {y}) \<omega>) = (\<Sum>i. ennreal (Suc i) * indicator {\<omega>\<in>space (T y). ev_at (HLD {y}) i \<omega>} \<omega>)"
       by (subst suminf_cmult_indicator[where i=n])
          (auto simp: disjoint_family_on_def ev_at_unique space_stream_space
                      sfirst_eq_enat_iff[symmetric] ennreal_of_nat_eq_real_of_nat
                split: split_indicator)
   qed
   also have "\<dots> = (\<Sum>i. ennreal (Suc i) * emeasure (T x) {\<omega>\<in>space (T x). ev_at (HLD {y}) i \<omega>})"
     by (subst nn_integral_suminf)
        (auto intro!: arg_cong[where f=suminf] nn_integral_cmult_indicator simp: fun_eq_iff)
   finally show ?thesis
     by (simp add: U'_def u_def T.emeasure_eq_measure mult_ac ennreal_mult)
 qed
 
 lemma gf_U'_tendsto_U':
   assumes x: "recurrent x" "(x, y) \<in> acc"
   shows "((\<lambda>z. ennreal (gf_U' x y z)) \<longlongrightarrow> U' x y) (at_left 1)"
   unfolding U'_eq_suminf[OF x] gf_U'_def
   by (auto intro!: power_series_tendsto_at_left summable_gf_U' mult_nonneg_nonneg u_nonneg simp del: of_nat_Suc)
 
 lemma one_le_integral_t:
   assumes x: "recurrent x" shows "1 \<le> U' x x"
   by (simp add: nn_integral_add T.emeasure_space_1 U'_def del: space_T)
 
 lemma gf_U'_pos:
   fixes z :: real
   assumes z: "0 < z" "z < 1" and "U x y \<noteq> 0"
   shows "0 < gf_U' x y z"
   unfolding gf_U'_def
 proof (subst suminf_pos_iff)
   show "summable (\<lambda>n. u x y n * real (Suc n) * z ^ n)"
     using z by (intro summable_gf_U') simp
   show pos: "\<And>n. 0 \<le> u x y n * real (Suc n) * z ^ n"
     using u_nonneg z by auto
   show "\<exists>n. 0 < u x y n * real (Suc n) * z ^ n"
   proof (rule ccontr)
     assume "\<not> (\<exists>n. 0 < u x y n * real (Suc n) * z ^ n)"
     with pos have "\<forall>n. u x y n * real (Suc n) * z ^ n = 0"
       by (intro antisym allI) (simp_all add: not_less)
     with z have "u x y = (\<lambda>n. 0)"
       by (intro ext) simp
     with u_sums_U[of x y, THEN sums_unique] \<open>U x y \<noteq> 0\<close> show False
       by simp
   qed
 qed
 
 lemma inverse_gf_U'_tendsto:
   assumes "recurrent y"
   shows "((\<lambda>x. - 1 / - gf_U' y y x) \<longlongrightarrow> enn2real (1 / U' y y)) (at_left (1::real))"
 proof cases
   assume inf: "U' y y = \<infinity>"
   with gf_U'_tendsto_U'[of y y] \<open>recurrent y\<close>
   have "LIM z (at_left 1). gf_U' y y z :> at_top"
     by (auto simp: ennreal_tendsto_top_eq_at_top U'_def)
   then have "LIM z (at_left 1). gf_U' y y z :> at_infinity"
     by (rule filterlim_mono) (auto simp: at_top_le_at_infinity)
   with inf show ?thesis
     by (auto intro!: tendsto_divide_0)
 next
   assume fin: "U' y y \<noteq> \<infinity>"
   then obtain r where r: "U' y y = ennreal r" and [simp]: "0 \<le> r"
     by (cases "U' y y") (auto simp: U'_def)
   then have eq: "enn2real (1 / U' y y) = - 1 / - r" and "1 \<le> r"
     using one_le_integral_t[OF \<open>recurrent y\<close>]
     by (auto simp add: ennreal_1[symmetric] divide_ennreal simp del: ennreal_1)
   have "((\<lambda>z. ennreal (gf_U' y y z)) \<longlongrightarrow> ennreal r) (at_left 1)"
     using gf_U'_tendsto_U'[OF \<open>recurrent y\<close>, of y] r by simp
   then have gf_U': "(gf_U' y y \<longlongrightarrow> r) (at_left (1::real))"
     by (rule tendsto_ennrealD)
        (insert summable_gf_U', auto intro!: eventually_at_left_1 suminf_nonneg simp: gf_U'_def u_nonneg)
   show ?thesis
     using \<open>1 \<le> r\<close> unfolding eq by (intro tendsto_intros gf_U') simp
 qed
 
 lemma gf_G_pos:
   fixes z :: real
   assumes z: "0 < z" "z < 1" and *: "(x, y) \<in> acc"
   shows "0 < gf_G x y z"
   unfolding gf_G_def
 proof (subst suminf_pos_iff)
   show "summable (\<lambda>n. p x y n *\<^sub>R z ^ n)"
     using z by (intro convergence_G convergence_G_less_1) simp
   show pos: "\<And>n. 0 \<le> p x y n *\<^sub>R z ^ n"
     using z by (auto intro!: mult_nonneg_nonneg p_nonneg)
   show "\<exists>n. 0 < p x y n *\<^sub>R z ^ n"
   proof (rule ccontr)
     assume "\<not> (\<exists>n. 0 < p x y n *\<^sub>R z ^ n)"
     with pos have "\<forall>n. p x y n * z ^ n = 0"
       by (intro antisym allI) (simp_all add: not_less)
     with z have "\<And>n. p x y n = 0"
       by simp
     with *[THEN accD_pos] show False
       by simp
   qed
 qed
 
 lemma pos_recurrentI_communicating:
   assumes y: "pos_recurrent y" and x: "(y, x) \<in> communicating"
   shows "pos_recurrent x"
 proof -
   from y x have recurrent: "recurrent y" "recurrent x" and fin: "U' y y \<noteq> \<infinity>"
     by (auto simp: pos_recurrent_def recurrent_iffI_communicating nn_integral_add)
   have pos: "0 < enn2real (1 / U' y y)"
     using one_le_integral_t[OF \<open>recurrent y\<close>] fin
     by (auto simp: U'_def enn2real_positive_iff less_top[symmetric] ennreal_zero_less_divide ennreal_divide_eq_top_iff)
 
   from fin obtain r where r: "U' y y = ennreal r" and [simp]: "0 \<le> r"
     by (cases "U' y y") (auto simp: U'_def)
 
   from x obtain n m where "0 < p x y n" "0 < p y x m"
     by (auto dest!: accD_pos simp: communicating_def)
 
   let ?L = "at_left (1::real)"
   have le: "eventually (\<lambda>z. p x y n * p y x m * z^(n + m) \<le> (1 - gf_U y y z) / (1 - gf_U x x z)) ?L"
   proof (rule eventually_at_left_1)
     fix z :: real assume z: "0 < z" "z < 1"
     then have conv: "\<And>x. convergence_G x x z"
       by (intro convergence_G_less_1) simp
     have sums: "(\<lambda>i. (p x y n * p y x m * z^(n + m)) * (p y y i * z^i)) sums ((p x y n * p y x m * z^(n + m)) * gf_G y y z)"
       unfolding gf_G_def
       by (intro sums_mult summable_sums) (auto intro!: conv convergence_G[where 'a=real, simplified])
     have "(\<Sum>i. (p x y n * p y x m * z^(n + m)) * (p y y i * z^i)) \<le> (\<Sum>i. p x x (i + (n + m)) * z^(i + (n + m)))"
     proof (intro allI suminf_le sums_summable[OF sums] summable_ignore_initial_segment convergence_G[where 'a=real, simplified] convergence_G_less_1)
       show "norm z < 1" using z by simp
       fix i
       have "(p x y n * p y y ((n + i) - n)) * p y x ((n + i + m) - (n + i)) \<le> p x y (n + i) * p y x ((n + i + m) - (n + i))"
         by (intro mult_right_mono prob_reachable_le) simp_all
       also have "\<dots> \<le> p x x (n + i + m)"
          by (intro prob_reachable_le) simp_all
       finally show "p x y n * p y x m * z ^ (n + m) * (p y y i * z ^ i) \<le> p x x (i + (n + m)) * z ^ (i + (n + m))"
         using z by (auto simp add: ac_simps power_add intro!: mult_left_mono)
     qed
     also have "\<dots> \<le> gf_G x x z"
       unfolding gf_G_def
       using z
       apply (subst (2) suminf_split_initial_segment[where k="n + m"])
       apply (intro convergence_G conv)
       apply (simp add: sum_nonneg)
       done
     finally have "(p x y n * p y x m * z^(n + m)) * gf_G y y z \<le> gf_G x x z"
       using sums_unique[OF sums] by simp
     then have "(p x y n * p y x m * z^(n + m)) \<le> gf_G x x z / gf_G y y z"
       using z gf_G_pos[of z y y] by (simp add: field_simps)
     also have "\<dots> = (1 - gf_U y y z) / (1 - gf_U x x z)"
       unfolding gf_G_eq_gf_U[OF conv] using gf_G_eq_gf_U(2)[OF conv] by (simp add: field_simps )
     finally show "p x y n * p y x m * z^(n + m) \<le> (1 - gf_U y y z) / (1 - gf_U x x z)" .
   qed
 
   have "U' x x \<noteq> \<infinity>"
   proof
     assume "U' x x = \<infinity>"
     have "((\<lambda>z. (1 - gf_U y y z) / (1 - gf_U x x z)) \<longlongrightarrow> 0) ?L"
     proof (rule lhopital_left)
       show "((\<lambda>z. 1 - gf_U y y z) \<longlongrightarrow> 0) ?L"
         using gf_U[of y] recurrent_iff_U_eq_1[of y] \<open>recurrent y\<close> by (auto intro!: tendsto_eq_intros)
       show "((\<lambda>z. 1 - gf_U x x z) \<longlongrightarrow> 0) ?L"
         using gf_U[of x] recurrent_iff_U_eq_1[of x] \<open>recurrent x\<close> by (auto intro!: tendsto_eq_intros)
       show "eventually (\<lambda>z. 1 - gf_U x x z \<noteq> 0) ?L"
         by (auto intro!: eventually_at_left_1 simp: gf_G_eq_gf_U(2) convergence_G_less_1)
       show "eventually (\<lambda>z. - gf_U' x x z \<noteq> 0) ?L"
         using gf_U'_pos[of _ x x] recurrent_iff_U_eq_1[of x] \<open>recurrent x\<close>
         by (auto intro!: eventually_at_left_1) (metis less_le)
       show "eventually (\<lambda>z. DERIV (\<lambda>xa. 1 - gf_U x x xa) z :> - gf_U' x x z) ?L"
         by (auto intro!: eventually_at_left_1 derivative_eq_intros DERIV_gf_U)
       show "eventually (\<lambda>z. DERIV (\<lambda>xa. 1 - gf_U y y xa) z :> - gf_U' y y z) ?L"
         by (auto intro!: eventually_at_left_1 derivative_eq_intros DERIV_gf_U)
 
       have "(gf_U' y y \<longlongrightarrow> U' y y) ?L"
         using \<open>recurrent y\<close> by (rule gf_U'_tendsto_U') simp
       then have *: "(gf_U' y y \<longlongrightarrow> r) ?L"
         by (auto simp add: r eventually_at_left_1 dest!: tendsto_ennrealD)
       moreover
       have "(gf_U' x x \<longlongrightarrow> U' x x) ?L"
         using \<open>recurrent x\<close> by (rule gf_U'_tendsto_U') simp
       then have "LIM z ?L. - gf_U' x x z :> at_bot"
         by (simp add: ennreal_tendsto_top_eq_at_top \<open>U' x x = \<infinity>\<close> filterlim_uminus_at_top
                  del: ennreal_of_enat_eSuc)
       then have "LIM z ?L. - gf_U' x x z :> at_infinity"
         by (rule filterlim_mono) (auto simp: at_bot_le_at_infinity)
       ultimately show "((\<lambda>z. - gf_U' y y z / - gf_U' x x z) \<longlongrightarrow> 0) ?L"
         by (intro tendsto_divide_0[where c="- r"] tendsto_intros)
     qed
     moreover
     have "((\<lambda>z. p x y n * p y x m * z^(n + m)) \<longlongrightarrow> p x y n * p y x m) ?L"
       by (auto intro!: tendsto_eq_intros)
     ultimately have "p x y n * p y x m \<le> 0"
       using le by (rule tendsto_le[OF trivial_limit_at_left_real])
     with \<open>0 < p x y n\<close> \<open>0 < p y x m\<close> show False
       by (auto simp add: mult_le_0_iff)
   qed
   with \<open>recurrent x\<close> show ?thesis
     by (simp add: pos_recurrent_def nn_integral_add)
 qed
 
 lemma pos_recurrent_iffI_communicating:
   "(y, x) \<in> communicating \<Longrightarrow> pos_recurrent y \<longleftrightarrow> pos_recurrent x"
   using pos_recurrentI_communicating[of x y] pos_recurrentI_communicating[of y x]
   by (auto simp add: communicating_def)
 
 lemma U_le_F: "U x y \<le> F x y"
   by (auto simp: U_def F_def intro!: T.finite_measure_mono)
 
 lemma not_empty_irreducible: "C \<in> UNIV // communicating \<Longrightarrow> C \<noteq> {}"
   by (auto simp: quotient_def Image_def communicating_def)
 
 subsection \<open>Stationary distribution\<close>
 
 definition stat :: "'s set \<Rightarrow> 's measure" where
   "stat C = point_measure UNIV (\<lambda>x. indicator C x / U' x x)"
 
 lemma sets_stat[simp]: "sets (stat C) = sets (count_space UNIV)"
   by (simp add: stat_def sets_point_measure)
 
 lemma space_stat[simp]: "space (stat C) = UNIV"
   by (simp add: stat_def space_point_measure)
 
 lemma stat_subprob:
   assumes C: "essential_class C" and "countable C" and pos: "\<forall>c\<in>C. pos_recurrent c"
   shows "emeasure (stat C) C \<le> 1"
 proof -
   let ?L = "at_left (1::real)"
-  from finite_sequence_to_countable_set[OF \<open>countable C\<close>] guess A . note A = this
+  from finite_sequence_to_countable_set[OF \<open>countable C\<close>]
+  obtain A where A: "\<And>i. A i \<subseteq> C" "\<And>i. A i \<subseteq> A (Suc i)" "\<And>i. finite (A i)" "\<Union> (range A) = C"
+    by blast
   then have "(\<lambda>n. emeasure (stat C) (A n)) \<longlonglongrightarrow> emeasure (stat C) (\<Union>i. A i)"
     by (intro Lim_emeasure_incseq) (auto simp: incseq_Suc_iff)
   then have "emeasure (stat C) (\<Union>i. A i) \<le> 1"
   proof (rule LIMSEQ_le[OF _ tendsto_const], intro exI allI impI)
     fix n
     from A(1,3) have A_n: "finite (A n)"
       by auto
 
     from C have "C \<noteq> {}"
       by (simp add: essential_class_def not_empty_irreducible)
     then obtain x where "x \<in> C" by auto
 
     have "((\<lambda>z. (\<Sum>y\<in>A n. gf_F x y z * ((1 - z) / (1 - gf_U y y z)))) \<longlongrightarrow> (\<Sum>y\<in>A n. F x y * enn2real (1 / U' y y))) ?L"
     proof (intro tendsto_intros gf_F, rule lhopital_left)
       fix y assume "y \<in> A n"
       with \<open>A n \<subseteq> C\<close> have "y \<in> C"
         by auto
       show "((-) 1 \<longlongrightarrow> 0) ?L"
         by (intro tendsto_eq_intros) simp_all
       have "recurrent y"
         using pos[THEN bspec, OF \<open>y\<in>C\<close>] by (simp add: pos_recurrent_def)
       then have "U y y = 1"
         by (simp add: recurrent_iff_U_eq_1)
 
       show "((\<lambda>x. 1 - gf_U y y x) \<longlongrightarrow> 0) ?L"
         using gf_U[of y y] \<open>U y y = 1\<close> by (intro tendsto_eq_intros) auto
       show "eventually (\<lambda>x. 1 - gf_U y y x \<noteq> 0) ?L"
         using gf_G_eq_gf_U(2)[OF convergence_G_less_1, where 'z=real] by (auto intro!: eventually_at_left_1)
       have "eventually (\<lambda>x. 0 < gf_U' y y x) ?L"
         by (intro eventually_at_left_1 gf_U'_pos) (simp_all add: \<open>U y y = 1\<close>)
       then show "eventually (\<lambda>x. - gf_U' y y x \<noteq> 0) ?L"
         by eventually_elim simp
       show "eventually (\<lambda>x. DERIV (\<lambda>x. 1 - gf_U y y x) x :> - gf_U' y y x) ?L"
         by (auto intro!: eventually_at_left_1 derivative_eq_intros DERIV_gf_U)
       show "eventually (\<lambda>x. DERIV ((-) 1) x :> - 1) ?L"
         by (auto intro!: eventually_at_left_1 derivative_eq_intros)
       show "((\<lambda>x. - 1 / - gf_U' y y x) \<longlongrightarrow> enn2real (1 / U' y y)) ?L"
         using \<open>recurrent y\<close> by (rule inverse_gf_U'_tendsto)
     qed
     also have "(\<Sum>y\<in>A n. F x y * enn2real (1 / U' y y)) = (\<Sum>y\<in>A n. enn2real (1 / U' y y))"
     proof (intro sum.cong refl)
       fix y assume "y \<in> A n"
       with \<open>A n \<subseteq> C\<close> have "y \<in> C" by auto
       with \<open>x \<in> C\<close> have "(x, y) \<in> communicating"
         by (rule essential_classD3[OF C])
       with \<open>y\<in>C\<close> have "recurrent y" "(y, x) \<in> acc"
         using pos[THEN bspec, of y] by (auto simp add: pos_recurrent_def communicating_def)
       then have "U x y = 1"
         by (rule recurrent_acc)
       with F_le_1[of x y] U_le_F[of x y] have "F x y = 1" by simp
       then show "F x y * enn2real (1 / U' y y) = enn2real (1 / U' y y)"
         by simp
     qed
     finally have le: "(\<Sum>y\<in>A n. enn2real (1 / U' y y)) \<le> 1"
     proof (rule tendsto_le[OF trivial_limit_at_left_real tendsto_const], intro eventually_at_left_1)
       fix z :: real assume z: "0 < z" "z < 1"
       with \<open>x \<in> C\<close> have "norm z < 1"
         by auto
       then have conv: "\<And>x y. convergence_G x y z"
         by (simp add: convergence_G_less_1)
       have "(\<Sum>y\<in>A n. gf_F x y z / (1 - gf_U y y z)) = (\<Sum>y\<in>A n. gf_G x y z)"
         using \<open>norm z < 1\<close>
         apply (intro sum.cong refl)
         apply (subst gf_G_eq_gf_F)
         apply assumption
         apply (subst gf_G_eq_gf_U(1)[OF conv])
         apply auto
         done
       also have "\<dots> = (\<Sum>y\<in>A n. \<Sum>n. p x y n * z^n)"
         by (simp add: gf_G_def)
       also have "\<dots>  = (\<Sum>i. \<Sum>y\<in>A n. p x y i *\<^sub>R z^i)"
         by (subst suminf_sum[OF convergence_G[OF conv]]) simp
       also have "\<dots>  \<le> (\<Sum>i. z^i)"
       proof (intro suminf_le summable_sum convergence_G conv summable_geometric allI)
         fix l
         have "(\<Sum>y\<in>A n. p x y l *\<^sub>R z ^ l) = (\<Sum>y\<in>A n. p x y l) * z ^ l"
           by (simp add: sum_distrib_right)
         also have "\<dots> \<le> z ^ l"
         proof (intro mult_left_le_one_le)
           have "(\<Sum>y\<in>A n. p x y l) = \<P>(\<omega> in T x. (x ## \<omega>) !! l \<in> A n)"
             unfolding p_def using \<open>finite (A n)\<close>
             by (subst T.finite_measure_finite_Union[symmetric])
                (auto simp: disjoint_family_on_def intro!: arg_cong2[where f=measure])
           then show "(\<Sum>y\<in>A n. p x y l) \<le> 1"
             by simp
         qed (insert z, auto simp: sum_nonneg)
         finally show "(\<Sum>y\<in>A n. p x y l *\<^sub>R z ^ l) \<le> z ^ l" .
       qed fact
       also have "\<dots> = 1 / (1 - z)"
         using sums_unique[OF geometric_sums, OF \<open>norm z < 1\<close>] ..
       finally have "(\<Sum>y\<in>A n. gf_F x y z / (1 - gf_U y y z)) \<le> 1 / (1 - z)" .
       then have "(\<Sum>y\<in>A n. gf_F x y z / (1 - gf_U y y z)) * (1 - z) \<le> 1"
         using z by (simp add: field_simps)
       then have "(\<Sum>y\<in>A n. gf_F x y z / (1 - gf_U y y z) * (1 - z)) \<le> 1"
         by (simp add: sum_distrib_right)
       then show "(\<Sum>y\<in>A n. gf_F x y z * ((1 - z) / (1 - gf_U y y z))) \<le> 1"
         by simp
     qed
 
     from A_n have "emeasure (stat C) (A n) = (\<Sum>y\<in>A n. emeasure (stat C) {y})"
       by (intro emeasure_eq_sum_singleton) simp_all
     also have "\<dots> = (\<Sum>y\<in>A n. inverse (U' y y))"
       unfolding stat_def U'_def using A(1)[of n]
       apply (intro sum.cong refl)
       apply (subst emeasure_point_measure_finite2)
         apply (auto simp: divide_ennreal_def Collect_conv_if)
       done
     also have "\<dots> = ennreal (\<Sum>y\<in>A n. enn2real (1 / U' y y))"
       apply (subst sum_ennreal[symmetric], simp)
     proof (intro sum.cong refl)
       fix y assume "y \<in> A n"
       with \<open>A n \<subseteq> C\<close> pos have "pos_recurrent y"
         by auto
       with one_le_integral_t[of y] obtain r where "U' y y = ennreal r" "1 \<le> U' y y" and [simp]: "0 \<le> r"
         by (cases "U' y y") (auto simp: pos_recurrent_def nn_integral_add)
       then show "inverse (U' y y) = ennreal (enn2real (1 / U' y y))"
         by (simp add: ennreal_1[symmetric] divide_ennreal inverse_ennreal inverse_eq_divide del: ennreal_1)
     qed
     also have "\<dots> \<le> 1"
       using le by simp
     finally show "emeasure (stat C) (A n) \<le> 1" .
   qed
   with A show ?thesis
     by simp
 qed
 
 lemma emeasure_stat_not_C:
   assumes "y \<notin> C"
   shows "emeasure (stat C) {y} = 0"
   unfolding stat_def using \<open>y \<notin> C\<close>
   by (subst emeasure_point_measure_finite2) auto
 
 definition stationary_distribution :: "'s pmf \<Rightarrow> bool" where
   "stationary_distribution N \<longleftrightarrow> N = bind_pmf N K"
 
 lemma stationary_distributionI:
   assumes le: "\<And>y. (\<integral>x. pmf (K x) y \<partial>measure_pmf N) \<le> pmf N y"
   shows "stationary_distribution N"
   unfolding stationary_distribution_def
 proof (rule pmf_eqI antisym)+
   fix i
   show "pmf (bind_pmf N K) i \<le> pmf N i"
     by (simp add: pmf_bind le)
 
   define \<Omega> where "\<Omega> = N \<union> (\<Union>i\<in>N. set_pmf (K i))"
   then have \<Omega>: "countable \<Omega>"
     by (auto intro: countable_set_pmf)
   then interpret N: sigma_finite_measure "count_space \<Omega>"
     by (rule sigma_finite_measure_count_space_countable)
   interpret pN: pair_sigma_finite N "count_space \<Omega>"
     by unfold_locales
 
   have measurable_pmf[measurable]: "(\<lambda>(x, y). pmf (K x) y) \<in> borel_measurable (N \<Otimes>\<^sub>M count_space \<Omega>)"
     unfolding measurable_split_conv
     apply (rule measurable_compose_countable'[OF _ measurable_snd])
     apply (rule measurable_compose[OF measurable_fst])
     apply (simp_all add: \<Omega>)
     done
 
   { assume *: "(\<integral>y. pmf (K y) i \<partial>N) < pmf N i"
     have "0 \<le> (\<integral>y. pmf (K y) i \<partial>N)"
       by (intro integral_nonneg_AE) simp
     with * have i: "i \<in> set_pmf N" "i \<in> \<Omega>"
       by (auto simp: set_pmf_iff \<Omega>_def not_le[symmetric])
     from * have "0 < pmf N i - (\<integral>y. pmf (K y) i \<partial>N)"
       by (simp add: field_simps)
     also have "\<dots> = (\<integral>t. (pmf N i - (\<integral>y. pmf (K y) i \<partial>N)) * indicator {i} t \<partial>count_space \<Omega>)"
       by (simp add: i)
     also have "\<dots> \<le> (\<integral>t. pmf N t - \<integral>y. pmf (K y) t \<partial>N \<partial>count_space \<Omega>)"
       using le
       by (intro integral_mono integrable_diff)
          (auto simp: i pmf_bind[symmetric] integrable_pmf field_simps split: split_indicator)
     also have "\<dots> = (\<integral>t. pmf N t \<partial>count_space \<Omega>) - (\<integral>t. \<integral>y. pmf (K y) t \<partial>N \<partial>count_space \<Omega>)"
       by (subst Bochner_Integration.integral_diff) (auto intro!: integrable_pmf simp: pmf_bind[symmetric])
     also have "(\<integral>t. \<integral>y. pmf (K y) t \<partial>N \<partial>count_space \<Omega>) = (\<integral>y. \<integral>t. pmf (K y) t \<partial>count_space \<Omega> \<partial>N)"
       apply (intro pN.Fubini_integral integrable_iff_bounded[THEN iffD2] conjI)
       apply (auto simp add: N.nn_integral_fst[symmetric] nn_integral_eq_integral integrable_pmf)
       unfolding less_top[symmetric] unfolding infinity_ennreal_def[symmetric]
       apply (intro integrableD)
       apply (auto intro!: measure_pmf.integrable_const_bound[where B=1]
                   simp: AE_measure_pmf_iff integral_nonneg_AE integral_pmf)
       done
     also have "(\<integral>y. \<integral>t. pmf (K y) t \<partial>count_space \<Omega> \<partial>N) = (\<integral>y. 1 \<partial>N)"
       by (intro integral_cong_AE)
          (auto simp: AE_measure_pmf_iff integral_pmf \<Omega>_def intro!: measure_pmf.prob_eq_1[THEN iffD2])
     finally have False
       using measure_pmf.prob_space[of N] by (simp add: integral_pmf field_simps not_le[symmetric]) }
   then show "pmf N i \<le> pmf (bind_pmf N K) i"
     by (auto simp: pmf_bind not_le[symmetric])
 qed
 
 lemma stationary_distribution_iterate:
   assumes N: "stationary_distribution N"
   shows "ennreal (pmf N y) = (\<integral>\<^sup>+x. p x y n \<partial>N)"
 proof (induct n arbitrary: y)
   have [simp]: "\<And>x y. ennreal (if x = y then 1 else 0) = indicator {y} x"
     by simp
   case 0 then show ?case
     by (simp add: p_0 pmf.rep_eq measure_pmf.emeasure_eq_measure)
 next
   case (Suc n) with N show ?case
     apply (simp add: nn_integral_eq_integral[symmetric] p_le_1 p_Suc'
                      measure_pmf.integrable_const_bound[where B=1])
     apply (subst nn_integral_bind[symmetric, where B="count_space UNIV"])
     apply (auto simp: stationary_distribution_def measure_pmf_bind[symmetric]
                 simp del: measurable_pmf_measure1)
     done
 qed
 
 lemma stationary_distribution_iterate':
   assumes "stationary_distribution N"
   shows "measure N {y} = (\<integral>x. p x y n \<partial>N)"
   using stationary_distribution_iterate[OF assms]
   by (subst (asm) nn_integral_eq_integral)
      (auto intro!: measure_pmf.integrable_const_bound[where B=1] simp: p_le_1 pmf.rep_eq)
 
 lemma stationary_distributionD:
   assumes C: "essential_class C" "countable C"
   assumes N: "stationary_distribution N" "N \<subseteq> C"
   shows "\<forall>x\<in>C. pos_recurrent x" "measure_pmf N = stat C"
 proof -
   have integrable_K: "\<And>f x. integrable N (\<lambda>s. pmf (K s) (f x))"
     by (rule measure_pmf.integrable_const_bound[where B=1]) (simp_all add: pmf_le_1)
 
   have measure_C: "measure N C = 1" and ae_C: "AE x in N. x \<in> C"
     using N C measure_pmf.prob_eq_1[of C] by (auto simp: AE_measure_pmf_iff)
 
   have integrable_p: "\<And>n y. integrable N (\<lambda>x. p x y n)"
     by (rule measure_pmf.integrable_const_bound[where B=1]) (simp_all add: p_le_1)
 
   { fix e :: real assume "0 < e"
     then have [simp]: "0 \<le> e" by simp
     have "\<exists>A\<subseteq>C. finite A \<and> 1 - e < measure N A"
     proof (rule ccontr)
       assume contr: "\<not> (\<exists>A \<subseteq> C. finite A \<and> 1 - e < measure N A)"
-      from finite_sequence_to_countable_set[OF \<open>countable C\<close>] guess F . note F = this
+      from finite_sequence_to_countable_set[OF \<open>countable C\<close>]
+      obtain F where F: "\<And>i. F i \<subseteq> C" "\<And>i. F i \<subseteq> F (Suc i)" "\<And>i. finite (F i)" "\<Union> (range F) = C"
+        by blast
       then have *: "(\<lambda>n. measure N (F n)) \<longlonglongrightarrow> measure N (\<Union>i. F i)"
         by (intro measure_pmf.finite_Lim_measure_incseq) (auto simp: incseq_Suc_iff)
       with F contr have "measure N (\<Union>i. F i) \<le> 1 - e"
         by (intro LIMSEQ_le[OF * tendsto_const]) (auto simp: not_less)
       with F \<open>0 < e\<close> show False
         by (simp add: measure_C)
     qed
     then obtain A where "A \<subseteq> C" "finite A" and e: "1 - e < measure N A" by auto
 
     { fix y n assume "y \<in> C"
       from N(1) have "measure N {y} = (\<integral>x. p x y n \<partial>N)"
         by (rule stationary_distribution_iterate')
       also have "\<dots> \<le> (\<integral>x. p x y n * indicator A x + indicator (C - A) x \<partial>N)"
         using ae_C \<open>A \<subseteq> C\<close>
         by (intro integral_mono_AE)
            (auto elim!: eventually_mono
                  intro!: integral_add integral_indicator p_le_1 integrable_real_mult_indicator
                    integrable_add
                  split: split_indicator simp: integrable_p less_top[symmetric] top_unique)
       also have "\<dots> = (\<integral>x. p x y n * indicator A x \<partial>N) + measure N (C - A)"
         using ae_C \<open>A \<subseteq> C\<close>
         apply (subst Bochner_Integration.integral_add)
         apply (auto elim!: eventually_mono
                     intro!: integral_add integral_indicator p_le_1 integrable_real_mult_indicator
                     split: split_indicator simp: integrable_p less_top[symmetric] top_unique)
         done
       also have "\<dots> \<le> (\<integral>x. p x y n * indicator A x \<partial>N) + e"
         using e \<open>A \<subseteq> C\<close>  by (simp add: measure_pmf.finite_measure_Diff measure_C)
       finally have "measure N {y} \<le> (\<integral>x. p x y n * indicator A x \<partial>N) + e" .
       then have "emeasure N {y} \<le> ennreal (\<integral>x. p x y n * indicator A x \<partial>N) + e"
         by (simp add: measure_pmf.emeasure_eq_measure ennreal_plus[symmetric] del: ennreal_plus)
       also have "\<dots> = (\<integral>\<^sup>+x. ennreal (p x y n) * indicator A x \<partial>N) + e"
         by (subst nn_integral_eq_integral[symmetric])
            (auto intro!: measure_pmf.integrable_const_bound[where B=1]
                  simp: abs_mult p_le_1 mult_le_one ennreal_indicator ennreal_mult)
       finally have "emeasure N {y} \<le> (\<integral>\<^sup>+x. ennreal (p x y n) * indicator A x \<partial>N) + e" . }
     note v_le = this
 
     { fix y and z :: real assume y: "y \<in> C" and z: "0 < z" "z < 1"
       have summable_int_p: "summable (\<lambda>n. (\<integral> x. p x y n * indicator A x \<partial>N) * (1 - z) * z ^ n)"
         using \<open>y\<in>C\<close> z \<open>A \<subseteq> C\<close>
         by (auto intro!: summable_comparison_test[OF _ summable_mult[OF summable_geometric[of z], of 1]] exI[of _ 0] mult_le_one
                             measure_pmf.integral_le_const integrable_real_mult_indicator integrable_p AE_I2 p_le_1
                     simp: abs_mult integral_nonneg_AE)
 
       from y z have sums_y: "(\<lambda>n. measure N {y} * (1 - z) * z ^ n) sums measure N {y}"
         using sums_mult[OF geometric_sums[of z], of "measure N {y} * (1 - z)"] by simp
       then have "emeasure N {y} = ennreal (\<Sum>n. (measure N {y} * (1 - z)) * z ^ n)"
         by (auto simp add: sums_unique[symmetric] measure_pmf.emeasure_eq_measure)
       also have "\<dots> = (\<Sum>n. emeasure N {y} * (1 - z) * z ^ n)"
         using z  summable_mult[OF summable_geometric[of z], of "measure_pmf.prob N {y} * (1 - z)"]
         by (subst suminf_ennreal[symmetric])
            (auto simp: measure_pmf.emeasure_eq_measure ennreal_mult[symmetric] ennreal_suminf_neq_top)
       also have "\<dots> \<le> (\<Sum>n. ((\<integral>\<^sup>+x. ennreal (p x y n) * indicator A x \<partial>N) + e) * (1 - z) * z ^ n)"
         using \<open>y\<in>C\<close> z \<open>A \<subseteq> C\<close>
         by (intro suminf_le mult_right_mono v_le allI)
            (auto simp: measure_pmf.emeasure_eq_measure)
       also have "\<dots> = (\<Sum>n. (\<integral>\<^sup>+x. ennreal (p x y n) * indicator A x \<partial>N) * (1 - z) * z ^ n) + e"
         using \<open>0 < e\<close> z sums_mult[OF geometric_sums[of z], of "e * (1 - z)"] \<open>0<z\<close> \<open>z<1\<close>
         by (simp add: distrib_right suminf_add[symmetric] ennreal_suminf_cmult[symmetric]
                       ennreal_mult[symmetric] suminf_ennreal_eq sums_unique[symmetric]
                  del: ennreal_suminf_cmult)
       also have "\<dots> = (\<Sum>n. ennreal (1 - z) * ((\<integral>\<^sup>+x. ennreal (p x y n) * indicator A x \<partial>N) * z ^ n)) + e"
         by (simp add: ac_simps)
       also have "\<dots> = ennreal (1 - z) * (\<Sum>n. ((\<integral>\<^sup>+x. ennreal (p x y n) * indicator A x \<partial>N) * z ^ n)) + e"
         using z by (subst ennreal_suminf_cmult) simp_all
       also have "(\<Sum>n. ((\<integral>\<^sup>+x. ennreal (p x y n) * indicator A x \<partial>N) * z ^ n)) =
           (\<Sum>n. (\<integral>\<^sup>+x. ennreal (p x y n * z ^ n) * indicator A x \<partial>N))"
         using z by (simp add: ac_simps nn_integral_cmult[symmetric] ennreal_mult)
       also have "\<dots> = (\<integral>\<^sup>+x. ennreal (gf_G x y z) * indicator A x \<partial>N)"
         using z
         apply (subst nn_integral_suminf[symmetric])
         apply (auto simp add: gf_G_def simp del: suminf_ennreal
                     intro!: ennreal_mult_right_cong suminf_ennreal2 nn_integral_cong)
         apply (intro summable_comparison_test[OF _ summable_mult[OF summable_geometric[of z], of 1]] impI)
         apply (simp_all add: abs_mult p_le_1 mult_le_one power_le_one split: split_indicator)
         done
       also have "\<dots> = (\<integral>\<^sup>+x. ennreal (gf_F x y z * gf_G y y z) * indicator A x \<partial>N)"
         using z by (intro nn_integral_cong) (simp add: gf_G_eq_gf_F[symmetric])
       also have "\<dots> = ennreal (gf_G y y z) * (\<integral>\<^sup>+x. ennreal (gf_F x y z) * indicator A x \<partial>N)"
         using z by (subst nn_integral_cmult[symmetric]) (simp_all add: gf_G_nonneg gf_F_nonneg ac_simps ennreal_mult)
       also have "\<dots> = ennreal (1 / (1 - gf_U y y z)) * (\<integral>\<^sup>+x. ennreal (gf_F x y z) * indicator A x \<partial>N)"
         using z \<open>y \<in> C\<close> by (subst gf_G_eq_gf_U) (auto intro!: convergence_G_less_1)
       finally have "emeasure N {y} \<le> ennreal ((1 - z) / (1 - gf_U y y z)) * (\<integral>\<^sup>+x. gf_F x y z * indicator A x \<partial>N) + e"
         using z
         by (subst (asm) mult.assoc[symmetric])
            (simp add: ennreal_indicator[symmetric] ennreal_mult'[symmetric] gf_F_nonneg)
       then have "measure N {y} \<le> (1 - z) / (1 - gf_U y y z) * (\<integral>x. gf_F x y z * indicator A x \<partial>N) + e"
         using z
         by (subst (asm) nn_integral_eq_integral[OF measure_pmf.integrable_const_bound[where B=1]])
            (auto simp: gf_F_nonneg gf_U_le_1 gf_F_le_1 measure_pmf.emeasure_eq_measure mult_le_one
                        ennreal_mult''[symmetric] ennreal_plus[symmetric]
                  simp del: ennreal_plus) }
     then have "\<exists>A \<subseteq> C. finite A \<and> (\<forall>y\<in>C. \<forall>z. 0 < z \<longrightarrow> z < 1 \<longrightarrow> measure N {y} \<le> (1 - z) / (1 - gf_U y y z) * (\<integral>x. gf_F x y z * indicator A x \<partial>N) + e)"
       using \<open>A \<subseteq> C\<close> \<open>finite A\<close> by auto }
   note eps = this
 
   { fix y A assume "y \<in> C" "finite A" "A \<subseteq> C"
     then have "((\<lambda>z. \<integral>x. gf_F x y z * indicator A x \<partial>N) \<longlongrightarrow> \<integral>x. F x y * indicator A x \<partial>N) (at_left 1)"
       by (subst (1 2) integral_measure_pmf[of A]) (auto intro!: tendsto_intros gf_F simp: indicator_eq_0_iff) }
   note int_gf_F = this
 
   have all_recurrent: "\<forall>y\<in>C. recurrent y"
   proof (rule ccontr)
     assume "\<not> (\<forall>y\<in>C. recurrent y)"
     then obtain x where "x \<in> C" "\<not> recurrent x" by auto
     then have transient: "\<And>x. x \<in> C \<Longrightarrow> \<not> recurrent x"
       using C by (auto simp: essential_class_def recurrent_iffI_communicating[symmetric] elim!: quotientE)
 
     { fix y assume "y \<in> C"
       with transient have "U y y < 1"
         by (metis recurrent_iff_U_eq_1 U_cases)
       have "measure N {y} \<le> 0"
       proof (rule dense_ge)
         fix e :: real assume "0 < e"
         from eps[OF this] \<open>y \<in> C\<close> obtain A where
           A: "finite A" "A \<subseteq> C" and
           le: "\<And>z. 0 < z \<Longrightarrow> z < 1 \<Longrightarrow> measure N {y} \<le> (1 - z) / (1 - gf_U y y z) * (\<integral>x. gf_F x y z * indicator A x \<partial>N) + e"
           by auto
         have "((\<lambda>z. (1 - z) / (1 - gf_U y y z) * (\<integral>x. gf_F x y z * indicator A x \<partial>N) + e) \<longlongrightarrow>
           (1 - 1) / (1 - U y y) * (\<integral>x. F x y * indicator A x \<partial>N) + e) (at_left (1::real))"
           using A \<open>U y y < 1\<close> \<open>y \<in> C\<close> by (intro tendsto_intros gf_U int_gf_F) auto
         then have 1: "((\<lambda>z. (1 - z) / (1 - gf_U y y z) * (\<integral>x. gf_F x y z * indicator A x \<partial>N) + e) \<longlongrightarrow> e) (at_left (1::real))"
           by simp
         with le show "measure N {y} \<le> e"
           by (intro tendsto_le[OF trivial_limit_at_left_real _ tendsto_const])
              (auto simp: eventually_at_left_1)
       qed
       then have "measure N {y} = 0"
         by (intro antisym measure_nonneg) }
     then have "emeasure N C = 0"
       by (subst emeasure_countable_singleton) (auto simp: measure_pmf.emeasure_eq_measure nn_integral_0_iff_AE ae_C C)
     then show False
       using \<open>measure N C = 1\<close> by (simp add: measure_pmf.emeasure_eq_measure)
   qed
   then have "\<And>x. x \<in> C \<Longrightarrow> U x x = 1"
     by (metis recurrent_iff_U_eq_1)
 
   { fix y assume "y \<in> C"
     then have "U y y = 1" "recurrent y"
       using \<open>y \<in> C \<Longrightarrow> U y y = 1\<close> all_recurrent by auto
     have "measure N {y} \<le> enn2real (1 / U' y y)"
     proof (rule field_le_epsilon)
       fix e :: real assume "0 < e"
       from eps[OF \<open>0 < e\<close>] \<open>y \<in> C\<close> obtain A where
         A: "finite A" "A \<subseteq> C" and
         le: "\<And>z. 0 < z \<Longrightarrow> z < 1 \<Longrightarrow> measure N {y} \<le> (1 - z) / (1 - gf_U y y z) * (\<integral>x. gf_F x y z * indicator A x \<partial>N) + e"
         by auto
       let ?L = "at_left (1::real)"
       have "((\<lambda>z. (1 - z) / (1 - gf_U y y z) * (\<integral>x. gf_F x y z * indicator A x \<partial>N) + e) \<longlongrightarrow>
           enn2real (1 / U' y y) * (\<integral>x. F x y * indicator A x \<partial>N) + e) ?L"
       proof (intro tendsto_add tendsto_const tendsto_mult int_gf_F,
              rule lhopital_left[where f'="\<lambda>x. - 1" and g'="\<lambda>z. - gf_U' y y z"])
         show "((-) 1 \<longlongrightarrow> 0) ?L" "((\<lambda>x. 1 - gf_U y y x) \<longlongrightarrow> 0) ?L"
           using gf_U[of y y] by (auto intro!: tendsto_eq_intros simp: \<open>U y y = 1\<close>)
         show "y \<in> C" "finite A" "A \<subseteq> C" by fact+
         show "eventually (\<lambda>x. 1 - gf_U y y x \<noteq> 0) ?L"
           using gf_G_eq_gf_U(2)[OF convergence_G_less_1, where 'z=real] by (auto intro!: eventually_at_left_1)
         show "((\<lambda>x. - 1 / - gf_U' y y x) \<longlongrightarrow> enn2real (1 / U' y y)) ?L"
           using \<open>recurrent y\<close> by (rule inverse_gf_U'_tendsto)
         have "eventually (\<lambda>x. 0 < gf_U' y y x) ?L"
           by (intro eventually_at_left_1 gf_U'_pos) (simp_all add: \<open>U y y = 1\<close>)
         then show "eventually (\<lambda>x. - gf_U' y y x \<noteq> 0) ?L"
           by eventually_elim simp
         show "eventually (\<lambda>x. DERIV (\<lambda>x. 1 - gf_U y y x) x :> - gf_U' y y x) ?L"
           by (auto intro!: eventually_at_left_1 derivative_eq_intros DERIV_gf_U)
         show "eventually (\<lambda>x. DERIV ((-) 1) x :> - 1) ?L"
           by (auto intro!: eventually_at_left_1 derivative_eq_intros)
       qed
       then have "measure N {y} \<le> enn2real (1 / U' y y) * (\<integral>x. F x y * indicator A x \<partial>N) + e"
         by (rule tendsto_le[OF trivial_limit_at_left_real _ tendsto_const]) (intro eventually_at_left_1 le)
       then have "measure N {y} - e \<le> enn2real (1 / U' y y) * (\<integral>x. F x y * indicator A x \<partial>N)"
         by simp
       also have "\<dots> \<le> enn2real (1 / U' y y)"
         using A
         by (intro mult_left_le measure_pmf.integral_le_const measure_pmf.integrable_const_bound[where B=1])
            (auto simp: mult_le_one F_le_1 U'_def)
       finally show "measure N {y} \<le> enn2real (1 / U' y y) + e"
         by simp
     qed }
   note measure_y_le = this
 
   show pos: "\<forall>y\<in>C. pos_recurrent y"
   proof (rule ccontr)
     assume "\<not> (\<forall>y\<in>C. pos_recurrent y)"
     then obtain x where x: "x \<in> C" "\<not> pos_recurrent x" by auto
     { fix y assume "y \<in> C"
       with x have "\<not> pos_recurrent y"
         using C by (auto simp: essential_class_def pos_recurrent_iffI_communicating[symmetric] elim!: quotientE)
       with all_recurrent \<open>y \<in> C\<close> have "enn2real (1 / U' y y) = 0"
         by (simp add: pos_recurrent_def nn_integral_add)
       with measure_y_le[OF \<open>y \<in> C\<close>] have "measure N {y} = 0"
         by (auto intro!: antisym simp: pos_recurrent_def) }
     then have "emeasure N C = 0"
       by (subst emeasure_countable_singleton) (auto simp: C ae_C measure_pmf.emeasure_eq_measure nn_integral_0_iff_AE)
     then show False
       using \<open>measure N C = 1\<close> by (simp add: measure_pmf.emeasure_eq_measure)
   qed
 
   { fix A :: "'s set" assume [simp]: "countable A"
     have "emeasure N A = (\<integral>\<^sup>+x. emeasure N {x} \<partial>count_space A)"
       by (intro emeasure_countable_singleton) auto
     also have "\<dots> \<le> (\<integral>\<^sup>+x. emeasure (stat C) {x} \<partial>count_space A)"
     proof (intro nn_integral_mono)
       fix y assume "y \<in> space (count_space A)"
       show "emeasure N {y} \<le> emeasure (stat C) {y}"
       proof cases
         assume "y \<in> C"
         with pos have "pos_recurrent y"
           by auto
         with one_le_integral_t[of y] obtain r where r: "U' y y = ennreal r" "1 \<le> U' y y" and [simp]: "0 \<le> r"
           by (cases "U' y y") (auto simp: pos_recurrent_def nn_integral_add)
 
         from measure_y_le[OF \<open>y \<in> C\<close>]
         have "emeasure N {y} \<le> ennreal (enn2real (1 / U' y y))"
           by (simp add: measure_pmf.emeasure_eq_measure)
         also have "\<dots> = emeasure (stat C) {y}"
           unfolding stat_def using \<open>y \<in> C\<close> r
           by (subst emeasure_point_measure_finite2)
              (auto simp add: ennreal_1[symmetric] divide_ennreal inverse_ennreal inverse_eq_divide ennreal_mult[symmetric]
                    simp del: ennreal_1)
         finally show "emeasure N {y} \<le> emeasure (stat C) {y}"
           by simp
       next
         assume "y \<notin> C"
         with ae_C have "emeasure N {y} = 0"
           by (subst AE_iff_measurable[symmetric, where P="\<lambda>x. x \<noteq> y"]) (auto elim!: eventually_mono)
         moreover have "emeasure (stat C) {y} = 0"
           using emeasure_stat_not_C[OF \<open>y \<notin> C\<close>] .
         ultimately show ?thesis by simp
       qed
     qed
     also have "\<dots> = emeasure (stat C) A"
       by (intro emeasure_countable_singleton[symmetric]) auto
     finally have "emeasure N A \<le> emeasure (stat C) A" . }
   note N_le_C = this
 
   from stat_subprob[OF C(1) \<open>countable C\<close> pos] N_le_C[OF \<open>countable C\<close>] \<open>measure N C = 1\<close>
   have stat_C_eq_1: "emeasure (stat C) C = 1"
     by (auto simp add: measure_pmf.emeasure_eq_measure one_ennreal_def)
   moreover have "emeasure (stat C) (UNIV - C) = 0"
     by (subst AE_iff_measurable[symmetric, where P="\<lambda>x. x \<in> C"])
        (auto simp: stat_def AE_point_measure sets_point_measure space_point_measure
                 split: split_indicator cong del: AE_cong)
   ultimately have "emeasure (stat C) (space (stat C)) = 1"
     using plus_emeasure[of C "stat C" "UNIV - C"] by (simp add: Un_absorb1)
   interpret stat: prob_space "stat C"
     by standard fact
 
   show "measure_pmf N = stat C"
   proof (rule measure_eqI_countable_AE)
     show "sets N = UNIV" "sets (stat C) = UNIV"
       by auto
     show "countable C" "AE x in N. x \<in> C" and ae_stat: "AE x in stat C. x \<in> C"
       using C ae_C stat_C_eq_1 by (auto intro!: stat.AE_prob_1 simp: stat.emeasure_eq_measure)
 
     { assume "\<exists>x. emeasure N {x} \<noteq> emeasure (stat C) {x}"
       then obtain x where [simp]: "emeasure N {x} \<noteq> emeasure (stat C) {x}" by auto
       with N_le_C[of "{x}"] have x: "emeasure N {x} < emeasure (stat C) {x}"
         by (auto simp: less_le)
       have "1 = emeasure N {x} + emeasure N (C - {x})"
         using ae_C
         by (subst plus_emeasure) (auto intro!: measure_pmf.emeasure_eq_1_AE)
       also have "\<dots> < emeasure (stat C) {x} + emeasure (stat C) (C - {x})"
         using x N_le_C[of "C - {x}"] C ae_C
         by (simp add: stat.emeasure_eq_measure measure_pmf.emeasure_eq_measure
                       ennreal_plus[symmetric] ennreal_less_iff
                  del: ennreal_plus)
       also have "\<dots> = 1"
         using ae_stat by (subst plus_emeasure) (auto intro!: stat.emeasure_eq_1_AE)
       finally have False by simp }
     then show "\<And>x. emeasure N {x} = emeasure (stat C) {x}" by auto
   qed
 qed
 
 lemma measure_point_measure_singleton:
   "x \<in> A \<Longrightarrow> measure (point_measure A X) {x} = enn2real (X x)"
   unfolding measure_def by (subst emeasure_point_measure_finite2) auto
 
 lemma stationary_distribution_imp_int_t:
   assumes C: "essential_class C" "countable C" "stationary_distribution N" "N \<subseteq> C"
   assumes x: "x \<in> C" shows "U' x x = 1 / ennreal (pmf N x)"
 proof -
   from stationary_distributionD[OF C]
   have "measure_pmf N = stat C" and *: "\<forall>x\<in>C. pos_recurrent x" by auto
   show ?thesis
     unfolding \<open>measure_pmf N = stat C\<close> pmf.rep_eq stat_def
     using *[THEN bspec, OF x] x
     apply (simp add: measure_point_measure_singleton)
     apply (cases "U' x x")
     subgoal for r
       by (cases "r = 0")
          (simp_all add: divide_ennreal_def inverse_ennreal)
     apply simp
     done
 qed
 
 definition "period_set x = {i. 0 < i \<and> 0 < p x x i }"
 definition "period C = (SOME d. \<forall>x\<in>C. d = Gcd (period_set x))"
 
 lemma Gcd_period_set_invariant:
   assumes c: "(x, y) \<in> communicating"
   shows "Gcd (period_set x) = Gcd (period_set y)"
 proof -
   { fix x y n assume c: "(x, y) \<in> communicating" "x \<noteq> y" and n: "n \<in> period_set x"
     from c obtain l k where "0 < p x y l" "0 < p y x k"
       by (auto simp: communicating_def dest!: accD_pos)
     moreover with \<open>x \<noteq> y\<close> have "l \<noteq> 0 \<and> k \<noteq> 0"
       by (intro notI conjI) (auto simp: p_0)
     ultimately have pos: "0 < l" "0 < k" and l: "0 < p x y l" and k: "0 < p y x k"
       by auto
 
     from mult_pos_pos[OF k l] prob_reachable_le[of k "k + l" y x y] c
     have k_l: "0 < p y y (k + l)"
       by simp
     then have "Gcd (period_set y) dvd k + l"
       using pos by (auto intro!: Gcd_dvd_nat simp: period_set_def)
     moreover
     from n have "0 < p x x n" "0 < n" by (auto simp: period_set_def)
     from mult_pos_pos[OF k this(1)] prob_reachable_le[of k "k + n" y x x] c
     have "0 < p y x (k + n)"
       by simp
     from mult_pos_pos[OF this(1) l] prob_reachable_le[of "k + n" "(k + n) + l" y x y] c
     have "0 < p y y (k + n + l)"
       by simp
     then have "Gcd (period_set y) dvd (k + l) + n"
       using pos by (auto intro!: Gcd_dvd_nat simp: period_set_def ac_simps)
     ultimately have "Gcd (period_set y) dvd n"
       by (metis dvd_add_left_iff add.commute) }
   note this[of x y] this[of y x] c
   moreover have "(y, x) \<in> communicating"
     using c by (simp add: communicating_def)
   ultimately show ?thesis
     by (auto intro: dvd_antisym Gcd_greatest Gcd_dvd)
 qed
 
 lemma period_eq:
   assumes "C \<in> UNIV // communicating" "x \<in> C"
   shows "period C = Gcd (period_set x)"
   unfolding period_def
   using assms
   by (rule_tac someI2[where a="Gcd (period_set x)"])
      (auto intro!: Gcd_period_set_invariant irreducibleD)
 
 definition "aperiodic C \<longleftrightarrow> C \<in> UNIV // communicating \<and> period C = 1"
 
 definition "not_ephemeral C \<longleftrightarrow> C \<in> UNIV // communicating \<and> \<not> (\<exists>x. C = {x} \<and> p x x 1 = 0)"
 
 lemma not_ephemeralD:
   assumes C: "not_ephemeral C" "x \<in> C"
   shows "\<exists>n>0. 0 < p x x n"
 proof cases
   assume "\<exists>x. C = {x}"
   with \<open>x \<in> C\<close> have "C = {x}" by auto
   with C p_nonneg[of x x 1] have "0 < p x x 1"
     by (auto simp: not_ephemeral_def less_le)
   with \<open>C = {x}\<close> show ?thesis by auto
 next
   from C have irr: "C \<in> UNIV // communicating"
     by (auto simp: not_ephemeral_def)
   assume "\<not>(\<exists>x. C = {x})"
   then have "\<forall>x. C \<noteq> {x}" by auto
   with \<open>x \<in> C\<close> obtain y where "y \<in> C" "x \<noteq> y"
     by blast
   with irreducibleD[OF irr, of x y] C \<open>x \<in> C\<close> have c: "(x, y) \<in> communicating" by auto
   with accD_pos[of x y] accD_pos[of y x]
   obtain k l where pos: "0 < p x y k" "0 < p y x l"
     by (auto simp: communicating_def)
   with \<open>x \<noteq> y\<close> have "l \<noteq> 0"
     by (intro notI) (auto simp: p_0)
   have "0 < p x y k * p y x (k + l - k)"
     using pos by auto
   also have "p x y k * p y x (k + l - k) \<le> p x x (k + l)"
     using prob_reachable_le[of "k" "k + l" x y x] c by auto
   finally show ?thesis
     using \<open>l \<noteq> 0\<close> \<open>x \<in> C\<close> by (auto intro!: exI[of _ "k + l"])
 qed
 
 lemma not_ephemeralD_pos_period:
   assumes C: "not_ephemeral C"
   shows "0 < period C"
 proof -
   from C not_empty_irreducible[of C] obtain x where "x \<in> C"
     by (auto simp: not_ephemeral_def)
   from not_ephemeralD[OF C this]
   obtain n where n: "0 < p x x n" "0 < n" by auto
   have C': "C \<in> UNIV // communicating"
     using C by (auto simp: not_ephemeral_def)
 
   have "period C \<noteq> 0"
     unfolding period_eq [OF C' \<open>x \<in> C\<close>]
     using n by (auto simp: period_set_def)
   then show ?thesis by auto
 qed
 
 
 lemma period_posD:
   assumes C: "C \<in> UNIV // communicating" and "0 < period C" "x \<in> C"
   shows "\<exists>n>0. 0 < p x x n"
 proof -
   from \<open>0 < period C\<close> have "period C \<noteq> 0"
     by auto
   then show ?thesis
     unfolding period_eq [OF C \<open>x \<in> C\<close>]
     unfolding period_set_def by auto
 qed
 
 lemma not_ephemeralD_pos_period':
   assumes C: "C \<in> UNIV // communicating"
   shows "not_ephemeral C \<longleftrightarrow> 0 < period C"
 proof (auto dest!: not_ephemeralD_pos_period intro: C)
   from C not_empty_irreducible[of C] obtain x where "x \<in> C"
     by (auto simp: not_ephemeral_def)
 
   assume "0 < period C"
   then show "not_ephemeral C"
     apply (auto simp: not_ephemeral_def C)
 oops \<comment> \<open>should be easy to finish\<close>
 
 
 lemma eventually_periodic:
   assumes C: "C \<in> UNIV // communicating" "0 < period C" "x \<in> C"
   shows "eventually (\<lambda>m. 0 < p x x (m * period C)) sequentially"
 proof -
   from period_posD[OF assms] obtain n where n: "0 < p x x n" "0 < n" by auto
   have C': "C \<in> UNIV // communicating"
     using C by auto
 
   have "period C \<noteq> 0"
     unfolding period_eq [OF C' \<open>x \<in> C\<close>]
     using n by (auto simp: period_set_def)
   have "eventually (\<lambda>m. m * Gcd (period_set x) \<in> (period_set x)) sequentially"
   proof (rule eventually_mult_Gcd)
     show "n > 0" "n \<in> period_set x"
       using n by (auto simp add: period_set_def)
     fix k l  assume "k \<in> period_set x" "l \<in> period_set x"
     then have "0 < p x x k * p x x l" "0 < l" "0 < k"
       by (auto simp: period_set_def)
     moreover have "p x x k * p x x l \<le> p x x (k + l)"
       using prob_reachable_le[of k "k + l" x x x] \<open>x \<in> C\<close>
       by auto
     ultimately show "k + l \<in> period_set x"
       using \<open>0 < l\<close> by (auto simp: period_set_def)
   qed
   with eventually_ge_at_top[of 1] show "eventually (\<lambda>m. 0 < p x x (m * period C)) sequentially"
     by eventually_elim 
        (insert \<open>period C \<noteq> 0\<close> period_eq[OF C' \<open>x \<in> C\<close>, symmetric], auto simp: period_set_def)
 qed
 
 
 lemma aperiodic_eventually_recurrent:
   "aperiodic C \<longleftrightarrow> C \<in> UNIV // communicating \<and> (\<forall>x\<in>C. eventually (\<lambda>m. 0 < p x x m) sequentially)"
 proof safe
   fix x assume "x \<in> C" "aperiodic C"
   with eventually_periodic[of C x]
   show "eventually (\<lambda>m. 0 < p x x m) sequentially"
     by (auto simp add: aperiodic_def)
 next
   assume "\<forall>x\<in>C. eventually (\<lambda>m. 0 < p x x m) sequentially" and C: "C \<in> UNIV // communicating"
   moreover from not_empty_irreducible[OF C] obtain x where "x \<in> C" by auto
   ultimately obtain N where "\<And>M.  M\<ge>N \<Longrightarrow> 0 < p x x M"
     by (auto simp: eventually_sequentially)
   then have "{N <..} \<subseteq> period_set x"
     by (auto simp: period_set_def)
   from C show "aperiodic C"
     unfolding period_eq [OF C \<open>x \<in> C\<close>] aperiodic_def
   proof
     show "Gcd (period_set x) = 1"
     proof (rule Gcd_eqI)
       from one_dvd show "1 dvd q" for q :: nat .
       fix m
       assume "\<And>q. q \<in> period_set x \<Longrightarrow> m dvd q"
       moreover from \<open>{N <..} \<subseteq> period_set x\<close>
       have "{Suc N, Suc (Suc N)} \<subseteq> period_set x"
         by auto
       ultimately have "m dvd Suc (Suc N)" and "m dvd Suc N"
         by auto
       then have "m dvd Suc (Suc N) - Suc N"
         by (rule dvd_diff_nat)
       then show "is_unit m"
         by simp
     qed simp
   qed
 qed (simp add: aperiodic_def)
 
 lemma stationary_distributionD_emeasure:
   assumes N: "stationary_distribution N"
   shows "emeasure N A = (\<integral>\<^sup>+s. emeasure (K s) A \<partial>N)"
 proof -
   have "prob_space (measure_pmf N)"
     by intro_locales
   then interpret subprob_space "measure_pmf N"
     by (rule prob_space_imp_subprob_space)
   show ?thesis
     unfolding measure_pmf.emeasure_eq_measure
     apply (subst N[unfolded stationary_distribution_def])
     apply (simp add: measure_pmf_bind)
     apply (subst measure_pmf.measure_bind[where N="count_space UNIV"])
     apply (rule measurable_compose[OF _ measurable_measure_pmf])
     apply (auto intro!: nn_integral_eq_integral[symmetric] measure_pmf.integrable_const_bound[where B=1])
     done
 qed
 
 lemma communicatingD1:
   "C \<in> UNIV // communicating \<Longrightarrow> (a, b) \<in> communicating \<Longrightarrow> a \<in> C \<Longrightarrow> b \<in> C"
   by (auto elim!: quotientE) (auto simp add: communicating_def)
 
 lemma communicatingD2:
   "C \<in> UNIV // communicating \<Longrightarrow> (a, b) \<in> communicating \<Longrightarrow> b \<in> C \<Longrightarrow> a \<in> C"
   by (auto elim!: quotientE) (auto simp add: communicating_def)
 
 lemma acc_iff: "(x, y) \<in> acc \<longleftrightarrow> (\<exists>n. 0 < p x y n)"
   by (blast intro: accD_pos accI_pos)
 
 lemma communicating_iff: "(x, y) \<in> communicating \<longleftrightarrow> (\<exists>n. 0 < p x y n) \<and> (\<exists>n. 0 < p y x n)"
   by (auto simp add: acc_iff communicating_def)
 
 end
 
 context MC_pair
 begin
 
 lemma p_eq_p1_p2:
   "p (x1, x2) (y1, y2) n = K1.p x1 y1 n * K2.p x2 y2 n"
   unfolding p_def K1.p_def K2.p_def
   by (subst prod_eq_prob_T)
      (auto intro!: arg_cong2[where f=measure] split: nat.splits simp: Stream_snth)
 
 lemma P_accD:
   assumes "((x1, x2), (y1, y2)) \<in> acc"shows "(x1, y1) \<in> K1.acc" "(x2, y2) \<in> K2.acc"
   using assms by (auto simp: acc_iff K1.acc_iff K2.acc_iff p_eq_p1_p2 zero_less_mult_iff not_le[of 0, symmetric]
                        cong: conj_cong)
 
 lemma aperiodicI_pair:
   assumes C1: "K1.aperiodic C1" and C2: "K2.aperiodic C2"
   shows "aperiodic (C1 \<times> C2)"
   unfolding aperiodic_eventually_recurrent
 proof safe
   from C1[unfolded K1.aperiodic_eventually_recurrent] C2[unfolded K2.aperiodic_eventually_recurrent]
   have C1: "C1 \<in> UNIV // K1.communicating" and C2: "C2 \<in> UNIV // K2.communicating" and
     ev: "\<And>x. x \<in> C1 \<Longrightarrow> eventually (\<lambda>m. 0 < K1.p x x m) sequentially" "\<And>x. x \<in> C2 \<Longrightarrow> eventually (\<lambda>m. 0 < K2.p x x m) sequentially"
     by auto
   { fix x1 x2 assume x: "x1 \<in> C1" "x2 \<in> C2"
     from ev(1)[OF x(1)] ev(2)[OF x(2)]
     show "eventually (\<lambda>m. 0 < p (x1, x2) (x1, x2) m) sequentially"
        by eventually_elim  (simp add: p_eq_p1_p2 x) }
 
   { fix x1 x2 y1 y2
     assume acc: "(x1, y1) \<in> K1.acc" "(x2, y2) \<in> K2.acc" "x1 \<in> C1" "y1 \<in> C1" "x2 \<in> C2" "y2 \<in> C2"
     then obtain k l where "0 < K1.p x1 y1 l" "0 < K2.p x2 y2 k"
       by (auto dest!: K1.accD_pos K2.accD_pos)
     with acc ev(1)[of y1] ev(2)[of y2]
     have "eventually (\<lambda>m. 0 < K1.p x1 y1 l * K1.p y1 y1 m \<and> 0 < K2.p x2 y2 k * K2.p y2 y2 m) sequentially"
       by (auto elim: eventually_elim2)
     then have "eventually (\<lambda>m. 0 < K1.p x1 y1 (m + l) \<and> 0 < K2.p x2 y2 (m + k)) sequentially"
     proof eventually_elim
       fix m assume "0 < K1.p x1 y1 l * K1.p y1 y1 m \<and> 0 < K2.p x2 y2 k * K2.p y2 y2 m"
       with acc
         K1.prob_reachable_le[of l "l + m" x1 y1 y1]
         K2.prob_reachable_le[of k "k + m" x2 y2 y2]
       show "0 < K1.p x1 y1 (m + l) \<and> 0 < K2.p x2 y2 (m + k)"
         by (auto simp add: ac_simps)
     qed
     then have "eventually (\<lambda>m. 0 < K1.p x1 y1 m \<and> 0 < K2.p x2 y2 m) sequentially"
       unfolding eventually_conj_iff by (subst (asm) (1 2) eventually_sequentially_seg) (auto elim: eventually_elim2)
     then obtain N where "0 < K1.p x1 y1 N" "0 < K2.p x2 y2 N"
       by (auto simp: eventually_sequentially)
     with acc have "0 < p (x1, x2) (y1, y2) N"
       by (auto simp add: p_eq_p1_p2)
     with acc have "((x1, x2), (y1, y2)) \<in> acc"
       by (auto intro!: accI_pos) }
   note 1 = this
 
   { fix x1 x2 y1 y2 assume acc:"((x1, x2), (y1, y2)) \<in> acc"
     moreover from acc obtain k where "0 < p (x1, x2) (y1, y2) k" by (auto dest!: accD_pos)
     ultimately have "(x1, y1) \<in> K1.acc \<and> (x2, y2) \<in> K2.acc"
       by (subst (asm) p_eq_p1_p2)
          (auto intro!: K1.accI_pos K2.accI_pos simp: zero_less_mult_iff not_le[of 0, symmetric]) }
   note 2 = this
 
   from K1.not_empty_irreducible[OF C1] K2.not_empty_irreducible[OF C2]
   obtain x1 x2 where xC: "x1 \<in> C1" "x2 \<in> C2" by auto
   show "C1 \<times> C2 \<in> UNIV // communicating"
     apply (simp add: quotient_def Image_def)
     apply (safe intro!: exI[of _ x1] exI[of _ x2])
   proof -
     fix y1 y2 assume yC: "y1 \<in> C1" "y2 \<in> C2"
     from K1.irreducibleD[OF C1 \<open>x1 \<in> C1\<close> \<open>y1 \<in> C1\<close>] K2.irreducibleD[OF C2 \<open>x2 \<in> C2\<close> \<open>y2 \<in> C2\<close>]
     show "((x1, x2), (y1, y2)) \<in> communicating"
       using 1[of x1 y1 x2 y2] 1[of y1 x1 y2 x2] xC yC
       by (auto simp: communicating_def K1.communicating_def K2.communicating_def)
   next
     fix y1 y2 assume "((x1, x2), (y1, y2)) \<in> communicating"
     with 2[of x1 x2 y1 y2] 2[of y1 y2 x1 x2]
     have "(x1, y1) \<in> K1.communicating" "(x2, y2) \<in> K2.communicating"
       by (auto simp: communicating_def K1.communicating_def K2.communicating_def)
     with xC show "y1 \<in> C1" "y2 \<in> C2"
       using K1.communicatingD1[OF C1] K2.communicatingD1[OF C2] by auto
   qed
 qed
 
 lemma stationary_distributionI_pair:
   assumes N1: "K1.stationary_distribution N1"
   assumes N2: "K2.stationary_distribution N2"
   shows "stationary_distribution (pair_pmf N1 N2)"
   unfolding stationary_distribution_def
   unfolding Kp_def pair_pmf_def
   apply (subst N1[unfolded K1.stationary_distribution_def])
   apply (subst N2[unfolded K2.stationary_distribution_def])
   apply (simp add: bind_assoc_pmf bind_return_pmf)
   apply (subst bind_commute_pmf[of N2])
   apply simp
   done
 
 end
 
 context MC_syntax
 begin
 
 lemma stationary_distribution_imp_limit:
   assumes C: "aperiodic C" "essential_class C" "countable C" and N: "stationary_distribution N" "N \<subseteq> C"
   assumes [simp]: "y \<in> C"
   shows "(\<lambda>n. \<integral>x. \<bar>p y x n - pmf N x\<bar> \<partial>count_space C) \<longlonglongrightarrow> 0"
     (is "?L \<longlonglongrightarrow> 0")
 proof -
   from \<open>essential_class C\<close> have C_comm: "C \<in> UNIV // communicating"
     by (simp add: essential_class_def)
 
   define K' where "K' = (\<lambda>Some x \<Rightarrow> map_pmf Some (K x) | None \<Rightarrow> map_pmf Some N)"
 
   interpret K2: MC_syntax K' .
   interpret KN: MC_pair K K' .
 
   from stationary_distributionD[OF C(2,3) N]
   have pos: "\<And>x. x \<in> C \<Longrightarrow> pos_recurrent x" and "measure_pmf N = stat C" by auto
 
   have pos: "\<And>x. x \<in> C \<Longrightarrow> 0 < emeasure N {x}"
     using pos unfolding stat_def \<open>measure_pmf N = stat C\<close>
     by (subst emeasure_point_measure_finite2)
        (auto simp: U'_def pos_recurrent_def nn_integral_add ennreal_zero_less_divide less_top)
   then have rpos: "\<And>x. x \<in> C \<Longrightarrow> 0 < pmf N x"
     by (simp add: measure_pmf.emeasure_eq_measure pmf.rep_eq)
 
   have eq: "\<And>x y. (if x = y then 1 else 0) = indicator {y} x" by auto
 
   have intK: "\<And>f x. (\<integral>x. (f x :: real) \<partial>K' (Some x)) = (\<integral>x. f (Some x) \<partial>K x)"
     by (simp add: K'_def integral_distr map_pmf_rep_eq)
 
   { fix m and x y :: 's
     have "K2.p (Some x) (Some y) m = p x y m"
       by (induct m arbitrary: x)
          (auto intro!: integral_cong simp add: K2.p_Suc' p_Suc' intK K2.p_0 p_0) }
   note K_p_eq = this
 
   { fix n and x :: 's have "K2.p (Some x) None n = 0"
       by (induct n arbitrary: x) (auto simp: K2.p_Suc' K2.p_0 intK cong: integral_cong) }
   note K_S_None = this
 
   from not_empty_irreducible[OF C_comm] obtain c0 where c0: "c0 \<in> C" by auto
 
   have K2_acc: "\<And>x y. (Some x, y) \<in> K2.acc \<longleftrightarrow> (\<exists>z. y = Some z \<and> (x, z) \<in> acc)"
     apply (auto simp: K2.acc_iff acc_iff K_p_eq)
     apply (case_tac y)
     apply (auto simp: K_p_eq K_S_None)
     done
 
   have K2_communicating: "\<And>c x. c \<in> C \<Longrightarrow> (Some c, x) \<in> K2.communicating \<longleftrightarrow> (\<exists>c'\<in>C. x = Some c')"
   proof safe
     fix x c assume "c \<in> C" "(Some c, x) \<in> K2.communicating"
     then show "\<exists>c'\<in>C. x = Some c'"
       by (cases x)
          (auto simp: communicating_iff K2.communicating_iff K_p_eq K_S_None intro!: irreducibleD2[OF C_comm \<open>c\<in>C\<close>])
   next
     fix c c' x assume "c \<in> C" "c' \<in> C"
     with irreducibleD[OF C_comm this] show "(Some c, Some c') \<in> K2.communicating"
       by (auto simp: K2.communicating_iff communicating_iff K_p_eq)
   qed
 
   have "Some ` C \<in> UNIV // K2.communicating"
     by (auto simp add: quotient_def Image_def c0 K2_communicating
              intro!: exI[of _ "Some c0"])
   then have "K2.essential_class (Some ` C)"
     by (rule K2.essential_classI)
        (auto simp: K2_acc essential_classD2[OF \<open>essential_class C\<close>])
 
   have "K2.aperiodic (Some ` C)"
     unfolding K2.aperiodic_eventually_recurrent
   proof safe
     fix x assume "x \<in> C" then show "eventually (\<lambda>m. 0 < K2.p (Some x) (Some x) m) sequentially"
       using \<open>aperiodic C\<close> unfolding aperiodic_eventually_recurrent
       by (auto elim!: eventually_mono simp: K_p_eq)
   qed fact
   then have aperiodic: "KN.aperiodic (C \<times> Some ` C)"
     by (rule KN.aperiodicI_pair[OF \<open>aperiodic C\<close>])
 
   have KN_essential: "KN.essential_class (C \<times> Some ` C)"
   proof (rule KN.essential_classI)
     show "C \<times> Some ` C \<in> UNIV // KN.communicating"
       using aperiodic by (simp add: KN.aperiodic_def)
   next
     fix x y assume "x \<in> C \<times> Some ` C" "(x, y) \<in> KN.acc"
     with KN.P_accD[of "fst x" "snd x" "fst y" "snd y"]
     show "y \<in> C \<times> Some ` C"
       by (cases x y rule: prod.exhaust[case_product prod.exhaust])
          (auto simp: K2_acc essential_classD2[OF \<open>essential_class C\<close>])
   qed
 
   { fix n and x y :: 's
     have "measure N {y} = \<P>(\<omega> in K2.T None. (None ## \<omega>) !! (Suc n) = Some y)"
       unfolding stationary_distribution_iterate'[OF N(1), of y n]
       apply (subst K2.p_def[symmetric])
       apply (subst K2.p_Suc')
       apply (subst K'_def)
       apply (simp add: map_pmf_rep_eq integral_distr K_p_eq)
       done
     then have "measure N {y} = \<P>(\<omega> in K2.T None. \<omega> !! n = Some y)"
       by simp }
   note measure_y_eq = this
 
   define D where "D = {x::'s \<times> 's option. Some (fst x) = snd x}"
 
   have [measurable]:
     "\<And>P::('s \<times> 's option \<Rightarrow> bool). P \<in> measurable (count_space UNIV) (count_space UNIV)"
     by simp
 
   { fix n and x :: 's
     have "\<P>(\<omega> in KN.T (y, None). \<exists>i<n. snd (\<omega> !! n) = Some x \<and> ev_at (HLD D) i \<omega>) =
       (\<Sum>i<n. \<P>(\<omega> in KN.T (y, None). snd (\<omega> !! n) = Some x \<and> ev_at (HLD D) i \<omega>))"
       by (subst KN.T.finite_measure_finite_Union[symmetric])
          (auto simp: disjoint_family_on_def intro!: arg_cong2[where f=measure] dest: ev_at_unique)
     also have "\<dots> = (\<Sum>i<n. \<P>(\<omega> in KN.T (y, None). fst (\<omega> !! n) = x \<and> ev_at (HLD D) i \<omega>))"
     proof (intro sum.cong refl)
       fix i assume i: "i \<in> {..< n}"
       show "\<P>(\<omega> in KN.T (y, None). snd (\<omega> !! n) = Some x \<and> ev_at (HLD D) i \<omega>) =
         \<P>(\<omega> in KN.T (y, None). fst (\<omega> !! n) = x \<and> ev_at (HLD D) i \<omega>)"
         apply (subst (1 2) KN.prob_T_split[where n="Suc i"])
         apply (simp_all add: ev_at_shift snth_Stream del: stake.simps KN.space_T)
         unfolding ev_at_shift snth_Stream
       proof (intro Bochner_Integration.integral_cong refl)
         fix \<omega> :: "('s \<times> 's option) stream" let ?s = "\<lambda>\<omega>'. stake (Suc i) \<omega> @- \<omega>'"
         show "\<P>(\<omega>' in KN.T (\<omega> !! i). snd (?s \<omega>' !! n) = Some x \<and> ev_at (HLD D) i \<omega>) =
           \<P>(\<omega>' in KN.T (\<omega> !! i). fst (?s \<omega>' !! n) = x \<and> ev_at (HLD D) i \<omega>)"
         proof cases
           assume "ev_at (HLD D) i \<omega>"
           from ev_at_imp_snth[OF this]
           have eq: "snd (\<omega> !! i) = Some (fst (\<omega> !! i))"
             by (simp add: D_def HLD_iff)
 
           have "\<P>(\<omega>' in KN.T (\<omega> !! i). fst (\<omega>' !! (n - Suc i)) = x) =
             \<P>(\<omega>' in T (fst (\<omega> !! i)). \<omega>' !! (n - Suc i) = x) * \<P>(\<omega>' in K2.T (snd (\<omega> !! i)). True)"
             by (subst KN.prod_eq_prob_T) simp_all
           also have "\<dots> = p (fst (\<omega> !! i)) x (Suc (n - Suc i))"
             using K2.T.prob_space by (simp add: p_def)
           also have "\<dots> = K2.p (snd (\<omega> !! i)) (Some x) (Suc (n - Suc i))"
             by (simp add: K_p_eq eq)
           also have "\<dots> = \<P>(\<omega>' in T (fst (\<omega> !! i)). True) * \<P>(\<omega>' in K2.T (snd (\<omega> !! i)). \<omega>' !! (n - Suc i) = Some x)"
             using T.prob_space by (simp add: K2.p_def)
           also have "\<dots> = \<P>(\<omega>' in KN.T (\<omega> !! i). snd (\<omega>' !! (n - Suc i)) = Some x)"
             by (subst KN.prod_eq_prob_T) simp_all
           finally show ?thesis using \<open>ev_at (HLD D) i \<omega>\<close> i
             by (simp del: stake.simps)
         qed simp
       qed
     qed
     also have "\<dots> = \<P>(\<omega> in KN.T (y, None). (\<exists>i<n. fst (\<omega> !! n) = x \<and> ev_at (HLD D) i \<omega>))"
       by (subst KN.T.finite_measure_finite_Union[symmetric])
          (auto simp add: disjoint_family_on_def dest: ev_at_unique
                intro!: arg_cong2[where f=measure])
     finally have eq: "\<P>(\<omega> in KN.T (y, None). (\<exists>i<n. snd (\<omega> !! n) = Some x \<and> ev_at (HLD D) i \<omega>)) =
       \<P>(\<omega> in KN.T (y, None). (\<exists>i<n. fst (\<omega> !! n) = x \<and> ev_at (HLD D) i \<omega>))" .
 
     have "p y x (Suc n) - measure N {x} = \<P>(\<omega> in T y. \<omega> !! n = x) - \<P>(\<omega> in K2.T None. \<omega> !! n = Some x)"
       unfolding p_def by (subst measure_y_eq) simp_all
     also have "\<P>(\<omega> in T y. \<omega> !! n = x) = \<P>(\<omega> in T y. \<omega> !! n = x) * \<P>(\<omega> in K2.T None. True)"
       using K2.T.prob_space by simp
     also have "\<dots> = \<P>(\<omega> in KN.T (y, None). fst (\<omega> !! n) = x)"
       by (subst KN.prod_eq_prob_T) auto
     also have "\<dots> = \<P>(\<omega> in KN.T (y, None). (\<exists>i<n. fst (\<omega> !! n) = x \<and> ev_at (HLD D) i \<omega>)) +
       \<P>(\<omega> in KN.T (y, None). fst (\<omega> !! n) = x \<and> \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>))"
       by (subst KN.T.finite_measure_Union[symmetric])
          (auto intro!: arg_cong2[where f=measure])
     also have "\<P>(\<omega> in K2.T None. \<omega> !! n = Some x) = \<P>(\<omega> in T y. True) * \<P>(\<omega> in K2.T None. \<omega> !! n = Some x)"
       using T.prob_space by simp
     also have "\<dots> = \<P>(\<omega> in KN.T (y, None). snd (\<omega> !! n) = Some x)"
       by (subst KN.prod_eq_prob_T) auto
     also have "\<dots> = \<P>(\<omega> in KN.T (y, None). (\<exists>i<n. snd (\<omega> !! n) = Some x \<and> ev_at (HLD D) i \<omega>)) +
       \<P>(\<omega> in KN.T (y, None). snd (\<omega> !! n) = Some x \<and> \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>))"
       by (subst KN.T.finite_measure_Union[symmetric])
          (auto intro!: arg_cong2[where f=measure])
     finally have "\<bar> p y x (Suc n) - measure N {x} \<bar> =
       \<bar> \<P>(\<omega> in KN.T (y, None). fst (\<omega> !! n) = x \<and> \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>)) -
       \<P>(\<omega> in KN.T (y, None). snd (\<omega> !! n) = Some x \<and> \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>)) \<bar>"
       unfolding eq by (simp add: field_simps)
     also have "\<dots> \<le> \<bar> \<P>(\<omega> in KN.T (y, None). fst (\<omega> !! n) = x \<and> \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>)) \<bar> +
       \<bar> \<P>(\<omega> in KN.T (y, None). snd (\<omega> !! n) = Some x \<and> \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>)) \<bar>"
       by (rule abs_triangle_ineq4)
     also have "\<dots> \<le> \<P>(\<omega> in KN.T (y, None). fst (\<omega> !! n) = x \<and> \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>)) +
       \<P>(\<omega> in KN.T (y, None). snd (\<omega> !! n) = Some x \<and> \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>))"
       by simp
     finally have "\<bar> p y x (Suc n) - measure N {x} \<bar> \<le> \<dots>" . }
   note mono = this
 
   { fix n :: nat
     have "(\<integral>\<^sup>+x. \<bar> p y x (Suc n) - measure N {x} \<bar> \<partial>count_space C) \<le>
       (\<integral>\<^sup>+x. ennreal (\<P>(\<omega> in KN.T (y, None). fst (\<omega> !! n) = x \<and> \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>))) +
       ennreal (\<P>(\<omega> in KN.T (y, None). snd (\<omega> !! n) = Some x \<and> \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>))) \<partial>count_space C)"
       using mono by (intro nn_integral_mono) (simp add: ennreal_plus[symmetric] del: ennreal_plus)
     also have "\<dots> = (\<integral>\<^sup>+x. \<P>(\<omega> in KN.T (y, None). fst (\<omega> !! n) = x \<and> \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>)) \<partial>count_space C) +
       (\<integral>\<^sup>+x. \<P>(\<omega> in KN.T (y, None). snd (\<omega> !! n) = Some x \<and> \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>)) \<partial>count_space C)"
       by (subst nn_integral_add) auto
     also have "\<dots> = emeasure (KN.T (y, None)) (\<Union>x\<in>C. {\<omega>\<in>space (KN.T (y, None)). fst (\<omega> !! n) = x \<and> \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>)}) +
       emeasure (KN.T (y, None)) (\<Union>x\<in>C. {\<omega>\<in>space (KN.T (y, None)). snd (\<omega> !! n) = Some x \<and> \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>)})"
       by (subst (1 2) emeasure_UN_countable)
          (auto simp add: disjoint_family_on_def KN.T.emeasure_eq_measure C)
     also have "\<dots> \<le> ennreal (\<P>(\<omega> in KN.T (y, None). \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>))) + ennreal (\<P>(\<omega> in KN.T (y, None). \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>)))"
       unfolding KN.T.emeasure_eq_measure
       by (intro add_mono) (auto intro!: KN.T.finite_measure_mono)
     also have "\<dots> \<le> 2 * \<P>(\<omega> in KN.T (y, None). \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>))"
       by (simp add: ennreal_plus[symmetric] del: ennreal_plus)
     finally have "?L (Suc n) \<le> 2 * \<P>(\<omega> in KN.T (y, None). \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>))"
       by (auto intro!: integral_real_bounded simp add: pmf.rep_eq) }
   note le_2 = this
 
   have c0_D: "(c0, Some c0) \<in> D"
     by (simp add: D_def c0)
 
   let ?N' = "map_pmf Some N"
   interpret NP: pair_prob_space N ?N' ..
 
   have pos_recurrent: "\<forall>x\<in>C \<times> Some ` C. KN.pos_recurrent x"
   proof (rule KN.stationary_distributionD(1)[OF KN_essential _ KN.stationary_distributionI_pair[OF N(1)]])
     show "K2.stationary_distribution ?N'"
       unfolding K2.stationary_distribution_def
       by (subst N(1)[unfolded stationary_distribution_def])
          (auto intro!: bind_pmf_cong simp: K'_def map_pmf_def bind_assoc_pmf bind_return_pmf)
     show "countable (C \<times> Some`C)"
       using C by auto
     show "set_pmf (pair_pmf N (map_pmf Some N)) \<subseteq> C \<times> Some ` C"
       using \<open>N \<subseteq> C\<close> by auto
   qed
 
   from c0_D have "\<P>(\<omega> in KN.T (y, None). alw (not (HLD D)) \<omega>) \<le> \<P>(\<omega> in KN.T (y, None). alw (not (HLD {(c0, Some c0)})) \<omega>)"
     apply (auto intro!: KN.T.finite_measure_mono)
     apply (rule alw_mono, assumption)
     apply (auto simp: HLD_iff)
     done
   also have "\<dots> = 0"
     apply (rule KN.T.prob_eq_0_AE)
     apply (simp add: not_ev_iff[symmetric])
     apply (subst KN.AE_T_iff)
     apply simp
   proof
     fix t assume t: "t \<in> KN.Kp (y, None)"
     then obtain a b where t_eq: "t = (a, Some b)" "a \<in> K y" "b \<in> N"
       unfolding KN.Kp_def by (auto simp: K'_def)
     with \<open>y \<in> C\<close> have "a \<in> C"
       using essential_classD2[OF \<open>essential_class C\<close> \<open>y \<in> C\<close>] by auto
     have "b \<in> C"
       using \<open>N \<subseteq> C\<close> \<open>b \<in> N\<close> by auto
 
     from pos_recurrent[THEN bspec, of "(c0, Some c0)"]
     have recurrent_c0: "KN.recurrent (c0, Some c0)"
       by (simp add: KN.pos_recurrent_def c0)
     have "C \<times> Some ` C \<in> UNIV // KN.communicating"
       using aperiodic by (simp add: KN.aperiodic_def)
     then have "((c0, Some c0), t) \<in> KN.communicating"
       by (rule KN.irreducibleD) (simp_all add: t_eq c0 \<open>b \<in> C\<close> \<open>a \<in> C\<close>)
     then have "((c0, Some c0), t) \<in> KN.acc"
       by (simp add: KN.communicating_def)
     then have "KN.U t (c0, Some c0) = 1"
       by (rule KN.recurrent_acc(1)[OF recurrent_c0])
     then show "AE \<omega> in KN.T t. ev (HLD {(c0, Some c0)}) (t ## \<omega>)"
       unfolding KN.U_def by (subst (asm) KN.T.prob_Collect_eq_1) (auto simp add: ev_Stream)
   qed
   finally have "\<P>(\<omega> in KN.T (y, None). alw (not (HLD D)) \<omega>) = 0"
     by (intro antisym measure_nonneg)
 
   have "(\<lambda>n. \<P>(\<omega> in KN.T (y, None). \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>))) \<longlonglongrightarrow>
     measure (KN.T (y, None)) (\<Inter>n. {\<omega>\<in>space (KN.T (y, None)). \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>)})"
     by (rule KN.T.finite_Lim_measure_decseq) (auto simp: decseq_def)
   also have "(\<Inter>n. {\<omega>\<in>space (KN.T (y, None)). \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>)}) =
     {\<omega>\<in>space (KN.T (y, None)). alw (not (HLD D)) \<omega>}"
     by (auto simp: not_ev_iff[symmetric] ev_iff_ev_at)
   also have "\<P>(\<omega> in KN.T (y, None). alw (not (HLD D)) \<omega>) = 0" by fact
   finally have *: "(\<lambda>n. 2 * \<P>(\<omega> in KN.T (y, None). \<not> (\<exists>i<n. ev_at (HLD D) i \<omega>))) \<longlonglongrightarrow> 0"
     by (intro tendsto_eq_intros) auto
 
   show ?thesis
     apply (rule LIMSEQ_imp_Suc)
     apply (rule tendsto_sandwich[OF _ _ tendsto_const *])
     using le_2
     apply (simp_all add: integral_nonneg_AE)
     done
 qed
 
 lemma stationary_distribution_imp_p_limit:
   assumes "aperiodic C" "essential_class C" and [simp]: "countable C"
   assumes N: "stationary_distribution N" "N \<subseteq> C"
   assumes [simp]: "x \<in> C" "y \<in> C"
   shows "p x y \<longlonglongrightarrow> pmf N y"
 proof -
   define D where "D y n = \<bar>p x y n - pmf N y\<bar>" for y n
 
   from stationary_distribution_imp_limit[OF assms(1,2,3,4,5,6)]
   have INT: "(\<lambda>n. \<integral>y. D y n \<partial>count_space C) \<longlonglongrightarrow> 0"
     unfolding D_def .
 
   { fix n
     have "D y n \<le> (\<integral>z. D y n * indicator {y} z \<partial>count_space C)"
       by simp
     also have "\<dots> \<le> (\<integral>y. D y n \<partial>count_space C)"
       by (intro integral_mono)
          (auto split: split_indicator simp: D_def p_def disjoint_family_on_def
                intro!: Bochner_Integration.integrable_diff integrable_pmf T.integrable_measure)
     finally have "D y n \<le> (\<integral>y. D y n \<partial>count_space C)" . }
   note * = this
 
   have D_nonneg: "\<And>n. 0 \<le> D y n" by (simp add: D_def)
 
   have "D y \<longlonglongrightarrow> 0"
     by (rule tendsto_sandwich[OF _ _ tendsto_const INT])
        (auto simp: eventually_sequentially * D_nonneg)
   then show ?thesis
     using Lim_null[where l="pmf N y" and net=sequentially and f="p x y"]
     by (simp add: D_def [abs_def] tendsto_rabs_zero_iff)
 qed
 
 end
 
 lemma (in MC_syntax) essential_classI2:
   assumes "X \<noteq> {}"
   assumes accI: "\<And>x y. x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> (x, y) \<in> acc"
   assumes ED: "\<And>x y. x \<in> X \<Longrightarrow> y \<in> set_pmf (K x) \<Longrightarrow> y \<in> X"
   shows "essential_class X"
 proof (rule essential_classI)
   { fix x y assume "(x, y) \<in> acc" "x \<in> X"
     then show "y \<in> X"
       by induct (auto dest: ED)}
   note accD = this
   from \<open>X \<noteq> {}\<close> obtain x where "x \<in> X" by auto
   from \<open>x \<in> X\<close> show "X \<in> UNIV // communicating"
     by (auto simp add: quotient_def Image_def communicating_def accI dest: accD intro!: exI[of _ x])
 qed
 
 end
diff --git a/thys/Minsky_Machines/Minsky.thy b/thys/Minsky_Machines/Minsky.thy
--- a/thys/Minsky_Machines/Minsky.thy
+++ b/thys/Minsky_Machines/Minsky.thy
@@ -1,835 +1,835 @@
 section \<open>Minsky machines\<close>
 
 theory Minsky
-  imports Recursive_Inseparability "Abstract-Rewriting.Abstract_Rewriting"
+  imports Recursive_Inseparability "Abstract-Rewriting.Abstract_Rewriting" "Pure-ex.Guess"
 begin
 
 text \<open>We formalize Minksy machines, and relate them to recursive functions. In our flavor of
 Minsky machines, a machine has a set of registers and a set of labels, and a program is a set of
 labeled operations. There are two operations, @{term Inc} and @{term Dec}; the former takes a
 register and a label, and the latter takes a register and two labels. When an @{term Inc}
 instruction is executed, the register is incremented and execution continues at the provided label.
 The @{term Dec} instruction checks the register. If it is non-zero, the register and continues
 execution at the first label. Otherwise, the register remains at zero and execution continues at
 the second label.
 
 We continue to show that Minksy machines can implement any primitive recursive function. Based on
 that, we encode recursively enumerable sets as Minsky machines, and finally show that
 \begin{enumerate}
 \item The set of Minsky configurations such that from state $1$, state $0$ can be reached,
   is undecidable;
 \item There is a deterministic Minsky machine $U$ such that the set of values $x$ such that
   $(2, \lambda n.\, \text{if $n = 0$ then $x$ else $0$})$ reach state $0$ is recursively
   inseparable from those that reach state $1$; and
 \item As a corollary, the set of Minsky configurations that reach state $0$ but not state $1$ is
   recursively inseparable from the configurations that reach state $1$ but not state $0$.
 \end{enumerate}\<close>
 
 subsection \<open>Deterministic relations\<close>
 
 text \<open>A relation $\to$ is \emph{deterministic} if $t \from s \to u'$ implies $t = u$.
 This abstract rewriting notion is useful for talking about deterministic Minsky machines.\<close>
 
 definition
   "deterministic R \<longleftrightarrow> R\<inverse> O R \<subseteq> Id"
 
 lemma deterministicD:
   "deterministic R \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> (x, z) \<in> R \<Longrightarrow> y = z"
   by (auto simp: deterministic_def)
 
 lemma deterministic_empty [simp]:
   "deterministic {}"
   by (auto simp: deterministic_def)
 
 lemma deterministic_singleton [simp]:
   "deterministic {p}"
   by (auto simp: deterministic_def)
 
 lemma deterministic_imp_weak_diamond [intro]:
   "deterministic R \<Longrightarrow> w\<diamond> R"
   by (auto simp: weak_diamond_def deterministic_def)
 
 lemmas deterministic_imp_CR = deterministic_imp_weak_diamond[THEN weak_diamond_imp_CR]
 
 lemma deterministic_union:
   "fst ` S \<inter> fst ` R = {} \<Longrightarrow> deterministic S \<Longrightarrow> deterministic R \<Longrightarrow> deterministic (S \<union> R)"
   by (fastforce simp add: deterministic_def disjoint_iff_not_equal)
 
 lemma deterministic_map:
   "inj_on f (fst ` R) \<Longrightarrow> deterministic R \<Longrightarrow> deterministic (map_prod f g ` R)"
   by (auto simp add: deterministic_def dest!: inj_onD; force)
 
 
 subsection \<open>Minsky machine definition\<close>
 
 text \<open>A Minsky operation either decrements a register (testing for zero, with two possible
 successor states), or increments a register (with one successor state). A Minsky machine is a
 set of pairs of states and operations.\<close>
 
 datatype ('s, 'v) Op = Dec (op_var: 'v) 's 's | Inc (op_var: 'v) 's
 
 type_synonym ('s, 'v) minsky = "('s \<times> ('s, 'v) Op) set"
 
 text \<open>Semantics: A Minsky machine operates on pairs consisting of a state and an assignment of
 the registers; in each step, either a register is incremented, or a register is decremented,
 provided it is non-zero. We write $\alpha$ for assignments; $\alpha[v]$ for the value of the
 register $v$ in $\alpha$ and $\alpha[v := n]$ for the update of $v$ to $n$. Thus, the semantics
 is as follows:
 \begin{enumerate}
 \item if $(s, Inc\ v\ s') \in M$ then $(s, \alpha) \to (s', \alpha[v := \alpha[v] + 1]$);
 \item if $(s, Dec\ v\ s_n\ s_z) \in M$ and $\alpha[v] > 0$ then $(s, \alpha) \to (s_n, \alpha[v := \alpha[v] - 1]$); and
 \item if $(s, Dec\ v\ s_n\ s_z) \in M$ and $\alpha[v] = 0$ then $(s, \alpha) \to (s_z, \alpha)$.
 \end{enumerate}
 A state is finite if there is no operation associated with it.\<close>
 
 inductive_set step :: "('s, 'v) minsky \<Rightarrow> ('s \<times> ('v \<Rightarrow> nat)) rel" for M :: "('s, 'v) minsky" where
   inc: "(s, Inc v s') \<in> M \<Longrightarrow> ((s, vs), (s', \<lambda>x. if x = v then Suc (vs v) else vs x)) \<in> step M"
 | decn: "(s, Dec v sn sz) \<in> M \<Longrightarrow> vs v = Suc n \<Longrightarrow> ((s, vs), (sn, \<lambda>x. if x = v then n else vs x)) \<in> step M"
 | decz: "(s, Dec v sn sz) \<in> M \<Longrightarrow> vs v = 0 \<Longrightarrow> ((s, vs), (sz, vs)) \<in> step M"
 
 lemma step_mono:
   "M \<subseteq> M' \<Longrightarrow> step M \<subseteq> step M'"
   by (auto elim: step.cases intro: step.intros)
 
 lemmas steps_mono = rtrancl_mono[OF step_mono]
 
 text \<open>A Minsky machine has deterministic steps if its defining relation between states and
 operations is deterministic.\<close>
 
 lemma deterministic_stepI [intro]:
   assumes "deterministic M" shows "deterministic (step M)"
 proof -
   { fix s vs s1 vs1 s2 vs2
     assume s: "((s, vs), (s1, vs1)) \<in> step M" "((s, vs), (s2, vs2)) \<in> step M"
     have "(s1, vs1) = (s2, vs2)" using deterministicD[OF assms]
       by (cases rule: step.cases[OF s(1)]; cases rule: step.cases[OF s(2)]) fastforce+ }
   then show ?thesis by (auto simp: deterministic_def)
 qed
 
 text \<open>A Minksy machine halts when it reaches a state with no associated operation.\<close>
 
 lemma NF_stepI [intro]:
   "s \<notin> fst ` M \<Longrightarrow> (s, vs) \<in> NF (step M)"
   by (auto intro!: no_step elim!: step.cases simp: rev_image_eqI)
 
 text \<open>Deterministic Minsky machines enjoy unique normal forms.\<close>
 
 lemmas deterministic_minsky_UN =
   join_NF_imp_eq[OF CR_divergence_imp_join[OF deterministic_imp_CR[OF deterministic_stepI]] NF_stepI NF_stepI]
 
 text \<open>We will rename states and variables.\<close>
 
 definition map_minsky where
   "map_minsky f g M = map_prod f (map_Op f g) ` M"
 
 lemma map_minsky_id:
   "map_minsky id id M = M"
   by (simp add: map_minsky_def Op.map_id0 map_prod.id)
 
 lemma map_minsky_comp:
   "map_minsky f g (map_minsky f' g' M) = map_minsky (f \<circ> f') (g \<circ> g') M"
   unfolding map_minsky_def image_comp Op.map_comp map_prod.comp comp_def[of "map_Op _ _"] ..
 
 text \<open>When states and variables are renamed, computations carry over from the original machine,
 provided that variables are renamed injectively.\<close>
 
 lemma map_step:
   assumes "inj g" "vs = vs' \<circ> g" "((s, vs), (t, ws)) \<in> step M"
   shows "((f s, vs'), (f t, \<lambda>x. if x \<in> range g then ws (inv g x) else vs' x)) \<in> step (map_minsky f g M)"
   using assms(3)
 proof (cases rule: step.cases)
   case (inc v) note [simp] = inc(1)
   let ?ws' = "\<lambda>w. if w = g v then Suc (vs' (g v)) else vs' w"
   have "((f s, vs'), (f t, ?ws')) \<in> step (map_minsky f g M)"
     using inc(2) step.inc[of "f s" "g v" "f t" "map_minsky f g M" vs']
     by (force simp: map_minsky_def)
   moreover have "(\<lambda>x. if x \<in> range g then ws (inv g x) else vs' x) = ?ws'"
     using assms(1,2) by (auto intro!: ext simp: injD image_def)
   ultimately show ?thesis by auto
 next
   case (decn v sz n) note [simp] = decn(1)
   let ?ws' = "\<lambda>x. if x = g v then n else vs' x"
   have "((f s, vs'), (f t, ?ws')) \<in> step (map_minsky f g M)"
     using assms(2) decn(2-) step.decn[of "f s" "g v" "f t" "f sz" "map_minsky f g M" vs' n]
     by (force simp: map_minsky_def)
   moreover have "(\<lambda>x. if x \<in> range g then ws (inv g x) else vs' x) = ?ws'"
     using assms(1,2) by (auto intro!: ext simp: injD image_def)
   ultimately show ?thesis by auto
 next
   case (decz v sn) note [simp] = decz(1)
   have "((f s, vs'), (f t, vs')) \<in> step (map_minsky f g M)"
     using assms(2) decz(2-) step.decz[of "f s" "g v" "f sn" "f t" "map_minsky f g M" vs']
     by (force simp: map_minsky_def)
   moreover have "(\<lambda>x. if x \<in> range g then ws (inv g x) else vs' x) = vs'"
     using assms(1,2) by (auto intro!: ext simp: injD image_def)
   ultimately show ?thesis by auto
 qed
 
 lemma map_steps:
   assumes "inj g" "vs = ws \<circ> g" "((s, vs), (t, vs')) \<in> (step M)\<^sup>*"
   shows "((f s, ws), (f t, \<lambda>x. if x \<in> range g then vs' (inv g x) else ws x)) \<in> (step (map_minsky f g M))\<^sup>*"
   using assms(3,2)
 proof (induct "(s, vs)" arbitrary: s vs ws rule: converse_rtrancl_induct)
   case base
   then have "(\<lambda>x. if x \<in> range g then vs' (inv g x) else ws x) = ws"
     using assms(1) by (auto intro!: ext simp: injD image_def)
   then show ?case by auto
 next
   case (step y)
   have "snd y = (\<lambda>x. if x \<in> range g then snd y (inv g x) else ws x) \<circ> g" (is "_ = ?ys' \<circ> _")
     using assms(1) by auto
   then show ?case  using map_step[OF assms(1) step(4), of s "fst y" "snd y" M f] step(1)
     step(3)[OF prod.collapse[symmetric], of ?ys'] by (auto cong: if_cong)
 qed
 
 subsection \<open>Concrete Minsky machines\<close>
 
 text \<open>The following definition expresses when a Minsky machine $M$ implements a specification $P$.
 We adopt the convention that computations always start out in state $1$ and end in state $0$, which
 must be a final state. The specification $P$ relates initial assignments to final assignments.\<close>
 
 definition mk_minsky_wit :: "(nat, nat) minsky \<Rightarrow> ((nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool) \<Rightarrow> bool" where
   "mk_minsky_wit M P \<equiv> finite M \<and> deterministic M \<and> 0 \<notin> fst ` M \<and>
      (\<forall>vs. \<exists>vs'. ((Suc 0, vs), (0, vs')) \<in> (step M)\<^sup>* \<and> P vs vs')"
 
 abbreviation mk_minsky :: "((nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool) \<Rightarrow> bool" where
   "mk_minsky P \<equiv> \<exists>M. mk_minsky_wit M P"
 
 lemmas mk_minsky_def = mk_minsky_wit_def
 
 lemma mk_minsky_mono:
   shows "mk_minsky P \<Longrightarrow> (\<And>vs vs'. P vs vs' \<Longrightarrow> Q vs vs') \<Longrightarrow> mk_minsky Q"
   unfolding mk_minsky_def by meson
 
 lemma mk_minsky_sound:
   assumes "mk_minsky_wit M P" "((Suc 0, vs), (0, vs')) \<in> (step M)\<^sup>*"
   shows "P vs vs'"
 proof -
   have M: "deterministic M" "0 \<notin> fst ` M" "\<And>vs. \<exists>vs'. ((Suc 0, vs), 0, vs') \<in> (step M)\<^sup>* \<and> P vs vs'"
     using assms(1) by (auto simp: mk_minsky_wit_def)
   obtain vs'' where vs'': "((Suc 0, vs), (0, vs'')) \<in> (step M)\<^sup>*" "P vs vs''" using M(3) by blast
   have "(0 :: nat, vs') = (0, vs'')" using M(1,2)
     by (intro deterministic_minsky_UN[OF _ assms(2) vs''(1)])
   then show ?thesis using vs''(2) by simp
 qed
 
 text \<open>Realizability of $n$-ary functions for $n = 1 \dots 3$. Here we use the convention that the
 arguments are passed in registers $1 \dots 3$, and the result is stored in register $0$.\<close>
 
 abbreviation mk_minsky1 where
   "mk_minsky1 f \<equiv> mk_minsky (\<lambda>vs vs'. vs' 0 = f (vs 1))"
 
 abbreviation mk_minsky2 where
   "mk_minsky2 f \<equiv> mk_minsky (\<lambda>vs vs'. vs' 0 = f (vs 1) (vs 2))"
 
 abbreviation mk_minsky3 where
   "mk_minsky3 f \<equiv> mk_minsky (\<lambda>vs vs'. vs' 0 = f (vs 1) (vs 2) (vs 3))"
 
 subsection \<open>Trivial building blocks\<close>
 
 text \<open>We can increment and decrement any register.\<close>
 
 lemma mk_minsky_inc:
   shows "mk_minsky (\<lambda>vs vs'. vs' = (\<lambda>x. if x = v then Suc (vs v) else vs x))"
   using step.inc[of "Suc 0" v 0]
   by (auto simp: deterministic_def mk_minsky_def intro!: exI[of _ "{(1, Inc v 0)} :: (nat, nat) minsky"])
 
 lemma mk_minsky_dec:
   shows "mk_minsky (\<lambda>vs vs'. vs' = (\<lambda>x. if x = v then vs v - 1 else vs x))"
 proof -
   let ?M = "{(1, Dec v 0 0)} :: (nat, nat) minsky"
   show ?thesis unfolding mk_minsky_def
   proof (intro exI[of _ ?M] allI conjI, goal_cases)
     case (4 vs)
     have [simp]: "vs v = 0 \<Longrightarrow> (\<lambda>x. if x = v then 0 else vs x) = vs" by auto
     show ?case using step.decz[of "Suc 0" v 0 0 ?M] step.decn[of "Suc 0" v 0 0 ?M]
       by (cases "vs v") (auto cong: if_cong)
   qed auto
 qed
 
 subsection \<open>Sequential composition\<close>
 
 text \<open>The following lemma has two useful corollaries (which we prove simultaneously because they
 share much of the proof structure): First, if $P$ and $Q$ are realizable, then so is $P \circ Q$.
 Secondly, if we rename variables by an injective function $f$ in a Minksy machine, then the
 variables outside the range of $f$ remain unchanged.\<close>
 
 lemma mk_minsky_seq_map:
   assumes "mk_minsky P" "mk_minsky Q" "inj g"
     "\<And>vs vs' vs''. P vs vs' \<Longrightarrow> Q vs' vs'' \<Longrightarrow> R vs vs''"
   shows "mk_minsky (\<lambda>vs vs'. R (vs \<circ> g) (vs' \<circ> g) \<and> (\<forall>x. x \<notin> range g \<longrightarrow> vs x = vs' x))"
 proof -
   obtain M where M: "finite M" "deterministic M" "0 \<notin> fst ` M"
     "\<And>vs. \<exists>vs'. ((Suc 0, vs), 0, vs') \<in> (step M)\<^sup>* \<and> P vs vs'"
     using assms(1) by (auto simp: mk_minsky_def)
   obtain N where N: "finite N" "deterministic N" "0 \<notin> fst ` N"
     "\<And>vs. \<exists>vs'. ((Suc 0, vs), 0, vs') \<in> (step N)\<^sup>* \<and> Q vs vs'"
     using assms(2) by (auto simp: mk_minsky_def)
   let ?fM = "\<lambda>s. if s = 0 then 2 else if s = 1 then 1 else 2 * s + 1" \<comment> \<open>M: from 1 to 2\<close>
   let ?fN = "\<lambda>s. 2 * s"                                               \<comment> \<open>N: from 2 to 0\<close>
   let ?M = "map_minsky ?fM g M \<union> map_minsky ?fN g N"
   show ?thesis unfolding mk_minsky_def
   proof (intro exI[of _ ?M] conjI allI, goal_cases)
     case 1 show ?case using M(1) N(1) by (auto simp: map_minsky_def)
   next
     case 2 show ?case using M(2,3) N(2) unfolding map_minsky_def
       by (intro deterministic_union deterministic_map)
         (auto simp: inj_on_def rev_image_eqI Suc_double_not_eq_double split: if_splits)
   next
     case 3 show ?case using N(3) by (auto simp: rev_image_eqI map_minsky_def split: if_splits)
   next
     case (4 vs)
     obtain vsM where M': "((Suc 0, vs \<circ> g), 0, vsM) \<in> (step M)\<^sup>*" "P (vs \<circ> g) vsM"
       using M(4) by blast
     obtain vsN where N': "((Suc 0, vsM), 0, vsN) \<in> (step N)\<^sup>*" "Q vsM vsN"
       using N(4) by blast
     note * = subsetD[OF steps_mono, of _ ?M]
       map_steps[OF _ _ M'(1), of g vs ?fM, simplified]
       map_steps[OF _ _ N'(1), of g _ ?fN, simplified]
     show ?case
       using assms(3,4) M'(2) N'(2) rtrancl_trans[OF *(1)[OF _ *(2)] *(1)[OF _ *(3)]]
       by (auto simp: comp_def)
   qed
 qed
 
 text \<open>Sequential composition.\<close>
 
 lemma mk_minsky_seq:
   assumes "mk_minsky P" "mk_minsky Q"
     "\<And>vs vs' vs''. P vs vs' \<Longrightarrow> Q vs' vs'' \<Longrightarrow> R vs vs''"
   shows "mk_minsky R"
   using mk_minsky_seq_map[OF assms(1,2), of id] assms(3) by simp
 
 lemma mk_minsky_seq':
   assumes "mk_minsky P" "mk_minsky Q"
   shows "mk_minsky (\<lambda>vs vs''. (\<exists>vs'. P vs vs' \<and> Q vs' vs''))"
   by (intro mk_minsky_seq[OF assms]) blast
 
 text \<open>We can do nothing (besides transitioning from state 1 to state 0).\<close>
 
 lemma mk_minsky_nop:
   "mk_minsky (\<lambda>vs vs'. vs = vs')"
   by (intro mk_minsky_seq[OF mk_minsky_inc mk_minsky_dec]) auto
 
 text \<open>Renaming variables.\<close>
 
 lemma mk_minsky_map:
   assumes "mk_minsky P" "inj f"
   shows "mk_minsky (\<lambda>vs vs'. P (vs \<circ> f) (vs' \<circ> f) \<and> (\<forall>x. x \<notin> range f \<longrightarrow> vs x = vs' x))"
   using mk_minsky_seq_map[OF assms(1) mk_minsky_nop assms(2)] by simp
 
 lemma inj_shift [simp]:
   fixes a b :: nat
   assumes "a < b"
   shows "inj (\<lambda>x. if x = 0 then a else x + b)"
   using assms by (auto simp: inj_on_def)
 
 subsection \<open>Bounded loop\<close>
 
 text \<open>In the following lemma, $P$ is the specification of a loop body, and $Q$ the specification
 of the loop itself (a loop invariant). The loop variable is $v$. $Q$ can be realized provided that
 \begin{enumerate}
 \item $P$ can be realized;
 \item $P$ ensures that the loop variable is not changed by the loop body; and
 \item $Q$ follows by induction on the loop variable:
   \begin{enumerate}
   \item $\alpha\,Q\,\alpha$ holds when $\alpha[v] = 0$; and
   \item $\alpha[v := n]\,P\,\alpha'$ and $\alpha'\,Q\,\alpha''$ imply $\alpha\,Q\,alpha''$
     when $\alpha[v] = n+1$.
   \end{enumerate}
 \end{enumerate}\<close>
 
 lemma mk_minsky_loop:
   assumes "mk_minsky P"
     "\<And>vs vs'. P vs vs' \<Longrightarrow> vs' v = vs v"
     "\<And>vs. vs v = 0 \<Longrightarrow> Q vs vs"
     "\<And>n vs vs' vs''. vs v = Suc n \<Longrightarrow> P (\<lambda>x. if x = v then n else vs x) vs' \<Longrightarrow> Q vs' vs'' \<Longrightarrow> Q vs vs''"
   shows "mk_minsky Q"
 proof -
   obtain M where M: "finite M" "deterministic M" "0 \<notin> fst ` M"
     "\<And>vs. \<exists>vs'. ((Suc 0, vs), 0, vs') \<in> (step M)\<^sup>* \<and> P vs vs'"
     using assms(1) by (auto simp: mk_minsky_def)
   let ?M = "{(1, Dec v 2 0)} \<union> map_minsky Suc id M"
   show ?thesis unfolding mk_minsky_def
   proof (intro exI[of _ ?M] conjI allI, goal_cases)
     case 1 show ?case using M(1) by (auto simp: map_minsky_def)
   next
     case 2 show ?case using M(2,3) unfolding map_minsky_def
       by (intro deterministic_union deterministic_map) (auto simp: rev_image_eqI)
   next
     case 3 show ?case by (auto simp: map_minsky_def)
   next
     case (4 vs) show ?case
     proof (induct "vs v" arbitrary: vs)
       case 0 then show ?case using assms(3)[of vs] step.decz[of 1 v 2 0 ?M vs]
         by (auto simp: id_def)
     next
       case (Suc n)
       obtain vs' where M': "((Suc 0, \<lambda>x. if x = v then n else vs x), 0, vs') \<in> (step M)\<^sup>*"
         "P (\<lambda>x. if x = v then n else vs x) vs'" using M(4) by blast
       obtain vs'' where D: "((Suc 0, vs'), 0, vs'') \<in> (step ?M)\<^sup>*" "Q vs' vs''"
         using Suc(1)[of vs'] assms(2)[OF M'(2)] by auto
       note * = subsetD[OF steps_mono, of _ ?M]
         r_into_rtrancl[OF decn[of "Suc 0" v 2 0 ?M vs n]]
         map_steps[OF _ _ M'(1), of id _ Suc, simplified, OF refl, simplified, folded numeral_2_eq_2]
       show ?case using rtrancl_trans[OF rtrancl_trans, OF *(2) *(1)[OF _ *(3)] D(1)]
         D(2) Suc(2) assms(4)[OF _ M'(2), of vs''] by auto
     qed
   qed
 qed
 
 subsection \<open>Copying values\<close>
 
 text \<open>We work up to copying values in several steps.
 \begin{enumerate}
 \item Clear a register. This is a loop that decrements the register until it reaches $0$.
 \item Add a register to another one. This is a loop that decrements one register, and increments
   the other register, until the first register reaches 0.
 \item Add a register to two others. This is the same, except that two registers are incremented.
 \item Move a register: set a register to 0, then add another register to it.
 \item Copy a register destructively: clear two registers, then add another register to them.
 \end{enumerate}\<close>
 
 lemma mk_minsky_zero:
   shows "mk_minsky (\<lambda>vs vs'. vs' = (\<lambda>x. if x = v then 0 else vs x))"
   by (intro mk_minsky_loop[where v = v, OF \<comment> \<open> while v[v]$--$: \<close>
     mk_minsky_nop]) auto                   \<comment> \<open>   pass          \<close>
 
 lemma mk_minsky_add1:
   assumes "v \<noteq> w"
   shows "mk_minsky (\<lambda>vs vs'. vs' = (\<lambda>x. if x = v then 0 else if x = w then vs v + vs w else vs x))"
   using assms by (intro mk_minsky_loop[where v = v, OF \<comment> \<open> while v[v]$--$: \<close>
     mk_minsky_inc[of w]]) auto                         \<comment> \<open>   v[w]++        \<close>
 
 lemma mk_minsky_add2:
   assumes "u \<noteq> v" "u \<noteq> w" "v \<noteq> w"
   shows "mk_minsky (\<lambda>vs vs'. vs' =
     (\<lambda>x. if x = u then 0 else if x = v then vs u + vs v else if x = w then vs u + vs w else vs x))"
   using assms by (intro mk_minsky_loop[where v = u, OF mk_minsky_seq'[OF \<comment> \<open> while v[u]$--$: \<close>
     mk_minsky_inc[of v]                                                  \<comment> \<open>   v[v]++        \<close>
     mk_minsky_inc[of w]]]) auto                                          \<comment> \<open>   v[w]++        \<close>
 
 lemma mk_minsky_copy1:
   assumes "v \<noteq> w"
   shows "mk_minsky (\<lambda>vs vs'. vs' = (\<lambda>x. if x = v then 0 else if x = w then vs v else vs x))"
   using assms by (intro mk_minsky_seq[OF
     mk_minsky_zero[of w]          \<comment> \<open> v[w] := 0                      \<close>
     mk_minsky_add1[of v w]]) auto \<comment> \<open> v[w] := v[w] + v[v], v[v] := 0 \<close>
 
 lemma mk_minsky_copy2:
   assumes "u \<noteq> v" "u \<noteq> w" "v \<noteq> w"
   shows "mk_minsky (\<lambda>vs vs'. vs' =
     (\<lambda>x. if x = u then 0 else if x = v then vs u else if x = w then vs u else vs x))"
   using assms by (intro mk_minsky_seq[OF mk_minsky_seq', OF
     mk_minsky_zero[of v]            \<comment> \<open> v[v] := 0                                           \<close>
     mk_minsky_zero[of w]            \<comment> \<open> v[w] := 0                                           \<close>
     mk_minsky_add2[of u v w]]) auto \<comment> \<open> v[v] := v[v] + v[u], v[w] := v[w] + v[u], v[u] := 0 \<close>
 
 lemma mk_minsky_copy:
   assumes "u \<noteq> v" "u \<noteq> w" "v \<noteq> w"
   shows "mk_minsky (\<lambda>vs vs'. vs' = (\<lambda>x. if x = v then vs u else if x = w then 0 else vs x))"
   using assms by (intro mk_minsky_seq[OF
     mk_minsky_copy2[of u v w]      \<comment> \<open> v[v] := v[u], v[w] := v[u], v[u] := 0 \<close>
     mk_minsky_copy1[of w u]]) auto \<comment> \<open> v[u] := v[w], v[w] := 0               \<close>
 
 subsection \<open>Primitive recursive functions\<close>
 
 text \<open>Nondestructive apply: compute $f$ on arguments $\alpha[u]$, $\alpha[v]$, $\alpha[w]$,
 storing the result in $\alpha[t]$ and preserving all other registers below $k$. This is easy
 now that we can copy values.\<close>
 
 lemma mk_minsky_apply3:
   assumes "mk_minsky3 f" "t < k" "u < k" "v < k" "w < k"
   shows "mk_minsky (\<lambda>vs vs'. \<forall>x < k. vs' x = (if x = t then f (vs u) (vs v) (vs w) else vs x))"
   using assms(2-)
   by (intro mk_minsky_seq[OF mk_minsky_seq'[OF mk_minsky_seq'], OF
     mk_minsky_copy[of u "1 + k" k] \<comment> \<open> v[1+k] := v[u] \<close>
     mk_minsky_copy[of v "2 + k" k] \<comment> \<open> v[2+k] := v[v] \<close>
     mk_minsky_copy[of w "3 + k" k] \<comment> \<open> v[3+k] := v[w] \<close>
     mk_minsky_map[OF assms(1), of "\<lambda>x. if x = 0 then t else x + k"]]) (auto 0 2)
                                    \<comment> \<open> v[t] := f v[1+k] v[2+k] v[3+k] \<close>
 
 text \<open>Composition is just four non-destructive applies.\<close>
 
 lemma mk_minsky_comp3_3:
   assumes "mk_minsky3 f" "mk_minsky3 g" "mk_minsky3 h" "mk_minsky3 k"
   shows "mk_minsky3 (\<lambda>x y z. f (g x y z) (h x y z) (k x y z))"
   by (rule mk_minsky_seq[OF mk_minsky_seq'[OF mk_minsky_seq'], OF
     mk_minsky_apply3[OF assms(2), of 4 7 1 2 3]        \<comment> \<open> v[4] := g v[1] v[2] v[3] \<close>
     mk_minsky_apply3[OF assms(3), of 5 7 1 2 3]        \<comment> \<open> v[5] := h v[1] v[2] v[3] \<close>
     mk_minsky_apply3[OF assms(4), of 6 7 1 2 3]        \<comment> \<open> v[6] := k v[1] v[2] v[3] \<close>
     mk_minsky_apply3[OF assms(1), of 0 7 4 5 6]]) auto \<comment> \<open> v[0] := f v[4] v[5] v[6] \<close>
 
 text \<open>Primitive recursion is a non-destructive apply followed by a loop with another
 non-destructive apply. The key to the proof is the loop invariant, which we can specify
 as part of composing the various \<open>mk_minsky_*\<close> lemmas.\<close>
 
 lemma mk_minsky_prim_rec:
   assumes "mk_minsky1 g" "mk_minsky3 h"
   shows "mk_minsky2 (PrimRecOp g h)"
   by (intro mk_minsky_seq[OF mk_minsky_seq', OF
     mk_minsky_apply3[OF assms(1), of 0 4 2 2 2]       \<comment> \<open> v[0] := g v[2]             \<close>
     mk_minsky_zero[of 3]                              \<comment> \<open> v[3] := 0                  \<close>
     mk_minsky_loop[where v = 1, OF mk_minsky_seq', OF \<comment> \<open> while v[1]$--$:            \<close>
       mk_minsky_apply3[OF assms(2), of 0 4 3 0 2]     \<comment> \<open>   v[0] := h v[3] v[0] v[2] \<close>
       mk_minsky_inc[of 3],                            \<comment> \<open>   v[3]++                   \<close>
       of "\<lambda>vs vs'. vs 0 = PrimRecOp g h (vs 3) (vs 2) \<longrightarrow> vs' 0 = PrimRecOp g h (vs 3 + vs 1) (vs 2)"
     ]]) auto
 
 text \<open>With these building blocks we can easily show that all primitive recursive functions can
 be realized by a Minsky machine.\<close>
 
 lemma mk_minsky_PrimRec:
   "f \<in> PrimRec1 \<Longrightarrow> mk_minsky1 f"
   "g \<in> PrimRec2 \<Longrightarrow> mk_minsky2 g"
   "h \<in> PrimRec3 \<Longrightarrow> mk_minsky3 h"
 proof (goal_cases)
   have *: "(f \<in> PrimRec1 \<longrightarrow> mk_minsky1 f) \<and> (g \<in> PrimRec2 \<longrightarrow> mk_minsky2 g) \<and> (h \<in> PrimRec3 \<longrightarrow> mk_minsky3 h)"
   proof (induction rule: PrimRec1_PrimRec2_PrimRec3.induct)
     case zero show ?case by (intro mk_minsky_mono[OF mk_minsky_zero]) auto
   next
     case suc show ?case by (intro mk_minsky_seq[OF mk_minsky_copy1[of 1 0] mk_minsky_inc[of 0]]) auto
   next
     case id1_1 show ?case by (intro mk_minsky_mono[OF mk_minsky_copy1[of 1 0]]) auto
   next
     case id2_1 show ?case by (intro mk_minsky_mono[OF mk_minsky_copy1[of 1 0]]) auto
   next
     case id2_2 show ?case by (intro mk_minsky_mono[OF mk_minsky_copy1[of 2 0]]) auto
   next
     case id3_1 show ?case by (intro mk_minsky_mono[OF mk_minsky_copy1[of 1 0]]) auto
   next
     case id3_2 show ?case by (intro mk_minsky_mono[OF mk_minsky_copy1[of 2 0]]) auto
   next
     case id3_3 show ?case by (intro mk_minsky_mono[OF mk_minsky_copy1[of 3 0]]) auto
   next
     case (comp1_1 f g) then show ?case using mk_minsky_comp3_3 by fast
   next
     case (comp1_2 f g) then show ?case using mk_minsky_comp3_3 by fast
   next
     case (comp1_3 f g) then show ?case using mk_minsky_comp3_3 by fast
   next
     case (comp2_1 f g h) then show ?case using mk_minsky_comp3_3 by fast
   next
     case (comp3_1 f g h k) then show ?case using mk_minsky_comp3_3 by fast
   next
     case (comp2_2 f g h) then show ?case using mk_minsky_comp3_3 by fast
   next
     case (comp2_3 f g h) then show ?case using mk_minsky_comp3_3 by fast
   next
     case (comp3_2 f g h k) then show ?case using mk_minsky_comp3_3 by fast
   next
     case (comp3_3 f g h k) then show ?case using mk_minsky_comp3_3 by fast
   next
     case (prim_rec g h) then show ?case using mk_minsky_prim_rec by blast
   qed
   { case 1 thus ?case using * by blast next
     case 2 thus ?case using * by blast next
     case 3 thus ?case using * by blast }
 qed
 
 subsection \<open>Recursively enumerable sets as Minsky machines\<close>
 
 text \<open>The following is the most complicated lemma of this theory: Given two r.e.\ sets $A$ and $B$
 we want to construct a Minsky machine that reaches the final state $0$ for input $x$ if $x \in A$
 and final state $1$ if $x \in B$, and never reaches either of these states if $x \notin A \cup B$.
 (If $x \in A \cap B$, then either state $0$ or state $1$ may be reached.) We consider two
 r.e.\ sets rather than one because we target recursive inseparability.
 
 For the r.e.\ set $A$, there is a primitive recursive function $f$ such that
 $x \in A \iff \exists y.\, f(x,y) = 0$. Similarly there is a primitive recursive function $g$ for
 $B$ such that $x \in B \iff \exists y.\, f(x,y) = 0$. Our Minsky machine takes $x$ in register
 $0$ and $y$ in register $1$ (initially $0$) and works as follows.
 \begin{enumerate}
 \item evaluate $f(x,y)$; if the result is $0$, transition to state $0$; otherwise,
 \item evaluate $g(x,y)$; if the result is $0$, transition to state $1$; otherwise,
 \item increment $y$ and start over.
 \end{enumerate}\<close>
 
 lemma ce_set_pair_by_minsky:
   assumes "A \<in> ce_sets" "B \<in> ce_sets"
   obtains M :: "(nat, nat) minsky" where
     "finite M" "deterministic M" "0 \<notin> fst ` M" "Suc 0 \<notin> fst ` M"
     "\<And>x vs. vs 0 = x \<Longrightarrow> vs 1 = 0 \<Longrightarrow> x \<in> A \<union> B \<Longrightarrow>
      \<exists>vs'. ((2, vs), (0, vs')) \<in> (step M)\<^sup>* \<or> ((2, vs), (Suc 0, vs')) \<in> (step M)\<^sup>*"
     "\<And>x vs vs'. vs 0 = x \<Longrightarrow> vs 1 = 0 \<Longrightarrow> ((2, vs), (0, vs')) \<in> (step M)\<^sup>* \<Longrightarrow> x \<in> A"
     "\<And>x vs vs'. vs 0 = x \<Longrightarrow> vs 1 = 0 \<Longrightarrow> ((2, vs), (Suc 0, vs')) \<in> (step M)\<^sup>* \<Longrightarrow> x \<in> B"
 proof -
   obtain g where g: "g \<in> PrimRec2" "\<And>x. x \<in> A \<longleftrightarrow> (\<exists>y. g x y = 0)"
     using assms(1) by (auto simp: ce_sets_def fn_to_set_def)
   obtain h where h: "h \<in> PrimRec2" "\<And>x. x \<in> B \<longleftrightarrow> (\<exists>y. h x y = 0)"
     using assms(2) by (auto simp: ce_sets_def fn_to_set_def)
   have "mk_minsky (\<lambda>vs vs'. vs' 0 = vs 0 \<and> vs' 1 = vs 1 \<and> vs' 2 = g (vs 0) (vs 1))"
     using mk_minsky_seq[OF
       mk_minsky_apply3[OF mk_minsky_PrimRec(2)[OF g(1)], of 2 3 0 1 0] \<comment> \<open> v[2] := g v[0] v[1] \<close>
       mk_minsky_nop] by auto                                           \<comment> \<open> pass                \<close>
   then obtain M :: "(nat, nat) minsky" where M: "finite M" "deterministic M" "0 \<notin> fst ` M"
     "\<And>vs. \<exists>vs'. ((Suc 0, vs), 0, vs') \<in> (step M)\<^sup>* \<and>
     vs' 0 = vs 0 \<and> vs' 1 = vs 1 \<and> vs' 2 = g (vs 0) (vs 1)"
     unfolding mk_minsky_def by blast
   have "mk_minsky (\<lambda>vs vs'. vs' 0 = vs 0 \<and> vs' 1 = vs 1 + 1 \<and> vs' 2 = h (vs 0) (vs 1))"
     using mk_minsky_seq[OF
       mk_minsky_apply3[OF mk_minsky_PrimRec(2)[OF h(1)], of 2 3 0 1 0] \<comment> \<open> v[2] := h v[0] v[1] \<close>
       mk_minsky_inc[of 1]] by auto                                     \<comment> \<open> v[1] := v[1] + 1    \<close>
   then obtain N :: "(nat, nat) minsky" where N: "finite N" "deterministic N" "0 \<notin> fst ` N"
     "\<And>vs. \<exists>vs'. ((Suc 0, vs), 0, vs') \<in> (step N)\<^sup>* \<and>
     vs' 0 = vs 0 \<and> vs' 1 = vs 1 + 1 \<and> vs' 2 = h (vs 0) (vs 1)"
     unfolding mk_minsky_def by blast
   let ?f = "\<lambda>s. if s = 0 then 3 else 2 * s" \<comment> \<open>M: from state 4 to state 3\<close>
   let ?g = "\<lambda>s. 2 * s + 5"                  \<comment> \<open>N: from state 7 to state 5\<close>
   define X where "X = map_minsky ?f id M \<union> map_minsky ?g id N \<union> {(3, Dec 2 7 0)} \<union> {(5, Dec 2 2 1)}"
   have MX: "map_minsky ?f id M \<subseteq> X" by (auto simp: X_def)
   have NX: "map_minsky ?g id N \<subseteq> X" by (auto simp: X_def)
   have DX: "(3, Dec 2 7 0) \<in> X" "(5, Dec 2 2 1) \<in> X" by (auto simp: X_def)
   have X1: "finite X" using M(1) N(1) by (auto simp: map_minsky_def X_def)
   have X2: "deterministic X" unfolding X_def using M(2,3) N(2,3)
     apply (intro deterministic_union)
     by (auto simp: map_minsky_def rev_image_eqI inj_on_def split: if_splits
       intro!: deterministic_map) presburger+
   have X3: "0 \<notin> fst ` X" "Suc 0 \<notin> fst ` X" using M(3) N(3)
     by (auto simp: X_def map_minsky_def split: if_splits)
   have X4: "\<exists>vs'. g (vs 0) (vs 1) = 0 \<and> ((2, vs), (0, vs')) \<in> (step X)\<^sup>* \<or>
     h (vs 0) (vs 1) = 0 \<and> ((2, vs), (1, vs')) \<in> (step X)\<^sup>* \<or>
     g (vs 0) (vs 1) \<noteq> 0 \<and> h (vs 0) (vs 1) \<noteq> 0 \<and> vs' 0 = vs 0 \<and> vs' 1 = vs 1 + 1 \<and>
     ((2, vs), (2, vs')) \<in> (step X)\<^sup>+" for vs
   proof -
     guess vs' using M(4)[of vs] by (elim exE conjE) note vs' = this
     have 1: "((2, vs), (3, vs')) \<in> (step X)\<^sup>*"
       using subsetD[OF steps_mono[OF MX], OF map_steps[OF _ _ vs'(1), of id vs ?f]] by simp
     show ?thesis
     proof (cases "vs' 2")
       case 0 then show ?thesis using decz[OF DX(1), of vs'] vs' 1
         by (auto intro: rtrancl_into_rtrancl)
     next
       case (Suc n) note Suc' = Suc
       let ?vs = "\<lambda>x. if x = 2 then n else vs' x"
       have 2: "((2, vs), (7, ?vs)) \<in> (step X)\<^sup>*"
         using 1 decn[OF DX(1), of vs'] Suc by (auto intro: rtrancl_into_rtrancl)
       guess vs'' using N(4)[of "?vs"] by (elim exE conjE) note vs'' = this
       have 3: "((2, vs), (5, vs'')) \<in> (step X)\<^sup>*"
         using 2 subsetD[OF steps_mono[OF NX], OF map_steps[OF _ _ vs''(1), of id ?vs ?g]] by simp
       show ?thesis
       proof (cases "vs'' 2")
         case 0 then show ?thesis using 3 decz[OF DX(2), of vs''] vs''(2-) vs'(2-)
           by (auto intro: rtrancl_into_rtrancl)
       next
         case (Suc m)
         let ?vs = "\<lambda>x. if x = 2 then m else vs'' x"
         have 4: "((2, vs), (2, ?vs)) \<in> (step X)\<^sup>+" using 3 decn[OF DX(2), of vs'' m] Suc by auto
         then show ?thesis using vs''(2-) vs'(2-) Suc Suc' by (auto intro!: exI[of _ ?vs])
       qed
     qed
   qed
   have *: "vs 1 \<le> y \<Longrightarrow> g (vs 0) y = 0 \<or> h (vs 0) y = 0 \<Longrightarrow>
     \<exists>vs'. ((2, vs), (0, vs')) \<in> (step X)\<^sup>* \<or> ((2, vs), (1, vs')) \<in> (step X)\<^sup>*" for vs y
   proof (induct "vs 1" arbitrary: vs rule: inc_induct, goal_cases base step)
     case (base vs) then show ?case using X4[of vs] by auto
   next
     case (step vs)
     guess vs' using X4[of vs] by (elim exE)
     then show ?case unfolding ex_disj_distrib using step(4) step(3)[of vs']
       by (auto dest!: trancl_into_rtrancl) (meson rtrancl_trans)+
   qed
   have **: "((s, vs), (t, ws)) \<in> (step X)\<^sup>* \<Longrightarrow> t \<in> {0, 1} \<Longrightarrow> ((s, vs), (2, ws')) \<in> (step X)\<^sup>* \<Longrightarrow>
     \<exists>y. if t = 0 then g (ws' 0) y = 0 else h (ws' 0) y = 0" for s t vs ws' ws
   proof (induct arbitrary: ws' rule: converse_rtrancl_induct2)
     case refl show ?case using refl(1) NF_not_suc[OF refl(2) NF_stepI] X3 by auto
   next
     case (step s vs s' vs')
     show ?case using step(5)
     proof (cases rule: converse_rtranclE[case_names base' step'])
       case base'
       note *** = deterministic_minsky_UN[OF X2 _ _ X3]
       show ?thesis using X4[of ws']
       proof (elim exE disjE conjE, goal_cases)
         case (1 vs'') then show ?case using step(1,2,4) ***[of "(2,ws')" vs'' ws]
           by (auto simp: base' intro: converse_rtrancl_into_rtrancl)
       next
         case (2 vs'') then show ?case using step(1,2,4) ***[of "(2,ws')" ws vs'']
           by (auto simp: base' intro: converse_rtrancl_into_rtrancl)
       next
         case (3 vs'') then show ?case using step(2) step(3)[of vs'', OF step(4)]
           deterministicD[OF deterministic_stepI[OF X2], OF _ step(1)]
           by (auto simp: base' if_bool_eq_conj trancl_unfold_left)
       qed
     next
       case (step' y) then show ?thesis
         by (metis deterministicD[OF deterministic_stepI[OF X2]] step(1) step(3)[OF step(4)])
     qed
   qed
   show ?thesis
   proof (intro that[of X] X1 X2 X3, goal_cases)
     case (1 x vs) then show ?case using *[of vs] by (auto simp: g(2) h(2))
   next
     case (2 x vs vs') then show ?case using **[of 2 vs 0 vs' vs] by (auto simp: g(2) h(2))
   next
     case (3 x vs vs') then show ?case using **[of 2 vs 1 vs' vs] by (auto simp: g(2) h(2))
   qed
 qed
 
 text \<open>For r.e.\ sets we obtain the following lemma as a special case (taking $B = \varnothing$,
 and swapping states $1$ and $2$).\<close>
 
 lemma ce_set_by_minsky:
   assumes "A \<in> ce_sets"
   obtains M :: "(nat, nat) minsky" where
     "finite M" "deterministic M" "0 \<notin> fst ` M"
     "\<And>x vs. vs 0 = x \<Longrightarrow> vs 1 = 0 \<Longrightarrow> x \<in> A \<Longrightarrow> \<exists>vs'. ((Suc 0, vs), (0, vs')) \<in> (step M)\<^sup>*"
     "\<And>x vs vs'. vs 0 = x \<Longrightarrow> vs 1 = 0 \<Longrightarrow> ((Suc 0, vs), (0, vs')) \<in> (step M)\<^sup>* \<Longrightarrow> x \<in> A"
 proof -
   guess M using ce_set_pair_by_minsky[OF assms(1) ce_empty] . note M = this
   let ?f = "\<lambda>s. if s = 1 then 2 else if s = 2 then 1 else s" \<comment> \<open>swap states 1 and 2\<close>
   have "?f \<circ> ?f = id" by auto
   define N where "N = map_minsky ?f id M"
   have M_def: "M = map_minsky ?f id N"
     unfolding N_def map_minsky_comp \<open>?f \<circ> ?f = id\<close> map_minsky_id o_id ..
   show ?thesis using M(1-3)
   proof (intro that[of N], goal_cases)
     case (4 x vs) show ?case using M(5)[OF 4(4,5)] 4(6) M(7)[OF 4(4,5)]
       map_steps[of id vs vs 2 0 _ M ?f] by (auto simp: N_def)
   next
     case (5 x vs vs') show ?case
       using M(6)[OF 5(4,5)] 5(6) map_steps[of id vs vs 1 0 _ N ?f] by (auto simp: M_def)
   qed (auto simp: N_def map_minsky_def inj_on_def rev_image_eqI deterministic_map split: if_splits)
 qed
 
 subsection \<open>Encoding of Minsky machines\<close>
 
 text \<open>So far, Minsky machines have been sets of pairs of states and operations. We now provide an
 encoding of Minsky machines as natural numbers, so that we can talk about them as r.e.\ or
 computable sets. First we encode operations.\<close>
 
 primrec encode_Op :: "(nat, nat) Op \<Rightarrow> nat" where
   "encode_Op (Dec v s s') = c_pair 0 (c_pair v (c_pair s s'))"
 | "encode_Op (Inc v s) = c_pair 1 (c_pair v s)"
 
 definition decode_Op :: "nat \<Rightarrow> (nat, nat) Op" where
   "decode_Op n = (if c_fst n = 0
    then Dec (c_fst (c_snd n)) (c_fst (c_snd (c_snd n))) (c_snd (c_snd (c_snd n)))
    else Inc (c_fst (c_snd n)) (c_snd (c_snd n)))"
 
 lemma encode_Op_inv [simp]:
   "decode_Op (encode_Op x) = x"
   by (cases x) (auto simp: decode_Op_def)
 
 text \<open>Minsky machines are encoded via lists of pairs of states and operations.\<close>
 
 definition encode_minsky :: "(nat \<times> (nat, nat) Op) list \<Rightarrow> nat" where
   "encode_minsky M = list_to_nat (map (\<lambda>x. c_pair (fst x) (encode_Op (snd x))) M)"
 
 definition decode_minsky :: "nat \<Rightarrow> (nat \<times> (nat, nat) Op) list" where
   "decode_minsky n = map (\<lambda>n. (c_fst n, decode_Op (c_snd n))) (nat_to_list n)"
 
 lemma encode_minsky_inv [simp]:
   "decode_minsky (encode_minsky M) = M"
   by (auto simp: encode_minsky_def decode_minsky_def comp_def)
 
 text \<open>Assignments are stored as lists (starting with register 0).\<close>
 
 definition decode_regs :: "nat \<Rightarrow> (nat \<Rightarrow> nat)" where
   "decode_regs n = (\<lambda>i. let xs = nat_to_list n in if i < length xs then nat_to_list n ! i else 0)"
 
 text \<open>The undecidability results talk about Minsky configurations (pairs of Minsky machines and
 assignments). This means that we do not have to construct any recursive functions that modify
 Minsky machines (for example in order to initialize variables), keeping the proofs simple.\<close>
 
 definition decode_minsky_state :: "nat \<Rightarrow> ((nat, nat) minsky \<times> (nat \<Rightarrow> nat))" where
   "decode_minsky_state n = (set (decode_minsky (c_fst n)), (decode_regs (c_snd n)))"
 
 subsection \<open>Undecidablity results\<close>
 
 text \<open>We conclude with some undecidability results. First we show that it is undecidable whether
 a Minksy machine starting at state 1 terminates in state 0.\<close>
 
 definition minsky_reaching_0 where
   "minsky_reaching_0 = {n |n M vs vs'. (M, vs) = decode_minsky_state n \<and> ((Suc 0, vs), (0, vs')) \<in> (step M)\<^sup>*}"
 
 lemma minsky_reaching_0_not_computable:
   "\<not> computable minsky_reaching_0"
 proof -
   guess U using ce_set_by_minsky[OF univ_is_ce] . note U = this
   obtain us where [simp]: "set us = U" using finite_list[OF U(1)] by blast
   let ?f = "\<lambda>n. c_pair (encode_minsky us) (c_cons n 0)"
   have "?f \<in> PrimRec1"
     using comp2_1[OF c_pair_is_pr const_is_pr comp2_1[OF c_cons_is_pr id1_1 const_is_pr]] by simp
   moreover have "?f x \<in> minsky_reaching_0 \<longleftrightarrow> x \<in> univ_ce" for x
     using U(4,5)[of "\<lambda>i. if i = 0 then x else 0"]
     by (auto simp: minsky_reaching_0_def decode_minsky_state_def decode_regs_def c_cons_def cong: if_cong)
   ultimately have "many_reducible_to univ_ce minsky_reaching_0"
     by (auto simp: many_reducible_to_def many_reducible_to_via_def dest: pr_is_total_rec)
   then show ?thesis by (rule many_reducible_lm_1)
 qed
 
 text \<open>The remaining results are resursive inseparability results. We start be showing that there
 is a Minksy machine $U$ with final states $0$ and $1$ such that it is not possible to recursively
 separate inputs reaching state $0$ from inputs reaching state $1$.\<close>
 
 lemma rec_inseparable_0not1_1not0:
   "rec_inseparable {p. 0 \<in> nat_to_ce_set p \<and> 1 \<notin> nat_to_ce_set p} {p. 0 \<notin> nat_to_ce_set p \<and> 1 \<in> nat_to_ce_set p}"
 proof -
   obtain n where n: "nat_to_ce_set n = {0}" using nat_to_ce_set_srj[OF ce_finite[of "{0}"]] by auto
   obtain m where m: "nat_to_ce_set m = {1}" using nat_to_ce_set_srj[OF ce_finite[of "{1}"]] by auto
   show ?thesis by (rule rec_inseparable_mono[OF Rice_rec_inseparable[of n m]]) (auto simp: n m)
 qed
 
 lemma ce_sets_containing_n_ce:
   "{p. n \<in> nat_to_ce_set p} \<in> ce_sets"
   using ce_set_lm_5[OF univ_is_ce comp2_1[OF c_pair_is_pr id1_1 const_is_pr[of n]]]
   by (auto simp: univ_ce_lm_1)
 
 lemma rec_inseparable_fixed_minsky_reaching_0_1:
   obtains U :: "(nat, nat) minsky" where
     "finite U" "deterministic U" "0 \<notin> fst ` U" "1 \<notin> fst ` U"
     "rec_inseparable {x |x vs'. ((2, (\<lambda>n. if n = 0 then x else 0)), (0, vs')) \<in> (step U)\<^sup>*}
       {x |x vs'. ((2, (\<lambda>n. if n = 0 then x else 0)), (1, vs')) \<in> (step U)\<^sup>*}"
 proof -
   guess U using ce_set_pair_by_minsky[OF ce_sets_containing_n_ce ce_sets_containing_n_ce, of 0 1] .
   from this(1-4) this(5-7)[of "\<lambda>n. if n = 0 then _ else 0"]
   show ?thesis by (auto 0 0 intro!: that[of U] rec_inseparable_mono[OF rec_inseparable_0not1_1not0]
       pr_is_total_rec simp: rev_image_eqI cong: if_cong) meson+
 qed
 
 text \<open>Consequently, it is impossible to separate Minsky configurations with determistic machines
 and final states $0$ and $1$ that reach state $0$ from those that reach state $1$.\<close>
 
 definition minsky_reaching_s where
   "minsky_reaching_s s = {m |M m vs vs'. (M, vs) = decode_minsky_state m \<and>
     deterministic M \<and> 0 \<notin> fst ` M \<and> 1 \<notin> fst ` M \<and> ((2, vs), (s, vs')) \<in> (step M)\<^sup>*}"
 
 lemma rec_inseparable_minsky_reaching_0_1:
   "rec_inseparable (minsky_reaching_s 0) (minsky_reaching_s 1)"
 proof -
   guess U using rec_inseparable_fixed_minsky_reaching_0_1 . note U = this
   obtain us where [simp]: "set us = U" using finite_list[OF U(1)] by blast
   let ?f = "\<lambda>n. c_pair (encode_minsky us) (c_cons n 0)"
   have "?f \<in> PrimRec1"
     using comp2_1[OF c_pair_is_pr const_is_pr comp2_1[OF c_cons_is_pr id1_1 const_is_pr]] by simp
   then show ?thesis
     using U(1-4) rec_inseparable_many_reducible[of ?f, OF _ rec_inseparable_mono[OF U(5)]]
     by (auto simp: pr_is_total_rec minsky_reaching_s_def decode_minsky_state_def rev_image_eqI
       decode_regs_def c_cons_def cong: if_cong)
 qed
 
 text \<open>As a corollary, it is impossible to separate Minsky configurations that reach state 0 but not
 state 1 from those that reach state 1 but not state 0.\<close>
 
 definition minsky_reaching_s_not_t where
   "minsky_reaching_s_not_t s t = {m |M m vs vs'. (M, vs) = decode_minsky_state m \<and>
     ((2, vs), (s, vs')) \<in> (step M)\<^sup>* \<and> ((2, vs), (t, vs')) \<notin> (step M)\<^sup>*}"
 
 lemma minsky_reaching_s_imp_minsky_reaching_s_not_t:
   assumes "s \<in> {0,1}" "t \<in> {0,1}" "s \<noteq> t"
   shows "minsky_reaching_s s \<subseteq> minsky_reaching_s_not_t s t"
 proof -
   have [dest!]: "((2, vs), (0, vs')) \<notin> (step M)\<^sup>* \<or> ((2, vs), (1, vs')) \<notin> (step M)\<^sup>*"
     if "deterministic M" "0 \<notin> fst ` M" "1 \<notin> fst ` M" for M :: "(nat, nat) minsky" and vs vs'
     using deterministic_minsky_UN[OF that(1) _ _ that(2,3)] by auto
   show ?thesis using assms
     by (auto simp: minsky_reaching_s_def minsky_reaching_s_not_t_def rev_image_eqI)
 qed
 
 lemma rec_inseparable_minsky_reaching_0_not_1_1_not_0:
   "rec_inseparable (minsky_reaching_s_not_t 0 1) (minsky_reaching_s_not_t 1 0)"
   by (intro rec_inseparable_mono[OF rec_inseparable_minsky_reaching_0_1]
     minsky_reaching_s_imp_minsky_reaching_s_not_t) simp_all
 
 end
diff --git a/thys/Minsky_Machines/ROOT b/thys/Minsky_Machines/ROOT
--- a/thys/Minsky_Machines/ROOT
+++ b/thys/Minsky_Machines/ROOT
@@ -1,12 +1,13 @@
 chapter AFP
 
 session "Minsky_Machines" (AFP) = "Abstract-Rewriting" +
   options [timeout = 600]
   sessions
+    "Pure-ex"
     "Recursion-Theory-I"
   theories
     Recursive_Inseparability
     Minsky
   document_files
     "root.tex"
     "root.bib"
diff --git a/thys/Myhill-Nerode/Non_Regular_Languages.thy b/thys/Myhill-Nerode/Non_Regular_Languages.thy
--- a/thys/Myhill-Nerode/Non_Regular_Languages.thy
+++ b/thys/Myhill-Nerode/Non_Regular_Languages.thy
@@ -1,269 +1,272 @@
 (* 
   File:     Non_Regular_Languages.thy
   Author:   Manuel Eberl <eberlm@in.tum.de>
   
   This file provides some tools for showing the non-regularity of a language, either 
   via an infinite set of equivalence classes or via the Pumping Lemma.
 *)
 section \<open>Tools for showing non-regularity of a language\<close>
 theory Non_Regular_Languages
   imports Myhill
 begin
 
 subsection \<open>Auxiliary material\<close>
 
 lemma bij_betw_image_quotient:
   "bij_betw (\<lambda>y. f -` {y}) (f ` A) (A // {(a,b). f a = f b})"
   by (force simp: bij_betw_def inj_on_def image_image quotient_def)
    
 lemma regular_Derivs_finite:
   fixes r :: "'a :: finite rexp"
   shows "finite (range (\<lambda>w. Derivs w (lang r)))"
 proof -
   have "?thesis \<longleftrightarrow> finite (UNIV // \<approx>lang r)"
     unfolding str_eq_conv_Derivs by (rule bij_betw_finite bij_betw_image_quotient)+
   also have "\<dots>" by (subst Myhill_Nerode [symmetric]) auto
   finally show ?thesis .
 qed
   
 lemma Nil_in_Derivs_iff: "[] \<in> Derivs w A \<longleftrightarrow> w \<in> A"
   by (auto simp: Derivs_def)
 
 (* TODO: Move to distribution? *)
 text \<open>
   The following operation repeats a list $n$ times (usually written as $w ^ n$).
 \<close>
 primrec repeat :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "repeat 0 xs = []"
 | "repeat (Suc n) xs = xs @ repeat n xs"
   
 lemma repeat_Cons_left: "repeat (Suc n) xs = xs @ repeat n xs" by simp
     
 lemma repeat_Cons_right: "repeat (Suc n) xs = repeat n xs @ xs"
   by (induction n) simp_all
     
 lemma repeat_Cons_append_commute [simp]: "repeat n xs @ xs = xs @ repeat n xs"
   by (subst repeat_Cons_right [symmetric]) simp
     
 lemma repeat_Cons_add [simp]: "repeat (m + n) xs = repeat m xs @ repeat n xs"
   by (induction m) simp_all
     
 lemma repeat_Nil [simp]: "repeat n [] = []"
   by (induction n) simp_all
     
 lemma repeat_conv_replicate: "repeat n xs = concat (replicate n xs)"
   by (induction n) simp_all
 
     
 (* TODO: Move to distribution? *)
 lemma nth_prefixes [simp]: "n \<le> length xs \<Longrightarrow> prefixes xs ! n = take n xs"
   by (induction xs arbitrary: n) (auto simp: nth_Cons split: nat.splits)
     
 lemma nth_suffixes [simp]: "n \<le> length xs \<Longrightarrow> suffixes xs ! n = drop (length xs - n) xs"
   by (subst suffixes_conv_prefixes) (simp_all add: rev_take)
 
 lemma length_take_prefixes:
   assumes "xs \<in> set (take n (prefixes ys))"
   shows   "length xs < n"
 proof (cases "n \<le> Suc (length ys)")
   case True
   with assms obtain i where "i < n" "xs = take i ys"
     by (subst (asm) nth_image [symmetric]) auto
   thus ?thesis by simp
 next
   case False
   with assms have "prefix xs ys" by simp
   hence "length xs \<le> length ys" by (rule prefix_length_le)
   also from False have "\<dots> < n" by simp
   finally show ?thesis .
 qed
 
 
 subsection \<open>Non-regularity by giving an infinite set of equivalence classes\<close>
   
 text \<open>
   Non-regularity can be shown by giving an infinite set of non-equivalent words (w.r.t. the 
   Myhill--Nerode relation).
 \<close>
 lemma not_regular_langI:
   assumes "infinite B" "\<And>x y. x \<in> B \<Longrightarrow> y \<in> B \<Longrightarrow> x \<noteq> y \<Longrightarrow> \<exists>w. \<not>(x @ w \<in> A \<longleftrightarrow> y @ w \<in> A)"
   shows   "\<not>regular_lang (A :: 'a :: finite list set)"
 proof -
   have "(\<lambda>w. Derivs w A) ` B \<subseteq> range (\<lambda>w. Derivs w A)" by blast
   moreover from assms(2) have "inj_on (\<lambda>w. Derivs w A) B"
     by (auto simp: inj_on_def Derivs_def)
   with assms(1) have "infinite ((\<lambda>w. Derivs w A) ` B)"
     by (blast dest: finite_imageD)
   ultimately have "infinite (range (\<lambda>w. Derivs w A))" by (rule infinite_super)
   with regular_Derivs_finite show ?thesis by blast
 qed
 
 lemma not_regular_langI':
   assumes "infinite B" "\<And>x y. x \<in> B \<Longrightarrow> y \<in> B \<Longrightarrow> x \<noteq> y \<Longrightarrow> \<exists>w. \<not>(f x @ w \<in> A \<longleftrightarrow> f y @ w \<in> A)"
   shows   "\<not>regular_lang (A :: 'a :: finite list set)"
 proof (rule not_regular_langI)
   from assms(2) have "inj_on f B" by (force simp: inj_on_def)
   with \<open>infinite B\<close> show "infinite (f ` B)" by (simp add: finite_image_iff)
 qed (insert assms, auto)
 
   
 subsection \<open>The Pumping Lemma\<close>
 
 text \<open>
   The Pumping lemma can be shown very easily from the Myhill--Nerode theorem: if we have 
   a word whose length is more than the (finite) number of equivalence classes, then it must 
   have two different prefixes in the same class and the difference between these two 
   prefixes can then be ``pumped''.
 \<close>
 lemma pumping_lemma_aux:
   fixes A :: "'a list set"
   defines "\<delta> \<equiv> \<lambda>w. Derivs w A"
   defines "n \<equiv> card (range \<delta>)"
   assumes "z \<in> A" "finite (range \<delta>)" "length z \<ge> n"
   shows "\<exists>u v w. z = u @ v @ w \<and> length (u @ v) \<le> n \<and> v \<noteq> [] \<and> (\<forall>i. u @ repeat i v @ w \<in> A)"
 proof -
   define P where "P = set (take (Suc n) (prefixes z))"
   from \<open>length z \<ge> n\<close> have [simp]: "card P = Suc n"
     unfolding P_def by (subst distinct_card) (auto intro!: distinct_take)
   have length_le: "length y \<le> n" if "y \<in> P" for y
     using length_take_prefixes[OF that [unfolded P_def]] by simp
       
   have "card (\<delta> ` P) \<le> card (range \<delta>)" by (intro card_mono assms) auto
   also from assms have "\<dots> < card P" by simp
   finally have "\<not>inj_on \<delta> P" by (rule pigeonhole)
   then obtain a b where ab: "a \<in> P" "b \<in> P" "a \<noteq> b" "Derivs a A = Derivs b A"
     by (auto simp: inj_on_def \<delta>_def)
   from ab have prefix_ab: "prefix a z" "prefix b z" by (auto simp: P_def dest: in_set_takeD)
   from ab have length_ab: "length a \<le> n" "length b \<le> n"
     by (simp_all add: length_le)
       
   have *: ?thesis 
     if uz': "prefix u z'" "prefix z' z" "length z' \<le> n" 
             "u \<noteq> z'" "Derivs z' A = Derivs u A" for u z'
   proof -
     from \<open>prefix u z'\<close> and \<open>u \<noteq> z'\<close> 
       obtain v where v [simp]: "z' = u @ v" "v \<noteq> []" 
       by (auto simp: prefix_def)
     from \<open>prefix z' z\<close> obtain w where [simp]: "z = u @ v @ w" 
       by (auto simp: prefix_def)
       
     hence [simp]: "Derivs (repeat i v) (Derivs u A) = Derivs u A" for i
       by (induction i) (use uz' in simp_all)
     have "Derivs z A = Derivs (u @ repeat i v @ w) A" for i
       using uz' by simp
     with \<open>z \<in> A\<close> and uz' have "\<forall>i. u @ repeat i v @ w \<in> A"
       by (simp add: Nil_in_Derivs_iff [of _ A, symmetric])
     moreover have "z = u @ v @ w" by simp
     moreover from \<open>length z' \<le> n\<close> have "length (u @ v) \<le> n" by simp
     ultimately show ?thesis using \<open>v \<noteq> []\<close> by blast
   qed
   
   from prefix_ab have "prefix a b \<or> prefix b a" by (rule prefix_same_cases)
   with *[of a b] and *[of b a] and ab and prefix_ab and length_ab show ?thesis by blast
 qed
 
 theorem pumping_lemma:
   fixes r :: "'a :: finite rexp"
   obtains n where 
     "\<And>z. z \<in> lang r \<Longrightarrow> length z \<ge> n \<Longrightarrow> 
             \<exists>u v w. z = u @ v @ w \<and> length (u @ v) \<le> n \<and> v \<noteq> [] \<and> (\<forall>i. u @ repeat i v @ w \<in> lang r)"
 proof -
   let ?n = "card (range (\<lambda>w. Derivs w (lang r)))"
   have "\<exists>u v w. z = u @ v @ w \<and> length (u @ v) \<le> ?n \<and> v \<noteq> [] \<and> (\<forall>i. u @ repeat i v @ w \<in> lang r)"
     if "z \<in> lang r" and "length z \<ge> ?n" for z
     by (intro pumping_lemma_aux[of z] that regular_Derivs_finite)
   thus ?thesis by (rule that)
 qed
   
 corollary pumping_lemma_not_regular_lang:
   fixes A :: "'a :: finite list set"
   assumes "\<And>n. length (z n) \<ge> n" and "\<And>n. z n \<in> A"
   assumes "\<And>n u v w. z n = u @ v @ w \<Longrightarrow> length (u @ v) \<le> n \<Longrightarrow> v \<noteq> [] \<Longrightarrow> 
              u @ repeat (i n u v w) v @ w \<notin> A"
   shows   "\<not>regular_lang A"
 proof
   assume "regular_lang A"
   then obtain r where r: "lang r = A" by blast
-  from pumping_lemma[of r] guess n .
-  from this[of "z n"] and assms[of n] obtain u v w 
+  from pumping_lemma[of r] obtain n
+    where "z n \<in> lang r \<Longrightarrow> n \<le> length (z n) \<Longrightarrow>
+      \<exists>u v w. z n = u @ v @ w \<and> length (u @ v) \<le> n \<and> v \<noteq> [] \<and> (\<forall>i. u @ repeat i v @ w \<in> lang r)"
+    by metis
+  from this and assms[of n] obtain u v w 
     where "z n = u @ v @ w" and "length (u @ v) \<le> n" and "v \<noteq> []" and 
           "\<And>i. u @ repeat i v @ w \<in> lang r" by (auto simp: r)
   with assms(3)[of n u v w] show False by (auto simp: r)
 qed
 
 
 subsection \<open>Examples\<close>
 
 text \<open>
   The language of all words containing the same number of $a$s and $b$s is not regular.
 \<close>
 lemma "\<not>regular_lang {w. length (filter id w) = length (filter Not w)}" (is "\<not>regular_lang ?A")
 proof (rule not_regular_langI')
   show "infinite (UNIV :: nat set)" by simp
 next
   fix m n :: nat assume "m \<noteq> n"
   hence "replicate m True @ replicate m False \<in> ?A" and
         "replicate n True @ replicate m False \<notin> ?A" by simp_all
   thus "\<exists>w. \<not>(replicate m True @ w \<in> ?A \<longleftrightarrow> replicate n True @ w \<in> ?A)" by blast
 qed
 
 text \<open>
   The language $\{a^i b^i\ |\ i \in \mathbb{N}\}$ is not regular.
 \<close>
 lemma eq_replicate_iff:
   "xs = replicate n x \<longleftrightarrow> set xs \<subseteq> {x} \<and> length xs = n"
   using replicate_length_same[of xs x] by (subst eq_commute) auto
     
 lemma replicate_eq_appendE:
   assumes "xs @ ys = replicate n x"
   obtains i j where "n = i + j" "xs = replicate i x" "ys = replicate j x"
 proof -
   have "n = length (replicate n x)" by simp
   also note assms [symmetric]
   finally have "n = length xs + length ys" by simp
   moreover have "xs = replicate (length xs) x" and "ys = replicate (length ys) x"
     using assms by (auto simp: eq_replicate_iff)
   ultimately show ?thesis using that[of "length xs" "length ys"] by auto
 qed
   
 lemma "\<not>regular_lang (range (\<lambda>i. replicate i True @ replicate i False))" (is "\<not>regular_lang ?A")
 proof (rule pumping_lemma_not_regular_lang)
   fix n :: nat
   show "length (replicate n True @ replicate n False) \<ge> n" by simp
   show "replicate n True @ replicate n False \<in> ?A" by simp
 next
   fix n :: nat and u v w :: "bool list"
   assume decomp: "replicate n True @ replicate n False = u @ v @ w"
      and length_le: "length (u @ v) \<le> n" and v_ne: "v \<noteq> []"
   define w1 w2 where "w1 = take (n - length (u@v)) w" and "w2 = drop (n - length (u@v)) w"
   have w_decomp: "w = w1 @ w2" by (simp add: w1_def w2_def)
   
   have "replicate n True = take n (replicate n True @ replicate n False)" by simp
   also note decomp
   also have "take n (u @ v @ w) = u @ v @ w1" using length_le by (simp add: w1_def)
   finally have "u @ v @ w1 = replicate n True" by simp
   then obtain i j k 
     where uvw1: "n = i + j + k" "u = replicate i True" "v = replicate j True" "w1 = replicate k True"
     by (elim replicate_eq_appendE) auto
   
   have "replicate n False = drop n (replicate n True @ replicate n False)" by simp
   also note decomp
   finally have [simp]: "w2 = replicate n False" using length_le by (simp add: w2_def)
       
   have "u @ repeat (Suc (Suc 0)) v @ w = replicate (n + j) True @ replicate n False"
     by (simp add: uvw1 w_decomp replicate_add [symmetric])
   also have "\<dots> \<notin> ?A"
   proof safe
     fix m assume *: "replicate (n + j) True @ replicate n False = 
                        replicate m True @ replicate m False" (is "?lhs = ?rhs")
     have "n = length (filter Not ?lhs)" by simp
     also note *
     also have "length (filter Not ?rhs) = m" by simp
     finally have [simp]: "m = n" by simp
     from * have "v = []" by (simp add: uvw1)
     with \<open>v \<noteq> []\<close> show False by contradiction
   qed
   finally show "u @ repeat (Suc (Suc 0)) v @ w \<notin> ?A" .
 qed
     
 end
diff --git a/thys/Ordinary_Differential_Equations/Numerics/Refine_Rigorous_Numerics_Aform.thy b/thys/Ordinary_Differential_Equations/Numerics/Refine_Rigorous_Numerics_Aform.thy
--- a/thys/Ordinary_Differential_Equations/Numerics/Refine_Rigorous_Numerics_Aform.thy
+++ b/thys/Ordinary_Differential_Equations/Numerics/Refine_Rigorous_Numerics_Aform.thy
@@ -1,1740 +1,1744 @@
 theory Refine_Rigorous_Numerics_Aform
   imports
     Refine_Rigorous_Numerics
     "HOL-Types_To_Sets.Types_To_Sets"
 begin
 
 lemma Joints_ne_empty[simp]: "Joints xs \<noteq> {}" "{} \<noteq> Joints xs"
   by (auto simp: Joints_def valuate_def)
 
 lemma Inf_aform_le_Affine: "x \<in> Affine X \<Longrightarrow> Inf_aform X \<le> x"
   by (auto simp: Affine_def valuate_def intro!: Inf_aform)
 lemma Sup_aform_ge_Affine: "x \<in> Affine X \<Longrightarrow> x \<le> Sup_aform X"
   by (auto simp: Affine_def valuate_def intro!: Sup_aform)
 
 lemmas Inf_aform'_Affine_le = order_trans[OF Inf_aform' Inf_aform_le_Affine]
 lemmas Sup_aform'_Affine_ge = order_trans[OF Sup_aform_ge_Affine Sup_aform']
 
 fun approx_form_aform :: "nat \<Rightarrow> form \<Rightarrow> real aform list \<Rightarrow> bool" where
 "approx_form_aform prec (Less a b) bs =
    (case (approx_floatariths prec [a - b] bs)
    of Some [r] \<Rightarrow> Sup_aform' prec r < 0
     | _ \<Rightarrow> False)"
 | "approx_form_aform prec (LessEqual a b) bs =
    (case (approx_floatariths prec [a - b] bs)
    of Some [r] \<Rightarrow> Sup_aform' prec r \<le> 0
     | _ \<Rightarrow> False)"
 | "approx_form_aform prec (AtLeastAtMost a b c) bs =
    (case (approx_floatariths prec [a - b, a - c] bs)
    of Some [r, s] \<Rightarrow> 0 \<le> Inf_aform' prec r \<and>  Sup_aform' prec s \<le> 0
     | _ \<Rightarrow> False)"
 | "approx_form_aform prec (Bound a b c d) bs = False"
 | "approx_form_aform prec (Assign a b c) bs = False"
 | "approx_form_aform prec (Conj a b) bs \<longleftrightarrow>
     approx_form_aform prec a bs \<and> approx_form_aform prec b bs"
 | "approx_form_aform prec (Disj a b) bs \<longleftrightarrow>
     approx_form_aform prec a bs \<or> approx_form_aform prec b bs"
 
 lemma in_Joints_intervalD:
   "x \<in> {Inf_aform' p X .. Sup_aform' p X} \<and> xs \<in> Joints XS"
   if "x#xs \<in> Joints (X#XS)"
   using that
   by (auto simp: Joints_def valuate_def Affine_def
       intro!: Inf_aform'_Affine_le Sup_aform'_Affine_ge)
 
 lemma approx_form_aform:
   "interpret_form f vs"
   if "approx_form_aform p f VS" "vs \<in> Joints VS"
   using that
   by (induction f)
     (auto split: option.splits list.splits simp: algebra_simps
       dest!: approx_floatariths_outer
       dest!: in_Joints_intervalD[where p=p])
 
 fun msum_aforms::"nat \<Rightarrow> real aform list \<Rightarrow> real aform list \<Rightarrow> real aform list"  where
   "msum_aforms d (x#xs) (y#ys) = msum_aform d x y#msum_aforms d xs ys"
 | "msum_aforms d _ _ = []"
 
 definition [simp]: "degree_aforms_real = (degree_aforms::real aform list \<Rightarrow> nat)"
 
 abbreviation "msum_aforms' \<equiv> \<lambda>X Y. msum_aforms (degree_aforms_real (X @ Y)) X Y"
 
 lemma aform_val_msum_aforms:
   assumes "degree_aforms xs \<le> d"
   shows "aform_vals e (msum_aforms d xs ys) = List.map2 (+) (aform_vals e xs) (aform_vals (\<lambda>i. e (i + d)) ys)"
   using assms
 proof (induction xs ys rule: msum_aforms.induct)
   case (1 d x xs y ys)
   from 1 have "degree_aforms xs \<le> d"
     by (auto simp: degrees_def)
   from 1(1)[OF this] 1
   have "aform_vals e (msum_aforms d xs ys) = List.map2 (+) (aform_vals e xs) (aform_vals (\<lambda>i. e (i + d)) ys)"
     by simp
   then show ?case
     using 1
     by (simp add: aform_vals_def aform_val_msum_aform degrees_def)
 qed (auto simp: aform_vals_def)
 
 lemma Joints_msum_aforms:
   assumes "degree_aforms xs \<le> d"
   assumes "degree_aforms ys \<le> d"
   shows "Joints (msum_aforms d xs ys) = {List.map2 (+) a b |a b. a \<in> Joints xs \<and> b \<in> Joints ys}"
   apply (auto simp: Joints_def valuate_def aform_vals_def[symmetric]
       aform_val_msum_aforms assms)
    apply force
   subgoal for e e'
     apply (rule image_eqI[where x="\<lambda>i. if i < d then e i else e' (i - d)"])
      apply (auto simp: Pi_iff)
   proof goal_cases
     case 1
     have "(aform_vals e xs) = aform_vals (\<lambda>i. if i < d then e i else e' (i - d)) xs"
       using assms
       by (auto intro!: simp: aform_vals_def aform_val_def degrees_def intro!: pdevs_val_degree_cong)
     then show ?case
       by simp
   qed
   done
 
 definition "split_aforms_largest_uncond_take n X =
   (let (i, x) = max_pdev (abssum_of_pdevs_list (map snd (take n X))) in split_aforms X i)"
 
 text \<open>intersection with plane\<close>
 
 definition
   "project_coord x b n = (\<Sum>i\<leftarrow>Basis_list. (if i = b then n else if i = -b then -n else x \<bullet> i) *\<^sub>R i)"
 
 lemma inner_eq_abs_times_sgn:
   "u \<bullet> b = abs u \<bullet> b * sgn (u \<bullet> b)" if "b \<in> Basis" for b::"'a::ordered_euclidean_space"
   by (subst sgn_mult_abs[symmetric]) (auto simp: that abs_inner )
 
 lemma inner_Basis_eq_zero_absI: "x \<in> Basis \<Longrightarrow> abs u \<in> Basis \<Longrightarrow> x \<noteq> \<bar>u\<bar> \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> u \<bullet> x = 0"
   for x::"'a::ordered_euclidean_space"
   apply (subst euclidean_inner)
   apply (auto simp: inner_Basis if_distribR if_distrib cong: if_cong)
   apply (subst inner_eq_abs_times_sgn)
   by (auto simp: inner_Basis)
 
 lemma abs_in_BasisE:
   fixes u::"'a::ordered_euclidean_space"
   assumes "abs u \<in> Basis"
   obtains "abs u = u" | "abs u = - u"
 proof (cases "u \<bullet> abs u = 1")
   case True
   have "abs u = (\<Sum>i\<in>Basis. (if i = abs u then (abs u \<bullet> i) *\<^sub>R i else 0))"
     using assms
     by (auto simp: )
   also have "\<dots> = (\<Sum>i\<in>Basis. (if i = abs u then (u \<bullet> i) *\<^sub>R i else 0))"
     by (rule sum.cong) (auto simp: True)
   also have "\<dots> = (\<Sum>i\<in>Basis. (u \<bullet> i) *\<^sub>R i)"
     by (rule sum.cong) (auto simp: inner_Basis_eq_zero_absI assms)
   also have "\<dots> = u" by (simp add: euclidean_representation)
   finally show ?thesis ..
 next
   case False
   then have F: "u \<bullet> \<bar>u\<bar> = -1"
     apply (subst inner_eq_abs_times_sgn[OF assms]) 
     apply (subst (asm) inner_eq_abs_times_sgn[OF assms]) 
     using assms
     apply (auto simp: inner_Basis sgn_if)
     by (metis (full_types) abs_0_eq euclidean_all_zero_iff inner_Basis_eq_zero_absI nonzero_Basis)
   have "abs u = (\<Sum>i\<in>Basis. (if i = abs u then (abs u \<bullet> i) *\<^sub>R i else 0))"
     using assms
     by (auto simp: )
   also have "\<dots> = (\<Sum>i\<in>Basis. (if i = abs u then (- u \<bullet> i) *\<^sub>R i else 0))"
     by (rule sum.cong) (auto simp: F)
   also have "\<dots> = (\<Sum>i\<in>Basis. (- u \<bullet> i) *\<^sub>R i)"
     by (rule sum.cong) (auto simp: inner_Basis_eq_zero_absI assms)
   also have "\<dots> = - u" by (subst euclidean_representation) simp
   finally show ?thesis ..
 qed
   
 lemma abs_in_Basis_iff:
   fixes u::"'a::ordered_euclidean_space"
   shows "abs u \<in> Basis \<longleftrightarrow> u \<in> Basis \<or> - u \<in> Basis"
 proof -
   have u: "u = (\<Sum>i\<in>Basis. (u \<bullet> i) *\<^sub>R i)"
     by (simp add: euclidean_representation)
   have u': "- u = (\<Sum>i\<in>Basis. (- (u \<bullet> i)) *\<^sub>R i)"
     by (subst u) (simp add: sum_negf)
   have au: "abs u = (\<Sum>i\<in>Basis. \<bar>u \<bullet> i\<bar> *\<^sub>R i)"
     by (simp add: eucl_abs[where 'a='a])
   have "(u \<in> Basis \<or> - u \<in> Basis)" if "(\<bar>u\<bar> \<in> Basis)"
     apply (rule abs_in_BasisE[OF that])
     using that
     by auto
   show ?thesis
     apply safe
     subgoal premises prems
       using prems(1)
       apply (rule abs_in_BasisE)
       using prems
       by simp_all
     subgoal
       apply (subst au)
       apply (subst (asm) u)
       apply (subst sum.cong[OF refl])
        apply (subst abs_inner[symmetric]) apply auto
       using u apply auto[1]
       done
     subgoal
       apply (subst au)
       apply (subst (asm) u')
       apply (subst sum.cong[OF refl])
       apply (subst abs_inner[symmetric]) apply auto
       using u' apply auto
       by (metis Basis_nonneg abs_of_nonpos inner_minus_left neg_0_le_iff_le scaleR_left.minus)
     done
 qed
 
 lemma abs_inner_Basis:
   fixes u v::"'a::ordered_euclidean_space"
   assumes "abs u \<in> Basis" "abs v \<in> Basis"
   shows "inner u v = (if u = v then 1 else if u = -v then -1 else 0)"
 proof -
   define i where "i \<equiv> if u \<in> Basis then u else -u"
   define j where "j \<equiv> if v \<in> Basis then v else -v"
   have u: "u = (if u \<in> Basis then i else - i)"
     and v: "v = (if v \<in> Basis then j else - j)"
     by (auto simp: i_def j_def)
   have "i \<in> Basis" "j \<in> Basis"
     using assms
      by (auto simp: i_def j_def abs_in_Basis_iff)
    then show ?thesis
      apply (subst u)
      apply (subst v)
      apply (auto simp: inner_Basis)
      apply (auto simp: j_def i_def split: if_splits)
      using Basis_nonneg abs_of_nonpos by fastforce
  qed
 
 lemma
   project_coord_inner_Basis:
   assumes "i \<in> Basis"
   shows "(project_coord x b n) \<bullet> i = (if i = b then n else if i = -b then -n else x \<bullet> i)"
 proof -
   have "project_coord x b n \<bullet> i =
     (\<Sum>j\<in>Basis. (if j = b then n else if j = -b then -n else x \<bullet> j) * (if j = i then 1 else 0))"
     using assms
     by (auto simp: project_coord_def inner_sum_left inner_Basis)
   also have "\<dots> = (\<Sum>j\<in>Basis. (if j = i then (if j = b then n else if j = -b then -n else x \<bullet> j) else 0))"
     by (rule sum.cong) auto
   also have "\<dots> = (if i = b then n else if i = -b then -n else x \<bullet> i)"
     using assms
     by (subst sum.delta) auto
   finally show ?thesis by simp
 qed
 
 lemma
   project_coord_inner:
   assumes "abs i \<in> Basis"
   shows "(project_coord x b n) \<bullet> i = (if i = b then n else if i = -b then -n else x \<bullet> i)"
 proof -
   consider "i \<in> Basis" | "- i \<in> Basis"
     using assms
     by (auto simp: abs_in_Basis_iff)
   then show ?thesis
   proof cases
     case 1
     then show ?thesis by (simp add: project_coord_inner_Basis)
   next
     case 2
     have "project_coord x b n \<bullet> i = - (project_coord x b n \<bullet> - i)"
       by simp
     also have "\<dots> = - (if - i = b then n else if - i = -b then -n else x \<bullet> - i)"
       using 2
       by (subst project_coord_inner_Basis) simp_all
     also have "\<dots> = (if i = b then n else if i = -b then -n else x \<bullet> i)"
       using 2 by auto (metis Basis_nonneg abs_le_zero_iff abs_of_nonneg neg_le_0_iff_le nonzero_Basis)
     finally show ?thesis .
   qed
 qed
 
 lift_definition project_coord_pdevs::"'a::executable_euclidean_space sctn \<Rightarrow> 'a pdevs \<Rightarrow> 'a pdevs" is
   "\<lambda>sctn xs i. project_coord (xs i) (normal sctn) 0"
   by (rule finite_subset) (auto simp: project_coord_def cong: if_cong)
 
 definition "project_coord_aform sctn cxs =
   (project_coord (fst cxs) (normal sctn) (pstn sctn), project_coord_pdevs sctn (snd cxs))"
 
 definition project_coord_aform_lv :: "real aform list \<Rightarrow> nat \<Rightarrow> real \<Rightarrow> real aform list"
   where "project_coord_aform_lv xs b n = xs[b:=(n, zero_pdevs)]"
 
 definition "project_ncoord_aform x b n = project_coord_aform (Sctn (Basis_list ! b) n) x"
 
 lemma
   finite_sum_subset_aux_lemma:
   assumes "finite s"
   shows " {i. (\<Sum>x\<in>s. f x i) \<noteq> 0} \<subseteq> {i. \<exists>x\<in>s. f x i \<noteq> 0}"
 proof -
   have "{i. (\<Sum>x\<in>s. f x i) \<noteq> 0} = - {i. (\<Sum>x\<in>s. f x i) = 0}"
     by auto
   also have "\<dots> \<subseteq> - {i. \<forall>x \<in> s. f x i = 0}"
     by auto
   also have "\<dots> = {i. \<exists>x \<in> s. f x i \<noteq> 0}"
     by auto
   finally show ?thesis by simp
 qed
 
 lift_definition sum_pdevs::"('i \<Rightarrow> 'a::comm_monoid_add pdevs) \<Rightarrow> 'i set \<Rightarrow>  'a pdevs"
   is "\<lambda>f X. if finite X then (\<lambda>i. \<Sum>x\<in>X. f x i) else (\<lambda>_. 0)"
   apply auto
   apply (rule finite_subset)
    apply (rule finite_sum_subset_aux_lemma)
    apply auto
   done
 
 lemma pdevs_apply_sum_pdevs[simp]:
   "pdevs_apply (sum_pdevs f X) i = (\<Sum>x\<in>X. pdevs_apply (f x) i)"
   by transfer auto
 
 lemma sum_pdevs_empty[simp]: "sum_pdevs f {} = zero_pdevs"
   by transfer auto
 
 lemma sum_pdevs_insert[simp]:
   "finite xs \<Longrightarrow> sum_pdevs f (insert a xs) =
     (if a \<in> xs then sum_pdevs f xs else add_pdevs (f a) (sum_pdevs f xs))"
   by (auto simp: insert_absorb intro!: pdevs_eqI)
 
 lemma sum_pdevs_infinite[simp]: "infinite X \<Longrightarrow> sum_pdevs f X = zero_pdevs"
   by transfer auto
 
 lemma compute_sum_pdevs[code]:
   "sum_pdevs f (set XS) = foldr (\<lambda>a b. add_pdevs (f a) b) (remdups XS) zero_pdevs"
   by (induction XS) (auto simp: )
 
 lemma degree_sum_pdevs_le:
   "degree (sum_pdevs f X) \<le> Max (degree ` f ` X)"
   apply (rule degree_le)
   apply auto
   apply (cases "X = {}")
   subgoal by (simp add: )
   subgoal by (cases "finite X") simp_all
   done
 
 lemma pdevs_val_sum_pdevs:
   "pdevs_val e (sum_pdevs f X) = (\<Sum>x\<in>X. pdevs_val e (f x))"
   apply (cases "finite X")
   subgoal
     apply (subst pdevs_val_sum_le)
      apply (rule degree_sum_pdevs_le)
     apply (auto simp: scaleR_sum_right)
     apply (subst sum.swap)
     apply (rule sum.cong[OF refl])
     apply (subst pdevs_val_sum_le[where d="Max (degree ` f ` X)"])
      apply (auto simp: Max_ge_iff)
     done
   subgoal by simp
   done
 
 definition eucl_of_list_aform :: "(real \<times> real pdevs) list \<Rightarrow> 'a::executable_euclidean_space aform"
 where "eucl_of_list_aform xs =
   (eucl_of_list (map fst xs), sum_pdevs (\<lambda>i. pdevs_scaleR (snd (xs ! index Basis_list i)) i) Basis)"
 
 definition lv_aforms_rel::"(((real \<times> real pdevs) list) \<times> ('a::executable_euclidean_space aform)) set"
   where "lv_aforms_rel = br eucl_of_list_aform (\<lambda>xs. length xs = DIM('a))"
 
 
 definition "inner_aforms' p X Y =
   (let fas = [inner_floatariths (map floatarith.Var [0..<length X])
     (map floatarith.Var[length X..<length X + length Y])]
   in
     approx_slp_outer p (length fas) fas (X@Y)
     )"
 
 lemma
   affine_extension_AffineD:
   assumes "affine_extension2 (\<lambda>d x y. Some (F d x y)) f"
   assumes "[x, y] \<in> Joints [X, Y]"
   assumes "d \<ge> degree_aform X"
   assumes "d \<ge> degree_aform Y"
   shows "f x y \<in> Affine (F d X Y)"
 proof -
   from assms(2) obtain e where e:
     "e \<in> funcset UNIV {-1 .. 1}"
     "x = aform_val e X"
     "y = aform_val e Y"
     by (auto simp: Joints_def valuate_def)
   from affine_extension2E[OF assms(1) refl e(1) assms(3) assms(4)]
   obtain e' where "e' \<in> funcset UNIV {- 1..1}" "f (aform_val e X) (aform_val e Y) = aform_val e' (F d X Y)"
     "\<And>n. n < d \<Longrightarrow> e' n = e n" "aform_val e X = aform_val e' X" "aform_val e Y = aform_val e' Y"
     by auto
   then show ?thesis by (auto simp: Affine_def valuate_def e)
 qed
 
 lemma aform_val_zero_pdevs[simp]: "aform_val e (x, zero_pdevs) = x"
   by (auto simp: aform_val_def)
 
 lemma neg_equal_zero_eucl[simp]: "-a = a \<longleftrightarrow> a = 0" for a::"'a::euclidean_space"
   by (auto simp: algebra_simps euclidean_eq_iff[where 'a='a])
 
 context includes autoref_syntax begin
 
 lemma Option_bind_param[param, autoref_rules]:
   "((\<bind>), (\<bind>)) \<in> \<langle>S\<rangle>option_rel \<rightarrow> (S \<rightarrow> \<langle>R\<rangle>option_rel) \<rightarrow> \<langle>R\<rangle>option_rel"
   unfolding Option.bind_def
   by parametricity
 
 lemma zip_Basis_list_pat[autoref_op_pat_def]: "\<Sum>(b, m)\<leftarrow>zip Basis_list ms. m *\<^sub>R b \<equiv> OP eucl_of_list $ ms"
 proof (rule eq_reflection)
   have z: "zip ms (Basis_list::'a list) = map (\<lambda>(x, y). (y, x)) (zip Basis_list ms)"
     by (subst zip_commute) simp
   show "(\<Sum>(b, m)\<leftarrow>zip (Basis_list::'a list) ms. m *\<^sub>R b) = OP eucl_of_list $ ms"
     unfolding eucl_of_list_def autoref_tag_defs
     apply (subst z)
     apply (subst map_map)
     apply (auto cong: map_cong simp: split_beta')
     done
 qed
 
 lemma length_aforms_of_ivls: "length (aforms_of_ivls a b) = min (length a) (length b)"
   by (auto simp: aforms_of_ivls_def)
 
 lemma length_lv_rel:
   "(ys, y::'a) \<in> lv_rel \<Longrightarrow> length ys = DIM('a::executable_euclidean_space)"
   by (auto simp: lv_rel_def br_def)
 
 lemma lv_rel_nth[simp]: "(xs, x::'a::executable_euclidean_space) \<in> lv_rel \<Longrightarrow> b \<in> Basis \<Longrightarrow>
   xs ! index (Basis_list) b = x \<bullet> b"
   unfolding lv_rel_def
   by (auto simp: br_def eucl_of_list_inner)
 
 lemma aform_of_ivl_autoref[autoref_rules]:
   "(aforms_of_ivls, aform_of_ivl) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_aforms_rel"
   apply (auto simp: lv_aforms_rel_def br_def eucl_of_list_aform_def length_aforms_of_ivls length_lv_rel)
   subgoal for xs x ys y
     apply (auto simp: aform_of_ivl_def aforms_of_ivls_def o_def eucl_of_list_inner inner_simps
         pdevs_apply_pdevs_of_ivl length_lv_rel
         intro!: euclidean_eqI[where 'a='a] pdevs_eqI)
     by (metis index_Basis_list_nth inner_not_same_Basis length_Basis_list nth_Basis_list_in_Basis)
   done
 
 lemma bound_intersect_2d_ud[autoref_rules]:
   shows "(bound_intersect_2d_ud, bound_intersect_2d_ud) \<in> nat_rel \<rightarrow> ((rnv_rel \<times>\<^sub>r rnv_rel) \<times>\<^sub>r Id) \<rightarrow> rnv_rel \<rightarrow> \<langle>rnv_rel \<times>\<^sub>r rnv_rel\<rangle>option_rel"
   by auto
 
 lemma eucl_of_list_autoref[autoref_rules]:
   includes autoref_syntax
   assumes "SIDE_PRECOND (length xs = DIM('a::executable_euclidean_space))"
   assumes "(xsi, xs) \<in> \<langle>rnv_rel\<rangle>list_rel"
   shows "(xsi, eucl_of_list $ xs::'a) \<in> lv_rel"
   using assms
   unfolding lv_rel_def
   by (auto simp: br_def)
 
 definition "inner2s x b c = (inner_lv_rel x b, inner_lv_rel x c)"
 
 lemma inner_lv_rel_autoref[autoref_rules]:
   "(inner_lv_rel, (\<bullet>)) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> rnv_rel"
   using lv_rel_inner[unfolded inner_lv_rel_def[symmetric]]
   by auto
 
 lemma inner_lv_rel_eq:
   "\<lbrakk>length xs = DIM('a::executable_euclidean_space); (xa, x'a) \<in> lv_rel\<rbrakk> \<Longrightarrow>
   inner_lv_rel xs xa = eucl_of_list xs \<bullet> (x'a::'a)"
   using inner_lv_rel_autoref[param_fo, of "xs" "eucl_of_list xs" xa x'a]
   unfolding lv_rel_def
   by (auto simp: br_def)
 
 definition "inner_pdevs xs ys = sum_pdevs (\<lambda>i. scaleR_pdevs (ys ! i) (xs ! i)) {..<length xs}"
 
 definition "pdevs_inner2s xs a b = prod_of_pdevs (inner_pdevs xs a) (inner_pdevs xs b)"
 
 lemma inner2_aform_autoref[autoref_rules]:
   shows "((\<lambda>xs a b. (inner2s (map fst xs) a b, pdevs_inner2s (map snd xs) a b)), inner2_aform) \<in> lv_aforms_rel \<rightarrow> lv_rel \<rightarrow> lv_rel \<rightarrow> ((rnv_rel \<times>\<^sub>r rnv_rel)\<times>\<^sub>rId)"
   unfolding inner2_aform_def
   apply (auto simp: lv_aforms_rel_def br_def eucl_of_list_aform_def inner2_aform_def )
    apply (auto simp: inner2s_def inner2_def inner_lv_rel_eq pdevs_inner2s_def inner_pdevs_def
       sum_Basis_sum_nth_Basis_list inner_sum_left inner_Basis mult.commute
       intro!: pdevs_eqI)
   subgoal for a b c d e f
     apply (rule sum.cong)
      apply force
     subgoal for n by (auto dest!: lv_rel_nth[where b="Basis_list ! n"] simp: inner_commute)
     done
   subgoal for a b c d e f
     apply (rule sum.cong)
      apply force
     subgoal for n by (auto dest!: lv_rel_nth[where b="Basis_list ! n"] simp: inner_commute)
     done
   done
 
 lemma RETURN_inter_aform_plane_ortho_annot:
   "RETURN (inter_aform_plane_ortho p (Z::'a aform) n g) =
     (case those (map (\<lambda>b. bound_intersect_2d_ud p (inner2_aform Z n b) g) Basis_list) of
       Some mMs \<Rightarrow>
       do {
         ASSERT (length mMs = DIM('a::executable_euclidean_space));
         let l = (\<Sum>(b, m)\<leftarrow>zip Basis_list (map fst mMs). m *\<^sub>R b);
         let u = (\<Sum>(b, M)\<leftarrow>zip Basis_list (map snd mMs). M *\<^sub>R b);
         RETURN (Some (aform_of_ivl l u))
       }
   | None \<Rightarrow> RETURN None)"
   apply (auto simp: inter_aform_plane_ortho_def split: option.splits)
   subgoal premises prems for x2
   proof -
     have "length x2 = DIM('a)" using prems
       using map_eq_imp_length_eq by (force simp: those_eq_Some_map_Some_iff)
     then show ?thesis using prems by auto
   qed
   done
 
 definition "inter_aform_plane_ortho_nres p Z n g = RETURN (inter_aform_plane_ortho p Z n g)"
 
 schematic_goal inter_aform_plane_ortho_lv:
   fixes Z::"'a::executable_euclidean_space aform"
   assumes [autoref_rules_raw]: "DIM_precond TYPE('a) D"
   assumes [autoref_rules]: "(pp, p) \<in> nat_rel" "(Zi, Z) \<in> lv_aforms_rel"
     "(ni, n) \<in> lv_rel" "(gi, g) \<in> rnv_rel"
   notes [autoref_rules] = those_param param_map
   shows "(nres_of (?f::?'a dres), inter_aform_plane_ortho_nres $ p $ Z $ n $ g) \<in> ?R"
   unfolding autoref_tag_defs
   unfolding RETURN_inter_aform_plane_ortho_annot inter_aform_plane_ortho_nres_def
   including art
   by autoref_monadic
 concrete_definition inter_aform_plane_ortho_lv for pp Zi ni gi uses inter_aform_plane_ortho_lv
 lemmas [autoref_rules] = inter_aform_plane_ortho_lv.refine
 
 lemma project_coord_lv[autoref_rules]:
   assumes "(xs, x::'a::executable_euclidean_space aform) \<in> lv_aforms_rel" "(ni, n) \<in> nat_rel"
   assumes "SIDE_PRECOND (n < DIM('a))"
   shows "(project_coord_aform_lv xs ni, project_ncoord_aform $ x $ n) \<in> rnv_rel \<rightarrow> lv_aforms_rel"
   using assms
   apply (auto simp: project_coord_aform_lv_def project_ncoord_aform_def lv_rel_def
       project_coord_aform_def eucl_of_list_aform_def
       lv_aforms_rel_def br_def)
   subgoal
     apply (auto intro!: euclidean_eqI[where 'a='a])
     apply (subst project_coord_inner_Basis)
      apply (auto simp: eucl_of_list_inner )
      apply (subst nth_list_update)
       apply (auto simp: )
     using in_Basis_index_Basis_list apply force
     using inner_not_same_Basis nth_Basis_list_in_Basis apply fastforce
     apply (auto simp: nth_list_update)
     done
   subgoal for i
     apply (auto intro!: pdevs_eqI simp: project_coord_pdevs.rep_eq)
     apply (auto intro!: euclidean_eqI[where 'a='a])
     apply (subst project_coord_inner_Basis)
      apply (auto simp: eucl_of_list_inner )
      apply (subst nth_list_update)
       apply (auto simp: )
     using inner_not_same_Basis nth_Basis_list_in_Basis apply fastforce
     apply (auto simp: nth_list_update)
     done
   done
 
 definition inter_aform_plane
   where "inter_aform_plane prec Xs (sctn::'a sctn) =
     do {
       cxs \<leftarrow> inter_aform_plane_ortho_nres (prec) (Xs) (normal sctn) (pstn sctn);
       case cxs of
         Some cxs \<Rightarrow>
           (if normal sctn \<in> set Basis_list
             then do {
               ASSERT (index Basis_list (normal sctn) < DIM('a::executable_euclidean_space));
               RETURN ((project_ncoord_aform cxs (index Basis_list (normal sctn)) (pstn sctn)))
             }
           else if - normal sctn \<in> set Basis_list
             then do {
               ASSERT (index Basis_list (-normal sctn) < DIM('a));
               RETURN ((project_ncoord_aform cxs (index Basis_list (-normal sctn)) (- pstn sctn)))
             }
           else SUCCEED)
       | None \<Rightarrow> SUCCEED
     }"
 
 lemma [autoref_rules]:
   assumes [THEN GEN_OP_D, param]: "GEN_OP (=) (=) (A \<rightarrow> A \<rightarrow> bool_rel)"
   shows "(index, index) \<in> \<langle>A\<rangle>list_rel \<rightarrow> A \<rightarrow> nat_rel"
   unfolding index_def find_index_def
   by parametricity
 
 schematic_goal inter_aform_plane_lv:
   fixes Z::"'a::executable_euclidean_space aform"
   assumes [autoref_rules_raw]: "DIM_precond TYPE('a) D"
   assumes [autoref_rules]: "(preci, prec) \<in> nat_rel" "(Zi, Z) \<in> lv_aforms_rel"
       "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
   notes [autoref_rules] = those_param param_map
   shows "(nres_of (?f::?'a dres), inter_aform_plane prec Z sctn) \<in> ?R"
   unfolding autoref_tag_defs
   unfolding inter_aform_plane_def
   including art
   by (autoref_monadic )
 
 concrete_definition inter_aform_plane_lv for preci Zi sctni uses inter_aform_plane_lv
 lemmas [autoref_rules] = inter_aform_plane_lv.refine[autoref_higher_order_rule(1)]
 
 end
 
 
 lemma Basis_not_uminus:
   fixes i::"'a::euclidean_space"
   shows "i \<in> Basis \<Longrightarrow> - i \<notin> Basis"
   by (metis inner_Basis inner_minus_left one_neq_neg_one zero_neq_neg_one)
 
 lemma
   pdevs_apply_project_coord_pdevs:
   assumes "normal sctn \<in> Basis \<or> - normal sctn \<in> Basis"
   assumes "i \<in> Basis"
   shows "pdevs_apply (project_coord_pdevs sctn cxs) x \<bullet> i =
     (if i = abs (normal sctn) then 0 else pdevs_apply cxs x \<bullet> i)"
   using assms[unfolded abs_in_Basis_iff[symmetric]]
   apply (transfer fixing: sctn)
   apply (auto simp: project_coord_inner Basis_not_uminus)
   using Basis_nonneg apply force
   using Basis_nonneg assms(1) by force
 
 lemma pdevs_domain_project_coord_pdevs_subset:
   "pdevs_domain (project_coord_pdevs sctn X) \<subseteq> pdevs_domain X"
   apply (auto simp: )
   apply (auto simp: euclidean_eq_iff[where 'a='a] )
   by (metis add.inverse_neutral project_coord_inner_Basis project_coord_pdevs.rep_eq)
 
 lemma pdevs_val_project_coord_pdevs_inner_Basis:
   assumes "b \<in> Basis"
   shows "pdevs_val e (project_coord_pdevs sctn X) \<bullet> b =
     (if b = abs (normal sctn) then 0 else pdevs_val e X \<bullet> b)"
   using assms
   apply (auto simp: )
    apply (simp add: pdevs_val_pdevs_domain inner_sum_left )
    apply (subst sum.cong[OF refl])
     apply (subst pdevs_apply_project_coord_pdevs)
       apply (simp add: abs_in_Basis_iff)
      apply simp
     apply (rule refl)
    apply auto
   unfolding pdevs_val_pdevs_domain inner_sum_left
   apply (rule sum.mono_neutral_cong_left)
      apply simp
     apply (rule pdevs_domain_project_coord_pdevs_subset)
      apply auto
    apply (metis Basis_nonneg abs_minus_cancel abs_of_nonneg euclidean_all_zero_iff
       project_coord_inner_Basis project_coord_pdevs.rep_eq)
    apply (metis Basis_nonneg abs_minus_cancel abs_of_nonneg
       project_coord_inner_Basis project_coord_pdevs.rep_eq)
   done
 
 lemma inner_in_Sum: "b \<in> Basis \<Longrightarrow> x \<bullet> b = (\<Sum>i\<in>Basis. x \<bullet> i * (i \<bullet> b))"
   apply (subst euclidean_representation[of x, symmetric])
   unfolding inner_sum_left
   by (auto simp: intro!: )
 
 lemma aform_val_project_coord_aform:
   "aform_val e (project_coord_aform sctn X) = project_coord (aform_val e X) (normal sctn) (pstn sctn)"
   apply (auto simp: aform_val_def project_coord_def project_coord_aform_def)
   apply (rule euclidean_eqI)
   unfolding inner_add_left inner_sum_left
   apply (subst pdevs_val_project_coord_pdevs_inner_Basis)
    apply (auto simp: )
    apply (rule sum.cong)
   apply auto
    apply (metis abs_in_Basis_iff abs_inner abs_inner_Basis abs_zero inner_commute)
   apply (subst inner_in_Sum[where x="pdevs_val e (snd X)"], force)
   unfolding sum.distrib[symmetric]
   apply (rule sum.cong)
   apply auto
   apply (metis Basis_nonneg abs_inner_Basis abs_of_nonneg abs_of_nonpos inner_commute neg_0_le_iff_le)
    apply (metis Basis_nonneg abs_inner_Basis abs_of_nonneg abs_of_nonpos neg_0_le_iff_le)
   apply (auto simp: inner_Basis)
   done
 
 lemma project_coord_on_plane:
   assumes "x \<in> plane_of (Sctn n c)"
   shows "project_coord x n c = x"
   using assms
   by (auto simp: project_coord_def plane_of_def intro!: euclidean_eqI[where 'a='a])
 
 lemma
   mem_Affine_project_coord_aformI:
   assumes "x \<in> Affine X"
   assumes "x \<in> plane_of sctn"
   shows "x \<in> Affine (project_coord_aform sctn X)"
 proof -
   have "x = project_coord x (normal sctn) (pstn sctn)"
     using assms by (intro project_coord_on_plane[symmetric]) auto
   also
   from assms obtain e where "e \<in> funcset UNIV {-1 .. 1}" "x = aform_val e X"
     by (auto simp: Affine_def valuate_def)
   note this(2)
   also have "project_coord (aform_val e X) (normal sctn) (pstn sctn) =
     aform_val e (project_coord_aform sctn X)"
     by (simp add: aform_val_project_coord_aform)
   finally have "x = aform_val e (project_coord_aform sctn X)" unfolding \<open>x = aform_val e X\<close> .
   then show ?thesis using \<open>e \<in> _\<close>
     by (auto simp: Affine_def valuate_def)
 qed
 
 lemma
   mem_Affine_project_coord_aformD:
   assumes "x \<in> Affine (project_coord_aform sctn X)"
   assumes "abs (normal sctn) \<in> Basis"
   shows "x \<in> plane_of sctn"
   using assms
   by (auto simp: Affine_def valuate_def aform_val_project_coord_aform plane_of_def
       project_coord_inner)
 
 definition "reduce_aform prec t X =
     summarize_aforms (prec) (collect_threshold (prec) 0 t) (degree_aforms X) X"
 
 definition "correct_girard p m N (X::real aform list) =
   (let
     Xs = map snd X;
     M = pdevs_mapping Xs;
     D = domain_pdevs Xs;
     diff = m - card D
   in if 0 < diff then (\<lambda>_ _. True) else
     let
       Ds = sorted_list_of_set D;
       ortho_indices = map fst (take (diff + N) (sort_key (\<lambda>(i, r). r) (map (\<lambda>i. let xs = M i in (i, sum_list' p (map abs xs) - fold max (map abs xs) 0)) Ds)));
       _ = ()
     in (\<lambda>i (xs::real list). i \<notin> set ortho_indices))"
 
 definition "reduce_aforms prec C X = summarize_aforms (prec) C (degree_aforms X) X"
 
 definition "pdevs_of_real x = (x, zero_pdevs)"
 
 definition aform_inf_inner where "aform_inf_inner prec X n =
   (case inner_aforms' (prec) X (map pdevs_of_real n) of
     Some Xn \<Rightarrow> Inf_aform' (prec) (hd Xn))"
 definition aform_sup_inner where "aform_sup_inner prec X n =
   (case inner_aforms' (prec) X (map pdevs_of_real n) of
     Some Xn \<Rightarrow> Sup_aform' (prec) (hd Xn))"
 
 text \<open>cannot fail\<close>
 
 lemma approx_un_ne_None: "approx_un p (\<lambda>ivl. Some (f ivl)) (Some r) \<noteq> None"
   by (auto simp: approx_un_def split_beta')
 
 lemma approx_un_eq_Some:
   "approx_un p (\<lambda>ivl. Some (f ivl)) (Some r) = Some s \<longleftrightarrow>
   s = ivl_err (real_interval (f (ivl_of_aform_err p r)))"
   using approx_un_ne_None
   by (auto simp: approx_un_def split_beta')
 
 lemma is_float_uminus:
   "is_float aa \<Longrightarrow> is_float (- aa)"
   by (auto simp: is_float_def)
 
 lemma is_float_uminus_iff[simp]:
   "is_float (- aa) = is_float aa"
   using is_float_uminus[of aa] is_float_uminus[of "-aa"]
   by (auto simp: is_float_def)
 
 lemma is_float_simps[simp]:
   "is_float 0"
   "is_float 1"
   "is_float (real_of_float x)"
   "is_float (truncate_down p X)"
   "is_float (truncate_up p X)"
   "is_float (eucl_truncate_down p X)"
   "is_float (eucl_truncate_up p X)"
   by (auto simp: is_float_def eucl_truncate_down_def eucl_truncate_up_def truncate_down_def truncate_up_def)
 
 lemma is_float_sum_list'[simp]:
   "is_float (sum_list' p xs)"
   by (induction xs) (auto simp: is_float_def)
 
 lemma is_float_inverse_aform': "is_float (fst (fst (inverse_aform' p X)))"
   unfolding inverse_aform'_def
   by (simp add: Let_def trunc_bound_eucl_def)
 
 lemma is_float_min_range:
   "min_range_antimono p F D E X Y = Some ((a, b), c) \<Longrightarrow> is_float a"
   "min_range_antimono p F D E X Y = Some ((a, b), c) \<Longrightarrow> is_float c"
   "min_range_mono p F D E X Y = Some ((a, b), c) \<Longrightarrow> is_float a"
   "min_range_mono p F D E X Y = Some ((a, b), c) \<Longrightarrow> is_float c"
   by (auto simp: min_range_antimono_def min_range_mono_def Let_def bind_eq_Some_conv
       prod_eq_iff trunc_bound_eucl_def
       mid_err_def affine_unop_def split: prod.splits)
 
 lemma is_float_ivl_err:
   assumes "ivl_err x = ((a, b), c)" "is_float (lower x)" "is_float (upper x)"
   shows "is_float a" "is_float c"
 proof -
   define x1 where "x1 = lower x"
   define x2 where "x2 = upper x"
   have "a = (x1 + x2) / 2" "c = (x2 - x1) / 2"
     using assms by (auto simp: ivl_err_def x1_def x2_def)
   moreover have "(x1 + x2) / 2 \<in> float" "(x2 - x1) / 2 \<in> float"
     using assms
     by (auto simp: is_float_def x1_def x2_def)
   ultimately show "is_float a" "is_float c"
     unfolding is_float_def by blast+
 qed
 
 lemma is_float_trunc_bound_eucl[simp]:
   "is_float (fst (trunc_bound_eucl p X))"
   by (auto simp: trunc_bound_eucl_def Let_def)
 
 lemma add_eq_times_2_in_float: "a + b = c * 2 \<Longrightarrow> is_float a \<Longrightarrow> is_float b \<Longrightarrow> is_float c"
 proof goal_cases
   case 1
   then have "c = (a + b) / 2"
     by simp
   also have "\<dots> \<in> float" using 1(3,2) by (simp add: is_float_def)
   finally show ?case by (simp add: is_float_def)
 qed
 
 
 lemma approx_floatarith_Some_is_float:
   "approx_floatarith p fa XS = Some ((a, b), ba) \<Longrightarrow>
   list_all (\<lambda>((a, b), c). is_float a \<and> is_float c) XS \<Longrightarrow>
   is_float a \<and> is_float ba"
   apply (induction fa arbitrary: a b ba)
   subgoal by (auto simp: bind_eq_Some_conv add_aform'_def Let_def )
   subgoal by (auto simp: bind_eq_Some_conv uminus_aform_def Let_def)
   subgoal by (auto simp: bind_eq_Some_conv mult_aform'_def Let_def )
   subgoal by (auto simp: bind_eq_Some_conv inverse_aform_err_def map_aform_err_def
         prod_eq_iff is_float_inverse_aform'
         acc_err_def aform_to_aform_err_def aform_err_to_aform_def inverse_aform_def
         Let_def split: if_splits)
   subgoal by (auto simp: bind_eq_Some_conv cos_aform_err_def Let_def is_float_min_range
         is_float_ivl_err
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv arctan_aform_err_def Let_def is_float_min_range
         is_float_ivl_err
         split: if_splits prod.splits)
   subgoal apply (auto simp: bind_eq_Some_conv uminus_aform_def Let_def is_float_min_range
         is_float_ivl_err set_of_eq real_interval_abs
         split: if_splits prod.splits)
     apply (metis is_float_ivl_err(1) is_float_simps(3) lower_real_interval real_interval_abs upper_real_interval)
     by (metis is_float_ivl_err(2) is_float_simps(3) lower_real_interval real_interval_abs upper_real_interval)
   subgoal by (auto simp: bind_eq_Some_conv max_aform_err_def Let_def is_float_min_range
         is_float_ivl_err max_def
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv min_aform_err_def Let_def is_float_min_range
         is_float_ivl_err min_def
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv arctan_aform_err_def Let_def is_float_min_range
         is_float_ivl_err
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv sqrt_aform_err_def Let_def is_float_min_range
         is_float_ivl_err
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv exp_aform_err_def Let_def is_float_min_range
         is_float_ivl_err
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv powr_aform_err_def approx_bin_def
         exp_aform_err_def Let_def is_float_min_range
         is_float_ivl_err mult_aform'_def
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv ln_aform_err_def Let_def is_float_min_range
         is_float_ivl_err
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv power_aform_err_def Let_def is_float_min_range
         is_float_ivl_err mid_err_def dest!: add_eq_times_2_in_float
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv cos_aform_err_def Let_def is_float_min_range
         approx_un_def is_float_ivl_err
         split: if_splits)
   subgoal by (auto simp: bind_eq_Some_conv cos_aform_err_def Let_def is_float_min_range
         list_all_length
         split: if_splits)
   subgoal by (auto simp: bind_eq_Some_conv num_aform_def Let_def)
   done
 
 lemma plain_floatarith_not_None:
   assumes "plain_floatarith N fa" "N \<le> length XS"
     "list_all (\<lambda>((a, b), c). is_float a \<and> is_float c) XS"
   shows "approx_floatarith p fa XS \<noteq> None"
   using assms
   by (induction fa)
     (auto simp: Let_def split_beta' approx_un_eq_Some prod_eq_iff
       approx_floatarith_Some_is_float)
 
 lemma plain_floatarith_slp_not_None:
   assumes "\<And>fa. fa \<in> set fas \<Longrightarrow> plain_floatarith N fa" "N \<le> length XS"
     "list_all (\<lambda>((a, b), c). is_float a \<and> is_float c) XS"
   shows "approx_slp p fas XS \<noteq> None"
   using assms 
   apply (induction fas arbitrary: XS)
   subgoal by simp
   subgoal for fa fas XS
     using plain_floatarith_not_None[of N fa XS p]
     by (auto simp: Let_def split_beta' approx_un_eq_Some prod_eq_iff
       bind_eq_Some_conv approx_floatarith_Some_is_float)
   done
 
 lemma plain_floatarithE:
   assumes "plain_floatarith N fa" "N \<le> length XS"
     "list_all (\<lambda>((a, b), c). is_float a \<and> is_float c) XS"
   obtains R where "approx_floatarith p fa XS = Some R"
   using plain_floatarith_not_None[OF assms]
   by force
 
 lemma approx_slp_outer_eq_None_iff:
   "approx_slp_outer p a b XS = None \<longleftrightarrow>
     approx_slp p b ((map (\<lambda>x. (x, 0)) XS)) = None"
   by (auto simp: approx_slp_outer_def Let_def bind_eq_None_conv)
 
 lemma approx_slp_sing_eq_None_iff:
   "approx_slp p [b] xs = None \<longleftrightarrow> approx_floatarith p b xs = None"
   by (auto simp: approx_slp_outer_def Let_def bind_eq_None_conv)
 
 lemma plain_inner_floatariths:
   "plain_floatarith N (inner_floatariths xs ys)"
   if "list_all (plain_floatarith N) xs"  "list_all (plain_floatarith N) ys"
   using that
   by (induction xs ys rule: inner_floatariths.induct) auto
 
 lemma aiN: "approx_floatarith p (inner_floatariths xs ys) zs \<noteq> None"
   if "\<And>x. x \<in> set xs \<Longrightarrow> approx_floatarith p x zs \<noteq> None"
   and "\<And>x. x \<in> set ys \<Longrightarrow> approx_floatarith p x zs \<noteq> None"
   using that
   apply (induction xs ys rule: inner_floatariths.induct)
   apply (auto simp: Let_def bind_eq_Some_conv)
   by (metis old.prod.exhaust)
 
 lemma aiVN: "approx_floatarith p
         (inner_floatariths (map floatarith.Var [0..<length a])
           (map floatarith.Var [length a..<length a + length b]))
         (map (\<lambda>x. (x, 0)) a @ map (\<lambda>x. (x, 0)) b) \<noteq> None"
   by (rule aiN) (auto simp: nth_append)
 
 lemma iaN: "inner_aforms' p a b \<noteq> None"
   unfolding inner_aforms'_def Let_def approx_slp_outer_def
   using aiVN[of p a b]
   by (auto simp: Let_def bind_eq_Some_conv)
 
 definition "support_aform prec b X = (let ia = inner_aform X b in fst X \<bullet> b + tdev' (prec) (snd ia))"
 
 definition "width_aforms prec X =
   (let t = tdev' (prec) ((abssum_of_pdevs_list (map snd X))) in t)"
 
 definition "inf_aforms prec xs = map (Inf_aform' (prec)) xs"
 definition "sup_aforms prec xs = map (Sup_aform' (prec)) xs"
 
 definition "fresh_index_aforms xs = Max (insert 0 (degree_aform ` set xs))"
 
 definition "independent_aforms x env = (msum_aform (fresh_index_aforms env) (0, zero_pdevs) x#env)"
 
 definition "aform_form_ivl prec form xs =
   dRETURN (approx_form prec form (ivls_of_aforms prec xs) [])"
 definition "aform_form prec form xs =
   dRETURN (approx_form_aform prec form xs)"
 definition "aform_slp prec n slp xs =
   dRETURN (approx_slp_outer prec n slp xs)"
 definition
   "aform_isFDERIV prec n ns fas xs =
     dRETURN (isFDERIV_approx prec n ns fas (ivls_of_aforms prec xs))"
 
 definition aform_rel_internal: "aform_rel R = br Affine top O \<langle>R\<rangle>set_rel"
 lemma aform_rel_def: "\<langle>rnv_rel\<rangle>aform_rel = br Affine top"
   unfolding relAPP_def
   by (auto simp: aform_rel_internal)
 definition "aforms_rel = br Joints top"
 
 definition aform_rell :: "((real \<times> real pdevs) list \<times> real list set) set"
 where "aform_rell = aforms_rel"
 
 definition aforms_relp_internal: "aforms_relp R = aforms_rel O \<langle>R\<rangle>set_rel"
 lemma aforms_relp_def: "\<langle>R\<rangle>aforms_relp = aforms_rel O \<langle>R\<rangle>set_rel"
   by (auto simp: aforms_relp_internal relAPP_def)
 
 definition "product_aforms x y = x @ msum_aforms (degree_aforms (x)) (replicate (length y) (0, zero_pdevs)) y"
 
 lemma
   eucl_of_list_mem_eucl_of_list_aform:
   assumes "x \<in> Joints a"
   assumes "length a = DIM('a::executable_euclidean_space)"
   shows "eucl_of_list x \<in> Affine (eucl_of_list_aform a::'a aform)"
   using assms
   by (auto simp: Joints_def Affine_def valuate_def eucl_of_list_aform_def
       aform_val_def pdevs_val_sum_pdevs inner_simps eucl_of_list_inner
       intro!: euclidean_eqI[where 'a='a])
 
 lemma
   in_image_eucl_of_list_eucl_of_list_aform:
   assumes "length x = DIM('a::executable_euclidean_space)" "xa \<in> Affine (eucl_of_list_aform x::'a aform)"
   shows "xa \<in> eucl_of_list ` Joints x"
   using assms
   by (auto intro!: nth_equalityI image_eqI[where x="list_of_eucl xa"]
       simp: aform_val_def eucl_of_list_aform_def Affine_def valuate_def Joints_def
       inner_simps pdevs_val_sum_pdevs eucl_of_list_inner)
 
 lemma
   eucl_of_list_image_Joints:
   assumes "length x = DIM('a::executable_euclidean_space)"
   shows "eucl_of_list ` Joints x = Affine (eucl_of_list_aform x::'a aform)"
   using assms
   by (auto intro!: eucl_of_list_mem_eucl_of_list_aform
       in_image_eucl_of_list_eucl_of_list_aform)
 
 definition "aform_ops =
 \<lparr>
   appr_of_ivl = aforms_of_ivls,
   product_appr = product_aforms,
   msum_appr = msum_aforms',
   inf_of_appr = \<lambda>optns. inf_aforms (precision optns),
   sup_of_appr = \<lambda>optns. sup_aforms (precision optns),
   split_appr = split_aforms_largest_uncond_take,
   appr_inf_inner = \<lambda>optns. aform_inf_inner (precision optns),
   appr_sup_inner = \<lambda>optns. aform_sup_inner (precision optns),
   inter_appr_plane = \<lambda>optns xs sctn. inter_aform_plane_lv (length xs) (precision optns) xs sctn,
   reduce_appr = \<lambda>optns. reduce_aforms (precision optns),
   width_appr = \<lambda>optns. width_aforms (precision optns),
   approx_slp_dres = \<lambda>optns. aform_slp (precision optns),
   approx_euclarithform = \<lambda>optns. aform_form (precision optns),
   approx_isFDERIV = \<lambda>optns. aform_isFDERIV  (precision optns)
 \<rparr>"
 
 lemma Affine_eq_permI:
   assumes "fst X = fst Y"
   assumes "map snd (list_of_pdevs (snd X)) <~~> map snd (list_of_pdevs (snd Y))" (is "?perm X Y")
   shows "Affine X = Affine Y"
 proof -
   {
     fix X Y and e::"nat \<Rightarrow> real"
     assume perm: "?perm X Y" and e: "e \<in> funcset UNIV {- 1..1}"
     from pdevs_val_of_list_of_pdevs2[OF e, of "snd X"]
     obtain e' where e':
       "pdevs_val e (snd X) = pdevs_val e' (pdevs_of_list (map snd (list_of_pdevs (snd X))))"
       "e' \<in> funcset UNIV {- 1..1}"
       by auto
     note e'(1)
     also from pdevs_val_perm[OF perm e'(2)]
     obtain e'' where e'':
       "e'' \<in> funcset UNIV {- 1..1}"
       "pdevs_val e' (pdevs_of_list (map snd (list_of_pdevs (snd X)))) =
       pdevs_val e'' (pdevs_of_list (map snd (list_of_pdevs (snd Y))))"
       by auto
     note e''(2)
     also from pdevs_val_of_list_of_pdevs[OF e''(1), of "snd Y", simplified]
     obtain e''' where e''':
       "pdevs_val e'' (pdevs_of_list (map snd (list_of_pdevs (snd Y)))) = pdevs_val e''' (snd Y)"
       "e''' \<in> funcset UNIV {- 1..1}"
       by auto
     note e'''(1)
     finally have "\<exists>e' \<in> funcset UNIV {-1 .. 1}. pdevs_val e (snd X) = pdevs_val e' (snd Y)"
       using e'''(2) by auto
   } note E = this
   note e1 = E[OF assms(2)]
     and e2 = E[OF perm_sym[OF assms(2)]]
   show ?thesis
     by (auto simp: Affine_def valuate_def aform_val_def assms dest: e1 e2)
 qed
 
 context includes autoref_syntax begin
 
 lemma aform_of_ivl_refine: "x \<le> y \<Longrightarrow> (aform_of_ivl x y, atLeastAtMost x y) \<in> \<langle>rnv_rel\<rangle>aform_rel"
   by (auto simp: aform_rel_def br_def Affine_aform_of_ivl)
 
 lemma aforms_of_ivl_leI1:
   fixes en::real
   assumes "-1 \<le> en" "xsn \<le> ysn"
   shows "xsn \<le> (xsn + ysn) / 2 + (ysn - xsn) * en / 2"
 proof -
   have "xsn * (1 + en) \<le> ysn * (1 + en)"
     using assms mult_right_mono by force
   then show ?thesis
     by (auto simp: algebra_simps divide_simps)
 qed
 
 lemma aforms_of_ivl_leI2:
   fixes en::real
   assumes "1 \<ge> en" "xsn \<le> ysn"
   shows "(xsn + ysn) / 2 + (ysn - xsn) * en / 2 \<le> ysn"
 proof -
   have "xsn * (1 - en) \<le> ysn * (1 - en)"
     using assms mult_right_mono by force
   then show ?thesis
     by (auto simp: algebra_simps divide_simps)
 qed
 
 lemma Joints_aforms_of_ivlsD1:
   "zs \<in> Joints (aforms_of_ivls xs ys) \<Longrightarrow> list_all2 (\<le>) xs ys \<Longrightarrow> list_all2 (\<le>) xs zs"
   by (auto simp: Joints_def valuate_def aforms_of_ivls_def aform_val_def Pi_iff
       list_all2_conv_all_nth intro!: list_all2_all_nthI aforms_of_ivl_leI1)
 
 lemma Joints_aforms_of_ivlsD2:
   "zs \<in> Joints (aforms_of_ivls xs ys) \<Longrightarrow> list_all2 (\<le>) xs ys \<Longrightarrow> list_all2 (\<le>) zs ys"
   by (auto simp: Joints_def valuate_def aforms_of_ivls_def aform_val_def Pi_iff
       list_all2_conv_all_nth intro!: list_all2_all_nthI aforms_of_ivl_leI2)
 
 lemma aforms_of_ivls_refine:
   "list_all2 (\<le>) xrs yrs \<Longrightarrow>
        (xri, xrs) \<in> \<langle>rnv_rel\<rangle>list_rel \<Longrightarrow>
        (yri, yrs) \<in> \<langle>rnv_rel\<rangle>list_rel \<Longrightarrow> (aforms_of_ivls xri yri, lv_ivl xrs yrs) \<in> aforms_rel"
   apply (auto simp: aforms_rel_def br_def list_all2_lengthD lv_ivl_def
       Joints_aforms_of_ivlsD1 Joints_aforms_of_ivlsD2 intro!: aforms_of_ivls)
   subgoal by (simp add: list_all2_conv_all_nth)
   subgoal by (simp add: list_all2_conv_all_nth)
   done
 
 lemma degrees_zero_pdevs[simp]: "degrees (replicate n zero_pdevs) = 0"
   by (auto simp: degrees_def intro!: Max_eqI)
 
 lemma Joints_product_aforms:
   "Joints (product_aforms a b) = product_listset (Joints a) (Joints b)"
   apply (auto simp: Joints_def valuate_def product_listset_def product_aforms_def
       aform_vals_def[symmetric] aform_val_msum_aforms)
   subgoal for e
     apply (rule image_eqI[where
           x="(aform_vals e a,
               List.map2 (+) (aform_vals e (replicate (length b) (0, zero_pdevs))) (aform_vals (\<lambda>i. e (i + degree_aforms a)) b))"])
      apply (auto simp: split_beta')
     apply (auto simp: aform_vals_def intro!: nth_equalityI image_eqI[where x="\<lambda>i. e (i + degree_aforms a)"])
     done
   subgoal for e1 e2
     apply (rule image_eqI[where x="\<lambda>i. if i < degree_aforms a then e1 i else e2 (i - degree_aforms a)"])
      apply (auto simp: aform_vals_def aform_val_def Pi_iff
         intro!: nth_equalityI pdevs_val_degree_cong)
     subgoal premises prems for x xs k
     proof -
       from prems
       have "degree xs \<le> degree_aforms a"
         by (auto simp: degrees_def Max_gr_iff)
       then show ?thesis using prems by auto
     qed
     done
   done
 
 lemma product_aforms_refine:
   "(product_aforms, product_listset) \<in> aforms_rel \<rightarrow> aforms_rel \<rightarrow> aforms_rel"
   by (auto simp: aforms_rel_def br_def Joints_product_aforms)
 
 lemma mem_lv_rel_set_rel_iff:
   fixes z::"'a::executable_euclidean_space set"
   shows "(y, z) \<in> \<langle>lv_rel\<rangle>set_rel \<longleftrightarrow> (z = eucl_of_list ` y \<and> (\<forall>x \<in> y. length x = DIM('a)))"
   unfolding lv_rel_def
   by (auto simp: set_rel_def br_def)
 
 lemma eucl_of_list_mem_lv_rel: "length x = DIM('a::executable_euclidean_space) \<Longrightarrow>
     (x, eucl_of_list x::'a) \<in> lv_rel"
   unfolding lv_rel_def
   by (auto simp:  br_def)
 
 lemma
   mem_Joints_msum_aforms'I:
   "a \<in> Joints x \<Longrightarrow> b \<in> Joints y \<Longrightarrow> List.map2 (+) a b \<in> Joints (msum_aforms' x y)"
   by (auto simp: Joints_msum_aforms degrees_def)
 
 lemma
   mem_Joints_msum_aforms'E:
   assumes "xa \<in> Joints (msum_aforms' x y)" 
   obtains a b where "xa = List.map2 (+) a b" "a \<in> Joints x" "b \<in> Joints y"
   using assms
   by (auto simp: Joints_msum_aforms degrees_def)
 
 lemma msum_aforms'_refine_raw:
   shows "(msum_aforms' x y, {List.map2 (+) a b|a b. a \<in> Joints x \<and> b \<in> Joints y}) \<in> aforms_rel"
   unfolding aforms_rel_def br_def
   by (safe elim!: mem_Joints_msum_aforms'E intro!: mem_Joints_msum_aforms'I) (auto simp: Joints_imp_length_eq)
 
 lemma aforms_relD: "(a, b) \<in> aforms_rel \<Longrightarrow> b = Joints a"
   by (auto simp: aforms_rel_def br_def)
 
 lemma msum_aforms'_refine:
   "(msum_aforms', \<lambda>xs ys. {List.map2 (+) x y |x y. x \<in> xs \<and> y \<in> ys}) \<in> aforms_rel \<rightarrow> aforms_rel \<rightarrow> aforms_rel"
   by (safe dest!: aforms_relD intro!: msum_aforms'_refine_raw)
 
 lemma length_inf_aforms[simp]: "length (inf_aforms optns x) = length x"
   and length_sup_aforms[simp]: "length (sup_aforms optns x) = length x"
   by (auto simp: inf_aforms_def sup_aforms_def)
 
 lemma inf_aforms_refine:
   "(xi, x) \<in> aforms_rel \<Longrightarrow> length xi = d \<Longrightarrow> (RETURN (inf_aforms optns xi), Inf_specs d x) \<in> \<langle>rl_rel\<rangle>nres_rel"
   unfolding o_def
   apply (auto simp: br_def aforms_rel_def mem_lv_rel_set_rel_iff nres_rel_def Inf_specs_def
       intro!: RETURN_SPEC_refine)
   unfolding lv_rel_def
   by (auto simp: aforms_rel_def br_def Joints_imp_length_eq
       eucl_of_list_inner inf_aforms_def nth_in_AffineI
       intro!: Inf_aform'_Affine_le list_all2_all_nthI)
 
 lemma sup_aforms_refine:
   "(xi, x) \<in> aforms_rel \<Longrightarrow> length xi = d \<Longrightarrow> (RETURN (sup_aforms optns xi), Sup_specs d x) \<in> \<langle>rl_rel\<rangle>nres_rel"
   unfolding o_def
   apply (auto simp: aforms_relp_def mem_lv_rel_set_rel_iff nres_rel_def Sup_specs_def
       intro!: RETURN_SPEC_refine)
   unfolding lv_rel_def
   by (auto simp: aforms_rel_def br_def Joints_imp_length_eq
       eucl_of_list_inner sup_aforms_def nth_in_AffineI
       intro!: Sup_aform'_Affine_ge list_all2_all_nthI)
 
 lemma nres_of_THE_DRES_le:
   assumes "\<And>v. x = Some v \<Longrightarrow> RETURN v \<le> y"
   shows "nres_of (THE_DRES x) \<le> y"
   using assms by (auto simp: THE_DRES_def split: option.split)
 
 lemma degree_le_fresh_index: "a \<in> set A \<Longrightarrow> degree_aform a \<le> fresh_index_aforms A"
   by (auto simp: fresh_index_aforms_def intro!: Max_ge)
 
 lemma zero_in_JointsI: "xs \<in> Joints XS \<Longrightarrow> z = (0, zero_pdevs) \<Longrightarrow> 0 # xs \<in> Joints (z # XS)"
   by (auto simp: Joints_def valuate_def)
 
 lemma cancel_nonneg_pos_add_multI: "0 \<le> c + c * x"
   if "c \<ge> 0" "1 + x \<ge> 0"
   for c x::real
 proof -
   have "0 \<le> c + c * x \<longleftrightarrow> 0 \<le> c * (1 + x)" by (auto simp: algebra_simps)
   also have "\<dots> \<longleftrightarrow> 0 \<le> 1 + x"
     using that
     by (auto simp: zero_le_mult_iff)
   finally show ?thesis 
     using that by simp
 qed
    
 lemma Joints_map_split_aform:
   fixes x::"real aform list"
   shows "Joints x \<subseteq> Joints (map (\<lambda>a. fst (split_aform a i)) x) \<union> Joints (map (\<lambda>b. snd (split_aform b i)) x)"
   unfolding subset_iff
   apply (intro allI impI)
 proof goal_cases
   case (1 xs)
   then obtain e where e: "e \<in> funcset UNIV {-1 .. 1}" "xs = map (aform_val e) x"
     by (auto simp: Joints_def valuate_def)
   consider "e i \<ge> 0" | "e i \<le> 0" by arith
   then show ?case
   proof cases
     case 1
     let ?e = "e(i:= 2 * e i - 1)"
     note e(2)
     also
     have "map (aform_val e) x = map (aform_val ?e) (map (\<lambda>b. snd (split_aform b i)) x)"
       by (auto simp: aform_val_def split_aform_def Let_def divide_simps algebra_simps)
     also have "\<dots> \<in> Joints (map (\<lambda>b. snd (split_aform b i)) x)"
       using e \<open>0 \<le> e i\<close>
       by (auto simp: Joints_def valuate_def Pi_iff intro!: image_eqI[where x = ?e])
     finally show ?thesis by simp
   next
     case 2
     let ?e = "e(i:= 2 * e i + 1)"
     note e(2)
     also
     have "map (aform_val e) x = map (aform_val ?e) (map (\<lambda>b. fst (split_aform b i)) x)"
       by (auto simp: aform_val_def split_aform_def Let_def divide_simps algebra_simps)
     also have "\<dots> \<in> Joints (map (\<lambda>b. fst (split_aform b i)) x)"
       using e \<open>0 \<ge> e i\<close>
       by (auto simp: Joints_def valuate_def Pi_iff real_0_le_add_iff
           intro!: image_eqI[where x = ?e] cancel_nonneg_pos_add_multI)
     finally show ?thesis by simp
   qed
 qed
 
 
 lemma split_aforms_lemma:
   fixes x::"real aform list"
   assumes "(x, y) \<in> aforms_rel"
   assumes "z \<subseteq> y"
   assumes "l = (length x)"
   shows "\<exists>a b. (split_aforms x i, a, b)
      \<in> aforms_rel \<times>\<^sub>r aforms_rel \<and> env_len a l \<and> env_len b l \<and> z \<subseteq> a \<union> b"
   using assms
   apply (auto simp: split_aforms_def o_def)
   apply (rule exI[where x="Joints (map (\<lambda>x. fst (split_aform x i)) x)"])
   apply auto
   subgoal by (auto intro!: brI simp: aforms_rel_def)
   apply (rule exI[where x="Joints (map (\<lambda>x. snd (split_aform x i)) x)"])
   apply (rule conjI)
   subgoal by (auto intro!: brI simp: aforms_rel_def)
   subgoal
     using Joints_map_split_aform[of x i]
     by (auto simp: br_def aforms_rel_def env_len_def Joints_imp_length_eq)
   done
 
 lemma length_summarize_pdevs_list[simp]:
   "length (summarize_pdevs_list a b c d) = length d"
   by (auto simp: summarize_pdevs_list_def)
 
 lemma length_summarize_aforms[simp]:
   "length (summarize_aforms a b e d) = length d"
   by (auto simp: summarize_aforms_def Let_def)
 
 lemma
   split_aform_largest_take_refine:
   "(ni, n) \<in> nat_rel \<Longrightarrow>
        (xi::real aform list, x) \<in> aforms_rel \<Longrightarrow>
        length xi = d \<Longrightarrow> (RETURN (split_aforms_largest_uncond_take ni xi), split_spec_params d n x) \<in> \<langle>aforms_rel \<times>\<^sub>r aforms_rel\<rangle>nres_rel"
   apply (auto simp: split_spec_params_def nres_rel_def aforms_relp_def mem_lv_rel_set_rel_iff
       split_aforms_largest_uncond_take_def Let_def comps
       split: prod.splits
       intro!: RETURN_SPEC_refine)
   apply (rule split_aforms_lemma)
   by (auto simp add: aforms_rel_def)
 
 lemma aform_val_pdevs_of_real[simp]: "aform_val e (pdevs_of_real x) = x"
   by (auto simp: pdevs_of_real_def)
 
 lemma degree_aform_pdevs_of_real[simp]: "degree_aform (pdevs_of_real x) = 0"
   by (auto simp: pdevs_of_real_def)
 
 lemma interpret_floatarith_inner_eq:
   shows "interpret_floatarith (inner_floatariths xs ys) vs =
     (\<Sum>(x, y) \<leftarrow> (zip xs ys). (interpret_floatarith x vs) * (interpret_floatarith y vs))"
   by (induction xs ys rule: inner_floatariths.induct) auto
 
 lemma approx_slp_outer_sing:
   "approx_slp_outer p (Suc 0) [fa] XS = Some R \<longleftrightarrow> (\<exists>Y.
   approx_floatarith p fa (map (\<lambda>x. (x, 0)) XS) = Some Y \<and>
        [aform_err_to_aform Y (max (degree_aforms XS) (degree_aform_err Y))] = R)"
   by (auto simp: approx_slp_outer_def bind_eq_Some_conv degrees_def)
 
 lemma aforms_err_aform_valsI:
   assumes "vs = aform_vals e XS"
   shows "vs \<in> aforms_err e (map (\<lambda>x. (x, 0)) (XS))"
     by (auto simp: assms aforms_err_def o_def aform_err_def aform_vals_def)
 
 
 lemma aform_val_degree_cong:
   "b = d \<Longrightarrow> (\<And>i. i < degree_aform d \<Longrightarrow> a i = c i) \<Longrightarrow> aform_val a b = aform_val c d"
   by (auto simp: aform_val_def intro!: pdevs_val_degree_cong)
 
 lemma mem_degree_aformD: "x \<in> set XS \<Longrightarrow> degree_aform x \<le> degree_aforms XS"
   by (auto simp: degrees_def)
 lemma degrees_append_leD1: "(degrees xs) \<le> degrees (xs @ ys)"
   unfolding degrees_def
   by (rule Max_mono) (auto simp: degrees_def min_def max_def Max_ge_iff image_Un Max_gr_iff)
 
 lemma inner_aforms':
   assumes "xs \<in> Joints XS"
   assumes "inner_aforms' p XS (map pdevs_of_real rs) = Some R"
   shows "(\<Sum>(x, y) \<leftarrow> (zip xs rs). x * y) \<in> Affine (hd R)" (is ?th1) "length R = 1" (is ?th2)
 proof -
   from assms obtain e where "e \<in> funcset UNIV {-1 .. 1}" "xs = aform_vals e XS"
     by (auto simp: Joints_def valuate_def aform_vals_def)
   then have e: "xs @ rs = aform_vals e (XS @ map pdevs_of_real rs)"
     "xs @ rs \<in> Joints (XS @ map pdevs_of_real rs)"
     "length xs = length XS"
     "e \<in> funcset UNIV {- 1..1}"
     by (auto simp: aform_vals_def o_def degrees_def Joints_def valuate_def)
   have "approx_slp_outer p (Suc 0)
      ([inner_floatariths (map floatarith.Var [0..<length XS])
          (map floatarith.Var [length XS..<length XS + length rs])])
      (XS @ map pdevs_of_real rs) =
     Some R"
     using assms(2)
     by (auto simp: inner_aforms'_def)
   then obtain Y where Y:
     "approx_floatarith p
        (inner_floatariths (map floatarith.Var [0..<length XS])
          (map floatarith.Var [length XS..<length XS + length rs]))
        (map (\<lambda>x. (x, 0)) (XS @ map pdevs_of_real rs)) =
       Some Y"
     "R = [aform_err_to_aform Y (max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y))]"
     unfolding approx_slp_outer_sing by auto
   let ?m = "(max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y))"
   from approx_floatarith_Elem[OF Y(1) e(4) aforms_err_aform_valsI[OF e(1)]]
   have "interpret_floatarith
      (inner_floatariths (map floatarith.Var [0..<length XS]) (map floatarith.Var [length XS..<length XS + length rs]))
      (xs @ rs)
     \<in> aform_err e Y" "degree_aform_err Y \<le> max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y)"
     by auto
   from aform_err_to_aformE[OF this] obtain err where err:
     "interpret_floatarith
            (inner_floatariths (map floatarith.Var [0..<length XS])
              (map floatarith.Var [length XS..<length XS + length rs]))
            (xs @ rs) =
           aform_val (e(max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y) := err))
            (aform_err_to_aform Y (max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y)))"
     "- 1 \<le> err" "err \<le> 1"
     by auto
   let ?e' = "(e(max (degrees (map snd XS @ map (snd \<circ> pdevs_of_real) rs)) (degree_aform_err Y) := err))"
   from e(1) have e': "xs @ rs = aform_vals ?e' (XS @ map pdevs_of_real rs)"
     apply (auto simp: aform_vals_def intro!: aform_val_degree_cong)
      apply (frule mem_degree_aformD)
      apply (frule le_less_trans[OF degrees_append_leD1])
      apply (auto simp: o_def)
     done
   from err have "interpret_floatarith
            (inner_floatariths (map floatarith.Var [0..<length XS])
              (map floatarith.Var [length XS..<length XS + length rs]))
            (xs @ rs)#xs@rs \<in> Joints (R @ XS @ map pdevs_of_real rs)"
     using e(1,3,4) e'
     apply (auto simp: valuate_def Joints_def
       intro!: nth_equalityI
         image_eqI[where x="?e'"])
      apply (simp add: Y aform_vals_def; fail)
     apply (simp add: Y o_def)
     apply (simp add: nth_append nth_Cons)
     apply (auto split: nat.splits simp: nth_append nth_Cons aform_vals_def)
     done
   then have "(\<Sum>(x, y)\<leftarrow>zip (map floatarith.Var [0..<length XS])
                 (map floatarith.Var
                   [length XS..<
                    length XS + length rs]). interpret_floatarith x (xs @ rs) * interpret_floatarith y (xs @ rs)) #
     xs @ rs
     \<in> Joints (R @ XS @ map pdevs_of_real rs)"
     apply (subst (asm)interpret_floatarith_inner_eq )
     apply (auto simp:  )
     done
   also have "(\<Sum>(x, y)\<leftarrow>zip (map floatarith.Var [0..<length XS])
                 (map floatarith.Var
                   [length XS..<
                    length XS + length rs]). interpret_floatarith x (xs @ rs) * interpret_floatarith y (xs @ rs)) =
     (\<Sum>(x, y)\<leftarrow>zip xs rs. x * y)"
     by (auto simp: sum_list_sum_nth assms e(3) nth_append intro!: sum.cong)
   finally show ?th1 ?th2
     by (auto simp: Affine_def valuate_def Joints_def Y)
 qed
 
 lemma inner_aforms'_inner_lv_rel:
   "(a, a') \<in> aforms_rel \<Longrightarrow>
        inner_aforms' prec a (map pdevs_of_real a'a) = Some R \<Longrightarrow>
        x \<in> a' \<Longrightarrow> inner_lv_rel x a'a \<in> Affine (hd R)"
   unfolding mem_lv_rel_set_rel_iff
   unfolding lv_rel_def aforms_rel_def
   apply (auto simp: br_def)
   apply (subst arg_cong2[where f="(\<in>)", OF _ refl])
   defer
    apply (rule inner_aforms')
      apply (auto simp: br_def Joints_imp_length_eq inner_lv_rel_def)
   done
 
 lemma aform_inf_inner_refine:
   "(RETURN o2 aform_inf_inner optns, Inf_inners) \<in> aforms_rel \<rightarrow> rl_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
   by (auto simp: aforms_relp_def nres_rel_def Inf_inners_def aform_inf_inner_def[abs_def] comp2_def
       iaN
       intro!: Inf_aform'_Affine_le inner_aforms'_inner_lv_rel
       split: option.splits list.splits)
 
 lemma aform_sup_inner_refine:
   "(RETURN o2 aform_sup_inner optns, Sup_inners) \<in> aforms_rel \<rightarrow> rl_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
   by (auto simp: aforms_relp_def nres_rel_def Sup_inners_def aform_sup_inner_def[abs_def] comp2_def
       iaN
       intro!: Sup_aform'_Affine_ge inner_aforms'_inner_lv_rel
       split: option.splits list.splits)
 
 lemma lv_aforms_rel_comp_br_Affine_le: "lv_aforms_rel O br Affine top \<subseteq> \<langle>lv_rel\<rangle>aforms_relp"
   apply (auto simp: lv_aforms_rel_def aforms_relp_def br_def)
   apply (rule relcompI)
    apply (auto simp: aforms_rel_def intro!: brI )
   by (auto simp: mem_lv_rel_set_rel_iff Joints_imp_length_eq
       intro!: eucl_of_list_mem_eucl_of_list_aform intro!: in_image_eucl_of_list_eucl_of_list_aform)
 
 lemma bijective_lv_rel[relator_props]: "bijective lv_rel"
   unfolding lv_rel_def bijective_def
   apply (auto simp: br_def)
   by (metis eucl_of_list_inj)
 
 lemma sv_lv_rel_inverse[relator_props]: "single_valued (lv_rel\<inverse>)"
   using bijective_lv_rel
   by (rule bijective_imp_sv)
 
 lemma list_of_eucl_image_lv_rel_inverse:
   "(x, list_of_eucl ` x) \<in> \<langle>lv_rel\<inverse>\<rangle>set_rel"
   unfolding set_rel_sv[OF sv_lv_rel_inverse]
   apply (auto simp: )
     apply (rule ImageI)
      apply (rule converseI)
      apply (rule lv_relI)
      apply auto
    apply (rule image_eqI)
     prefer 2 apply assumption
   unfolding lv_rel_def
    apply (auto simp: br_def)
   subgoal for y
     apply (rule exI[where x="list_of_eucl y"])
     apply auto
     done
   done
 
 lemma lv_rel_comp_lv_rel_inverse:
   "((lv_rel::(_\<times>'a::executable_euclidean_space) set) O lv_rel\<inverse>) = {(x, y). x = y \<and> length x = DIM('a)}"
   apply (auto simp: intro!: lv_relI)
   unfolding lv_rel_def
   by (auto simp: br_def intro!: eucl_of_list_inj)
 
 lemma inter_aform_plane_refine_aux:
   "d = CARD('n::enum) \<Longrightarrow>
   (xi, x) \<in> aforms_rel \<Longrightarrow> (si, s) \<in> \<langle>rl_rel\<rangle>sctn_rel \<Longrightarrow>
   length xi = d \<Longrightarrow>
   length (normal si) = d \<Longrightarrow>
   (nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s)
   \<in> \<langle>aforms_rel\<rangle>nres_rel"
 proof (goal_cases)
   case 1
   from 1 have sis: "si = s"
     by (cases si; cases s) (auto simp: sctn_rel_def)
   have Dp: "DIM_precond TYPE('n rvec) CARD('n)"
     by auto
   have a: "(xi, eucl_of_list_aform xi::'n rvec aform) \<in> lv_aforms_rel"
     by (auto simp: lv_aforms_rel_def br_def aforms_relp_def aforms_rel_def mem_lv_rel_set_rel_iff 1
         Joints_imp_length_eq)
   have b: "(si, (Sctn (eucl_of_list (normal si)) (pstn si))::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
     using 1
     by (cases si)
       (auto simp: lv_aforms_rel_def br_def aforms_relp_def aforms_rel_def mem_lv_rel_set_rel_iff
         Joints_imp_length_eq sctn_rel_def intro!: lv_relI)
   have a: "(nres_of (inter_aform_plane_lv CARD('n) optns xi si),
     inter_aform_plane optns (eucl_of_list_aform xi::'n rvec aform) (Sctn (eucl_of_list (normal si)) (pstn si)))
     \<in> \<langle>lv_aforms_rel\<rangle>nres_rel"
     (is "(_, inter_aform_plane _ ?ea ?se) \<in> _")
     using inter_aform_plane_lv.refine[OF Dp IdI a b, of optns]
     by simp
   have b: "(inter_aform_plane optns ?ea ?se, inter_sctn_spec (Affine ?ea) ?se) \<in> \<langle>br Affine top\<rangle>nres_rel"
     using 1
     apply (auto simp: inter_sctn_spec_def nres_rel_def inter_aform_plane_def project_ncoord_aform_def
         inter_aform_plane_ortho_nres_def
         split: option.splits
         intro!: RETURN_SPEC_refine
         dest!: inter_inter_aform_plane_ortho)
      apply (auto simp: aform_rel_def br_def nres_rel_def comps bind_eq_Some_conv
         inter_sctn_spec_def inter_aform_plane_def plane_of_def aforms_relp_def aforms_rel_def
         mem_lv_rel_set_rel_iff
         intro!: RETURN_SPEC_refine nres_of_THE_DRES_le mem_Affine_project_coord_aformI
         dest!: inter_inter_aform_plane_ortho
         split: if_splits)
      apply (auto dest!: mem_Affine_project_coord_aformD simp: abs_in_Basis_iff plane_of_def)
     done
   from relcompI[OF a b]
   have "(nres_of (inter_aform_plane_lv CARD('n) optns xi si), inter_sctn_spec (Affine ?ea) ?se) \<in>
       \<langle>lv_aforms_rel\<rangle>nres_rel O \<langle>br Affine top\<rangle>nres_rel"
     by auto
   also have "\<langle>lv_aforms_rel\<rangle>nres_rel O \<langle>br Affine top\<rangle>nres_rel \<subseteq> \<langle>\<langle>lv_rel\<rangle>aforms_relp\<rangle>nres_rel"
     unfolding nres_rel_comp
     apply (rule nres_rel_mono)
     apply (rule lv_aforms_rel_comp_br_Affine_le)
     done
   finally
   have step1: "(nres_of (inter_aform_plane_lv CARD('n) optns xi si),
       inter_sctn_spec (Affine (eucl_of_list_aform xi)::'n rvec set) (Sctn (eucl_of_list (normal si)) (pstn si)))
       \<in> \<langle>\<langle>lv_rel\<rangle>aforms_relp\<rangle>nres_rel"
     by simp
   have step2: "(inter_sctn_spec (Affine (eucl_of_list_aform xi)::'n rvec set) (Sctn (eucl_of_list (normal si)) (pstn si)),
     inter_sctn_specs CARD('n) (Joints xi) si) \<in> \<langle>\<langle>lv_rel\<inverse>\<rangle>set_rel\<rangle>nres_rel"
     apply (auto simp: inter_sctn_specs_def inter_sctn_spec_def simp: nres_rel_def intro!: SPEC_refine)
     subgoal for x
       apply (rule exI[where x="list_of_eucl ` x"])
       apply (auto simp: env_len_def plane_ofs_def intro: list_of_eucl_image_lv_rel_inverse)
       subgoal for y
         apply (rule image_eqI[where x="eucl_of_list y"])
           apply (subst list_of_eucl_eucl_of_list)
           apply (auto simp: 1 Joints_imp_length_eq)
         apply (rule subsetD, assumption)
         apply (auto simp: intro!: eucl_of_list_mem_eucl_of_list_aform 1)
         using inner_lv_rel_autoref[where 'a="'n rvec", param_fo, OF lv_relI lv_relI, of y "normal si"]
         by (auto simp: plane_of_def 1 Joints_imp_length_eq)
       subgoal for y
         apply (drule subsetD, assumption)
         using inner_lv_rel_autoref[where 'a="'n rvec", param_fo, OF lv_relI lv_relI, of "list_of_eucl y" "normal si"]
         by (auto simp: plane_of_def 1 Joints_imp_length_eq)
       done
     done
   from relcompI[OF step1 step2]
   have "(nres_of (inter_aform_plane_lv CARD('n) optns xi si), inter_sctn_specs CARD('n) (Joints xi) si)
     \<in> \<langle>\<langle>lv_rel::(real list \<times> 'n rvec)set\<rangle>aforms_relp\<rangle>nres_rel O \<langle>\<langle>lv_rel\<inverse>\<rangle>set_rel\<rangle>nres_rel" by simp
   also have "\<langle>\<langle>lv_rel::(real list \<times> 'n rvec)set\<rangle>aforms_relp\<rangle>nres_rel O \<langle>\<langle>lv_rel\<inverse>\<rangle>set_rel\<rangle>nres_rel \<subseteq>
     \<langle>aforms_rel O Id\<rangle>nres_rel"
     unfolding nres_rel_comp O_assoc aforms_relp_def
     apply (rule nres_rel_mono)
     apply (rule relcomp_mono[OF order_refl])
     unfolding set_rel_sv[OF sv_lv_rel_inverse] set_rel_sv[OF lv_rel_sv]
     apply (auto simp: length_lv_rel)
     unfolding relcomp_Image[symmetric] lv_rel_comp_lv_rel_inverse
      apply (auto simp: Basis_not_uminus length_lv_rel)
     unfolding lv_rel_def
     subgoal for a b c d
       apply (auto dest!: brD simp: length_lv_rel)
       using eucl_of_list_inj[where 'a="'n rvec", of d b]
       by auto
     done
   finally show ?case using 1 by (simp add: aforms_rel_def br_def sis)
 qed
 
 end
 
 setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum"}, SOME @{typ "'a list"})\<close>
 setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum_all"}, SOME @{typ "('a \<Rightarrow> bool) \<Rightarrow> bool"})\<close>
 setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum_ex"}, SOME @{typ "('a \<Rightarrow> bool) \<Rightarrow> bool"})\<close>
 
 lemmas inter_aform_plane_refine_unoverloaded0 =
   inter_aform_plane_refine_aux[internalize_sort "'n::enum",
     unoverload enum_class.enum,
     unoverload enum_class.enum_all,
     unoverload enum_class.enum_ex]
 
 theorem
   inter_aform_plane_refine_unoverloaded:
     "class.enum (enum::'a list) enum_all enum_ex \<and> d = CARD('a) \<Longrightarrow>
     (xi, x) \<in> aforms_rel \<Longrightarrow>
     (si, s) \<in> \<langle>rl_rel\<rangle>sctn_rel \<Longrightarrow>
     length xi = d \<Longrightarrow>
     length (normal si) = d \<Longrightarrow>
     (nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s)
     \<in> \<langle>aforms_rel\<rangle>nres_rel"
   by (rule inter_aform_plane_refine_unoverloaded0) auto
 
 setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum"}, SOME @{typ "'a::enum list"})\<close>
 setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum_all"}, SOME @{typ "('a::enum \<Rightarrow> bool) \<Rightarrow> bool"})\<close>
 setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum_ex"}, SOME @{typ "('a::enum \<Rightarrow> bool) \<Rightarrow> bool"})\<close>
 
 context includes autoref_syntax begin
 
 text \<open>TODO: this is a special case of \<open>Cancel_Card_Constraint\<close> from \<open>AFP/Perron_Frobenius\<close>!\<close>
 lemma type_impl_card_n_enum:
   assumes "\<exists>(Rep :: 'a \<Rightarrow> nat) Abs. type_definition Rep Abs {0 ..< n :: nat}"
   obtains enum enum_all enum_ex
   where "class.enum (enum::'a list) enum_all enum_ex \<and> n = CARD('a)"
 proof -
   from assms obtain rep :: "'a \<Rightarrow> nat" and abs :: "nat \<Rightarrow> 'a"
     where t: "type_definition rep abs {0 ..<n}" by auto
   then interpret type_definition rep abs \<open>{0 ..<n}\<close> .
   have "card (UNIV :: 'a set) = card {0 ..< n}"
     by (rule card)
   also have "\<dots> = n" by auto
   finally have bn: "CARD ('a) = n" .
 
   let ?enum = "(map abs [0..<n])"
   have "class.enum ?enum (Ball (set ?enum)) (Bex (set ?enum))"
     by standard (auto simp: distinct_map univ Abs_inject intro: inj_onI)
   with bn have "class.enum ?enum (Ball (set ?enum)) (Bex (set ?enum)) \<and> n = CARD('a)"
     by simp
   then show ?thesis ..
 qed
 
 
 lemma inter_aform_plane_refine_ex_typedef:
   "(xi, x) \<in> aforms_rel \<Longrightarrow>
   (si, s) \<in> \<langle>rl_rel\<rangle>sctn_rel \<Longrightarrow>
   length xi = d \<Longrightarrow>
   length (normal si) = d \<Longrightarrow>
   (nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s)
   \<in> \<langle>aforms_rel\<rangle>nres_rel"
   if "\<exists>(Rep :: 'a \<Rightarrow> nat) Abs. type_definition Rep Abs {0 ..< d :: nat}"
   by (rule type_impl_card_n_enum[OF that]) (rule inter_aform_plane_refine_unoverloaded; assumption)
 
 lemma inter_aform_plane_refine:
   "0 < d \<Longrightarrow>
   (xi, x) \<in> aforms_rel \<Longrightarrow>
   (si, s) \<in> \<langle>Id\<rangle>sctn_rel \<Longrightarrow>
   length xi = d \<Longrightarrow>
   length (normal si) = d \<Longrightarrow>
   (nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s)
   \<in> \<langle>aforms_rel\<rangle>nres_rel"
   by (rule inter_aform_plane_refine_ex_typedef[cancel_type_definition, simplified])
 
 lemma Joints_reduce_aforms: "x \<in> Joints X \<Longrightarrow> x \<in> Joints (reduce_aforms prec t X)"
 proof (auto simp: reduce_aforms_def summarize_threshold_def[abs_def] Joints_def valuate_def aform_val_def, goal_cases)
   case (1 e)
-  from summarize_aformsE[OF \<open>e \<in> _\<close> order_refl, of "X" "prec" t]
-  guess e' .
+  from summarize_aformsE[OF \<open>e \<in> _\<close> order_refl]
+  obtain e' where
+    "aform_vals e X = aform_vals e' (summarize_aforms prec t (degree_aforms X) X)"
+    "\<And>i. i < degree_aforms X \<Longrightarrow> e i = e' i"
+    "e' \<in> funcset UNIV {- 1..1}"
+    by blast
   thus ?case
     by (auto intro!: image_eqI[where x=e'] simp: aform_vals_def)
 qed
 
 lemma length_reduce_aform[simp]: "length (reduce_aforms optns a x) = length x"
   by (auto simp: reduce_aforms_def)
 
 lemma reduce_aform_refine:
   "(xi, x) \<in> aforms_rel \<Longrightarrow> length xi = d \<Longrightarrow>
     (RETURN (reduce_aforms prec C xi), reduce_specs d r x) \<in> \<langle>aforms_rel\<rangle>nres_rel"
   apply (auto simp: reduce_specs_def nres_rel_def comps aforms_relp_def mem_lv_rel_set_rel_iff
       aforms_rel_def env_len_def
       intro!: RETURN_SPEC_refine)
   apply (auto simp: br_def env_len_def)
   by (auto simp: mem_lv_rel_set_rel_iff Joints_imp_length_eq
       intro!: in_image_eucl_of_list_eucl_of_list_aform Joints_reduce_aforms
       eucl_of_list_mem_eucl_of_list_aform)
 
 lemma aform_euclarithform_refine:
   "(nres_of o2 aform_form optns, approx_form_spec) \<in> Id \<rightarrow> aforms_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
   by (auto simp: approx_form_spec_def nres_rel_def comps aform_form_def
       aforms_rel_def br_def approx_form_aform
       dest!: approx_form_aux
       intro!: ivls_of_aforms)
 
 lemma aform_isFDERIV:
   "(\<lambda>N xs fas vs. nres_of (aform_isFDERIV optns N xs fas vs), isFDERIV_spec)
     \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>list_rel \<rightarrow> \<langle>Id\<rangle>list_rel \<rightarrow> aforms_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
   by (auto simp: isFDERIV_spec_def nres_rel_def comps aform_isFDERIV_def
       aforms_rel_def br_def
       dest!: approx_form_aux
       intro!: ivls_of_aforms isFDERIV_approx)
 
 lemma approx_slp_lengthD: "approx_slp p slp a = Some xs \<Longrightarrow>
   length xs = length slp + length a"
   by (induction slp arbitrary: xs a) (auto simp: bind_eq_Some_conv)
 
 lemma approx_slp_outer_lengthD: "approx_slp_outer p d slp a = Some xs \<Longrightarrow>
   length xs = min d (length slp + length a)"
   by (auto simp: approx_slp_outer_def Let_def bind_eq_Some_conv o_def
       aforms_err_to_aforms_def aform_err_to_aform_def dest!: approx_slp_lengthD)
 
 lemma approx_slp_refine:
   "(nres_of o3 aform_slp prec, approx_slp_spec fas) \<in> 
     nat_rel \<rightarrow> fas_rel \<rightarrow> aforms_rel \<rightarrow> \<langle>\<langle>aforms_rel\<rangle>option_rel\<rangle>nres_rel"
   apply (auto simp: approx_slp_spec_def comps aform_slp_def nres_rel_def
       intro!: RETURN_SPEC_refine ASSERT_refine_right)
   subgoal for a b
     apply (rule exI[where x = "map_option Joints (approx_slp_outer prec (length fas) (slp_of_fas fas) a)"])
     apply (auto simp: option.splits aforms_rel_def br_def env_len_def Joints_imp_length_eq)
     apply (auto dest!: approx_slp_outer_lengthD)[]
     using length_slp_of_fas_le trans_le_add1 approx_slp_outer_lengthD apply blast
     using approx_slp_outer_plain by blast
   done
 
 lemma fresh_index_aforms_Nil[simp]: "fresh_index_aforms [] = 0"
   by (auto simp: fresh_index_aforms_def)
 
 lemma independent_aforms_Nil[simp]:
   "independent_aforms x [] = [x]"
   by (auto simp: independent_aforms_def)
 
 lemma mem_Joints_zero_iff[simp]: "x # xs \<in> Joints ((0, zero_pdevs) # XS) \<longleftrightarrow> (x = 0 \<and> xs \<in> Joints XS)"
   by (auto simp: Joints_def valuate_def)
 
 lemma Joints_independent_aforms_eq: "Joints (independent_aforms x xs) = set_Cons (Affine x) (Joints xs)"
   by (simp add: independent_aforms_def Joints_msum_aform degree_le_fresh_index set_Cons_def)
 
 lemma independent_aforms_refine: "(independent_aforms, set_Cons) \<in> \<langle>rnv_rel\<rangle>aform_rel \<rightarrow> aforms_rel \<rightarrow> aforms_rel"
   by (auto simp: aforms_rel_def br_def aform_rel_def Joints_independent_aforms_eq)
 
 end
 
 
 locale aform_approximate_sets = approximate_sets
   aform_ops
   Joints
   aforms_rel
 begin
 
 lemma Joints_in_lv_rel_set_relD:
   "(Joints xs, X) \<in> \<langle>lv_rel\<rangle>set_rel \<Longrightarrow> X = Affine (eucl_of_list_aform xs)"
   unfolding lv_rel_def set_rel_br
   by (auto simp: br_def Joints_imp_length_eq eucl_of_list_image_Joints[symmetric])
 
 lemma ncc_precond: "ncc_precond TYPE('a::executable_euclidean_space)"
   unfolding ncc_precond_def ncc_def appr_rel_def
   by (auto simp: aforms_rel_def compact_Affine convex_Affine dest!: Joints_in_lv_rel_set_relD brD)
 
 lemma fst_eucl_of_list_aform_map: "fst (eucl_of_list_aform (map (\<lambda>x. (fst x, asdf x)) x)) =
   fst (eucl_of_list_aform x)"
   by (auto simp: eucl_of_list_aform_def o_def)
 
 lemma
   Affine_pdevs_of_list:\<comment> \<open>TODO: move!\<close>
   "Affine (fst x, pdevs_of_list (map snd (list_of_pdevs (snd x)))) = Affine x"
   by (auto simp: Affine_def valuate_def aform_val_def
       elim: pdevs_val_of_list_of_pdevs2[where X = "snd x"]
         pdevs_val_of_list_of_pdevs[where X = "snd x"])
 
 end
 
 lemma aform_approximate_sets: "aform_approximate_sets prec"
   apply (unfold_locales)
   unfolding aform_ops_def approximate_set_ops.simps
   subgoal unfolding relAPP_def aforms_rel_def .
   subgoal by (force simp: aforms_of_ivls_refine)
   subgoal by (rule product_aforms_refine)
   subgoal by (rule msum_aforms'_refine)
   subgoal by (rule inf_aforms_refine)
   subgoal by (rule sup_aforms_refine)
   subgoal by (rule split_aform_largest_take_refine)
   subgoal by (rule aform_inf_inner_refine)
   subgoal by (rule aform_sup_inner_refine)
   subgoal by (rule inter_aform_plane_refine) simp_all
   subgoal by (auto split: option.splits intro!: reduce_aform_refine)
   subgoal by (force simp: width_spec_def nres_rel_def)
   subgoal by (rule approx_slp_refine)
   subgoal by (rule aform_euclarithform_refine)
   subgoal by (rule aform_isFDERIV)
   subgoal by simp
   subgoal by (auto simp: Joints_imp_length_eq)
   subgoal by (force simp: Affine_def Joints_def valuate_def intro!:)
   subgoal by (force simp: Affine_def Joints_def valuate_def intro!:)
   subgoal by (auto simp: Joints_imp_length_eq)
   done
 
 end
diff --git a/thys/Pratt_Certificate/Pratt_Certificate.thy b/thys/Pratt_Certificate/Pratt_Certificate.thy
--- a/thys/Pratt_Certificate/Pratt_Certificate.thy
+++ b/thys/Pratt_Certificate/Pratt_Certificate.thy
@@ -1,884 +1,889 @@
 section \<open>Pratt's Primality Certificates\<close>
 text_raw \<open>\label{sec:pratt}\<close>
 theory Pratt_Certificate
 imports
   Complex_Main
   Lehmer.Lehmer
 begin
 
 text \<open>
   This work formalizes Pratt's proof system as described in his article
   ``Every Prime has a Succinct Certificate''\cite{pratt1975certificate}.
 
   The proof system makes use of two types of predicates:
   \begin{itemize}
     \item $\text{Prime}(p)$: $p$ is a prime number
     \item $(p, a, x)$: \<open>\<forall>q \<in> prime_factors(x). [a^((p - 1) div q) \<noteq> 1] (mod p)\<close>
   \end{itemize}
   We represent these predicates with the following datatype:
 \<close>
 
 datatype pratt = Prime nat | Triple nat nat nat
 
 text \<open>
   Pratt describes an inference system consisting of the axiom $(p, a, 1)$
   and the following inference rules:
   \begin{itemize}
   \item R1: If we know that $(p, a, x)$ and \<open>[a^((p - 1) div q) \<noteq> 1] (mod p)\<close> hold for some
               prime number $q$ we can conclude $(p, a, qx)$ from that.
   \item R2: If we know that $(p, a, p - 1)$ and  \<open>[a^(p - 1) = 1] (mod p)\<close> hold, we can
               infer $\text{Prime}(p)$.
   \end{itemize}
   Both rules follow from Lehmer's theorem as we will show later on.
 
   A list of predicates (i.e., values of type @{type pratt}) is a \emph{certificate}, if it is
   built according to the inference system described above. I.e., a list @{term "x # xs :: pratt list"}
   is a certificate if @{term "xs :: pratt list"} is a certificate and @{term "x :: pratt"} is
   either an axiom or all preconditions of @{term "x :: pratt"} occur in @{term "xs :: pratt list"}.
 
   We call a certificate @{term "xs :: pratt list"} a \emph{certificate for @{term p}},
   if @{term "Prime p"} occurs in @{term "xs :: pratt list"}.
 
   The function \<open>valid_cert\<close> checks whether a list is a certificate.
 \<close>
 
 fun valid_cert :: "pratt list \<Rightarrow> bool" where
   "valid_cert [] = True"
 | R2: "valid_cert (Prime p#xs) \<longleftrightarrow> 1 < p \<and> valid_cert xs
     \<and> (\<exists> a . [a^(p - 1) = 1] (mod p) \<and> Triple p a (p - 1) \<in> set xs)"
 | R1: "valid_cert (Triple p a x # xs) \<longleftrightarrow> p > 1 \<and> 0 < x  \<and> valid_cert xs \<and> (x=1 \<or>
     (\<exists>q y. x = q * y \<and> Prime q \<in> set xs \<and> Triple p a y \<in> set xs
       \<and> [a^((p - 1) div q) \<noteq> 1] (mod p)))"
 
 text \<open>
   We define a function @{term size_cert} to measure the size of a certificate, assuming
   a binary encoding of numbers. We will use this to show that there is a certificate for a
   prime number $p$ such that the size of the certificate is polynomially bounded in the size
   of the binary representation of $p$.
 \<close>
 fun size_pratt :: "pratt \<Rightarrow> real" where
   "size_pratt (Prime p) = log 2 p" |
   "size_pratt (Triple p a x) = log 2 p + log 2 a + log 2 x"
 
 fun size_cert :: "pratt list \<Rightarrow> real" where
   "size_cert [] = 0" |
   "size_cert (x # xs) = 1 + size_pratt x + size_cert xs"
 
 
 subsection \<open>Soundness\<close>
 
 text \<open>
   In Section \ref{sec:pratt} we introduced the predicates $\text{Prime}(p)$ and $(p, a, x)$.
   In this section we show that for a certificate every predicate occurring in this certificate
   holds. In particular, if $\text{Prime}(p)$ occurs in a certificate, $p$ is prime.
 \<close>
 
 lemma prime_factors_one [simp]: shows "prime_factors (Suc 0) = {}"
   using prime_factorization_1 [where ?'a = nat] by simp
 
 lemma prime_factors_of_prime: fixes p :: nat assumes "prime p" shows "prime_factors p = {p}"
   using assms by (fact prime_prime_factors)
 
 definition pratt_triple :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
   "pratt_triple p a x \<longleftrightarrow> x > 0 \<and> (\<forall>q\<in>prime_factors x. [a ^ ((p - 1) div q) \<noteq> 1] (mod p))"
 
 lemma pratt_triple_1: "p > 1 \<Longrightarrow> x = 1 \<Longrightarrow> pratt_triple p a x"
   by (auto simp: pratt_triple_def)
 
 lemma pratt_triple_extend:
   assumes "prime q" "pratt_triple p a y"
           "p > 1" "x > 0" "x = q * y" "[a ^ ((p - 1) div q) \<noteq> 1] (mod p)"
   shows   "pratt_triple p a x"
 proof -
   have "prime_factors x = insert q (prime_factors y)"
     using assms by (simp add: prime_factors_product prime_prime_factors)
   also have "\<forall>r\<in>\<dots>. [a ^ ((p - 1) div r) \<noteq> 1] (mod p)"
     using assms by (auto simp: pratt_triple_def)
   finally show ?thesis using assms
     unfolding pratt_triple_def by blast
 qed
 
 lemma pratt_triple_imp_prime:
   assumes "pratt_triple p a x" "p > 1" "x = p - 1" "[a ^ (p - 1) = 1] (mod p)"
   shows   "prime p"
   using lehmers_theorem[of p a] assms by (auto simp: pratt_triple_def)
 
 theorem pratt_sound:
   assumes 1: "valid_cert c"
   assumes 2: "t \<in> set c"
   shows "(t = Prime p \<longrightarrow> prime p) \<and>
          (t = Triple p a x \<longrightarrow> ((\<forall>q \<in> prime_factors x . [a^((p - 1) div q) \<noteq> 1] (mod p)) \<and> 0<x))"
 using assms
 proof (induction c arbitrary: p a x t)
   case Nil then show ?case by force
   next
   case (Cons y ys)
   { assume "y=Triple p a x" "x=1"
     then have "(\<forall> q \<in> prime_factors x . [a^((p - 1) div q) \<noteq> 1] (mod p)) \<and> 0<x" by simp
     }
   moreover
   { assume x_y: "y=Triple p a x" "x~=1"
     hence "x>0" using Cons.prems by auto
     obtain q z where "x=q*z" "Prime q \<in> set ys \<and> Triple p a z \<in> set ys"
                and cong:"[a^((p - 1) div q) \<noteq> 1] (mod p)" using Cons.prems x_y by auto
     then have factors_IH:"(\<forall> r \<in> prime_factors z . [a^((p - 1) div r) \<noteq> 1] (mod p))" "prime q" "z>0"
       using Cons.IH Cons.prems \<open>x>0\<close> \<open>y=Triple p a x\<close>
       by force+
     then have "prime_factors x = prime_factors z \<union> {q}"  using \<open>x =q*z\<close> \<open>x>0\<close>
       by (simp add: prime_factors_product prime_factors_of_prime)
     then have "(\<forall> q \<in> prime_factors x . [a^((p - 1) div q) \<noteq> 1] (mod p)) \<and> 0 < x"
       using factors_IH cong by (simp add: \<open>x>0\<close>)
     }
   ultimately have y_Triple:"y=Triple p a x \<Longrightarrow> (\<forall> q \<in> prime_factors x .
                                                 [a^((p - 1) div q) \<noteq> 1] (mod p)) \<and> 0<x" by linarith
   { assume y: "y=Prime p" "p>2" then
     obtain a where a:"[a^(p - 1) = 1] (mod p)" "Triple p a (p - 1) \<in> set ys"
       using Cons.prems by auto
     then have Bier:"(\<forall>q\<in>prime_factors (p - 1). [a^((p - 1) div q) \<noteq> 1] (mod p))"
       using Cons.IH Cons.prems(1) by (simp add:y(1))
     then have "prime p" using lehmers_theorem[OF _ _a(1)] \<open>p>2\<close> by fastforce
     }
   moreover
   { assume "y=Prime p" "p=2" hence "prime p" by simp }
   moreover
   { assume "y=Prime p" then have "p>1"  using Cons.prems  by simp }
   ultimately have y_Prime:"y = Prime p \<Longrightarrow> prime p" by linarith
 
   show ?case
   proof (cases "t \<in> set ys")
     case True
       show ?thesis using Cons.IH[OF _ True] Cons.prems(1) by (cases y) auto
     next
     case False
       thus ?thesis using Cons.prems(2) y_Prime y_Triple by force
   qed
 qed
 
 corollary pratt_primeI:
   assumes "valid_cert xs" "Prime p \<in> set xs"
   shows   "prime p"
   using pratt_sound[OF assms] by simp
 
 
 subsection \<open>Completeness\<close>
 
 text \<open>
   In this section we show completeness of Pratt's proof system, i.e., we show that for
   every prime number $p$ there exists a certificate for $p$. We also give an upper
   bound for the size of a minimal certificate
 
   The prove we give is constructive. We assume that we have certificates for all prime
   factors of $p - 1$ and use these to build a certificate for $p$ from that. It is
   important to note that certificates can be concatenated.
 \<close>
 
 lemma valid_cert_appendI:
   assumes "valid_cert r"
   assumes "valid_cert s"
   shows "valid_cert (r @ s)"
   using assms
 proof (induction r)
   case (Cons y ys) then show ?case by (cases y) auto
 qed simp
 
 lemma valid_cert_concatI: "(\<forall>x \<in> set xs . valid_cert x) \<Longrightarrow> valid_cert (concat xs)"
   by (induction xs) (auto simp add: valid_cert_appendI)
 
 lemma size_pratt_le:
  fixes d::real
  assumes "\<forall> x \<in> set c. size_pratt x \<le> d"
  shows "size_cert c \<le> length c * (1 + d)" using assms
  by (induction c) (simp_all add: algebra_simps)
 
 fun build_fpc :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> pratt list" where
   "build_fpc p a r [] = [Triple p a r]" |
   "build_fpc p a r (y # ys) = Triple p a r # build_fpc p a (r div y) ys"
 
 text \<open>
   The function @{term build_fpc} helps us to construct a certificate for $p$ from
   the certificates for the prime factors of $p - 1$. Called as
   @{term "build_fpc p a (p - 1) qs"} where $@{term "qs"} = q_1 \ldots q_n$
   is prime decomposition of $p - 1$ such that $q_1 \cdot \dotsb \cdot q_n = @{term "p - 1 :: nat"}$,
   it returns the following list of predicates:
   \[
   (p,a,p-1), (p,a,\frac{p - 1}{q_1}), (p,a,\frac{p - 1}{q_1 q_2}), \ldots, (p,a,\frac{p-1}{q_1 \ldots q_n}) = (p,a,1)
   \]
 
   I.e., if there is an appropriate $a$ and and a certificate @{term rs} for all
   prime factors of $p$, then we can construct a certificate for $p$ as
   @{term [display] "Prime p # build_fpc p a (p - 1) qs @ rs"}
 \<close>
 
 text \<open>
   The following lemma shows that \<open>build_fpc\<close> extends a certificate that
   satisfies the preconditions described before to a correct certificate.
 \<close>
 
 lemma correct_fpc:
   assumes "valid_cert xs" "p > 1"
   assumes "prod_list qs = r" "r \<noteq> 0"
   assumes "\<forall> q \<in> set qs . Prime q \<in> set xs"
   assumes "\<forall> q \<in> set qs . [a^((p - 1) div q) \<noteq> 1] (mod p)"
   shows "valid_cert (build_fpc p a r qs @ xs)"
   using assms
 proof (induction qs arbitrary: r)
   case Nil thus ?case by auto
 next
   case (Cons y ys)
   have "prod_list ys = r div y" using Cons.prems by auto
   then have T_in: "Triple p a (prod_list ys) \<in> set (build_fpc p a (r div y) ys @ xs)"
     by (cases ys) auto
 
   have "valid_cert (build_fpc p a (r div y) ys @ xs)"
     using Cons.prems by (intro Cons.IH) auto
   then have "valid_cert (Triple p a r # build_fpc p a (r div y) ys @ xs)"
     using \<open>r \<noteq> 0\<close> T_in Cons.prems by auto
   then show ?case by simp
 qed
 
 lemma length_fpc:
   "length (build_fpc p a r qs) = length qs + 1" by (induction qs arbitrary: r) auto
 
 lemma div_gt_0:
   fixes m n :: nat assumes "m \<le> n" "0 < m" shows "0 < n div m"
 proof -
   have "0 < m div m" using \<open>0 < m\<close> div_self by auto
   also have "m div m \<le> n div m" using \<open>m \<le> n\<close> by (rule div_le_mono)
   finally show ?thesis .
 qed
 
 lemma size_pratt_fpc:
   assumes "a \<le> p" "r \<le> p" "0 < a" "0 < r" "0 < p" "prod_list qs = r"
   shows "\<forall>x \<in> set (build_fpc p a r qs) . size_pratt x \<le> 3 * log 2 p" using assms
 proof (induction qs arbitrary: r)
   case Nil
   then have "log 2 a \<le> log 2 p" "log 2 r \<le> log 2 p" by auto
   then show ?case by simp
 next
   case (Cons q qs)
   then have "log 2 a \<le> log 2 p" "log 2 r \<le> log 2 p" by auto
   then have  "log 2 a + log 2 r \<le> 2 * log 2 p" by arith
   moreover have "r div q > 0" using Cons.prems by (fastforce intro: div_gt_0)
   moreover hence "prod_list qs = r div q" using Cons.prems(6) by auto
   moreover have "r div q \<le> p" using \<open>r\<le>p\<close> div_le_dividend[of r q] by linarith
   ultimately show ?case using Cons by simp
 qed
 
 lemma concat_set:
   assumes "\<forall> q \<in> qs . \<exists> c \<in> set cs . Prime q \<in> set c"
   shows "\<forall> q \<in> qs . Prime q \<in> set (concat cs)"
   using assms by (induction cs) auto
 
 lemma p_in_prime_factorsE:
   fixes n :: nat
   assumes "p \<in> prime_factors n" "0 < n"
   obtains "2 \<le> p" "p \<le> n" "p dvd n" "prime p"
 proof
   from assms show "prime p" by auto
   then show "2 \<le> p" by (auto dest: prime_gt_1_nat)
 
   from assms show "p dvd n" by auto
   then show "p \<le> n" using  \<open>0 < n\<close> by (rule dvd_imp_le)
 qed
 
 lemma prime_factors_list_prime:
   fixes n :: nat
   assumes "prime n"
   shows "\<exists> qs. prime_factors n = set qs \<and> prod_list qs = n \<and> length qs = 1"
   using assms by (auto simp add: prime_factorization_prime intro: exI [of _ "[n]"])
 
 lemma prime_factors_list:
   fixes n :: nat assumes "3 < n" "\<not> prime n"
   shows "\<exists> qs. prime_factors n = set qs \<and> prod_list qs = n \<and> length qs \<ge> 2"
   using assms
 proof (induction n rule: less_induct)
   case (less n)
     obtain p where "p \<in> prime_factors n" using \<open>n > 3\<close> prime_factors_elem by force
     then have p':"2 \<le> p" "p \<le> n" "p dvd n" "prime p"
       using \<open>3 < n\<close> by (auto elim: p_in_prime_factorsE)
     { assume "n div p > 3" "\<not> prime (n div p)"
       then obtain qs
         where "prime_factors (n div p) = set qs" "prod_list qs = (n div p)" "length qs \<ge> 2"
         using p' by atomize_elim (auto intro: less simp: div_gt_0)
       moreover
       have "prime_factors (p * (n div p)) = insert p (prime_factors (n div p))"
         using \<open>3 < n\<close> \<open>2 \<le> p\<close> \<open>p \<le> n\<close> \<open>prime p\<close>
       by (auto simp: prime_factors_product div_gt_0 prime_factors_of_prime)
       ultimately
       have "prime_factors n = set (p # qs)" "prod_list (p # qs) = n" "length (p#qs) \<ge> 2"
         using \<open>p dvd n\<close> by simp_all
       hence ?case by blast
     }
     moreover
     { assume "prime (n div p)"
       then obtain qs
         where "prime_factors (n div p) = set qs" "prod_list qs = (n div p)" "length qs = 1"
         using prime_factors_list_prime by blast
       moreover
       have "prime_factors (p * (n div p)) = insert p (prime_factors (n div p))"
         using \<open>3 < n\<close> \<open>2 \<le> p\<close> \<open>p \<le> n\<close> \<open>prime p\<close>
       by (auto simp: prime_factors_product div_gt_0 prime_factors_of_prime)
       ultimately
       have "prime_factors n = set (p # qs)" "prod_list (p # qs) = n" "length (p#qs) \<ge> 2"
         using \<open>p dvd n\<close> by simp_all
       hence ?case by blast
     } note case_prime = this
     moreover
     { assume "n div p = 1"
       hence "n = p" using \<open>n>3\<close>  using One_leq_div[OF \<open>p dvd n\<close>] p'(2) by force
       hence ?case using \<open>prime p\<close> \<open>\<not> prime n\<close> by auto
     }
     moreover
     { assume "n div p = 2"
       hence ?case using case_prime by force
     }
     moreover
     { assume "n div p = 3"
       hence ?case using p' case_prime by force
     }
     ultimately show ?case using p' div_gt_0[of p n] case_prime by fastforce
 
 qed
 
 lemma prod_list_ge:
   fixes xs::"nat list"
   assumes "\<forall> x \<in> set xs . x \<ge> 1"
   shows "prod_list xs \<ge> 1" using assms by (induction xs) auto
 
 lemma sum_list_log:
   fixes b::real
   fixes xs::"nat list"
   assumes b: "b > 0" "b \<noteq> 1"
   assumes xs:"\<forall> x \<in> set xs . x \<ge> b"
   shows "(\<Sum>x\<leftarrow>xs. log b x) = log b (prod_list xs)"
   using assms
 proof (induction xs)
   case Nil
     thus ?case by simp
   next
   case (Cons y ys)
     have "real (prod_list ys) > 0" using prod_list_ge Cons.prems by fastforce
     thus ?case using log_mult[OF Cons.prems(1-2)] Cons by force
 qed
 
 lemma concat_length_le:
   fixes g :: "nat \<Rightarrow> real"
   assumes "\<forall> x \<in> set xs . real (length (f x)) \<le> g x"
   shows "length (concat (map f xs)) \<le> (\<Sum>x\<leftarrow>xs. g x)" using assms
   by (induction xs) force+
 
 lemma prime_gt_3_impl_p_minus_one_not_prime:
   fixes p::nat
   assumes "prime p" "p>3"
   shows "\<not> prime (p - 1)"
 proof
   assume "prime (p - 1)"
   have "\<not> even p" using assms by (simp add: prime_odd_nat)
   hence "2 dvd (p - 1)" by presburger
   then obtain q where "p - 1 = 2 * q" ..
   then have "2 \<in> prime_factors (p - 1)" using \<open>p>3\<close>
     by (auto simp: prime_factorization_times_prime)
   thus False using prime_factors_of_prime \<open>p>3\<close> \<open>prime (p - 1)\<close> by auto
 qed
 
 text \<open>
   We now prove that Pratt's proof system is complete and derive upper bounds for
   the length and the size of the entries of a minimal certificate.
 \<close>
 
 theorem pratt_complete':
   assumes "prime p"
   shows "\<exists>c. Prime p \<in> set c \<and> valid_cert c \<and> length c \<le> 6*log 2 p - 4 \<and> (\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p)" using assms
 proof (induction p rule: less_induct)
   case (less p)
   from \<open>prime p\<close> have "p > 1" by (rule prime_gt_1_nat)
   then consider "p = 2" | " p = 3" | "p > 3" by force
   thus ?case
   proof cases
     assume [simp]: "p = 2"
     have "Prime p \<in> set [Prime 2, Triple 2 1 1]" by simp
     thus ?case by fastforce
   next
     assume [simp]: "p = 3"
     let ?cert = "[Prime 3, Triple 3 2 2, Triple 3 2 1, Prime 2, Triple 2 1 1]"
 
     have "length ?cert \<le> 6*log 2 p - 4 \<longleftrightarrow> 3 \<le> 2 * log 2 3" by simp
     also have "2 * log 2 3 = log 2 (3 ^ 2 :: real)" by (subst log_nat_power) simp_all
     also have "\<dots> = log 2 9" by simp
     also have "3 \<le> log 2 9 \<longleftrightarrow> True" by (subst le_log_iff) simp_all
     finally show ?case
       by (intro exI[where x = "?cert"]) (simp add: cong_def)
   next
     assume "p > 3"
     have qlp: "\<forall>q \<in> prime_factors (p - 1) . q < p" using \<open>prime p\<close>
       by (metis One_nat_def Suc_pred le_imp_less_Suc lessI less_trans p_in_prime_factorsE prime_gt_1_nat zero_less_diff)
     hence factor_certs:"\<forall>q \<in> prime_factors (p - 1) . (\<exists>c . ((Prime q \<in> set c) \<and> (valid_cert c)
                                                       \<and> length c \<le> 6*log 2 q - 4) \<and> (\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 q))"
       by (auto intro: less.IH)
     obtain a where a:"[a^(p - 1) = 1] (mod p) \<and> (\<forall> q. q \<in> prime_factors (p - 1)
               \<longrightarrow> [a^((p - 1) div q) \<noteq> 1] (mod p))" and a_size: "a > 0" "a < p"
       using converse_lehmer[OF \<open>prime p\<close>] by blast
 
     have "\<not> prime (p - 1)" using \<open>p>3\<close> prime_gt_3_impl_p_minus_one_not_prime \<open>prime p\<close> by auto
     have "p \<noteq> 4" using \<open>prime p\<close> by auto
     hence "p - 1 > 3" using \<open>p > 3\<close> by auto
 
     then obtain qs where prod_qs_eq:"prod_list qs = p - 1"
         and qs_eq:"set qs = prime_factors (p - 1)" and qs_length_eq: "length qs \<ge> 2"
       using prime_factors_list[OF _ \<open>\<not> prime (p - 1)\<close>] by auto
     obtain f where f:"\<forall>q \<in> prime_factors (p - 1) . \<exists> c. f q = c
                      \<and> ((Prime q \<in> set c) \<and> (valid_cert c) \<and> length c \<le> 6*log 2 q - 4)
                      \<and> (\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 q)"
       using factor_certs by metis
     let ?cs = "map f qs"
     have cs: "\<forall>q \<in> prime_factors (p - 1) . (\<exists>c \<in> set ?cs . (Prime q \<in> set c) \<and> (valid_cert c)
                                            \<and> length c \<le> 6*log 2 q - 4
                                            \<and> (\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 q))"
       using f qs_eq by auto
 
     have cs_cert_size: "\<forall>c \<in> set ?cs . \<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p"
     proof
       fix c assume "c \<in> set (map f qs)"
       then obtain q where "c = f q" and "q \<in> set qs" by auto
       hence *:"\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 q" using f qs_eq by blast
       have "q < p" "q > 0" using qlp \<open>q \<in> set qs\<close> qs_eq prime_factors_gt_0_nat by auto
       show "\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p"
       proof
         fix x assume "x \<in> set c"
         hence "size_pratt x \<le> 3 * log 2 q" using * by fastforce
         also have "\<dots> \<le> 3 * log 2 p" using \<open>q < p\<close> \<open>q > 0\<close> \<open>p > 3\<close> by simp
         finally show "size_pratt x \<le> 3 * log 2 p" .
       qed
     qed
 
     have cs_valid_all: "\<forall>c \<in> set ?cs . valid_cert c"
       using f qs_eq by fastforce
 
     have "\<forall>x \<in> set (build_fpc p a (p - 1) qs). size_pratt x \<le> 3 * log 2 p"
       using cs_cert_size a_size \<open>p > 3\<close> prod_qs_eq by (intro size_pratt_fpc) auto
     hence "\<forall>x \<in> set (build_fpc p a (p - 1) qs @ concat ?cs) . size_pratt x \<le> 3 * log 2 p"
       using cs_cert_size by auto
     moreover
     have "Triple p a (p - 1) \<in> set (build_fpc p a (p - 1) qs @ concat ?cs)" by (cases qs) auto
     moreover
     have "valid_cert ((build_fpc p a (p - 1) qs)@ concat ?cs)"
     proof (rule correct_fpc)
       show "valid_cert (concat ?cs)"
         using cs_valid_all by (auto simp: valid_cert_concatI)
       show "prod_list qs = p - 1" by (rule prod_qs_eq)
       show "p - 1 \<noteq> 0" using prime_gt_1_nat[OF \<open>prime p\<close>] by arith
       show "\<forall> q \<in> set qs . Prime q \<in> set (concat ?cs)"
         using concat_set[of "prime_factors (p - 1)"] cs qs_eq by blast
       show "\<forall> q \<in> set qs . [a^((p - 1) div q) \<noteq> 1] (mod p)" using qs_eq a by auto
     qed (insert \<open>p > 3\<close>, simp_all)
     moreover
     { let ?k = "length qs"
 
       have qs_ge_2:"\<forall>q \<in> set qs . q \<ge> 2" using qs_eq
         by (auto intro: prime_ge_2_nat)
 
       have "\<forall>x\<in>set qs. real (length (f x)) \<le> 6 * log 2 (real x) - 4" using f qs_eq by blast
       hence "length (concat ?cs) \<le> (\<Sum>q\<leftarrow>qs. 6*log 2 q - 4)" using concat_length_le
         by fast
       hence "length (Prime p # ((build_fpc p a (p - 1) qs)@ concat ?cs))
             \<le> ((\<Sum>q\<leftarrow>(map real qs). 6*log 2 q - 4) + ?k + 2)"
             by (simp add: o_def length_fpc)
       also have "\<dots> = (6*(\<Sum>q\<leftarrow>(map real qs). log 2 q) + (-4 * real ?k) + ?k + 2)"
         by (simp add: o_def sum_list_subtractf sum_list_triv sum_list_const_mult)
       also have "\<dots> \<le> 6*log 2 (p - 1) - 4" using \<open>?k\<ge>2\<close> prod_qs_eq sum_list_log[of 2 qs] qs_ge_2
         by force
       also have "\<dots> \<le> 6*log 2 p - 4" using log_le_cancel_iff[of 2 "p - 1" p] \<open>p>3\<close> by force
       ultimately have "length (Prime p # ((build_fpc p a (p - 1) qs)@ concat ?cs))
                        \<le> 6*log 2 p - 4" by linarith }
     ultimately obtain c where c:"Triple p a (p - 1) \<in> set c" "valid_cert c"
                                "length (Prime p #c) \<le> 6*log 2 p - 4"
                                "(\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p)" by blast
     hence "Prime p \<in> set (Prime p # c)" "valid_cert (Prime p # c)"
          "(\<forall> x \<in> set (Prime p # c). size_pratt x \<le> 3 * log 2 p)"
     using a \<open>prime p\<close> by (auto simp: Primes.prime_gt_Suc_0_nat)
     thus ?case using c by blast
   qed
 qed
 
 text \<open>
   We now recapitulate our results. A number $p$ is prime if and only if there
   is a certificate for $p$. Moreover, for a prime $p$ there always is a certificate
   whose size is polynomially bounded in the logarithm of $p$.
 \<close>
 
 corollary pratt:
   "prime p \<longleftrightarrow> (\<exists>c. Prime p \<in> set c \<and> valid_cert c)"
   using pratt_complete' pratt_sound(1) by blast
 
 corollary pratt_size:
   assumes "prime p"
   shows "\<exists>c. Prime p \<in> set c \<and> valid_cert c \<and> size_cert c \<le> (6 * log 2 p - 4) * (1 + 3 * log 2 p)"
 proof -
   obtain c where c: "Prime p \<in> set c" "valid_cert c"
       and len: "length c \<le> 6*log 2 p - 4" and "(\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p)"
     using pratt_complete' assms by blast
   hence "size_cert c \<le> length c * (1 + 3 * log 2 p)" by (simp add: size_pratt_le)
   also have "\<dots> \<le> (6*log 2 p - 4) * (1 + 3 * log 2 p)" using len by simp
   finally show ?thesis using c by blast
 qed
 
 
 subsection \<open>Efficient modular exponentiation\<close>
 
 locale efficient_power =
   fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
   assumes f_assoc: "\<And>x z. f x (f x z) = f (f x x) z"
 begin
 
 function efficient_power :: "'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a" where
   "efficient_power y x 0 = y"
 | "efficient_power y x (Suc 0) = f x y"
 | "n \<noteq> 0 \<Longrightarrow> even n \<Longrightarrow> efficient_power y x n = efficient_power y (f x x) (n div 2)"
 | "n \<noteq> 1 \<Longrightarrow> odd n \<Longrightarrow> efficient_power y x n = efficient_power (f x y) (f x x) (n div 2)"
   by force+
 termination by (relation "measure (snd \<circ> snd)") (auto elim: oddE)
 
 lemma efficient_power_code:
   "efficient_power y x n =
      (if n = 0 then y
       else if n = 1 then f x y
       else if even n then efficient_power y (f x x) (n div 2)
       else efficient_power (f x y) (f x x) (n div 2))"
   by (induction y x n rule: efficient_power.induct) auto
 
 lemma efficient_power_correct: "efficient_power y x n = (f x ^^ n) y"
 proof -
   have [simp]: "f ^^ 2 = (\<lambda>x. f (f x))" for f :: "'a \<Rightarrow> 'a"
     by (simp add: eval_nat_numeral o_def)
   show ?thesis
     by (induction y x n rule: efficient_power.induct)
        (auto elim!: evenE oddE simp: funpow_mult [symmetric] funpow_Suc_right f_assoc
              simp del: funpow.simps(2))
 qed
 
 end
 
 interpretation mod_exp_nat: efficient_power "\<lambda>x y :: nat. (x * y) mod m"
   by standard (simp add: mod_mult_left_eq mod_mult_right_eq mult_ac)
 
 definition mod_exp_nat_aux where "mod_exp_nat_aux = mod_exp_nat.efficient_power"
 
 lemma mod_exp_nat_aux_code [code]:
   "mod_exp_nat_aux m y x n =
      (if n = 0 then y
       else if n = 1 then (x * y) mod m
       else if even n then mod_exp_nat_aux m y ((x * x) mod m) (n div 2)
       else mod_exp_nat_aux m ((x * y) mod m) ((x * x) mod m) (n div 2))"
   unfolding mod_exp_nat_aux_def by (rule mod_exp_nat.efficient_power_code)
 
 lemma mod_exp_nat_aux_correct:
   "mod_exp_nat_aux m y x n mod m = (x ^ n * y) mod m"
 proof -
   have "mod_exp_nat_aux m y x n = ((\<lambda>y. x * y mod m) ^^ n) y"
     by (simp add: mod_exp_nat_aux_def mod_exp_nat.efficient_power_correct)
   also have "((\<lambda>y. x * y mod m) ^^ n) y mod m = (x ^ n * y) mod m"
   proof (induction n)
     case (Suc n)
     hence "x * ((\<lambda>y. x * y mod m) ^^ n) y mod m = x * x ^ n * y mod m"
       by (metis mod_mult_right_eq mult.assoc)
     thus ?case by auto
   qed auto
   finally show ?thesis .
 qed
 
 definition mod_exp_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where [code_abbrev]: "mod_exp_nat b e m = (b ^ e) mod m"
 
 lemma mod_exp_nat_code [code]: "mod_exp_nat b e m = mod_exp_nat_aux m 1 b e mod m"
   by (simp add: mod_exp_nat_def mod_exp_nat_aux_correct)
 
 lemmas [code_unfold] = cong_def
 
 lemma eval_mod_exp_nat_aux [simp]:
   "mod_exp_nat_aux m y x 0 = y"
   "mod_exp_nat_aux m y x (Suc 0) = (x * y) mod m"
   "mod_exp_nat_aux m y x (numeral (num.Bit0 n)) =
      mod_exp_nat_aux m y (x\<^sup>2 mod m) (numeral n)"
   "mod_exp_nat_aux m y x (numeral (num.Bit1 n)) =
      mod_exp_nat_aux m ((x * y) mod m) (x\<^sup>2 mod m) (numeral n)"
 proof -
   define n' where "n' = (numeral n :: nat)"
   have [simp]: "n' \<noteq> 0" by (auto simp: n'_def)
   
   show "mod_exp_nat_aux m y x 0 = y" and "mod_exp_nat_aux m y x (Suc 0) = (x * y) mod m"
     by (simp_all add: mod_exp_nat_aux_def)
 
   have "numeral (num.Bit0 n) = (2 * n')"
     by (subst numeral.numeral_Bit0) (simp del: arith_simps add: n'_def)
   also have "mod_exp_nat_aux m y x \<dots> = mod_exp_nat_aux m y (x^2 mod m) n'"
     by (subst mod_exp_nat_aux_code) (simp_all add: power2_eq_square)
   finally show "mod_exp_nat_aux m y x (numeral (num.Bit0 n)) =
                   mod_exp_nat_aux m y (x\<^sup>2 mod m) (numeral n)"
     by (simp add: n'_def)
 
   have "numeral (num.Bit1 n) = Suc (2 * n')"
     by (subst numeral.numeral_Bit1) (simp del: arith_simps add: n'_def)
   also have "mod_exp_nat_aux m y x \<dots> = mod_exp_nat_aux m ((x * y) mod m) (x^2 mod m) n'"
     by (subst mod_exp_nat_aux_code) (simp_all add: power2_eq_square)
   finally show "mod_exp_nat_aux m y x (numeral (num.Bit1 n)) =
                   mod_exp_nat_aux m ((x * y) mod m) (x\<^sup>2 mod m) (numeral n)"
     by (simp add: n'_def)
 qed
 
 lemma eval_mod_exp [simp]:
   "mod_exp_nat b' 0 m' = 1 mod m'"
   "mod_exp_nat b' 1 m' = b' mod m'"
   "mod_exp_nat b' (Suc 0) m' = b' mod m'"
   "mod_exp_nat b' e' 0 = b' ^ e'"  
   "mod_exp_nat b' e' 1 = 0"
   "mod_exp_nat b' e' (Suc 0) = 0"
   "mod_exp_nat 0 1 m' = 0"
   "mod_exp_nat 0 (Suc 0) m' = 0"
   "mod_exp_nat 0 (numeral e) m' = 0"
   "mod_exp_nat 1 e' m' = 1 mod m'"
   "mod_exp_nat (Suc 0) e' m' = 1 mod m'"
   "mod_exp_nat (numeral b) (numeral e) (numeral m) =
      mod_exp_nat_aux (numeral m) 1 (numeral b) (numeral e) mod numeral m"
   by (simp_all add: mod_exp_nat_def mod_exp_nat_aux_correct)
 
 
 
 subsection \<open>Executable certificate checker\<close>
 
 lemmas [code] = valid_cert.simps(1)
 
 context
 begin
 
 lemma valid_cert_Cons1 [code]:
   "valid_cert (Prime p # xs) \<longleftrightarrow>
      p > 1 \<and> (\<exists>t\<in>set xs. case t of Prime _ \<Rightarrow> False | 
      Triple p' a x \<Rightarrow> p' = p \<and> x = p - 1 \<and> mod_exp_nat a (p-1) p = 1 ) \<and> valid_cert xs"
   (is "?lhs = ?rhs")
 proof
   assume ?lhs thus ?rhs by (auto simp: mod_exp_nat_def cong_def split: pratt.splits)
 next
   assume ?rhs
   hence "p > 1" "valid_cert xs" by blast+
   moreover from \<open>?rhs\<close> obtain t where "t \<in> set xs" "case t of Prime _ \<Rightarrow> False | 
      Triple p' a x \<Rightarrow> p' = p \<and> x = p - 1 \<and> [a^(p-1) = 1] (mod p)" 
      by (auto simp: cong_def mod_exp_nat_def cong: pratt.case_cong)
   ultimately show ?lhs by (cases t) auto
 qed
 
 private lemma Suc_0_mod_eq_Suc_0_iff:
   "Suc 0 mod n = Suc 0 \<longleftrightarrow> n \<noteq> Suc 0"
 proof -
   consider "n = 0" | "n = Suc 0" | "n > 1" by (cases n) auto
   thus ?thesis by cases auto
 qed
 
 private lemma Suc_0_eq_Suc_0_mod_iff:
   "Suc 0 = Suc 0 mod n \<longleftrightarrow> n \<noteq> Suc 0"
   using Suc_0_mod_eq_Suc_0_iff by (simp add: eq_commute)
 
 lemma valid_cert_Cons2 [code]:
   "valid_cert (Triple p a x # xs) \<longleftrightarrow> x > 0 \<and> p > 1 \<and> (x = 1 \<or> (
      (\<exists>t\<in>set xs. case t of Prime _ \<Rightarrow> False |
         Triple p' a' y \<Rightarrow> p' = p \<and> a' = a \<and> y dvd x \<and> 
         (let q = x div y in Prime q \<in> set xs \<and> mod_exp_nat a ((p-1) div q) p \<noteq> 1)))) \<and> valid_cert xs"
   (is "?lhs = ?rhs")
 proof
   assume ?lhs
   from \<open>?lhs\<close> have pos: "x > 0" and gt_1: "p > 1" and valid: "valid_cert xs" by simp_all
   show ?rhs
   proof (cases "x = 1")
     case True
     with \<open>?lhs\<close> show ?thesis by auto
   next
     case False
     with \<open>?lhs\<close> have "(\<exists>q y. x = q * y \<and> Prime q \<in> set xs \<and> Triple p a y \<in> set xs
       \<and> [a^((p - 1) div q) \<noteq> 1] (mod p))" by auto
-    then guess q y by (elim exE conjE) note qy = this
+    then obtain q y where qy:
+      "x = q * y"
+      "Prime q \<in> set xs"
+      "Triple p a y \<in> set xs"
+      "[a ^ ((p - 1) div q) \<noteq> 1] (mod p)"
+      by blast
     hence "(\<exists>t\<in>set xs. case t of Prime _ \<Rightarrow> False |
         Triple p' a' y \<Rightarrow> p' = p \<and> a' = a \<and> y dvd x \<and> 
         (let q = x div y in Prime q \<in> set xs \<and> mod_exp_nat a ((p-1) div q) p \<noteq> 1))"
     using pos gt_1 by (intro bexI [of _ "Triple p a y"]) 
       (auto simp: Suc_0_mod_eq_Suc_0_iff Suc_0_eq_Suc_0_mod_iff cong_def mod_exp_nat_def)
     with pos gt_1 valid show ?thesis by blast
   qed
 next
   assume ?rhs
   hence pos: "x > 0" and gt_1: "p > 1" and valid: "valid_cert xs" by simp_all
   show ?lhs
   proof (cases "x = 1")
     case True
     with \<open>?rhs\<close> show ?thesis by auto
   next
     case False
     with \<open>?rhs\<close> obtain t where t: "t \<in> set xs" "case t of Prime x \<Rightarrow> False
          | Triple p' a' y \<Rightarrow> p' = p \<and> a' = a \<and> y dvd x \<and> (let q = x div y
               in Prime q \<in> set xs \<and> mod_exp_nat a ((p - 1) div q) p \<noteq> 1)" by auto
     then obtain y where y: "t = Triple p a y" "y dvd x" "let q = x div y in Prime q \<in> set xs \<and> 
                               mod_exp_nat a ((p - 1) div q) p \<noteq> 1" 
       by (cases t rule: pratt.exhaust) auto
     with gt_1 have y': "let q = x div y in Prime q \<in> set xs \<and> [a^((p - 1) div q) \<noteq> 1] (mod p)"
       by (auto simp: cong_def Let_def mod_exp_nat_def Suc_0_mod_eq_Suc_0_iff Suc_0_eq_Suc_0_mod_iff)
     define q where "q = x div y"
     have "\<exists>q y. x = q * y \<and> Prime q \<in> set xs \<and> Triple p a y \<in> set xs
                      \<and> [a^((p - 1) div q) \<noteq> 1] (mod p)"
       by (rule exI[of _ q], rule exI[of _ y]) (insert t y y', auto simp: Let_def q_def)
     with pos gt_1 valid show ?thesis by simp
   qed
 qed
 
 declare valid_cert.simps(2,3) [simp del]
 
 lemmas eval_valid_cert = valid_cert.simps(1) valid_cert_Cons1 valid_cert_Cons2
 
 end
 
 
 text \<open>
   The following alternative tree representation of certificates is better suited for 
   efficient checking.
 \<close>
 
 datatype pratt_tree = Pratt_Node "nat \<times> nat \<times> pratt_tree list"
 
 fun pratt_tree_number where
   "pratt_tree_number (Pratt_Node (n, _, _)) = n"
 
 
 text \<open>
   The following function checks that a given list contains all the prime factors of the given
   number.
 \<close>
 
 fun check_prime_factors_subset :: "nat \<Rightarrow> nat list \<Rightarrow> bool" where
   "check_prime_factors_subset n [] \<longleftrightarrow> n = 1"
 | "check_prime_factors_subset n (p # ps) \<longleftrightarrow> (if n = 0 then False else
      (if p > 1 \<and> p dvd n then check_prime_factors_subset (n div p) (p # ps)
                          else check_prime_factors_subset n ps))"
 
 lemma check_prime_factors_subset_0 [simp]: "\<not>check_prime_factors_subset 0 ps"
   by (induction ps) auto
 
 lemmas [simp del] = check_prime_factors_subset.simps(2)
 
 lemma check_prime_factors_subset_Cons [simp]:
   "check_prime_factors_subset (Suc 0) (p # ps) \<longleftrightarrow> check_prime_factors_subset (Suc 0) ps"
   "check_prime_factors_subset 1 (p # ps) \<longleftrightarrow> check_prime_factors_subset 1 ps"
   "p > 1 \<Longrightarrow> p dvd numeral n \<Longrightarrow> check_prime_factors_subset (numeral n) (p # ps) \<longleftrightarrow>
                            check_prime_factors_subset (numeral n div p) (p # ps)"
   "p \<le> 1 \<or> \<not>p dvd numeral n \<Longrightarrow> check_prime_factors_subset (numeral n) (p # ps) \<longleftrightarrow>
                            check_prime_factors_subset (numeral n) ps"
  by (subst check_prime_factors_subset.simps; force)+
 
 lemma check_prime_factors_subset_correct:
   assumes "check_prime_factors_subset n ps" "list_all prime ps"
   shows   "prime_factors n \<subseteq> set ps"
   using assms
 proof (induction n ps rule: check_prime_factors_subset.induct)
   case (2 n p ps)
   note * = this
   from "2.prems" have "prime p" and "p > 1"
     by (auto simp: prime_gt_Suc_0_nat)
 
   consider "n = 0" | "n > 0" "p dvd n" | "n > 0" "\<not>(p dvd n)"
     by blast
   thus ?case
   proof cases
     case 2
     hence "n div p > 0" by auto
     hence "prime_factors ((n div p) * p) = insert p (prime_factors (n div p))"
       using \<open>p > 1\<close> \<open>prime p\<close> by (auto simp: prime_factors_product prime_prime_factors)
     also have "(n div p) * p = n"
       using 2 by auto
     finally show ?thesis using 2 \<open>p > 1\<close> *
       by (auto simp: check_prime_factors_subset.simps(2)[of n])
   next
     case 3
     with * and \<open>p > 1\<close> show ?thesis
       by (auto simp: check_prime_factors_subset.simps(2)[of n])
   qed auto
 qed auto
 
 
 fun valid_pratt_tree where
   "valid_pratt_tree (Pratt_Node (n, a, ts)) \<longleftrightarrow>
      n \<ge> 2 \<and>
      check_prime_factors_subset (n - 1) (map pratt_tree_number ts) \<and>
      [a ^ (n - 1) = 1] (mod n) \<and>
      (\<forall>t\<in>set ts. [a ^ ((n - 1) div pratt_tree_number t) \<noteq> 1] (mod n)) \<and>
      (\<forall>t\<in>set ts. valid_pratt_tree t)"
 
 lemma valid_pratt_tree_code [code]:
   "valid_pratt_tree (Pratt_Node (n, a, ts)) \<longleftrightarrow>
      n \<ge> 2 \<and>
      check_prime_factors_subset (n - 1) (map pratt_tree_number ts) \<and>
      mod_exp_nat a (n - 1) n = 1 \<and>
      (\<forall>t\<in>set ts. mod_exp_nat a ((n - 1) div pratt_tree_number t) n \<noteq> 1) \<and>
      (\<forall>t\<in>set ts. valid_pratt_tree t)"
   by (simp add: mod_exp_nat_def cong_def)
 
 lemma valid_pratt_tree_imp_prime:
   assumes "valid_pratt_tree t"
   shows   "prime (pratt_tree_number t)"
   using assms
 proof (induction t rule: valid_pratt_tree.induct)
   case (1 n a ts)
   from 1 have "prime_factors (n - 1) \<subseteq> set (map pratt_tree_number ts)"
     by (intro check_prime_factors_subset_correct) (auto simp: list.pred_set)
   with 1 show ?case
     by (intro lehmers_theorem[where a = a]) auto
 qed
 
 lemma valid_pratt_tree_imp_prime':
   assumes "PROP (Trueprop (valid_pratt_tree (Pratt_Node (n, a, ts)))) \<equiv> PROP (Trueprop True)"
   shows   "prime n"
 proof -
   have "valid_pratt_tree (Pratt_Node (n, a, ts))"
     by (subst assms) auto
   from valid_pratt_tree_imp_prime[OF this] show ?thesis by simp
 qed
 
 
 subsection \<open>Proof method setup\<close>
 
 theorem lehmers_theorem':
   fixes p :: nat
   assumes "list_all prime ps" "a \<equiv> a" "n \<equiv> n"
   assumes "list_all (\<lambda>p. mod_exp_nat a ((n - 1) div p) n \<noteq> 1) ps" "mod_exp_nat a (n - 1) n = 1"
   assumes "check_prime_factors_subset (n - 1) ps" "2 \<le> n"
   shows "prime n"
   using assms check_prime_factors_subset_correct[OF assms(6,1)]
   by (intro lehmers_theorem[where a = a]) (auto simp: cong_def mod_exp_nat_def list.pred_set)
 
 lemma list_all_ConsI: "P x \<Longrightarrow> list_all P xs \<Longrightarrow> list_all P (x # xs)"
   by simp
 
 ML_file \<open>pratt.ML\<close>
 
 method_setup pratt = \<open>
   Scan.lift (Pratt.tac_config_parser -- Scan.option Pratt.cert_cartouche) >> 
     (fn (config, cert) => fn ctxt => SIMPLE_METHOD (HEADGOAL (Pratt.tac config cert ctxt)))
 \<close> "Prove primality of natural numbers using Pratt certificates."
 
 text \<open>
   The proof method replays a given Pratt certificate to prove the primality of a given number.
   If no certificate is given, the method attempts to compute one. The computed certificate is then
   also printed with a prompt to insert it into the proof document so that it does not have to
   be recomputed the next time.
 
   The format of the certificates is compatible with those generated by Mathematica. Therefore,
   for larger numbers, certificates generated by Mathematica can be used with this method directly.
 \<close>
 lemma "prime (47 :: nat)"
   by (pratt (silent))
 
 lemma "prime (2503 :: nat)"
   by pratt
 
 lemma "prime (7919 :: nat)"
   by pratt
 
 lemma "prime (131059 :: nat)"
   by (pratt \<open>{131059, 2, {2, {3, 2, {2}}, {809, 3, {2, {101, 2, {2, {5, 2, {2}}}}}}}}\<close>)
 
 end
diff --git a/thys/Prime_Number_Theorem/Prime_Number_Theorem_Library.thy b/thys/Prime_Number_Theorem/Prime_Number_Theorem_Library.thy
--- a/thys/Prime_Number_Theorem/Prime_Number_Theorem_Library.thy
+++ b/thys/Prime_Number_Theorem/Prime_Number_Theorem_Library.thy
@@ -1,2041 +1,2042 @@
 section \<open>Auxiliary material\<close>
 theory Prime_Number_Theorem_Library
 imports
   Zeta_Function.Zeta_Function
   "HOL-Real_Asymp.Real_Asymp"
 begin
 
 (* TODO: Move *)
 lemma asymp_equivD_strong:
   assumes "f \<sim>[F] g" "eventually (\<lambda>x. f x \<noteq> 0 \<or> g x \<noteq> 0) F"
   shows   "((\<lambda>x. f x / g x) \<longlongrightarrow> 1) F"
 proof -
   from assms(1) have "((\<lambda>x. if f x = 0 \<and> g x = 0 then 1 else f x / g x) \<longlongrightarrow> 1) F"
     by (rule asymp_equivD)
   also have "?this \<longleftrightarrow> ?thesis"
     by (intro filterlim_cong eventually_mono[OF assms(2)]) auto
   finally show ?thesis .
 qed
 
 lemma frontier_real_Ici [simp]:
   fixes a :: real
   shows "frontier {a..} = {a}"
   unfolding frontier_def by (auto simp: interior_real_atLeast)
 
 lemma sum_upto_ln_conv_sum_upto_mangoldt:
   "sum_upto (\<lambda>n. ln (real n)) x = sum_upto (\<lambda>n. mangoldt n * nat \<lfloor>x / real n\<rfloor>) x"
 proof -
   have "sum_upto (\<lambda>n. ln (real n)) x =
           sum_upto (\<lambda>n. \<Sum>d | d dvd n. mangoldt d) x"
     by (intro sum_upto_cong) (simp_all add: mangoldt_sum)
   also have "\<dots> = sum_upto (\<lambda>k. sum_upto (\<lambda>d. mangoldt k) (x / real k)) x"
     by (rule sum_upto_sum_divisors)
   also have "\<dots> = sum_upto (\<lambda>n. mangoldt n * nat \<lfloor>x / real n\<rfloor>) x"
     unfolding sum_upto_altdef by (simp add: mult_ac)
   finally show ?thesis .
 qed
 
 lemma ln_fact_conv_sum_upto_mangoldt:
   "ln (fact n) = sum_upto (\<lambda>k. mangoldt k * (n div k)) n"
 proof -
   have [simp]: "{0<..Suc n} = insert (Suc n) {0<..n}" for n by auto
   have "ln (fact n) = sum_upto (\<lambda>n. ln (real n)) n"
     by (induction n) (auto simp: sum_upto_altdef nat_add_distrib ln_mult)
   also have "\<dots> = sum_upto (\<lambda>k. mangoldt k * (n div k)) n"
     unfolding sum_upto_ln_conv_sum_upto_mangoldt
     by (intro sum_upto_cong) (auto simp: floor_divide_of_nat_eq)
   finally show ?thesis .
 qed
 
 lemma powr_sum: "x \<noteq> 0 \<Longrightarrow> finite A \<Longrightarrow> x powr sum f A = (\<Prod>y\<in>A. x powr f y)"
   by (simp add: powr_def exp_sum sum_distrib_right)
 
 lemma fds_abs_converges_comparison_test:
   fixes s :: "'a :: dirichlet_series"
   assumes "eventually (\<lambda>n. norm (fds_nth f n) \<le> fds_nth g n) at_top" and "fds_converges g (s \<bullet> 1)"
   shows   "fds_abs_converges f s"
   unfolding fds_abs_converges_def
 proof (rule summable_comparison_test_ev)
   from assms(2) show "summable (\<lambda>n. fds_nth g n / n powr (s \<bullet> 1))"
     by (auto simp: fds_converges_def)
   from assms(1) eventually_gt_at_top[of 0]
     show "eventually (\<lambda>n. norm (norm (fds_nth f n / nat_power n s)) \<le>
                             fds_nth g n / real n powr (s \<bullet> 1)) at_top"
     by eventually_elim (auto simp: norm_divide norm_nat_power intro!: divide_right_mono)
 qed
 
 lemma fds_converges_scaleR [intro]:
   assumes "fds_converges f s"
   shows   "fds_converges (c *\<^sub>R f) s"
 proof -
   from assms have "summable (\<lambda>n. c *\<^sub>R (fds_nth f n / nat_power n s))"
     by (intro summable_scaleR_right) (auto simp: fds_converges_def)
   also have "(\<lambda>n. c *\<^sub>R (fds_nth f n / nat_power n s)) = (\<lambda>n. (c *\<^sub>R fds_nth f n / nat_power n s))"
     by (simp add: scaleR_conv_of_real)
   finally show ?thesis by (simp add: fds_converges_def)
 qed
 
 lemma fds_abs_converges_scaleR [intro]:
   assumes "fds_abs_converges f s"
   shows   "fds_abs_converges (c *\<^sub>R f) s"
 proof -
   from assms have "summable (\<lambda>n. abs c * norm (fds_nth f n / nat_power n s))"
     by (intro summable_mult) (auto simp: fds_abs_converges_def)
   also have "(\<lambda>n. abs c * norm (fds_nth f n / nat_power n s)) =
                (\<lambda>n. norm ((c *\<^sub>R fds_nth f n) / nat_power n s))" by (simp add: norm_divide)
   finally show ?thesis by (simp add: fds_abs_converges_def)
 qed
 
 lemma conv_abscissa_scaleR: "conv_abscissa (scaleR c f) \<le> conv_abscissa f"
   by (rule conv_abscissa_mono) auto
 
 lemma abs_conv_abscissa_scaleR: "abs_conv_abscissa (scaleR c f) \<le> abs_conv_abscissa f"
   by (rule abs_conv_abscissa_mono) auto
 
 lemma fds_converges_mult_const_left [intro]:
   "fds_converges f s \<Longrightarrow> fds_converges (fds_const c * f) s"
   by (auto simp: fds_converges_def dest: summable_mult[of _ c])
 
 lemma fds_abs_converges_mult_const_left [intro]:
   "fds_abs_converges f s \<Longrightarrow> fds_abs_converges (fds_const c * f) s"
   by (auto simp: fds_abs_converges_def norm_mult norm_divide dest: summable_mult[of _ "norm c"])
 
 lemma conv_abscissa_mult_const_left:
   "conv_abscissa (fds_const c * f) \<le> conv_abscissa f"
   by (intro conv_abscissa_mono) auto
 
 lemma abs_conv_abscissa_mult_const_left:
   "abs_conv_abscissa (fds_const c * f) \<le> abs_conv_abscissa f"
   by (intro abs_conv_abscissa_mono) auto
 
 lemma fds_converges_mult_const_right [intro]:
   "fds_converges f s \<Longrightarrow> fds_converges (f * fds_const c) s"
   by (auto simp: fds_converges_def dest: summable_mult2[of _ c])
 
 lemma fds_abs_converges_mult_const_right [intro]:
   "fds_abs_converges f s \<Longrightarrow> fds_abs_converges (f * fds_const c) s"
   by (auto simp: fds_abs_converges_def norm_mult norm_divide dest: summable_mult2[of _ "norm c"])
 
 lemma conv_abscissa_mult_const_right:
   "conv_abscissa (f * fds_const c) \<le> conv_abscissa f"
   by (intro conv_abscissa_mono) auto
 
 lemma abs_conv_abscissa_mult_const_right:
   "abs_conv_abscissa (f * fds_const c) \<le> abs_conv_abscissa f"
   by (intro abs_conv_abscissa_mono) auto
 
 
 lemma bounded_coeffs_imp_fds_abs_converges:
   fixes s :: "'a :: dirichlet_series" and f :: "'a fds"
   assumes "Bseq (fds_nth f)" "s \<bullet> 1 > 1"
   shows   "fds_abs_converges f s"
 proof -
   from assms obtain C where C: "\<And>n. norm (fds_nth f n) \<le> C"
     by (auto simp: Bseq_def)
   show ?thesis
   proof (rule fds_abs_converges_comparison_test)
     from \<open>s \<bullet> 1 > 1\<close> show "fds_converges (C *\<^sub>R fds_zeta) (s \<bullet> 1)"
       by (intro fds_abs_converges_imp_converges) auto
     from C show "eventually (\<lambda>n. norm (fds_nth f n) \<le> fds_nth (C *\<^sub>R fds_zeta) n) at_top"
       by (intro always_eventually) (auto simp: fds_nth_zeta)
   qed
 qed
 
 lemma bounded_coeffs_imp_fds_abs_converges':
   fixes s :: "'a :: dirichlet_series" and f :: "'a fds"
   assumes "Bseq (\<lambda>n. fds_nth f n * nat_power n s0)" "s \<bullet> 1 > 1 - s0 \<bullet> 1"
   shows   "fds_abs_converges f s"
 proof -
   have "fds_nth (fds_shift s0 f) = (\<lambda>n. fds_nth f n * nat_power n s0)"
     by (auto simp: fun_eq_iff)
   with assms have "Bseq (fds_nth (fds_shift s0 f))" by simp
   with assms(2) have "fds_abs_converges (fds_shift s0 f) (s + s0)"
     by (intro bounded_coeffs_imp_fds_abs_converges) (auto simp: algebra_simps)
   thus ?thesis by simp
 qed
 
 lemma bounded_coeffs_imp_abs_conv_abscissa_le:
   fixes s :: "'a :: dirichlet_series" and f :: "'a fds" and c :: ereal
   assumes "Bseq (\<lambda>n. fds_nth f n * nat_power n s)" "1 - s \<bullet> 1 \<le> c"
   shows   "abs_conv_abscissa f \<le> c"
 proof (rule abs_conv_abscissa_leI_weak)
   fix x assume "c < ereal x"
   have "ereal (1 - s \<bullet> 1) \<le> c" by fact
   also have "\<dots> < ereal x" by fact
   finally have "1 - s \<bullet> 1 < ereal x" by simp
   thus "fds_abs_converges f (of_real x)"
     by (intro bounded_coeffs_imp_fds_abs_converges'[OF assms(1)]) auto
 qed
 
 lemma bounded_coeffs_imp_abs_conv_abscissa_le_1:
   fixes s :: "'a :: dirichlet_series" and f :: "'a fds"
   assumes "Bseq (\<lambda>n. fds_nth f n)"
   shows   "abs_conv_abscissa f \<le> 1"
 proof -
   have [simp]: "fds_nth f n * nat_power n 0 = fds_nth f n" for n
     by (cases "n = 0") auto
   show ?thesis
     by (rule bounded_coeffs_imp_abs_conv_abscissa_le[where s = 0]) (insert assms, auto simp:)
 qed
 
 (* TODO: replace library version *)
 (* EXAMPLE: This might make a good example to illustrate real_asymp *)
 lemma
   fixes a b c :: real
   assumes ab: "a + b > 0" and c: "c < -1"
   shows set_integrable_powr_at_top: "(\<lambda>x. (b + x) powr c) absolutely_integrable_on {a<..}"
   and   set_lebesgue_integral_powr_at_top:
           "(\<integral>x\<in>{a<..}. ((b + x) powr c) \<partial>lborel) = -((b + a) powr (c + 1) / (c + 1))"
   and   powr_has_integral_at_top:
           "((\<lambda>x. (b + x) powr c) has_integral -((b + a) powr (c + 1) / (c + 1))) {a<..}"
 proof -
   let ?f = "\<lambda>x. (b + x) powr c" and ?F = "\<lambda>x. (b + x) powr (c + 1) / (c + 1)"
   have limits: "((?F \<circ> real_of_ereal) \<longlongrightarrow> ?F a) (at_right (ereal a))"
                "((?F \<circ> real_of_ereal) \<longlongrightarrow> 0) (at_left \<infinity>)"
     using c ab unfolding ereal_tendsto_simps1 by (real_asymp simp: field_simps)+
   have 1: "set_integrable lborel (einterval a \<infinity>) ?f" using ab c limits
     by (intro interval_integral_FTC_nonneg) (auto intro!: derivative_eq_intros)
   thus 2: "?f absolutely_integrable_on {a<..}"
     by (auto simp: set_integrable_def integrable_completion)
   have "LBINT x=ereal a..\<infinity>. (b + x) powr c = 0 - ?F a" using ab c limits
     by (intro interval_integral_FTC_nonneg) (auto intro!: derivative_eq_intros)
   thus 3: "(\<integral>x\<in>{a<..}. ((b + x) powr c) \<partial>lborel) = -((b + a) powr (c + 1) / (c + 1))"
     by (simp add: interval_integral_to_infinity_eq)
   show "(?f has_integral -((b + a) powr (c + 1) / (c + 1))) {a<..}"
     using set_borel_integral_eq_integral[OF 1] 3 by (simp add: has_integral_iff)
 qed
 
 lemma fds_converges_altdef2:
   "fds_converges f s \<longleftrightarrow> convergent (\<lambda>N. eval_fds (fds_truncate N f) s)"
   unfolding fds_converges_def summable_iff_convergent' eval_fds_truncate
   by (auto simp: not_le intro!: convergent_cong always_eventually sum.mono_neutral_right)
 
 lemma tendsto_eval_fds_truncate:
   assumes "fds_converges f s"
   shows   "(\<lambda>N. eval_fds (fds_truncate N f) s) \<longlonglongrightarrow> eval_fds f s"
 proof -
   have "(\<lambda>N. eval_fds (fds_truncate N f) s) \<longlonglongrightarrow> eval_fds f s \<longleftrightarrow>
           (\<lambda>N. \<Sum>i\<le>N. fds_nth f i / nat_power i s) \<longlonglongrightarrow> eval_fds f s"
     unfolding eval_fds_truncate
     by (intro filterlim_cong always_eventually allI sum.mono_neutral_left) (auto simp: not_le)
   also have \<dots> using assms
     by (simp add: fds_converges_iff sums_def' atLeast0AtMost)
   finally show ?thesis .
 qed
 
 lemma linepath_translate_left: "linepath (c + a) (c + a) = (\<lambda>x. c + a) \<circ> linepath a b"
   by (auto simp: fun_eq_iff linepath_def algebra_simps)
 
 lemma linepath_translate_right: "linepath (a + c) (b + c) = (\<lambda>x. x + c) \<circ> linepath a b"
   by (auto simp: fun_eq_iff linepath_def algebra_simps)
 
 lemma integrable_on_affinity:
   assumes "m \<noteq> 0" "f integrable_on (cbox a b)"
   shows   "(\<lambda>x. f (m *\<^sub>R x + c)) integrable_on ((\<lambda>x. (1 / m) *\<^sub>R x - ((1 / m) *\<^sub>R c)) ` cbox a b)"
 proof -
   from assms obtain I where "(f has_integral I) (cbox a b)"
     by (auto simp: integrable_on_def)
   from has_integral_affinity[OF this assms(1), of c] show ?thesis
     by (auto simp: integrable_on_def)
 qed
 
 lemma has_integral_cmul_iff:
   assumes "c \<noteq> 0"
   shows   "((\<lambda>x. c *\<^sub>R f x) has_integral (c *\<^sub>R I)) A \<longleftrightarrow> (f has_integral I) A"
   using assms has_integral_cmul[of f I A c]
         has_integral_cmul[of "\<lambda>x. c *\<^sub>R f x" "c *\<^sub>R I" A "inverse c"] by (auto simp: field_simps)
 
 lemma has_integral_affinity':
   fixes a :: "'a::euclidean_space"
   assumes "(f has_integral i) (cbox a b)" and "m > 0"
   shows "((\<lambda>x. f(m *\<^sub>R x + c)) has_integral (i /\<^sub>R m ^ DIM('a)))
            (cbox ((a - c) /\<^sub>R m) ((b - c) /\<^sub>R m))"
 proof (cases "cbox a b = {}")
   case True
   hence "(cbox ((a - c) /\<^sub>R m) ((b - c) /\<^sub>R m)) = {}"
     using \<open>m > 0\<close> unfolding box_eq_empty by (auto simp: algebra_simps)
   with True and assms show ?thesis by simp
 next
   case False
   have "((\<lambda>x. f (m *\<^sub>R x + c)) has_integral (1 / \<bar>m\<bar> ^ DIM('a)) *\<^sub>R i)
           ((\<lambda>x. (1 / m) *\<^sub>R x + - ((1 / m) *\<^sub>R c)) ` cbox a b)"
     using assms by (intro has_integral_affinity) auto
   also have "((\<lambda>x. (1 / m) *\<^sub>R x + - ((1 / m) *\<^sub>R c)) ` cbox a b) =
                ((\<lambda>x.  - ((1 / m) *\<^sub>R c) + x) ` (\<lambda>x. (1 / m) *\<^sub>R x) ` cbox a b)"
     by (simp add: image_image algebra_simps)
   also have "(\<lambda>x. (1 / m) *\<^sub>R x) ` cbox a b = cbox ((1 / m) *\<^sub>R a) ((1 / m) *\<^sub>R b)" using \<open>m > 0\<close> False
     by (subst image_smult_cbox) simp_all
   also have "(\<lambda>x. - ((1 / m) *\<^sub>R c) + x) ` \<dots> = cbox ((a - c) /\<^sub>R m) ((b - c) /\<^sub>R m)"
     by (subst cbox_translation [symmetric]) (simp add: field_simps vector_add_divide_simps)
   finally show ?thesis using \<open>m > 0\<close> by (simp add: field_simps)
 qed
 
 lemma has_integral_affinity_iff:
   fixes f :: "'a :: euclidean_space \<Rightarrow> 'b :: real_normed_vector"
   assumes "m > 0"
   shows   "((\<lambda>x. f (m *\<^sub>R x + c)) has_integral (I /\<^sub>R m ^ DIM('a)))
                (cbox ((a - c) /\<^sub>R m) ((b - c) /\<^sub>R m)) \<longleftrightarrow>
            (f has_integral I) (cbox a b)" (is "?lhs = ?rhs")
 proof
   assume ?lhs
   from has_integral_affinity'[OF this, of "1 / m" "-c /\<^sub>R m"] and \<open>m > 0\<close>
     show ?rhs by (simp add: vector_add_divide_simps) (simp add: field_simps)
 next
   assume ?rhs
   from has_integral_affinity'[OF this, of m c] and \<open>m > 0\<close>
   show ?lhs by simp
 qed
 
 lemma has_contour_integral_linepath_Reals_iff:
   fixes a b :: complex and f :: "complex \<Rightarrow> complex"
   assumes "a \<in> Reals" "b \<in> Reals" "Re a < Re b"
   shows   "(f has_contour_integral I) (linepath a b) \<longleftrightarrow>
              ((\<lambda>x. f (of_real x)) has_integral I) {Re a..Re b}"
 proof -
   from assms have [simp]: "of_real (Re a) = a" "of_real (Re b) = b"
     by (simp_all add: complex_eq_iff)
   from assms have "a \<noteq> b" by auto
   have "((\<lambda>x. f (of_real x)) has_integral I) (cbox (Re a) (Re b)) \<longleftrightarrow>
           ((\<lambda>x. f (a + b * of_real x - a * of_real x)) has_integral I /\<^sub>R (Re b - Re a)) {0..1}"
     by (subst has_integral_affinity_iff [of "Re b - Re a" _ "Re a", symmetric])
        (insert assms, simp_all add: field_simps scaleR_conv_of_real)
   also have "(\<lambda>x. f (a + b * of_real x - a * of_real x)) =
                (\<lambda>x. (f (a + b * of_real x - a * of_real x) * (b - a)) /\<^sub>R (Re b - Re a))"
     using \<open>a \<noteq> b\<close> by (auto simp: field_simps fun_eq_iff scaleR_conv_of_real)
   also have "(\<dots> has_integral I /\<^sub>R (Re b - Re a)) {0..1} \<longleftrightarrow>
                ((\<lambda>x. f (linepath a b x) * (b - a)) has_integral I) {0..1}" using assms
     by (subst has_integral_cmul_iff) (auto simp: linepath_def scaleR_conv_of_real algebra_simps)
   also have "\<dots> \<longleftrightarrow> (f has_contour_integral I) (linepath a b)" unfolding has_contour_integral_def
     by (intro has_integral_cong) (simp add: vector_derivative_linepath_within)
   finally show ?thesis by simp
 qed
 
 lemma contour_integrable_linepath_Reals_iff:
   fixes a b :: complex and f :: "complex \<Rightarrow> complex"
   assumes "a \<in> Reals" "b \<in> Reals" "Re a < Re b"
   shows   "(f contour_integrable_on linepath a b) \<longleftrightarrow>
              (\<lambda>x. f (of_real x)) integrable_on {Re a..Re b}"
   using has_contour_integral_linepath_Reals_iff[OF assms, of f]
   by (auto simp: contour_integrable_on_def integrable_on_def)
 
 lemma contour_integral_linepath_Reals_eq:
   fixes a b :: complex and f :: "complex \<Rightarrow> complex"
   assumes "a \<in> Reals" "b \<in> Reals" "Re a < Re b"
   shows   "contour_integral (linepath a b) f = integral {Re a..Re b} (\<lambda>x. f (of_real x))"
 proof (cases "f contour_integrable_on linepath a b")
   case True
   thus ?thesis using has_contour_integral_linepath_Reals_iff[OF assms, of f]
     using has_contour_integral_integral has_contour_integral_unique by blast
 next
   case False
   thus ?thesis using contour_integrable_linepath_Reals_iff[OF assms, of f]
     by (simp add: not_integrable_contour_integral not_integrable_integral)
 qed
 
 lemma has_contour_integral_linepath_same_Im_iff:
   fixes a b :: complex and f :: "complex \<Rightarrow> complex"
   assumes "Im a = Im b" "Re a < Re b"
   shows   "(f has_contour_integral I) (linepath a b) \<longleftrightarrow>
              ((\<lambda>x. f (of_real x + Im a * \<i>)) has_integral I) {Re a..Re b}"
 proof -
   have deriv: "vector_derivative ((\<lambda>x. x - Im a * \<i>) \<circ> linepath a b) (at y) = b - a" for y
     using linepath_translate_right[of a "-Im a * \<i>" b, symmetric] by simp
   have "(f has_contour_integral I) (linepath a b) \<longleftrightarrow>
           ((\<lambda>x. f (x + Im a * \<i>)) has_contour_integral I) (linepath (a - Im a * \<i>) (b - Im a * \<i>))"
     using linepath_translate_right[of a "-Im a * \<i>" b] deriv by (simp add: has_contour_integral)
   also have "\<dots> \<longleftrightarrow> ((\<lambda>x. f (x + Im a * \<i>)) has_integral I) {Re a..Re b}" using assms
     by (subst has_contour_integral_linepath_Reals_iff) (auto simp: complex_is_Real_iff)
   finally show ?thesis .
 qed
 
 lemma contour_integrable_linepath_same_Im_iff:
   fixes a b :: complex and f :: "complex \<Rightarrow> complex"
   assumes "Im a = Im b" "Re a < Re b"
   shows   "(f contour_integrable_on linepath a b) \<longleftrightarrow>
              (\<lambda>x. f (of_real x + Im a * \<i>)) integrable_on {Re a..Re b}"
   using has_contour_integral_linepath_same_Im_iff[OF assms, of f]
   by (auto simp: contour_integrable_on_def integrable_on_def)
 
 lemma contour_integral_linepath_same_Im:
   fixes a b :: complex and f :: "complex \<Rightarrow> complex"
   assumes "Im a = Im b" "Re a < Re b"
   shows   "contour_integral (linepath a b) f = integral {Re a..Re b} (\<lambda>x. f (x + Im a * \<i>))"
 proof (cases "f contour_integrable_on linepath a b")
   case True
   thus ?thesis using has_contour_integral_linepath_same_Im_iff[OF assms, of f]
     using has_contour_integral_integral has_contour_integral_unique by blast
 next
   case False
   thus ?thesis using contour_integrable_linepath_same_Im_iff[OF assms, of f]
     by (simp add: not_integrable_contour_integral not_integrable_integral)
 qed
 
 
 lemmas [simp del] = div_mult_self3 div_mult_self4 div_mult_self2 div_mult_self1
 
 lemma continuous_on_compact_bound:
   assumes "compact A" "continuous_on A f"
   obtains B where "B \<ge> 0" "\<And>x. x \<in> A \<Longrightarrow> norm (f x) \<le> B"
 proof -
   from assms(2,1) have "compact (f ` A)" by (rule compact_continuous_image)
   then obtain B where "\<forall>x\<in>A. norm (f x) \<le> B"
     by (auto dest!: compact_imp_bounded simp: bounded_iff)
   hence "max B 0 \<ge> 0" and "\<forall>x\<in>A. norm (f x) \<le> max B 0" by auto
   thus ?thesis using that by blast
 qed
 
 interpretation cis: periodic_fun_simple cis "2 * pi"
   by standard (simp_all add: complex_eq_iff)
 
 lemma open_contains_cbox:
   fixes x :: "'a :: euclidean_space"
   assumes "open A" "x \<in> A"
   obtains a b where "cbox a b \<subseteq> A" "x \<in> box a b" "\<forall>i\<in>Basis. a \<bullet> i < b \<bullet> i"
 proof -
   from assms obtain R where R: "R > 0" "ball x R \<subseteq> A"
     by (auto simp: open_contains_ball)
   define r :: real where "r = R / (2 * sqrt DIM('a))"
   from \<open>R > 0\<close> have [simp]: "r > 0" by (auto simp: r_def)
   define d :: 'a where "d = r *\<^sub>R Topology_Euclidean_Space.One"
   have "cbox (x - d) (x + d) \<subseteq> A"
   proof safe
     fix y assume y: "y \<in> cbox (x - d) (x + d)"
     have "dist x y = sqrt (\<Sum>i\<in>Basis. (dist (x \<bullet> i) (y \<bullet> i))\<^sup>2)"
       by (subst euclidean_dist_l2) (auto simp: L2_set_def)
     also from y have "sqrt (\<Sum>i\<in>Basis. (dist (x \<bullet> i) (y \<bullet> i))\<^sup>2) \<le> sqrt (\<Sum>i\<in>(Basis::'a set). r\<^sup>2)"
       by (intro real_sqrt_le_mono sum_mono power_mono)
          (auto simp: dist_norm d_def cbox_def algebra_simps)
     also have "\<dots> = sqrt (DIM('a) * r\<^sup>2)" by simp
     also have "DIM('a) * r\<^sup>2 = (R / 2) ^ 2"
       by (simp add: r_def power_divide)
     also have "sqrt \<dots> = R / 2"
       using \<open>R > 0\<close> by simp
     also from \<open>R > 0\<close> have "\<dots> < R" by simp
     finally have "y \<in> ball x R" by simp
     with R show "y \<in> A" by blast
   qed
   thus ?thesis
     using that[of "x - d" "x + d"] by (auto simp: algebra_simps d_def box_def)
 qed
 
 lemma open_contains_box:
   fixes x :: "'a :: euclidean_space"
   assumes "open A" "x \<in> A"
   obtains a b where "box a b \<subseteq> A" "x \<in> box a b" "\<forall>i\<in>Basis. a \<bullet> i < b \<bullet> i"
 proof -
-  from open_contains_cbox[OF assms] guess a b .
+  from assms obtain a b where "cbox a b \<subseteq> A" "x \<in> box a b" "\<forall>i\<in>Basis. a \<bullet> i < b \<bullet> i"
+    by (rule open_contains_cbox)
   with that[of a b] box_subset_cbox[of a b] show ?thesis by auto
 qed
 
 lemma analytic_onE_box:
   assumes "f analytic_on A" "s \<in> A"
   obtains a b where "Re a < Re b" "Im a < Im b" "s \<in> box a b" "f analytic_on box a b"
 proof -
   from assms obtain r where r: "r > 0" "f holomorphic_on ball s r"
     by (auto simp: analytic_on_def)
   with open_contains_box[of "ball s r" s] obtain a b
     where "box a b \<subseteq> ball s r" "s \<in> box a b" "\<forall>i\<in>Basis. a \<bullet> i < b \<bullet> i" by auto
   moreover from r have "f analytic_on ball s r" by (simp add: analytic_on_open)
   ultimately show ?thesis using that[of a b] analytic_on_subset[of _ "ball s r" "box a b"]
     by (auto simp: Basis_complex_def)
 qed
 
 lemma inner_image_box:
   assumes "(i :: 'a :: euclidean_space) \<in> Basis"
   assumes "\<forall>i\<in>Basis. a \<bullet> i < b \<bullet> i"
   shows   "(\<lambda>x. x \<bullet> i) ` box a b = {a \<bullet> i<..<b \<bullet> i}"
 proof safe
   fix x assume x: "x \<in> {a \<bullet> i<..<b \<bullet> i}"
   let ?y = "(\<Sum>j\<in>Basis. (if i = j then x else (a + b) \<bullet> j / 2) *\<^sub>R j)"
   from x assms have "?y \<bullet> i \<in> (\<lambda>x. x \<bullet> i) ` box a b"
     by (intro imageI) (auto simp: box_def algebra_simps)
   also have "?y \<bullet> i = (\<Sum>j\<in>Basis. (if i = j then x else (a + b) \<bullet> j / 2) * (j \<bullet> i))"
     by (simp add: inner_sum_left)
   also have "\<dots> = (\<Sum>j\<in>Basis. if i = j then x else 0)"
     by (intro sum.cong) (auto simp: inner_not_same_Basis assms)
   also have "\<dots> = x" using assms by simp
   finally show "x \<in> (\<lambda>x. x \<bullet> i) ` box a b"  .
 qed (insert assms, auto simp: box_def)
 
 lemma Re_image_box:
   assumes "Re a < Re b" "Im a < Im b"
   shows   "Re ` box a b = {Re a<..<Re b}"
   using inner_image_box[of "1::complex" a b] assms by (auto simp: Basis_complex_def)
 
 lemma Im_image_box:
   assumes "Re a < Re b" "Im a < Im b"
   shows   "Im ` box a b = {Im a<..<Im b}"
   using inner_image_box[of "\<i>::complex" a b] assms by (auto simp: Basis_complex_def)
 
 lemma inner_image_cbox:
   assumes "(i :: 'a :: euclidean_space) \<in> Basis"
   assumes "\<forall>i\<in>Basis. a \<bullet> i \<le> b \<bullet> i"
   shows   "(\<lambda>x. x \<bullet> i) ` cbox a b = {a \<bullet> i..b \<bullet> i}"
 proof safe
   fix x assume x: "x \<in> {a \<bullet> i..b \<bullet> i}"
   let ?y = "(\<Sum>j\<in>Basis. (if i = j then x else a \<bullet> j) *\<^sub>R j)"
   from x assms have "?y \<bullet> i \<in> (\<lambda>x. x \<bullet> i) ` cbox a b"
     by (intro imageI) (auto simp: cbox_def)
   also have "?y \<bullet> i = (\<Sum>j\<in>Basis. (if i = j then x else a \<bullet> j) * (j \<bullet> i))"
     by (simp add: inner_sum_left)
   also have "\<dots> = (\<Sum>j\<in>Basis. if i = j then x else 0)"
     by (intro sum.cong) (auto simp: inner_not_same_Basis assms)
   also have "\<dots> = x" using assms by simp
   finally show "x \<in> (\<lambda>x. x \<bullet> i) ` cbox a b"  .
 qed (insert assms, auto simp: cbox_def)
 
 lemma Re_image_cbox:
   assumes "Re a \<le> Re b" "Im a \<le> Im b"
   shows   "Re ` cbox a b = {Re a..Re b}"
   using inner_image_cbox[of "1::complex" a b] assms by (auto simp: Basis_complex_def)
 
 lemma Im_image_cbox:
   assumes "Re a \<le> Re b" "Im a \<le> Im b"
   shows   "Im ` cbox a b = {Im a..Im b}"
   using inner_image_cbox[of "\<i>::complex" a b] assms by (auto simp: Basis_complex_def)
 
 lemma analytic_onE_cball:
   assumes "f analytic_on A" "s \<in> A" "ub > (0::real)"
   obtains R where "R > 0" "R < ub" "f analytic_on cball s R"
 proof -
   from assms obtain r where "r > 0" "f holomorphic_on ball s r"
     by (auto simp: analytic_on_def)
   hence "f analytic_on ball s r" by (simp add: analytic_on_open)
   hence "f analytic_on cball s (min (ub / 2) (r / 2))"
     by (rule analytic_on_subset, subst cball_subset_ball_iff) (use \<open>r > 0\<close> in auto)
   moreover have "min (ub / 2) (r / 2) > 0" and "min (ub / 2) (r / 2) < ub"
     using \<open>r > 0\<close> and \<open>ub > 0\<close> by (auto simp: min_def)
   ultimately show ?thesis using that[of "min (ub / 2) (r / 2)"]
     by blast
 qed
 
 
 corollary analytic_pre_zeta' [analytic_intros]:
   assumes "f analytic_on A" "a > 0"
   shows   "(\<lambda>x. pre_zeta a (f x)) analytic_on A"
   using analytic_on_compose_gen[OF assms(1) analytic_pre_zeta[of a UNIV]] assms(2)
   by (auto simp: o_def)
 
 corollary analytic_hurwitz_zeta' [analytic_intros]:
   assumes "f analytic_on A" "(\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> 1)" "a > 0"
   shows   "(\<lambda>x. hurwitz_zeta a (f x)) analytic_on A"
   using analytic_on_compose_gen[OF assms(1) analytic_hurwitz_zeta[of a "-{1}"]] assms(2,3)
   by (auto simp: o_def)
 
 corollary analytic_zeta' [analytic_intros]:
   assumes "f analytic_on A" "(\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> 1)"
   shows   "(\<lambda>x. zeta (f x)) analytic_on A"
   using analytic_on_compose_gen[OF assms(1) analytic_zeta[of "-{1}"]] assms(2)
   by (auto simp: o_def)
 
 
 lemma logderiv_zeta_analytic: "(\<lambda>s. deriv zeta s / zeta s) analytic_on {s. Re s \<ge> 1} - {1}"
   using zeta_Re_ge_1_nonzero by (auto intro!: analytic_intros)
 
 lemma cis_pi_half [simp]: "cis (pi / 2) = \<i>"
   by (simp add: complex_eq_iff)
 
 lemma mult_real_sqrt: "x \<ge> 0 \<Longrightarrow> x * sqrt y = sqrt (x ^ 2 * y)"
   by (simp add: real_sqrt_mult)
 
 lemma arcsin_pos: "x \<in> {0<..1} \<Longrightarrow> arcsin x > 0"
   using arcsin_less_arcsin[of 0 x] by simp
 
 lemmas analytic_imp_holomorphic' = holomorphic_on_subset[OF analytic_imp_holomorphic]
 
 lemma residue_simple':
   assumes "open s" "0 \<in> s" "f holomorphic_on s"
   shows   "residue (\<lambda>w. f w / w) 0 = f 0"
   using residue_simple[of s 0 f] assms by simp
 
 
 lemma fds_converges_cong:
   assumes "eventually (\<lambda>n. fds_nth f n = fds_nth g n) at_top" "s = s'"
   shows   "fds_converges f s \<longleftrightarrow> fds_converges g s'"
   unfolding fds_converges_def
   by (intro summable_cong eventually_mono[OF assms(1)]) (simp_all add: assms)
 
 lemma fds_abs_converges_cong:
   assumes "eventually (\<lambda>n. fds_nth f n = fds_nth g n) at_top" "s = s'"
   shows   "fds_abs_converges f s \<longleftrightarrow> fds_abs_converges g s'"
   unfolding fds_abs_converges_def
   by (intro summable_cong eventually_mono[OF assms(1)]) (simp_all add: assms)
 
 lemma conv_abscissa_cong:
   assumes "eventually (\<lambda>n. fds_nth f n = fds_nth g n) at_top"
   shows   "conv_abscissa f = conv_abscissa g"
 proof -
   have "fds_converges f = fds_converges g"
     by (intro ext fds_converges_cong assms refl)
   thus ?thesis by (simp add: conv_abscissa_def)
 qed
 
 lemma abs_conv_abscissa_cong:
   assumes "eventually (\<lambda>n. fds_nth f n = fds_nth g n) at_top"
   shows   "abs_conv_abscissa f = abs_conv_abscissa g"
 proof -
   have "fds_abs_converges f = fds_abs_converges g"
     by (intro ext fds_abs_converges_cong assms refl)
   thus ?thesis by (simp add: abs_conv_abscissa_def)
 qed
 
 
 definition fds_remainder where
   "fds_remainder m = fds_subseries (\<lambda>n. n > m)"
 
 lemma fds_nth_remainder: "fds_nth (fds_remainder m f) = (\<lambda>n. if n > m then fds_nth f n else 0)"
   by (simp add: fds_remainder_def fds_subseries_def fds_nth_fds')
 
 lemma fds_converges_remainder_iff [simp]:
   "fds_converges (fds_remainder m f) s \<longleftrightarrow> fds_converges f s"
   by (intro fds_converges_cong eventually_mono[OF eventually_gt_at_top[of m]])
      (auto simp: fds_nth_remainder)
 
 lemma fds_abs_converges_remainder_iff [simp]:
   "fds_abs_converges (fds_remainder m f) s \<longleftrightarrow> fds_abs_converges f s"
   by (intro fds_abs_converges_cong eventually_mono[OF eventually_gt_at_top[of m]])
      (auto simp: fds_nth_remainder)
 
 lemma fds_converges_remainder [intro]:
         "fds_converges f s \<Longrightarrow> fds_converges (fds_remainder m f) s"
   and fds_abs_converges_remainder [intro]:
         "fds_abs_converges f s \<Longrightarrow> fds_abs_converges (fds_remainder m f) s"
   by simp_all
 
 lemma conv_abscissa_remainder [simp]:
   "conv_abscissa (fds_remainder m f) = conv_abscissa f"
   by (intro conv_abscissa_cong eventually_mono[OF eventually_gt_at_top[of m]])
      (auto simp: fds_nth_remainder)
 
 lemma abs_conv_abscissa_remainder [simp]:
   "abs_conv_abscissa (fds_remainder m f) = abs_conv_abscissa f"
   by (intro abs_conv_abscissa_cong eventually_mono[OF eventually_gt_at_top[of m]])
      (auto simp: fds_nth_remainder)
 
 lemma eval_fds_remainder:
    "eval_fds (fds_remainder m f) s = (\<Sum>n. fds_nth f (n + Suc m) / nat_power (n + Suc m) s)"
     (is "_ = suminf (\<lambda>n. ?f (n + Suc m))")
 proof (cases "fds_converges f s")
   case False
   hence "\<not>fds_converges (fds_remainder m f) s" by simp
   hence "(\<lambda>x. (\<lambda>n. fds_nth (fds_remainder m f) n / nat_power n s) sums x) = (\<lambda>_. False)"
     by (auto simp: fds_converges_def summable_def)
   hence "eval_fds (fds_remainder m f) s = (THE _. False)"
     by (simp add: eval_fds_def suminf_def)
   moreover from False have "\<not>summable (\<lambda>n. ?f (n + Suc m))" unfolding fds_converges_def
     by (subst summable_iff_shift) auto
   hence "(\<lambda>x. (\<lambda>n. ?f (n + Suc m)) sums x) = (\<lambda>_. False)"
     by (auto simp: summable_def)
   hence "suminf (\<lambda>n. ?f (n + Suc m)) = (THE _. False)"
     by (simp add: suminf_def)
   ultimately show ?thesis by simp
 next
   case True
   hence *: "fds_converges (fds_remainder m f) s" by simp
   have "eval_fds (fds_remainder m f) s = (\<Sum>n. fds_nth (fds_remainder m f) n / nat_power n s)"
     unfolding eval_fds_def ..
   also have "\<dots> = (\<Sum>n. fds_nth (fds_remainder m f) (n + Suc m) / nat_power (n + Suc m) s)"
     using * unfolding fds_converges_def
     by (subst suminf_minus_initial_segment) (auto simp: fds_nth_remainder)
   also have "(\<lambda>n. fds_nth (fds_remainder m f) (n + Suc m)) = (\<lambda>n. fds_nth f (n + Suc m))"
     by (intro ext) (auto simp: fds_nth_remainder)
   finally show ?thesis .
 qed
 
 lemma fds_truncate_plus_remainder: "fds_truncate m f + fds_remainder m f = f"
   by (intro fds_eqI) (auto simp: fds_truncate_def fds_remainder_def fds_subseries_def)
 
 
 lemma holomorphic_fds_eval' [holomorphic_intros]:
   assumes "g holomorphic_on A" "\<And>x. x \<in> A \<Longrightarrow> Re (g x) > conv_abscissa f"
   shows   "(\<lambda>x. eval_fds f (g x)) holomorphic_on A"
   using holomorphic_on_compose_gen[OF assms(1) holomorphic_fds_eval[OF order.refl, of f]] assms(2)
   by (auto simp: o_def)
 
 lemma analytic_fds_eval' [analytic_intros]:
   assumes "g analytic_on A" "\<And>x. x \<in> A \<Longrightarrow> Re (g x) > conv_abscissa f"
   shows   "(\<lambda>x. eval_fds f (g x)) analytic_on A"
   using analytic_on_compose_gen[OF assms(1) analytic_fds_eval[OF order.refl, of f]] assms(2)
   by (auto simp: o_def)
 
 lemma homotopic_loopsI:
   fixes h :: "real \<times> real \<Rightarrow> _"
   assumes "continuous_on ({0..1} \<times> {0..1}) h"
           "h ` ({0..1} \<times> {0..1}) \<subseteq> s"
           "\<And>x. x \<in> {0..1} \<Longrightarrow> h (0, x) = p x"
           "\<And>x. x \<in> {0..1} \<Longrightarrow> h (1, x) = q x"
           "\<And>x. x \<in> {0..1} \<Longrightarrow> pathfinish (h \<circ> Pair x) = pathstart (h \<circ> Pair x)"
   shows   "homotopic_loops s p q"
   using assms unfolding homotopic_loops by (intro exI[of _ h]) auto
 
 lemma continuous_on_linepath [continuous_intros]:
   assumes "continuous_on A a" "continuous_on A b" "continuous_on A f"
   shows   "continuous_on A (\<lambda>x. linepath (a x) (b x) (f x))"
   using assms by (auto simp: linepath_def intro!: continuous_intros assms)
 
 lemma continuous_on_part_circlepath [continuous_intros]:
   assumes "continuous_on A c" "continuous_on A r" "continuous_on A a" "continuous_on A b"
           "continuous_on A f"
   shows   "continuous_on A (\<lambda>x. part_circlepath (c x) (r x) (a x) (b x) (f x))"
   using assms by (auto simp: part_circlepath_def intro!: continuous_intros assms)
 
 lemma homotopic_loops_part_circlepath:
   assumes "sphere c r \<subseteq> A" and "r \<ge> 0" and
           "b1 = a1 + 2 * of_int k * pi" and "b2 = a2 + 2 * of_int k * pi"
   shows   "homotopic_loops A (part_circlepath c r a1 b1) (part_circlepath c r a2 b2)"
 proof -
   define h where "h = (\<lambda>(x,y). part_circlepath c r (linepath a1 a2 x) (linepath b1 b2 x) y)"
   show ?thesis
   proof (rule homotopic_loopsI)
     show "continuous_on ({0..1} \<times> {0..1}) h"
       by (auto simp: h_def case_prod_unfold intro!: continuous_intros)
   next
     from assms have "h ` ({0..1} \<times> {0..1}) \<subseteq> sphere c r"
       by (auto simp: h_def part_circlepath_def dist_norm norm_mult)
     also have "\<dots> \<subseteq> A" by fact
     finally show "h ` ({0..1} \<times> {0..1}) \<subseteq> A" .
   next
     fix x :: real assume x: "x \<in> {0..1}"
     show "h (0, x) = part_circlepath c r a1 b1 x" and "h (1, x) = part_circlepath c r a2 b2 x"
       by (simp_all add: h_def linepath_def)
     have "cis (pi * (real_of_int k * 2)) = 1"
       using cis.plus_of_int[of 0 k] by (simp add: algebra_simps)
     thus "pathfinish (h \<circ> Pair x) = pathstart (h \<circ> Pair x)"
       by (simp add: h_def o_def exp_eq_polar linepath_def algebra_simps
                     cis_mult [symmetric] cis_divide [symmetric] assms)
   qed
 qed
 
 lemma homotopic_pathsI:
   fixes h :: "real \<times> real \<Rightarrow> _"
   assumes "continuous_on ({0..1} \<times> {0..1}) h"
   assumes "h ` ({0..1} \<times> {0..1}) \<subseteq> s"
   assumes "\<And>x. x \<in> {0..1} \<Longrightarrow> h (0, x) = p x"
   assumes "\<And>x. x \<in> {0..1} \<Longrightarrow> h (1, x) = q x"
   assumes "\<And>x. x \<in> {0..1} \<Longrightarrow> pathstart (h \<circ> Pair x) = pathstart p"
   assumes "\<And>x. x \<in> {0..1} \<Longrightarrow> pathfinish (h \<circ> Pair x) = pathfinish p"
   shows   "homotopic_paths s p q"
   using assms unfolding homotopic_paths by (intro exI[of _ h]) auto
 
 lemma part_circlepath_conv_subpath:
   "part_circlepath c r a b = subpath (a / (2*pi)) (b / (2*pi)) (circlepath c r)"
   by (simp add: part_circlepath_def circlepath_def subpath_def linepath_def algebra_simps exp_eq_polar)
 
 lemma homotopic_paths_part_circlepath:
   assumes "a \<le> b" "b \<le> c"
   assumes "path_image (part_circlepath C r a c) \<subseteq> A" "r \<ge> 0"
   shows   "homotopic_paths A (part_circlepath C r a c)
              (part_circlepath C r a b +++ part_circlepath C r b c)"
   (is "homotopic_paths _ ?g (?h1 +++ ?h2)")
 proof (cases "a = c")
   case False
   with assms have "a < c" by simp
   define slope where "slope = (b - a) / (c - a)"
   from assms and \<open>a < c\<close> have slope: "slope \<in> {0..1}"
     by (auto simp: field_simps slope_def)
   define f :: "real \<Rightarrow> real" where
     "f = linepath 0 slope +++ linepath slope 1"
 
   show ?thesis
   proof (rule homotopic_paths_reparametrize)
     fix t :: real assume t: "t \<in> {0..1}"
     show "(?h1 +++ ?h2) t = ?g (f t)"
     proof (cases "t \<le> 1 / 2")
       case True
       hence "?g (f t) = C + r * cis ((1 - f t) * a + f t * c)"
         by (simp add: joinpaths_def part_circlepath_def exp_eq_polar linepath_def)
       also from True \<open>a < c\<close> have "(1 - f t) * a + f t * c = (1 - 2 * t) * a + 2 * t * b"
         unfolding f_def slope_def linepath_def joinpaths_def
         by (simp add: divide_simps del: div_mult_self3 div_mult_self4 div_mult_self2 div_mult_self1)
            (simp add: algebra_simps)?
       also from True have "C + r * cis \<dots> = (?h1 +++ ?h2) t"
         by (simp add: joinpaths_def part_circlepath_def exp_eq_polar linepath_def)
       finally show ?thesis ..
     next
       case False
       hence "?g (f t) = C + r * cis ((1 - f t) * a + f t * c)"
         by (simp add: joinpaths_def part_circlepath_def exp_eq_polar linepath_def)
       also from False \<open>a < c\<close> have "(1 - f t) * a + f t * c = (2 - 2 * t) * b + (2 * t - 1) * c"
         unfolding f_def slope_def linepath_def joinpaths_def
         by (simp add: divide_simps del: div_mult_self3 div_mult_self4 div_mult_self2 div_mult_self1)
            (simp add: algebra_simps)?
       also from False have "C + r * cis \<dots> = (?h1 +++ ?h2) t"
         by (simp add: joinpaths_def part_circlepath_def exp_eq_polar linepath_def)
       finally show ?thesis ..
     qed
   next
     from slope have "path_image f \<subseteq> {0..1}"
       by (auto simp: f_def path_image_join closed_segment_eq_real_ivl)
     thus "f ` {0..1} \<subseteq> {0..1}" by (simp add: path_image_def)
   next
     have "path f" unfolding f_def by auto
     thus "continuous_on {0..1} f" by (simp add: path_def)
   qed (insert assms, auto simp: f_def joinpaths_def linepath_def)
 next
   case [simp]: True
   with assms have [simp]: "b = c" by auto
   have "part_circlepath C r c c +++ part_circlepath C r c c = part_circlepath C r c c"
     by (simp add: fun_eq_iff joinpaths_def part_circlepath_def)
   thus ?thesis using assms by simp
 qed
 
 lemma has_contour_integral_mirror_iff:
   assumes "valid_path g"
   shows   "(f has_contour_integral I) (-g) \<longleftrightarrow> ((\<lambda>x. -f (- x)) has_contour_integral I) g"
 proof -
   from assms have "g piecewise_differentiable_on {0..1}"
     by (auto simp: valid_path_def piecewise_C1_imp_differentiable)
   then obtain S where S: "finite S" "\<And>x. x \<in> {0..1} - S \<Longrightarrow> g differentiable at x within {0..1}"
      unfolding piecewise_differentiable_on_def by blast
   have S': "g differentiable at x" if "x \<in> {0..1} - ({0, 1} \<union> S)" for x
   proof -
     from that have "x \<in> interior {0..1}" by auto
     with S(2)[of x] that show ?thesis by (auto simp: at_within_interior[of _ "{0..1}"])
   qed
 
   have "(f has_contour_integral I) (-g) \<longleftrightarrow>
           ((\<lambda>x. f (- g x) * vector_derivative (-g) (at x)) has_integral I) {0..1}"
     by (simp add: has_contour_integral)
   also have "\<dots> \<longleftrightarrow> ((\<lambda>x. -f (- g x) * vector_derivative g (at x)) has_integral I) {0..1}"
     by (intro has_integral_spike_finite_eq[of "S \<union> {0, 1}"])
        (insert \<open>finite S\<close> S', auto simp: o_def fun_Compl_def)
   also have "\<dots> \<longleftrightarrow> ((\<lambda>x. -f (-x)) has_contour_integral I) g"
     by (simp add: has_contour_integral)
   finally show ?thesis .
 qed
 
 lemma contour_integral_on_mirror_iff:
   assumes "valid_path g"
   shows   "f contour_integrable_on (-g) \<longleftrightarrow> (\<lambda>x. -f (- x)) contour_integrable_on g"
   by (auto simp: contour_integrable_on_def has_contour_integral_mirror_iff assms)
 
 lemma contour_integral_mirror:
   assumes "valid_path g"
   shows   "contour_integral (-g) f = contour_integral g (\<lambda>x. -f (- x))"
 proof (cases "f contour_integrable_on (-g)")
   case True
   then obtain I where I: "(f has_contour_integral I) (-g)"
     by (auto simp: contour_integrable_on_def)
   also note has_contour_integral_mirror_iff[OF assms]
   finally have "((\<lambda>x. - f (- x)) has_contour_integral I) g" .
   with I show ?thesis using contour_integral_unique by blast
 next
   case False
   hence "\<not>(\<lambda>x. -f (-x)) contour_integrable_on g"
     by (auto simp: contour_integral_on_mirror_iff assms)
   from False and this show ?thesis
     by (simp add: not_integrable_contour_integral)
 qed
 
 lemma contour_integrable_neg_iff:
   "(\<lambda>x. -f x) contour_integrable_on g \<longleftrightarrow> f contour_integrable_on g"
   using contour_integrable_neg[of f g] contour_integrable_neg[of "\<lambda>x. -f x" g] by auto
 
 lemma contour_integral_neg:
   shows "contour_integral g (\<lambda>x. -f x) = -contour_integral g f"
 proof (cases "f contour_integrable_on g")
   case True
   thus ?thesis by (simp add: contour_integral_neg)
 next
   case False
   hence "\<not>(\<lambda>x. -f x) contour_integrable_on g" by (simp add: contour_integrable_neg_iff)
   with False show ?thesis
     by (simp add: not_integrable_contour_integral)
 qed
 
 
 lemma minus_cis: "-cis x = cis (x + pi)"
   by (simp add: complex_eq_iff)
 
 lemma path_image_part_circlepath_subset:
   assumes "a \<le> a'" "a' \<le> b'" "b' \<le> b"
   shows   "path_image (part_circlepath c r a' b') \<subseteq> path_image (part_circlepath c r a b)"
   using assms by (subst (1 2) path_image_part_circlepath) auto
 
 lemma part_circlepath_mirror:
   assumes "a' = a + pi + 2 * pi * of_int k" "b' = b + pi + 2 * pi * of_int k" "c' = -c"
   shows   "-part_circlepath c r a b = part_circlepath c' r a' b'"
 proof
   fix x :: real
   have "part_circlepath c' r a' b' x = c' + r * cis (linepath a b x + pi + k * (2 * pi))"
     by (simp add: part_circlepath_def exp_eq_polar assms linepath_translate_right mult_ac)
   also have "cis (linepath a b x + pi + k * (2 * pi)) = cis (linepath a b x + pi)"
     by (rule cis.plus_of_int)
   also have "\<dots> = -cis (linepath a b x)"
     by (simp add: minus_cis)
   also have "c' + r * \<dots> = -part_circlepath c r a b x"
     by (simp add: part_circlepath_def assms exp_eq_polar)
   finally show "(- part_circlepath c r a b) x = part_circlepath c' r a' b' x"
     by simp
 qed
 
 lemma path_mirror [intro]: "path (g :: _ \<Rightarrow> 'b::topological_group_add) \<Longrightarrow> path (-g)"
   by (auto simp: path_def intro!: continuous_intros)
 
 lemma path_mirror_iff [simp]: "path (-g :: _ \<Rightarrow> 'b::topological_group_add) \<longleftrightarrow> path g"
   using path_mirror[of g] path_mirror[of "-g"] by (auto simp: fun_Compl_def)
 
 lemma valid_path_mirror [intro]: "valid_path g \<Longrightarrow> valid_path (-g)"
   by (auto simp: valid_path_def fun_Compl_def piecewise_C1_differentiable_neg)
 
 lemma valid_path_mirror_iff [simp]: "valid_path (-g) \<longleftrightarrow> valid_path g"
   using valid_path_mirror[of g] valid_path_mirror[of "-g"] by (auto simp: fun_Compl_def)
 
 lemma pathstart_mirror [simp]: "pathstart (-g) = -pathstart g"
   and pathfinish_mirror [simp]: "pathfinish (-g) = -pathfinish g"
   by (simp_all add: pathstart_def pathfinish_def)
 
 lemma path_image_mirror: "path_image (-g) = uminus ` path_image g"
   by (auto simp: path_image_def)
 
 lemma contour_integral_bound_part_circlepath:
   assumes "f contour_integrable_on part_circlepath c r a b"
   assumes "B \<ge> 0" "r \<ge> 0" "\<And>x. x \<in> path_image (part_circlepath c r a b) \<Longrightarrow> norm (f x) \<le> B"
   shows   "norm (contour_integral (part_circlepath c r a b) f) \<le> B * r * \<bar>b - a\<bar>"
 proof -
   let ?I = "integral {0..1} (\<lambda>x. f (part_circlepath c r a b x) * \<i> * of_real (r * (b - a)) *
               exp (\<i> * linepath a b x))"
   have "norm ?I \<le> integral {0..1} (\<lambda>x::real. B * 1 * (r * \<bar>b - a\<bar>) * 1)"
   proof (rule integral_norm_bound_integral, goal_cases)
     case 1
     with assms(1) show ?case
       by (simp add: contour_integrable_on vector_derivative_part_circlepath mult_ac)
   next
     case (3 x)
     with assms(2-) show ?case unfolding norm_mult norm_of_real abs_mult
       by (intro mult_mono) (auto simp: path_image_def)
   qed auto
   also have "?I = contour_integral (part_circlepath c r a b) f"
     by (simp add: contour_integral_integral vector_derivative_part_circlepath mult_ac)
   finally show ?thesis by simp
 qed
 
 lemma contour_integral_spike_finite_simple_path:
   assumes "finite A" "simple_path g" "g = g'" "\<And>x. x \<in> path_image g - A \<Longrightarrow> f x = f' x"
   shows   "contour_integral g f = contour_integral g' f'"
   unfolding contour_integral_integral
 proof (rule integral_spike)
   have "finite (g -` A \<inter> {0<..<1})" using \<open>simple_path g\<close> \<open>finite A\<close>
     by (intro finite_vimage_IntI simple_path_inj_on) auto
   hence "finite ({0, 1} \<union> g -` A \<inter> {0<..<1})" by auto
   thus "negligible ({0, 1} \<union> g -` A \<inter> {0<..<1})" by (rule negligible_finite)
 next
   fix x assume "x \<in> {0..1} - ({0, 1} \<union> g -` A \<inter> {0<..<1})"
   hence "g x \<in> path_image g - A" by (auto simp: path_image_def)
   from assms(4)[OF this] and assms(3)
     show "f' (g' x) * vector_derivative g' (at x) = f (g x) * vector_derivative g (at x)" by simp
   qed
 
 proposition contour_integral_bound_part_circlepath_strong:
   assumes fi: "f contour_integrable_on part_circlepath z r s t"
       and "finite k" and le: "0 \<le> B" "0 < r" "s \<le> t"
       and B: "\<And>x. x \<in> path_image(part_circlepath z r s t) - k \<Longrightarrow> norm(f x) \<le> B"
     shows "cmod (contour_integral (part_circlepath z r s t) f) \<le> B * r * (t - s)"
 proof -
   from fi have "(f has_contour_integral contour_integral (part_circlepath z r s t) f)
                   (part_circlepath z r s t)"
     by (rule has_contour_integral_integral)
   from has_contour_integral_bound_part_circlepath_strong[OF this assms(2-)] show ?thesis by auto
 qed
 
 lemma cos_le_zero:
   assumes "x \<in> {pi/2..3*pi/2}"
   shows   "cos x \<le> 0"
 proof -
   have "cos x = -cos (x - pi)" by (simp add: cos_diff)
   moreover from assms have "cos (x - pi) \<ge> 0"
     by (intro cos_ge_zero) auto
   ultimately show ?thesis by simp
 qed
 
 lemma cos_le_zero': "x \<in> {-3*pi/2..-pi/2} \<Longrightarrow> cos x \<le> 0"
   using cos_le_zero[of "-x"] by simp
 
 lemma cis_minus_pi_half [simp]: "cis (- (pi / 2)) = -\<i>"
   by (simp add: complex_eq_iff)
 
 lemma winding_number_join_pos_combined':
      "\<lbrakk>valid_path \<gamma>1 \<and> z \<notin> path_image \<gamma>1 \<and> 0 < Re (winding_number \<gamma>1 z);
        valid_path \<gamma>2 \<and> z \<notin> path_image \<gamma>2 \<and> 0 < Re (winding_number \<gamma>2 z);
        pathfinish \<gamma>1 = pathstart \<gamma>2\<rbrakk>
       \<Longrightarrow> valid_path(\<gamma>1 +++ \<gamma>2) \<and> z \<notin> path_image(\<gamma>1 +++ \<gamma>2) \<and> 0 < Re(winding_number(\<gamma>1 +++ \<gamma>2) z)"
   by (simp add: valid_path_join path_image_join winding_number_join valid_path_imp_path)
 
 lemma Union_atLeastAtMost_real_of_nat:
   assumes "a < b"
   shows   "(\<Union>n\<in>{a..<b}. {real n..real (n + 1)}) = {real a..real b}"
 proof (intro equalityI subsetI)
   fix x assume x: "x \<in> {real a..real b}"
   thus "x \<in> (\<Union>n\<in>{a..<b}. {real n..real (n + 1)})"
   proof (cases "x = real b")
     case True
     with assms show ?thesis by (auto intro!: bexI[of _ "b - 1"])
   next
     case False
     with x have x: "x \<ge> real a" "x < real b" by simp_all
     hence "x \<ge> real (nat \<lfloor>x\<rfloor>)" "x \<le> real (Suc (nat \<lfloor>x\<rfloor>))" by linarith+
     moreover from x have "nat \<lfloor>x\<rfloor> \<ge> a" "nat \<lfloor>x\<rfloor> < b" by linarith+
     ultimately have "\<exists>n\<in>{a..<b}. x \<in> {real n..real (n + 1)}"
       by (intro bexI[of _ "nat \<lfloor>x\<rfloor>"]) simp_all
     thus ?thesis by blast
   qed
 qed auto
 
 lemma nat_sum_has_integral_floor:
   fixes f :: "nat \<Rightarrow> 'a :: banach"
   assumes mn: "m < n"
   shows "((\<lambda>x. f (nat \<lfloor>x\<rfloor>)) has_integral sum f {m..<n}) {real m..real n}"
 proof -
   define D where "D = (\<lambda>i. {real i..real (Suc i)}) ` {m..<n}"
   have D: "D division_of {m..n}"
     using Union_atLeastAtMost_real_of_nat[OF mn] by (simp add: division_of_def D_def)
   have "((\<lambda>x. f (nat \<lfloor>x\<rfloor>)) has_integral (\<Sum>X\<in>D. f (nat \<lfloor>Inf X\<rfloor>))) {real m..real n}"
   proof (rule has_integral_combine_division)
     fix X assume X: "X \<in> D"
     have "nat \<lfloor>x\<rfloor> = nat \<lfloor>Inf X\<rfloor>" if "x \<in> X - {Sup X}" for x
       using that X by (auto simp: D_def nat_eq_iff floor_eq_iff)
     hence "((\<lambda>x. f (nat \<lfloor>x\<rfloor>)) has_integral f (nat \<lfloor>Inf X\<rfloor>)) X \<longleftrightarrow>
            ((\<lambda>x. f (nat \<lfloor>Inf X\<rfloor>)) has_integral f (nat \<lfloor>Inf X\<rfloor>)) X" using X
       by (intro has_integral_spike_eq[of "{Sup X}"]) auto
     also from X have "\<dots>" using has_integral_const_real[of "f (nat \<lfloor>Inf X\<rfloor>)" "Inf X" "Sup X"]
       by (auto simp: D_def)
     finally show "((\<lambda>x. f (nat \<lfloor>x\<rfloor>)) has_integral f (nat \<lfloor>Inf X\<rfloor>)) X" .
   qed fact+
   also have "(\<Sum>X\<in>D. f (nat \<lfloor>Inf X\<rfloor>)) = (\<Sum>k\<in>{m..<n}. f k)"
     unfolding D_def by (subst sum.reindex) (auto simp: inj_on_def nat_add_distrib)
   finally show ?thesis .
 qed
 
 lemma nat_sum_has_integral_ceiling:
   fixes f :: "nat \<Rightarrow> 'a :: banach"
   assumes mn: "m < n"
   shows "((\<lambda>x. f (nat \<lceil>x\<rceil>)) has_integral sum f {m<..n}) {real m..real n}"
 proof -
   define D where "D = (\<lambda>i. {real i..real (Suc i)}) ` {m..<n}"
   have D: "D division_of {m..n}"
     using Union_atLeastAtMost_real_of_nat[OF mn] by (simp add: division_of_def D_def)
   have "((\<lambda>x. f (nat \<lceil>x\<rceil>)) has_integral (\<Sum>X\<in>D. f (nat \<lfloor>Sup X\<rfloor>))) {real m..real n}"
   proof (rule has_integral_combine_division)
     fix X assume X: "X \<in> D"
     have "nat \<lceil>x\<rceil> = nat \<lfloor>Sup X\<rfloor>" if "x \<in> X - {Inf X}" for x
       using that X by (auto simp: D_def nat_eq_iff ceiling_eq_iff)
     hence "((\<lambda>x. f (nat \<lceil>x\<rceil>)) has_integral f (nat \<lfloor>Sup X\<rfloor>)) X \<longleftrightarrow>
            ((\<lambda>x. f (nat \<lfloor>Sup X\<rfloor>)) has_integral f (nat \<lfloor>Sup X\<rfloor>)) X" using X
       by (intro has_integral_spike_eq[of "{Inf X}"]) auto
     also from X have "\<dots>" using has_integral_const_real[of "f (nat \<lfloor>Sup X\<rfloor>)" "Inf X" "Sup X"]
       by (auto simp: D_def)
     finally show "((\<lambda>x. f (nat \<lceil>x\<rceil>)) has_integral f (nat \<lfloor>Sup X\<rfloor>)) X" .
   qed fact+
   also have "(\<Sum>X\<in>D. f (nat \<lfloor>Sup X\<rfloor>)) = (\<Sum>k\<in>{m..<n}. f (Suc k))"
     unfolding D_def by (subst sum.reindex) (auto simp: inj_on_def nat_add_distrib)
   also have "\<dots> = (\<Sum>k\<in>{m<..n}. f k)"
     by (intro sum.reindex_bij_witness[of _ "\<lambda>x. x - 1" Suc]) auto
   finally show ?thesis .
 qed
 
 lemma zeta_partial_sum_le:
   fixes x :: real and m :: nat
   assumes x: "x \<in> {0<..1}"
   shows "(\<Sum>k=1..m. real k powr (x - 1)) \<le> real m powr x / x"
 proof -
   consider "m = 0" | "m = 1" | "m > 1" by force
   thus ?thesis
   proof cases
     assume m: "m > 1"
     hence "{1..m} = insert 1 {1<..m}" by auto
     also have "(\<Sum>k\<in>\<dots>. real k powr (x - 1)) = 1 + (\<Sum>k\<in>{1<..m}. real k powr (x - 1))"
       by simp
     also have "(\<Sum>k\<in>{1<..m}. real k powr (x - 1)) \<le> real m powr x / x - 1 / x"
     proof (rule has_integral_le)
       show "((\<lambda>t. (nat \<lceil>t\<rceil>) powr (x - 1)) has_integral (\<Sum>n\<in>{1<..m}. n powr (x - 1))) {real 1..m}"
         using m by (intro nat_sum_has_integral_ceiling) auto
     next
       have "((\<lambda>t. t powr (x - 1)) has_integral (real m powr x / x - real 1 powr x / x))
               {real 1..real m}"
         by (intro fundamental_theorem_of_calculus)
            (insert x m, auto simp flip: has_field_derivative_iff_has_vector_derivative
                              intro!: derivative_eq_intros)
       thus "((\<lambda>t. t powr (x - 1)) has_integral (real m powr x / x - 1 / x)) {real 1..real m}"
         by simp
     qed (insert x, auto intro!: powr_mono2')
     also have "1 + (real m powr x / x - 1 / x) \<le> real m powr x / x"
       using x by (simp add: field_simps)
     finally show ?thesis by simp
   qed (use assms in auto)
 qed
 
 lemma zeta_partial_sum_le':
   fixes x :: real and m :: nat
   assumes x: "x > 0" and m: "m > 0"
   shows   "(\<Sum>n=1..m. real n powr (x - 1)) \<le> m powr x * (1 / x + 1 / m)"
 proof (cases "x > 1")
   case False
   with assms have "(\<Sum>n=1..m. real n powr (x - 1)) \<le> m powr x / x"
     by (intro zeta_partial_sum_le) auto
   also have "\<dots> \<le> m powr x * (1 / x + 1 / m)"
     using assms by (simp add: field_simps)
   finally show ?thesis .
 next
   case True
   have "(\<Sum>n\<in>{1..m}. n powr (x - 1)) = (\<Sum>n\<in>insert m {0..<m}. n powr (x - 1))"
     by (intro sum.mono_neutral_left) auto
   also have "\<dots> = m powr (x - 1) + (\<Sum>n\<in>{0..<m}. n powr (x - 1))" by simp
   also have "(\<Sum>n\<in>{0..<m}. n powr (x - 1)) \<le> real m powr x / x"
   proof (rule has_integral_le)
     show "((\<lambda>t. (nat \<lfloor>t\<rfloor>) powr (x - 1)) has_integral (\<Sum>n\<in>{0..<m}. n powr (x - 1))) {real 0..m}"
       using m by (intro nat_sum_has_integral_floor) auto
   next
     show "((\<lambda>t. t powr (x - 1)) has_integral (real m powr x / x)) {real 0..real m}"
       using has_integral_powr_from_0[of "x - 1"] x by auto
   next
     fix t assume "t \<in> {real 0..real m}"
     with \<open>x > 1\<close> show "real (nat \<lfloor>t\<rfloor>) powr (x - 1) \<le> t powr (x - 1)"
       by (cases "t = 0") (auto intro: powr_mono2)
   qed
   also have "m powr (x - 1) + m powr x / x = m powr x * (1 / x + 1 / m)"
     using m x by (simp add: powr_diff field_simps)
   finally show ?thesis by simp
 qed
 
 lemma natfun_bigo_1E:
   assumes "(f :: nat \<Rightarrow> _) \<in> O(\<lambda>_. 1)"
   obtains C where "C \<ge> lb" "\<And>n. norm (f n) \<le> C"
 proof -
   from assms obtain C N where "\<forall>n\<ge>N. norm (f n) \<le> C"
     by (auto elim!: landau_o.bigE simp: eventually_at_top_linorder)
   hence *: "norm (f n) \<le> Max ({C, lb} \<union> (norm ` f ` {..<N}))" for n
     by (cases "n \<ge> N") (subst Max_ge_iff; force simp: image_iff)+
   moreover have "Max ({C, lb} \<union> (norm ` f ` {..<N})) \<ge> lb"
     by (intro Max.coboundedI) auto
   ultimately show ?thesis using that by blast
 qed
 
 lemma natfun_bigo_iff_Bseq: "f \<in> O(\<lambda>_. 1) \<longleftrightarrow> Bseq f"
 proof
   assume "Bseq f"
   then obtain C where "C > 0" "\<And>n. norm (f n) \<le> C" by (auto simp: Bseq_def)
   thus "f \<in> O(\<lambda>_. 1)" by (intro bigoI[of _ C]) auto
 next
   assume "f \<in> O(\<lambda>_. 1)"
   from natfun_bigo_1E[OF this, where lb = 1] obtain C where "C \<ge> 1" "\<And>n. norm (f n) \<le> C"
     by auto
   thus "Bseq f" by (auto simp: Bseq_def intro!: exI[of _ C])
 qed
 
 lemma enn_decreasing_sum_le_set_nn_integral:
   fixes f :: "real \<Rightarrow> ennreal"
   assumes decreasing: "\<And>x y. 0 \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> f y \<le> f x"
   shows "(\<Sum>n. f (real (Suc n))) \<le> set_nn_integral lborel {0..} f"
 proof -
   have "(\<Sum>n. (f (Suc n))) =
           (\<Sum>n. \<integral>\<^sup>+x\<in>{real n<..real (Suc n)}. (f (Suc n)) \<partial>lborel)"
     by (subst nn_integral_cmult_indicator) auto
   also have "nat \<lceil>x\<rceil> = Suc n" if "x \<in> {real n<..real (Suc n)}" for x n
     using that by (auto simp: nat_eq_iff ceiling_eq_iff)
   hence "(\<Sum>n. \<integral>\<^sup>+x\<in>{real n<..real (Suc n)}. (f (Suc n)) \<partial>lborel) =
           (\<Sum>n. \<integral>\<^sup>+x\<in>{real n<..real (Suc n)}. (f (real (nat \<lceil>x\<rceil>))) \<partial>lborel)"
     by (intro suminf_cong nn_integral_cong) (auto simp: indicator_def)
   also have "\<dots> = (\<integral>\<^sup>+x\<in>(\<Union>i. {real i<..real (Suc i)}). (f (nat \<lceil>x::real\<rceil>)) \<partial>lborel)"
     by (subst nn_integral_disjoint_family)
        (auto simp: disjoint_family_on_def)
   also have "\<dots> \<le> (\<integral>\<^sup>+x\<in>{0..}. (f x) \<partial>lborel)"
     by (intro nn_integral_mono) (auto simp: indicator_def intro!: decreasing)
   finally show ?thesis .
 qed
 
 (* TODO replace version in library *)
 lemma nn_integral_has_integral_lebesgue:
   fixes f :: "'a::euclidean_space \<Rightarrow> real"
   assumes nonneg: "\<And>x. x \<in> \<Omega> \<Longrightarrow> 0 \<le> f x" and I: "(f has_integral I) \<Omega>"
   shows "integral\<^sup>N lborel (\<lambda>x. indicator \<Omega> x * f x) = I"
 proof -
   from I have "(\<lambda>x. indicator \<Omega> x *\<^sub>R f x) \<in> lebesgue \<rightarrow>\<^sub>M borel"
     by (rule has_integral_implies_lebesgue_measurable)
   then obtain f' :: "'a \<Rightarrow> real"
     where [measurable]: "f' \<in> borel \<rightarrow>\<^sub>M borel" and eq: "AE x in lborel. indicator \<Omega> x * f x = f' x"
     by (auto dest: completion_ex_borel_measurable_real)
 
   from I have "((\<lambda>x. abs (indicator \<Omega> x * f x)) has_integral I) UNIV"
     using nonneg by (simp add: indicator_def of_bool_def if_distrib[of "\<lambda>x. x * f y" for y] cong: if_cong)
   also have "((\<lambda>x. abs (indicator \<Omega> x * f x)) has_integral I) UNIV \<longleftrightarrow> ((\<lambda>x. abs (f' x)) has_integral I) UNIV"
     using eq by (intro has_integral_AE) auto
   finally have "integral\<^sup>N lborel (\<lambda>x. abs (f' x)) = I"
     by (rule nn_integral_has_integral_lborel[rotated 2]) auto
   also have "integral\<^sup>N lborel (\<lambda>x. abs (f' x)) = integral\<^sup>N lborel (\<lambda>x. abs (indicator \<Omega> x * f x))"
     using eq by (intro nn_integral_cong_AE) auto
   also have "(\<lambda>x. abs (indicator \<Omega> x * f x)) = (\<lambda>x. indicator \<Omega> x * f x)"
     using nonneg by (auto simp: indicator_def fun_eq_iff)
   finally show ?thesis .
 qed
 
 lemma decreasing_sum_le_integral:
   fixes f :: "real \<Rightarrow> real"
   assumes nonneg: "\<And>x. x \<ge> 0 \<Longrightarrow> f x \<ge> 0"
   assumes decreasing: "\<And>x y. 0 \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> f y \<le> f x"
   assumes integral: "(f has_integral I) {0..}"
   shows   "summable (\<lambda>i. f (real (Suc i)))" and "suminf (\<lambda>i. f (real (Suc i))) \<le> I"
 proof -
   have [simp]: "I \<ge> 0"
     by (intro has_integral_nonneg[OF integral] nonneg) auto
   have "(\<Sum>n. ennreal (f (Suc n))) =
           (\<Sum>n. \<integral>\<^sup>+x\<in>{real n<..real (Suc n)}. ennreal (f (Suc n)) \<partial>lborel)"
     by (subst nn_integral_cmult_indicator) auto
   also have "nat \<lceil>x\<rceil> = Suc n" if "x \<in> {real n<..real (Suc n)}" for x n
     using that by (auto simp: nat_eq_iff ceiling_eq_iff)
   hence "(\<Sum>n. \<integral>\<^sup>+x\<in>{real n<..real (Suc n)}. ennreal (f (Suc n)) \<partial>lborel) =
           (\<Sum>n. \<integral>\<^sup>+x\<in>{real n<..real (Suc n)}. ennreal (f (real (nat \<lceil>x\<rceil>))) \<partial>lborel)"
     by (intro suminf_cong nn_integral_cong) (auto simp: indicator_def)
   also have "\<dots> = (\<integral>\<^sup>+x\<in>(\<Union>i. {real i<..real (Suc i)}). ennreal (f (nat \<lceil>x::real\<rceil>)) \<partial>lborel)"
     by (subst nn_integral_disjoint_family)
        (auto simp: disjoint_family_on_def intro!: measurable_completion)
   also have "\<dots> \<le> (\<integral>\<^sup>+x\<in>{0..}. ennreal (f x) \<partial>lborel)"
     by (intro nn_integral_mono) (auto simp: indicator_def nonneg intro!: decreasing)
   also have "\<dots> = (\<integral>\<^sup>+ x. ennreal (indicat_real {0..} x * f x) \<partial>lborel)"
     by (intro nn_integral_cong) (auto simp: indicator_def)
   also have "\<dots> = ennreal I"
     using nn_integral_has_integral_lebesgue[OF nonneg integral] by (auto simp: nonneg)
   finally have *: "(\<Sum>n. ennreal (f (Suc n))) \<le> ennreal I" .
   from * show summable: "summable (\<lambda>i. f (real (Suc i)))"
     by (intro summable_suminf_not_top) (auto simp: top_unique intro: nonneg)
   note *
   also from summable have "(\<Sum>n. ennreal (f (Suc n))) = ennreal (\<Sum>n. f (Suc n))"
     by (subst suminf_ennreal2) (auto simp: o_def nonneg)
   finally show "(\<Sum>n. f (real (Suc n))) \<le> I" by (subst (asm) ennreal_le_iff) auto
 qed
 
 lemma decreasing_sum_le_integral':
   fixes f :: "real \<Rightarrow> real"
   assumes "\<And>x. x \<ge> 0 \<Longrightarrow> f x \<ge> 0"
   assumes "\<And>x y. 0 \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> f y \<le> f x"
   assumes "(f has_integral I) {0..}"
   shows   "summable (\<lambda>i. f (real i))" and "suminf (\<lambda>i. f (real i)) \<le> f 0 + I"
 proof -
   have "summable ((\<lambda>i. f (real (Suc i))))"
     using decreasing_sum_le_integral[OF assms] by (simp add: o_def)
   thus *: "summable (\<lambda>i. f (real i))" by (subst (asm) summable_Suc_iff)
   have "(\<Sum>n. f (real (Suc n))) \<le> I" by (intro decreasing_sum_le_integral assms)
   thus "suminf (\<lambda>i. f (real i)) \<le> f 0 + I"
     using * by (subst (asm) suminf_split_head) auto
 qed
 
 lemma norm_suminf_le:
   assumes "\<And>n. norm (f n :: 'a :: banach) \<le> g n" "summable g"
   shows   "norm (suminf f) \<le> suminf g"
 proof -
   have *: "summable (\<lambda>n. norm (f n))" using assms
     by (intro summable_norm summable_comparison_test[OF _ assms(2)] exI[of _ 0]) auto
   hence "norm (suminf f) \<le> (\<Sum>n. norm (f n))" by (intro summable_norm) auto
   also have "\<dots> \<le> suminf g" by (intro suminf_le * assms allI)
   finally show ?thesis .
 qed
 
 lemma of_nat_powr_neq_1_complex [simp]:
   assumes "n > 1" "Re s \<noteq> 0"
   shows   "of_nat n powr s \<noteq> (1::complex)"
 proof -
   have "norm (of_nat n powr s) = real n powr Re s"
     by (simp add: norm_powr_real_powr)
   also have "\<dots> \<noteq> 1"
     using assms by (auto simp: powr_def)
   finally show ?thesis by auto
 qed
 
 lemma abs_summable_on_uminus_iff:
   "(\<lambda>x. -f x) abs_summable_on A \<longleftrightarrow> f abs_summable_on A"
   using abs_summable_on_uminus[of f A] abs_summable_on_uminus[of "\<lambda>x. -f x" A] by auto
 
 lemma abs_summable_on_cmult_right_iff:
   fixes f :: "'a \<Rightarrow> 'b :: {banach, real_normed_field, second_countable_topology}"
   assumes "c \<noteq> 0"
   shows   "(\<lambda>x. c * f x) abs_summable_on A \<longleftrightarrow> f abs_summable_on A"
   using assms abs_summable_on_cmult_right[of c f A]
         abs_summable_on_cmult_right[of "inverse c" "\<lambda>x. c * f x" A] by (auto simp: field_simps)
 
 lemma abs_summable_on_cmult_left_iff:
   fixes f :: "'a \<Rightarrow> 'b :: {banach, real_normed_field, second_countable_topology}"
   assumes "c \<noteq> 0"
   shows   "(\<lambda>x. f x * c) abs_summable_on A \<longleftrightarrow> f abs_summable_on A"
   using assms abs_summable_on_cmult_left[of c f A]
         abs_summable_on_cmult_left[of "inverse c" "\<lambda>x. f x * c" A] by (auto simp: field_simps)
 
 lemma fds_logderiv_completely_multiplicative:
   fixes f :: "'a :: {real_normed_field} fds"
   assumes "completely_multiplicative_function (fds_nth f)" "fds_nth f 1 \<noteq> 0"
   shows   "fds_deriv f / f = - fds (\<lambda>n. fds_nth f n * mangoldt n)"
 proof -
   have "fds_deriv f / f = - fds (\<lambda>n. fds_nth f n * mangoldt n) * f / f"
     using completely_multiplicative_fds_deriv[of "fds_nth f"] assms by simp
   also have "\<dots> = - fds (\<lambda>n. fds_nth f n * mangoldt n)"
     using assms by (simp add: divide_fds_def fds_right_inverse)
   finally show ?thesis .
 qed
 
 lemma fds_nth_logderiv_completely_multiplicative:
   fixes f :: "'a :: {real_normed_field} fds"
   assumes "completely_multiplicative_function (fds_nth f)" "fds_nth f 1 \<noteq> 0"
   shows   "fds_nth (fds_deriv f / f) n = -fds_nth f n * mangoldt n"
   using assms by (subst fds_logderiv_completely_multiplicative) (simp_all add: fds_nth_fds')
 
 lemma eval_fds_logderiv_completely_multiplicative:
   fixes s :: "'a :: dirichlet_series" and l :: 'a and f :: "'a fds"
   defines "h \<equiv> fds_deriv f / f"
   assumes "completely_multiplicative_function (fds_nth f)" and [simp]: "fds_nth f 1 \<noteq> 0"
   assumes "s \<bullet> 1 > abs_conv_abscissa f"
   shows  "(\<lambda>p. of_real (ln (real p)) * (1 / (1 - fds_nth f p / nat_power p s) - 1))
             abs_summable_on {p. prime p}" (is ?th1)
     and  "eval_fds h s = -(\<Sum>\<^sub>ap | prime p. of_real (ln (real p)) *
                             (1 / (1 - fds_nth f p / nat_power p s) - 1))" (is ?th2)
 proof -
   let ?P = "{p::nat. prime p}"
   interpret f: completely_multiplicative_function "fds_nth f" by fact
   have "fds_abs_converges h s"
     using abs_conv_abscissa_completely_multiplicative_log_deriv[OF assms(2)] assms
     by (intro fds_abs_converges) auto
   hence *: "(\<lambda>n. fds_nth h n / nat_power n s) abs_summable_on UNIV"
     by (auto simp: h_def fds_abs_converges_altdef')
 
   note *
   also have "(\<lambda>n. fds_nth h n / nat_power n s) abs_summable_on UNIV \<longleftrightarrow>
           (\<lambda>x. -fds_nth f x * mangoldt x / nat_power x s) abs_summable_on Collect primepow"
     unfolding h_def using fds_nth_logderiv_completely_multiplicative[OF assms(2)]
     by (intro abs_summable_on_cong_neutral) (auto simp: fds_nth_fds mangoldt_def)
   finally have sum1: "(\<lambda>x. -fds_nth f x * mangoldt x / nat_power x s)
                       abs_summable_on Collect primepow"
     by (rule abs_summable_on_subset) auto
   also have "?this \<longleftrightarrow> (\<lambda>(p,k). -fds_nth f (p ^ Suc k) * mangoldt (p ^ Suc k) /
                                 nat_power (p ^ Suc k) s) abs_summable_on (?P \<times> UNIV)"
     using bij_betw_primepows unfolding case_prod_unfold
     by (intro abs_summable_on_reindex_bij_betw [symmetric])
   also have "\<dots> \<longleftrightarrow> (\<lambda>(p,k). -((fds_nth f p / nat_power p s) ^ Suc k * of_real (ln (real p))))
                 abs_summable_on (?P \<times> UNIV)"
     unfolding case_prod_unfold
     by (intro abs_summable_on_cong, subst mangoldt_primepow)
        (auto simp: f.mult f.power nat_power_mult_distrib nat_power_power_left power_divide
              dest: prime_gt_1_nat)
   finally have sum2: \<dots> .
 
   have sum4: "summable (\<lambda>n. (norm (fds_nth f p / nat_power p s)) ^ Suc n)" if p: "prime p" for p
   proof -
     have "summable (\<lambda>n. \<bar>ln (real p)\<bar> * (norm (fds_nth f p / nat_power p s)) ^ Suc n)"
       using p abs_summable_on_Sigma_project2[OF sum2, of p] unfolding abs_summable_on_nat_iff'
       by (simp add: norm_power norm_mult norm_divide mult_ac del: power_Suc)
     thus ?thesis by (rule summable_mult_D) (insert p, auto dest: prime_gt_1_nat)
   qed
   have sums: "(\<lambda>n. (fds_nth f p / nat_power p s) ^ Suc n) sums
                 (1 / (1 - fds_nth f p / nat_power p s) - 1)" if p: "prime p" for p :: nat
   proof -
     from sum4[OF p] have "norm (fds_nth f p / nat_power p s) < 1"
       unfolding summable_Suc_iff by (simp add: summable_geometric_iff)
     from geometric_sums[OF this] show ?thesis by (subst sums_Suc_iff) auto
   qed
 
   have eq: "(\<Sum>\<^sub>ak. - ((fds_nth f p / nat_power p s) ^ Suc k * of_real (ln (real p)))) =
                -(of_real (ln (real p)) * (1 / (1 - fds_nth f p / nat_power p s) - 1))"
     if p: "prime p" for p
   proof -
     have "(\<Sum>\<^sub>ak. - ((fds_nth f p / nat_power p s) ^ Suc k * of_real (ln (real p)))) =
              (\<Sum>\<^sub>ak. (fds_nth f p / nat_power p s) ^ Suc k) * of_real (-ln (real p))"
       using sum4[of p] p
       by (subst infsetsum_cmult_left [symmetric])
          (auto simp: abs_summable_on_nat_iff' norm_power simp del: power_Suc)
     also have "(\<Sum>\<^sub>ak. (fds_nth f p / nat_power p s) ^ Suc k) =
                  (1 / (1 - fds_nth f p / nat_power p s) - 1)" using sum4[OF p] sums[OF p]
       by (subst infsetsum_nat')
          (auto simp: sums_iff abs_summable_on_nat_iff' norm_power simp del: power_Suc)
     finally show ?thesis by (simp add: mult_ac)
   qed
 
   have sum3: "(\<lambda>x. \<Sum>\<^sub>ay. - ((fds_nth f x / nat_power x s) ^ Suc y * of_real (ln (real x))))
                  abs_summable_on {p. prime p}"
     using sum2 by (rule abs_summable_on_Sigma_project1') auto
   also have "?this \<longleftrightarrow> (\<lambda>p. -(of_real (ln (real p)) *
                 (1 / (1 - fds_nth f p / nat_power p s) - 1))) abs_summable_on {p. prime p}"
     by (intro abs_summable_on_cong eq) auto
   also have "\<dots> \<longleftrightarrow> ?th1" by (subst abs_summable_on_uminus_iff) auto
   finally show ?th1 .
 
   have "eval_fds h s = (\<Sum>\<^sub>an. fds_nth h n / nat_power n s)"
     using * unfolding eval_fds_def by (subst infsetsum_nat') auto
   also have "\<dots> = (\<Sum>\<^sub>an \<in> {n. primepow n}. -fds_nth f n * mangoldt n / nat_power n s)"
     unfolding h_def using fds_nth_logderiv_completely_multiplicative[OF assms(2)]
     by (intro infsetsum_cong_neutral) (auto simp: fds_nth_fds mangoldt_def)
   also have "\<dots> = (\<Sum>\<^sub>a(p,k)\<in>(?P \<times> UNIV). -fds_nth f (p ^ Suc k) * mangoldt (p ^ Suc k) /
                                             nat_power (p ^ Suc k) s)"
      using bij_betw_primepows unfolding case_prod_unfold
      by (intro infsetsum_reindex_bij_betw [symmetric])
   also have "\<dots> = (\<Sum>\<^sub>a(p,k)\<in>(?P \<times> UNIV).
                      -((fds_nth f p / nat_power p s) ^ Suc k) * of_real (ln (real p)))"
     by (intro infsetsum_cong)
        (auto simp: f.mult f.power mangoldt_def aprimedivisor_prime_power ln_realpow prime_gt_0_nat
           nat_power_power_left divide_simps simp del: power_Suc)
   also have "\<dots> = (\<Sum>\<^sub>ap | prime p. \<Sum>\<^sub>ak.
                     - ((fds_nth f p / nat_power p s) ^ Suc k) * of_real (ln (real p)))"
     using sum2 by (subst infsetsum_Times) (auto simp: case_prod_unfold)
   also have "\<dots> = (\<Sum>\<^sub>ap | prime p. -(of_real (ln (real p)) *
                     (1 / (1 - fds_nth f p / nat_power p s) - 1)))"
     using eq by (intro infsetsum_cong) auto
   finally show ?th2 by (subst (asm) infsetsum_uminus)
 qed
 
 lemma eval_fds_logderiv_zeta:
   assumes "Re s > 1"
   shows  "(\<lambda>p. of_real (ln (real p)) / (p powr s - 1))
             abs_summable_on {p. prime p}" (is ?th1)
     and  "deriv zeta s / zeta s =
             -(\<Sum>\<^sub>ap | prime p. of_real (ln (real p)) / (p powr s - 1))" (is ?th2)
 proof -
   have *: "completely_multiplicative_function (fds_nth fds_zeta :: _ \<Rightarrow> complex)"
     by standard auto
   note abscissa = le_less_trans[OF abs_conv_abscissa_completely_multiplicative_log_deriv[OF *]]
   have "(\<lambda>p. ln (real p) * (1 / (1 - fds_nth fds_zeta p / p powr s) - 1))
            abs_summable_on {p. prime p}"
     using eval_fds_logderiv_completely_multiplicative[OF *, of s] assms by auto
   also have "?this \<longleftrightarrow> (\<lambda>p. ln (real p) / (p powr s - 1)) abs_summable_on {p. prime p}" using assms
     by (intro abs_summable_on_cong) (auto simp: fds_nth_zeta divide_simps dest: prime_gt_1_nat)
   finally show ?th1 .
 
   from assms have ev: "eventually (\<lambda>z. z \<in> {z. Re z > 1}) (nhds s)"
     by (intro eventually_nhds_in_open open_halfspace_Re_gt) auto
   have "deriv zeta s = deriv (eval_fds fds_zeta) s"
     by (intro deriv_cong_ev[OF eventually_mono[OF ev]]) (auto simp: eval_fds_zeta)
   also have "deriv (eval_fds fds_zeta) s / zeta s = eval_fds (fds_deriv fds_zeta / fds_zeta) s"
     using assms zeta_Re_gt_1_nonzero[of s]
     by (subst eval_fds_log_deriv) (auto simp: eval_fds_zeta eval_fds_deriv intro!: abscissa)
   also have "eval_fds (fds_deriv fds_zeta / fds_zeta) s =
                -(\<Sum>\<^sub>ap | prime p. ln (real p) * (1 / (1 - fds_nth fds_zeta p / p powr s) - 1))"
     (is "_ = -?S") using eval_fds_logderiv_completely_multiplicative[OF *, of s] assms by auto
   also have "?S = (\<Sum>\<^sub>ap | prime p. ln (real p) / (p powr s - 1))" using assms
     by (intro infsetsum_cong) (auto simp: fds_nth_zeta divide_simps dest: prime_gt_1_nat)
   finally show ?th2 .
 qed
 
 lemma sums_logderiv_zeta:
   assumes "Re s > 1"
   shows   "(\<lambda>p. if prime p then of_real (ln (real p)) / (of_nat p powr s - 1) else 0) sums
              -(deriv zeta s / zeta s)" (is "?f sums _")
 proof -
   note * = eval_fds_logderiv_zeta[OF assms]
   from sums_infsetsum_nat[OF *(1)] and *(2) show ?thesis by simp
 qed
 
 lemma abs_conv_abscissa_diff_le:
   "abs_conv_abscissa (f - g :: 'a :: dirichlet_series fds) \<le>
      max (abs_conv_abscissa f) (abs_conv_abscissa g)"
   using abs_conv_abscissa_add_le[of f "-g"] by auto
 
 lemma abs_conv_abscissa_diff_leI:
   "abs_conv_abscissa (f :: 'a :: dirichlet_series fds) \<le> d \<Longrightarrow> abs_conv_abscissa g \<le> d \<Longrightarrow>
      abs_conv_abscissa (f - g) \<le> d"
   using abs_conv_abscissa_diff_le[of f g] by (auto simp: le_max_iff_disj)
 
 lemma range_add_nat: "range (\<lambda>n. n + c) = {(c::nat)..}"
 proof safe
   fix x assume "x \<ge> c"
   hence "x = x - c + c" by simp
   thus "x \<in> range (\<lambda>n. n + c)" by blast
 qed auto
 
 lemma abs_summable_hurwitz_zeta:
   assumes "Re s > 1" "a + real b > 0"
   shows   "(\<lambda>n. 1 / (of_nat n + a) powr s) abs_summable_on {b..}"
 proof -
   from assms have "summable (\<lambda>n. cmod (1 / (of_nat (n + b) + a) powr s))"
     using summable_hurwitz_zeta_real[of "Re s" "a + b"]
     by (auto simp: norm_divide powr_minus field_simps norm_powr_real_powr)
   hence "(\<lambda>n. 1 / (of_nat (n + b) + a) powr s) abs_summable_on UNIV"
     by (auto simp: abs_summable_on_nat_iff' add_ac)
   also have "?this \<longleftrightarrow> (\<lambda>n. 1 / (of_nat n + a) powr s) abs_summable_on range (\<lambda>n. n + b)"
     by (rule abs_summable_on_reindex_iff) auto
   also have "range (\<lambda>n. n + b) = {b..}" by (rule range_add_nat)
   finally show ?thesis .
 qed
 
 lemma hurwitz_zeta_nat_conv_infsetsum:
   assumes "a > 0" and "Re s > 1"
   shows   "hurwitz_zeta (real a) s = (\<Sum>\<^sub>an. of_nat (n + a) powr -s)"
           "hurwitz_zeta (real a) s = (\<Sum>\<^sub>an\<in>{a..}. of_nat n powr -s)"
 proof -
   have "hurwitz_zeta (real a) s = (\<Sum>n. of_nat (n + a) powr -s)"
     using assms by (subst hurwitz_zeta_conv_suminf) auto
   also have "\<dots> = (\<Sum>\<^sub>an. of_nat (n + a) powr -s)"
     using abs_summable_hurwitz_zeta[of s a 0] assms
     by (intro infsetsum_nat' [symmetric]) (auto simp: powr_minus field_simps)
   finally show "hurwitz_zeta (real a) s = (\<Sum>\<^sub>an. of_nat (n + a) powr -s)" .
   also have "\<dots> = (\<Sum>\<^sub>an\<in>range (\<lambda>n. n + a). of_nat n powr -s)"
     by (rule infsetsum_reindex [symmetric]) auto
   also have "range (\<lambda>n. n + a) = {a..}" by (rule range_add_nat)
   finally show "hurwitz_zeta (real a) s = (\<Sum>\<^sub>an\<in>{a..}. of_nat n powr -s)" .
 qed
 
 lemma continuous_on_pre_zeta [continuous_intros]:
   assumes "continuous_on A f" "a > 0"
   shows   "continuous_on A (\<lambda>x. pre_zeta a (f x))"
 proof -
   from assms have "continuous_on UNIV (pre_zeta a)"
     by (intro holomorphic_on_imp_continuous_on[OF holomorphic_pre_zeta]) auto
   from continuous_on_compose2[OF this assms(1)] show ?thesis by simp
 qed
 
 lemma continuous_pre_zeta [continuous_intros]:
   assumes "continuous (at x within A) f" "a > 0"
   shows   "continuous (at x within A) (\<lambda>x. pre_zeta a (f x))"
 proof -
   have "continuous (at z) (pre_zeta a)" for z
     by (rule continuous_on_interior[of UNIV]) (insert assms, auto intro!: continuous_intros)
   from continuous_within_compose3[OF this assms(1)] show ?thesis .
 qed
 
 
 lemma pre_zeta_bound:
   assumes "0 < Re s" and a: "a > 0"
   shows   "norm (pre_zeta a s) \<le> (1 + norm s / Re s) / 2 * a powr -Re s"
 proof -
   let ?f = "\<lambda>x. - (s * (x + a) powr (-1-s))"
   let ?g' = "\<lambda>x. norm s * (x + a) powr (-1-Re s)"
   let ?g = "\<lambda>x. -norm s / Re s * (x + a) powr (-Re s)"
   define R where "R = EM_remainder 1 ?f 0"
   have [simp]: "-Re s - 1 = -1 - Re s" by (simp add: algebra_simps)
 
   have "\<bar>frac x - 1 / 2\<bar> \<le> 1 / 2" for x :: real unfolding frac_def
     by linarith
   hence "\<bar>pbernpoly (Suc 0) x\<bar> \<le> 1 / 2" for x
     by (simp add: pbernpoly_def bernpoly_def)
   moreover have "((\<lambda>b. cmod s * (b + a) powr - Re s / Re s) \<longlongrightarrow> 0) at_top"
     using \<open>Re s > 0\<close> \<open>a > 0\<close> by real_asymp
   ultimately have *: "\<forall>x. x \<ge> real 0 \<longrightarrow> norm (EM_remainder 1 ?f (int x)) \<le>
                            (1 / 2) / fact 1 * (-?g (real x))"
     using \<open>a > 0\<close> \<open>Re s > 0\<close>
     by (intro norm_EM_remainder_le_strong_nat'[where g' = ?g' and Y = "{}"])
        (auto intro!: continuous_intros derivative_eq_intros
              simp: field_simps norm_mult norm_powr_real_powr add_eq_0_iff)
   have R: "norm R \<le> norm s / (2 * Re s) * a powr -Re s"
     unfolding R_def using spec[OF *, of 0] by simp
 
   from assms have "pre_zeta a s = a powr -s / 2 + R"
     by (simp add: pre_zeta_def pre_zeta_aux_def R_def)
   also have "norm \<dots> \<le> a powr -Re s / 2 + norm s / (2 * Re s) * a powr -Re s" using a
     by (intro order.trans[OF norm_triangle_ineq] add_mono R) (auto simp: norm_powr_real_powr)
   also have "\<dots> = (1 + norm s / Re s) / 2 * a powr -Re s"
     by (simp add: field_simps)
   finally show ?thesis .
 qed
 
 lemma pre_zeta_bound':
   assumes "0 < Re s" and a: "a > 0"
   shows   "norm (pre_zeta a s) \<le> norm s / (Re s * a powr Re s)"
 proof -
   from assms have "norm (pre_zeta a s) \<le> (1 + norm s / Re s) / 2 * a powr -Re s"
     by (intro pre_zeta_bound) auto
   also have "\<dots> = (Re s + norm s) / 2 / (Re s * a powr Re s)"
     using assms by (auto simp: field_simps powr_minus)
   also have "Re s + norm s \<le> norm s + norm s" by (intro add_right_mono complex_Re_le_cmod)
   also have "(norm s + norm s) / 2 = norm s" by simp
   finally show "norm (pre_zeta a s) \<le> norm s / (Re s * a powr Re s)"
     using assms by (simp add: divide_right_mono)
 qed
 
 lemma summable_comparison_test_bigo:
   fixes f :: "nat \<Rightarrow> real"
   assumes "summable (\<lambda>n. norm (g n))" "f \<in> O(g)"
   shows   "summable f"
 proof -
   from \<open>f \<in> O(g)\<close> obtain C where C: "eventually (\<lambda>x. norm (f x) \<le> C * norm (g x)) at_top"
     by (auto elim: landau_o.bigE)
   thus ?thesis
     by (rule summable_comparison_test_ev) (insert assms, auto intro: summable_mult)
 qed
 
 lemma deriv_zeta_eq:
   assumes s: "s \<noteq> 1"
   shows   "deriv zeta s = deriv (pre_zeta 1) s - 1 / (s - 1)\<^sup>2"
 proof -
   from s have ev: "eventually (\<lambda>z. z \<noteq> 1) (nhds s)" by (intro t1_space_nhds)
   have [derivative_intros]: "(pre_zeta 1 has_field_derivative deriv (pre_zeta 1) s) (at s)"
     by (intro holomorphic_derivI[of _ UNIV] holomorphic_intros) auto
   have "((\<lambda>s. pre_zeta 1 s + 1 / (s - 1)) has_field_derivative
           (deriv (pre_zeta 1) s - 1 / (s - 1)\<^sup>2)) (at s)"
     using s by (auto intro!: derivative_eq_intros simp: power2_eq_square)
   also have "?this \<longleftrightarrow> (zeta has_field_derivative (deriv (pre_zeta 1) s - 1 / (s - 1)\<^sup>2)) (at s)"
     by (intro has_field_derivative_cong_ev eventually_mono[OF ev])
        (auto simp: zeta_def hurwitz_zeta_def)
   finally show ?thesis by (rule DERIV_imp_deriv)
 qed
 
 lemma zeta_remove_zero:
   assumes "Re s \<ge> 1"
   shows   "(s - 1) * pre_zeta 1 s + 1 \<noteq> 0"
 proof (cases "s = 1")
   case False
   hence "(s - 1) * pre_zeta 1 s + 1 = (s - 1) * zeta s"
     by (simp add: zeta_def hurwitz_zeta_def divide_simps)
   also from False assms have "\<dots> \<noteq> 0" using zeta_Re_ge_1_nonzero[of s] by auto
   finally show ?thesis .
 qed auto
 
 lemma eval_fds_deriv_zeta:
   assumes "Re s > 1"
   shows   "eval_fds (fds_deriv fds_zeta) s = deriv zeta s"
 proof -
   have ev: "eventually (\<lambda>z. z \<in> {z. Re z > 1}) (nhds s)"
     using assms by (intro eventually_nhds_in_open open_halfspace_Re_gt) auto
   from assms have "eval_fds (fds_deriv fds_zeta) s = deriv (eval_fds fds_zeta) s"
     by (subst eval_fds_deriv) auto
   also have "\<dots> = deriv zeta s"
     by (intro deriv_cong_ev eventually_mono[OF ev]) (auto simp: eval_fds_zeta)
   finally show ?thesis .
 qed
 
 lemma length_sorted_list_of_set [simp]:
   "finite A \<Longrightarrow> length (sorted_list_of_set A) = card A"
   by (metis length_remdups_card_conv length_sort set_sorted_list_of_set
             sorted_list_of_set_sort_remdups)
 
 lemma le_nat_iff': "x \<le> nat y \<longleftrightarrow> x = 0 \<and> y \<le> 0 \<or> int x \<le> y"
   by auto
 
 lemma sum_upto_plus1:
   assumes "x \<ge> 0"
   shows   "sum_upto f (x + 1) = sum_upto f x + f (Suc (nat \<lfloor>x\<rfloor>))"
 proof -
   have "sum_upto f (x + 1) = sum f {0<..Suc (nat \<lfloor>x\<rfloor>)}"
     using assms by (simp add: sum_upto_altdef nat_add_distrib)
   also have "{0<..Suc (nat \<lfloor>x\<rfloor>)} = insert (Suc (nat \<lfloor>x\<rfloor>)) {0<..nat \<lfloor>x\<rfloor>}"
     by auto
   also have "sum f \<dots> = sum_upto f x + f (Suc (nat \<lfloor>x\<rfloor>))"
     by (subst sum.insert) (auto simp: sum_upto_altdef add_ac)
   finally show ?thesis .
 qed
 
 lemma sum_upto_minus1:
   assumes "x \<ge> 1"
   shows   "sum_upto f (x - 1) = (sum_upto f x - f (nat \<lfloor>x\<rfloor>) :: 'a :: ab_group_add)"
   using sum_upto_plus1[of "x - 1" f] assms by (simp add: algebra_simps nat_diff_distrib)
 
 lemma integral_smallo:
   fixes f g g' :: "real \<Rightarrow> real"
   assumes "f \<in> o(g')" and "filterlim g at_top at_top"
   assumes "\<And>a' x. a \<le> a' \<Longrightarrow> a' \<le> x \<Longrightarrow> f integrable_on {a'..x}"
   assumes deriv: "\<And>x. x \<ge> a \<Longrightarrow> (g has_field_derivative g' x) (at x)"
   assumes cont: "continuous_on {a..} g'"
   assumes nonneg: "\<And>x. x \<ge> a \<Longrightarrow> g' x \<ge> 0"
   shows   "(\<lambda>x. integral {a..x} f) \<in> o(g)"
 proof (rule landau_o.smallI)
   fix c :: real assume c: "c > 0"
   note [continuous_intros] = continuous_on_subset[OF cont]
   define c' where "c' = c / 2"
   from c have c': "c' > 0" by (simp add: c'_def)
   from landau_o.smallD[OF assms(1) this]
     obtain b where b: "\<And>x. x \<ge> b \<Longrightarrow> norm (f x) \<le> c' * norm (g' x)"
     unfolding eventually_at_top_linorder by blast
   define b' where "b' = max a b"
   define D where "D = norm (integral {a..b'} f)"
 
   have "filterlim (\<lambda>x. c' * g x) at_top at_top"
     using c' by (intro filterlim_tendsto_pos_mult_at_top[OF tendsto_const] assms)
   hence "eventually (\<lambda>x. c' * g x \<ge> D - c' * g b') at_top"
     by (auto simp: filterlim_at_top)
   thus "eventually (\<lambda>x. norm (integral {a..x} f) \<le> c * norm (g x)) at_top"
     using eventually_ge_at_top[of b']
   proof eventually_elim
     case (elim x)
     have b': "a \<le> b'" "b \<le> b'" by (auto simp: b'_def)
     from elim b' have integrable: "(\<lambda>x. \<bar>g' x\<bar>) integrable_on {b'..x}"
       by (intro integrable_continuous_real continuous_intros) auto
     have "integral {a..x} f = integral {a..b'} f + integral {b'..x} f"
       using elim b' by (intro Henstock_Kurzweil_Integration.integral_combine [symmetric] assms) auto
     also have "norm \<dots> \<le> D + norm (integral {b'..x} f)"
       unfolding D_def by (rule norm_triangle_ineq)
     also have "norm (integral {b'..x} f) \<le> integral {b'..x} (\<lambda>x. c' * norm (g' x))"
       using b' elim assms c' integrable by (intro integral_norm_bound_integral b assms) auto
     also have "\<dots> = c' * integral {b'..x} (\<lambda>x. \<bar>g' x\<bar>)" by simp
     also have "integral {b'..x} (\<lambda>x. \<bar>g' x\<bar>) = integral {b'..x} g'"
       using assms b' by (intro integral_cong) auto
     also have "(g' has_integral (g x - g b')) {b'..x}" using b' elim
       by (intro fundamental_theorem_of_calculus)
          (auto simp flip: has_field_derivative_iff_has_vector_derivative
                intro!: has_field_derivative_at_within[OF deriv])
     hence "integral {b'..x} g' = g x - g b'"
       by (simp add: has_integral_iff)
     also have "D + c' * (g x - g b') \<le> c * g x"
       using elim by (simp add: field_simps c'_def)
     also have "\<dots> \<le> c * norm (g x)"
       using c by (intro mult_left_mono) auto
     finally show ?case by simp
   qed
 qed
 
 lemma integral_bigo:
   fixes f g g' :: "real \<Rightarrow> real"
   assumes "f \<in> O(g')" and "filterlim g at_top at_top"
   assumes "\<And>a' x. a \<le> a' \<Longrightarrow> a' \<le> x \<Longrightarrow> f integrable_on {a'..x}"
   assumes deriv: "\<And>x. x \<ge> a \<Longrightarrow> (g has_field_derivative g' x) (at x within {a..})"
   assumes cont: "continuous_on {a..} g'"
   assumes nonneg: "\<And>x. x \<ge> a \<Longrightarrow> g' x \<ge> 0"
   shows   "(\<lambda>x. integral {a..x} f) \<in> O(g)"
 proof -
   note [continuous_intros] = continuous_on_subset[OF cont]
   from landau_o.bigE[OF assms(1)]
     obtain c b where c: "c > 0" and b: "\<And>x. x \<ge> b \<Longrightarrow> norm (f x) \<le> c * norm (g' x)"
       unfolding eventually_at_top_linorder by metis
   define c' where "c' = c / 2"
   define b' where "b' = max a b"
   define D where "D = norm (integral {a..b'} f)"
 
   have "filterlim (\<lambda>x. c * g x) at_top at_top"
     using c by (intro filterlim_tendsto_pos_mult_at_top[OF tendsto_const] assms)
   hence "eventually (\<lambda>x. c * g x \<ge> D - c * g b') at_top"
     by (auto simp: filterlim_at_top)
   hence "eventually (\<lambda>x. norm (integral {a..x} f) \<le> 2 * c * norm (g x)) at_top"
     using eventually_ge_at_top[of b']
   proof eventually_elim
     case (elim x)
     have b': "a \<le> b'" "b \<le> b'" by (auto simp: b'_def)
     from elim b' have integrable: "(\<lambda>x. \<bar>g' x\<bar>) integrable_on {b'..x}"
       by (intro integrable_continuous_real continuous_intros) auto
     have "integral {a..x} f = integral {a..b'} f + integral {b'..x} f"
       using elim b' by (intro Henstock_Kurzweil_Integration.integral_combine [symmetric] assms) auto
     also have "norm \<dots> \<le> D + norm (integral {b'..x} f)"
       unfolding D_def by (rule norm_triangle_ineq)
     also have "norm (integral {b'..x} f) \<le> integral {b'..x} (\<lambda>x. c * norm (g' x))"
       using b' elim assms c integrable by (intro integral_norm_bound_integral b assms) auto
     also have "\<dots> = c * integral {b'..x} (\<lambda>x. \<bar>g' x\<bar>)" by simp
     also have "integral {b'..x} (\<lambda>x. \<bar>g' x\<bar>) = integral {b'..x} g'"
       using assms b' by (intro integral_cong) auto
     also have "(g' has_integral (g x - g b')) {b'..x}" using b' elim
       by (intro fundamental_theorem_of_calculus)
          (auto simp flip: has_field_derivative_iff_has_vector_derivative
                intro!: DERIV_subset[OF deriv])
     hence "integral {b'..x} g' = g x - g b'"
       by (simp add: has_integral_iff)
     also have "D + c * (g x - g b') \<le> 2 * c * g x"
       using elim by (simp add: field_simps c'_def)
     also have "\<dots> \<le> 2 * c * norm (g x)"
       using c by (intro mult_left_mono) auto
     finally show ?case by simp
   qed
   thus ?thesis by (rule bigoI)
 qed
 
 lemma primepows_le_subset:
   assumes x: "x > 0" and l: "l > 0"
   shows   "{(p, i). prime p \<and> l \<le> i \<and> real (p ^ i) \<le> x} \<subseteq> {..nat \<lfloor>root l x\<rfloor>} \<times> {..nat \<lfloor>log 2 x\<rfloor>}"
 proof safe
   fix p i :: nat assume pi: "prime p" "i \<ge> l" "real (p ^ i) \<le> x"
   have "real p ^ l \<le> real p ^ i" using pi x l
     by (intro power_increasing) (auto dest: prime_gt_0_nat)
   also have "\<dots> \<le> x" using pi by simp
   finally have "root l (real p ^ l) \<le> root l x"
     using x pi l by (subst real_root_le_iff) auto
   also have "root l (real p ^ l) = real p"
     using pi l by (subst real_root_pos2) auto
   finally show "p \<le> nat \<lfloor>root l x\<rfloor>" using pi l x by (simp add: le_nat_iff' le_floor_iff)
 
   from pi have "2 ^ i \<le> real p ^ i" using l
     by (intro power_mono) (auto dest: prime_gt_1_nat)
   also have "\<dots> \<le> x" using pi by simp
   finally show "i \<le> nat \<lfloor>log 2 x\<rfloor>" using pi x
     by (auto simp: le_nat_iff' le_floor_iff le_log_iff powr_realpow)
 qed
 
 lemma mangoldt_non_primepow: "\<not>primepow n \<Longrightarrow> mangoldt n = 0"
   by (auto simp: mangoldt_def)
 
 lemma le_imp_bigo_real:
   assumes "c \<ge> 0" "eventually (\<lambda>x. f x \<le> c * (g x :: real)) F" "eventually (\<lambda>x. 0 \<le> f x) F"
   shows   "f \<in> O[F](g)"
 proof -
   have "eventually (\<lambda>x. norm (f x) \<le> c * norm (g x)) F"
     using assms(2,3)
   proof eventually_elim
     case (elim x)
     have "norm (f x) \<le> c * g x" using elim by simp
     also have "\<dots> \<le> c * norm (g x)" by (intro mult_left_mono assms) auto
     finally show ?case .
   qed
   thus ?thesis by (intro bigoI[of _ c]) auto
 qed
 
 (* TODO: unneeded. But why does real_asymp not work? *)
 lemma ln_minus_ln_floor_bigo: "(\<lambda>x. ln x - ln (real (nat \<lfloor>x\<rfloor>))) \<in> O(\<lambda>_. 1)"
 proof (intro le_imp_bigo_real[of 1] eventually_mono[OF eventually_ge_at_top[of 1]])
   fix x :: real assume x: "x \<ge> 1"
   from x have *: "x - real (nat \<lfloor>x\<rfloor>) \<le> 1" by linarith
   from x have "ln x - ln (real (nat \<lfloor>x\<rfloor>)) \<le> (x - real (nat \<lfloor>x\<rfloor>)) / real (nat \<lfloor>x\<rfloor>)"
     by (intro ln_diff_le) auto
   also have "\<dots> \<le> 1 / 1" using x * by (intro frac_le) auto
   finally show "ln x - ln (real (nat \<lfloor>x\<rfloor>)) \<le> 1 * 1" by simp
 qed auto
 
 lemma cos_geD:
   assumes "cos x \<ge> cos a" "0 \<le> a" "a \<le> pi" "-pi \<le> x" "x \<le> pi"
   shows   "x \<in> {-a..a}"
 proof (cases "x \<ge> 0")
   case True
   with assms show ?thesis
     by (subst (asm) cos_mono_le_eq) auto
 next
   case False
   with assms show ?thesis using cos_mono_le_eq[of a "-x"]
     by auto
 qed
 
 (* TODO: Could be generalised *)
 lemma path_image_part_circlepath_same_Re:
   assumes "0 \<le> b" "b \<le> pi" "a = -b" "r \<ge> 0"
   shows   "path_image (part_circlepath c r a b) = sphere c r \<inter> {s. Re s \<ge> Re c + r * cos a}"
 proof safe
   fix z assume "z \<in> path_image (part_circlepath c r a b)"
   with assms obtain t where t: "t \<in> {a..b}" "z = c + of_real r * cis t"
     by (auto simp: path_image_part_circlepath exp_eq_polar)
   from t and assms show "z \<in> sphere c r"
     by (auto simp: dist_norm norm_mult)
   from t and assms show "Re z \<ge> Re c + r * cos a"
     using cos_monotone_0_pi_le[of t b] cos_monotone_minus_pi_0'[of a t]
     by (cases "t \<ge> 0") (auto intro!: mult_left_mono)
 next
   fix z assume z: "z \<in> sphere c r" "Re z \<ge> Re c + r * cos a"
   show "z \<in> path_image (part_circlepath c r a b)"
   proof (cases "r = 0")
     case False
     with assms have r: "r > 0" by simp
     with z have z_eq: "z = c + r * cis (Arg (z - c))"
       using Arg_eq[of "z - c"] by (auto simp: dist_norm exp_eq_polar norm_minus_commute)
   moreover from z(2) r assms have "cos b \<le> cos (Arg (z - c))"
     by (subst (asm) z_eq) auto
   with assms have "Arg (z - c) \<in> {-b..b}"
     using Arg_le_pi[of "z - c"] mpi_less_Arg[of "z - c"] by (intro cos_geD) auto
   ultimately show "z \<in> path_image (part_circlepath c r a b)"
     using assms by (subst path_image_part_circlepath) (auto simp: exp_eq_polar)
   qed (insert assms z, auto simp: path_image_part_circlepath)
 qed
 
 lemma part_circlepath_rotate_left:
   "part_circlepath c r (x + a) (x + b) = (\<lambda>z. c + cis x * (z - c)) \<circ> part_circlepath c r a b"
   by (simp add: part_circlepath_def exp_eq_polar fun_eq_iff
                 linepath_translate_left linepath_translate_right cis_mult add_ac)
 
 lemma part_circlepath_rotate_right:
   "part_circlepath c r (a + x) (b + x) = (\<lambda>z. c + cis x * (z - c)) \<circ> part_circlepath c r a b"
   by (simp add: part_circlepath_def exp_eq_polar fun_eq_iff
                 linepath_translate_left linepath_translate_right cis_mult add_ac)
 
 lemma path_image_semicircle_Re_ge:
   assumes "r \<ge> 0"
   shows   "path_image (part_circlepath c r (-pi/2) (pi/2)) =
              sphere c r \<inter> {s. Re s \<ge> Re c}"
   by (subst path_image_part_circlepath_same_Re) (simp_all add: assms)
 
 lemma sphere_rotate: "(\<lambda>z. c + cis x * (z - c)) ` sphere c r = sphere c r"
 proof safe
   fix z assume z: "z \<in> sphere c r"
   hence "z = c + cis x * (c + cis (-x) * (z - c) - c)"
         "c + cis (-x) * (z - c) \<in> sphere c r"
     by (auto simp: dist_norm norm_mult norm_minus_commute
                    cis_conv_exp exp_minus field_simps norm_divide)
   with z show "z \<in> (\<lambda>z. c + cis x * (z - c)) ` sphere c r" by blast
 qed (auto simp: dist_norm norm_minus_commute norm_mult)
 
 
 lemma path_image_semicircle_Re_le:
   assumes "r \<ge> 0"
   shows   "path_image (part_circlepath c r (pi/2) (3/2*pi)) =
              sphere c r \<inter> {s. Re s \<le> Re c}"
 proof -
   let ?f = "(\<lambda>z. c + cis pi * (z - c))"
   have *: "part_circlepath c r (pi/2) (3/2*pi) = part_circlepath c r (pi + (-pi/2)) (pi + pi/2)"
     by simp
   have "path_image (part_circlepath c r (pi/2) (3/2*pi)) =
           ?f ` sphere c r \<inter> ?f ` {s. Re c \<le> Re s}"
     unfolding * part_circlepath_rotate_left path_image_compose path_image_semicircle_Re_ge[OF assms]
     by auto
   also have "?f ` sphere c r = sphere c r"
     by (rule sphere_rotate)
   also have "?f ` {s. Re c \<le> Re s} = {s. Re c \<ge> Re s}"
     by (auto simp: image_iff intro!: exI[of _ "2 * c - x" for x])
   finally show ?thesis .
 qed
 
 lemma path_image_semicircle_Im_ge:
   assumes "r \<ge> 0"
   shows   "path_image (part_circlepath c r 0 pi) =
              sphere c r \<inter> {s. Im s \<ge> Im c}"
 proof -
   let ?f = "(\<lambda>z. c + cis (pi/2) * (z - c))"
   have *: "part_circlepath c r 0 pi = part_circlepath c r (pi / 2 + (-pi/2)) (pi / 2 + pi/2)"
     by simp
   have "path_image (part_circlepath c r 0 pi) =
           ?f ` sphere c r \<inter> ?f ` {s. Re c \<le> Re s}"
     unfolding * part_circlepath_rotate_left path_image_compose path_image_semicircle_Re_ge[OF assms]
     by auto
   also have "?f ` sphere c r = sphere c r"
     by (rule sphere_rotate)
   also have "?f ` {s. Re c \<le> Re s} = {s. Im c \<le> Im s}"
     by (auto simp: image_iff intro!: exI[of _ "c - \<i> * (x - c)" for x])
   finally show ?thesis .
 qed
 
 lemma path_image_semicircle_Im_le:
   assumes "r \<ge> 0"
   shows   "path_image (part_circlepath c r pi (2 * pi)) =
              sphere c r \<inter> {s. Im s \<le> Im c}"
 proof -
   let ?f = "(\<lambda>z. c + cis (3*pi/2) * (z - c))"
   have *: "part_circlepath c r pi (2*pi) = part_circlepath c r (3*pi/2 + (-pi/2)) (3*pi/2 + pi/2)"
     by simp
   have "path_image (part_circlepath c r pi (2 * pi)) =
           ?f ` sphere c r \<inter> ?f ` {s. Re c \<le> Re s}"
     unfolding * part_circlepath_rotate_left path_image_compose path_image_semicircle_Re_ge[OF assms]
     by auto
   also have "?f ` sphere c r = sphere c r"
     by (rule sphere_rotate)
   also have "cis (3 * pi / 2) = -\<i>"
     using cis_mult[of pi "pi / 2"] by simp
   hence "?f ` {s. Re c \<le> Re s} = {s. Im c \<ge> Im s}"
     by (auto simp: image_iff intro!: exI[of _ "c + \<i> * (x - c)" for x])
   finally show ?thesis .
 qed
 
 lemma powr_numeral [simp]: "x \<ge> 0 \<Longrightarrow> (x::real) powr numeral y = x ^ numeral y"
   using powr_numeral[of x y] by (cases "x = 0") auto
 
 lemma eval_fds_logderiv_zeta_real:
   assumes "x > (1 :: real)"
   shows  "(\<lambda>p. ln (real p) / (p powr x - 1)) abs_summable_on {p. prime p}" (is ?th1)
     and  "deriv zeta (of_real x) / zeta (of_real x) =
             -of_real (\<Sum>\<^sub>ap | prime p. ln (real p) / (p powr x - 1))" (is ?th2)
 proof -
   have "(\<lambda>p. Re (of_real (ln (real p)) / (of_nat p powr of_real x - 1)))
           abs_summable_on {p. prime p}" using assms
     by (intro abs_summable_Re eval_fds_logderiv_zeta) auto
   also have "?this \<longleftrightarrow> ?th1"
     by (intro abs_summable_on_cong) (auto simp: powr_Reals_eq)
   finally show ?th1 .
   show ?th2 using assms
     by (subst eval_fds_logderiv_zeta) (auto simp: infsetsum_of_real [symmetric] powr_Reals_eq)
 qed
 
 lemma
   fixes a b c d :: real
   assumes ab: "d * a + b \<ge> 1" and c: "c < -1" and d: "d > 0"
   defines "C \<equiv> - ((ln (d * a + b) - 1 / (c + 1)) * (d * a + b) powr (c + 1) / (d * (c + 1)))"
   shows set_integrable_ln_powr_at_top:
           "(\<lambda>x. (ln (d * x + b) * ((d * x + b) powr c))) absolutely_integrable_on {a<..}" (is ?th1)
   and   set_lebesgue_integral_ln_powr_at_top:
           "(\<integral>x\<in>{a<..}. (ln (d * x + b) * ((d * x + b) powr c)) \<partial>lborel) = C" (is ?th2)
   and   ln_powr_has_integral_at_top:
           "((\<lambda>x. ln (d * x + b) * (d * x + b) powr c) has_integral C) {a<..}" (is ?th3)
 proof -
   define f where "f = (\<lambda>x. ln (d * x + b) * (d * x + b) powr c)"
   define F where "F = (\<lambda>x. (ln (d * x + b) - 1 / (c + 1)) * (d * x + b) powr (c + 1) / (d * (c + 1)))"
 
   have *: "(F has_field_derivative f x) (at x)" "isCont f x" "f x \<ge> 0" if "x > a" for x
   proof -
     have "1 \<le> d * a + b" by fact
     also have "\<dots> < d * x + b" using that assms
       by (intro add_strict_right_mono mult_strict_left_mono)
     finally have gt_1: "d * x + b > 1" .
     show "(F has_field_derivative f x) (at x)" "isCont f x" using ab c d gt_1
     by (auto simp: F_def f_def divide_simps intro!: derivative_eq_intros continuous_intros)
        (auto simp: algebra_simps powr_add)?
     show "f x \<ge> 0" using gt_1 by (auto simp: f_def)
   qed
 
   have limits: "((F \<circ> real_of_ereal) \<longlongrightarrow> F a) (at_right (ereal a))"
                "((F \<circ> real_of_ereal) \<longlongrightarrow> 0) (at_left \<infinity>)"
     using c ab d unfolding ereal_tendsto_simps1 F_def  by (real_asymp; simp add: field_simps)+
   have 1: "set_integrable lborel (einterval a \<infinity>) f" using ab c limits
     by (intro interval_integral_FTC_nonneg) (auto intro!: * AE_I2)
   thus 2: "f absolutely_integrable_on {a<..}"
     by (auto simp: set_integrable_def integrable_completion)
   have "(LBINT x=ereal a..\<infinity>. f x) = 0 - F a" using ab c limits
     by (intro interval_integral_FTC_nonneg) (auto intro!: *)
   thus 3: ?th2
     by (simp add: interval_integral_to_infinity_eq F_def f_def C_def)
   show ?th3
     using set_borel_integral_eq_integral[OF 1] 3 by (simp add: has_integral_iff f_def C_def)
 qed
 
 lemma ln_fact_conv_sum_upto: "ln (fact n) = sum_upto ln n"
   by (induction n) (auto simp: sum_upto_plus1 add.commute[of 1] ln_mult)
 
 lemma sum_upto_ln_conv_ln_fact: "sum_upto ln x = ln (fact (nat \<lfloor>x\<rfloor>))"
   by (simp add: ln_fact_conv_sum_upto sum_upto_altdef)
 
 lemma real_of_nat_div: "real (a div b) = real_of_int \<lfloor>real a / real b\<rfloor>"
   by (subst floor_divide_of_nat_eq) auto
 
 lemma integral_subset_negligible:
   fixes f :: "'a :: euclidean_space \<Rightarrow> 'b :: banach"
   assumes "S \<subseteq> T" "negligible (T - S)"
   shows   "integral S f = integral T f"
 proof -
   have "integral T f = integral T (\<lambda>x. if x \<in> S then f x else 0)"
     by (rule integral_spike[of "T - S"]) (use assms in auto)
   also have "\<dots> = integral (S \<inter> T) f"
     by (subst integral_restrict_Int) auto
   also have "S \<inter> T = S" using assms by auto
   finally show ?thesis ..
 qed
 
 lemma integrable_on_cong [cong]:
   assumes "\<And>x. x \<in> A \<Longrightarrow> f x = g x" "A = B"
   shows   "f integrable_on A \<longleftrightarrow> g integrable_on B"
   using has_integral_cong[of A f g, OF assms(1)] assms(2)
   by (auto simp: integrable_on_def)
 
 lemma measurable_sum_upto [measurable]:
   fixes f :: "'a \<Rightarrow> nat \<Rightarrow> real"
   assumes [measurable]: "\<And>y. (\<lambda>t. f t y) \<in> M \<rightarrow>\<^sub>M borel"
   assumes [measurable]: "x \<in> M \<rightarrow>\<^sub>M borel"
   shows "(\<lambda>t. sum_upto (f t) (x t)) \<in> M \<rightarrow>\<^sub>M borel"
 proof -
   have meas: "(\<lambda>t. set_lebesgue_integral lborel {y. y \<ge> 0 \<and> y - real (nat \<lfloor>x t\<rfloor>) \<le> 0} (\<lambda>y. f t (nat \<lceil>y\<rceil>)))
           \<in> M \<rightarrow>\<^sub>M borel" (is "?f \<in> _") unfolding set_lebesgue_integral_def
     by measurable
   also have "?f = (\<lambda>t. sum_upto (f t) (x t))"
   proof
     fix t :: 'a
     show "?f t = sum_upto (f t) (x t)"
     proof (cases "x t < 1")
       case True
       hence "{y. y \<ge> 0 \<and> y - real (nat \<lfloor>x t\<rfloor>) \<le> 0} = {0}" by auto
       thus ?thesis using True
         by (simp add: set_integral_at_point sum_upto_altdef)
     next
       case False
       define n where "n = nat \<lfloor>x t\<rfloor>"
       from False have "n > 0" by (auto simp: n_def)
 
       have *: "((\<lambda>x. f t (nat \<lceil>x\<rceil>)) has_integral sum (f t) {0<..n}) {real 0..real n}"
         using \<open>n > 0\<close> by (intro nat_sum_has_integral_ceiling) auto
 
       have **: "(\<lambda>x. f t (nat \<lceil>x\<rceil>)) absolutely_integrable_on {real 0..real n}"
       proof (rule absolutely_integrable_absolutely_integrable_ubound)
         show "(\<lambda>_. MAX n\<in>{0..n}. \<bar>f t n\<bar>) absolutely_integrable_on {real 0..real n}"
           using \<open>n > 0\<close> by (subst absolutely_integrable_on_iff_nonneg)
                            (auto simp: Max_ge_iff intro!: exI[of _ "f t 0"])
         show "(\<lambda>x. f t (nat \<lceil>x\<rceil>)) integrable_on {real 0..real n}"
           using * by (simp add: has_integral_iff)
       next
         fix y :: real assume y: "y \<in> {real 0..real n}"
         have "f t (nat \<lceil>y\<rceil>) \<le> \<bar>f t (nat \<lceil>y\<rceil>)\<bar>"
           by simp
         also have "\<dots> \<le> (MAX n\<in>{0..n}. \<bar>f t n\<bar>)"
           using y by (intro Max.coboundedI) auto
         finally show "f t (nat \<lceil>y\<rceil>) \<le> (MAX n\<in>{0..n}. \<bar>f t n\<bar>)" .
       qed
       have "sum (f t) {0<..n} = (\<integral>x\<in>{real 0..real n}. f t (nat \<lceil>x\<rceil>) \<partial>lebesgue)"
         using has_integral_set_lebesgue[OF **] * by (simp add: has_integral_iff)
       also have "\<dots> = (\<integral>x\<in>{real 0..real n}. f t (nat \<lceil>x\<rceil>) \<partial>lborel)"
         unfolding set_lebesgue_integral_def by (subst integral_completion) auto
       also have "{real 0..real n} = {y. 0 \<le> y \<and> y - real (nat \<lfloor>x t\<rfloor>) \<le> 0}"
         by (auto simp: n_def)
       also have "sum (f t) {0<..n} = sum_upto (f t) (x t)"
         by (simp add: sum_upto_altdef n_def)
       finally show ?thesis ..
     qed
   qed
   finally show ?thesis .
 qed
 
 end
diff --git a/thys/Probabilistic_Timed_Automata/ROOT b/thys/Probabilistic_Timed_Automata/ROOT
--- a/thys/Probabilistic_Timed_Automata/ROOT
+++ b/thys/Probabilistic_Timed_Automata/ROOT
@@ -1,17 +1,18 @@
 chapter AFP
 
 session Probabilistic_Timed_Automata (AFP) = "Markov_Models" +
   options [timeout = 1200]
   sessions
+    "Pure-ex"
     "Timed_Automata"
     "HOL-Eisbach"
   directories
     "library"
   theories [document = false]
     "library/Lib"
   theories
     "PTA"
     "PTA_Reachability"
   document_files
     "root.tex"
     "root.bib"
diff --git a/thys/Probabilistic_Timed_Automata/library/Graphs.thy b/thys/Probabilistic_Timed_Automata/library/Graphs.thy
--- a/thys/Probabilistic_Timed_Automata/library/Graphs.thy
+++ b/thys/Probabilistic_Timed_Automata/library/Graphs.thy
@@ -1,1362 +1,1365 @@
 (* Author: Simon Wimmer *)
 theory Graphs
   imports
     More_List Stream_More
     "HOL-Library.Rewrite"
     Instantiate_Existentials
 begin
 
 section \<open>Graphs\<close>
 
 subsection \<open>Basic Definitions and Theorems\<close>
 
 locale Graph_Defs =
   fixes E :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
 begin
 
 inductive steps where
   Single: "steps [x]" |
   Cons: "steps (x # y # xs)" if "E x y" "steps (y # xs)"
 
 lemmas [intro] = steps.intros
 
 lemma steps_append:
   "steps (xs @ tl ys)" if "steps xs" "steps ys" "last xs = hd ys"
   using that by induction (auto 4 4 elim: steps.cases)
 
 lemma steps_append':
   "steps xs" if "steps as" "steps bs" "last as = hd bs" "as @ tl bs = xs"
   using steps_append that by blast
 
 coinductive run where
   "run (x ## y ## xs)" if "E x y" "run (y ## xs)"
 
 lemmas [intro] = run.intros
 
 lemma steps_appendD1:
   "steps xs" if "steps (xs @ ys)" "xs \<noteq> []"
   using that proof (induction xs)
   case Nil
   then show ?case by auto
 next
   case (Cons a xs)
   then show ?case
     by - (cases xs; auto elim: steps.cases)
 qed
 
 lemma steps_appendD2:
   "steps ys" if "steps (xs @ ys)" "ys \<noteq> []"
   using that by (induction xs) (auto elim: steps.cases)
 
 lemma steps_appendD3:
   "steps (xs @ [x]) \<and> E x y" if "steps (xs @ [x, y])"
   using that proof (induction xs)
   case Nil
   then show ?case by (auto elim!: steps.cases)
 next
   case prems: (Cons a xs)
   then show ?case by (cases xs) (auto elim: steps.cases)
 qed
 
 lemma steps_ConsD:
   "steps xs" if "steps (x # xs)" "xs \<noteq> []"
   using that by (auto elim: steps.cases)
 
 lemmas stepsD = steps_ConsD steps_appendD1 steps_appendD2
 
 lemma steps_alt_induct[consumes 1, case_names Single Snoc]:
   assumes
     "steps x" "(\<And>x. P [x])"
     "\<And>y x xs. E y x \<Longrightarrow> steps (xs @ [y]) \<Longrightarrow> P (xs @ [y]) \<Longrightarrow> P (xs @ [y,x])"
   shows "P x"
   using assms(1)
   proof (induction rule: rev_induct)
     case Nil
     then show ?case by (auto elim: steps.cases)
   next
     case prems: (snoc x xs)
     then show ?case by (cases xs rule: rev_cases) (auto intro: assms(2,3) dest!: steps_appendD3)
   qed
 
 lemma steps_appendI:
   "steps (xs @ [x, y])" if "steps (xs @ [x])" "E x y"
   using that
 proof (induction xs)
   case Nil
   then show ?case by auto
 next
   case (Cons a xs)
   then show ?case by (cases xs; auto elim: steps.cases)
 qed
 
 lemma steps_append_single:
   assumes
     "steps xs" "E (last xs) x" "xs \<noteq> []"
   shows "steps (xs @ [x])"
   using assms(3,1,2) by (induction xs rule: list_nonempty_induct) (auto 4 4 elim: steps.cases)
 
 lemma extend_run:
   assumes
     "steps xs" "E (last xs) x" "run (x ## ys)" "xs \<noteq> []"
   shows "run (xs @- x ## ys)"
   using assms(4,1-3) by (induction xs rule: list_nonempty_induct) (auto 4 3 elim: steps.cases)
 
 lemma run_cycle:
   assumes "steps xs" "E (last xs) (hd xs)" "xs \<noteq> []"
   shows "run (cycle xs)"
   using assms proof (coinduction arbitrary: xs)
   case run
   then show ?case
     apply (rewrite at \<open>cycle xs\<close> stream.collapse[symmetric])
     apply (rewrite at \<open>stl (cycle xs)\<close> stream.collapse[symmetric])
     apply clarsimp
     apply (erule steps.cases)
     subgoal for x
       apply (rule conjI)
        apply (simp; fail)
       apply (rule disjI1)
       apply (inst_existentials xs)
          apply (simp, metis cycle_Cons[of x "[]", simplified])
       by auto
     subgoal for x y xs'
       apply (rule conjI)
        apply (simp; fail)
       apply (rule disjI1)
       apply (inst_existentials "y # xs' @ [x]")
       using steps_append_single[of "y # xs'" x]
          apply (auto elim: steps.cases split: if_split_asm)
        apply (subst (2) cycle_Cons, simp) (* XXX Automate forward reasoning *)
       apply (subst cycle_Cons, simp)
       done
     done
 qed
 
 lemma run_stl:
   "run (stl xs)" if "run xs"
   using that by (auto elim: run.cases)
 
 lemma run_sdrop:
   "run (sdrop n xs)" if "run xs"
   using that by (induction n arbitrary: xs) (auto intro: run_stl)
 
 lemma run_reachable':
   assumes "run (x ## xs)" "E\<^sup>*\<^sup>* x\<^sub>0 x"
   shows "pred_stream (\<lambda> x. E\<^sup>*\<^sup>* x\<^sub>0 x) xs"
   using assms by (coinduction arbitrary: x xs) (auto 4 3 elim: run.cases)
 
 lemma run_reachable:
   assumes "run (x\<^sub>0 ## xs)"
   shows "pred_stream (\<lambda> x. E\<^sup>*\<^sup>* x\<^sub>0 x) xs"
   by (rule run_reachable'[OF assms]) blast
 
 lemma run_decomp:
   assumes "run (xs @- ys)" "xs \<noteq> []"
   shows "steps xs \<and> run ys \<and> E (last xs) (shd ys)"
 using assms(2,1) proof (induction xs rule: list_nonempty_induct)
   case (single x)
   then show ?case by (auto elim: run.cases)
 next
   case (cons x xs)
   then show ?case by (cases xs; auto 4 4 elim: run.cases)
 qed
 
 lemma steps_decomp:
   assumes "steps (xs @ ys)" "xs \<noteq> []" "ys \<noteq> []"
   shows "steps xs \<and> steps ys \<and> E (last xs) (hd ys)"
 using assms(2,1,3) proof (induction xs rule: list_nonempty_induct)
   case (single x)
   then show ?case by (auto elim: steps.cases)
 next
   case (cons x xs)
   then show ?case by (cases xs; auto 4 4 elim: steps.cases)
 qed
 
 lemma steps_rotate:
   assumes "steps (x # xs @ y # ys @ [x])"
   shows "steps (y # ys @ x # xs @ [y])"
 proof -
   from steps_decomp[of "x # xs" "y # ys @ [x]"] assms have
     "steps (x # xs)" "steps (y # ys @ [x])" "E (last (x # xs)) y"
     by auto
   then have "steps ((x # xs) @ [y])" by (blast intro: steps_append_single)
   from steps_append[OF \<open>steps (y # ys @ [x])\<close> this] show ?thesis by auto
 qed
 
 lemma run_shift_coinduct[case_names run_shift, consumes 1]:
   assumes "R w"
       and "\<And> w. R w \<Longrightarrow> \<exists> u v x y. w = u @- x ## y ## v \<and> steps (u @ [x]) \<and> E x y \<and> R (y ## v)"
   shows "run w"
   using assms(2)[OF \<open>R w\<close>] proof (coinduction arbitrary: w)
   case (run w)
   then obtain u v x y where "w = u @- x ## y ## v" "steps (u @ [x])" "E x y" "R (y ## v)"
     by auto
   then show ?case
     apply -
     apply (drule assms(2))
     apply (cases u)
      apply force
     subgoal for z zs
       apply (cases zs)
       subgoal
         apply simp
         apply safe
          apply (force elim: steps.cases)
         subgoal for u' v' x' y'
           by (inst_existentials "x # u'") (cases u'; auto)
         done
       subgoal for a as
         apply simp
         apply safe
          apply (force elim: steps.cases)
         subgoal for u' v' x' y'
           apply (inst_existentials "a # as @ x # u'")
           using steps_append[of "a # as @ [x, y]" "u' @ [x']"]
           apply simp
           apply (drule steps_appendI[of "a # as" x, rotated])
           by (cases u'; force elim: steps.cases)+
         done
       done
     done
 qed
 
 lemma run_flat_coinduct[case_names run_shift, consumes 1]:
   assumes "R xss"
     and
     "\<And> xs ys xss.
     R (xs ## ys ## xss) \<Longrightarrow> xs \<noteq> [] \<and> steps xs \<and> E (last xs) (hd ys) \<and> R (ys ## xss)"
   shows "run (flat xss)"
 proof -
   obtain xs ys xss' where "xss = xs ## ys ## xss'" by (metis stream.collapse)
   with assms(2)[OF assms(1)[unfolded this]] show ?thesis
   proof (coinduction arbitrary: xs ys xss' xss rule: run_shift_coinduct)
     case (run_shift xs ys xss' xss)
     from run_shift show ?case
       apply (cases xss')
       apply clarify
       apply (drule assms(2))
       apply (inst_existentials "butlast xs" "tl ys @- flat xss'" "last xs" "hd ys")
          apply (cases ys)
           apply (simp; fail)
       subgoal premises prems for x1 x2 z zs
       proof (cases "xs = []")
         case True
         with prems show ?thesis
           by auto
       next
         case False
         then have "xs = butlast xs @ [last xs]" by auto
         then have "butlast xs @- last xs ## tail = xs @- tail" for tail
           by (metis shift.simps(1,2) shift_append)
         with prems show ?thesis by simp
       qed
         apply (simp; fail)
        apply assumption
       subgoal for ws wss
         by (inst_existentials ys ws wss) (cases ys, auto)
       done
   qed
 qed
 
 lemma steps_non_empty[simp]:
   "\<not> steps []"
   by (auto elim: steps.cases)
 
 lemma steps_non_empty'[simp]:
   "xs \<noteq> []" if "steps xs"
   using that by auto
 
 (* XXX Generalize *)
 lemma steps_replicate:
   "steps (hd xs # concat (replicate n (tl xs)))" if "last xs = hd xs" "steps xs" "n > 0"
   using that
 proof (induction n)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   show ?case
   proof (cases n)
     case 0
     with Suc.prems show ?thesis by (cases xs; auto)
   next
     case prems: (Suc nat)
     from Suc.prems have [simp]: "hd xs # tl xs @ ys = xs @ ys" for ys
       by (cases xs; auto)
     from Suc.prems have **: "tl xs @ ys = tl (xs @ ys)" for ys
       by (cases xs; auto)
     from prems Suc show ?thesis
       by (fastforce intro: steps_append')
   qed
 qed
 
 notation E ("_ \<rightarrow> _" [100, 100] 40)
 
 abbreviation reaches ("_ \<rightarrow>* _" [100, 100] 40) where "reaches x y \<equiv> E\<^sup>*\<^sup>* x y"
 
 abbreviation reaches1 ("_ \<rightarrow>\<^sup>+ _" [100, 100] 40) where "reaches1 x y \<equiv> E\<^sup>+\<^sup>+ x y"
 
 lemma steps_reaches:
   "hd xs \<rightarrow>* last xs" if "steps xs"
   using that by (induction xs) auto
 
 lemma steps_reaches':
   "x \<rightarrow>* y" if "steps xs" "hd xs = x" "last xs = y"
   using that steps_reaches by auto
 
 lemma reaches_steps:
   "\<exists> xs. hd xs = x \<and> last xs = y \<and> steps xs" if "x \<rightarrow>* y"
   using that
   apply (induction)
    apply force
   apply clarsimp
   subgoal for z xs
     by (inst_existentials "xs @ [z]", (cases xs; simp), auto intro: steps_append_single)
   done
 
 lemma reaches_steps_iff:
   "x \<rightarrow>* y \<longleftrightarrow> (\<exists> xs. hd xs = x \<and> last xs = y \<and> steps xs)"
   using steps_reaches reaches_steps by fast
 
 lemma steps_reaches1:
   "x \<rightarrow>\<^sup>+ y" if "steps (x # xs @ [y])"
   by (metis list.sel(1,3) rtranclp_into_tranclp2 snoc_eq_iff_butlast steps.cases steps_reaches that)
 
 lemma stepsI:
   "steps (x # xs)" if "x \<rightarrow> hd xs" "steps xs"
   using that by (cases xs) auto
 
 lemma reaches1_steps:
   "\<exists> xs. steps (x # xs @ [y])" if "x \<rightarrow>\<^sup>+ y"
 proof -
   from that obtain z where "x \<rightarrow> z" "z \<rightarrow>* y"
     by atomize_elim (simp add: tranclpD)
   from reaches_steps[OF this(2)] obtain xs where *: "hd xs = z" "last xs = y" "steps xs"
     by auto
   then obtain xs' where [simp]: "xs = xs' @ [y]"
     by atomize_elim (auto 4 3 intro: append_butlast_last_id[symmetric])
   with \<open>x \<rightarrow> z\<close> * show ?thesis
     by (auto intro: stepsI)
 qed
 
 lemma reaches1_steps_iff:
   "x \<rightarrow>\<^sup>+ y \<longleftrightarrow> (\<exists> xs. steps (x # xs @ [y]))"
   using steps_reaches1 reaches1_steps by fast
 
 lemma reaches1_reaches_iff1:
   "x \<rightarrow>\<^sup>+ y \<longleftrightarrow> (\<exists> z. x \<rightarrow> z \<and> z \<rightarrow>* y)"
   by (auto dest: tranclpD)
 
 lemma reaches1_reaches_iff2:
   "x \<rightarrow>\<^sup>+ y \<longleftrightarrow> (\<exists> z. x \<rightarrow>* z \<and> z \<rightarrow> y)"
   apply safe
    apply (metis Nitpick.rtranclp_unfold tranclp.cases)
   by auto
 
 lemma
   "x \<rightarrow>\<^sup>+ z" if "x \<rightarrow>* y" "y \<rightarrow>\<^sup>+ z"
   using that by auto
 
 lemma
   "x \<rightarrow>\<^sup>+ z" if "x \<rightarrow>\<^sup>+ y" "y \<rightarrow>* z"
   using that by auto
 
 lemma steps_append2:
   "steps (xs @ x # ys)" if "steps (xs @ [x])" "steps (x # ys)"
   using that by (auto dest: steps_append)
 
 lemma reaches1_steps_append:
   assumes "a \<rightarrow>\<^sup>+ b" "steps xs" "hd xs = b"
   shows "\<exists> ys. steps (a # ys @ xs)"
   using assms by (fastforce intro: steps_append' dest: reaches1_steps)
 
 lemma steps_last_step:
   "\<exists> a. a \<rightarrow> last xs" if "steps xs" "length xs > 1"
   using that by induction auto
 
 lemmas graphI =
   steps.intros
   steps_append_single
   steps_reaches'
   stepsI
 
 end (* Graph Defs *)
 
 
 subsection \<open>Graphs with a Start Node\<close>
 
 locale Graph_Start_Defs = Graph_Defs +
   fixes s\<^sub>0 :: 'a
 begin
 
 definition reachable where
   "reachable = E\<^sup>*\<^sup>* s\<^sub>0"
 
 lemma start_reachable[intro!, simp]:
   "reachable s\<^sub>0"
   unfolding reachable_def by auto
 
 lemma reachable_step:
   "reachable b" if "reachable a" "E a b"
   using that unfolding reachable_def by auto
 
 lemma reachable_reaches:
   "reachable b" if "reachable a" "a \<rightarrow>* b"
   using that(2,1) by induction (auto intro: reachable_step)
 
 lemma reachable_steps_append:
   assumes "reachable a" "steps xs" "hd xs = a" "last xs = b"
   shows "reachable b"
   using assms by (auto intro: graphI reachable_reaches)
 
 lemmas steps_reachable = reachable_steps_append[of s\<^sub>0, simplified]
 
 lemma reachable_steps_elem:
   "reachable y" if "reachable x" "steps xs" "y \<in> set xs" "hd xs = x"
 proof -
   from \<open>y \<in> set xs\<close> obtain as bs where [simp]: "xs = as @ y # bs"
     by (auto simp: in_set_conv_decomp)
   show ?thesis
   proof (cases "as = []")
     case True
     with that show ?thesis
       by simp
   next
     case False
     (* XXX *)
     from \<open>steps xs\<close> have "steps (as @ [y])"
       by (auto intro: stepsD)
     with \<open>as \<noteq> []\<close> \<open>hd xs = x\<close> \<open>reachable x\<close> show ?thesis
       by (auto 4 3 intro: reachable_reaches graphI)
   qed
 qed
 
 lemma reachable_steps:
   "\<exists> xs. steps xs \<and> hd xs = s\<^sub>0 \<and> last xs = x" if "reachable x"
   using that unfolding reachable_def
 proof induction
   case base
   then show ?case by (inst_existentials "[s\<^sub>0]"; force)
 next
   case (step y z)
-  from step.IH guess xs by clarify
+  from step.IH obtain xs where "steps xs" "s\<^sub>0 = hd xs" "y = last xs"
+    by auto
   with step.hyps show ?case
     apply (inst_existentials "xs @ [z]")
     apply (force intro: graphI)
     by (cases xs; auto)+
 qed
 
 lemma reachable_cycle_iff:
   "reachable x \<and> x \<rightarrow>\<^sup>+ x \<longleftrightarrow> (\<exists> ws xs. steps (s\<^sub>0 # ws @ [x] @ xs @ [x]))"
 proof (safe, goal_cases)
   case (2 ws)
   then show ?case
     by (auto intro: steps_reachable stepsD)
 next
   case (3 ws xs)
   then show ?case
     by (auto intro: stepsD steps_reaches1)
 next
   case prems: 1
   from \<open>reachable x\<close> prems(2) have "s\<^sub>0 \<rightarrow>\<^sup>+ x"
     unfolding reachable_def by auto
   with \<open>x \<rightarrow>\<^sup>+ x\<close> show ?case
     by (fastforce intro: steps_append' dest: reaches1_steps)
 qed
 
 lemma reachable_induct[consumes 1, case_names start step, induct pred: reachable]:
   assumes "reachable x"
     and "P s\<^sub>0"
     and "\<And> a b. reachable a \<Longrightarrow> P a \<Longrightarrow> a \<rightarrow> b \<Longrightarrow> P b"
   shows "P x"
   using assms(1) unfolding reachable_def
   by induction (auto intro: assms(2-)[unfolded reachable_def])
 
 lemmas graphI_aggressive =
   tranclp_into_rtranclp
   rtranclp.rtrancl_into_rtrancl
   tranclp.trancl_into_trancl
   rtranclp_into_tranclp2
 
 lemmas graphI_aggressive1 =
   graphI_aggressive
   steps_append'
 
 lemmas graphI_aggressive2 =
   graphI_aggressive
   stepsD
   steps_reaches1
   steps_reachable
 
 lemmas graphD =
   reaches1_steps
 
 lemmas graphD_aggressive =
   tranclpD
 
 lemmas graph_startI =
   reachable_reaches
   start_reachable
 
 end (* Graph Start Defs *)
 
 
 subsection \<open>Subgraphs\<close>
 
 subsubsection \<open>Edge-induced Subgraphs\<close>
 
 locale Subgraph_Defs = G: Graph_Defs +
   fixes E' :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
 begin
 
 sublocale G': Graph_Defs E' .
 
 end (* Subgraph Defs *)
 
 locale Subgraph_Start_Defs = G: Graph_Start_Defs +
   fixes E' :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
 begin
 
 sublocale G': Graph_Start_Defs E' s\<^sub>0 .
 
 end (* Subgraph Start Defs *)
 
 locale Subgraph = Subgraph_Defs +
   assumes subgraph[intro]: "E' a b \<Longrightarrow> E a b"
 begin
 
 lemma non_subgraph_cycle_decomp:
   "\<exists> c d. G.reaches a c \<and> E c d \<and> \<not> E' c d \<and> G.reaches d b" if
   "G.reaches1 a b" "\<not> G'.reaches1 a b" for a b
     using that
   proof induction
     case (base y)
     then show ?case
       by auto
   next
     case (step y z)
     show ?case
     proof (cases "E' y z")
       case True
       with step have "\<not> G'.reaches1 a y"
         by (auto intro: tranclp.trancl_into_trancl) (* XXX *)
       with step obtain c d where
         "G.reaches a c" "E c d" "\<not> E' c d" "G.reaches d y"
         by auto
       with \<open>E' y z\<close> show ?thesis
         by (blast intro: rtranclp.rtrancl_into_rtrancl) (* XXX *)
     next
       case False
       with step show ?thesis
         by (intro exI conjI) auto
     qed
   qed
 
 lemma reaches:
   "G.reaches a b" if "G'.reaches a b"
   using that by induction (auto intro: rtranclp.intros(2))
 
 lemma reaches1:
   "G.reaches1 a b" if "G'.reaches1 a b"
   using that by induction (auto intro: tranclp.intros(2))
 
 end (* Subgraph *)
 
 locale Subgraph_Start = Subgraph_Start_Defs + Subgraph
 begin
 
 lemma reachable_subgraph[intro]: "G.reachable b" if \<open>G.reachable a\<close> \<open>G'.reaches a b\<close> for a b
   using that by (auto intro: G.graph_startI mono_rtranclp[rule_format, of E'])
 
 lemma reachable:
   "G.reachable x" if "G'.reachable x"
   using that by (fastforce simp: G.reachable_def G'.reachable_def)
 
 end (* Subgraph Start *)
 
 subsubsection \<open>Node-induced Subgraphs\<close>
 
 locale Subgraph_Node_Defs = Graph_Defs +
   fixes V :: "'a \<Rightarrow> bool"
 begin
 
 definition E' where "E' x y \<equiv> E x y \<and> V x \<and> V y"
 
 sublocale Subgraph E E' by standard (auto simp: E'_def)
 
 lemma subgraph':
   "E' x y" if "E x y" "V x" "V y"
   using that unfolding E'_def by auto
 
 lemma E'_V1:
   "V x" if "E' x y"
   using that unfolding E'_def by auto
 
 lemma E'_V2:
   "V y" if "E' x y"
   using that unfolding E'_def by auto
 
 lemma G'_reaches_V:
   "V y" if "G'.reaches x y" "V x"
   using that by (cases) (auto intro: E'_V2)
 
 lemma G'_steps_V_all:
   "list_all V xs" if "G'.steps xs" "V (hd xs)"
   using that by induction (auto intro: E'_V2)
 
 lemma G'_steps_V_last:
   "V (last xs)" if "G'.steps xs" "V (hd xs)"
   using that by induction (auto dest: E'_V2)
 
 lemmas subgraphI = E'_V1 E'_V2 G'_reaches_V
 
 lemmas subgraphD = E'_V1 E'_V2 G'_reaches_V
 
 end (* Subgraph Node *)
 
 
 locale Subgraph_Node_Defs_Notation = Subgraph_Node_Defs
 begin
 
 no_notation E ("_ \<rightarrow> _" [100, 100] 40)
 notation E' ("_ \<rightarrow> _" [100, 100] 40)
 no_notation reaches ("_ \<rightarrow>* _" [100, 100] 40)
 notation G'.reaches ("_ \<rightarrow>* _" [100, 100] 40)
 no_notation reaches1 ("_ \<rightarrow>\<^sup>+ _" [100, 100] 40)
 notation G'.reaches1 ("_ \<rightarrow>\<^sup>+ _" [100, 100] 40)
 
 end (* Subgraph_Node_Defs_Notation *)
 
 
 subsubsection \<open>The Reachable Subgraph\<close>
 
 context Graph_Start_Defs
 begin
 
 interpretation Subgraph_Node_Defs_Notation E reachable .
 
 sublocale reachable_subgraph: Subgraph_Node_Defs E reachable .
 
 lemma reachable_supgraph:
   "x \<rightarrow> y" if "E x y" "reachable x"
   using that unfolding E'_def by (auto intro: graph_startI)
 
 lemma reachable_reaches_equiv: "reaches x y \<longleftrightarrow> x \<rightarrow>* y" if "reachable x" for x y
   apply standard
   subgoal premises prems
     using prems \<open>reachable x\<close>
     by induction (auto dest: reachable_supgraph intro: graph_startI graphI_aggressive)
   subgoal premises prems
     using prems \<open>reachable x\<close>
     by induction (auto dest: subgraph)
   done
 
 lemma reachable_reaches1_equiv: "reaches1 x y \<longleftrightarrow> x \<rightarrow>\<^sup>+ y" if "reachable x" for x y
   apply standard
   subgoal premises prems
     using prems \<open>reachable x\<close>
     by induction (auto dest: reachable_supgraph intro: graph_startI graphI_aggressive)
   subgoal premises prems
     using prems \<open>reachable x\<close>
     by induction (auto dest: subgraph)
   done
 
 lemma reachable_steps_equiv:
   "steps (x # xs) \<longleftrightarrow> G'.steps (x # xs)" if "reachable x"
   apply standard
   subgoal premises prems
     using prems \<open>reachable x\<close>
     by (induction "x # xs" arbitrary: x xs) (auto dest: reachable_supgraph intro: graph_startI)
   subgoal premises prems
     using prems by induction auto
   done
 
 end (* Graph Start Defs *)
 
 
 subsection \<open>Bundles\<close>
 
 bundle graph_automation
 begin
 
 lemmas [intro] = Graph_Defs.graphI Graph_Start_Defs.graph_startI
 lemmas [dest]  = Graph_Start_Defs.graphD
 
 end (* Bundle *)
 
 bundle reaches_steps_iff =
   Graph_Defs.reaches1_steps_iff [iff]
   Graph_Defs.reaches_steps_iff  [iff]
 
 bundle graph_automation_aggressive
 begin
 
 unbundle graph_automation
 
 lemmas [intro] = Graph_Start_Defs.graphI_aggressive
 lemmas [dest]  = Graph_Start_Defs.graphD_aggressive
 
 end (* Bundle *)
 
 bundle subgraph_automation
 begin
 
 unbundle graph_automation
 
 lemmas [intro] = Subgraph_Node_Defs.subgraphI
 lemmas [dest]  = Subgraph_Node_Defs.subgraphD
 
 end (* Bundle *)
 
 
 subsection \<open>Simulations and Bisimulations\<close>
 
 locale Graph_Invariant = Graph_Defs +
   fixes P :: "'a \<Rightarrow> bool"
   assumes invariant: "P a \<Longrightarrow> a \<rightarrow> b \<Longrightarrow> P b"
 begin
 
 lemma invariant_steps:
   "list_all P as" if "steps (a # as)" "P a"
   using that by (induction "a # as" arbitrary: as a) (auto intro: invariant)
 
 lemma invariant_reaches:
   "P b" if "a \<rightarrow>* b" "P a"
   using that by (induction; blast intro: invariant)
 
 lemma invariant_run:
   assumes run: "run (x ## xs)" and P: "P x"
   shows "pred_stream P (x ## xs)"
   using run P by (coinduction arbitrary: x xs) (auto 4 3 elim: invariant run.cases)
 
 end (* Graph Invariant *)
 
 locale Graph_Invariants = Graph_Defs +
   fixes P Q :: "'a \<Rightarrow> bool"
   assumes invariant: "P a \<Longrightarrow> a \<rightarrow> b \<Longrightarrow> Q b" and Q_P: "Q a \<Longrightarrow> P a"
 begin
 
 sublocale Pre: Graph_Invariant E P
   by standard (blast intro: invariant Q_P)
 
 sublocale Post: Graph_Invariant E Q
   by standard (blast intro: invariant Q_P)
 
 lemma invariant_steps:
   "list_all Q as" if "steps (a # as)" "P a"
   using that by (induction "a # as" arbitrary: as a) (auto intro: invariant Q_P)
 
 lemma invariant_run:
   assumes run: "run (x ## xs)" and P: "P x"
   shows "pred_stream Q xs"
   using run P by (coinduction arbitrary: x xs) (auto 4 4 elim: invariant run.cases intro: Q_P)
 
 lemma invariant_reaches1:
   "Q b" if "a \<rightarrow>\<^sup>+ b" "P a"
   using that by (induction; blast intro: invariant Q_P)
 
 end (* Graph Invariants *)
 
 locale Graph_Invariant_Start = Graph_Start_Defs + Graph_Invariant +
   assumes P_s\<^sub>0: "P s\<^sub>0"
 begin
 
 lemma invariant_steps:
   "list_all P as" if "steps (s\<^sub>0 # as)"
   using that P_s\<^sub>0 by (rule invariant_steps)
 
 lemma invariant_reaches:
   "P b" if "s\<^sub>0 \<rightarrow>* b"
   using invariant_reaches[OF that P_s\<^sub>0] .
 
 lemmas invariant_run = invariant_run[OF _ P_s\<^sub>0]
 
 end (* Graph Invariant Start *)
 
 locale Graph_Invariant_Strong = Graph_Defs +
   fixes P :: "'a \<Rightarrow> bool"
   assumes invariant: "a \<rightarrow> b \<Longrightarrow> P b"
 begin
 
 sublocale inv: Graph_Invariant by standard (rule invariant)
 
 lemma P_invariant_steps:
   "list_all P as" if "steps (a # as)"
   using that by (induction "a # as" arbitrary: as a) (auto intro: invariant)
 
 lemma steps_last_invariant:
   "P (last xs)" if "steps (x # xs)" "xs \<noteq> []"
   using steps_last_step[of "x # xs"] that by (auto intro: invariant)
 
 lemmas invariant_reaches = inv.invariant_reaches
 
 lemma invariant_reaches1:
   "P b" if "a \<rightarrow>\<^sup>+ b"
   using that by (induction; blast intro: invariant)
 
 end (* Graph Invariant *)
 
 locale Simulation_Defs =
   fixes A :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and B :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
     and sim :: "'a \<Rightarrow> 'b \<Rightarrow> bool" (infixr "\<sim>" 60)
 begin
 
 sublocale A: Graph_Defs A .
 
 sublocale B: Graph_Defs B .
 
 end (* Simulation Defs *)
 
 locale Simulation = Simulation_Defs +
   assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
 begin
 
 lemma simulation_reaches:
   "\<exists> b'. B\<^sup>*\<^sup>* b b' \<and> a' \<sim> b'" if "A\<^sup>*\<^sup>* a a'" "a \<sim> b"
   using that by (induction rule: rtranclp_induct) (auto intro: rtranclp.intros(2) dest: A_B_step)
 
 lemma simulation_reaches1:
   "\<exists> b'. B\<^sup>+\<^sup>+ b b' \<and> a' \<sim> b'" if "A\<^sup>+\<^sup>+ a a'" "a \<sim> b"
   using that by (induction rule: tranclp_induct) (auto 4 3 intro: tranclp.intros(2) dest: A_B_step)
 
 lemma simulation_steps:
   "\<exists> bs. B.steps (b # bs) \<and> list_all2 (\<lambda> a b. a \<sim> b) as bs" if "A.steps (a # as)" "a \<sim> b"
   using that
   apply (induction "a # as" arbitrary: a b as)
    apply force
   apply (frule A_B_step, auto)
   done
 
 lemma simulation_run:
   "\<exists> ys. B.run (y ## ys) \<and> stream_all2 (\<sim>) xs ys" if "A.run (x ## xs)" "x \<sim> y"
 proof -
   let ?ys = "sscan (\<lambda> a' b. SOME b'. B b b' \<and> a' \<sim> b') xs y"
   have "B.run (y ## ?ys)"
     using that by (coinduction arbitrary: x y xs) (force dest!: someI_ex A_B_step elim: A.run.cases)
   moreover have "stream_all2 (\<sim>) xs ?ys"
     using that by (coinduction arbitrary: x y xs) (force dest!: someI_ex A_B_step elim: A.run.cases)
   ultimately show ?thesis by blast
 qed
 
 end (* Simulation *)
 
 lemma (in Subgraph) Subgraph_Simulation:
   "Simulation E' E (=)"
   by standard auto
 
 locale Simulation_Invariant = Simulation_Defs +
   fixes PA :: "'a \<Rightarrow> bool" and PB :: "'b \<Rightarrow> bool"
   assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
   assumes A_invariant[intro]: "\<And> a b. PA a \<Longrightarrow> A a b \<Longrightarrow> PA b"
   assumes B_invariant[intro]: "\<And> a b. PB a \<Longrightarrow> B a b \<Longrightarrow> PB b"
 begin
 
 definition "equiv' \<equiv> \<lambda> a b. a \<sim> b \<and> PA a \<and> PB b"
 
 sublocale Simulation A B equiv' by standard (auto dest: A_B_step simp: equiv'_def)
 
 sublocale PA_invariant: Graph_Invariant A PA by standard blast
 
 lemma simulation_reaches:
   "\<exists> b'. B\<^sup>*\<^sup>* b b' \<and> a' \<sim> b' \<and> PA a' \<and> PB b'" if "A\<^sup>*\<^sup>* a a'" "a \<sim> b" "PA a" "PB b"
   using simulation_reaches[of a a' b] that unfolding equiv'_def by simp
 
 lemma simulation_steps:
   "\<exists> bs. B.steps (b # bs) \<and> list_all2 (\<lambda> a b. a \<sim> b \<and> PA a \<and> PB b) as bs"
   if "A.steps (a # as)" "a \<sim> b" "PA a" "PB b"
   using simulation_steps[of a as b] that unfolding equiv'_def by simp
 
 lemma simulation_steps':
   "\<exists> bs. B.steps (b # bs) \<and> list_all2 (\<lambda> a b. a \<sim> b) as bs \<and> list_all PA as \<and> list_all PB bs"
   if "A.steps (a # as)" "a \<sim> b" "PA a" "PB b"
   using simulation_steps[OF that]
   by (metis (mono_tags, lifting) list_all2_conv_all_nth list_all_length)
 
 context
   fixes f
   assumes eq: "a \<sim> b \<Longrightarrow> b = f a"
 begin
 
 lemma simulation_steps'_map:
   "\<exists> bs.
     B.steps (b # bs) \<and> bs = map f as
     \<and> list_all2 (\<lambda> a b. a \<sim> b) as bs
     \<and> list_all PA as \<and> list_all PB bs"
   if "A.steps (a # as)" "a \<sim> b" "PA a" "PB b"
 proof -
-  from simulation_steps'[OF that] guess bs by clarify
-  note guessed = this
-  from this(2) have "bs = map f as"
+  from simulation_steps'[OF that]
+  obtain bs where bs: "B.steps (b # bs)" "list_all2 (\<sim>) as bs" "list_all PA as" "list_all PB bs"
+    by auto
+  from bs(2) have "bs = map f as"
     by (induction; simp add: eq)
-  with guessed show ?thesis
+  with bs show ?thesis
     by auto
 qed
 
 end (* Context for Equality Relation *)
 
 end (* Simulation Invariant *)
 
 locale Simulation_Invariants = Simulation_Defs +
   fixes PA QA :: "'a \<Rightarrow> bool" and PB QB :: "'b \<Rightarrow> bool"
   assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
   assumes A_invariant[intro]: "\<And> a b. PA a \<Longrightarrow> A a b \<Longrightarrow> QA b"
   assumes B_invariant[intro]: "\<And> a b. PB a \<Longrightarrow> B a b \<Longrightarrow> QB b"
   assumes PA_QA[intro]: "\<And> a. QA a \<Longrightarrow> PA a" and PB_QB[intro]: "\<And> a. QB a \<Longrightarrow> PB a"
 begin
 
 sublocale Pre: Simulation_Invariant A B "(\<sim>)" PA PB
   by standard (auto intro: A_B_step)
 
 sublocale Post: Simulation_Invariant A B "(\<sim>)" QA QB
   by standard (auto intro: A_B_step)
 
 sublocale A_invs: Graph_Invariants A PA QA
   by standard auto
 
 sublocale B_invs: Graph_Invariants B PB QB
   by standard auto
 
 lemma simulation_reaches1:
   "\<exists> b2. B.reaches1 b1 b2 \<and> a2 \<sim> b2 \<and> QB b2" if "A.reaches1 a1 a2" "a1 \<sim> b1" "PA a1" "PB b1"
   using that
   by - (drule Pre.simulation_reaches1, auto intro: B_invs.invariant_reaches1 simp: Pre.equiv'_def)
 
 lemma reaches1_unique:
   assumes unique: "\<And> b2. a \<sim> b2 \<Longrightarrow> QB b2 \<Longrightarrow> b2 = b"
     and that: "A.reaches1 a a" "a \<sim> b" "PA a" "PB b"
   shows "B.reaches1 b b"
   using that by (auto dest: unique simulation_reaches1)
 
 end (* Simualation Invariants *)
 
 locale Bisimulation = Simulation_Defs +
   assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
   assumes B_A_step: "\<And> a a' b'. B a' b' \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b. A a b \<and> b \<sim> b')"
 begin
 
 sublocale A_B: Simulation A B "(\<sim>)" by standard (rule A_B_step)
 
 sublocale B_A: Simulation B A "\<lambda> x y. y \<sim> x" by standard (rule B_A_step)
 
 lemma A_B_reaches:
   "\<exists> b'. B\<^sup>*\<^sup>* b b' \<and> a' \<sim> b'" if "A\<^sup>*\<^sup>* a a'" "a \<sim> b"
   using A_B.simulation_reaches[OF that] .
 
 lemma B_A_reaches:
   "\<exists> b'. A\<^sup>*\<^sup>* b b' \<and> b' \<sim> a'" if "B\<^sup>*\<^sup>* a a'" "b \<sim> a"
   using B_A.simulation_reaches[OF that] .
 
 end (* Bisim *)
 
 locale Bisimulation_Invariant = Simulation_Defs +
   fixes PA :: "'a \<Rightarrow> bool" and PB :: "'b \<Rightarrow> bool"
   assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> a \<sim> a' \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
   assumes B_A_step: "\<And> a a' b'. B a' b' \<Longrightarrow> a \<sim> a' \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> (\<exists> b. A a b \<and> b \<sim> b')"
   assumes A_invariant[intro]: "\<And> a b. PA a \<Longrightarrow> A a b \<Longrightarrow> PA b"
   assumes B_invariant[intro]: "\<And> a b. PB a \<Longrightarrow> B a b \<Longrightarrow> PB b"
 begin
 
 sublocale PA_invariant: Graph_Invariant A PA by standard blast
 
 sublocale PB_invariant: Graph_Invariant B PB by standard blast
 
 lemmas B_steps_invariant[intro] = PB_invariant.invariant_reaches
 
 definition "equiv' \<equiv> \<lambda> a b. a \<sim> b \<and> PA a \<and> PB b"
 
 sublocale bisim: Bisimulation A B equiv'
   by standard (clarsimp simp add: equiv'_def, frule A_B_step B_A_step, assumption; auto)+
 
 sublocale A_B: Simulation_Invariant A B "(\<sim>)" PA PB
   by (standard; blast intro: A_B_step B_A_step)
 
 sublocale B_A: Simulation_Invariant B A "\<lambda> x y. y \<sim> x" PB PA
   by (standard; blast intro: A_B_step B_A_step)
 
 context
   fixes f
   assumes eq: "a \<sim> b \<longleftrightarrow> b = f a"
     and inj: "\<forall> a b. PB (f a) \<and> PA b \<and> f a = f b \<longrightarrow> a = b"
 begin
 
 lemma list_all2_inj_map_eq:
   "as = bs" if "list_all2 (\<lambda>a b. a = f b) (map f as) bs" "list_all PB (map f as)" "list_all PA bs"
   using that inj
   by (induction "map f as" bs arbitrary: as rule: list_all2_induct) (auto simp: inj_on_def)
 
 lemma steps_map_equiv:
   "A.steps (a # as) \<longleftrightarrow> B.steps (b # map f as)" if "a \<sim> b" "PA a" "PB b"
   using A_B.simulation_steps'_map[of f a as b] B_A.simulation_steps'[of b "map f as" a] that eq
   by (auto dest: list_all2_inj_map_eq)
 
 lemma steps_map:
   "\<exists> as. bs = map f as" if "B.steps (f a # bs)" "PA a" "PB (f a)"
 proof -
   have "a \<sim> f a" unfolding eq ..
-  from B_A.simulation_steps'[OF that(1) this \<open>PB _\<close> \<open>PA _\<close>] guess as by clarify
-  from this(2) show ?thesis
+  from B_A.simulation_steps'[OF that(1) this \<open>PB _\<close> \<open>PA _\<close>]
+  obtain as where "list_all2 (\<lambda>a b. b \<sim> a) bs as" by auto
+  then show ?thesis
     unfolding eq by (inst_existentials as, induction rule: list_all2_induct, auto)
 qed
 
 lemma reaches_equiv:
   "A.reaches a a' \<longleftrightarrow> B.reaches (f a) (f a')" if "PA a" "PB (f a)"
   apply safe
    apply (drule A_B.simulation_reaches[of a a' "f a"]; simp add: eq that)
   apply (drule B_A.simulation_reaches)
      defer
      apply (rule that | clarsimp simp: eq | metis inj)+
   done
 
 end (* Context for Equality Relation *)
 
 lemma equiv'_D:
   "a \<sim> b" if "A_B.equiv' a b"
   using that unfolding A_B.equiv'_def by auto
 
 lemma equiv'_rotate_1:
   "B_A.equiv' b a" if "A_B.equiv' a b"
   using that by (auto simp: B_A.equiv'_def A_B.equiv'_def)
 
 lemma equiv'_rotate_2:
   "A_B.equiv' a b" if "B_A.equiv' b a"
   using that by (auto simp: B_A.equiv'_def A_B.equiv'_def)
 
 lemma stream_all2_equiv'_D:
   "stream_all2 (\<sim>) xs ys" if "stream_all2 A_B.equiv' xs ys"
   using stream_all2_weaken[OF that equiv'_D] by fast
 
 lemma stream_all2_equiv'_D2:
   "stream_all2 B_A.equiv' ys xs \<Longrightarrow> stream_all2 (\<sim>)\<inverse>\<inverse> ys xs"
   by (coinduction arbitrary: xs ys) (auto simp: B_A.equiv'_def)
 
 lemma stream_all2_rotate_1:
   "stream_all2 B_A.equiv' ys xs \<Longrightarrow> stream_all2 A_B.equiv' xs ys"
   by (coinduction arbitrary: xs ys) (auto simp: B_A.equiv'_def A_B.equiv'_def)
 
 lemma stream_all2_rotate_2:
   "stream_all2 A_B.equiv' xs ys \<Longrightarrow> stream_all2 B_A.equiv' ys xs"
   by (coinduction arbitrary: xs ys) (auto simp: B_A.equiv'_def A_B.equiv'_def)
 
 end (* Bisim Invariant *)
 
 locale Bisimulation_Invariants = Simulation_Defs +
   fixes PA QA :: "'a \<Rightarrow> bool" and PB QB :: "'b \<Rightarrow> bool"
   assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> a \<sim> a' \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
   assumes B_A_step: "\<And> a a' b'. B a' b' \<Longrightarrow> a \<sim> a' \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> (\<exists> b. A a b \<and> b \<sim> b')"
   assumes A_invariant[intro]: "\<And> a b. PA a \<Longrightarrow> A a b \<Longrightarrow> QA b"
   assumes B_invariant[intro]: "\<And> a b. PB a \<Longrightarrow> B a b \<Longrightarrow> QB b"
   assumes PA_QA[intro]: "\<And> a. QA a \<Longrightarrow> PA a" and PB_QB[intro]: "\<And> a. QB a \<Longrightarrow> PB a"
 begin
 
 sublocale PA_invariant: Graph_Invariant A PA by standard blast
 
 sublocale PB_invariant: Graph_Invariant B PB by standard blast
 
 sublocale QA_invariant: Graph_Invariant A QA by standard blast
 
 sublocale QB_invariant: Graph_Invariant B QB by standard blast
 
 sublocale Pre_Bisim: Bisimulation_Invariant A B "(\<sim>)" PA PB
   by standard (auto intro: A_B_step B_A_step)
 
 sublocale Post_Bisim: Bisimulation_Invariant A B "(\<sim>)" QA QB
   by standard (auto intro: A_B_step B_A_step)
 
 sublocale A_B: Simulation_Invariants A B "(\<sim>)" PA QA PB QB
   by standard (blast intro: A_B_step)+
 
 sublocale B_A: Simulation_Invariants B A "\<lambda> x y. y \<sim> x" PB QB PA QA
   by standard (blast intro: B_A_step)+
 
 context
   fixes f
   assumes eq[simp]: "a \<sim> b \<longleftrightarrow> b = f a"
     and inj: "\<forall> a b. QB (f a) \<and> QA b \<and> f a = f b \<longrightarrow> a = b"
 begin
 
 lemmas list_all2_inj_map_eq = Post_Bisim.list_all2_inj_map_eq[OF eq inj]
 lemmas steps_map_equiv' = Post_Bisim.steps_map_equiv[OF eq inj]
 
 lemma list_all2_inj_map_eq':
   "as = bs" if "list_all2 (\<lambda>a b. a = f b) (map f as) bs" "list_all QB (map f as)" "list_all QA bs"
   using that by (rule list_all2_inj_map_eq)
 
 lemma steps_map_equiv:
   "A.steps (a # as) \<longleftrightarrow> B.steps (b # map f as)" if "a \<sim> b" "PA a" "PB b"
 proof
   assume "A.steps (a # as)"
   then show "B.steps (b # map f as)"
   proof cases
     case Single
     then show ?thesis by auto
   next
     case prems: (Cons a' xs)
     from A_B_step[OF \<open>A a a'\<close> \<open>a \<sim> b\<close> \<open>PA a\<close> \<open>PB b\<close>] obtain b' where "B b b'" "a' \<sim> b'"
       by auto
     with steps_map_equiv'[OF \<open>a' \<sim> b'\<close>, of xs] prems that show ?thesis
       by auto
   qed
 next
   assume "B.steps (b # map f as)"
   then show "A.steps (a # as)"
   proof cases
     case Single
     then show ?thesis by auto
   next
     case prems: (Cons b' xs)
     from B_A_step[OF \<open>B b b'\<close> \<open>a \<sim> b\<close> \<open>PA a\<close> \<open>PB b\<close>] obtain a' where "A a a'" "a' \<sim> b'"
       by auto
     with that prems have "QA a'" "QB b'"
       by auto
     with \<open>A a a'\<close> \<open>a' \<sim> b'\<close> steps_map_equiv'[OF \<open>a' \<sim> b'\<close>, of "tl as"] prems that show ?thesis
       apply clarsimp
       subgoal for z zs
         using inj[rule_format, of z a'] by auto
       done
   qed
 qed
 
 lemma steps_map:
   "\<exists> as. bs = map f as" if "B.steps (f a # bs)" "PA a" "PB (f a)"
   using that proof cases
   case Single
   then show ?thesis by simp
 next
   case prems: (Cons b' xs)
   from B_A_step[OF \<open>B _ b'\<close> _ \<open>PA a\<close> \<open>PB (f a)\<close>] obtain a' where "A a a'" "a' \<sim> b'"
     by auto
   with that prems have "QA a'" "QB b'"
     by auto
   with Post_Bisim.steps_map[OF eq inj, of a' xs] prems \<open>a' \<sim> b'\<close> obtain ys where "xs = map f ys"
     by auto
   with \<open>bs = _\<close> \<open>a' \<sim> b'\<close> show ?thesis
     by (inst_existentials "a' # ys") auto
 qed
 
 text \<open>
   @{thm Post_Bisim.reaches_equiv} cannot be lifted directly:
   injectivity cannot be applied for the reflexive case.
 \<close>
 lemma reaches1_equiv:
   "A.reaches1 a a' \<longleftrightarrow> B.reaches1 (f a) (f a')" if "PA a" "PB (f a)"
 proof safe
   assume "A.reaches1 a a'"
   then obtain a'' where prems: "A a a''" "A.reaches a'' a'"
     including graph_automation_aggressive by blast
   from A_B_step[OF \<open>A a _\<close> _ that] obtain b where "B (f a) b" "a'' \<sim> b"
     by auto
   with that prems have "QA a''" "QB b"
     by auto
   with Post_Bisim.reaches_equiv[OF eq inj, of a'' a'] prems \<open>B (f a) b\<close> \<open>a'' \<sim> b\<close>
   show "B.reaches1 (f a) (f a')"
     by auto
 next
   assume "B.reaches1 (f a) (f a')"
   then obtain b where prems: "B (f a) b" "B.reaches b (f a')"
     including graph_automation_aggressive by blast
   from B_A_step[OF \<open>B _ b\<close> _ \<open>PA a\<close> \<open>PB (f a)\<close>] obtain a'' where "A a a''" "a'' \<sim> b"
     by auto
   with that prems have "QA a''" "QB b"
     by auto
   with Post_Bisim.reaches_equiv[OF eq inj, of a'' a'] prems \<open>A a a''\<close> \<open>a'' \<sim> b\<close>
   show "A.reaches1 a a'"
     by auto
 qed
 
 end (* Context for Equality Relation *)
 
 end (* Bisim Invariant *)
 
 lemma Bisimulation_Invariant_composition:
   assumes
     "Bisimulation_Invariant A B sim1 PA PB"
     "Bisimulation_Invariant B C sim2 PB PC"
   shows
     "Bisimulation_Invariant A C (\<lambda> a c. \<exists> b. PB b \<and> sim1 a b \<and> sim2 b c) PA PC"
 proof -
   interpret A: Bisimulation_Invariant A B sim1 PA PB
     by (rule assms(1))
   interpret B: Bisimulation_Invariant B C sim2 PB PC
     by (rule assms(2))
   show ?thesis
     by (standard; (blast dest: A.A_B_step B.A_B_step | blast dest: A.B_A_step B.B_A_step))
 qed
 
 lemma Bisimulation_Invariant_filter:
   assumes
     "Bisimulation_Invariant A B sim PA PB"
     "\<And> a b. sim a b \<Longrightarrow> PA a \<Longrightarrow> PB b \<Longrightarrow> FA a \<longleftrightarrow> FB b"
     "\<And> a b. A a b \<and> FA b \<longleftrightarrow> A' a b"
     "\<And> a b. B a b \<and> FB b \<longleftrightarrow> B' a b"
   shows
     "Bisimulation_Invariant A' B' sim PA PB"
 proof -
   interpret Bisimulation_Invariant A B sim PA PB
     by (rule assms(1))
   have unfold:
     "A' = (\<lambda> a b. A a b \<and> FA b)" "B' = (\<lambda> a b. B a b \<and> FB b)"
     using assms(3,4) by auto
   show ?thesis
     unfolding unfold
     apply standard
     using assms(2) apply (blast dest: A_B_step)
     using assms(2) apply (blast dest: B_A_step)
     by blast+
 qed
 
 lemma Bisimulation_Invariants_filter:
   assumes
     "Bisimulation_Invariants A B sim PA QA PB QB"
     "\<And> a b. QA a \<Longrightarrow> QB b \<Longrightarrow> FA a \<longleftrightarrow> FB b"
     "\<And> a b. A a b \<and> FA b \<longleftrightarrow> A' a b"
     "\<And> a b. B a b \<and> FB b \<longleftrightarrow> B' a b"
   shows
     "Bisimulation_Invariants A' B' sim PA QA PB QB"
 proof -
   interpret Bisimulation_Invariants A B sim PA QA PB QB
     by (rule assms(1))
   have unfold:
     "A' = (\<lambda> a b. A a b \<and> FA b)" "B' = (\<lambda> a b. B a b \<and> FB b)"
     using assms(3,4) by auto
   show ?thesis
     unfolding unfold
     apply standard
     using assms(2) apply (blast dest: A_B_step)
     using assms(2) apply (blast dest: B_A_step)
     by blast+
 qed
 
 lemma Bisimulation_Invariants_composition:
   assumes
     "Bisimulation_Invariants A B sim1 PA QA PB QB"
     "Bisimulation_Invariants B C sim2 PB QB PC QC"
   shows
     "Bisimulation_Invariants A C (\<lambda> a c. \<exists> b. PB b \<and> sim1 a b \<and> sim2 b c) PA QA PC QC"
 proof -
   interpret A: Bisimulation_Invariants A B sim1 PA QA PB QB
     by (rule assms(1))
   interpret B: Bisimulation_Invariants B C sim2 PB QB PC QC
     by (rule assms(2))
   show ?thesis
     by (standard; (blast dest: A.A_B_step B.A_B_step | blast dest: A.B_A_step B.B_A_step))
 qed
 
 lemma Bisimulation_Invariant_Invariants_composition:
   assumes
     "Bisimulation_Invariant A B sim1 PA PB"
     "Bisimulation_Invariants B C sim2 PB QB PC QC"
   shows
     "Bisimulation_Invariants A C (\<lambda> a c. \<exists> b. PB b \<and> sim1 a b \<and> sim2 b c) PA PA PC QC"
 proof -
   interpret Bisimulation_Invariant A B sim1 PA PB
     by (rule assms(1))
   interpret B: Bisimulation_Invariants B C sim2 PB QB PC QC
     by (rule assms(2))
   interpret A: Bisimulation_Invariants A B sim1 PA PA PB QB
     by (standard; blast intro: A_B_step B_A_step)+
   show ?thesis
     by (standard; (blast dest: A.A_B_step B.A_B_step | blast dest: A.B_A_step B.B_A_step))
 qed
 
 lemma Bisimulation_Invariant_Bisimulation_Invariants:
   assumes "Bisimulation_Invariant A B sim PA PB"
   shows "Bisimulation_Invariants A B sim PA PA PB PB"
 proof -
   interpret Bisimulation_Invariant A B sim PA PB
     by (rule assms)
   show ?thesis
     by (standard; blast intro: A_B_step B_A_step)
 qed
 
 lemma Bisimulation_Invariant_strengthen_post:
   assumes
     "Bisimulation_Invariant A B sim PA PB"
     "\<And> a b. PA' a \<Longrightarrow> PA b \<Longrightarrow> A a b \<Longrightarrow> PA' b"
     "\<And> a. PA' a \<Longrightarrow> PA a"
   shows "Bisimulation_Invariant A B sim PA' PB"
 proof -
   interpret Bisimulation_Invariant A B sim PA PB
     by (rule assms)
   show ?thesis
     by (standard; blast intro: A_B_step B_A_step assms)
 qed
 
 lemma Bisimulation_Invariant_strengthen_post':
   assumes
     "Bisimulation_Invariant A B sim PA PB"
     "\<And> a b. PB' a \<Longrightarrow> PB b \<Longrightarrow> B a b \<Longrightarrow> PB' b"
     "\<And> a. PB' a \<Longrightarrow> PB a"
   shows "Bisimulation_Invariant A B sim PA PB'"
 proof -
   interpret Bisimulation_Invariant A B sim PA PB
     by (rule assms)
   show ?thesis
     by (standard; blast intro: A_B_step B_A_step assms)
 qed
 
 lemma Simulation_Invariant_strengthen_post:
   assumes
     "Simulation_Invariant A B sim PA PB"
     "\<And> a b. PA a \<Longrightarrow> PA b \<Longrightarrow> A a b \<Longrightarrow> PA' b"
     "\<And> a. PA' a \<Longrightarrow> PA a"
   shows "Simulation_Invariant A B sim PA' PB"
 proof -
   interpret Simulation_Invariant A B sim PA PB
     by (rule assms)
   show ?thesis
     by (standard; blast intro: A_B_step assms)
 qed
 
 lemma Simulation_Invariant_strengthen_post':
   assumes
     "Simulation_Invariant A B sim PA PB"
     "\<And> a b. PB a \<Longrightarrow> PB b \<Longrightarrow> B a b \<Longrightarrow> PB' b"
     "\<And> a. PB' a \<Longrightarrow> PB a"
   shows "Simulation_Invariant A B sim PA PB'"
 proof -
   interpret Simulation_Invariant A B sim PA PB
     by (rule assms)
   show ?thesis
     by (standard; blast intro: A_B_step assms)
 qed
 
 lemma Simulation_Invariants_strengthen_post:
   assumes
     "Simulation_Invariants A B sim PA QA PB QB"
     "\<And> a b. PA a \<Longrightarrow> QA b \<Longrightarrow> A a b \<Longrightarrow> QA' b"
     "\<And> a. QA' a \<Longrightarrow> QA a"
   shows "Simulation_Invariants A B sim PA QA' PB QB"
 proof -
   interpret Simulation_Invariants A B sim PA QA PB QB
     by (rule assms)
   show ?thesis
     by (standard; blast intro: A_B_step assms)
 qed
 
 lemma Simulation_Invariants_strengthen_post':
   assumes
     "Simulation_Invariants A B sim PA QA PB QB"
     "\<And> a b. PB a \<Longrightarrow> QB b \<Longrightarrow> B a b \<Longrightarrow> QB' b"
     "\<And> a. QB' a \<Longrightarrow> QB a"
   shows "Simulation_Invariants A B sim PA QA PB QB'"
 proof -
   interpret Simulation_Invariants A B sim PA QA PB QB
     by (rule assms)
   show ?thesis
     by (standard; blast intro: A_B_step assms)
 qed
 
 lemma Bisimulation_Invariant_sim_replace:
   assumes "Bisimulation_Invariant A B sim PA PB"
       and "\<And> a b. PA a \<Longrightarrow> PB b \<Longrightarrow> sim a b \<longleftrightarrow> sim' a b"
     shows "Bisimulation_Invariant A B sim' PA PB"
 proof -
   interpret Bisimulation_Invariant A B sim PA PB
     by (rule assms(1))
   show ?thesis
     apply standard
     using assms(2) apply (blast dest: A_B_step)
     using assms(2) apply (blast dest: B_A_step)
     by blast+
 qed
 
 end (* Theory *)
diff --git a/thys/Probabilistic_Timed_Automata/library/More_List.thy b/thys/Probabilistic_Timed_Automata/library/More_List.thy
--- a/thys/Probabilistic_Timed_Automata/library/More_List.thy
+++ b/thys/Probabilistic_Timed_Automata/library/More_List.thy
@@ -1,301 +1,308 @@
 (* Author: Simon Wimmer *)
 theory More_List
   imports
     Main
     Instantiate_Existentials
 begin
 
 section \<open>First and Last Elements of Lists\<close>
 
 lemma (in -) hd_butlast_last_id:
   "hd xs # tl (butlast xs) @ [last xs] = xs" if "length xs > 1"
   using that by (cases xs) auto
 
 section \<open>@{term list_all}\<close>
 
 lemma (in -) list_all_map:
   assumes inv: "\<And> x. P x \<Longrightarrow> \<exists> y. f y = x"
     and all: "list_all P as"
   shows "\<exists> as'. map f as' = as"
   using all
     apply (induction as)
    apply (auto dest!: inv)
   subgoal for as' a
     by (inst_existentials "a # as'") simp
   done
 
 section \<open>@{term list_all2}\<close>
 
 lemma list_all2_op_map_iff:
   "list_all2 (\<lambda> a b. b = f a) xs ys \<longleftrightarrow> map f xs = ys"
   unfolding list_all2_iff
   proof (induction xs arbitrary: ys)
     case Nil
     then show ?case by auto
   next
     case (Cons a xs ys)
     then show ?case by (cases ys) auto
   qed
 
 lemma list_all2_last:
   "R (last xs) (last ys)" if "list_all2 R xs ys" "xs \<noteq> []"
   using that
   unfolding list_all2_iff
   proof (induction xs arbitrary: ys)
     case Nil
     then show ?case by simp
   next
     case (Cons a xs ys)
     then show ?case by (cases ys) auto
   qed
 
 lemma list_all2_set1:
   "\<forall>x\<in>set xs. \<exists>xa\<in>set as. P x xa" if "list_all2 P xs as"
   using that
 proof (induction xs arbitrary: as)
   case Nil
   then show ?case by auto
 next
   case (Cons a xs as)
   then show ?case by (cases as) auto
 qed
 
 lemma list_all2_swap:
   "list_all2 P xs ys \<longleftrightarrow> list_all2 (\<lambda> x y. P y x) ys xs"
   unfolding list_all2_iff by (fastforce simp: in_set_zip)+
 
 lemma list_all2_set2:
   "\<forall>x\<in>set as. \<exists>xa\<in>set xs. P xa x" if "list_all2 P xs as"
   using that by - (rule list_all2_set1, subst (asm) list_all2_swap)
 
 section \<open>Distinct lists\<close>
 
 (* XXX Duplication with Floyd_Warshall.thy *)
 lemma distinct_length_le:"finite s \<Longrightarrow> set xs \<subseteq> s \<Longrightarrow> distinct xs \<Longrightarrow> length xs \<le> card s"
   by (metis card_mono distinct_card)
 
 section \<open>@{term filter}\<close>
 
 lemma filter_eq_appendD:
   "\<exists> xs' ys'. filter P xs' = xs \<and> filter P ys' = ys \<and> as = xs' @ ys'" if "filter P as = xs @ ys"
   using that
 proof (induction xs arbitrary: as)
   case Nil
   then show ?case
     by (inst_existentials "[] :: 'a list" as) auto
 next
   case (Cons a xs)
   from filter_eq_ConsD[OF Cons.prems[simplified]] obtain us vs where
     "as = us @ a # vs" "\<forall>u\<in>set us. \<not> P u" "P a" "filter P vs = xs @ ys"
     by auto
   moreover from Cons.IH[OF \<open>_ = xs @ ys\<close>] obtain xs' ys where
     "filter P xs' = xs" "vs = xs' @ ys"
     by auto
   ultimately show ?case
     by (inst_existentials "us @ [a] @ xs'" ys) auto
 qed
 
 lemma list_all2_elem_filter:
   assumes "list_all2 P xs us" "x \<in> set xs"
   shows "length (filter (P x) us) \<ge> 1"
   using assms by (induction xs arbitrary: us) (auto simp: list_all2_Cons1)
 
 lemma list_all2_replicate_elem_filter:
   assumes "list_all2 P (concat (replicate n xs)) ys" "x \<in> set xs"
   shows "length (filter (P x) ys) \<ge> n"
   using assms
   by (induction n arbitrary: ys; fastforce dest: list_all2_elem_filter simp: list_all2_append1)
 
 section \<open>Sublists\<close>
 
 lemma nths_split:
   "nths xs (A \<union> B) = nths xs A @ nths xs B" if "\<forall> i \<in> A. \<forall> j \<in> B. i < j"
   using that
   proof (induction xs arbitrary: A B)
     case Nil
     then show ?case by simp
   next
     case (Cons a xs)
     let ?A = "{j. Suc j \<in> A}" and ?B = "{j. Suc j \<in> B}"
     from Cons.prems have *: "\<forall>i\<in>?A. \<forall>a\<in>?B. i < a"
       by auto
     have [simp]: "{j. Suc j \<in> A \<or> Suc j \<in> B} = ?A \<union> ?B"
       by auto
     show ?case
       unfolding nths_Cons
     proof (clarsimp, safe, goal_cases)
       case 2
       with Cons.prems have "A = {}"
         by auto
       with Cons.IH[OF *] show ?case by auto
     qed (use Cons.prems Cons.IH[OF *] in auto)
   qed
 
 lemma nths_nth:
   "nths xs {i} = [xs ! i]" if "i < length xs"
   using that
   proof (induction xs arbitrary: i)
     case Nil
     then show ?case by simp
   next
     case (Cons a xs)
     then show ?case
       by (cases i) (auto simp: nths_Cons)
   qed
 
 lemma nths_shift:
   "nths (xs @ ys) S = nths ys {x - length xs | x. x \<in> S}" if
   "\<forall> i \<in> S. length xs \<le> i"
   using that
 proof (induction xs arbitrary: S)
   case Nil
   then show ?case by auto
 next
   case (Cons a xs)
   have [simp]: "{x - length xs |x. Suc x \<in> S} = {x - Suc (length xs) |x. x \<in> S}" if "0 \<notin> S"
     using that apply safe
      apply force
     subgoal for x x'
       by (cases x') auto
     done
   from Cons.prems show ?case
     by (simp, subst nths_Cons, subst Cons.IH; auto)
 qed
 
 lemma nths_eq_ConsD:
   assumes "nths xs I = x # as"
   shows
     "\<exists> ys zs.
       xs = ys @ x # zs \<and> length ys \<in> I \<and> (\<forall> i \<in> I. i \<ge> length ys)
       \<and> nths zs ({i - length ys - 1 | i. i \<in> I \<and> i > length ys}) = as"
   using assms
 proof (induction xs arbitrary: I x as)
   case Nil
   then show ?case by simp
 next
   case (Cons a xs)
   from Cons.prems show ?case
     unfolding nths_Cons
     apply (auto split: if_split_asm)
     subgoal
       by (inst_existentials "[] :: 'a list" xs; force intro: arg_cong2[of xs xs _ _ nths])
     subgoal
       apply (drule Cons.IH)
       apply safe
       subgoal for ys zs
         apply (inst_existentials "a # ys" zs)
            apply simp+
          apply standard
         subgoal for i
           by (cases i; auto)
         apply (rule arg_cong2[of zs zs _ _ nths])
          apply simp
         apply safe
         subgoal for _ i
           by (cases i; auto)
         by force
       done
     done
 qed
 
 lemma nths_out_of_bounds:
   "nths xs I = []" if "\<forall>i \<in> I. i \<ge> length xs"
   using that
   (* Found by sledgehammer *)
 proof -
   have
     "\<forall>N as.
       (\<exists>n. n \<in> N \<and> \<not> length (as::'a list) \<le> n)
       \<or> (\<forall>asa. nths (as @ asa) N = nths asa {n - length as |n. n \<in> N})"
     using nths_shift by blast
   then obtain nn :: "nat set \<Rightarrow> 'a list \<Rightarrow> nat" where
     "\<forall>N as.
       nn N as \<in> N \<and> \<not> length as \<le> nn N as
     \<or> (\<forall>asa. nths (as @ asa) N = nths asa {n - length as |n. n \<in> N})"
     by moura
   then have
     "\<And>as. nths as {n - length xs |n. n \<in> I} = nths (xs @ as) I
       \<or> nths (xs @ []) I = []"
     using that by fastforce
   then have "nths (xs @ []) I = []"
     by (metis (no_types) nths_nil)
   then show ?thesis
     by simp
 qed
 
 lemma nths_eq_appendD:
   assumes "nths xs I = as @ bs"
   shows
     "\<exists> ys zs.
         xs = ys @ zs \<and> nths ys I = as
         \<and> nths zs {i - length ys | i. i \<in> I \<and> i \<ge> length ys} = bs"
   using assms
 proof (induction as arbitrary: xs I)
   case Nil
   then show ?case
     by (inst_existentials "[] :: 'a list" "nths bs") auto
 next
   case (Cons a ys xs)
-  from nths_eq_ConsD[of xs I a "ys @ bs"] Cons.prems obtain ys' zs' where
-    "xs = ys' @ a # zs'" "length ys' \<in> I" "\<forall>i \<in> I. i \<ge> length ys'"
-    "nths zs' {i - length ys' - 1 |i. i \<in> I \<and> i > length ys'} = ys @ bs"
+  from nths_eq_ConsD[of xs I a "ys @ bs"] Cons.prems
+  obtain ys' zs' where
+      "xs = ys' @ a # zs'"
+      "length ys' \<in> I"
+      "\<forall>i \<in> I. i \<ge> length ys'"
+      "nths zs' {i - length ys' - 1 |i. i \<in> I \<and> i > length ys'} = ys @ bs"
     by auto
-  moreover from Cons.IH[OF \<open>nths zs' _ = _\<close>] guess ys'' zs'' by clarify
+  moreover from Cons.IH[OF \<open>nths zs' _ = _\<close>] obtain ys'' zs'' where
+    "zs' = ys'' @ zs''"
+    "ys = nths ys'' {i - length ys' - 1 |i. i \<in> I \<and> length ys' < i}"
+    "bs = nths zs'' {i - length ys'' |i. i \<in> {i - length ys' - 1 |i. i \<in> I \<and> length ys' < i} \<and> length ys'' \<le> i}"
+    by auto
   ultimately show ?case
     apply (inst_existentials "ys' @ a # ys''" zs'')
       apply (simp; fail)
     subgoal
       by (simp add: nths_out_of_bounds nths_append nths_Cons)
         (rule arg_cong2[of ys'' ys'' _ _ nths]; force)
     subgoal
       by safe (rule arg_cong2[of zs'' zs'' _ _ nths]; force) (* Slow *)
     done
 qed
 
 lemma filter_nths_length:
   "length (filter P (nths xs I)) \<le> length (filter P xs)"
 proof (induction xs arbitrary: I)
   case Nil
   then show ?case
     by simp
 next
   case Cons
   then show ?case
   (* Found by sledgehammer *)
   proof -
     fix a :: 'a and xsa :: "'a list" and Ia :: "nat set"
     assume a1: "\<And>I. length (filter P (nths xsa I)) \<le> length (filter P xsa)"
     have f2:
       "\<forall>b bs N. if 0 \<in> N then nths ((b::'a) # bs) N =
         [b] @ nths bs {n. Suc n \<in> N} else nths (b # bs) N = [] @ nths bs {n. Suc n \<in> N}"
       by (simp add: nths_Cons)
     have f3:
       "nths (a # xsa) Ia = [] @ nths xsa {n. Suc n \<in> Ia}
         \<longrightarrow> length (filter P (nths (a # xsa) Ia)) \<le> length (filter P xsa)"
       using a1 by (metis append_Nil)
     have f4: "length (filter P (nths xsa {n. Suc n \<in> Ia})) + 0 \<le> length (filter P xsa) + 0"
       using a1 by simp
     have f5:
       "Suc (length (filter P (nths xsa {n. Suc n \<in> Ia})) + 0)
       = length (a # filter P (nths xsa {n. Suc n \<in> Ia}))"
       by force
     have f6: "Suc (length (filter P xsa) + 0) = length (a # filter P xsa)"
       by simp
     { assume "\<not> length (filter P (nths (a # xsa) Ia)) \<le> length (filter P (a # xsa))"
       { assume "nths (a # xsa) Ia \<noteq> [a] @ nths xsa {n. Suc n \<in> Ia}"
         moreover
         { assume
             "nths (a # xsa) Ia = [] @ nths xsa {n. Suc n \<in> Ia}
             \<and> length (filter P (a # xsa)) \<le> length (filter P xsa)"
           then have "length (filter P (nths (a # xsa) Ia)) \<le> length (filter P (a # xsa))"
             using a1 by (metis (no_types) append_Nil filter.simps(2) impossible_Cons) }
         ultimately have "length (filter P (nths (a # xsa) Ia)) \<le> length (filter P (a # xsa))"
           using f3 f2 by (meson dual_order.trans le_cases) }
       then have "length (filter P (nths (a # xsa) Ia)) \<le> length (filter P (a # xsa))"
         using f6 f5 f4 a1 by (metis Suc_le_mono append_Cons append_Nil filter.simps(2)) }
     then show "length (filter P (nths (a # xsa) Ia)) \<le> length (filter P (a # xsa))"
       by meson
   qed
 qed
 
 end (* Theory *)
diff --git a/thys/Probabilistic_Timed_Automata/library/Stream_More.thy b/thys/Probabilistic_Timed_Automata/library/Stream_More.thy
--- a/thys/Probabilistic_Timed_Automata/library/Stream_More.thy
+++ b/thys/Probabilistic_Timed_Automata/library/Stream_More.thy
@@ -1,331 +1,358 @@
 theory Stream_More
 imports
   Sequence_LTL
   Instantiate_Existentials
   "HOL-Library.Rewrite"
 begin
 
 (*
 
 (* TODO: can be replaced by stream.rel_cases *)
 lemma stream_all2_Cons1:
   "stream_all2 P (y ## ys) xs \<longleftrightarrow> (\<exists> x xs'. xs = x ## xs' \<and> P y x \<and> stream_all2 P ys xs')"
   by (cases xs) auto
 lemma stream_all2_Cons2:
   "stream_all2 P xs (y ## ys) \<longleftrightarrow> (\<exists> x xs'. xs = x ## xs' \<and> P x y \<and> stream_all2 P xs' ys)"
   by (cases xs) auto
 
 (* TODO: inline? *)
 lemma filter_list_all_iff: "filter P xs = [] \<longleftrightarrow> list_all (Not \<circ> P) xs"
   unfolding filter_empty_conv list.pred_set by simp
 
 (* TODO: inline? *)
 lemma append_single_shift: "(xs @ [x]) @- ys = xs @- x ## ys" by simp
 
 (* TODO: inline? *)
 lemma sset_finite_decomp:
   assumes "finite (sset w)"
   obtains u v a w'
   where "w = u @- a ## v @- a ## w'"
   using sdistinct_infinite_sset not_sdistinct_decomp assms by metis
 
 *)
 
 lemma list_all_stake_least:
   "list_all (Not \<circ> P) (stake (LEAST n. P (xs !! n)) xs)" (is "?G") if "\<exists> n. P (xs !! n)"
 proof (rule ccontr)
   let ?n = "LEAST n. P (xs !! n)"
   assume "\<not> ?G"
   then have "\<exists> x \<in> set (stake ?n xs). P x" unfolding list_all_iff by auto
   then obtain n' where "n' < ?n" "P (xs !! n')" using set_stake_snth by metis
   with Least_le[of "\<lambda> n. P (xs !! n)" n'] show False by auto
 qed
 
 lemma alw_stream_all2_mono:
   assumes "stream_all2 P xs ys" "alw Q xs" "\<And> xs ys. stream_all2 P xs ys \<Longrightarrow> Q xs \<Longrightarrow> R ys"
   shows "alw R ys"
   using assms stream.rel_sel by (coinduction arbitrary: xs ys) (blast)
 
 lemma alw_ev_HLD_cycle:
   assumes "stream_all2 (\<in>) xs (cycle as)" "a \<in> set as"
   shows "infs a xs"
 using assms(1)
 proof coinduct
   case (infs xs)
   have 1: "as \<noteq> []" using assms(2) by auto
   have 2:
     "list_all2 (\<in>) (stake (length as) xs) (stake (length as) (cycle as))"
     "stream_all2 (\<in>) (sdrop (length as) xs) (sdrop (length as) (cycle as))"
     using infs stream_rel_shift stake_sdrop length_stake by metis+
   have 3: "stake (length as) (cycle as) = as" using 1 by simp
   have 4: "sdrop (length as) (cycle as) = cycle as" using sdrop_cycle_eq 1 by this
   have 5: "set (stake (length as) xs) \<inter> a \<noteq> {}"
     using assms(2) 2(1) unfolding list.in_rel 3
     by (auto) (metis IntI empty_iff mem_Collect_eq set_zip_leftD split_conv subsetCE zip_map_fst_snd)
   show ?case using 2 5 unfolding 4 by force
 qed
 
 lemma alw_ev_mono:
   assumes "alw (ev \<phi>) xs" and "\<And> xs. \<phi> xs \<Longrightarrow> \<psi> xs"
   shows "alw (ev \<psi>) xs"
   by (rule alw_mp[OF assms(1)]) (auto intro: ev_mono assms(2) simp: alw_iff_sdrop)
 
 lemma alw_ev_lockstep:
   assumes
     "alw (ev (holds P)) xs" "stream_all2 Q xs as"
     "\<And> x a. P x \<Longrightarrow> Q x a \<Longrightarrow> R a"
   shows
     "alw (ev (holds R)) as"
   using assms(1,2)
   apply (coinduction arbitrary: xs as)
   apply auto
   subgoal
     by (metis alw.cases assms(3) ev_holds_sset stream_all2_sset1)
   subgoal
     by (meson alw.cases stream.rel_sel)
   done
 
 subsection \<open>sfilter, wait, nxt\<close>
 
 text \<open>Useful?\<close>
 lemma nxt_holds_iff_snth: "(nxt ^^ y) (holds P) xs \<longleftrightarrow> P (xs !! y)"
   by (induction y arbitrary: xs; simp)
 
 text \<open>Useful?\<close>
 lemma wait_LEAST:
   "wait (holds P) xs = (LEAST n. P (xs !! n))" unfolding wait_def nxt_holds_iff_snth ..
 
 lemma sfilter_SCons_decomp:
   assumes "sfilter P xs = x ## zs" "ev (holds P) xs"
   shows "\<exists> ys' zs'. xs = ys' @- x ## zs' \<and> list_all (Not o P) ys' \<and> P x \<and> sfilter P zs' = zs"
 proof -
   from ev_imp_shift[OF assms(2)] obtain as bs where "xs = as @- bs" "holds P bs"
     by auto
   then have "P (shd bs)" by auto
   with \<open>xs = _\<close> have "\<exists> n. P (xs !! n)" using assms(2) sdrop_wait by fastforce
   from sdrop_while_sdrop_LEAST[OF this] have *:
     "sdrop_while (Not \<circ> P) xs = sdrop (LEAST n. P (xs !! n)) xs" .
   let ?xs = "sdrop_while (Not \<circ> P) xs" let ?n = "LEAST n. P (xs !! n)"
   from assms(1) have "x = shd ?xs" "zs = sfilter P (stl ?xs)"
     by (subst (asm) sfilter.ctr; simp)+
   have "xs = stake ?n xs @- sdrop ?n xs" by simp
   moreover have "P x" using assms(1) unfolding sfilter_eq[OF assms(2)] ..
   moreover from \<open>\<exists> n. P _\<close> have "list_all (Not o P) (stake ?n xs)" by (rule list_all_stake_least)
   ultimately show ?thesis
     using \<open>x = _\<close> \<open>zs = _\<close> *[symmetric] by (inst_existentials "stake ?n xs" "stl ?xs") auto
 qed
 
 lemma sfilter_SCons_decomp':
   assumes "sfilter P xs = x ## zs" "ev (holds P) xs"
   shows
     "list_all (Not o P) (stake (wait (holds P) xs) xs)" (is "?G1")
     "P x"
     "\<exists> zs'. xs = stake (wait (holds P) xs) xs @- x ## zs' \<and> sfilter P zs' = zs" (is "?G2")
 proof -
   from ev_imp_shift[OF assms(2)] obtain as bs where "xs = as @- bs" "holds P bs"
     by auto
   then have "P (shd bs)" by auto
   with \<open>xs = _\<close> have "\<exists> n. P (xs !! n)" using assms(2) sdrop_wait by fastforce thm sdrop_wait
   from sdrop_while_sdrop_LEAST[OF this] have *:
     "sdrop_while (Not \<circ> P) xs = sdrop (LEAST n. P (xs !! n)) xs" .
   let ?xs = "sdrop_while (Not \<circ> P) xs" let ?n = "wait (holds P) xs"
   from assms(1) have "x = shd ?xs" "zs = sfilter P (stl ?xs)"
     by (subst (asm) sfilter.ctr; simp)+
   have "xs = stake ?n xs @- sdrop ?n xs" by simp
   moreover show "P x" using assms(1) unfolding sfilter_eq[OF assms(2)] ..
   moreover from \<open>\<exists> n. P _\<close> show "list_all (Not o P) (stake ?n xs)"
     by (auto intro: list_all_stake_least simp: wait_LEAST)
   ultimately show ?G2
     using \<open>x = _\<close> \<open>zs = _\<close> *[symmetric] by (inst_existentials "stl ?xs") (auto simp: wait_LEAST)
 qed
 
 lemma sfilter_shift_decomp:
   assumes "sfilter P xs = ys @- zs" "alw (ev (holds P)) xs"
   shows "\<exists> ys' zs'. xs = ys' @- zs' \<and> filter P ys' = ys \<and> sfilter P zs' = zs"
   using assms(1,2)
 proof (induction ys arbitrary: xs)
   case Nil
   then show ?case by (inst_existentials "[] :: 'a list" xs; simp)
 next
   case (Cons y ys)
   from alw_ev_imp_ev_alw[OF \<open>alw (ev _) xs\<close>] have "ev (holds P) xs"
     by (auto elim: ev_mono)
-  with Cons.prems(1) sfilter_SCons_decomp[of P xs y "ys @- zs"] guess ys' zs' by clarsimp
-  note guessed = this
+  with Cons.prems(1) sfilter_SCons_decomp[of P xs y "ys @- zs"]
+  obtain ys' zs' where *:
+      "xs = ys' @- y ## zs'"
+      "list_all (Not \<circ> P) ys'"
+      "P y"
+      "sfilter P zs' = ys @- zs"
+    by auto
   then have "sfilter P zs' = ys @- zs" by auto
   from \<open>alw (ev _) xs\<close> \<open>xs = _\<close> have "alw (ev (holds P)) zs'"
     by (metis ev.intros(2) ev_shift not_alw_iff stream.sel(2))
-  from Cons.IH[OF \<open>sfilter P zs' = _\<close> this] guess zs1 zs2 by clarsimp
-  with guessed show ?case
+  from Cons.IH[OF \<open>sfilter P zs' = _\<close> this]
+  obtain zs1 zs2 where
+    "zs' = zs1 @- zs2"
+    "ys = filter P zs1"
+    "zs = sfilter P zs2"
+    by auto
+  with * show ?case
     by (inst_existentials "ys' @ y # zs1" zs2; simp add: list.pred_set)
 qed
 
 lemma finite_sset_sfilter_decomp:
   assumes "finite (sset (sfilter P xs))" "alw (ev (holds P)) xs"
   obtains x ws ys zs where "xs = ws @- x ## ys @- x ## zs" "P x"
 proof atomize_elim
   let ?xs = "sfilter P xs"
   have 1: "\<not> sdistinct (sfilter P xs)" using sdistinct_infinite_sset assms(1) by auto
-  from not_sdistinct_decomp[OF 1] guess ws ys x zs .
-  note guessed1 = this
-  from sfilter_shift_decomp[OF this assms(2)] guess ys' zs' by clarsimp
-  note guessed2 = this
+  from not_sdistinct_decomp[OF 1]
+  obtain ws ys x zs where 1: "sfilter P xs = ws @- x ## ys @- x ## zs" .
+  from sfilter_shift_decomp[OF this assms(2)]
+  obtain ys' zs' where 2: "xs = ys' @- zs'" "sfilter P zs' = x ## ys @- x ## zs" by auto
   then have "ev (holds P) zs'" using alw_shift assms(2) by blast
-  from sfilter_SCons_decomp[OF guessed2(2) this] guess zs1 zs2 by clarsimp
-  note guessed3 = this
+  from sfilter_SCons_decomp[OF 2(2) this]
+  obtain zs1 zs2 where 3:
+    "zs' = zs1 @- x ## zs2" "list_all (Not \<circ> P) zs1" "P x" "sfilter P zs2 = ys @- x ## zs"
+    by auto
   have "alw (ev (holds P)) zs2"
-    by (metis alw_ev_stl alw_shift assms(2) guessed2(1) guessed3(1) stream.sel(2))
-  from sfilter_shift_decomp[OF guessed3(4) this] guess zs3 zs4 by clarsimp
-  note guessed4 = this
+    by (metis alw_ev_stl alw_shift assms(2) 2(1) 3(1) stream.sel(2))
+  from sfilter_shift_decomp[OF 3(4) this]
+  obtain zs3 zs4 where 4: "zs2 = zs3 @- zs4" "sfilter P zs4 = x ## zs" by auto
   have "ev (holds P) zs4"
-    using \<open>alw (ev (holds P)) zs2\<close> alw_shift guessed4(1) by blast
-  from sfilter_SCons_decomp[OF guessed4(2) this] guess zs5 zs6 by clarsimp
-  with guessed1 guessed2 guessed3 guessed4 show "\<exists>ws x ys zs. xs = ws @- x ## ys @- x ## zs \<and> P x"
+    using \<open>alw (ev (holds P)) zs2\<close> alw_shift 4(1) by blast
+  from sfilter_SCons_decomp[OF 4(2) this]
+  obtain zs5 zs6 where "zs4 = zs5 @- x ## zs6" "list_all (Not \<circ> P) zs5" "P x" "zs = sfilter P zs6"
+    by auto
+  with 1 2 3 4 show "\<exists>ws x ys zs. xs = ws @- x ## ys @- x ## zs \<and> P x"
     by (inst_existentials "ys' @ zs1" x "zs3 @ zs5" zs6; force)
 qed
 
 text \<open>Useful?\<close>
 lemma sfilter_shd_LEAST:
   "shd (sfilter P xs) = xs !! (LEAST n. P (xs !! n))" if "ev (holds P) xs"
 proof -
   from sdrop_wait[OF \<open>ev _ xs\<close>] have "\<exists> n. P (xs !! n)" by auto
   from sdrop_while_sdrop_LEAST[OF this] show ?thesis by simp
 qed
 
 lemma alw_nxt_holds_cong:
   "(nxt ^^ n) (holds (\<lambda>x. P x \<and> Q x)) xs = (nxt ^^ n) (holds Q) xs" if "alw (holds P) xs"
   using that unfolding nxt_holds_iff_snth alw_iff_sdrop by simp
 
 lemma alw_wait_holds_cong:
   "wait (holds (\<lambda>x. P x \<and> Q x)) xs = wait (holds Q) xs" if "alw (holds P) xs"
   unfolding wait_def alw_nxt_holds_cong[OF that] ..
 
 lemma alw_sfilter:
   "sfilter (\<lambda> x. P x \<and> Q x) xs = sfilter Q xs" if "alw (holds P) xs" "alw (ev (holds Q)) xs"
   using that
 proof (coinduction arbitrary: xs)
   case prems: stream_eq
   from prems(3,4) have ev_one: "ev (holds (\<lambda>x. P x \<and> Q x)) xs"
     by (subst ev_cong[of _ _ _ "holds Q"]) (assumption | auto)+
   from prems have "a = shd (sfilter (\<lambda>x. P x \<and> Q x) xs)" "b = shd (sfilter Q xs)"
     by (metis stream.sel(1))+
   with prems(3,4) have
     "a = xs !! (LEAST n. P (xs !! n) \<and> Q (xs !! n))" "b = xs !! (LEAST n. Q (xs !! n))"
     using ev_one by (auto 4 3 dest: sfilter_shd_LEAST)
   with alw_wait_holds_cong[unfolded wait_LEAST, OF \<open>alw (holds P) xs\<close>] have "a = b" by simp
-  from sfilter_SCons_decomp'[OF prems(1)[symmetric], OF ev_one] guess u2 by clarsimp
-  note guessed_a = this
+  from sfilter_SCons_decomp'[OF prems(1)[symmetric], OF ev_one]
+  obtain u2 where u2:
+    "xs = stake (wait (holds (\<lambda>x. P x \<and> Q x)) xs) xs @- a ## u2"
+    "u = sfilter (\<lambda>x. P x \<and> Q x) u2"
+    by auto
   have "ev (holds Q) xs" using prems(4) by blast
-  from sfilter_SCons_decomp'[OF prems(2)[symmetric], OF this] guess v2 by clarsimp
-  with guessed_a \<open>a = b\<close> show ?case
+  from sfilter_SCons_decomp'[OF prems(2)[symmetric], OF this]
+  obtain v2 where
+    "list_all (Not \<circ> Q) (stake (wait (holds Q) xs) xs)"
+    "xs = stake (wait (holds Q) xs) xs @- b ## v2"
+    "v = sfilter Q v2"
+    by auto
+  with u2 \<open>a = b\<close> show ?case
     apply (intro conjI exI)
         apply assumption+
       apply (simp add: alw_wait_holds_cong[OF prems(3)], metis shift_left_inj stream.inject)
     by (metis alw.cases alw_shift prems(3,4) stream.sel(2))+
 qed
 
 lemma alw_ev_holds_mp:
   "alw (holds P) xs \<Longrightarrow> ev (holds Q) xs \<Longrightarrow> ev (holds (\<lambda>x. P x \<and> Q x)) xs"
   by (subst ev_cong, assumption) auto
 
 lemma alw_ev_conjI:
   "alw (ev (holds (\<lambda> x. P x \<and> Q x))) xs" if "alw (holds P) xs" "alw (ev (holds Q)) xs"
   using that(2,1) by - (erule alw_mp, coinduction arbitrary: xs, auto intro: alw_ev_holds_mp)
 
 subsection \<open>Useful?\<close>
 
 lemma alw_holds_pred_stream_iff:
   "alw (holds P) xs \<longleftrightarrow> pred_stream P xs"
   by (simp add: alw_iff_sdrop stream_pred_snth)
 
 lemma alw_holds_sset:
   "alw (holds P) xs = (\<forall> x \<in> sset xs. P x)"
   by (simp add: alw_holds_pred_stream_iff stream.pred_set)
 
 lemma pred_stream_sfilter:
   assumes alw_ev: "alw (ev (holds P)) xs"
   shows "pred_stream P (sfilter P xs)"
   using alw_ev
 proof (coinduction arbitrary: xs)
   case (stream_pred xs)
   then have "ev (holds P) xs" by auto
   have "sfilter P xs = shd (sfilter P xs) ## stl (sfilter P xs)"
     by (cases "sfilter P xs") auto
-  from sfilter_SCons_decomp[OF this \<open>ev (holds P) xs\<close>] guess ys' zs' by clarsimp
+  from sfilter_SCons_decomp[OF this \<open>ev (holds P) xs\<close>]
+  obtain ys' zs' where
+    "xs = ys' @- shd (sdrop_while (Not \<circ> P) xs) ## zs'"
+    "P (shd (sdrop_while (Not \<circ> P) xs))"
+    "sfilter P zs' = sfilter P (stl (sdrop_while (Not \<circ> P) xs))"
+    by auto
   then show ?case
     apply (inst_existentials zs')
     apply (metis sfilter.simps(1) stream.sel(1) stream_pred(1))
     apply (metis scons_eq sfilter.simps(2) stream_pred(1))
     apply (metis alw_ev_stl alw_shift stream.sel(2) stream_pred(2))
     done
 qed
 
 lemma alw_ev_sfilter_mono:
   assumes alw_ev: "alw (ev (holds P)) xs"
     and mono: "\<And> x. P x \<Longrightarrow> Q x"
   shows "pred_stream Q (sfilter P xs)"
   using stream.pred_mono[of P Q] assms pred_stream_sfilter by blast
 
 lemma sset_sfilter:
   "sset (sfilter P xs) \<subseteq> sset xs" if "alw (ev (holds P)) xs"
 proof -
   have "alw (holds (\<lambda> x. x \<in> sset xs)) xs" by (simp add: alw_iff_sdrop)
   with \<open>alw (ev _) _\<close> alw_sfilter[OF this \<open>alw (ev _) _\<close>, symmetric]
     have "pred_stream (\<lambda> x. x \<in> sset xs) (sfilter P xs)"
     by (simp) (rule alw_ev_sfilter_mono; auto intro: alw_ev_conjI)
   then have "\<forall> x \<in> sset (sfilter P xs). x \<in> sset xs" unfolding stream.pred_set by this
   then show ?thesis by blast
 qed
 
 lemma stream_all2_weaken:
   "stream_all2 Q xs ys" if "stream_all2 P xs ys" "\<And> x y. P x y \<Longrightarrow> Q x y"
   using that by (coinduction arbitrary: xs ys) auto
 
 lemma stream_all2_SCons1:
   "stream_all2 P (x ## xs) ys = (\<exists>z zs. ys = z ## zs \<and> P x z \<and> stream_all2 P xs zs)"
   by (subst (3) stream.collapse[symmetric], simp del: stream.collapse, force)
 
 lemma stream_all2_SCons2:
   "stream_all2 P xs (y ## ys) = (\<exists>z zs. xs = z ## zs \<and> P z y \<and> stream_all2 P zs ys)"
   by (subst stream.collapse[symmetric], simp del: stream.collapse, force)
 
 lemma stream_all2_combine:
   "stream_all2 R xs zs" if
   "stream_all2 P xs ys" "stream_all2 Q ys zs" "\<And> x y z. P x y \<and> Q y z \<Longrightarrow> R x z"
   using that(1,2)
   by (coinduction arbitrary: xs ys zs)
      (auto intro: that(3) simp: stream_all2_SCons1 stream_all2_SCons2)
 
 lemma stream_all2_shift1:
   "stream_all2 P (xs1 @- xs2) ys =
   (\<exists> ys1 ys2. ys = ys1 @- ys2 \<and> list_all2 P xs1 ys1 \<and> stream_all2 P xs2 ys2)"
   apply (induction xs1 arbitrary: ys)
    apply (simp; fail)
   apply (simp add: stream_all2_SCons1 list_all2_Cons1)
   apply safe
   subgoal for a xs1 ys z zs ys1 ys2
     by (inst_existentials "z # ys1" ys2; simp)
   subgoal for a xs1 ys ys1 ys2 z zs
     by (inst_existentials z "zs @- ys2" zs "ys2"; simp)
   done
 
 lemma stream_all2_shift2:
   "stream_all2 P ys (xs1 @- xs2) =
   (\<exists> ys1 ys2. ys = ys1 @- ys2 \<and> list_all2 P ys1 xs1 \<and> stream_all2 P ys2 xs2)"
   by (meson list.rel_flip stream.rel_flip stream_all2_shift1)
 
 lemma stream_all2_bisim:
   assumes "stream_all2 (\<in>) xs as" "stream_all2 (\<in>) ys as" "sset as \<subseteq> S"
   shows "stream_all2 (\<lambda> x y. \<exists> a. x \<in> a \<and> y \<in> a \<and> a \<in> S) xs ys"
   using assms
   apply (coinduction arbitrary: as xs ys)
   subgoal for a u b v as xs ys
     apply (rule conjI)
      apply (inst_existentials "shd as", auto simp: stream_all2_SCons1; fail)
     apply (inst_existentials "stl as", auto 4 3 simp: stream_all2_SCons1; fail)
     done
   done
 
 
 
 end
diff --git a/thys/Propositional_Proof_Systems/Compactness.thy b/thys/Propositional_Proof_Systems/Compactness.thy
--- a/thys/Propositional_Proof_Systems/Compactness.thy
+++ b/thys/Propositional_Proof_Systems/Compactness.thy
@@ -1,312 +1,312 @@
 subsection\<open>Compactness\<close>
 
 theory Compactness
 imports Sema
 begin
 
 lemma fin_sat_extend: "fin_sat S \<Longrightarrow> fin_sat (insert F S) \<or> fin_sat (insert (\<^bold>\<not>F) S)"
 proof (rule ccontr)
   assume fs: "fin_sat S"
   assume nfs: "\<not> (fin_sat (insert F S) \<or> fin_sat (insert (\<^bold>\<not> F) S))"
   from nfs obtain s1 where s1: "s1 \<subseteq> insert F S"       "finite s1" "\<not>sat s1" unfolding fin_sat_def by blast
   from nfs obtain s2 where s2: "s2 \<subseteq> insert (Not F) S" "finite s2" "\<not>sat s2" unfolding fin_sat_def by blast
   let ?u = "(s1 - {F}) \<union> (s2 - {Not F})"
   have "?u \<subseteq> S" "finite ?u" using s1 s2 by auto
   hence "sat ?u" using fs unfolding fin_sat_def by blast
   then obtain A where A: "\<forall>F \<in> ?u. A \<Turnstile> F" unfolding sat_def by blast
   have "A \<Turnstile> F \<or> A \<Turnstile> \<^bold>\<not>F" by simp
   hence "sat s1 \<or> sat s2" using A unfolding sat_def by(fastforce intro!: exI[where x=A])
   thus False using s1(3) s2(3) by simp
 qed
 
 context
 begin
 
 lemma fin_sat_antimono: "fin_sat F \<Longrightarrow> G \<subseteq> F \<Longrightarrow> fin_sat G" unfolding fin_sat_def by simp
 lemmas fin_sat_insert = fin_sat_antimono[OF _ subset_insertI]
 
 primrec extender :: "nat \<Rightarrow> ('a :: countable) formula set \<Rightarrow> 'a formula set" where
 "extender 0 S = S" |
 "extender (Suc n) S = (
   let r = extender n S; 
   rt = insert (from_nat n) r;
   rf = insert (\<^bold>\<not>(from_nat n)) r
   in if fin_sat rf then rf else rt
 )"
 
 private lemma extender_fin_sat: "fin_sat S \<Longrightarrow> fin_sat (extender n S)"
 proof(induction n arbitrary: S)
   case (Suc n)
   note mIH = Suc.IH[OF Suc.prems]
   show ?case proof(cases "fin_sat (insert (Not (from_nat n)) (extender n S))")
     case True thus ?thesis by simp
   next
     case False
     hence "fin_sat (insert ((from_nat n)) (extender n S))" using mIH fin_sat_extend by auto
     thus ?thesis by(simp add: Let_def)
   qed
 qed simp
 
 definition "extended S = \<Union>{extender n S|n. True}"
 
 lemma extended_max: "F \<in> extended S \<or> Not F \<in> extended S"
 proof -
   obtain n where [simp]: "F = from_nat n" by (metis from_nat_to_nat)
   have "F \<in> extender (Suc n) S \<or> Not F \<in> extender (Suc n) S" by(simp add: Let_def)
   thus ?thesis unfolding extended_def by blast
 qed
 
 private lemma extender_Sucset: "extender k S \<subseteq> extender (Suc k) S" by(force simp add: Let_def)
 private lemma extender_deeper: "F \<in> extender k S \<Longrightarrow> k \<le> l \<Longrightarrow> F \<in> extender l S" using extender_Sucset le_Suc_eq
   by(induction l) (auto simp del: extender.simps)
 private lemma extender_subset: "S \<subseteq> extender k S"
 proof -
   from extender_deeper[OF _ le0] have "F \<in> extender 0 Sa \<Longrightarrow> F \<in> extender l Sa" for Sa l F .
   thus ?thesis by auto
 qed
 
 lemma extended_fin_sat: 
   assumes "fin_sat S"
   shows  "fin_sat (extended S)"
 proof -
   have assm: "\<lbrakk>s \<subseteq> extender n S; finite s\<rbrakk> \<Longrightarrow> sat s" for s n
     using extender_fin_sat[OF assms] unfolding fin_sat_def by presburger
   hence "sat s" if su: "s \<subseteq> \<Union>{extender n S |n. True}" and fin: "finite s" for s proof -
     { fix x assume e: "x \<in> s"
       with su have "x \<in> \<Union>{extender n S |n. True}" by blast
       hence "\<exists>n. x \<in> extender n S" unfolding Union_eq by blast }
     hence "\<forall>x \<in> s. \<exists>n. x \<in> extender n S" by blast
     from finite_set_choice[OF fin this] obtain f where cf: "\<forall>x\<in>s. x \<in> extender (f x) S" ..
     have "\<exists>k. s \<subseteq> \<Union>{extender n S |n. n \<le> k}" proof(intro exI subsetI)
       fix x assume e: "x \<in> s"
       with cf have "x \<in> extender (f x) S" ..
       hence "x \<in> extender (Max (f ` s)) S" by(elim extender_deeper; simp add: e fin)
       thus "x \<in> \<Union>{extender n S |n. n \<le> Max (f ` s)}" by blast
     qed
     moreover have "\<Union>{extender n S |n. n \<le> k} = extender k S" for k proof(induction k) 
       case (Suc k)
       moreover have "\<Union>{extender n S |n. n \<le> Suc k} = \<Union>{extender n S |n. n \<le> k} \<union> extender (Suc k) S" 
         unfolding Union_eq le_Suc_eq
         using le_Suc_eq by(auto simp del: extender.simps)
       ultimately show ?case using extender_Sucset by(force simp del: extender.simps)
     qed simp
     ultimately show "sat s" using assm fin by auto
   qed
   thus ?thesis unfolding extended_def fin_sat_def by presburger
 qed
 
 lemma extended_superset: "S \<subseteq> extended S" unfolding extended_def using extender.simps(1) by blast
 
 lemma extended_complem:
   assumes fs: "fin_sat S"
   shows "(F \<in> extended S) \<noteq> (Not F \<in> extended S)"
 proof -
   note fs = fs[THEN extended_fin_sat]
   show ?thesis proof(cases "F \<in> extended S")
     case False with extended_max show ?thesis by blast
   next
     case True have "Not F \<notin> extended S" proof 
       assume False: "Not F \<in> extended S"
       with True have "{F, Not F} \<subseteq> extended S" by blast
       moreover have "finite {F, Not F}" by simp
       ultimately have "sat {F, Not F}" using fs unfolding fin_sat_def by blast
       thus False unfolding sat_def by simp
     qed
     with True show ?thesis by blast
   qed
 qed
 
 lemma not_fin_sat_extended_UNIV: fixes S :: "'a :: countable formula set" assumes "\<not>fin_sat S" shows "extended S = UNIV" 
 text\<open>Note that this crucially depends on the fact that we check \emph{first} whether adding @{term "\<^bold>\<not>F"} makes the set not satisfiable, 
   and add @{term F} otherwise \emph{without any further checks}.
   The proof of compactness does (to the best of my knowledge) depend on neither of these two facts.\<close>
 proof -
   from assms[unfolded fin_sat_def, simplified] obtain s :: "'a :: countable formula set"
     where "finite s" "\<not> sat s" by clarify
   from this(2)[unfolded sat_def, simplified] have "\<exists>x\<in>s. \<not> A \<Turnstile> x" for A ..
   have nfs: "\<not>fin_sat (insert x (extender n S))" for n x 
     apply(rule notI)
     apply(drule fin_sat_insert)
     apply(drule fin_sat_antimono)
      apply(rule extender_subset)
     apply(erule notE[rotated])
     apply(fact assms)
   done
   have "x \<in> \<Union>{extender n S |n. True}" for x proof cases
     assume "x \<in> S" thus ?thesis by (metis extended_def extended_superset insert_absorb insert_subset)
   next
     assume "x \<notin> S"
     have "x \<in> extender (Suc (to_nat x)) S" 
       unfolding extender.simps Let_def
       unfolding if_not_P[OF nfs] by simp
     thus ?thesis by blast
   qed
   thus ?thesis unfolding extended_def by auto
 qed
 
 lemma extended_tran: "S \<subseteq> T \<Longrightarrow> extended S \<subseteq> extended T"
 text\<open>This lemma doesn't hold: think of making S empty and inserting a formula into T s.t. it can never be satisfied simultaneously with the first 
 non-tautological formula in the extension S. Showing that this is possible is not worth the effort, since we can't influence the ordering of formulae.
 But we showed it anyway.\<close>
 oops
 lemma extended_not_increasing: "\<exists>S T. fin_sat S \<and> fin_sat T \<and> \<not> (S \<subseteq> T \<longrightarrow> extended S \<subseteq> extended (T :: 'a :: countable formula set))"
 proof -
   have ex_then_min: "\<exists>x :: nat. P x \<Longrightarrow> P (LEAST x. P x)" for P using LeastI2_wellorder by auto
   define P where "P x = (let F = (from_nat x :: 'a formula) in (\<exists>A. \<not> A \<Turnstile> F) \<and> (\<exists> A. A \<Turnstile> F))" for x
   define x where "x = (LEAST n. P n)"
   hence "\<exists>n. P n" unfolding P_def Let_def by(auto intro!: exI[where x="to_nat (Atom undefined :: 'a formula)"])
   from ex_then_min[OF this] have Px: "P x" unfolding x_def .
   have lessx: "n < x \<Longrightarrow> \<not> P n" for n unfolding x_def using not_less_Least by blast
   let ?S = "{} :: 'a formula set" let ?T = "{from_nat x :: 'a formula}"
   have s: "fin_sat ?S" "fin_sat ?T" using Px unfolding P_def fin_sat_def sat_def Let_def by fastforce+
   have reject: "Q A \<Longrightarrow> \<forall>A. \<not> Q A \<Longrightarrow> False" for A Q by simp
   have "y \<le> x \<Longrightarrow> F \<in> extender y ?S \<Longrightarrow> \<Turnstile> F" for F y
   proof(induction y arbitrary: F)
     case (Suc y)
     have *: "F \<in> extender y {} \<Longrightarrow> \<Turnstile> F" for F :: "'a formula" using Suc.IH Suc.prems(1) by auto
     let ?Y = "from_nat y :: 'a formula"
     have ex: "(\<forall>A. \<not> A \<Turnstile> ?Y) \<or> \<Turnstile> ?Y" unfolding formula_semantics.simps by (meson P_def Suc.prems(1) Suc_le_lessD lessx)
     have 1: "\<forall>A. \<not> A \<Turnstile> ?Y" if "fin_sat (Not ?Y \<triangleright> extender y ?S)"
     proof -
       note[[show_types]]
       from that have "\<exists>A. A \<Turnstile> Not ?Y" unfolding fin_sat_def sat_def  by(elim allE[where x="{Not ?Y}"]) simp
       hence "\<not>\<Turnstile> ?Y" by simp
       hence "\<forall>A. \<not> A \<Turnstile> ?Y" using ex by argo
       thus ?thesis by simp
     qed
     have 2: "\<not> fin_sat (Not ?Y \<triangleright> extender y ?S) \<Longrightarrow> \<Turnstile> ?Y"
     proof(erule contrapos_np)
       assume "\<not> \<Turnstile> ?Y"
       hence "\<forall>A. \<not> A \<Turnstile> ?Y" using ex by argo
       hence "\<Turnstile> \<^bold>\<not> ?Y" by simp
       thus "fin_sat (\<^bold>\<not> ?Y \<triangleright> extender y ?S)" unfolding fin_sat_def sat_def
         by(auto intro!: exI[where x="\<lambda>_ :: 'a. False"] dest!: rev_subsetD[rotated] *)
     qed
     show ?case using Suc.prems(2) by(simp add: Let_def split: if_splits; elim disjE; simp add: * 1 2)
   qed simp
   hence "fin_sat (\<^bold>\<not> (from_nat x) \<triangleright> extender x ?S)" using Px unfolding P_def Let_def
     by (clarsimp simp: fin_sat_def sat_def) (insert formula_semantics.simps(3), blast)
   hence "Not (from_nat x) \<in> extender (Suc x) ?S" by(simp)
   hence "Not (from_nat x) \<in> extended ?S" unfolding extended_def by blast
   moreover have "Not (from_nat x) \<notin> extended ?T" using extended_complem extended_superset s(2) by blast
   ultimately show ?thesis using s by blast
 qed
 
 private lemma not_in_extended_FE: "fin_sat S \<Longrightarrow> (\<not>sat (insert (Not F) G)) \<Longrightarrow> F \<notin> extended S \<Longrightarrow> G \<subseteq> extended S \<Longrightarrow> finite G \<Longrightarrow> False"
 proof(goal_cases)
   case 1
   hence "Not F \<in> extended S" using extended_max by blast
   thus False using 1 extended_fin_sat fin_sat_def
     by (metis Diff_eq_empty_iff finite.insertI insert_Diff_if)
 qed
   
 lemma extended_id: "extended (extended S) = extended S" 
   using extended_complem extended_fin_sat extended_max extended_superset not_fin_sat_extended_UNIV 
   by(intro equalityI[rotated] extended_superset) blast
   
 (* This would be nicer, though\<dots> 
 inductive_set extended_set :: "form set \<Rightarrow> form set" for S where
 "F \<in> S \<Longrightarrow> F \<in> extended_set S" |
 "fin_sat (insert F (extended_set S)) \<or> F \<in> extended_set S \<Longrightarrow> F \<in> extended_set S"
 but it can't work, as extended is not increasing (?) *)
   
 lemma ext_model:
   assumes r: "fin_sat S"
   shows "(\<lambda>k. Atom k \<in> extended S) \<Turnstile> F \<longleftrightarrow> F \<in> extended S"
 proof -
   note fs = r[THEN extended_fin_sat]
   have Elim: "F \<in> S \<and> G \<in> S \<Longrightarrow> {F,G} \<subseteq> S" "F \<in> S \<Longrightarrow> {F} \<subseteq> S" for F G S by simp+
   show ?thesis
   proof(induction F)
     case Atom thus ?case by(simp)
   next
     case Bot
     have False if "\<bottom> \<in> extended S" proof -
       have "finite {\<bottom>}" by simp
       moreover from that have "{\<bottom>} \<subseteq> extended S" by simp
       ultimately have "\<exists>A. A \<Turnstile> \<bottom>" using fs unfolding fin_sat_def sat_def
         by(elim allE[of _ "{\<bottom>}"]) simp
       thus False by simp
     qed
     thus ?case by auto
   next
     case (Not F)
     moreover have "A \<Turnstile> F \<noteq> A \<Turnstile> \<^bold>\<not>F" for A F by simp
     ultimately show ?case using extended_complem[OF r] by blast
   next
     case (And F G)
     have "(F \<in> extended S \<and> G \<in> extended S) = (F \<^bold>\<and> G \<in> extended S)" proof -
       have *: "\<not>sat {\<^bold>\<not> (F \<^bold>\<and> G), F, G}" "\<not>sat {\<^bold>\<not> F, (F \<^bold>\<and> G)}" "\<not>sat {\<^bold>\<not> G, (F \<^bold>\<and> G)}" unfolding sat_def by auto
       show ?thesis by(intro iffI; rule ccontr) (auto intro: *[THEN not_in_extended_FE[OF r]])
     qed
     thus ?case by(simp add: And) 
   next
     case (Or F G)
     have "(F \<in> extended S \<or> G \<in> extended S) = (F \<^bold>\<or> G \<in> extended S)" proof -
       have "\<not>sat {\<^bold>\<not>(F \<^bold>\<or> G), F}" "\<not>sat {\<^bold>\<not>(F \<^bold>\<or> G), G}" unfolding sat_def by auto
       from this[THEN not_in_extended_FE[OF r]] have 1: "\<lbrakk>F \<in> extended S \<or> G \<in> extended S; F \<^bold>\<or> G \<notin> extended S\<rbrakk> \<Longrightarrow> False" by auto
       have "\<not>sat {\<^bold>\<not>F, \<^bold>\<not>G, F \<^bold>\<or> G}" unfolding sat_def by auto
       hence 2: "\<lbrakk>F \<^bold>\<or> G \<in> extended S; F \<notin> extended S; G \<notin> extended S\<rbrakk> \<Longrightarrow> False" using extended_max not_in_extended_FE[OF r] by fastforce
       show ?thesis by(intro iffI; rule ccontr) (auto intro: 1 2)
     qed
     thus ?case by(simp add: Or)
   next
     case (Imp F G)
     have "(F \<in> extended S \<longrightarrow> G \<in> extended S) = (F \<^bold>\<rightarrow> G \<in> extended S)" proof -
       have "\<not>sat {\<^bold>\<not>G, F, F \<^bold>\<rightarrow> G}" unfolding sat_def by auto
       hence 1: "\<lbrakk>F \<^bold>\<rightarrow> G \<in> extended S; F \<in> extended S; G \<notin> extended S\<rbrakk> \<Longrightarrow> False" using extended_max not_in_extended_FE[OF r] by blast
       have "\<not>sat {\<^bold>\<not>F,\<^bold>\<not>(F \<^bold>\<rightarrow> G)}" unfolding sat_def by auto
       hence 2: "\<lbrakk>F \<^bold>\<rightarrow> G \<notin> extended S; F \<notin> extended S\<rbrakk> \<Longrightarrow> False" using extended_max not_in_extended_FE[OF r] by blast
       have "\<not>sat {\<^bold>\<not>(F \<^bold>\<rightarrow> G),G}" unfolding sat_def by auto
       hence 3: "\<lbrakk>F \<^bold>\<rightarrow> G \<notin> extended S; G \<in> extended S\<rbrakk> \<Longrightarrow> False" using extended_max not_in_extended_FE[OF r] by blast
       show ?thesis by(intro iffI; rule ccontr) (auto intro: 1 2 3)
     qed
     thus ?case by(simp add: Imp)
   qed
 qed
 
 theorem compactness:
   fixes S :: "'a :: countable formula set"
   shows "sat S \<longleftrightarrow> fin_sat S" (is "?l = ?r")
 proof
   assume ?l thus ?r unfolding sat_def fin_sat_def by blast
 next
   assume r: ?r
   note ext_model[OF r, THEN iffD2]
   hence "\<forall>F\<in>S. (\<lambda>k. Atom k \<in> extended S) \<Turnstile> F" using extended_superset by blast
   thus ?l unfolding sat_def by blast
 qed
 
 corollary compact_entailment:
   fixes F :: "'a :: countable formula"
   assumes fent: "\<Gamma> \<TTurnstile> F"
   shows "\<exists>\<Gamma>'. finite \<Gamma>' \<and> \<Gamma>' \<subseteq> \<Gamma> \<and> \<Gamma>' \<TTurnstile> F"
 proof -
   have ND_sem:  "\<Gamma> \<TTurnstile> F \<longleftrightarrow> \<not>sat (insert (\<^bold>\<not>F) \<Gamma>)" 
     for \<Gamma> F unfolding sat_def entailment_def by auto
   obtain \<Gamma>' where 0: "finite \<Gamma>'" "\<Gamma>' \<TTurnstile> F" "\<Gamma>' \<subseteq> \<Gamma>" proof(goal_cases)
     from fent[unfolded ND_sem compactness] have "\<not> fin_sat (insert (\<^bold>\<not> F) \<Gamma>)" .
     from this[unfolded fin_sat_def] obtain s where s: "s \<subseteq> insert(\<^bold>\<not>F) \<Gamma>" "finite s" "\<not>sat s" by blast
     have 2: "finite (s - {\<^bold>\<not> F})" using s by simp
     have 3: "s - {\<^bold>\<not> F} \<TTurnstile> F" unfolding ND_sem using s(3) unfolding sat_def by blast
     have 4: "s - {\<^bold>\<not> F} \<subseteq> \<Gamma>" using s by blast
     case 1 from 2 3 4 show ?case by(intro 1[of "s - {Not F}"])
   qed
   thus ?thesis by blast
 qed
   
 corollary compact_to_formula:
   fixes F :: "'a :: countable formula"
   assumes fent: "\<Gamma> \<TTurnstile> F"
   obtains \<Gamma>' where "set \<Gamma>' \<subseteq> \<Gamma>" "\<Turnstile> (\<^bold>\<And>\<Gamma>') \<^bold>\<rightarrow> F"
 proof goal_cases
   case 1
-  note compact_entailment[OF assms]
-  then guess \<Gamma>' ..
-  moreover then obtain \<Gamma>'' where "\<Gamma>' = set \<Gamma>''" using finite_list by auto
-  ultimately show thesis by(intro 1)  (blast, simp add: entailment_def)
+  from compact_entailment[OF assms]
+  obtain \<Gamma>' where \<Gamma>': "finite \<Gamma>' \<and> \<Gamma>' \<subseteq> \<Gamma> \<and> \<Gamma>' \<TTurnstile> F" ..
+  then obtain \<Gamma>'' where "\<Gamma>' = set \<Gamma>''" using finite_list by auto
+  with \<Gamma>' show thesis by(intro 1)  (blast, simp add: entailment_def)
 qed
 
 end
     
 end
diff --git a/thys/Propositional_Proof_Systems/Consistency.thy b/thys/Propositional_Proof_Systems/Consistency.thy
--- a/thys/Propositional_Proof_Systems/Consistency.thy
+++ b/thys/Propositional_Proof_Systems/Consistency.thy
@@ -1,359 +1,358 @@
 subsection\<open>Consistency\<close>
 
 text\<open>We follow the proofs by Melvin Fitting~\cite{fitting1990first}.\<close>
 theory Consistency
 imports Sema
 begin
 
 definition "Hintikka S \<equiv> (
   \<bottom> \<notin> S
 \<and> (\<forall>k. Atom k \<in> S \<longrightarrow> \<^bold>\<not> (Atom k) \<in> S \<longrightarrow> False)
 \<and> (\<forall>F G. F \<^bold>\<and> G \<in> S \<longrightarrow> F \<in> S \<and> G \<in> S)
 \<and> (\<forall>F G. F \<^bold>\<or> G \<in> S \<longrightarrow> F \<in> S \<or> G \<in> S)
 \<and> (\<forall>F G. F \<^bold>\<rightarrow> G \<in> S \<longrightarrow> \<^bold>\<not>F \<in> S \<or> G \<in> S)
 \<and> (\<forall>F. \<^bold>\<not> (\<^bold>\<not>F) \<in> S \<longrightarrow> F \<in> S)
 \<and> (\<forall>F G. \<^bold>\<not>(F \<^bold>\<and> G) \<in> S \<longrightarrow> \<^bold>\<not> F \<in> S \<or> \<^bold>\<not> G \<in> S)
 \<and> (\<forall>F G. \<^bold>\<not>(F \<^bold>\<or> G) \<in> S \<longrightarrow> \<^bold>\<not> F \<in> S \<and> \<^bold>\<not> G \<in> S)
 \<and> (\<forall>F G. \<^bold>\<not>(F \<^bold>\<rightarrow> G) \<in> S \<longrightarrow> F \<in> S \<and> \<^bold>\<not> G \<in> S)
 )"
 
 lemma "Hintikka {Atom 0 \<^bold>\<and> ((\<^bold>\<not> (Atom 1)) \<^bold>\<rightarrow> Atom 2), ((\<^bold>\<not> (Atom 1)) \<^bold>\<rightarrow> Atom 2), Atom 0, \<^bold>\<not>(\<^bold>\<not> (Atom 1)), Atom 1}"
   unfolding Hintikka_def by simp
 
 theorem Hintikkas_lemma:
   assumes H: "Hintikka S"
   shows "sat S"
 proof -
   from H[unfolded Hintikka_def]
   have H': "\<bottom> \<notin> S" 
     "Atom k \<in> S \<Longrightarrow> \<^bold>\<not> (Atom k) \<in> S \<Longrightarrow> False"
     "F \<^bold>\<and> G \<in> S \<Longrightarrow> F \<in> S \<and> G \<in> S"
     "F \<^bold>\<or> G \<in> S \<Longrightarrow> F \<in> S \<or> G \<in> S"
     "F \<^bold>\<rightarrow> G \<in> S \<Longrightarrow> \<^bold>\<not>F \<in> S \<or> G \<in> S"
     "\<^bold>\<not> (\<^bold>\<not> F) \<in> S \<Longrightarrow> F \<in> S"
     "\<^bold>\<not> (F \<^bold>\<and> G) \<in> S \<Longrightarrow> \<^bold>\<not> F \<in> S \<or> \<^bold>\<not> G \<in> S"
     "\<^bold>\<not> (F \<^bold>\<or> G) \<in> S \<Longrightarrow> \<^bold>\<not> F \<in> S \<and> \<^bold>\<not> G \<in> S"
     "\<^bold>\<not> (F \<^bold>\<rightarrow> G) \<in> S \<Longrightarrow> F \<in> S \<and> \<^bold>\<not> G \<in> S"
     for k F G by blast+
   let ?M = "\<lambda>k. Atom k \<in> S"
   have "(F \<in> S \<longrightarrow> (?M \<Turnstile> F)) \<and> (\<^bold>\<not> F \<in> S \<longrightarrow> (\<not>(?M \<Turnstile> F)))" for F
     by(induction F) (auto simp: H'(1) dest!: H'(2-))
   thus ?thesis unfolding sat_def by blast
 qed
 
 definition "pcp C \<equiv> (\<forall>S \<in> C.
   \<bottom> \<notin> S
 \<and> (\<forall>k. Atom k \<in> S \<longrightarrow> \<^bold>\<not> (Atom k) \<in> S \<longrightarrow> False)
 \<and> (\<forall>F G. F \<^bold>\<and> G \<in> S \<longrightarrow> F \<triangleright> G \<triangleright> S \<in> C)
 \<and> (\<forall>F G. F \<^bold>\<or> G \<in> S \<longrightarrow> F \<triangleright> S \<in> C \<or> G \<triangleright> S \<in> C)
 \<and> (\<forall>F G. F \<^bold>\<rightarrow> G \<in> S \<longrightarrow> \<^bold>\<not>F \<triangleright> S \<in> C \<or> G \<triangleright> S \<in> C)
 \<and> (\<forall>F. \<^bold>\<not> (\<^bold>\<not>F) \<in> S \<longrightarrow> F \<triangleright> S \<in> C)
 \<and> (\<forall>F G. \<^bold>\<not>(F \<^bold>\<and> G) \<in> S \<longrightarrow> \<^bold>\<not> F \<triangleright> S \<in> C \<or> \<^bold>\<not> G \<triangleright> S \<in> C)
 \<and> (\<forall>F G. \<^bold>\<not>(F \<^bold>\<or> G) \<in> S \<longrightarrow> \<^bold>\<not> F \<triangleright> \<^bold>\<not> G \<triangleright> S \<in> C)
 \<and> (\<forall>F G. \<^bold>\<not>(F \<^bold>\<rightarrow> G) \<in> S \<longrightarrow> F \<triangleright> \<^bold>\<not> G \<triangleright> S \<in> C)
 )"
 
 (* just some examples *)
 lemma "pcp {}" "pcp {{}}" "pcp {{Atom 0}}" by (simp add: pcp_def)+
 lemma "pcp {{(\<^bold>\<not> (Atom 1)) \<^bold>\<rightarrow> Atom 2},
    {((\<^bold>\<not> (Atom 1)) \<^bold>\<rightarrow> Atom 2), \<^bold>\<not>(\<^bold>\<not> (Atom 1))},
   {((\<^bold>\<not> (Atom 1)) \<^bold>\<rightarrow> Atom 2), \<^bold>\<not>(\<^bold>\<not> (Atom 1)),  Atom 1}}" by (auto simp add: pcp_def)
 
 text\<open>Fitting uses uniform notation~\cite{smullyan1963unifying} for the definition of @{const pcp}. 
 We try to mimic this, more to see whether it works than because it is ultimately necessary.\<close>
 (* It does help a bit, occasionally. *)
     
 inductive Con :: "'a formula => 'a formula => 'a formula => bool" where
 "Con (And F G) F G" |
 "Con (Not (Or F G)) (Not F) (Not G)" |
 "Con (Not (Imp F G)) F (Not G)" |
 "Con (Not (Not F)) F F"
 
 inductive Dis :: "'a formula => 'a formula => 'a formula => bool" where
 "Dis (Or F G) F G" |
 "Dis (Imp F G) (Not F) G" |
 "Dis (Not (And F G)) (Not F) (Not G)" |
 "Dis (Not (Not F)) F F"
 
 (* note that *)
 lemma "Con (Not (Not F)) F F" "Dis (Not (Not F)) F F" by(intro Con.intros Dis.intros)+
 (* i.e. \<^bold>\<not>\<^bold>\<not> is both Conjunctive and Disjunctive. I saw no reason to break this symmetry. *)
 
 lemma con_dis_simps:
   "Con a1 a2 a3 = (a1 = a2 \<^bold>\<and> a3 \<or> (\<exists>F G. a1 = \<^bold>\<not> (F \<^bold>\<or> G) \<and> a2 = \<^bold>\<not> F \<and> a3 = \<^bold>\<not> G) \<or> (\<exists>G. a1 = \<^bold>\<not> (a2 \<^bold>\<rightarrow> G) \<and> a3 = \<^bold>\<not> G) \<or> a1 = \<^bold>\<not> (\<^bold>\<not> a2) \<and> a3 = a2)"
   "Dis a1 a2 a3 = (a1 = a2 \<^bold>\<or> a3 \<or> (\<exists>F G. a1 = F \<^bold>\<rightarrow> G \<and> a2 = \<^bold>\<not> F \<and> a3 = G) \<or> (\<exists>F G. a1 = \<^bold>\<not> (F \<^bold>\<and> G) \<and> a2 = \<^bold>\<not> F \<and> a3 = \<^bold>\<not> G) \<or> a1 = \<^bold>\<not> (\<^bold>\<not> a2) \<and> a3 = a2)"
   by(simp_all add: Con.simps Dis.simps)
 
 lemma Hintikka_alt: "Hintikka S = (
   \<bottom> \<notin> S
 \<and> (\<forall>k. Atom k \<in> S \<longrightarrow> \<^bold>\<not> (Atom k) \<in> S \<longrightarrow> False)
 \<and> (\<forall>F G H. Con F G H \<longrightarrow> F \<in> S \<longrightarrow> G \<in> S \<and> H \<in> S)
 \<and> (\<forall>F G H. Dis F G H \<longrightarrow> F \<in> S \<longrightarrow> G \<in> S \<or> H \<in> S)
 )"  
   apply(simp add: Hintikka_def con_dis_simps)
   apply(rule iffI)
     (* simp only: \<emptyset> loops. :( *)
    subgoal by blast
   subgoal by safe metis+
 done
 
 lemma pcp_alt: "pcp C = (\<forall>S \<in> C.
   \<bottom> \<notin> S
 \<and> (\<forall>k. Atom k \<in> S \<longrightarrow> \<^bold>\<not> (Atom k) \<in> S \<longrightarrow> False)
 \<and> (\<forall>F G H. Con F G H \<longrightarrow> F \<in> S \<longrightarrow> G \<triangleright> H \<triangleright> S \<in> C)
 \<and> (\<forall>F G H. Dis F G H \<longrightarrow> F \<in> S \<longrightarrow> G \<triangleright> S \<in> C \<or> H \<triangleright> S \<in> C)
 )"
   apply(simp add: pcp_def con_dis_simps)
   apply(rule iffI; unfold Ball_def; elim all_forward)
   by (auto simp add: insert_absorb split: formula.splits)
   
 definition "subset_closed C \<equiv> (\<forall>S \<in> C. \<forall>s\<subseteq>S. s \<in> C)"
 definition "finite_character C \<equiv> (\<forall>S. S \<in> C \<longleftrightarrow> (\<forall>s \<subseteq> S. finite s \<longrightarrow> s \<in> C))"
 
 lemma ex1: "pcp C \<Longrightarrow> \<exists>C'. C \<subseteq> C' \<and> pcp C' \<and> subset_closed C'"
 proof(intro exI[of _ "{s . \<exists>S \<in> C. s \<subseteq> S}"] conjI)
   let ?E = "{s. \<exists>S\<in>C. s \<subseteq> S}"
   show "C \<subseteq> ?E" by blast
   show "subset_closed ?E" unfolding subset_closed_def by blast
   assume C: \<open>pcp C\<close>
   show "pcp ?E" using C unfolding pcp_alt
     by (intro ballI conjI; simp; meson insertI1 rev_subsetD subset_insertI subset_insertI2)
 qed
 
 lemma sallI: "(\<And>s. s \<subseteq> S \<Longrightarrow> P s) \<Longrightarrow> \<forall>s \<subseteq> S. P s" by simp 
 
 lemma ex2: 
   assumes fc: "finite_character C"
   shows "subset_closed C"
   unfolding subset_closed_def
 proof (intro ballI sallI)
   fix s S
   assume e: \<open>S \<in> C\<close> and s: \<open>s \<subseteq> S\<close>
   hence *: "t \<subseteq> s \<Longrightarrow> t \<subseteq> S" for t by simp
   from fc have "t \<subseteq> S \<Longrightarrow> finite t \<Longrightarrow> t \<in> C" for t unfolding finite_character_def using e by blast
   hence "t \<subseteq> s \<Longrightarrow> finite t \<Longrightarrow> t \<in> C" for t using * by simp
   with fc show \<open>s \<in> C\<close> unfolding finite_character_def by blast
 qed
 
 lemma
   assumes C: "pcp C"
   assumes S: "subset_closed C"
   shows ex3: "\<exists>C'. C \<subseteq> C' \<and> pcp C' \<and> finite_character C'"
 proof(intro exI[of _ "C \<union> {S. \<forall>s \<subseteq> S. finite s \<longrightarrow> s \<in> C}"] conjI)
   let ?E = " {S. \<forall>s \<subseteq> S. finite s \<longrightarrow> s \<in> C}"
   show "C \<subseteq> C \<union> ?E" by blast
   from S show "finite_character (C \<union> ?E)" unfolding finite_character_def subset_closed_def by blast
   note C'' = C[unfolded pcp_alt, THEN bspec]
     
   (* uniform notation. what did I learn? only slightly more elegant\<dots> *)
   have CON: "G \<triangleright> H \<triangleright> S \<in> C \<union> {S. \<forall>s\<subseteq>S. finite s \<longrightarrow> s \<in> C}" if si: "\<And>s. \<lbrakk>s\<subseteq>S; finite s\<rbrakk> \<Longrightarrow> s \<in> C" and
     un: "Con F G H" and el: " F \<in> S" for F G H S proof -
     have k: "\<forall>s \<subseteq> S. finite s \<longrightarrow> F \<in> s \<longrightarrow> G \<triangleright> H \<triangleright> s \<in> C"
       using si un C'' by simp
     have "G \<triangleright> H \<triangleright> S \<in> ?E"
       unfolding mem_Collect_eq Un_iff proof safe
       fix s
       assume "s \<subseteq> G \<triangleright> H \<triangleright> S" and f: "finite s"
       hence "F \<triangleright> (s - {G,H}) \<subseteq> S" using el by blast
       with k f have "G \<triangleright> H \<triangleright> F \<triangleright> (s - {G,H}) \<in> C" by simp
       hence "F \<triangleright> G \<triangleright> H \<triangleright> s \<in> C" using insert_absorb by fastforce
       thus "s \<in> C" using S unfolding subset_closed_def by fast  
     qed
     thus "G \<triangleright> H \<triangleright> S \<in> C \<union> ?E" by simp
   qed
   have DIS: "G \<triangleright> S \<in> C \<union> {S. \<forall>s\<subseteq>S. finite s \<longrightarrow> s \<in> C} \<or> H \<triangleright> S \<in> C \<union> {S. \<forall>s\<subseteq>S. finite s \<longrightarrow> s \<in> C}" 
     if si: "\<And>s. s\<subseteq>S \<Longrightarrow> finite s \<Longrightarrow> s \<in> C" and un: "Dis F G H" and el: "F \<in> S"
     for F G H S proof -
     have l: "\<exists>I\<in>{G, H}. I \<triangleright> s1 \<in> C \<and> I \<triangleright> s2 \<in> C" 
       if "s1 \<subseteq> S" "finite s1" "F \<in> s1" 
          "s2 \<subseteq> S" "finite s2" "F \<in> s2" for s1 s2
     proof -
       let ?s = "s1 \<union> s2"
       have "?s \<subseteq> S" "finite ?s" using that by simp_all 
       with si have "?s \<in> C" by simp
       moreover have "F \<in> ?s" using that by simp
       ultimately have "\<exists>I\<in>{G,H}. I \<triangleright> ?s \<in> C"
         using C'' un by simp
       thus "\<exists>I\<in>{G,H}. I \<triangleright> s1 \<in> C \<and> I \<triangleright> s2 \<in> C"
         by (meson S[unfolded subset_closed_def, THEN bspec] insert_mono sup.cobounded2 sup_ge1)
     qed
     have m: "\<lbrakk>s1 \<subseteq> S; finite s1; F \<in> s1; G \<triangleright> s1 \<notin> C; s2 \<subseteq> S; finite s2; F \<in> s2; H \<triangleright> s2 \<notin> C\<rbrakk> \<Longrightarrow> False" for s1 s2
       using l by blast
     have "False" if "s1 \<subseteq> S" "finite s1" "G \<triangleright> s1 \<notin> C" "s2 \<subseteq> S" "finite s2" "H \<triangleright> s2 \<notin> C" for s1 s2
     proof -
       have *: "F \<triangleright> s1 \<subseteq> S" "finite (F \<triangleright> s1)" "F \<in> F \<triangleright> s1" if  "s1 \<subseteq> S" "finite s1" for s1
         using that el by simp_all
       have  "G \<triangleright> F \<triangleright> s1 \<notin> C" "H \<triangleright> F \<triangleright> s2 \<notin> C" 
         by (meson S insert_mono subset_closed_def subset_insertI that(3,6))+
       from m[OF *[OF that(1-2)] this(1) *[OF that(4-5)] this(2)]
       show False .
     qed
     hence "G \<triangleright> S \<in> ?E \<or> H \<triangleright> S \<in> ?E"
       unfolding mem_Collect_eq Un_iff
       by (metis (no_types, lifting) finite_Diff insert_Diff si subset_insert_iff)
     thus "G \<triangleright> S \<in> C \<union> ?E \<or> H \<triangleright> S \<in> C \<union> ?E" by blast
   qed
     
   (* this proof does benefit from uniform notation a bit. Before it was introduced,
      the subclaims CON, DIS had to be stated as *)  
   have CON': "\<And>f2 g2 h2 F2 G2 S2. \<lbrakk>\<And>s. \<lbrakk>s \<in> C; h2 F2 G2 \<in> s\<rbrakk> \<Longrightarrow> f2 F2 \<triangleright> s \<in> C \<or> g2 G2 \<triangleright> s \<in> C; 
                                    \<forall>s\<subseteq>S2. finite s \<longrightarrow> s \<in> C; h2 F2 G2 \<in> S2; False\<rbrakk>
       \<Longrightarrow> f2 F2 \<triangleright> S2 \<in> C \<union> {S. \<forall>s\<subseteq>S. finite s \<longrightarrow> s \<in> C} \<or> g2 G2 \<triangleright> S2 \<in> C \<union> {S. \<forall>s\<subseteq>S. finite s \<longrightarrow> s \<in> C}" 
     by fast
   (* (without the False, obviously). The proof of the subclaim does not change gravely, 
       but the f2 g2 h2 have to be instantiated manually upon use (with, e.g., id Not (\<lambda>F G. \<^bold>\<not>(F \<^bold>\<rightarrow> G))),
       and there were multiple working instantiations. Generally not as beautiful. *)
 
   show "pcp (C \<union> ?E)" unfolding pcp_alt
     apply(intro ballI conjI; elim UnE; (unfold mem_Collect_eq)?)
            subgoal using C'' by blast
           subgoal using C'' by blast
          subgoal using C'' by (simp;fail)
         subgoal by (meson C'' empty_subsetI finite.emptyI finite_insert insert_subset subset_insertI)
        subgoal using C'' by simp
       subgoal using CON by simp
      subgoal using C'' by blast
     subgoal using DIS by simp
   done
 qed
 
 primrec pcp_seq where
 "pcp_seq C S 0 = S" |
 "pcp_seq C S (Suc n) = (
   let Sn = pcp_seq C S n; Sn1 = from_nat n \<triangleright> Sn in
   if Sn1 \<in> C then Sn1 else Sn
 )"
 
 lemma pcp_seq_in: "pcp C \<Longrightarrow> S \<in> C \<Longrightarrow> pcp_seq C S n \<in> C"
 proof(induction n)
   case (Suc n)
   hence "pcp_seq C S n \<in> C" by simp
   thus ?case by(simp add: Let_def)
 qed simp
   
 lemma pcp_seq_mono: "n \<le> m \<Longrightarrow> pcp_seq C S n \<subseteq> pcp_seq C S m"
 proof(induction m)
   case (Suc m)
   thus ?case by(cases "n = Suc m"; simp add: Let_def; blast)
 qed simp
 
 lemma pcp_seq_UN: "\<Union>{pcp_seq C S n|n. n \<le> m} = pcp_seq C S m"
 proof(induction m)
   case (Suc m)
   have "{f n |n. n \<le> Suc m} = f (Suc m) \<triangleright> {f n |n. n \<le> m}" for f using le_Suc_eq by auto
   hence "{pcp_seq C S n |n. n \<le> Suc m} = pcp_seq C S (Suc m) \<triangleright> {pcp_seq C S n |n. n \<le> m}" .
   hence "\<Union>{pcp_seq C S n |n. n \<le> Suc m} = \<Union>{pcp_seq C S n |n. n \<le> m} \<union> pcp_seq C S (Suc m)" by auto
   thus ?case using Suc pcp_seq_mono by blast
 qed simp
   
 lemma wont_get_added: "(F :: ('a :: countable) formula) \<notin> pcp_seq C S (Suc (to_nat F)) \<Longrightarrow> F \<notin> pcp_seq C S (Suc (to_nat F) + n)"
 text\<open>We don't necessarily have @{term "n = to_nat (from_nat n)"}, so this doesn't hold.\<close>
 oops
 
 definition "pcp_lim C S \<equiv> \<Union>{pcp_seq C S n|n. True}"
   
 lemma pcp_seq_sub: "pcp_seq C S n \<subseteq> pcp_lim C S"
   unfolding pcp_lim_def by(induction n; blast)
     
 lemma pcp_lim_inserted_at_ex: "x \<in> pcp_lim C S \<Longrightarrow> \<exists>k. x \<in> pcp_seq C S k"
   unfolding pcp_lim_def by blast
 
 lemma pcp_lim_in:
   assumes c: "pcp C"
   and el: "S \<in> C"
   and sc: "subset_closed C"
   and fc: "finite_character C"
   shows "pcp_lim C S \<in> C" (is "?cl \<in> C")
 proof -
   from pcp_seq_in[OF c el, THEN allI] have "\<forall>n. pcp_seq C S n \<in> C" .
   hence "\<forall>m. \<Union>{pcp_seq C S n|n. n \<le> m} \<in> C" unfolding pcp_seq_UN .
   
   have "\<forall>s \<subseteq> ?cl. finite s \<longrightarrow> s \<in> C"
   proof safe
     fix s :: "'a formula set"
     have "pcp_seq C S (Suc (Max (to_nat ` s))) \<subseteq> pcp_lim C S" using pcp_seq_sub by blast
     assume \<open>finite s\<close> \<open>s \<subseteq> pcp_lim C S\<close>
     hence "\<exists>k. s \<subseteq> pcp_seq C S k" 
     proof(induction s rule: finite_induct) 
       case (insert x s)
-      hence "\<exists>k. s \<subseteq> pcp_seq C S k" by fast
-      then guess k1 ..
+      then obtain k1 where "s \<subseteq> pcp_seq C S k1" by blast
       moreover obtain k2 where "x \<in> pcp_seq C S k2"
         by (meson pcp_lim_inserted_at_ex insert.prems insert_subset)
       ultimately have "x \<triangleright> s \<subseteq> pcp_seq C S (max k1 k2)"
         by (meson pcp_seq_mono dual_order.trans insert_subset max.bounded_iff order_refl subsetCE)
       thus ?case by blast
     qed simp
     with pcp_seq_in[OF c el] sc
     show "s \<in> C" unfolding subset_closed_def by blast
   qed
   thus "?cl \<in> C" using fc unfolding finite_character_def by blast
 qed
   
 lemma cl_max:
   assumes c: "pcp C"
   assumes sc: "subset_closed C"
   assumes el: "K \<in> C"
   assumes su: "pcp_lim C S \<subseteq> K"
   shows "pcp_lim C S = K" (is ?e)
 proof (rule ccontr)
   assume \<open>\<not>?e\<close>
   with su have "pcp_lim C S \<subset> K" by simp
   then obtain F where e: "F \<in> K" and ne: "F \<notin> pcp_lim C S" by blast
   from ne have "F \<notin> pcp_seq C S (Suc (to_nat F))" using pcp_seq_sub by fast
   hence 1: "F \<triangleright> pcp_seq C S (to_nat F) \<notin> C" by (simp add: Let_def split: if_splits)
   have "F \<triangleright> pcp_seq C S (to_nat F) \<subseteq> K" using pcp_seq_sub e su by blast
   hence "F \<triangleright> pcp_seq C S (to_nat F) \<in> C" using sc unfolding subset_closed_def using el by blast
   with 1 show False ..
 qed
 
 lemma cl_max':
   assumes c: "pcp C"
   assumes sc: "subset_closed C"
   shows "F \<triangleright> pcp_lim C S \<in> C \<Longrightarrow> F \<in> pcp_lim C S"
     "F \<triangleright> G \<triangleright> pcp_lim C S \<in> C \<Longrightarrow> F \<in> pcp_lim C S \<and> G \<in> pcp_lim C S"
 using cl_max[OF assms] by blast+
 
 lemma pcp_lim_Hintikka:
   assumes c: "pcp C"
   assumes sc: "subset_closed C"
   assumes fc: "finite_character C"
   assumes el: "S \<in> C"
   shows "Hintikka (pcp_lim C S)"
 proof -
   let ?cl = "pcp_lim C S"
   have "?cl \<in> C" using pcp_lim_in[OF c el sc fc] .
   from c[unfolded pcp_alt, THEN bspec, OF this]
   have d: "\<bottom> \<notin> ?cl"
     "Atom k \<in> ?cl \<Longrightarrow> \<^bold>\<not> (Atom k) \<in> ?cl \<Longrightarrow> False"
     "Con F G H \<Longrightarrow> F \<in> ?cl \<Longrightarrow> G \<triangleright> H \<triangleright> ?cl \<in> C"
     "Dis F G H \<Longrightarrow> F \<in> ?cl \<Longrightarrow> G \<triangleright> ?cl \<in> C \<or> H \<triangleright> ?cl \<in> C"
   for k F G H by blast+
   have
     "Con F G H \<Longrightarrow> F \<in> ?cl \<Longrightarrow> G \<in> ?cl \<and> H \<in> ?cl"
     "Dis F G H \<Longrightarrow> F \<in> ?cl \<Longrightarrow> G \<in> ?cl \<or> H \<in> ?cl"
     for F G H
     by(auto dest: d(3-) cl_max'[OF c sc])
   with d(1,2) show ?thesis unfolding Hintikka_alt by fast
 qed
   
 theorem pcp_sat: \<comment> \<open>model existence theorem\<close>
   fixes S :: "'a :: countable formula set"
   assumes c: "pcp C"
   assumes el: "S \<in> C"
   shows "sat S"
 proof -
   note [[show_types]]
   from c obtain Ce where "C \<subseteq> Ce" "pcp Ce" "subset_closed Ce" "finite_character Ce" using ex1[where 'a='a] ex2[where 'a='a] ex3[where 'a='a]
     by (meson dual_order.trans ex2)
   have "S \<in> Ce" using \<open>C \<subseteq> Ce\<close> el ..
   with pcp_lim_Hintikka \<open>pcp Ce\<close> \<open>subset_closed Ce\<close> \<open>finite_character Ce\<close>
   have  "Hintikka (pcp_lim Ce S)" .
   with Hintikkas_lemma have "sat (pcp_lim Ce S)" .
   moreover have "S \<subseteq> pcp_lim Ce S" using pcp_seq.simps(1) pcp_seq_sub by fast
   ultimately show ?thesis unfolding sat_def by fast
 qed
 (* This and Hintikka's lemma are the only two where we need semantics. 
    Still, I don't think it's meaningful to separate those two into an extra theory. *)
 
 end
diff --git a/thys/Propositional_Proof_Systems/LSC_Resolution.thy b/thys/Propositional_Proof_Systems/LSC_Resolution.thy
--- a/thys/Propositional_Proof_Systems/LSC_Resolution.thy
+++ b/thys/Propositional_Proof_Systems/LSC_Resolution.thy
@@ -1,232 +1,233 @@
 subsection\<open>Converting between Resolution and SC proofs\<close>
 theory LSC_Resolution
 imports LSC Resolution
 begin    
 
 lemma literal_subset_sandwich:
   assumes "is_lit_plus F" "cnf F = {C}" "R \<subseteq> C"
   shows "R = \<box> \<or> R = C"
 using assms by(cases F rule: is_lit_plus.cases; simp) blast+ (* proof somewhat strange internally\<dots> *)
 
 text\<open>Proof following Gallier~\cite{gallier2015logic}.\<close>
 theorem CSC_Resolution_pre: "\<Gamma> \<Rightarrow>\<^sub>n \<Longrightarrow> \<forall>\<gamma> \<in> set_mset \<Gamma>. is_cnf \<gamma> \<Longrightarrow> (\<Union>(cnf ` set_mset \<Gamma>)) \<turnstile> \<box>"
 proof(induction rule: LSC.induct)
   case (Ax k \<Gamma>)
   let ?s = "\<Union>(cnf ` set_mset (\<^bold>\<not> (Atom k), Atom k, \<Gamma>))"
   have "?s \<turnstile> {k\<^sup>+}" "?s \<turnstile> {k\<inverse>}" using Resolution.Ass[where 'a='a] by simp_all
   from Resolution.R[OF this, of k]
   have "?s \<turnstile> \<box>" by simp
   thus ?case by simp
 next
   case (BotL \<Gamma>) thus ?case by(simp add: Ass)
 next
   case (AndL F G \<Gamma>)
   hence "\<Union>(cnf ` set_mset (F, G, \<Gamma>)) \<turnstile> \<box>" by simp
   thus ?case by(simp add: Un_left_commute sup.assoc)
 next
   (* The idea for the whole trickery with F being a literal (is_disj has to only allows right deep formulas)
     and the sandwiching is from Gallier, but mentioned there only in one little sentence. *)
   case (OrL F \<Gamma> G)
   hence "is_cnf (F \<^bold>\<or> G)" by simp
   hence d: "is_disj (F \<^bold>\<or> G)" by simp
   hence db: "is_disj F" "is_lit_plus F" "is_disj G" by (-, cases F) simp_all
   hence "is_cnf F \<and> is_cnf G" by(cases F; cases G; simp)
   with OrL have IH: "(\<Union>(cnf ` set_mset (F, \<Gamma>))) \<turnstile> \<box>" "(\<Union>(cnf ` set_mset (G, \<Gamma>))) \<turnstile> \<box>" by simp_all
   let ?\<Gamma> = "(\<Union>(cnf ` set_mset \<Gamma>))"
   from IH have IH_readable: "cnf F \<union> ?\<Gamma> \<turnstile> \<box>" "cnf G \<union> ?\<Gamma> \<turnstile> \<box>" by auto
   show ?case proof(cases "cnf F = {} \<or> cnf G = {}")
     case True
     hence "cnf (F \<^bold>\<or> G) = {}" by auto
     thus ?thesis using True IH by auto
   next
     case False
     then obtain S T where ST: "cnf F = {S}" "cnf G = {T}"
       using cnf_disj_ex db(1,3) (* try applying meson here. It's weird. and sledgehammer even suggests it. *) by metis
     (* hint: card S \<le> 1 *)
     hence R: "cnf (F \<^bold>\<or> G) = { S \<union> T }" by simp
     have "\<lbrakk>S\<triangleright>?\<Gamma> \<turnstile> \<box>; T\<triangleright>?\<Gamma> \<turnstile> \<box>\<rbrakk> \<Longrightarrow> S \<union> T\<triangleright> ?\<Gamma> \<turnstile> \<box>" proof -
       assume s: "S\<triangleright>?\<Gamma> \<turnstile> \<box>" and t: "T\<triangleright>?\<Gamma> \<turnstile> \<box>"
       hence s_w: "S \<triangleright> S \<union> T \<triangleright> ?\<Gamma> \<turnstile> \<box>" using Resolution_weaken by (metis insert_commute insert_is_Un)
       note Resolution_taint_assumptions[of "{T}" ?\<Gamma> "\<box>" S] t
       then obtain R where R: "S \<union> T \<triangleright> \<Union>(cnf ` set_mset \<Gamma>) \<turnstile> R" "R\<subseteq>S" by (auto simp: Un_commute)
       show ?thesis using literal_subset_sandwich[OF db(2) ST(1) R(2)] proof
         assume "R = \<box>" thus ?thesis using R(1) by blast
       next
         from Resolution_unnecessary[where T="{_}", simplified] R(1)
         have "(R \<triangleright> S \<union> T \<triangleright> ?\<Gamma> \<turnstile> \<box>) = (S \<union> T \<triangleright> ?\<Gamma> \<turnstile> \<box>)"  .
         moreover assume "R = S" 
         ultimately show ?thesis using s_w by simp
       qed
     qed
     thus ?thesis using IH ST R by simp
   qed
   hence case_readable: "cnf (F \<^bold>\<or> G) \<union> ?\<Gamma> \<turnstile> \<box>" by auto
 qed auto
 
 corollary LSC_Resolution:
   assumes "\<Gamma> \<Rightarrow>\<^sub>n"
   shows "(\<Union>(cnf ` nnf ` set_mset \<Gamma>)) \<turnstile> \<box>"
 proof -
   from assms
   have "image_mset nnf \<Gamma> \<Rightarrow>\<^sub>n" by (simp add: LSC_NNF)
   from LSC_cnf[OF this]
   have "image_mset (cnf_form_of \<circ> nnf) \<Gamma> \<Rightarrow>\<^sub>n" by(simp add: image_mset.compositionality is_nnf_nnf)
   moreover have "\<forall>\<gamma> \<in> set_mset (image_mset (cnf_form_of \<circ> nnf) \<Gamma>). is_cnf \<gamma>" 
     using cnf_form_of_is[where 'a='a, OF is_nnf_nnf] by simp
   moreover note CSC_Resolution_pre
   ultimately have "\<Union>(cnf ` set_mset (image_mset (cnf_form_of \<circ> nnf) \<Gamma>)) \<turnstile> \<box>"  by blast
   hence "\<Union>((\<lambda>F. cnf (cnf_form_of (nnf F))) ` set_mset \<Gamma>) \<turnstile> \<box>" by simp
   thus ?thesis unfolding cnf_cnf[OF is_nnf_nnf] by simp
 qed
   
 corollary SC_Resolution:
   assumes "\<Gamma> \<Rightarrow> {#}"
   shows "(\<Union>(cnf ` nnf ` set_mset \<Gamma>)) \<turnstile> \<box>"
 proof -
   from assms have "image_mset nnf \<Gamma> \<Rightarrow>\<^sub>n" by (simp add: LSC_NNF SC_LSC)
   hence "\<Union>(cnf` nnf ` set_mset (image_mset nnf \<Gamma>)) \<turnstile> \<box>" using LSC_Resolution by blast
   thus ?thesis using is_nnf_nnf_id[where 'a='a] is_nnf_nnf[where 'a='a] by auto
 qed
 
 (* Gallier just goes "Any resolution refutation can be transformed to a derivation in SCNF'"
    But we don't know what a resolution refutation is, inductively speaking. *)
 (* would have been a bit nicer with orderings on formula to convert mset \<rightarrow> list *)
 lemma Resolution_LSC_pre:
   assumes "S \<turnstile> R"
   assumes "finite R"
   assumes "finite S" "Ball S finite"
   shows "\<exists>S' R'. \<forall>\<Gamma>. set R' = R \<and> set (map set S') = S \<and> 
     (disj_of_clause R', {#disj_of_clause c. c \<in># mset S'#} + \<Gamma> \<Rightarrow>\<^sub>n \<longrightarrow> {#disj_of_clause c. c \<in># mset S'#} + \<Gamma> \<Rightarrow>\<^sub>n)"
 (* order of quantifiers is important here\<dots> *)
 using assms proof(induction S R rule: Resolution.induct)
   case (Ass F S)
   (* Idea: we don't just obtain an S', we obtain an S' that contains R (and not just some reordering of it) *)
   define Sm where "Sm = S - {F}"
   hence Sm: "S = F\<triangleright>Sm" "F \<notin> Sm" using Ass by fast+ (* try doing this with obtain\<dots> *)
   with Ass have fsm: "finite Sm" "Ball Sm finite" by auto
   then obtain Sm' where "Sm = set (map set Sm')" by (metis (full_types) ex_map_conv finite_list)
   moreover obtain R' where [simp]: "F = set R'" using Ass finite_list by blast
   ultimately have S: "S = set (map set (R'#Sm'))" unfolding Sm by simp
   show ?case
     using LSC_Contract[where 'a='a]
     by(intro exI[where x="R'#Sm'"] exI[where x=R']) (simp add: S add_ac)
   (* this was the base case. ugh. *)
 next
   case (R S F G k)
   from R.prems have fin: "finite F" "finite G" by simp_all
   from R.IH(1)[OF fin(1) R.prems(2,3)] obtain FR FS where IHF:
     "set FR = F" "set (map set FS) = S"
     "\<And>\<Gamma> GS. (disj_of_clause FR, image_mset disj_of_clause (mset (FS@GS)) + \<Gamma> \<Rightarrow>\<^sub>n 
       \<Longrightarrow> image_mset disj_of_clause (mset (FS@GS)) + \<Gamma> \<Rightarrow>\<^sub>n)"
       by simp (metis add.assoc)
   from R.IH(2)[OF fin(2) R.prems(2,3)] obtain GR GS where IHG:
     "set GR = G" "set (map set GS) = S"
     "\<And>\<Gamma> HS. (disj_of_clause GR, image_mset disj_of_clause (mset (GS@HS)) + \<Gamma> \<Rightarrow>\<^sub>n 
       \<Longrightarrow> image_mset disj_of_clause (mset (GS@HS)) + \<Gamma> \<Rightarrow>\<^sub>n)"
     by simp (metis add.assoc)
   have IH: "image_mset disj_of_clause (mset (FS @ GS)) + \<Gamma> \<Rightarrow>\<^sub>n"
     if "disj_of_clause FR, disj_of_clause GR, image_mset disj_of_clause (mset (FS @ GS)) + \<Gamma> \<Rightarrow>\<^sub>n"
     for \<Gamma> using IHF(3)[of GS \<Gamma>] IHG(3)[of FS "disj_of_clause FR, \<Gamma>"] that
     by(simp add: add_mset_commute add_ac)
   show ?case
     apply(intro exI[where x="FS @ GS"] exI[where x="removeAll (k\<^sup>+) FR @ removeAll (k\<inverse>) GR"] allI impI conjI)
       apply(simp add: IHF IHG;fail)
      apply(insert IHF IHG; simp;fail)
     apply(intro IH)
     apply(auto dest!: LSC_Sim_resolution_la simp add: IHF IHG R.hyps)
   done
 qed
   
 lemma Resolution_LSC_pre_nodisj: (* I've tried showing this directly instead of Resolution_LSC_pre, but that is surprisingly painful. *)
   assumes "S \<turnstile> R"
   assumes "finite R"
   assumes "finite S" "Ball S finite"
   shows "\<exists>S' R'. \<forall>\<Gamma>. is_nnf_mset \<Gamma> \<longrightarrow> is_disj R' \<and> is_nnf S' \<and> cnf R' = {R} \<and> cnf S' \<subseteq> S \<and> 
     (R', S', \<Gamma> \<Rightarrow>\<^sub>n \<longrightarrow> S', \<Gamma> \<Rightarrow>\<^sub>n)"
 proof -
   have mehorder: "F, \<^bold>\<And>G, \<Gamma> = \<^bold>\<And>G, F, \<Gamma>" for F G \<Gamma> by(simp add: add_ac)
   from Resolution_LSC_pre[where 'a='a,OF assms]
   obtain S' R' where o: "\<And>\<Gamma>. is_nnf_mset \<Gamma> \<Longrightarrow> set R' = R \<and> set (map set S') = S \<and> 
   (disj_of_clause R', image_mset disj_of_clause (mset S') + \<Gamma> \<Rightarrow>\<^sub>n \<longrightarrow> image_mset disj_of_clause (mset S') + \<Gamma> \<Rightarrow>\<^sub>n)"
     by blast
   hence p: "is_nnf_mset \<Gamma> \<Longrightarrow> (disj_of_clause R', image_mset disj_of_clause (mset S') + \<Gamma> \<Rightarrow>\<^sub>n \<Longrightarrow> image_mset disj_of_clause (mset S') + \<Gamma> \<Rightarrow>\<^sub>n)" 
     for \<Gamma> by blast
   show ?thesis
     apply(rule exI[where x="\<^bold>\<And>map disj_of_clause S'"])
     apply(rule exI[where x="disj_of_clause R'"])
     apply safe
          apply(intro disj_of_clause_is;fail)
         apply(simp add: cnf_disj o; fail)+
      subgoal using o by(fastforce simp add: cnf_BigAnd cnf_disj)
     subgoal for \<Gamma>
       apply(frule p)
        apply(unfold mehorder)
        apply(drule LSC_BigAndL_inv)
          apply(simp;fail)+
       by (simp add: LSC_BigAndL)     
     done
 qed
 
 corollary Resolution_LSC1:
   assumes "S \<turnstile> \<box>"
   shows "\<exists>F. is_nnf F \<and> cnf F \<subseteq> S \<and> {#F#} \<Rightarrow>\<^sub>n"
 proof -
   have *: "{f \<union> g |f g. f \<in> F \<and> g \<in> G} = {\<box>} \<Longrightarrow> F = {\<box>}" for F G
   proof (rule ccontr)
     assume m: "{f \<union> g |f g. f \<in> F \<and> g \<in> G} = {\<box>}"
     assume "F \<noteq> {\<box>}"
     hence "F = {} \<or> (\<exists>E. E \<in> F \<and> E \<noteq> \<box>)" by blast
     thus False proof
       assume "F = {}"
       with m show False by simp
     next
-      assume "\<exists>E. E \<in> F \<and> E \<noteq> \<box>" then guess E .. note E = this
+      assume "\<exists>E. E \<in> F \<and> E \<noteq> \<box>"
+      then obtain E where E: "E \<in> F \<and> E \<noteq> \<box>" ..
       show False proof cases
         assume "G = {}" with m show False by simp
       next
         assume "G \<noteq> {}"
         then obtain D where "D \<in> G" by blast
         with E have "E \<union> D \<in> {f \<union> g |f g. f \<in> F \<and> g \<in> G}" by blast
         with m E show False by simp
       qed
     qed
   qed
   have *: "F = {\<box>} \<and> G = {\<box>}" if "{f \<union> g |f g. f \<in> F \<and> g \<in> G} = {\<box>}" for F G
   proof (intro conjI)
     show "G = {\<box>}"
       apply(rule *[of G F])
       apply(subst that[symmetric])
     by blast
   qed (rule *[OF that])
   have *: "is_nnf F \<Longrightarrow> is_nnf_mset \<Gamma> \<Longrightarrow> cnf F = {\<box>} \<Longrightarrow> F,\<Gamma> \<Rightarrow>\<^sub>n" for F \<Gamma>
     apply(induction F rule: cnf.induct; simp)
       apply blast
      apply (metis LSC.LSC.AndL LSC_weaken add_mset_commute singleton_Un_iff)
     apply(drule *; simp add: LSC.LSC.OrL)
   done
   from Resolution_useless_infinite[OF assms]
   obtain S' where su: "S'\<subseteq>S" and fin: "finite S'" "Ball S' finite" and pr: "(S' \<turnstile> \<box>)" by blast
   from Resolution_LSC_pre_nodisj[OF pr finite.emptyI fin]
   obtain S'' where "is_nnf S''" "cnf S'' \<subseteq> S'" "{# S'' #} \<Rightarrow>\<^sub>n" 
     using * [OF disj_is_nnf, of _ \<open>{#}\<close>]
     by (metis LSC_weaken add_mset_commute empty_iff set_mset_empty)
   with su show ?thesis by blast
 qed
 
 corollary Resolution_SC1:
   assumes "S \<turnstile> \<box>"
   shows "\<exists>F. cnf (nnf F) \<subseteq> S \<and> {#F#} \<Rightarrow> {#}"
   apply(insert Resolution_LSC1[OF assms])
   apply(elim ex_forward)
   apply(elim conjE; intro conjI)
    subgoal by(subst is_nnf_nnf_id; assumption)
   apply(unfold SC_LSC)
   subgoal by (simp;fail)
 done
     
 (* really, these proofs have to do with sets, multisets and lists.
 If I'd introduce finite sets somehow, the chaos would be perfect.
 I want out.
 *)
 
 end
diff --git a/thys/Propositional_Proof_Systems/ND_Compl_Truthtable_Compact.thy b/thys/Propositional_Proof_Systems/ND_Compl_Truthtable_Compact.thy
--- a/thys/Propositional_Proof_Systems/ND_Compl_Truthtable_Compact.thy
+++ b/thys/Propositional_Proof_Systems/ND_Compl_Truthtable_Compact.thy
@@ -1,17 +1,17 @@
 theory ND_Compl_Truthtable_Compact
 imports ND_Compl_Truthtable Compactness
 begin
   
 theorem 
   fixes \<Gamma> :: "'a :: countable formula set"
   shows "\<Gamma> \<TTurnstile> F \<Longrightarrow> \<Gamma> \<turnstile> F"
 proof -
   assume \<open>\<Gamma> \<TTurnstile> F\<close>
-  with compact_to_formula guess G .
+  then obtain G  where "set G \<subseteq> \<Gamma>" "\<Turnstile> \<^bold>\<And>G \<^bold>\<rightarrow> F" by (rule compact_to_formula)
   from ND_complete \<open>\<Turnstile> \<^bold>\<And>G \<^bold>\<rightarrow> F\<close> have \<open>{} \<turnstile> \<^bold>\<And>G \<^bold>\<rightarrow> F\<close> .
   with AssmBigAnd have \<open>set G \<turnstile> F\<close> ..
   with Weaken show ?thesis using \<open>set G \<subseteq> \<Gamma>\<close> .
 qed
   
 
 end
diff --git a/thys/Propositional_Proof_Systems/ND_FiniteAssms.thy b/thys/Propositional_Proof_Systems/ND_FiniteAssms.thy
--- a/thys/Propositional_Proof_Systems/ND_FiniteAssms.thy
+++ b/thys/Propositional_Proof_Systems/ND_FiniteAssms.thy
@@ -1,81 +1,89 @@
 theory ND_FiniteAssms
 imports ND
 begin
 
 lemma ND_finite_assms: "\<Gamma> \<turnstile> F \<Longrightarrow> \<exists>\<Gamma>'. \<Gamma>' \<subseteq> \<Gamma> \<and> finite \<Gamma>' \<and> (\<Gamma>' \<turnstile> F)"
 proof(induction rule: ND.induct)
   case (Ax F \<Gamma>) thus ?case by(intro exI[of _ "{F}"]) (simp add: ND.Ax)
 next
   case (AndI \<Gamma> F G)
-  from AndI.IH(1) guess \<Gamma>1 .. moreover
-  from AndI.IH(2) guess \<Gamma>2 .. ultimately
-  show ?case by(intro exI[where x="\<Gamma>1\<union>\<Gamma>2"]) (force elim: Weaken intro!: ND.AndI)
+  from AndI.IH obtain \<Gamma>1 \<Gamma>2
+    where "\<Gamma>1 \<subseteq> \<Gamma> \<and> finite \<Gamma>1 \<and> (\<Gamma>1 \<turnstile> F)"
+      and "\<Gamma>2 \<subseteq> \<Gamma> \<and> finite \<Gamma>2 \<and> (\<Gamma>2 \<turnstile> G)"
+    by blast
+  then show ?case by(intro exI[where x="\<Gamma>1\<union>\<Gamma>2"]) (force elim: Weaken intro!: ND.AndI)
 next
   case (CC F \<Gamma>)
-  from CC.IH guess \<Gamma>' .. note \<Gamma>' = this
+  from CC.IH obtain \<Gamma>' where \<Gamma>': "\<Gamma>' \<subseteq> \<^bold>\<not> F \<triangleright> \<Gamma> \<and> finite \<Gamma>' \<and> (\<Gamma>' \<turnstile> \<bottom>)" ..
   thus ?case proof(cases "Not F \<in> \<Gamma>'") text\<open>case distinction: Did we actually use @{term "\<^bold>\<not>F"}?\<close>
     case False hence "\<Gamma>' \<subseteq> \<Gamma>" using \<Gamma>' by blast
     with \<Gamma>' show ?thesis using BotE by(intro exI[where x="\<Gamma>'"]) fast
   next
     case True
     then obtain \<Gamma>'' where "\<Gamma>' = \<^bold>\<not> F\<triangleright>\<Gamma>''" "\<^bold>\<not> F \<notin> \<Gamma>''" by (meson Set.set_insert)
     hence "\<Gamma>'' \<subseteq> \<Gamma>" "finite \<Gamma>''" "\<^bold>\<not> F\<triangleright>\<Gamma>'' \<turnstile> \<bottom>" using \<Gamma>' by auto
     thus ?thesis using ND.CC by auto
   qed
 next
   case AndE1 thus ?case by(blast dest: ND.AndE1) next
   case AndE2 thus ?case by(blast dest: ND.AndE2)
 next
   case OrI1 thus ?case by(blast dest: ND.OrI1) next
   case OrI2 thus ?case by(blast dest: ND.OrI2)
 next
   case (OrE \<Gamma> F G H)
-  from OrE.IH(1) guess \<Gamma>1 .. moreover
-  from OrE.IH(2) guess \<Gamma>2 .. moreover
-  from OrE.IH(3) guess \<Gamma>3 ..
-  note IH = calculation this
+  from OrE.IH obtain \<Gamma>1 \<Gamma>2 \<Gamma>3
+    where IH:
+      "\<Gamma>1 \<subseteq> \<Gamma> \<and> finite \<Gamma>1 \<and> (\<Gamma>1 \<turnstile> F \<^bold>\<or> G)"
+      "\<Gamma>2 \<subseteq> F \<triangleright> \<Gamma> \<and> finite \<Gamma>2 \<and> (\<Gamma>2 \<turnstile> H)"
+      "\<Gamma>3 \<subseteq> G \<triangleright> \<Gamma> \<and> finite \<Gamma>3 \<and> (\<Gamma>3 \<turnstile> H)"
+    by blast
   let ?w = "\<Gamma>1 \<union> (\<Gamma>2 - {F}) \<union> (\<Gamma>3 - {G})"
   from IH have "?w \<turnstile> F \<^bold>\<or> G" using Weaken[OF _ sup_ge1] by metis moreover
   from IH have "F\<triangleright>?w \<turnstile> H" "G\<triangleright>?w \<turnstile> H" using Weaken by (metis Un_commute Un_insert_right Un_upper1 Weaken insert_Diff_single)+ ultimately
   have "?w \<turnstile> H" using ND.OrE by blast
   thus ?case using IH by(intro exI[where x="?w"]) auto
   text\<open>Clever evasion of the case distinction made for CC.\<close>
 next
   case (ImpI F \<Gamma> G)
-  from ImpI.IH guess \<Gamma>' ..
+  from ImpI.IH obtain \<Gamma>' where "\<Gamma>' \<subseteq> F \<triangleright> \<Gamma> \<and> finite \<Gamma>' \<and> (\<Gamma>' \<turnstile> G)" ..
   thus ?case by (intro exI[where x="\<Gamma>' - {F}"]) (force elim: Weaken intro!: ND.ImpI)
 next
   case (ImpE \<Gamma> F G)
-  from ImpE.IH(1) guess \<Gamma>1 .. moreover
-  from ImpE.IH(2) guess \<Gamma>2 .. ultimately
-  show ?case by(intro exI[where x="\<Gamma>1 \<union> \<Gamma>2"]) (force elim: Weaken intro: ND.ImpE[where F=F])
+  from ImpE.IH obtain \<Gamma>1 \<Gamma>2 where
+      "\<Gamma>1 \<subseteq> \<Gamma> \<and> finite \<Gamma>1 \<and> (\<Gamma>1 \<turnstile> F \<^bold>\<rightarrow> G)"
+      "\<Gamma>2 \<subseteq> \<Gamma> \<and> finite \<Gamma>2 \<and> (\<Gamma>2 \<turnstile> F)"
+    by blast
+  then show ?case by(intro exI[where x="\<Gamma>1 \<union> \<Gamma>2"]) (force elim: Weaken intro: ND.ImpE[where F=F])
 next
   case (NotE \<Gamma> F)
-  from NotE.IH(1) guess \<Gamma>1 .. moreover
-  from NotE.IH(2) guess \<Gamma>2 .. ultimately
-  show ?case by(intro exI[where x="\<Gamma>1 \<union> \<Gamma>2"]) (force elim: Weaken intro: ND.NotE[where F=F])
+  from NotE.IH obtain \<Gamma>1 \<Gamma>2 where
+      "\<Gamma>1 \<subseteq> \<Gamma> \<and> finite \<Gamma>1 \<and> (\<Gamma>1 \<turnstile> \<^bold>\<not> F)"
+      "\<Gamma>2 \<subseteq> \<Gamma> \<and> finite \<Gamma>2 \<and> (\<Gamma>2 \<turnstile> F)"
+    by blast
+  then show ?case by(intro exI[where x="\<Gamma>1 \<union> \<Gamma>2"]) (force elim: Weaken intro: ND.NotE[where F=F])
 next
   case (NotI F \<Gamma>)
-  from NotI.IH guess \<Gamma>' ..
+  from NotI.IH obtain \<Gamma>' where "\<Gamma>' \<subseteq> F \<triangleright> \<Gamma> \<and> finite \<Gamma>' \<and> (\<Gamma>' \<turnstile> \<bottom>)" ..
   thus ?case by(intro exI[where x="\<Gamma>' - {F}"]) (force elim: Weaken intro: ND.NotI[where F=F])
 qed
 
 text\<open>We thought that a lemma like this would be necessary for the ND completeness by SC completeness proof
   (this lemma shows that if we made an ND proof, we can always limit ourselves to a finite set of assumptions --
    and thus put all the assumptions into one formula).
 That is not the case, since in the completeness proof,
 we assume a valid entailment and have to show (the existence of) a derivation.
 The author hopes that his misunderstanding can help the reader's understanding.\<close>
 corollary ND_no_assms: 
   assumes "\<Gamma> \<turnstile> F"
   obtains \<Gamma>' where "set \<Gamma>' \<subseteq> \<Gamma> \<and> ({} \<turnstile> \<^bold>\<And>\<Gamma>' \<^bold>\<rightarrow> F)"
 proof(goal_cases)
   case 1
   from ND_finite_assms[OF assms] obtain \<Gamma>' where "\<Gamma>'\<subseteq>\<Gamma>" "finite \<Gamma>'" "\<Gamma>' \<turnstile> F" by blast
   from \<open>finite \<Gamma>'\<close> obtain G where \<Gamma>'[simp]: "\<Gamma>' = set G"  using finite_list by blast
   with \<open>\<Gamma>'\<subseteq>\<Gamma>\<close> have "set G \<subseteq> \<Gamma>" by clarify
   moreover from \<open>\<Gamma>' \<turnstile> F\<close> have "{} \<turnstile> \<^bold>\<And> G \<^bold>\<rightarrow> F" unfolding \<Gamma>' AssmBigAnd .
   ultimately show ?case by(intro 1[where \<Gamma>'=G] conjI)
 qed
 
 end
diff --git a/thys/Propositional_Proof_Systems/SC_Depth.thy b/thys/Propositional_Proof_Systems/SC_Depth.thy
--- a/thys/Propositional_Proof_Systems/SC_Depth.thy
+++ b/thys/Propositional_Proof_Systems/SC_Depth.thy
@@ -1,592 +1,593 @@
 theory SC_Depth
 imports SC
 begin
   
 text\<open>
 Many textbook arguments about SC use the depth of the derivation tree as basis for inductions.
 We had originally thought that this is mandatory for the proof of contraction,
 but found out it is not.
 It remains unclear to us whether there is any proof on SC that requires an argument using depth.
 \<close>
 text\<open>
 We keep our formalization of SC with depth for didactic reasons:
 we think that arguments about depth do not need much meta-explanation,
 but structural induction and rule induction usually need extra explanation
 for students unfamiliar with Isabelle/HOL.
 They are also a lot harder to execute.
 We dare the reader to write down (a few of) the cases for, e.g. \<open>AndL_inv'\<close>, by hand.
 \<close>
 
 (* Warning: This theory may have name collisions with SC.thy\<dots> *)
 
 inductive SCc :: "'a formula multiset \<Rightarrow> 'a formula multiset \<Rightarrow> nat \<Rightarrow> bool" ("((_ \<Rightarrow>/ _) \<down> _)" [53,53] 53) where
 BotL: "\<bottom> \<in># \<Gamma> \<Longrightarrow> \<Gamma>\<Rightarrow>\<Delta> \<down> Suc n" |
 Ax: "Atom k \<in># \<Gamma> \<Longrightarrow> Atom k \<in># \<Delta> \<Longrightarrow> \<Gamma>\<Rightarrow>\<Delta> \<down> Suc n" |
 NotL: "\<Gamma> \<Rightarrow> F,\<Delta> \<down> n \<Longrightarrow> Not F, \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n" |
 NotR: "F,\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> Not F, \<Delta> \<down> Suc n" |
 AndL: "F,G,\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> And F G, \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n" |
 AndR: "\<lbrakk> \<Gamma> \<Rightarrow> F,\<Delta> \<down> n; \<Gamma> \<Rightarrow> G,\<Delta> \<down> n \<rbrakk> \<Longrightarrow> \<Gamma> \<Rightarrow> And F G, \<Delta> \<down> Suc n" |
 OrL: "\<lbrakk> F,\<Gamma> \<Rightarrow> \<Delta> \<down> n; G,\<Gamma> \<Rightarrow> \<Delta> \<down> n \<rbrakk> \<Longrightarrow> Or F G, \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n" |
 OrR: "\<Gamma> \<Rightarrow> F,G,\<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> Or F G, \<Delta> \<down> Suc n" |
 ImpL: "\<lbrakk> \<Gamma> \<Rightarrow> F,\<Delta> \<down> n; G,\<Gamma> \<Rightarrow> \<Delta> \<down> n \<rbrakk> \<Longrightarrow> Imp F G, \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n" |
 ImpR: "F,\<Gamma> \<Rightarrow> G,\<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> Imp F G, \<Delta> \<down> Suc n"
 
 lemma
   shows BotL_canonical'[intro!]: "\<bottom>,\<Gamma>\<Rightarrow>\<Delta> \<down> Suc n"
     and Ax_canonical'[intro!]: "Atom k,\<Gamma> \<Rightarrow> Atom k,\<Delta> \<down> Suc n"
   by (meson SCc.intros union_single_eq_member)+
     
 lemma deeper: "\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta> \<down> n + m"
   by(induction rule: SCc.induct; insert SCc.intros; auto) 
 lemma deeper_suc: "\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n"
   (* this version is actually required more often. It can be declared as an elim!, but I want to make its usage explicit *)
   thm deeper[unfolded Suc_eq_plus1[symmetric]]
   by(drule deeper[where m=1]) simp
     
 text\<open>The equivalence is obvious.\<close>
 theorem SC_SCp_eq:
   fixes \<Gamma> \<Delta> :: "'a formula multiset"
   shows "(\<exists>n. \<Gamma> \<Rightarrow> \<Delta> \<down> n) \<longleftrightarrow> \<Gamma> \<Rightarrow> \<Delta>" (is "?c \<longleftrightarrow> ?p")
 proof
-  assume ?c then guess n ..
+  assume ?c
+  then obtain n where "\<Gamma> \<Rightarrow> \<Delta> \<down> n" ..
   thus ?p by(induction rule: SCc.induct; simp add: SCp.intros)
 next
   have deeper_max: "\<Gamma> \<Rightarrow> \<Delta> \<down> max m n" "\<Gamma> \<Rightarrow> \<Delta> \<down> max n m" if "\<Gamma> \<Rightarrow> \<Delta> \<down> n" for n m and \<Gamma> \<Delta> :: "'a formula multiset"
   proof -
     have "n \<le> m \<Longrightarrow> \<exists>k. m = n + k" by presburger
     with that[THEN deeper] that
     show "\<Gamma> \<Rightarrow> \<Delta> \<down> max n m" unfolding max_def by clarsimp
     thus "\<Gamma> \<Rightarrow> \<Delta> \<down> max m n" by (simp add: max.commute)
   qed
   assume ?p thus ?c by(induction rule: SCp.induct)
     (insert SCc.intros[where 'a='a] deeper_max; metis)+
 qed
 
 (* it makes a difference whether we say Ax is 0 or any: with Ax \<down> 0 we could not prove the deepening rules.
    Also, it is important to allow only atoms in Ax, otherwise the inv-rules are not depth preserving.
   Making Ax/BotL start from \<ge>1 saves proving the base-cases twice
  *)
 lemma no_0_SC[dest!]: "\<Gamma> \<Rightarrow> \<Delta> \<down> 0 \<Longrightarrow> False"
   by(cases rule: SCc.cases[of \<Gamma> \<Delta> 0]) assumption
     
 
 lemma inR1': "\<Gamma> \<Rightarrow> G, H, \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> H, G, \<Delta> \<down> n" by(simp add: add_mset_commute)
 lemma inL1': "G, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> H, G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" by(simp add: add_mset_commute)
 lemma inR2': "\<Gamma> \<Rightarrow> F, G, H, \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> G, H, F, \<Delta> \<down> n" by(simp add: add_mset_commute)
 lemma inL2': "F, G, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> G, H, F, \<Gamma> \<Rightarrow> \<Delta> \<down> n" by(simp add: add_mset_commute)
 lemma inR3': "\<Gamma> \<Rightarrow> F, G, H, \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> H, F, G, \<Delta> \<down> n" by(simp add: add_mset_commute)
 lemma inR4': "\<Gamma> \<Rightarrow> F, G, H, I, \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> H, I, F, G, \<Delta> \<down> n" by(simp add: add_mset_commute)
 lemma inL3': "F, G, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> H, F, G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" by(simp add: add_mset_commute)
 lemma inL4': "F, G, H, I, \<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> H, I, F, G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" by(simp add: add_mset_commute)
 lemmas SC_swap_applies[intro,elim!] = inL1' inL2' inL3' inL4' inR1' inR2' inR3' inR4'
   (* these are here because they can be used for more careful reasoning with intro *)
 
 lemma "Atom C \<^bold>\<rightarrow> Atom D \<^bold>\<rightarrow> Atom E,
        Atom k \<^bold>\<rightarrow> Atom C \<^bold>\<and> Atom D, 
        Atom k, {#} 
 \<Rightarrow> {# Atom E #} \<down> Suc (Suc (Suc (Suc (Suc 0))))"
   by(auto intro!: SCc.intros(3-) intro: SCc.intros(1,2))
 
 lemma Bot_delR': "\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>-{#\<bottom>#} \<down> n"
 proof(induction rule: SCc.induct) 
   case BotL thus ?case by(rule SCc.BotL; simp) (* SC.BotL refers to SC.SCp.BotL. Even more interestingly, there used to be a SCc.SC.BotL (which was not reffered to). I'll just leave this here and see how long till someone breaks it. *)
 next case (Ax k) thus ?case by(intro SCc.Ax[of k]; simp; metis diff_single_trivial formula.distinct(1) insert_DiffM lem1)
 next case NotL thus ?case using SCc.NotL by (metis add_mset_remove_trivial diff_single_trivial diff_union_swap insert_DiffM)
 next case NotR thus ?case using SCc.NotR by (metis diff_union_swap formula.distinct(11))
 next case AndR thus ?case using SCc.AndR by (metis diff_single_trivial diff_union_swap diff_union_swap2 formula.distinct(13))
 next case OrR thus ?case using SCc.OrR by (metis diff_single_trivial diff_union_swap2 formula.distinct(15) insert_iff set_mset_add_mset_insert)
 next case ImpL thus ?case using SCc.ImpL by (metis diff_single_trivial diff_union_swap2)
 next case ImpR thus ?case using SCc.ImpR by (metis diff_single_trivial diff_union_swap diff_union_swap2 formula.distinct(17))
 qed (simp_all add: SCc.intros)
   
 lemma NotL_inv': "Not F, \<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> F,\<Delta>  \<down> n"
 proof(induction "Not F, \<Gamma>" \<Delta> n arbitrary: \<Gamma> rule: SCc.induct)
   case (NotL \<Gamma>' G \<Delta> n) thus ?case by(cases "Not F = Not G")
     (auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc)
 qed (auto intro!: SCc.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)
 
 lemma AndL_inv': "And F G, \<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> F,G,\<Gamma> \<Rightarrow> \<Delta> \<down> n"
 proof(induction "And F G, \<Gamma>" \<Delta> n arbitrary: \<Gamma> rule: SCc.induct)
   case (AndL F' G' \<Gamma>' \<Delta>) thus ?case 
     by(cases "And F G = And F' G'"; 
        auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc;
        metis add_mset_commute)
 qed (auto intro!: SCc.intros(3-) dest!: multi_member_split simp: SCc.intros lem1 lem2 inL2')
 
 lemma OrL_inv': 
   assumes "Or F G, \<Gamma> \<Rightarrow> \<Delta> \<down> n"
   shows "F,\<Gamma> \<Rightarrow> \<Delta> \<down> n \<and> G,\<Gamma> \<Rightarrow> \<Delta> \<down> n"
 proof(insert assms, induction "Or F G, \<Gamma>" \<Delta> n arbitrary: \<Gamma> rule: SCc.induct)
   case (OrL F' \<Gamma>' \<Delta> n G') thus ?case 
     by(cases "Or F G = Or F' G'"; 
        auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc;
        blast)
 qed (fastforce intro!: SCc.intros(3-) dest!: multi_member_split simp: SCc.intros lem1 lem2)+
 
 lemma ImpL_inv': 
   assumes "Imp F G, \<Gamma> \<Rightarrow> \<Delta> \<down> n"
   shows "\<Gamma> \<Rightarrow> F,\<Delta> \<down> n \<and> G,\<Gamma> \<Rightarrow> \<Delta> \<down> n"
 proof(insert assms, induction "Imp F G, \<Gamma>" \<Delta> n arbitrary: \<Gamma> rule: SCc.induct)
   case (ImpL \<Gamma>' F' \<Delta> n G') thus ?case 
     by(cases "Or F G = Or F' G'"; (* oops, I didn't pay attention and used the wrong constructor\<dots> doesn't matter! *)
        auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc;
        blast)
 qed (fastforce intro!: SCc.intros(3-) dest!: multi_member_split simp: SCc.intros lem1 lem2)+
   
 lemma ImpR_inv':
   assumes "\<Gamma> \<Rightarrow> Imp F G,\<Delta> \<down> n"
   shows "F,\<Gamma> \<Rightarrow> G,\<Delta> \<down> n"
 proof(insert assms, induction \<Gamma> "Imp F G, \<Delta>" n arbitrary: \<Delta> rule: SCc.induct)
   case (ImpR  F' \<Gamma> G' \<Delta>') thus ?case 
     by(cases "Or F G = Or F' G'"; 
        auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc;
        blast)
 qed (fastforce intro!: SCc.intros(3-) dest!: multi_member_split simp: SCc.intros lem1 lem2)+
 
 lemma AndR_inv':
 shows "\<Gamma> \<Rightarrow> And F G, \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> F, \<Delta> \<down> n \<and> \<Gamma> \<Rightarrow> G, \<Delta> \<down> n"
 proof(induction \<Gamma> "And F G, \<Delta>" n arbitrary: \<Delta> rule: SCc.induct)
   case (AndR  \<Gamma> F' \<Delta>' n G') thus ?case 
     by(cases "Or F G = Or F' G'"; 
        auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc;
        blast)
 qed (fastforce intro!: SCc.intros(3-) dest!: multi_member_split simp: SCc.intros lem1 lem2)+
 
 lemma OrR_inv': "\<Gamma> \<Rightarrow> Or F G, \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> F,G,\<Delta> \<down> n"
 proof(induction \<Gamma> "Or F G, \<Delta>" n arbitrary: \<Delta> rule: SCc.induct)
   case (OrR  \<Gamma> F' G' \<Delta>') thus ?case 
     by(cases "Or F G = Or F' G'"; 
        auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc;
        metis add_mset_commute)
 qed (fastforce intro!: SCc.intros(3-) dest!: multi_member_split simp: SCc.intros lem1 lem2)+
 
 lemma NotR_inv': "\<Gamma> \<Rightarrow> Not F, \<Delta> \<down> n \<Longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta> \<down> n"
 proof(induction \<Gamma> "Not F, \<Delta>" n arbitrary: \<Delta> rule: SCc.induct)
   case (NotR  G \<Gamma> \<Delta>') thus ?case 
     by(cases "Not F = Not G"; 
        auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc;
        metis add_mset_commute)
 qed (fastforce intro!: SCc.intros(3-) dest!: multi_member_split simp: SCc.intros lem1 lem2)+
 
 lemma weakenL': "\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta>  \<down> n"
   by(induction rule: SCc.induct) 
     (auto intro!: SCc.intros(3-) intro: SCc.intros(1,2))
 
 lemma weakenR': "\<Gamma> \<Rightarrow> \<Delta>  \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> F,\<Delta>  \<down> n"
   by(induction rule: SCc.induct)
     (auto intro!: SCc.intros(3-) intro: SCc.intros(1,2))
 
 lemma contract':
   "(F,F,\<Gamma> \<Rightarrow> \<Delta> \<down> n \<longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta> \<down> n) \<and> (\<Gamma> \<Rightarrow> F,F,\<Delta> \<down> n \<longrightarrow> \<Gamma> \<Rightarrow> F,\<Delta> \<down> n)"
 proof(induction n arbitrary: F \<Gamma> \<Delta>)
   case (Suc n)
   hence IH: "F, F, \<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> F, \<Gamma> \<Rightarrow> \<Delta> \<down> n" "\<Gamma> \<Rightarrow> F, F, \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> F, \<Delta> \<down> n" for F :: "'a formula" and \<Gamma> \<Delta> by blast+
   show ?case proof(intro conjI allI impI, goal_cases)
     case 1
     let ?ffs = "\<lambda>\<Gamma>. \<Gamma> - {# F #} - {# F #}"
     from 1 show ?case proof(insert 1; cases rule: SCc.cases[of "F,F,\<Gamma>" \<Delta> "Suc n"])
       case (NotL  \<Gamma>' G)
       show ?thesis
       proof(cases)
         assume e: "F = \<^bold>\<not>G"
         with NotL have \<Gamma>': "\<Gamma>' = \<^bold>\<not>G, \<Gamma>" by simp
         from NotL_inv' NotL(2) have "\<Gamma> \<Rightarrow> G, G, \<Delta> \<down> n" unfolding \<Gamma>' .
         with IH(2) have "\<Gamma> \<Rightarrow> G, \<Delta> \<down> n" .
         with SCc.NotL show ?thesis unfolding e .
       next
         assume e: "F \<noteq> \<^bold>\<not>G"
         have ?thesis
           using NotL(2) IH(1)[of F "?ffs \<Gamma>'" "G, \<Delta>"] SCc.NotL[of "F, \<Gamma>' - {# F #} - {# F #}" G \<Delta> n]
           using e NotL(1) by (metis (no_types, lifting) insert_DiffM lem2)
         from e NotL(1) have \<Gamma>: "\<Gamma> = \<^bold>\<not> G, ?ffs \<Gamma>'" by (meson lem1)
         with NotL(1) have \<Gamma>': "F,F,?ffs \<Gamma>' = \<Gamma>'" by simp
         show ?thesis using NotL(2) IH(1)[of F "?ffs \<Gamma>'" "G, \<Delta>"] SCc.NotL[of "F, ?ffs \<Gamma>'" G \<Delta> n] \<open>F, \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n\<close> by blast
       qed
     next
       case (AndL G H \<Gamma>') show ?thesis proof cases
         assume e: "F = And G H"
         with AndL(1) have \<Gamma>': "\<Gamma>' = And G H, \<Gamma>" by simp
         have "G \<^bold>\<and> H, G, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n" using AndL(2) unfolding \<Gamma>' by auto
         hence "G, H, G, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n" by(rule AndL_inv')
         hence "G, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n" using IH(1) by (metis inL1' inL3')
         thus "F, \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n" using e SCc.AndL by simp
       next
         assume ne: "F \<noteq> And G H"
         with AndL(1) have \<Gamma>: "\<Gamma> = And G H, ?ffs \<Gamma>'" by (metis (no_types, lifting) diff_diff_add lem2)
         have "F, F, G, H, ?ffs \<Gamma>' \<Rightarrow> \<Delta> \<down> n" using AndL(2) using \<Gamma> inL4' local.AndL(1) by auto
         hence "G, H, F, ?ffs \<Gamma>' \<Rightarrow> \<Delta> \<down> n" using IH(1) inL2 by blast
         thus ?thesis using SCc.AndL unfolding \<Gamma> using inL1 by blast
       qed
     next
       case (OrL G \<Gamma>' H) show ?thesis proof cases
         assume e: "F = Or G H"
         with OrL(1) have \<Gamma>': "\<Gamma>' = Or G H, \<Gamma>" by simp
         have "Or G H, G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" "Or G H, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n" using OrL(2,3) unfolding \<Gamma>' by simp_all
         hence "G, G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" "H, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n" using OrL_inv' by blast+
         hence "G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" "H, \<Gamma> \<Rightarrow> \<Delta> \<down> n" using IH(1) by presburger+
         thus "F, \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n" unfolding e using SCc.OrL by blast
       next
         assume ne: "F \<noteq> Or G H"
         with OrL(1) have \<Gamma>: "\<Gamma> = Or G H, ?ffs \<Gamma>'" by (metis (no_types, lifting) diff_diff_add lem2)
         have "F, F, G, ?ffs \<Gamma>' \<Rightarrow> \<Delta> \<down> n" "F, F, H,?ffs \<Gamma>' \<Rightarrow> \<Delta> \<down> n" using OrL \<Gamma> by auto
         hence "G, F, ?ffs \<Gamma>' \<Rightarrow> \<Delta> \<down> n" "H, F, ?ffs \<Gamma>' \<Rightarrow> \<Delta> \<down> n" using IH(1) by(metis add_mset_commute)+
         thus ?thesis using SCc.OrL unfolding \<Gamma> by auto
       qed
     next
       case (ImpL \<Gamma>' G H) show ?thesis proof cases
         assume e: "F = Imp G H"
         with ImpL(1) have \<Gamma>': "\<Gamma>' = Imp G H, \<Gamma>" by simp
         have "H, \<Gamma> \<Rightarrow> \<Delta> \<down> n" "\<Gamma> \<Rightarrow> G,\<Delta> \<down> n" using IH ImpL_inv' ImpL(2,3) unfolding \<Gamma>'
           by (metis add_mset_commute)+
         thus ?thesis unfolding e using SCc.ImpL[where 'a='a] by simp
       next
         assume ne: "F \<noteq> Imp G H"
         with ImpL(1) have \<Gamma>: "\<Gamma> = Imp G H, ?ffs \<Gamma>'" by (metis (no_types, lifting) diff_diff_add lem2)
         have "F, F, ?ffs \<Gamma>' \<Rightarrow> G, \<Delta> \<down> n" "F, F, H, ?ffs \<Gamma>' \<Rightarrow> \<Delta> \<down> n" using ImpL \<Gamma> by auto
         thus ?thesis using SCc.ImpL IH unfolding \<Gamma> by (metis inL1')
       qed
     next
       case ImpR thus ?thesis by (simp add: IH(1) SCc.intros(10) add_mset_commute)
     next
       case (NotR G \<Delta>') thus ?thesis using IH(1) by (simp add: SCc.NotR add_mset_commute)
     qed (auto intro: IH SCc.intros(1,2) intro!: SCc.intros(3-10))
   next
     case 2
     let ?ffs = "\<lambda>\<Gamma>. \<Gamma> - {# F #} - {# F #}"
     have not_principal[dest]:
       "\<lbrakk>F \<noteq> f G H; F, F, \<Delta> = f G H, \<Delta>'\<rbrakk> \<Longrightarrow> \<Delta> = f G H, ?ffs \<Delta>' \<and> F, F, ?ffs \<Delta>' = \<Delta>'" for f G H \<Delta>' proof(intro conjI, goal_cases)
         case 2
         from 2 have "F \<in># \<Delta>'" by(blast dest: lem1[THEN iffD1])
         then obtain \<Delta>'' where \<Delta>': "\<Delta>' = F,\<Delta>''"  by (metis insert_DiffM)
         with 2(2) have "F, \<Delta> = f G H, \<Delta>''" by(simp add: add_mset_commute)
         hence "F \<in># \<Delta>''" using 2(1) by(blast dest: lem1[THEN iffD1])
         then obtain \<Delta>''' where \<Delta>'': "\<Delta>'' = F,\<Delta>'''" by (metis insert_DiffM)
         show ?case unfolding \<Delta>' \<Delta>'' by simp
         case 1 show ?case using 1(2) unfolding \<Delta>' \<Delta>'' by(simp add: add_mset_commute)
       qed
     have principal[dest]: "F, F, \<Delta> = f G H, \<Delta>' \<Longrightarrow> F = f G H \<Longrightarrow> \<Delta>' = f G H, \<Delta>" for f G H \<Delta>' by simp
     from 2 show ?case proof(cases rule: SCc.cases[of \<Gamma> "F,F,\<Delta>" "Suc n"])
       case (ImpR G H \<Delta>') thus ?thesis proof cases
         assume e[simp]: "F = Imp G H"
         with ImpR(1) have \<Delta>'[simp]: "\<Delta>' = Imp G H, \<Delta>" by simp
         have "G, \<Gamma> \<Rightarrow> Imp G H, H, \<Delta> \<down> n" using ImpR(2) by simp
         hence "G, G, \<Gamma> \<Rightarrow> H, H, \<Delta> \<down> n" by(rule ImpR_inv')
         hence "G, \<Gamma> \<Rightarrow> H, \<Delta> \<down> n" using IH by fast
         thus "\<Gamma> \<Rightarrow> F, \<Delta> \<down> Suc n" using SCc.ImpR by simp
       next
         assume a: "F \<noteq> Imp G H"
         with ImpR(1) have \<Delta>: "\<Delta> = Imp G H, ?ffs \<Delta>'" by (metis (no_types, lifting) diff_diff_add lem2)
         have "G,\<Gamma> \<Rightarrow> F, F, H, ?ffs \<Delta>' \<down> n" using ImpR \<Delta> by fastforce
         thus ?thesis using SCc.ImpR IH unfolding \<Delta> by (metis inR1')
       qed
     next
       case (AndR G \<Delta>' H) thus ?thesis proof(cases "F = And G H")
         case True thus ?thesis using AndR by(auto intro!: SCc.intros(3-) dest!: AndR_inv' intro: IH)
       next
         case False 
         hence e: "\<Delta> = And G H, ?ffs \<Delta>'" using AndR(1) using diff_diff_add lem2 by blast
         hence "G \<^bold>\<and> H, F, F, ?ffs \<Delta>' = G \<^bold>\<and> H, \<Delta>'" using AndR(1) by simp
         hence "\<Gamma> \<Rightarrow> F, F, G, ?ffs \<Delta>' \<down> n" "\<Gamma> \<Rightarrow> F, F, H, ?ffs \<Delta>' \<down> n" using AndR(2,3) using add_left_imp_eq inR2 by fastforce+
         hence "\<Gamma> \<Rightarrow> G, F, ?ffs \<Delta>' \<down> n" "\<Gamma> \<Rightarrow> H, F, ?ffs \<Delta>' \<down> n" using IH(2) by blast+
         thus ?thesis unfolding e by(intro SCc.AndR[THEN inR1'])
       qed
     next
     case (OrR G H \<Delta>') thus ?thesis proof cases
       assume a: "F = Or G H" 
       hence \<Delta>': "\<Delta>' = G \<^bold>\<or> H, \<Delta>" using OrR(1) by(intro principal)
       hence "\<Gamma> \<Rightarrow> G, H, G, H, \<Delta> \<down> n" using inR3'[THEN OrR_inv'] OrR(2) by auto
       hence "\<Gamma> \<Rightarrow> H, G, \<Delta> \<down> n" using IH(2)[of \<Gamma> G "H,H,\<Delta>"] IH(2)[of \<Gamma> H "G,\<Delta>"]
         unfolding add_ac(3)[of "{#H#}" "{#G#}"] using inR2  by blast
       hence "\<Gamma> \<Rightarrow> G, H, \<Delta> \<down> n" by(elim SC_swap_applies)
     thus ?thesis unfolding a by (simp add: SCc.OrR)
     next
       assume a: "F \<noteq> Or G H"
       with not_principal have np: "\<Delta> = G \<^bold>\<or> H, ?ffs \<Delta>' \<and> F, F, ?ffs \<Delta>' = \<Delta>'" using OrR(1) .
       with OrR(2) have "\<Gamma> \<Rightarrow> G, H, F, ?ffs \<Delta>' \<down> n" using IH(2) by (metis inR2' inR4')
       hence "\<Gamma> \<Rightarrow> F, G \<^bold>\<or> H, ?ffs \<Delta>' \<down> Suc n" by(intro SCc.OrR[THEN inR1'])
       thus ?thesis using np by simp
     qed
     next
       case (NotR G \<Delta>') thus ?thesis proof(cases "F = Not G") 
         case True 
         with principal NotR(1) have "\<Delta>' = \<^bold>\<not> G, \<Delta>" .
         with NotR_inv' NotR(2) have "G, G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" by blast
         with IH(1) have "G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" .
         thus "\<Gamma> \<Rightarrow> F, \<Delta> \<down> Suc n" unfolding True by(intro SCc.NotR)
       next
         case False 
         with not_principal have np: "\<Delta> = \<^bold>\<not> G, \<Delta>' - (F, {#F#}) \<and> F, F, \<Delta>' - (F, {#F#}) = \<Delta>'" using NotR(1) by auto
         hence "G, \<Gamma> \<Rightarrow> F, F, ?ffs \<Delta>' \<down> n" using NotR(2) by simp
         hence "G, \<Gamma> \<Rightarrow> F, ?ffs \<Delta>' \<down> n" by(elim IH(2))
         thus ?thesis using np SCc.NotR inR1 by auto
       qed
     next
       case BotL thus ?thesis by(elim SCc.BotL)
     next
       case (Ax k) thus ?thesis by(intro SCc.Ax[where k=k]) simp_all
     next
       case NotL thus ?thesis by (simp add: SCc.NotL Suc.IH add_mset_commute)
     next
       case AndL thus ?thesis using SCc.AndL Suc.IH by blast
     next
       case OrL thus ?thesis using SCc.OrL Suc.IH by blast
     next
       case ImpL thus ?thesis by (metis SCc.ImpL Suc.IH add_mset_commute)
     qed
   qed
 qed blast
 
 (* depth for cut? *)
 lemma Cut_Atom_depth: "Atom k,\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> Atom k,\<Delta> \<down> m \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta> \<down> n + m"
 proof(induction "Atom k,\<Gamma>" "\<Delta>" n arbitrary: \<Gamma> m rule: SCc.induct)
   case (BotL \<Delta>)
   hence "\<bottom> \<in># \<Gamma>" by simp
   thus ?case using SCc.BotL  by auto
 next
   case (Ax l \<Delta>)
   show ?case proof cases
     assume "l = k"
     with \<open>Atom l \<in># \<Delta>\<close> obtain \<Delta>' where "\<Delta> = Atom k, \<Delta>'" by (meson multi_member_split)
     with \<open>\<Gamma> \<Rightarrow> Atom k, \<Delta> \<down> m\<close> have "\<Gamma> \<Rightarrow> \<Delta> \<down> m" using contract' by blast
     thus ?thesis by (metis add.commute deeper)
   next
     assume "l \<noteq> k"
     with \<open>Atom l \<in># Atom k, \<Gamma>\<close> have "Atom l \<in># \<Gamma>" by simp
     with \<open>Atom l \<in># \<Delta>\<close> show ?thesis using SCc.Ax[of l] by simp
   qed
 next
   case (NotL \<Gamma> F \<Delta>)
   obtain \<Gamma>' where \<Gamma>: "\<Gamma> = Not F, \<Gamma>'" by (meson NotL.hyps(3) add_eq_conv_ex formula.simps(9))
   show ?case unfolding \<Gamma>
     apply(unfold plus_nat.add_Suc)
     apply(intro SCc.NotL)
     apply(intro NotL.hyps (* IH *))
      subgoal using NotL \<Gamma> by (simp add: lem2)
     subgoal using \<Gamma> NotL.prems NotL_inv' by blast
   done
 next
   case (NotR F \<Delta>)
   then show ?case by(auto intro!: SCc.NotR dest!: NotR_inv')
 next
   case (AndL F G \<Gamma> \<Delta>)
   obtain \<Gamma>' where \<Gamma>: "\<Gamma> = And F G, \<Gamma>'" by (metis AndL.hyps(3) add_eq_conv_diff formula.distinct(5))
   show ?case unfolding \<Gamma>
     apply(unfold plus_nat.add_Suc)
     apply(intro SCc.AndL)
     apply(intro AndL.hyps (* IH *))
      subgoal using AndL \<Gamma> by (simp add: lem2)
     subgoal using \<Gamma> AndL.prems AndL_inv' by blast
   done
 next
   case (AndR F \<Delta> G)
   then show ?case
     using AndR_inv' SCc.AndR by (metis add_Suc inR1')
 next
   case (OrL F \<Gamma>' \<Delta> n G)
   obtain \<Gamma>'' where \<Gamma>: "\<Gamma> = Or F G, \<Gamma>''" by (meson OrL.hyps(5) add_eq_conv_ex formula.simps(13))
   have ihm: "F, \<Gamma>' = Atom k, F, \<Gamma>''" "G, \<Gamma>' = Atom k, G, \<Gamma>''" using OrL \<Gamma>  by (simp_all add: lem2)
   show ?case unfolding \<Gamma>
     apply(unfold plus_nat.add_Suc)
     apply(intro SCc.OrL OrL.hyps(2)[OF ihm(1)] OrL.hyps(4)[OF ihm(2)])
      subgoal using \<Gamma> OrL.prems OrL_inv' by blast
     subgoal using \<Gamma> OrL.prems OrL_inv' by blast
   done
 next
   case (OrR F G \<Delta>)
   then show ?case by(auto intro!: SCc.intros(3-) dest!: OrR_inv')
 next
   case (ImpL \<Gamma>' F \<Delta> n G)
   obtain \<Gamma>'' where \<Gamma>: "\<Gamma> = Imp F G, \<Gamma>''" by (metis ImpL.hyps(5) add_eq_conv_ex formula.simps)
   show ?case unfolding \<Gamma>
     apply(unfold plus_nat.add_Suc)
     apply(intro SCc.ImpL ImpL.hyps(2) ImpL.hyps(4))
        subgoal using ImpL \<Gamma> by (simp add: lem2)
       subgoal using \<Gamma> ImpL.prems by(auto dest!: ImpL_inv')
      subgoal using ImpL \<Gamma> by (simp add: lem2)
     subgoal using \<Gamma> ImpL.prems ImpL_inv' by blast
   done
 next
   case (ImpR F G \<Delta>)
   then show ?case by (auto dest!: ImpR_inv' intro!: SCc.ImpR)
 qed
 primrec cut_bound :: "nat \<Rightarrow> nat \<Rightarrow> 'a formula \<Rightarrow> nat" where
   "cut_bound n m (Atom _) = m + n" |
   "cut_bound n m Bot = n" |
   "cut_bound n m (Not F) = cut_bound m n F" |
   "cut_bound n m (And F G) = cut_bound n (cut_bound n m F) G" |
   "cut_bound n m (Or F G) = cut_bound (cut_bound n m F) m G" |
   "cut_bound n m (Imp F G) = cut_bound (cut_bound m n F) m G"
 theorem cut_bound: "\<Gamma> \<Rightarrow> F,\<Delta> \<down> n \<Longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta>  \<down> m \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta> \<down> cut_bound n m F"
 proof(induction F arbitrary: \<Gamma> \<Delta> n m)
   case (Atom k) thus ?case using Cut_Atom_depth by simp fast
 next
   case Bot thus ?case using Bot_delR' by fastforce 
 next
   case Not from Not.prems show ?case by(auto dest!: NotL_inv' NotR_inv' intro!: Not.IH elim!: weakenL)
 next
   case (And F G) from And.prems show ?case by(auto dest!: AndL_inv' AndR_inv' intro!: And.IH elim!: weakenR' weakenL')
 next
   case (Or F G) from Or.prems show ?case by(auto dest: OrL_inv' OrR_inv' intro!: Or.IH elim!:  weakenR' weakenL')
 next
   case (Imp F G)
   from ImpR_inv' \<open>\<Gamma> \<Rightarrow> F \<^bold>\<rightarrow> G, \<Delta> \<down> n\<close> have R: "F, \<Gamma> \<Rightarrow> G, \<Delta> \<down> n" by blast
   from ImpL_inv' \<open>F \<^bold>\<rightarrow> G, \<Gamma> \<Rightarrow> \<Delta> \<down> m\<close> have L: "\<Gamma> \<Rightarrow> F, \<Delta> \<down> m" "G, \<Gamma> \<Rightarrow> \<Delta> \<down> m" by blast+
   from L(1) have "\<Gamma> \<Rightarrow> F, G, \<Delta> \<down> m" using weakenR' by blast
   from Imp.IH(1)[OF this R] have "\<Gamma> \<Rightarrow> G, \<Delta> \<down> cut_bound m n F" .
   from Imp.IH(2)[OF this L(2)] have "\<Gamma> \<Rightarrow> \<Delta> \<down> cut_bound (cut_bound m n F) m G" .
   thus "\<Gamma> \<Rightarrow> \<Delta> \<down> cut_bound n m (F \<^bold>\<rightarrow> G)" by simp
 qed
   
 context begin
 private primrec cut_bound' :: "nat \<Rightarrow> 'a formula \<Rightarrow> nat" where
   "cut_bound' n (Atom _) = 2*n" |
   "cut_bound' n Bot = n" |
   "cut_bound' n (Not F) = cut_bound' n F" |
   "cut_bound' n (And F G) = cut_bound' (cut_bound' n F) G" |
   "cut_bound' n (Or F G) = cut_bound' (cut_bound' n F) G" |
   "cut_bound' n (Imp F G) = cut_bound' (cut_bound' n F) G"
   
 private lemma cut_bound'_mono: "a \<le> b \<Longrightarrow> cut_bound' a F \<le> cut_bound' b F"
   by(induction F arbitrary: a b; simp)
     
 private lemma cut_bound_mono: "a \<le> c \<Longrightarrow> b \<le> d \<Longrightarrow> cut_bound a b F \<le> cut_bound c d F"
   by(induction F arbitrary: a b c d; simp)
     
 private lemma cut_bound_max: "max n (cut_bound' (max n m) F) = cut_bound' (max n m) F"
   by(induction F arbitrary: n m; simp; metis)
 private lemma cut_bound_max': "max n (cut_bound' n F) = cut_bound' n F"
   by(induction F arbitrary: n ; simp; metis max.assoc)
     
 private lemma cut_bound_': "cut_bound n m F \<le> cut_bound' (max n m) F"
 proof(induction F arbitrary: n m)
   case (Not F)
   then show ?case by simp (metis max.commute)
 next
   case (And F1 F2)
   from And.IH(1) have 1: "cut_bound n (cut_bound n m F1) F2 \<le> cut_bound n (cut_bound' (max n m) F1) F2" 
     by(rule cut_bound_mono[OF order.refl])
   also from And.IH(2) have "\<dots> \<le> cut_bound' (max n (cut_bound' (max n m) F1)) F2" by simp
   also have "\<dots> = cut_bound' (cut_bound' (max n m) F1) F2" by (simp add: cut_bound_max)
   finally show ?case by simp
 next
   case (Or F1 F2)
   from Or.IH(1) have 1: "cut_bound (cut_bound n m F1) m F2 \<le> cut_bound (cut_bound' (max n m) F1) m F2" 
     by(rule cut_bound_mono[OF _ order.refl])
   also from Or.IH(2)[of "cut_bound' (max n m) F1"] have "\<dots> \<le> cut_bound' (max (cut_bound' (max n m) F1) m) F2" by simp
   also have "\<dots> = cut_bound' (cut_bound' (max n m) F1) F2" by (simp add: cut_bound_max max.commute)
   finally show ?case by simp
 next
   case (Imp F1 F2)
   from Imp.IH(1) have 1: "cut_bound (cut_bound m n F1) m F2 \<le> cut_bound (cut_bound' (max m n) F1) m F2" 
     by(rule cut_bound_mono[OF _ order.refl])
   also from Imp.IH(2)[of "cut_bound' (max m n) F1"] have "\<dots> \<le> cut_bound' (max (cut_bound' (max m n) F1) m) F2" by simp
   also have "\<dots> = cut_bound' (cut_bound' (max n m) F1) F2" by (simp add: cut_bound_max max.commute)
   finally show ?case by simp
 qed simp_all
     
 primrec depth :: "'a formula \<Rightarrow> nat" where
   "depth (Atom _) = 0" |
   "depth Bot = 0" |
   "depth (Not F) = Suc (depth F)" |
   "depth (And F G) = Suc (max (depth F) (depth G))" |
   "depth (Or F G) = Suc (max (depth F) (depth G))" |
   "depth (Imp F G) = Suc (max (depth F) (depth G))"
   
 private primrec (* primrec works, but fun would give me a nicer induction rule *) cbnd where
   "cbnd k 0 = 2*k" |
   "cbnd k (Suc n) = cbnd (cbnd k n) n"
   
 private lemma cbnd_grow: "(k :: nat) \<le> cbnd k d"
   by(induction d arbitrary: k; simp) (insert le_trans, blast)
     
 private lemma cbnd_mono: assumes "b \<le> d" shows "cbnd (a::nat) b \<le> cbnd a d"
 proof -
   have "cbnd (a::nat) b \<le> cbnd a (b + d)" for b d
     by(induction d arbitrary: a b; simp) (insert le_trans cbnd_grow, blast)
   thus ?thesis using assms using le_Suc_ex by blast
 qed
 
 private lemma cut_bound'_cbnd: "cut_bound' n F \<le> cbnd n (depth F)"
 proof(induction F arbitrary: n)
 next
   case (Not F)
   then show ?case using cbnd_grow dual_order.trans by fastforce
 next
   case (And F1 F2)
   let ?md = "max (depth F1) (depth F2)"
   have "cut_bound' (cut_bound' n F1) F2 \<le> cut_bound' (cbnd n (depth F1)) F2" by (simp add: And.IH(1) cut_bound'_mono)
   also have "... \<le> cut_bound' (cbnd n ?md) F2" by (simp add: cbnd_mono cut_bound'_mono)
   also have "... \<le> cbnd (cbnd n ?md) (depth F2)" using And.IH(2) by blast
   also have "... \<le> cbnd (cbnd n ?md) ?md" by (simp add: cbnd_mono)
   finally show ?case by simp
 next
   case (Imp F1 F2)
   case (Or F1 F2)
   text\<open>analogous\<close> (*<*)
   let ?md = "max (depth F1) (depth F2)"
   have "cut_bound' (cut_bound' n F1) F2 \<le> cut_bound' (cbnd n (depth F1)) F2" by (simp add: Or.IH(1) cut_bound'_mono)
   also have "... \<le> cut_bound' (cbnd n ?md) F2" by (simp add: cbnd_mono cut_bound'_mono)
   also have "... \<le> cbnd (cbnd n ?md) (depth F2)" using Or.IH(2) by blast
   also have "... \<le> cbnd (cbnd n ?md) ?md" by (simp add: cbnd_mono)
   finally show ?case by simp
 next
   case (Imp F1 F2)
   let ?md = "max (depth F1) (depth F2)"
   have "cut_bound' (cut_bound' n F1) F2 \<le> cut_bound' (cbnd n (depth F1)) F2" by (simp add: Imp.IH(1) cut_bound'_mono)
   also have "... \<le> cut_bound' (cbnd n ?md) F2" by (simp add: cbnd_mono cut_bound'_mono)
   also have "... \<le> cbnd (cbnd n ?md) (depth F2)" using Imp.IH(2) by blast
   also have "... \<le> cbnd (cbnd n ?md) ?md" by (simp add: cbnd_mono)
   finally show ?case by simp
 (*>*)
 qed simp_all
 
 value "map (cbnd (0::int)) [0,1,2,3,4]"
 value "map (cbnd (1::int)) [0,1,2,3,4]" (* int, because that's easier to read\<dots> *)
 value "map (cbnd (2::int)) [0,1,2,3,4]"
 value "map (cbnd (3::int)) [0,1,2,3,4]"
 value [nbe] "map (int \<circ> (\<lambda>n. n div 3) \<circ> cut_bound 3 3 \<circ> (\<lambda>n. ((\<lambda>F. And F F) ^^ n) (Atom 0))) [0,1,2,3,4,5,6,7]"
 value [nbe] "map (int \<circ> (\<lambda>n. n div 3) \<circ> cut_bound' 3 \<circ> (\<lambda>n. ((\<lambda>F. And F F) ^^ n) (Atom 0))) [0,1,2,3,4]"
 (* TODO: hm *)
 value [nbe] "map (int \<circ> (\<lambda>n. n div 3) \<circ> cut_bound 3 3 \<circ> (\<lambda>n. ((\<lambda>F. Imp (Or F F) (And F F)) ^^ n) (Atom 0))) [0,1,2]"
 value [nbe] "map (int \<circ> (\<lambda>n. n div 3) \<circ> cut_bound' 3 \<circ> (\<lambda>n. ((\<lambda>F. Imp (Or F F) (And F F)) ^^ n) (Atom 0))) [0,1,2]"
 (* Hmhm *)
 value [nbe] "(\<lambda>F. And (Or F F) (Or F F)) ^^ 2"
 
 lemma "n + ((n + m) * 2 ^ (size F - Suc 0) + 
       (n + (n + m + (n + m) * 2 ^ (size F - Suc 0))) * 2 ^ (size G - Suc 0))
     \<le> (n + (m :: nat)) * 2 ^ (size F + size G)"
   oops
     (* so the proof below won't work. *)
 lemma "cut_bound (n :: nat) m F \<le> (n + m) * (2 ^ (size F - 1) + 1)"
 proof(induction F arbitrary: n m)
 next
   case (Not F)
   show ?case unfolding cut_bound.simps by(rule le_trans[OF Not]) (simp add: add.commute)
 next
   have "1 \<le> size F" for F :: "'a formula" by(cases F; simp)
   case (And F G)
   from And(2) have "cut_bound n (cut_bound n m F) G \<le> (n + (cut_bound n m F)) * (2 ^ (size G - 1) + 1)" by simp
   also from And(1) have "\<dots> \<le> (n + (n + m) * (2 ^ (size F - 1) + 1)) * (2 ^ (size G - 1) + 1)" 
     by (meson add_le_cancel_left mult_le_mono1)
   also have "\<dots> \<le> (n + m) * (2 ^ (size (F \<^bold>\<and> G) - 1) + 1)"
     apply simp
     oops
       
 (* Oh! Look: *)
 private lemma cbnd_comm: "cbnd (l * k::nat) n = l * cbnd (k::nat) n"
   by(induction n arbitrary: k; simp)
 
 private lemma cbnd_closed: "cbnd (k::nat) n = k * 2 ^ (2 ^ n)"
   by(induction n arbitrary: k;simp add: semiring_normalization_rules(26))
     
 theorem cut': assumes "\<Gamma> \<Rightarrow> F,\<Delta> \<down> n" "F,\<Gamma> \<Rightarrow> \<Delta> \<down> n" shows "\<Gamma> \<Rightarrow> \<Delta> \<down> n * 2 ^ (2 ^ depth F)"
 proof -
   from cut_bound[OF assms] have c: "\<Gamma> \<Rightarrow> \<Delta> \<down> cut_bound n n F" .
   have d: "cut_bound n n F \<le> max n n * 2 ^ (2 ^ depth F)" 
     using cut_bound_' cut_bound'_cbnd cbnd_closed by (metis order_trans)
   show ?thesis using c d le_Suc_ex deeper unfolding max.idem by metis
 qed
   
 end
 
 end
diff --git a/thys/Propositional_Proof_Systems/SC_Gentzen.thy b/thys/Propositional_Proof_Systems/SC_Gentzen.thy
--- a/thys/Propositional_Proof_Systems/SC_Gentzen.thy
+++ b/thys/Propositional_Proof_Systems/SC_Gentzen.thy
@@ -1,250 +1,257 @@
 subsubsection\<open>Mimicking the original\<close>
 
 theory SC_Gentzen
 imports SC_Depth SC_Cut
 begin
 
 text\<open>This system attempts to mimic the original sequent calculus 
   (``Reihen von Formeln, durch Kommata getrennt'', translates roughly to sequences of formulas, separated by a comma)~\cite{gentzen1935untersuchungen}.\<close>
 inductive SCg :: "'a formula list \<Rightarrow> 'a formula list \<Rightarrow> bool" (infix "\<Rightarrow>" 30) where
 Anfang: "[\<DD>] \<Rightarrow> [\<DD>]" |
 FalschA: "[\<bottom>] \<Rightarrow> []" |
 VerduennungA: "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<DD>#\<Gamma> \<Rightarrow> \<Theta>" |
 VerduennungS: "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<DD>#\<Theta>" |
 ZusammenziehungA: "\<DD>#\<DD>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<DD>#\<Gamma> \<Rightarrow> \<Theta>" |
 ZusammenziehungS: "\<Gamma> \<Rightarrow> \<DD>#\<DD>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<DD>#\<Theta>" |
 VertauschungA: "\<Delta>@\<DD>#\<EE>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Delta>@\<EE>#\<DD>#\<Gamma> \<Rightarrow> \<Theta>" |
 VertauschungS: "\<Gamma> \<Rightarrow> \<Theta>@\<EE>#\<DD>#\<Lambda> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>@\<DD>#\<EE>#\<Lambda>" |
 Schnitt: "\<lbrakk>\<Gamma> \<Rightarrow> \<DD>#\<Theta>; \<DD>#\<Delta> \<Rightarrow> \<Lambda>\<rbrakk> \<Longrightarrow> \<Gamma>@\<Delta> \<Rightarrow> \<Theta>@\<Lambda>" |
 UES: "\<lbrakk>\<Gamma> \<Rightarrow> \<AA>#\<Theta>; \<Gamma> \<Rightarrow> \<BB>#\<Theta>\<rbrakk> \<Longrightarrow> \<Gamma> \<Rightarrow> \<AA>\<^bold>\<and>\<BB>#\<Theta>" |
 UEA1: "\<AA>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<AA>\<^bold>\<and>\<BB>#\<Gamma> \<Rightarrow> \<Theta>" | UEA2: "\<BB>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<AA>\<^bold>\<and>\<BB>#\<Gamma> \<Rightarrow> \<Theta>" |
 OEA: "\<lbrakk>\<AA>#\<Gamma> \<Rightarrow> \<Theta>; \<BB>#\<Gamma> \<Rightarrow> \<Theta>\<rbrakk> \<Longrightarrow> \<AA>\<^bold>\<or>\<BB>#\<Gamma> \<Rightarrow> \<Theta>" |
 OES1: "\<Gamma> \<Rightarrow> \<AA>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<AA>\<^bold>\<or>\<BB>#\<Theta>" | OES2: "\<Gamma> \<Rightarrow> \<BB>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<AA>\<^bold>\<or>\<BB>#\<Theta>" |
 FES: "\<AA>#\<Gamma> \<Rightarrow> \<BB>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<AA>\<^bold>\<rightarrow>\<BB>#\<Theta>" |
 FEA: "\<lbrakk>\<Gamma> \<Rightarrow> \<AA>#\<Theta>; \<BB>#\<Delta> \<Rightarrow> \<Lambda>\<rbrakk> \<Longrightarrow> \<AA>\<^bold>\<rightarrow>\<BB>#\<Gamma>@\<Delta> \<Rightarrow> \<Theta>@\<Lambda>" |
 NES: "\<AA>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<^bold>\<not>\<AA>#\<Theta>" |
 NEA: "\<Gamma> \<Rightarrow> \<AA>#\<Theta> \<Longrightarrow> \<^bold>\<not>\<AA>#\<Gamma> \<Rightarrow> \<Theta>"
 text\<open>Nota bene: E here stands for ``Einführung'', which is introduction and not elemination.\<close>
 text\<open>The rule for @{term \<bottom>} is not part of the original calculus. Its addition is necessary to show equivalence to our @{const SCp}.\<close>
 
 text\<open>Note that we purposefully did not recreate the fact that Gentzen sometimes puts his principal formulas on end and sometimes on the beginning of the list.\<close>
 
 lemma AnfangTauschA: "\<DD>#\<Delta>@\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Delta>@\<DD>#\<Gamma> \<Rightarrow> \<Theta>"
   by(induction \<Delta> arbitrary: \<Gamma> rule: List.rev_induct) (simp_all add: VertauschungA)
 lemma AnfangTauschS: "\<Gamma> \<Rightarrow> \<DD>#\<Delta>@\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>@\<DD>#\<Theta>"
   by(induction \<Delta> arbitrary: \<Theta> rule: List.rev_induct) (simp_all add: VertauschungS)
 lemma MittenTauschA: "\<Delta>@\<DD>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<DD>#\<Delta>@\<Gamma> \<Rightarrow> \<Theta>"
   by(induction \<Delta> arbitrary: \<Gamma> rule: List.rev_induct) (simp_all add: VertauschungA)
 lemma MittenTauschS: "\<Gamma> \<Rightarrow> \<Delta>@\<DD>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<DD>#\<Delta>@\<Theta>"
   by(induction \<Delta> arbitrary: \<Theta> rule: List.rev_induct) (simp_all add: VertauschungS)
 
 lemma BotLe: "\<bottom>\<in>set \<Gamma> \<Longrightarrow> \<Gamma>\<Rightarrow>\<Delta>"
 proof -
   have A: "\<bottom>#\<Gamma>\<Rightarrow>[]" for \<Gamma> by(induction \<Gamma>) (simp_all add: FalschA VerduennungA VertauschungA[where \<Delta>=Nil, simplified])
   have *: "\<bottom>#\<Gamma>\<Rightarrow>\<Delta>" for \<Gamma> by(induction \<Delta>) (simp_all add: A VerduennungS)
   assume "\<bottom>\<in>set \<Gamma>" then obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1@\<bottom>#\<Gamma>2" by (meson split_list)
   show ?thesis unfolding \<Gamma> using AnfangTauschA * by blast
 qed
 
 lemma Axe: "A \<in> set \<Gamma> \<Longrightarrow> A \<in> set \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
 proof -
   have A: "A#\<Gamma> \<Rightarrow> [A]" for \<Gamma> by(induction \<Gamma>) (simp_all add: Anfang VertauschungA[where \<Delta>=Nil, simplified] VerduennungA)
   have S: "A#\<Gamma> \<Rightarrow> A#\<Delta>" for \<Gamma> \<Delta> by(induction \<Delta>) (simp_all add: A Anfang VertauschungS[where \<Theta>=Nil, simplified] VerduennungS)
   assume "A \<in> set \<Gamma>" "A \<in> set \<Delta>" thus ?thesis
     apply(-)
     apply(drule split_list)+
     apply(clarify)
     apply(intro AnfangTauschA AnfangTauschS)
     apply(rule S)
   done
 qed
 
 lemma VerduennungListeA: "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma>@\<Gamma> \<Rightarrow> \<Theta>"
 proof -
   have "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<exists>\<Gamma>''. \<Gamma>=\<Gamma>''@\<Gamma>' \<Longrightarrow> \<Gamma>'@\<Gamma> \<Rightarrow> \<Theta>" for \<Gamma>'
   proof(induction \<Gamma>')
     case (Cons a as)
-    from \<open>\<exists>\<Gamma>''. \<Gamma> = \<Gamma>'' @ a # as\<close> guess \<Gamma>'' ..
+    then obtain \<Gamma>'' where "\<Gamma> = \<Gamma>'' @ a # as" by blast
     hence "\<exists>\<Gamma>''. \<Gamma> = \<Gamma>'' @ as" by(intro exI[where x="\<Gamma>'' @ [a]"]) simp
     from Cons.IH[OF Cons.prems(1) this] have "as @ \<Gamma> \<Rightarrow> \<Theta>" .
     thus ?case using VerduennungA by simp
   qed simp
   thus "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma>@\<Gamma> \<Rightarrow> \<Theta>" by simp
 qed
 lemma VerduennungListeS: "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>@\<Theta>"
 proof -
   have "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<exists>\<Theta>''. \<Theta>=\<Theta>''@\<Theta>' \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>'@\<Theta>" for \<Theta>'
   proof(induction \<Theta>')
     case (Cons a as)
-    from \<open>\<exists>\<Theta>''. \<Theta> = \<Theta>'' @ a # as\<close> guess \<Theta>'' ..
+    then obtain \<Theta>'' where "\<Theta> = \<Theta>'' @ a # as" by blast
     hence "\<exists>\<Theta>''. \<Theta> = \<Theta>'' @ as" by(intro exI[where x="\<Theta>'' @ [a]"]) simp
     from Cons.IH[OF Cons.prems(1) this] have " \<Gamma> \<Rightarrow> as @ \<Theta>" .
     thus ?case using VerduennungS by simp
   qed simp
   thus "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>@\<Theta>" by simp
 qed
 (* wak, those weren't the droids I was looking for. *)
 lemma ZusammenziehungListeA: "\<Gamma>@\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>"
 proof -
   have "\<Gamma>'@\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<exists>\<Gamma>''. \<Gamma>=\<Gamma>''@\<Gamma>' \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>" for \<Gamma>'
   proof(induction \<Gamma>')
     case (Cons a \<Gamma>')
-    from \<open>\<exists>\<Gamma>''. \<Gamma> = \<Gamma>'' @ a # \<Gamma>'\<close> guess \<Gamma>'' .. note \<Gamma>'' = this
+    then obtain \<Gamma>'' where \<Gamma>'': "\<Gamma> = \<Gamma>'' @ a # \<Gamma>'" by blast
     then obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ a # \<Gamma>2" by blast
     from \<Gamma>'' have **: "\<exists>\<Gamma>''. \<Gamma> = \<Gamma>'' @ \<Gamma>'" by(intro exI[where x="\<Gamma>'' @ [a]"]) simp
     from Cons.prems(1) have "a # (a # \<Gamma>') @ \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Theta>" unfolding \<Gamma>  using MittenTauschA by (metis append_assoc)
     hence "(a # \<Gamma>') @ \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Theta>" using ZusammenziehungA by auto
     hence "\<Gamma>' @ \<Gamma> \<Rightarrow> \<Theta>" unfolding \<Gamma>  using AnfangTauschA by (metis append_Cons append_assoc)
     from Cons.IH[OF this **] show "\<Gamma> \<Rightarrow> \<Theta>" .
   qed simp
   thus "\<Gamma>@\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>" by simp
 qed
 lemma ZusammenziehungListeS: "\<Gamma> \<Rightarrow> \<Theta>@\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>"
 proof -
   have "\<Gamma> \<Rightarrow> \<Theta>'@\<Theta> \<Longrightarrow> \<exists>\<Theta>''. \<Theta>=\<Theta>''@\<Theta>' \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>" for \<Theta>'
   proof(induction \<Theta>')
     case (Cons a \<Theta>')
-    from \<open>\<exists>\<Theta>''. \<Theta> = \<Theta>'' @ a # \<Theta>'\<close> guess \<Theta>'' .. note \<Theta>'' = this
+    then obtain \<Theta>'' where \<Theta>'': "\<Theta> = \<Theta>'' @ a # \<Theta>'" by blast
     then obtain \<Theta>1 \<Theta>2 where \<Theta>: "\<Theta> = \<Theta>1 @ a # \<Theta>2" by blast
     from \<Theta>'' have **: "\<exists>\<Theta>''. \<Theta> = \<Theta>'' @ \<Theta>'" by(intro exI[where x="\<Theta>'' @ [a]"]) simp
     from Cons.prems(1) have "\<Gamma> \<Rightarrow> a # (a # \<Theta>') @ \<Theta>1 @ \<Theta>2" unfolding \<Theta>  using MittenTauschS by (metis append_assoc)
     hence "\<Gamma> \<Rightarrow> (a # \<Theta>') @ \<Theta>1 @ \<Theta>2" using ZusammenziehungS by auto
     hence "\<Gamma> \<Rightarrow> \<Theta>' @ \<Theta>" unfolding \<Theta>  using AnfangTauschS by (metis append_Cons append_assoc)
     from Cons.IH[OF this **] show "\<Gamma> \<Rightarrow> \<Theta>" .
   qed simp
   thus "\<Gamma> \<Rightarrow> \<Theta>@\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow>\<Theta>" by simp
 qed
 
 theorem gentzen_sc_eq: "mset \<Gamma> \<Rightarrow> mset \<Delta> \<longleftrightarrow> \<Gamma> \<Rightarrow> \<Delta>" proof
   assume "mset \<Gamma> \<Rightarrow> mset \<Delta>" 
   then obtain n where "mset \<Gamma> \<Rightarrow> mset \<Delta> \<down> n" unfolding SC_SCp_eq[symmetric] ..
   thus "\<Gamma> \<Rightarrow> \<Delta>"
   (* structural induction not necessary at all. I still don't get it. *)
   proof(induction n arbitrary: \<Gamma> \<Delta> rule: nat.induct)
     case (Suc n) 
     have sr: "\<exists>\<Gamma>1 \<Gamma>2. \<Gamma> = \<Gamma>1 @ F # \<Gamma>2 \<and> \<Gamma>' = mset (\<Gamma>1@\<Gamma>2)" (is "?s") if "mset \<Gamma> = F, \<Gamma>'" for \<Gamma> \<Gamma>' F proof -
       from that obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ F # \<Gamma>2" by (metis split_list add.commute ex_mset list.set_intros(1) mset.simps(2) set_mset_mset)
       hence \<Gamma>': "\<Gamma>' = mset (\<Gamma>1@\<Gamma>2)" using that by auto
       show ?s using \<Gamma> \<Gamma>' by blast
     qed
     from Suc.prems show ?case proof(cases rule: SCc.cases)
       case BotL thus ?thesis using BotLe by simp
     next
       case Ax thus ?thesis using Axe by simp
     next
       case (NotL \<Gamma>' F)
       from \<open>mset \<Gamma> = \<^bold>\<not> F, \<Gamma>'\<close> obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ \<^bold>\<not> F # \<Gamma>2" 
         by (metis split_list add.commute ex_mset list.set_intros(1) mset.simps(2) set_mset_mset)
       hence \<Gamma>': "\<Gamma>' = mset (\<Gamma>1@\<Gamma>2)" using NotL(1) by simp
       from \<open>\<Gamma>' \<Rightarrow> F, mset \<Delta> \<down> n\<close> have "mset (\<Gamma>1@\<Gamma>2) \<Rightarrow> mset (F#\<Delta>) \<down> n" unfolding \<Gamma>' by (simp add: add.commute)
       from Suc.IH[OF this] show ?thesis unfolding \<Gamma> using AnfangTauschA NEA by blast
     next
       case (NotR F \<Delta>')
-      from sr[OF NotR(1)] guess \<Delta>1 .. then guess \<Delta>2 .. note \<Delta> = this
+      from sr[OF NotR(1)] obtain \<Delta>1 \<Delta>2 where \<Delta>: "\<Delta> = \<Delta>1 @ \<^bold>\<not> F # \<Delta>2 \<and> \<Delta>' = mset (\<Delta>1 @ \<Delta>2)"
+        by blast
       with NotR have "mset (F#\<Gamma>) \<Rightarrow> mset (\<Delta>1@\<Delta>2) \<down> n" by (simp add: add.commute)
       from Suc.IH[OF this] show ?thesis using \<Delta> using AnfangTauschS NES by blast
     next
       case (AndR F \<Delta>' G)
-      from sr[OF AndR(1)] guess \<Delta>1 .. then guess \<Delta>2 .. note \<Delta> = this
+      from sr[OF AndR(1)] obtain \<Delta>1 \<Delta>2 where \<Delta>: "\<Delta> = \<Delta>1 @ F \<^bold>\<and> G # \<Delta>2 \<and> \<Delta>' = mset (\<Delta>1 @ \<Delta>2)"
+        by blast
       with AndR have "mset \<Gamma> \<Rightarrow> mset (F # \<Delta>1@\<Delta>2) \<down> n" "mset \<Gamma> \<Rightarrow> mset (G # \<Delta>1@\<Delta>2) \<down> n" by (simp add: add.commute)+
       from this[THEN Suc.IH] show ?thesis using \<Delta> using AnfangTauschS UES by blast
     next
       case (OrR F G \<Delta>')
-      from sr[OF OrR(1)] guess \<Delta>1 .. then guess \<Delta>2 .. note \<Delta> = this
+      from sr[OF OrR(1)] obtain \<Delta>1 \<Delta>2 where \<Delta>: "\<Delta> = \<Delta>1 @ F \<^bold>\<or> G # \<Delta>2 \<and> \<Delta>' = mset (\<Delta>1 @ \<Delta>2)"
+        by blast
       with OrR have "mset \<Gamma> \<Rightarrow> mset (G # F # \<Delta>1@\<Delta>2) \<down> n" by (simp add: add.commute add.left_commute add_mset_commute)
       from this[THEN Suc.IH] have "\<Gamma> \<Rightarrow> G # F # \<Delta>1 @ \<Delta>2" .
       with OES2 have "\<Gamma> \<Rightarrow> F \<^bold>\<or> G # F # \<Delta>1 @ \<Delta>2" .
       with VertauschungS[where \<Theta>=Nil, simplified] have "\<Gamma> \<Rightarrow> F # F \<^bold>\<or> G # \<Delta>1 @ \<Delta>2" .
       with OES1 have "\<Gamma> \<Rightarrow> F \<^bold>\<or> G # F \<^bold>\<or> G # \<Delta>1 @ \<Delta>2" .
       hence "\<Gamma> \<Rightarrow> F \<^bold>\<or> G # \<Delta>1 @ \<Delta>2" using ZusammenziehungS by fast 
       thus ?thesis unfolding \<Delta>[THEN conjunct1] using AnfangTauschS by blast
     next
       case (ImpR F G \<Delta>')
-      from sr[OF ImpR(1)] guess \<Delta>1 .. then guess \<Delta>2 .. note \<Delta> = this
+      from sr[OF ImpR(1)] obtain \<Delta>1 \<Delta>2 where \<Delta>: "\<Delta> = \<Delta>1 @ F \<^bold>\<rightarrow> G # \<Delta>2 \<and> \<Delta>' = mset (\<Delta>1 @ \<Delta>2)"
+        by blast
       with ImpR have "mset (F#\<Gamma>) \<Rightarrow> mset (G # \<Delta>1@\<Delta>2) \<down> n" by (simp add: add.commute)
       from this[THEN Suc.IH] show ?thesis using \<Delta> using AnfangTauschS FES by blast
     next
       case (AndL F G \<Gamma>')
-      from sr[OF this(1)] guess \<Gamma>1 .. then guess \<Gamma>2 .. note \<Gamma> = this
+      from sr[OF this(1)] obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ F \<^bold>\<and> G # \<Gamma>2 \<and> \<Gamma>' = mset (\<Gamma>1 @ \<Gamma>2)"
+        by blast
       with AndL have "mset (G # F # \<Gamma>1@\<Gamma>2) \<Rightarrow> mset \<Delta> \<down> n" by (simp add: add.commute add.left_commute add_mset_commute)
       from this[THEN Suc.IH] have "G # F # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
       with UEA2 have "F \<^bold>\<and> G # F # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
       with VertauschungA[where \<Delta>=Nil, simplified] have "F # F \<^bold>\<and> G # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
       with UEA1 have "F \<^bold>\<and> G # F \<^bold>\<and> G # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
       hence "F \<^bold>\<and> G # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" using ZusammenziehungA by fast 
       thus ?thesis unfolding \<Gamma>[THEN conjunct1] using AnfangTauschA by blast
     next
       case (OrL F \<Delta>' G)
-      from sr[OF this(1)] guess \<Gamma>1 .. then guess \<Gamma>2 .. note \<Gamma> = this
+      from sr[OF this(1)] obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ F \<^bold>\<or> G # \<Gamma>2 \<and> \<Delta>' = mset (\<Gamma>1 @ \<Gamma>2)"
+        by blast
       with OrL have "mset (F # \<Gamma>1@\<Gamma>2) \<Rightarrow> mset \<Delta> \<down> n" "mset (G # \<Gamma>1@\<Gamma>2) \<Rightarrow> mset \<Delta> \<down> n" by (simp add: add.commute)+
       from this[THEN Suc.IH] show ?thesis using \<Gamma> using AnfangTauschA OEA by blast
     next
       case (ImpL \<Gamma>' F G)
-      from sr[OF this(1)] guess \<Gamma>1 .. then guess \<Gamma>2 .. note \<Gamma> = this
+      from sr[OF this(1)] obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ F \<^bold>\<rightarrow> G # \<Gamma>2 \<and> \<Gamma>' = mset (\<Gamma>1 @ \<Gamma>2)"
+        by blast
       with ImpL have "mset (\<Gamma>1@\<Gamma>2) \<Rightarrow> mset (F#\<Delta>) \<down> n" "mset (G # \<Gamma>1@\<Gamma>2) \<Rightarrow> mset \<Delta> \<down> n" by (simp add: add.commute)+
       from this[THEN Suc.IH] have "\<Gamma>1 @ \<Gamma>2 \<Rightarrow> F # \<Delta>" "G # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
       from FEA[OF this] have "F \<^bold>\<rightarrow> G # (\<Gamma>1 @ \<Gamma>2) @ (\<Gamma>1 @ \<Gamma>2) \<Rightarrow> \<Delta> @ \<Delta>" .
       hence "F \<^bold>\<rightarrow> G # (\<Gamma>1 @ \<Gamma>2) @ (F \<^bold>\<rightarrow> G # \<Gamma>1 @ \<Gamma>2) \<Rightarrow> \<Delta> @ \<Delta>" using AnfangTauschA VerduennungA by blast (* given the form of ZusammenziehungListeA, using this intermediate step is just easier. maybe a different from for ZusammenziehungListeA would be nice? *)
       hence "F \<^bold>\<rightarrow> G # (\<Gamma>1 @ \<Gamma>2) \<Rightarrow> \<Delta> @ \<Delta>" using ZusammenziehungListeA[where \<Gamma>="F \<^bold>\<rightarrow> G # (\<Gamma>1 @ \<Gamma>2)"] by simp
       thus ?thesis unfolding \<Gamma>[THEN conjunct1] by(intro AnfangTauschA; elim ZusammenziehungListeS)
     qed
   qed blast
 next
   have mset_Cons[simp]: "mset (A # S) = A, mset S" for A::"'a formula" and S by (simp add: add.commute)
   note mset.simps(2)[simp del]
   show "\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> mset \<Gamma> \<Rightarrow> mset \<Delta>" proof(induction rule: SCg.induct)
     (*sed -n '/^\([^\\]*\):/ {N;s/_\\\?//g; s/let.*$//; s/\n//; s/[\\:]//g; s/fix //; s/  / /g; s/^.*$/case (&) thus ?case sorry/; p;}' ${print_cases} *)
     case (Anfang \<DD>) thus ?case using extended_Ax SC_SCp_eq by force
   next
     case (FalschA) thus ?case using SCp.BotL by force
   next
     case (VerduennungA \<Gamma> \<Theta> \<DD>) thus ?case by (simp add: SC.weakenL)
   next
     case (VerduennungS \<Gamma> \<Theta> \<DD>) thus ?case by (simp add: SC.weakenR)
   next
     case (ZusammenziehungA \<DD> \<Gamma> \<Theta>) thus ?case using contractL by force
   next
     case (ZusammenziehungS \<Gamma> \<DD> \<Theta>) thus ?case using contract by force
   next
     case (VertauschungA \<Delta> \<DD> \<EE> \<Gamma> \<Theta>) thus ?case by fastforce
   next
     case (VertauschungS \<Gamma> \<Theta> \<EE> \<DD> \<Lambda>) thus ?case by fastforce
   next
     case (Schnitt \<Gamma> \<DD> \<Theta> \<Delta> \<Lambda>)
     hence "mset \<Gamma> \<Rightarrow> \<DD>,mset \<Theta>" "\<DD>,mset \<Delta> \<Rightarrow> mset \<Lambda>" using SC_SCp_eq by auto
     from cut_cf[OF this] show ?case unfolding SC_SCp_eq by simp
   next
     case (UES \<Gamma> \<AA> \<Theta> \<BB>) thus ?case using SCp.AndR by (simp add: SC_SCp_eq)
   next
     case (UEA1 \<AA> \<Gamma> \<Theta> \<BB>) 
     from \<open>mset (\<AA> # \<Gamma>) \<Rightarrow> mset \<Theta>\<close> have "\<AA>,\<BB>,mset \<Gamma> \<Rightarrow> mset \<Theta>" using SC.weakenL by auto
     thus ?case using SCp.AndL by force
   next
     case (UEA2 \<BB> \<Gamma> \<Theta> \<AA>)
     from \<open>mset (\<BB> # \<Gamma>) \<Rightarrow> mset \<Theta>\<close> have "\<AA>,\<BB>,mset \<Gamma> \<Rightarrow> mset \<Theta>" using SC.weakenL by auto
     thus ?case using SCp.AndL by force
   next
     case (OEA \<AA> \<Gamma> \<Theta> \<BB>) thus ?case unfolding SC_SCp_eq by (simp add: SCp.OrL)
   next
     case (OES1 \<Gamma> \<AA> \<Theta> \<BB>) thus ?case using SC.weakenR[where 'a='a] by(auto intro!: SCp.intros(3-))
   next
     case (OES2 \<Gamma> \<BB> \<Theta> \<AA>) thus ?case by (simp add: SC.weakenR SCp.OrR)
   next
     case (FES \<AA> \<Gamma> \<BB> \<Theta>) thus ?case using weakenR unfolding SC_SCp_eq by (simp add: SCp.ImpR)
   next
     case (FEA \<Gamma> \<AA> \<Theta> \<BB> \<Delta> \<Lambda>) 
     from \<open>mset \<Gamma> \<Rightarrow> mset (\<AA> # \<Theta>)\<close>[THEN weakenL_set, THEN weakenR_set, of "mset \<Delta>" "mset \<Lambda>"]
     have S: "mset (\<Gamma>@\<Delta>) \<Rightarrow> \<AA>,mset (\<Theta>@\<Lambda>)" unfolding mset_append mset_Cons by (simp add: add_ac) (* sledgehammer comes up with some funny proof using cut\<dots> *)
     from FEA obtain m where "mset (\<BB> # \<Delta>) \<Rightarrow> mset \<Lambda>" by blast
     hence "mset \<Gamma> + mset (\<BB> # \<Delta>) \<Rightarrow> mset \<Theta> + mset \<Lambda>" using weakenL_set weakenR_set by fast
     hence A: "\<BB>,mset (\<Gamma>@\<Delta>) \<Rightarrow> mset (\<Theta>@\<Lambda>)" by (simp add: add.left_commute)
     show ?case using S A SC_SCp_eq SCp.ImpL unfolding mset_Cons by blast
   next
     case (NES \<AA> \<Gamma> \<Theta>) thus ?case using SCp.NotR by(simp add: SC_SCp_eq)
   next
     case (NEA \<Gamma> \<AA> \<Theta>) thus ?case using SCp.NotL by(simp add: SC_SCp_eq)
   qed
 qed
 
 
 end
diff --git a/thys/Randomised_Social_Choice/Preference_Profiles.thy b/thys/Randomised_Social_Choice/Preference_Profiles.thy
--- a/thys/Randomised_Social_Choice/Preference_Profiles.thy
+++ b/thys/Randomised_Social_Choice/Preference_Profiles.thy
@@ -1,837 +1,839 @@
 (*  
   Title:    Preference_Profiles.thy
   Author:   Manuel Eberl, TU München
 
   Definition of (weak) preference profiles and functions for building
   and manipulating them
 *)
 
 section \<open>Preference Profiles\<close>
 
 theory Preference_Profiles
 imports
   Main 
   Order_Predicates 
   "HOL-Library.Multiset"
   "HOL-Library.Disjoint_Sets"
 begin
 
 text \<open>The type of preference profiles\<close>
 type_synonym ('agent, 'alt) pref_profile = "'agent \<Rightarrow> 'alt relation"
 
 locale preorder_family = 
   fixes dom :: "'a set" and carrier :: "'b set" and R :: "'a \<Rightarrow> 'b relation"
   assumes nonempty_dom: "dom \<noteq> {}"
   assumes in_dom [simp]: "i \<in> dom \<Longrightarrow> preorder_on carrier (R i)"
   assumes not_in_dom [simp]: "i \<notin> dom \<Longrightarrow> \<not>R i x y"
 begin
 
 lemma not_in_dom': "i \<notin> dom \<Longrightarrow> R i = (\<lambda>_ _. False)"
   by (simp add: fun_eq_iff)
 
 end
 
 
 locale pref_profile_wf =
   fixes agents :: "'agent set" and alts :: "'alt set" and R :: "('agent, 'alt) pref_profile"
   assumes nonempty_agents [simp]: "agents \<noteq> {}" and nonempty_alts [simp]: "alts \<noteq> {}"
   assumes prefs_wf [simp]: "i \<in> agents \<Longrightarrow> finite_total_preorder_on alts (R i)"
   assumes prefs_undefined [simp]: "i \<notin> agents \<Longrightarrow> \<not>R i x y"
 begin
 
 lemma finite_alts [simp]: "finite alts"
 proof -
   from nonempty_agents obtain i where "i \<in> agents" by blast
   then interpret finite_total_preorder_on alts "R i" by simp
   show ?thesis by (rule finite_carrier)
 qed
 
 lemma prefs_wf' [simp]:
   "i \<in> agents \<Longrightarrow> total_preorder_on alts (R i)" "i \<in> agents \<Longrightarrow> preorder_on alts (R i)"
   using prefs_wf[of i]
   by (simp_all add: finite_total_preorder_on_def total_preorder_on_def del: prefs_wf)
 
 lemma not_outside: 
   assumes "x \<preceq>[R i] y"
   shows   "i \<in> agents" "x \<in> alts" "y \<in> alts"
 proof -
   from assms show "i \<in> agents" by (cases "i \<in> agents") auto
   then interpret preorder_on alts "R i" by simp
   from assms show "x \<in> alts" "y \<in> alts" by (simp_all add: not_outside)
 qed
 
 sublocale preorder_family agents alts R
   by (intro preorder_family.intro) simp_all
 
 lemmas prefs_undefined' = not_in_dom'
 
 lemma wf_update:
   assumes "i \<in> agents" "total_preorder_on alts Ri'"
   shows   "pref_profile_wf agents alts (R(i := Ri'))"
 proof -
   interpret total_preorder_on alts Ri' by fact
   from finite_alts have "finite_total_preorder_on alts Ri'" by unfold_locales
   with assms show ?thesis
     by (auto intro!: pref_profile_wf.intro split: if_splits)
 qed
 
 lemma wf_permute_agents:
   assumes "\<sigma> permutes agents"
   shows   "pref_profile_wf agents alts (R \<circ> \<sigma>)"
   unfolding o_def using permutes_in_image[OF assms(1)]
   by (intro pref_profile_wf.intro prefs_wf) simp_all
 
 lemma (in -) pref_profile_eqI:
   assumes "pref_profile_wf agents alts R1" "pref_profile_wf agents alts R2"
   assumes "\<And>x. x \<in> agents \<Longrightarrow> R1 x = R2 x"
   shows   "R1 = R2"
 proof
   interpret R1: pref_profile_wf agents alts R1 by fact
   interpret R2: pref_profile_wf agents alts R2 by fact
   fix x show "R1 x = R2 x"
     by (cases "x \<in> agents"; intro ext) (simp_all add: assms(3)) 
 qed
 
 end
 
 
 text \<open>
   Permutes a preference profile w.r.t. alternatives in the way described in the paper.
   This is needed for the definition of neutrality.
 \<close>
 definition permute_profile where
   "permute_profile \<sigma> R = (\<lambda>i x y. R i (inv \<sigma> x) (inv \<sigma> y))"
   
 lemma permute_profile_map_relation:
   "permute_profile \<sigma> R = (\<lambda>i. map_relation (inv \<sigma>) (R i))"
   by (simp add: permute_profile_def map_relation_def)
 
 lemma permute_profile_compose [simp]:
   "permute_profile \<sigma> (R \<circ> \<pi>) = permute_profile \<sigma> R \<circ> \<pi>"
   by (auto simp: fun_eq_iff permute_profile_def o_def)
 
 lemma permute_profile_id [simp]: "permute_profile id R = R"
   by (simp add: permute_profile_def)
 
 lemma permute_profile_o:
   assumes "bij f" "bij g"
   shows   "permute_profile f (permute_profile g R) = permute_profile (f \<circ> g) R"
   using assms by (simp add: permute_profile_def o_inv_distrib)
 
 lemma (in pref_profile_wf) wf_permute_alts:
   assumes "\<sigma> permutes alts"
   shows   "pref_profile_wf agents alts (permute_profile \<sigma> R)"
 proof (rule pref_profile_wf.intro)
   fix i assume "i \<in> agents"
   with assms interpret R: finite_total_preorder_on alts "R i" by simp
     
   from assms have [simp]: "inv \<sigma> x \<in> alts \<longleftrightarrow> x \<in> alts" for x
     by (simp add: permutes_in_image permutes_inv)
 
   show "finite_total_preorder_on alts (permute_profile \<sigma> R i)"
   proof
     fix x y assume "permute_profile \<sigma> R i x y"
     thus "x \<in> alts" "y \<in> alts"
       using R.not_outside[of "inv \<sigma> x" "inv \<sigma> y"]
       by (auto simp: permute_profile_def)
   next
     fix x y z assume "permute_profile \<sigma> R i x y" "permute_profile \<sigma> R i y z"
     thus "permute_profile \<sigma> R i x z"
       using R.trans[of "inv \<sigma> x" "inv \<sigma> y" "inv \<sigma> z"] 
       by (simp_all add: permute_profile_def)
   qed (insert R.total R.refl R.finite_carrier, simp_all add: permute_profile_def)
 qed (insert assms, simp_all add: permute_profile_def pref_profile_wf_def)
 
 
 text \<open>
   This shows that the above definition is equivalent to that in the paper.  
 \<close>
 lemma permute_profile_iff [simp]:
   fixes R :: "('agent, 'alt) pref_profile"
   assumes "\<sigma> permutes alts" "x \<in> alts" "y \<in> alts"
   defines "R' \<equiv> permute_profile \<sigma> R"
   shows   "\<sigma> x \<preceq>[R' i] \<sigma> y \<longleftrightarrow> x \<preceq>[R i] y"
   using assms by (simp add: permute_profile_def permutes_inverses)
 
 
 subsection \<open>Pareto dominance\<close>
 
 definition Pareto :: "('agent \<Rightarrow> 'alt relation) \<Rightarrow> 'alt relation" where
   "x \<preceq>[Pareto(R)] y \<longleftrightarrow> (\<exists>j. x \<preceq>[R j] x) \<and> (\<forall>i. x \<preceq>[R i] x \<longrightarrow> x \<preceq>[R i] y)"
 
 text \<open>
   A Pareto loser is an alternative that is Pareto-dominated by some other alternative.
 \<close>
 definition pareto_losers :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt set" where
   "pareto_losers R = {x. \<exists>y. y \<succ>[Pareto(R)] x}"
 
 lemma pareto_losersI [intro?, simp]: "y \<succ>[Pareto(R)] x \<Longrightarrow> x \<in> pareto_losers R"
   by (auto simp: pareto_losers_def)
 
 context preorder_family
 begin
 
 lemma Pareto_iff:
   "x \<preceq>[Pareto(R)] y \<longleftrightarrow> (\<forall>i\<in>dom. x \<preceq>[R i] y)"
 proof
   assume A: "x \<preceq>[Pareto(R)] y"
   then obtain j where j: "x \<preceq>[R j] x" by (auto simp: Pareto_def)
   hence j': "j \<in> dom" by (cases "j \<in> dom") auto
   then interpret preorder_on carrier "R j" by simp
   from j have "x \<in> carrier" by (auto simp: carrier_eq)
   with A preorder_on.refl[OF in_dom]
     show "(\<forall>i\<in>dom. x \<preceq>[R i] y)" by (auto simp: Pareto_def)
 next
   assume A: "(\<forall>i\<in>dom. x \<preceq>[R i] y)"
   from nonempty_dom obtain j where j: "j \<in> dom" by blast
   then interpret preorder_on carrier "R j" by simp 
   from j A have "x \<preceq>[R j] y" by simp
   hence "x \<preceq>[R j] x" using not_outside refl by blast
   with A show "x \<preceq>[Pareto(R)] y" by (auto simp: Pareto_def)
 qed
 
 lemma Pareto_strict_iff: 
   "x \<prec>[Pareto(R)] y \<longleftrightarrow> (\<forall>i\<in>dom. x \<preceq>[R i] y) \<and> (\<exists>i\<in>dom. x \<prec>[R i] y)"
   by (auto simp: strongly_preferred_def Pareto_iff nonempty_dom)
 
 lemma Pareto_strictI:
   assumes "\<And>i. i \<in> dom \<Longrightarrow> x \<preceq>[R i] y" "i \<in> dom" "x \<prec>[R i] y"
   shows   "x \<prec>[Pareto(R)] y"
   using assms by (auto simp: Pareto_strict_iff)
 
 lemma Pareto_strictI':
   assumes "\<And>i. i \<in> dom \<Longrightarrow> x \<preceq>[R i] y" "i \<in> dom" "\<not>x \<succeq>[R i] y"
   shows   "x \<prec>[Pareto(R)] y"
 proof -
   from assms interpret preorder_on carrier "R i" by simp
   from assms have "x \<prec>[R i] y" by (simp add: strongly_preferred_def)
   with assms show ?thesis by (auto simp: Pareto_strict_iff )
 qed
 
 
 sublocale Pareto: preorder_on carrier "Pareto(R)"
 proof -
   have "preorder_on carrier (R i)" if "i \<in> dom" for i using that by simp_all
   note A = preorder_on.not_outside[OF this(1)] preorder_on.refl[OF this(1)]
            preorder_on.trans[OF this(1)]
   from nonempty_dom obtain i where i: "i \<in> dom" by blast
   show "preorder_on carrier (Pareto R)"
   proof
     fix x y assume "x \<preceq>[Pareto(R)] y"
     with A(1,2)[OF i] i show "x \<in> carrier" "y \<in> carrier" by (auto simp: Pareto_iff)
   qed (auto simp: Pareto_iff intro: A)
 qed
 
 lemma pareto_loser_in_alts: 
   assumes "x \<in> pareto_losers R"
   shows   "x \<in> carrier"
 proof -
   from assms obtain y i where "i \<in> dom" "x \<prec>[R i] y"
     by (auto simp: pareto_losers_def Pareto_strict_iff)
   then interpret preorder_on carrier "R i" by simp
   from \<open>x \<prec>[R i] y\<close> have "x \<preceq>[R i] y" by (simp add: strongly_preferred_def)
   thus "x \<in> carrier" using not_outside by simp
 qed
 
 lemma pareto_losersE:
   assumes "x \<in> pareto_losers R"
   obtains y where "y \<in> carrier" "y \<succ>[Pareto(R)] x"
 proof -
   from assms obtain y where y: "y \<succ>[Pareto(R)] x" unfolding pareto_losers_def by blast
   with Pareto.not_outside[of x y] have "y \<in> carrier" 
     by (simp add: strongly_preferred_def)
   with y show ?thesis using that by blast
 qed
 
 end
 
 
 subsection \<open>Preferred alternatives\<close>
 
 context pref_profile_wf
 begin
 
 lemma preferred_alts_subset_alts: "preferred_alts (R i) x \<subseteq> alts" (is ?A)
   and finite_preferred_alts [simp,intro!]: "finite (preferred_alts (R i) x)" (is ?B)
 proof -
   have "?A \<and> ?B"
   proof (cases "i \<in> agents")
     assume "i \<in> agents"
     then interpret total_preorder_on alts "R i" by simp
     have "preferred_alts (R i) x \<subseteq> alts" using not_outside
       by (auto simp: preferred_alts_def)
     thus ?thesis by (auto dest: finite_subset)
   qed (auto simp: preferred_alts_def)
   thus ?A ?B by blast+
 qed
 
 lemma preferred_alts_altdef: 
   "i \<in> agents \<Longrightarrow> preferred_alts (R i) x = {y\<in>alts. y \<succeq>[R i] x}"
   by (simp add: preorder_on.preferred_alts_altdef)  
 
 end
 
 
 subsection \<open>Favourite alternatives\<close>
 
 definition favorites :: "('agent, 'alt) pref_profile \<Rightarrow> 'agent \<Rightarrow> 'alt set" where
   "favorites R i = Max_wrt (R i)"
 
 definition favorite :: "('agent, 'alt) pref_profile \<Rightarrow> 'agent \<Rightarrow> 'alt" where
   "favorite R i = the_elem (favorites R i)"
 
 definition has_unique_favorites :: "('agent, 'alt) pref_profile \<Rightarrow> bool" where
   "has_unique_favorites R \<longleftrightarrow> (\<forall>i. favorites R i = {} \<or> is_singleton (favorites R i))"
 
 context pref_profile_wf
 begin
 
 lemma favorites_altdef:
   "favorites R i = Max_wrt_among (R i) alts"
 proof (cases "i \<in> agents")
   assume "i \<in> agents"
   then interpret total_preorder_on alts "R i" by simp
   show ?thesis 
     by (simp add: favorites_def Max_wrt_total_preorder Max_wrt_among_total_preorder)
 qed (simp_all add: favorites_def Max_wrt_def Max_wrt_among_def pref_profile_wf_def)
 
 lemma favorites_no_agent [simp]: "i \<notin> agents \<Longrightarrow> favorites R i = {}"
   by (auto simp: favorites_def Max_wrt_def Max_wrt_among_def)
 
 lemma favorites_altdef':
   "favorites R i = {x\<in>alts. \<forall>y\<in>alts. x \<succeq>[R i] y}"
 proof (cases "i \<in> agents")
   assume "i \<in> agents"
   then interpret finite_total_preorder_on alts "R i" by simp
   show ?thesis using Max_wrt_among_nonempty[of alts] Max_wrt_among_subset[of alts]
     by (auto simp: favorites_altdef Max_wrt_among_total_preorder)
 qed simp_all
 
 lemma favorites_subset_alts: "favorites R i \<subseteq> alts"
   by (auto simp: favorites_altdef')
 
 lemma finite_favorites [simp, intro]: "finite (favorites R i)"
   using favorites_subset_alts finite_alts  by (rule finite_subset)
 
 lemma favorites_nonempty: "i \<in> agents \<Longrightarrow> favorites R i \<noteq> {}"
 proof -
   assume "i \<in> agents"
   then interpret finite_total_preorder_on alts "R i" by simp
   show ?thesis unfolding favorites_def by (intro Max_wrt_nonempty) simp_all
 qed
 
 lemma favorites_permute: 
   assumes i: "i \<in> agents" and perm: "\<sigma> permutes alts"
   shows   "favorites (permute_profile \<sigma> R) i = \<sigma> ` favorites R i"
 proof -
   from i interpret finite_total_preorder_on alts "R i" by simp
   from perm show ?thesis
   unfolding favorites_def
     by (subst Max_wrt_map_relation_bij)
        (simp_all add: permute_profile_def map_relation_def permutes_bij)
 qed
 
 lemma has_unique_favorites_altdef:
   "has_unique_favorites R \<longleftrightarrow> (\<forall>i\<in>agents. is_singleton (favorites R i))"
 proof safe
   fix i assume "has_unique_favorites R" "i \<in> agents"
   thus "is_singleton (favorites R i)" using favorites_nonempty[of i]
     by (auto simp: has_unique_favorites_def)
 next
   assume "\<forall>i\<in>agents. is_singleton (favorites R i)"
   hence "is_singleton (favorites R i) \<or> favorites R i = {}" for i
     by (cases "i \<in> agents") (simp add: favorites_nonempty, simp add: favorites_altdef')
   thus "has_unique_favorites R" by (auto simp: has_unique_favorites_def)
 qed
 
 end
 
 
 locale pref_profile_unique_favorites = pref_profile_wf agents alts R
   for agents :: "'agent set" and alts :: "'alt set" and R +
   assumes unique_favorites': "has_unique_favorites R"
 begin
   
 lemma unique_favorites: "i \<in> agents \<Longrightarrow> favorites R i = {favorite R i}"
   using unique_favorites' 
   by (auto simp: favorite_def has_unique_favorites_altdef is_singleton_the_elem)
 
 lemma favorite_in_alts: "i \<in> agents \<Longrightarrow> favorite R i \<in> alts"
   using favorites_subset_alts[of i] by (simp add: unique_favorites)
 
 end
 
   
 
 subsection \<open>Anonymous profiles\<close>
 
 type_synonym ('agent, 'alt) apref_profile = "'alt set list multiset"
 
 definition anonymous_profile :: "('agent, 'alt) pref_profile \<Rightarrow> ('agent, 'alt) apref_profile" 
   where anonymous_profile_auxdef:
     "anonymous_profile R = image_mset (weak_ranking \<circ> R) (mset_set {i. R i \<noteq> (\<lambda>_ _. False)})"
 
 lemma (in pref_profile_wf) agents_eq:
   "agents = {i. R i \<noteq> (\<lambda>_ _. False)}"
 proof safe
   fix i assume i: "i \<in> agents" and Ri: "R i = (\<lambda>_ _. False)"
   from i interpret preorder_on alts "R i" by simp
   from carrier_eq Ri nonempty_alts show False by simp
 next
   fix i assume "R i \<noteq> (\<lambda>_ _. False)"
   thus "i \<in> agents" using prefs_undefined'[of i] by (cases "i \<in> agents") auto
 qed
 
 lemma (in pref_profile_wf) anonymous_profile_def:
   "anonymous_profile R = image_mset (weak_ranking \<circ> R) (mset_set agents)"
   by (simp only: agents_eq anonymous_profile_auxdef)
 
 lemma (in pref_profile_wf) anonymous_profile_permute:
   assumes "\<sigma> permutes alts"  "finite agents" 
   shows   "anonymous_profile (permute_profile \<sigma> R) = 
              image_mset (map ((`) \<sigma>)) (anonymous_profile R)"
 proof -
   from assms(1) interpret R': pref_profile_wf agents alts "permute_profile \<sigma> R"
     by (rule wf_permute_alts)
   have "anonymous_profile (permute_profile \<sigma> R) = 
           {#weak_ranking (map_relation (inv \<sigma>) (R x)). x \<in># mset_set agents#}"
     unfolding R'.anonymous_profile_def
     by (simp add:  multiset.map_comp permute_profile_map_relation o_def)
   also from assms have "\<dots> = {#map ((`) \<sigma>) (weak_ranking (R x)). x \<in># mset_set agents#}"
     by (intro image_mset_cong)
        (simp add: finite_total_preorder_on.weak_ranking_permute[of alts])
   also have "\<dots> = image_mset (map ((`) \<sigma>)) (anonymous_profile R)"
     by (simp add: anonymous_profile_def multiset.map_comp o_def)
   finally show ?thesis .
 qed
 
 lemma (in pref_profile_wf) anonymous_profile_update:
   assumes i:  "i \<in> agents" and fin [simp]: "finite agents" and "total_preorder_on alts Ri'"
   shows   "anonymous_profile (R(i := Ri')) =
              anonymous_profile R - {#weak_ranking (R i)#} + {#weak_ranking Ri'#}"
 proof -
   from assms interpret R': pref_profile_wf agents alts "R(i := Ri')"
     by (simp add: finite_total_preorder_on_iff wf_update)
   have "anonymous_profile (R(i := Ri')) = 
           {#weak_ranking (if x = i then Ri' else R x). x \<in># mset_set agents#}"
     by (simp add: R'.anonymous_profile_def o_def)
   also have "\<dots> = {#if x = i then weak_ranking Ri' else weak_ranking (R x). x \<in># mset_set agents#}"
     by (intro image_mset_cong) simp_all
   also have "\<dots> = {#weak_ranking Ri'. x \<in># mset_set {x \<in> agents. x = i}#} +
                     {#weak_ranking (R x). x \<in># mset_set {x \<in> agents. x \<noteq> i}#}"
     by (subst image_mset_If) ((subst filter_mset_mset_set, simp)+, rule refl)
   also from i have "{x \<in> agents. x = i} = {i}" by auto
   also have "{x \<in> agents. x \<noteq> i} = agents - {i}" by auto
   also have "{#weak_ranking Ri'. x \<in># mset_set {i}#} = {#weak_ranking Ri'#}" by simp
   also from i have "mset_set (agents - {i}) = mset_set agents - {#i#}"
     by (simp add: mset_set_Diff)
   also from i 
     have "{#weak_ranking (R x). x \<in># \<dots>#} =
             {#weak_ranking (R x). x \<in># mset_set agents#} - {#weak_ranking (R i)#}"
       by (subst image_mset_Diff) (simp_all add: in_multiset_in_set mset_subset_eq_single)
   also have "{#weak_ranking Ri'#} + \<dots> = 
                anonymous_profile R - {#weak_ranking (R i)#} + {#weak_ranking Ri'#}"
     by (simp add: anonymous_profile_def add_ac o_def)
   finally show ?thesis .
 qed
 
 
 subsection \<open>Preference profiles from lists\<close>
 
 definition prefs_from_table :: "('agent \<times> 'alt set list) list \<Rightarrow> ('agent, 'alt) pref_profile" where
   "prefs_from_table xss = (\<lambda>i. case_option (\<lambda>_ _. False) of_weak_ranking (map_of xss i))"
 
 definition prefs_from_table_wf where
   "prefs_from_table_wf agents alts xss \<longleftrightarrow> agents \<noteq> {} \<and> alts \<noteq> {} \<and> distinct (map fst xss) \<and> 
        set (map fst xss) = agents \<and> (\<forall>xs\<in>set (map snd xss). \<Union>(set xs) = alts \<and> 
        is_finite_weak_ranking xs)"
 
 lemma prefs_from_table_wfI:
   assumes "agents \<noteq> {}" "alts \<noteq> {}" "distinct (map fst xss)"
   assumes "set (map fst xss) = agents"
   assumes "\<And>xs. xs \<in> set (map snd xss) \<Longrightarrow> \<Union>(set xs) = alts"
   assumes "\<And>xs. xs \<in> set (map snd xss) \<Longrightarrow> is_finite_weak_ranking xs"
   shows   "prefs_from_table_wf agents alts xss"
   using assms unfolding prefs_from_table_wf_def by auto
 
 lemma prefs_from_table_wfD:
   assumes "prefs_from_table_wf agents alts xss"
   shows "agents \<noteq> {}" "alts \<noteq> {}" "distinct (map fst xss)"
     and "set (map fst xss) = agents"
     and "\<And>xs. xs \<in> set (map snd xss) \<Longrightarrow> \<Union>(set xs) = alts"
     and "\<And>xs. xs \<in> set (map snd xss) \<Longrightarrow> is_finite_weak_ranking xs"
   using assms unfolding prefs_from_table_wf_def by auto
        
 lemma pref_profile_from_tableI: 
   "prefs_from_table_wf agents alts xss \<Longrightarrow> pref_profile_wf agents alts (prefs_from_table xss)"
 proof (intro pref_profile_wf.intro)
   assume wf: "prefs_from_table_wf agents alts xss"
   fix i assume i: "i \<in> agents"
   with wf have "i \<in> set (map fst xss)" by (simp add: prefs_from_table_wf_def)
   then obtain xs where xs: "xs \<in> set (map snd xss)" "prefs_from_table xss i = of_weak_ranking xs"
     by (cases "map_of xss i")
        (fastforce dest: map_of_SomeD simp: prefs_from_table_def map_of_eq_None_iff)+
   with wf show "finite_total_preorder_on alts (prefs_from_table xss i)"
     by (auto simp: prefs_from_table_wf_def intro!: finite_total_preorder_of_weak_ranking)
 next
   assume wf: "prefs_from_table_wf agents alts xss"
   fix i x y assume i: "i \<notin> agents"
   with wf have "i \<notin> set (map fst xss)" by (simp add: prefs_from_table_wf_def)
   hence "map_of xss i = None" by (simp add: map_of_eq_None_iff)
   thus "\<not>prefs_from_table xss i x y" by (simp add: prefs_from_table_def)
 qed (simp_all add: prefs_from_table_wf_def)
 
 lemma prefs_from_table_eqI:
   assumes "distinct (map fst xs)" "distinct (map fst ys)" "set xs = set ys"
   shows   "prefs_from_table xs = prefs_from_table ys"
 proof -
   from assms have "map_of xs = map_of ys" by (subst map_of_inject_set) simp_all
   thus ?thesis by (simp add: prefs_from_table_def)
 qed
 
 lemma prefs_from_table_undef:
   assumes "prefs_from_table_wf agents alts xss" "i \<notin> agents"
   shows   "prefs_from_table xss i = (\<lambda>_ _. False)"
 proof -
   from assms have "i \<notin> fst ` set xss"
     by (simp add: prefs_from_table_wf_def)
   hence "map_of xss i = None" by (simp add: map_of_eq_None_iff)
   thus ?thesis by (simp add: prefs_from_table_def)
 qed
 
 lemma prefs_from_table_map_of:
   assumes "prefs_from_table_wf agents alts xss" "i \<in> agents"
   shows   "prefs_from_table xss i = of_weak_ranking (the (map_of xss i))"
   using assms 
   by (auto simp: prefs_from_table_def map_of_eq_None_iff prefs_from_table_wf_def
            split: option.splits)
 
 lemma prefs_from_table_update:
   fixes x xs
   assumes "i \<in> set (map fst xs)"
   defines "xs' \<equiv> map (\<lambda>(j,y). if j = i then (j, x) else (j, y)) xs"
   shows   "(prefs_from_table xs)(i := of_weak_ranking x) =
              prefs_from_table xs'" (is "?lhs = ?rhs")
 proof
   have xs': "set (map fst xs') = set (map fst xs)" by (force simp: xs'_def)  
   fix k
   consider "k = i" | "k \<notin> set (map fst xs)" | "k \<noteq> i" "k \<in> set (map fst xs)" by blast
   thus "?lhs k = ?rhs k"
   proof cases 
     assume k: "k = i"
     moreover from k have "y = x" if "(i, y) \<in> set xs'" for y
       using that by (auto simp: xs'_def split: if_splits)
     ultimately show ?thesis using assms(1) k xs'
       by (auto simp add: prefs_from_table_def map_of_eq_None_iff 
                dest!: map_of_SomeD split: option.splits)
   next
     assume k: "k \<notin> set (map fst xs)"
     with assms(1) have k': "k \<noteq> i" by auto
     with k xs' have "map_of xs k = None" "map_of xs' k = None"
       by (simp_all add: map_of_eq_None_iff)
     thus ?thesis by (simp add: prefs_from_table_def k')
   next
     assume k: "k \<noteq> i" "k \<in> set (map fst xs)"
     with k(1) have "map_of xs k = map_of xs' k" unfolding xs'_def
       by (induction xs) fastforce+
     with k show ?thesis by (simp add: prefs_from_table_def)
   qed
 qed
 
 lemma prefs_from_table_swap:
   "x \<noteq> y \<Longrightarrow> prefs_from_table ((x,x')#(y,y')#xs) = prefs_from_table ((y,y')#(x,x')#xs)"
   by (intro ext) (auto simp: prefs_from_table_def)
 
 lemma permute_prefs_from_table:
   assumes "\<sigma> permutes fst ` set xs"
   shows   "prefs_from_table xs \<circ> \<sigma> = prefs_from_table (map (\<lambda>(x,y). (inv \<sigma> x, y)) xs)"
 proof
   fix i
   have "(prefs_from_table xs \<circ> \<sigma>) i = 
           (case map_of xs (\<sigma> i) of
              None \<Rightarrow> \<lambda>_ _. False
            | Some x \<Rightarrow> of_weak_ranking x)"
     by (simp add: prefs_from_table_def o_def)
   also have "map_of xs (\<sigma> i) = map_of (map (\<lambda>(x,y). (inv \<sigma> x, y)) xs) i"
     using map_of_permute[OF assms] by (simp add: o_def fun_eq_iff)
   finally show "(prefs_from_table xs \<circ> \<sigma>) i = prefs_from_table (map (\<lambda>(x,y). (inv \<sigma> x, y)) xs) i"
     by (simp only: prefs_from_table_def)
 qed
 
 lemma permute_profile_from_table:
   assumes wf: "prefs_from_table_wf agents alts xss"
   assumes perm: "\<sigma> permutes alts"
   shows   "permute_profile \<sigma> (prefs_from_table xss) = 
              prefs_from_table (map (\<lambda>(x,y). (x, map ((`) \<sigma>) y)) xss)" (is "?f = ?g")
 proof
   fix i
   have wf': "prefs_from_table_wf agents alts (map (\<lambda>(x, y). (x, map ((`) \<sigma>) y)) xss)"
   proof (intro prefs_from_table_wfI, goal_cases)
     case (5 xs)
     then obtain y where "y \<in> set xss" "xs = map ((`) \<sigma>) (snd y)"
       by (auto simp add: o_def case_prod_unfold)
     with assms show ?case
       by (simp add: image_Union [symmetric] prefs_from_table_wf_def permutes_image o_def case_prod_unfold)
   next
     case (6 xs)
     then obtain y where "y \<in> set xss" "xs = map ((`) \<sigma>) (snd y)"
       by (auto simp add: o_def case_prod_unfold)
     with assms show ?case
       by (auto simp: is_finite_weak_ranking_def is_weak_ranking_iff prefs_from_table_wf_def
             distinct_map permutes_inj_on inj_on_image intro!: disjoint_image)
   qed (insert assms, simp_all add: image_Union [symmetric] prefs_from_table_wf_def permutes_image o_def case_prod_unfold)
   show "?f i = ?g i"
   proof (cases "i \<in> agents")
     assume "i \<notin> agents"
     with assms wf' show ?thesis
       by (simp add: permute_profile_def prefs_from_table_undef)
   next
     assume i: "i \<in> agents"
     define xs where "xs = the (map_of xss i)"
     from i wf have xs: "map_of xss i = Some xs"
       by (cases "map_of xss i") (auto simp: prefs_from_table_wf_def xs_def)
     have xs_in_xss: "xs \<in> snd ` set xss"
       using xs by (force dest!: map_of_SomeD)
     with wf have set_xs: "\<Union>(set xs) = alts"
       by (simp add: prefs_from_table_wfD)
 
     from i have "prefs_from_table (map (\<lambda>(x,y). (x, map ((`) \<sigma>) y)) xss) i =
                    of_weak_ranking (the (map_of (map (\<lambda>(x,y). (x, map ((`) \<sigma>) y)) xss) i))"
       using wf' by (intro prefs_from_table_map_of) simp_all
     also have "\<dots> = of_weak_ranking (map ((`) \<sigma>) xs)"
       by (subst map_of_map) (simp add: xs)
     also have "\<dots> = (\<lambda>a b. of_weak_ranking xs (inv \<sigma> a) (inv \<sigma> b))"
       by (intro ext) (simp add: of_weak_ranking_permute map_relation_def set_xs perm)
     also have "\<dots> = permute_profile \<sigma> (prefs_from_table xss) i"
       by (simp add: prefs_from_table_def xs permute_profile_def)
     finally show ?thesis ..
   qed
 qed
 
 
 subsection \<open>Automatic evaluation of preference profiles\<close>
 
 lemma eval_prefs_from_table [simp]:
   "prefs_from_table []i = (\<lambda>_ _. False)"
   "prefs_from_table ((i, y) # xs) i = of_weak_ranking y"
   "i \<noteq> j \<Longrightarrow> prefs_from_table ((j, y) # xs) i = prefs_from_table xs i"
   by (simp_all add: prefs_from_table_def)
 
 lemma eval_of_weak_ranking [simp]:
   "a \<notin> \<Union>(set xs) \<Longrightarrow> \<not>of_weak_ranking xs a b"
   "b \<in> x \<Longrightarrow> a \<in> \<Union>(set (x#xs)) \<Longrightarrow> of_weak_ranking (x # xs) a b"
   "b \<notin> x \<Longrightarrow> of_weak_ranking (x # xs) a b \<longleftrightarrow> of_weak_ranking xs a b"
   by (induction xs) (simp_all add: of_weak_ranking_Cons)
 
 lemma prefs_from_table_cong [cong]:
   assumes "prefs_from_table xs = prefs_from_table ys"
   shows   "prefs_from_table (x#xs) = prefs_from_table (x#ys)"
 proof
   fix i
   show "prefs_from_table (x # xs) i = prefs_from_table (x # ys) i"
     using assms by (cases x, cases "i = fst x") simp_all
 qed
 
 definition of_weak_ranking_Collect_ge where
   "of_weak_ranking_Collect_ge xs x = {y. of_weak_ranking xs y x}"
 
 lemma eval_Collect_of_weak_ranking:
   "Collect (of_weak_ranking xs x) = of_weak_ranking_Collect_ge (rev xs) x"
   by (simp add: of_weak_ranking_Collect_ge_def)
 
 lemma of_weak_ranking_Collect_ge_empty [simp]:
   "of_weak_ranking_Collect_ge [] x = {}"
   by (simp add: of_weak_ranking_Collect_ge_def)
 
 lemma of_weak_ranking_Collect_ge_Cons [simp]:
   "y \<in> x \<Longrightarrow> of_weak_ranking_Collect_ge (x#xs) y = \<Union>(set (x#xs))"
   "y \<notin> x \<Longrightarrow> of_weak_ranking_Collect_ge (x#xs) y = of_weak_ranking_Collect_ge xs y"
   by (auto simp: of_weak_ranking_Cons of_weak_ranking_Collect_ge_def)
 
 lemma of_weak_ranking_Collect_ge_Cons':
   "of_weak_ranking_Collect_ge (x#xs) = (\<lambda>y.
      (if y \<in> x then \<Union>(set (x#xs)) else of_weak_ranking_Collect_ge xs y))"
   by (auto simp: of_weak_ranking_Cons of_weak_ranking_Collect_ge_def fun_eq_iff)
 
 lemma anonymise_prefs_from_table:
   assumes "prefs_from_table_wf agents alts xs"
   shows   "anonymous_profile (prefs_from_table xs) = mset (map snd xs)"
 proof -
   from assms interpret pref_profile_wf agents alts "prefs_from_table xs"
     by (simp add: pref_profile_from_tableI) 
   from assms have agents: "agents = fst ` set xs"
     by (simp add: prefs_from_table_wf_def)
   hence [simp]: "finite agents" by auto
   have "anonymous_profile (prefs_from_table xs) = 
           {#weak_ranking (prefs_from_table xs x). x \<in># mset_set agents#}"
     by (simp add: o_def anonymous_profile_def)
   also from assms have "\<dots> = {#the (map_of xs i). i \<in># mset_set agents#}"
   proof (intro image_mset_cong)
     fix i assume i: "i \<in># mset_set agents"
     from i assms 
       have "weak_ranking (prefs_from_table xs i) = 
               weak_ranking (of_weak_ranking (the (map_of xs i))) "
       by (simp add: prefs_from_table_map_of)
     also from assms i have "\<dots> = the (map_of xs i)"
       by (intro weak_ranking_of_weak_ranking)
          (auto simp: prefs_from_table_wf_def)
     finally show "weak_ranking (prefs_from_table xs i) = the (map_of xs i)" .
   qed
   also from agents have "mset_set agents = mset_set (set (map fst xs))" by simp
   also from assms have "\<dots> = mset (map fst xs)"
     by (intro mset_set_set) (simp_all add: prefs_from_table_wf_def)
   also from assms have "{#the (map_of xs i). i \<in># mset (map fst xs)#} = mset (map snd xs)"
     by (intro image_mset_map_of) (simp_all add: prefs_from_table_wf_def)
   finally show ?thesis .
 qed
 
 lemma prefs_from_table_agent_permutation:
   assumes wf: "prefs_from_table_wf agents alts xs" "prefs_from_table_wf agents alts ys"
   assumes mset_eq: "mset (map snd xs) = mset (map snd ys)"
   obtains \<pi> where "\<pi> permutes agents" "prefs_from_table xs \<circ> \<pi> = prefs_from_table ys"
 proof -
   from wf(1) have agents: "agents = set (map fst xs)"
     by (simp_all add: prefs_from_table_wf_def)
   from wf(2) have agents': "agents = set (map fst ys)"
     by (simp_all add: prefs_from_table_wf_def)
   from agents agents' wf(1) wf(2) have "mset (map fst xs) = mset (map fst ys)"
     by (subst set_eq_iff_mset_eq_distinct [symmetric]) (simp_all add: prefs_from_table_wfD)
   hence same_length: "length xs = length ys" by (auto dest: mset_eq_length simp del: mset_map)
 
   from \<open>mset (map fst xs) = mset (map fst ys)\<close>
     obtain g where g: "g permutes {..<length ys}" "permute_list g (map fst ys) = map fst xs"
     by (auto elim: mset_eq_permutation simp: same_length simp del: mset_map)
 
   from mset_eq g 
     have "mset (map snd ys) = mset (permute_list g (map snd ys))" by simp
   with mset_eq obtain f 
     where f: "f permutes {..<length xs}" 
              "permute_list f (permute_list g (map snd ys)) = map snd xs"
     by (auto elim: mset_eq_permutation simp: same_length simp del: mset_map)
   from permutes_in_image[OF f(1)]
   have [simp]: "f x < length xs \<longleftrightarrow> x < length xs" 
                  "f x < length ys \<longleftrightarrow> x < length ys" for x by (simp_all add: same_length)
 
   define idx unidx where "idx = index (map fst xs)" and "unidx i = map fst xs ! i" for i
   from wf(1) have "bij_betw idx agents {0..<length xs}" unfolding idx_def
     by (intro bij_betw_index) (simp_all add: prefs_from_table_wf_def)
   hence bij_betw_idx: "bij_betw idx agents {..<length xs}" by (simp add: atLeast0LessThan)
   have [simp]: "idx x < length xs" if "x \<in> agents" for x
     using that by (simp add: idx_def agents)
   have [simp]: "unidx i \<in> agents" if "i < length xs" for i
     using that by (simp add: agents unidx_def)
 
   have unidx_idx: "unidx (idx x) = x" if x: "x \<in> agents" for x
     using x unfolding idx_def unidx_def using nth_index[of x "map fst xs"]
     by (simp add: agents set_map [symmetric] nth_map [symmetric] del: set_map)
   have idx_unidx: "idx (unidx i) = i" if i: "i < length xs" for i
     unfolding idx_def unidx_def using wf(1) index_nth_id[of "map fst xs" i] i
     by (simp add: prefs_from_table_wfD(3))
  
   define \<pi> where "\<pi> x = (if x \<in> agents then (unidx \<circ> f \<circ> idx) x else x)" for x
   define \<pi>' where "\<pi>' x = (if x \<in> agents then (unidx \<circ> inv f \<circ> idx) x else x)" for x
   have "bij_betw (unidx \<circ> f \<circ> idx) agents agents" (is "?P") unfolding unidx_def
     by (rule bij_betw_trans bij_betw_idx permutes_imp_bij f g bij_betw_nth)+
        (insert wf(1) g, simp_all add: prefs_from_table_wf_def same_length)
   also have "?P \<longleftrightarrow> bij_betw \<pi> agents agents"
     by (intro bij_betw_cong) (simp add: \<pi>_def)
   finally have perm: "\<pi> permutes agents"
     by (intro bij_imp_permutes) (simp_all add: \<pi>_def)
 
   define h where "h = g \<circ> f"
   from f g have h: "h permutes {..<length ys}" unfolding h_def
     by (intro permutes_compose) (simp_all add: same_length)
 
   have inv_\<pi>: "inv \<pi> = \<pi>'"
   proof (rule permutes_invI[OF perm])
     fix x assume "x \<in> agents"
     with f(1) show "\<pi>' (\<pi> x) = x"
       by (simp add: \<pi>_def \<pi>'_def idx_unidx unidx_idx inv_f_f permutes_inj)
   qed (simp add: \<pi>_def \<pi>'_def)
   with perm have inv_\<pi>': "inv \<pi>' = \<pi>" by (auto simp: inv_inv_eq permutes_bij)
 
   from wf h have "prefs_from_table ys = prefs_from_table (permute_list h ys)"
     by (intro prefs_from_table_eqI)
        (simp_all add: prefs_from_table_wfD permute_list_map [symmetric])
   also have "permute_list h ys = permute_list h (zip (map fst ys) (map snd ys))"
     by (simp add: zip_map_fst_snd)
   also from same_length f g
     have "permute_list h (zip (map fst ys) (map snd ys)) = 
             zip (permute_list f (map fst xs)) (map snd xs)"
     by (subst permute_list_zip[OF h]) (simp_all add: h_def permute_list_compose)
   also {
     fix i assume i: "i < length xs"
     from i have "permute_list f (map fst xs) ! i = unidx (f i)"
       using permutes_in_image[OF f(1)] f(1) 
       by (subst permute_list_nth) (simp_all add: same_length unidx_def)
     also from i have "\<dots> = \<pi> (unidx i)" by (simp add: \<pi>_def idx_unidx)
     also from i have "\<dots> = map \<pi> (map fst xs) ! i" by (simp add: unidx_def)
     finally have "permute_list f (map fst xs) ! i = map \<pi> (map fst xs) ! i" .
   }
   hence "permute_list f (map fst xs) = map \<pi> (map fst xs)"
     by (intro nth_equalityI) simp_all
   also have "zip (map \<pi> (map fst xs)) (map snd xs) = map (\<lambda>(x,y). (inv \<pi>' x, y)) xs"
     by (induction xs) (simp_all add: case_prod_unfold inv_\<pi>')
   also from permutes_inv[OF perm] inv_\<pi> have "prefs_from_table \<dots> = prefs_from_table xs \<circ> \<pi>'"
     by (intro permute_prefs_from_table [symmetric]) (simp_all add: agents)
   finally have "prefs_from_table xs \<circ> \<pi>' = prefs_from_table ys" ..
   with that[of \<pi>'] permutes_inv[OF perm] inv_\<pi> show ?thesis by auto
 qed
 
 lemma permute_list_distinct:
   assumes "f ` {..<length xs} \<subseteq> {..<length xs}" "distinct xs"
   shows   "permute_list f xs = map (\<lambda>x. xs ! f (index xs x)) xs"
   using assms by (intro nth_equalityI) (auto simp: index_nth_id permute_list_def)
 
 lemma image_mset_eq_permutation:
   assumes "{#f x. x \<in># mset_set A#} = {#g x. x \<in># mset_set A#}" "finite A"
   obtains \<pi> where "\<pi> permutes A" "\<And>x. x \<in> A \<Longrightarrow> g (\<pi> x) = f x"
 proof -
   from assms(2) obtain xs where xs: "A = set xs" "distinct xs"
     using finite_distinct_list by blast
   with assms have "mset (map f xs) = mset (map g xs)" 
     by (simp add: mset_set_set)
   from mset_eq_permutation[OF this] obtain \<pi> where
     \<pi>: "\<pi> permutes {0..<length xs}" "permute_list \<pi> (map g xs) = map f xs"
     by (auto simp: atLeast0LessThan)
   define \<pi>' where "\<pi>' x = (if x \<in> A then ((!) xs \<circ> \<pi> \<circ> index xs) x else x)" for x
   have "bij_betw ((!) xs \<circ> \<pi> \<circ> index xs) A A" (is "?P")
     by (rule bij_betw_trans bij_betw_index xs refl permutes_imp_bij \<pi> bij_betw_nth)+
        (simp_all add: atLeast0LessThan xs)
   also have "?P \<longleftrightarrow> bij_betw \<pi>' A A"
     by (intro bij_betw_cong) (simp_all add: \<pi>'_def)
   finally have "\<pi>' permutes A"
     by (rule bij_imp_permutes) (simp_all add: \<pi>'_def)
   moreover from \<pi> xs(1)[symmetric] xs(2) have "g (\<pi>' x) = f x" if "x \<in> A" for x
     by (simp add: permute_list_map permute_list_distinct
           permutes_image \<pi>'_def that atLeast0LessThan)
   ultimately show ?thesis by (rule that)
 qed
 
 lemma anonymous_profile_agent_permutation:
   assumes eq:  "anonymous_profile R1 = anonymous_profile R2"
   assumes wf:  "pref_profile_wf agents alts R1" "pref_profile_wf agents alts R2"
   assumes fin: "finite agents"
   obtains \<pi> where "\<pi> permutes agents" "R2 \<circ> \<pi> = R1"
 proof -
   interpret R1: pref_profile_wf agents alts R1 by fact
   interpret R2: pref_profile_wf agents alts R2 by fact
 
   from eq have "{#weak_ranking (R1 x). x \<in># mset_set agents#} = 
                   {#weak_ranking (R2 x). x \<in># mset_set agents#}"
     by (simp add: R1.anonymous_profile_def R2.anonymous_profile_def o_def)
-  from image_mset_eq_permutation[OF this fin] guess \<pi> . note \<pi> = this
+  from image_mset_eq_permutation[OF this fin] obtain \<pi>
+    where \<pi>: "\<pi> permutes agents"
+      "\<And>x. x \<in> agents \<Longrightarrow> weak_ranking (R2 (\<pi> x)) = weak_ranking (R1 x)" by auto
   from \<pi> have wf': "pref_profile_wf agents alts (R2 \<circ> \<pi>)"
     by (intro R2.wf_permute_agents)
   then interpret R2': pref_profile_wf agents alts "R2 \<circ> \<pi>" .
   have "R2 \<circ> \<pi> = R1"
   proof (intro pref_profile_eqI[OF wf' wf(1)])
     fix x assume x: "x \<in> agents"
     with \<pi> have "weak_ranking ((R2 o \<pi>) x) = weak_ranking (R1 x)" by simp
     with wf' wf(1) x show "(R2 \<circ> \<pi>) x = R1 x"
       by (intro weak_ranking_eqD[of alts] R2'.prefs_wf) simp_all
   qed
   from \<pi>(1) and this show ?thesis by (rule that)
 qed
 
 end
diff --git a/thys/Randomised_Social_Choice/SDS_Lowering.thy b/thys/Randomised_Social_Choice/SDS_Lowering.thy
--- a/thys/Randomised_Social_Choice/SDS_Lowering.thy
+++ b/thys/Randomised_Social_Choice/SDS_Lowering.thy
@@ -1,409 +1,410 @@
 (*  
   Title:    SDS_Lowering.thy
   Author:   Manuel Eberl, TU München
 
   Allows to lower an SDS, i.e. take an existing ex-post efficient SDS
   and construct from it an SDS for fewer agents and alternatives. (which is
   also ex-post efficient)
     The standard properties (anonymity, neutrality, SD efficiency, strategyproofness)
   are preserved by this construction.
 *)
 
 section \<open>Lowering Social Decision Schemes\<close>
 
 theory SDS_Lowering
 imports Social_Decision_Schemes
 begin
 
 definition lift_pref_profile :: 
     "'agent set \<Rightarrow> 'alt set \<Rightarrow> 'agent set \<Rightarrow> 'alt set \<Rightarrow>
        ('agent, 'alt) pref_profile \<Rightarrow> ('agent, 'alt) pref_profile" where
   "lift_pref_profile agents alts agents' alts' R = (\<lambda>i x y. 
      x \<in> alts' \<and> y \<in> alts' \<and> i \<in> agents' \<and>
      (x = y \<or> x \<notin> alts \<or> i \<notin> agents \<or> (y \<in> alts \<and> R i x y)))"
 
 lemma lift_pref_profile_wf:
   assumes "pref_profile_wf agents alts R"
   assumes "agents \<subseteq> agents'" "alts \<subseteq> alts'" "finite alts'"
   defines "R' \<equiv> lift_pref_profile agents alts agents' alts' R"
   shows   "pref_profile_wf agents' alts' R'"
 proof -
   from assms interpret R: pref_profile_wf agents alts by simp
   have "finite_total_preorder_on alts' (R' i)" 
     if i: "i \<in> agents'" for i
   proof (cases "i \<in> agents")
     case True
     then interpret finite_total_preorder_on alts "R i" by simp
     from True assms show ?thesis
       by unfold_locales (auto simp: lift_pref_profile_def dest: total intro: trans)
   next 
     case False
     with assms i show ?thesis
       by unfold_locales (simp_all add: lift_pref_profile_def)
   qed
   moreover have "R' i = (\<lambda>_ _. False)" if "i \<notin> agents'" for i
     unfolding lift_pref_profile_def R'_def using that by simp
   ultimately show ?thesis unfolding pref_profile_wf_def using assms by auto
 qed
 
 lemma lift_pref_profile_permute_agents:
   assumes "\<pi> permutes agents" "agents \<subseteq> agents'"
   shows   "lift_pref_profile agents alts agents' alts' (R \<circ> \<pi>) = 
              lift_pref_profile agents alts agents' alts' R \<circ> \<pi>"
   using assms permutes_subset[OF assms]
   by (auto simp add: lift_pref_profile_def o_def permutes_in_image)
 
 lemma lift_pref_profile_permute_alts:
   assumes "\<sigma> permutes alts" "alts \<subseteq> alts'"
   shows   "lift_pref_profile agents alts agents' alts' (permute_profile \<sigma> R) = 
              permute_profile \<sigma> (lift_pref_profile agents alts agents' alts' R)"
 proof -
   from assms have inv: "inv \<sigma> permutes alts" by (intro permutes_inv)
   from this assms(2) have "inv \<sigma> permutes alts'" by (rule permutes_subset)
   with inv show ?thesis using assms permutes_inj[OF \<open>inv \<sigma> permutes alts\<close>]
     by (fastforce simp add: lift_pref_profile_def permutes_in_image
           permute_profile_def fun_eq_iff dest: injD)
 qed
 
 
 lemma lotteries_on_subset: "A \<subseteq> B \<Longrightarrow> p \<in> lotteries_on A \<Longrightarrow> p \<in> lotteries_on B"
   unfolding lotteries_on_def by blast
 
 lemma lottery_prob_carrier: "p \<in> lotteries_on A \<Longrightarrow> measure_pmf.prob p A = 1"
   by (auto simp: measure_pmf.prob_eq_1 lotteries_on_def AE_measure_pmf_iff)
 
 context
   fixes agents alts R agents' alts' R'
   assumes R_wf: "pref_profile_wf agents alts R"
   assumes election: "agents \<subseteq> agents'" "alts \<subseteq> alts'" "alts \<noteq> {}" "agents \<noteq> {}" "finite alts'"
   defines "R' \<equiv> lift_pref_profile agents alts agents' alts' R"
 begin
 
 interpretation R: pref_profile_wf agents alts R by fact
 interpretation R': pref_profile_wf agents' alts' R' 
   using election R_wf by (simp add: R'_def lift_pref_profile_wf)
 
 lemma lift_pref_profile_strict_iff:
   "x \<prec>[lift_pref_profile agents alts agents' alts' R i] y \<longleftrightarrow>
      i \<in> agents \<and> ((y \<in> alts \<and> x \<in> alts' - alts) \<or> x \<prec>[R i] y)"
 proof (cases "i \<in> agents")
   case True
   then interpret total_preorder_on alts "R i" by simp
   show ?thesis using not_outside election
     by (auto simp: lift_pref_profile_def strongly_preferred_def)
 qed (simp_all add: lift_pref_profile_def strongly_preferred_def)
 
 lemma preferred_alts_lift_pref_profile: 
   assumes i: "i \<in> agents'" and x: "x \<in> alts'"
   shows   "preferred_alts (R' i) x = 
              (if i \<in> agents \<and> x \<in> alts then preferred_alts (R i) x else alts')"
 proof (cases "i \<in> agents")
   assume i: "i \<in> agents"
   then interpret Ri: total_preorder_on alts "R i" by simp
   show ?thesis
   using i x election Ri.not_outside
     by (auto simp: preferred_alts_def R'_def lift_pref_profile_def Ri.refl)
 qed (auto simp: preferred_alts_def R'_def lift_pref_profile_def i x)
 
 lemma lift_pref_profile_Pareto_iff:
   "x \<preceq>[Pareto(R')] y \<longleftrightarrow> x \<in> alts' \<and> y \<in> alts' \<and> (x \<notin> alts \<or> x \<preceq>[Pareto(R)] y)"
 proof -
   from R.nonempty_agents obtain i where i: "i \<in> agents" by blast
   then interpret Ri: finite_total_preorder_on alts "R i" by simp
   show ?thesis unfolding R'.Pareto_iff R.Pareto_iff unfolding R'_def lift_pref_profile_def
     using election i by (auto simp: preorder_on.refl[OF R.in_dom] 
       simp del: R.nonempty_alts R.nonempty_agents  intro: Ri.not_outside)
 qed
 
 lemma lift_pref_profile_Pareto_strict_iff:
   "x \<prec>[Pareto(R')] y \<longleftrightarrow> x \<in> alts' \<and> y \<in> alts' \<and> (x \<notin> alts \<and> y \<in> alts \<or> x \<prec>[Pareto(R)] y)"
   by (auto simp: strongly_preferred_def lift_pref_profile_Pareto_iff R.Pareto.not_outside)
 
 lemma pareto_losers_lift_pref_profile:
   shows   "pareto_losers R' = pareto_losers R \<union> (alts' - alts)"
 proof -
   have A: "x \<in> alts" "y \<in> alts" if "x \<prec>[Pareto(R)] y" for x y
     using that R.Pareto.not_outside unfolding strongly_preferred_def by auto
   have B: "x \<in> alts'" if "x \<in> alts" for x using election that by blast
   from R.nonempty_alts obtain x where x: "x \<in> alts" by blast
   thus ?thesis unfolding pareto_losers_def lift_pref_profile_Pareto_strict_iff [abs_def]
     by (auto dest: A B)
 qed
 
 context
 begin
 private lemma lift_SD_iff_agent:
   assumes "p \<in> lotteries_on alts" "q \<in> lotteries_on alts" and i: "i \<in> agents"
   shows   "p \<preceq>[SD(R' i)] q \<longleftrightarrow> p \<preceq>[SD(R i)] q"
 proof -
   from i interpret Ri: preorder_on alts "R i" by simp
   from i election have i': "i \<in> agents'" by blast
   then interpret R'i: preorder_on alts' "R' i" by simp
   from assms election have "p \<in> lotteries_on alts'" "q \<in> lotteries_on alts'"
     by (auto intro: lotteries_on_subset)
   with assms election i' show ?thesis
     by (auto simp: Ri.SD_preorder R'i.SD_preorder 
           preferred_alts_lift_pref_profile lottery_prob_carrier)
 qed
 
 private lemma lift_SD_iff_nonagent:
   assumes "p \<in> lotteries_on alts" "q \<in> lotteries_on alts" and i: "i \<in> agents' - agents"
   shows   "p \<preceq>[SD(R' i)] q"
 proof -
   from i election have i': "i \<in> agents'" by blast
   then interpret R'i: preorder_on alts' "R' i" by simp
   from assms election have "p \<in> lotteries_on alts'" "q \<in> lotteries_on alts'"
     by (auto intro: lotteries_on_subset)
   with assms election i' show ?thesis
     by (auto simp: R'i.SD_preorder preferred_alts_lift_pref_profile lottery_prob_carrier)
 qed
 
 lemmas lift_SD_iff = lift_SD_iff_agent lift_SD_iff_nonagent
 
 lemma lift_SD_iff':
   "p \<in> lotteries_on alts \<Longrightarrow> q \<in> lotteries_on alts \<Longrightarrow> i \<in> agents' \<Longrightarrow>
      p \<preceq>[SD(R' i)] q \<longleftrightarrow> i \<notin> agents \<or> p \<preceq>[SD(R i)] q"
   by (cases "i \<in> agents") (simp_all add: lift_SD_iff)
 
 end
 
 lemma lift_SD_strict_iff:
   assumes "p \<in> lotteries_on alts" "q \<in> lotteries_on alts" and i: "i \<in> agents"
   shows   "p \<prec>[SD(R' i)] q \<longleftrightarrow> p \<prec>[SD(R i)] q"
   using assms by (simp add: strongly_preferred_def lift_SD_iff)
 
 lemma lift_Pareto_SD_iff:
   assumes "p \<in> lotteries_on alts" "q \<in> lotteries_on alts"
   shows   "p \<preceq>[Pareto(SD \<circ> R')] q \<longleftrightarrow> p \<preceq>[Pareto(SD \<circ> R)] q"
   using assms election by (auto simp: R.SD.Pareto_iff R'.SD.Pareto_iff lift_SD_iff')
 
 lemma lift_Pareto_SD_strict_iff:
   assumes "p \<in> lotteries_on alts" "q \<in> lotteries_on alts"
   shows   "p \<prec>[Pareto(SD \<circ> R')] q \<longleftrightarrow> p \<prec>[Pareto(SD \<circ> R)] q"
   using assms by (simp add: strongly_preferred_def lift_Pareto_SD_iff)
 
 lemma lift_SD_efficient_iff:
   assumes p: "p \<in> lotteries_on alts"
   shows   "SD_efficient R' p \<longleftrightarrow> SD_efficient R p"
 proof
   assume eff: "SD_efficient R' p"
   have "\<not>(q \<succ>[Pareto(SD \<circ> R)] p)" if q: "q \<in> lotteries_on alts" for q
   proof -
     from q election have q': "q \<in> lotteries_on alts'" by (blast intro: lotteries_on_subset)
     with eff have "\<not>(q \<succ>[Pareto(SD \<circ> R')] p)" by (simp add: R'.SD_efficient_def)
     with p q show ?thesis by (simp add: lift_Pareto_SD_strict_iff)
   qed
   thus "SD_efficient R p" by (simp add: R.SD_efficient_def)
 next
   assume eff: "SD_efficient R p"
   have "\<not>(q \<succ>[Pareto(SD \<circ> R')] p)" if q: "q \<in> lotteries_on alts'" for q
   proof
     assume less: "q \<succ>[Pareto(SD \<circ> R')] p"
-    from R'.SD_efficient_lottery_exists[OF q] guess q' . note q' = this
+    from R'.SD_efficient_lottery_exists[OF q]
+    obtain q' where q': "q' \<in> lotteries_on alts'" "Pareto (SD \<circ> R') q q'" "SD_efficient R' q'" .
     have "x \<notin> set_pmf q'" if x: "x \<in> alts' - alts" for x
     proof -
       from x have "x \<in> pareto_losers R'" by (simp add: pareto_losers_lift_pref_profile)
       with R'.SD_efficient_no_pareto_loser[OF q'(3,1)] show "x \<notin> set_pmf q'" by blast
     qed
     with q' have "q' \<in> lotteries_on alts" by (auto simp: lotteries_on_def)
     moreover from q' less have "q' \<succ>[Pareto(SD \<circ> R')] p" 
       by (auto intro: R'.SD.Pareto.strict_weak_trans)
     with \<open>q' \<in> lotteries_on alts\<close> p have "q' \<succ>[Pareto(SD \<circ> R)] p"
       by (subst (asm) lift_Pareto_SD_strict_iff)
     ultimately have "\<not>SD_efficient R p" by (auto simp: R.SD_efficient_def)
     with eff show False by contradiction
   qed
   thus "SD_efficient R' p" by (simp add: R'.SD_efficient_def)
 qed
 
 end
 
 
 locale sds_lowering = 
   ex_post_efficient_sds agents alts sds
   for agents :: "'agent set" and alts :: "'alt set" and sds +
   fixes agents' alts' 
   assumes agents'_subset: "agents' \<subseteq> agents" and alts'_subset: "alts' \<subseteq> alts"
       and agents'_nonempty [simp]: "agents' \<noteq> {}" and alts'_nonempty [simp]: "alts' \<noteq> {}"
 begin
 
 lemma finite_agents' [simp]: "finite agents'"
   using agents'_subset finite_agents by (rule finite_subset)
 
 lemma finite_alts' [simp]: "finite alts'"
   using alts'_subset finite_alts by (rule finite_subset)
 
 abbreviation lift :: "('agent, 'alt) pref_profile \<Rightarrow> ('agent, 'alt) pref_profile" where
   "lift \<equiv> lift_pref_profile agents' alts' agents alts"
 
 definition lowered :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt lottery" where
   "lowered = sds \<circ> lift"
 
 lemma lift_wf [simp, intro]: 
   "pref_profile_wf agents' alts' R \<Longrightarrow> is_pref_profile (lift R)"
   using alts'_subset agents'_subset by (intro lift_pref_profile_wf) simp_all
 
 sublocale lowered: election agents' alts'
   by unfold_locales simp_all
 
 lemma preferred_alts_lift:
   "lowered.is_pref_profile R \<Longrightarrow> i \<in> agents \<Longrightarrow> x \<in> alts \<Longrightarrow>
      preferred_alts (lift R i) x = 
        (if i \<in> agents' \<and> x \<in> alts' then preferred_alts (R i) x else alts)"
   using alts'_subset agents'_subset
   by (intro preferred_alts_lift_pref_profile) simp_all
 
 lemma pareto_losers_lift:
   "lowered.is_pref_profile R \<Longrightarrow> pareto_losers (lift R) = pareto_losers R \<union> (alts - alts')"
   using agents'_subset alts'_subset by (intro pareto_losers_lift_pref_profile) simp_all
 
 lemma lowered_lotteries: "lowered.lotteries \<subseteq> lotteries"
   unfolding lotteries_on_def using alts'_subset by blast
 
 sublocale lowered: social_decision_scheme agents' alts' lowered
 proof
   fix R assume R_wf: "pref_profile_wf agents' alts' R"
   from R_wf have R'_wf: "pref_profile_wf agents alts (lift R)" by (rule lift_wf)
   show "lowered R \<in> lowered.lotteries" unfolding lotteries_on_def
   proof safe
     fix x assume "x \<in> set_pmf (lowered R)"
     hence x: "x \<in> set_pmf (sds (lift R))" by (simp add: lowered_def)
     with ex_post_efficient[OF R'_wf]
       have "x \<notin> pareto_losers (lift R)" by blast
     with pareto_losers_lift[OF R_wf]
       have "x \<notin> alts - alts'" by blast
     moreover from x have "x \<in> alts" using sds_wf[OF R'_wf] 
       by (auto simp: lotteries_on_def)
     ultimately show "x \<in> alts'" by simp
   qed
 qed
 
 sublocale ex_post_efficient_sds agents' alts' lowered
 proof
   fix R assume R_wf: "lowered.is_pref_profile R"
   hence "is_pref_profile (lift R)" by simp
   have "set_pmf (lowered R) \<inter> pareto_losers (lift R) = {}"
     unfolding lowered_def o_def by (intro ex_post_efficient lift_wf R_wf)
   also have "pareto_losers (lift R) = pareto_losers R \<union> (alts - alts')"
     by (intro pareto_losers_lift R_wf)
   finally show "set_pmf (lowered R) \<inter> pareto_losers R = {}" by blast
 qed
 
 lemma lowered_in_lotteries [simp]: "lowered.is_pref_profile R \<Longrightarrow> lowered R \<in> lotteries"
   using lowered.sds_wf[of R] lowered_lotteries by blast
 
 end
 
 
 
 locale sds_lowering_anonymous =
   anonymous_sds agents alts sds +
   sds_lowering agents alts sds agents' alts'
   for agents :: "'agent set" and alts :: "'alt set" and sds agents' alts'
 begin
 
 sublocale lowered: anonymous_sds agents' alts' lowered
 proof
   fix \<pi> R assume perm: "\<pi> permutes agents'" and R_wf: "lowered.is_pref_profile R"
   from perm have "lift (R \<circ> \<pi>) = lift R \<circ> \<pi>"
     using agents'_subset by (rule lift_pref_profile_permute_agents)
   hence "sds (lift (R \<circ> \<pi>)) = sds (lift R \<circ> \<pi>)" by simp
   also from perm R_wf have "\<pi> permutes agents" "is_pref_profile (lift R)"
     using agents'_subset by (auto dest: permutes_subset)
   from anonymous[OF this] have "sds (lift R \<circ> \<pi>) = sds (lift R)"
     by (simp add: lowered_def)
   finally show "lowered (R \<circ> \<pi>) = lowered R" unfolding lowered_def o_def .
 qed
 
 end
 
 locale sds_lowering_neutral =
   neutral_sds agents alts sds +
   sds_lowering agents alts sds agents' alts'
   for agents :: "'agent set" and alts :: "'alt set" and sds agents' alts'
 begin
 
 sublocale lowered: neutral_sds agents' alts' lowered
 proof
   fix \<sigma> R assume perm: "\<sigma> permutes alts'" and R_wf: "lowered.is_pref_profile R"
   from perm alts'_subset 
     have "lift (permute_profile \<sigma> R) = permute_profile \<sigma> (lift R)"
     by (rule lift_pref_profile_permute_alts)
   hence "sds (lift (permute_profile \<sigma> R)) = sds (permute_profile \<sigma> (lift R))" by simp
   also from R_wf perm have "is_pref_profile (lift R)" by simp
   with perm alts'_subset 
     have "sds (permute_profile \<sigma> (lift R)) = map_pmf \<sigma> (sds (lift R))"
     by (intro neutral) (auto intro: permutes_subset)
   finally show "lowered (permute_profile \<sigma> R) = map_pmf \<sigma> (lowered R)"
     by (simp add: lowered_def o_def)
 qed
 
 end
 
 locale sds_lowering_sd_efficient =
   sd_efficient_sds agents alts sds +
   sds_lowering agents alts sds agents' alts'
   for agents :: "'agent set" and alts :: "'alt set" and sds agents' alts'
 begin
 
 sublocale sd_efficient_sds agents' alts' lowered
 proof
   fix R assume R_wf: "lowered.is_pref_profile R"
   interpret R: pref_profile_wf agents' alts' R by fact
   from R_wf agents'_subset alts'_subset show "SD_efficient R (lowered R)"
     unfolding lowered_def o_def
     by (subst lift_SD_efficient_iff [symmetric])
        (insert SD_efficient R_wf lowered.sds_wf[OF R_wf], auto simp: lowered_def)
 qed
 
 end
 
 
 locale sds_lowering_strategyproof =
   strategyproof_sds agents alts sds +
   sds_lowering agents alts sds agents' alts'
   for agents :: "'agent set" and alts :: "'alt set" and sds agents' alts'
 begin
 
 sublocale strategyproof_sds agents' alts' lowered
 proof (unfold_locales, safe)
   fix R i Ri'
   assume R_wf: "lowered.is_pref_profile R" and i: "i \<in> agents'"
   assume Ri': "total_preorder_on alts' Ri'"
   assume manipulable: "lowered.manipulable_profile R i Ri'"
   from i agents'_subset have i': "i \<in> agents" by blast
   interpret R: pref_profile_wf agents' alts' R by fact
   from R_wf interpret liftR: pref_profile_wf agents alts "lift R" by simp
 
   define lift_Ri'
     where "lift_Ri' x y \<longleftrightarrow> x \<in> alts \<and> y \<in> alts \<and> (x = y \<or> x \<notin> alts' \<or> (y \<in> alts' \<and> Ri' x y))"
     for x y
   define S where "S = (lift R)(i := lift_Ri')"
   from Ri' interpret Ri': total_preorder_on alts' Ri' .
   have wf_lift_Ri': "total_preorder_on alts lift_Ri'" using Ri'.total
     by unfold_locales (auto simp: lift_Ri'_def intro: Ri'.trans)
   from agents'_subset i have S_altdef: "S = lift (R(i := Ri'))"
     by (auto simp: fun_eq_iff lift_pref_profile_def lift_Ri'_def S_def)
   have "lowered (R(i := Ri')) \<in> lowered.lotteries"
     by (intro lowered.sds_wf R.wf_update i Ri')
   hence sds_S_wf: "sds S \<in> lowered.lotteries" by (simp add: S_altdef lowered_def)
 
   from manipulable have "lowered R \<prec>[SD (R i)] sds (lift (R(i := Ri')))"
     unfolding lowered.manipulable_profile_def by (simp add: lowered_def)
   also note S_altdef [symmetric]
   finally have "lowered R \<prec>[SD (lift R i)] sds S"
     using R_wf i lowered.sds_wf[OF R_wf] sds_S_wf
       by (subst lift_SD_strict_iff) (simp_all add: agents'_subset alts'_subset)
   hence "manipulable_profile (lift R) i lift_Ri'"
     by (simp add: manipulable_profile_def lowered_def S_def)
   with strategyproof[OF lift_wf[OF R_wf] i' wf_lift_Ri'] show False by contradiction
 qed
 
 end
 
 
 locale sds_lowering_anonymous_neutral_sdeff_stratproof =
   sds_lowering_anonymous + sds_lowering_neutral + 
   sds_lowering_sd_efficient + sds_lowering_strategyproof
 
 end
diff --git a/thys/Randomised_Social_Choice/SD_Efficiency.thy b/thys/Randomised_Social_Choice/SD_Efficiency.thy
--- a/thys/Randomised_Social_Choice/SD_Efficiency.thy
+++ b/thys/Randomised_Social_Choice/SD_Efficiency.thy
@@ -1,392 +1,393 @@
 (*  
   Title:    SD_Efficiency.thy
   Author:   Manuel Eberl, TU München
 
   Characterisation of SD-efficiency.
 *)
 
 theory SD_Efficiency
 imports Complex_Main Preference_Profiles Lotteries Stochastic_Dominance
 begin
 
 (* 
   TODO: Perhaps a general concept of "efficiency" can be introduced, 
   parametrised over the way in which two lotteries are compared.
 *)
 
 context pref_profile_wf
 begin
 
 lemma SD_inefficient_support_subset:
   assumes inefficient: "\<not>SD_efficient R p'"
   assumes support: "set_pmf p' \<subseteq> set_pmf p"
   assumes lotteries: "p \<in> lotteries_on alts"
   shows   "\<not>SD_efficient R p"
 proof -
   from assms have p'_wf: "p' \<in> lotteries_on alts" by (simp add: lotteries_on_def)
   from inefficient obtain q' i where q': "q' \<in> lotteries_on alts" "i \<in> agents"
     "\<And>i. i \<in> agents \<Longrightarrow> q' \<succeq>[SD(R i)] p'" "q' \<succ>[SD(R i)] p'" 
     unfolding SD_efficient_def' by blast
 
   have subset: "{x. pmf p' x > pmf q' x} \<subseteq> set_pmf p'" by (auto simp: set_pmf_eq)
   also have "\<dots> \<subseteq> set_pmf p" by fact
   also have "\<dots> \<subseteq> alts" using lotteries by (simp add: lotteries_on_def)
   finally have finite: "finite {x. pmf p' x > pmf q' x}" 
     using finite_alts by (rule finite_subset)
 
   define \<epsilon> where "\<epsilon> = Min (insert 1 {pmf p x / (pmf p' x - pmf q' x) |x. pmf p' x > pmf q' x})"
   define supp where "supp = set_pmf p \<union> set_pmf q'"
   from lotteries finite_alts q'(1) have finite_supp: "finite supp"
     by (auto simp: lotteries_on_def supp_def dest: finite_subset)
   from support have [simp]: "pmf p x = 0" "pmf p' x = 0" "pmf q' x = 0" if "x \<notin> supp" for x
     using that by (auto simp: supp_def set_pmf_eq)
 
   from finite support subset have \<epsilon>: "\<epsilon> > 0" unfolding \<epsilon>_def 
     by (auto simp: field_simps set_pmf_eq')
   have nonneg: "pmf p x + \<epsilon> * (pmf q' x - pmf p' x) \<ge> 0" for x
   proof (cases "pmf p' x > pmf q' x")
     case True
     with finite have "\<epsilon> \<le> pmf p x / (pmf p' x - pmf q' x)"
       unfolding \<epsilon>_def by (intro Min_le) auto
     with True show ?thesis by (simp add: field_simps)
   next
     case False
     with pmf_nonneg[of p x] \<epsilon> show ?thesis by simp
   qed
 
   define q where "q = embed_pmf (\<lambda>x. pmf p x + \<epsilon> * (pmf q' x - pmf p' x))"
   have "(\<integral>\<^sup>+ x. ennreal (pmf p x + \<epsilon> * (pmf q' x - pmf p' x)) \<partial>count_space UNIV) = 1"
   proof (subst nn_integral_count_space')
     have "(\<Sum>x\<in>supp. ennreal (pmf p x + \<epsilon> * (pmf q' x - pmf p' x))) = 
             ennreal ((\<Sum>x\<in>supp. pmf p x) + \<epsilon> * ((\<Sum>x\<in>supp. pmf q' x) - (\<Sum>x\<in>supp. pmf p' x)))"
      by (subst sum_ennreal[OF nonneg], rule ennreal_cong)
         (auto simp: sum_subtractf ring_distribs sum.distrib sum_distrib_left)
     also from finite_supp support have "\<dots> = 1"
       by (subst (1 2 3) sum_pmf_eq_1) (auto simp: supp_def)
     finally show "(\<Sum>x\<in>supp. ennreal (pmf p x + \<epsilon> * (pmf q' x - pmf p' x))) = 1" .
   qed (insert nonneg finite_supp, simp_all)
   with nonneg have pmf_q: "pmf q x = pmf p x + \<epsilon> * (pmf q' x - pmf p' x)" for x
     unfolding q_def by (intro pmf_embed_pmf) simp_all
   with support have support_q: "set_pmf q \<subseteq> supp" 
     unfolding supp_def by (auto simp: set_pmf_eq)
   with lotteries support q'(1) have q_wf: "q \<in> lotteries_on alts"
     by (auto simp add: lotteries_on_def supp_def)
   
   from support_q support have expected_utility:
     "measure_pmf.expectation q u = measure_pmf.expectation p u + 
          \<epsilon> * (measure_pmf.expectation q' u - measure_pmf.expectation p' u)" for u
     by (subst (1 2 3 4) integral_measure_pmf[OF finite_supp])
        (auto simp: pmf_q supp_def sum.distrib sum_distrib_left 
                    sum_distrib_right sum_subtractf algebra_simps)
   
   have "q \<succeq>[SD(R i)] p" if i: "i \<in> agents" for i
   proof -
     from i interpret finite_total_preorder_on alts "R i" by simp
     from i lotteries q'(1) q'(3)[OF i] q_wf p'_wf \<epsilon> show ?thesis
       by (fastforce simp: SD_iff_expected_utilities_le expected_utility)
   qed
   moreover from \<open>i \<in> agents\<close> interpret finite_total_preorder_on alts "R i" by simp
     from lotteries q'(1,4) q_wf p'_wf \<epsilon> have "q \<succ>[SD(R i)] p"
     by (force simp: SD_iff_expected_utilities_le expected_utility not_le strongly_preferred_def)
   ultimately show ?thesis using q_wf \<open>i \<in> agents\<close> unfolding SD_efficient_def' by blast
 qed
 
 lemma SD_efficient_support_subset:
   assumes "SD_efficient R p" "set_pmf p' \<subseteq> set_pmf p" "p \<in> lotteries_on alts"
   shows   "SD_efficient R p'"
   using SD_inefficient_support_subset[OF _ assms(2,3)] assms(1) by blast
 
 lemma SD_efficient_same_support:
   assumes "set_pmf p = set_pmf p'" "p \<in> lotteries_on alts"
   shows   "SD_efficient R p \<longleftrightarrow> SD_efficient R p'"
   using SD_inefficient_support_subset[of p p'] SD_inefficient_support_subset[of p' p] assms
   by (auto simp: lotteries_on_def)  
 
 lemma SD_efficient_iff:
   assumes "p \<in> lotteries_on alts"
   shows   "SD_efficient R p \<longleftrightarrow> SD_efficient R (pmf_of_set (set_pmf p))"
   using assms finite_alts
   by (intro SD_efficient_same_support)
      (simp, subst set_pmf_of_set,
       auto simp: set_pmf_not_empty lotteries_on_def intro: finite_subset[OF _ finite_alts])
 
 lemma SD_efficient_no_pareto_loser:
   assumes efficient: "SD_efficient R p" and p_wf: "p \<in> lotteries_on alts"
   shows   "set_pmf p \<inter> pareto_losers R = {}"
 proof -
   have "x \<notin> pareto_losers R" if x: "x \<in> set_pmf p" for x
   proof -
     from x have "set_pmf (return_pmf x) \<subseteq> set_pmf p" by auto
     from efficient this p_wf have "SD_efficient R (return_pmf x)"
       by (rule SD_efficient_support_subset)
     moreover from assms x have "x \<in> alts" by (auto simp: lotteries_on_def)
     ultimately show "x \<notin> pareto_losers R" by (simp add: SD_efficient_singleton_iff)
   qed
   thus ?thesis by blast
 qed
 
 text \<open>
   Given two lotteries with the same support where one is strictly Pareto-SD-preferred to 
   the other, one can construct a third lottery that is weakly Pareto-SD-preferred to the 
   better lottery (and therefore strictly Pareto-SD-preferred to the worse lottery) and
   whose support is a strict subset of the original supports.
 \<close>
 lemma improve_lottery_support_subset:
   assumes "p \<in> lotteries_on alts" "q \<in> lotteries_on alts" "q \<succ>[Pareto(SD \<circ> R)] p"
           "set_pmf p = set_pmf q"
   obtains r where "r \<in> lotteries_on alts" "r \<succeq>[Pareto(SD \<circ> R)] q" "set_pmf r \<subset> set_pmf p"
 proof -
   have subset: "{x. pmf p x > pmf q x} \<subseteq> set_pmf p" by (auto simp: set_pmf_eq)
   also have "\<dots> \<subseteq> alts" using assms by (simp add: lotteries_on_def)
   finally have finite: "finite {x. pmf p x > pmf q x}" 
     using finite_alts by (rule finite_subset)
 
   from assms have "q \<noteq> p" by (auto simp: strongly_preferred_def)
   hence ex_less: "\<exists>x. pmf p x > pmf q x" by (rule pmf_neq_exists_less)
 
   define \<epsilon> where "\<epsilon> = Min {pmf p x / (pmf p x - pmf q x) |x. pmf p x > pmf q x}"
   define supp where "supp = set_pmf p"
   from assms finite_alts have finite_supp: "finite supp"
     by (auto simp: lotteries_on_def supp_def dest: finite_subset)
   from assms have [simp]: "pmf p x = 0" "pmf q x = 0" if "x \<notin> supp" for x
     using that by (auto simp: supp_def set_pmf_eq)
 
   from finite subset ex_less have \<epsilon>: "\<epsilon> \<ge> 1" unfolding \<epsilon>_def 
     by (intro Min.boundedI) (auto simp: field_simps pmf_nonneg)
   have nonneg: "pmf p x + \<epsilon> * (pmf q x - pmf p x) \<ge> 0" for x
   proof (cases "pmf p x > pmf q x")
     case True
     with finite have "\<epsilon> \<le> pmf p x / (pmf p x - pmf q x)"
       unfolding \<epsilon>_def by (intro Min_le) auto
     with True show ?thesis by (simp add: field_simps)
   next
     case False
     with pmf_nonneg[of p x] \<epsilon> show ?thesis by simp
   qed
 
   define r where "r = embed_pmf (\<lambda>x. pmf p x + \<epsilon> * (pmf q x - pmf p x))"
   have "(\<integral>\<^sup>+ x. ennreal (pmf p x + \<epsilon> * (pmf q x - pmf p x)) \<partial>count_space UNIV) = 1"
   proof (subst nn_integral_count_space')
     have "(\<Sum>x\<in>supp. ennreal (pmf p x + \<epsilon> * (pmf q x - pmf p x))) = 
             ennreal ((\<Sum>x\<in>supp. pmf p x) + \<epsilon> * ((\<Sum>x\<in>supp. pmf q x) - (\<Sum>x\<in>supp. pmf p x)))"
      by (subst sum_ennreal[OF nonneg], rule ennreal_cong)
         (auto simp: sum_subtractf ring_distribs sum.distrib sum_distrib_left)
     also from finite_supp  have "\<dots> = 1"
       by (subst (1 2 3) sum_pmf_eq_1) (auto simp: supp_def assms)
     finally show "(\<Sum>x\<in>supp. ennreal (pmf p x + \<epsilon> * (pmf q x - pmf p x))) = 1" .
   qed (insert nonneg finite_supp, simp_all)
   with nonneg have pmf_r: "pmf r x = pmf p x + \<epsilon> * (pmf q x - pmf p x)" for x
     unfolding r_def by (intro pmf_embed_pmf) simp_all
 
   with assms have "set_pmf r \<subseteq> supp" 
     unfolding supp_def by (auto simp: set_pmf_eq)
   from finite ex_less have "\<epsilon> \<in> {pmf p x / (pmf p x - pmf q x) |x. pmf p x > pmf q x}"
      unfolding \<epsilon>_def by (intro Min_in) auto
   then obtain x where "\<epsilon> = pmf p x / (pmf p x - pmf q x)" "pmf p x > pmf q x" by blast
   hence "pmf r x = 0" by (simp add: pmf_r field_simps)
   moreover from \<open>pmf p x > pmf q x\<close> pmf_nonneg[of q x] 
     have "pmf p x > 0" by linarith
   ultimately have "x \<in> set_pmf p - set_pmf r" by (auto simp: set_pmf_iff)
   with \<open>set_pmf r \<subseteq> supp\<close> have support_r: "set_pmf r \<subset> set_pmf p" unfolding supp_def by blast
   from this assms have r_wf: "r \<in> lotteries_on alts" by (simp add: lotteries_on_def)
 
   have "r \<succeq>[Pareto(SD\<circ>R)] q" unfolding SD.Pareto_iff unfolding o_def
   proof 
     fix i assume i: "i \<in> agents"
     then interpret finite_total_preorder_on alts "R i" by simp
     show "r \<succeq>[SD(R i)] q"
     proof (subst SD_iff_expected_utilities_le; safe?)
       fix u assume u: "is_vnm_utility u"
       from support_r have expected_utility_r:
         "measure_pmf.expectation r u = measure_pmf.expectation p u + 
              \<epsilon> * (measure_pmf.expectation q u - measure_pmf.expectation p u)"
         by (subst (1 2 3 4) integral_measure_pmf[OF finite_supp])
            (auto simp: supp_def assms pmf_r sum.distrib sum_distrib_left
             sum_distrib_right sum_subtractf algebra_simps)
       from assms i have "q \<succeq>[SD(R i)] p" by (simp add: SD.Pareto_strict_iff)
       with assms u have "measure_pmf.expectation q u \<ge> measure_pmf.expectation p u"
         by (simp add: SD_iff_expected_utilities_le r_wf)
       hence "(\<epsilon> - 1) * measure_pmf.expectation p u \<le> (\<epsilon> - 1) * measure_pmf.expectation q u"
         using \<epsilon> by (intro mult_left_mono) simp_all
       thus "measure_pmf.expectation q u \<le> measure_pmf.expectation r u" 
         by (simp add: algebra_simps expected_utility_r)
     qed fact+
   qed
   from that[OF r_wf this support_r] show ?thesis .
 qed
 
 subsection \<open>Existence of SD-efficient lotteries\<close>
 
 text \<open>
   In this section, we will show that any lottery can be `improved' to an SD-efficient lottery,
   i.e. for any lottery, there exists an SD-efficient lottery that is weakly SD-preferred to 
   the original one by all agents.
 \<close>
 
 context
   fixes p :: "'alt lottery"
   assumes lott: "p \<in> lotteries_on alts"
 begin
 
 private definition improve_lottery :: "'alt lottery \<Rightarrow> 'alt lottery" where
   "improve_lottery q = (let A = {r\<in>lotteries_on alts. r \<succ>[Pareto(SD\<circ>R)] q} in
      (SOME r. r \<in> A \<and> \<not>(\<exists>r'\<in>A. set_pmf r' \<subset> set_pmf r)))" 
 
 private lemma improve_lottery:
   assumes "\<not>SD_efficient R q"
   defines "r \<equiv> improve_lottery q"
   shows   "r \<in> lotteries_on alts" "r \<succ>[Pareto(SD\<circ>R)] q"
           "\<And>r'. r' \<in> lotteries_on alts \<Longrightarrow> r' \<succ>[Pareto(SD\<circ>R)] q \<Longrightarrow> \<not>(set_pmf r' \<subset> set_pmf r)"
 proof -
   define A where "A = {r\<in>lotteries_on alts. r \<succ>[Pareto(SD\<circ>R)] q}"
   have subset_alts: "X \<subseteq> alts" if "X \<in> set_pmf`A" for X using that 
     by (auto simp: A_def lotteries_on_def)
   have r_altdef: "r = (SOME r. r \<in> A \<and> \<not>(\<exists>r'\<in>A. set_pmf r' \<subset> set_pmf r))"
     unfolding r_def improve_lottery_def Let_def A_def by simp
   from assms have nonempty: "A \<noteq> {}" by (auto simp: A_def SD_efficient_def)
   hence nonempty': "set_pmf`A \<noteq> {}" by simp
   have "set_pmf ` A \<subseteq> Pow alts" by (auto simp: A_def lotteries_on_def)
 
   from finite_alts have wf: "wf {(X,Y). X \<subset> Y \<and> Y \<subseteq> alts}"
     by (rule finite_subset_wf)
   obtain X 
     where "X \<in> set_pmf`A" "\<And>Y. Y \<subset> X \<and> X \<subseteq> alts \<Longrightarrow> Y \<notin> set_pmf ` A" 
     by (rule wfE_min'[OF wf nonempty']) simp_all
   hence "\<exists>r. r \<in> A \<and> \<not>(\<exists>r'\<in>A. set_pmf r' \<subset> set_pmf r)"
     by (auto simp: subset_alts[of X])
   from someI_ex[OF this, folded r_altdef] 
     show "r \<in> lotteries_on alts" "r \<succ>[Pareto(SD\<circ>R)] q"
           "\<And>r'. r' \<in> lotteries_on alts \<Longrightarrow> r' \<succ>[Pareto(SD\<circ>R)] q \<Longrightarrow> \<not>(set_pmf r' \<subset> set_pmf r)"
     unfolding A_def by blast+
 qed
 
 private fun sd_chain :: "nat \<Rightarrow> 'alt lottery option" where
   "sd_chain 0 = Some p"
 | "sd_chain (Suc n) = 
      (case sd_chain n of
         None \<Rightarrow> None
       | Some p \<Rightarrow> if SD_efficient R p then None else Some (improve_lottery p))"
 
 private lemma sd_chain_None_propagate:
   "m \<ge> n \<Longrightarrow> sd_chain n = None \<Longrightarrow> sd_chain m = None"
   by (induction rule: inc_induct) simp_all
 
 private lemma sd_chain_Some_propagate:
   "m \<ge> n \<Longrightarrow> sd_chain m = Some q \<Longrightarrow> \<exists>q'. sd_chain n = Some q'"
   by (cases "sd_chain n") (auto simp: sd_chain_None_propagate)
 
 private lemma sd_chain_NoneD:
   "sd_chain n = None \<Longrightarrow> \<exists>n p. sd_chain n = Some p \<and> SD_efficient R p"
   by (induction n) (auto split: option.splits if_splits)
 
 private lemma sd_chain_lottery: "sd_chain n = Some q \<Longrightarrow> q \<in> lotteries_on alts"
   by (induction n) (insert lott, auto split: option.splits if_splits simp: improve_lottery)
 
 private lemma sd_chain_Suc:
   assumes "sd_chain m = Some q"
   assumes "sd_chain (Suc m) = Some r"
   shows   "q \<prec>[Pareto(SD\<circ>R)] r"
   using assms by (auto split: if_splits simp: improve_lottery)
 
 private lemma sd_chain_strictly_preferred:
   assumes "m < n"
   assumes "sd_chain m = Some q"
   assumes "sd_chain n = Some s"
   shows   "q \<prec>[Pareto(SD\<circ>R)] s"
   using assms
 proof (induction arbitrary: q rule: strict_inc_induct)
   case (base k q)
   with sd_chain_Suc[of k q s] show ?case by (simp del: sd_chain.simps add: o_def)
 next
   case (step k q)
   from step.hyps have "Suc k \<le> n" by simp
   from sd_chain_Some_propagate[OF this, of s] step.prems obtain r 
     where r: "sd_chain (Suc k) = Some r" by (auto simp del: sd_chain.simps)
   with step.prems have "q \<prec>[Pareto (SD \<circ> R)] r" by (intro sd_chain_Suc)
   moreover from r step.prems have "r \<prec>[Pareto (SD \<circ> R)] s" by (intro step.IH) simp_all
   ultimately show ?case by (rule SD.Pareto.strict_trans)
 qed
 
 private lemma sd_chain_preferred:
   assumes "m \<le> n"
   assumes "sd_chain m = Some q"
   assumes "sd_chain n = Some s"
   shows   "q \<preceq>[Pareto(SD\<circ>R)] s"
 proof (cases "m < n")
   case True
   from sd_chain_strictly_preferred[OF this assms(2,3)] show ?thesis
     by (simp add: strongly_preferred_def)
 next
   case False
   with assms show ?thesis by (auto intro: SD.Pareto.refl sd_chain_lottery)
 qed
 
 lemma SD_efficient_lottery_exists: 
   obtains q where "q \<in> lotteries_on alts" "q \<succeq>[Pareto(SD\<circ>R)] p" "SD_efficient R q"
 proof -
   consider "\<exists>n. sd_chain n = None" | "\<forall>n. \<exists>q. sd_chain n = Some q" 
     using option.exhaust by metis
   thus ?thesis
   proof cases
     case 1
     define m where "m = (LEAST m. sd_chain m = None)"
     define k where "k = m - 1"
     from LeastI_ex[OF 1] have m: "sd_chain m = None" by (simp add: m_def)
     from m have nz: "m \<noteq> 0" by (intro notI) simp_all
     from nz have m_altdef: "m = Suc k" by (simp add: k_def)
     from nz Least_le[of "\<lambda>m. sd_chain m = None" "m - 1", folded m_def]
       obtain q where q: "sd_chain k = Some q" by (cases "sd_chain (m - 1)") (auto simp: k_def)
     from sd_chain_preferred[OF _ sd_chain.simps(1) this] have "q \<succeq>[Pareto(SD\<circ>R)] p" by simp
     moreover from q have "q \<in> lotteries_on alts" by (simp add: sd_chain_lottery)
     moreover from q m have "SD_efficient R q" by (auto split: if_splits simp: m_altdef)
     ultimately show ?thesis using that[of q] by blast
   next
     case 2
     have "range (set_pmf \<circ> the \<circ> sd_chain) \<subseteq> Pow alts" unfolding o_def
     proof safe
       fix n x assume A: "x \<in> set_pmf (the (sd_chain n))"
       from 2 obtain q where "sd_chain n = Some q" by auto
       with sd_chain_lottery[of n q] have "set_pmf (the (sd_chain n)) \<subseteq> alts"
         by (simp add: lotteries_on_def)
       with A show "x \<in> alts" by blast
     qed
     hence "finite (range (set_pmf \<circ> the \<circ> sd_chain))" by (rule finite_subset) simp_all
     from pigeonhole_infinite[OF infinite_UNIV_nat this]
       obtain m where "infinite {n. set_pmf (the (sd_chain n)) = set_pmf (the (sd_chain m))}"
       by auto
     hence "infinite ({n. set_pmf (the (sd_chain n)) = set_pmf (the (sd_chain m))} - {k. \<not>(k > m)})"
       by (simp add: not_less)
     hence "({n. set_pmf (the (sd_chain n)) = set_pmf (the (sd_chain m))} - {k. \<not>(k > m)}) \<noteq> {}"
       by (intro notI) simp_all
     then obtain n where mn: "n > m" "set_pmf (the (sd_chain n)) = set_pmf (the (sd_chain m))"
       by blast
     from 2 obtain p q where pq: "sd_chain m = Some p" "sd_chain n = Some q" by blast
     from mn pq have supp_eq: "set_pmf p = set_pmf q" by simp
     from mn(1) pq have less: "p \<prec>[Pareto(SD\<circ>R)] q" by (rule sd_chain_strictly_preferred)
 
     from \<open>m < n\<close> have "n > 0" by simp
     with \<open>sd_chain n = Some q\<close> sd_chain.simps(2)[of "n - 1"]
       obtain r where r: "\<not>SD_efficient R r" "q = improve_lottery r"
       by (auto simp del: sd_chain.simps split: if_splits option.splits)
 
     from pq have "p \<in> lotteries_on alts" "q \<in> lotteries_on alts" 
       by (simp_all add: sd_chain_lottery)
-    from improve_lottery_support_subset[OF this less supp_eq] guess s . note s = this
+    from improve_lottery_support_subset[OF this less supp_eq]
+    obtain s where s: "s \<in> lotteries_on alts" "Pareto (SD \<circ> R) q s" "set_pmf s \<subset> set_pmf p" .
     from improve_lottery(2)[of r] r s have "s \<succ>[Pareto(SD\<circ>R)] r"
       by (auto intro: SD.Pareto.strict_weak_trans)
     from improve_lottery(3)[OF r(1) s(1) this] supp_eq r 
       have "\<not>set_pmf s \<subset> set_pmf p" by simp
     with s(3) show ?thesis by contradiction
   qed
 qed
 
 end
  
 lemma 
   assumes "p \<in> lotteries_on alts"
   shows   "\<exists>q\<in>lotteries_on alts. q \<succeq>[Pareto(SD\<circ>R)] p \<and> SD_efficient R q"
   using SD_efficient_lottery_exists[OF assms] by blast
 
 end
 
 end
diff --git a/thys/Randomised_Social_Choice/Social_Decision_Schemes.thy b/thys/Randomised_Social_Choice/Social_Decision_Schemes.thy
--- a/thys/Randomised_Social_Choice/Social_Decision_Schemes.thy
+++ b/thys/Randomised_Social_Choice/Social_Decision_Schemes.thy
@@ -1,411 +1,412 @@
 (*  
   Title:    Social Decision Schemes.thy
   Author:   Manuel Eberl, TU München
 
   Definitions of Social Decision Schemes, their properties, and related concepts
 *)
 
 section \<open>Social Decision Schemes\<close>
 
 theory Social_Decision_Schemes
 imports 
   Complex_Main 
   "HOL-Probability.Probability"
   Preference_Profiles
   Elections
   Order_Predicates
   Stochastic_Dominance
   SD_Efficiency
 begin
 
 subsection \<open>Basic Social Choice definitions\<close>
 
 context election
 begin
 
 text \<open>
   The set of lotteries, i.e. the probability mass functions on the type @{typ "'alt"}
   whose support is a subset of the alternative set. 
 \<close>
 abbreviation lotteries where
   "lotteries \<equiv> lotteries_on alts"
 
 text \<open>
   The probability that a lottery returns an alternative that is in the given set
 \<close>
 abbreviation lottery_prob :: "'alt lottery \<Rightarrow> 'alt set \<Rightarrow> real" where
   "lottery_prob \<equiv> measure_pmf.prob"
 
 lemma lottery_prob_alts_superset: 
   assumes "p \<in> lotteries" "alts \<subseteq> A"
   shows   "lottery_prob p A = 1"
   using assms by (subst measure_pmf.prob_eq_1) (auto simp: AE_measure_pmf_iff lotteries_on_def)
 
 lemma lottery_prob_alts: "p \<in> lotteries \<Longrightarrow> lottery_prob p alts = 1"
   by (rule lottery_prob_alts_superset) simp_all
 
 end
 
 
 text \<open>
   In the context of an election, a preference profile is a function that 
   assigns to each agent her preference relation (which is a total preorder)
 \<close>
 
 
 subsection \<open>Social Decision Schemes\<close>
 
 text \<open>
   In the context of an election, a Social Decision Scheme (SDS) is a function that 
   maps preference profiles to lotteries on the alternatives.
 \<close> 
 locale social_decision_scheme = election agents alts 
   for agents :: "'agent set" and alts :: "'alt set" +
   fixes sds :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt lottery"
   assumes sds_wf: "is_pref_profile R \<Longrightarrow> sds R \<in> lotteries"
 
 
 subsection \<open>Anonymity\<close>
 
 text \<open>
   An SDS is anonymous if permuting the agents in the input does not change the result.
 \<close>
 locale anonymous_sds = social_decision_scheme agents alts sds
   for agents :: "'agent set" and alts :: "'alt set" and sds +
   assumes anonymous: "\<pi> permutes agents \<Longrightarrow> is_pref_profile R \<Longrightarrow> sds (R \<circ> \<pi>) = sds R" 
 begin
 
 lemma anonymity_prefs_from_table:
   assumes "prefs_from_table_wf agents alts xs" "prefs_from_table_wf agents alts ys"
   assumes "mset (map snd xs) = mset (map snd ys)"
   shows   "sds (prefs_from_table xs) = sds (prefs_from_table ys)"
 proof -
-  from prefs_from_table_agent_permutation[OF assms] guess \<pi> .
+  from assms obtain \<pi> where "\<pi> permutes agents" "prefs_from_table xs \<circ> \<pi> = prefs_from_table ys"
+    by (rule prefs_from_table_agent_permutation)
   with anonymous[of \<pi>, of "prefs_from_table xs"] assms(1) show ?thesis 
     by (simp add: pref_profile_from_tableI)
 qed
 
 context
 begin
 qualified lemma anonymity_prefs_from_table_aux:
   assumes "R1 = prefs_from_table xs" "prefs_from_table_wf agents alts xs"
   assumes "R2 = prefs_from_table ys" "prefs_from_table_wf agents alts ys"
   assumes "mset (map snd xs) = mset (map snd ys)"
   shows   "sds R1 = sds R2" unfolding assms(1,3)
   by (rule anonymity_prefs_from_table) (simp_all add: assms del: mset_map)
 end
 
 end
 
 
 subsection \<open>Neutrality\<close>
 
 text \<open>
   An SDS is neutral if permuting the alternatives in the input does not change the
   result, modulo the equivalent permutation in the output lottery.
 \<close>
 locale neutral_sds = social_decision_scheme agents alts sds
   for agents :: "'agent set" and alts :: "'alt set" and sds +
   assumes neutral: "\<sigma> permutes alts \<Longrightarrow> is_pref_profile R \<Longrightarrow> 
                         sds (permute_profile \<sigma> R) = map_pmf \<sigma> (sds R)"
 begin
 
 text \<open>
   Alternative formulation of neutrality that shows that our definition is 
   equivalent to that in the paper.
 \<close>
 lemma neutral':
   assumes "\<sigma> permutes alts"
   assumes "is_pref_profile R"
   assumes "a \<in> alts"
   shows   "pmf (sds (permute_profile \<sigma> R)) (\<sigma> a) = pmf (sds R) a"
 proof -
   from assms have A: "set_pmf (sds R) \<subseteq> alts" using sds_wf
     by (simp add: lotteries_on_def)
   from assms(1,2) have "pmf (sds (permute_profile \<sigma> R)) (\<sigma> a) = pmf (map_pmf \<sigma> (sds R)) (\<sigma> a)"
     by (subst neutral) simp_all
   also from assms have "\<dots> = pmf (sds R) a"
     by (intro pmf_map_inj') (simp_all add: permutes_inj)
   finally show ?thesis .
 qed
 
 end
 
 
 locale an_sds = 
   anonymous_sds agents alts sds + neutral_sds agents alts sds
   for agents :: "'agent set" and alts :: "'alt set" and sds
 begin
 
 lemma sds_anonymous_neutral:
   assumes perm: "\<sigma> permutes alts" and wf: "is_pref_profile R1" "is_pref_profile R2"
   assumes eq: "anonymous_profile R1 = 
                  image_mset (map ((`) \<sigma>)) (anonymous_profile R2)"
   shows   "sds R1 = map_pmf \<sigma> (sds R2)"
 proof -
   interpret R1: pref_profile_wf agents alts R1 by fact
   interpret R2: pref_profile_wf agents alts R2 by fact
   from perm have wf': "is_pref_profile (permute_profile \<sigma> R2)"
     by (rule R2.wf_permute_alts)
   from eq perm have "anonymous_profile R1 = anonymous_profile (permute_profile \<sigma> R2)"
     by (simp add: R2.anonymous_profile_permute)
   from anonymous_profile_agent_permutation[OF this wf(1) wf']
     obtain \<pi> where "\<pi> permutes agents" "permute_profile \<sigma> R2 \<circ> \<pi> = R1" by auto
   have "sds (permute_profile \<sigma> R2 \<circ> \<pi>) = sds (permute_profile \<sigma> R2)"
     by (rule anonymous) fact+
   also have "\<dots> = map_pmf \<sigma> (sds R2)"
     by (rule neutral) fact+
   also have "permute_profile \<sigma> R2 \<circ> \<pi> = R1" by fact
   finally show ?thesis .
 qed
 
 
 lemma sds_anonymous_neutral':
   assumes perm: "\<sigma> permutes alts" and wf: "is_pref_profile R1" "is_pref_profile R2"
   assumes eq: "anonymous_profile R1 = 
                  image_mset (map ((`) \<sigma>)) (anonymous_profile R2)"
   shows   "pmf (sds R1) (\<sigma> x) = pmf (sds R2) x"
 proof -
   have "sds R1 = map_pmf \<sigma> (sds R2)" by (intro sds_anonymous_neutral) fact+
   also have "pmf \<dots> (\<sigma> x) = pmf (sds R2) x" by (intro pmf_map_inj' permutes_inj[OF perm])
   finally show ?thesis .
 qed
 
 lemma sds_automorphism:
   assumes perm: "\<sigma> permutes alts" and wf: "is_pref_profile R"
   assumes eq: "image_mset (map ((`) \<sigma>)) (anonymous_profile R) = anonymous_profile R"
   shows   "map_pmf \<sigma> (sds R) = sds R"
   using sds_anonymous_neutral[OF perm wf wf eq [symmetric]] ..
 
 end
 
 lemma an_sds_automorphism_aux:
   assumes wf: "prefs_from_table_wf agents alts yss" "R \<equiv> prefs_from_table yss"
   assumes an: "an_sds agents alts sds"
   assumes eq: "mset (map ((map ((`) (permutation_of_list xs))) \<circ> snd) yss) = mset (map snd yss)"
   assumes perm: "set (map fst xs) \<subseteq> alts" "set (map snd xs) = set (map fst xs)" 
                 "distinct (map fst xs)" 
       and x: "x \<in> alts" "y = permutation_of_list xs x"
   shows   "pmf (sds R) x = pmf (sds R) y"
 proof -
   note perm = list_permutesI[OF perm]
   let ?\<sigma> = "permutation_of_list xs"
   note perm' = permutation_of_list_permutes [OF perm]
   from wf have wf': "pref_profile_wf agents alts R" by (simp add: pref_profile_from_tableI)
   then interpret R: pref_profile_wf agents alts R .
   from perm' interpret R': pref_profile_wf agents alts "permute_profile ?\<sigma> R"
     by (simp add: R.wf_permute_alts)
   from an interpret an_sds agents alts sds .
 
   from eq wf have eq': "image_mset (map ((`) ?\<sigma>)) (anonymous_profile R) = anonymous_profile R"
     by (simp add: anonymise_prefs_from_table mset_map multiset.map_comp)
   from perm' x have "pmf (sds R) x = pmf (map_pmf ?\<sigma> (sds R)) (?\<sigma> x)"
     by (simp add: pmf_map_inj' permutes_inj)
   also from eq' x wf' perm' have "map_pmf ?\<sigma> (sds R) = sds R"
     by (intro sds_automorphism) 
        (simp_all add: R.anonymous_profile_permute pref_profile_from_tableI)
   finally show ?thesis using x by simp
 qed
 
 
 subsection \<open>Ex-post efficiency\<close>
 
 locale ex_post_efficient_sds = social_decision_scheme agents alts sds
   for agents :: "'agent set" and alts :: "'alt set" and sds +
   assumes ex_post_efficient: 
     "is_pref_profile R \<Longrightarrow> set_pmf (sds R) \<inter> pareto_losers R = {}"
 begin
 
 lemma ex_post_efficient':
   assumes "is_pref_profile R" "y \<succ>[Pareto(R)] x"
   shows   "pmf (sds R) x = 0"
   using ex_post_efficient[of R] assms 
   by (auto simp: set_pmf_eq pareto_losers_def)
 
 lemma ex_post_efficient'':
   assumes "is_pref_profile R" "i \<in> agents"  "\<forall>i\<in>agents. y \<succeq>[R i] x" "\<not>y \<preceq>[R i] x"
   shows   "pmf (sds R) x = 0"
 proof -
   from assms(1) interpret pref_profile_wf agents alts R .
   from assms(2-) show ?thesis
     by (intro ex_post_efficient'[OF assms(1), of _ y])
        (auto simp: Pareto_iff strongly_preferred_def)
 qed
 
 end
 
 
 
 subsection \<open>SD efficiency\<close>
 
 text \<open>
   An SDS is SD-efficient if it returns an SD-efficient lottery for every 
   preference profile, i.e. if the SDS outputs a lottery, it is never the case 
   that there is another lottery that is weakly preferred by all agents an 
   strictly preferred by at least one agent.
 \<close>
 locale sd_efficient_sds = social_decision_scheme agents alts sds
   for agents :: "'agent set" and alts :: "'alt set" and sds +
   assumes SD_efficient: "is_pref_profile R \<Longrightarrow> SD_efficient R (sds R)"
 begin
 
 text \<open>
   An alternative formulation of SD-efficiency that is somewhat more convenient to use.
 \<close>
 lemma SD_efficient':
   assumes "is_pref_profile R" "q \<in> lotteries"
   assumes "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] sds R" "i \<in> agents" "q \<succ>[SD(R i)] sds R"
   shows   P
 proof -
   interpret pref_profile_wf agents alts R by fact
   show ?thesis
     using SD_efficient[of R] sds_wf[OF assms(1)] assms unfolding SD_efficient_def' by blast
 qed
 
 
 text \<open>
   Any SD-efficient SDS is also ex-post efficient.
 \<close>
 sublocale ex_post_efficient_sds
 proof unfold_locales
   fix R :: "('agent, 'alt) pref_profile" assume R_wf: "is_pref_profile R"
   interpret pref_profile_wf agents alts R by fact
   from R_wf show "set_pmf (sds R) \<inter> pareto_losers R = {}"
     by (intro SD_efficient_no_pareto_loser SD_efficient sds_wf)
 qed
 
 
 text \<open>
   The following rule can be used to derive facts from inefficient supports:
   If a set of alternatives is an inefficient support, at least one of the 
   alternatives in it must receive probability 0.
 \<close>
 lemma SD_inefficient_support:
   assumes A: "A \<noteq> {}" "A \<subseteq> alts" and inefficient: "\<not>SD_efficient R (pmf_of_set A)" 
   assumes wf: "is_pref_profile R" 
   shows   "\<exists>x\<in>A. pmf (sds R) x = 0"
 proof (rule ccontr)
   interpret pref_profile_wf agents alts R by fact
   assume "\<not>(\<exists>x\<in>A. pmf (sds R) x = 0)"
   with A have "set_pmf (pmf_of_set A) \<subseteq> set_pmf (sds R)"
      by (subst set_pmf_of_set) (auto simp: set_pmf_eq intro: finite_subset[OF _ finite_alts])
   from inefficient and this have "\<not>SD_efficient R (sds R)"
     by (rule SD_inefficient_support_subset) (simp add: wf sds_wf)
   moreover from SD_efficient wf have "SD_efficient R (sds R)" .
   ultimately show False by contradiction
 qed
 
 lemma SD_inefficient_support':
   assumes wf: "is_pref_profile R" 
   assumes A: "A \<noteq> {}" "A \<subseteq> alts" and 
      wit: "p \<in> lotteries" "\<forall>i\<in>agents. p \<succeq>[SD(R i)] pmf_of_set A" "i \<in> agents" 
           "\<not>p \<preceq>[SD(R i)] pmf_of_set A"
   shows   "\<exists>x\<in>A. pmf (sds R) x = 0"
 proof (rule SD_inefficient_support)
   from wf interpret pref_profile_wf agents alts R .
   from wit show "\<not>SD_efficient R (pmf_of_set A)"
     by (intro SD_inefficientI') (auto intro!: bexI[of _ i] simp: strongly_preferred_def)
 qed fact+
 
 end
 
 
 
 subsection \<open>Weak strategyproofness\<close>
 
 context social_decision_scheme
 begin
 
 text \<open>
   The SDS is said to be manipulable for a particular preference profile,
   a particular agent, and a particular alternative preference ordering for that agent
   if the lottery obtained if the agent submits the alternative preferences strictly 
   SD-dominates that obtained if the original preferences are submitted.
   (SD-dominated w.r.t. the original preferences)
 \<close>
 definition manipulable_profile 
     :: "('agent, 'alt) pref_profile \<Rightarrow> 'agent \<Rightarrow> 'alt relation \<Rightarrow> bool" where 
   "manipulable_profile R i Ri' \<longleftrightarrow> sds (R(i := Ri')) \<succ>[SD (R i)] sds R"
 
 end
 
 
 text \<open>
   An SDS is weakly strategyproof (or just strategyproof) if it is not manipulable 
   for any combination of preference profiles, agents, and alternative preference relations.
 \<close>
 locale strategyproof_sds = social_decision_scheme agents alts sds
   for agents :: "'agent set" and alts :: "'alt set" and sds +
   assumes strategyproof: 
     "is_pref_profile R \<Longrightarrow> i \<in> agents \<Longrightarrow> total_preorder_on alts Ri' \<Longrightarrow>
          \<not>manipulable_profile R i Ri'"  
 
 
 subsection \<open>Strong strategyproofness\<close>
 
 context social_decision_scheme
 begin
 
 text \<open>
   The SDS is said to be strongly strategyproof for a particular preference profile, 
   a particular agent, and a particular alternative preference ordering for that agent
   if the lottery obtained if the agent submits the alternative preferences is
   SD-dominated by the one obtained if the original preferences are submitted.
   (SD-dominated w.r.t. the original preferences)
   
   In other words: the SDS is strategyproof w.r.t the preference profile $R$ and 
   the agent $i$ and the alternative preference relation $R_i'$ if the lottery for 
   obtained for $R$ is at least as good for $i$ as the lottery obtained when $i$ 
   misrepresents her preferences as $R_i'$.
 \<close>
 definition strongly_strategyproof_profile 
     :: "('agent, 'alt) pref_profile \<Rightarrow> 'agent \<Rightarrow> 'alt relation \<Rightarrow> bool" where
   "strongly_strategyproof_profile R i Ri' \<longleftrightarrow> sds R \<succeq>[SD (R i)] sds (R(i := Ri'))"
 
 lemma strongly_strategyproof_profileI [intro]:
   assumes "is_pref_profile R" "total_preorder_on alts Ri'" "i \<in> agents"
   assumes "\<And>x. x \<in> alts \<Longrightarrow> lottery_prob (sds (R(i := Ri'))) (preferred_alts (R i) x)
                                \<le> lottery_prob (sds R) (preferred_alts (R i) x)"
   shows "strongly_strategyproof_profile R i Ri'"
 proof -
   interpret pref_profile_wf agents alts R by fact
   show ?thesis
     unfolding strongly_strategyproof_profile_def
     by rule (auto intro!: sds_wf assms pref_profile_wf.wf_update)
 qed
 
 lemma strongly_strategyproof_imp_not_manipulable:
   assumes "strongly_strategyproof_profile R i Ri'"
   shows   "\<not>manipulable_profile R i Ri'"
   using assms unfolding strongly_strategyproof_profile_def manipulable_profile_def
   by (auto simp: strongly_preferred_def)
 
 end
 
 
 text \<open>
   An SDS is strongly strategyproof if it is strongly strategyproof for all combinations
   of preference profiles, agents, and alternative preference relations.
 \<close>
 locale strongly_strategyproof_sds = social_decision_scheme agents alts sds
   for agents :: "'agent set" and alts :: "'alt set" and sds +
   assumes strongly_strategyproof: 
     "is_pref_profile R \<Longrightarrow> i \<in> agents \<Longrightarrow> total_preorder_on alts Ri' \<Longrightarrow>
          strongly_strategyproof_profile R i Ri'"
 begin
 
 text \<open>
   Any SDS that is strongly strategyproof is also weakly strategyproof.
 \<close>
 sublocale strategyproof_sds
   by unfold_locales
      (simp add: strongly_strategyproof_imp_not_manipulable strongly_strategyproof)
 
 end
 
 
 locale strategyproof_an_sds =
   strategyproof_sds agents alts sds + an_sds agents alts sds
   for agents :: "'agent set" and alts :: "'alt set" and sds
 
 end
diff --git a/thys/Randomised_Social_Choice/Stochastic_Dominance.thy b/thys/Randomised_Social_Choice/Stochastic_Dominance.thy
--- a/thys/Randomised_Social_Choice/Stochastic_Dominance.thy
+++ b/thys/Randomised_Social_Choice/Stochastic_Dominance.thy
@@ -1,530 +1,537 @@
 section \<open>Stochastic Dominance\<close>
 
 theory Stochastic_Dominance
 imports
   Complex_Main
   "HOL-Probability.Probability"
   Lotteries
   Preference_Profiles
   Utility_Functions
 begin
 
 subsection \<open>Definition of Stochastic Dominance\<close>
 
 text \<open>
   This is the definition of stochastic dominance. It lifts a preference relation
   on alternatives to the stochastic dominance ordering on lotteries.
 \<close>
 definition SD :: "'alt relation \<Rightarrow> 'alt lottery relation" where
   "p \<succeq>[SD(R)] q \<longleftrightarrow> p \<in> lotteries_on {x. R x x} \<and> q \<in> lotteries_on {x. R x x} \<and>
       (\<forall>x. R x x \<longrightarrow> measure_pmf.prob p {y. y \<succeq>[R] x} \<ge>
                        measure_pmf.prob q {y. y \<succeq>[R] x})"
 
 lemma SD_empty [simp]: "SD (\<lambda>_ _. False) = (\<lambda>_ _. False)"
   by (auto simp: fun_eq_iff SD_def lotteries_on_def set_pmf_not_empty)
 
 text \<open>
   Stochastic dominance over any relation is a preorder.
 \<close>
 lemma SD_refl: "p \<preceq>[SD(R)] p \<longleftrightarrow> p \<in> lotteries_on {x. R x x}"
   by (simp add: SD_def)
 
 lemma SD_trans [simp, trans]: "p \<preceq>[SD(R)] q \<Longrightarrow> q \<preceq>[SD(R)] r \<Longrightarrow> p \<preceq>[SD(R)] r"
   unfolding SD_def by (auto intro: order.trans)
 
 lemma SD_is_preorder: "preorder_on (lotteries_on {x. R x x}) (SD R)"
   by unfold_locales (auto simp: SD_def intro: order.trans)
 
 context preorder_on
 begin
 
 lemma SD_preorder:
    "p \<succeq>[SD(le)] q \<longleftrightarrow> p \<in> lotteries_on carrier \<and> q \<in> lotteries_on carrier \<and>
       (\<forall>x\<in>carrier. measure_pmf.prob p (preferred_alts le x) \<ge>
                      measure_pmf.prob q (preferred_alts le x))"
   by (simp add: SD_def preferred_alts_def carrier_eq)
 
 lemma SD_preorderI [intro?]:
   assumes "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
   assumes "\<And>x. x \<in> carrier \<Longrightarrow>
              measure_pmf.prob p (preferred_alts le x) \<ge> measure_pmf.prob q (preferred_alts le x)"
   shows   "p \<succeq>[SD(le)] q"
   using assms by (simp add: SD_preorder)
 
 lemma SD_preorderD:
   assumes "p \<succeq>[SD(le)] q"
   shows   "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
   and      "\<And>x. x \<in> carrier \<Longrightarrow>
              measure_pmf.prob p (preferred_alts le x) \<ge> measure_pmf.prob q (preferred_alts le x)"
   using assms unfolding SD_preorder by simp_all
 
 lemma SD_refl' [simp]: "p \<preceq>[SD(le)] p \<longleftrightarrow> p \<in> lotteries_on carrier"
   by (simp add: SD_def carrier_eq)
 
 lemma SD_is_preorder': "preorder_on (lotteries_on carrier) (SD(le))"
   using SD_is_preorder[of le] by (simp add: carrier_eq)
 
 lemma SD_singleton_left:
   assumes "x \<in> carrier" "q \<in> lotteries_on carrier"
   shows   "return_pmf x \<preceq>[SD(le)] q \<longleftrightarrow> (\<forall>y\<in>set_pmf q. x \<preceq>[le] y)"
 proof
   assume SD: "return_pmf x \<preceq>[SD(le)] q"
   from assms SD_preorderD(3)[OF SD, of x]
     have "measure_pmf.prob (return_pmf x) (preferred_alts le x) \<le>
             measure_pmf.prob q (preferred_alts le x)" by simp
   also from assms have "measure_pmf.prob (return_pmf x) (preferred_alts le x) = 1"
     by (simp add: indicator_def)
   finally have "AE y in q. y \<succeq>[le] x"
     by (simp add: measure_pmf.measure_ge_1_iff measure_pmf.prob_eq_1 preferred_alts_def)
   thus "\<forall>y\<in>set_pmf q. y \<succeq>[le] x" by (simp add: AE_measure_pmf_iff)
 next
   assume A: "\<forall>y\<in>set_pmf q. x \<preceq>[le] y"
   show "return_pmf x \<preceq>[SD(le)] q"
   proof (rule SD_preorderI)
     fix y assume y: "y \<in> carrier"
     show "measure_pmf.prob (return_pmf x) (preferred_alts le y)
               \<le> measure_pmf.prob q (preferred_alts le y)"
     proof (cases "y \<preceq>[le] x")
       case True
       from True A have "measure_pmf.prob q (preferred_alts le y) = 1"
         by (auto simp: AE_measure_pmf_iff measure_pmf.prob_eq_1 preferred_alts_def intro: trans)
       thus ?thesis by simp
     qed (simp_all add: preferred_alts_def indicator_def measure_nonneg)
   qed (insert assms, simp_all add: lotteries_on_def)
 qed
 
 lemma SD_singleton_right:
   assumes x: "x \<in> carrier" and q: "q \<in> lotteries_on carrier"
   shows   "q \<preceq>[SD(le)] return_pmf x \<longleftrightarrow> (\<forall>y\<in>set_pmf q. y \<preceq>[le] x)"
 proof safe
   fix y assume SD: "q \<preceq>[SD(le)] return_pmf x" and y: "y \<in> set_pmf q"
   from y assms have [simp]: "y \<in> carrier" by (auto simp: lotteries_on_def)
 
   from y have "0 < measure_pmf.prob q (preferred_alts le y)"
     by (rule measure_pmf_posI) simp_all
   also have "\<dots> \<le> measure_pmf.prob (return_pmf x) (preferred_alts le y)"
     by (rule SD_preorderD(3)[OF SD]) simp_all
   finally show "y \<preceq>[le] x"
     by (auto simp: indicator_def preferred_alts_def split: if_splits)
 next
   assume A: "\<forall>y\<in>set_pmf q. y \<preceq>[le] x"
   show "q \<preceq>[SD(le)] return_pmf x"
   proof (rule SD_preorderI)
     fix y assume y: "y \<in> carrier"
     show "measure_pmf.prob q (preferred_alts le y) \<le>
             measure_pmf.prob (return_pmf x) (preferred_alts le y)"
     proof (cases "y \<preceq>[le] x")
       case False
       with A show ?thesis
         by (auto simp: preferred_alts_def indicator_def measure_le_0_iff
                        measure_pmf.prob_eq_0 AE_measure_pmf_iff intro: trans)
     qed (simp_all add: indicator_def preferred_alts_def)
   qed (insert assms, simp_all add: lotteries_on_def)
 qed
 
 lemma SD_strict_singleton_left:
   assumes "x \<in> carrier" "q \<in> lotteries_on carrier"
   shows   "return_pmf x \<prec>[SD(le)] q \<longleftrightarrow> (\<forall>y\<in>set_pmf q. x \<preceq>[le] y) \<and> (\<exists>y\<in>set_pmf q. (x \<prec>[le] y))"
   using assms by (auto simp add: strongly_preferred_def SD_singleton_left SD_singleton_right)
 
 lemma SD_strict_singleton_right:
   assumes "x \<in> carrier" "q \<in> lotteries_on carrier"
   shows   "q \<prec>[SD(le)] return_pmf x \<longleftrightarrow> (\<forall>y\<in>set_pmf q. y \<preceq>[le] x) \<and> (\<exists>y\<in>set_pmf q. (y \<prec>[le] x))"
   using assms by (auto simp add: strongly_preferred_def SD_singleton_left SD_singleton_right)
 
 lemma SD_singleton [simp]:
   "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> return_pmf x \<preceq>[SD(le)] return_pmf y \<longleftrightarrow> x \<preceq>[le] y"
   by (subst SD_singleton_left) (simp_all add: lotteries_on_def)
 
 lemma SD_strict_singleton [simp]:
   "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> return_pmf x \<prec>[SD(le)] return_pmf y \<longleftrightarrow> x \<prec>[le] y"
   by (simp add: strongly_preferred_def)
 
 end
 
 context pref_profile_wf
 begin
 
 context
 fixes i assumes i: "i \<in> agents"
 begin
 
 interpretation Ri: preorder_on alts "R i" by (simp add: i)
 
 lemmas SD_singleton_left = Ri.SD_singleton_left
 lemmas SD_singleton_right = Ri.SD_singleton_right
 lemmas SD_strict_singleton_left = Ri.SD_strict_singleton_left
 lemmas SD_strict_singleton_right = Ri.SD_strict_singleton_right
 lemmas SD_singleton = Ri.SD_singleton
 lemmas SD_strict_singleton = Ri.SD_strict_singleton
 
 end
 end
 
 lemmas (in pref_profile_wf) [simp] = SD_singleton SD_strict_singleton
 
 
 subsection \<open>Stochastic Dominance for preference profiles\<close>
 
 context pref_profile_wf
 begin
 
 lemma SD_pref_profile:
   assumes "i \<in> agents"
   shows   "p \<succeq>[SD(R i)] q \<longleftrightarrow> p \<in> lotteries_on alts \<and> q \<in> lotteries_on alts \<and>
              (\<forall>x\<in>alts. measure_pmf.prob p (preferred_alts (R i) x) \<ge>
                          measure_pmf.prob q (preferred_alts (R i) x))"
 proof -
   from assms interpret total_preorder_on alts "R i" by simp
   have "preferred_alts (R i) x = {y. y \<succeq>[R i] x}" for x using not_outside
     by (auto simp: preferred_alts_def)
   thus ?thesis by (simp add: SD_preorder preferred_alts_def)
 qed
 
 lemma SD_pref_profileI [intro?]:
   assumes "i \<in> agents" "p \<in> lotteries_on alts" "q \<in> lotteries_on alts"
   assumes "\<And>x. x \<in> alts \<Longrightarrow>
              measure_pmf.prob p (preferred_alts (R i) x) \<ge>
              measure_pmf.prob q (preferred_alts (R i) x)"
   shows   "p \<succeq>[SD(R i)] q"
   using assms by (simp add: SD_pref_profile)
 
 lemma SD_pref_profileD:
   assumes "i \<in> agents" "p \<succeq>[SD(R i)] q"
   shows   "p \<in> lotteries_on alts" "q \<in> lotteries_on alts"
   and     "\<And>x. x \<in> alts \<Longrightarrow>
              measure_pmf.prob p (preferred_alts (R i) x) \<ge>
              measure_pmf.prob q (preferred_alts (R i) x)"
   using assms by (simp_all add: SD_pref_profile)
 
 end
 
 
 subsection \<open>SD efficient lotteries\<close>
 
 definition SD_efficient :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt lottery \<Rightarrow> bool" where
   SD_efficient_auxdef:
     "SD_efficient R p \<longleftrightarrow> \<not>(\<exists>q\<in>lotteries_on {x. \<exists>i. R i x x}. q \<succ>[Pareto (SD \<circ> R)] p)"
 
 context pref_profile_wf
 begin
 
 sublocale SD: preorder_family agents "lotteries_on alts" "SD \<circ> R" unfolding o_def
   by (intro preorder_family.intro SD_is_preorder)
      (simp_all add: preorder_on.SD_is_preorder' prefs_undefined')
 
 text \<open>
   A lottery is considered SD-efficient if there is no other lottery such that
   all agents weakly prefer the other lottery (w.r.t. stochastic dominance) and at least
   one agent strongly prefers the other lottery.
 \<close>
 lemma SD_efficient_def:
   "SD_efficient R p \<longleftrightarrow> \<not>(\<exists>q\<in>lotteries_on alts. q \<succ>[Pareto (SD \<circ> R)] p)"
 proof -
   have "SD_efficient R p \<longleftrightarrow> \<not>(\<exists>q\<in>lotteries_on {x. \<exists>i. R i x x}. q \<succ>[Pareto (SD \<circ> R)] p)"
     unfolding SD_efficient_auxdef ..
   also from nonempty_agents obtain i where i: "i \<in> agents" by blast
   with preorder_on.refl[of alts "R i"]
     have "{x. \<exists>i. R i x x} = alts" by (auto intro!: exI[of _ i] not_outside)
   finally show ?thesis .
 qed
 
 
 lemma SD_efficient_def':
   "SD_efficient R p \<longleftrightarrow>
      \<not>(\<exists>q\<in>lotteries_on alts. (\<forall>i\<in>agents. q \<succeq>[SD(R i)] p) \<and> (\<exists>i\<in>agents. q \<succ>[SD(R i)] p))"
   unfolding SD_efficient_def SD.Pareto_iff strongly_preferred_def [abs_def] by auto
 
 lemma SD_inefficientI:
   assumes "q \<in> lotteries_on alts" "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] p"
           "i \<in> agents" "q \<succ>[SD(R i)] p"
   shows   "\<not>SD_efficient R p"
   using assms unfolding SD_efficient_def' by blast
 
 lemma SD_inefficientI':
   assumes "q \<in> lotteries_on alts" "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] p"
           "\<exists>i \<in> agents. q \<succ>[SD(R i)] p"
   shows   "\<not>SD_efficient R p"
   using assms unfolding SD_efficient_def' by blast
 
 lemma SD_inefficientE:
   assumes "\<not>SD_efficient R p"
   obtains q i where
     "q \<in> lotteries_on alts" "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] p"
     "i \<in> agents" "q \<succ>[SD(R i)] p"
   using assms unfolding SD_efficient_def' by blast
 
 lemma SD_efficientD:
   assumes "SD_efficient R p" "q \<in> lotteries_on alts"
       and "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] p" "\<exists>i\<in>agents. \<not>(q \<preceq>[SD(R i)] p)"
   shows False
   using assms unfolding SD_efficient_def' strongly_preferred_def by blast
 
 lemma SD_efficient_singleton_iff:
   assumes [simp]: "x \<in> alts"
   shows   "SD_efficient R (return_pmf x) \<longleftrightarrow> x \<notin> pareto_losers R"
 proof -
   {
-    assume x: "x \<in> pareto_losers R"
-    from pareto_losersE[OF x] guess y . note y = this
-    from y have "\<not>SD_efficient R (return_pmf x)"
+    assume "x \<in> pareto_losers R"
+    then obtain y where "y \<in> alts" "x \<prec>[Pareto R] y"
+      by (rule pareto_losersE)
+    then have "\<not>SD_efficient R (return_pmf x)"
       by (intro SD_inefficientI'[of "return_pmf y"]) (force simp: Pareto_strict_iff)+
   } moreover {
     assume "\<not>SD_efficient R (return_pmf x)"
-    from SD_inefficientE[OF this] guess q i . note q = this
-    moreover from q obtain y where "y \<in> set_pmf q" "y \<succ>[R i] x"
+    from SD_inefficientE[OF this] obtain q i
+      where q:
+        "q \<in> lotteries_on alts"
+        "\<And>i. i \<in> agents \<Longrightarrow> SD (R i) (return_pmf x) q"
+        "i \<in> agents"
+        "return_pmf x \<prec>[SD (R i)] q"
+      by blast
+    from q obtain y where "y \<in> set_pmf q" "y \<succ>[R i] x"
       by (auto simp: SD_strict_singleton_left)
-    ultimately have "y \<succ>[Pareto(R)] x"
+    with q have "y \<succ>[Pareto(R)] x"
       by (fastforce simp: Pareto_strict_iff SD_singleton_left)
     hence "x \<in> pareto_losers R" by simp
   }
   ultimately show ?thesis by blast
 qed
 
 end
 
 
 subsection \<open>Equivalence proof\<close>
 
 text \<open>
   We now show that a lottery is preferred w.r.t. Stochastic Dominance iff
   it yields more expected utility for all compatible utility functions.
 \<close>
 
 context finite_total_preorder_on
 begin
 
 abbreviation "is_vnm_utility \<equiv> vnm_utility carrier le"
 
 lemma utility_weak_ranking_index:
   "is_vnm_utility (\<lambda>x. real (length (weak_ranking le) - weak_ranking_index x))"
 proof
   fix x y assume xy: "x \<in> carrier" "y \<in> carrier"
   with this[THEN nth_weak_ranking_index(1)] this[THEN nth_weak_ranking_index(2)]
     show "(real (length (weak_ranking le) - weak_ranking_index x)
             \<le> real (length (weak_ranking le) - weak_ranking_index y)) \<longleftrightarrow> le x y"
     by (simp add: le_diff_iff')
 qed
 
 (*
   TODO: one direction could probably be generalised to weakly consistent
   utility functions
 *)
 lemma SD_iff_expected_utilities_le:
   assumes "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
   shows   "p \<preceq>[SD(le)] q \<longleftrightarrow>
              (\<forall>u. is_vnm_utility u \<longrightarrow> measure_pmf.expectation p u \<le> measure_pmf.expectation q u)"
 proof safe
   fix u assume SD: "p \<preceq>[SD(le)] q" and is_utility: "is_vnm_utility u"
   from is_utility interpret vnm_utility carrier le u .
   define xs where "xs = weak_ranking le"
   have le: "is_weak_ranking xs" "le = of_weak_ranking xs"
     by (simp_all add: xs_def weak_ranking_total_preorder)
 
   let ?pref = "\<lambda>p x. measure_pmf.prob p {y. x \<preceq>[le] y}" and
       ?pref' = "\<lambda>p x. measure_pmf.prob p {y. x \<prec>[le] y}"
   define f where "f i = (SOME x. x \<in> xs ! i)" for i
   have xs_wf: "is_weak_ranking xs"
     by (simp add: xs_def weak_ranking_total_preorder)
   hence f: "f i \<in> xs ! i" if "i < length xs" for i
     using that unfolding f_def is_weak_ranking_def
     by (intro someI_ex[of "\<lambda>x. x \<in> xs ! i"]) (auto simp: set_conv_nth)
   have f': "f i \<in> carrier" if "i < length xs" for i
     using that f weak_ranking_Union unfolding xs_def by (auto simp: set_conv_nth)
   define n where "n = length xs - 1"
   from assms weak_ranking_Union have carrier_nonempty: "carrier \<noteq> {}" and "xs \<noteq> []"
     by (auto simp: xs_def lotteries_on_def set_pmf_not_empty)
   hence n: "length xs = Suc n" and xs_nonempty: "xs \<noteq> []" by (auto simp add: n_def)
   have SD': "?pref p (f i) \<le> ?pref q (f i)" if "i < length xs" for i
     using f'[OF that] SD by (auto simp: SD_preorder preferred_alts_def)
   have f_le: "le (f i) (f j) \<longleftrightarrow> i \<ge> j" if "i < length xs" "j < length xs" for i j
     using that weak_ranking_index_unique[OF xs_wf that(1) _ f]
                weak_ranking_index_unique[OF xs_wf that(2) _ f]
     by (auto simp add: le intro: f elim!: of_weak_ranking.cases intro!: of_weak_ranking.intros)
 
   have "measure_pmf.expectation p u =
           (\<Sum>i<n. (u (f i) - u (f (Suc i))) * ?pref p (f i)) + u (f n)"
     if p: "p \<in> lotteries_on carrier" for p
   proof -
     from p have "measure_pmf.expectation p u =
                    (\<Sum>i<length xs. u (f i) * measure_pmf.prob p (xs ! i))"
       by (simp add: f_def expected_utility_weak_ranking xs_def sum_list_sum_nth atLeast0LessThan)
     also have "\<dots> = (\<Sum>i<length xs. u (f i) * (?pref p (f i) - ?pref' p (f i)))"
     proof (intro sum.cong HOL.refl)
       fix i assume i: "i \<in> {..<length xs}"
       have "?pref p (f i) - ?pref' p (f i) =
               measure_pmf.prob p ({y. f i \<preceq>[le] y} - {y. f i \<prec>[le] y})"
         by (subst measure_pmf.finite_measure_Diff [symmetric])
            (auto simp: strongly_preferred_def)
       also have "{y. f i \<preceq>[le] y} - {y. f i \<prec>[le] y} =
                    {y. f i \<preceq>[le] y \<and> y \<preceq>[le] f i}" (is "_ = ?A")
         by (auto simp: strongly_preferred_def)
       also have "\<dots> = xs ! i"
       proof safe
         fix x assume le: "le (f i) x" "le x (f i)"
         from i f show "x \<in> xs ! i"
           by (intro weak_ranking_eqclass2[OF _ _ le]) (auto simp: xs_def)
       next
         fix x assume "x \<in> xs ! i"
         from weak_ranking_eqclass1[OF _ this f] weak_ranking_eqclass1[OF _ f this] i
           show "le x (f i)" "le (f i) x" by (simp_all add: xs_def)
       qed
       finally show "u (f i) * measure_pmf.prob p (xs ! i) =
                       u (f i) * (?pref p (f i) - ?pref' p (f i))" by simp
     qed
     also have "\<dots> = (\<Sum>i<length xs. u (f i) * ?pref p (f i)) -
                       (\<Sum>i<length xs. u (f i) * ?pref' p (f i))"
       by (simp add: sum_subtractf ring_distribs)
     also have "(\<Sum>i<length xs. u (f i) * ?pref p (f i)) =
                  (\<Sum>i<n. u (f i) * ?pref p (f i)) + u (f n) * ?pref p (f n)" (is "_ = ?sum")
       by (simp add: n)
     also have "(\<Sum>i<length xs. u (f i) * ?pref' p (f i)) =
                  (\<Sum>i<n. u (f (Suc i)) * ?pref' p (f (Suc i))) + u (f 0) * ?pref' p (f 0)"
       unfolding n sum.lessThan_Suc_shift by simp
     also have "(\<Sum>i<n. u (f (Suc i)) * ?pref' p (f (Suc i))) =
                  (\<Sum>i<n. u (f (Suc i)) * ?pref p (f i))"
     proof (intro sum.cong HOL.refl)
       fix i assume i: "i \<in> {..<n}"
       have "f (Suc i) \<prec>[le] y \<longleftrightarrow> f i \<preceq>[le] y" for y
       proof (cases "y \<in> carrier")
         assume "y \<in> carrier"
         with weak_ranking_Union obtain j where j: "j < length xs" "y \<in> xs ! j"
           by (auto simp: set_conv_nth xs_def)
         with weak_ranking_eqclass1[OF _ f j(2)] weak_ranking_eqclass1[OF _ j(2) f]
           have iff: "le y z \<longleftrightarrow> le (f j) z" "le z y \<longleftrightarrow> le z (f j)" for z
           by (auto intro: trans simp: xs_def)
         thus ?thesis using i j unfolding n_def
           by (auto simp: iff f_le strongly_preferred_def)
       qed (insert not_outside, auto simp: strongly_preferred_def)
       thus "u (f (Suc i)) * ?pref' p (f (Suc i)) = u (f (Suc i)) * ?pref p (f i)" by simp
     qed
     also have "?sum - (\<dots> + u (f 0) * ?pref' p (f 0)) =
       (\<Sum>i<n. (u (f i) - u (f (Suc i))) * ?pref p (f i)) -
        u (f 0) * ?pref' p (f 0) + u (f n) * ?pref p (f n)"
          by (simp add: ring_distribs sum_subtractf)
     also have "{y. f 0 \<prec>[le] y} = {}"
       using hd_weak_ranking[of "f 0"] xs_nonempty f not_outside
       by (auto simp: hd_conv_nth xs_def strongly_preferred_def)
     also have "{y. le (f n) y} = carrier"
       using last_weak_ranking[of "f n"] xs_nonempty f not_outside
       by (auto simp: last_conv_nth xs_def n_def)
     also from p have "measure_pmf.prob p carrier = 1"
       by (subst measure_pmf.prob_eq_1)
          (auto simp: AE_measure_pmf_iff lotteries_on_def)
     finally show ?thesis by simp
   qed
 
   from assms[THEN this] show "measure_pmf.expectation p u \<le> measure_pmf.expectation q u"
     unfolding SD_preorder n_def using f'
     by (auto intro!: sum_mono mult_left_mono SD' simp: utility_le_iff f_le)
 
 next
   assume "\<forall>u. is_vnm_utility u \<longrightarrow> measure_pmf.expectation p u \<le> measure_pmf.expectation q u"
   hence expected_utility_le: "measure_pmf.expectation p u \<le> measure_pmf.expectation q u"
     if "is_vnm_utility u" for u using that by blast
   define xs where "xs = weak_ranking le"
   have le: "le = of_weak_ranking xs" and [simp]: "is_weak_ranking xs"
     by (simp_all add: xs_def weak_ranking_total_preorder)
   have carrier: "carrier = \<Union>(set xs)"
     by (simp add: xs_def weak_ranking_Union)
   from assms have carrier_nonempty: "carrier \<noteq> {}"
     by (auto simp: lotteries_on_def set_pmf_not_empty)
 
   {
     fix x assume x: "x \<in> carrier"
     let ?idx = "\<lambda>y. length xs - weak_ranking_index y"
     have preferred_subset_carrier: "{y. le x y} \<subseteq> carrier"
       using not_outside x by auto
     have "measure_pmf.prob p {y. le x y} / real (length xs) \<le>
              measure_pmf.prob q {y. le x y} / real (length xs)"
     proof (rule field_le_epsilon)
       fix \<epsilon> :: real assume \<epsilon>: "\<epsilon> > 0"
       define u where "u y = indicator {y. y \<succeq>[le] x} y + \<epsilon> * ?idx y" for y
       have is_utility: "is_vnm_utility u" unfolding u_def xs_def
       proof (intro vnm_utility.add_left vnm_utility.scaled utility_weak_ranking_index)
         fix y z assume "le y z"
         thus "indicator {y. y \<succeq>[le] x} y \<le> (indicator {y. y \<succeq>[le] x} z :: real)"
           by (auto intro: trans simp: indicator_def split: if_splits)
       qed fact+
 
       have "(\<Sum>y|le x y. pmf p y) \<le>
               (\<Sum>y|le x y. pmf p y) + \<epsilon> * (\<Sum>y\<in>carrier. ?idx y * pmf p y)"
         using \<epsilon> by (auto intro!: mult_nonneg_nonneg sum_nonneg pmf_nonneg)
       also from expected_utility_le is_utility have
         "measure_pmf.expectation p u \<le> measure_pmf.expectation q u" .
       with assms
         have "(\<Sum>a\<in>carrier. u a * pmf p a) \<le> (\<Sum>a\<in>carrier. u a * pmf q a)"
         by (subst (asm) (1 2) integral_measure_pmf[OF finite_carrier])
            (auto simp: lotteries_on_def set_pmf_eq ac_simps)
       hence "(\<Sum>y|le x y. pmf p y) + \<epsilon> * (\<Sum>y\<in>carrier. ?idx y * pmf p y) \<le>
              (\<Sum>y|le x y. pmf q y) + \<epsilon> * (\<Sum>y\<in>carrier. ?idx y * pmf q y)"
         using x preferred_subset_carrier not_outside
         by (simp add: u_def sum.distrib finite_carrier algebra_simps sum_distrib_left Int_absorb1 cong: rev_conj_cong)
       also have "(\<Sum>y\<in>carrier. ?idx y * pmf q y) \<le> (\<Sum>y\<in>carrier. length xs * pmf q y)"
         by (intro sum_mono mult_right_mono) (simp_all add: pmf_nonneg)
       also have "\<dots> = measure_pmf.expectation q (\<lambda>_. length xs)"
         using assms by (subst integral_measure_pmf[OF finite_carrier])
                        (auto simp: lotteries_on_def set_pmf_eq ac_simps)
       also have "\<dots> = length xs" by simp
       also have "(\<Sum>y | le x y. pmf p y) = measure_pmf.prob p {y. le x y}"
         using finite_subset[OF preferred_subset_carrier finite_carrier]
         by (simp add: measure_measure_pmf_finite)
       also have "(\<Sum>y | le x y. pmf q y) = measure_pmf.prob q {y. le x y}"
         using finite_subset[OF preferred_subset_carrier finite_carrier]
         by (simp add: measure_measure_pmf_finite)
       finally show "measure_pmf.prob p {y. le x y} / length xs \<le>
                       measure_pmf.prob q {y. le x y} / length xs + \<epsilon>"
         using \<epsilon> by (simp add: divide_simps)
     qed
     moreover from carrier_nonempty carrier have "xs \<noteq> []" by auto
     ultimately have "measure_pmf.prob p {y. le x y} \<le>
                        measure_pmf.prob q {y. le x y}"
       by (simp add: field_simps)
   }
   with assms show "p \<preceq>[SD(le)] q" unfolding SD_preorder preferred_alts_def by blast
 qed
 
 lemma not_strict_SD_iff:
   assumes "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
   shows   "\<not>(p \<prec>[SD(le)] q) \<longleftrightarrow>
              (\<exists>u. is_vnm_utility u \<and> measure_pmf.expectation q u \<le> measure_pmf.expectation p u)"
 proof
   let ?E = "measure_pmf.expectation :: 'a pmf \<Rightarrow> _ \<Rightarrow> real"
   assume "\<exists>u. is_vnm_utility u \<and> ?E p u \<ge> ?E q u"
   then obtain u where u: "is_vnm_utility u" "?E p u \<ge> ?E q u" by blast
   interpret u: vnm_utility carrier le u by fact
 
   show "\<not> p \<prec>[SD le] q"
   proof
     assume less: "p \<prec>[SD le] q"
     with assms have pq: "?E p u \<le> ?E q u" if "is_vnm_utility u" for u
       using that by (auto simp: SD_iff_expected_utilities_le strongly_preferred_def)
     with u have u_eq: "?E p u = ?E q u" by (intro antisym) simp_all
     from less assms obtain u' where u': "is_vnm_utility u'" "?E p u' < ?E q u'"
       by (auto simp: SD_iff_expected_utilities_le strongly_preferred_def not_le)
     interpret u': vnm_utility carrier le u' by fact
 
     have "\<exists>\<epsilon>>0. is_vnm_utility (\<lambda>x. u x - \<epsilon> * u' x)"
       by (intro u.diff_epsilon antisym u'.utility_le)
-    then guess \<epsilon> by (elim exE conjE) note \<epsilon> = this
+    then obtain \<epsilon> where \<epsilon>: "\<epsilon> > 0" "is_vnm_utility (\<lambda>x. u x - \<epsilon> * u' x)" by auto
     define u'' where "u'' x = u x - \<epsilon> * u' x" for x
     interpret u'': vnm_utility carrier le u'' unfolding u''_def by fact
     have exp_u'': "?E p u'' = ?E p u - \<epsilon> * ?E p u'" if "p \<in> lotteries_on carrier" for p using that
       by (subst (1 2 3) integral_measure_pmf[of carrier])
          (auto simp: lotteries_on_def u''_def algebra_simps sum_subtractf sum_distrib_left)
     from assms \<epsilon> have "?E p u'' > ?E q u''"
       by (simp_all add: exp_u'' algebra_simps u_eq u')
     with pq[OF u''.vnm_utility_axioms] show False by simp
   qed
 qed (insert assms utility_weak_ranking_index,
      auto simp: strongly_preferred_def SD_iff_expected_utilities_le not_le not_less intro: antisym)
 
 lemma strict_SD_iff:
   assumes "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
   shows   "(p \<prec>[SD(le)] q) \<longleftrightarrow>
              (\<forall>u. is_vnm_utility u \<longrightarrow> measure_pmf.expectation p u < measure_pmf.expectation q u)"
   using not_strict_SD_iff[OF assms] by auto
 
 end
 
 end
diff --git a/thys/Routing/ROOT b/thys/Routing/ROOT
--- a/thys/Routing/ROOT
+++ b/thys/Routing/ROOT
@@ -1,12 +1,14 @@
 chapter AFP
 
 session Routing (AFP) = Simple_Firewall +
   options [timeout = 300]
+  sessions
+    "Pure-ex"
   theories
     Routing_Table
     Linux_Router
     IpRoute_Parser
     Linorder_Helper
     (*Dependencies: RoutingIpAssmt depends on Iptables_Semantics and is thus in another session*)
   document_files
     "root.tex"
diff --git a/thys/Routing/Routing_Table.thy b/thys/Routing/Routing_Table.thy
--- a/thys/Routing/Routing_Table.thy
+++ b/thys/Routing/Routing_Table.thy
@@ -1,503 +1,504 @@
 section\<open>Routing Table\<close>
 theory Routing_Table
 imports IP_Addresses.Prefix_Match
         IP_Addresses.IPv4 IP_Addresses.IPv6
         Linorder_Helper
         IP_Addresses.Prefix_Match_toString
+        "Pure-ex.Guess"
 begin
 
 text\<open>This section makes the necessary definitions to work with a routing table using longest prefix matching.\<close>
 subsection\<open>Definition\<close>
 
 record(overloaded) 'i routing_action = 
   output_iface :: string
   next_hop :: "'i word option" (* no next hop iff locally attached *)
 
 (* Routing rule matching ip route unicast type *)
 record(overloaded) 'i routing_rule =
   routing_match :: "('i::len) prefix_match" (* done on the dst *)
   metric :: nat
   routing_action :: "'i routing_action"
 
 text\<open>This definition is engineered to model routing tables on packet forwarding devices.
 It eludes, e.g., the source address hint, which is only relevant for packets originating from the device itself.\<close>
 (* See also: http://linux-ip.net/html/routing-saddr-selection.html *)
 
 context
 begin
 
 definition "default_metric = 0"
 
 type_synonym 'i prefix_routing = "('i routing_rule) list"
 
 abbreviation "routing_oiface a \<equiv> output_iface (routing_action a)" (* I needed this a lot... *)
 abbreviation "routing_prefix r \<equiv> pfxm_length (routing_match r)"
 
 definition valid_prefixes where
   "valid_prefixes r = foldr conj (map (\<lambda>rr. valid_prefix (routing_match rr)) r) True"
 lemma valid_prefixes_split: "valid_prefixes (r#rs) \<Longrightarrow> valid_prefix (routing_match r) \<and> valid_prefixes rs"
   using valid_prefixes_def by force
 
 lemma foldr_True_set: "foldr (\<lambda>x. (\<and>) (f x)) l True = (\<forall>x \<in> set l. f x)"
   by (induction l) simp_all
 lemma valid_prefixes_alt_def: "valid_prefixes r = (\<forall>e \<in> set r. valid_prefix (routing_match e))"
   unfolding valid_prefixes_def
   unfolding foldr_map
   unfolding comp_def
   unfolding foldr_True_set
   ..
   
 fun has_default_route :: "('i::len) prefix_routing \<Rightarrow> bool" where
 "has_default_route (r#rs) = (((pfxm_length (routing_match r)) = 0) \<or> has_default_route rs)" |
 "has_default_route Nil = False"
 
 lemma has_default_route_alt: "has_default_route rt \<longleftrightarrow> (\<exists>r \<in> set rt. pfxm_length (routing_match r) = 0)" by(induction rt) simp_all
 
 subsection\<open>Single Packet Semantics\<close>
 
 fun routing_table_semantics :: "('i::len) prefix_routing \<Rightarrow> 'i word \<Rightarrow> 'i routing_action" where
 "routing_table_semantics [] _ = routing_action (undefined::'i routing_rule)" | 
 "routing_table_semantics (r#rs) p = (if prefix_match_semantics (routing_match r) p then routing_action r else routing_table_semantics rs p)"
 lemma routing_table_semantics_ports_from_table: "valid_prefixes rtbl \<Longrightarrow> has_default_route rtbl \<Longrightarrow> 
   routing_table_semantics rtbl packet = r \<Longrightarrow> r \<in> routing_action ` set rtbl"
 proof(induction rtbl)
   case (Cons r rs)
   note v_pfxs = valid_prefixes_split[OF Cons.prems(1)]
   show ?case
   proof(cases "pfxm_length (routing_match r) = 0")
     case True                                                 
     note zero_prefix_match_all[OF conjunct1[OF v_pfxs] True] Cons.prems(3)
     then show ?thesis by simp
   next
     case False
     hence "has_default_route rs" using Cons.prems(2) by simp
     from Cons.IH[OF conjunct2[OF v_pfxs] this] Cons.prems(3) show ?thesis by force
   qed
 qed simp
 
 subsection\<open>Longest Prefix Match\<close>
 
 text\<open>We can abuse @{const LinordHelper} to sort.\<close>
 definition "routing_rule_sort_key \<equiv> \<lambda>r. LinordHelper (0 - (of_nat :: nat \<Rightarrow> int) (pfxm_length (routing_match r))) (metric r)"
 text\<open>There is actually a slight design choice here. We can choose to sort based on @{thm less_eq_prefix_match_def} (thus including the address) or only the prefix length (excluding it).
   Which is taken does not matter gravely, since the bits of the prefix can't matter. They're either eqal or the rules don't overlap and the metric decides. (It does matter for the resulting list though.)
   Ignoring the prefix and taking only its length is slightly easier.\<close>
 
 (*example: get longest prefix match by sorting by pfxm_length*)
 definition "rr_ctor m l a nh me \<equiv> \<lparr> routing_match = PrefixMatch (ipv4addr_of_dotdecimal m) l, metric = me, routing_action =\<lparr>output_iface = a, next_hop = (map_option ipv4addr_of_dotdecimal nh)\<rparr> \<rparr>"
 value "sort_key routing_rule_sort_key [
   rr_ctor (0,0,0,1) 3 '''' None 0,
   rr_ctor (0,0,0,2) 8 [] None 0,
   rr_ctor (0,0,0,3) 4 [] None 13,
   rr_ctor (0,0,0,3) 4 [] None 42]"
 
 definition "is_longest_prefix_routing \<equiv> sorted \<circ> map routing_rule_sort_key"
 
 definition correct_routing :: "('i::len) prefix_routing \<Rightarrow> bool" where 
   "correct_routing r \<equiv> is_longest_prefix_routing r \<and> valid_prefixes r"
 text\<open>Many proofs and functions around routing require at least parts of @{const correct_routing} as an assumption.
 Obviously, @{const correct_routing} is not given for arbitrary routing tables. Therefore,
 @{const correct_routing} is made to be executable and should be checked for any routing table after parsing.
 Note: @{const correct_routing} used to also require @{const has_default_route},
 but none of the proofs require it anymore and it is not given for any routing table.\<close>
 
 lemma is_longest_prefix_routing_rule_exclusion:
   assumes "is_longest_prefix_routing (r1 # rn # rss)"
   shows "is_longest_prefix_routing (r1 # rss)"
 using assms by(case_tac rss) (auto simp add: is_longest_prefix_routing_def)
 
 lemma int_of_nat_less: "int_of_nat a < int_of_nat b \<Longrightarrow> a < b" by (simp add: int_of_nat_def)
 
 lemma is_longest_prefix_routing_sorted_by_length:
   assumes "is_longest_prefix_routing r"
      and "r = r1 # rs @ r2 # rss"
   shows "(pfxm_length (routing_match r1) \<ge> pfxm_length (routing_match r2))"
 using assms
 proof(induction rs arbitrary: r)
   case (Cons rn rs)
   let ?ro = "r1 # rs @ r2 # rss"
   have "is_longest_prefix_routing ?ro" using Cons.prems is_longest_prefix_routing_rule_exclusion[of r1 rn "rs @ r2 # rss"] by simp
   from Cons.IH[OF this] show ?case by simp
 next
   case Nil thus ?case by(auto simp add: is_longest_prefix_routing_def routing_rule_sort_key_def linord_helper_less_eq1_def less_eq_linord_helper_def int_of_nat_def)    
 qed
 
 definition "sort_rtbl :: ('i::len) routing_rule list \<Rightarrow> 'i routing_rule list \<equiv> sort_key routing_rule_sort_key"
 
 lemma is_longest_prefix_routing_sort: "is_longest_prefix_routing (sort_rtbl r)" unfolding sort_rtbl_def is_longest_prefix_routing_def by simp
 
 definition "unambiguous_routing rtbl \<equiv> (\<forall>rt1 rt2 rr ra. rtbl = rt1 @ rr # rt2 \<longrightarrow> ra \<in> set (rt1 @ rt2) \<longrightarrow> routing_match rr = routing_match ra \<longrightarrow> routing_rule_sort_key rr \<noteq> routing_rule_sort_key ra)"
 lemma unambiguous_routing_Cons: "unambiguous_routing (r # rtbl) \<Longrightarrow> unambiguous_routing rtbl"
   unfolding unambiguous_routing_def by(clarsimp) (metis append_Cons in_set_conv_decomp)
 lemma "unambiguous_routing (rr # rtbl) \<Longrightarrow> is_longest_prefix_routing (rr # rtbl) \<Longrightarrow> ra \<in> set rtbl \<Longrightarrow> routing_match rr = routing_match ra \<Longrightarrow> routing_rule_sort_key rr < routing_rule_sort_key ra"
   unfolding is_longest_prefix_routing_def unambiguous_routing_def by(fastforce)
 primrec unambiguous_routing_code where
 "unambiguous_routing_code [] = True" |
 "unambiguous_routing_code (rr#rtbl) = (list_all (\<lambda>ra. routing_match rr \<noteq> routing_match ra \<or> routing_rule_sort_key rr \<noteq> routing_rule_sort_key ra) rtbl \<and> unambiguous_routing_code rtbl)"
 lemma unambiguous_routing_code[code_unfold]: "unambiguous_routing rtbl \<longleftrightarrow> unambiguous_routing_code rtbl"
 proof(induction rtbl)
   case (Cons rr rtbl) show ?case (is "?l \<longleftrightarrow> ?r") proof
     assume l: ?l
     with unambiguous_routing_Cons Cons.IH have "unambiguous_routing_code rtbl" by blast
     moreover have "list_all (\<lambda>ra. routing_match rr \<noteq> routing_match ra \<or> routing_rule_sort_key rr \<noteq> routing_rule_sort_key ra) rtbl"
       using l unfolding unambiguous_routing_def by(fastforce simp add: list_all_iff)
     ultimately show ?r by simp
   next
     assume r: ?r
     with Cons.IH have "unambiguous_routing rtbl" by simp
     from r have *: "list_all (\<lambda>ra. routing_match rr \<noteq> routing_match ra \<or>  routing_rule_sort_key rr \<noteq> routing_rule_sort_key ra) rtbl" by simp
     have False if "rr # rtbl = rt1 @ rra # rt2" "ra \<in> set (rt1 @ rt2)" "routing_rule_sort_key rra = routing_rule_sort_key ra \<and> routing_match rra = routing_match ra" for rt1 rt2 rra ra
     proof(cases "rt1 = []")
       case True thus ?thesis using that * by(fastforce simp add: list_all_iff)
     next
       case False
       with that(1) have rtbl: "rtbl = tl rt1 @ rra # rt2" by (metis list.sel(3) tl_append2)
       show ?thesis proof(cases "ra = hd rt1") (* meh case split\<dots> *)
         case False hence "ra \<in> set (tl rt1 @ rt2)" using that by(cases rt1; simp)
         with \<open>unambiguous_routing rtbl\<close> show ?thesis  using that(3) rtbl unfolding unambiguous_routing_def by fast
       next
         case True hence "rr = ra" using that \<open>rt1 \<noteq> []\<close> by(cases rt1; simp) 
         thus ?thesis using that * unfolding rtbl by(fastforce simp add: list_all_iff)
       qed
     qed
     thus ?l unfolding unambiguous_routing_def by blast 
   qed
 qed(simp add: unambiguous_routing_def)
 
 lemma unambigous_prefix_routing_weak_mono:
   assumes lpfx: "is_longest_prefix_routing (rr#rtbl)"
   assumes e:"rr' \<in> set rtbl"
   shows "routing_rule_sort_key rr' \<ge> routing_rule_sort_key rr"
 using assms  by(simp add: is_longest_prefix_routing_def)
 lemma unambigous_prefix_routing_strong_mono:
   assumes lpfx: "is_longest_prefix_routing (rr#rtbl)" 
   assumes uam: "unambiguous_routing (rr#rtbl)" 
   assumes e:"rr' \<in> set rtbl"
   assumes ne: "routing_match rr' = routing_match rr"
   shows "routing_rule_sort_key rr' > routing_rule_sort_key rr" 
 proof -
   from uam e ne have "routing_rule_sort_key rr \<noteq> routing_rule_sort_key rr'" by(fastforce simp add: unambiguous_routing_def)
   moreover from unambigous_prefix_routing_weak_mono lpfx e have "routing_rule_sort_key rr \<le> routing_rule_sort_key rr'" .
   ultimately show ?thesis by simp
 qed
 
 lemma "routing_rule_sort_key (rr_ctor (0,0,0,0) 8 [] None 0) > routing_rule_sort_key (rr_ctor (0,0,0,0) 24 [] None 0)" by eval
 (* get the inequality right\<dots> bigger means lower priority *)
 text\<open>In case you don't like that formulation of @{const is_longest_prefix_routing} over sorting, this is your lemma.\<close>
 theorem existential_routing: "valid_prefixes rtbl \<Longrightarrow> is_longest_prefix_routing rtbl \<Longrightarrow> has_default_route rtbl \<Longrightarrow> unambiguous_routing rtbl \<Longrightarrow>
 routing_table_semantics rtbl addr = act \<longleftrightarrow> (\<exists>rr \<in> set rtbl. prefix_match_semantics (routing_match rr) addr \<and> routing_action rr = act \<and>
   (\<forall>ra \<in> set rtbl. routing_rule_sort_key ra < routing_rule_sort_key rr \<longrightarrow> \<not>prefix_match_semantics (routing_match ra) addr))"
 proof(induction rtbl)
   case Nil thus ?case by simp
 next
   case (Cons rr rtbl)
   show ?case proof(cases "prefix_match_semantics (routing_match rr) addr")
     case False
     hence [simp]: "routing_table_semantics (rr # rtbl) addr = routing_table_semantics (rr # rtbl) addr" by simp
     show ?thesis proof(cases "routing_prefix rr = 0")
       case True text\<open>Need special treatment, rtbl won't have a default route, so the IH is not usable.\<close>
       have "valid_prefix (routing_match rr)" using Cons.prems valid_prefixes_split by blast
       with True False have False using zero_prefix_match_all by blast
       thus ?thesis ..
     next
       case False
       with Cons.prems have mprems: "valid_prefixes rtbl" "is_longest_prefix_routing rtbl" "has_default_route rtbl" "unambiguous_routing rtbl" 
         by(simp_all add: valid_prefixes_split unambiguous_routing_Cons is_longest_prefix_routing_def)
       show ?thesis using Cons.IH[OF mprems] False \<open>\<not> prefix_match_semantics (routing_match rr) addr\<close> by simp
     qed
   next
     case True
     from True have [simp]: "routing_table_semantics (rr # rtbl) addr = routing_action rr" by simp
     show ?thesis (is "?l \<longleftrightarrow> ?r") proof
       assume ?l
       hence [simp]: "act = routing_action rr" by(simp add: True)
       have *: "(\<forall>ra\<in>set (rr # rtbl). routing_rule_sort_key rr \<le> routing_rule_sort_key ra)"
         using \<open>is_longest_prefix_routing (rr # rtbl)\<close>  by(clarsimp simp: is_longest_prefix_routing_def)
       thus ?r by(fastforce simp add: True)
     next
       assume ?r
       then guess rr' .. note rr' = this
       have "rr' = rr" proof(rule ccontr)
         assume C: "rr' \<noteq> rr"
         from C have e: "rr' \<in> set rtbl" using rr' by simp
         show False proof cases
           assume eq: "routing_match rr' = routing_match rr"
           with e have "routing_rule_sort_key rr < routing_rule_sort_key rr'" using unambigous_prefix_routing_strong_mono[OF Cons.prems(2,4) _ eq] by simp
           with True rr' show False by simp
         next
           assume ne: "routing_match rr' \<noteq> routing_match rr"
           from rr' Cons.prems have "valid_prefix (routing_match rr)" "valid_prefix (routing_match rr')" "prefix_match_semantics (routing_match rr') addr" by(auto simp add: valid_prefixes_alt_def)
           note same_length_prefixes_distinct[OF this(1,2) ne[symmetric] _ True this(3)]
           moreover have "routing_prefix rr = routing_prefix rr'" (is ?pe) proof -
             have "routing_rule_sort_key rr < routing_rule_sort_key rr' \<longrightarrow> \<not> prefix_match_semantics (routing_match rr) addr" using rr' by simp
             with unambigous_prefix_routing_weak_mono[OF Cons.prems(2) e] True have "routing_rule_sort_key rr = routing_rule_sort_key rr'" by simp
             thus ?pe by(simp add: routing_rule_sort_key_def int_of_nat_def)
           qed
           ultimately show False .
         qed
       qed
       thus ?l using rr' by simp
     qed
   qed
 qed
     
 
 
 subsection\<open>Printing\<close>
 
 definition "routing_rule_32_toString (rr::32 routing_rule) \<equiv> 
   prefix_match_32_toString (routing_match rr) 
 @ (case next_hop (routing_action rr) of Some nh \<Rightarrow> '' via '' @ ipv4addr_toString nh | _ \<Rightarrow> [])
 @ '' dev '' @ routing_oiface rr 
 @ '' metric '' @ string_of_nat (metric rr)"
 
 definition "routing_rule_128_toString (rr::128 routing_rule) \<equiv> 
   prefix_match_128_toString (routing_match rr) 
 @ (case next_hop (routing_action rr) of Some nh \<Rightarrow> '' via '' @ ipv6addr_toString nh | _ \<Rightarrow> [])
 @ '' dev '' @ routing_oiface rr 
 @ '' metric '' @ string_of_nat (metric rr)"
 
 lemma "map routing_rule_32_toString 
 [rr_ctor (42,0,0,0) 7 ''eth0'' None 808, 
  rr_ctor (0,0,0,0) 0 ''eth1'' (Some (222,173,190,239)) 707] =
 [''42.0.0.0/7 dev eth0 metric 808'',
  ''0.0.0.0/0 via 222.173.190.239 dev eth1 metric 707'']" by eval
 
 section\<open>Routing table to Relation\<close>
 
 text\<open>Walking through a routing table splits the (remaining) IP space when traversing a routing table into a pair of sets:
  the pair contains the IPs concerned by the current rule and those left alone.\<close>
 private definition ipset_prefix_match where 
   "ipset_prefix_match pfx rg = (let pfxrg = prefix_to_wordset pfx in (rg \<inter> pfxrg, rg - pfxrg))"
 private lemma ipset_prefix_match_m[simp]:  "fst (ipset_prefix_match pfx rg) = rg \<inter> (prefix_to_wordset pfx)" by(simp only: Let_def ipset_prefix_match_def, simp)
 private lemma ipset_prefix_match_nm[simp]: "snd (ipset_prefix_match pfx rg) = rg - (prefix_to_wordset pfx)" by(simp only: Let_def ipset_prefix_match_def, simp)
 private lemma ipset_prefix_match_distinct: "rpm = ipset_prefix_match pfx rg \<Longrightarrow> 
   (fst rpm) \<inter> (snd rpm) = {}" by force
 private lemma ipset_prefix_match_complete: "rpm = ipset_prefix_match pfx rg \<Longrightarrow> 
   (fst rpm) \<union> (snd rpm) = rg" by force
 private lemma rpm_m_dup_simp: "rg \<inter> fst (ipset_prefix_match (routing_match r) rg) = fst (ipset_prefix_match (routing_match r) rg)"
   by simp
 private definition range_prefix_match :: "'i::len prefix_match \<Rightarrow> 'i wordinterval \<Rightarrow> 'i wordinterval \<times> 'i wordinterval" where
   "range_prefix_match pfx rg \<equiv> (let pfxrg = prefix_to_wordinterval pfx in 
   (wordinterval_intersection rg pfxrg, wordinterval_setminus rg pfxrg))"
 private lemma range_prefix_match_set_eq:
   "(\<lambda>(r1,r2). (wordinterval_to_set r1, wordinterval_to_set r2)) (range_prefix_match pfx rg) =
     ipset_prefix_match pfx (wordinterval_to_set rg)"
   unfolding range_prefix_match_def ipset_prefix_match_def Let_def 
   using wordinterval_intersection_set_eq wordinterval_setminus_set_eq prefix_to_wordinterval_set_eq  by auto
 private lemma range_prefix_match_sm[simp]:  "wordinterval_to_set (fst (range_prefix_match pfx rg)) = 
     fst (ipset_prefix_match pfx (wordinterval_to_set rg))"
   by (metis fst_conv ipset_prefix_match_m  wordinterval_intersection_set_eq prefix_to_wordinterval_set_eq range_prefix_match_def)
 private lemma range_prefix_match_snm[simp]: "wordinterval_to_set (snd (range_prefix_match pfx rg)) =
     snd (ipset_prefix_match pfx (wordinterval_to_set rg))"
   by (metis snd_conv ipset_prefix_match_nm wordinterval_setminus_set_eq prefix_to_wordinterval_set_eq range_prefix_match_def)
 
 subsection\<open>Wordintervals for Ports by Routing\<close>
 text\<open>This split, although rather trivial, 
 can be used to construct the sets (or rather: the intervals) 
 of IPs that are actually matched by an entry in a routing table.\<close>
 
 private fun routing_port_ranges :: "'i prefix_routing \<Rightarrow> 'i wordinterval \<Rightarrow> (string \<times> ('i::len) wordinterval) list" where
 "routing_port_ranges [] lo = (if wordinterval_empty lo then [] else [(routing_oiface (undefined::'i routing_rule),lo)])" | (* insert default route to nirvana. has to match what routing_table_semantics does. *)
 "routing_port_ranges (a#as) lo = (
 	let rpm = range_prefix_match (routing_match a) lo; m = fst rpm; nm = snd rpm in (
 	(routing_oiface a,m) # routing_port_ranges as nm))"
 
 private lemma routing_port_ranges_subsets:
 "(a1, b1) \<in> set (routing_port_ranges tbl s) \<Longrightarrow> wordinterval_to_set b1 \<subseteq> wordinterval_to_set s"
   by(induction tbl arbitrary: s; fastforce simp add: Let_def split: if_splits)
 
 private lemma routing_port_ranges_sound: "e \<in> set (routing_port_ranges tbl s) \<Longrightarrow> k \<in> wordinterval_to_set (snd e) \<Longrightarrow> valid_prefixes tbl \<Longrightarrow>
 	fst e = output_iface (routing_table_semantics tbl k)"
 proof(induction tbl arbitrary: s)
 	case (Cons a as)
 	note s = Cons.prems(1)[unfolded routing_port_ranges.simps Let_def list.set]
 	note vpfx = valid_prefixes_split[OF Cons.prems(3)] 
 	show ?case (is ?kees) proof(cases "e = (routing_oiface a, fst (range_prefix_match (routing_match a) s))")
 		case False
 		hence es: "e \<in> set (routing_port_ranges as (snd (range_prefix_match (routing_match a) s)))" using s by blast
 		note eq = Cons.IH[OF this Cons.prems(2) conjunct2[OF vpfx]]
 		have "\<not>prefix_match_semantics (routing_match a) k" (is ?nom)
 		proof -
 		  from routing_port_ranges_subsets[of "fst e" "snd e", unfolded prod.collapse, OF es]
 		  have *: "wordinterval_to_set (snd e) \<subseteq> wordinterval_to_set (snd (range_prefix_match (routing_match a) s))" .
 			show ?nom unfolding prefix_match_semantics_wordset[OF conjunct1[OF vpfx]]
 			  using * Cons.prems(2)	unfolding wordinterval_subset_set_eq
 				by(auto simp add: range_prefix_match_def Let_def)
 		qed
 		thus ?kees using eq by simp
 	next
 		case True
 		hence fe: "fst e = routing_oiface a" by simp
 		from True have "k \<in> wordinterval_to_set (fst (range_prefix_match (routing_match a) s))"
 			using Cons.prems(2) by(simp)
 		hence "prefix_match_semantics (routing_match a) k" 
 			unfolding prefix_match_semantics_wordset[OF conjunct1, OF vpfx]
 			unfolding range_prefix_match_def Let_def
 			by simp
 		thus ?kees by(simp add: fe)
 	qed
 qed (simp split: if_splits)
 
 private lemma routing_port_ranges_disjoined:
 assumes vpfx: "valid_prefixes tbl"
   and ins:  "(a1, b1) \<in> set (routing_port_ranges tbl s)" "(a2, b2) \<in> set (routing_port_ranges tbl s)"
   and nemp: "wordinterval_to_set b1 \<noteq> {}"
 shows "b1 \<noteq> b2 \<longleftrightarrow> wordinterval_to_set b1 \<inter> wordinterval_to_set b2 = {}"
 using assms
 proof(induction tbl arbitrary: s)
   case (Cons r rs)
   have vpfx: "valid_prefix (routing_match r)" "valid_prefixes rs" using Cons.prems(1) using valid_prefixes_split by blast+
   { (* In case that one of b1 b2 stems from r and one does not, we assume it is b1 WLOG. *)
     fix a1 b1 a2 b2
     assume one: "b1 = fst (range_prefix_match (routing_match r) s)"
     assume two: "(a2, b2) \<in> set (routing_port_ranges rs (snd (range_prefix_match (routing_match r) s)))"
     have dc: "wordinterval_to_set (snd (range_prefix_match (routing_match r) s)) \<inter>
           wordinterval_to_set (fst (range_prefix_match (routing_match r) s)) = {}" by force
     hence "wordinterval_to_set b1 \<inter> wordinterval_to_set b2 = {}"
     unfolding one using two[THEN routing_port_ranges_subsets] by fast
   } note * = this
   show ?case
   using \<open>(a1, b1) \<in> set (routing_port_ranges (r # rs) s)\<close> \<open>(a2, b2) \<in> set (routing_port_ranges (r # rs) s)\<close> nemp
     Cons.IH[OF vpfx(2)] * 
     by(fastforce simp add: Let_def)    
 qed (simp split: if_splits)
 
 private lemma routing_port_rangesI:
 "valid_prefixes tbl \<Longrightarrow>
  output_iface (routing_table_semantics tbl k) = output_port \<Longrightarrow>
  k \<in> wordinterval_to_set wi \<Longrightarrow>
  (\<exists>ip_range. (output_port, ip_range) \<in> set (routing_port_ranges tbl wi) \<and> k \<in> wordinterval_to_set ip_range)"
 proof(induction tbl arbitrary: wi)
   case Nil thus ?case by simp blast
 next
   case (Cons r rs)
   from Cons.prems(1) have vpfx: "valid_prefix (routing_match r)" and vpfxs: "valid_prefixes rs" 
     by(simp_all add: valid_prefixes_split)
   show ?case
   proof(cases "prefix_match_semantics (routing_match r) k")
     case True
     thus ?thesis 
       using Cons.prems(2) using vpfx \<open>k \<in> wordinterval_to_set wi\<close>
       by (intro exI[where x =  "fst (range_prefix_match (routing_match r) wi)"]) 
          (simp add: prefix_match_semantics_wordset Let_def)
   next
     case False
     with \<open>k \<in> wordinterval_to_set wi\<close> have ksnd: "k \<in> wordinterval_to_set (snd (range_prefix_match (routing_match r) wi))"
       by (simp add: prefix_match_semantics_wordset vpfx)
     have mpr: "output_iface (routing_table_semantics rs k) = output_port" using Cons.prems False by simp
     note Cons.IH[OF vpfxs mpr ksnd]
     thus ?thesis by(fastforce simp: Let_def)
   qed
 qed
 
 subsection\<open>Reduction\<close>
 text\<open>So far, one entry in the list would be generated for each routing table entry. 
 This next step reduces it to one for each port. 
 The resulting list will represent a function from port to IP wordinterval.
 (It can also be understood as a function from IP (interval) to port (where the intervals don't overlap).\<close>
 
 definition "reduce_range_destination l \<equiv>
 let ps = remdups (map fst l) in
 let c = \<lambda>s. (wordinterval_Union \<circ> map snd \<circ> filter (((=) s) \<circ> fst)) l in
 [(p, c p). p \<leftarrow> ps]
 "
 
 definition "routing_ipassmt_wi tbl \<equiv> reduce_range_destination (routing_port_ranges tbl wordinterval_UNIV)"
 
 lemma routing_ipassmt_wi_distinct: "distinct (map fst (routing_ipassmt_wi tbl))"
   unfolding routing_ipassmt_wi_def reduce_range_destination_def
   by(simp add: comp_def)
 
 private lemma routing_port_ranges_superseted:
 "(a1,b1) \<in> set (routing_port_ranges tbl wordinterval_UNIV) \<Longrightarrow> 
   \<exists>b2. (a1,b2) \<in> set (routing_ipassmt_wi tbl) \<and> wordinterval_to_set b1 \<subseteq> wordinterval_to_set b2"
   unfolding routing_ipassmt_wi_def reduce_range_destination_def
   by(force simp add: Set.image_iff wordinterval_Union)
 
 private lemma routing_ipassmt_wi_subsetted:
 "(a1,b1) \<in> set (routing_ipassmt_wi tbl) \<Longrightarrow> 
  (a1,b2) \<in> set (routing_port_ranges tbl wordinterval_UNIV) \<Longrightarrow>  wordinterval_to_set b2 \<subseteq> wordinterval_to_set b1"
   unfolding routing_ipassmt_wi_def reduce_range_destination_def
   by(fastforce simp add: Set.image_iff wordinterval_Union comp_def)
 
 text\<open>This lemma should hold without the @{const valid_prefixes} assumption, but that would break the semantic argument and make the proof a lot harder.\<close>
 lemma routing_ipassmt_wi_disjoint:
 assumes vpfx: "valid_prefixes (tbl::('i::len) prefix_routing)"
   and dif: "a1 \<noteq> a2"
   and ins:  "(a1, b1) \<in> set (routing_ipassmt_wi tbl)" "(a2, b2) \<in> set (routing_ipassmt_wi tbl)"
 shows "wordinterval_to_set b1 \<inter> wordinterval_to_set b2 = {}"
 proof(rule ccontr)
   note iuf = ins[unfolded routing_ipassmt_wi_def reduce_range_destination_def Let_def, simplified, unfolded Set.image_iff comp_def, simplified]
   assume "(wordinterval_to_set b1 \<inter> wordinterval_to_set b2 \<noteq> {})"
   hence "wordinterval_to_set b1 \<inter> wordinterval_to_set b2 \<noteq> {}" by simp
   text\<open>If the intervals are not disjoint, there exists a witness of that.\<close>
   then obtain x where x[simp]: "x \<in> wordinterval_to_set b1" "x \<in> wordinterval_to_set b2" by blast
   text\<open>This witness has to have come from some entry in the result of @{const routing_port_ranges}, for both of @{term b1} and @{term b2}.\<close>
   hence "\<exists>b1g. x \<in> wordinterval_to_set b1g \<and> wordinterval_to_set b1g \<subseteq> wordinterval_to_set b1 \<and> (a1, b1g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)"
     using iuf(1) by(fastforce simp add: wordinterval_Union) (* strangely, this doesn't work with obtain *)
   then obtain b1g where b1g: "x \<in> wordinterval_to_set b1g" "wordinterval_to_set b1g \<subseteq> wordinterval_to_set b1" "(a1, b1g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)" by clarsimp
   from x have "\<exists>b2g. x \<in> wordinterval_to_set b2g \<and> wordinterval_to_set b2g \<subseteq> wordinterval_to_set b2 \<and> (a2, b2g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)"
     using iuf(2) by(fastforce simp add: wordinterval_Union)
   then obtain b2g where b2g: "x \<in> wordinterval_to_set b2g" "wordinterval_to_set b2g \<subseteq> wordinterval_to_set b2" "(a2, b2g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)" by clarsimp
   text\<open>Soudness tells us that the both @{term a1} and @{term a2} have to be the result of routing @{term x}.\<close>
   note routing_port_ranges_sound[OF b1g(3), unfolded fst_conv snd_conv, OF b1g(1) vpfx] routing_port_ranges_sound[OF b2g(3), unfolded fst_conv snd_conv, OF b2g(1) vpfx]
   text\<open>A contradiction follows from @{thm dif}.\<close>
   with dif show False by simp
 qed
 
 lemma routing_ipassmt_wi_sound:
   assumes vpfx: "valid_prefixes tbl"
   and ins: "(ea,eb) \<in> set (routing_ipassmt_wi tbl)"
   and x: "k \<in> wordinterval_to_set eb"
   shows "ea = output_iface (routing_table_semantics tbl k)"
 proof -
   note iuf = ins[unfolded routing_ipassmt_wi_def reduce_range_destination_def Let_def, simplified, unfolded Set.image_iff comp_def, simplified]
   from x have "\<exists>b1g. k \<in> wordinterval_to_set b1g \<and> wordinterval_to_set b1g \<subseteq> wordinterval_to_set eb \<and> (ea, b1g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)"
     using iuf(1) by(fastforce simp add: wordinterval_Union)
   then obtain b1g where b1g: "k \<in> wordinterval_to_set b1g" "wordinterval_to_set b1g \<subseteq> wordinterval_to_set eb" "(ea, b1g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)" by clarsimp
   note routing_port_ranges_sound[OF b1g(3), unfolded fst_conv snd_conv, OF b1g(1) vpfx]
   thus ?thesis .
 qed
 
 theorem routing_ipassmt_wi:
 assumes vpfx: "valid_prefixes tbl"
   shows 
   "output_iface (routing_table_semantics tbl k) = output_port \<longleftrightarrow>
     (\<exists>ip_range. k \<in> wordinterval_to_set ip_range \<and> (output_port, ip_range) \<in> set (routing_ipassmt_wi tbl))"
 proof (intro iffI, goal_cases)
   case 2 with vpfx routing_ipassmt_wi_sound show ?case by blast
 next
   case 1
   then obtain ip_range where "(output_port, ip_range) \<in> set (routing_port_ranges tbl wordinterval_UNIV) \<and> k \<in> wordinterval_to_set ip_range"
     using routing_port_rangesI[where wi = wordinterval_UNIV, OF vpfx] by auto
   thus ?case
     unfolding routing_ipassmt_wi_def reduce_range_destination_def
     unfolding Let_def comp_def
     by(force simp add: Set.image_iff wordinterval_Union)
 qed
 
 (* this was not given for the old reduced_range_destination *)
 lemma routing_ipassmt_wi_has_all_interfaces:
   assumes in_tbl: "r \<in> set tbl"
   shows "\<exists>s. (routing_oiface r,s) \<in> set (routing_ipassmt_wi tbl)"
 proof -
   from in_tbl have "\<exists>s. (routing_oiface r,s) \<in> set (routing_port_ranges tbl S)" for S
   proof(induction tbl arbitrary: S)
     case (Cons l ls)
     show ?case
     proof(cases "r = l")
       case True thus ?thesis using Cons.prems by(auto simp: Let_def)
     next
       case False with Cons.prems have "r \<in> set ls" by simp
       from Cons.IH[OF this] show ?thesis by(simp add: Let_def) blast
     qed
   qed simp
   thus ?thesis
     unfolding routing_ipassmt_wi_def reduce_range_destination_def
     by(force simp add: Set.image_iff)
 qed
 
 end
 
 end
diff --git a/thys/SDS_Impossibility/SDS_Impossibility.thy b/thys/SDS_Impossibility/SDS_Impossibility.thy
--- a/thys/SDS_Impossibility/SDS_Impossibility.thy
+++ b/thys/SDS_Impossibility/SDS_Impossibility.thy
@@ -1,815 +1,816 @@
 (*
   File:   SDS_Impossibility.thy
   Author: Manuel Eberl <eberlm@in.tum.de>
 
   The proof that there exists no anonymous and neutral SDS for at least 
   four voters and alternatives that satisfies SD-Efficiency and 
   SD-Strategy-Proofness.
 *)
 
 section \<open>Incompatibility of SD-Efficiency and SD-Strategy-Proofness\<close>
 
 theory SDS_Impossibility
 imports
   Randomised_Social_Choice.SDS_Automation
   Randomised_Social_Choice.Randomised_Social_Choice
 begin
 
 subsection \<open>Preliminary Definitions\<close>
 
 locale sds_impossibility = 
   anonymous_sds agents alts sds +
   neutral_sds agents alts sds +
   sd_efficient_sds agents alts sds +
   strategyproof_sds agents alts sds
   for agents :: "'agent set" and alts :: "'alt set" and sds +
   assumes agents_ge_4: "card agents \<ge> 4"
       and alts_ge_4:   "card alts \<ge> 4"
 
 locale sds_impossibility_4_4 = sds_impossibility agents alts sds
   for agents :: "'agent set" and alts :: "'alt set" and sds +
   fixes A1 A2 A3 A4 :: 'agent and a b c d :: 'alt
   assumes distinct_agents: "distinct [A1, A2, A3, A4]"
       and distinct_alts: "distinct [a, b, c, d]"
       and agents: "agents = {A1, A2, A3, A4}"
       and alts:   "alts   = {a, b, c, d}"
 begin
 
 lemma an_sds: "an_sds agents alts sds" by unfold_locales
 lemma ex_post_efficient_sds: "ex_post_efficient_sds agents alts sds" by unfold_locales
 lemma sd_efficient_sds: "sd_efficient_sds agents alts sds" by unfold_locales
 lemma strategyproof_an_sds: "strategyproof_an_sds agents alts sds" by unfold_locales
 
 lemma distinct_agents' [simp]: 
   "A1 \<noteq> A2" "A1 \<noteq> A3" "A1 \<noteq> A4" "A2 \<noteq> A1" "A2 \<noteq> A3" "A2 \<noteq> A4" 
   "A3 \<noteq> A1" "A3 \<noteq> A2" "A3 \<noteq> A4" "A4 \<noteq> A1" "A4 \<noteq> A2" "A4 \<noteq> A3"
   using distinct_agents by auto
   
 lemma distinct_alts' [simp]:
   "a \<noteq> b" "a \<noteq> c" "a \<noteq> d" "b \<noteq> a" "b \<noteq> c" "b \<noteq> d" 
   "c \<noteq> a" "c \<noteq> b" "c \<noteq> d" "d \<noteq> a" "d \<noteq> b" "d \<noteq> c"
   using distinct_alts by auto
 
 lemma card_agents [simp]: "card agents = 4" and card_alts [simp]: "card alts = 4"
   using distinct_agents distinct_alts by (simp_all add: agents alts)
 
 lemma in_agents [simp]: "A1 \<in> agents" "A2 \<in> agents" "A3 \<in> agents" "A4 \<in> agents"
   by (simp_all add: agents)
 
 lemma in_alts [simp]: "a \<in> alts" "b \<in> alts" "c \<in> alts" "d \<in> alts"
   by (simp_all add: alts)
   
 lemma agent_iff: "x \<in> agents \<longleftrightarrow> x \<in> {A1, A2, A3, A4}"
                  "(\<forall>x\<in>agents. P x) \<longleftrightarrow> P A1 \<and> P A2 \<and> P A3 \<and> P A4"
                  "(\<exists>x\<in>agents. P x) \<longleftrightarrow> P A1 \<or> P A2 \<or> P A3 \<or> P A4"
   by (auto simp add: agents)
 
 lemma alt_iff: "x \<in> alts \<longleftrightarrow> x \<in> {a,b,c,d}"
                "(\<forall>x\<in>alts. P x) \<longleftrightarrow> P a \<and> P b \<and> P c \<and> P d"
                "(\<exists>x\<in>alts. P x) \<longleftrightarrow> P a \<or> P b \<or> P c \<or> P d"
   by (auto simp add: alts)
 
 
 
 
 subsection \<open>Definition of Preference Profiles and Fact Gathering\<close>
 
 preference_profile 
   agents: agents
   alts:   alts
 where R1  = A1: [c, d], [a, b]    A2: [b, d], a, c      A3: a, b, [c, d]      A4: [a, c], [b, d]
   and R2  = A1: [a, c], [b, d]    A2: [c, d], a, b      A3: [b, d], a, c      A4: a, b, [c, d]
   and R3  = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: d, [a, b], c      A4: c, a, [b, d]
   and R4  = A1: [a, b], [c, d]    A2: [a, d], [b, c]    A3: c, [a, b], d      A4: d, c, [a, b]
   and R5  = A1: [c, d], [a, b]    A2: [a, b], [c, d]    A3: [a, c], d, b      A4: d, [a, b], c
   and R6  = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: [a, c], [b, d]    A4: d, b, a, c
   and R7  = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: a, c, d, b        A4: d, [a, b], c
   and R8  = A1: [a, b], [c, d]    A2: [a, c], [b, d]    A3: d, [a, b], c      A4: d, c, [a, b]
   and R9  = A1: [a, b], [c, d]    A2: [a, d], c, b      A3: d, c, [a, b]      A4: [a, b, c], d
   and R10 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: [a, c], d, b      A4: [b, d], a, c
   and R11 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: d, [a, b], c      A4: c, a, b, d
   and R12 = A1: [c, d], [a, b]    A2: [a, b], [c, d]    A3: [a, c], d, b      A4: [a, b, d], c
   and R13 = A1: [a, c], [b, d]    A2: [c, d], a, b      A3: [b, d], a, c      A4: a, b, d, c
   and R14 = A1: [a, b], [c, d]    A2: d, c, [a, b]      A3: [a, b, c], d      A4: a, d, c, b
   and R15 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: [b, d], a, c      A4: a, c, d, b
   and R16 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: a, c, d, b        A4: [a, b, d], c
   and R17 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: [a, c], [b, d]    A4: d, [a, b], c
   and R18 = A1: [a, b], [c, d]    A2: [a, d], [b, c]    A3: [a, b, c], d      A4: d, c, [a, b]
   and R19 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: [b, d], a, c      A4: [a, c], [b, d]
   and R20 = A1: [b, d], a, c      A2: b, a, [c, d]      A3: a, c, [b, d]      A4: d, c, [a, b]
   and R21 = A1: [a, d], c, b      A2: d, c, [a, b]      A3: c, [a, b], d      A4: a, b, [c, d]
   and R22 = A1: [a, c], d, b      A2: d, c, [a, b]      A3: d, [a, b], c      A4: a, b, [c, d]
   and R23 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: [a, c], [b, d]    A4: [a, b, d], c
   and R24 = A1: [c, d], [a, b]    A2: d, b, a, c        A3: c, a, [b, d]      A4: b, a, [c, d]
   and R25 = A1: [c, d], [a, b]    A2: [b, d], a, c      A3: a, b, [c, d]      A4: a, c, [b, d]
   and R26 = A1: [b, d], [a, c]    A2: [c, d], [a, b]    A3: a, b, [c, d]      A4: a, c, [b, d]
   and R27 = A1: [a, b], [c, d]    A2: [b, d], a, c      A3: [a, c], [b, d]    A4: [c, d], a, b
   and R28 = A1: [c, d], a, b      A2: [b, d], a, c      A3: a, b, [c, d]      A4: a, c, [b, d]
   and R29 = A1: [a, c], d, b      A2: [b, d], a, c      A3: a, b, [c, d]      A4: d, c, [a, b]
   and R30 = A1: [a, d], c, b      A2: d, c, [a, b]      A3: c, [a, b], d      A4: [a, b], d, c
   and R31 = A1: [b, d], a, c      A2: [a, c], d, b      A3: c, d, [a, b]      A4: [a, b], c, d
   and R32 = A1: [a, c], d, b      A2: d, c, [a, b]      A3: d, [a, b], c      A4: [a, b], d, c
   and R33 = A1: [c, d], [a, b]    A2: [a, c], d, b      A3: a, b, [c, d]      A4: d, [a, b], c
   and R34 = A1: [a, b], [c, d]    A2: a, c, d, b        A3: b, [a, d], c      A4: c, d, [a, b]
   and R35 = A1: [a, d], c, b      A2: a, b, [c, d]      A3: [a, b, c], d      A4: d, c, [a, b]
   and R36 = A1: [c, d], [a, b]    A2: [a, c], d, b      A3: [b, d], a, c      A4: a, b, [c, d]
   and R37 = A1: [a, c], [b, d]    A2: [b, d], [a, c]    A3: a, b, [c, d]      A4: c, d, [a, b]
   and R38 = A1: [c, d], a, b      A2: [b, d], a, c      A3: a, b, [c, d]      A4: [a, c], b, d
   and R39 = A1: [a, c], d, b      A2: [b, d], a, c      A3: a, b, [c, d]      A4: [c, d], a, b
   and R40 = A1: [a, d], c, b      A2: [a, b], c, d      A3: [a, b, c], d      A4: d, c, [a, b]
   and R41 = A1: [a, d], c, b      A2: [a, b], d, c      A3: [a, b, c], d      A4: d, c, [a, b]
   and R42 = A1: [c, d], [a, b]    A2: [a, b], [c, d]    A3: d, b, a, c        A4: c, a, [b, d]
   and R43 = A1: [a, b], [c, d]    A2: [c, d], [a, b]    A3: d, [a, b], c      A4: a, [c, d], b
   and R44 = A1: [c, d], [a, b]    A2: [a, c], d, b      A3: [a, b], d, c      A4: [a, b, d], c
   and R45 = A1: [a, c], d, b      A2: [b, d], a, c      A3: [a, b], c, d      A4: [c, d], b, a
   and R46 = A1: [b, d], a, c      A2: d, c, [a, b]      A3: [a, c], [b, d]    A4: b, a, [c, d]
   and R47 = A1: [a, b], [c, d]    A2: [a, d], c, b      A3: d, c, [a, b]      A4: c, [a, b], d
   by (simp_all add: agents alts)
 
 derive_orbit_equations (an_sds)
   R10 R26 R27 R28 R29 R43 R45
   by simp_all
 
 prove_inefficient_supports (ex_post_efficient_sds sd_efficient_sds)
   R3 [b] and R4 [b] and R5 [b] and R7 [b] and R8 [b] and
   R9 [b] and R11 [b] and R12 [b] and R14 [b] and R16 [b] and
   R17 [b] and R18 [b] and R21 [b] and R22 [b] and R23 [b] and
   R30 [b] and R32 [b] and R33 [b] and R35 [b] and R40 [b] and
   R41 [b] and R43 [b] and R44 [b] and R47 [b] and
   R10 [c, b] witness: [a: 1 / 2, b: 0, c: 0, d: 1 / 2] and
   R15 [c, b] witness: [a: 1 / 2, b: 0, c: 0, d: 1 / 2] and
   R19 [c, b] witness: [a: 1 / 2, b: 0, c: 0, d: 1 / 2] and
   R25 [b, c] witness: [c: 0, d: 1 / 2, a: 1 / 2, b: 0] and
   R26 [c, b] witness: [b: 0, d: 1 / 2, a: 1 / 2, c: 0] and
   R27 [c, b] witness: [a: 1 / 2, b: 0, c: 0, d: 1 / 2] and
   R28 [b, c] witness: [c: 0, d: 1 / 2, a: 1 / 2, b: 0] and
   R29 [b, c] witness: [a: 1 / 2, c: 0, d: 1 / 2, b: 0] and
   R39 [b, c] witness: [a: 1 / 2, c: 0, d: 1 / 2, b: 0]
   by (simp_all add: agent_iff alt_iff)
 
 derive_strategyproofness_conditions (strategyproof_an_sds)
   distance: 2
   R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 R11 R12 R13 R14 R15 R16 R17 R18 R19 R20
   R21 R22 R23 R24 R25 R26 R27 R28 R29 R30 R31 R32 R33 R34 R35 R36 R37 R38 R39 R40
   R41 R42 R43 R44 R45 R46 R47
   by (simp_all add: agent_iff alt_iff)
 
 lemma lottery_conditions:
   assumes "is_pref_profile R"
   shows   "pmf (sds R) a \<ge> 0" "pmf (sds R) b \<ge> 0" "pmf (sds R) c \<ge> 0" "pmf (sds R) d \<ge> 0"
           "pmf (sds R) a + pmf (sds R) b + pmf (sds R) c + pmf (sds R) d = 1"
   using lottery_prob_alts[OF sds_wf[OF assms]]
   by (simp_all add: alts pmf_nonneg measure_measure_pmf_finite)
 
 
 subsection \<open>Main Proof\<close>
 
 lemma R45 [simp]: "pmf (sds R45) a = 1/4" "pmf (sds R45) b = 1/4" 
            "pmf (sds R45) c = 1/4" "pmf (sds R45) d = 1/4"
   using R45.orbits lottery_conditions[OF R45.wf] by simp_all
 
 lemma R10_bc [simp]: "pmf (sds R10) b = 0" "pmf (sds R10) c = 0"
   using R10.support R10.orbits by auto
 
 lemma R10_ad [simp]: "pmf (sds R10) a = 1/2" "pmf (sds R10) d = 1/2"
   using lottery_conditions[OF R10.wf] R10_bc R10.orbits by simp_all
 
 
 lemma R26_bc [simp]: "pmf (sds R26) b = 0" "pmf (sds R26) c = 0"
   using R26.support R26.orbits by auto
 
 lemma R26_d [simp]: "pmf (sds R26) d = 1 - pmf (sds R26) a"
   using lottery_conditions[OF R26.wf] R26_bc by simp
 
 
 lemma R27_bc [simp]: "pmf (sds R27) b = 0" "pmf (sds R27) c = 0"
   using R27.support R27.orbits by auto
 
 lemma R27_d [simp]: "pmf (sds R27) d = 1 - pmf (sds R27) a"
   using lottery_conditions[OF R27.wf] R27_bc by simp
 
 
 lemma R28_bc [simp]: "pmf (sds R28) b = 0" "pmf (sds R28) c = 0"
   using R28.support R28.orbits by auto
 
 lemma R28_d [simp]: "pmf (sds R28) d = 1 - pmf (sds R28) a"
   using lottery_conditions[OF R28.wf] R28_bc by simp
 
 
 lemma R29_bc [simp]: "pmf (sds R29) b = 0" "pmf (sds R29) c = 0"
   using R29.support R29.orbits by auto
 
 lemma R29_ac [simp]: "pmf (sds R29) a = 1/2" "pmf (sds R29) d = 1/2"
   using lottery_conditions[OF R29.wf] R29_bc R29.orbits by simp_all
 
 
 lemmas R43_bc [simp] = R43.support
 
 lemma R43_ad [simp]: "pmf (sds R43) a = 1/2" "pmf (sds R43) d = 1/2"
   using lottery_conditions[OF R43.wf] R43_bc R43.orbits by simp_all
 
 
 lemma R39_b [simp]: "pmf (sds R39) b = 0"
 proof -
   {
     assume [simp]: "pmf (sds R39) c = 0"
     with R29_R39.strategyproofness(1)
       have "pmf (sds R39) d \<le> 1/2" by auto
     with R39_R29.strategyproofness(1) lottery_conditions[OF R39.wf] 
       have "pmf (sds R39) b = 0" by auto
   }
   with R39.support show ?thesis by blast
 qed
 
 lemma R36_a [simp]: "pmf (sds R36) a = 1/2" and R36_b [simp]: "pmf (sds R36) b = 0"
 proof -
   from R10_R36.strategyproofness(1) lottery_conditions[OF R36.wf] 
     have "pmf (sds R36) a + pmf (sds R36) b \<le> 1/2" by auto
   with R36_R10.strategyproofness(1) lottery_conditions[OF R36.wf]
     show "pmf (sds R36) a = 1/2" "pmf (sds R36) b = 0" by auto
 qed
 
 lemma R36_d [simp]: "pmf (sds R36) d = 1/2 - pmf (sds R36) c"
   using lottery_conditions[OF R36.wf] by simp
 
 lemma R39_a [simp]: "pmf (sds R39) a = 1/2"
 proof -
   from R36_R39.strategyproofness(1) lottery_conditions[OF R39.wf]
     have "pmf (sds R39) a \<ge> 1/2" by auto
   with R39_R36.strategyproofness(1) lottery_conditions[OF R39.wf]
     show ?thesis by auto
 qed
 
 lemma R39_d [simp]: "pmf (sds R39) d = 1/2 - pmf (sds R39) c"
   using lottery_conditions[OF R39.wf] by simp
 
 
 
 lemmas R12_b [simp] = R12.support
 
 lemma R12_c [simp]: "pmf (sds R12) c = 0"
   using R12_R10.strategyproofness(1) lottery_conditions[OF R12.wf] 
   by (auto simp del: pmf_nonneg)
   
 
 lemma R12_d [simp]: "pmf (sds R12) d = 1 - pmf (sds R12) a"
   using lottery_conditions[OF R12.wf] by simp
 
 lemma R12_a_ge_one_half: "pmf (sds R12) a \<ge> 1/2"
   using R10_R12.strategyproofness(1) lottery_conditions[OF R12.wf]
   by auto
 
 
 lemma R44 [simp]: 
   "pmf (sds R44) a = pmf (sds R12) a" "pmf (sds R44) d = 1 - pmf (sds R12) a"
   "pmf (sds R44) b = 0" "pmf (sds R44) c = 0"
 proof -
   from R12_R44.strategyproofness(1) R44.support have "pmf (sds R44) a \<le> pmf (sds R12) a" by simp
   with R44_R12.strategyproofness(1) R44.support lottery_conditions[OF R44.wf]
     show "pmf (sds R44) a = pmf (sds R12) a" "pmf (sds R44) c = 0"
          "pmf (sds R44) d = 1 - pmf (sds R12) a" by (auto simp del: pmf_nonneg)
 qed (insert R44.support, simp_all)
 
 lemma R9_a [simp]: "pmf (sds R9) a = pmf (sds R35) a"
 proof -
   from R9_R35.strategyproofness(1) R35.support R9.support 
     have "pmf (sds R35) a \<le> pmf (sds R9) a" by simp
   with R35_R9.strategyproofness(1) R9.support R35.support show ?thesis by simp
 qed
 
 lemma R18_c [simp]: "pmf (sds R18) c = pmf (sds R9) c"
 proof -
   from R18_R9.strategyproofness(1) R18.support R9.support
     have "pmf (sds R18) d + pmf (sds R18) a \<ge> pmf (sds R9) d + pmf (sds R9) a" by auto
   with R9_R18.strategyproofness(1) R18.support R9.support
         lottery_conditions[OF R9.wf] lottery_conditions[OF R18.wf]
     show ?thesis by auto
 qed
 
 lemma R5_d_ge_one_half: "pmf (sds R5) d \<ge> 1/2"
   using R5_R10.strategyproofness(1) R5.support lottery_conditions[OF R5.wf] by auto
 
 lemma R7 [simp]: "pmf (sds R7) a = 1/2" "pmf (sds R7) b = 0" "pmf (sds R7) c = 0" "pmf (sds R7) d = 1/2"
 proof -
   from R5_d_ge_one_half have "1/2 \<le> pmf (sds R5) d" by simp
   also from R5_R17.strategyproofness(1) R17.support lottery_conditions[OF R5.wf] lottery_conditions[OF R17.wf] 
     have "\<dots> \<le> pmf (sds R17) d" by (auto simp del: pmf_nonneg)
   also from R17_R7.strategyproofness(1) lottery_conditions[OF R7.wf] lottery_conditions[OF R17.wf] R7.support
     have "pmf (sds R17) d \<le> pmf (sds R7) d" by (auto simp del: pmf_nonneg)
   finally have "pmf (sds R7) d \<ge> 1/2" .
   with R7_R43.strategyproofness(1) lottery_conditions[OF R7.wf] R7.support
     show "pmf (sds R7) a = 1/2" "pmf (sds R7) b = 0" "pmf (sds R7) c = 0" "pmf (sds R7) d = 1/2"
     by auto
 qed
 
 lemma R5 [simp]: "pmf (sds R5) a = 1/2" "pmf (sds R5) b = 0" "pmf (sds R5) c = 0" "pmf (sds R5) d = 1/2"
 proof -
   from R5_R7.strategyproofness(1) lottery_conditions[OF R5.wf] R5.support 
     have "pmf (sds R5) d \<le> 1/2" by auto
   with R5_d_ge_one_half show d: "pmf (sds R5) d = 1 / 2" by simp
   with R5_R10.strategyproofness(1) lottery_conditions[OF R5.wf] R5.support
     show "pmf (sds R5) c = 0" "pmf (sds R5) a = 1/2" by simp_all
 qed (simp_all add: R5.support)
 
 lemma R15 [simp]: "pmf (sds R15) a = 1/2" "pmf (sds R15) b = 0" "pmf (sds R15) c = 0" "pmf (sds R15) d = 1/2"
 proof -
   {
     assume "pmf (sds R15) b = 0"
     with R10_R15.strategyproofness(1) lottery_conditions[OF R15.wf]
       have "pmf (sds R15) a + pmf (sds R15) c \<le> 1/2" by auto
     with R15_R10.strategyproofness(1) lottery_conditions[OF R15.wf] 
       have "pmf (sds R15) c = 0" by auto
   }
   with R15.support show [simp]: "pmf (sds R15) c = 0" by blast
   with R15_R5.strategyproofness(1) lottery_conditions[OF R15.wf] 
     have "pmf (sds R15) a \<ge> 1/2" by auto
   moreover from R15_R7.strategyproofness(1) lottery_conditions[OF R15.wf]
     have "pmf (sds R15) b + pmf (sds R15) d \<ge> 1/2" by auto
   ultimately show "pmf (sds R15) a = 1/2" using lottery_conditions[OF R15.wf] by auto
   with R15_R5.strategyproofness(1) lottery_conditions[OF R15.wf]
     show "pmf (sds R15) d = 1/2" "pmf (sds R15) b = 0" by auto
 qed
 
 lemma R13_aux: "pmf (sds R13) b = 0" "pmf (sds R13) c = 0" "pmf (sds R13) d = 1 - pmf (sds R13) a"
   and R27_R13 [simp]: "pmf (sds R27) a = pmf (sds R13) a" 
   using R27_R13.strategyproofness(1) R13_R27.strategyproofness(1) lottery_conditions[OF R13.wf] by auto
 
 lemma R13 [simp]: "pmf (sds R13) a = 1/2" "pmf (sds R13) b = 0" "pmf (sds R13) c = 0" "pmf (sds R13) d = 1/2"
   using R15_R13.strategyproofness(1) R13_R15.strategyproofness(1) R13_aux by simp_all
 
 lemma R27 [simp]: "pmf (sds R27) a = 1/2" "pmf (sds R27) b = 0" "pmf (sds R27) c = 0" "pmf (sds R27) d = 1/2"
   by simp_all
 
 lemma R19 [simp]: "pmf (sds R19) a = 1/2" "pmf (sds R19) b = 0" "pmf (sds R19) c = 0" "pmf (sds R19) d = 1/2"
 proof -
   have "pmf (sds R19) a = 1/2 \<and> pmf (sds R19) b = 0 \<and> pmf (sds R19) c = 0 \<and> pmf (sds R19) d = 1/2"
   proof (rule disjE[OF R19.support]; safe)
     assume [simp]: "pmf (sds R19) b = 0"
     from R10_R19.strategyproofness(1) lottery_conditions[OF R19.wf] 
       have "pmf (sds R19) a + pmf (sds R19) c \<le> 1/2" by auto
     moreover from R19_R10.strategyproofness(1) 
       have "pmf (sds R19) a + pmf (sds R19) c \<ge> 1/2" by simp
     ultimately show "pmf (sds R19) d = 1/2" using lottery_conditions[OF R19.wf] by simp
     with R27_R19.strategyproofness(1) lottery_conditions[OF R19.wf] 
       show "pmf (sds R19) a = 1/2" "pmf (sds R19) c = 0" by auto
   next
     assume [simp]: "pmf (sds R19) c = 0"
     from R19_R10.strategyproofness(1) have "pmf (sds R19) a \<ge> 1/2" by auto
     moreover from R19_R27.strategyproofness(1) have "pmf (sds R19) d \<ge> 1/2" by auto
     ultimately show "pmf (sds R19) a = 1/2" "pmf (sds R19) d = 1/2" "pmf (sds R19) b = 0"
       using lottery_conditions[OF R19.wf] by (auto simp del: pmf_nonneg)
   qed
   thus "pmf (sds R19) a = 1/2" "pmf (sds R19) b = 0" "pmf (sds R19) c = 0" "pmf (sds R19) d = 1/2" 
     by blast+
 qed
 
 lemma R1 [simp]: "pmf (sds R1) a = 1/2" "pmf (sds R1) b = 0"
 proof -
   from R19_R1.strategyproofness(1) lottery_conditions[OF R1.wf]
     have "pmf (sds R1) a + pmf (sds R1) b \<le> 1/2" by simp
   with R1_R19.strategyproofness(1) lottery_conditions[OF R1.wf]
     show "pmf (sds R1) a = 1/2" "pmf (sds R1) b = 0" by auto
 qed
 
 lemma R22 [simp]: "pmf (sds R22) a = 1/2" "pmf (sds R22) b = 0" "pmf (sds R22) c = 0" "pmf (sds R22) d = 1/2"
 proof -
   from R33_R5.strategyproofness(1) R33.support
     have "1/2 \<le> pmf (sds R33) a" by auto
   also from R33_R22.strategyproofness(1) R22.support R33.support 
     lottery_conditions[OF R22.wf] lottery_conditions[OF R33.wf]
     have "\<dots> \<le> pmf (sds R22) a" by simp
   finally show "pmf (sds R22) a = 1/2" "pmf (sds R22) b = 0" "pmf (sds R22) c = 0" "pmf (sds R22) d = 1/2"
     using R22_R29.strategyproofness(1) lottery_conditions[OF R22.wf] by (auto simp del: pmf_nonneg)
 qed
 
 lemma R28 [simp]: "pmf (sds R28) a = 1/2" "pmf (sds R28) b = 0" "pmf (sds R28) c = 0" "pmf (sds R28) d = 1/2"
 proof -
   have "pmf (sds R28) a \<le> pmf (sds R32) d"
     using R32_R28.strategyproofness(1) lottery_conditions[OF R32.wf] by auto
   hence R32_d: "pmf (sds R32) d = pmf (sds R28) a"
     using R28_R32.strategyproofness(1) lottery_conditions[OF R32.wf] by auto
 
   from R22_R32.strategyproofness(1) lottery_conditions[OF R32.wf] R32.support 
     have "pmf (sds R32) a \<le> 1/2" by auto
   with R32_R22.strategyproofness(1) lottery_conditions[OF R32.wf] R32.support 
     show "pmf (sds R28) a = 1/2" "pmf (sds R28) b = 0" "pmf (sds R28) c = 0" "pmf (sds R28) d = 1/2"
     by (auto simp: R32_d simp del: pmf_nonneg)
 qed
 
 lemma R39 [simp]: "pmf (sds R39) a = 1/2" "pmf (sds R39) b = 0" "pmf (sds R39) c = 0" "pmf (sds R39) d = 1/2"
 proof -
   from R28_R39.strategyproofness(1) show "pmf (sds R39) c = 0" by simp
   thus "pmf (sds R39) a = 1/2" "pmf (sds R39) b = 0" "pmf (sds R39) d = 1/2"
     by simp_all
 qed
 
 lemma R2 [simp]: "pmf (sds R2) a = 1/2" "pmf (sds R2) b = 0" "pmf (sds R2) c = 0" "pmf (sds R2) d = 1/2"
 proof -
   from R1_R2.strategyproofness(1) R2_R1.strategyproofness(1) lottery_conditions[OF R2.wf] lottery_conditions[OF R1.wf]
     have "pmf (sds R2) a = 1/2" "pmf (sds R2) c + pmf (sds R2) d = 1/2" 
     by (auto simp: algebra_simps simp del: pmf_nonneg)
   with R39_R2.strategyproofness(1) lottery_conditions[OF R2.wf]
     show "pmf (sds R2) a = 1/2" "pmf (sds R2) b = 0" "pmf (sds R2) c = 0" "pmf (sds R2) d = 1/2"
     by auto
 qed
 
 lemma R42 [simp]: "pmf (sds R42) a = 0" "pmf (sds R42) b = 0" "pmf (sds R42) c = 1/2" "pmf (sds R42) d = 1/2"
 proof -
   from R17_R5.strategyproofness(1) lottery_conditions[OF R17.wf] R17.support 
     have "pmf (sds R17) d \<le> 1/2" by auto
   moreover from R5_R17.strategyproofness(1) R17.support lottery_conditions[OF R17.wf] 
     have "pmf (sds R17) d \<ge> 1/2" by auto
   ultimately have R17_d: "pmf (sds R17) d = 1/2" by simp
 
   from R6_R42.strategyproofness(1) 
     have "pmf (sds R42) a + pmf (sds R42) c \<le> pmf (sds R6) a + pmf (sds R6) c" by simp
   also from R6_R19.strategyproofness(1) lottery_conditions[OF R6.wf] 
     have "pmf (sds R6) a + pmf (sds R6) c \<le> 1/2" by (auto simp del: pmf_nonneg)
   finally have "pmf (sds R42) a + pmf (sds R42) c \<le> 1 / 2" .
   moreover from R17_R11.strategyproofness(1) R11.support R17.support
        lottery_conditions[OF R11.wf] lottery_conditions[OF R17.wf]
     have "pmf (sds R11) d \<ge> 1/2" by (auto simp: R17_d)
   ultimately have "pmf (sds R42) a + pmf (sds R42) c \<le> pmf (sds R11) d" by simp
   with R42_R11.strategyproofness(1) R11.support
     have E: "pmf (sds R11) d \<le> pmf (sds R42) c" by auto
   with \<open>pmf (sds R11) d \<ge> 1/2\<close> have "pmf (sds R42) c \<ge> 1/2" by simp
   moreover from R17_R3.strategyproofness(1) R3.support R17.support
        lottery_conditions[OF R17.wf] lottery_conditions[OF R3.wf] 
     have "pmf (sds R3) d \<ge> 1/2" by (auto simp: R17_d)
   ultimately show "pmf (sds R42) a = 0" "pmf (sds R42) b = 0" "pmf (sds R42) c = 1/2" "pmf (sds R42) d = 1/2"
     using R42_R3.strategyproofness(1) lottery_conditions[OF R3.wf] lottery_conditions[OF R42.wf]
     by linarith+
 qed
 
 lemma R37 [simp]: "pmf (sds R37) a = 1/2" "pmf (sds R37) b = 0" "pmf (sds R37) c = 1/2" "pmf (sds R37) d = 0"
 proof -
   from R37_R42.strategyproofness(1) lottery_conditions[OF R37.wf]
     have "pmf (sds R37) a = 1/2 \<or> pmf (sds R37) a + pmf (sds R37) b > 1/2"
     by (auto simp del: pmf_nonneg)
   moreover from R37_R42.strategyproofness(2) lottery_conditions[OF R37.wf]
     have "pmf (sds R37) c = 1/2 \<or> pmf (sds R37) c + pmf (sds R37) d > 1/2" 
     by (auto simp del: pmf_nonneg)
   ultimately show "pmf (sds R37) a = 1/2" "pmf (sds R37) b = 0" "pmf (sds R37) c = 1/2" "pmf (sds R37) d = 0"
     using lottery_conditions[OF R37.wf] by (auto simp del: pmf_nonneg)
 qed
 
 lemma R24 [simp]: "pmf (sds R24) a = 0" "pmf (sds R24) b = 0" "pmf (sds R24) d = 1 - pmf (sds R24) c"
   using R42_R24.strategyproofness(1) lottery_conditions[OF R24.wf] by (auto simp del: pmf_nonneg)
 
 lemma R34 [simp]:
   "pmf (sds R34) a = 1 - pmf (sds R24) c" "pmf (sds R34) b = pmf (sds R24) c"
   "pmf (sds R34) c = 0" "pmf (sds R34) d = 0"
 proof -
   from R24_R34.strategyproofness(1) lottery_conditions[OF R34.wf] 
     have "pmf (sds R34) b \<le> pmf (sds R24) c" by (auto simp del: pmf_nonneg)
   moreover from R34_R24.strategyproofness(1) lottery_conditions[OF R34.wf] 
     have "pmf (sds R34) b \<ge> pmf (sds R24) c" by auto
   ultimately show bc: "pmf (sds R34) b = pmf (sds R24) c" by simp
   from R34_R24.strategyproofness(1) bc lottery_conditions[OF R34.wf] 
     show "pmf (sds R34) c = 0" by auto
   moreover from R24_R34.strategyproofness(1) bc show "pmf (sds R34) d = 0" by simp
   ultimately show "pmf (sds R34) a = 1 - pmf (sds R24) c"
     using bc lottery_conditions[OF R34.wf] by auto
 qed
 
 lemma R14 [simp]: "pmf (sds R14) b = 0" "pmf (sds R14) d = 0" "pmf (sds R14) c = 1 - pmf (sds R14) a"
   using R14_R34.strategyproofness(1) R14.support lottery_conditions[OF R14.wf] 
   by (auto simp del: pmf_nonneg)
 
 lemma R46 [simp]: "pmf (sds R46) a = 0" "pmf (sds R46) c = 0" "pmf (sds R46) d = 1 - pmf (sds R46) b"
   using R46_R37.strategyproofness(1) lottery_conditions[OF R46.wf] by auto
 
 lemma R20 [simp]: "pmf (sds R20) a = 0" "pmf (sds R20) c = 0" "pmf (sds R20) d = 1 - pmf (sds R20) b" 
   using R46_R20.strategyproofness(1) lottery_conditions[OF R20.wf] by (auto simp del: pmf_nonneg)
 
 lemma R21 [simp]: "pmf (sds R21) d = 1 - pmf (sds R21) a" "pmf (sds R21) b = 0" "pmf (sds R21) c = 0"
   using R20_R21.strategyproofness(1) lottery_conditions[OF R21.wf] by auto
 
 
 lemma R16_R12: "pmf (sds R16) c + pmf (sds R16) a \<le> pmf (sds R12) a"
   using R12_R16.strategyproofness(1) R16.support lottery_conditions[OF R16.wf] by auto
 
 lemma R16 [simp]: "pmf (sds R16) b = 0" "pmf (sds R16) c = 0" "pmf (sds R16) d = 1 - pmf (sds R16) a"
 proof -
   from R16_R12 have "pmf (sds R16) c + pmf (sds R16) a \<le> pmf (sds R12) a" by simp
   also from R44_R40.strategyproofness(1) lottery_conditions[OF R40.wf] R40.support
     have "pmf (sds R12) a \<le> pmf (sds R40) a" by auto
   also from R9_R40.strategyproofness(1) R9.support R40.support 
     have "pmf (sds R40) a \<le> pmf (sds R9) a" by auto
   finally have "pmf (sds R16) c + pmf (sds R16) a \<le> pmf (sds R9) a" by simp
   moreover from R14_R16.strategyproofness(1) R16.support lottery_conditions[OF R16.wf] 
     have "pmf (sds R16) a \<ge> pmf (sds R14) a" by auto
   ultimately have "pmf (sds R16) c \<le> pmf (sds R9) a - pmf (sds R14) a" by simp
   also from R14_R9.strategyproofness(1) R9.support lottery_conditions[OF R9.wf]
     have "pmf (sds R9) a - pmf (sds R14) a \<le> 0" by (auto simp del: pmf_nonneg)
   finally show "pmf (sds R16) b = 0" "pmf (sds R16) c = 0" "pmf (sds R16) d = 1 - pmf (sds R16) a"
     using lottery_conditions[OF R16.wf] R16.support by auto
 qed
 
 lemma R12_R14: "pmf (sds R14) a \<le> pmf (sds R12) a"
   using R14_R16.strategyproofness(1) R16_R12 by auto
 
 lemma R12_a [simp]: "pmf (sds R12) a = pmf (sds R9) a"
 proof -
   from R44_R40.strategyproofness(1) R40.support lottery_conditions[OF R40.wf] 
     have "pmf (sds R12) a \<le> pmf (sds R40) a" by auto
   also from R9_R40.strategyproofness(1) R9.support R40.support 
     have "pmf (sds R40) a \<le> pmf (sds R9) a" by auto
   finally have B: "pmf (sds R12) a \<le> pmf (sds R9) a" by simp
   moreover from R14_R9.strategyproofness(1) lottery_conditions[OF R9.wf] R9.support 
     have "pmf (sds R9) a \<le> pmf (sds R14) a" by (auto simp del: pmf_nonneg)
   with R12_R14 have "pmf (sds R9) a \<le> pmf (sds R12) a" by simp
   ultimately show "pmf (sds R12) a = pmf (sds R9) a" by simp
 qed
 
 lemma R9 [simp]: "pmf (sds R9) b = 0" "pmf (sds R9) d = 0" "pmf (sds R14) a = pmf (sds R35) a" "pmf (sds R9) c = 1 - pmf (sds R35) a"
   using R12_R14 R14_R9.strategyproofness(1) lottery_conditions[OF R9.wf] R9.support
   by auto
 
 lemma R23 [simp]: "pmf (sds R23) b = 0" "pmf (sds R23) c = 0" "pmf (sds R23) d = 1 - pmf (sds R23) a"
   using R23_R19.strategyproofness(1) lottery_conditions[OF R23.wf] R23.support 
   by (auto simp del: pmf_nonneg)
 
 lemma R35 [simp]: "pmf (sds R35) a = pmf (sds R21) a" "pmf (sds R35) b = 0" "pmf (sds R35) c = 0" "pmf (sds R35) d = 1 - pmf (sds R21) a"
 proof -
   from R35_R21.strategyproofness(1) R35.support
     have "pmf (sds R21) a \<le> pmf (sds R35) a + pmf (sds R35) c" by auto
   with R21_R35.strategyproofness(1) R35.support lottery_conditions[OF R35.wf]
     show "pmf (sds R35) a = pmf (sds R21) a" "pmf (sds R35) b = 0" 
          "pmf (sds R35) c = 0" "pmf (sds R35) d = 1 - pmf (sds R21) a" by simp_all
 qed
 
 lemma R18 [simp]: "pmf (sds R18) a = pmf (sds R14) a" "pmf (sds R18) b = 0"
                   "pmf (sds R18) d = 0" "pmf (sds R18) c = 1 - pmf (sds R14) a"
 proof -
  from R23_R12.strategyproofness(1)
     have R21_R23: "pmf (sds R21) a \<le> pmf (sds R23) a" by simp
 
   from R23_R18.strategyproofness(1) 
     have "pmf (sds R18) d \<le> pmf (sds R21) a - pmf (sds R23) a" by simp
   also from R21_R23 have "\<dots> \<le> 0" by simp
   finally show "pmf (sds R18) d = 0" by simp
   with lottery_conditions[OF R18.wf] R18.support
     show "pmf (sds R18) a = pmf (sds R14) a"
          "pmf (sds R18) c = 1 - pmf (sds R14) a" by auto
 qed (insert R18.support, simp_all)
 
 lemma R4 [simp]: "pmf (sds R4) a = pmf (sds R21) a" "pmf (sds R4) b = 0"
                  "pmf (sds R4) c = 1 - pmf (sds R4) a" "pmf (sds R4) d = 0"
 proof -
   from R30_R21.strategyproofness(1) R30.support lottery_conditions[OF R30.wf] 
     have "pmf (sds R4) c + pmf (sds R21) a \<le> pmf (sds R4) c + pmf (sds R30) a" by auto
   also {
     have "pmf (sds R30) a \<le> pmf (sds R47) a"
       using R47_R30.strategyproofness(1) R30.support R47.support 
              lottery_conditions[OF R4.wf] lottery_conditions[OF R47.wf] by auto
     moreover from R4_R47.strategyproofness(1) R4.support R47.support
            lottery_conditions[OF R4.wf] lottery_conditions[OF R47.wf]
       have "pmf (sds R4) c \<le> pmf (sds R47) c" by simp
     ultimately have "pmf (sds R4) c + pmf (sds R30) a \<le> 1 - pmf (sds R47) d" 
       using lottery_conditions[OF R47.wf] R47.support by simp
   }
   finally have "pmf (sds R4) c + pmf (sds R14) a \<le> 1"
     using lottery_conditions[OF R47.wf] by (auto simp del: pmf_nonneg)
   with R4_R18.strategyproofness(1) lottery_conditions[OF R4.wf] R4.support
     show "pmf (sds R4) a = pmf (sds R21) a" "pmf (sds R4) b = 0"
          "pmf (sds R4) c = 1 - pmf (sds R4) a" "pmf (sds R4) d = 0" by auto
 qed
 
 lemma R8_d [simp]: "pmf (sds R8) d = 1 - pmf (sds R8) a"
   and R8_c [simp]: "pmf (sds R8) c = 0"
   and R26_a [simp]: "pmf (sds R26) a = 1 - pmf (sds R8) a"
 proof -
   from R8_R26.strategyproofness(2) R8.support lottery_conditions[OF R8.wf] 
     have "pmf (sds R26) a \<le> pmf (sds R8) d" by auto
   with R26_R8.strategyproofness(2) R8.support lottery_conditions[OF R8.wf] 
     have "pmf (sds R26) a = pmf (sds R8) d" by auto
   with R8_R26.strategyproofness(2) R8.support lottery_conditions[OF R8.wf]
     show "pmf (sds R8) c = 0" "pmf (sds R8) d = 1 - pmf (sds R8) a" 
          "pmf (sds R26) a = 1 - pmf (sds R8) a" by (auto simp del: pmf_nonneg)
 qed
 
 lemma R21_R47: "pmf (sds R21) d \<le> pmf (sds R47) c"
   using R4_R47.strategyproofness(1) R4.support R47.support
          lottery_conditions[OF R4.wf] lottery_conditions[OF R47.wf] 
   by auto
 
 lemma R30 [simp]: "pmf (sds R30) a = pmf (sds R47) a" "pmf (sds R30) b = 0" 
   "pmf (sds R30) c = 0" "pmf (sds R30) d = 1 - pmf (sds R47) a"
 proof -
   have A: "pmf (sds R30) a \<le> pmf (sds R47) a"
     using R47_R30.strategyproofness(1) R30.support R47.support 
            lottery_conditions[OF R4.wf] lottery_conditions[OF R47.wf] by auto
   with R21_R47 R30_R21.strategyproofness(1) 
     lottery_conditions[OF R30.wf] lottery_conditions[OF R47.wf]
     show "pmf (sds R30) a = pmf (sds R47) a" "pmf (sds R30) b = 0" 
          "pmf (sds R30) c = 0" "pmf (sds R30) d = 1 - pmf (sds R47) a"
       by (auto simp: R30.support R47.support simp del: pmf_nonneg) (* tricky step! *)
 qed
 
 lemma R31_c_ge_one_half: "pmf (sds R31) c \<ge> 1/2"
 proof -
   from R25.support have "pmf (sds R25) a \<ge> 1/2"
   proof
     assume "pmf (sds R25) c = 0"
     with R25_R36.strategyproofness(1) lottery_conditions[OF R36.wf]
        show "pmf (sds R25) a \<ge> 1/2" by (auto simp del: pmf_nonneg)
   next
     assume [simp]: "pmf (sds R25) b = 0"
     from R36_R25.strategyproofness(1) lottery_conditions[OF R25.wf]
       have "pmf (sds R25) c + pmf (sds R25) a \<le> pmf (sds R36) c + 1 / 2" by auto
     with R25_R36.strategyproofness(1) show "pmf (sds R25) a \<ge> 1/2" by auto
   qed
   hence "pmf (sds R26) a \<ge> 1/2"
     using R25_R26.strategyproofness(1) lottery_conditions[OF R25.wf] by (auto simp del: pmf_nonneg)
   with lottery_conditions[OF R47.wf]
     have "1/2 \<le> pmf (sds R26) a + pmf (sds R47) d" by (simp del: pmf_nonneg)
   also have "\<dots> = 1 - pmf (sds R8) a + pmf (sds R47) d" by simp
   also from R4_R8.strategyproofness(1) 
     have "1 - pmf (sds R8) a \<le> pmf (sds R21) d" by auto
   also note R21_R47
   also from R30_R41.strategyproofness(1) R41.support 
             lottery_conditions[OF R41.wf] lottery_conditions[OF R47.wf] 
     have "pmf (sds R47) c + pmf (sds R47) d \<le> pmf (sds R41) d" by (auto simp del: pmf_nonneg)
   also from R41_R31.strategyproofness(1) R41.support lottery_conditions[OF R31.wf] 
        lottery_conditions[OF R41.wf]  
     have "pmf (sds R41) d \<le> pmf (sds R31) c" by auto
   finally show "pmf (sds R31) c \<ge> 1/2" by simp
 qed
 
 lemma R31: "pmf (sds R31) a = 0" "pmf (sds R31) c = 1/2" "pmf (sds R31) b + pmf (sds R31) d = 1/2"
 proof -
   from R2_R38.strategyproofness(1) lottery_conditions[OF R38.wf] 
     have A: "pmf (sds R38) b + pmf (sds R38) d \<ge> 1/2" by auto
   with R31_c_ge_one_half R31_R38.strategyproofness(1) 
         lottery_conditions[OF R31.wf] lottery_conditions[OF R38.wf]
   have "pmf (sds R38) b + pmf (sds R38) d = pmf (sds R31) d + pmf (sds R31) b" by auto
   with R31_c_ge_one_half A lottery_conditions[OF R31.wf] lottery_conditions[OF R38.wf]
     show "pmf (sds R31) a = 0" "pmf (sds R31) c = 1/2" "pmf (sds R31) b + pmf (sds R31) d = 1/2"
     by linarith+
 qed
 
 lemma absurd: False
   using R31 R45_R31.strategyproofness(2) by simp
 
 
 (* TODO (Re-)move *)
 (* This is just to output a list of all the Strategy-Proofness conditions used in the proof *)
 (*
 ML_val \<open>
 let
 val thms = @{thms
 R1_R2.strategyproofness(1)
 R1_R19.strategyproofness(1)
 R2_R1.strategyproofness(1)
 R2_R38.strategyproofness(1)
 R4_R8.strategyproofness(1)
 R4_R18.strategyproofness(1)
 R4_R47.strategyproofness(1)
 R5_R7.strategyproofness(1)
 R5_R10.strategyproofness(1)
 R5_R17.strategyproofness(1)
 R6_R19.strategyproofness(1)
 R6_R42.strategyproofness(1)
 R7_R43.strategyproofness(1)
 R8_R26.strategyproofness(2)
 R9_R18.strategyproofness(1)
 R9_R35.strategyproofness(1)
 R9_R40.strategyproofness(1)
 R10_R12.strategyproofness(1)
 R10_R15.strategyproofness(1)
 R10_R19.strategyproofness(1)
 R10_R36.strategyproofness(1)
 R12_R10.strategyproofness(1)
 R12_R16.strategyproofness(1)
 R12_R44.strategyproofness(1)
 R13_R15.strategyproofness(1)
 R13_R27.strategyproofness(1)
 R14_R9.strategyproofness(1)
 R14_R16.strategyproofness(1)
 R14_R34.strategyproofness(1)
 R15_R5.strategyproofness(1)
 R15_R7.strategyproofness(1)
 R15_R10.strategyproofness(1)
 R15_R13.strategyproofness(1)
 R17_R3.strategyproofness(1)
 R17_R5.strategyproofness(1)
 R17_R7.strategyproofness(1)
 R17_R11.strategyproofness(1)
 R18_R9.strategyproofness(1)
 R19_R1.strategyproofness(1)
 R19_R10.strategyproofness(1)
 R19_R27.strategyproofness(1)
 R20_R21.strategyproofness(1)
 R21_R35.strategyproofness(1)
 R22_R29.strategyproofness(1)
 R22_R32.strategyproofness(1)
 R23_R12.strategyproofness(1)
 R23_R18.strategyproofness(1)
 R23_R19.strategyproofness(1)
 R24_R34.strategyproofness(1)
 R25_R26.strategyproofness(1)
 R25_R36.strategyproofness(1)
 R26_R8.strategyproofness(2)
 R27_R13.strategyproofness(1)
 R27_R19.strategyproofness(1)
 R28_R32.strategyproofness(1)
 R28_R39.strategyproofness(1)
 R29_R39.strategyproofness(1)
 R30_R21.strategyproofness(1)
 R30_R41.strategyproofness(1)
 R31_R38.strategyproofness(1)
 R32_R22.strategyproofness(1)
 R32_R28.strategyproofness(1)
 R33_R5.strategyproofness(1)
 R33_R22.strategyproofness(1)
 R34_R24.strategyproofness(1)
 R35_R9.strategyproofness(1)
 R35_R21.strategyproofness(1)
 R36_R10.strategyproofness(1)
 R36_R25.strategyproofness(1)
 R36_R39.strategyproofness(1)
 R37_R42.strategyproofness(1)
 R37_R42.strategyproofness(2)
 R39_R2.strategyproofness(1)
 R39_R29.strategyproofness(1)
 R39_R36.strategyproofness(1)
 R41_R31.strategyproofness(1)
 R42_R3.strategyproofness(1)
 R42_R11.strategyproofness(1)
 R42_R24.strategyproofness(1)
 R44_R12.strategyproofness(1)
 R44_R40.strategyproofness(1)
 R45_R31.strategyproofness(2)
 R46_R20.strategyproofness(1)
 R46_R37.strategyproofness(1)
 R47_R30.strategyproofness(1)
 };
 in
  thms
  |> map (Pretty.quote o Pretty.str o Pretty.unformatted_string_of o Syntax.pretty_term @{context} o Thm.prop_of)
  |> Pretty.list "[" "]"
  |> (fn x => Pretty.block [Pretty.str "thms = ", x])
  |> Pretty.string_of
  |> writeln
 end
 \<close>*)
 
 end
 
 
 subsection \<open>Lifting to more than 4 agents and alternatives\<close>
 
 (* TODO: Move? *)
 lemma finite_list':
   assumes "finite A"
   obtains xs where "A = set xs" "distinct xs" "length xs = card A"
 proof -
   from assms obtain xs where "set xs = A" using finite_list by blast
   thus ?thesis using distinct_card[of "remdups xs"]
     by (intro that[of "remdups xs"]) simp_all
 qed
 
 lemma finite_list_subset:
   assumes "finite A" "card A \<ge> n"
   obtains xs where "set xs \<subseteq> A" "distinct xs" "length xs = n"
 proof -
   obtain xs where "A = set xs" "distinct xs" "length xs = card A"
     using finite_list'[OF assms(1)] by blast
   with assms show ?thesis
     by (intro that[of "take n xs"]) (simp_all add: set_take_subset)
 qed
 
 lemma card_ge_4E:
   assumes "finite A" "card A \<ge> 4"
   obtains a b c d where "distinct [a,b,c,d]" "{a,b,c,d} \<subseteq> A"
 proof -
-  from finite_list_subset[OF assms] guess xs .
-  moreover then obtain a b c d where "xs = [a, b, c, d]" 
+  from assms obtain xs where xs: "set xs \<subseteq> A" "distinct xs" "length xs = 4"
+    by (rule finite_list_subset)
+  then obtain a b c d where "xs = [a, b, c, d]" 
     by (auto simp: eval_nat_numeral length_Suc_conv)
-  ultimately show ?thesis by (intro that[of a b c d]) simp_all
+  with xs show ?thesis by (intro that[of a b c d]) simp_all
 qed
 
 
 context sds_impossibility
 begin
 
 lemma absurd: False
 proof -
-  from card_ge_4E[OF finite_agents agents_ge_4] guess A1 A2 A3 A4 .
-  note agents = this
-  from card_ge_4E[OF finite_alts alts_ge_4] guess a b c d .
-  note alts = this
+  from card_ge_4E[OF finite_agents agents_ge_4]
+  obtain A1 A2 A3 A4 where agents: "distinct [A1, A2, A3, A4]" "{A1, A2, A3, A4} \<subseteq> agents" .
+  from card_ge_4E[OF finite_alts alts_ge_4]
+  obtain a b c d where alts: "distinct [a, b, c, d]" "{a, b, c, d} \<subseteq> alts" .
   define agents' alts' where "agents' = {A1,A2,A3,A4}" and "alts' = {a,b,c,d}"
   from agents alts 
     interpret sds_lowering_anonymous_neutral_sdeff_stratproof agents alts sds agents' alts'
     unfolding agents'_def alts'_def by unfold_locales simp_all
   from agents alts 
     interpret sds_impossibility_4_4 agents' alts' lowered A1 A2 A3 A4 a b c d
     by unfold_locales (simp_all add: agents'_def alts'_def)
   from absurd show False .
 qed
 
 end
 
 end
diff --git a/thys/Stirling_Formula/Gamma_Asymptotics.thy b/thys/Stirling_Formula/Gamma_Asymptotics.thy
--- a/thys/Stirling_Formula/Gamma_Asymptotics.thy
+++ b/thys/Stirling_Formula/Gamma_Asymptotics.thy
@@ -1,1891 +1,1893 @@
 (*
   File:    Gamma_Asymptotics.thy
   Author:  Manuel Eberl
 
   The complete asymptotics of the real and complex logarithmic Gamma functions.
   Also of the real Polygamma functions (could be extended to the complex ones fairly easily
   if needed).
 *)
 section \<open>Complete asymptotics of the logarithmic Gamma function\<close>
 theory Gamma_Asymptotics
 imports 
   "HOL-Complex_Analysis.Complex_Analysis"
   "HOL-Real_Asymp.Real_Asymp"
   Bernoulli.Bernoulli_FPS 
   Bernoulli.Periodic_Bernpoly 
   Stirling_Formula
 begin
 
 subsection \<open>Auxiliary Facts\<close>
 
 (* TODO: could be automated with Laurent series expansions in the future *)
 lemma stirling_limit_aux1: 
   "((\<lambda>y. Ln (1 + z * of_real y) / of_real y) \<longlongrightarrow> z) (at_right 0)" for z :: complex
 proof (cases "z = 0")
   case True
   then show ?thesis by simp
 next
   case False
   have "((\<lambda>y. ln (1 + z * of_real y)) has_vector_derivative 1 * z) (at 0)"
     by (rule has_vector_derivative_real_field) (auto intro!: derivative_eq_intros)
   then have "(\<lambda>y. (Ln (1 + z * of_real y) - of_real y * z) / of_real \<bar>y\<bar>) \<midarrow>0\<rightarrow> 0"
     by (auto simp add: has_vector_derivative_def has_derivative_def netlimit_at 
           scaleR_conv_of_real field_simps)
   then have "((\<lambda>y. (Ln (1 + z * of_real y) - of_real y * z) / of_real \<bar>y\<bar>) \<longlongrightarrow> 0) (at_right 0)"
     by (rule filterlim_mono[OF _ _ at_le]) simp_all
   also have "?this \<longleftrightarrow> ((\<lambda>y. Ln (1 + z * of_real y) / (of_real y) - z) \<longlongrightarrow> 0) (at_right 0)"
     using eventually_at_right_less[of "0::real"]
     by (intro filterlim_cong refl) (auto elim!: eventually_mono simp: field_simps)
   finally show ?thesis by (simp only: LIM_zero_iff)
 qed
   
 lemma stirling_limit_aux2: 
   "((\<lambda>y. y * Ln (1 + z / of_real y)) \<longlongrightarrow> z) at_top" for z :: complex
   using stirling_limit_aux1[of z] by (subst filterlim_at_top_to_right) (simp add: field_simps)
 
 lemma Union_atLeastAtMost: 
   assumes "N > 0" 
   shows   "(\<Union>n\<in>{0..<N}. {real n..real (n + 1)}) = {0..real N}"
 proof (intro equalityI subsetI)
   fix x assume x: "x \<in> {0..real N}"
   thus "x \<in> (\<Union>n\<in>{0..<N}. {real n..real (n + 1)})"
   proof (cases "x = real N")
     case True
     with assms show ?thesis by (auto intro!: bexI[of _ "N - 1"])
   next
     case False
     with x have x: "x \<ge> 0" "x < real N" by simp_all
     hence "x \<ge> real (nat \<lfloor>x\<rfloor>)" "x \<le> real (nat \<lfloor>x\<rfloor> + 1)" by linarith+
     moreover from x have "nat \<lfloor>x\<rfloor> < N" by linarith
     ultimately have "\<exists>n\<in>{0..<N}. x \<in> {real n..real (n + 1)}"
       by (intro bexI[of _ "nat \<lfloor>x\<rfloor>"]) simp_all
     thus ?thesis by blast
   qed
 qed auto
 
 
 subsection \<open>Cones in the complex plane\<close>
 
 definition complex_cone :: "real \<Rightarrow> real \<Rightarrow> complex set" where
   "complex_cone a b = {z. \<exists>y\<in>{a..b}. z = rcis (norm z) y}"
 
 abbreviation complex_cone' :: "real \<Rightarrow> complex set" where
   "complex_cone' a \<equiv> complex_cone (-a) a"
 
 lemma zero_in_complex_cone [simp, intro]: "a \<le> b \<Longrightarrow> 0 \<in> complex_cone a b"
   by (auto simp: complex_cone_def)
 
 lemma complex_coneE:
   assumes "z \<in> complex_cone a b"
   obtains r \<alpha> where "r \<ge> 0" "\<alpha> \<in> {a..b}" "z = rcis r \<alpha>"
 proof -
   from assms obtain y where "y \<in> {a..b}" "z = rcis (norm z) y"
     unfolding complex_cone_def by auto
   thus ?thesis using that[of "norm z" y] by auto
 qed
 
 lemma arg_cis [simp]:
   assumes "x \<in> {-pi<..pi}"
   shows   "Arg (cis x) = x"
   using assms by (intro cis_Arg_unique) auto
 
 lemma arg_mult_of_real_left [simp]:
   assumes "r > 0"
   shows   "Arg (of_real r * z) = Arg z"
 proof (cases "z = 0")
   case False
   thus ?thesis
     using Arg_bounded[of z] assms
     by (intro cis_Arg_unique) (auto simp: sgn_mult sgn_of_real cis_Arg)
 qed auto
 
 lemma arg_mult_of_real_right [simp]:
   assumes "r > 0"
   shows   "Arg (z * of_real r) = Arg z"
   by (subst mult.commute, subst arg_mult_of_real_left) (simp_all add: assms)
 
 lemma arg_rcis [simp]:
   assumes "x \<in> {-pi<..pi}" "r > 0"
   shows   "Arg (rcis r x) = x"
   using assms by (simp add: rcis_def)
 
 lemma rcis_in_complex_cone [intro]: 
   assumes "\<alpha> \<in> {a..b}" "r \<ge> 0"
   shows   "rcis r \<alpha> \<in> complex_cone a b"
   using assms by (auto simp: complex_cone_def)  
 
 lemma arg_imp_in_complex_cone:
   assumes "Arg z \<in> {a..b}"
   shows   "z \<in> complex_cone a b"
 proof -
   have "z = rcis (norm z) (Arg z)"
     by (simp add: rcis_cmod_Arg)
   also have "\<dots> \<in> complex_cone a b"
     using assms by auto
   finally show ?thesis .
 qed
 
 lemma complex_cone_altdef:
   assumes "-pi < a" "a \<le> b" "b \<le> pi"
   shows   "complex_cone a b = insert 0 {z. Arg z \<in> {a..b}}"
 proof (intro equalityI subsetI)
   fix z assume "z \<in> complex_cone a b"
   then obtain r \<alpha> where *: "r \<ge> 0" "\<alpha> \<in> {a..b}" "z = rcis r \<alpha>"
     by (auto elim: complex_coneE)
   have "Arg z \<in> {a..b}" if [simp]: "z \<noteq> 0"
   proof -
     have "r > 0" using that * by (subst (asm) *) auto
     hence "\<alpha> \<in> {a..b}"
       using *(1,2) assms by (auto simp: *(1))
     moreover from assms *(2) have "\<alpha> \<in> {-pi<..pi}"
       by auto
     ultimately show ?thesis using *(3) \<open>r > 0\<close>
       by (subst *) auto
   qed
   thus "z \<in> insert 0 {z. Arg z \<in> {a..b}}"
     by auto
 qed (use assms in \<open>auto intro: arg_imp_in_complex_cone\<close>)
 
 lemma nonneg_of_real_in_complex_cone [simp, intro]:
   assumes "x \<ge> 0" "a \<le> 0" "0 \<le> b"
   shows   "of_real x \<in> complex_cone a b"
 proof -
   from assms have "rcis x 0 \<in> complex_cone a b"
     by (intro rcis_in_complex_cone) auto
   thus ?thesis by simp
 qed
 
 lemma one_in_complex_cone [simp, intro]: "a \<le> 0 \<Longrightarrow> 0 \<le> b \<Longrightarrow> 1 \<in> complex_cone a b"
   using nonneg_of_real_in_complex_cone[of 1] by (simp del: nonneg_of_real_in_complex_cone)
 
 lemma of_nat_in_complex_cone [simp, intro]: "a \<le> 0 \<Longrightarrow> 0 \<le> b \<Longrightarrow> of_nat n \<in> complex_cone a b"
   using nonneg_of_real_in_complex_cone[of "real n"] by (simp del: nonneg_of_real_in_complex_cone)
 
 
 subsection \<open>Another integral representation of the Beta function\<close>
 
 lemma complex_cone_inter_nonpos_Reals:
   assumes "-pi < a" "a \<le> b" "b < pi"
   shows   "complex_cone a b \<inter> \<real>\<^sub>\<le>\<^sub>0 = {0}"
 proof (safe elim!: nonpos_Reals_cases)
   fix x :: real
   assume "complex_of_real x \<in> complex_cone a b" "x \<le> 0"
   hence "\<not>(x < 0)"
     using assms by (intro notI) (auto simp: complex_cone_altdef)
   with \<open>x \<le> 0\<close> show "complex_of_real x = 0" by auto  
 qed (use assms in auto)
 
 theorem 
   assumes a: "a > 0" and b: "b > (0 :: real)"
   shows has_integral_Beta_real': 
           "((\<lambda>u. u powr (b - 1) / (1 + u) powr (a + b)) has_integral Beta a b) {0<..}"
     and Beta_conv_nn_integral:
           "Beta a b = (\<integral>\<^sup>+u. ennreal (indicator {0<..} u * u powr (b - 1) / (1 + u) powr (a + b)) \<partial>lborel)"
 proof -
   define I where 
     "I = (\<integral>\<^sup>+u. ennreal (indicator {0<..} u * u powr (b - 1) / (1 + u) powr (a + b)) \<partial>lborel)"
   have "Gamma (a + b) > 0" "Beta a b > 0"
     using assms by (simp_all add: add_pos_pos Beta_def)
   from a b have "ennreal (Gamma a * Gamma b) =
     (\<integral>\<^sup>+ t. ennreal (indicator {0..} t * t powr (a - 1) / exp t) \<partial>lborel) *
     (\<integral>\<^sup>+ t. ennreal (indicator {0..} t * t powr (b - 1) / exp t) \<partial>lborel)"
     by (subst ennreal_mult') (simp_all add: Gamma_conv_nn_integral_real)
   also have "\<dots> = (\<integral>\<^sup>+t. \<integral>\<^sup>+u. ennreal (indicator {0..} t * t powr (a - 1) / exp t) *
                             ennreal (indicator {0..} u * u powr (b - 1) / exp u) \<partial>lborel \<partial>lborel)"
     by (simp add: nn_integral_cmult nn_integral_multc)
   also have "\<dots> = (\<integral>\<^sup>+t. indicator {0<..} t * (\<integral>\<^sup>+u. indicator {0..} u * t powr (a - 1) * u powr (b - 1)
                             / exp (t + u) \<partial>lborel) \<partial>lborel)"
     by (intro nn_integral_cong_AE AE_I[of _ _ "{0}"])
        (auto simp: indicator_def divide_ennreal ennreal_mult' [symmetric] exp_add mult_ac)
   also have "\<dots> = (\<integral>\<^sup>+t. indicator {0<..} t * (\<integral>\<^sup>+u. indicator {0..} u * t powr (a - 1) * u powr (b - 1)
                             / exp (t + u) 
                     \<partial>(density (distr lborel borel ((*) t)) (\<lambda>x. ennreal \<bar>t\<bar>))) \<partial>lborel)"
     by (intro nn_integral_cong mult_indicator_cong, subst lborel_distr_mult' [symmetric]) auto
   also have "\<dots> = (\<integral>\<^sup>+(t::real). indicator {0<..} t * (\<integral>\<^sup>+u. 
                      indicator {0..} (u * t) * t powr a *
                      (u * t) powr (b - 1) / exp (t + t * u) \<partial>lborel) \<partial>lborel)"
     by (intro nn_integral_cong mult_indicator_cong)
        (auto simp: nn_integral_density nn_integral_distr algebra_simps powr_diff
              simp flip: ennreal_mult)
   also have "\<dots> = (\<integral>\<^sup>+(t::real). \<integral>\<^sup>+u. indicator ({0<..}\<times>{0..}) (t, u) *
                      t powr a * (u * t) powr (b - 1) / exp (t * (u + 1)) \<partial>lborel \<partial>lborel)"
     by (subst nn_integral_cmult [symmetric], simp, intro nn_integral_cong)
        (auto simp: indicator_def zero_le_mult_iff algebra_simps)
   also have "\<dots> = (\<integral>\<^sup>+(t::real). \<integral>\<^sup>+u. indicator ({0<..}\<times>{0..}) (t, u) *
                      t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1)) \<partial>lborel \<partial>lborel)"
     by (intro nn_integral_cong) (auto simp: powr_add powr_diff indicator_def powr_mult field_simps)
   also have "\<dots> = (\<integral>\<^sup>+(u::real). \<integral>\<^sup>+t. indicator ({0<..}\<times>{0..}) (t, u) *
                      t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1)) \<partial>lborel \<partial>lborel)"
     by (rule lborel_pair.Fubini') auto
   also have "\<dots> = (\<integral>\<^sup>+(u::real). indicator {0..} u * (\<integral>\<^sup>+t. indicator {0<..} t *
                      t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1)) \<partial>lborel) \<partial>lborel)"
     by (intro nn_integral_cong mult_indicator_cong) (auto simp: indicator_def)
   also have "\<dots> = (\<integral>\<^sup>+(u::real). indicator {0<..} u * (\<integral>\<^sup>+t. indicator {0<..} t *
                      t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1)) \<partial>lborel) \<partial>lborel)"
     by (intro nn_integral_cong_AE AE_I[of _ _ "{0}"]) (auto simp: indicator_def)
   also have "\<dots> = (\<integral>\<^sup>+(u::real). indicator {0<..} u * (\<integral>\<^sup>+t. indicator {0<..} t *
                      t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1)) 
                     \<partial>(density (distr lborel borel ((*) (1/(1+u)))) (\<lambda>x. ennreal \<bar>1/(1+u)\<bar>))) \<partial>lborel)"
     by (intro nn_integral_cong mult_indicator_cong, subst lborel_distr_mult' [symmetric]) auto
   also have "\<dots> = (\<integral>\<^sup>+(u::real). indicator {0<..} u * 
                     (\<integral>\<^sup>+t. ennreal (1 / (u + 1)) * ennreal (indicator {0<..} (t / (u + 1)) *
                      (t / (1+u)) powr (a + b - 1) * u powr (b - 1) / exp t)
                     \<partial>lborel) \<partial>lborel)"
     by (intro nn_integral_cong mult_indicator_cong)
        (auto simp: nn_integral_distr nn_integral_density add_ac)
   also have "\<dots> = (\<integral>\<^sup>+u. \<integral>\<^sup>+t. indicator ({0<..}\<times>{0<..}) (u, t) * 
                     1/(u+1) * (t / (u+1)) powr (a + b - 1) * u powr (b - 1) / exp t
                     \<partial>lborel \<partial>lborel)"
     by (subst nn_integral_cmult [symmetric], simp, intro nn_integral_cong)
        (auto simp: indicator_def field_simps divide_ennreal simp flip: ennreal_mult ennreal_mult')
   also have "\<dots> = (\<integral>\<^sup>+u. \<integral>\<^sup>+t. ennreal (indicator {0<..} u * u powr (b - 1) / (1 + u) powr (a + b)) *
                             ennreal (indicator {0<..} t * t powr (a + b - 1) / exp t)
                     \<partial>lborel \<partial>lborel)"
     by (intro nn_integral_cong)
        (auto simp: indicator_def powr_add powr_diff powr_divide powr_minus divide_simps add_ac
              simp flip: ennreal_mult)
   also have "\<dots> = I * (\<integral>\<^sup>+t. indicator {0<..} t * t powr (a + b - 1) / exp t \<partial>lborel)"
     by (simp add: nn_integral_cmult nn_integral_multc I_def)
   also have "(\<integral>\<^sup>+t. indicator {0<..} t * t powr (a + b - 1) / exp t \<partial>lborel) =
                ennreal (Gamma (a + b))"
     using assms
     by (subst Gamma_conv_nn_integral_real)
        (auto intro!: nn_integral_cong_AE[OF AE_I[of _ _ "{0}"]] 
              simp: indicator_def split: if_splits)
   finally have "ennreal (Gamma a * Gamma b) = I * ennreal (Gamma (a + b))" .
   hence "ennreal (Gamma a * Gamma b) / ennreal (Gamma (a + b)) =
            I * ennreal (Gamma (a + b)) / ennreal (Gamma (a + b))" by simp
   also have "\<dots> = I"
     using \<open>Gamma (a + b) > 0\<close> by (intro ennreal_mult_divide_eq) (auto simp: )
   also have "ennreal (Gamma a * Gamma b) / ennreal (Gamma (a + b)) =
                ennreal (Gamma a * Gamma b / Gamma (a + b))"
     using assms by (intro divide_ennreal) auto
   also have "\<dots> = ennreal (Beta a b)"
     by (simp add: Beta_def)
   finally show *: "ennreal (Beta a b) = I" .
 
   define f where "f = (\<lambda>u. u powr (b - 1) / (1 + u) powr (a + b))"
   have "((\<lambda>u. indicator {0<..} u * f u) has_integral Beta a b) UNIV"
     using * \<open>Beta a b > 0\<close>
     by (subst has_integral_iff_nn_integral_lebesgue)
        (auto simp: f_def measurable_completion nn_integral_completion I_def mult_ac)
   also have "(\<lambda>u. indicator {0<..} u * f u) = (\<lambda>u. if u \<in> {0<..} then f u else 0)"
     by (auto simp: fun_eq_iff)
   also have "(\<dots> has_integral Beta a b) UNIV \<longleftrightarrow> (f has_integral Beta a b) {0<..}"
     by (rule has_integral_restrict_UNIV)
   finally show \<dots> by (simp add: f_def)
 qed
 
 lemma has_integral_Beta2:
   fixes a :: real
   assumes "a < -1/2"
   shows   "((\<lambda>x. (1 + x ^ 2) powr a) has_integral Beta (- a - 1 / 2) (1 / 2) / 2) {0<..}"
 proof -
   define f where "f = (\<lambda>u. u powr (-1/2) / (1 + u) powr (-a))"
   define C where "C = Beta (-a-1/2) (1/2)"
   have I: "(f has_integral C) {0<..}"
     using has_integral_Beta_real'[of "-a-1/2" "1/2"] assms
     by (simp_all add: diff_divide_distrib f_def C_def)
 
   define g where "g = (\<lambda>x. x ^ 2 :: real)"
   have bij: "bij_betw g {0<..} {0<..}"
     by (intro bij_betwI[of _ _ _ sqrt]) (auto simp: g_def)
 
   have "(f absolutely_integrable_on g ` {0<..} \<and> integral (g ` {0<..}) f = C)"
     using I bij by (simp add: bij_betw_def has_integral_iff absolutely_integrable_on_def f_def)
   also have "?this \<longleftrightarrow> ((\<lambda>x. \<bar>2 * x\<bar> *\<^sub>R f (g x)) absolutely_integrable_on {0<..} \<and>
                          integral {0<..} (\<lambda>x. \<bar>2 * x\<bar> *\<^sub>R f (g x)) = C)"
     using bij by (intro has_absolute_integral_change_of_variables_1' [symmetric])
                  (auto intro!: derivative_eq_intros simp: g_def bij_betw_def)
   finally have "((\<lambda>x. \<bar>2 * x\<bar> * f (g x)) has_integral C) {0<..}"
     by (simp add: absolutely_integrable_on_def f_def has_integral_iff)
   also have "?this \<longleftrightarrow> ((\<lambda>x::real. 2 * (1 + x\<^sup>2) powr a) has_integral C) {0<..}"
     by (intro has_integral_cong) (auto simp: f_def g_def powr_def exp_minus ln_realpow field_simps)
   finally have "((\<lambda>x::real. 1/2 * (2 * (1 + x\<^sup>2) powr a)) has_integral 1/2 * C) {0<..}"
     by (intro has_integral_mult_right)
   thus ?thesis by (simp add: C_def)
 qed
 
 lemma has_integral_Beta3:
   fixes a b :: real
   assumes "a < -1/2" and "b > 0"
   shows   "((\<lambda>x. (b + x ^ 2) powr a) has_integral
              Beta (-a - 1/2) (1/2) / 2 * b powr (a + 1/2)) {0<..}"
 proof -
   define C where "C = Beta (- a - 1 / 2) (1 / 2) / 2"
   have int: "nn_integral lborel (\<lambda>x. indicator {0<..} x * (1 + x ^ 2) powr a) = C"
     using nn_integral_has_integral_lebesgue[OF _ has_integral_Beta2[OF assms(1)]]
     by (auto simp: C_def)
   have "nn_integral lborel (\<lambda>x. indicator {0<..} x * (b + x ^ 2) powr a) =
         (\<integral>\<^sup>+x. ennreal (indicat_real {0<..} (x * sqrt b) * (b + (x * sqrt b)\<^sup>2) powr a * sqrt b) \<partial>lborel)"
     using assms
     by (subst lborel_distr_mult'[of "sqrt b"])
        (auto simp: nn_integral_density nn_integral_distr mult_ac simp flip: ennreal_mult)
   also have "\<dots> = (\<integral>\<^sup>+x. ennreal (indicat_real {0<..} x * (b * (1 + x ^ 2)) powr a * sqrt b) \<partial>lborel)"
     using assms
     by (intro nn_integral_cong) (auto simp: indicator_def field_simps zero_less_mult_iff)
   also have "\<dots> = (\<integral>\<^sup>+x. ennreal (indicat_real {0<..} x * b powr (a + 1/2) * (1 + x ^ 2) powr a) \<partial>lborel)"
     using assms
     by (intro nn_integral_cong) (auto simp: indicator_def powr_add powr_half_sqrt powr_mult)    
   also have "\<dots> = b powr (a + 1/2) * (\<integral>\<^sup>+x. ennreal (indicat_real {0<..} x * (1 + x ^ 2) powr a) \<partial>lborel)"
     using assms by (subst nn_integral_cmult [symmetric]) (simp_all add: mult_ac flip: ennreal_mult)
   also have "(\<integral>\<^sup>+x. ennreal (indicat_real {0<..} x * (1 + x ^ 2) powr a) \<partial>lborel) = C"
     using int by simp
   also have "ennreal (b powr (a + 1/2)) * ennreal C = ennreal (C * b powr (a + 1/2))"
     using assms by (subst ennreal_mult) (auto simp: C_def mult_ac Beta_def)
   finally have *: "(\<integral>\<^sup>+ x. ennreal (indicat_real {0<..} x * (b + x\<^sup>2) powr a) \<partial>lborel) = \<dots>" .
   hence "((\<lambda>x. indicator {0<..} x * (b + x^2) powr a) has_integral C * b powr (a + 1/2)) UNIV"
     using assms
     by (subst has_integral_iff_nn_integral_lebesgue)
        (auto simp: C_def measurable_completion nn_integral_completion Beta_def)
   also have "(\<lambda>x. indicator {0<..} x * (b + x^2) powr a) =
              (\<lambda>x. if x \<in> {0<..} then (b + x^2) powr a else 0)"
     by (auto simp: fun_eq_iff)
   finally show ?thesis
     by (subst (asm) has_integral_restrict_UNIV) (auto simp: C_def)
 qed
 
   
 subsection \<open>Asymptotics of the real $\log\Gamma$ function and its derivatives\<close>
 
 text \<open>
   This is the error term that occurs in the expansion of @{term ln_Gamma}. It can be shown to 
   be of order $O(s^{-n})$.
 \<close>
 definition stirling_integral :: "nat \<Rightarrow> 'a :: {real_normed_div_algebra, banach} \<Rightarrow> 'a" where
   "stirling_integral n s = 
      lim (\<lambda>N. integral {0..N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n))"
 
 context
   fixes s :: complex assumes s: "s \<notin> \<real>\<^sub>\<le>\<^sub>0"
   fixes approx :: "nat \<Rightarrow> complex"
   defines "approx \<equiv> (\<lambda>N. 
     (\<Sum>n = 1..<N. s / of_nat n - ln (1 + s / of_nat n)) - (euler_mascheroni * s + ln s) - \<comment> \<open>\<open>\<longrightarrow> ln_Gamma s\<close>\<close>
     (ln_Gamma (of_nat N) - ln (2 * pi / of_nat N) / 2 - of_nat N * ln (of_nat N) + of_nat N) - \<comment> \<open>\<open>\<longrightarrow> 0\<close>\<close>
     s * (harm (N - 1) - ln (of_nat (N - 1)) - euler_mascheroni) + \<comment> \<open>\<open>\<longrightarrow> 0\<close>\<close>
     s * (ln (of_nat N + s) - ln (of_nat (N - 1))) - \<comment> \<open>\<open>\<longrightarrow> 0\<close>\<close>
     (1/2) * (ln (of_nat N + s) - ln (of_nat N)) +       \<comment> \<open>\<open>\<longrightarrow> 0\<close>\<close>
     of_nat N * (ln (of_nat N + s) - ln (of_nat N)) -  \<comment> \<open>\<open>\<longrightarrow> s\<close>\<close>
     (s - 1/2) * ln s - ln (2 * pi) / 2)"
 begin       
   
 qualified lemma
   assumes N: "N > 0"
   shows   integrable_pbernpoly_1:
             "(\<lambda>x. of_real (-pbernpoly 1 x) / (of_real x + s)) integrable_on {0..real N}"
   and     integral_pbernpoly_1_aux:
             "integral {0..real N} (\<lambda>x. -of_real (pbernpoly 1 x) / (of_real x + s)) = approx N"
   and     has_integral_pbernpoly_1:
             "((\<lambda>x. pbernpoly 1 x /(x + s)) has_integral 
               (\<Sum>m<N. (of_nat m + 1 / 2 + s) * (ln (of_nat m + s) - 
                         ln (of_nat m + 1 + s)) + 1)) {0..real N}"
 proof -
   let ?A = "(\<lambda>n. {of_nat n..of_nat (n+1)}) ` {0..<N}"
   have has_integral: 
     "((\<lambda>x. -pbernpoly 1 x / (x + s)) has_integral 
              (of_nat n + 1/2 + s) * (ln (of_nat (n + 1) + s) - ln (of_nat n + s)) - 1) 
            {of_nat n..of_nat (n + 1)}" for n
   proof (rule has_integral_spike)      
     have "((\<lambda>x. (of_nat n + 1/2 + s) * (1 / (x + s)) - 1) has_integral 
               (of_nat n + 1/2 + s) * (ln (of_real (real (n + 1)) + s) - ln (of_real (real n) + s)) - 1) 
             {of_nat n..of_nat (n + 1)}" 
       using s has_integral_const_real[of 1 "of_nat n" "of_nat (n + 1)"]
       by (intro has_integral_diff has_integral_mult_right fundamental_theorem_of_calculus)
          (auto intro!: derivative_eq_intros has_vector_derivative_real_field
                simp: has_field_derivative_iff_has_vector_derivative [symmetric] field_simps
                      complex_nonpos_Reals_iff)
     thus "((\<lambda>x. (of_nat n + 1/2 + s) * (1 / (x + s)) - 1) has_integral 
               (of_nat n + 1/2 + s) * (ln (of_nat (n + 1) + s) - ln (of_nat n + s)) - 1) 
             {of_nat n..of_nat (n + 1)}" by simp
              
     show "-pbernpoly 1 x / (x + s) = (of_nat n + 1/2 + s) * (1 / (x + s)) - 1"
          if "x \<in> {of_nat n..of_nat (n + 1)} - {of_nat (n + 1)}" for x
     proof -
       have x: "x \<ge> real n" "x < real (n + 1)" using that by simp_all
       hence "floor x = int n" by linarith
       moreover from s x have "complex_of_real x \<noteq> -s" 
         by (auto simp add: complex_eq_iff complex_nonpos_Reals_iff simp del: of_nat_Suc)
       ultimately show "-pbernpoly 1 x / (x + s) = (of_nat n + 1/2 + s) * (1 / (x + s)) - 1"
         by (auto simp: pbernpoly_def bernpoly_def frac_def divide_simps add_eq_0_iff2)
     qed
   qed simp_all
   hence *: "\<And>I. I\<in>?A \<Longrightarrow> ((\<lambda>x. -pbernpoly 1 x / (x + s)) has_integral 
               (Inf I + 1/2 + s) * (ln (Inf I + 1 + s) - ln (Inf I + s)) - 1) I"
     by (auto simp: add_ac)
   have "((\<lambda>x. - pbernpoly 1 x / (x + s)) has_integral
           (\<Sum>I\<in>?A. (Inf I + 1 / 2 + s) * (ln (Inf I + 1 + s) - ln (Inf I + s)) - 1))
           (\<Union>n\<in>{0..<N}. {real n..real (n + 1)})" (is "(_ has_integral ?i) _")
     apply (intro has_integral_Union * finite_imageI)
       apply (force intro!: negligible_atLeastAtMostI pairwiseI)+
     done
   hence has_integral: "((\<lambda>x. - pbernpoly 1 x / (x + s)) has_integral ?i) {0..real N}"
     by (subst has_integral_spike_set_eq)
        (use Union_atLeastAtMost assms in \<open>auto simp: intro!: empty_imp_negligible\<close>)
   hence "(\<lambda>x. - pbernpoly 1 x / (x + s)) integrable_on {0..real N}"
     and integral:   "integral {0..real N} (\<lambda>x. - pbernpoly 1 x / (x + s)) = ?i"
     by (simp_all add: has_integral_iff)
   show "(\<lambda>x. - pbernpoly 1 x / (x + s)) integrable_on {0..real N}" by fact
 
   note has_integral_neg[OF has_integral]
   also have "-?i = (\<Sum>x<N. (of_nat x + 1 / 2 + s) * (ln (of_nat x + s) - ln (of_nat x + 1 + s)) + 1)" 
     by (subst sum.reindex) 
        (simp_all add: inj_on_def atLeast0LessThan algebra_simps sum_negf [symmetric])
   finally show has_integral: 
     "((\<lambda>x. of_real (pbernpoly 1 x) / (of_real x + s)) has_integral \<dots>) {0..real N}" by simp
       
   note integral
   also have "?i = (\<Sum>n<N. (of_nat n + 1 / 2 + s) * 
                     (ln (of_nat n + 1 + s) - ln (of_nat n + s))) - N" (is "_ = ?S - _")
     by (subst sum.reindex) (simp_all add: inj_on_def sum_subtractf atLeast0LessThan)
   also have "?S = (\<Sum>n<N. of_nat n * (ln (of_nat n + 1 + s) - ln (of_nat n + s))) +
                     (s + 1 / 2) * (\<Sum>n<N. ln (of_nat (Suc n) + s) - ln (of_nat n + s))" 
     (is "_ = ?S1 + _ * ?S2") by (simp add: algebra_simps sum.distrib sum_subtractf sum_distrib_left)
   also have "?S2 = ln (of_nat N + s) - ln s" by (subst sum_lessThan_telescope) simp
   also have "?S1 = (\<Sum>n=1..<N. of_nat n * (ln (of_nat n + 1 + s) - ln (of_nat n + s)))"
     by (intro sum.mono_neutral_right) auto
   also have "\<dots> = (\<Sum>n=1..<N. of_nat n * ln (of_nat n + 1 + s)) - (\<Sum>n=1..<N. of_nat n * ln (of_nat n + s))"
     by (simp add: algebra_simps sum_subtractf)
   also have "(\<Sum>n=1..<N. of_nat n * ln (of_nat n + 1 + s)) = 
                (\<Sum>n=1..<N. (of_nat n - 1) * ln (of_nat n + s)) + (N - 1) * ln (of_nat N + s)"
     by (induction N) (simp_all add: add_ac of_nat_diff)
   also have "\<dots> - (\<Sum>n = 1..<N. of_nat n * ln (of_nat n + s)) =
                -(\<Sum>n=1..<N. ln (of_nat n + s)) + (N - 1) * ln (of_nat N + s)"
     by (induction N) (simp_all add: algebra_simps)
   also from s have neq: "s + of_nat x \<noteq> 0" for x
     by (auto simp:  complex_nonpos_Reals_iff complex_eq_iff)
   hence "(\<Sum>n=1..<N. ln (of_nat n + s)) = (\<Sum>n=1..<N. ln (of_nat n) + ln (1 + s/n))"
     by (intro sum.cong refl, subst Ln_times_of_nat [symmetric]) (auto simp: divide_simps add_ac)
   also have "\<dots> = ln (fact (N - 1)) + (\<Sum>n=1..<N. ln (1 + s/n))"
     by (induction N) (simp_all add: Ln_times_of_nat fact_reduce add_ac)
   also have "(\<Sum>n=1..<N. ln (1 + s/n)) = -(\<Sum>n=1..<N. s / n - ln (1 + s/n)) + s * (\<Sum>n=1..<N. 1 / of_nat n)"
     by (simp add: sum_distrib_left sum_subtractf) 
   also from N have "ln (fact (N - 1)) = ln_Gamma (of_nat N :: complex)" 
     by (simp add: ln_Gamma_complex_conv_fact)
   also have "{1..<N} = {1..N - 1}" by auto
   hence "(\<Sum>n = 1..<N. 1 / of_nat n) = (harm (N - 1) :: complex)" 
     by (simp add: harm_def divide_simps)
   also have "- (ln_Gamma (of_nat N) + (- (\<Sum>n = 1..<N. s / of_nat n - ln (1 + s / of_nat n)) +
                  s * harm (N - 1))) + of_nat (N - 1) * ln (of_nat N + s) +
                 (s + 1 / 2) * (ln (of_nat N + s) - ln s) - of_nat N = approx N"
     using N by (simp add: field_simps of_nat_diff ln_div approx_def Ln_of_nat 
                           ln_Gamma_complex_of_real [symmetric])
   finally show "integral {0..of_nat N} (\<lambda>x. -of_real (pbernpoly 1 x) / (of_real x + s)) = \<dots>" 
     by simp
 qed
   
 lemma integrable_ln_Gamma_aux:
   shows   "(\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n) integrable_on {0..real N}"
 proof (cases "n = 1")
   case True
   with s show ?thesis using integrable_neg[OF integrable_pbernpoly_1[of N]] 
     by (cases "N = 0") (simp_all add: integrable_negligible)
 next
   case False
   from s have "of_real x + s \<noteq> 0" if "x \<ge> 0" for x using that 
     by (auto simp: complex_eq_iff add_eq_0_iff2 complex_nonpos_Reals_iff)
   with False s show ?thesis
     by (auto intro!: integrable_continuous_real continuous_intros)
 qed
   
 text \<open>
   This following proof is based on ``Rudiments of the theory of the gamma function'' 
   by Bruce Berndt~\cite{berndt}.
 \<close>
 lemma tendsto_of_real_0_I: 
   "(f \<longlongrightarrow> 0) G \<Longrightarrow> ((\<lambda>x. (of_real (f x))) \<longlongrightarrow> (0 ::'a::real_normed_div_algebra)) G"
   using tendsto_of_real_iff by force
 
 qualified lemma integral_pbernpoly_1:
   "(\<lambda>N. integral {0..real N} (\<lambda>x. pbernpoly 1 x / (x + s)))
      \<longlonglongrightarrow> -ln_Gamma s - s + (s - 1 / 2) * ln s + ln (2 * pi) / 2"
 proof -  
   have neq: "s + of_real x \<noteq> 0" if "x \<ge> 0" for x :: real
     using that s by (auto simp: complex_eq_iff complex_nonpos_Reals_iff)
   have "(approx \<longlongrightarrow> ln_Gamma s - 0 - 0 + 0 - 0 + s - (s - 1/2) * ln s - ln (2 * pi) / 2) at_top"
     unfolding approx_def
   proof (intro tendsto_add tendsto_diff)
     from s have s': "s \<notin> \<int>\<^sub>\<le>\<^sub>0" by (auto simp: complex_nonpos_Reals_iff elim!: nonpos_Ints_cases)
     have "(\<lambda>n. \<Sum>i=1..<n. s / of_nat i - ln (1 + s / of_nat i)) \<longlonglongrightarrow> 
              ln_Gamma s + euler_mascheroni * s + ln s" (is "?f \<longlonglongrightarrow> _")
       using ln_Gamma_series'_aux[OF s'] unfolding sums_def 
       by (subst filterlim_sequentially_Suc [symmetric], subst (asm) sum.atLeast1_atMost_eq [symmetric]) 
          (simp add: atLeastLessThanSuc_atLeastAtMost)
     thus "((\<lambda>n. ?f n - (euler_mascheroni * s + ln s)) \<longlongrightarrow> ln_Gamma s) at_top"
       by (auto intro: tendsto_eq_intros)
   next
     show "(\<lambda>x. complex_of_real (ln_Gamma (real x) - ln (2 * pi / real x) / 2 - 
                  real x * ln (real x) + real x)) \<longlonglongrightarrow> 0"
     proof (intro tendsto_of_real_0_I 
              filterlim_compose[OF tendsto_sandwich filterlim_real_sequentially])
       show "eventually (\<lambda>x::real. ln_Gamma x - ln (2 * pi / x) / 2 - x * ln x + x \<ge> 0) at_top"
         using eventually_ge_at_top[of "1::real"] 
         by eventually_elim (insert ln_Gamma_bounds(1), simp add: algebra_simps)
       show "eventually (\<lambda>x::real. ln_Gamma x - ln (2 * pi / x) / 2 - x * ln x + x \<le> 
               1 / 12 * inverse x) at_top"
         using eventually_ge_at_top[of "1::real"] 
         by eventually_elim (insert ln_Gamma_bounds(2), simp add: field_simps)
       show "((\<lambda>x::real. 1 / 12 * inverse x) \<longlongrightarrow> 0) at_top"
         by (intro tendsto_mult_right_zero tendsto_inverse_0_at_top filterlim_ident)
     qed simp_all
   next
     have "(\<lambda>x. s * of_real (harm (x - 1) - ln (real (x - 1)) - euler_mascheroni)) \<longlonglongrightarrow> 
             s * of_real (euler_mascheroni - euler_mascheroni)"
       by (subst filterlim_sequentially_Suc [symmetric], intro tendsto_intros) 
          (insert euler_mascheroni_LIMSEQ, simp_all)
     also have "?this \<longleftrightarrow> (\<lambda>x. s * (harm (x - 1) - ln (of_nat (x - 1)) - euler_mascheroni)) \<longlonglongrightarrow> 0"
       by (intro filterlim_cong refl eventually_mono[OF eventually_gt_at_top[of "1::nat"]]) 
          (auto simp: Ln_of_nat of_real_harm)
     finally show "(\<lambda>x. s * (harm (x - 1) - ln (of_nat (x - 1)) - euler_mascheroni)) \<longlonglongrightarrow> 0"  .
   next
     have "((\<lambda>x. ln (1 + (s + 1) / of_real x)) \<longlongrightarrow> ln (1 + 0)) at_top" (is ?P)
       by (intro tendsto_intros tendsto_divide_0[OF tendsto_const]) 
          (simp_all add: filterlim_ident filterlim_at_infinity_conv_norm_at_top filterlim_abs_real)
     also have "ln (of_real (x + 1) + s) - ln (complex_of_real x) = ln (1 + (s + 1) / of_real x)" 
       if "x > 1" for x using that s
       using Ln_divide_of_real[of x "of_real (x + 1) + s", symmetric] neq[of "x+1"]
       by (simp add: field_simps Ln_of_real)
     hence "?P \<longleftrightarrow> ((\<lambda>x. ln (of_real (x + 1) + s) - ln (of_real x)) \<longlongrightarrow> 0) at_top"
       by (intro filterlim_cong refl) 
          (auto intro: eventually_mono[OF eventually_gt_at_top[of "1::real"]])
     finally have "((\<lambda>n. ln (of_real (real n + 1) + s) - ln (of_real (real n))) \<longlongrightarrow> 0) at_top"
       by (rule filterlim_compose[OF _ filterlim_real_sequentially])
     hence "((\<lambda>n. ln (of_nat n + s) - ln (of_nat (n - 1))) \<longlongrightarrow> 0) at_top"
       by (subst filterlim_sequentially_Suc [symmetric]) (simp add: add_ac)
     thus "(\<lambda>x. s * (ln (of_nat x + s) - ln (of_nat (x - 1)))) \<longlonglongrightarrow> 0"
       by (rule tendsto_mult_right_zero)
   next
     have "((\<lambda>x. ln (1 + s / of_real x)) \<longlongrightarrow> ln (1 + 0)) at_top" (is ?P)
       by (intro tendsto_intros tendsto_divide_0[OF tendsto_const]) 
          (simp_all add: filterlim_ident  filterlim_at_infinity_conv_norm_at_top filterlim_abs_real)
     also have "ln (of_real x + s) - ln (of_real x) = ln (1 + s / of_real x)" if "x > 0" for x
       using Ln_divide_of_real[of x "of_real x + s"] neq[of x] that
       by (auto simp: field_simps Ln_of_real)
     hence "?P \<longleftrightarrow> ((\<lambda>x. ln (of_real x + s) - ln (of_real x)) \<longlongrightarrow> 0) at_top"
       using s by (intro filterlim_cong refl) 
                  (auto intro: eventually_mono [OF eventually_gt_at_top[of "1::real"]])
     finally have "(\<lambda>x. (1/2) * (ln (of_real (real x) + s) - ln (of_real (real x)))) \<longlonglongrightarrow> 0"        
       by (rule tendsto_mult_right_zero[OF filterlim_compose[OF _ filterlim_real_sequentially]])
     thus "(\<lambda>x. (1/2) * (ln (of_nat x + s) - ln (of_nat x))) \<longlonglongrightarrow> 0" by simp
   next
     have "((\<lambda>x. x * (ln (1 + s / of_real x))) \<longlongrightarrow> s) at_top" (is ?P) 
       by (rule stirling_limit_aux2)
     also have "ln (1 + s / of_real x) = ln (of_real x + s) - ln (of_real x)" if "x > 1" for x 
       using that s Ln_divide_of_real [of x "of_real x + s", symmetric] neq[of x]
       by (auto simp: Ln_of_real field_simps)
     hence "?P \<longleftrightarrow> ((\<lambda>x. of_real x * (ln (of_real x + s) - ln (of_real x))) \<longlongrightarrow> s) at_top"
       by (intro filterlim_cong refl) 
          (auto intro: eventually_mono[OF eventually_gt_at_top[of "1::real"]])
     finally have "(\<lambda>n. of_real (real n) * (ln (of_real (real n) + s) - ln (of_real (real n)))) \<longlonglongrightarrow> s"
       by (rule filterlim_compose[OF _ filterlim_real_sequentially])
     thus "(\<lambda>n. of_nat n * (ln (of_nat n + s) - ln (of_nat n))) \<longlonglongrightarrow> s" by simp
   qed simp_all
   also have "?this \<longleftrightarrow> ((\<lambda>N. integral {0..real N} (\<lambda>x. -pbernpoly 1 x / (x + s))) \<longlongrightarrow>
                          ln_Gamma s + s - (s - 1/2) * ln s - ln (2 * pi) / 2) at_top"
     using integral_pbernpoly_1_aux
     by (intro filterlim_cong refl) 
        (auto intro: eventually_mono[OF eventually_gt_at_top[of "0::nat"]])
   also have "(\<lambda>N. integral {0..real N} (\<lambda>x. -pbernpoly 1 x / (x + s))) =
                (\<lambda>N. -integral {0..real N} (\<lambda>x. pbernpoly 1 x / (x + s)))"
     by (simp add: fun_eq_iff)
   finally show ?thesis by (simp add: tendsto_minus_cancel_left [symmetric] algebra_simps)
 qed
 
 
 qualified lemma pbernpoly_integral_conv_pbernpoly_integral_Suc:
   assumes "n \<ge> 1"
   shows   "integral {0..real N} (\<lambda>x. pbernpoly n x / (x + s) ^ n) =
              of_real (pbernpoly (Suc n) (real N)) / (of_nat (Suc n) * (s + of_nat N) ^ n) -
              of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n) + of_nat n / of_nat (Suc n) * 
                integral {0..real N} (\<lambda>x. of_real (pbernpoly (Suc n) x) / (of_real x + s) ^ Suc n)"
 proof - 
   note [derivative_intros] = has_field_derivative_pbernpoly_Suc'
   define I where "I = -of_real (pbernpoly (Suc n) (of_nat N)) / (of_nat (Suc n) * (of_nat N + s) ^ n) +
             of_real (bernoulli (Suc n) / real (Suc n)) / s ^ n +
             integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)"
   have "((\<lambda>x. (-of_nat n * inverse (of_real x + s) ^ Suc n) * 
           (of_real (pbernpoly (Suc n) x) / (of_nat (Suc n))))
           has_integral -I) {0..real N}"
   proof (rule integration_by_parts_interior_strong[OF bounded_bilinear_mult])
     fix x :: real assume x: "x \<in> {0<..<real N} - real ` {0..N}"
     have "x \<notin> \<int>"
     proof
       assume "x \<in> \<int>"
       then obtain n where "x = of_int n" by (auto elim!: Ints_cases)
       with x have x': "x = of_nat (nat n)" by simp
       from x show False by (auto simp: x')
     qed
     hence "((\<lambda>x. of_real (pbernpoly (Suc n) x / of_nat (Suc n))) has_vector_derivative
         complex_of_real (pbernpoly n x)) (at x)"
       by (intro has_vector_derivative_of_real) (auto intro!: derivative_eq_intros)
     thus "((\<lambda>x. of_real (pbernpoly (Suc n) x) / of_nat (Suc n)) has_vector_derivative
             complex_of_real (pbernpoly n x)) (at x)" by simp
     from x s have "complex_of_real x + s \<noteq> 0"
       by (auto simp: complex_eq_iff complex_nonpos_Reals_iff)
     thus "((\<lambda>x. inverse (of_real x + s) ^ n) has_vector_derivative 
              - of_nat n * inverse (of_real x + s) ^ Suc n) (at x)" using x s assms
       by (auto intro!: derivative_eq_intros has_vector_derivative_real_field simp: divide_simps power_add [symmetric]
                simp del: power_Suc)
   next
     have "complex_of_real x + s \<noteq> 0" if "x \<ge> 0" for x 
       using that s by (auto simp: complex_eq_iff complex_nonpos_Reals_iff)
     thus "continuous_on {0..real N} (\<lambda>x. inverse (of_real x + s) ^ n)" 
          "continuous_on {0..real N} (\<lambda>x. complex_of_real (pbernpoly (Suc n) x) / of_nat (Suc n))"
       using assms s by (auto intro!: continuous_intros simp del: of_nat_Suc)
   next
     have "((\<lambda>x. inverse (of_real x + s) ^ n * of_real (pbernpoly n x)) has_integral
             pbernpoly (Suc n) (of_nat N) / (of_nat (Suc n) * (of_nat N + s) ^ n) -
             of_real (bernoulli (Suc n) / real (Suc n)) / s ^ n - -I) {0..real N}" 
       using integrable_ln_Gamma_aux[of n N] assms
       by (auto simp: I_def has_integral_integral divide_simps)
     thus "((\<lambda>x. inverse (of_real x + s) ^ n * of_real (pbernpoly n x)) has_integral
               inverse (of_real (real N) + s) ^ n * (of_real (pbernpoly (Suc n) (real N)) / 
                   of_nat (Suc n)) -
               inverse (of_real 0 + s) ^ n * (of_real (pbernpoly (Suc n) 0) / of_nat (Suc n)) - - I)
             {0..real N}" by (simp_all add: field_simps)
   qed simp_all
   also have "(\<lambda>x. - of_nat n * inverse (of_real x + s) ^ Suc n * (of_real (pbernpoly (Suc n) x) /
                          of_nat (Suc n))) =
              (\<lambda>x. - (of_nat n / of_nat (Suc n) * of_real (pbernpoly (Suc n) x) / 
                          (of_real x + s) ^ Suc n))"
     by (simp add: divide_simps fun_eq_iff)
   finally have "((\<lambda>x. - (of_nat n / of_nat (Suc n) * of_real (pbernpoly (Suc n) x) /
                             (of_real x + s) ^ Suc n)) has_integral - I) {0..real N}" .
   from has_integral_neg[OF this] show ?thesis
     by (auto simp add: I_def has_integral_iff algebra_simps integral_mult_right [symmetric] 
              simp del: power_Suc of_nat_Suc )
 qed
 
 lemma pbernpoly_over_power_tendsto_0: 
   assumes "n > 0"
   shows   "(\<lambda>x. of_real (pbernpoly (Suc n) (real x)) / (of_nat (Suc n) * (s + of_nat x) ^ n)) \<longlonglongrightarrow> 0"
 proof -
   from s have neq: "s + of_nat n \<noteq> 0" for n
     by (auto simp: complex_eq_iff complex_nonpos_Reals_iff)
-  from bounded_pbernpoly[of "Suc n"] guess c . note c = this
+  obtain c where c: "\<And>x. norm (pbernpoly (Suc n) x) \<le> c"
+    using bounded_pbernpoly by auto
   have "eventually (\<lambda>x. real x + Re s > 0) at_top"
     by real_asymp
   hence "eventually (\<lambda>x. norm (of_real (pbernpoly (Suc n) (real x)) / 
                                     (of_nat (Suc n) * (s + of_nat x) ^ n)) \<le>
                           (c / real (Suc n)) / (real x + Re s) ^ n) at_top"
     using eventually_gt_at_top[of "0::nat"]
   proof eventually_elim
     case (elim x)
     have "norm (of_real (pbernpoly (Suc n) (real x)) / 
                                     (of_nat (Suc n) * (s + of_nat x) ^ n)) \<le>
             (c / real (Suc n)) / norm (s + of_nat x) ^ n" (is "_ \<le> ?rhs") using c[of x]
       by (auto simp: norm_divide norm_mult norm_power neq field_simps simp del: of_nat_Suc)
     also have "(real x + Re s) \<le> cmod (s + of_nat x)"
       using complex_Re_le_cmod[of "s + of_nat x"] s by (auto simp add: complex_nonpos_Reals_iff)
     hence "?rhs \<le> (c / real (Suc n)) / (real x + Re s) ^ n" using s elim c[of 0] neq[of x]
       by (intro divide_left_mono power_mono mult_pos_pos divide_nonneg_pos zero_less_power) auto
     finally show ?case .
   qed 
   moreover have "(\<lambda>x. (c / real (Suc n)) / (real x + Re s) ^ n) \<longlonglongrightarrow> 0"
     using \<open>n > 0\<close> by real_asymp
   ultimately show ?thesis by (rule Lim_null_comparison)
 qed
 
 lemma convergent_stirling_integral:
   assumes "n > 0"
   shows   "convergent (\<lambda>N. integral {0..real N} 
              (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n))" (is "convergent (?f n)")
 proof -
   have "convergent (?f (Suc n))" for n
   proof (induction n)
     case 0
     thus ?case using integral_pbernpoly_1 by (auto intro!: convergentI)
   next
     case (Suc n)
     have "convergent (\<lambda>N. ?f (Suc n) N -
             of_real (pbernpoly (Suc (Suc n)) (real N)) / 
                 (of_nat (Suc (Suc n)) * (s + of_nat N) ^ Suc n) +
             of_real (bernoulli (Suc (Suc n)) / (real (Suc (Suc n)))) / s ^ Suc n)" 
       (is "convergent ?g")
       by (intro convergent_add convergent_diff Suc 
             convergent_const convergentI[OF pbernpoly_over_power_tendsto_0]) simp_all
     also have "?g = (\<lambda>N. of_nat (Suc n) / of_nat (Suc (Suc n)) * ?f (Suc (Suc n)) N)" using s
       by (subst pbernpoly_integral_conv_pbernpoly_integral_Suc) 
          (auto simp: fun_eq_iff field_simps simp del: of_nat_Suc power_Suc)
     also have "convergent \<dots> \<longleftrightarrow> convergent (?f (Suc (Suc n)))"
       by (intro convergent_mult_const_iff) (simp_all del: of_nat_Suc)
     finally show ?case .
   qed
   from this[of "n - 1"] assms show ?thesis by simp
 qed
 
 lemma stirling_integral_conv_stirling_integral_Suc:
   assumes "n > 0"
   shows   "stirling_integral n s =
              of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s -
              of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n)"
 proof -
   have "(\<lambda>N. of_real (pbernpoly (Suc n) (real N)) / (of_nat (Suc n) * (s + of_nat N) ^ n) -
              of_real (bernoulli (Suc n)) / (real (Suc n) * s ^ n) +
              integral {0..real N} (\<lambda>x. of_nat n / of_nat (Suc n) * 
                 (of_real (pbernpoly (Suc n) x) / (of_real x + s) ^ Suc n)))
            \<longlonglongrightarrow> 0 - of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n) +
                    of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s" (is "?f \<longlonglongrightarrow> _")
     unfolding stirling_integral_def integral_mult_right
     using convergent_stirling_integral[of "Suc n"] assms s
     by (intro tendsto_intros pbernpoly_over_power_tendsto_0)
        (auto simp: convergent_LIMSEQ_iff simp del: of_nat_Suc)
   also have "?this \<longleftrightarrow> (\<lambda>N. integral {0..real N} 
                (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<longlonglongrightarrow>
                of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s -
                  of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n)" 
     using eventually_gt_at_top[of "0::nat"] pbernpoly_integral_conv_pbernpoly_integral_Suc[of n] 
           assms unfolding integral_mult_right
     by (intro filterlim_cong refl) (auto elim!: eventually_mono simp del: power_Suc)
   finally show ?thesis unfolding stirling_integral_def[of n] by (rule limI)
 qed
 
 lemma stirling_integral_1_unfold:
   assumes "m > 0"
   shows   "stirling_integral 1 s = stirling_integral m s / of_nat m - 
              (\<Sum>k=1..<m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k))"
 proof -
   have "stirling_integral 1 s = stirling_integral (Suc m) s / of_nat (Suc m) -
           (\<Sum>k=1..<Suc m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k))" for m
   proof (induction m)
     case (Suc m)
     let ?C = "(\<Sum>k = 1..<Suc m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k))"
     note Suc.IH
     also have "stirling_integral (Suc m) s / of_nat (Suc m) = 
                  stirling_integral (Suc (Suc m)) s / of_nat (Suc (Suc m)) -
                  of_real (bernoulli (Suc (Suc m))) / 
                    (of_nat (Suc m) * of_nat (Suc (Suc m)) * s ^ Suc m)"
       (is "_ = ?A - ?B") by (subst stirling_integral_conv_stirling_integral_Suc)
                             (simp_all del: of_nat_Suc power_Suc add: divide_simps)
     also have "?A - ?B - ?C = ?A - (?B + ?C)" by (rule diff_diff_eq)
     also have "?B + ?C = (\<Sum>k = 1..<Suc (Suc m). of_real (bernoulli (Suc k)) /
                              (of_nat k * of_nat (Suc k) * s ^ k))" 
       using s by (simp add: divide_simps)
     finally show ?case .
   qed simp_all
   note this[of "m - 1"]
   also from assms have "Suc (m - 1) = m" by simp
   finally show ?thesis .
 qed
   
 lemma ln_Gamma_stirling_complex:
   assumes "m > 0"
   shows   "ln_Gamma s = (s - 1 / 2) * ln s - s + ln (2 * pi) / 2 +
              (\<Sum>k=1..<m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k)) - 
              stirling_integral m s / of_nat m"
 proof -
   have "ln_Gamma s = (s - 1 / 2) * ln s - s + ln (2 * pi) / 2 - stirling_integral 1 s"
     using limI[OF integral_pbernpoly_1] by (simp add: stirling_integral_def algebra_simps)
   also have "stirling_integral 1 s = stirling_integral m s / of_nat m -
                (\<Sum>k = 1..<m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k))"
     using assms by (rule stirling_integral_1_unfold)
   finally show ?thesis by simp
 qed
 
 lemma LIMSEQ_stirling_integral:
   "n > 0 \<Longrightarrow> (\<lambda>x. integral {0..real x} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n))
      \<longlonglongrightarrow> stirling_integral n s" unfolding stirling_integral_def 
   using convergent_stirling_integral[of n] by (simp only: convergent_LIMSEQ_iff)
 
 end
 
 lemmas has_integral_of_real = has_integral_linear[OF _ bounded_linear_of_real, unfolded o_def]
 lemmas integral_of_real = integral_linear[OF _ bounded_linear_of_real, unfolded o_def]
 
 lemma integrable_ln_Gamma_aux_real:
   assumes "0 < s"
   shows   "(\<lambda>x. pbernpoly n x / (x + s) ^ n) integrable_on {0..real N}"
 proof -
   have "(\<lambda>x. complex_of_real (pbernpoly n x / (x + s) ^ n)) integrable_on {0..real N}"
     using integrable_ln_Gamma_aux[of "of_real s" n N] assms by simp
   from integrable_linear[OF this bounded_linear_Re] show ?thesis 
     by (simp only: o_def Re_complex_of_real) 
 qed
   
 lemma  
   assumes "x > 0" "n > 0"
   shows   stirling_integral_complex_of_real:
             "stirling_integral n (complex_of_real x) = of_real (stirling_integral n x)"
     and   LIMSEQ_stirling_integral_real:
             "(\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))
             \<longlonglongrightarrow> stirling_integral n x"
     and   stirling_integral_real_convergent:
             "convergent (\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))"
 proof -
   have "(\<lambda>N. integral {0..real N} (\<lambda>t. of_real (pbernpoly n t / (t + x) ^ n)))
            \<longlonglongrightarrow> stirling_integral n (complex_of_real x)"
     using LIMSEQ_stirling_integral[of "complex_of_real x" n] assms by simp
   hence "(\<lambda>N. of_real (integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n)))
            \<longlonglongrightarrow> stirling_integral n (complex_of_real x)"
     using integrable_ln_Gamma_aux_real[OF assms(1), of n] 
     by (subst (asm) integral_of_real) simp
   from tendsto_Re[OF this] 
     have "(\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))
            \<longlonglongrightarrow> Re (stirling_integral n (complex_of_real x))" by simp
   thus "convergent (\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))"
     by (rule convergentI)
   thus "(\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))
           \<longlonglongrightarrow> stirling_integral n x" unfolding stirling_integral_def
     by (simp add: convergent_LIMSEQ_iff)
   from tendsto_of_real[OF this, where 'a = complex] 
        integrable_ln_Gamma_aux_real[OF assms(1), of n]
     have "(\<lambda>xa. integral {0..real xa} 
                     (\<lambda>xa. complex_of_real (pbernpoly n xa) / (complex_of_real xa + x) ^ n))
              \<longlonglongrightarrow> complex_of_real (stirling_integral n x)"
     by (subst (asm) integral_of_real [symmetric]) simp_all
   from LIMSEQ_unique[OF this LIMSEQ_stirling_integral[of "complex_of_real x" n]] assms
     show "stirling_integral n (complex_of_real x) = of_real (stirling_integral n x)" by simp
 qed
 
 lemma ln_Gamma_stirling_real:
   assumes "x > (0 :: real)" "m > (0::nat)"
   shows   "ln_Gamma x = (x - 1 / 2) * ln x - x + ln (2 * pi) / 2 +
               (\<Sum>k = 1..<m. bernoulli (Suc k) / (of_nat k * of_nat (Suc k) * x ^ k)) -
               stirling_integral m x / of_nat m"
 proof -
   from assms have "complex_of_real (ln_Gamma x) = ln_Gamma (complex_of_real x)"
     by (simp add: ln_Gamma_complex_of_real)
   also have "ln_Gamma (complex_of_real x) = complex_of_real (
                 (x - 1 / 2) * ln x - x + ln (2 * pi) / 2 +
                 (\<Sum>k = 1..<m. bernoulli (Suc k) / (of_nat k * of_nat (Suc k) * x ^ k)) -
                 stirling_integral m x / of_nat m)" using assms
     by (subst ln_Gamma_stirling_complex[of _ m])
        (simp_all add: Ln_of_real stirling_integral_complex_of_real)
   finally show ?thesis by (subst (asm) of_real_eq_iff)
 qed
 
 
 lemma stirling_integral_bound_aux:
   assumes n: "n > (1::nat)"
   obtains c where "\<And>s. Re s > 0 \<Longrightarrow> norm (stirling_integral n s) \<le>  c / Re s ^ (n - 1)"
 proof -
   obtain c where c: "norm (pbernpoly n x) \<le> c" for x by (rule bounded_pbernpoly[of n]) blast
   have c': "pbernpoly n x \<le> c" for x using c[of x] by (simp add: abs_real_def split: if_splits)
   from c[of 0] have c_nonneg: "c \<ge> 0" by simp
   have "norm (stirling_integral n s) \<le> c / (real n - 1) / Re s ^ (n - 1)" if s: "Re s > 0" for s
   proof (rule Lim_norm_ubound[OF _ LIMSEQ_stirling_integral])
     have pos: "x + norm s > 0" if "x \<ge> 0" for x using s that by (intro add_nonneg_pos) auto
     have nz: "of_real x + s \<noteq> 0" if "x \<ge> 0" for x using s that by (auto simp: complex_eq_iff)
     let ?bound = "\<lambda>N. c / (Re s ^ (n - 1) * (real n - 1)) - 
                         c / ((real N + Re s) ^ (n - 1) * (real n - 1))"
     show "eventually (\<lambda>N. norm (integral {0..real N} 
               (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le> 
             c / (real n - 1) / Re s ^ (n - 1)) at_top"
       using eventually_gt_at_top[of "0::nat"]
     proof eventually_elim
       case (elim N)
       let ?F = "\<lambda>x. -c / ((x + Re s) ^ (n - 1) * (real n - 1))"
       from n s have "((\<lambda>x. c / (x + Re s) ^ n) has_integral (?F (real N) - ?F 0)) {0..real N}"
         by (intro fundamental_theorem_of_calculus)
            (auto intro!: derivative_eq_intros simp: divide_simps power_diff add_eq_0_iff2
                    has_field_derivative_iff_has_vector_derivative [symmetric])      
       also have "?F (real N) - ?F 0 = ?bound N" by simp
       finally have *: "((\<lambda>x. c / (x + Re s) ^ n) has_integral ?bound N) {0..real N}" .
       have "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le>
               integral {0..real N} (\<lambda>x. c / (x + Re s) ^ n)"
       proof (intro integral_norm_bound_integral integrable_ln_Gamma_aux s ballI)
         fix x assume x: "x \<in> {0..real N}"
         have "norm (of_real (pbernpoly n x) / (of_real x + s) ^ n) \<le> c / norm (of_real x + s) ^ n"
           unfolding norm_divide norm_power using c by (intro divide_right_mono) simp_all
         also have "\<dots> \<le> c / (x + Re s) ^ n" 
           using x c c_nonneg s nz[of x] complex_Re_le_cmod[of "of_real x + s"]
           by (intro divide_left_mono power_mono mult_pos_pos zero_less_power add_nonneg_pos) auto
         finally show "norm (of_real (pbernpoly n x) / (of_real x + s) ^ n) \<le> \<dots>" .
       qed (insert n s * pos nz c, auto simp: complex_nonpos_Reals_iff)
       also have "\<dots> = ?bound N" using * by (simp add: has_integral_iff)
       also have "\<dots> \<le> c / (Re s ^ (n - 1) * (real n - 1))" using c_nonneg elim s n by simp
       also have "\<dots> = c / (real n - 1) / (Re s ^ (n - 1))" by simp
       finally show "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) /
                       (of_real x + s) ^ n)) \<le> c / (real n - 1) / Re s ^ (n - 1)" .
     qed
   qed (insert s n, simp_all add: complex_nonpos_Reals_iff)
   thus ?thesis by (rule that)
 qed
 
 lemma stirling_integral_bound_aux_integral1:
   fixes a b c :: real and n :: nat
   assumes "a \<ge> 0" "b > 0" "c \<ge> 0" "n > 1" "l < a - b" "r > a + b"
   shows "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral
            2*c*(n / (n - 1))/b^(n-1) - c/(n-1) * (1/(a-l)^(n-1) + 1/(r-a)^(n-1))) {l..r}"
 proof -
   define x1 x2 where "x1 = a - b" and "x2 = a + b"
   define F1 where "F1 = (\<lambda>x::real. c / (a - x) ^ (n - 1) / (n - 1))"
   define F3 where "F3 = (\<lambda>x::real. -c / (x - a) ^ (n - 1) / (n - 1))"
   have deriv: "(F1 has_vector_derivative (c / (a - x) ^ n)) (at x within A)"
               "(F3 has_vector_derivative (c / (x - a) ^ n)) (at x within A)"
     if "x \<noteq> a" for x :: real and A
     unfolding F1_def F3_def using assms that
     by (auto intro!: derivative_eq_intros simp: divide_simps power_diff add_eq_0_iff2
              simp flip: has_field_derivative_iff_has_vector_derivative)
 
   from assms have "((\<lambda>x. c / (a - x) ^ n) has_integral (F1 x1 - F1 l)) {l..x1}"
     by (intro fundamental_theorem_of_calculus deriv) (auto simp: x1_def max_def split: if_splits)
   also have "?this \<longleftrightarrow> ((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F1 x1 - F1 l)) {l..x1}"
     using assms
     by (intro has_integral_spike_finite_eq[of "{l}"]) (auto simp: x1_def max_def split: if_splits)
   finally have I1: "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F1 x1 - F1 l)) {l..x1}" .
 
   have "((\<lambda>x. c / b ^ n) has_integral (x2 - x1) * c / b ^ n) {x1..x2}"
     using has_integral_const_real[of "c / b ^ n" x1 x2] assms by (simp add: x1_def x2_def)
   also have "?this \<longleftrightarrow> ((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral ((x2 - x1) * c / b ^ n)) {x1..x2}"
     by (intro has_integral_spike_finite_eq[of "{x1, x2}"])
        (auto simp: x1_def x2_def split: if_splits)
   finally have I2: "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral ((x2 - x1) * c / b ^ n)) {x1..x2}" .
 
   from assms have I3: "((\<lambda>x. c / (x - a) ^ n) has_integral (F3 r - F3 x2)) {x2..r}"
     by (intro fundamental_theorem_of_calculus deriv) (auto simp: x2_def min_def split: if_splits)
   also have "?this \<longleftrightarrow> ((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F3 r - F3 x2)) {x2..r}"
     using assms
     by (intro has_integral_spike_finite_eq[of "{r}"]) (auto simp: x2_def min_def split: if_splits)
   finally have I3: "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F3 r - F3 x2)) {x2..r}" .
 
   have "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F1 x1 - F1 l) + ((x2 - x1) * c / b ^ n) + (F3 r - F3 x2)) {l..r}"
     using assms
     by (intro has_integral_combine[OF _ _ has_integral_combine[OF _ _ I1 I2] I3])
        (auto simp: x1_def x2_def)
   also have "(F1 x1 - F1 l) + ((x2 - x1) * c / b ^ n) + (F3 r - F3 x2) =
              F1 x1 - F1 l + F3 r - F3 x2 + (x2 - x1) * c / b ^ n"
     by (simp add: algebra_simps)
   also have "x2 - x1 = 2 * b"
     using assms by (simp add: x2_def x1_def min_def max_def)
   also have "2 * b * c / b ^ n = 2 * c / b ^ (n - 1)"
     using assms by (simp add: power_diff field_simps)
   also have "F1 x1 - F1 l + F3 r - F3 x2 =
                c/(n-1) * (2/b^(n-1) - 1/(a-l)^(n-1) - 1/(r-a)^(n-1))"
     using assms by (simp add: x1_def x2_def F1_def F3_def field_simps)
   also have "\<dots> + 2 * c / b ^ (n - 1) =
              2*c*(1 + 1/(n-1))/b^(n-1) - c/(n-1) * (1/(a-l)^(n-1) + 1/(r-a)^(n-1))"
     using assms by (simp add: field_simps)
   also have "1 + 1 / (n - 1) = n / (n - 1)"
     using assms by (simp add: field_simps)
   finally show ?thesis .
 qed
 
 lemma stirling_integral_bound_aux_integral2:
   fixes a b c :: real and n :: nat
   assumes "a \<ge> 0" "b > 0" "c \<ge> 0" "n > 1"
   obtains I where "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral I) {l..r}"
                   "I \<le> 2 * c * (n / (n - 1)) / b ^ (n-1)"
 proof -
   define l' where "l' = min l (a - b - 1)"
   define r' where "r' = max r (a + b + 1)"
 
   define A where "A = 2 * c * (n / (n - 1)) / b ^ (n - 1)"
   define B where "B = c / real (n - 1) * (1 / (a - l') ^ (n - 1) + 1 / (r' - a) ^ (n - 1))"
 
   have has_int: "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (A - B)) {l'..r'}"
     using assms unfolding A_def B_def
     by (intro stirling_integral_bound_aux_integral1) (auto simp: l'_def r'_def)
   have "(\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) integrable_on {l..r}"
     by (rule integrable_on_subinterval[OF has_integral_integrable[OF has_int]])
        (auto simp: l'_def r'_def)
   then obtain I where has_int': "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral I) {l..r}"
     by (auto simp: integrable_on_def)
 
   from assms have "I \<le> A - B"
     by (intro has_integral_subset_le[OF _ has_int' has_int]) (auto simp: l'_def r'_def)
   also have "\<dots> \<le> A"
     using assms by (simp add: B_def l'_def r'_def)
   finally show ?thesis using that[of I] has_int' unfolding A_def by blast
 qed
 
 lemma stirling_integral_bound_aux':
   assumes n: "n > (1::nat)" and \<alpha>: "\<alpha> \<in> {0<..<pi}"
   obtains c where "\<And>s::complex. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow>
                      norm (stirling_integral n s) \<le> c / norm s ^ (n - 1)"
 proof -
   obtain c where c: "norm (pbernpoly n x) \<le> c" for x by (rule bounded_pbernpoly[of n]) blast
   have c': "pbernpoly n x \<le> c" for x using c[of x] by (simp add: abs_real_def split: if_splits)
   from c[of 0] have c_nonneg: "c \<ge> 0" by simp
 
   define D where "D = c * Beta (- (real_of_int (- int n) / 2) - 1 / 2) (1 / 2) / 2"
   define C where "C = max D (2*c*(n/(n-1))/sin \<alpha>^(n-1))"
 
   have *: "norm (stirling_integral n s) \<le> C / norm s ^ (n - 1)"
     if s: "s \<in> complex_cone' \<alpha> - {0}" for s :: complex
   proof (rule Lim_norm_ubound[OF _ LIMSEQ_stirling_integral])
     from s \<alpha> have Arg: "\<bar>Arg s\<bar> \<le> \<alpha>" by (auto simp: complex_cone_altdef)
     have s': "s \<notin> \<real>\<^sub>\<le>\<^sub>0"
       using complex_cone_inter_nonpos_Reals[of "-\<alpha>" \<alpha>] \<alpha> s  by auto
     from s have [simp]: "s \<noteq> 0" by auto
 
     show "eventually (\<lambda>N. norm (integral {0..real N}
               (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le> 
             C / norm s ^ (n - 1)) at_top"
       using eventually_gt_at_top[of "0::nat"]
     proof eventually_elim
       case (elim N)
       show ?case
       proof (cases "Re s > 0")
         case True
         have int: "((\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2)) has_integral
                   D * (norm s ^ 2) powr (-n / 2 + 1 / 2)) {0<..}"
           using has_integral_mult_left[OF has_integral_Beta3[of "-n/2" "norm s ^ 2"], of c] assms True
           unfolding D_def by (simp add: algebra_simps)
         hence int': "((\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2)) has_integral
                   D * (norm s ^ 2) powr (-n / 2 + 1 / 2)) {0..}"
           by (subst has_integral_interior [symmetric]) simp_all
         hence integrable: "(\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2)) integrable_on {0..}"
           by (simp add: has_integral_iff)
 
         have "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le>
                 integral {0..real N} (\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2))"
         proof (intro integral_norm_bound_integral s ballI integrable_ln_Gamma_aux)
           have [simp]: "{0<..} - {0::real..} = {}" "{0..} - {0<..} = {0::real}"
             by auto
           have "(\<lambda>x. c * (x\<^sup>2 + (cmod s)\<^sup>2) powr (real_of_int (- int n) / 2)) integrable_on {0<..}"
             using int by (simp add: has_integral_iff)
           also have "?this \<longleftrightarrow> (\<lambda>x. c * (x\<^sup>2 + (cmod s)\<^sup>2) powr (real_of_int (- int n) / 2)) integrable_on {0..}"
             by (intro integrable_spike_set_eq) auto
           finally show "(\<lambda>x. c * (x\<^sup>2 + (cmod s)\<^sup>2) powr (real_of_int (- int n) / 2)) integrable_on
                    {0..real N}" by (rule integrable_on_subinterval) auto
         next
           fix x assume x: "x \<in> {0..real N}"
           have nz: "complex_of_real x + s \<noteq> 0"
             using True x by (auto simp: complex_eq_iff)
           have "norm (of_real (pbernpoly n x) / (of_real x + s) ^ n) \<le> c / norm (of_real x + s) ^ n"
             unfolding norm_divide norm_power using c by (intro divide_right_mono) simp_all
           also have "\<dots> \<le> c / sqrt (x ^ 2 + norm s ^ 2) ^ n"
           proof (intro divide_left_mono mult_pos_pos zero_less_power power_mono)
             show "sqrt (x\<^sup>2 + (cmod s)\<^sup>2) \<le> cmod (complex_of_real x + s)"
               using x True by (simp add: cmod_def algebra_simps power2_eq_square)
           qed (use x True c_nonneg assms nz in \<open>auto simp: add_nonneg_pos\<close>)
           also have "sqrt (x ^ 2 + norm s ^ 2) ^ n = (x ^ 2 + norm s ^ 2) powr (1/2 * n)"
             by (subst powr_powr [symmetric], subst powr_realpow)
                (auto simp: powr_half_sqrt add_nonneg_pos)
           also have "c / \<dots> = c * (x^2 + norm s^2) powr (-n / 2)"
             by (simp add: powr_minus field_simps)
           finally show "norm (complex_of_real (pbernpoly n x) / (complex_of_real x + s) ^ n) \<le> \<dots>" .
         qed fact+
         also have "\<dots> \<le> integral {0..} (\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2))"
           using c_nonneg
           by (intro integral_subset_le integrable integrable_on_subinterval[OF integrable]) auto
         also have "\<dots> = D * (norm s ^ 2) powr (-n / 2 + 1 / 2)"
           using int' by (simp add: has_integral_iff)
         also have "(norm s ^ 2) powr (-n / 2 + 1 / 2) = norm s powr (2 * (-n / 2 + 1 / 2))"
           by (subst powr_powr [symmetric]) auto
         also have "\<dots> = norm s powr (-real (n - 1))"
           using assms by (simp add: of_nat_diff)
         also have "D * \<dots> = D / norm s ^ (n - 1)"
           by (auto simp: powr_minus powr_realpow field_simps)
         also have "\<dots> \<le> C / norm s ^ (n - 1)"
           by (intro divide_right_mono) (auto simp: C_def)
         finally show "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le> \<dots>" .
 
       next
 
         case False
         have "cos \<bar>Arg s\<bar> = cos (Arg s)"
           by (simp add: abs_if)
         also have "cos (Arg s) = Re (rcis (norm s) (Arg s)) / norm s"
           by (subst Re_rcis) auto
         also have "\<dots> = Re s / norm s"
           by (subst rcis_cmod_Arg) auto
         also have "\<dots> \<le> cos (pi / 2)"
           using False by (auto simp: field_simps)
         finally have "\<bar>Arg s\<bar> \<ge> pi / 2"
           using Arg \<alpha> by (subst (asm) cos_mono_le_eq) auto
 
         have "sin \<alpha> * norm s = sin (pi - \<alpha>) * norm s"
           by simp
         also have "\<dots> \<le> sin (pi - \<bar>Arg s\<bar>) * norm s"
           using \<alpha> Arg \<open>\<bar>Arg s\<bar> \<ge> pi / 2\<close>
           by (intro mult_right_mono sin_monotone_2pi_le) auto
         also have "sin \<bar>Arg s\<bar> \<ge> 0"
           using Arg_bounded[of s] by (intro sin_ge_zero) auto
         hence "sin (pi - \<bar>Arg s\<bar>) = \<bar>sin \<bar>Arg s\<bar>\<bar>"
           by simp 
         also have "\<dots> = \<bar>sin (Arg s)\<bar>"
           by (simp add: abs_if)
         also have "\<dots> * norm s = \<bar>Im (rcis (norm s) (Arg s))\<bar>"
           by (simp add: abs_mult)
         also have "\<dots> = \<bar>Im s\<bar>"
           by (subst rcis_cmod_Arg) auto
         finally have abs_Im_ge: "\<bar>Im s\<bar> \<ge> sin \<alpha> * norm s" .
 
         have [simp]: "Im s \<noteq> 0" "s \<noteq> 0"
           using s \<open>s \<notin> \<real>\<^sub>\<le>\<^sub>0\<close> False
           by (auto simp: cmod_def zero_le_mult_iff complex_nonpos_Reals_iff)
         have "sin \<alpha> > 0"
           using assms by (intro sin_gt_zero) auto
   
         obtain I where I: "((\<lambda>x. c / max \<bar>Im s\<bar> \<bar>x + Re s\<bar> ^ n) has_integral I) {0..real N}"
                           "I \<le> 2*c*(n/(n-1)) / \<bar>Im s\<bar> ^ (n - 1)"
           using s c_nonneg assms False 
                 stirling_integral_bound_aux_integral2[of "-Re s" "\<bar>Im s\<bar>" c n 0 "real N"] by auto
   
         have "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le>
                 integral {0..real N} (\<lambda>x. c / max \<bar>Im s\<bar> \<bar>x + Re s\<bar> ^ n)"
         proof (intro integral_norm_bound_integral integrable_ln_Gamma_aux s ballI)
           show "(\<lambda>x. c / max \<bar>Im s\<bar> \<bar>x + Re s\<bar> ^ n) integrable_on {0..real N}"
             using I(1) by (simp add: has_integral_iff)
         next
           fix x assume x: "x \<in> {0..real N}"
           have nz: "complex_of_real x + s \<noteq> 0"
             by (auto simp: complex_eq_iff)
           have "norm (complex_of_real (pbernpoly n x) / (complex_of_real x + s) ^ n) \<le>
                   c / norm (complex_of_real x + s) ^ n"
             unfolding norm_divide norm_power using c[of x] by (intro divide_right_mono) simp_all
           also have "\<dots> \<le> c / max \<bar>Im s\<bar> \<bar>x + Re s\<bar> ^ n"
             using c_nonneg nz abs_Re_le_cmod[of "of_real x + s"] abs_Im_le_cmod[of "of_real x + s"]
             by (intro divide_left_mono power_mono mult_pos_pos zero_less_power)
                (auto simp: less_max_iff_disj)
           finally show "norm (complex_of_real (pbernpoly n x) / (complex_of_real x + s) ^ n) \<le> \<dots>" .
         qed (auto simp: complex_nonpos_Reals_iff)
         also have "\<dots> \<le> 2*c*(n/(n-1)) / \<bar>Im s\<bar> ^ (n - 1)"
           using I by (simp add: has_integral_iff)
         also have "\<dots> \<le> 2*c*(n/(n-1)) / (sin \<alpha> * norm s) ^ (n - 1)"
           using \<open>sin \<alpha> > 0\<close> s c_nonneg abs_Im_ge
           by (intro divide_left_mono mult_pos_pos zero_less_power power_mono mult_nonneg_nonneg) auto
         also have "\<dots> = 2*c*(n/(n-1))/sin \<alpha>^(n-1) / norm s ^ (n - 1)"
           by (simp add: field_simps)
         also have "\<dots> \<le> C / norm s ^ (n - 1)"
           by (intro divide_right_mono) (auto simp: C_def)
         finally show ?thesis .
       qed
     qed
   qed (use that assms complex_cone_inter_nonpos_Reals[of "-\<alpha>" \<alpha>] \<alpha> in auto)
   thus ?thesis by (rule that)
 qed
 
 lemma stirling_integral_bound:
   assumes "n > 0"
   obtains c where 
     "\<And>s. Re s > 0 \<Longrightarrow> norm (stirling_integral n s) \<le> c / Re s ^ n"
 proof -
   let ?f = "\<lambda>s. of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s -
                   of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n)"
   from stirling_integral_bound_aux[of "Suc n"] assms obtain c where 
     c: "\<And>s. Re s > 0 \<Longrightarrow> norm (stirling_integral (Suc n) s) \<le> c / Re s ^ n" by auto
   define c1 where "c1 = real n / real (Suc n) * c"
   define c2 where "c2 = \<bar>bernoulli (Suc n)\<bar> / real (Suc n)"
   have c2_nonneg: "c2 \<ge> 0" by (simp add: c2_def)
   show ?thesis
   proof (rule that)
     fix s :: complex assume s: "Re s > 0"
     hence s': "s \<notin> \<real>\<^sub>\<le>\<^sub>0" by (auto simp: complex_nonpos_Reals_iff)
     have "stirling_integral n s = ?f s" using s' assms 
       by (rule stirling_integral_conv_stirling_integral_Suc)
     also have "norm \<dots> \<le> norm (of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s) +
                            norm (of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n))"
       by (rule norm_triangle_ineq4)
     also have "\<dots> = real n / real (Suc n) * norm (stirling_integral (Suc n) s) +
                       c2 / norm s ^ n" (is "_ = ?A + ?B")
       by (simp add: norm_divide norm_mult norm_power c2_def field_simps del: of_nat_Suc)
     also have "?A \<le> real n / real (Suc n) * (c / Re s ^ n)"
       by (intro mult_left_mono c s) simp_all
     also have "\<dots> = c1 / Re s ^ n" by (simp add: c1_def)
     also have "c2 / norm s ^ n \<le> c2 / Re s ^ n" using s c2_nonneg
       by (intro divide_left_mono power_mono complex_Re_le_cmod mult_pos_pos zero_less_power) auto
     also have "c1 / Re s ^ n + c2 / Re s ^ n = (c1 + c2) / Re s ^ n" 
       using s by (simp add: field_simps)
     finally show "norm (stirling_integral n s) \<le> (c1 + c2) / Re s ^ n" by - simp_all
   qed
 qed
 
 lemma stirling_integral_bound':
   assumes "n > 0" and "\<alpha> \<in> {0<..<pi}"
   obtains c where 
     "\<And>s::complex. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow> norm (stirling_integral n s) \<le> c / norm s ^ n"
 proof -
   let ?f = "\<lambda>s. of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s -
                   of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n)"
   from stirling_integral_bound_aux'[of "Suc n"] assms obtain c where 
     c: "\<And>s::complex. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow>
             norm (stirling_integral (Suc n) s) \<le> c / norm s ^ n" by auto
   define c1 where "c1 = real n / real (Suc n) * c"
   define c2 where "c2 = \<bar>bernoulli (Suc n)\<bar> / real (Suc n)"
   have c2_nonneg: "c2 \<ge> 0" by (simp add: c2_def)
   show ?thesis
   proof (rule that)
     fix s :: complex assume s: "s \<in> complex_cone' \<alpha> - {0}"
     have s': "s \<notin> \<real>\<^sub>\<le>\<^sub>0"
       using complex_cone_inter_nonpos_Reals[of "-\<alpha>" \<alpha>] assms s by auto
       
     have "stirling_integral n s = ?f s" using s' assms 
       by (intro stirling_integral_conv_stirling_integral_Suc) auto
     also have "norm \<dots> \<le> norm (of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s) +
                            norm (of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n))"
       by (rule norm_triangle_ineq4)
     also have "\<dots> = real n / real (Suc n) * norm (stirling_integral (Suc n) s) +
                       c2 / norm s ^ n" (is "_ = ?A + ?B")
       by (simp add: norm_divide norm_mult norm_power c2_def field_simps del: of_nat_Suc)
     also have "?A \<le> real n / real (Suc n) * (c / norm s ^ n)"
       by (intro mult_left_mono c s) simp_all
     also have "\<dots> = c1 / norm s ^ n" by (simp add: c1_def)
     also have "c1 / norm s ^ n + c2 / norm s ^ n = (c1 + c2) / norm s ^ n" 
       using s by (simp add: divide_simps)
     finally show "norm (stirling_integral n s) \<le> (c1 + c2) / norm s ^ n" by - simp_all
   qed
 qed
 
 
 lemma stirling_integral_holomorphic [holomorphic_intros]:
   assumes m: "m > 0" and "A \<inter> \<real>\<^sub>\<le>\<^sub>0 = {}"
   shows   "stirling_integral m holomorphic_on A"  
 proof -
   from assms have [simp]: "z \<notin> \<real>\<^sub>\<le>\<^sub>0" if "z \<in> A" for z
     using that by auto
   let ?f = "\<lambda>s::complex. of_nat m * ((s - 1 / 2) * Ln s - s + of_real (ln (2 * pi) / 2) +
           (\<Sum>k=1..<m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k)) - 
           ln_Gamma s)"
   have "?f holomorphic_on A" using assms
     by (auto intro!: holomorphic_intros simp del: of_nat_Suc elim!: nonpos_Reals_cases)
   also have "?this \<longleftrightarrow> stirling_integral m holomorphic_on A" 
     using assms by (intro holomorphic_cong refl) 
                    (simp_all add: field_simps ln_Gamma_stirling_complex)
   finally show "stirling_integral m holomorphic_on A" .
 qed
 
 lemma stirling_integral_continuous_on_complex [continuous_intros]:
   assumes m: "m > 0" and "A \<inter> \<real>\<^sub>\<le>\<^sub>0 = {}"
   shows   "continuous_on A (stirling_integral m :: _ \<Rightarrow> complex)"
   by (intro holomorphic_on_imp_continuous_on stirling_integral_holomorphic assms)
     
 lemma has_field_derivative_stirling_integral_complex:
   fixes x :: complex
   assumes "x \<notin> \<real>\<^sub>\<le>\<^sub>0" "n > 0"
   shows   "(stirling_integral n has_field_derivative deriv (stirling_integral n) x) (at x)"
   using assms
   by (intro holomorphic_derivI[OF stirling_integral_holomorphic, of n  "-\<real>\<^sub>\<le>\<^sub>0"]) auto
 
 
  
 lemma
   assumes n: "n > 0" and "x > 0"
   shows   deriv_stirling_integral_complex_of_real:
             "(deriv ^^ j) (stirling_integral n) (complex_of_real x) =
                complex_of_real ((deriv ^^ j) (stirling_integral n) x)" (is "?lhs x = ?rhs x")
   and     differentiable_stirling_integral_real:
             "(deriv ^^ j) (stirling_integral n) field_differentiable at x" (is ?thesis2)
 proof -
   let ?A = "{s. Re s > 0}"
   let ?f = "\<lambda>j x. (deriv ^^ j) (stirling_integral n) (complex_of_real x)"
   let ?f' = "\<lambda>j x. complex_of_real ((deriv ^^ j) (stirling_integral n) x)"
     
   have [simp]: "open ?A" by (simp add: open_halfspace_Re_gt)      
 
   have "?lhs x = ?rhs x \<and> (deriv ^^ j) (stirling_integral n) field_differentiable at x" 
     if "x > 0" for x using that
   proof (induction j arbitrary: x)
     case 0
     have "((\<lambda>x. Re (stirling_integral n (of_real x))) has_field_derivative 
                   Re (deriv (\<lambda>x. stirling_integral n x) (of_real x))) (at x)" using 0 n
       by (auto intro!: derivative_intros has_vector_derivative_real_field
                  field_differentiable_derivI holomorphic_on_imp_differentiable_at[of _ ?A]
                  stirling_integral_holomorphic simp: complex_nonpos_Reals_iff)
     also have "?this \<longleftrightarrow> (stirling_integral n has_field_derivative 
              Re (deriv (\<lambda>x. stirling_integral n x) (of_real x))) (at x)"
       using eventually_nhds_in_open[of "{0<..}" x] 0 n
       by (intro has_field_derivative_cong_ev refl) 
          (auto elim!: eventually_mono simp: stirling_integral_complex_of_real)
     finally have "stirling_integral n field_differentiable at x"
       by (auto simp: field_differentiable_def)
     with 0 n show ?case by (auto simp: stirling_integral_complex_of_real)
   next
     case (Suc j x)
     note IH = conjunct1[OF Suc.IH] conjunct2[OF Suc.IH]
     have *: "(deriv ^^ Suc j) (stirling_integral n) (complex_of_real x) =
                  of_real ((deriv ^^ Suc j) (stirling_integral n) x)" if x: "x > 0" for x
     proof -
       have "deriv ((deriv ^^ j) (stirling_integral n)) (complex_of_real x) =
               vector_derivative (\<lambda>x. (deriv ^^ j) (stirling_integral n) (of_real x)) (at x)"
         using n x
         by (intro vector_derivative_of_real_right [symmetric] 
                    holomorphic_on_imp_differentiable_at[of _ ?A] holomorphic_higher_deriv
                    stirling_integral_holomorphic) (auto simp: complex_nonpos_Reals_iff)
       also have "\<dots> = vector_derivative (\<lambda>x. of_real ((deriv ^^ j) (stirling_integral n) x)) (at x)"
         using eventually_nhds_in_open[of "{0<..}" x] x
         by (intro vector_derivative_cong_eq) (auto elim!: eventually_mono simp: IH(1))
       also have "\<dots> = of_real (deriv ((deriv ^^ j) (stirling_integral n)) x)"
         by (intro vector_derivative_of_real_left holomorphic_on_imp_differentiable_at[of _ ?A]
               field_differentiable_imp_differentiable IH(2) x)
       finally show ?thesis by simp
     qed
     have "((\<lambda>x. Re ((deriv ^^ Suc j) (stirling_integral n) (of_real x))) has_field_derivative 
              Re (deriv ((deriv ^^ Suc j) (stirling_integral n)) (of_real x))) (at x)"
       using Suc.prems n
       by (intro derivative_intros has_vector_derivative_real_field field_differentiable_derivI
                 holomorphic_on_imp_differentiable_at[of _ ?A] stirling_integral_holomorphic
                 holomorphic_higher_deriv) (auto simp: complex_nonpos_Reals_iff)
     also have "?this \<longleftrightarrow> ((deriv ^^ Suc j) (stirling_integral n) has_field_derivative 
                   Re (deriv ((deriv ^^ Suc j) (stirling_integral n)) (of_real x))) (at x)"  
       using eventually_nhds_in_open[of "{0<..}" x] Suc.prems *
       by (intro has_field_derivative_cong_ev refl) (auto elim!: eventually_mono)
     finally have "(deriv ^^ Suc j) (stirling_integral n) field_differentiable at x"
       by (auto simp: field_differentiable_def)
     with *[OF Suc.prems] show ?case by blast
   qed
   from this[OF assms(2)] show "?lhs x = ?rhs x" ?thesis2 by blast+
 qed
 
 text \<open>
   Unfortunately, asymptotic power series cannot, in general, be differentiated. However, since 
   @{term ln_Gamma} is holomorphic on the entire positive real half-space, we can differentiate 
   its asymptotic expansion after all.
 
   To do this, we use an ad-hoc version of the more general approach outlined in Erdelyi's
   ``Asymptotic Expansions'' for holomorphic functions: We bound the value of the $j$-th derivative 
   of the remainder term at some value $x$ by applying Cauchy's integral formula along a circle 
   centred at $x$ with radius $\frac{1}{2} x$.
 \<close>
 lemma deriv_stirling_integral_real_bound:
   assumes m: "m > 0"
   shows   "(deriv ^^ j) (stirling_integral m) \<in> O(\<lambda>x::real. 1 / x ^ (m + j))"
 proof -
-  from stirling_integral_bound[OF m] guess c . note c = this
+  obtain c where c: "\<And>s. 0 < Re s \<Longrightarrow> cmod (stirling_integral m s) \<le> c / Re s ^ m"
+    using stirling_integral_bound[OF m] by auto
   have "0 \<le> cmod (stirling_integral m 1)" by simp
   also have "\<dots> \<le> c" using c[of 1] by simp
   finally have c_nonneg: "c \<ge> 0" .
   define B where "B = c * 2 ^ (m + Suc j)"
   define B' where "B' = B * fact j / 2"
 
   have "eventually (\<lambda>x::real. norm ((deriv ^^ j) (stirling_integral m) x) \<le> 
           B' * norm (1 / x ^ (m+ j))) at_top"
     using eventually_gt_at_top[of "0::real"]
   proof eventually_elim
     case (elim x)
     have "s \<notin> \<real>\<^sub>\<le>\<^sub>0" if "s \<in> cball (of_real x) (x/2)" for s :: complex
     proof -
       have "x - Re s \<le> norm (of_real x - s)" using complex_Re_le_cmod[of "of_real x - s"] by simp
       also from that have "\<dots> \<le> x/2" by (simp add: dist_complex_def)
       finally show ?thesis using elim by (auto simp: complex_nonpos_Reals_iff)
     qed
     hence "((\<lambda>u. stirling_integral m u / (u - of_real x) ^ Suc j) has_contour_integral
             complex_of_real (2 * pi) * \<i> / fact j * 
               (deriv ^^ j) (stirling_integral m) (of_real x)) (circlepath (of_real x) (x/2))"
       using m elim
       by (intro Cauchy_has_contour_integral_higher_derivative_circlepath 
                 stirling_integral_continuous_on_complex stirling_integral_holomorphic) auto
     hence "norm (of_real (2 * pi) * \<i> / fact j * (deriv ^^ j) (stirling_integral m) (of_real x)) \<le>
             B / x ^ (m + Suc j) * (2 * pi * (x / 2))"
     proof (rule has_contour_integral_bound_circlepath)
       fix u :: complex assume dist: "norm (u - of_real x) = x / 2"
       have "Re (of_real x - u) \<le> norm (of_real x - u)" by (rule complex_Re_le_cmod)
       also have "\<dots> = x / 2" using dist by (simp add: norm_minus_commute)
       finally have Re_u: "Re u \<ge> x/2" using elim by simp
       have "norm (stirling_integral m u / (u - of_real x) ^ Suc j) \<le> 
               c / Re u ^ m / (x / 2) ^ Suc j" using Re_u elim
         unfolding norm_divide norm_power dist
         by (intro divide_right_mono zero_le_power c) simp_all
       also have "\<dots> \<le> c / (x/2) ^ m / (x / 2) ^ Suc j" using c_nonneg elim Re_u
         by (intro divide_right_mono divide_left_mono power_mono) simp_all
       also have "\<dots> = B / x ^ (m + Suc j)" using elim by (simp add: B_def field_simps power_add)
       finally show "norm (stirling_integral m u / (u - of_real x) ^ Suc j) \<le> B / x ^ (m + Suc j)" .
     qed (insert elim c_nonneg, auto simp: B_def simp del: power_Suc)
     hence "cmod ((deriv ^^ j) (stirling_integral m) (of_real x)) \<le> B' / x ^ (j + m)"
       using elim by (simp add: field_simps norm_divide norm_mult norm_power B'_def)
     with elim m show ?case by (simp_all add: add_ac deriv_stirling_integral_complex_of_real)
   qed
   thus ?thesis by (rule bigoI)
 qed
 
 definition stirling_sum where
   "stirling_sum j m x = 
      (-1) ^ j * (\<Sum>k = 1..<m. (of_real (bernoulli (Suc k)) * pochhammer (of_nat k) j / (of_nat k *
                                  of_nat (Suc k))) * inverse x ^ (k + j))"
   
 definition stirling_sum' where
   "stirling_sum' j m x = 
      (-1) ^ (Suc j) * (\<Sum>k\<le>m. (of_real (bernoulli' k) * 
        pochhammer (of_nat (Suc k)) (j - 1) * inverse x ^ (k + j)))"
 
 lemma stirling_sum_complex_of_real:
   "stirling_sum j m (complex_of_real x) = complex_of_real (stirling_sum j m x)"
   by (simp add: stirling_sum_def pochhammer_of_real [symmetric] del: of_nat_Suc)
 
 lemma stirling_sum'_complex_of_real:
   "stirling_sum' j m (complex_of_real x) = complex_of_real (stirling_sum' j m x)"
   by (simp add: stirling_sum'_def pochhammer_of_real [symmetric] del: of_nat_Suc)
 
 lemma has_field_derivative_stirling_sum_complex [derivative_intros]:
   "Re x > 0 \<Longrightarrow> (stirling_sum j m has_field_derivative stirling_sum (Suc j) m x) (at x)"
     unfolding stirling_sum_def [abs_def] sum_distrib_left
     by (rule DERIV_sum) (auto intro!: derivative_eq_intros simp del: of_nat_Suc 
                               simp: pochhammer_Suc power_diff)
 
 lemma has_field_derivative_stirling_sum_real [derivative_intros]:
   "x > (0::real) \<Longrightarrow> (stirling_sum j m has_field_derivative stirling_sum (Suc j) m x) (at x)"
     unfolding stirling_sum_def [abs_def] sum_distrib_left
     by (rule DERIV_sum) (auto intro!: derivative_eq_intros simp del: of_nat_Suc 
                               simp: pochhammer_Suc power_diff)
 
 lemma has_field_derivative_stirling_sum'_complex [derivative_intros]:
   assumes "j > 0" "Re x > 0"
   shows   "(stirling_sum' j m has_field_derivative stirling_sum' (Suc j) m x) (at x)"
 proof (cases j)
   case (Suc j')
   from assms have [simp]: "x \<noteq> 0" by auto
   define c where "c = (\<lambda>n. (-1) ^ Suc j * complex_of_real (bernoulli' n) * 
                           pochhammer (of_nat (Suc n)) j')"
   define T where "T = (\<lambda>n x. c n * inverse x ^ (j + n))"
   define T' where "T' = (\<lambda>n x. - (of_nat (j + n)) * c n * inverse x ^ (Suc (j + n)))"
   have "((\<lambda>x. \<Sum>k\<le>m. T k x) has_field_derivative (\<Sum>k\<le>m. T' k x)) (at x)" using assms Suc
     by (intro DERIV_sum)
        (auto simp: T_def T'_def intro!: derivative_eq_intros 
              simp: field_simps power_add [symmetric]  simp del: of_nat_Suc power_Suc of_nat_add)
   also have "(\<lambda>x. (\<Sum>k\<le>m. T k x)) = stirling_sum' j m"
     by (simp add: Suc T_def c_def stirling_sum'_def fun_eq_iff add_ac mult.assoc sum_distrib_left)
   also have "(\<Sum>k\<le>m. T' k x) = stirling_sum' (Suc j) m x"
     by (simp add: T'_def c_def Suc stirling_sum'_def sum_distrib_left 
           sum_distrib_right algebra_simps pochhammer_Suc)
   finally show ?thesis .
 qed (insert assms, simp_all)
   
 lemma has_field_derivative_stirling_sum'_real [derivative_intros]:
   assumes "j > 0" "x > (0::real)"
   shows   "(stirling_sum' j m has_field_derivative stirling_sum' (Suc j) m x) (at x)"
 proof (cases j)
   case (Suc j')
   from assms have [simp]: "x \<noteq> 0" by auto
   define c where "c = (\<lambda>n. (-1) ^ Suc j * (bernoulli' n) * pochhammer (of_nat (Suc n)) j')"
   define T where "T = (\<lambda>n x. c n * inverse x ^ (j + n))"
   define T' where "T' = (\<lambda>n x. - (of_nat (j + n)) * c n * inverse x ^ (Suc (j + n)))"
   have "((\<lambda>x. \<Sum>k\<le>m. T k x) has_field_derivative (\<Sum>k\<le>m. T' k x)) (at x)" using assms Suc
     by (intro DERIV_sum)
        (auto simp: T_def T'_def intro!: derivative_eq_intros 
              simp: field_simps power_add [symmetric]  simp del: of_nat_Suc power_Suc of_nat_add)
   also have "(\<lambda>x. (\<Sum>k\<le>m. T k x)) = stirling_sum' j m"
     by (simp add: Suc T_def c_def stirling_sum'_def fun_eq_iff add_ac mult.assoc sum_distrib_left)
   also have "(\<Sum>k\<le>m. T' k x) = stirling_sum' (Suc j) m x"
     by (simp add: T'_def c_def Suc stirling_sum'_def sum_distrib_left 
           sum_distrib_right algebra_simps pochhammer_Suc)
   finally show ?thesis .
 qed (insert assms, simp_all)
 
 lemma higher_deriv_stirling_sum_complex:
   "Re x > 0 \<Longrightarrow> (deriv ^^ i) (stirling_sum j m) x = stirling_sum (i + j) m x"
 proof (induction i arbitrary: x)
   case (Suc i)
   have "deriv ((deriv ^^ i) (stirling_sum j m)) x = deriv (stirling_sum (i + j) m) x"
     using eventually_nhds_in_open[of "{x. Re x > 0}" x] Suc.prems
     by (intro deriv_cong_ev refl) (auto elim!: eventually_mono simp: open_halfspace_Re_gt Suc.IH)
   also from Suc.prems have "\<dots> = stirling_sum (Suc (i + j)) m x"
     by (intro DERIV_imp_deriv has_field_derivative_stirling_sum_complex)
   finally show ?case by simp
 qed simp_all
   
 
 definition Polygamma_approx :: "nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a :: {real_normed_field, ln}" where
   "Polygamma_approx j m = 
      (deriv ^^ j) (\<lambda>x. (x - 1 / 2) * ln x - x + of_real (ln (2 * pi)) / 2 + stirling_sum 0 m x)"
   
 lemma Polygamma_approx_Suc: "Polygamma_approx (Suc j) m = deriv (Polygamma_approx j m)"
   by (simp add: Polygamma_approx_def)  
 
 lemma Polygamma_approx_0: 
   "Polygamma_approx 0 m x = (x - 1/2) * ln x - x + of_real (ln (2*pi)) / 2 + stirling_sum 0 m x"
   by (simp add: Polygamma_approx_def)
     
 lemma Polygamma_approx_1_complex: 
   "Re x > 0 \<Longrightarrow> 
      Polygamma_approx (Suc 0) m x = ln x - 1 / (2*x) + stirling_sum (Suc 0) m x"
   unfolding Polygamma_approx_Suc Polygamma_approx_0
   by (intro DERIV_imp_deriv) 
      (auto intro!: derivative_eq_intros elim!: nonpos_Reals_cases simp: field_simps)
      
 lemma Polygamma_approx_1_real: 
   "x > (0 :: real) \<Longrightarrow> 
      Polygamma_approx (Suc 0) m x = ln x - 1 / (2*x) + stirling_sum (Suc 0) m x"
   unfolding Polygamma_approx_Suc Polygamma_approx_0
   by (intro DERIV_imp_deriv) 
      (auto intro!: derivative_eq_intros elim!: nonpos_Reals_cases simp: field_simps)
  
 lemma stirling_sum_2_conv_stirling_sum'_1:
   fixes x :: "'a :: {real_div_algebra, field_char_0}"
   assumes "m > 0" "x \<noteq> 0"
   shows   "stirling_sum' 1 m x = 1 / x + 1 / (2 * x^2) + stirling_sum 2 m x"
 proof -
   have pochhammer_2: "pochhammer (of_nat k) 2 = of_nat k * of_nat (Suc k)" for k 
     by (simp add: pochhammer_Suc eval_nat_numeral add_ac)
   have "stirling_sum 2 m x = 
           (\<Sum>k = Suc 0..<m. of_real (bernoulli' (Suc k)) * inverse x ^ Suc (Suc k))"
     unfolding stirling_sum_def pochhammer_2 power2_minus power_one mult_1_left
     by (intro sum.cong refl)
        (simp_all add: stirling_sum_def pochhammer_2 power2_eq_square divide_simps bernoulli'_def
                  del: of_nat_Suc power_Suc)
   also have "1 / (2 * x^2) + \<dots> = 
                (\<Sum>k=0..<m. of_real (bernoulli' (Suc k)) * inverse x ^ Suc (Suc k))" using assms
     by (subst (2) sum.atLeast_Suc_lessThan) (simp_all add: power2_eq_square field_simps)
   also have "1 / x + \<dots> = (\<Sum>k=0..<Suc m. of_real (bernoulli' k) * inverse x ^ Suc k)"
     by (subst sum.atLeast0_lessThan_Suc_shift) (simp_all add: bernoulli'_def divide_simps)
   also have "\<dots> = (\<Sum>k\<le>m. of_real (bernoulli' k) * inverse x ^ Suc k)"
     by (intro sum.cong) auto
   also have "\<dots> = stirling_sum' 1 m x" by (simp add: stirling_sum'_def)
   finally show ?thesis by (simp add: add_ac)
 qed
 
 lemma Polygamma_approx_2_real: 
   assumes "x > (0::real)" "m > 0"
   shows   "Polygamma_approx (Suc (Suc 0)) m x = stirling_sum' 1 m x"
 proof -
   have "Polygamma_approx (Suc (Suc 0)) m x = deriv (Polygamma_approx (Suc 0) m) x" 
     by (simp add: Polygamma_approx_Suc)
   also have "\<dots> = deriv (\<lambda>x. ln x - 1 / (2*x) + stirling_sum (Suc 0) m x) x"
     using eventually_nhds_in_open[of "{0<..}" x] assms
     by (intro deriv_cong_ev) (auto elim!: eventually_mono simp: Polygamma_approx_1_real)
   also have "\<dots> = 1 / x + 1 / (2*x^2) + stirling_sum (Suc (Suc 0)) m x" using assms
     by (intro DERIV_imp_deriv) (auto intro!: derivative_eq_intros 
            elim!: nonpos_Reals_cases simp: field_simps power2_eq_square)
   also have "\<dots> = stirling_sum' 1 m x" using stirling_sum_2_conv_stirling_sum'_1[of m x] assms
     by (simp add: eval_nat_numeral)
   finally show ?thesis .
 qed
   
 lemma Polygamma_approx_2_complex: 
   assumes "Re x > 0" "m > 0"
   shows   "Polygamma_approx (Suc (Suc 0)) m x = stirling_sum' 1 m x"
 proof -
   have "Polygamma_approx (Suc (Suc 0)) m x = deriv (Polygamma_approx (Suc 0) m) x" 
     by (simp add: Polygamma_approx_Suc)
   also have "\<dots> = deriv (\<lambda>x. ln x - 1 / (2*x) + stirling_sum (Suc 0) m x) x"
     using eventually_nhds_in_open[of "{s. Re s > 0}" x] assms
     by (intro deriv_cong_ev)
        (auto simp: open_halfspace_Re_gt elim!: eventually_mono simp: Polygamma_approx_1_complex)
   also have "\<dots> = 1 / x + 1 / (2*x^2) + stirling_sum (Suc (Suc 0)) m x" using assms
     by (intro DERIV_imp_deriv) (auto intro!: derivative_eq_intros 
            elim!: nonpos_Reals_cases simp: field_simps power2_eq_square)
   also have "\<dots> = stirling_sum' 1 m x" using stirling_sum_2_conv_stirling_sum'_1[of m x] assms
       by (subst stirling_sum_2_conv_stirling_sum'_1) (auto simp: eval_nat_numeral)
   finally show ?thesis .
 qed
   
 lemma Polygamma_approx_ge_2_real: 
   assumes "x > (0::real)" "m > 0"
   shows   "Polygamma_approx (Suc (Suc j)) m x = stirling_sum' (Suc j) m x"
 using assms(1)
 proof (induction j arbitrary: x)
   case (0 x)
   with assms show ?case by (simp add: Polygamma_approx_2_real)
 next
   case (Suc j x)
   have "Polygamma_approx (Suc (Suc (Suc j))) m x = deriv (Polygamma_approx (Suc (Suc j)) m) x"
     by (simp add: Polygamma_approx_Suc)
   also have "\<dots> = deriv (stirling_sum' (Suc j) m) x"
     using eventually_nhds_in_open[of "{0<..}" x] Suc.prems
     by (intro deriv_cong_ev refl) (auto elim!: eventually_mono simp: Suc.IH)
   also have "\<dots> = stirling_sum' (Suc (Suc j)) m x" using Suc.prems
     by (intro DERIV_imp_deriv derivative_intros) simp_all
   finally show ?case .
 qed
   
 lemma Polygamma_approx_ge_2_complex:
   assumes "Re x > 0" "m > 0"
   shows   "Polygamma_approx (Suc (Suc j)) m x = stirling_sum' (Suc j) m x"
 using assms(1)
 proof (induction j arbitrary: x)
   case (0 x)
   with assms show ?case by (simp add: Polygamma_approx_2_complex)
 next
   case (Suc j x)
   have "Polygamma_approx (Suc (Suc (Suc j))) m x = deriv (Polygamma_approx (Suc (Suc j)) m) x"
     by (simp add: Polygamma_approx_Suc)
   also have "\<dots> = deriv (stirling_sum' (Suc j) m) x"
     using eventually_nhds_in_open[of "{x. Re x > 0}" x] Suc.prems
     by (intro deriv_cong_ev refl) (auto elim!: eventually_mono simp: Suc.IH open_halfspace_Re_gt)
   also have "\<dots> = stirling_sum' (Suc (Suc j)) m x" using Suc.prems
     by (intro DERIV_imp_deriv derivative_intros) simp_all
   finally show ?case .
 qed
 
 lemma Polygamma_approx_complex_of_real:
   assumes "x > 0" "m > 0"
   shows   "Polygamma_approx j m (complex_of_real x) = of_real (Polygamma_approx j m x)"
 proof (cases j)
   case 0
   with assms show ?thesis by (simp add: Polygamma_approx_0 Ln_of_real stirling_sum_complex_of_real)
 next
   case [simp]: (Suc j')
   thus ?thesis
   proof (cases j')
     case 0
     with assms show ?thesis 
       by (simp add: Polygamma_approx_1_complex 
                     Polygamma_approx_1_real stirling_sum_complex_of_real Ln_of_real)
   next
     case (Suc j'')
     with assms show ?thesis
       by (simp add: Polygamma_approx_ge_2_complex Polygamma_approx_ge_2_real 
                     stirling_sum'_complex_of_real)
   qed
 qed
   
 lemma higher_deriv_Polygamma_approx [simp]: 
   "(deriv ^^ j) (Polygamma_approx i m) = Polygamma_approx (j + i) m"
   by (simp add: Polygamma_approx_def funpow_add)
   
 lemma stirling_sum_holomorphic [holomorphic_intros]:
   "0 \<notin> A \<Longrightarrow> stirling_sum j m holomorphic_on A"
   unfolding stirling_sum_def by (intro holomorphic_intros) auto
   
 lemma Polygamma_approx_holomorphic [holomorphic_intros]:
   "Polygamma_approx j m holomorphic_on {s. Re s > 0}"
   unfolding Polygamma_approx_def
   by (intro holomorphic_intros) (auto simp: open_halfspace_Re_gt elim!: nonpos_Reals_cases)
   
 lemma higher_deriv_lnGamma_stirling:
   assumes m: "m > 0"
   shows   "(\<lambda>x::real. (deriv ^^ j) ln_Gamma x - Polygamma_approx j m x) \<in> O(\<lambda>x. 1 / x ^ (m + j))"
 proof -
   have "eventually (\<lambda>x. \<bar>(deriv ^^ j) ln_Gamma x - Polygamma_approx j m x\<bar> =
                           inverse (real m) * \<bar>(deriv ^^ j) (stirling_integral m) x\<bar>) at_top"
     using eventually_gt_at_top[of "0::real"]
   proof eventually_elim
     case (elim x)
     note x = this
     have "\<forall>\<^sub>F y in nhds (complex_of_real x). y \<in> - \<real>\<^sub>\<le>\<^sub>0"
       using elim by (intro eventually_nhds_in_open) auto
     hence "(deriv ^^ j) (\<lambda>x. ln_Gamma x - Polygamma_approx 0 m x) (complex_of_real x) =
             (deriv ^^ j) (\<lambda>x. (-inverse (of_nat m)) * stirling_integral m x) (complex_of_real x)"
       using x m
       by (intro higher_deriv_cong_ev refl)
          (auto elim!: eventually_mono simp: ln_Gamma_stirling_complex Polygamma_approx_def 
             field_simps open_halfspace_Re_gt stirling_sum_def)
     also have "\<dots> = - inverse (of_nat m) * (deriv ^^ j) (stirling_integral m) (of_real x)" using x m
       by (intro higher_deriv_cmult[of _ "-\<real>\<^sub>\<le>\<^sub>0"] stirling_integral_holomorphic)
          (auto simp: open_halfspace_Re_gt)
     also have "(deriv ^^ j) (\<lambda>x. ln_Gamma x - Polygamma_approx 0 m x) (complex_of_real x) = 
                  (deriv ^^ j) ln_Gamma (of_real x) - (deriv ^^ j) (Polygamma_approx 0 m) (of_real x)"
       using x 
       by (intro higher_deriv_diff[of _ "{s. Re s > 0}"])
          (auto intro!: holomorphic_intros elim!: nonpos_Reals_cases simp: open_halfspace_Re_gt)
     also have "(deriv ^^ j) (Polygamma_approx 0 m) (complex_of_real x) =
                  of_real (Polygamma_approx j m x)" using x m
       by (simp add: Polygamma_approx_complex_of_real)
     also have "norm (- inverse (of_nat m) * (deriv ^^ j) (stirling_integral m) (complex_of_real x)) = 
                  inverse (real m) * \<bar>(deriv ^^ j) (stirling_integral m) x\<bar>"
       using x m by (simp add: norm_mult norm_inverse deriv_stirling_integral_complex_of_real)
     also have "(deriv ^^ j) ln_Gamma (complex_of_real x) = of_real ((deriv ^^ j) ln_Gamma x)" using x
       by (simp add: higher_deriv_ln_Gamma_complex_of_real)
     also have "norm (\<dots> - of_real (Polygamma_approx j m x)) = 
                  \<bar>(deriv ^^ j) ln_Gamma x - Polygamma_approx j m x\<bar>"
       by (simp only: of_real_diff [symmetric] norm_of_real)
     finally show ?case .
   qed
   from bigthetaI_cong[OF this] m
     have "(\<lambda>x::real. (deriv ^^ j) ln_Gamma x - Polygamma_approx j m x) \<in> 
              \<Theta>(\<lambda>x. (deriv ^^ j) (stirling_integral m) x)" by simp
   also have "(\<lambda>x::real. (deriv ^^ j) (stirling_integral m) x) \<in> O(\<lambda>x. 1 / x ^ (m + j))" using m
       by (rule deriv_stirling_integral_real_bound)
   finally show ?thesis .
 qed
 
 lemma Polygamma_approx_1_real':
   assumes x: "(x::real) > 0" and m: "m > 0"
   shows   "Polygamma_approx 1 m x = ln x - (\<Sum>k = Suc 0..m. bernoulli' k * inverse x ^ k / real k)"
 proof -
   have "Polygamma_approx 1 m x = ln x - (1 / (2 * x) + 
           (\<Sum>k=Suc 0..<m. bernoulli (Suc k) * inverse x ^ Suc k / real (Suc k)))"
     (is "_ = _ - (_ + ?S)") using x by (simp add: Polygamma_approx_1_real stirling_sum_def)
   also have "?S = (\<Sum>k=Suc 0..<m. bernoulli' (Suc k) * inverse x ^ Suc k / real (Suc k))"
     by (intro sum.cong refl) (simp_all add: bernoulli'_def)
   also have "1 / (2 * x) + \<dots> = 
                (\<Sum>k=0..<m. bernoulli' (Suc k) * inverse x ^ Suc k / real (Suc k))" using m
     by (subst (2) sum.atLeast_Suc_lessThan) (simp_all add: field_simps)
   also have "\<dots> = (\<Sum>k = Suc 0..m. bernoulli' k * inverse x ^ k / real k)" using assms
     by (subst sum.shift_bounds_Suc_ivl [symmetric]) (simp add: atLeastLessThanSuc_atLeastAtMost)
   finally show ?thesis .
 qed
 
 theorem
   assumes m: "m > 0"
   shows   ln_Gamma_real_asymptotics:
             "(\<lambda>x. ln_Gamma x - ((x - 1 / 2) * ln x - x + ln (2 * pi) / 2 +
                      (\<Sum>k = 1..<m. bernoulli (Suc k) / (real k * real (Suc k)) / x^k)))
                 \<in> O(\<lambda>x. 1 / x ^ m)" (is ?th1)
     and   Digamma_real_asymptotics:
             "(\<lambda>x. Digamma x - (ln x - (\<Sum>k=1..m. bernoulli' k / real k / x ^ k)))
                 \<in> O(\<lambda>x. 1 / (x ^ Suc m))" (is ?th2)
     and   Polygamma_real_asymptotics: "j > 0 \<Longrightarrow> 
              (\<lambda>x. Polygamma j x - (- 1) ^ Suc j * (\<Sum>k\<le>m. bernoulli' k *
                      pochhammer (real (Suc k)) (j - 1) / x ^ (k + j))) 
                 \<in> O(\<lambda>x. 1 / x ^ (m+j+1))" (is "_ \<Longrightarrow> ?th3")
 proof -
   define G :: "nat \<Rightarrow> real \<Rightarrow> real" where 
     "G = (\<lambda>m. if m = 0 then ln_Gamma else Polygamma (m - 1))"
   have *: "(\<lambda>x. G j x - h x) \<in> O(\<lambda>x. 1 / x ^ (m + j))"
     if "\<And>x::real. x > 0 \<Longrightarrow> Polygamma_approx j m x = h x" for j h
   proof -
     have "(\<lambda>x. G j x - h x) \<in> 
             \<Theta>(\<lambda>x. (deriv ^^ j) ln_Gamma x - Polygamma_approx j m x)" (is "_ \<in> \<Theta>(?f)")
       using that
       by (intro bigthetaI_cong) (auto intro: eventually_mono[OF eventually_gt_at_top[of "0::real"]]
             simp del: funpow.simps simp: higher_deriv_ln_Gamma_real G_def)
     also have "?f \<in> O(\<lambda>x::real. 1 / x ^ (m + j))" using m
       by (rule higher_deriv_lnGamma_stirling)
     finally show ?thesis .
   qed  
     
   note [[simproc del: simplify_landau_sum]]
   from *[OF Polygamma_approx_0] assms show ?th1 
     by (simp add: G_def Polygamma_approx_0 stirling_sum_def field_simps)
   from *[OF Polygamma_approx_1_real'] assms show ?th2 by (simp add: G_def field_simps)
       
   assume j: "j > 0"
   from *[OF Polygamma_approx_ge_2_real, of "j - 1"] assms j show ?th3
     by (simp add: G_def stirling_sum'_def power_add power_diff field_simps)
 qed
 
 
 
 
 subsection \<open>Asymptotics of the complex Gamma function\<close>
 
 text \<open>
   The \<open>m\<close>-th order remainder of Stirling's formula for $\log\Gamma$ is $O(s^{-m})$ uniformly over
   any complex cone $\text{Arg}(z) \leq \alpha$, $z\neq 0$ for any angle
   $\alpha\in(0, \pi)$. This means that there is bounded by $c z^{-m}$ for some constant $c$ for
   all $z$ in this cone.
 \<close>
 context
   fixes F and \<alpha>
   assumes \<alpha>: "\<alpha> \<in> {0<..<pi}"
   defines "F \<equiv> principal (complex_cone' \<alpha> - {0})"
 begin
 
 lemma stirling_integral_bigo:
   fixes m :: nat
   assumes m: "m > 0"
   shows   "stirling_integral m \<in> O[F](\<lambda>s. 1 / s ^ m)"
 proof -
   obtain c where c: "\<And>s. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow> norm (stirling_integral m s) \<le> c / norm s ^ m"
     using stirling_integral_bound'[OF \<open>m > 0\<close> \<alpha>] by blast
   have "0 \<le> norm (stirling_integral m 1 :: complex)"
     by simp
   also have "\<dots> \<le> c"
     using c[of 1] \<alpha> by simp
   finally have "c \<ge> 0" .
 
   have "eventually (\<lambda>s. s \<in> complex_cone' \<alpha> - {0}) F"
     unfolding F_def by (auto simp: eventually_principal)
   hence "eventually (\<lambda>s. norm (stirling_integral m s) \<le>
                      c * norm (1 / s ^ m)) F"
     by eventually_elim (use c in \<open>simp add: norm_divide norm_power\<close>)
   thus "stirling_integral m \<in> O[F](\<lambda>s. 1 / s ^ m)"
     by (intro bigoI[of _ c]) auto
 qed
 
 end
 
 text \<open>
   The following is a more explicit statement of this:
 \<close>
 theorem ln_Gamma_complex_asymptotics_explicit:
   fixes m :: nat and \<alpha> :: real
   assumes "m > 0" and "\<alpha> \<in> {0<..<pi}"
   obtains C :: real and R :: "complex \<Rightarrow> complex"
   where "\<forall>s::complex. s \<notin> \<real>\<^sub>\<le>\<^sub>0 \<longrightarrow>
                ln_Gamma s = (s - 1/2) * ln s - s + ln (2 * pi) / 2 +
                             (\<Sum>k=1..<m. bernoulli (k+1) / (k * (k+1) * s ^ k)) - R s"
     and "\<forall>s. s \<noteq> 0 \<and> \<bar>Arg s\<bar> \<le> \<alpha> \<longrightarrow> norm (R s) \<le> C / norm s ^ m"    
 proof -
   obtain c where c: "\<And>s. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow> norm (stirling_integral m s) \<le> c / norm s ^ m"
     using stirling_integral_bound'[OF assms] by blast
   have "0 \<le> norm (stirling_integral m 1 :: complex)"
     by simp
   also have "\<dots> \<le> c"
     using c[of 1] assms by simp
   finally have "c \<ge> 0" .
   define R where "R = (\<lambda>s::complex. stirling_integral m s / of_nat m)"
   show ?thesis
   proof (rule that)
     from ln_Gamma_stirling_complex[of _ m] assms show
            "\<forall>s::complex. s \<notin> \<real>\<^sub>\<le>\<^sub>0 \<longrightarrow>
                ln_Gamma s = (s - 1 / 2) * ln s - s + ln (2 * pi) / 2 +
                (\<Sum>k=1..<m. bernoulli (k+1) / (k * (k+1) * s ^ k)) - R s"
       by (auto simp add: R_def algebra_simps)
     show "\<forall>s. s \<noteq> 0 \<and> \<bar>Arg s\<bar> \<le> \<alpha> \<longrightarrow> cmod (R s) \<le> c / real m / cmod s ^ m"
     proof (safe, goal_cases)
       case (1 s)
       show ?case
         using 1 c[of s] assms
         by (auto simp: complex_cone_altdef abs_le_iff R_def norm_divide field_simps)
     qed
   qed
 qed
 
 
 text \<open>
   Lastly, we can also derive the asymptotics of $\Gamma$ itself:
   \[\Gamma(z) \sim \sqrt{2\pi / z} \left(\frac{z}{e}\right)^z\]
   uniformly for $|z|\to\infty$ within the cone $\text{Arg}(z) \leq \alpha$ for $\alpha\in(0,\pi)$:
 \<close>
 
 context
   fixes F and \<alpha>
   assumes \<alpha>: "\<alpha> \<in> {0<..<pi}"
   defines "F \<equiv> inf at_infinity (principal (complex_cone' \<alpha>))"
 begin
 
 lemma Gamma_complex_asymp_equiv:
   "Gamma \<sim>[F] (\<lambda>s. sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2))"
 proof -
   define I :: "complex \<Rightarrow> complex" where "I = stirling_integral 1"
   have "eventually (\<lambda>s. s \<in> complex_cone' \<alpha>) F"
     by (auto simp: eventually_inf_principal F_def)
   moreover have "eventually (\<lambda>s. s \<noteq> 0) F"
     unfolding F_def eventually_inf_principal
     using eventually_not_equal_at_infinity by eventually_elim auto
   ultimately have "eventually (\<lambda>s. Gamma s =
                      sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2) / exp (I s)) F"
   proof eventually_elim
     case (elim s)
     from elim have s': "s \<notin> \<real>\<^sub>\<le>\<^sub>0"
       using complex_cone_inter_nonpos_Reals[of "-\<alpha>" \<alpha>] \<alpha> by auto
     from elim have [simp]: "s \<noteq> 0" by auto      
     from s' have "Gamma s = exp (ln_Gamma s)"
       unfolding Gamma_complex_altdef using nonpos_Ints_subset_nonpos_Reals by auto
     also from s' have "ln_Gamma s = (s-1/2) * Ln s - s + complex_of_real (ln (2 * pi) / 2) - I s"
       by (subst ln_Gamma_stirling_complex[of _ 1]) (simp_all add: exp_add exp_diff I_def)
     also have "exp \<dots> = exp ((s - 1 / 2) * Ln s) / exp s *
                         exp (complex_of_real (ln (2 * pi) / 2)) / exp (I s)"
       unfolding exp_diff exp_add by (simp add: exp_diff exp_add)
     also have "exp ((s - 1 / 2) * Ln s) = s powr (s - 1 / 2)"
       by (simp add: powr_def)
     also have "exp (complex_of_real (ln (2 * pi) / 2)) = sqrt (2 * pi)"
       by (subst exp_of_real) (auto simp: powr_def simp flip: powr_half_sqrt)
     also have "exp s = exp 1 powr s"
       by (simp add: powr_def)
     also have "s powr (s - 1 / 2) / exp 1 powr s = (s powr s / exp 1 powr s) / s powr (1/2)"
       by (subst powr_diff) auto
     also have *: "Ln (s / exp 1) = Ln s - 1"
       using Ln_divide_of_real[of "exp 1" s] by (simp flip: exp_of_real)
     hence "s powr s / exp 1 powr s = (s / exp 1) powr s"
       unfolding powr_def by (subst *) (auto simp: exp_diff field_simps)
     finally show "Gamma s = sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2) / exp (I s)"
       by (simp add: algebra_simps)
   qed
   hence "Gamma \<sim>[F] (\<lambda>s. sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2) / exp (I s))"
     by (rule asymp_equiv_refl_ev)
   also have "\<dots> \<sim>[F] (\<lambda>s. sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2) / 1)"
   proof (intro asymp_equiv_intros)
     have "F \<le> principal (complex_cone' \<alpha> - {0})"
       unfolding le_principal F_def eventually_inf_principal
       using eventually_not_equal_at_infinity by eventually_elim auto
     moreover have "I \<in> O[principal (complex_cone' \<alpha> - {0})](\<lambda>s. 1 / s)"
       using stirling_integral_bigo[of \<alpha> 1] \<alpha> unfolding F_def by (simp add: I_def)
     ultimately have "I \<in> O[F](\<lambda>s. 1 / s)"
       by (rule landau_o.big.filter_mono)
     also have "(\<lambda>s. 1 / s) \<in> o[F](\<lambda>s. 1)"
     proof (rule landau_o.smallI)
       fix c :: real
       assume c: "c > 0"
       hence "eventually (\<lambda>z::complex. norm z \<ge> 1 / c) at_infinity"
         by (auto simp: eventually_at_infinity)
       moreover have "eventually (\<lambda>z::complex. z \<noteq> 0) at_infinity"
         by (rule eventually_not_equal_at_infinity)
       ultimately show "eventually (\<lambda>z::complex. norm (1 / z) \<le> c * norm (1 :: complex)) F"
         unfolding F_def eventually_inf_principal
         by eventually_elim (use \<open>c > 0\<close> in \<open>auto simp: norm_divide field_simps\<close>)
     qed
     finally have "I \<in> o[F](\<lambda>s. 1)" .
     from smalloD_tendsto[OF this] have [tendsto_intros]: "(I \<longlongrightarrow> 0) F"
       by simp
     show "(\<lambda>x. exp (I x)) \<sim>[F] (\<lambda>x. 1)"
       by (rule asymp_equivI' tendsto_eq_intros refl | simp)+
   qed
   finally show ?thesis by simp
 qed
 
 end
 
 end
diff --git a/thys/Sturm_Sequences/Lib/Misc_Polynomial.thy b/thys/Sturm_Sequences/Lib/Misc_Polynomial.thy
--- a/thys/Sturm_Sequences/Lib/Misc_Polynomial.thy
+++ b/thys/Sturm_Sequences/Lib/Misc_Polynomial.thy
@@ -1,961 +1,961 @@
 (* Author: Manuel Eberl <eberlm@in.tum.de> *)
 theory Misc_Polynomial
-imports "HOL-Computational_Algebra.Polynomial" "HOL-Computational_Algebra.Polynomial_Factorial"
+imports "HOL-Computational_Algebra.Polynomial" "HOL-Computational_Algebra.Polynomial_Factorial" "Pure-ex.Guess"
 begin
 
 subsection \<open>Analysis\<close>
 
 lemma fun_eq_in_ivl:
   assumes "a \<le> b" "\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> eventually (\<lambda>\<xi>. f \<xi> = f x) (at x)"
   shows "f a = f b"
 proof (rule connected_local_const)
   show "connected {a..b}" "a \<in> {a..b}" "b \<in> {a..b}" using \<open>a \<le> b\<close> by (auto intro: connected_Icc)
   show "\<forall>aa\<in>{a..b}. eventually (\<lambda>b. f aa = f b) (at aa within {a..b})"
   proof
     fix x assume "x \<in> {a..b}"
     with assms(2)[rule_format, of x]
     show "eventually (\<lambda>b. f x = f b) (at x within {a..b})"
       by (auto simp: eventually_at_filter elim: eventually_mono)
   qed
 qed
 
 subsection \<open>Polynomials\<close>
 
 subsubsection \<open>General simplification lemmas\<close>
 
 lemma pderiv_div:
   assumes [simp]: "q dvd p" "q \<noteq> 0"
   shows "pderiv (p div q) = (q * pderiv p - p * pderiv q) div (q * q)"
         "q*q dvd (q * pderiv p - p * pderiv q)"
 proof-
   from assms obtain r where "p = q * r" unfolding dvd_def by blast
   hence "q * pderiv p - p * pderiv q = (q * q) * pderiv r"
       by (simp add: algebra_simps pderiv_mult)
   thus "q*q dvd (q * pderiv p - p * pderiv q)" by simp
   note 0 = pderiv_mult[of q "p div q"]
   have 1: "q * (p div q) = p" 
     by (metis assms(1) assms(2) dvd_def nonzero_mult_div_cancel_left)
   have f1: "pderiv (p div q) * (q * q) div (q * q) = pderiv (p div q)"
     by simp
   have f2: "pderiv p = q * pderiv (p div q) + p div q * pderiv q"
     by (metis 0 1) 
   have "p * pderiv q = pderiv q * (q * (p div q))"
     by (metis 1 mult.commute) 
   then have "p * pderiv q = q * (p div q * pderiv q)"
     by fastforce
   then have "q * pderiv p - p * pderiv q = q * (q * pderiv (p div q))"
     using f2 by (metis add_diff_cancel_right' distrib_left)
   then show "pderiv (p div q) = (q * pderiv p - p * pderiv q) div (q * q)"
     using f1 by (metis mult.commute mult.left_commute)
 qed
 
 
 subsubsection \<open>Divisibility of polynomials\<close>
 
 text \<open>
   Two polynomials that are coprime have no common roots.
 \<close>
 lemma coprime_imp_no_common_roots:
   "\<not> (poly p x = 0 \<and> poly q x = 0)" if "coprime p q"
      for x :: "'a :: field"
 proof clarify
   assume "poly p x = 0" "poly q x = 0"
   then have "[:-x, 1:] dvd p" "[:-x, 1:] dvd q"
     by (simp_all add: poly_eq_0_iff_dvd)
   with that have "is_unit [:-x, 1:]"
     by (rule coprime_common_divisor)
   then show False
     by (auto simp add: is_unit_pCons_iff)
 qed
 
 lemma poly_div:
   assumes "poly q x \<noteq> 0" and "(q::'a :: field poly) dvd p"
   shows "poly (p div q) x = poly p x / poly q x"
 proof-
   from assms have [simp]: "q \<noteq> 0" by force
   have "poly q x * poly (p div q) x = poly (q * (p div q)) x" by simp
   also have "q * (p div q) = p"
       using assms by (simp add: div_mult_swap)
   finally show "poly (p div q) x = poly p x / poly q x"
       using assms by (simp add: field_simps)
 qed
 
 (* TODO: make this less ugly *)
 lemma poly_div_gcd_squarefree_aux:
   assumes "pderiv (p::('a::{field_char_0,field_gcd}) poly) \<noteq> 0"
   defines "d \<equiv> gcd p (pderiv p)"
   shows "coprime (p div d) (pderiv (p div d))" and
         "\<And>x. poly (p div d) x = 0 \<longleftrightarrow> poly p x = 0"
 proof -
   obtain r s where "bezout_coefficients p (pderiv p) = (r, s)"
     by (auto simp add: prod_eq_iff)
   then have "r * p + s * pderiv p = gcd p (pderiv p)"
     by (rule bezout_coefficients)
   then have rs: "d = r * p + s * pderiv p"
     by (simp add: d_def)
   define t where "t = p div d"
   define p' where [simp]: "p' = pderiv p"
   define d' where [simp]: "d' = pderiv d"
   define u where "u = p' div d"
   have A: "p = t * d" and B: "p' = u * d"
     by (simp_all add: t_def u_def d_def algebra_simps)
   from poly_squarefree_decomp[OF assms(1) A B[unfolded p'_def] rs]
     show "\<And>x. poly (p div d) x = 0 \<longleftrightarrow> poly p x = 0" by (auto simp: t_def)
 
   from rs have C: "s*t*d' = d * (1 - r*t - s*pderiv t)"
       by (simp add: A B algebra_simps pderiv_mult)
   from assms have [simp]: "p \<noteq> 0" "d \<noteq> 0" "t \<noteq> 0"
       by (force, force, subst (asm) A, force)
 
   have "\<And>x. \<lbrakk>x dvd t; x dvd (pderiv t)\<rbrakk> \<Longrightarrow> x dvd 1"
   proof -
     fix x assume "x dvd t" "x dvd (pderiv t)"
     then obtain v w where vw:
         "t = x*v" "pderiv t = x*w" unfolding dvd_def by blast
     define x' v' where [simp]: "x' = pderiv x" and [simp]: "v' = pderiv v"
     from vw have "x*v' + v*x' = x*w" by (simp add: pderiv_mult)
     hence "v*x' = x*(w - v')" by (simp add: algebra_simps)
     hence "x dvd v*pderiv x" by simp
     then obtain y where y: "v*x' = x*y" unfolding dvd_def by force
     from \<open>t \<noteq> 0\<close> and vw have "x \<noteq> 0" by simp
 
     have x_pow_n_dvd_d: "\<And>n. x^n dvd d"
     proof-
       fix n show "x ^ n dvd d"
       proof (induction n, simp, rename_tac n, case_tac n)
         fix n assume "n = (0::nat)"
         from vw and C have "d = x*(d*r*v + d*s*w + s*v*d')"
             by (simp add: algebra_simps)
         with \<open>n = 0\<close> show "x^Suc n dvd d" by (force intro: dvdI)
       next
         fix n n' assume IH: "x^n dvd d" and "n = Suc n'"
         hence [simp]: "Suc n' = n" "x * x^n' = x^n" by simp_all
         define c :: "'a poly" where "c = [:of_nat n:]"
         from pderiv_power_Suc[of x n']
             have [simp]: "pderiv (x^n) = c*x^n' * x'" unfolding c_def
             by simp
 
         from IH obtain z where d: "d = x^n * z" unfolding dvd_def by blast
         define z' where [simp]: "z' = pderiv z"
         from d \<open>d \<noteq> 0\<close> have "x^n \<noteq> 0" "z \<noteq> 0" by force+
         from C d have "x^n*z = z*r*v*x^Suc n + z*s*c*x^n*(v*x') +
                           s*v*z'*x^Suc n + s*z*(v*x')*x^n + s*z*v'*x^Suc n"
             by (simp add: algebra_simps vw pderiv_mult)
         also have "... = x^n*x * (z*r*v + z*s*c*y + s*v*z' + s*z*y + s*z*v')"
             by (simp only: y, simp add: algebra_simps)
         finally have "z = x*(z*r*v+z*s*c*y+s*v*z'+s*z*y+s*z*v')"
              using \<open>x^n \<noteq> 0\<close> by force
         hence "x dvd z" by (metis dvd_triv_left)
         with d show "x^Suc n dvd d" by simp
      qed
    qed
 
    have "degree x = 0"
    proof (cases "degree x", simp)
      case (Suc n)
        hence "x \<noteq> 0" by auto
        with Suc have "degree (x ^ (Suc (degree d))) > degree d"
            by (subst degree_power_eq, simp_all)
        moreover from x_pow_n_dvd_d[of "Suc (degree d)"] and \<open>d \<noteq> 0\<close>
            have "degree (x^Suc (degree d)) \<le> degree d"
                 by (simp add: dvd_imp_degree_le)
        ultimately show ?thesis by simp
     qed
     then obtain c where [simp]: "x = [:c:]" by (cases x, simp split: if_split_asm)
     moreover from \<open>x \<noteq> 0\<close> have "c \<noteq> 0" by simp
     ultimately show "x dvd 1" using dvdI[of 1 x "[:inverse c:]"]
       by simp
   qed
 
   then show "coprime t (pderiv t)"
     by (rule coprimeI)
 qed
 
 lemma normalize_field:
   "normalize (x :: 'a :: {field,normalization_semidom}) = (if x = 0 then 0 else 1)"
   by (auto simp: is_unit_normalize dvd_field_iff)
 
 lemma normalize_field_eq_1 [simp]:
   "x \<noteq> 0 \<Longrightarrow> normalize (x :: 'a :: {field,normalization_semidom}) = 1"
   by (simp add: normalize_field)
 
 lemma unit_factor_field [simp]:
   "unit_factor (x :: 'a :: {field,normalization_semidom}) = x"
   by (cases "x = 0") (auto simp: is_unit_unit_factor dvd_field_iff)
 
 text \<open>
   Dividing a polynomial by its gcd with its derivative yields
   a squarefree polynomial with the same roots.
 \<close>
 lemma poly_div_gcd_squarefree:
   assumes "(p :: ('a::{field_char_0,field_gcd}) poly) \<noteq> 0"
   defines "d \<equiv> gcd p (pderiv p)"
   shows "coprime (p div d) (pderiv (p div d))" (is ?A) and
         "\<And>x. poly (p div d) x = 0 \<longleftrightarrow> poly p x = 0" (is "\<And>x. ?B x")
 proof-
   have "?A \<and> (\<forall>x. ?B x)"
   proof (cases "pderiv p = 0")
     case False
       from poly_div_gcd_squarefree_aux[OF this] show ?thesis
           unfolding d_def by auto
   next
     case True
       then obtain c where [simp]: "p = [:c:]" using pderiv_iszero by blast
       from assms(1) have "c \<noteq> 0" by simp
       from True have "d = smult (inverse c) p"
         by (simp add: d_def normalize_poly_def map_poly_pCons field_simps)
       with \<open>p \<noteq> 0\<close> \<open>c \<noteq> 0\<close> have "p div d = [:c:]"
         by (simp add: pCons_one)
       with \<open>c \<noteq> 0\<close> show ?thesis
         by (simp add: normalize_const_poly is_unit_triv)
   qed
   thus ?A and "\<And>x. ?B x" by simp_all
 qed
 
 
 
 subsubsection \<open>Sign changes of a polynomial\<close>
 
 text \<open>
   If a polynomial has different signs at two points, it has a root inbetween.
 \<close>
 lemma poly_different_sign_imp_root:
   assumes "a < b" and "sgn (poly p a) \<noteq> sgn (poly p (b::real))"
   shows "\<exists>x. a \<le> x \<and> x \<le> b \<and> poly p x = 0"
 proof (cases "poly p a = 0 \<or> poly p b = 0")
   case True
     thus ?thesis using assms(1)
         by (elim disjE, rule_tac exI[of _ a], simp,
                         rule_tac exI[of _ b], simp)
 next
   case False
     hence [simp]: "poly p a \<noteq> 0" "poly p b \<noteq> 0" by simp_all
     show ?thesis
     proof (cases "poly p a < 0")
       case True
         hence "sgn (poly p a) = -1" by simp
         with assms True have "poly p b > 0"
             by (auto simp: sgn_real_def split: if_split_asm)
         from poly_IVT_pos[OF \<open>a < b\<close> True this] guess x ..
         thus ?thesis by (intro exI[of _ x], simp)
     next
       case False
         hence "poly p a > 0" by (simp add: not_less less_eq_real_def)
         hence "sgn (poly p a) = 1"  by simp
         with assms False have "poly p b < 0"
             by (auto simp: sgn_real_def not_less
                            less_eq_real_def split: if_split_asm)
         from poly_IVT_neg[OF \<open>a < b\<close> \<open>poly p a > 0\<close> this] guess x ..
         thus ?thesis by (intro exI[of _ x], simp)
     qed
 qed
 
 lemma poly_different_sign_imp_root':
   assumes "sgn (poly p a) \<noteq> sgn (poly p (b::real))"
   shows "\<exists>x. poly p x = 0"
 using assms by (cases "a < b", auto dest!: poly_different_sign_imp_root
                                     simp: less_eq_real_def not_less)
 
 
 lemma no_roots_inbetween_imp_same_sign:
   assumes "a < b" "\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> (0::real)"
   shows "sgn (poly p a) = sgn (poly p b)"
   using poly_different_sign_imp_root assms by auto
 
 
 
 subsubsection \<open>Limits of polynomials\<close>
 
 lemma poly_neighbourhood_without_roots:
   assumes "(p :: real poly) \<noteq> 0"
   shows "eventually (\<lambda>x. poly p x \<noteq> 0) (at x\<^sub>0)"
 proof-
   {
     fix \<epsilon> :: real assume "\<epsilon> > 0"
     have fin: "finite {x. \<bar>x-x\<^sub>0\<bar> < \<epsilon> \<and> x \<noteq> x\<^sub>0 \<and> poly p x = 0}"
         using poly_roots_finite[OF assms] by simp
     with \<open>\<epsilon> > 0\<close>have "\<exists>\<delta>>0. \<delta>\<le>\<epsilon> \<and> (\<forall>x. \<bar>x-x\<^sub>0\<bar> < \<delta> \<and> x \<noteq> x\<^sub>0 \<longrightarrow> poly p x \<noteq> 0)"
     proof (induction "card {x. \<bar>x-x\<^sub>0\<bar> < \<epsilon> \<and> x \<noteq> x\<^sub>0 \<and> poly p x = 0}"
            arbitrary: \<epsilon> rule: less_induct)
     case (less \<epsilon>)
     let ?A = "{x. \<bar>x - x\<^sub>0\<bar> < \<epsilon> \<and> x \<noteq> x\<^sub>0 \<and> poly p x = 0}"
     show ?case
       proof (cases "card ?A")
       case 0
         hence "?A = {}" using less by auto
         thus ?thesis using less(2) by (rule_tac exI[of _ \<epsilon>], auto)
       next
       case (Suc _)
         with less(3) have "{x. \<bar>x - x\<^sub>0\<bar> < \<epsilon> \<and> x \<noteq> x\<^sub>0 \<and> poly p x = 0} \<noteq> {}" by force
         then obtain x where x_props: "\<bar>x - x\<^sub>0\<bar> < \<epsilon>" "x \<noteq> x\<^sub>0" "poly p x = 0" by blast
         define \<epsilon>' where "\<epsilon>' = \<bar>x - x\<^sub>0\<bar> / 2"
         have "\<epsilon>' > 0" "\<epsilon>' < \<epsilon>" unfolding \<epsilon>'_def using x_props by simp_all
         from x_props(1,2) and \<open>\<epsilon> > 0\<close>
             have "x \<notin> {x'. \<bar>x' - x\<^sub>0\<bar> < \<epsilon>' \<and> x' \<noteq> x\<^sub>0 \<and> poly p x' = 0}" (is "_ \<notin> ?B")
             by (auto simp: \<epsilon>'_def)
         moreover from x_props
             have "x \<in> {x. \<bar>x - x\<^sub>0\<bar> < \<epsilon> \<and> x \<noteq> x\<^sub>0 \<and> poly p x = 0}" by blast
         ultimately have "?B \<subset> ?A" by auto
         hence "card ?B < card ?A" "finite ?B"
             by (rule psubset_card_mono[OF less(3)],
                 blast intro: finite_subset[OF _ less(3)])
         from less(1)[OF this(1) \<open>\<epsilon>' > 0\<close> this(2)]
             show ?thesis using \<open>\<epsilon>' < \<epsilon>\<close> by force
       qed
     qed
   }
   from this[of "1"]
     show ?thesis by (auto simp: eventually_at dist_real_def)
 qed
 
 
 lemma poly_neighbourhood_same_sign:
   assumes "poly p (x\<^sub>0 :: real) \<noteq> 0"
   shows "eventually (\<lambda>x. sgn (poly p x) = sgn (poly p x\<^sub>0)) (at x\<^sub>0)"
 proof -
   have cont: "isCont (\<lambda>x. sgn (poly p x)) x\<^sub>0"
       by (rule isCont_sgn, rule poly_isCont, rule assms)
   then have "eventually (\<lambda>x. \<bar>sgn (poly p x) - sgn (poly p x\<^sub>0)\<bar> < 1) (at x\<^sub>0)"
       by (auto simp: isCont_def tendsto_iff dist_real_def)
   then show ?thesis
     by (rule eventually_mono) (simp add: sgn_real_def split: if_split_asm)
 qed
 
 lemma poly_lhopital:
   assumes "poly p (x::real) = 0" "poly q x = 0" "q \<noteq> 0"
   assumes "(\<lambda>x. poly (pderiv p) x / poly (pderiv q) x) \<midarrow>x\<rightarrow> y"
   shows "(\<lambda>x. poly p x / poly q x) \<midarrow>x\<rightarrow> y"
 using assms
 proof (rule_tac lhopital)
   have "isCont (poly p) x" "isCont (poly q) x" by simp_all
   with assms(1,2) show "poly p \<midarrow>x\<rightarrow> 0" "poly q \<midarrow>x\<rightarrow> 0"
        by (simp_all add: isCont_def)
   from \<open>q \<noteq> 0\<close> and \<open>poly q x = 0\<close> have "pderiv q \<noteq> 0"
       by (auto dest: pderiv_iszero)
   from poly_neighbourhood_without_roots[OF this]
       show "eventually (\<lambda>x. poly (pderiv q) x \<noteq> 0) (at x)" .
 qed (auto intro: poly_DERIV poly_neighbourhood_without_roots)
 
 
 lemma poly_roots_bounds:
   assumes "p \<noteq> 0"
   obtains l u
   where "l \<le> (u :: real)"
     and "poly p l \<noteq> 0"
     and "poly p u \<noteq> 0"
     and "{x. x > l \<and> x \<le> u \<and> poly p x = 0 } = {x. poly p x = 0}"
     and "\<And>x. x \<le> l \<Longrightarrow> sgn (poly p x) = sgn (poly p l)"
     and "\<And>x. x \<ge> u \<Longrightarrow> sgn (poly p x) = sgn (poly p u)"
 proof
   from assms have "finite {x. poly p x = 0}" (is "finite ?roots")
       using poly_roots_finite by fast
   let ?roots' = "insert 0 ?roots"
 
   define l where "l = Min ?roots' - 1"
   define u where "u = Max ?roots' + 1"
 
   from \<open>finite ?roots\<close> have A: "finite ?roots'"  by auto
   from Min_le[OF this, of 0] and Max_ge[OF this, of 0]
       show "l \<le>  u" by (simp add: l_def u_def)
   from Min_le[OF A] have l_props: "\<And>x. x\<le>l \<Longrightarrow> poly p x \<noteq> 0"
       by (fastforce simp: l_def)
   from Max_ge[OF A] have u_props: "\<And>x. x\<ge>u \<Longrightarrow> poly p x \<noteq> 0"
       by (fastforce simp: u_def)
   from l_props u_props show [simp]: "poly p l \<noteq> 0" "poly p u \<noteq> 0" by auto
 
   from l_props have "\<And>x. poly p x = 0 \<Longrightarrow> x > l" by (metis not_le)
   moreover from u_props have "\<And>x. poly p x = 0 \<Longrightarrow> x \<le> u" by (metis linear)
   ultimately show "{x. x > l \<and> x \<le> u \<and> poly p x = 0} = ?roots" by auto
 
   {
     fix x assume A: "x < l" "sgn (poly p x) \<noteq> sgn (poly p l)"
     with poly_IVT_pos[OF A(1), of p] poly_IVT_neg[OF A(1), of p] A(2)
         have False by (auto split: if_split_asm
                          simp: sgn_real_def l_props not_less less_eq_real_def)
   }
   thus "\<And>x. x \<le> l \<Longrightarrow> sgn (poly p x) = sgn (poly p l)"
       by (case_tac "x = l", auto simp: less_eq_real_def)
 
   {
     fix x assume A: "x > u" "sgn (poly p x) \<noteq> sgn (poly p u)"
     with u_props poly_IVT_neg[OF A(1), of p] poly_IVT_pos[OF A(1), of p] A(2)
         have False by (auto split: if_split_asm
                          simp: sgn_real_def l_props not_less less_eq_real_def)
   }
   thus "\<And>x. x \<ge> u \<Longrightarrow> sgn (poly p x) = sgn (poly p u)"
       by (case_tac "x = u", auto simp: less_eq_real_def)
 qed
 
 
 
 definition poly_inf :: "('a::real_normed_vector) poly \<Rightarrow> 'a" where
   "poly_inf p \<equiv> sgn (coeff p (degree p))"
 definition poly_neg_inf :: "('a::real_normed_vector) poly \<Rightarrow> 'a" where
   "poly_neg_inf p \<equiv> if even (degree p) then sgn (coeff p (degree p))
                                        else -sgn (coeff p (degree p))"
 lemma poly_inf_0_iff[simp]:
     "poly_inf p = 0 \<longleftrightarrow> p = 0" "poly_neg_inf p = 0 \<longleftrightarrow> p = 0"
     by (auto simp: poly_inf_def poly_neg_inf_def sgn_zero_iff)
 
 lemma poly_inf_mult[simp]:
   fixes p :: "('a::real_normed_field) poly"
   shows "poly_inf (p*q) = poly_inf p * poly_inf q"
         "poly_neg_inf (p*q) = poly_neg_inf p * poly_neg_inf q"
 unfolding poly_inf_def poly_neg_inf_def
 by ((cases "p = 0 \<or> q = 0",auto simp: sgn_zero_iff
          degree_mult_eq[of p q] coeff_mult_degree_sum Real_Vector_Spaces.sgn_mult)[])+
 
 
 lemma poly_neq_0_at_infinity:
   assumes "(p :: real poly) \<noteq> 0"
   shows "eventually (\<lambda>x. poly p x \<noteq> 0) at_infinity"
 proof-
   from poly_roots_bounds[OF assms] guess l u .
   note lu_props = this
   define b where "b = max (-l) u"
   show ?thesis
   proof (subst eventually_at_infinity, rule exI[of _ b], clarsimp)
     fix x assume A: "\<bar>x\<bar> \<ge> b" and B: "poly p x = 0"
     show False
     proof (cases "x \<ge> 0")
       case True
         with A have "x \<ge> u" unfolding b_def by simp
         with lu_props(3, 6) show False by (metis sgn_zero_iff B)
     next
       case False
         with A have "x \<le> l" unfolding b_def by simp
         with lu_props(2, 5) show False by (metis sgn_zero_iff B)
     qed
   qed
 qed
 
 
 
 
 lemma poly_limit_aux:
   fixes p :: "real poly"
   defines "n \<equiv> degree p"
   shows "((\<lambda>x. poly p x / x ^ n) \<longlongrightarrow> coeff p n) at_infinity"
 proof (subst filterlim_cong, rule refl, rule refl)
   show "eventually (\<lambda>x. poly p x / x^n = (\<Sum>i\<le>n. coeff p i / x^(n-i)))
             at_infinity"
   proof (rule eventually_mono)
     show "eventually (\<lambda>x::real. x \<noteq> 0) at_infinity"
         by (simp add: eventually_at_infinity, rule exI[of _ 1], auto)
     fix x :: real assume [simp]: "x \<noteq> 0"
     show "poly p x / x ^ n = (\<Sum>i\<le>n. coeff p i / x ^ (n - i))"
         by (simp add: n_def sum_divide_distrib power_diff poly_altdef)
   qed
 
   let ?a = "\<lambda>i. if i = n then coeff p n else 0"
   have "\<forall>i\<in>{..n}. ((\<lambda>x. coeff p i / x ^ (n - i)) \<longlongrightarrow> ?a i) at_infinity"
   proof
     fix i assume "i \<in> {..n}"
     hence "i \<le> n" by simp
     show "((\<lambda>x. coeff p i / x ^ (n - i)) \<longlongrightarrow> ?a i) at_infinity"
     proof (cases "i = n")
       case True
         thus ?thesis by (intro tendstoI, subst eventually_at_infinity,
                          intro exI[of _ 1], simp add: dist_real_def)
     next
       case False
         hence "n - i > 0" using \<open>i \<le> n\<close> by simp
         from tendsto_inverse_0 and divide_real_def[of 1]
             have "((\<lambda>x. 1 / x :: real) \<longlongrightarrow> 0) at_infinity" by simp
         from tendsto_power[OF this, of "n - i"]
             have "((\<lambda>x::real. 1 / x ^ (n - i)) \<longlongrightarrow> 0) at_infinity"
                 using \<open>n - i > 0\<close> by (simp add: power_0_left power_one_over)
         from tendsto_mult_right_zero[OF this, of "coeff p i"]
             have "((\<lambda>x. coeff p i / x ^ (n - i)) \<longlongrightarrow> 0) at_infinity"
                 by (simp add: field_simps)
         thus ?thesis using False by simp
     qed
   qed
   hence "((\<lambda>x. \<Sum>i\<le>n. coeff p i / x^(n-i)) \<longlongrightarrow> (\<Sum>i\<le>n. ?a i)) at_infinity"
     by (force intro!: tendsto_sum)
   also have "(\<Sum>i\<le>n. ?a i) = coeff p n" by (subst sum.delta, simp_all)
   finally show "((\<lambda>x. \<Sum>i\<le>n. coeff p i / x^(n-i)) \<longlongrightarrow> coeff p n) at_infinity" .
 qed
 
 
 
 lemma poly_at_top_at_top:
   fixes p :: "real poly"
   assumes "degree p \<ge> 1" "coeff p (degree p) > 0"
   shows "LIM x at_top. poly p x :> at_top"
 proof-
   let ?n = "degree p"
   define f g where "f x = poly p x / x^?n" and "g x = x ^ ?n" for x :: real
 
   from poly_limit_aux have "(f \<longlongrightarrow> coeff p (degree p)) at_top"
       using tendsto_mono at_top_le_at_infinity unfolding f_def by blast
   moreover from assms
       have "LIM x at_top. g x :> at_top"
         by (auto simp add: g_def intro!: filterlim_pow_at_top filterlim_ident)
   ultimately have "LIM x at_top. f x * g x :> at_top"
       using filterlim_tendsto_pos_mult_at_top assms by simp
   also have "eventually (\<lambda>x. f x * g x = poly p x) at_top"
       unfolding f_def g_def
       by (subst eventually_at_top_linorder, rule exI[of _ 1],
           simp add: poly_altdef field_simps sum_distrib_left power_diff)
   note filterlim_cong[OF refl refl this]
   finally show ?thesis .
 qed
 
 lemma poly_at_bot_at_top:
   fixes p :: "real poly"
   assumes "degree p \<ge> 1" "coeff p (degree p) < 0"
   shows "LIM x at_top. poly p x :> at_bot"
 proof-
   from poly_at_top_at_top[of "-p"] and assms
       have "LIM x at_top. -poly p x :> at_top" by simp
   thus ?thesis by (simp add: filterlim_uminus_at_bot)
 qed
 
 lemma poly_lim_inf:
   "eventually (\<lambda>x::real. sgn (poly p x) = poly_inf p) at_top"
 proof (cases "degree p \<ge> 1")
   case False
     hence "degree p = 0" by simp
     then obtain c where "p = [:c:]" by (cases p, auto split: if_split_asm)
     thus ?thesis
         by (simp add: eventually_at_top_linorder poly_inf_def)
 next
   case True
     note deg = this
     let ?lc = "coeff p (degree p)"
     from True have "?lc \<noteq> 0" by force
     show ?thesis
     proof (cases "?lc > 0")
       case True
         from poly_at_top_at_top[OF deg this]
           obtain x\<^sub>0 where "\<And>x. x \<ge> x\<^sub>0 \<Longrightarrow> poly p x \<ge> 1"
               by (fastforce simp: filterlim_at_top
                       eventually_at_top_linorder less_eq_real_def)
         hence "\<And>x. x \<ge> x\<^sub>0 \<Longrightarrow> sgn (poly p x) = 1" by force
         thus ?thesis by (simp only: eventually_at_top_linorder poly_inf_def,
                              intro exI[of _ x\<^sub>0], simp add: True)
     next
       case False
         hence "?lc < 0" using \<open>?lc \<noteq> 0\<close> by linarith
         from poly_at_bot_at_top[OF deg this]
           obtain x\<^sub>0 where "\<And>x. x \<ge> x\<^sub>0 \<Longrightarrow> poly p x \<le> -1"
               by (fastforce simp: filterlim_at_bot
                       eventually_at_top_linorder less_eq_real_def)
         hence "\<And>x. x \<ge> x\<^sub>0 \<Longrightarrow> sgn (poly p x) = -1" by force
         thus ?thesis by (simp only: eventually_at_top_linorder poly_inf_def,
                              intro exI[of _ x\<^sub>0], simp add: \<open>?lc < 0\<close>)
     qed
 qed
 
 lemma poly_at_top_or_bot_at_bot:
   fixes p :: "real poly"
   assumes "degree p \<ge> 1" "coeff p (degree p) > 0"
   shows "LIM x at_bot. poly p x :> (if even (degree p) then at_top else at_bot)"
 proof-
   let ?n = "degree p"
   define f g where "f x = poly p x / x ^ ?n" and "g x = x ^ ?n" for x :: real
 
   from poly_limit_aux have "(f \<longlongrightarrow> coeff p (degree p)) at_bot"
       using tendsto_mono at_bot_le_at_infinity by (force simp: f_def [abs_def])
   moreover from assms
       have "LIM x at_bot. g x :> (if even (degree p) then at_top else at_bot)"
         by (auto simp add: g_def split: if_split_asm intro: filterlim_pow_at_bot_even filterlim_pow_at_bot_odd filterlim_ident)
   ultimately have "LIM x at_bot. f x * g x :>
                       (if even ?n then at_top else at_bot)"
       by (auto simp: assms intro: filterlim_tendsto_pos_mult_at_top
                                   filterlim_tendsto_pos_mult_at_bot)
   also have "eventually (\<lambda>x. f x * g x = poly p x) at_bot"
       unfolding f_def g_def
       by (subst eventually_at_bot_linorder, rule exI[of _ "-1"],
           simp add: poly_altdef field_simps sum_distrib_left power_diff)
   note filterlim_cong[OF refl refl this]
   finally show ?thesis .
 qed
 
 
 lemma poly_at_bot_or_top_at_bot:
   fixes p :: "real poly"
   assumes "degree p \<ge> 1" "coeff p (degree p) < 0"
   shows "LIM x at_bot. poly p x :> (if even (degree p) then at_bot else at_top)"
 proof-
   from poly_at_top_or_bot_at_bot[of "-p"] and assms
       have "LIM x at_bot. -poly p x :>
                 (if even (degree p) then at_top else at_bot)" by simp
   thus ?thesis by (auto simp: filterlim_uminus_at_bot)
 qed
 
 lemma poly_lim_neg_inf:
   "eventually (\<lambda>x::real. sgn (poly p x) = poly_neg_inf p) at_bot"
 proof (cases "degree p \<ge> 1")
   case False
     hence "degree p = 0" by simp
     then obtain c where "p = [:c:]" by (cases p, auto split: if_split_asm)
     thus ?thesis
         by (simp add: eventually_at_bot_linorder poly_neg_inf_def)
 next
   case True
     note deg = this
     let ?lc = "coeff p (degree p)"
     from True have "?lc \<noteq> 0" by force
     show ?thesis
     proof (cases "?lc > 0")
       case True
         note lc_pos = this
         show ?thesis
         proof (cases "even (degree p)")
           case True
             from poly_at_top_or_bot_at_bot[OF deg lc_pos] and True
               obtain x\<^sub>0 where "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> poly p x \<ge> 1"
                 by (fastforce simp add: filterlim_at_top filterlim_at_bot
                         eventually_at_bot_linorder less_eq_real_def)
                 hence "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> sgn (poly p x) = 1" by force
               thus ?thesis
                 by (simp add: True eventually_at_bot_linorder poly_neg_inf_def,
                     intro exI[of _ x\<^sub>0], simp add: lc_pos)
        next
           case False
             from poly_at_top_or_bot_at_bot[OF deg lc_pos] and False
               obtain x\<^sub>0 where "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> poly p x \<le> -1"
                 by (fastforce simp add: filterlim_at_bot
                         eventually_at_bot_linorder less_eq_real_def)
                 hence "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> sgn (poly p x) = -1" by force
               thus ?thesis
                 by (simp add: False eventually_at_bot_linorder poly_neg_inf_def,
                               intro exI[of _ x\<^sub>0], simp add: lc_pos)
       qed
     next
       case False
         hence lc_neg: "?lc < 0" using \<open>?lc \<noteq> 0\<close> by linarith
         show ?thesis
         proof (cases "even (degree p)")
           case True
             with poly_at_bot_or_top_at_bot[OF deg lc_neg]
               obtain x\<^sub>0 where "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> poly p x \<le> -1"
                   by (fastforce simp: filterlim_at_bot
                           eventually_at_bot_linorder less_eq_real_def)
               hence "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> sgn (poly p x) = -1" by force
               thus ?thesis
                 by (simp only: True eventually_at_bot_linorder poly_neg_inf_def,
                                intro exI[of _ x\<^sub>0], simp add: lc_neg)
         next
           case False
             with poly_at_bot_or_top_at_bot[OF deg lc_neg]
               obtain x\<^sub>0 where "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> poly p x \<ge> 1"
                   by (fastforce simp: filterlim_at_top
                           eventually_at_bot_linorder less_eq_real_def)
               hence "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> sgn (poly p x) = 1" by force
               thus ?thesis
                 by (simp only: False eventually_at_bot_linorder poly_neg_inf_def,
                                intro exI[of _ x\<^sub>0], simp add: lc_neg)
         qed
     qed
 qed
 
 
 
 
 
 subsubsection \<open>Signs of polynomials for sufficiently large values\<close>
 
 lemma polys_inf_sign_thresholds:
   assumes "finite (ps :: real poly set)"
   obtains l u
   where "l \<le> u"
     and "\<And>p. \<lbrakk>p \<in> ps; p \<noteq> 0\<rbrakk> \<Longrightarrow>
               {x. l < x \<and> x \<le> u \<and> poly p x = 0} = {x. poly p x = 0}"
     and "\<And>p x. \<lbrakk>p \<in> ps; x \<ge> u\<rbrakk> \<Longrightarrow> sgn (poly p x) = poly_inf p"
     and "\<And>p x. \<lbrakk>p \<in> ps; x \<le> l\<rbrakk> \<Longrightarrow> sgn (poly p x) = poly_neg_inf p"
 proof goal_cases
   case prems: 1
   have "\<exists>l u. l \<le> u \<and> (\<forall>p x. p \<in> ps \<and> x \<ge> u \<longrightarrow> sgn (poly p x) = poly_inf p) \<and>
               (\<forall>p x. p \<in> ps \<and> x \<le> l \<longrightarrow> sgn (poly p x) = poly_neg_inf p)"
       (is "\<exists>l u. ?P ps l u")
   proof (induction rule: finite_subset_induct[OF assms(1), where A = UNIV])
     case 1
       show ?case by simp
   next
     case 2
       show ?case by (intro exI[of _ 42], simp)
   next
     case prems: (3 p ps)
       from prems(4) obtain l u where lu_props: "?P ps l u" by blast
       from poly_lim_inf obtain u'
           where u'_props: "\<forall>x\<ge>u'. sgn (poly p x) = poly_inf p"
           by (force simp add: eventually_at_top_linorder)
       from poly_lim_neg_inf obtain l'
           where l'_props: "\<forall>x\<le>l'. sgn (poly p x) = poly_neg_inf p"
           by (force simp add: eventually_at_bot_linorder)
       show ?case
           by (rule exI[of _ "min l l'"], rule exI[of _ "max u u'"],
               insert lu_props l'_props u'_props, auto)
   qed
   then obtain l u where lu_props: "l \<le> u"
         "\<And>p x. p \<in> ps \<Longrightarrow> u \<le> x \<Longrightarrow> sgn (poly p x) = poly_inf p"
         "\<And>p x. p \<in> ps \<Longrightarrow> x \<le> l \<Longrightarrow> sgn (poly p x) = poly_neg_inf p" by blast
   moreover {
     fix p x assume A: "p \<in> ps" "p \<noteq> 0" "poly p x = 0"
     from A have "l < x" "x < u"
         by (auto simp: not_le[symmetric] dest: lu_props(2,3))
   }
   note A = this
   have "\<And>p. p \<in> ps \<Longrightarrow> p \<noteq> 0 \<Longrightarrow>
                  {x. l < x \<and> x \<le> u \<and> poly p x = 0} = {x. poly p x = 0}"
       by (auto dest: A)
 
   from prems[OF lu_props(1) this lu_props(2,3)] show thesis .
 qed
 
 
 subsubsection \<open>Positivity of polynomials\<close>
 
 lemma poly_pos:
   "(\<forall>x::real. poly p x > 0) \<longleftrightarrow> poly_inf p = 1 \<and> (\<forall>x. poly p x \<noteq> 0)"
 proof (intro iffI conjI)
   assume A: "\<forall>x::real. poly p x > 0"
   have "\<And>x. poly p (x::real) > 0 \<Longrightarrow> poly p x \<noteq> 0" by simp
   with A show "\<forall>x::real. poly p x \<noteq> 0" by simp
 
   from poly_lim_inf obtain x where "sgn (poly p x) = poly_inf p"
       by (auto simp: eventually_at_top_linorder)
   with A show "poly_inf p = 1"
       by (simp add: sgn_real_def split: if_split_asm)
 next
   assume "poly_inf p = 1 \<and> (\<forall>x. poly p x \<noteq> 0)"
   hence A: "poly_inf p = 1" and B: "(\<forall>x. poly p x \<noteq> 0)" by simp_all
   from poly_lim_inf obtain x where C: "sgn (poly p x) = poly_inf p"
       by (auto simp: eventually_at_top_linorder)
   show "\<forall>x. poly p x > 0"
   proof (rule ccontr)
     assume "\<not>(\<forall>x. poly p x > 0)"
     then obtain x' where "poly p x' \<le> 0" by (auto simp: not_less)
     with A and C have "sgn (poly p x') \<noteq> sgn (poly p x)"
         by (auto simp: sgn_real_def split: if_split_asm)
     from poly_different_sign_imp_root'[OF this] and B
         show False by blast
   qed
 qed
 
 lemma poly_pos_greater:
   "(\<forall>x::real. x > a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
     poly_inf p = 1 \<and> (\<forall>x. x > a \<longrightarrow> poly p x \<noteq> 0)"
 proof (intro iffI conjI)
   assume A: "\<forall>x::real. x > a \<longrightarrow> poly p x > 0"
   have "\<And>x. poly p (x::real) > 0 \<Longrightarrow> poly p x \<noteq> 0" by simp
   with A show "\<forall>x::real. x > a \<longrightarrow> poly p x \<noteq> 0" by auto
 
   from poly_lim_inf obtain x\<^sub>0 where
       "\<forall>x\<ge>x\<^sub>0. sgn (poly p x) = poly_inf p"
       by (auto simp: eventually_at_top_linorder)
   hence "poly_inf p = sgn (poly p (max x\<^sub>0 (a + 1)))" by simp
   also from A have "... = 1" by force
   finally show "poly_inf p = 1" .
 next
   assume "poly_inf p = 1 \<and> (\<forall>x. x > a \<longrightarrow> poly p x \<noteq> 0)"
   hence A: "poly_inf p = 1" and
         B: "(\<forall>x. x > a \<longrightarrow> poly p x \<noteq> 0)" by simp_all
   from poly_lim_inf obtain x\<^sub>0 where
       C: "\<forall>x\<ge>x\<^sub>0. sgn (poly p x) = poly_inf p"
       by (auto simp: eventually_at_top_linorder)
   hence "sgn (poly p (max x\<^sub>0 (a+1))) = poly_inf p" by simp
   with A have D: "sgn (poly p (max x\<^sub>0 (a+1))) = 1" by simp
   show "\<forall>x. x > a \<longrightarrow> poly p x > 0"
   proof (rule ccontr)
     assume "\<not>(\<forall>x. x > a \<longrightarrow> poly p x > 0)"
     then obtain x' where "x' > a" "poly p x' \<le> 0" by (auto simp: not_less)
     with A and D have E: "sgn (poly p x') \<noteq> sgn (poly p (max x\<^sub>0(a+1)))"
         by (auto simp: sgn_real_def split: if_split_asm)
     show False
         apply (cases x' "max x\<^sub>0 (a+1)" rule: linorder_cases)
         using B E \<open>x' > a\<close>
             apply (force dest!: poly_different_sign_imp_root[of _ _ p])+
         done
   qed
 qed
 
 lemma poly_pos_geq:
   "(\<forall>x::real. x \<ge> a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
     poly_inf p = 1 \<and> (\<forall>x. x \<ge> a \<longrightarrow> poly p x \<noteq> 0)"
 proof (intro iffI conjI)
   assume A: "\<forall>x::real. x \<ge> a \<longrightarrow> poly p x > 0"
   hence "\<forall>x::real. x > a \<longrightarrow> poly p x > 0" by simp
   also note poly_pos_greater
   finally have "poly_inf p = 1" "(\<forall>x>a. poly p x \<noteq> 0)" by simp_all
   moreover from A have "poly p a > 0" by simp
   ultimately show "poly_inf p = 1" "\<forall>x\<ge>a. poly p x \<noteq> 0"
       by (auto simp: less_eq_real_def)
 next
   assume "poly_inf p = 1 \<and> (\<forall>x. x \<ge> a \<longrightarrow> poly p x \<noteq> 0)"
   hence A: "poly_inf p = 1" and
         B: "poly p a \<noteq> 0" and C: "\<forall>x>a. poly p x \<noteq> 0" by simp_all
   from A and C and poly_pos_greater have "\<forall>x>a. poly p x > 0" by simp
   moreover with B C poly_IVT_pos[of a "a+1" p] have "poly p a > 0" by force
   ultimately show "\<forall>x\<ge>a. poly p x > 0" by (auto simp: less_eq_real_def)
 qed
 
 lemma poly_pos_less:
   "(\<forall>x::real. x < a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
     poly_neg_inf p = 1 \<and> (\<forall>x. x < a \<longrightarrow> poly p x \<noteq> 0)"
 proof (intro iffI conjI)
   assume A: "\<forall>x::real. x < a \<longrightarrow> poly p x > 0"
   have "\<And>x. poly p (x::real) > 0 \<Longrightarrow> poly p x \<noteq> 0" by simp
   with A show "\<forall>x::real. x < a \<longrightarrow> poly p x \<noteq> 0" by auto
 
   from poly_lim_neg_inf obtain x\<^sub>0 where
       "\<forall>x\<le>x\<^sub>0. sgn (poly p x) = poly_neg_inf p"
       by (auto simp: eventually_at_bot_linorder)
   hence "poly_neg_inf p = sgn (poly p (min x\<^sub>0 (a - 1)))" by simp
   also from A have "... = 1" by force
   finally show "poly_neg_inf p = 1" .
 next
   assume "poly_neg_inf p = 1 \<and> (\<forall>x. x < a \<longrightarrow> poly p x \<noteq> 0)"
   hence A: "poly_neg_inf p = 1" and
         B: "(\<forall>x. x < a \<longrightarrow> poly p x \<noteq> 0)" by simp_all
   from poly_lim_neg_inf obtain x\<^sub>0 where
       C: "\<forall>x\<le>x\<^sub>0. sgn (poly p x) = poly_neg_inf p"
       by (auto simp: eventually_at_bot_linorder)
   hence "sgn (poly p (min x\<^sub>0 (a - 1))) = poly_neg_inf p" by simp
   with A have D: "sgn (poly p (min x\<^sub>0 (a - 1))) = 1" by simp
   show "\<forall>x. x < a \<longrightarrow> poly p x > 0"
   proof (rule ccontr)
     assume "\<not>(\<forall>x. x < a \<longrightarrow> poly p x > 0)"
     then obtain x' where "x' < a" "poly p x' \<le> 0" by (auto simp: not_less)
     with A and D have E: "sgn (poly p x') \<noteq> sgn (poly p (min x\<^sub>0 (a - 1)))"
         by (auto simp: sgn_real_def split: if_split_asm)
     show False
         apply (cases x' "min x\<^sub>0 (a - 1)" rule: linorder_cases)
         using B E \<open>x' < a\<close>
             apply (auto dest!: poly_different_sign_imp_root[of _ _ p])+
         done
   qed
 qed
 
 lemma poly_pos_leq:
   "(\<forall>x::real. x \<le> a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
     poly_neg_inf p = 1 \<and> (\<forall>x. x \<le> a \<longrightarrow> poly p x \<noteq> 0)"
 proof (intro iffI conjI)
   assume A: "\<forall>x::real. x \<le> a \<longrightarrow> poly p x > 0"
   hence "\<forall>x::real. x < a \<longrightarrow> poly p x > 0" by simp
   also note poly_pos_less
   finally have "poly_neg_inf p = 1" "(\<forall>x<a. poly p x \<noteq> 0)" by simp_all
   moreover from A have "poly p a > 0" by simp
   ultimately show "poly_neg_inf p = 1" "\<forall>x\<le>a. poly p x \<noteq> 0"
       by (auto simp: less_eq_real_def)
 next
   assume "poly_neg_inf p = 1 \<and> (\<forall>x. x \<le> a \<longrightarrow> poly p x \<noteq> 0)"
   hence A: "poly_neg_inf p = 1" and
         B: "poly p a \<noteq> 0" and C: "\<forall>x<a. poly p x \<noteq> 0" by simp_all
   from A and C and poly_pos_less have "\<forall>x<a. poly p x > 0" by simp
   moreover with B C poly_IVT_neg[of "a - 1" a p] have "poly p a > 0" by force
   ultimately show "\<forall>x\<le>a. poly p x > 0" by (auto simp: less_eq_real_def)
 qed
 
 lemma poly_pos_between_less_less:
   "(\<forall>x::real. a < x \<and> x < b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
     (a \<ge> b \<or> poly p ((a+b)/2) > 0) \<and> (\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x \<noteq> 0)"
 proof (intro iffI conjI)
   assume A: "\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x > 0"
   have "\<And>x. poly p (x::real) > 0 \<Longrightarrow> poly p x \<noteq> 0" by simp
   with A show "\<forall>x::real. a < x \<and> x < b \<longrightarrow> poly p x \<noteq> 0" by auto
   from A show "a \<ge> b \<or> poly p ((a+b)/2) > 0" by (cases "a < b", auto)
 next
   assume "(b \<le> a \<or> 0 < poly p ((a+b)/2)) \<and> (\<forall>x. a<x \<and> x<b \<longrightarrow> poly p x \<noteq> 0)"
   hence A: "b \<le> a \<or> 0 < poly p ((a+b)/2)" and
         B: "\<forall>x. a<x \<and> x<b \<longrightarrow> poly p x \<noteq> 0" by simp_all
   show "\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x > 0"
   proof (cases "a \<ge> b", simp, clarify, rule_tac ccontr,
          simp only: not_le not_less)
     fix x assume "a < b" "a < x" "x < b" "poly p x \<le> 0"
     with B have "poly p x < 0" by (simp add: less_eq_real_def)
     moreover from A and \<open>a < b\<close> have "poly p ((a+b)/2) > 0" by simp
     ultimately have "sgn (poly p x) \<noteq> sgn (poly p ((a+b)/2))" by simp
     thus False using B
        apply (cases x "(a+b)/2" rule: linorder_cases)
        apply (drule poly_different_sign_imp_root[of _ _ p], assumption,
               insert \<open>a < b\<close> \<open>a < x\<close> \<open>x < b\<close> , force) []
        apply simp
        apply (drule poly_different_sign_imp_root[of _ _ p], simp,
               insert \<open>a < b\<close> \<open>a < x\<close> \<open>x < b\<close> , force)
        done
   qed
 qed
 
 lemma poly_pos_between_less_leq:
   "(\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
     (a \<ge> b \<or> poly p b > 0) \<and> (\<forall>x. a < x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0)"
 proof (intro iffI conjI)
   assume A: "\<forall>x. a < x \<and> x \<le> b \<longrightarrow> poly p x > 0"
   have "\<And>x. poly p (x::real) > 0 \<Longrightarrow> poly p x \<noteq> 0" by simp
   with A show "\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0" by auto
   from A show "a \<ge> b \<or> poly p b > 0" by (cases "a < b", auto)
 next
   assume "(b \<le> a \<or> 0 < poly p b) \<and> (\<forall>x. a<x \<and> x\<le>b \<longrightarrow> poly p x \<noteq> 0)"
   hence A: "b \<le> a \<or> 0 < poly p b" and B: "\<forall>x. a<x \<and> x\<le>b \<longrightarrow> poly p x \<noteq> 0"
       by simp_all
   show "\<forall>x. a < x \<and> x \<le> b \<longrightarrow> poly p x > 0"
   proof (cases "a \<ge> b", simp, clarify, rule_tac ccontr,
          simp only: not_le not_less)
     fix x assume "a < b" "a < x" "x \<le> b" "poly p x \<le> 0"
     with B have "poly p x < 0" by (simp add: less_eq_real_def)
     moreover from A and \<open>a < b\<close> have "poly p b > 0" by simp
     ultimately have "x < b" using \<open>x \<le> b\<close> by (auto simp: less_eq_real_def)
     from \<open>poly p x < 0\<close> and \<open>poly p b > 0\<close>
         have "sgn (poly p x) \<noteq> sgn (poly p b)" by simp
     from poly_different_sign_imp_root[OF \<open>x < b\<close> this] and B and \<open>x > a\<close>
         show False by auto
   qed
 qed
 
 lemma poly_pos_between_leq_less:
   "(\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
     (a \<ge> b \<or> poly p a > 0) \<and> (\<forall>x. a \<le> x \<and> x < b \<longrightarrow> poly p x \<noteq> 0)"
 proof (intro iffI conjI)
   assume A: "\<forall>x. a \<le> x \<and> x < b \<longrightarrow> poly p x > 0"
   have "\<And>x. poly p (x::real) > 0 \<Longrightarrow> poly p x \<noteq> 0" by simp
   with A show "\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> poly p x \<noteq> 0" by auto
   from A show "a \<ge> b \<or> poly p a > 0" by (cases "a < b", auto)
 next
   assume "(b \<le> a \<or> 0 < poly p a) \<and> (\<forall>x. a\<le>x \<and> x<b \<longrightarrow> poly p x \<noteq> 0)"
   hence A: "b \<le> a \<or> 0 < poly p a" and B: "\<forall>x. a\<le>x \<and> x<b \<longrightarrow> poly p x \<noteq> 0"
       by simp_all
   show "\<forall>x. a \<le> x \<and> x < b \<longrightarrow> poly p x > 0"
   proof (cases "a \<ge> b", simp, clarify, rule_tac ccontr,
          simp only: not_le not_less)
     fix x assume "a < b" "a \<le> x" "x < b" "poly p x \<le> 0"
     with B have "poly p x < 0" by (simp add: less_eq_real_def)
     moreover from A and \<open>a < b\<close> have "poly p a > 0" by simp
     ultimately have "x > a" using \<open>x \<ge> a\<close> by (auto simp: less_eq_real_def)
     from \<open>poly p x < 0\<close> and \<open>poly p a > 0\<close>
         have "sgn (poly p a) \<noteq> sgn (poly p x)" by simp
     from poly_different_sign_imp_root[OF \<open>x > a\<close> this] and B and \<open>x < b\<close>
         show False by auto
   qed
 qed
 
 lemma poly_pos_between_leq_leq:
   "(\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
     (a > b \<or> poly p a > 0) \<and> (\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0)"
 proof (intro iffI conjI)
   assume A: "\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x > 0"
   have "\<And>x. poly p (x::real) > 0 \<Longrightarrow> poly p x \<noteq> 0" by simp
   with A show "\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0" by auto
   from A show "a > b \<or> poly p a > 0" by (cases "a \<le> b", auto)
 next
   assume "(b < a \<or> 0 < poly p a) \<and> (\<forall>x. a\<le>x \<and> x\<le>b \<longrightarrow> poly p x \<noteq> 0)"
   hence A: "b < a \<or> 0 < poly p a" and B: "\<forall>x. a\<le>x \<and> x\<le>b \<longrightarrow> poly p x \<noteq> 0"
       by simp_all
   show "\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x > 0"
   proof (cases "a > b", simp, clarify, rule_tac ccontr,
          simp only: not_le not_less)
     fix x assume "a \<le> b" "a \<le> x" "x \<le> b" "poly p x \<le> 0"
     with B have "poly p x < 0" by (simp add: less_eq_real_def)
     moreover from A and \<open>a \<le> b\<close> have "poly p a > 0" by simp
     ultimately have "x > a" using \<open>x \<ge> a\<close> by (auto simp: less_eq_real_def)
     from \<open>poly p x < 0\<close> and \<open>poly p a > 0\<close>
         have "sgn (poly p a) \<noteq> sgn (poly p x)" by simp
     from poly_different_sign_imp_root[OF \<open>x > a\<close> this] and B and \<open>x \<le> b\<close>
         show False by auto
   qed
 qed
 
 end
diff --git a/thys/Sturm_Sequences/ROOT b/thys/Sturm_Sequences/ROOT
--- a/thys/Sturm_Sequences/ROOT
+++ b/thys/Sturm_Sequences/ROOT
@@ -1,20 +1,22 @@
 chapter AFP
 
 session Sturm_Sequences (AFP) = "HOL-Computational_Algebra" +
   options [timeout = 600, document_logo = "_",
     document_variants = "document:outline=/proof,/ML:userguide"]
+  sessions
+    "Pure-ex"
   directories
     "Lib"
     "Examples"
   theories
     "Lib/Sturm_Library_Document"
     "Lib/Misc_Polynomial"
   theories [document = false]
     "Lib/Sturm_Library"
   theories
     Sturm_Theorem
     Sturm_Method
     "Examples/Sturm_Ex"
   document_files
     "root.tex"
     "root_userguide.tex"
diff --git a/thys/Treaps/Random_List_Permutation.thy b/thys/Treaps/Random_List_Permutation.thy
--- a/thys/Treaps/Random_List_Permutation.thy
+++ b/thys/Treaps/Random_List_Permutation.thy
@@ -1,474 +1,475 @@
 (*
   File:      Random_List.thy
   Authors:   Manuel Eberl
 
   Some facts about randomly permuted lists and how to obtain them by drawing i.i.d.
   priorities for every element.
 *)
 section \<open>Randomly-permuted lists\<close>
 theory Random_List_Permutation
 imports
   Probability_Misc
   Comparison_Sort_Lower_Bound.Linorder_Relations
 begin
 
 subsection \<open>General facts about linear orderings\<close>
 
 text \<open>
   We define the set of all linear orderings on a given set and show some properties about it.
 \<close>
 definition linorders_on :: "'a set \<Rightarrow> ('a \<times> 'a) set set" where
   "linorders_on A = {R. linorder_on A R}"
   
 lemma linorders_on_empty [simp]: "linorders_on {} = {{}}"
   by (auto simp: linorders_on_def linorder_on_def refl_on_def)
     
 lemma linorders_finite_nonempty:
   assumes "finite A"
   shows   "linorders_on A \<noteq> {}"
 proof -
   from finite_distinct_list[OF assms] obtain xs where "set xs = A" "distinct xs" by blast
   hence "linorder_on A (linorder_of_list xs)" by auto
   thus ?thesis by (auto simp: linorders_on_def)
 qed
 
 text \<open>
   There is an obvious bijection between permutations of a set (i.\,e.\ lists with all elements
   from that set without repetition) and linear orderings on it.
 \<close>
 lemma bij_betw_linorders_on:
   assumes "finite A"
   shows   "bij_betw linorder_of_list (permutations_of_set A) (linorders_on A)"
   using bij_betw_linorder_of_list[of A] assms unfolding linorders_on_def by simp
 
 lemma sorted_wrt_list_of_set_linorder_of_list [simp]:
   assumes "distinct xs"
   shows   "sorted_wrt_list_of_set (linorder_of_list xs) (set xs) = xs"
   by (rule sorted_wrt_list_of_set_eqI[of "set xs"]) (insert assms, auto)
     
 lemma linorder_of_list_sorted_wrt_list_of_set [simp]:
   assumes "linorder_on A R" "finite A"
   shows   "linorder_of_list (sorted_wrt_list_of_set R A) = R"
 proof -
   from assms(1) have subset: "R \<subseteq> A \<times> A" by (auto simp: linorder_on_def refl_on_def)
   from assms and subset show ?thesis
     by (auto simp: linorder_of_list_def linorder_sorted_wrt_list_of_set sorted_wrt_linorder_index_le_iff)
 qed
 
 lemma bij_betw_linorders_on':
   assumes "finite A"
   shows   "bij_betw (\<lambda>R. sorted_wrt_list_of_set R A) (linorders_on A) (permutations_of_set A)"
   by (rule bij_betw_byWitness[where f' = linorder_of_list])
      (insert assms, auto simp: linorders_on_def permutations_of_set_def
         linorder_sorted_wrt_list_of_set)
 
 lemma finite_linorders_on [intro]:
   assumes "finite A"
   shows   "finite (linorders_on A)"
 proof -
   have "finite (permutations_of_set A)" by simp
   also have "?this \<longleftrightarrow> finite (linorders_on A)"
     using assms by (rule bij_betw_finite [OF bij_betw_linorders_on])
   finally show ?thesis .
 qed
 
 
 text \<open>
   Next, we look at the ordering defined by a list that is permuted with some permutation
   function. For this, we first define the composition of a relation with a function.
 \<close>
 definition map_relation :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<times> 'b) set \<Rightarrow> ('a \<times> 'a) set" where
   "map_relation A f R = {(x,y)\<in>A\<times>A. (f x, f y) \<in> R}"
 
 lemma index_distinct_eqI:
   assumes "distinct xs" "i < length xs" "xs ! i = x"
   shows   "index xs x = i"
   using assms by (induction xs arbitrary: i) (auto simp: nth_Cons split: nat.splits)
   
 lemma index_permute_list:
   assumes "\<pi> permutes {..<length xs}" "distinct xs" "x \<in> set xs"
   shows   "index (permute_list \<pi> xs) x = inv \<pi> (index xs x)"
 proof -
   have *: "inv \<pi> permutes {..<length xs}" by (rule permutes_inv) fact
   from assms show ?thesis
     using assms permutes_in_image[OF *]
     by (intro index_distinct_eqI) (simp_all add: permute_list_nth permutes_inverses)
 qed
 
 lemma linorder_of_list_permute:
   assumes "\<pi> permutes {..<length xs}" "distinct xs"
   shows   "linorder_of_list (permute_list \<pi> xs) =
              map_relation (set xs) ((!) xs \<circ> inv \<pi> \<circ> index xs) (linorder_of_list xs)"
 proof -
   note * = permutes_inv[OF assms(1)]
   have less: "inv \<pi> i < length xs" if "i < length xs" for i
     using permutes_in_image[OF *] and that by simp
   from assms and * show ?thesis
     by (auto simp: linorder_of_list_def map_relation_def index_nth_id index_permute_list less)
 qed
 
 
 lemma inj_on_conv_Ex1: "inj_on f A \<longleftrightarrow> (\<forall>y\<in>f`A. \<exists>!x\<in>A. y = f x)"
   by (auto simp: inj_on_def)
 
 lemma bij_betw_conv_Ex1: "bij_betw f A B \<longleftrightarrow> (\<forall>y\<in>B. \<exists>!x\<in>A. f x = y) \<and> B = f ` A"
   unfolding bij_betw_def inj_on_conv_Ex1 by (auto simp: eq_commute)
 
 lemma permutesI:
   assumes "bij_betw f A A" "\<forall>x. x \<notin> A \<longrightarrow> f x = x"
   shows   "f permutes A"
   unfolding permutes_def
 proof (intro conjI allI impI)
   fix y
   from assms have [simp]: "f x \<in> A \<longleftrightarrow> x \<in> A" for x
     by (auto simp: bij_betw_def)
   show "\<exists>!x. f x = y"
   proof (cases "y \<in> A")
     case True
     also from assms have "A = f ` A" by (auto simp: bij_betw_def)
     finally obtain x where "x \<in> A" "y = f x" by auto
     with assms and \<open>y \<in> A\<close> show ?thesis
       by (intro ex1I[of _ x]) (auto simp: bij_betw_def dest: inj_onD)
   qed (insert assms, auto)
 qed (insert assms, auto)
 
 text \<open>
   We now show the important lemma that any two linear orderings on a finite set can be
   mapped onto each other by a permutation.
 \<close>
 lemma linorder_permutation_exists:
   assumes "finite A" "linorder_on A R" "linorder_on A R'"
   obtains \<pi> where "\<pi> permutes A" "R' = map_relation A \<pi> R"
 proof -
   define xs where "xs = sorted_wrt_list_of_set R A"
   define ys where "ys = sorted_wrt_list_of_set R' A"
   have xs_ys: "distinct xs" "distinct ys" "set xs = A" "set ys = A"
     using assms by (simp_all add: linorder_sorted_wrt_list_of_set xs_def ys_def)
       
   from xs_ys have "mset ys = mset xs" by (simp add: set_eq_iff_mset_eq_distinct [symmetric])
-  from mset_eq_permutation[OF this] guess \<pi> . note \<pi> = this
+  then obtain \<pi> where \<pi>: "\<pi> permutes {..<length xs}" "permute_list \<pi> xs = ys"
+    by (rule mset_eq_permutation)
   define \<pi>' where "\<pi>' = (\<lambda>x. if x \<notin> A then x else xs ! inv \<pi> (index xs x))"
   have \<pi>': "\<pi>' permutes A"
   proof (rule permutesI)
     have "bij_betw ((!) xs \<circ> inv \<pi>) {..<length xs} A"
       by (rule bij_betw_trans permutes_imp_bij permutes_inv \<pi> bij_betw_nth)+ (simp_all add: xs_ys)
     hence "bij_betw ((!) xs \<circ> inv \<pi> \<circ> index xs) A A"
       by (rule bij_betw_trans [rotated] bij_betw_index)+
          (insert bij_betw_index[of xs A "length xs"], simp_all add: xs_ys atLeast0LessThan)
     also have "bij_betw ((!) xs \<circ> inv \<pi> \<circ> index xs) A A \<longleftrightarrow> bij_betw \<pi>' A A"
       by (rule bij_betw_cong) (auto simp: \<pi>'_def)
     finally show \<dots> .
   qed (simp_all add: \<pi>'_def)
   
   from assms have "R' = linorder_of_list ys" by (simp add: ys_def)
   also from \<pi> have "ys = permute_list \<pi> xs" by simp
   also have "linorder_of_list (permute_list \<pi> xs) = 
                map_relation A ((!) xs \<circ> inv \<pi> \<circ> index xs) (linorder_of_list xs)"
     using \<pi> by (subst linorder_of_list_permute) (simp_all add: xs_ys)
   also from assms have "linorder_of_list xs = R" by (simp add: xs_def)
   finally have "R' = map_relation A ((!) xs \<circ> inv \<pi> \<circ> index xs) R" .
   also have "\<dots> = map_relation A \<pi>' R" by (auto simp: map_relation_def \<pi>'_def)
   finally show ?thesis using \<pi>' and that[of \<pi>'] by simp
 qed
 
 text \<open>
   We now define the linear ordering defined by some priority function, i.\,e.\ a function
   that injectively associates priorities to every element such that elements with lower priority
   are smaller in the resulting ordering.
 \<close>
 definition linorder_from_keys :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b :: linorder) \<Rightarrow> ('a \<times> 'a) set" where
   "linorder_from_keys A f = {(x,y)\<in>A\<times>A. f x \<le> f y}"
 
 lemma linorder_from_keys_permute:
   assumes "g permutes A"
   shows   "linorder_from_keys A (f \<circ> g) = map_relation A g (linorder_from_keys A f)"
   using permutes_in_image[OF assms] by (auto simp: map_relation_def linorder_from_keys_def)
   
 lemma linorder_on_linorder_from_keys [intro]:
   assumes "inj_on f A"
   shows   "linorder_on A (linorder_from_keys A f)"
   using assms by (auto simp: linorder_on_def refl_on_def antisym_def linorder_from_keys_def
                     trans_def total_on_def dest: inj_onD)
 
 lemma linorder_from_keys_empty [simp]: "linorder_from_keys {} = (\<lambda>_. {})"
   by (simp add: linorder_from_keys_def fun_eq_iff)
     
 
 text \<open>
   We now show another important fact, namely that when we draw $n$ values i.\,i.\,d.\ uniformly
   from a non-trivial real interval, we almost surely get distinct values.
 \<close>
 lemma emeasure_PiM_diagonal:
   fixes a b :: real
   assumes "x \<in> A" "y \<in> A" "x \<noteq> y"
   assumes "a < b" "finite A"
   defines "M \<equiv> uniform_measure lborel {a..b}"
   shows   "emeasure (PiM A (\<lambda>_. M)) {h\<in>A \<rightarrow>\<^sub>E UNIV. h x = h y} = 0"
 proof -
   from assms have M: "prob_space M" unfolding M_def
     by (intro prob_space_uniform_measure) auto
   then interpret product_prob_space "\<lambda>_. M" A
     unfolding product_prob_space_def product_prob_space_axioms_def product_sigma_finite_def
     by (auto simp: prob_space_imp_sigma_finite)
   from M interpret pair_sigma_finite M M by unfold_locales
   have [measurable]: "{h\<in>extensional {x, y}. h x = h y} \<in> sets (Pi\<^sub>M {x, y} (\<lambda>i. lborel))"
   proof -
     have "{h\<in>extensional {x,y}. h x = h y} = {h \<in> space (Pi\<^sub>M {x, y} (\<lambda>i. lborel)). h x = h y}"
       by (auto simp: extensional_def space_PiM)
     also have "... \<in> sets (Pi\<^sub>M {x, y} (\<lambda>i. lborel))"
       by measurable
     finally show ?thesis .
   qed
   have [simp]: "sets (PiM A (\<lambda>_. M)) = sets (PiM A (\<lambda>_. lborel))" for A :: "'a set"
     by (intro sets_PiM_cong refl) (simp_all add: M_def)
   have sets_M_M: "sets (M \<Otimes>\<^sub>M M) = sets (borel \<Otimes>\<^sub>M borel)"
     by (intro sets_pair_measure_cong) (auto simp: M_def)
   have [measurable]: "(\<lambda>(b, a). if b = a then 1 else 0) \<in> borel_measurable (M \<Otimes>\<^sub>M M)"
     unfolding measurable_split_conv
     by (subst measurable_cong_sets[OF sets_M_M refl])
        (auto intro!: measurable_If measurable_const measurable_equality_set)
       
   have "{h\<in>A \<rightarrow>\<^sub>E UNIV. h x = h y} = 
           (\<lambda>h. restrict h {x, y}) -` {h\<in>extensional {x, y}. h x = h y} \<inter> space (PiM A (\<lambda>_. M :: real measure))"
     by (auto simp: space_PiM PiE_def extensional_def M_def)
   also have "emeasure (PiM A (\<lambda>_. M)) \<dots> = 
                emeasure (distr (PiM A (\<lambda>_. M)) (PiM {x,y} (\<lambda>_. lborel :: real measure)) 
                  (\<lambda>h. restrict h {x,y})) {h\<in>extensional {x, y}. h x = h y}"
   proof (rule emeasure_distr [symmetric])
     have "(\<lambda>h. restrict h {x, y}) \<in> Pi\<^sub>M A (\<lambda>_. lborel) \<rightarrow>\<^sub>M Pi\<^sub>M {x, y} (\<lambda>_. lborel)"
       using assms by (intro measurable_restrict_subset) auto
     also have "\<dots> = Pi\<^sub>M A (\<lambda>_. M) \<rightarrow>\<^sub>M Pi\<^sub>M {x, y} (\<lambda>_. lborel)"
       by (intro sets_PiM_cong measurable_cong_sets refl) (simp_all add: M_def)
     finally show "(\<lambda>h. restrict h {x, y}) \<in> \<dots>" .
   next
     show "{h\<in>extensional {x, y}. h x = h y} \<in> sets (Pi\<^sub>M {x, y} (\<lambda>_. lborel))" by simp
   qed
   also have "distr (PiM A (\<lambda>_. M)) (PiM {x,y} (\<lambda>_. lborel :: real measure)) (\<lambda>h. restrict h {x,y}) =
                distr (PiM A (\<lambda>_. M)) (PiM {x,y} (\<lambda>_. M)) (\<lambda>h. restrict h {x,y})"
     by (intro distr_cong refl sets_PiM_cong) (simp_all add: M_def)
   also from assms have "\<dots> = Pi\<^sub>M {x, y} (\<lambda>i. M)" by (intro distr_restrict [symmetric]) auto
   also have "emeasure \<dots> {h\<in>extensional {x, y}. h x = h y} =
     nn_integral \<dots> (\<lambda>h. indicator {h\<in>extensional {x, y}. h x = h y} h)"
     by (intro nn_integral_indicator [symmetric]) simp_all
   also have "\<dots> = nn_integral (Pi\<^sub>M {x, y} (\<lambda>i. M)) (\<lambda>h. if h x = h y then 1 else 0)"
     by (intro nn_integral_cong) (auto simp add: indicator_def space_PiM PiE_def)
   also from \<open>x \<noteq> y\<close> have "\<dots> = (\<integral>\<^sup>+ z. (if fst z = snd z then 1 else 0) \<partial>(M \<Otimes>\<^sub>M M))"
     by (intro product_nn_integral_pair) auto
   also have "\<dots> = (\<integral>\<^sup>+ x. (\<integral>\<^sup>+y. (if x = y then 1 else 0) \<partial>M) \<partial>M)"
     by (subst M.nn_integral_fst [symmetric]) simp_all
   also have "\<dots> = (\<integral>\<^sup>+ x. (\<integral>\<^sup>+y. indicator {x} y \<partial>M) \<partial>M)"
     by (simp add: indicator_def of_bool_def eq_commute)
   also have "\<dots> = (\<integral>\<^sup>+ x. emeasure M {x} \<partial>M)" by (subst nn_integral_indicator) (simp_all add: M_def)
   also have "\<dots> = (\<integral>\<^sup>+ x. 0 \<partial>M)" unfolding M_def
     by (intro nn_integral_cong_AE refl AE_uniform_measureI) auto
   also have "\<dots> = 0" by simp
   finally show ?thesis .
 qed      
 
 lemma measurable_linorder_from_keys_restrict:
   assumes fin: "finite A"
   shows "linorder_from_keys A \<in> Pi\<^sub>M A (\<lambda>_. borel :: real measure) \<rightarrow>\<^sub>M count_space (Pow (A \<times> A))"
   (is "_ : ?M \<rightarrow>\<^sub>M _")
   apply (subst measurable_count_space_eq2)
   apply (auto simp add: fin linorder_from_keys_def)
 proof -
   note fin[simp]
   fix R assume "R \<subseteq> A \<times> A"
   then have "linorder_from_keys A -` {R} \<inter> space ?M =
     {f \<in> space ?M. \<forall>x\<in>A. \<forall>y\<in>A. (x, y) \<in> R \<longleftrightarrow> f x \<le> f y}"
     by (auto simp add: linorder_from_keys_def set_eq_iff)
   also have "\<dots> \<in> sets ?M"
     by measurable
   finally show "linorder_from_keys A -` {R} \<inter> space ?M \<in> sets ?M" .
 qed
 
 lemma measurable_count_space_extend:
   assumes "f \<in> measurable M (count_space A)" "A \<subseteq> B"
   shows   "f \<in> measurable M (count_space B)"
 proof -
   note assms(1)
   also have "count_space A = restrict_space (count_space B) A"
     using assms(2) by (subst restrict_count_space) (simp_all add: Int_absorb2)
   finally show ?thesis by (simp add: measurable_restrict_space2_iff)
 qed
   
 lemma measurable_linorder_from_keys_restrict':
   assumes fin: "finite A" "A \<subseteq> B"
   shows "linorder_from_keys A \<in> Pi\<^sub>M A (\<lambda>_. borel :: real measure) \<rightarrow>\<^sub>M count_space (Pow (B \<times> B))"
   apply (rule measurable_count_space_extend)
    apply (rule measurable_linorder_from_keys_restrict[OF assms(1)])
   using assms by auto
   
 
 context
   fixes a b :: real and A :: "'a set" and M and B
   assumes fin: "finite A" and ab: "a < b" and B: "A \<subseteq> B"
   defines "M \<equiv> distr (PiM A (\<lambda>_. uniform_measure lborel {a..b})) 
                   (count_space (Pow (B \<times> B))) (linorder_from_keys A)"
 begin
 
 lemma measurable_linorder_from_keys [measurable]: 
   "linorder_from_keys A \<in> Pi\<^sub>M A (\<lambda>_. borel :: real measure) \<rightarrow>\<^sub>M count_space (Pow (B \<times> B))"
   by (rule measurable_linorder_from_keys_restrict') (auto simp: fin B)
 
 text \<open>
   The ordering defined by randomly-chosen priorities is almost surely linear:
 \<close>
 theorem almost_everywhere_linorder: "AE R in M. linorder_on A R"
 proof -
   define N where "N = PiM A (\<lambda>_. uniform_measure lborel {a..b})"
   have [simp]: "sets (Pi\<^sub>M A (\<lambda>_. uniform_measure lborel {a..b})) = sets (PiM A (\<lambda>_. lborel))"
     by (intro sets_PiM_cong) simp_all
   let ?M_A = "(Pi\<^sub>M A (\<lambda>_. lborel :: real measure))"
   have meas: "{h \<in> A \<rightarrow>\<^sub>E UNIV. h i = h j} \<in> sets ?M_A"
     if [simp]: "i \<in> A" "j \<in> A" for i j
   proof -
     have "{h \<in> A \<rightarrow>\<^sub>E UNIV. h i = h j} = {h \<in> space ?M_A. h i = h j}"
       by (auto simp: space_PiM)
     also have "... \<in> sets ?M_A"
       by measurable
     finally show ?thesis .
   qed
   define X :: "('a \<Rightarrow> real) set" where "X = (\<Union>x\<in>A. \<Union>y\<in>A-{x}. {h\<in>A \<rightarrow>\<^sub>E UNIV. h x = h y})"
   have "AE f in N. inj_on f A"
   proof (rule AE_I)
     show "{f \<in> space N. \<not> inj_on f A} \<subseteq> X"
       by (auto simp: inj_on_def X_def space_PiM N_def)
   next
     show "X \<in> sets N" unfolding X_def N_def
       using meas by (auto intro!: countable_finite fin sets.countable_UN')
   next
     have "emeasure N X \<le> (\<Sum>i\<in>A. emeasure N (\<Union>y\<in>A - {i}. {h \<in> A \<rightarrow>\<^sub>E UNIV. h i = h y}))"
       unfolding X_def N_def using fin meas
       by (intro emeasure_subadditive_finite) 
          (auto simp: disjoint_family_on_def intro!: sets.countable_UN' countable_finite)
     also have "\<dots> \<le> (\<Sum>i\<in>A. \<Sum>j\<in>A-{i}. emeasure N {h \<in> A \<rightarrow>\<^sub>E UNIV. h i = h j})"
       unfolding N_def using fin meas
       by (intro emeasure_subadditive_finite sum_mono) 
          (auto simp: disjoint_family_on_def intro!: sets.countable_UN' countable_finite)
     also have "\<dots> = (\<Sum>i\<in>A. \<Sum>j\<in>A-{i}. 0)" unfolding N_def using fin ab
       by (intro sum.cong refl emeasure_PiM_diagonal) auto
     also have "\<dots> = 0" by simp
     finally show "emeasure N X = 0" by simp
   qed
   hence "AE f in N. linorder_on A (linorder_from_keys A f)"
     by eventually_elim auto
   thus ?thesis unfolding M_def N_def
     by (subst AE_distr_iff) auto
 qed
 
 text \<open>
   Furthermore, this is equivalent to choosing one of the $|A|!$ linear orderings uniformly
   at random.
 \<close>
 theorem random_linorder_by_prios:
   "M = uniform_measure (count_space (Pow (B \<times> B))) (linorders_on A)"
 proof -
   from linorders_finite_nonempty[OF fin] obtain R where R: "linorder_on A R"
     by (auto simp: linorders_on_def)
   
   have *: "emeasure M {R} \<le> emeasure M {R'}" if "linorder_on A R" "linorder_on A R'" for R R'
   proof -
     define N where "N = PiM A (\<lambda>_. uniform_measure lborel {a..b})"
     from linorder_permutation_exists[OF fin that]
     obtain \<pi> where \<pi>: "\<pi> permutes A" "R' = map_relation A \<pi> R"
       by blast
     have "(\<lambda>f. f \<circ> \<pi>) \<in> Pi\<^sub>M A (\<lambda>_. lborel :: real measure) \<rightarrow>\<^sub>M Pi\<^sub>M A (\<lambda>_. lborel :: real measure)"
       by (auto intro!: measurable_PiM_single' measurable_PiM_component_rev
           simp: comp_def permutes_in_image[OF \<pi>(1)] space_PiM PiE_def extensional_def)
     also have "\<dots> = N \<rightarrow>\<^sub>M Pi\<^sub>M A (\<lambda>_. lborel)"
       unfolding N_def by (intro measurable_cong_sets refl sets_PiM_cong) simp_all
     finally have [measurable]: "(\<lambda>f. f \<circ> \<pi>) \<in> \<dots>" .    
         
     have [simp]: "measurable N X = measurable (PiM A (\<lambda>_. lborel)) X" for X :: "('a \<times> 'a) set measure"
       unfolding N_def by (intro measurable_cong_sets refl sets_PiM_cong) simp_all
     have [simp]: "measurable M X = measurable (count_space (Pow (B \<times> B))) X" for X :: "('a \<times> 'a) set measure"
       unfolding M_def by simp
       
     have M_eq: "M = distr N (count_space (Pow (B \<times> B))) (linorder_from_keys A)"
       by (simp only: M_def N_def)
     also have "N = distr N (PiM A (\<lambda>_. lborel)) (\<lambda>f. f \<circ> \<pi>)"
       unfolding N_def by (rule PiM_uniform_measure_permute [symmetric]) fact+
     also have "distr \<dots> (count_space (Pow (B \<times> B))) (linorder_from_keys A) = 
                  distr N (count_space (Pow (B \<times> B))) (linorder_from_keys A \<circ> (\<lambda>f. f \<circ> \<pi>)) "
       by (intro distr_distr) simp_all
     also have "\<dots> = distr N (count_space (Pow (B \<times> B))) (map_relation A \<pi> \<circ> linorder_from_keys A)"
       by (intro distr_cong refl) (auto simp: linorder_from_keys_permute[OF \<pi>(1)])
     also have "\<dots> = distr M (count_space (Pow (B \<times> B))) (map_relation A \<pi>)"
       unfolding M_eq using B
       by (intro distr_distr [symmetric]) (auto simp: map_relation_def)
     finally have M_eq': "distr M (count_space (Pow (B \<times> B))) (map_relation A \<pi>) = M" ..
 
     from that have subset': "R \<subseteq> B \<times> B" "R' \<subseteq> B \<times> B"
       using B by (auto simp: linorder_on_def refl_on_def)
     hence "emeasure M {R} \<le> emeasure M (map_relation A \<pi> -` {R'} \<inter> space M)"
       using subset' by (intro emeasure_mono) (auto simp: M_def \<pi> )
     also have "\<dots> = emeasure (distr M (count_space (Pow (B \<times> B))) (map_relation A \<pi>)) {R'} "
       by (rule emeasure_distr [symmetric]) (insert subset' B, auto simp: map_relation_def)
     also note M_eq'
     finally show ?thesis .
   qed
   have same_prob: "emeasure M {R'} = emeasure M {R}" if "linorder_on A R'" for R'
     using *[of R R'] and *[of R' R] and R and that by simp
   
   from ab have "prob_space M"
     unfolding M_def
     by (intro prob_space.prob_space_distr prob_space_PiM prob_space_uniform_measure) simp_all
   hence "1 = emeasure M (Pow (B \<times> B))" 
     using prob_space.emeasure_space_1[OF \<open>prob_space M\<close>] by (simp add: M_def)
   also have "(Pow (B \<times> B)) = linorders_on A \<union> ((Pow (B \<times> B))-linorders_on A)"
     using B by (auto simp: linorders_on_def linorder_on_def refl_on_def)
   also have "emeasure M \<dots> = emeasure M (linorders_on A) + emeasure M (Pow (B \<times> B)-linorders_on A)"
     using B by (subst plus_emeasure) (auto simp: M_def linorders_on_def linorder_on_def refl_on_def)
   also have "emeasure M (Pow (B \<times> B)-linorders_on A) = 0" using almost_everywhere_linorder 
     by (subst (asm) AE_iff_measurable) (auto simp: linorders_on_def M_def)
   also from fin have "emeasure M (linorders_on A) = (\<Sum>R'\<in>linorders_on A. emeasure M {R'})"
     using B by (intro emeasure_eq_sum_singleton) 
                (auto simp: M_def  linorders_on_def linorder_on_def refl_on_def)
   also have "\<dots> = (\<Sum>R'\<in>linorders_on A. emeasure M {R})"
     by (rule sum.cong) (simp_all add: linorders_on_def same_prob)
   also from fin have "\<dots> = fact (card A) * emeasure M {R}"
     by (simp add: linorders_on_def card_finite_linorders)
   finally have [simp]: "emeasure M {R} = inverse (fact (card A))"
     by (simp add: inverse_ennreal_unique)
   
   show ?thesis
   proof (rule measure_eqI_countable_AE')
     show "sets M = Pow (Pow (B \<times> B))"
       by (simp add: M_def)
   next
     from \<open>finite A\<close> show "countable (linorders_on A)"
       by (blast intro: countable_finite)
   next
     show "AE R in uniform_measure (count_space (Pow (B \<times> B))) 
             (linorders_on A). R \<in> linorders_on A"
       by (rule AE_uniform_measureI) 
          (insert B, auto simp: linorders_on_def linorder_on_def refl_on_def)
   next
     fix R' assume R': "R' \<in> linorders_on A"
     have subset: "linorders_on A \<subseteq> Pow (B \<times> B)"
       using B by (auto simp: linorders_on_def linorder_on_def refl_on_def)
     have "emeasure (uniform_measure (count_space (Pow (B \<times> B))) 
            (linorders_on A)) {R'} = emeasure (count_space (Pow (B \<times> B))) (linorders_on A \<inter> {R'}) /
                                       emeasure (count_space (Pow (B \<times> B))) (linorders_on A)"
       using R' B by (subst emeasure_uniform_measure) (auto simp: linorders_on_def linorder_on_def refl_on_def)
     also have "\<dots> = 1 / emeasure (count_space (Pow (B \<times> B))) (linorders_on A)"
       using R' B by (subst emeasure_count_space) (auto simp: linorders_on_def linorder_on_def refl_on_def)
     also have "\<dots> = 1 / fact (card A)"
       using fin finite_linorders_on[of A]
       by (subst emeasure_count_space [OF subset])
          (auto simp: divide_ennreal [symmetric] linorders_on_def card_finite_linorders)
     also have "\<dots> = emeasure M {R}"
       by (simp add: field_simps divide_ennreal_def)
     also have "\<dots> = emeasure M {R'}"
       using R' by (intro same_prob [symmetric]) (auto simp: linorders_on_def)
     finally show "emeasure M {R'} = emeasure (uniform_measure (count_space (Pow (B \<times> B))) 
                     (linorders_on A)) {R'}" ..
   next
     show "linorders_on A \<subseteq> Pow (B \<times> B)"
       using B by (auto simp: linorders_on_def linorder_on_def refl_on_def)
   qed (auto simp: M_def linorders_on_def almost_everywhere_linorder)
 qed
 
 end
 end
diff --git a/thys/Twelvefold_Way/Twelvefold_Way_Core.thy b/thys/Twelvefold_Way/Twelvefold_Way_Core.thy
--- a/thys/Twelvefold_Way/Twelvefold_Way_Core.thy
+++ b/thys/Twelvefold_Way/Twelvefold_Way_Core.thy
@@ -1,966 +1,966 @@
 (*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)
 
 section \<open>Main Observations on Operations and Permutations\<close>
 
 theory Twelvefold_Way_Core
 imports Preliminaries
 begin
 
 subsection \<open>Range Multiset\<close>
 
 subsubsection \<open>Existence of a Suitable Finite Function\<close>
 
 lemma obtain_function:
   assumes "finite A"
   assumes "size M = card A"
   shows "\<exists>f. image_mset f (mset_set A) = M"
 using assms
 proof (induct arbitrary: M rule: finite_induct)
   case empty
   from this show ?case by simp
 next
   case (insert x A)
   from insert(1,2,4) have "size M > 0"
     by (simp add: card_gt_0_iff)
   from this obtain y where "y \<in># M"
     using gr0_implies_Suc size_eq_Suc_imp_elem by blast
   from insert(1,2,4) this have "size (M - {#y#}) = card A"
     by (simp add: Diff_insert_absorb card_Diff_singleton_if insertI1 size_Diff_submset)
   from insert.hyps this obtain f' where "image_mset f' (mset_set A) = M - {#y#}" by blast
   from this have "image_mset (f'(x := y)) (mset_set (insert x A)) = M"
     using \<open>finite A\<close> \<open>x \<notin> A\<close> \<open>y \<in># M\<close> by (simp add: image_mset_fun_upd)
   from this show ?case by blast
 qed
 
 lemma obtain_function_on_ext_funcset:
   assumes "finite A"
   assumes "size M = card A"
   shows "\<exists>f \<in> A \<rightarrow>\<^sub>E set_mset M. image_mset f (mset_set A) = M"
 proof -
   obtain f where range_eq_M: "image_mset f (mset_set A) = M"
     using obtain_function \<open>finite A\<close> \<open>size M = card A\<close> by blast
   let ?f = "\<lambda>x. if x \<in> A then f x else undefined"
   have "?f \<in> A \<rightarrow>\<^sub>E set_mset M"
     using range_eq_M \<open>finite A\<close> by auto
   moreover have "image_mset ?f (mset_set A) = M"
     using range_eq_M \<open>finite A\<close> by (auto intro: multiset.map_cong0)
   ultimately show ?thesis by auto
 qed
 
 subsubsection \<open>Existence of Permutation\<close>
 
 lemma image_mset_eq_implies_bij_betw:
   fixes f :: "'a1 \<Rightarrow> 'b" and f' :: "'a2 \<Rightarrow> 'b"
   assumes "finite A" "finite A'"
   assumes mset_eq: "image_mset f (mset_set A) = image_mset f' (mset_set A')"
   obtains bij where "bij_betw bij A A'" and "\<forall>x\<in>A. f x = f' (bij x)"
 proof -
   from \<open>finite A\<close> have [simp]: "finite {a \<in> A. f a = (b::'b)}" for b by auto
   from \<open>finite A'\<close> have [simp]: "finite {a \<in> A'. f' a = (b::'b)}" for b by auto
   have "f ` A = f' ` A'"
   proof -
     have "f ` A = f ` (set_mset (mset_set A))" using \<open>finite A\<close> by simp
     also have "\<dots> = f' ` (set_mset (mset_set A'))"
       by (metis mset_eq multiset.set_map)
     also have "\<dots> = f' ` A'" using \<open>finite A'\<close> by simp
     finally show ?thesis .
   qed
   have "\<forall>b\<in>(f ` A). \<exists>bij. bij_betw bij {a \<in> A. f a = b} {a \<in> A'. f' a = b}"
   proof
     fix b
     from mset_eq have
       "count (image_mset f (mset_set A)) b = count (image_mset f' (mset_set A')) b" by simp
     from this have "card {a \<in> A. f a = b} = card {a \<in> A'. f' a = b}"
       using \<open>finite A\<close> \<open>finite A'\<close>
       by (simp add: count_image_mset_eq_card_vimage)
     from this show "\<exists>bij. bij_betw bij {a \<in> A. f a = b} {a \<in> A'. f' a = b}"
       by (intro finite_same_card_bij) simp_all
   qed
-  hence "\<exists>bij. \<forall>b\<in>f ` A. bij_betw (bij b) {a \<in> A. f a = b} {a \<in> A'. f' a = b}"
-    by (rule bchoice)
-  then guess bij .. note bij = this
+  from bchoice [OF this]
+  obtain bij where bij: "\<forall>b\<in>f ` A. bij_betw (bij b) {a \<in> A. f a = b} {a \<in> A'. f' a = b}"
+    by auto
   define bij' where "bij' = (\<lambda>a. bij (f a) a)"
   have "bij_betw bij' A A'"
   proof -
     have "disjoint_family_on (\<lambda>i. {a \<in> A'. f' a = i}) (f ` A)"
       unfolding disjoint_family_on_def by auto
     moreover have "bij_betw (\<lambda>a. bij (f a) a) {a \<in> A. f a = b} {a \<in> A'. f' a = b}" if b: "b \<in> f ` A" for b
       using bij b by (subst bij_betw_cong[where g="bij b"]) auto
     ultimately have "bij_betw (\<lambda>a. bij (f a) a) (\<Union>b\<in>f ` A. {a \<in> A. f a = b}) (\<Union>b\<in>f ` A. {a \<in> A'. f' a = b})"
       by (rule bij_betw_UNION_disjoint)
     moreover have "(\<Union>b\<in>f ` A. {a \<in> A. f a = b}) = A" by auto
     moreover have "(\<Union>b\<in>f ` A. {a \<in> A'. f' a = b}) = A'" using \<open>f ` A = f' ` A'\<close> by auto
     ultimately show "bij_betw bij' A A'"
       unfolding bij'_def by (subst bij_betw_cong[where g="(\<lambda>a. bij (f a) a)"]) auto
   qed
   moreover from bij have "\<forall>x\<in>A. f x = f' (bij' x)"
     unfolding bij'_def using bij_betwE by fastforce
   ultimately show ?thesis by (rule that)
 qed
 
 lemma image_mset_eq_implies_permutes:
   fixes f :: "'a \<Rightarrow> 'b"
   assumes "finite A"
   assumes mset_eq: "image_mset f (mset_set A) = image_mset f' (mset_set A)"
   obtains p where "p permutes A" and "\<forall>x\<in>A. f x = f' (p x)"
 proof -
   from assms obtain b where "bij_betw b A A" and "\<forall>x\<in>A. f x = f' (b x)"
     using image_mset_eq_implies_bij_betw by blast
   define p where "p = (\<lambda>a. if a \<in> A then b a else a)"
   have "p permutes A"
   proof (rule bij_imp_permutes)
     show "bij_betw p A A"
       unfolding p_def by (simp add: \<open>bij_betw b A A\<close> bij_betw_cong)
   next
     fix x
     assume "x \<notin> A"
     from this show "p x = x"
       unfolding p_def by simp
   qed
   moreover from \<open>\<forall>x\<in>A. f x = f' (b x)\<close> have "\<forall>x\<in>A. f x = f' (p x)"
     unfolding p_def by simp
   ultimately show ?thesis by (rule that)
 qed
 
 subsection \<open>Domain Partition\<close>
 
 subsubsection \<open>Existence of a Suitable Finite Function\<close>
 
 lemma obtain_function_with_partition:
   assumes "finite A" "finite B"
   assumes "partition_on A P"
   assumes "card P \<le> card B"
   shows "\<exists>f \<in> A \<rightarrow>\<^sub>E B. (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = P"
 proof -
   obtain g' where "bij_betw g' P (g' ` P)" and "g' ` P \<subseteq> B"
     by (meson assms card_le_inj finite_elements inj_on_imp_bij_betw)
   define f where "\<And>a. f a = (if a \<in> A then g' (THE X. a \<in> X \<and> X \<in> P) else undefined)"
   have "f \<in> A \<rightarrow>\<^sub>E B"
   unfolding f_def
   using \<open>g' ` P \<subseteq> B\<close> assms(3) partition_on_the_part_mem by fastforce
   moreover have "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = P"
   proof
     show "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} \<subseteq> P"
     proof
       fix X
       assume X:"X \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
       from this obtain b where "b \<in> B" and "X = {x' \<in> A. f x' = b}" by auto
       from this X obtain a where "a \<in> A" and "a \<in> X" and "f a = b" by blast
       have "(THE X. a \<in> X \<and> X \<in> P) \<in> P"
         using \<open>a \<in> A\<close> \<open>partition_on A P\<close> by (simp add: partition_on_the_part_mem)
       from \<open>X = {x' \<in> A. f x' = b}\<close> have X_eq1: "X = {x' \<in> A. g' (THE X. x' \<in> X \<and> X \<in> P) = b}"
         unfolding f_def by auto
       also have "\<dots> = {x' \<in> A. (THE X. x' \<in> X \<and> X \<in> P) = inv_into P g' b}"
       proof -
         {
           fix x'
           assume "x' \<in> A"
           have "(THE X. x' \<in> X \<and> X \<in> P) \<in> P"
             using \<open>partition_on A P\<close> \<open>x' \<in> A\<close> by (simp add: partition_on_the_part_mem)
           from X_eq1 \<open>a \<in> X\<close> have "g' (THE X. a \<in> X \<and> X \<in> P) = b"
             unfolding f_def by auto
           from this \<open>(THE X. a \<in> X \<and> X \<in> P) \<in> P\<close> have "b \<in> g' ` P" by auto
           have "(g' (THE X. x' \<in> X \<and> X \<in> P) = b) \<longleftrightarrow> ((THE X. x' \<in> X \<and> X \<in> P) = inv_into P g' b)"
           proof -
             from \<open>(THE X. x' \<in> X \<and> X \<in> P) \<in> P\<close>
             have "(g' (THE X. x' \<in> X \<and> X \<in> P) = b) \<longleftrightarrow> (inv_into P g' (g' (THE X. x' \<in> X \<and> X \<in> P)) = inv_into P g' b)"
               using \<open>b \<in> g' ` P\<close> by (auto intro: inv_into_injective)
             moreover have "inv_into P g' (g' (THE X. x' \<in> X \<and> X \<in> P)) = (THE X. x' \<in> X \<and> X \<in> P)"
               using \<open>bij_betw g' P (g' ` P)\<close> \<open>(THE X. x' \<in> X \<and> X \<in> P) \<in> P\<close>
               by (simp add: bij_betw_inv_into_left)
             ultimately show ?thesis by simp
           qed
         }
         from this show ?thesis by auto
       qed
       finally have X_eq: "X = {x' \<in> A. (THE X. x' \<in> X \<and> X \<in> P) = inv_into P g' b}" .
       moreover have "inv_into P g' b \<in> P"
       proof -
         from X_eq have eq: "inv_into P g' b = (THE X. a \<in> X \<and> X \<in> P)"
           using \<open>a \<in> X\<close> \<open>a \<in> A\<close> by auto
         from this show ?thesis
           using \<open>(THE X. a \<in> X \<and> X \<in> P) \<in> P\<close> by simp
       qed
       ultimately have "X = inv_into P g' b"
         using partition_on_all_in_part_eq_part[OF \<open>partition_on A P\<close>] by blast
       from this \<open>inv_into P g' b \<in> P\<close> show "X \<in> P" by blast
     qed
   next
     show "P \<subseteq> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
     proof
       fix X
       assume "X \<in> P"
       from assms(3) this have "X \<noteq> {}"
         by (auto elim: partition_onE)
       moreover have "X \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B"
       proof
         show "g' X \<in> B"
           using \<open>X \<in> P\<close> \<open>g' ` P \<subseteq> B\<close> by blast
         show "X = {x \<in> A. f x = g' X}"
         proof
           show "X \<subseteq> {x \<in> A. f x = g' X}"
           proof
             fix x
             assume "x \<in> X"
             from this have "x \<in> A"
               using \<open>X \<in> P\<close> assms(3) by (fastforce elim: partition_onE)
             have "(THE X. x \<in> X \<and> X \<in> P) = X"
               using \<open>X \<in> P\<close> \<open>x \<in> X\<close> assms(3) partition_on_the_part_eq by fastforce
             from this \<open>x \<in> A\<close> have "f x = g' X"
               unfolding f_def by auto
             from this \<open>x \<in> A\<close> show "x \<in> {x \<in> A. f x = g' X}" by auto
           qed
         next
           show "{x \<in> A. f x = g' X} \<subseteq> X"
           proof
             fix x
             assume "x \<in> {x \<in> A. f x = g' X}"
             from this have "x \<in> A" and g_eq: "g' (THE X. x \<in> X \<and> X \<in> P) = g' X"
               unfolding f_def by auto
             from \<open>x \<in> A\<close> have "(THE X. x \<in> X \<and> X \<in> P) \<in> P"
               using assms(3) by (simp add: partition_on_the_part_mem)
             from this g_eq have "(THE X. x \<in> X \<and> X \<in> P) = X"
               using \<open>X \<in> P\<close> \<open>bij_betw g' P (g' ` P)\<close>
               by (metis bij_betw_inv_into_left)
             from this \<open>x \<in> A\<close> assms(3) show "x \<in> X"
               using partition_on_in_the_unique_part by fastforce
           qed
         qed
       qed
       ultimately show "X \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
         by auto
     qed
   qed
   ultimately show ?thesis by blast
 qed
 
 subsubsection \<open>Equality under Permutation Application\<close>
 
 lemma permutes_implies_inv_image_on_eq:
   assumes "p permutes B"
   shows "(\<lambda>b. {x \<in> A. p (f x) = b}) ` B = (\<lambda>b. {x \<in> A. f x = b}) ` B"
 proof -
   have "\<forall>b \<in> B. \<forall>x \<in> A. p (f x) = b \<longleftrightarrow> f x = inv p b"
     using \<open>p permutes B\<close> by (auto simp add: permutes_inverses)
   from this have "(\<lambda>b. {x \<in> A. p (f x) = b}) ` B = (\<lambda>b. {x \<in> A. f x = inv p b}) ` B"
     using image_cong by blast
   also have "\<dots> = (\<lambda>b. {x \<in> A. f x = b}) ` inv p ` B"
     by (auto simp add: image_comp)
   also have "\<dots> = (\<lambda>b. {x \<in> A. f x = b}) ` B"
     by (simp add: \<open>p permutes B\<close> permutes_inv permutes_image)
   finally show ?thesis .
 qed
 
 subsubsection \<open>Existence of Permutation\<close>
 
 lemma the_elem:
   assumes "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
   assumes partitions_eq: "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}"
   assumes "x \<in> A"
   shows "the_elem (f ` {xa \<in> A. f' xa = f' x}) = f x"
 proof -
   from \<open>x \<in> A\<close> have x: "x \<in> {x' \<in> A. f' x' = f' x}" by blast
   have "f' x \<in> B"
     using \<open>x \<in> A\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> by blast
   from this have "{x' \<in> A. f' x' = f' x} \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}"
     using \<open>x \<in> A\<close> by blast
   from this have "{x' \<in> A. f' x' = f' x} \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
     using partitions_eq by blast
   from this obtain b where eq: "{x' \<in> A. f' x' = f' x} = {x' \<in> A. f x' = b}" by blast
   also from x this show "the_elem (f ` {x' \<in> A. f' x' = f' x}) = f x"
     by (metis (mono_tags, lifting) empty_iff mem_Collect_eq the_elem_image_unique)
 qed
 
 lemma the_elem_eq:
   assumes "f \<in> A \<rightarrow>\<^sub>E B"
   assumes "b \<in> f ` A"
   shows "the_elem (f ` {x' \<in> A. f x' = b}) = b"
 proof -
   from \<open>b \<in> f ` A\<close> obtain a where "a \<in> A" and "b = f a" by blast
   from this show "the_elem (f ` {x' \<in> A. f x' = b}) = b"
     using the_elem[OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>] by simp
 qed
 
 lemma partitions_eq_implies:
   assumes "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
   assumes partitions_eq: "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}"
   assumes "x \<in> A" "x' \<in> A"
   assumes "f x = f x'"
   shows "f' x = f' x'"
 proof -
   have "f x \<in> B" and "x \<in> {a \<in> A. f a = f x}" and "x' \<in> {a \<in> A. f a = f x}"
     using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>x \<in> A\<close> \<open>x' \<in> A\<close> \<open>f x = f x'\<close> by auto
   moreover have "{a \<in> A. f a = f x} \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
     using \<open>f x \<in> B\<close> \<open>x \<in> {a \<in> A. f a = f x}\<close> by auto
   ultimately obtain b where "x \<in> {a \<in> A. f' a = b}" and "x' \<in> {a \<in> A. f' a = b}"
     using partitions_eq by (metis (no_types, lifting) Diff_iff imageE)
   from this show "f' x = f' x'" by auto
 qed
 
 lemma card_domain_partitions:
   assumes "f \<in> A \<rightarrow>\<^sub>E B"
   assumes "finite B"
   shows "card ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) = card (f ` A)"
 proof -
   note [simp] = the_elem_eq[OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>]
   have "bij_betw (\<lambda>X. the_elem (f ` X)) ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) (f ` A)"
   proof (rule bij_betw_imageI)
     show "inj_on (\<lambda>X. the_elem (f ` X)) ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})"
     proof (rule inj_onI)
       fix X X'
       assume X: "X \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
       assume X': "X' \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
       assume eq: "the_elem (f ` X) = the_elem (f ` X')"
       from X obtain b where "b \<in> B" and X_eq: "X = {x \<in> A. f x = b}" by blast
       from X this have "b \<in> f ` A"
         using Collect_empty_eq Diff_iff image_iff insertCI by auto
       from X' obtain b' where "b' \<in> B" and X'_eq: "X' = {x \<in> A. f x = b'}" by blast
       from X' this have "b' \<in> f ` A"
         using Collect_empty_eq Diff_iff image_iff insertCI by auto
       from X_eq X'_eq eq \<open>\<And>b. b \<in> f ` A \<Longrightarrow> the_elem (f ` {x' \<in> A. f x' = b}) = b\<close> \<open>b \<in> f ` A\<close> \<open>b' \<in> f ` A\<close>
         have "b = b'" by auto
       from this show "X = X'"
         using X_eq X'_eq by simp
     qed
     show "(\<lambda>X. the_elem (f ` X)) ` ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) = f ` A"
     proof
       show "(\<lambda>X. the_elem (f ` X)) ` ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) \<subseteq> f ` A"
         using \<open>\<And>b. b \<in> f ` A \<Longrightarrow> the_elem (f ` {x' \<in> A. f x' = b}) = b\<close> by auto 
     next
       show "f ` A \<subseteq> (\<lambda>X. the_elem (f ` X)) ` ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})"
       proof
         fix b
         assume "b \<in> f ` A"
         from this have "b = the_elem (f ` {x \<in> A. f x = b})"
           using \<open>\<And>b. b \<in> f ` A \<Longrightarrow> the_elem (f ` {x' \<in> A. f x' = b}) = b\<close> by auto
         moreover from \<open>b \<in> f ` A\<close> have " {x \<in> A. f x = b} \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
           using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> by auto
         ultimately show "b \<in> (\<lambda>X. the_elem (f ` X)) ` ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})" ..
       qed
     qed
   qed
   from this show ?thesis by (rule bij_betw_same_card)
 qed
 
 lemma partitions_eq_implies_permutes:
   assumes "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
   assumes "finite B"
   assumes partitions_eq: "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}"
   shows "\<exists>p. p permutes B \<and> (\<forall>x\<in>A. f x = p (f' x))"
 proof -
   have card_eq: "card (f' ` A) = card (f ` A)"
     using card_domain_partitions[OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>finite B\<close>]
     using card_domain_partitions[OF \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> \<open>finite B\<close>]
     using partitions_eq by simp
   have "f' ` A \<subseteq> B" "f ` A \<subseteq> B"
     using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> by auto
   from this card_eq have "card (B - f' ` A) = card (B - f ` A)"
     using \<open>finite B\<close> by (auto simp add: card_Diff_subset finite_subset)
   from this obtain p' where "bij_betw p' (B - f' ` A) (B - f ` A)"
     using \<open>finite B\<close> by (metis finite_same_card_bij finite_Diff)
   from this have "p' ` (B - f' ` A) = (B - f ` A)"
     by (simp add: bij_betw_imp_surj_on)
   define p where "\<And>b. p b = (if b \<in> B then
     (if b \<in> f' ` A then the_elem (f ` {x \<in> A. f' x = b}) else p' b) else b)"
   have "\<forall>x\<in>A. f x = p (f' x)"
   proof
     fix x
     assume "x \<in> A"
     from this partitions_eq have "the_elem (f ` {xa \<in> A. f' xa = f' x}) = f x"
       using the_elem[OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close>] by auto
     from this show "f x = p (f' x)"
       using \<open>x \<in> A\<close> p_def \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> by auto
   qed
   moreover have "p permutes B"
   proof (rule bij_imp_permutes)
     let ?invp = "\<lambda>b. if b \<in> f ` A then the_elem (f' ` {x \<in> A. f x = b}) else b"
     note [simp] = the_elem[OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> partitions_eq]
     show "bij_betw p B B"
     proof (rule bij_betw_imageI)
       show "p ` B = B"
       proof
         have "(\<lambda>b. the_elem (f ` {x \<in> A. f' x = b})) ` (f' ` A) \<subseteq> B"
           using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> by auto
         from \<open>p' ` (B - f' ` A) = (B - f ` A)\<close> this show "p ` B \<subseteq> B"
           unfolding p_def \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> by force
       next
         show "B \<subseteq> p ` B"
         proof
           fix b
           assume "b \<in> B"
           show "b \<in> p ` B"
           proof (cases "b \<in> f ` A")
             assume "b \<notin> f ` A"
             note \<open>p' ` (B - f' ` A) = (B - f ` A)\<close>
             from this \<open>b \<in> B\<close> \<open>b \<notin> f ` A\<close> show ?thesis
               unfolding p_def by auto
           next
             assume "b \<in> f ` A"
             from this \<open>\<forall>x\<in>A. f x = p (f' x)\<close> \<open>b \<in> B\<close> show ?thesis
               using \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> by auto
           qed
         qed
       qed
     next
       show "inj_on p B"
       proof (rule inj_onI)
         fix b b'
         assume "b \<in> B" "b' \<in> B" "p b = p b'"
         have "b \<in> f' ` A \<longleftrightarrow> b' \<in> f' ` A"
         proof -
           have "b \<in> f' ` A \<longleftrightarrow> p b \<in> f ` A"
             unfolding p_def using \<open>b \<in> B\<close> \<open>p' ` (B - f' ` A) = B - f ` A\<close> by auto
           also have "p b \<in> f ` A \<longleftrightarrow> p b' \<in> f ` A"
             using \<open>p b = p b'\<close> by simp
           also have "p b' \<in> f ` A \<longleftrightarrow> b' \<in> f' ` A"
             unfolding p_def using \<open>b' \<in> B\<close> \<open>p' ` (B - f' ` A) = B - f ` A\<close> by auto
           finally show ?thesis .
         qed
         from this have "(b \<in> f' ` A \<and> b' \<in> f' ` A) \<or> (b \<notin> f' ` A \<and> b' \<notin> f' ` A)" by blast
         from this show "b = b'"
         proof
           assume "b \<in> f' ` A \<and> b' \<in> f' ` A"
           from this obtain a a' where "a \<in> A" "b = f' a" and "a' \<in> A" "b' = f' a'" by auto
           from this \<open>b \<in> B\<close> \<open>b' \<in> B\<close> have "p b = f a" "p b' = f a'"
             unfolding p_def by auto
           from this \<open>p b = p b'\<close> have "f a = f a'" by simp
           from this have "f' a = f' a'"
             using partitions_eq_implies[OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> partitions_eq]
             using \<open>a \<in> A\<close> \<open>a' \<in> A\<close> by blast
           from this show "b = b'"
             using \<open>b' = f' a'\<close> \<open>b = f' a\<close> by simp
         next
           assume "b \<notin> f' ` A \<and> b' \<notin> f' ` A"
           from this \<open>b \<in> B\<close> \<open>b' \<in> B\<close> have "p b' = p' b'" "p b = p' b"
             unfolding p_def by auto
           from this \<open>p b = p b'\<close> have "p' b = p' b'" by simp
           moreover have "b \<in> B - f' ` A" "b' \<in> B - f' ` A"
             using \<open>b \<in> B\<close> \<open>b' \<in> B\<close> \<open>b \<notin> f' ` A \<and> b' \<notin> f' ` A\<close> by auto
           ultimately show "b = b'"
             using \<open>bij_betw p' _ _\<close> by (metis bij_betw_inv_into_left)
         qed
       qed
     qed
   next
     fix x
     assume "x \<notin> B"
     from this show "p x = x"
       using \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> p_def by auto
   qed
   ultimately show ?thesis by blast
 qed
 
 subsection \<open>Number Partition of Range\<close>
 
 subsubsection \<open>Existence of a Suitable Finite Function\<close>
 
 lemma obtain_partition:
   assumes "finite A"
   assumes "number_partition (card A) N"
   shows "\<exists>P. partition_on A P \<and> image_mset card (mset_set P) = N"
 using assms
 proof (induct N arbitrary: A)
   case empty
   from this have "A = {}"
     unfolding number_partition_def by auto
   from this have "partition_on A {}" by (simp add: partition_on_empty)
   moreover have "image_mset card (mset_set {}) = {#}" by simp
   ultimately show ?case by blast
 next
   case (add x N)
   from add.prems(2) have "0 \<notin># add_mset x N" and "sum_mset (add_mset x N) = card A"
     unfolding number_partition_def by auto
   from this have "x \<le> card A" by auto
   from this obtain X where "X \<subseteq> A" and "card X = x"
     using subset_with_given_card_exists by auto
   from this have "X \<noteq> {}"
     using \<open>0 \<notin># add_mset x N\<close> \<open>finite A\<close> by auto
   have "sum_mset N = card (A - X)"
     using \<open>sum_mset (add_mset x N) = card A\<close> \<open>card X = x\<close> \<open>X \<subseteq> A\<close>
     by (metis add.commute add.prems(1) add_diff_cancel_right' card_Diff_subset infinite_super sum_mset.add_mset)
   from this \<open>0 \<notin># add_mset x N\<close> have "number_partition (card (A - X)) N"
     unfolding number_partition_def by auto
   from this obtain P where "partition_on (A - X) P" and eq_N: "image_mset card (mset_set P) = N"
     using add.hyps \<open>finite A\<close> by auto
   from \<open>partition_on (A - X) P\<close> have "finite P"
     using \<open>finite A\<close> finite_elements by blast
   from \<open>partition_on (A - X) P\<close> have "X \<notin> P"
     using \<open>X \<noteq> {}\<close> partition_onD1 by fastforce
   have "partition_on A (insert X P)"
     using \<open>partition_on (A - X) P\<close> \<open>X \<subseteq> A\<close> \<open>X \<noteq> {}\<close>
     by (rule partition_on_insert')
   moreover have "image_mset card (mset_set (insert X P)) = add_mset x N"
     using eq_N \<open>card X = x\<close> \<open>finite P\<close> \<open>X \<notin> P\<close> by simp
   ultimately show ?case by blast
 qed
 
 lemma obtain_extensional_function_from_number_partition:
   assumes "finite A" "finite B"
   assumes "number_partition (card A) N"
   assumes "size N \<le> card B"
   shows "\<exists>f\<in>A \<rightarrow>\<^sub>E B. image_mset (\<lambda>X. card X) (mset_set (((\<lambda>b. {x \<in> A. f x = b})) ` B - {{}})) = N"
 proof -
   obtain P where "partition_on A P" and eq_N: "image_mset card (mset_set P) = N"
     using assms obtain_partition by blast
   from eq_N[symmetric] \<open>size N \<le> card B\<close> have "card P \<le> card B" by simp
   from \<open>partition_on A P\<close> this obtain f where "f \<in> A \<rightarrow>\<^sub>E B"
     and eq_P: "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = P"
     using obtain_function_with_partition[OF \<open>finite A\<close> \<open>finite B\<close>] by blast
   have "image_mset (\<lambda>X. card X) (mset_set (((\<lambda>b. {x \<in> A. f x = b})) ` B - {{}})) = N"
     using eq_P eq_N by simp
   from this \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> show ?thesis by auto
 qed
 
 subsubsection \<open>Equality under Permutation Application\<close>
 
 lemma permutes_implies_multiset_of_partition_cards_eq:
   assumes "p\<^sub>A permutes A" "p\<^sub>B permutes B"
   shows "image_mset card (mset_set ((\<lambda>b. {x \<in> A. p\<^sub>B (f' (p\<^sub>A x)) = b}) ` B - {{}})) = image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}))"
 proof -
   have "inj_on ((`) (inv p\<^sub>A)) ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}})"
     by (meson \<open>p\<^sub>A permutes A\<close> inj_image_eq_iff inj_onI permutes_surj surj_imp_inj_inv)
   have "image_mset card (mset_set ((\<lambda>b. {x \<in> A. p\<^sub>B (f' (p\<^sub>A x)) = b}) ` B - {{}})) =
     image_mset card (mset_set ((\<lambda>X. inv p\<^sub>A ` X) ` ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}})))"
   proof -
     have "(\<lambda>b. {x \<in> A. p\<^sub>B (f' (p\<^sub>A x)) = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' (p\<^sub>A x) = b}) ` B - {{}}"
       using permutes_implies_inv_image_on_eq[OF \<open>p\<^sub>B permutes B\<close>] by metis
     also have "\<dots> = (\<lambda>b. inv p\<^sub>A ` {x \<in> A. f' x = b}) ` B - {{}}"
     proof -
       have "{x \<in> A. f' (p\<^sub>A x) = b} = inv p\<^sub>A ` {x \<in> A. f' x = b}" for b
       proof
         show "{x \<in> A. f' (p\<^sub>A x) = b} \<subseteq> inv p\<^sub>A ` {x \<in> A. f' x = b}"
         proof
           fix x
           assume "x \<in> {x \<in> A. f' (p\<^sub>A x) = b}"
           from this have "x \<in> A" "f' (p\<^sub>A x) = b" by auto
           moreover from this \<open>p\<^sub>A permutes A\<close> have "p\<^sub>A x \<in> A" by (simp add: permutes_in_image)
           moreover from \<open>p\<^sub>A permutes A\<close> have "x = inv p\<^sub>A (p\<^sub>A x)"
             using permutes_inverses(2) by fastforce
           ultimately show "x \<in> inv p\<^sub>A ` {x \<in> A. f' x = b}" by auto
         qed
       next
         show "inv p\<^sub>A ` {x \<in> A. f' x = b} \<subseteq> {x \<in> A. f' (p\<^sub>A x) = b}"
         proof
           fix x
           assume "x \<in> inv p\<^sub>A ` {x \<in> A. f' x = b}"
           from this obtain x' where x: "x = inv p\<^sub>A x'" "x' \<in> A" "f' x' = b" by auto
           from this \<open>p\<^sub>A permutes A\<close> have "x \<in> A" by (simp add: permutes_in_image permutes_inv)
           from \<open>x = inv p\<^sub>A x'\<close> \<open>f' x' = b\<close> have "f' (p\<^sub>A x) = b"
             using \<open>p\<^sub>A permutes A\<close> permutes_inverses(1) by fastforce
           from this \<open>x \<in> A\<close> show "x \<in> {x \<in> A. f' (p\<^sub>A x) = b}" by auto
         qed
       qed
       from this show ?thesis by blast
     qed
     also have "\<dots> = (\<lambda>X. inv p\<^sub>A ` X) ` ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}})" by auto
     finally show ?thesis by simp
   qed
   also have "\<dots> = image_mset (\<lambda>X. card (inv p\<^sub>A ` X)) (mset_set ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}))"
     using \<open>inj_on ((`) (inv p\<^sub>A)) ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}})\<close>
     by (simp only: image_mset_mset_set[symmetric] image_mset.compositionality) (meson comp_apply)
   also have "\<dots> = image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}))"
     using \<open>p\<^sub>A permutes A\<close> by (simp add: card_image inj_on_inv_into permutes_surj)
   finally show ?thesis .
 qed
 
 subsubsection \<open>Existence of Permutation\<close>
 
 lemma partition_implies_permutes:
   assumes "finite A"
   assumes "partition_on A P" "partition_on A P'"
   assumes "image_mset card (mset_set P') = image_mset card (mset_set P)"
   obtains p where "p permutes A" "P' = (\<lambda>X. p ` X) ` P"
 proof -
   from \<open>partition_on A P\<close> \<open>partition_on A P'\<close> have "finite P" "finite P'"
     using \<open>finite A\<close> finite_elements by blast+
   from this \<open>image_mset card (mset_set P') = image_mset card (mset_set P)\<close>
   obtain bij where "bij_betw bij P P'" and "\<forall>X\<in>P. card X = card (bij X)"
     using image_mset_eq_implies_bij_betw by metis
   have "\<forall>X\<in>P. \<exists>p'. bij_betw p' X (bij X)"
   proof
     fix X
     assume "X \<in> P"
     from this have "X \<subseteq> A"
       using \<open>partition_on A P\<close> partition_onD1 by fastforce
     from this have "finite X"
       using \<open>finite A\<close> rev_finite_subset by blast
     from \<open>X \<in> P\<close> have "bij X \<in> P'"
       using \<open>bij_betw bij P P'\<close> bij_betwE by blast
     from this have "bij X \<subseteq> A"
       using \<open>partition_on A P'\<close> partition_onD1 by fastforce
     from this have "finite (bij X)"
       using \<open>finite A\<close> rev_finite_subset by blast
     from \<open>X \<in> P\<close> have "card X = card (bij X)"
       using \<open>\<forall>X\<in>P. card X = card (bij X)\<close> by blast
     from this show "\<exists>p'. bij_betw p' X (bij X)"
       using \<open>finite (bij X)\<close> \<open>finite X\<close> finite_same_card_bij by blast
   qed
   from this have "\<exists>p'. \<forall>X\<in>P. bij_betw (p' X) X (bij X)" by metis
   from this obtain p' where p': "\<forall>X\<in>P. bij_betw (p' X) X (bij X)" ..
   define p where "\<And>a. p a = (if a \<in> A then p' (THE X. a \<in> X \<and> X \<in> P) a else a)"
   have "p permutes A"
   proof -
     have "bij_betw p A A"
     proof -
       have "disjoint_family_on bij P"
       proof
         fix X X'
         assume XX': "X \<in> P" "X' \<in> P" "X \<noteq> X'"
         from this have "bij X \<in> P'" "bij X' \<in> P'"
           using \<open>bij_betw bij P P'\<close> bij_betwE by blast+
         moreover from XX' have "bij X \<noteq> bij X'"
           using \<open>bij_betw bij P P'\<close> by (metis bij_betw_inv_into_left)
         ultimately show "bij X \<inter> bij X' = {}"
           using \<open>partition_on A P'\<close> by (meson partition_onE)
       qed
       moreover have "bij_betw (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) X (bij X)" if "X \<in> P" for X
       proof -
         from \<open>X \<in> P\<close> have "bij_betw (p' X) X (bij X)"
           using \<open>\<forall>X\<in>P. bij_betw (p' X) X (bij X)\<close> by blast
         moreover from \<open>X \<in> P\<close> have "\<forall>a\<in>X. (THE X. a \<in> X \<and> X \<in> P) = X"
           using \<open>partition_on A P\<close> partition_on_the_part_eq by fastforce
         ultimately show ?thesis by (auto intro: bij_betw_congI)
       qed
       ultimately have "bij_betw (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) (\<Union>X\<in>P. X) (\<Union>X\<in>P. bij X)"
         by (rule bij_betw_UNION_disjoint)
       moreover have "(\<Union>X\<in>P. X) = A" "(\<Union>X\<in>P'. X) = A"
         using \<open>partition_on A P\<close> \<open>partition_on A P'\<close> partition_onD1 by auto
       moreover have "(\<Union>X\<in>P. bij X) = (\<Union>X\<in>P'. X)"
         using \<open>bij_betw bij P P'\<close> bij_betw_imp_surj_on by force
       ultimately have "bij_betw (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) A A" by simp
       moreover have "\<forall>a \<in> A. p' (THE X. a \<in> X \<and> X \<in> P) a = p a"
         unfolding p_def by auto
       ultimately show ?thesis by (rule bij_betw_congI)
     qed
     moreover have "p x = x" if "x \<notin> A" for x
       using \<open>x \<notin> A\<close> p_def by auto
     ultimately show ?thesis by (rule bij_imp_permutes)
   qed
   moreover have "P' = (\<lambda>X. p ` X) ` P"
   proof
     show "P' \<subseteq> (\<lambda>X. p ` X) ` P"
     proof
       fix X
       assume "X \<in> P'"
       have in_P: "the_inv_into P bij X \<in> P"
         using \<open>X \<in> P'\<close> \<open>bij_betw bij P P'\<close> bij_betwE bij_betw_the_inv_into by blast
       have eq_X: "bij (the_inv_into P bij X) = X"
         using \<open>X \<in> P'\<close> \<open>bij_betw bij P P'\<close>
         by (meson f_the_inv_into_f_bij_betw)
       have "X = p ` (the_inv_into P bij X)"
       proof
         from in_P have "the_inv_into P bij X \<subseteq> A"
           using \<open>partition_on A P\<close> partition_onD1 by fastforce
         have "(\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` the_inv_into P bij X = X"
         proof
           show "(\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` the_inv_into P bij X \<subseteq> X"
           proof
             fix x
             assume "x \<in> (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` the_inv_into P bij X"
             from this obtain a where a_in: "a \<in> the_inv_into P bij X"
               and x_eq: "x = p' (THE X. a \<in> X \<and> X \<in> P) a" by blast
             have "(THE X. a \<in> X \<and> X \<in> P) = the_inv_into P bij X"
               using a_in in_P \<open>partition_on A P\<close> partition_on_the_part_eq
               by fastforce
             from this x_eq have x_eq: "x = p' (the_inv_into P bij X) a"
               by auto
             from this have "x \<in> bij (the_inv_into P bij X)"
               using a_in in_P bij_betwE p' by blast
             from this eq_X show "x \<in> X" by blast
           qed
         next
           show "X \<subseteq> (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` the_inv_into P bij X"
           proof
             fix x
             assume "x \<in> X"
             let ?X' = "the_inv_into P bij X"
             define x' where "x' = the_inv_into ?X' (p' ?X') x"
             from in_P p' eq_X have bij_betw: "bij_betw (p' ?X') ?X' X" by auto
             from bij_betw \<open>x \<in> X\<close> have "x' \<in> ?X'"
               unfolding x'_def
               using bij_betwE bij_betw_the_inv_into by blast
             from this in_P have "(THE X. x' \<in> X \<and> X \<in> P) = ?X'"
               using \<open>partition_on A P\<close> partition_on_the_part_eq by fastforce
             from this \<open>x \<in> X\<close> have "x = p' (THE X. x' \<in> X \<and> X \<in> P) x'"
               unfolding x'_def
               using bij_betw f_the_inv_into_f_bij_betw by fastforce
             from this \<open>x' \<in> ?X'\<close> show "x \<in> (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` the_inv_into P bij X" ..
           qed
         qed
         from this \<open>the_inv_into P bij X \<subseteq> A\<close> show "X \<subseteq> p ` the_inv_into P bij X"
           unfolding p_def by auto
       next
         show "p ` the_inv_into P bij X \<subseteq> X"
         proof
           fix x
           assume "x \<in> p ` the_inv_into P bij X"
           from this obtain x' where "x = p x'" and "x' \<in> the_inv_into P bij X"
             by auto
           have "x' \<in> A"
             using \<open>x' \<in> the_inv_into P bij X\<close> assms(2) in_P partition_onD1 by fastforce
           have eq: "(THE X. x' \<in> X \<and> X \<in> P) = the_inv_into P bij X"
             using \<open>x' \<in> the_inv_into P bij X\<close> assms(2) in_P partition_on_the_part_eq by fastforce
           have p': "p' (the_inv_into P bij X) x' \<in> X"
             using \<open>x' \<in> the_inv_into P bij X\<close> bij_betwE eq_X in_P p' by blast
           from \<open>x = p x'\<close> \<open>x' \<in> A\<close> eq p' show "x \<in> X"
             unfolding p_def by auto
         qed
       qed
       moreover from \<open>X \<in> P'\<close> \<open>bij_betw bij P P'\<close> have "the_inv_into P bij X \<in> P"
         using bij_betwE bij_betw_the_inv_into by blast
       ultimately show "X \<in> (\<lambda>X. p ` X) ` P" ..
     qed
   next
     show "(\<lambda>X. p ` X) ` P \<subseteq> P'"
     proof
       fix X'
       assume "X' \<in> (\<lambda>X. p ` X) ` P"
       from this obtain X where X'_eq: "X' = p ` X" and "X \<in> P" ..
       from \<open>X \<in> P\<close> have "X \<subseteq> A"
         using assms(2) partition_onD1 by force
       from \<open>X \<in> P\<close> p' have bij: "bij_betw (p' X) X (bij X)" by auto
       have "p ` X \<in> P'"
       proof -
         from \<open>X \<in> P\<close> \<open>bij_betw bij P P'\<close> have "bij X \<in> P'"
           using bij_betwE by blast
         moreover have "(\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X = bij X"
         proof
           show "(\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X \<subseteq> bij X"
           proof
             fix x'
             assume "x' \<in> (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X"
             from this obtain x where "x \<in> X" and x'_eq: "x' = p' (THE X. x \<in> X \<and> X \<in> P) x" ..
             from \<open>X \<in> P\<close> \<open>x \<in> X\<close> have eq_X: "(THE X. x \<in> X \<and> X \<in> P) = X"
               using assms(2) partition_on_the_part_eq by fastforce
             from bij \<open>x \<in> X\<close> x'_eq eq_X show "x' \<in> bij X"
               using bij_betwE by blast
           qed
         next
           show "bij X \<subseteq> (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X"
           proof
             fix x'
             assume "x' \<in> bij X"
             let ?x = "inv_into X (p' X) x'"
             from \<open>x' \<in> bij X\<close> bij have "?x \<in> X"
               by (metis  bij_betw_imp_surj_on inv_into_into)
             from this \<open>X \<in> P\<close> have "(THE X. ?x \<in> X \<and> X \<in> P) = X"
               using assms(2) partition_on_the_part_eq by fastforce
             from this \<open>x' \<in> bij X\<close> bij have "x' = p' (THE X. ?x \<in> X \<and> X \<in> P) ?x"
               using bij_betw_inv_into_right by fastforce
             moreover from \<open>x' \<in> bij X\<close> bij have "?x \<in> X"
               by (metis bij_betw_imp_surj_on inv_into_into)
             ultimately show "x' \<in> (\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X" ..
           qed
         qed
         ultimately have "(\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X \<in> P'" by simp
         have "(\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X = (\<lambda>a. if a \<in> A then p' (THE X. a \<in> X \<and> X \<in> P) a else a) ` X "
           using \<open>X \<subseteq> A\<close> by (auto intro: image_cong)
         from this show ?thesis
          using \<open>(\<lambda>a. p' (THE X. a \<in> X \<and> X \<in> P) a) ` X \<in> P'\<close> unfolding p_def by auto
       qed
       from this X'_eq show "X' \<in> P'" by simp
     qed
   qed
   ultimately show thesis using that by blast
 qed
 
 lemma permutes_domain_partition_eq:
   assumes "f \<in> A \<rightarrow> B"
   assumes "p\<^sub>A permutes A"
   assumes "b \<in> B"
   shows "p\<^sub>A ` {x \<in> A. f x = b} = {x \<in> A. f (inv p\<^sub>A x) = b}"
 proof
   show "p\<^sub>A ` {x \<in> A. f x = b} \<subseteq> {x \<in> A. f (inv p\<^sub>A x) = b}"
     using \<open>p\<^sub>A permutes A\<close> permutes_in_image permutes_inverses(2) by fastforce
 next
   show "{x \<in> A. f (inv p\<^sub>A x) = b} \<subseteq> p\<^sub>A ` {x \<in> A. f x = b}"
   proof
     fix x
     assume "x \<in> {x \<in> A. f (inv p\<^sub>A x) = b}"
     from this have "x \<in> A" "f (inv p\<^sub>A x) = b" by auto
     from \<open>x \<in> A\<close> have "x = p\<^sub>A (inv p\<^sub>A x)"
       using \<open>p\<^sub>A permutes A\<close> permutes_inverses(1) by fastforce
     moreover from \<open>f (inv p\<^sub>A x) = b\<close> \<open>x \<in> A\<close> have "inv p\<^sub>A x \<in> {x \<in> A. f x = b}"
       by (simp add: \<open>p\<^sub>A permutes A\<close> permutes_in_image permutes_inv)
     ultimately show "x \<in> p\<^sub>A ` {x \<in> A. f x = b}" ..
   qed
 qed
 
 lemma image_domain_partition_eq:
   assumes "f \<in> A \<rightarrow>\<^sub>E B"
   assumes "p\<^sub>A permutes A"
   shows "(\<lambda>X. p\<^sub>A ` X) ` ((\<lambda>b. {x \<in> A. f x = b}) ` B) = (\<lambda>b. {x \<in> A. f (inv p\<^sub>A x) = b}) ` B"
 proof
   from \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> have "f \<in> A \<rightarrow> B" by auto
   note eq = permutes_domain_partition_eq[OF \<open>f \<in> A \<rightarrow> B\<close> \<open>p\<^sub>A permutes A\<close>]
   show "(\<lambda>X. p\<^sub>A ` X) ` (\<lambda>b. {x \<in> A. f x = b}) ` B \<subseteq> (\<lambda>b. {x \<in> A. f (inv p\<^sub>A x) = b}) ` B"
   proof
     fix X
     assume "X \<in> (\<lambda>X. p\<^sub>A ` X) ` (\<lambda>b. {x \<in> A. f x = b}) ` B"
     from this obtain b where "b \<in> B" and X_eq: "X = p\<^sub>A ` {x \<in> A. f x = b}" by auto
     from this eq have "X = {x \<in> A. f (inv p\<^sub>A x) = b}" by simp
     from this \<open>b \<in> B\<close> show "X \<in> (\<lambda>b. {x \<in> A. f (inv p\<^sub>A x) = b}) ` B" ..
   qed
 next
   from \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> have "f \<in> A \<rightarrow> B" by auto
   note eq = permutes_domain_partition_eq[OF \<open>f \<in> A \<rightarrow> B\<close> \<open>p\<^sub>A permutes A\<close>, symmetric]
   show "(\<lambda>b. {x \<in> A. f (inv p\<^sub>A x) = b}) ` B \<subseteq> (\<lambda>X. p\<^sub>A ` X) ` (\<lambda>b. {x \<in> A. f x = b}) ` B"
   proof
     fix X
     assume "X \<in> (\<lambda>b. {x \<in> A. f (inv p\<^sub>A x) = b}) ` B"
     from this obtain b where "b \<in> B" and X_eq: "X = {x \<in> A. f (inv p\<^sub>A x) = b}" by auto
     from this eq have "X = p\<^sub>A ` {x \<in> A. f x = b}" by simp
     from this \<open>b \<in> B\<close> show "X \<in> (\<lambda>X. p\<^sub>A ` X) ` (\<lambda>b. {x \<in> A. f x = b}) ` B" by auto
   qed
 qed
 
 lemma multiset_of_partition_cards_eq_implies_permutes:
   assumes "finite A" "finite B" "f \<in> A \<rightarrow>\<^sub>E B" "f' \<in> A \<rightarrow>\<^sub>E B"
   assumes eq: "image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})) = image_mset card (mset_set ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}))"
   obtains p\<^sub>A p\<^sub>B where "p\<^sub>A permutes A" "p\<^sub>B permutes B" "\<forall>x\<in>A. f x = p\<^sub>B (f' (p\<^sub>A x))"
 proof -
   have "partition_on A ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})"
     using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> by (auto intro!: partition_onI)
   moreover have "partition_on A ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}})"
     using \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> by (auto intro!: partition_onI)
   moreover note partition_implies_permutes[OF \<open>finite A\<close> _ _ eq]
   ultimately obtain p\<^sub>A where "p\<^sub>A permutes A" and
     inv_image_eq: "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} =
       (`) p\<^sub>A ` ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}})" by blast
   from \<open>p\<^sub>A permutes A\<close> have "inj ((`) p\<^sub>A)"
     by (meson injI inj_image_eq_iff permutes_inj)
   have inv_image_eq': "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' (inv p\<^sub>A x) = b}) ` B - {{}}"
   proof -
     note inv_image_eq
     also have "(\<lambda>X. p\<^sub>A ` X) ` ((\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}) = (\<lambda>b. {x \<in> A. f' (inv p\<^sub>A x) = b}) ` B - {{}}"
       using image_domain_partition_eq[OF \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> \<open>p\<^sub>A permutes A\<close>]
       by (simp add: image_set_diff[OF \<open>inj ((`) p\<^sub>A)\<close>])
     finally show ?thesis .
   qed
   from \<open>p\<^sub>A permutes A\<close> have "inv p\<^sub>A permutes A"
     using permutes_inv by blast
   have "(\<lambda>x. f' (inv p\<^sub>A x)) \<in> A \<rightarrow>\<^sub>E B"
     using \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> \<open>inv p\<^sub>A permutes A\<close> permutes_in_image by fastforce
   from \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> this \<open>finite B\<close> obtain p\<^sub>B
     where "p\<^sub>B permutes B" and eq'': "\<forall>x\<in>A. f x = p\<^sub>B (f' (inv p\<^sub>A x))"
     using partitions_eq_implies_permutes[OF _ _ _ inv_image_eq'] by blast
   from \<open>inv p\<^sub>A permutes A\<close> \<open>p\<^sub>B permutes B\<close> eq'' that show thesis by blast
 qed
 
 subsection \<open>Bijections on Same Domain and Range\<close>
 
 subsubsection \<open>Existence of Domain Permutation\<close>
 
 lemma obtain_domain_permutation_for_two_bijections:
   assumes "bij_betw f A B" "bij_betw f' A B"
   obtains p where "p permutes A" and "\<forall>a\<in>A. f a = f' (p a)"
 proof -
   let ?p = "\<lambda>a. if a \<in> A then the_inv_into A f' (f a) else a"
   have "?p permutes A"
   proof (rule bij_imp_permutes)
     show "bij_betw ?p A A"
     proof (rule bij_betw_imageI)
       show "inj_on ?p A"
       proof (rule inj_onI)
         fix a a'
         assume "a \<in> A" "a' \<in> A" "?p a = ?p a'"
         from this have "the_inv_into A f' (f a) = the_inv_into A f' (f a')"
           using \<open>a \<in> A\<close> \<open>a' \<in> A\<close> by simp
         from this have "f a = f a'"
           using \<open>a \<in> A\<close> \<open>a' \<in> A\<close> assms
           by (metis bij_betwE f_the_inv_into_f_bij_betw)
         from this show "a = a'"
           using \<open>a \<in> A\<close> \<open>a' \<in> A\<close> assms
           by (metis bij_betw_inv_into_left)
       qed
     next
       show "?p ` A = A"
       proof
         show "?p ` A \<subseteq> A"
         proof
           fix a
           assume "a \<in> ?p ` A"
           from this obtain a' where "a' \<in> A" and "a = the_inv_into A f' (f a')" by auto
           from this assms show "a \<in> A"
             by (metis bij_betwE bij_betw_imp_inj_on bij_betw_imp_surj_on subset_iff the_inv_into_into)
         qed
       next
         show "A \<subseteq> ?p ` A"
         proof
           fix a
           assume "a \<in> A"
           from this assms have "the_inv_into A f (f' a) \<in> A"
             by (meson bij_betwE bij_betw_the_inv_into)
           moreover from  \<open>a \<in> A\<close> assms have "a = the_inv_into A f' (f (the_inv_into A f (f' a)))"
             by (metis bij_betwE bij_betw_imp_inj_on f_the_inv_into_f_bij_betw the_inv_into_f_eq)
           ultimately show "a \<in> ?p ` A" by auto
         qed
       qed
     qed
   next
     fix a
     assume "a \<notin> A"
     from this show "?p a = a" by auto
   qed
   moreover have "\<forall>a\<in>A. f a = f' (?p a)"
     using \<open>bij_betw f A B\<close> \<open>bij_betw f' A B\<close>
     using bij_betwE f_the_inv_into_f_bij_betw by fastforce
   moreover note that
   ultimately show thesis by auto
 qed
 
 subsubsection \<open>Existence of Range Permutation\<close>
 
 lemma obtain_range_permutation_for_two_bijections:
   assumes "bij_betw f A B" "bij_betw f' A B"
   obtains p where "p permutes B" and "\<forall>a\<in>A. f a = p (f' a)"
 proof -
   let ?p = "\<lambda>b. if b \<in> B then f (inv_into A f' b) else b"
   have "?p permutes B"
   proof (rule bij_imp_permutes)
     show "bij_betw ?p B B"
     proof (rule bij_betw_imageI)
       show "inj_on ?p B"
       proof (rule inj_onI)
         fix b b'
         assume "b \<in> B" "b' \<in> B" "?p b = ?p b'"
         from this have "f (inv_into A f' b) = f (inv_into A f' b')"
           using \<open>b \<in> B\<close> \<open>b' \<in> B\<close> by simp
         from this have "inv_into A f' b = inv_into A f' b'"
           using \<open>b \<in> B\<close> \<open>b' \<in> B\<close> assms
           by (metis bij_betw_imp_surj_on bij_betw_inv_into_left inv_into_into)
         from this show "b = b'"
           using \<open>b \<in> B\<close> \<open>b' \<in> B\<close> assms(2)
           by (metis bij_betw_inv_into_right)
       qed
     next
       show "?p ` B = B"
       proof
         from assms show "?p ` B \<subseteq> B"
           by (auto simp add: bij_betwE bij_betw_def inv_into_into)
       next
         show "B \<subseteq> ?p ` B"
         proof
           fix b
           assume "b \<in> B"
           from this assms have "f' (inv_into A f b) \<in> B"
             by (metis bij_betwE bij_betw_imp_surj_on inv_into_into)
           moreover have "b = ?p (f' (inv_into A f b))"
             using assms \<open>f' (inv_into A f b) \<in> B\<close> \<open>b \<in> B\<close>
             by (auto simp add: bij_betw_imp_surj_on bij_betw_inv_into_left bij_betw_inv_into_right inv_into_into)
           ultimately show "b \<in> ?p ` B" by auto
         qed
       qed
     qed
   next
     fix b
     assume "b \<notin> B"
     from this show "?p b = b" by auto
   qed
   moreover have "\<forall>a\<in>A. f a = ?p (f' a)"
     using \<open>bij_betw f' A B\<close> bij_betw_inv_into_left bij_betwE by fastforce
   moreover note that
   ultimately show thesis by auto
 qed
 
 end
diff --git a/thys/UpDown_Scheme/Triangular_Function.thy b/thys/UpDown_Scheme/Triangular_Function.thy
--- a/thys/UpDown_Scheme/Triangular_Function.thy
+++ b/thys/UpDown_Scheme/Triangular_Function.thy
@@ -1,422 +1,422 @@
 section \<open> Hat Functions \<close>
 
 theory Triangular_Function
 imports
  "HOL-Analysis.Equivalence_Lebesgue_Henstock_Integration"
  Grid
 begin
 
 lemma continuous_on_max[continuous_intros]:
   fixes f :: "_ \<Rightarrow> 'a::linorder_topology"
   shows "continuous_on S f \<Longrightarrow> continuous_on S g \<Longrightarrow> continuous_on S (\<lambda>x. max (f x) (g x))"
   by (auto simp: continuous_on_def intro: tendsto_max)
 
 definition \<phi> :: "(nat \<times> int) \<Rightarrow> real \<Rightarrow> real" where
   "\<phi> \<equiv> (\<lambda>(l,i) x. max 0 (1 - \<bar> x * 2^(l + 1) - real_of_int i \<bar>))"
 
 definition \<Phi> :: "(nat \<times> int) list \<Rightarrow> (nat \<Rightarrow> real) \<Rightarrow> real" where
   "\<Phi> p x = (\<Prod>d<length p. \<phi> (p ! d) (x d))"
 
 definition l2_\<phi> where
   "l2_\<phi> p1 p2 = (\<integral>x. \<phi> p1 x * \<phi> p2 x \<partial>lborel)"
 
 definition l2 where
   "l2 a b = (\<integral>x. \<Phi> a x * \<Phi> b x \<partial>(\<Pi>\<^sub>M d\<in>{..<length a}. lborel))"
 
 lemma measurable_\<phi>[measurable]: "\<phi> p \<in> borel_measurable borel"
   by (cases p) (simp add: \<phi>_def)
 
 lemma \<phi>_nonneg: "0 \<le> \<phi> p x"
   by (simp add: \<phi>_def split: prod.split)
 
 lemma \<phi>_zero_iff:
   "\<phi> (l,i) x = 0 \<longleftrightarrow> x \<notin> {real_of_int (i - 1) / 2^(l + 1) <..< real_of_int (i + 1) / 2^(l + 1)}"
   by (auto simp: \<phi>_def field_simps split: split_max)
 
 lemma \<phi>_zero: "x \<notin> {real_of_int (i - 1) / 2^(l + 1) <..< real_of_int (i + 1) / 2^(l + 1)} \<Longrightarrow> \<phi> (l,i) x = 0"
   unfolding \<phi>_zero_iff by simp
 
 lemma \<phi>_eq_0: assumes x: "x < 0 \<or> 1 < x" and i: "0 < i" "i < 2^Suc l" shows "\<phi> (l, i) x = 0"
   using x
 proof
   assume "x < 0"
   also have "0 \<le> real_of_int (i - 1) / 2^(l + 1)"
     using i by (auto simp: field_simps)
   finally show ?thesis
     by (auto intro!: \<phi>_zero simp: field_simps)
 next
   have "real_of_int (i + 1) / 2^(l + 1) \<le> 1"
     using i by (subst divide_le_eq_1_pos) (auto simp del: of_int_add power_Suc)
   also assume "1 < x"
   finally show ?thesis
     by (auto intro!: \<phi>_zero simp: field_simps)
 qed
 
 lemma ix_lt: "p \<in> sparsegrid dm lm \<Longrightarrow> d < dm \<Longrightarrow> ix p d < 2^(lv p d + 1)"
   unfolding sparsegrid_def lgrid_def
   using grid_estimate[of d "start dm" p "{0 ..< dm}"] by auto
 
 lemma ix_gt: "p \<in> sparsegrid dm lm \<Longrightarrow> d < dm \<Longrightarrow> 0 < ix p d"
   unfolding sparsegrid_def lgrid_def
   using grid_estimate[of d "start dm" p "{0 ..< dm}"] by auto
 
 lemma \<Phi>_eq_0: assumes x: "\<exists>d<length p. x d < 0 \<or> 1 < x d" and p: "p \<in> sparsegrid dm lm" shows "\<Phi> p x = 0"
   unfolding \<Phi>_def
 proof (rule prod_zero)
-  from x guess d ..
+  from x obtain d where "d < length p \<and> (x d < 0 \<or> 1 < x d)" ..
   with p[THEN ix_lt, of d] p[THEN ix_gt, of d] p
   show "\<exists>a\<in>{..<length p}. \<phi> (p ! a) (x a) = 0"
     apply (cases "p!d")
     apply (intro bexI[of _ d])
     apply (auto intro!: \<phi>_eq_0 simp: sparsegrid_length ix_def lv_def)
     done
 qed simp
 
 lemma \<phi>_left_support':
   "x \<in> {real_of_int (i - 1) / 2^(l + 1) .. real_of_int i / 2^(l + 1)} \<Longrightarrow> \<phi> (l,i) x = 1 + x * 2^(l + 1) - real_of_int i"
   by (auto simp: \<phi>_def field_simps split: split_max)
 
 lemma \<phi>_left_support: "x \<in> {-1 .. 0::real} \<Longrightarrow> \<phi> (l,i) ((x + real_of_int i) / 2^(l + 1)) = 1 + x"
   by (auto simp: \<phi>_def field_simps split: split_max)
 
 lemma \<phi>_right_support':
   "x \<in> {real_of_int i / 2^(l + 1) .. real_of_int (i + 1) / 2^(l + 1)} \<Longrightarrow> \<phi> (l,i) x = 1 - x * 2^(l + 1) + real_of_int i"
   by (auto simp: \<phi>_def field_simps split: split_max)
 
 lemma \<phi>_right_support: 
   "x \<in> {0 .. 1::real} \<Longrightarrow> \<phi> (l,i) ((x + real i) / 2^(l + 1)) = 1 - x"
   by (auto simp: \<phi>_def field_simps split: split_max)
 
 lemma integrable_\<phi>: "integrable lborel (\<phi> p)"
 proof (induct p)
   case (Pair l i)
   have "integrable lborel (\<lambda>x. indicator {real_of_int (i - 1) / 2^(l + 1) .. real_of_int (i + 1) / 2^(l + 1)} x *\<^sub>R \<phi> (l, i) x)"
     unfolding \<phi>_def by (intro borel_integrable_compact) (auto intro!: continuous_intros)
   then show ?case
     by (rule integrable_cong[THEN iffD1, rotated -1]) (auto simp: \<phi>_zero_iff)
 qed
 
 lemma integrable_\<phi>2: "integrable lborel (\<lambda>x. \<phi> p x * \<phi> q x)"
 proof (cases p q rule: prod.exhaust[case_product prod.exhaust])
   case (Pair_Pair l i l' i')
   have "integrable lborel
       (\<lambda>x. indicator {real_of_int (i - 1) / 2^(l + 1) .. real_of_int (i + 1) / 2^(l + 1)} x *\<^sub>R (\<phi> (l, i) x * \<phi> (l', i') x))"
     unfolding \<phi>_def by (intro borel_integrable_compact) (auto intro!: continuous_intros)
   then show ?thesis unfolding Pair_Pair
     by (rule integrable_cong[THEN iffD1, rotated -1]) (auto simp: \<phi>_zero_iff)
 qed
 
 lemma l2_\<phi>I_DERIV:
   assumes n: "\<And> x. x \<in> { (real_of_int i' - 1) / 2^(l' + 1) .. real_of_int i' / 2^(l' + 1) } \<Longrightarrow>
     DERIV \<Phi>_n x :> (\<phi> (l', i') x * \<phi> (l, i) x)" (is "\<And> x. x \<in> {?a..?b} \<Longrightarrow> DERIV _ _ :> ?P x")
     and p: "\<And> x. x \<in> { real_of_int i' / 2^(l' + 1) .. (real_of_int i' + 1) / 2^(l' + 1) } \<Longrightarrow>
     DERIV \<Phi>_p x :> (\<phi> (l', i') x * \<phi> (l, i) x)" (is "\<And> x. x \<in> {?b..?c} \<Longrightarrow> _")
   shows "l2_\<phi> (l', i') (l, i) = (\<Phi>_n ?b - \<Phi>_n ?a) + (\<Phi>_p ?c - \<Phi>_p ?b)"
 proof -
   have "has_bochner_integral lborel
       (\<lambda>x. ?P x * indicator {?a..?b} x + ?P x * indicator {?b..?c} x)
       ((\<Phi>_n ?b - \<Phi>_n ?a) + (\<Phi>_p ?c - \<Phi>_p ?b))"
     by (intro has_bochner_integral_add has_bochner_integral_FTC_Icc_nonneg n p)
        (auto simp: \<phi>_nonneg field_simps)
   then have "has_bochner_integral lborel?P ((\<Phi>_n ?b - \<Phi>_n ?a) + (\<Phi>_p ?c - \<Phi>_p ?b))"
     by (rule has_bochner_integral_discrete_difference[where X="{?b}", THEN iffD1, rotated -1])
        (auto simp: power_add intro!: \<phi>_zero integral_cong split: split_indicator)
   then show ?thesis by (simp add: has_bochner_integral_iff l2_\<phi>_def)
 qed
 
 lemma l2_eq: "length a = length b \<Longrightarrow> l2 a b = (\<Prod>d<length a. l2_\<phi> (a!d) (b!d))"
   unfolding l2_def l2_\<phi>_def \<Phi>_def 
   apply (simp add: prod.distrib[symmetric])
 proof (rule product_sigma_finite.product_integral_prod)
   show "product_sigma_finite (\<lambda>d. lborel)" ..
 qed (auto intro: integrable_\<phi>2)
 
 lemma l2_when_disjoint:
   assumes "l \<le> l'"
   defines "d == l' - l"
   assumes "(i + 1) * 2^d < i' \<or> i' < (i - 1) * 2^d" (is "?right \<or> ?left")
   shows "l2_\<phi> (l', i') (l, i) = 0"
 proof -
   let ?sup = "\<lambda>l i. {real_of_int (i - 1) / 2^(l + 1) <..< real_of_int (i + 1) / 2^(l + 1)}"
 
   have l': "l' = l + d"
     using assms by simp
   have *: "\<And>i l. 2 ^ l = real_of_int (2 ^ l::int)"
     by simp
   have [arith]: "0 < (2^d::int)"
     by simp
 
   from \<open>?right \<or> ?left\<close> \<open>l \<le> l'\<close> have empty_support: "?sup l i \<inter> ?sup l' i' = {}"
     by (auto simp add: min_def max_def divide_simps l' power_add * of_int_mult[symmetric]
                 simp del: of_int_diff of_int_add of_int_mult of_int_power)
        (simp_all add: field_simps)
   then have "\<And>x. \<phi> (l', i') x * \<phi> (l, i) x = 0"
     unfolding \<phi>_zero_iff mult_eq_0_iff by blast
   then show ?thesis
     by (simp add: l2_\<phi>_def del: mult_eq_0_iff vector_space_over_itself.scale_eq_0_iff)
 qed
 
 lemma l2_commutative: "l2_\<phi> p q = l2_\<phi> q p"
   by (simp add: l2_\<phi>_def mult.commute)
 
 lemma l2_when_same: "l2_\<phi> (l, i) (l, i) = 1/3 / 2^l"
 proof (subst l2_\<phi>I_DERIV)
   let ?l = "(2 :: real)^(l + 1)"
   let ?in = "real_of_int i - 1"
   let ?ip = "real_of_int i + 1"
   let ?\<phi> = "\<phi> (l,i)"
   let ?\<phi>2 = "\<lambda>x. ?\<phi> x * ?\<phi> x"
 
   { fix x assume "x \<in> {?in / ?l .. real_of_int i / ?l}"
     hence \<phi>_eq: "?\<phi> x = ?l * x  - ?in" using \<phi>_left_support' by auto
     show "DERIV (\<lambda>x. x^3 / 3 * ?l^2 + x * ?in^2 - x^2/2 * 2 * ?l * ?in) x :> ?\<phi>2 x"
       by (auto intro!: derivative_eq_intros simp add: power2_eq_square field_simps \<phi>_eq) }
 
   { fix x assume "x \<in> {real_of_int i / ?l .. ?ip / ?l}"
     hence \<phi>_eq: "?\<phi> x = ?ip - ?l * x" using \<phi>_right_support' by auto
     show "DERIV (\<lambda>x. x^3 / 3 * ?l^2 + x * ?ip^2 - x^2/2 * 2 * ?l * ?ip) x :> ?\<phi>2 x"
       by (auto intro!: derivative_eq_intros simp add: power2_eq_square field_simps \<phi>_eq) }
 qed (simp_all add: field_simps power_eq_if[of _ 2] power_eq_if[of _ 3])
 
 lemma l2_when_left_child:
   assumes "l < l'"
   and i'_bot: "i' > (i - 1) * 2^(l' - l)"
   and i'_top: "i' < i * 2^(l' - l)"
   shows "l2_\<phi> (l', i') (l, i) = (1 + real_of_int i' / 2^(l' - l) - real_of_int i) / 2^(l' + 1)"
 proof (subst l2_\<phi>I_DERIV)
   let ?l' = "(2 :: real)^(l' + 1)"
   let ?in' = "real_of_int i' - 1"
   let ?ip' = "real_of_int i' + 1"
   let ?l = "(2 :: real)^(l + 1)"
   let ?i = "real_of_int i - 1"
   let ?\<phi>' = "\<phi> (l',i')"
   let ?\<phi> = "\<phi> (l, i)"
   let "?\<phi>2 x" = "?\<phi>' x * ?\<phi> x"
   define \<Phi>_n where "\<Phi>_n x = x^3 / 3 * ?l' * ?l + x * ?i * ?in' - x^2 / 2 * (?in' * ?l + ?i * ?l')" for x
   define \<Phi>_p where "\<Phi>_p x = x^2 / 2 * (?ip' * ?l + ?i * ?l') - x^3 / 3 * ?l' * ?l - x * ?i * ?ip'" for x
 
   have level_diff: "2^(l' - l) = 2^l' / (2^l :: real)" using power_diff[of "2::real" l l'] \<open>l < l'\<close> by auto
 
   { fix x assume x: "x \<in> {?in' / ?l' .. ?ip' / ?l'}"
     have "?i * 2^(l' - l) \<le> ?in'"
       using i'_bot int_less_real_le by auto
     hence "?i / ?l \<le> ?in' / ?l'"
       using level_diff by (auto simp: field_simps)
     hence "?i / ?l \<le> x" using x by auto
     moreover
     have "?ip' \<le> real_of_int i * 2^(l' - l)"
       using i'_top int_less_real_le by auto
     hence ip'_le_i: "?ip' / ?l' \<le> real_of_int i / ?l"
       using level_diff by (auto simp: field_simps)
     hence "x \<le> real_of_int i / ?l" using x by auto
     ultimately have "?\<phi> x = ?l * x  - ?i" using \<phi>_left_support' by auto
   } note \<phi>_eq = this
 
   { fix x assume x: "x \<in> {?in' / ?l' .. real_of_int i' / ?l'}"
     hence \<phi>'_eq: "?\<phi>' x = ?l' * x  - ?in'" using \<phi>_left_support' by auto
     from x have x': "x \<in> {?in' / ?l' .. ?ip' / ?l'}" by (auto simp add: field_simps)
     show "DERIV \<Phi>_n x :> ?\<phi>2 x" unfolding \<phi>_eq[OF x'] \<phi>'_eq \<Phi>_n_def
       by (auto intro!: derivative_eq_intros simp add: power2_eq_square algebra_simps) }
 
   { fix x assume x: "x \<in> {real_of_int i' / ?l' .. ?ip' / ?l'}"
     hence \<phi>'_eq: "?\<phi>' x = ?ip' - ?l' * x" using \<phi>_right_support' by auto
     from x have x': "x \<in> {?in' / ?l' .. ?ip' / ?l'}" by (simp add: field_simps)
     show "DERIV \<Phi>_p x :> ?\<phi>2 x" unfolding \<phi>_eq[OF x'] \<phi>'_eq \<Phi>_p_def
       by (auto intro!: derivative_eq_intros simp add: power2_eq_square algebra_simps) }
 qed (simp_all add: field_simps power_eq_if[of _ 2] power_eq_if[of _ 3] power_diff[of "2::real", OF _ \<open>l < l'\<close>[THEN less_imp_le]] )
 
 lemma l2_when_right_child:
   assumes "l < l'"
   and i'_bot: "i' > i * 2^(l' - l)"
   and i'_top: "i' < (i + 1) * 2^(l' - l)"
   shows "l2_\<phi> (l', i') (l, i) = (1 - real_of_int i' / 2^(l' - l) + real_of_int i) / 2^(l' + 1)"
 proof (subst l2_\<phi>I_DERIV)
   let ?l' = "(2 :: real)^(l' + 1)"
   let ?in' = "real_of_int i' - 1"
   let ?ip' = "real_of_int i' + 1"
   let ?l = "(2 :: real)^(l + 1)"
   let ?i = "real_of_int i + 1"
   let ?\<phi>' = "\<phi> (l',i')"
   let ?\<phi> = "\<phi> (l, i)"
   let ?\<phi>2 = "\<lambda>x. ?\<phi>' x * ?\<phi> x"
   define \<Phi>_n where "\<Phi>_n x = x^2 / 2 * (?in' * ?l + ?i * ?l') - x^3 / 3 * ?l' * ?l - x * ?i * ?in'" for x
   define \<Phi>_p where "\<Phi>_p x = x^3 / 3 * ?l' * ?l + x * ?i * ?ip' - x^2 / 2 * (?ip' * ?l + ?i * ?l')" for x
 
   have level_diff: "2^(l' - l) = 2^l' / (2^l :: real)" using power_diff[of "2::real" l l'] \<open>l < l'\<close> by auto
 
   { fix x assume x: "x \<in> {?in' / ?l' .. ?ip' / ?l'}"
     have "real_of_int i * 2^(l' - l) \<le> ?in'"
       using i'_bot int_less_real_le by auto
     hence "real_of_int i / ?l \<le> ?in' / ?l'"
       using level_diff by (auto simp: field_simps)
     hence "real_of_int i / ?l \<le> x" using x by auto
     moreover
     have "?ip' \<le> ?i * 2^(l' - l)"
       using i'_top int_less_real_le by auto
     hence ip'_le_i: "?ip' / ?l' \<le> ?i / ?l"
       using level_diff by (auto simp: field_simps)
     hence "x \<le> ?i / ?l" using x by auto
     ultimately have "?\<phi> x = ?i - ?l * x" using \<phi>_right_support' by auto
   } note \<phi>_eq = this
 
   { fix x assume x: "x \<in> {?in' / ?l' .. real_of_int i' / ?l'}"
     hence \<phi>'_eq: "?\<phi>' x = ?l' * x  - ?in'" using \<phi>_left_support' by auto
 
     from x have x': "x \<in> {?in' / ?l' .. ?ip' / ?l'}" by (simp add: field_simps)
     show "DERIV \<Phi>_n x :> ?\<phi>2 x" unfolding \<Phi>_n_def \<phi>_eq[OF x'] \<phi>'_eq
       by (auto intro!: derivative_eq_intros simp add: simp add: power2_eq_square algebra_simps) }
 
   { fix x assume x: "x \<in> {real_of_int i' / ?l' .. ?ip' / ?l'}"
     hence \<phi>'_eq: "?\<phi>' x = ?ip' - ?l' * x" using \<phi>_right_support' by auto
     from x have x': "x \<in> {?in' / ?l' .. ?ip' / ?l'}" by (auto simp: field_simps)
     show "DERIV \<Phi>_p x :> ?\<phi>2 x" unfolding \<phi>_eq[OF x'] \<phi>'_eq \<Phi>_p_def
       by (auto intro!: derivative_eq_intros simp add: power2_eq_square algebra_simps) }
 qed (simp_all add: field_simps power_eq_if[of _ 2] power_eq_if[of _ 3] power_diff[of "2::real", OF _ \<open>l < l'\<close>[THEN less_imp_le]] )
 
 lemma level_shift: "lc > l \<Longrightarrow> (x :: real) / 2 ^ (lc - Suc l) = x * 2 / 2 ^ (lc - l)"
   by (auto simp add: power_diff)
 
 lemma l2_child: assumes "d < length b"
   and p_grid: "p \<in> grid (child b dir d) ds" (is "p \<in> grid ?child ds")
   shows "l2_\<phi> (p ! d) (b ! d) = (1 - real_of_int (sgn dir) * (real_of_int (ix p d) / 2^(lv p d - lv b d) - real_of_int (ix b d))) /
                                  2^(lv p d + 1)"
 proof -
   have "lv ?child d \<le> lv p d" using \<open>d < length b\<close> and p_grid
     using grid_single_level by auto
   hence "lv b d < lv p d" using \<open>d < length b\<close> and p_grid
     using child_lv by auto
 
   let ?i_c = "ix ?child d" and ?l_c = "lv ?child d"
   let ?i_p = "ix p d" and ?l_p = "lv p d"
   let ?i_b = "ix b d" and ?l_b = "lv b d"
 
   have "(2::int) * 2^(?l_p - ?l_c) = 2^Suc (?l_p - ?l_c)" by auto
   also have "\<dots> = 2^(Suc ?l_p - ?l_c)"
   proof -
     have "Suc (?l_p - ?l_c) = Suc ?l_p - ?l_c"
       using \<open>lv ?child d \<le> lv p d\<close> by auto
     thus ?thesis by auto
   qed
   also have "\<dots> = 2^(?l_p - ?l_b)"
     using \<open>d < length b\<close> and \<open>lv b d < lv p d\<close>
     by (auto simp add: child_def lv_def)
   finally have level: "2^(?l_p - ?l_b) = (2::int) * 2^(?l_p - ?l_c)" ..
 
   from \<open>d < length b\<close> and p_grid
   have range_left: "?i_p > (?i_c - 1) * 2^(?l_p - ?l_c)" and
        range_right: "?i_p < (?i_c + 1) * 2^(?l_p - ?l_c)"
     using grid_estimate by auto
 
   show ?thesis
   proof (cases dir)
     case left
     with child_ix_left[OF \<open>d < length b\<close>]
     have "(?i_b - 1) * 2^(?l_p - ?l_b) = (?i_c - 1) * 2^(?l_p - ?l_c)" and
       "?i_b * 2^(?l_p - ?l_b) = (?i_c + 1) * 2^(?l_p - ?l_c)" using level by auto
     hence "?i_p > (?i_b - 1) * 2^(?l_p - ?l_b)" and
       "?i_p < ?i_b * 2^(?l_p - ?l_b)"
       using range_left and range_right by auto
     with \<open>?l_b < ?l_p\<close>
     have "l2_\<phi> (?l_p, ?i_p) (?l_b, ?i_b) =
           (1 + real_of_int ?i_p / 2^(?l_p - ?l_b) - real_of_int ?i_b) / 2^(?l_p + 1)"
       by (rule l2_when_left_child)
     thus ?thesis using left by (auto simp add: ix_def lv_def)
   next
     case right
     hence "?i_c = 2 * ?i_b + 1" using child_ix_right and \<open>d < length b\<close> by auto
     hence "?i_b * 2^(?l_p - ?l_b) = (?i_c - 1) * 2^(?l_p - ?l_c)" and
       "(?i_b + 1) * 2^(?l_p - ?l_b) = (?i_c + 1) * 2^(?l_p - ?l_c)" using level by auto
     hence "?i_p > ?i_b * 2^(?l_p - ?l_b)" and
       "?i_p < (?i_b + 1) * 2^(?l_p - ?l_b)"
       using range_left and range_right by auto
     with \<open>?l_b < ?l_p\<close>
     have "l2_\<phi> (?l_p, ?i_p) (?l_b, ?i_b) =
           (1 - real_of_int ?i_p / 2^(?l_p - ?l_b) + real_of_int ?i_b) / 2^(?l_p + 1)"
       by (rule l2_when_right_child)
     thus ?thesis using right by (auto simp add: ix_def lv_def)
   qed
 qed
 
 lemma l2_same: "l2_\<phi> (p!d) (p!d) = 1/3 / 2^(lv p d)"
 proof -
   have "l2_\<phi> (p!d) (p!d) = l2_\<phi> (lv p d, ix p d) (lv p d, ix p d)"
     by (auto simp add: lv_def ix_def)
   thus ?thesis using l2_when_same by auto
 qed
 
 lemma l2_disjoint: assumes "d < length b" and "p \<in> grid b {d}" and "p' \<in> grid b {d}"
   and "p' \<notin> grid p {d}" and "lv p' d \<ge> lv p d"
   shows "l2_\<phi> (p' ! d) (p ! d) = 0"
 proof -
   have range: "ix p' d > (ix p d + 1) * 2^(lv p' d - lv p d) \<or> ix p' d < (ix p d - 1) * 2^(lv p' d - lv p d)"
   proof (rule ccontr)
     assume "\<not> ?thesis"
     hence "ix p' d \<le> (ix p d + 1) * 2^(lv p' d - lv p d)" and "ix p' d \<ge> (ix p d - 1) * 2^(lv p' d - lv p d)" by auto
     with \<open>p' \<in> grid b {d}\<close> and \<open>p \<in> grid b {d}\<close> and \<open>lv p' d \<ge> lv p d\<close> and \<open>d < length b\<close>
     have "p' \<in> grid p {d}" using grid_part[where p=p and b=b and d=d and p'=p'] by auto
     with \<open>p' \<notin> grid p {d}\<close> show False by auto
   qed
 
   have "l2_\<phi> (p' ! d) (p ! d) = l2_\<phi> (lv p' d, ix p' d) (lv p d, ix p d)" by (auto simp add: ix_def lv_def)
   also have "\<dots> = 0" using range and \<open>lv p' d \<ge> lv p d\<close> and l2_when_disjoint by auto
   finally show ?thesis .
 qed
 
 lemma l2_down2:
   fixes pc pd p
   assumes "d < length pd"
   assumes pc_in_grid: "pc \<in> grid (child pd dir d) {d}"
   assumes pd_is_child: "pd = child p dir d" (is "pd = ?pd")
   shows "l2_\<phi> (pc ! d) (pd ! d) / 2 = l2_\<phi> (pc ! d) (p ! d)"
 proof -
   have "d < length p" using pd_is_child \<open>d < length pd\<close> by auto
 
   moreover
   have "pc \<in> grid ?pd {d}" using pd_is_child and grid_child and pc_in_grid by auto
   hence "lv p d < lv pc d" using grid_child_level and \<open>d < length pd\<close> and pd_is_child by auto
 
   moreover
   have "real_of_int (sgn dir) * real_of_int (sgn dir) = 1" by (cases dir, auto)
 
   ultimately show ?thesis
     unfolding l2_child[OF \<open>d < length pd\<close> pc_in_grid]
               l2_child[OF \<open>d < length p\<close> \<open>pc \<in> grid ?pd {d}\<close>]
     using child_lv and child_ix and pd_is_child and level_shift
     by (auto simp add: algebra_simps diff_divide_distrib add_divide_distrib)
 qed
 
 lemma l2_zigzag:
   assumes "d < length p" and p_child: "p = child p_p dir d"
   and p'_grid: "p' \<in> grid (child p (inv dir) d) {d}"
   and ps_intro: "child p (inv dir) d = child ps dir d" (is "?c_p = ?c_ps")
   shows "l2_\<phi> (p' ! d) (p_p ! d) = l2_\<phi> (p' ! d) (ps ! d) + l2_\<phi> (p' ! d) (p ! d) / 2"
 proof -
   have "length p = length ?c_p" by auto
   also have "\<dots> = length ?c_ps" using ps_intro by auto
   finally have "length p = length ps" using ps_intro by auto
   hence "d < length p_p" using p_child and \<open>d < length p\<close> by auto
 
   moreover
   from ps_intro have "ps = p[d := (lv p d, ix p d - sgn dir)]" by (rule child_neighbour)
   hence "lv ps d = lv p d" and "real_of_int (ix ps d) = real_of_int (ix p d) - real_of_int (sgn dir)"
     using lv_def and ix_def and \<open>length p = length ps\<close> and \<open>d < length p\<close> by auto
 
   moreover
   have "d < length ps" and *: "p' \<in> grid (child ps dir d) {d}"
     using p'_grid ps_intro \<open>length p = length ps\<close> \<open>d < length p\<close> by auto
 
   have "p' \<in> grid p {d}" using p'_grid and grid_child by auto
   hence p_p_grid: "p' \<in> grid (child p_p dir d) {d}" using p_child by auto
   hence "lv p' d > lv p_p d" using grid_child_level and \<open>d < length p_p\<close> by auto
 
   moreover
   have "real_of_int (sgn dir) * real_of_int (sgn dir) = 1" by (cases dir, auto)
 
   ultimately show ?thesis
     unfolding l2_child[OF \<open>d < length p\<close> p'_grid] l2_child[OF \<open>d < length ps\<close> *]
               l2_child[OF \<open>d < length p_p\<close> p_p_grid]
     using child_lv and child_ix and p_child level_shift
     by (auto simp add: add_divide_distrib algebra_simps diff_divide_distrib)
 qed
 
 end
diff --git a/thys/Zeta_Function/ROOT b/thys/Zeta_Function/ROOT
--- a/thys/Zeta_Function/ROOT
+++ b/thys/Zeta_Function/ROOT
@@ -1,23 +1,24 @@
 chapter AFP
 
 session Zeta_Function (AFP) = Dirichlet_Series +
   options [timeout = 600]
   sessions
+    "Pure-ex"
     Euler_MacLaurin
     Bernoulli
     "HOL-Library"
     "HOL-Real_Asymp"
     Dirichlet_Series
     Winding_Number_Eval
   theories [document=false]
     "Euler_MacLaurin.Euler_MacLaurin"
     "Bernoulli.Bernoulli_Zeta"
     "HOL-Library.Landau_Symbols"
     "Dirichlet_Series.Dirichlet_Series_Analysis"
   theories
     Zeta_Function
     Zeta_Laurent_Expansion
     Hadjicostas_Chapman
   document_files
     "root.tex"
     "root.bib"
diff --git a/thys/Zeta_Function/Zeta_Function.thy b/thys/Zeta_Function/Zeta_Function.thy
--- a/thys/Zeta_Function/Zeta_Function.thy
+++ b/thys/Zeta_Function/Zeta_Function.thy
@@ -1,3703 +1,3704 @@
 (*
     File:      Zeta_Function.thy
     Author:    Manuel Eberl, TU München
 *)
 section \<open>The Hurwitz and Riemann $\zeta$ functions\<close>
 theory Zeta_Function
 imports
   "Euler_MacLaurin.Euler_MacLaurin"
   "Bernoulli.Bernoulli_Zeta"
   "Dirichlet_Series.Dirichlet_Series_Analysis"
   "Winding_Number_Eval.Winding_Number_Eval"
   "HOL-Real_Asymp.Real_Asymp"
   Zeta_Library
+  "Pure-ex.Guess"
 begin
 
 subsection \<open>Preliminary facts\<close>
 
 (* TODO Move once Landau symbols are in the distribution *)
 lemma holomorphic_on_extend:
   assumes "f holomorphic_on S - {\<xi>}" "\<xi> \<in> interior S" "f \<in> O[at \<xi>](\<lambda>_. 1)"
   shows   "(\<exists>g. g holomorphic_on S \<and> (\<forall>z\<in>S - {\<xi>}. g z = f z))"
   by (subst holomorphic_on_extend_bounded) (insert assms, auto elim!: landau_o.bigE)
 
 lemma removable_singularities:
   assumes "finite X" "X \<subseteq> interior S" "f holomorphic_on (S - X)"
   assumes "\<And>z. z \<in> X \<Longrightarrow> f \<in> O[at z](\<lambda>_. 1)"
   shows   "\<exists>g. g holomorphic_on S \<and> (\<forall>z\<in>S-X. g z = f z)"
   using assms
 proof (induction arbitrary: f rule: finite_induct)
   case empty
   thus ?case by auto
 next
   case (insert z0 X f)
   from insert.prems and insert.hyps have z0: "z0 \<in> interior (S - X)"
     by (auto simp: interior_diff finite_imp_closed)
   hence "\<exists>g. g holomorphic_on (S - X) \<and> (\<forall>z\<in>S - X - {z0}. g z = f z)"
     using insert.prems insert.hyps by (intro holomorphic_on_extend) auto
   then obtain g where g: "g holomorphic_on (S - X)" "\<forall>z\<in>S - X - {z0}. g z = f z" by blast
   have "\<exists>h. h holomorphic_on S \<and> (\<forall>z\<in>S - X. h z = g z)"
   proof (rule insert.IH)
     fix z0' assume z0': "z0' \<in> X"
     hence "eventually (\<lambda>z. z \<in> interior S - (X - {z0'}) - {z0}) (nhds z0')"
       using insert.prems insert.hyps
       by (intro eventually_nhds_in_open open_Diff finite_imp_closed) auto
     hence ev: "eventually (\<lambda>z. z \<in> S - X - {z0}) (at z0')"
       unfolding eventually_at_filter 
       by eventually_elim (insert z0' insert.hyps interior_subset[of S], auto)
     have "g \<in> \<Theta>[at z0'](f)"
       by (intro bigthetaI_cong eventually_mono[OF ev]) (insert g, auto)
     also have "f \<in> O[at z0'](\<lambda>_. 1)"
       using z0' by (intro insert.prems) auto
     finally show "g \<in> \<dots>" .
   qed (insert insert.prems g, auto)
   then obtain h where "h holomorphic_on S" "\<forall>z\<in>S - X. h z = g z" by blast
   with g have "h holomorphic_on S" "\<forall>z\<in>S - insert z0 X. h z = f z" by auto
   thus ?case by blast
 qed
 
 lemma continuous_imp_bigo_1:
   assumes "continuous (at x within A) f"
   shows   "f \<in> O[at x within A](\<lambda>_. 1)"
 proof (rule bigoI_tendsto)
   from assms show "((\<lambda>x. f x / 1) \<longlongrightarrow> f x) (at x within A)"
     by (auto simp: continuous_within)
 qed auto
 
 lemma taylor_bigo_linear:
   assumes "f field_differentiable at x0 within A"
   shows   "(\<lambda>x. f x - f x0) \<in> O[at x0 within A](\<lambda>x. x - x0)"
 proof -
   from assms obtain f' where "(f has_field_derivative f') (at x0 within A)"
     by (auto simp: field_differentiable_def)
   hence "((\<lambda>x. (f x - f x0) / (x - x0)) \<longlongrightarrow> f') (at x0 within A)"
     by (auto simp: has_field_derivative_iff)
   thus ?thesis by (intro bigoI_tendsto[where c = f']) (auto simp: eventually_at_filter)
 qed
 (* END TODO *)
 
 (* TODO Move? *)
 lemma powr_add_minus_powr_asymptotics:
   fixes a z :: complex 
   shows "((\<lambda>z. ((1 + z) powr a - 1) / z) \<longlongrightarrow> a) (at 0)"
 proof (rule Lim_transform_eventually)
   have "eventually (\<lambda>z::complex. z \<in> ball 0 1 - {0}) (at 0)"
     using eventually_at_ball'[of 1 "0::complex" UNIV] by (simp add: dist_norm)
   thus "eventually (\<lambda>z. (\<Sum>n. (a gchoose (Suc n)) * z ^ n) = ((1 + z) powr a - 1) / z) (at 0)"
   proof eventually_elim
     case (elim z)
     hence "(\<lambda>n. (a gchoose n) * z ^ n) sums (1 + z) powr a"
       by (intro gen_binomial_complex) auto
     hence "(\<lambda>n. (a gchoose (Suc n)) * z ^ (Suc n)) sums ((1 + z) powr a - 1)"
       by (subst sums_Suc_iff) simp_all
     also have "(\<lambda>n. (a gchoose (Suc n)) * z ^ (Suc n)) = (\<lambda>n. z * ((a gchoose (Suc n)) * z ^ n))"
       by (simp add: algebra_simps)
     finally have "(\<lambda>n. (a gchoose (Suc n)) * z ^ n) sums (((1 + z) powr a - 1) / z)"
       by (rule sums_mult_D) (use elim in auto)
     thus ?case by (simp add: sums_iff)
   qed
 next
   have "conv_radius (\<lambda>n. a gchoose (n + 1)) = conv_radius (\<lambda>n. a gchoose n)"
     using conv_radius_shift[of "\<lambda>n. a gchoose n" 1] by simp
   hence "continuous_on (cball 0 (1/2)) (\<lambda>z. \<Sum>n. (a gchoose (Suc n)) * (z - 0) ^ n)"
     using conv_radius_gchoose[of a] by (intro powser_continuous_suminf) (simp_all)
   hence "isCont (\<lambda>z. \<Sum>n. (a gchoose (Suc n)) * z ^ n) 0"
     by (auto intro: continuous_on_interior)
   thus "(\<lambda>z. \<Sum>n. (a gchoose Suc n) * z ^ n) \<midarrow>0\<rightarrow> a"
     by (auto simp: isCont_def)
 qed
 
 lemma complex_powr_add_minus_powr_asymptotics:
   fixes s :: complex
   assumes a: "a > 0" and s: "Re s < 1"
   shows "filterlim (\<lambda>x. of_real (x + a) powr s - of_real x powr s) (nhds 0) at_top"
 proof (rule Lim_transform_eventually)
   show "eventually (\<lambda>x. ((1 + of_real (a / x)) powr s - 1) / of_real (a / x) * 
                             of_real x powr (s - 1) * a = 
                           of_real (x + a) powr s - of_real x powr s) at_top"
     (is "eventually (\<lambda>x. ?f x / ?g x * ?h x * _ = _) _") using eventually_gt_at_top[of a]
   proof eventually_elim
     case (elim x)
     have "?f x / ?g x * ?h x * a = ?f x * (a * ?h x / ?g x)" by simp
     also have "a * ?h x / ?g x = of_real x powr s"
       using elim a by (simp add: powr_diff)
     also have "?f x * \<dots> = of_real (x + a) powr s - of_real x powr s"
       using a elim by (simp add: algebra_simps powr_times_real [symmetric])
     finally show ?case .
   qed
 
   have "filterlim (\<lambda>x. complex_of_real (a / x)) (nhds (complex_of_real 0)) at_top"
     by (intro tendsto_of_real real_tendsto_divide_at_top[OF tendsto_const] filterlim_ident)
   hence "filterlim (\<lambda>x. complex_of_real (a / x)) (at 0) at_top"
     using a by (intro filterlim_atI) auto
   hence "((\<lambda>x. ?f x / ?g x * ?h x * a) \<longlongrightarrow> s * 0 * a) at_top" using s
     by (intro tendsto_mult filterlim_compose[OF powr_add_minus_powr_asymptotics]
               tendsto_const tendsto_neg_powr_complex_of_real filterlim_ident) auto
   thus "((\<lambda>x. ?f x / ?g x * ?h x * a) \<longlongrightarrow> 0) at_top" by simp
 qed
 (* END TODO *)
 
 lemma summable_zeta:
   assumes "Re s > 1"
   shows   "summable (\<lambda>n. of_nat (Suc n) powr -s)"
 proof -
   have "summable (\<lambda>n. exp (complex_of_real (ln (real (Suc n))) * - s))" (is "summable ?f")
     by (subst summable_Suc_iff, rule summable_complex_powr_iff) (use assms in auto)
   also have "?f = (\<lambda>n. of_nat (Suc n) powr -s)"
     by (simp add: powr_def algebra_simps del: of_nat_Suc)
   finally show ?thesis .
 qed
 
 lemma summable_zeta_real:
   assumes "x > 1"
   shows   "summable (\<lambda>n. real (Suc n) powr -x)"
 proof -
   have "summable (\<lambda>n. of_nat (Suc n) powr -complex_of_real x)"
     using assms by (intro summable_zeta) simp_all
   also have "(\<lambda>n. of_nat (Suc n) powr -complex_of_real x) = (\<lambda>n. of_real (real (Suc n) powr -x))"
     by (subst powr_Reals_eq) simp_all
   finally show ?thesis
     by (subst (asm) summable_complex_of_real)
 qed
 
 lemma summable_hurwitz_zeta:
   assumes "Re s > 1" "a > 0"
   shows   "summable (\<lambda>n. (of_nat n + of_real a) powr -s)"
 proof -
   have "summable (\<lambda>n. (of_nat (Suc n) + of_real a) powr -s)"
   proof (rule summable_comparison_test' [OF summable_zeta_real [OF assms(1)]] )
     fix n :: nat
     have "norm ((of_nat (Suc n) + of_real a) powr -s) = (real (Suc n) + a) powr - Re s"
       (is "?N = _") using assms by (simp add: norm_powr_real_powr)
     also have "\<dots> \<le> real (Suc n) powr -Re s"
       using assms by (intro powr_mono2') auto
     finally show "?N \<le> \<dots>" .
   qed
   thus ?thesis by (subst (asm) summable_Suc_iff)
 qed
 
 lemma summable_hurwitz_zeta_real:
   assumes "x > 1" "a > 0"
   shows   "summable (\<lambda>n. (real n + a) powr -x)"
 proof -
   have "summable (\<lambda>n. (of_nat n + of_real a) powr -complex_of_real x)"
     using assms by (intro summable_hurwitz_zeta) simp_all
   also have "(\<lambda>n. (of_nat n + of_real a) powr -complex_of_real x) = 
                (\<lambda>n. of_real ((real n + a) powr -x))"
     using assms by (subst powr_Reals_eq) simp_all
   finally show ?thesis
     by (subst (asm) summable_complex_of_real)
 qed
 
 
 
 subsection \<open>Definitions\<close>
 
 text \<open>
   We use the Euler--MacLaurin summation formula to express $\zeta(s,a) - \frac{a^{1-s}}{s-1}$ as
   a polynomial plus some remainder term, which is an integral over a function of 
   order $O(-1-2n-\mathfrak{R}(s))$. It is then clear that this integral converges uniformly
   to an analytic function in $s$ for all $s$ with $\mathfrak{R}(s) > -2n$.
 \<close>
 definition pre_zeta_aux :: "nat \<Rightarrow> real \<Rightarrow> complex \<Rightarrow> complex" where
   "pre_zeta_aux N a s = a powr - s / 2 +
     (\<Sum>i=1..N. (bernoulli (2 * i) / fact (2 * i)) *\<^sub>R (pochhammer s (2*i - 1) * 
                  of_real a powr (- s - of_nat (2*i - 1)))) +
     EM_remainder (Suc (2*N)) 
       (\<lambda>x. -(pochhammer s (Suc (2*N)) * of_real (x + a) powr (- 1 - 2*N - s))) 0"
 
 text \<open>
   By iterating the above construction long enough, we can extend this to the entire
   complex plane.
 \<close>
 definition pre_zeta :: "real \<Rightarrow> complex \<Rightarrow> complex" where
   "pre_zeta a s = pre_zeta_aux (nat (1 - \<lceil>Re s / 2\<rceil>)) a s"
 
 text \<open>
   We can then obtain the Hurwitz $\zeta$ function by adding back the pole at 1.
   Note that it is not necessary to trust that this somewhat complicated definition is,
   in fact, the correct one, since we will later show that this Hurwitz zeta function
   fulfils
   \[\zeta(s,a) = \sum_{n=0}^\infty \frac{1}{(n + a)^s}\]
   and is analytic on $\mathbb{C}\setminus \{1\}$, which uniquely defines the function
   due to analytic continuation. It is therefore obvious that any alternative definition
   that is analytic on $\mathbb{C}\setminus \{1\}$ and satisfies the above equation 
   must be equal to our Hurwitz $\zeta$ function.
 \<close>
 definition hurwitz_zeta :: "real \<Rightarrow> complex \<Rightarrow> complex" where
   "hurwitz_zeta a s = (if s = 1 then 0 else pre_zeta a s + of_real a powr (1 - s) / (s - 1))"
 
 text \<open>
   The Riemann $\zeta$ function is simply the Hurwitz $\zeta$ function with $a = 1$.
 \<close>
 definition zeta :: "complex \<Rightarrow> complex" where
   "zeta = hurwitz_zeta 1"
 
 
 text \<open>
   We define the $\zeta$ functions as 0 at their poles. To avoid confusion, these facts
   are not added as simplification rules by default.
 \<close>
 lemma hurwitz_zeta_1: "hurwitz_zeta c 1 = 0"
   by (simp add: hurwitz_zeta_def)
 
 lemma zeta_1: "zeta 1 = 0"
   by (simp add: zeta_def hurwitz_zeta_1)
 
 lemma zeta_minus_pole_eq: "s \<noteq> 1 \<Longrightarrow> zeta s - 1 / (s - 1) = pre_zeta 1 s"
   by (simp add: zeta_def hurwitz_zeta_def)
 
 
 context
 begin
 
 private lemma holomorphic_pre_zeta_aux':
   assumes "a > 0" "bounded U" "open U" "U \<subseteq> {s. Re s > \<sigma>}" and \<sigma>: "\<sigma> > - 2 * real n"
   shows   "pre_zeta_aux n a holomorphic_on U" unfolding pre_zeta_aux_def
 proof (intro holomorphic_intros)
   define C :: real where "C = max 0 (Sup ((\<lambda>s. norm (pochhammer s (Suc (2 * n)))) ` closure U))"
   have "compact (closure U)" 
     using assms by (auto simp: compact_eq_bounded_closed)
   hence "compact ((\<lambda>s. norm (pochhammer s (Suc (2 * n)))) ` closure U)"
     by (rule compact_continuous_image [rotated]) (auto intro!: continuous_intros)
   hence "bounded ((\<lambda>s. norm (pochhammer s (Suc (2 * n)))) ` closure U)"
     by (simp add: compact_eq_bounded_closed)
   hence C: "cmod (pochhammer s (Suc (2 * n))) \<le> C" if "s \<in> U" for s
     using that closure_subset[of U] unfolding C_def 
     by (intro max.coboundedI2 cSup_upper bounded_imp_bdd_above) (auto simp: image_iff)
   have C' [simp]: "C \<ge> 0" by (simp add: C_def)
 
   let ?g = "\<lambda>(x::real). C * (x + a) powr (- 1 - 2 * of_nat n - \<sigma>)"
   let ?G = "\<lambda>(x::real). C / (- 2 * of_nat n - \<sigma>) * (x + a) powr (- 2 * of_nat n - \<sigma>)"  
   define poch' where "poch' = deriv (\<lambda>z::complex. pochhammer z (Suc (2 * n)))"
   have [derivative_intros]:
     "((\<lambda>z. pochhammer z (Suc (2 * n))) has_field_derivative poch' z) (at z within A)" 
     for z :: complex and A unfolding poch'_def
     by (rule holomorphic_derivI [OF holomorphic_pochhammer [of _ UNIV]]) auto
   have A: "continuous_on A poch'" for A unfolding poch'_def 
     by (rule continuous_on_subset[OF _ subset_UNIV], 
         intro holomorphic_on_imp_continuous_on holomorphic_deriv)
         (auto intro: holomorphic_pochhammer) 
   note [continuous_intros] = continuous_on_compose2[OF this _ subset_UNIV]
 
   define f' where "f' = (\<lambda>z t. - (poch' z * complex_of_real (t + a) powr (- 1 - 2 * of_nat n - z) -
                           Ln (complex_of_real (t + a)) * complex_of_real (t + a) powr 
                             (- 1 - 2 * of_nat n - z) * pochhammer z (Suc (2 * n))))"
 
   show "(\<lambda>z. EM_remainder (Suc (2 * n)) (\<lambda>x. - (pochhammer z (Suc (2 * n)) *
                   complex_of_real (x + a) powr (- 1 - 2 * of_nat n - z))) 0) holomorphic_on
     U" unfolding pre_zeta_aux_def
   proof (rule holomorphic_EM_remainder[of _ ?G ?g _ _ f'], goal_cases)
     case (1 x)
     show ?case
       by (insert 1 \<sigma> \<open>a > 0\<close>, rule derivative_eq_intros refl | simp)+
          (auto simp: field_simps powr_diff powr_add powr_minus)
   next
     case (2 z t x)
     note [derivative_intros] = has_field_derivative_powr_right [THEN DERIV_chain2]
     show ?case
       by (insert 2 \<sigma> \<open>a > 0\<close>, (rule derivative_eq_intros refl | (simp add: add_eq_0_iff; fail))+)
          (simp add: f'_def)
   next
     case 3
     hence *: "complex_of_real x + complex_of_real a \<notin> \<real>\<^sub>\<le>\<^sub>0" if "x \<ge> 0" for x
       using nonpos_Reals_of_real_iff[of "x+a", unfolded of_real_add] that \<open>a > 0\<close> by auto
     show ?case using \<open>a > 0\<close> and * unfolding f'_def
       by (auto simp: case_prod_unfold add_eq_0_iff intro!: continuous_intros)
   next
     case (4 b c z e)
     have "- 2 * real n < \<sigma>" by (fact \<sigma>)
     also from 4 assms have "\<sigma> < Re z" by auto
     finally show ?case using assms 4
       by (intro integrable_continuous_real continuous_intros) (auto simp: add_eq_0_iff)
   next
     case (5 t x s)
     thus ?case using \<open>a > 0\<close>
       by (intro integrable_EM_remainder') (auto intro!: continuous_intros simp: add_eq_0_iff)
   next
     case 6
     from \<sigma> have "(\<lambda>y. C / (-2 * real n - \<sigma>) * (a + y) powr (-2 * real n - \<sigma>)) \<longlonglongrightarrow> 0"
       by (intro tendsto_mult_right_zero tendsto_neg_powr
             filterlim_real_sequentially filterlim_tendsto_add_at_top [OF tendsto_const]) auto
     thus ?case unfolding convergent_def by (auto simp: add_ac)
   next
     case 7
     show ?case 
     proof (intro eventually_mono [OF eventually_ge_at_top[of 1]] ballI)
       fix x :: real and s :: complex assume x: "x \<ge> 1" and s: "s \<in> U"
       have "norm (- (pochhammer s (Suc (2 * n)) * of_real (x + a) powr (- 1 - 2 * of_nat n - s))) =
               norm (pochhammer s (Suc (2 * n))) * (x + a) powr (-1 - 2 * of_nat n - Re s)"
         (is "?N = _") using 7 \<open>a > 0\<close> x by (simp add: norm_mult norm_powr_real_powr)
       also have "\<dots> \<le> ?g x"
         using 7 assms x s \<open>a > 0\<close> by (intro mult_mono C powr_mono) auto
       finally show "?N \<le> ?g x" .
     qed
   qed (insert assms, auto)
 qed (insert assms, auto)
 
 lemma analytic_pre_zeta_aux:
   assumes "a > 0"
   shows   "pre_zeta_aux n a analytic_on {s. Re s > - 2 * real n}"
   unfolding analytic_on_def
 proof
   fix s assume s: "s \<in> {s. Re s > - 2 * real n}"
   define \<sigma> where "\<sigma> = (Re s - 2 * real n) / 2"
   with s have \<sigma>: "\<sigma> > - 2 * real n" 
     by (simp add: \<sigma>_def field_simps)
   from s have s': "s \<in> {s. Re s > \<sigma>}"
     by (auto simp: \<sigma>_def field_simps)
 
   have "open {s. Re s > \<sigma>}"
     by (rule open_halfspace_Re_gt)
   with s' obtain \<epsilon> where "\<epsilon> > 0" "ball s \<epsilon> \<subseteq> {s. Re s > \<sigma>}"
     unfolding open_contains_ball by blast
   with \<sigma> have "pre_zeta_aux n a holomorphic_on ball s \<epsilon>"
     by (intro holomorphic_pre_zeta_aux' [OF assms, of _ \<sigma>]) auto
   with \<open>\<epsilon> > 0\<close> show "\<exists>e>0. pre_zeta_aux n a holomorphic_on ball s e"
     by blast
 qed
 end
 
 context
   fixes s :: complex and N :: nat and \<zeta> :: "complex \<Rightarrow> complex" and a :: real
   assumes s: "Re s > 1" and a: "a > 0"
   defines "\<zeta> \<equiv> (\<lambda>s. \<Sum>n. (of_nat n + of_real a) powr -s)"
 begin
 
 interpretation \<zeta>: euler_maclaurin_nat'
   "\<lambda>x. of_real (x + a) powr (1 - s) / (1 - s)" "\<lambda>x. of_real (x + a) powr -s" 
   "\<lambda>n x. (-1) ^ n * pochhammer s n * of_real (x + a) powr -(s + n)" 
   0 N "\<zeta> s" "{}"
 proof (standard, goal_cases)
   case 2
   show ?case by (simp add: powr_minus field_simps)
 next
   case (3 k)
   have "complex_of_real x + complex_of_real a = 0 \<longleftrightarrow> x = -a" for x
     by (simp only: of_real_add [symmetric] of_real_eq_0_iff add_eq_0_iff2)
   with a s show ?case
     by (intro continuous_intros) (auto simp: add_nonneg_nonneg)
 next
   case (4 k x)
   with a have "0 < x + a" by simp
   hence *: "complex_of_real x + complex_of_real a \<notin> \<real>\<^sub>\<le>\<^sub>0"
     using nonpos_Reals_of_real_iff[of "x+a", unfolded of_real_add] by auto
   have **: "pochhammer z (Suc n) = - pochhammer z n * (-z - of_nat n :: complex)" for z n
     by (simp add: pochhammer_rec' field_simps)
   show "((\<lambda>x. (- 1) ^ k * pochhammer s k * of_real (x + a) powr - (s + of_nat k)) 
           has_vector_derivative (- 1) ^ Suc k * pochhammer s (Suc k) *
             of_real (x + a) powr - (s + of_nat (Suc k))) (at x)"
     by (insert 4 *, (rule has_vector_derivative_real_field derivative_eq_intros refl | simp)+)
        (auto simp: divide_simps powr_add powr_diff powr_minus **)
 next
   case 5
   with s a show ?case 
     by (auto intro!: continuous_intros simp: minus_equation_iff add_eq_0_iff)
 next
   case (6 x)
   with a have "0 < x + a" by simp
   hence *: "complex_of_real x + complex_of_real a \<notin> \<real>\<^sub>\<le>\<^sub>0"
     using nonpos_Reals_of_real_iff[of "x+a", unfolded of_real_add] by auto
   show ?case unfolding of_real_add
     by (insert 6 s *, (rule has_vector_derivative_real_field derivative_eq_intros refl | 
           force simp add: minus_equation_iff)+)
 next
   case 7
   from s a have "(\<lambda>k. (of_nat k + of_real a) powr -s) sums \<zeta> s"
     unfolding \<zeta>_def by (intro summable_sums summable_hurwitz_zeta) auto
   hence 1: "(\<lambda>b. (\<Sum>k=0..b. (of_nat k + of_real a) powr -s)) \<longlonglongrightarrow> \<zeta> s"
     by (simp add: sums_def')
 
   {
     fix z assume "Re z < 0"
     hence "((\<lambda>b. (a + real b) powr Re z) \<longlongrightarrow> 0) at_top"
       by (intro tendsto_neg_powr filterlim_tendsto_add_at_top filterlim_real_sequentially) auto    
     also have "(\<lambda>b. (a + real b) powr Re z) = (\<lambda>b. norm ((of_nat b + a) powr z))"
       using a by (subst norm_powr_real_powr) (auto simp: add_ac)
     finally have "((\<lambda>b. (of_nat b + a) powr z) \<longlongrightarrow> 0) at_top" 
       by (subst (asm) tendsto_norm_zero_iff) simp
   } note * = this
   have "(\<lambda>b. (of_nat b + a) powr (1 - s) / (1 - s)) \<longlonglongrightarrow> 0 / (1 - s)"
     using s by (intro tendsto_divide tendsto_const *) auto
   hence 2: "(\<lambda>b. (of_nat b + a) powr (1 - s) / (1 - s)) \<longlonglongrightarrow> 0"
     by simp
 
   have "(\<lambda>b. (\<Sum>i<2 * N + 1. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R
              ((- 1) ^ i * pochhammer s i * (of_nat b + a) powr -(s + of_nat i))))
           \<longlonglongrightarrow> (\<Sum>i<2 * N + 1. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R 
                    ((- 1) ^ i * pochhammer s i * 0))"
     using s by (intro tendsto_intros *) auto
   hence 3: "(\<lambda>b. (\<Sum>i<2 * N + 1. (bernoulli' (Suc i) / fact (Suc i)) *\<^sub>R
               ((- 1) ^ i * pochhammer s i * (of_nat b + a) powr -(s + of_nat i)))) \<longlonglongrightarrow> 0" 
     by simp
 
   from tendsto_diff[OF tendsto_diff[OF 1 2] 3]
   show ?case by simp
 qed simp_all
 
 text \<open>
   The pre-$\zeta$ functions agree with the infinite sum that is used to define the $\zeta$
   function for $\mathfrak{R}(s)>1$.
 \<close>
 lemma pre_zeta_aux_conv_zeta:
   "pre_zeta_aux N a s = \<zeta> s + a powr (1 - s) / (1 - s)"
 proof -
   let ?R = "(\<Sum>i=1..N. ((bernoulli (2*i) / fact (2*i)) *\<^sub>R pochhammer s (2*i - 1) * of_real a powr (-s - (2*i-1))))"
   let ?S = "EM_remainder (Suc (2 * N)) (\<lambda>x. - (pochhammer s (Suc (2*N)) *
               of_real (x + a) powr (- 1 - 2 * of_nat N - s))) 0"
   from \<zeta>.euler_maclaurin_strong_nat'[OF le_refl, simplified]
   have "of_real a powr -s = a powr (1 - s) / (1 - s) + \<zeta> s + a powr -s / 2 + (-?R) - ?S"
     unfolding sum_negf [symmetric] by (simp add: scaleR_conv_of_real pre_zeta_aux_def mult_ac)
   thus ?thesis unfolding pre_zeta_aux_def 
     (* TODO: Field_as_Ring causes some problems with field_simps vs. div_mult_self *)
     by (simp add: field_simps del: div_mult_self3 div_mult_self4 div_mult_self2 div_mult_self1)
 qed
 
 end
 
 
 text \<open>
   Since all of the partial pre-$\zeta$ functions are analytic and agree in the halfspace with 
   $\mathfrak R(s)>0$, they must agree in their entire domain.
 \<close>
 lemma pre_zeta_aux_eq:
   assumes "m \<le> n" "a > 0" "Re s > -2 * real m"
   shows   "pre_zeta_aux m a s = pre_zeta_aux n a s"
 proof -
   have "pre_zeta_aux n a s - pre_zeta_aux m a s = 0"
   proof (rule analytic_continuation[of "\<lambda>s. pre_zeta_aux n a s - pre_zeta_aux m a s"])
     show "(\<lambda>s. pre_zeta_aux n a s - pre_zeta_aux m a s) holomorphic_on {s. Re s > -2 * real m}"
       using assms by (intro holomorphic_intros analytic_imp_holomorphic 
                         analytic_on_subset[OF analytic_pre_zeta_aux]) auto
   next
     fix s assume "s \<in> {s. Re s > 1}"
     with \<open>a > 0\<close> show "pre_zeta_aux n a s - pre_zeta_aux m a s = 0"
       by (simp add: pre_zeta_aux_conv_zeta)
   next
     have "2 \<in> {s. Re s > 1}" by simp
     also have "\<dots> = interior \<dots>"
       by (intro interior_open [symmetric] open_halfspace_Re_gt)
     finally show "2 islimpt {s. Re s > 1}"
       by (rule interior_limit_point)
   next
     show "connected {s. Re s > -2 * real m}"
       using convex_halfspace_gt[of "-2 * real m" "1::complex"]
       by (intro convex_connected) auto
   qed (insert assms, auto simp: open_halfspace_Re_gt)
   thus ?thesis by simp
 qed
 
 lemma pre_zeta_aux_eq':
   assumes "a > 0" "Re s > -2 * real m" "Re s > -2 * real n"
   shows   "pre_zeta_aux m a s = pre_zeta_aux n a s"
 proof (cases m n rule: linorder_cases)
   case less
   with assms show ?thesis by (intro pre_zeta_aux_eq) auto
 next
   case greater
   with assms show ?thesis by (subst eq_commute, intro pre_zeta_aux_eq) auto
 qed auto
 
 lemma pre_zeta_aux_eq_pre_zeta:
   assumes "Re s > -2 * real n" and "a > 0"
   shows   "pre_zeta_aux n a s = pre_zeta a s"
   unfolding pre_zeta_def
 proof (intro pre_zeta_aux_eq')
   from assms show "- 2 * real (nat (1 - \<lceil>Re s / 2\<rceil>)) < Re s"
     by linarith
 qed (insert assms, simp_all)
 
 text \<open>
   This means that the idea of iterating that construction infinitely does yield
   a well-defined entire function.
 \<close>
 lemma analytic_pre_zeta: 
   assumes "a > 0"
   shows   "pre_zeta a analytic_on A"
   unfolding analytic_on_def
 proof
   fix s assume "s \<in> A"
   let ?B = "{s'. Re s' > of_int \<lfloor>Re s\<rfloor> - 1}"
   have s: "s \<in> ?B" by simp linarith?
   moreover have "open ?B" by (rule open_halfspace_Re_gt)
   ultimately obtain \<epsilon> where \<epsilon>: "\<epsilon> > 0" "ball s \<epsilon> \<subseteq> ?B"
     unfolding open_contains_ball by blast
   define C where "C = ball s \<epsilon>"
 
   note analytic = analytic_on_subset[OF analytic_pre_zeta_aux]
   have "pre_zeta_aux (nat \<lceil>- Re s\<rceil> + 2) a holomorphic_on C"
   proof (intro analytic_imp_holomorphic analytic subsetI assms, goal_cases)
     case (1 w)
     with \<epsilon> have "w \<in> ?B" by (auto simp: C_def)
     thus ?case by (auto simp: ceiling_minus)
   qed
   also have "?this \<longleftrightarrow> pre_zeta a holomorphic_on C"
   proof (intro holomorphic_cong refl pre_zeta_aux_eq_pre_zeta assms)
     fix w assume "w \<in> C"
     with \<epsilon> have w: "w \<in> ?B" by (auto simp: C_def)
     thus " - 2 * real (nat \<lceil>- Re s\<rceil> + 2) < Re w"
       by (simp add: ceiling_minus)
   qed
   finally show "\<exists>e>0. pre_zeta a holomorphic_on ball s e"
     using \<open>\<epsilon> > 0\<close> unfolding C_def by blast
 qed
 
 lemma holomorphic_pre_zeta [holomorphic_intros]:
   "f holomorphic_on A \<Longrightarrow> a > 0 \<Longrightarrow> (\<lambda>z. pre_zeta a (f z)) holomorphic_on A"
   using holomorphic_on_compose [OF _ analytic_imp_holomorphic [OF analytic_pre_zeta], of f]
   by (simp add: o_def)
 
 corollary continuous_on_pre_zeta:
   "a > 0 \<Longrightarrow> continuous_on A (pre_zeta a)"
   by (intro holomorphic_on_imp_continuous_on holomorphic_intros) auto
 
 corollary continuous_on_pre_zeta' [continuous_intros]:
   "continuous_on A f \<Longrightarrow> a > 0 \<Longrightarrow> continuous_on A (\<lambda>x. pre_zeta a (f x))"
   using continuous_on_compose2 [OF continuous_on_pre_zeta, of a A f "f ` A"]
   by (auto simp: image_iff)
 
 corollary continuous_pre_zeta [continuous_intros]:
   "a > 0 \<Longrightarrow> continuous (at s within A) (pre_zeta a)"
   by (rule continuous_within_subset[of _ UNIV])
      (insert continuous_on_pre_zeta[of a UNIV], 
       auto simp: continuous_on_eq_continuous_at open_Compl)
 
 corollary continuous_pre_zeta' [continuous_intros]:
   "a > 0 \<Longrightarrow> continuous (at s within A) f \<Longrightarrow>
      continuous (at s within A) (\<lambda>s. pre_zeta a (f s))"
   using continuous_within_compose3[OF continuous_pre_zeta, of a s A f] by auto
 
 
 text \<open>
   It is now obvious that $\zeta$ is holomorphic everywhere except 1, where it has a 
   simple pole with residue 1, which we can simply read off.
 \<close>
 theorem holomorphic_hurwitz_zeta: 
   assumes "a > 0" "1 \<notin> A"
   shows   "hurwitz_zeta a holomorphic_on A"
 proof -
   have "(\<lambda>s. pre_zeta a s + complex_of_real a powr (1 - s) / (s - 1)) holomorphic_on A"
     using assms by (auto intro!: holomorphic_intros)
   also from assms have "?this \<longleftrightarrow> ?thesis"
     by (intro holomorphic_cong) (auto simp: hurwitz_zeta_def)
   finally show ?thesis .
 qed
 
 corollary holomorphic_hurwitz_zeta' [holomorphic_intros]:
   assumes "f holomorphic_on A" and "a > 0" and "\<And>z. z \<in> A \<Longrightarrow> f z \<noteq> 1"
   shows   "(\<lambda>x. hurwitz_zeta a (f x)) holomorphic_on A"
 proof -
   have "hurwitz_zeta a \<circ> f holomorphic_on A" using assms
     by (intro holomorphic_on_compose_gen[of _ _ _ "f ` A"] holomorphic_hurwitz_zeta assms) auto
   thus ?thesis by (simp add: o_def)
 qed
 
 theorem holomorphic_zeta: "1 \<notin> A\<Longrightarrow> zeta holomorphic_on A"
   unfolding zeta_def by (auto intro: holomorphic_intros)
 
 corollary holomorphic_zeta' [holomorphic_intros]:
   assumes "f holomorphic_on A" and "\<And>z. z \<in> A \<Longrightarrow> f z \<noteq> 1"
   shows   "(\<lambda>x. zeta (f x)) holomorphic_on A"
   using assms unfolding zeta_def by (auto intro: holomorphic_intros)
 
 corollary analytic_hurwitz_zeta: 
   assumes "a > 0" "1 \<notin> A"
   shows   "hurwitz_zeta a analytic_on A"
 proof -
   from assms(1) have "hurwitz_zeta a holomorphic_on -{1}"
     by (rule holomorphic_hurwitz_zeta) auto
   also have "?this \<longleftrightarrow> hurwitz_zeta a analytic_on -{1}"
     by (intro analytic_on_open [symmetric]) auto
   finally show ?thesis by (rule analytic_on_subset) (insert assms, auto)
 qed
 
 corollary analytic_zeta: "1 \<notin> A \<Longrightarrow> zeta analytic_on A"
   unfolding zeta_def by (rule analytic_hurwitz_zeta) auto
 
 corollary continuous_on_hurwitz_zeta:
   "a > 0 \<Longrightarrow> 1 \<notin> A \<Longrightarrow> continuous_on A (hurwitz_zeta a)"
   by (intro holomorphic_on_imp_continuous_on holomorphic_intros) auto
 
 corollary continuous_on_hurwitz_zeta' [continuous_intros]:
   "continuous_on A f \<Longrightarrow> a > 0 \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> 1) \<Longrightarrow> 
      continuous_on A (\<lambda>x. hurwitz_zeta a (f x))"
   using continuous_on_compose2 [OF continuous_on_hurwitz_zeta, of a "f ` A" A f]
   by (auto simp: image_iff)
 
 corollary continuous_on_zeta: "1 \<notin> A \<Longrightarrow> continuous_on A zeta"
   by (intro holomorphic_on_imp_continuous_on holomorphic_intros) auto
 
 corollary continuous_on_zeta' [continuous_intros]:
   "continuous_on A f \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> 1) \<Longrightarrow> 
      continuous_on A (\<lambda>x. zeta (f x))"
   using continuous_on_compose2 [OF continuous_on_zeta, of "f ` A" A f]
   by (auto simp: image_iff)
 
 corollary continuous_hurwitz_zeta [continuous_intros]:
   "a > 0 \<Longrightarrow> s \<noteq> 1 \<Longrightarrow> continuous (at s within A) (hurwitz_zeta a)"
   by (rule continuous_within_subset[of _ UNIV])
      (insert continuous_on_hurwitz_zeta[of a "-{1}"], 
       auto simp: continuous_on_eq_continuous_at open_Compl)
 
 corollary continuous_hurwitz_zeta' [continuous_intros]:
   "a > 0 \<Longrightarrow> f s \<noteq> 1 \<Longrightarrow> continuous (at s within A) f \<Longrightarrow>
      continuous (at s within A) (\<lambda>s. hurwitz_zeta a (f s))"
   using continuous_within_compose3[OF continuous_hurwitz_zeta, of a f s A] by auto
 
 corollary continuous_zeta [continuous_intros]:
   "s \<noteq> 1 \<Longrightarrow> continuous (at s within A) zeta"
   unfolding zeta_def by (intro continuous_intros) auto
 
 corollary continuous_zeta' [continuous_intros]:
   "f s \<noteq> 1 \<Longrightarrow> continuous (at s within A) f \<Longrightarrow> continuous (at s within A) (\<lambda>s. zeta (f s))"
   unfolding zeta_def by (intro continuous_intros) auto
 
 corollary field_differentiable_at_zeta:
   assumes "s \<noteq> 1"
   shows "zeta field_differentiable at s"
 proof -
   have "zeta holomorphic_on (- {1})" using holomorphic_zeta by force
   moreover have "open (-{1} :: complex set)" by (intro open_Compl) auto
   ultimately show ?thesis using assms
     by (auto simp add: holomorphic_on_open open_halfspace_Re_gt open_Diff field_differentiable_def)
 qed
 
 theorem is_pole_hurwitz_zeta:
   assumes "a > 0"
   shows   "is_pole (hurwitz_zeta a) 1"
 proof -
   from assms have "continuous_on UNIV (pre_zeta a)"
     by (intro holomorphic_on_imp_continuous_on analytic_imp_holomorphic analytic_pre_zeta)
   hence "isCont (pre_zeta a) 1"
     by (auto simp: continuous_on_eq_continuous_at)
   hence *: "pre_zeta a \<midarrow>1\<rightarrow> pre_zeta a 1"
     by (simp add: isCont_def)
   from assms have "isCont (\<lambda>s. complex_of_real a powr (1 - s)) 1"
     by (intro isCont_powr_complex) auto
   with assms have **: "(\<lambda>s. complex_of_real a powr (1 - s)) \<midarrow>1\<rightarrow> 1" 
     by (simp add: isCont_def)
   have "(\<lambda>s::complex. s - 1) \<midarrow>1\<rightarrow> 1 - 1" by (intro tendsto_intros)
   hence "filterlim (\<lambda>s::complex. s - 1) (at 0) (at 1)"
     by (auto simp: filterlim_at eventually_at_filter)
   hence ***: "filterlim (\<lambda>s :: complex. a powr (1 - s) / (s - 1)) at_infinity (at 1)"
     by (intro filterlim_divide_at_infinity [OF **]) auto
   have "is_pole (\<lambda>s. pre_zeta a s + complex_of_real a powr (1 - s) / (s - 1)) 1"
     unfolding is_pole_def hurwitz_zeta_def by (rule tendsto_add_filterlim_at_infinity * ***)+
   also have "?this \<longleftrightarrow> ?thesis" unfolding is_pole_def
     by (intro filterlim_cong refl) (auto simp: eventually_at_filter hurwitz_zeta_def)
   finally show ?thesis .
 qed
 
 corollary is_pole_zeta: "is_pole zeta 1"
   unfolding zeta_def by (rule is_pole_hurwitz_zeta) auto
 
 theorem zorder_hurwitz_zeta: 
   assumes "a > 0"
   shows   "zorder (hurwitz_zeta a) 1 = -1"
 proof (rule zorder_eqI[of UNIV])
   fix w :: complex assume "w \<in> UNIV" "w \<noteq> 1"
   thus "hurwitz_zeta a w = (pre_zeta a w * (w - 1) + a powr (1 - w)) * (w - 1) powr (of_int (-1))"
     apply (subst (1) powr_of_int)
     by (auto simp add: hurwitz_zeta_def field_simps)
 qed (insert assms, auto intro!: holomorphic_intros)
 
 corollary zorder_zeta: "zorder zeta 1 = - 1"
   unfolding zeta_def by (rule zorder_hurwitz_zeta) auto
 
 theorem residue_hurwitz_zeta: 
   assumes "a > 0"
   shows   "residue (hurwitz_zeta a) 1 = 1"
 proof -
   note holo = analytic_imp_holomorphic[OF analytic_pre_zeta]
   have "residue (hurwitz_zeta a) 1 = residue (\<lambda>z. pre_zeta a z + a powr (1 - z) / (z - 1)) 1"
     by (intro residue_cong) (auto simp: eventually_at_filter hurwitz_zeta_def)
   also have "\<dots> = residue (\<lambda>z. a powr (1 - z) / (z - 1)) 1" using assms
     by (subst residue_add [of UNIV])
        (auto intro!: holomorphic_intros holo intro: residue_holo[of UNIV, OF _ _ holo])
   also have "\<dots> = complex_of_real a powr (1 - 1)"
     using assms by (intro residue_simple [of UNIV]) (auto intro!: holomorphic_intros)
   also from assms have "\<dots> = 1" by simp
   finally show ?thesis .
 qed
 
 corollary residue_zeta: "residue zeta 1 = 1"
   unfolding zeta_def by (rule residue_hurwitz_zeta) auto
 
 lemma zeta_bigo_at_1: "zeta \<in> O[at 1 within A](\<lambda>x. 1 / (x - 1))"
 proof -
   have "zeta \<in> \<Theta>[at 1 within A](\<lambda>s. pre_zeta 1 s + 1 / (s - 1))"
     by (intro bigthetaI_cong) (auto simp: eventually_at_filter zeta_def hurwitz_zeta_def)
   also have "(\<lambda>s. pre_zeta 1 s + 1 / (s - 1)) \<in> O[at 1 within A](\<lambda>s. 1 / (s - 1))"
   proof (rule sum_in_bigo)
     have "continuous_on UNIV (pre_zeta 1)"
       by (intro holomorphic_on_imp_continuous_on holomorphic_intros) auto
     hence "isCont (pre_zeta 1) 1" by (auto simp: continuous_on_eq_continuous_at)
     hence "continuous (at 1 within A) (pre_zeta 1)"
       by (rule continuous_within_subset) auto
     hence "pre_zeta 1 \<in> O[at 1 within A](\<lambda>_. 1)"
       by (intro continuous_imp_bigo_1) auto
     also have ev: "eventually (\<lambda>s. s \<in> ball 1 1 \<and> s \<noteq> 1 \<and> s \<in> A) (at 1 within A)"
       by (intro eventually_at_ball') auto
     have "(\<lambda>_. 1) \<in> O[at 1 within A](\<lambda>s. 1 / (s - 1))"
       by (intro landau_o.bigI[of 1] eventually_mono[OF ev]) 
          (auto simp: eventually_at_filter norm_divide dist_norm norm_minus_commute field_simps)
     finally show "pre_zeta 1 \<in> O[at 1 within A](\<lambda>s. 1 / (s - 1))" .
   qed simp_all
   finally show ?thesis .
 qed
 
 theorem
   assumes "a > 0" "Re s > 1"
   shows hurwitz_zeta_conv_suminf: "hurwitz_zeta a s = (\<Sum>n. (of_nat n + of_real a) powr -s)"
   and   sums_hurwitz_zeta: "(\<lambda>n. (of_nat n + of_real a) powr -s) sums hurwitz_zeta a s"
 proof -
   from assms have [simp]: "s \<noteq> 1" by auto
   from assms have "hurwitz_zeta a s = pre_zeta_aux 0 a s + of_real a powr (1 - s) / (s - 1)"
     by (simp add: hurwitz_zeta_def pre_zeta_def)
   also from assms have "pre_zeta_aux 0 a s = (\<Sum>n. (of_nat n + of_real a) powr -s) + 
                           of_real a powr (1 - s) / (1 - s)"
     by (intro pre_zeta_aux_conv_zeta)
   also have "\<dots> + a powr (1 - s) / (s - 1) = 
                (\<Sum>n. (of_nat n + of_real a) powr -s) + a powr (1 - s) * (1 / (1 - s) + 1 / (s - 1))"
     by (simp add: algebra_simps)
   also have "1 / (1 - s) + 1 / (s - 1) = 0" 
     by (simp add: divide_simps)
   finally show "hurwitz_zeta a s = (\<Sum>n. (of_nat n + of_real a) powr -s)" by simp
   moreover have "(\<lambda>n. (of_nat n + of_real a) powr -s) sums (\<Sum>n. (of_nat n + of_real a) powr -s)"
     by (intro summable_sums summable_hurwitz_zeta assms)
   ultimately show "(\<lambda>n. (of_nat n + of_real a) powr -s) sums hurwitz_zeta a s" 
     by simp
 qed
 
 corollary
   assumes "Re s > 1"
   shows zeta_conv_suminf: "zeta s = (\<Sum>n. of_nat (Suc n) powr -s)"
   and   sums_zeta: "(\<lambda>n. of_nat (Suc n) powr -s) sums zeta s"
   using hurwitz_zeta_conv_suminf[of 1 s] sums_hurwitz_zeta[of 1 s] assms 
   by (simp_all add: zeta_def add_ac)
 
 corollary
   assumes "n > 1"
   shows zeta_nat_conv_suminf: "zeta (of_nat n) = (\<Sum>k. 1 / of_nat (Suc k) ^ n)"
   and   sums_zeta_nat: "(\<lambda>k. 1 / of_nat (Suc k) ^ n) sums zeta (of_nat n)"
 proof -
   have "(\<lambda>k. of_nat (Suc k) powr -of_nat n) sums zeta (of_nat n)"
     using assms by (intro sums_zeta) auto
   also have "(\<lambda>k. of_nat (Suc k) powr -of_nat n) = (\<lambda>k. 1 / of_nat (Suc k) ^ n :: complex)"
     by (simp add: powr_minus divide_simps del: of_nat_Suc)
   finally show "(\<lambda>k. 1 / of_nat (Suc k) ^ n) sums zeta (of_nat n)" .
   thus "zeta (of_nat n) = (\<Sum>k. 1 / of_nat (Suc k) ^ n)" by (simp add: sums_iff)
 qed
 
 lemma pre_zeta_aux_cnj [simp]: 
   assumes "a > 0"
   shows   "pre_zeta_aux n a (cnj z) = cnj (pre_zeta_aux n a z)"
 proof -
   have "cnj (pre_zeta_aux n a z) = 
           of_real a powr -cnj z / 2 + (\<Sum>x=1..n. (bernoulli (2 * x) / fact (2 * x)) *\<^sub>R
             a powr (-cnj z - (2*x-1)) * pochhammer (cnj z) (2*x-1)) + EM_remainder (2*n+1)
           (\<lambda>x. -(pochhammer (cnj z) (Suc (2 * n)) * 
                   cnj (of_real (x + a) powr (-1 - 2 * of_nat n - z)))) 0"
     (is "_ = _ + ?A + ?B") unfolding pre_zeta_aux_def complex_cnj_add using assms
     by (subst EM_remainder_cnj [symmetric]) 
        (auto intro!: continuous_intros simp: cnj_powr add_eq_0_iff mult_ac)
   also have "?B = EM_remainder (2*n+1)
         (\<lambda>x. -(pochhammer (cnj z) (Suc (2 * n)) * of_real (x + a) powr (-1 - 2 * of_nat n - cnj z))) 0"
     using assms by (intro EM_remainder_cong) (auto simp: cnj_powr)
   also have "of_real a powr -cnj z / 2 + ?A + \<dots> = pre_zeta_aux n a (cnj z)"
     by (simp add: pre_zeta_aux_def mult_ac)
   finally show ?thesis ..
 qed
 
 lemma pre_zeta_cnj [simp]: "a > 0 \<Longrightarrow> pre_zeta a (cnj z) = cnj (pre_zeta a z)"
   by (simp add: pre_zeta_def)
 
 lemma hurwitz_zeta_cnj [simp]: "a > 0 \<Longrightarrow> hurwitz_zeta a (cnj z) = cnj (hurwitz_zeta a z)"
 proof -
   assume "a > 0"
   moreover have "cnj z = 1 \<longleftrightarrow> z = 1" by (simp add: complex_eq_iff)
   ultimately show ?thesis by (auto simp: hurwitz_zeta_def cnj_powr)
 qed
 
 lemma zeta_cnj [simp]: "zeta (cnj z) = cnj (zeta z)"
   by (simp add: zeta_def)
 
 corollary hurwitz_zeta_real: "a > 0 \<Longrightarrow> hurwitz_zeta a (of_real x) \<in> \<real>"
   using hurwitz_zeta_cnj [of a "of_real x"] by (simp add: Reals_cnj_iff del: zeta_cnj)
 
 corollary zeta_real: "zeta (of_real x) \<in> \<real>"
   unfolding zeta_def by (rule hurwitz_zeta_real) auto
 
 corollary zeta_real': "z \<in> \<real> \<Longrightarrow> zeta z \<in> \<real>"
   by (elim Reals_cases) (auto simp: zeta_real)
 
 
 subsection \<open>Connection to Dirichlet series\<close>
 
 lemma eval_fds_zeta: "Re s > 1 \<Longrightarrow> eval_fds fds_zeta s = zeta s"
   using sums_zeta [of s] by (intro eval_fds_eqI) (auto simp: powr_minus divide_simps)
 
 theorem euler_product_zeta:
   assumes "Re s > 1"
   shows   "(\<lambda>n. \<Prod>p\<le>n. if prime p then inverse (1 - 1 / of_nat p powr s) else 1) \<longlonglongrightarrow> zeta s"
   using euler_product_fds_zeta[of s] assms unfolding nat_power_complex_def 
   by (simp add: eval_fds_zeta)
 
 corollary euler_product_zeta':
   assumes "Re s > 1"
   shows   "(\<lambda>n. \<Prod>p | prime p \<and> p \<le> n. inverse (1 - 1 / of_nat p powr s)) \<longlonglongrightarrow> zeta s"
 proof -
   note euler_product_zeta [OF assms]
   also have "(\<lambda>n. \<Prod>p\<le>n. if prime p then inverse (1 - 1 / of_nat p powr s) else 1) =
                (\<lambda>n. \<Prod>p | prime p \<and> p \<le> n. inverse (1 - 1 / of_nat p powr s))"
     by (intro ext prod.mono_neutral_cong_right refl) auto
   finally show ?thesis .
 qed
 
 theorem zeta_Re_gt_1_nonzero: "Re s > 1 \<Longrightarrow> zeta s \<noteq> 0"
   using eval_fds_zeta_nonzero[of s] by (simp add: eval_fds_zeta)
 
 theorem tendsto_zeta_Re_going_to_at_top: "(zeta \<longlongrightarrow> 1) (Re going_to at_top)"
 proof (rule Lim_transform_eventually)
   have "eventually (\<lambda>x::real. x > 1) at_top"
     by (rule eventually_gt_at_top)
   hence "eventually (\<lambda>s. Re s > 1) (Re going_to at_top)"
     by blast
   thus "eventually (\<lambda>z. eval_fds fds_zeta z = zeta z) (Re going_to at_top)"
     by eventually_elim (simp add: eval_fds_zeta)
 next
   have "conv_abscissa (fds_zeta :: complex fds) \<le> 1"
   proof (rule conv_abscissa_leI)
     fix c' assume "ereal c' > 1"
     thus "\<exists>s. s \<bullet> 1 = c' \<and> fds_converges fds_zeta (s::complex)"
       by (auto intro!: exI[of _ "of_real c'"])
   qed
   hence "(eval_fds fds_zeta \<longlongrightarrow> fds_nth fds_zeta 1) (Re going_to at_top)"
     by (intro tendsto_eval_fds_Re_going_to_at_top') auto
   thus "(eval_fds fds_zeta \<longlongrightarrow> 1) (Re going_to at_top)" by simp
 qed
 
 lemma conv_abscissa_zeta [simp]: "conv_abscissa (fds_zeta :: complex fds) = 1"
   and abs_conv_abscissa_zeta [simp]: "abs_conv_abscissa (fds_zeta :: complex fds) = 1"
 proof -
   let ?z = "fds_zeta :: complex fds"
   have A: "conv_abscissa ?z \<ge> 1"
   proof (intro conv_abscissa_geI)
     fix c' assume "ereal c' < 1"
     hence "\<not>summable (\<lambda>n. real n powr -c')"
       by (subst summable_real_powr_iff) auto
     hence "\<not>summable (\<lambda>n. of_real (real n powr -c') :: complex)"
       by (subst summable_of_real_iff)
     also have "summable (\<lambda>n. of_real (real n powr -c') :: complex) \<longleftrightarrow> 
                  fds_converges fds_zeta (of_real c' :: complex)"
       unfolding fds_converges_def
       by (intro summable_cong eventually_mono [OF eventually_gt_at_top[of 0]])
          (simp add: fds_nth_zeta powr_Reals_eq powr_minus divide_simps)
     finally show "\<exists>s::complex. s \<bullet> 1 = c' \<and> \<not>fds_converges fds_zeta s"
       by (intro exI[of _ "of_real c'"]) auto
   qed
 
   have B: "abs_conv_abscissa ?z \<le> 1"
   proof (intro abs_conv_abscissa_leI)
     fix c' assume "1 < ereal c'"
     thus "\<exists>s::complex. s \<bullet> 1 = c' \<and> fds_abs_converges fds_zeta s"
       by (intro exI[of _ "of_real c'"]) auto
   qed
 
   have "conv_abscissa ?z \<le> abs_conv_abscissa ?z"
     by (rule conv_le_abs_conv_abscissa)
   also note B
   finally show "conv_abscissa ?z = 1" using A by (intro antisym)
 
   note A
   also have "conv_abscissa ?z \<le> abs_conv_abscissa ?z"
     by (rule conv_le_abs_conv_abscissa)
   finally show "abs_conv_abscissa ?z = 1" using B by (intro antisym)
 qed
 
 theorem deriv_zeta_sums:
   assumes s: "Re s > 1"
   shows "(\<lambda>n. -of_real (ln (real (Suc n))) / of_nat (Suc n) powr s) sums deriv zeta s"
 proof -
   from s have "fds_converges (fds_deriv fds_zeta) s"
     by (intro fds_converges_deriv) simp_all
   with s have "(\<lambda>n. -of_real (ln (real (Suc n))) / of_nat (Suc n) powr s) sums
                   deriv (eval_fds fds_zeta) s"
     unfolding fds_converges_altdef
     by (simp add: fds_nth_deriv scaleR_conv_of_real eval_fds_deriv eval_fds_zeta)
   also from s have "eventually (\<lambda>s. s \<in> {s. Re s > 1}) (nhds s)"
     by (intro eventually_nhds_in_open) (auto simp: open_halfspace_Re_gt)
   hence "eventually (\<lambda>s. eval_fds fds_zeta s = zeta s) (nhds s)"
     by eventually_elim (auto simp: eval_fds_zeta)
   hence "deriv (eval_fds fds_zeta) s = deriv zeta s"
     by (intro deriv_cong_ev refl)
   finally show ?thesis .
 qed
 
 theorem inverse_zeta_sums:
   assumes s: "Re s > 1"
   shows   "(\<lambda>n. moebius_mu (Suc n) / of_nat (Suc n) powr s) sums inverse (zeta s)"
 proof -
   have "fds_converges (fds moebius_mu) s"
     using assms by (auto intro!: fds_abs_converges_moebius_mu)
   hence "(\<lambda>n. moebius_mu (Suc n) / of_nat (Suc n) powr s) sums eval_fds (fds moebius_mu) s"
     by (simp add: fds_converges_altdef)
   also have "fds moebius_mu = inverse (fds_zeta :: complex fds)"
     by (rule fds_moebius_inverse_zeta)
   also from s have "eval_fds \<dots> s = inverse (zeta s)"
     by (subst eval_fds_inverse)
        (auto simp: fds_moebius_inverse_zeta [symmetric] eval_fds_zeta 
              intro!: fds_abs_converges_moebius_mu)
   finally show ?thesis .
 qed
 
 text \<open>
   The following gives an extension of the $\zeta$ functions to the critical strip.
 \<close>
 lemma hurwitz_zeta_critical_strip:
   fixes s :: complex and a :: real
   defines "S \<equiv> (\<lambda>n. \<Sum>i<n. (of_nat i + a) powr - s)"
   defines "I' \<equiv> (\<lambda>n. of_nat n powr (1 - s) / (1 - s))"
   assumes "Re s > 0" "s \<noteq> 1" and "a > 0"
   shows   "(\<lambda>n. S n - I' n) \<longlonglongrightarrow> hurwitz_zeta a s"
 proof -
   from assms have [simp]: "s \<noteq> 1" by auto
   let ?f = "\<lambda>x. of_real (x + a) powr -s"
   let ?fs = "\<lambda>n x. (-1) ^ n * pochhammer s n * of_real (x + a) powr (-s - of_nat n)"
   have minus_commute: "-a - b = -b - a" for a b :: complex by (simp add: algebra_simps)
   define I where "I = (\<lambda>n. (of_nat n + a) powr (1 - s) / (1 - s))"
   define R where "R = (\<lambda>n. EM_remainder' 1 (?fs 1) (real 0) (real n))"
   define R_lim where "R_lim = EM_remainder 1 (?fs 1) 0"
   define C where "C = - (a powr -s / 2)"
   define D where "D = (\<lambda>n. (1/2) * (of_real (a + real n) powr - s))"
   define D' where "D' = (\<lambda>n. of_real (a + real n) powr - s)"
   define C' where "C' = a powr (1 - s) / (1 - s)"
   define C'' where "C'' = of_real a powr - s"
   {
     fix n :: nat assume n: "n > 0"
     have "((\<lambda>x. of_real (x + a) powr -s) has_integral (of_real (real n + a) powr (1-s) / (1 - s) - 
             of_real (0 + a) powr (1 - s) / (1 - s))) {0..real n}" using n assms 
       by (intro fundamental_theorem_of_calculus)
          (auto intro!: continuous_intros has_vector_derivative_real_field derivative_eq_intros
                simp: complex_nonpos_Reals_iff)
     hence I: "((\<lambda>x. of_real (x + a) powr -s) has_integral (I n - C')) {0..n}"
       by (auto simp: divide_simps C'_def I_def)
     have "(\<Sum>i\<in>{0<..n}. ?f (real i)) - integral {real 0..real n} ?f =
             (\<Sum>k<1. (bernoulli' (Suc k) / fact (Suc k)) *\<^sub>R (?fs k (real n) - ?fs k (real 0))) + R n" 
       using n assms unfolding R_def
       by (intro euler_maclaurin_strong_raw_nat[where Y = "{0}"])
          (auto intro!: continuous_intros derivative_eq_intros has_vector_derivative_real_field
                simp: pochhammer_rec' algebra_simps complex_nonpos_Reals_iff add_eq_0_iff)
     also have "(\<Sum>k<1. (bernoulli' (Suc k) / fact (Suc k)) *\<^sub>R (?fs k (real n) - ?fs k (real 0))) = 
                   ((n + a) powr - s - a powr - s) / 2"
       by (simp add: lessThan_nat_numeral scaleR_conv_of_real numeral_2_eq_2 [symmetric])
     also have "\<dots> = C + D n" by (simp add: C_def D_def field_simps)
     also have "integral {real 0..real n} (\<lambda>x. complex_of_real (x + a) powr - s) = I n - C'"
       using I by (simp add: has_integral_iff)
     also have "(\<Sum>i\<in>{0<..n}. of_real (real i + a) powr - s) = 
                  (\<Sum>i=0..n. of_real (real i + a) powr - s) - of_real a powr -s"
       using assms by (subst sum.head) auto
     also have "(\<Sum>i=0..n. of_real (real i + a) powr - s) = S n + of_real (real n + a) powr -s"
       unfolding S_def by (subst sum.last_plus) (auto simp: atLeast0LessThan)
     finally have "C - C' + C'' - D' n + D n + R n + (I n - I' n) = S n - I' n"
       by (simp add: algebra_simps S_def D'_def C''_def)
   }
   hence ev: "eventually (\<lambda>n. C - C' + C'' - D' n + D n + R n + (I n - I' n) = S n - I' n) at_top"
     by (intro eventually_mono[OF eventually_gt_at_top[of 0]]) auto
 
   have [simp]: "-1 - s = -s - 1" by simp
   {
     let ?C = "norm (pochhammer s 1)"
     have "R \<longlonglongrightarrow> R_lim" unfolding R_def R_lim_def of_nat_0
     proof (subst of_int_0 [symmetric], rule tendsto_EM_remainder)
       show "eventually (\<lambda>x. norm (?fs 1 x) \<le> ?C * (x + a) powr (-Re s - 1)) at_top"
         using eventually_ge_at_top[of 0]
         by eventually_elim (insert assms, auto simp: norm_mult norm_powr_real_powr)
     next
       fix x assume x: "x \<ge> real_of_int 0"
       have [simp]: "-numeral n - (x :: real) = -x - numeral n" for x n by (simp add: algebra_simps)
       show "((\<lambda>x. ?C / (-Re s) * (x + a) powr (-Re s)) has_real_derivative 
               ?C * (x + a) powr (- Re s - 1)) (at x within {real_of_int 0..})"
         using assms x by (auto intro!: derivative_eq_intros)
     next
       have "(\<lambda>y. ?C / (- Re s) * (a + real y) powr (- Re s)) \<longlonglongrightarrow> 0"
         by (intro tendsto_mult_right_zero tendsto_neg_powr filterlim_real_sequentially
                   filterlim_tendsto_add_at_top[OF tendsto_const]) (use assms in auto)
       thus "convergent (\<lambda>y. ?C / (- Re s) * (real y + a) powr (- Re s))"
         by (auto simp: add_ac convergent_def)
     qed (intro integrable_EM_remainder' continuous_intros, insert assms, auto simp: add_eq_0_iff)
   }
   moreover have "(\<lambda>n. I n - I' n) \<longlonglongrightarrow> 0"
   proof -
     have "(\<lambda>n. (complex_of_real (real n + a) powr (1 - s) - 
                  of_real (real n) powr (1 - s)) / (1 - s)) \<longlonglongrightarrow> 0 / (1 - s)" 
       using assms(3-5) by (intro filterlim_compose[OF _ filterlim_real_sequentially]
                              tendsto_divide complex_powr_add_minus_powr_asymptotics) auto
     thus "(\<lambda>n. I n - I' n) \<longlonglongrightarrow> 0" by (simp add: I_def I'_def divide_simps)
   qed
   ultimately have "(\<lambda>n. C - C' + C'' - D' n + D n + R n + (I n - I' n)) 
                      \<longlonglongrightarrow> C - C' + C'' - 0 + 0 + R_lim + 0"
     unfolding D_def D'_def using assms
     by (intro tendsto_add tendsto_diff tendsto_const tendsto_mult_right_zero
               tendsto_neg_powr_complex_of_real filterlim_tendsto_add_at_top 
               filterlim_real_sequentially) auto
   also have "C - C' + C'' - 0 + 0 + R_lim + 0 = 
                (a powr - s / 2) + a powr (1 - s) / (s - 1) + R_lim"
     by (simp add: C_def C'_def C''_def field_simps)
   also have "\<dots> = hurwitz_zeta a s"
     using assms by (simp add: hurwitz_zeta_def pre_zeta_def pre_zeta_aux_def
                               R_lim_def scaleR_conv_of_real)
   finally have "(\<lambda>n. C - C' + C'' - D' n + D n + R n + (I n - I' n)) \<longlonglongrightarrow> hurwitz_zeta a s" .
   with ev show ?thesis
     by (blast intro: Lim_transform_eventually)
 qed
 
 lemma zeta_critical_strip:
   fixes s :: complex and a :: real
   defines "S \<equiv> (\<lambda>n. \<Sum>i=1..n. (of_nat i) powr - s)"
   defines "I \<equiv> (\<lambda>n. of_nat n powr (1 - s) / (1 - s))"
   assumes s: "Re s > 0" "s \<noteq> 1"
   shows   "(\<lambda>n. S n - I n) \<longlonglongrightarrow> zeta s"
 proof -
   from hurwitz_zeta_critical_strip[OF s zero_less_one]
     have "(\<lambda>n. (\<Sum>i<n. complex_of_real (Suc i) powr - s) -
             of_nat n powr (1 - s) / (1 - s)) \<longlonglongrightarrow> hurwitz_zeta 1 s" by (simp add: add_ac)
   also have "(\<lambda>n. (\<Sum>i<n. complex_of_real (Suc i) powr -s)) = (\<lambda>n. (\<Sum>i=1..n. of_nat i powr -s))"
     by (intro ext sum.reindex_bij_witness[of _ "\<lambda>x. x - 1" Suc]) auto
   finally show ?thesis by (simp add: zeta_def S_def I_def)
 qed
 
 
 subsection \<open>The non-vanishing of $\zeta$ for $\mathfrak{R}(s) \geq 1$\<close>
 
 text \<open>
   This proof is based on a sketch by Newman~\cite{newman1998analytic}, which was previously
   formalised in HOL Light by Harrison~\cite{harrison2009pnt}, albeit in a much more concrete
   and low-level style.
 
   Our aim here is to reproduce Newman's proof idea cleanly and on the same high level of
   abstraction.
 \<close>
 theorem zeta_Re_ge_1_nonzero:
   fixes s assumes "Re s \<ge> 1" "s \<noteq> 1"
   shows "zeta s \<noteq> 0"
 proof (cases "Re s > 1")
   case False
   define a where "a = -Im s"
   from False assms have s [simp]: "s = 1 - \<i> * a" and a: "a \<noteq> 0"
     by (auto simp: complex_eq_iff a_def)
   show ?thesis
   proof
     assume "zeta s = 0"
     hence zero: "zeta (1 - \<i> * a) = 0" by simp
     with zeta_cnj[of "1 - \<i> * a"] have zero': "zeta (1 + \<i> * a) = 0" by simp
 
     \<comment> \<open>We define the function $Q(s) = \zeta(s)^2\zeta(s+ia)\zeta(s-ia)$ and its Dirichlet series.
         The objective will be to show that this function is entire and its Dirichlet series
         converges everywhere. Of course, $Q(s)$ has singularities at $1$ and $1\pm ia$, so we 
         need to show they can be removed.\<close>
     define Q Q_fds
       where "Q = (\<lambda>s. zeta s ^ 2 * zeta (s + \<i> * a) * zeta (s - \<i> * a))"
         and "Q_fds = fds_zeta ^ 2 * fds_shift (\<i> * a) fds_zeta * fds_shift (-\<i> * a) fds_zeta"  
     let ?sings = "{1, 1 + \<i> * a, 1 - \<i> * a}"
  
     \<comment> \<open>We show that @{term Q} is locally bounded everywhere. This is the case because the
         poles of $\zeta(s)$ cancel with the zeros of $\zeta(s\pm ia)$ and vice versa.
         This boundedness is then enough to show that @{term Q} has only removable singularities.\<close>
     have Q_bigo_1: "Q \<in> O[at s](\<lambda>_. 1)" for s
     proof -
       have Q_eq: "Q = (\<lambda>s. (zeta s * zeta (s + \<i> * a)) * (zeta s * zeta (s - \<i> * a)))"
         by (simp add: Q_def power2_eq_square mult_ac)
 
       \<comment> \<open>The singularity of $\zeta(s)$ at 1 gets cancelled by the zero of $\zeta(s-ia)$:\<close>
       have bigo1: "(\<lambda>s. zeta s * zeta (s - \<i> * a)) \<in> O[at 1](\<lambda>_. 1)"
         if "zeta (1 - \<i> * a) = 0" "a \<noteq> 0" for a :: real
       proof -
         have "(\<lambda>s. zeta (s - \<i> * a) - zeta (1 - \<i> * a)) \<in> O[at 1](\<lambda>s. s - 1)"
           using that
           by (intro taylor_bigo_linear holomorphic_on_imp_differentiable_at[of _ "-{1 + \<i> * a}"]
                     holomorphic_intros) (auto simp: complex_eq_iff)
         hence "(\<lambda>s. zeta s * zeta (s - \<i> * a)) \<in> O[at 1](\<lambda>s. 1 / (s - 1) * (s - 1))" 
           using that by (intro landau_o.big.mult zeta_bigo_at_1) simp_all
         also have "(\<lambda>s. 1 / (s - 1) * (s - 1)) \<in> \<Theta>[at 1](\<lambda>_. 1)"
           by (intro bigthetaI_cong) (auto simp: eventually_at_filter)
         finally show ?thesis .
       qed
 
       \<comment> \<open>The analogous result for $\zeta(s) \zeta(s+ia)$:\<close>
       have bigo1': "(\<lambda>s. zeta s * zeta (s + \<i> * a)) \<in> O[at 1](\<lambda>_. 1)"
         if "zeta (1 - \<i> * a) = 0" "a \<noteq> 0" for a :: real
         using bigo1[of  "-a"] that zeta_cnj[of "1 - \<i> * a"] by simp
 
       \<comment> \<open>The singularity of $\zeta(s-ia)$ gets cancelled by the zero of $\zeta(s)$:\<close>
       have bigo2: "(\<lambda>s. zeta s * zeta (s - \<i> * a)) \<in> O[at (1 + \<i> * a)](\<lambda>_. 1)"
         if "zeta (1 - \<i> * a) = 0" "a \<noteq> 0" for a :: real
       proof -
         have "(\<lambda>s. zeta s * zeta (s - \<i> * a)) \<in> O[filtermap (\<lambda>s. s + \<i> * a) (at 1)](\<lambda>_. 1)"
           using bigo1'[of a] that by (simp add: mult.commute landau_o.big.in_filtermap_iff)
         also have "filtermap (\<lambda>s. s + \<i> * a) (at 1) = at (1 + \<i> * a)"
           using filtermap_at_shift[of "-\<i> * a" 1] by simp
         finally show ?thesis .
       qed
 
       \<comment> \<open>Again, the analogous result for $\zeta(s) \zeta(s+ia)$:\<close>
       have bigo2': "(\<lambda>s. zeta s * zeta (s + \<i> * a)) \<in> O[at (1 - \<i> * a)](\<lambda>_. 1)"
         if "zeta (1 - \<i> * a) = 0" "a \<noteq> 0" for a :: real
         using bigo2[of "-a"] that zeta_cnj[of "1 - \<i> * a"] by simp
 
       \<comment> \<open>Now the final case distinction to show $Q(s)\in O(1)$ for all $s\in\mathbb{C}$:\<close>
       consider "s = 1" | "s = 1 + \<i> * a" | "s = 1 - \<i> * a" | "s \<notin> ?sings" by blast
       thus ?thesis
       proof cases
         case 1
         thus ?thesis unfolding Q_eq using zero zero' a
           by (auto intro: bigo1 bigo1' landau_o.big.mult_in_1)
       next
         case 2
         from a have "isCont (\<lambda>s. zeta s * zeta (s + \<i> * a)) (1 + \<i> * a)"
           by (auto intro!: continuous_intros)
         with 2 show ?thesis unfolding Q_eq using zero zero' a
           by (auto intro: bigo2 landau_o.big.mult_in_1 continuous_imp_bigo_1)
       next
         case 3
         from a have "isCont (\<lambda>s. zeta s * zeta (s - \<i> * a)) (1 - \<i> * a)"
           by (auto intro!: continuous_intros)
         with 3 show ?thesis unfolding Q_eq using zero zero' a
           by (auto intro: bigo2' landau_o.big.mult_in_1 continuous_imp_bigo_1)
       qed (auto intro!: continuous_imp_bigo_1 continuous_intros simp: Q_def complex_eq_iff)
     qed
   
     \<comment> \<open>Thus, we can remove the singularities from @{term Q} and extend it to an entire function.\<close>
     have "\<exists>Q'. Q' holomorphic_on UNIV \<and> (\<forall>z\<in>UNIV - ?sings. Q' z = Q z)"
       by (intro removable_singularities Q_bigo_1)
          (auto simp: Q_def complex_eq_iff intro!: holomorphic_intros)
     then obtain Q' where Q': "Q' holomorphic_on UNIV" "\<And>z. z \<notin> ?sings \<Longrightarrow> Q' z = Q z" by blast
 
     \<comment> \<open>@{term Q'} constitutes an analytic continuation of the Dirichlet series of @{term Q}.\<close>
     have eval_Q_fds: "eval_fds Q_fds s = Q' s" if "Re s > 1" for s
     proof -
       have "eval_fds Q_fds s = Q s" using that
         by (simp add: Q_fds_def Q_def eval_fds_mult eval_fds_power fds_abs_converges_mult 
                       fds_abs_converges_power eval_fds_zeta)
       also from that have "\<dots> = Q' s" by (subst Q') auto
       finally show ?thesis .
     qed
   
     \<comment> \<open>Since $\zeta(s)$ and $\zeta(s\pm ia)$ are completely multiplicative Dirichlet series,
         the logarithm of their product can be rewritten into the following nice form:\<close>
     have ln_Q_fds_eq: 
       "fds_ln 0 Q_fds = fds (\<lambda>k. of_real (2 * mangoldt k / ln k * (1 + cos (a * ln k))))"
     proof -
       note simps = fds_ln_mult[where l' = 0 and l'' = 0] fds_ln_power[where l' = 0]
                    fds_ln_prod[where l' = "\<lambda>_. 0"]
       have "fds_ln 0 Q_fds = 2 * fds_ln 0 fds_zeta + fds_shift (\<i> * a) (fds_ln 0 fds_zeta) + 
                                fds_shift (-\<i> * a) (fds_ln 0 fds_zeta)"
         by (auto simp: Q_fds_def simps)
       also have "completely_multiplicative_function (fds_nth (fds_zeta :: complex fds))"
         by standard auto
       hence "fds_ln (0 :: complex) fds_zeta = fds (\<lambda>n. mangoldt n /\<^sub>R ln (real n))"
         by (subst fds_ln_completely_multiplicative) (auto simp: fds_eq_iff)
       also have "2 * \<dots> + fds_shift (\<i> * a) \<dots> + fds_shift (-\<i> * a) \<dots> = 
                    fds (\<lambda>k. of_real (2 * mangoldt k / ln k * (1 + cos (a * ln k))))"
         (is "?a = ?b")
       proof (intro fds_eqI, goal_cases)
         case (1 n)
         then consider "n = 1" | "n > 1" by force
         hence "fds_nth ?a n = mangoldt n / ln (real n) * (2 + (n powr (\<i> * a) + n powr (-\<i> * a)))"
           by cases (auto simp: field_simps scaleR_conv_of_real numeral_fds)
         also have "n powr (\<i> * a) + n powr (-\<i> * a) = 2 * cos (of_real (a * ln n))"
           using 1 by (subst cos_exp_eq) (simp_all add: powr_def algebra_simps)
         also have "mangoldt n / ln (real n) * (2 + \<dots>) = 
                      of_real (2 * mangoldt n / ln n * (1 + cos (a * ln n)))"
           by (subst cos_of_real) simp_all
         finally show ?case by (simp add: fds_nth_fds')
       qed
       finally show ?thesis .
     qed
     \<comment> \<open>It is then obvious that this logarithm series has non-negative real coefficients.\<close>
     also have "nonneg_dirichlet_series \<dots>"
     proof (standard, goal_cases)
       case (1 n)
       from cos_ge_minus_one[of "a * ln n"] have "1 + cos (a * ln (real n)) \<ge> 0" by linarith
       thus ?case using 1
         by (cases "n = 0")
            (auto simp: complex_nonneg_Reals_iff fds_nth_fds' mangoldt_nonneg
                  intro!: divide_nonneg_nonneg mult_nonneg_nonneg)
     qed
     \<comment> \<open>Therefore, the original series also has non-negative real coefficients.\<close>
     finally have nonneg: "nonneg_dirichlet_series Q_fds"
       by (rule nonneg_dirichlet_series_lnD) (auto simp: Q_fds_def)
   
     \<comment> \<open>By the Pringsheim--Landau theorem, a Dirichlet series with non-negative coefficnets that 
         can be analytically continued to the entire complex plane must converge everywhere, i.\,e.\ 
         its abscissa of (absolute) convergence is $-\infty$:\<close>
     have abscissa_Q_fds: "abs_conv_abscissa Q_fds \<le> 1"
       unfolding Q_fds_def by (auto intro!: abs_conv_abscissa_mult_leI abs_conv_abscissa_power_leI)
     with nonneg and eval_Q_fds and \<open>Q' holomorphic_on UNIV\<close>
       have abscissa: "abs_conv_abscissa Q_fds = -\<infinity>"
         by (intro entire_continuation_imp_abs_conv_abscissa_MInfty[where c = 1 and g = Q'])
            (auto simp: one_ereal_def)
   
     \<comment> \<open>This now leads to a contradiction in a very obvious way. If @{term Q_fds} is
         absolutely convergent, then the subseries corresponding to powers of 2 (\i.e.
         we delete all summands $a_n / n ^ s$ where $n$ is not a power of 2 from the sum) is
         also absolutely convergent. We denote this series with $R$.\<close>
     define R_fds where "R_fds = fds_primepow_subseries 2 Q_fds"
     have "conv_abscissa R_fds \<le> abs_conv_abscissa R_fds" by (rule conv_le_abs_conv_abscissa)
     also have "abs_conv_abscissa R_fds \<le> abs_conv_abscissa Q_fds"
       unfolding R_fds_def by (rule abs_conv_abscissa_restrict)
     also have "\<dots> = -\<infinity>" by (simp add: abscissa)
     finally have abscissa': "conv_abscissa R_fds = -\<infinity>" by simp
   
     \<comment> \<open>Since $\zeta(s)$ and $\zeta(s \pm ia)$ have an Euler product expansion for 
         $\mathfrak{R}(s) > 1$, we have
           \[R(s) = (1 - 2^{-s})^-2 (1 - 2^{-s+ia})^{-1} (1 - 2^{-s-ia})^{-1}\]
         there, and since $R$ converges everywhere and the right-hand side is holomorphic for
         $\mathfrak{R}(s) > 0$, the equation is also valid for all $s$ with $\mathfrak{R}(s) > 0$
         by analytic continuation.\<close>
     have eval_R: "eval_fds R_fds s = 
                    1 / ((1 - 2 powr -s) ^ 2 * (1 - 2 powr (-s + \<i> * a)) * (1 - 2 powr (-s - \<i> * a)))"
       (is "_ = ?f s") if "Re s > 0" for s
     proof -
       show ?thesis
       proof (rule analytic_continuation_open[where f = "eval_fds R_fds"])
         show "?f holomorphic_on {s. Re s > 0}"
           by (intro holomorphic_intros) (auto simp: powr_def exp_eq_1 Ln_Reals_eq)
       next
         fix z assume z: "z \<in> {s. Re s > 1}"
         have [simp]: "completely_multiplicative_function (fds_nth fds_zeta)" by standard auto
         thus "eval_fds R_fds z = ?f z" using z
           by (simp add: R_fds_def Q_fds_def eval_fds_mult eval_fds_power fds_abs_converges_mult 
                 fds_abs_converges_power fds_primepow_subseries_euler_product_cm divide_simps
                 powr_minus powr_diff powr_add fds_abs_summable_zeta)
       qed (insert that abscissa', auto intro!: exI[of _ 2] convex_connected open_halfspace_Re_gt
                                                convex_halfspace_Re_gt holomorphic_intros)
     qed
   
     \<comment> \<open>We now clearly have a contradiction: $R(s)$, being entire, is continuous everywhere,
         while the function on the right-hand side clearly has a pole at $0$.\<close>
     show False
     proof (rule not_tendsto_and_filterlim_at_infinity)
       have "((\<lambda>b. (1-2 powr - b)\<^sup>2 * (1 - 2 powr (-b+\<i>*a)) * (1 - 2 powr (-b-\<i>*a))) \<longlongrightarrow> 0) 
               (at 0 within {s. Re s > 0})"
         (is "filterlim ?f' _ _") by (intro tendsto_eq_intros) (auto)
       moreover have "eventually (\<lambda>s. s \<in> {s. Re s > 0}) (at 0 within {s. Re s > 0})"
         by (auto simp: eventually_at_filter)
       hence "eventually (\<lambda>s. ?f' s \<noteq> 0) (at 0 within {s. Re s > 0})"
         by eventually_elim (auto simp: powr_def exp_eq_1 Ln_Reals_eq)
       ultimately have "filterlim ?f' (at 0) (at 0 within {s. Re s > 0})" by (simp add: filterlim_at)
       hence "filterlim ?f at_infinity (at 0 within {s. Re s > 0})" (is ?lim)
         by (intro filterlim_divide_at_infinity[OF tendsto_const]
                      tendsto_mult_filterlim_at_infinity) auto
       also have ev: "eventually (\<lambda>s. Re s > 0) (at 0 within {s. Re s > 0})"
         by (auto simp: eventually_at intro!: exI[of _ 1])
       have "?lim \<longleftrightarrow> filterlim (eval_fds R_fds) at_infinity (at 0 within {s. Re s > 0})"
         by (intro filterlim_cong refl eventually_mono[OF ev]) (auto simp: eval_R)
       finally show \<dots> .
     next
       have "continuous (at 0 within {s. Re s > 0}) (eval_fds R_fds)"
         by (intro continuous_intros) (auto simp: abscissa')
       thus "((eval_fds R_fds \<longlongrightarrow> eval_fds R_fds 0)) (at 0 within {s. Re s > 0})"
         by (auto simp: continuous_within)
     next
       have "0 \<in> {s. Re s \<ge> 0}" by simp
       also have "{s. Re s \<ge> 0} = closure {s. Re s > 0}"
         using closure_halfspace_gt[of "1::complex" 0] by (simp add: inner_commute)
       finally have "0 \<in> \<dots>" .
       thus "at 0 within {s. Re s > 0} \<noteq> bot"
         by (subst at_within_eq_bot_iff) auto
     qed
   qed
 qed (fact zeta_Re_gt_1_nonzero)
 
 
 subsection \<open>Special values of the $\zeta$ functions\<close>
 
 theorem hurwitz_zeta_neg_of_nat: 
   assumes "a > 0"
   shows   "hurwitz_zeta a (-of_nat n) = -bernpoly (Suc n) a / of_nat (Suc n)"
 proof -
   have "-of_nat n \<noteq> (1::complex)" by (simp add: complex_eq_iff)
   hence "hurwitz_zeta a (-of_nat n) = 
            pre_zeta a (-of_nat n) + a powr real (Suc n) / (-of_nat (Suc n))"
     unfolding zeta_def hurwitz_zeta_def using assms by (simp add: powr_of_real [symmetric])
   also have "a powr real (Suc n) / (-of_nat (Suc n)) = - (a powr real (Suc n) / of_nat (Suc n))"
     by (simp add: divide_simps del: of_nat_Suc)
   also have "a powr real (Suc n) = a ^ Suc n"
     using assms by (intro powr_realpow)
   also have "pre_zeta a (-of_nat n) = pre_zeta_aux (Suc n) a (- of_nat n)"
     using assms by (intro pre_zeta_aux_eq_pre_zeta [symmetric]) auto
   also have "\<dots> = of_real a powr of_nat n / 2 +
                     (\<Sum>i = 1..Suc n. (bernoulli (2 * i) / fact (2 * i)) *\<^sub>R
                        (pochhammer (- of_nat n) (2 * i - 1) *
                        of_real a powr (of_nat n - of_nat (2 * i - 1)))) +
                     EM_remainder (Suc (2 * Suc n)) (\<lambda>x. - (pochhammer (- of_nat n)
                       (2*n+3) * of_real (x + a) powr (- of_nat n - 3))) 0"
     (is "_ = ?B + sum (\<lambda>n. ?f (2 * n)) _ + _") 
     unfolding pre_zeta_aux_def by (simp add: add_ac eval_nat_numeral)
   also have "?B = of_real (a ^ n) / 2" 
     using assms by (subst powr_Reals_eq) (auto simp: powr_realpow)
   also have "pochhammer (-of_nat n :: complex) (2*n+3) = 0"
     by (subst pochhammer_eq_0_iff) auto
   finally have "hurwitz_zeta a (-of_nat n) = 
                   - (a ^ Suc n / of_nat (Suc n)) + (a ^ n / 2 + sum (\<lambda>n. ?f (2 * n)) {1..Suc n})"
     by simp
 
   also have "sum (\<lambda>n. ?f (2 * n)) {1..Suc n} = sum ?f ((*) 2 ` {1..Suc n})"
     by (intro sum.reindex_bij_witness[of _ "\<lambda>i. i div 2" "\<lambda>i. 2*i"]) auto
   also have "\<dots> = (\<Sum>i=2..2*n+2. ?f i)"
   proof (intro sum.mono_neutral_left ballI, goal_cases)
     case (3 i)
     hence "odd i" "i \<noteq> 1" by (auto elim!: evenE)
     thus ?case by (simp add: bernoulli_odd_eq_0)
   qed auto
   also have "\<dots> = (\<Sum>i=2..Suc n. ?f i)"
   proof (intro sum.mono_neutral_right ballI, goal_cases)
     case (3 i)
     hence "pochhammer (-of_nat n :: complex) (i - 1) = 0"
       by (subst pochhammer_eq_0_iff) auto
     thus ?case by simp
   qed auto
   also have "\<dots> = (\<Sum>i=Suc 1..Suc n. -of_real (real (Suc n choose i) * bernoulli i * 
                      a ^ (Suc n - i)) / of_nat (Suc n))"
     (is "sum ?lhs _ = sum ?f _")
   proof (intro sum.cong, goal_cases)
     case (2 i)
     hence "of_nat n - of_nat (i - 1) = (of_nat (Suc n - i) :: complex)"
       by (auto simp: of_nat_diff)
     also have "of_real a powr \<dots> = of_real (a ^ (Suc n - i))"
       using 2 assms by (subst powr_nat) auto
     finally have A: "of_real a powr (of_nat n - of_nat (i - 1)) = \<dots>" .
     have "pochhammer (-of_nat n) (i - 1) = complex_of_real (pochhammer (-real n) (i - 1))"
       by (simp add: pochhammer_of_real [symmetric])
     also have "pochhammer (-real n) (i - 1) = pochhammer (-of_nat (Suc n)) i / (-1 - real n)"
       using 2 by (subst (2) pochhammer_rec_if) auto
     also have "-1 - real n = -real (Suc n)" by simp
     finally have B: "pochhammer (-of_nat n) (i - 1) = 
                     -complex_of_real (pochhammer (-real (Suc n)) i / real (Suc n))"
       by (simp del: of_nat_Suc)
     have "?lhs i = -complex_of_real (bernoulli i * pochhammer (-real (Suc n)) i / fact i * 
                       a ^ (Suc n - i)) / of_nat (Suc n)"
       by (simp only: A B) (simp add: scaleR_conv_of_real)
     also have "bernoulli i * pochhammer (-real (Suc n)) i / fact i =
                  (real (Suc n) gchoose i) * bernoulli i" using 2
       by (subst gbinomial_pochhammer) (auto simp: minus_one_power_iff bernoulli_odd_eq_0)
     also have "real (Suc n) gchoose i = Suc n choose i"
       by (subst binomial_gbinomial) auto
     finally show ?case by simp
   qed auto
   also have "a ^ n / 2 + sum ?f {Suc 1..Suc n} = sum ?f {1..Suc n}"
     by (subst (2) sum.atLeast_Suc_atMost) (simp_all add: scaleR_conv_of_real del: of_nat_Suc)
   also have "-(a ^ Suc n / of_nat (Suc n)) + sum ?f {1..Suc n} = sum ?f {0..Suc n}"
     by (subst (2) sum.atLeast_Suc_atMost) (simp_all add: scaleR_conv_of_real)
   also have "\<dots> = - bernpoly (Suc n) a / of_nat (Suc n)"
     unfolding sum_negf sum_divide_distrib [symmetric] by (simp add: bernpoly_def atLeast0AtMost)
   finally show ?thesis .
 qed
 
 lemma hurwitz_zeta_0 [simp]: "a > 0 \<Longrightarrow> hurwitz_zeta a 0 = 1 / 2 - a"
   using hurwitz_zeta_neg_of_nat[of a 0] by (simp add: bernpoly_def)
 
 lemma zeta_0 [simp]: "zeta 0 = -1 / 2"
   by (simp add: zeta_def)
 
 theorem zeta_neg_of_nat: 
   "zeta (-of_nat n) = -of_real (bernoulli' (Suc n)) / of_nat (Suc n)"
   unfolding zeta_def by (simp add: hurwitz_zeta_neg_of_nat bernpoly_1')
 
 corollary zeta_trivial_zero:
   assumes "even n" "n \<noteq> 0"
   shows   "zeta (-of_nat n) = 0"
   using zeta_neg_of_nat[of n] assms by (simp add: bernoulli'_odd_eq_0)
 
 theorem zeta_even_nat: 
   "zeta (2 * of_nat n) = 
      of_real ((-1) ^ Suc n * bernoulli (2 * n) * (2 * pi) ^ (2 * n) / (2 * fact (2 * n)))"
 proof (cases "n = 0")
   case False
   hence "(\<lambda>k. 1 / of_nat (Suc k) ^ (2 * n)) sums zeta (of_nat (2 * n))"
     by (intro sums_zeta_nat) auto
   from sums_unique2 [OF this nat_even_power_sums_complex] False show ?thesis by simp
 qed (insert zeta_neg_of_nat[of 0], simp_all)
 
 corollary zeta_even_numeral: 
   "zeta (numeral (Num.Bit0 n)) = of_real
      ((- 1) ^ Suc (numeral n) * bernoulli (numeral (num.Bit0 n)) *
      (2 * pi) ^ numeral (num.Bit0 n) / (2 * fact (numeral (num.Bit0 n))))" (is "_ = ?rhs")
 proof -
   have *: "(2 * numeral n :: nat) = numeral (Num.Bit0 n)"
     by (subst numeral.numeral_Bit0, subst mult_2, rule refl)
   have "numeral (Num.Bit0 n) = (2 * numeral n :: complex)"
     by (subst numeral.numeral_Bit0, subst mult_2, rule refl)
   also have "\<dots> = 2 * of_nat (numeral n)" by (simp only: of_nat_numeral of_nat_mult)
   also have "zeta \<dots> = ?rhs" by (subst zeta_even_nat) (simp only: *)
   finally show ?thesis .
 qed
 
 corollary zeta_neg_even_numeral [simp]: "zeta (-numeral (Num.Bit0 n)) = 0"
 proof -
   have "-numeral (Num.Bit0 n) = (-of_nat (numeral (Num.Bit0 n)) :: complex)"
     by simp
   also have "zeta \<dots> = 0"
   proof (rule zeta_trivial_zero)
     have "numeral (Num.Bit0 n) = (2 * numeral n :: nat)"
       by (subst numeral.numeral_Bit0, subst mult_2, rule refl)
     also have "even \<dots>" by (rule dvd_triv_left)
     finally show "even (numeral (Num.Bit0 n) :: nat)" .
   qed auto
   finally show ?thesis .
 qed
 
 corollary zeta_neg_numeral:
   "zeta (-numeral n) = 
      -of_real (bernoulli' (numeral (Num.inc n)) / numeral (Num.inc n))"
 proof -
   have "-numeral n = (- of_nat (numeral n) :: complex)" 
     by simp
   also have "zeta \<dots> = -of_real (bernoulli' (numeral (Num.inc n)) / numeral (Num.inc n))"
     by (subst zeta_neg_of_nat) (simp add: numeral_inc)
   finally show ?thesis .
 qed
 
 corollary zeta_neg1: "zeta (-1) = - 1 / 12"
   using zeta_neg_of_nat[of 1] by (simp add: eval_bernoulli)
 
 corollary zeta_neg3: "zeta (-3) = 1 / 120"
   by (simp add: zeta_neg_numeral)
 
 corollary zeta_neg5: "zeta (-5) = - 1 / 252"
   by (simp add: zeta_neg_numeral)
 
 corollary zeta_2: "zeta 2 = pi ^ 2 / 6"
   by (simp add: zeta_even_numeral)
 
 corollary zeta_4: "zeta 4 = pi ^ 4 / 90"
   by (simp add: zeta_even_numeral fact_num_eq_if)
 
 corollary zeta_6: "zeta 6 = pi ^ 6 / 945"
   by (simp add: zeta_even_numeral fact_num_eq_if)
 
 corollary zeta_8: "zeta 8 = pi ^ 8 / 9450"
   by (simp add: zeta_even_numeral fact_num_eq_if)
 
 
 subsection \<open>Integral relation between $\Gamma$ and $\zeta$ function\<close>
 
 lemma
   assumes z: "Re z > 0" and a: "a > 0"
   shows   Gamma_hurwitz_zeta_aux_integral: 
             "Gamma z / (of_nat n + of_real a) powr z = 
                (\<integral>s\<in>{0<..}. (s powr (z - 1) / exp ((n+a) * s)) \<partial>lebesgue)"
     and   Gamma_hurwitz_zeta_aux_integrable:
             "set_integrable lebesgue {0<..} (\<lambda>s. s powr (z - 1) / exp ((n+a) * s))"
 proof -
   note integrable = absolutely_integrable_Gamma_integral' [OF z]
   let ?INT = "set_lebesgue_integral lebesgue {0<..} :: (real \<Rightarrow> complex) \<Rightarrow> complex"
   let ?INT' = "set_lebesgue_integral lebesgue {0<..} :: (real \<Rightarrow> real) \<Rightarrow> real"
 
   have meas1: "set_borel_measurable lebesgue {0<..} 
                  (\<lambda>x. of_real x powr (z - 1) / of_real (exp ((n+a) * x)))"
     unfolding set_borel_measurable_def
     by (intro measurable_completion, subst measurable_lborel2, 
         intro borel_measurable_continuous_on_indicator) (auto intro!: continuous_intros)
   show integrable1: "set_integrable lebesgue {0<..} 
                        (\<lambda>s. s powr (z - 1) / exp ((n+a) * s))"
     using assms by (intro absolutely_integrable_Gamma_integral) auto
   from assms have pos: "0 < real n + a" by (simp add: add_nonneg_pos)
   hence "complex_of_real 0 \<noteq> of_real (real n + a)" by (simp only: of_real_eq_iff)
   also have "complex_of_real (real n + a) = of_nat n + of_real a" by simp
   finally have nz: "\<dots> \<noteq> 0" by auto
 
   have "((\<lambda>t. complex_of_real t powr (z - 1) / of_real (exp t)) has_integral Gamma z) {0<..}"
     by (rule Gamma_integral_complex') fact+
   hence "Gamma z = ?INT (\<lambda>t. t powr (z - 1) / of_real (exp t))"
     using set_lebesgue_integral_eq_integral(2) [OF integrable] 
     by (simp add: has_integral_iff exp_of_real)
   also have "lebesgue = density (distr lebesgue lebesgue (\<lambda>t. (real n+a) * t)) 
                           (\<lambda>x. ennreal (real n+a))"
     using lebesgue_real_scale[of "real n + a"] pos by auto
   also have "set_lebesgue_integral \<dots> {0<..} (\<lambda>t. of_real t powr (z - 1) / of_real (exp t)) = 
                set_lebesgue_integral (distr lebesgue lebesgue (\<lambda>t. (real n + a) * t)) {0<..}
                  (\<lambda>t. (real n + a) * t powr (z - 1) / exp t)" using integrable pos
     unfolding set_lebesgue_integral_def
     by (subst integral_density) (simp_all add: exp_of_real algebra_simps scaleR_conv_of_real set_integrable_def)
   also have "\<dots> = ?INT (\<lambda>s. (n + a) * (of_real (n+a) * of_real s) powr (z - 1) / 
                     of_real (exp ((n+a) * s)))"
     unfolding set_lebesgue_integral_def
   proof (subst integral_distr)
     show "(*) (real n + a) \<in> lebesgue \<rightarrow>\<^sub>M lebesgue"
       using lebesgue_measurable_scaling[of "real n + a", where ?'a = real]
       unfolding real_scaleR_def .
   next
     have "(\<lambda>x. (n+a) * (indicator {0<..} x *\<^sub>R (of_real x powr (z - 1) / of_real (exp x)))) 
              \<in> lebesgue \<rightarrow>\<^sub>M borel" 
       using integrable unfolding set_integrable_def by (intro borel_measurable_times) simp_all
     thus "(\<lambda>x. indicator {0<..} x *\<^sub>R
            (complex_of_real (real n + a) * complex_of_real x powr (z - 1) / exp x))
     \<in> borel_measurable lebesgue" by simp
   qed (intro Bochner_Integration.integral_cong refl, insert pos, 
        auto simp: indicator_def zero_less_mult_iff)
   also have "\<dots> = ?INT (\<lambda>s. ((n+a) powr z) * (s powr (z - 1) / exp ((n+a) * s)))" using pos
     by (intro set_lebesgue_integral_cong refl allI impI, simp, subst powr_times_real)
        (auto simp: powr_diff)
   also have "\<dots> = (n + a) powr z * ?INT (\<lambda>s. s powr (z - 1) / exp ((n+a) * s))"
     unfolding set_lebesgue_integral_def
     by (subst integral_mult_right_zero [symmetric]) simp_all
   finally show "Gamma z / (of_nat n + of_real a) powr z = 
                   ?INT (\<lambda>s. s powr (z - 1) / exp ((n+a) * s))" 
     using nz by (auto simp add: field_simps)
 qed
 
 lemma
   assumes x: "x > 0" and "a > 0"
   shows   Gamma_hurwitz_zeta_aux_integral_real: 
             "Gamma x / (real n + a) powr x = 
                set_lebesgue_integral lebesgue {0<..} 
                (\<lambda>s. s powr (x - 1) / exp ((real n + a) * s))"
     and   Gamma_hurwitz_zeta_aux_integrable_real:
             "set_integrable lebesgue {0<..} (\<lambda>s. s powr (x - 1) / exp ((real n + a) * s))"
 proof -
   show "set_integrable lebesgue {0<..} (\<lambda>s. s powr (x - 1) / exp ((real n + a) * s))"
     using absolutely_integrable_Gamma_integral[of "of_real x" "real n + a"]
     unfolding set_integrable_def
   proof (rule Bochner_Integration.integrable_bound, goal_cases)
     case 3
     have "set_integrable lebesgue {0<..} (\<lambda>xa. complex_of_real xa powr (of_real x - 1) / 
               of_real (exp ((n + a) * xa)))"
       using assms by (intro Gamma_hurwitz_zeta_aux_integrable) auto
     also have "?this \<longleftrightarrow> integrable lebesgue
                  (\<lambda>s. complex_of_real (indicator {0<..} s *\<^sub>R (s powr (x - 1) / (exp ((n+a) * s)))))"
       unfolding set_integrable_def
       by (intro Bochner_Integration.integrable_cong refl) (auto simp: powr_Reals_eq indicator_def)
     finally have "set_integrable lebesgue {0<..} (\<lambda>s. s powr (x - 1) / exp ((n+a) * s))"
       unfolding set_integrable_def complex_of_real_integrable_eq .
     thus ?case
       by (simp add: set_integrable_def)
   qed (insert assms, auto intro!: AE_I2 simp: indicator_def norm_divide norm_powr_real_powr)
   from Gamma_hurwitz_zeta_aux_integral[of "of_real x" a n] and assms
     have "of_real (Gamma x / (real n + a) powr x) = set_lebesgue_integral lebesgue {0<..} 
             (\<lambda>s. complex_of_real s powr (of_real x - 1) / of_real (exp ((n+a) * s)))" (is "_ = ?I")
       by (auto simp: Gamma_complex_of_real powr_Reals_eq)
   also have "?I = lebesgue_integral lebesgue
                     (\<lambda>s. of_real (indicator {0<..} s *\<^sub>R (s powr (x - 1) / exp ((n+a) * s))))"
     unfolding set_lebesgue_integral_def
     using assms by (intro Bochner_Integration.integral_cong refl) 
                    (auto simp: indicator_def powr_Reals_eq)
   also have "\<dots> = of_real (set_lebesgue_integral lebesgue {0<..} 
                     (\<lambda>s. s powr (x - 1) / exp ((n+a) * s)))"
     unfolding set_lebesgue_integral_def
     by (rule Bochner_Integration.integral_complex_of_real)
   finally show "Gamma x / (real n + a) powr x = set_lebesgue_integral lebesgue {0<..} 
                   (\<lambda>s. s powr (x - 1) / exp ((real n + a) * s))"
     by (subst (asm) of_real_eq_iff)
 qed
 
 theorem
   assumes "Re z > 1" and "a > (0::real)"
   shows   Gamma_times_hurwitz_zeta_integral: "Gamma z * hurwitz_zeta a z =
             (\<integral>x\<in>{0<..}. (of_real x powr (z - 1) * of_real (exp (-a*x) / (1 - exp (-x)))) \<partial>lebesgue)"
     and   Gamma_times_hurwitz_zeta_integrable:
             "set_integrable lebesgue {0<..} 
                (\<lambda>x. of_real x powr (z - 1) * of_real (exp (-a*x) / (1 - exp (-x))))"
 proof -
   from assms have z: "Re z > 0" by simp
   let ?INT = "set_lebesgue_integral lebesgue {0<..} :: (real \<Rightarrow> complex) \<Rightarrow> complex"
   let ?INT' = "set_lebesgue_integral lebesgue {0<..} :: (real \<Rightarrow> real) \<Rightarrow> real"
 
   have 1: "complex_set_integrable lebesgue {0<..} 
             (\<lambda>x. of_real x powr (z - 1) / of_real (exp ((real n + a) * x)))" for n
       by (rule Gamma_hurwitz_zeta_aux_integrable) (use assms in simp_all)
   have 2: "summable (\<lambda>n. norm (indicator {0<..} s *\<^sub>R (of_real s powr (z - 1) / 
              of_real (exp ((n + a) * s)))))" for s
   proof (cases "s > 0")
     case True
     hence "summable (\<lambda>n. norm (of_real s powr (z - 1)) * exp (-a * s) * exp (-s) ^ n)"
       using assms by (intro summable_mult summable_geometric) simp_all
     with True show ?thesis
       by (simp add: norm_mult norm_divide exp_add exp_diff
                     exp_minus field_simps exp_of_nat_mult [symmetric])
   qed simp_all
   have 3: "summable (\<lambda>n. \<integral>x. norm (indicator {0<..} x *\<^sub>R (complex_of_real x powr (z - 1) /
                             complex_of_real (exp ((n + a) * x)))) \<partial>lebesgue)"
   proof -
     have "summable (\<lambda>n. Gamma (Re z) * (real n + a) powr -Re z)"
       using assms by (intro summable_mult summable_hurwitz_zeta_real) simp_all
     also have "?this \<longleftrightarrow> summable (\<lambda>n. ?INT' (\<lambda>s. norm (of_real s powr (z - 1) / 
                                        of_real (exp ((n+a) * s)))))"
     proof (intro summable_cong always_eventually allI, goal_cases)
       case (1 n)
       have "Gamma (Re z) * (real n + a) powr -Re z = Gamma (Re z) / (real n + a) powr Re z"
         by (subst powr_minus) (simp_all add: field_simps)
       also from assms have "\<dots> = (\<integral>x\<in>{0<..}. (x powr (Re z-1) / exp ((n+a) * x)) \<partial>lebesgue)"
         by (subst Gamma_hurwitz_zeta_aux_integral_real) simp_all
       also have "\<dots> = (\<integral>xa\<in>{0<..}. norm (of_real xa powr (z-1) / of_real (exp ((n+a) * xa)))
                          \<partial>lebesgue)"
         unfolding set_lebesgue_integral_def
         by (intro Bochner_Integration.integral_cong refl)
           (auto simp: indicator_def norm_divide norm_powr_real_powr)
       finally show ?case .
     qed
     finally show ?thesis
       by (simp add: set_lebesgue_integral_def)
   qed
 
   have sum_eq: "(\<Sum>n. indicator {0<..} s *\<^sub>R (of_real s powr (z - 1) / of_real (exp ((n+a) * s)))) = 
                    indicator {0<..} s *\<^sub>R (of_real s powr (z - 1) * 
                      of_real (exp (-a * s) / (1 - exp (-s))))" for s
   proof (cases "s > 0")
     case True
     hence "(\<Sum>n. indicator {0..} s *\<^sub>R (of_real s powr (z - 1) / of_real (exp ((n+a) * s)))) =
              (\<Sum>n. of_real s powr (z - 1) * of_real (exp (-a * s)) * of_real (exp (-s)) ^ n)"
       by (intro suminf_cong) 
          (auto simp: exp_add exp_minus exp_of_nat_mult [symmetric] field_simps of_real_exp)
     also have "(\<Sum>n. of_real s powr (z - 1) * of_real (exp (-a * s)) * of_real (exp (-s)) ^ n) =
                  of_real s powr (z - 1) * of_real (exp (-a * s)) * (\<Sum>n. of_real (exp (-s)) ^ n)"
       using True by (intro suminf_mult summable_geometric) simp_all
     also have "(\<Sum>n. complex_of_real (exp (-s)) ^ n) = 1 / (1 - of_real (exp (-s)))"
       using True by (intro suminf_geometric) auto
     also have "of_real s powr (z - 1) * of_real (exp (-a * s)) * \<dots> = 
                  of_real s powr (z - 1) * of_real (exp (-a * s) / (1 - exp (-s)))" using \<open>a > 0\<close>
       by (auto simp add: divide_simps exp_minus)
     finally show ?thesis using True by simp
   qed simp_all
 
   show "set_integrable lebesgue {0<..} 
           (\<lambda>x. of_real x powr (z - 1) * of_real (exp (-a*x) / (1 - exp (-x))))"
     using 1 unfolding sum_eq [symmetric] set_integrable_def 
     by (intro integrable_suminf[OF _ AE_I2] 2 3)
 
   have "(\<lambda>n. ?INT (\<lambda>s. s powr (z - 1) / exp ((n+a) * s))) sums lebesgue_integral lebesgue
             (\<lambda>s. \<Sum>n. indicator {0<..} s *\<^sub>R (s powr (z - 1) / exp ((n+a) * s)))" (is "?A sums ?B")
     using 1 unfolding set_lebesgue_integral_def set_integrable_def
     by (rule sums_integral[OF _ AE_I2[OF 2] 3])
   also have "?A = (\<lambda>n. Gamma z * (n + a) powr -z)"
     using assms by (subst Gamma_hurwitz_zeta_aux_integral [symmetric]) 
                    (simp_all add: powr_minus divide_simps)
   also have "?B = ?INT (\<lambda>s. of_real s powr (z - 1) * of_real (exp (-a * s) / (1 - exp (-s))))"
     unfolding sum_eq set_lebesgue_integral_def ..
   finally have "(\<lambda>n. Gamma z * (of_nat n + of_real a) powr -z) sums
                   ?INT (\<lambda>x. of_real x powr (z - 1) * of_real (exp (-a * x) / (1 - exp (-x))))" 
     by simp
   moreover have "(\<lambda>n. Gamma z * (of_nat n + of_real a) powr -z) sums (Gamma z * hurwitz_zeta a z)"
     using assms by (intro sums_mult sums_hurwitz_zeta) simp_all
   ultimately show "Gamma z * hurwitz_zeta a z = 
                      (\<integral>x\<in>{0<..}. (of_real x powr (z - 1) * 
                         of_real (exp (-a * x) / (1 - exp (-x)))) \<partial>lebesgue)"
     by (rule sums_unique2 [symmetric])
 qed
 
 corollary
   assumes "Re z > 1"
   shows   Gamma_times_zeta_integral: "Gamma z * zeta z =
             (\<integral>x\<in>{0<..}. (of_real x powr (z - 1) / of_real (exp x - 1)) \<partial>lebesgue)" (is ?th1)
     and   Gamma_times_zeta_integrable:
             "set_integrable lebesgue {0<..} 
                (\<lambda>x. of_real x powr (z - 1) / of_real (exp x - 1))" (is ?th2)
 proof -
   have *: "(\<lambda>x. indicator {0<..} x *\<^sub>R (of_real x powr (z - 1) * 
                 of_real (exp (-x) / (1 - exp (-x))))) =
              (\<lambda>x. indicator {0<..} x *\<^sub>R (of_real x powr (z - 1) / of_real (exp x - 1)))"
     by (intro ext) (simp add: field_simps exp_minus indicator_def)
   from Gamma_times_hurwitz_zeta_integral [OF assms zero_less_one] and *
     show ?th1 by (simp add: zeta_def set_lebesgue_integral_def)
   from Gamma_times_hurwitz_zeta_integrable [OF assms zero_less_one] and *
     show ?th2 by (simp add: zeta_def set_integrable_def)
 qed
 
 corollary hurwitz_zeta_integral_Gamma_def:
   assumes "Re z > 1" "a > 0"
   shows   "hurwitz_zeta a z = 
              rGamma z * (\<integral>x\<in>{0<..}. (of_real x powr (z - 1) * 
                of_real (exp (-a * x) / (1 - exp (-x)))) \<partial>lebesgue)"
 proof -
   from assms have "Gamma z \<noteq> 0" 
     by (subst Gamma_eq_zero_iff) (auto elim!: nonpos_Ints_cases)
   with Gamma_times_hurwitz_zeta_integral [OF assms] show ?thesis
     by (simp add: rGamma_inverse_Gamma field_simps)
 qed
 
 corollary zeta_integral_Gamma_def:
   assumes "Re z > 1"
   shows   "zeta z =
              rGamma z * (\<integral>x\<in>{0<..}. (of_real x powr (z - 1) / of_real (exp x - 1)) \<partial>lebesgue)"
 proof -
   from assms have "Gamma z \<noteq> 0" 
     by (subst Gamma_eq_zero_iff) (auto elim!: nonpos_Ints_cases)
   with Gamma_times_zeta_integral [OF assms] show ?thesis
     by (simp add: rGamma_inverse_Gamma field_simps)
 qed
 
 lemma Gamma_times_zeta_has_integral:
   assumes "Re z > 1"
   shows   "((\<lambda>x. x powr (z - 1) / (of_real (exp x) - 1)) has_integral (Gamma z * zeta z)) {0<..}"
     (is "(?f has_integral _) _")
 proof -
   have "(?f has_integral set_lebesgue_integral lebesgue {0<..} ?f) {0<..}"
     using Gamma_times_zeta_integrable[OF assms]
     by (intro has_integral_set_lebesgue) auto
   also have "set_lebesgue_integral lebesgue {0<..} ?f = Gamma z * zeta z"
     using Gamma_times_zeta_integral[OF assms] by simp
   finally show ?thesis .
 qed
 
 lemma Gamma_times_zeta_has_integral_real:
   fixes z :: real
   assumes "z > 1"
   shows   "((\<lambda>x. x powr (z - 1) / (exp x - 1)) has_integral (Gamma z * Re (zeta z))) {0<..}"
 proof -
   from assms have *: "Re (of_real z) > 1" by simp
   have "((\<lambda>x. Re (complex_of_real x powr (complex_of_real z - 1)) / (exp x - 1)) has_integral
            Gamma z * Re (zeta (complex_of_real z))) {0<..}"
     using has_integral_linear[OF Gamma_times_zeta_has_integral[OF *] bounded_linear_Re] 
     by (simp add: o_def Gamma_complex_of_real)
   also have "?this \<longleftrightarrow> ?thesis"
     using assms by (intro has_integral_cong) (auto simp: powr_Reals_eq)
   finally show ?thesis .
 qed
 
 lemma Gamma_integral_real':
   assumes x: "x > (0 :: real)"
   shows   "((\<lambda>t. t powr (x - 1) / exp t) has_integral Gamma x) {0<..}"
   using Gamma_integral_real[OF assms] by (subst has_integral_closure [symmetric]) auto
 
 
 subsection \<open>An analytic proof of the infinitude of primes\<close>
 
 text \<open>
   We can now also do an analytic proof of the infinitude of primes.
 \<close>
 lemma primes_infinite_analytic: "infinite {p :: nat. prime p}"
 proof
   \<comment> \<open>Suppose the set of primes were finite.\<close>
   define P :: "nat set" where "P = {p. prime p}"
   assume fin: "finite P"
 
   \<comment> \<open>Then the Euler product form of the $\zeta$ function ranges over a finite set,
       and since each factor is holomorphic in the positive real half-space, 
       the product is, too.\<close>
   define zeta' :: "complex \<Rightarrow> complex" 
     where "zeta' = (\<lambda>s. (\<Prod>p\<in>P. inverse (1 - 1 / of_nat p powr s)))"
   have holo: "zeta' holomorphic_on A" if "A \<subseteq> {s. Re s > 0}" for A
   proof -
     {
       fix p :: nat and s :: complex assume p: "p \<in> P" and s: "s \<in> A"
       from p have p': "real p > 1" 
         by (subst of_nat_1 [symmetric], subst of_nat_less_iff) (simp add: prime_gt_Suc_0_nat P_def)
       have "norm (of_nat p powr s) = real p powr Re s"
         by (simp add: norm_powr_real_powr)
       also have "\<dots> > real p powr 0" using p p' s that
         by (subst powr_less_cancel_iff) (auto simp: prime_gt_1_nat)
       finally have "of_nat p powr s \<noteq> 1" using p by (auto simp: P_def)
     }
     thus ?thesis by (auto simp: zeta'_def P_def intro!: holomorphic_intros)
   qed
 
   \<comment> \<open>Since the Euler product expansion of $\zeta(s)$ is valid for all $s$ with
       real value at least 1, and both $\zeta(s)$ and the Euler product must 
       be equal in the positive real half-space punctured at 1 by analytic
       continuation.\<close>
   have eq: "zeta s = zeta' s" if "Re s > 0" "s \<noteq> 1" for s
   proof (rule analytic_continuation_open[of "{s. Re s > 1}" "{s. Re s > 0} - {1}" zeta zeta'])
     fix s assume s: "s \<in> {s. Re s > 1}"
     let ?f = "(\<lambda>n. \<Prod>p\<le>n. if prime p then inverse (1 - 1 / of_nat p powr s) else 1)"
     have "eventually (\<lambda>n. ?f n = zeta' s) sequentially"
       using eventually_ge_at_top[of "Max P"]
     proof eventually_elim
       case (elim n)
       have "P \<noteq> {}" by (auto simp: P_def intro!: exI[of _ 2])
       with elim have "P \<subseteq> {..n}" using fin by auto
       thus ?case unfolding zeta'_def
         by (intro prod.mono_neutral_cong_right) (auto simp: P_def)
     qed
     moreover from s have "?f \<longlonglongrightarrow> zeta s" by (intro euler_product_zeta) auto
     ultimately have "(\<lambda>_. zeta' s) \<longlonglongrightarrow> zeta s"
       by (blast intro: Lim_transform_eventually)
     thus "zeta s = zeta' s" by (simp add: LIMSEQ_const_iff)
   qed (auto intro!: exI[of _ 2] open_halfspace_Re_gt connected_open_delete convex_halfspace_Re_gt 
          holomorphic_intros holo that intro: convex_connected)
 
   \<comment> \<open>However, since the Euler product is holomorphic on the entire positive real
       half-space, it cannot have a pole at 1, while $\zeta(s)$ does have a pole
       at 1. Since they are equal in the punctured neighbourhood of 1, this is
       a contradiction.\<close>
   have ev: "eventually (\<lambda>s. s \<in> {s. Re s > 0} - {1}) (at 1)"
     by (auto simp: eventually_at_filter intro!: open_halfspace_Re_gt
                eventually_mono[OF eventually_nhds_in_open[of "{s. Re s > 0}"]])
   have "\<not>is_pole zeta' 1"
     by (rule not_is_pole_holomorphic [of "{s. Re s > 0}"]) (auto intro!: holo open_halfspace_Re_gt)
   also have "is_pole zeta' 1 \<longleftrightarrow> is_pole zeta 1" unfolding is_pole_def
     by (intro filterlim_cong refl eventually_mono [OF ev] eq [symmetric]) auto
   finally show False using is_pole_zeta by contradiction
 qed
 
 
 subsection \<open>The periodic zeta function\<close>
 
 text \<open>
   The periodic zeta function $F(s, q)$ (as described e.\,g.\ by Apostol~\cite{apostol1976analytic} 
   is related to the Hurwitz zeta function. It is periodic in \<open>q\<close> with period 1 and it can be 
   represented by a Dirichlet series that is absolutely convergent for $\mathfrak{R}(s) > 1$.
    If \<open>q \<notin> \<int>\<close>, it furthermore convergent for $\mathfrak{R}(s) > 0$.
 
   It is clear that for integer \<open>q\<close>, we have $F(s, q) = F(s, 0) = \zeta(s)$. Moreover, for
   non-integer \<open>q\<close>, $F(s, q)$ can be analytically continued to an entire function.
 \<close>
 definition fds_perzeta :: "real \<Rightarrow> complex fds" where
   "fds_perzeta q = fds (\<lambda>m. exp (2 * pi * \<i> * m * q))"
 
 text \<open>
   The definition of the periodic zeta function on the full domain is a bit unwieldy.
   The precise reasoning for this definition will be given later, and, in any case, it
   is probably more instructive to look at the derived ``alternative'' definitions later.
 \<close>
 definition perzeta :: "real \<Rightarrow> complex \<Rightarrow> complex" where
   "perzeta q' s =
      (if q' \<in> \<int> then zeta s
       else let q = frac q' in
         if s = 0 then \<i> / (2 * pi) * (pre_zeta q 1 - pre_zeta (1 - q) 1 + 
                                              ln (1 - q) - ln q + pi * \<i>)
         else if s \<in> \<nat> then eval_fds (fds_perzeta q) s 
         else complex_of_real (2 * pi) powr (s - 1) * \<i> * Gamma (1 - s) *
                (\<i> powr (-s) * hurwitz_zeta q (1 - s) -
                 \<i> powr s * hurwitz_zeta (1 - q) (1 - s)))"
 
 interpretation fds_perzeta: periodic_fun_simple' fds_perzeta
   by standard (simp_all add: fds_perzeta_def exp_add ring_distribs exp_eq_polar
                              cis_mult [symmetric] cis_multiple_2pi)
 
 interpretation perzeta: periodic_fun_simple' perzeta
 proof -
   have [simp]: "n + 1 \<in> \<int> \<longleftrightarrow> n \<in> \<int>" for n :: real
     by (simp flip: frac_eq_0_iff add: frac.plus_1)
   show "periodic_fun_simple' perzeta"
     by standard (auto simp: fun_eq_iff perzeta_def Let_def frac.plus_1)
 qed
 
 lemma perzeta_frac [simp]: "perzeta (frac q) = perzeta q"
   by (auto simp: perzeta_def fun_eq_iff Let_def)
 
 lemma fds_perzeta_frac [simp]: "fds_perzeta (frac q) = fds_perzeta q"
   using fds_perzeta.plus_of_int[of "frac q" "\<lfloor>q\<rfloor>"] by (simp add: frac_def)
 
 lemma abs_conv_abscissa_perzeta: "abs_conv_abscissa (fds_perzeta q) \<le> 1"
 proof (rule abs_conv_abscissa_leI)
   fix c assume c: "ereal c > 1"
   hence "summable (\<lambda>n. n powr -c)"
     by (simp add: summable_real_powr_iff)
   also have "?this \<longleftrightarrow> fds_abs_converges (fds_perzeta q) (of_real c)" unfolding fds_abs_converges_def
     by (intro summable_cong eventually_mono[OF eventually_gt_at_top[of 0]])
        (auto simp: norm_divide norm_powr_real_powr fds_perzeta_def powr_minus field_simps)
   finally show "\<exists>s. s \<bullet> 1 = c \<and> fds_abs_converges (fds_perzeta q) s"
     by (intro exI[of _ "of_real c"]) auto
 qed
 
 lemma conv_abscissa_perzeta: "conv_abscissa (fds_perzeta q) \<le> 1"
   by (rule order.trans[OF conv_le_abs_conv_abscissa abs_conv_abscissa_perzeta])
 
 lemma fds_perzeta__left_0 [simp]: "fds_perzeta 0 = fds_zeta"
   by (simp add: fds_perzeta_def fds_zeta_def)
 
 lemma perzeta_0_left [simp]: "perzeta 0 s = zeta s"
   by (simp add: perzeta_def eval_fds_zeta)
 
 lemma perzeta_int: "q \<in> \<int> \<Longrightarrow> perzeta q = zeta"
   by (simp add: perzeta_def fun_eq_iff)
 
 lemma fds_perzeta_int: "q \<in> \<int> \<Longrightarrow> fds_perzeta q = fds_zeta"
   by (auto simp: fds_perzeta.of_int elim!: Ints_cases)
 
 lemma sums_fds_perzeta:
   assumes "Re s > 1"
   shows   "(\<lambda>m. exp (2 * pi * \<i> * Suc m * q) / of_nat (Suc m) powr s) sums
              eval_fds (fds_perzeta q) s"
 proof -
   have "conv_abscissa (fds_perzeta q) \<le> 1" by (rule conv_abscissa_perzeta)
   also have "\<dots> < ereal (Re s)"  using assms by (simp add: one_ereal_def)
   finally have "fds_converges (fds_perzeta q) s" by (intro fds_converges) auto
   hence "(\<lambda>n. fds_nth (fds_perzeta q) (Suc n) / nat_power (Suc n) s) sums
            eval_fds (fds_perzeta q) s" by (subst sums_Suc_iff) (auto simp: fds_converges_iff)
   thus ?thesis by (simp add: fds_perzeta_def)
 qed
 
 lemma sum_tendsto_fds_perzeta:
   assumes "Re s > 1"
   shows   "(\<lambda>n. \<Sum>k\<in>{0<..n}. exp (2 * real k * pi * q * \<i>) * of_nat k powr - s)
               \<longlonglongrightarrow> eval_fds (fds_perzeta q) s"
 proof -
   have "(\<lambda>m. exp (2 * pi * \<i> * Suc m * q) / of_nat (Suc m) powr s) sums eval_fds (fds_perzeta q) s"
     by (intro sums_fds_perzeta assms)
   hence "(\<lambda>n. \<Sum>k<n. exp (2 * real (Suc k) * pi * q * \<i>) * of_nat (Suc k) powr -s) \<longlonglongrightarrow>
            eval_fds (fds_perzeta q) s"
     (is "filterlim ?f _ _") by (simp add: sums_def powr_minus field_simps)
   also have "?f = (\<lambda>n. \<Sum>k\<in>{0<..n}. exp (2 * real k * pi * q * \<i>) * of_nat k powr -s)"
     by (intro ext sum.reindex_bij_betw sum.reindex_bij_witness[of _ "\<lambda>n. n - 1" Suc]) auto
   finally show ?thesis by simp
 qed
 
 text \<open>
   Using the geometric series, it is easy to see that the Dirichlet series for $F(s, q)$
   has bounded partial sums for non-integer \<open>q\<close>, so it must converge for any \<open>s\<close> with
   $\mathfrak{R}(s) > 0$.
 \<close>
 lemma conv_abscissa_perzeta':
   assumes "q \<notin> \<int>"
   shows   "conv_abscissa (fds_perzeta q) \<le> 0"
 proof (rule conv_abscissa_leI)
   fix c :: real assume c: "ereal c > 0"
   have "fds_converges (fds_perzeta q) (of_real c)"
   proof (rule bounded_partial_sums_imp_fps_converges)
     define \<omega> where "\<omega> = exp (2 * pi * \<i> * q)"
     have [simp]: "norm \<omega> = 1" by (simp add: \<omega>_def)
     define M where "M = 2 / norm (1 - \<omega>)"
     from \<open>q \<notin> \<int>\<close> have "\<omega> \<noteq> 1"
       by (auto simp: \<omega>_def exp_eq_1)
     hence "M > 0" by (simp add: M_def)
   
     show "Bseq (\<lambda>n. \<Sum>k\<le>n. fds_nth (fds_perzeta q) k / nat_power k 0)"
       unfolding Bseq_def
     proof (rule exI, safe)
       fix n :: nat
       show "norm (\<Sum>k\<le>n. fds_nth (fds_perzeta q) k / nat_power k 0) \<le> M"
       proof (cases "n = 0")
         case False
         have "(\<Sum>k\<le>n. fds_nth (fds_perzeta q) k / nat_power k 0) =
                 (\<Sum>k\<in>{1..1 + (n - 1)}. \<omega> ^ k)" using False
           by (intro sum.mono_neutral_cong_right)
              (auto simp: fds_perzeta_def fds_nth_fds exp_of_nat_mult [symmetric] mult_ac \<omega>_def)
         also have "\<dots> = \<omega> * (1 - \<omega> ^ n) / (1 - \<omega>)" using \<open>\<omega> \<noteq> 1\<close> and False
           by (subst sum_gp_offset) simp
         also have "norm \<dots> \<le> 1 * (norm (1::complex) + norm (\<omega> ^ n)) / norm (1 - \<omega>)"
           unfolding norm_mult norm_divide
           by (intro mult_mono divide_right_mono norm_triangle_ineq4) auto
         also have "\<dots> = M" by (simp add: M_def norm_power)
         finally show ?thesis .
       qed (use \<open>M > 0\<close> in simp_all)
     qed fact+
   qed (insert c, auto)
   thus "\<exists>s. s \<bullet> 1 = c \<and> fds_converges (fds_perzeta q) s"
     by (intro exI[of _ "of_real c"]) auto
 qed
 
 lemma fds_perzeta_one_half: "fds_perzeta (1 / 2) = fds (\<lambda>n. (-1) ^ n)"
   using Complex.DeMoivre[of pi]
   by (intro fds_eqI) (auto simp: fds_perzeta_def exp_eq_polar mult_ac)
 
 lemma perzeta_one_half_1 [simp]: "perzeta (1 / 2) 1 = -ln 2"
 proof (rule sums_unique2)
   have *: "(1 / 2 :: real) \<notin> \<int>"
     using fraction_not_in_ints[of 2 1] by auto
   have "fds_converges (fds_perzeta (1 / 2)) 1"
     by (rule fds_converges, rule le_less_trans, rule conv_abscissa_perzeta') (use * in auto)
   hence "(\<lambda>n. (-1) ^ Suc n / Suc n) sums eval_fds (fds_perzeta (1 / 2)) 1"
     unfolding fds_converges_altdef by (simp add: fds_perzeta_one_half)
   also from * have "eval_fds (fds_perzeta (1 / 2)) 1 = perzeta (1 / 2) 1"
     by (simp add: perzeta_def)
   finally show "(\<lambda>n. -complex_of_real ((-1) ^ n / Suc n)) sums perzeta (1 / 2) 1"
     by simp
   hence "(\<lambda>n. -complex_of_real ((-1) ^ n / Suc n)) sums -of_real (ln 2)"
     by (intro sums_minus sums_of_real alternating_harmonic_series_sums)
   thus "(\<lambda>n. -complex_of_real ((-1) ^ n / Suc n)) sums -(ln 2)"
     by (simp flip: Ln_of_real)
 qed
 
 
 subsection \<open>Hurwitz's formula\<close>
 
 text \<open>
   We now move on to prove Hurwitz's formula relating the Hurwitz zeta function and the
   periodic zeta function. We mostly follow Apostol's proof, although we do make some small
   changes in order to make the proof more amenable to Isabelle's complex analysis library.
  
   The big difference is that Apostol integrates along a circle with a slit, where the two
   sides of the slit lie on different branches of the integrand. This makes sense when looking
   as the integrand as a Riemann surface, but we do not have a notion of Riemann surfaces in
   Isabelle.
 
   It is therefore much easier to simply cut the circle into an upper and a lower half. In fact,
   the integral on the lower half can be reduced to the one on the upper half easily by
   symmetry, so we really only need to handle the integral on the upper half. The integration
   contour that we will use is therefore a semi-annulus in the upper half of the complex plane,
   centred around the origin.
 
   Now, first of all, we prove the existence of an important improper integral 
   that we will need later.
 \<close>
 (* TODO: Move *)
 lemma set_integrable_bigo:
   fixes f g :: "real \<Rightarrow> 'a :: {banach, real_normed_field, second_countable_topology}"
   assumes "f \<in> O(\<lambda>x. g x)" and "set_integrable lborel {a..} g"
   assumes "\<And>b. b \<ge> a \<Longrightarrow> set_integrable lborel {a..<b} f"
   assumes [measurable]: "set_borel_measurable borel {a..} f"
   shows   "set_integrable lborel {a..} f"
 proof -
   from assms(1) obtain C x0 where C: "C > 0" "\<And>x. x \<ge> x0 \<Longrightarrow> norm (f x) \<le> C * norm (g x)"
     by (fastforce elim!: landau_o.bigE simp: eventually_at_top_linorder)
   define x0' where "x0' = max a x0"
 
   have "set_integrable lborel {a..<x0'} f"
     by (intro assms) (auto simp: x0'_def)
   moreover have "set_integrable lborel {x0'..} f" unfolding set_integrable_def
   proof (rule Bochner_Integration.integrable_bound)
     from assms(2) have "set_integrable lborel {x0'..} g"
       by (rule set_integrable_subset) (auto simp: x0'_def)
     thus "integrable lborel (\<lambda>x. C *\<^sub>R (indicator {x0'..} x *\<^sub>R g x))" unfolding set_integrable_def
       by (intro integrable_scaleR_right) (simp add: abs_mult norm_mult)
   next
     from assms(4) have "set_borel_measurable borel {x0'..} f"
       by (rule set_borel_measurable_subset) (auto simp: x0'_def)
     thus "(\<lambda>x. indicator {x0'..} x *\<^sub>R f x) \<in> borel_measurable lborel"
       by (simp add: set_borel_measurable_def)
   next
     show "AE x in lborel. norm (indicator {x0'..} x *\<^sub>R f x)
                             \<le> norm (C *\<^sub>R (indicator {x0'..} x *\<^sub>R g x))"
       using C by (intro AE_I2) (auto simp: abs_mult indicator_def x0'_def)
   qed
   ultimately have "set_integrable lborel ({a..<x0'} \<union> {x0'..}) f"
     by (rule set_integrable_Un) auto
   also have "{a..<x0'} \<union> {x0'..} = {a..}" by (auto simp: x0'_def)
   finally show ?thesis .
 qed
 
 lemma set_integrable_Gamma_hurwitz_aux2_real:
   fixes s a :: real
   assumes "r > 0" and "a > 0"
   shows "set_integrable lborel {r..} (\<lambda>x. x powr s * (exp (-a * x)) / (1 - exp (-x)))"
     (is "set_integrable _ _ ?g")
 proof (rule set_integrable_bigo)
   have "(\<lambda>x. exp (-(a/2) * x)) integrable_on {r..}" using assms
     by (intro integrable_on_exp_minus_to_infinity) auto
   hence "set_integrable lebesgue {r..} (\<lambda>x. exp (-(a/2) * x))"
     by (intro nonnegative_absolutely_integrable) simp_all
   thus "set_integrable lborel {r..} (\<lambda>x. exp (-(a/2) * x))"
     by (simp add: set_integrable_def integrable_completion)
 next
   fix y :: real
   have "set_integrable lborel {r..y} ?g" using assms
     by (intro borel_integrable_atLeastAtMost') (auto intro!: continuous_intros)
   thus "set_integrable lborel {r..<y} ?g"
     by (rule set_integrable_subset) auto
 next
   from assms show "?g \<in> O(\<lambda>x. exp (-(a/2) * x))"
     by real_asymp
 qed (auto simp: set_borel_measurable_def)
 
 lemma set_integrable_Gamma_hurwitz_aux2:
   fixes s :: complex and a :: real
   assumes "r > 0" and "a > 0"
   shows   "set_integrable lborel {r..} (\<lambda>x. x powr -s * (exp (- a * x)) / (1 - exp (- x)))"
              (is "set_integrable _ _ ?g")
 proof -
   have "set_integrable lborel {r..} (\<lambda>x. x powr -Re s * (exp (-a * x)) / (1 - exp (-x)))" 
     (is "set_integrable _ _ ?g'")
     by (rule set_integrable_Gamma_hurwitz_aux2_real) (use assms in auto)
   also have "?this \<longleftrightarrow> integrable lborel (\<lambda>x. indicator {r..} x *\<^sub>R ?g' x)"
     by (simp add: set_integrable_def)
   also have "(\<lambda>x. indicator {r..} x *\<^sub>R ?g' x) = (\<lambda>x. norm (indicator {r..} x *\<^sub>R ?g x))" using assms
     by (auto simp: indicator_def norm_mult norm_divide norm_powr_real_powr fun_eq_iff
                    exp_of_real exp_minus norm_inverse in_Reals_norm power2_eq_square divide_simps)
   finally show ?thesis unfolding set_integrable_def
     by (subst (asm) integrable_norm_iff) auto
 qed
 
 lemma closed_neg_Im_slit: "closed {z. Re z = 0 \<and> Im z \<le> 0}"
 proof -
   have "closed ({z. Re z = 0} \<inter> {z. Im z \<le> 0})"
     by (intro closed_Int closed_halfspace_Re_eq closed_halfspace_Im_le)
   also have "{z. Re z = 0} \<inter> {z. Im z \<le> 0} = {z. Re z = 0 \<and> Im z \<le> 0}" by blast
   finally show ?thesis .
 qed
 
 
 text \<open>
   We define tour semi-annulus path. When this path is mirrored into the lower half of the complex
   plane and subtracted from the original path and the outer radius tends to \<open>\<infinity>\<close>, this becomes a
   Hankel contour extending to \<open>-\<infinity>\<close>.
 \<close>
 definition hankel_semiannulus :: "real \<Rightarrow> nat \<Rightarrow> real \<Rightarrow> complex" where
  "hankel_semiannulus r N = (let R = (2 * N + 1) * pi in
     part_circlepath 0 R 0 pi +++                  \<comment>\<open>Big half circle\<close>
     linepath (of_real (-R)) (of_real (-r)) +++    \<comment>\<open>Line on the negative real axis\<close>
     part_circlepath 0 r pi 0 +++                  \<comment>\<open>Small half circle\<close>
     linepath (of_real r) (of_real R))             \<comment>\<open>Line on the positive real axis\<close>" 
 
 lemma path_hankel_semiannulus [simp, intro]: "path (hankel_semiannulus r R)"
   and valid_path_hankel_semiannulus [simp, intro]: "valid_path (hankel_semiannulus r R)"
   and pathfinish_hankel_semiannulus [simp, intro]:
         "pathfinish (hankel_semiannulus r R) = pathstart (hankel_semiannulus r R)"
   by (simp_all add: hankel_semiannulus_def Let_def)
 
 
 text \<open>
   We set the stage for an application of the Residue Theorem. We define a function
   \[f(s, z) = z^{-s} \frac{\exp(az)}{1-\exp(-z)}\ ,\]
   which will be the integrand. However, the principal branch of $z^{-s}$ has a branch cut
   along the non-positive real axis, which is bad because a part of our integration path also
   lies on the non-positive real axis. We therefore choose a slightly different branch of $z^{-s}$
   by moving the logarithm branch along by $90^{\circ}$ so that the branch cut lies on the
   non-positive imaginary axis instead.
 \<close>
 context
   fixes a :: real
   fixes f :: "complex \<Rightarrow> complex \<Rightarrow> complex"
     and g :: "complex \<Rightarrow> real \<Rightarrow> complex"
     and h :: "real \<Rightarrow> complex \<Rightarrow> real \<Rightarrow> complex"
     and Res :: "complex \<Rightarrow> nat \<Rightarrow> complex" 
     and Ln' :: "complex \<Rightarrow> complex"
     and F :: "real \<Rightarrow> complex \<Rightarrow> complex"
   assumes a: "a \<in> {0<..1}"
 
   \<comment>\<open>Our custom branch of the logarithm\<close>
   defines "Ln' \<equiv> (\<lambda>z. ln (-\<i> * z) + \<i> * pi / 2)"
 
   \<comment>\<open>The integrand\<close>
   defines "f \<equiv> (\<lambda>s z. exp (Ln' z * (-s) + of_real a * z) / (1 - exp z))"
 
   \<comment>\<open>The integrand on the negative real axis\<close>
   defines "g \<equiv> (\<lambda>s x. complex_of_real x powr -s * of_real (exp (-a*x)) / of_real (1 - exp (-x)))"
 
   \<comment>\<open>The integrand on the circular arcs\<close>
   defines "h \<equiv> (\<lambda>r s t. r * \<i> * cis t * exp (a * (r * cis t) - (ln r + \<i> * t) * s) /
                         (1 - exp (r * cis t)))"
 
   \<comment>\<open>The interesting part of the residues\<close>
   defines "Res \<equiv> (\<lambda>s k. exp (of_real (2 * real k * pi * a) * \<i>) *
                             of_real (2 * real k * pi) powr (-s))"
 
   \<comment>\<open>The periodic zeta function (at least on $\mathfrak{R}(s) > 1$ half-plane)\<close>
   defines "F \<equiv> (\<lambda>q. eval_fds (fds_perzeta q))"
 begin
 
 text \<open>
   First, some basic properties of our custom branch of the logarithm:
 \<close>
 lemma Ln'_i: "Ln' \<i> = \<i> * pi / 2"
   by (simp add: Ln'_def)
 
 lemma Ln'_of_real_pos:
   assumes "x > 0"
   shows   "Ln' (of_real x) = of_real (ln x)"
 proof -
   have "Ln' (of_real x) = Ln (of_real x * (-\<i>)) + \<i> * pi / 2"
     by (simp add: Ln'_def mult_ac)
   also have "\<dots> = of_real (ln x)" using assms
     by (subst Ln_times_of_real) (auto simp: Ln_of_real)
   finally show ?thesis .
 qed
 
 lemma Ln'_of_real_neg:
   assumes "x < 0"
   shows   "Ln' (of_real x) = of_real (ln (-x)) + \<i> * pi"
 proof -
   have "Ln' (of_real x) = Ln (of_real (-x) * \<i>) + \<i> * pi / 2"
     by (simp add: Ln'_def mult_ac)
   also have "\<dots> = of_real (ln (-x)) + \<i> * pi" using assms
     by (subst Ln_times_of_real) (auto simp: Ln_Reals_eq)
   finally show ?thesis .
 qed
 
 lemma Ln'_times_of_real:
   "Ln' (of_real x * z) = of_real (ln x) + Ln' z" if "x > 0" "z \<noteq> 0" for z x
 proof -
   have "Ln' (of_real x * z) = Ln (of_real x * (- \<i> * z)) + \<i> * pi / 2"
     by (simp add: Ln'_def mult_ac)
   also have "\<dots> = of_real (ln x) + Ln' z"
     using that by (subst Ln_times_of_real) (auto simp: Ln'_def Ln_of_real)
   finally show ?thesis .
 qed
 
 lemma Ln'_cis:
   assumes "t \<in> {-pi / 2<..3 / 2 * pi}"
   shows   "Ln' (cis t) = \<i> * t"
 proof -
   have "exp (\<i> * pi / 2) = \<i>" by (simp add: exp_eq_polar)
   hence "Ln (- (\<i> * cis t)) = \<i> * (t - pi / 2)" using assms
     by (intro Ln_unique) (auto simp: algebra_simps exp_diff cis_conv_exp)
   thus ?thesis by (simp add: Ln'_def algebra_simps)
 qed
 
 text \<open>
   Next, we show that the line and circle integrals are holomorphic using Leibniz's rule:
 \<close>
 lemma contour_integral_part_circlepath_h:
   assumes r: "r > 0"
   shows   "contour_integral (part_circlepath 0 r 0 pi) (f s) = integral {0..pi} (h r s)"
 proof -
   have "contour_integral (part_circlepath 0 r 0 pi) (f s) = 
           integral {0..pi} (\<lambda>t. f s (r * cis t) * r * \<i> * cis t)"
     by (simp add: contour_integral_part_circlepath_eq)
   also have "integral {0..pi} (\<lambda>t. f s (r * cis t) * r * \<i> * cis t) = integral {0..pi} (h r s)"
   proof (intro integral_cong)
     fix t assume t: "t \<in> {0..pi}"
     have "-(pi / 2) < 0" by simp
     also have "0 \<le> t" using t by simp
     finally have "t \<in> {-(pi/2)<..3/2*pi}" using t by auto
     thus "f s (r * cis t) * r * \<i> * cis t = h r s t"
       using r by (simp add: f_def Ln'_times_of_real Ln'_cis h_def Ln_Reals_eq)
   qed
   finally show ?thesis .
 qed
 
 lemma integral_g_holomorphic:
   assumes "b > 0"
   shows   "(\<lambda>s. integral {b..c} (g s)) holomorphic_on A"
 proof -
   define g' where "g' = (\<lambda>s t. - (of_real t powr (-s)) * complex_of_real (ln t) * 
                           of_real (exp (- (a * t))) / of_real (1 - exp (- t)))"
   have "(\<lambda>s. integral (cbox b c) (g s)) holomorphic_on UNIV"
   proof (rule leibniz_rule_holomorphic)
     fix s :: complex and t :: real assume "t \<in> cbox b c"
     thus "((\<lambda>s. g s t) has_field_derivative g' s t) (at s)" using assms
       by (auto simp: g_def g'_def powr_def Ln_Reals_eq intro!: derivative_eq_intros)
   next
     fix s show "g s integrable_on cbox b c" for s unfolding g_def using assms
       by (intro integrable_continuous continuous_intros) auto
   next
     show "continuous_on (UNIV \<times> cbox b c) (\<lambda>(s, t). g' s t)" using assms
       by (auto simp: g'_def case_prod_unfold intro!: continuous_intros)
   qed auto
   thus ?thesis by auto
 qed
 
 lemma integral_h_holomorphic:
   assumes r: "r \<in> {0<..<2}"
   shows   "(\<lambda>s. integral {b..c} (h r s)) holomorphic_on A"
 proof -
   have no_sing: "exp (r * cis t) \<noteq> 1" for t
   proof
     define z where "z = r * cis t"
     assume "exp z = 1"
     then obtain n where "norm z = 2 * pi * of_int \<bar>n\<bar>"
       by (auto simp: exp_eq_1 cmod_def abs_mult)
     moreover have "norm z = r" using r by (simp add: z_def norm_mult)
     ultimately have r_eq: "r = 2 * pi * of_int \<bar>n\<bar>" by simp
     with r have "n \<noteq> 0" by auto
     moreover from r have "r < 2 * pi" using pi_gt3 by simp 
     with r_eq have "\<bar>n\<bar> < 1" by simp
     ultimately show False by simp
   qed
 
   define h' where "h' = (\<lambda>s t. exp (a * r * cis t - (ln r + \<i> * t) * s) *
                            (-ln r - \<i> * t) * (r * \<i> * cis t) / (1 - exp (r * cis t)))"
   have "(\<lambda>s. integral (cbox b c) (h r s)) holomorphic_on UNIV"
   proof (rule leibniz_rule_holomorphic)
     fix s t assume "t \<in> cbox b c"
     thus "((\<lambda>s. h r s t) has_field_derivative h' s t) (at s)" using no_sing r
       by (auto intro!: derivative_eq_intros simp: h_def h'_def mult_ac Ln_Reals_eq)
   next
     fix s show "h r s integrable_on cbox b c" using no_sing unfolding h_def
       by (auto intro!: integrable_continuous_real continuous_intros)
   next
     show "continuous_on (UNIV \<times> cbox b c) (\<lambda>(s, t). h' s t)" using no_sing
       by (auto simp: h'_def case_prod_unfold intro!: continuous_intros)
   qed auto
   thus ?thesis by auto
 qed
 
 text \<open>
   We now move on to the core result, which uses the Residue Theorem to relate a contour integral
   along a semi-annulus to a partial sum of the periodic zeta function.
 \<close>
 lemma hurwitz_formula_integral_semiannulus:
   fixes N :: nat and r :: real and s :: complex
   defines "R \<equiv> real (2 * N + 1) * pi"
   assumes "r > 0" and "r < 2"
   shows "exp (-\<i> * pi * s) * integral {r..R} (\<lambda>x. x powr (-s) * exp (-a * x) / (1 - exp (-x))) +
          integral {r..R} (\<lambda>x. x powr (-s) * exp (a * x) / (1 - exp x)) +
          contour_integral (part_circlepath 0 R 0 pi) (f s) +
          contour_integral (part_circlepath 0 r pi 0) (f s)
          = -2 * pi * \<i> * exp (- s * of_real pi * \<i> / 2) * (\<Sum>k\<in>{0<..N}. Res s k)" (is ?thesis1)
     and "f s contour_integrable_on hankel_semiannulus r N"
 proof -
   have "2 < 1 * pi" using pi_gt3 by simp
   also have "\<dots> \<le> R" unfolding R_def by (intro mult_right_mono) auto
   finally have "R > 2" by (auto simp: R_def)
   note r_R = \<open>r > 0\<close> \<open>r < 2\<close> this
 
   \<comment>\<open>We integrate along the edge of a semi-annulus in the upper half of the complex plane.
      It consists of a big semicircle, a small semicircle, and two lines connecting the two
      circles, one on the positive real axis and one on the negative real axis.
 
      The integral along the big circle will vanish as the radius of the circle tends to \<open>\<infinity>\<close>,
      whereas the remaining path becomes a Hankel contour, and the integral along that Hankel
      contour is what we are interested in, since it is connected to the Hurwitz zeta function.\<close>
   define big_circle where "big_circle = part_circlepath 0 R 0 pi"
   define small_circle where "small_circle = part_circlepath 0 r pi 0"
   define neg_line where "neg_line = linepath (complex_of_real (-R)) (complex_of_real (-r))"
   define pos_line where "pos_line = linepath (complex_of_real r) (complex_of_real R)"
   define \<gamma> where "\<gamma> = hankel_semiannulus r N"
   have \<gamma>_altdef: "\<gamma> = big_circle +++ neg_line +++ small_circle +++ pos_line"
     by (simp add: \<gamma>_def R_def add_ac hankel_semiannulus_def big_circle_def
                   neg_line_def small_circle_def pos_line_def)
   have [simp]: "path \<gamma>" "valid_path \<gamma>" "pathfinish \<gamma> = pathstart \<gamma>"
     by (simp_all add: \<gamma>_def)
 
   \<comment>\<open>The integrand has a branch cut along the non-positive imaginary axis and additional 
      simple poles at $2n\pi i$ for any \<open>n \<in> \<nat>\<^sub>>\<^sub>0\<close>. The radius of the smaller circle will always
      be less than $2\pi$ and the radius of the bigger circle of the form $(2N+1)\pi$, so we
      always have precisely the first $N$ poles inside our path.\<close>
   define sngs where "sngs = (\<lambda>n. of_real (2 * pi * real n) * \<i>) ` {0<..}"
   define sngs' where "sngs' = (\<lambda>n. of_real (2 * pi * real n) * \<i>) ` {0<..N}"
   have sngs_subset: "sngs' \<subseteq> sngs" unfolding sngs_def sngs'_def by (intro image_mono) auto
   have closed_sngs [intro]: "closed (sngs - sngs')" unfolding sngs_def
   proof (rule discrete_imp_closed[of "2 * pi"]; safe?)
     fix m n :: nat
     assume "dist (of_real (2 * pi * real m) * \<i>) (of_real (2 * pi * real n) * \<i>) < 2 * pi"
     also have "dist (of_real (2 * pi * real m) * \<i>) (of_real (2 * pi * real n) * \<i>) =
                 norm (of_real (2 * pi * real m) * \<i> - of_real (2 * pi * real n) * \<i>)"
       by (simp add: dist_norm)
     also have "of_real (2 * pi * real m) * \<i> - of_real (2 * pi * real n) * \<i> =
                  of_real (2 * pi) * \<i> * of_int (int m - int n)" by (simp add: algebra_simps)
     also have "norm \<dots> = 2 * pi * of_int \<bar>int m - int n\<bar>"
       unfolding norm_mult norm_of_int by (simp add: norm_mult)
     finally have "\<bar>real m - real n\<bar> < 1" by simp
     hence "m = n" by linarith
     thus "of_real (2 * pi * real m) * \<i> = of_real (2 * pi * real n) * \<i>" by simp
   qed auto
 
   \<comment>\<open>We define an area within which the integrand is holomorphic. Choosing this area as big as
      possible makes things easier later on, so we only remove the branch cut and the poles.\<close>
   define S where "S = - {z. Re z = 0 \<and> Im z \<le> 0} - (sngs - sngs')"
   define S' where "S' = - {z. Re z = 0 \<and> Im z \<le> 0}"
 
   have sngs: "exp z = 1 \<longleftrightarrow> z \<in> sngs" if "Re z \<noteq> 0 \<or> Im z > 0" for z
   proof
     assume "exp z = 1"
     then obtain n where n: "z = 2 * pi * of_int n * \<i>"
       unfolding exp_eq_1 by (auto simp: complex_eq_iff mult_ac)
     moreover from n and pi_gt_zero and that have "n > 0" by (auto simp: zero_less_mult_iff)
     ultimately have "z = of_real (2 * pi * nat n) * \<i>" and "nat n \<in> {0<..}"
       by auto
     thus "z \<in> sngs" unfolding sngs_def by blast
   qed (insert that, auto simp: sngs_def exp_eq_polar)
 
   \<comment>\<open>We show that the path stays within the well-behaved area.\<close>
   have "path_image neg_line = of_real ` {-R..-r}" using r_R
     by (auto simp: neg_line_def closed_segment_Reals closed_segment_eq_real_ivl)
   hence "path_image neg_line \<subseteq> S - sngs'" using r_R sngs_subset
     by (auto simp: S_def sngs_def complex_eq_iff)
 
   have "path_image pos_line = of_real ` {r..R}" using r_R
     by (auto simp: pos_line_def closed_segment_Reals closed_segment_eq_real_ivl)
   hence "path_image pos_line \<subseteq> S - sngs'" using r_R sngs_subset
     by (auto simp: S_def sngs_def complex_eq_iff)
 
   have part_circlepath_in_S: "z \<in> S - sngs'"
     if "z \<in> path_image (part_circlepath 0 r' 0 pi) \<or> z \<in> path_image (part_circlepath 0 r' pi 0)"
     and "r' > 0" "r' \<notin> (\<lambda>n. 2 * pi * real n) ` {0<..}" for z r'
   proof -
     have z: "norm z = r' \<and> Im z \<ge> 0" using that
       by (auto simp: path_image_def part_circlepath_def norm_mult Im_exp linepath_def
                intro!: mult_nonneg_nonneg sin_ge_zero)
     hence "Re z \<noteq> 0 \<or> Im z > 0" using that by (auto simp: cmod_def)
     moreover from z and that have "z \<notin> sngs"
       by (auto simp: sngs_def norm_mult image_iff)
     ultimately show "z \<in> S - sngs'" using sngs_subset by (auto simp: S_def)
   qed
 
   {
     fix n :: nat assume n: "n > 0"
     have "r < 2 * pi * 1" using pi_gt3 r_R by simp
     also have "\<dots> \<le> 2 * pi * real n" using n by (intro mult_left_mono) auto
     finally have "r < \<dots>" .
   }
   hence "r \<notin> (\<lambda>n. 2 * pi * real n) ` {0<..}" using r_R by auto
   from part_circlepath_in_S[OF _ _ this] r_R have "path_image small_circle \<subseteq> S - sngs'"
     by (auto simp: small_circle_def)
 
   {
     fix n :: nat assume n: "n > 0" "2 * pi * real n = real (2 * N + 1) * pi"
     hence "real (2 * n) = real (2 * N + 1)" unfolding of_nat_mult by simp
     hence False unfolding of_nat_eq_iff by presburger
   }
   hence "R \<notin> (\<lambda>n. 2 * pi * real n) ` {0<..}" unfolding R_def by force
   from part_circlepath_in_S[OF _ _ this] r_R have "path_image big_circle \<subseteq> S - sngs'"
     by (auto simp: big_circle_def)
 
   note path_images =
     \<open>path_image small_circle \<subseteq> S - sngs'\<close> \<open>path_image big_circle \<subseteq> S - sngs'\<close>
     \<open>path_image neg_line \<subseteq> S - sngs'\<close> \<open>path_image pos_line \<subseteq> S - sngs'\<close>
   have "path_image \<gamma> \<subseteq> S - sngs'" using path_images
     by (auto simp: \<gamma>_altdef path_image_join big_circle_def neg_line_def 
                    small_circle_def pos_line_def)
 
   \<comment>\<open>We need to show that the complex plane is still connected after we removed the branch cut
      and the poles. We do this by showing that the complex plane with the branch cut removed
      is starlike and therefore connected. Then we remove the (countably many) poles, which does not
      break connectedness either.\<close>
   have "open S" using closed_neg_Im_slit by (auto simp: S_def)
   have "starlike (UNIV - {z. Re z = 0 \<and> Im z \<le> 0})"
     (is "starlike ?S'") unfolding starlike_def
   proof (rule bexI ballI)+
     have "1 \<le> 1 * pi" using pi_gt3 by simp
     also have "\<dots> < (2 + 2 * real N) * pi" by (intro mult_strict_right_mono) auto
     finally show *: "\<i> \<in> ?S'" by (auto simp: S_def)
     fix z assume z: "z \<in> ?S'"
     have "closed_segment \<i> z \<inter> {z. Re z = 0 \<and> Im z \<le> 0} = {}"
     proof safe
       fix s assume s: "s \<in> closed_segment \<i> z" "Re s = 0" "Im s \<le> 0"
       then obtain t where t: "t \<in> {0..1}" "s = linepath \<i> z t"
         using linepath_image_01 by blast
       with z s t have z': "Re z = 0" "Im z > 0"
         by (auto simp: Re_linepath' S_def linepath_0')
       with s have "Im s \<in> closed_segment 1 (Im z) \<and> Im s \<le> 0"
         by (subst (asm) closed_segment_same_Re) auto
       with z' show "s \<in> {}"
         by (auto simp: closed_segment_eq_real_ivl split: if_splits)
     qed
     thus "closed_segment \<i> z \<subseteq> ?S'" by (auto simp: S_def)
   qed
   hence "connected ?S'" by (rule starlike_imp_connected)
   hence "connected S'" by (simp add: Compl_eq_Diff_UNIV S'_def)
   have "connected S" unfolding S_def
     by (rule connected_open_diff_countable)
        (insert \<open>connected S'\<close>, auto simp: sngs_def closed_neg_Im_slit S'_def)
 
   \<comment>\<open>The integrand is now clearly holomorphic on @{term "S - sngs'"} and we can apply the
      Residue Theorem.\<close>
   have holo: "f s holomorphic_on (S - sngs')"
     unfolding f_def Ln'_def S_def using sngs
     by (auto intro!: holomorphic_intros simp: complex_nonpos_Reals_iff)
   have "contour_integral \<gamma> (f s) =
           of_real (2 * pi) * \<i> * (\<Sum>z\<in>sngs'. winding_number \<gamma> z * residue (f s) z)"
   proof (rule Residue_theorem)
     show "\<forall>z. z \<notin> S \<longrightarrow> winding_number \<gamma> z = 0"
     proof safe
       fix z assume "z \<notin> S"
       hence "Re z = 0 \<and> Im z \<le> 0 \<or> z \<in> sngs - sngs'" by (auto simp: S_def)
       thus "winding_number \<gamma> z = 0"
       proof
         define x where "x = -Im z"
         assume "Re z = 0 \<and> Im z \<le> 0"
         hence x: "z = -of_real x * \<i>" "x \<ge> 0" unfolding complex_eq_iff by (simp_all add: x_def)
         obtain B where "\<And>z. norm z \<ge> B \<Longrightarrow> winding_number \<gamma> z = 0"
           using winding_number_zero_at_infinity[of \<gamma>] by auto
         hence "winding_number \<gamma> (-of_real (max B 0) * \<i>) = 0" by (auto simp: norm_mult)
         also have "winding_number \<gamma> (-of_real (max B 0) * \<i>) = winding_number \<gamma> z"
         proof (rule winding_number_eq)
           from x have "closed_segment (-of_real (max B 0) * \<i>) z \<subseteq> {z. Re z = 0 \<and> Im z \<le> 0}"
             by (auto simp: closed_segment_same_Re closed_segment_eq_real_ivl)
           with \<open>path_image \<gamma> \<subseteq> S - sngs'\<close>
           show "closed_segment (-of_real (max B 0) * \<i>) z \<inter> path_image \<gamma> = {}"
             by (auto simp: S_def)
         qed auto
         finally show "winding_number \<gamma> z = 0" .
       next
         assume z: "z \<in> sngs - sngs'"
         show "winding_number \<gamma> z = 0"
         proof (rule winding_number_zero_outside)
           have "path_image \<gamma> = path_image big_circle \<union> path_image neg_line \<union>
                                  path_image small_circle \<union> path_image pos_line"
             unfolding \<gamma>_altdef small_circle_def big_circle_def pos_line_def neg_line_def
             by (simp add: path_image_join Un_assoc)
           also have "\<dots> \<subseteq> cball 0 ((2 * N + 1) * pi)" using r_R
             by (auto simp: small_circle_def big_circle_def pos_line_def neg_line_def
                            path_image_join norm_mult R_def path_image_part_circlepath'
                            in_Reals_norm closed_segment_Reals closed_segment_eq_real_ivl)
           finally show "path_image \<gamma> \<subseteq> \<dots>" .
         qed (insert z, auto simp: sngs_def sngs'_def norm_mult)
       qed
     qed
   qed (insert \<open>path_image \<gamma> \<subseteq> S - sngs'\<close> \<open>connected S\<close> \<open>open S\<close> holo, auto simp: sngs'_def)
 
   \<comment>\<open>We can use Wenda Li's framework to compute the winding numbers at the poles and show that
      they are all 1.\<close>
   also have "winding_number \<gamma> z = 1" if "z \<in> sngs'" for z
   proof -
     have "r < 2 * pi * 1" using pi_gt3 r_R by simp
     also have "\<dots> \<le> 2 * pi * real n" if "n > 0" for n using that by (intro mult_left_mono) auto
     finally have norm_z: "norm z > r" "norm z < R" using that r_R
       by (auto simp: sngs'_def norm_mult R_def)
 
     have "cindex_pathE big_circle z = -1" using r_R that unfolding big_circle_def
       by (subst cindex_pathE_circlepath_upper(1)) (auto simp: sngs'_def norm_mult R_def)
     have "cindex_pathE small_circle z = -1" using r_R that norm_z unfolding small_circle_def
       by (subst cindex_pathE_reversepath', subst reversepath_part_circlepath,
           subst cindex_pathE_circlepath_upper(2)) (auto simp: sngs'_def norm_mult)
     have "cindex_pathE neg_line z = 0" "cindex_pathE pos_line z = 0" 
       unfolding neg_line_def pos_line_def using r_R that
       by (subst cindex_pathE_linepath; force simp: neg_line_def cindex_pathE_linepath
             closed_segment_Reals closed_segment_eq_real_ivl sngs'_def complex_eq_iff)+
     note indices = \<open>cindex_pathE big_circle z = -1\<close> \<open>cindex_pathE small_circle z = -1\<close>
                    \<open>cindex_pathE neg_line z = 0\<close> \<open>cindex_pathE pos_line z = 0\<close>
     show ?thesis unfolding \<gamma>_altdef big_circle_def small_circle_def pos_line_def neg_line_def
       by eval_winding (insert indices path_images that,
                        auto simp: big_circle_def small_circle_def pos_line_def neg_line_def)
   qed
   hence "(\<Sum>z\<in>sngs'. winding_number \<gamma> z * residue (f s) z) = (\<Sum>z\<in>sngs'. residue (f s) z)"
     by simp
   also have "\<dots> = (\<Sum>k\<in>{0<..N}. residue (f s) (2 * pi * of_nat k * \<i>))"
     unfolding sngs'_def by (subst sum.reindex) (auto intro!: inj_onI simp: o_def)
 
   \<comment>\<open>Next, we compute the residues at each pole.\<close>
   also have "residue (f s) (2 * pi * of_nat k * \<i>) = -exp (- s * of_real pi * \<i> / 2) * Res s k"
     if "k \<in> {0<..N}" for k unfolding f_def
   proof (subst residue_simple_pole_deriv)
     show "open S'" using closed_neg_Im_slit by (auto simp: S'_def)
     show "connected S'" by fact
     show "(\<lambda>z. exp (Ln' z * (-s) + of_real a * z)) holomorphic_on S'"
          "(\<lambda>z. 1 - exp z) holomorphic_on S'"
       by (auto simp: S'_def Ln'_def complex_nonpos_Reals_iff intro!: holomorphic_intros)
     have "((\<lambda>z. 1 - exp z) has_field_derivative -exp (2 * pi * k * \<i>))
             (at (of_real (2 * pi * real k) * \<i>))"
       by (auto intro!: derivative_eq_intros)
     also have "-exp (2 * pi * k * \<i>) = -1" by (simp add: exp_eq_polar)
     finally show "((\<lambda>z. 1 - exp z) has_field_derivative -1)
                     (at (of_real (2 * pi * real k) * \<i>))" .
     have "Im (of_real (2 * pi * real k) * \<i>) > 0" using pi_gt_zero that
       by auto
     thus "of_real (2 * pi * real k) * \<i> \<in> S'" by (simp add: S'_def)
 
     have "exp (\<i> * pi / 2) = \<i>" by (simp add: exp_eq_polar)
     hence "exp (Ln' (complex_of_real (2 * pi * real k) * \<i>) * -s +
               of_real a * (of_real (2 * pi * real k) * \<i>)) / -1 = 
             - exp (2 * k * a * pi * \<i> - s * pi * \<i> / 2 - s * ln (2 * k * pi))" (is "?R = _")
       using that by (subst Ln'_times_of_real) (simp_all add: Ln'_i algebra_simps exp_diff)
     also have "\<dots> = -exp (- s * of_real pi * \<i> / 2) * Res s k" using that 
       by (simp add: Res_def exp_diff powr_def exp_minus inverse_eq_divide Ln_Reals_eq mult_ac)
     finally show "?R = -exp (- s * of_real pi * \<i> / 2) * Res s k" .
   qed (insert that, auto simp: S'_def exp_eq_polar)
   hence "(\<Sum>k\<in>{0<..N}. residue (f s) (2 * pi * of_nat k * \<i>)) = 
            -exp (- s * of_real pi * \<i> / 2) * (\<Sum>k\<in>{0<..N}. Res s k)"
     by (simp add: sum_distrib_left)
 
   \<comment>\<open>This gives us the final result:\<close>
   finally have "contour_integral \<gamma> (f s) =
                   -2 * pi * \<i> * exp (- s * of_real pi * \<i> / 2) * (\<Sum>k\<in>{0<..N}. Res s k)" by simp
 
   \<comment>\<open>Lastly, we decompose the contour integral into its four constituent integrals because this
      makes them somewhat nicer to work with later on.\<close>
   also show "f s contour_integrable_on \<gamma>"
   proof (rule contour_integrable_holomorphic_simple)
     show "path_image \<gamma> \<subseteq> S - sngs'" by fact
     have "closed sngs'" by (intro finite_imp_closed) (auto simp: sngs'_def)
     with \<open>open S\<close> show "open (S - sngs')" by auto
   qed (insert holo, auto)
   hence eq: "contour_integral \<gamma> (f s) = 
                contour_integral big_circle (f s) + contour_integral neg_line (f s) +
                contour_integral small_circle (f s) + contour_integral pos_line (f s)"
     unfolding \<gamma>_altdef big_circle_def neg_line_def small_circle_def pos_line_def by simp
   
   also have "contour_integral neg_line (f s) = integral {-R..-r} (\<lambda>x. f s (complex_of_real x))"
     unfolding neg_line_def using r_R by (subst contour_integral_linepath_Reals_eq) auto
   also have "\<dots> = exp (- \<i> * pi * s) * 
                     integral {r..R} (\<lambda>x. exp (-ln x * s) * exp (-a * x) / (1 - exp (-x)))"
     (is "_ = _ * ?I") unfolding integral_mult_right [symmetric] using r_R
     by (subst Henstock_Kurzweil_Integration.integral_reflect_real [symmetric], intro integral_cong)
        (auto simp: f_def exp_of_real Ln'_of_real_neg exp_minus exp_Reals_eq
                    exp_diff exp_add field_simps)
   also have "?I = integral {r..R} (\<lambda>x. x powr (-s) * exp (-a * x) / (1 - exp (-x)))" using r_R
     by (intro integral_cong) (auto simp: powr_def Ln_Reals_eq exp_minus exp_diff field_simps)
 
   also have "contour_integral pos_line (f s) = integral {r..R} (\<lambda>x. f s (complex_of_real x))"
     unfolding pos_line_def using r_R by (subst contour_integral_linepath_Reals_eq) auto
   also have "\<dots> = integral {r..R} (\<lambda>x. x powr (-s) * exp (a * x) / (1 - exp x))"
     using r_R by (intro integral_cong) (simp add: f_def Ln'_of_real_pos exp_diff exp_minus
                                                   exp_Reals_eq field_simps powr_def Ln_Reals_eq)
   finally show ?thesis1 by (simp only: add_ac big_circle_def small_circle_def)
 qed
 
 text \<open>
   Next, we need bounds on the integrands of the two semicircles.
 \<close>
 lemma hurwitz_formula_bound1:
   defines "H \<equiv> \<lambda>z. exp (complex_of_real a * z) / (1 - exp z)"
   assumes "r > 0"
   obtains C where "C \<ge> 0" and "\<And>z. z \<notin> (\<Union>n::int. ball (2 * n * pi * \<i>) r) \<Longrightarrow> norm (H z) \<le> C"
 proof -
   define A where "A = cbox (-1 - pi * \<i>) (1 + pi * \<i>) - ball 0 r"
   {
     fix z assume "z \<in> A"
     have "exp z \<noteq> 1"
     proof
       assume "exp z = 1"
       then obtain n :: int where [simp]: "z = 2 * n * pi * \<i>"
         by (subst (asm) exp_eq_1) (auto simp: complex_eq_iff)
       from \<open>z \<in> A\<close> have "(2 * n) * pi \<ge> (-1) * pi" and "(2 * n) * pi \<le> 1 * pi"
         by (auto simp: A_def in_cbox_complex_iff)
       hence "n = 0" by (subst (asm) (1 2) mult_le_cancel_right) auto
       with \<open>z \<in> A\<close> and \<open>r > 0\<close> show False by (simp add: A_def)
     qed
   }
   hence "continuous_on A H"
     by (auto simp: A_def H_def intro!: continuous_intros)
   moreover have "compact A" by (auto simp: A_def compact_eq_bounded_closed)
   ultimately have "compact (H ` A)" by (rule compact_continuous_image)
   hence "bounded (H ` A)" by (rule compact_imp_bounded)
   then obtain C where bound_inside: "\<And>z. z \<in> A \<Longrightarrow> norm (H z) \<le> C"
     by (auto simp: bounded_iff)
 
   have bound_outside: "norm (H z) \<le> exp 1 / (exp 1 - 1)" if "\<bar>Re z\<bar> > 1" for z
   proof -
     have "norm (H z) = exp (a * Re z) / norm (1 - exp z)"
       by (simp add: H_def norm_divide)
     also have "\<bar>1 - exp (Re z)\<bar> \<le> norm (1 - exp z)"
       by (rule order.trans[OF _ norm_triangle_ineq3]) simp
     hence "exp (a * Re z) / norm (1 - exp z) \<le> exp (a * Re z) / \<bar>1 - exp (Re z)\<bar>"
       using that by (intro divide_left_mono mult_pos_pos) auto
     also have "\<dots> \<le> exp 1 / (exp 1 - 1)"
     proof (cases "Re z > 1")
       case True
       hence "exp (a * Re z) / \<bar>1 - exp (Re z)\<bar> = exp (a * Re z) / (exp (Re z) - 1)"
         by simp
       also have "\<dots> \<le> exp (Re z) / (exp (Re z) - 1)"
         using a True by (intro divide_right_mono) auto
       also have "\<dots> = 1 / (1 - exp (-Re z))" by (simp add: exp_minus field_simps)
       also have "\<dots> \<le> 1 / (1 - exp (-1))" using True by (intro divide_left_mono diff_mono) auto
       also have "\<dots> = exp 1 / (exp 1 - 1)" by (simp add: exp_minus field_simps)
       finally show ?thesis .
     next
       case False
       with that have "Re z < -1" by simp
       hence "exp (a * Re z) / \<bar>1 - exp (Re z)\<bar> = exp (a * Re z) / (1 - exp (Re z))" by simp
       also have "\<dots> \<le> 1 / (1 - exp (Re z))"
         using a and \<open>Re z < -1\<close> by (intro divide_right_mono) (auto intro: mult_nonneg_nonpos)
       also have "\<dots> \<le> 1 / (1 - exp (-1))"
         using \<open>Re z < -1\<close> by (intro divide_left_mono) auto
       also have "\<dots> = exp 1 / (exp 1 - 1)" by (simp add: exp_minus field_simps)
       finally show ?thesis .
     qed
     finally show ?thesis .
   qed
 
   define D where "D = max C (exp 1 / (exp 1 - 1))"
   have "D \<ge> 0" by (simp add: D_def max.coboundedI2)
 
   have "norm (H z) \<le> D" if "z \<notin> (\<Union>n::int. ball (2 * n * pi * \<i>) r)" for z
   proof (cases "\<bar>Re z\<bar> \<le> 1")
     case False
     with bound_outside[of z] show ?thesis by (simp add: D_def)
   next
     case True
     define n where "n = \<lfloor>Im z / (2 * pi) + 1 / 2\<rfloor>"
 
     have "Im (z - 2 * n * pi * \<i>) = frac (Im z / (2 * pi) + 1 / 2) * (2 * pi) - pi"
       by (simp add: n_def frac_def algebra_simps)
     also have "\<dots> \<in> {-pi..<pi}" using frac_lt_1 by simp
     finally have "norm (H (z - 2 * n * pi * \<i>)) \<le> C" using True that
       by (intro bound_inside) (auto simp: A_def in_cbox_complex_iff dist_norm n_def)
     also have "exp (2 * pi * n * \<i>) = 1" by (simp add: exp_eq_polar)
     hence "norm (H (z - 2 * n * pi * \<i>)) = norm (H z)"
       by (simp add: H_def norm_divide exp_diff mult_ac)
     also have "C \<le> D" by (simp add: D_def)
     finally show ?thesis .
   qed
   from \<open>D \<ge> 0\<close> and this show ?thesis by (rule that)
 qed
 
 lemma hurwitz_formula_bound2:
   obtains C where "C \<ge> 0" and "\<And>r z. r > 0 \<Longrightarrow> r < pi \<Longrightarrow> z \<in> sphere 0 r \<Longrightarrow>
      norm (f s z) \<le> C * r powr (-Re s - 1)"
 proof -
   have "2 * pi > 0" by auto
   have nz: "1 - exp z \<noteq> 0" if "z \<in> ball 0 (2 * pi) - {0}" for z :: complex
   proof
     assume "1 - exp z = 0"
     then obtain n where "z = 2 * pi * of_int n * \<i>"
       by (auto simp: exp_eq_1 complex_eq_iff[of z])
     moreover have "\<bar>real_of_int n\<bar> < 1 \<longleftrightarrow> n = 0" by linarith
     ultimately show False using that by (auto simp: norm_mult)
   qed
 
   have ev: "eventually (\<lambda>z::complex. 1 - exp z \<noteq> 0) (at 0)"
     using eventually_at_ball'[OF \<open>2 * pi > 0\<close>] by eventually_elim (use nz in auto)
   have [simp]: "subdegree (1 - fps_exp (1 :: complex)) = 1"
     by (intro subdegreeI) auto
   hence "(\<lambda>z. exp (a * z) * (if z = 0 then -1 else z / (1 - exp z :: complex)))
             has_fps_expansion fps_exp a * (fps_X / (fps_const 1 - fps_exp 1))"
     by (auto intro!: fps_expansion_intros)
   hence "(\<lambda>z::complex. exp (a * z) * (if z = 0 then -1 else z / (1 - exp z))) \<in> O[at 0](\<lambda>z. 1)"
     using continuous_imp_bigo_1 has_fps_expansion_imp_continuous by blast
   also have "?this \<longleftrightarrow> (\<lambda>z::complex. exp (a * z) * (z / (1 - exp z))) \<in> O[at 0](\<lambda>z. 1)"
     by (intro landau_o.big.in_cong eventually_mono[OF ev]) auto
   finally have "\<exists>g. g holomorphic_on ball 0 (2 * pi) \<and>
                     (\<forall>z\<in>ball 0 (2 * pi) - {0}. g z = exp (of_real a * z) * (z / (1 - exp z)))" 
     using nz by (intro holomorphic_on_extend holomorphic_intros) auto
   then guess g by (elim exE conjE) note g = this
   hence "continuous_on (ball 0 (2 * pi)) g"
     by (auto dest: holomorphic_on_imp_continuous_on)
   hence "continuous_on (cball 0 pi) g"
     by (rule continuous_on_subset) (subst cball_subset_ball_iff, use pi_gt_zero in auto)
   hence "compact (g ` cball 0 pi)" by (intro compact_continuous_image) auto
   hence "bounded (g ` cball 0 pi)" by (auto simp: compact_imp_bounded)
   then obtain C where C: "\<forall>x\<in>cball 0 pi. norm (g x) \<le> C" by (auto simp: bounded_iff)
 
   {
     fix r :: real assume r: "r > 0" "r < pi"
     fix z :: complex assume z: "z \<in> sphere 0 r"
     define x where "x = (if Arg z \<le> -pi / 2 then Arg z + 2 * pi else Arg z)"
     have "exp (\<i> * (2 * pi)) = 1" by (simp add: exp_eq_polar)
     with z have "z = r * exp (\<i> * x)" using r pi_gt_zero Arg_eq[of z]
       by (auto simp: x_def exp_add distrib_left)
     have "x > - pi / 2" "x \<le> 3 / 2 * pi" using Arg_le_pi[of z] mpi_less_Arg[of z]
       by (auto simp: x_def)
     note x = \<open>z = r * exp (\<i> * x)\<close> this
 
     from x r have z': "z \<in> cball 0 pi - {0}"
       using pi_gt3 by (auto simp: norm_mult)
     also have "cball 0 pi \<subseteq> ball (0::complex) (2 * pi)"
       by (subst cball_subset_ball_iff) (use pi_gt_zero in auto)
     hence "cball 0 pi - {0} \<subseteq> ball 0 (2 * pi) - {0::complex}" by blast
     finally have z'': "z \<in> ball 0 (2 * pi) - {0}" .
     hence bound: "norm (exp (a * z) * (z / (1 - exp z))) \<le> C" using C and g and z'
       by force
 
     have "exp z \<noteq> 1" using nz z'' by auto
     with bound z'' have bound': "norm (exp (a * z) / (1 - exp z)) \<le> C / norm z"
       by (simp add: norm_divide field_simps norm_mult)
 
     have "Ln' z = of_real (ln r) + Ln' (exp (\<i> * of_real x))"
       using x r by (simp add: Ln'_times_of_real)
     also have "exp (\<i> * pi / 2) = \<i>"
       by (simp add: exp_eq_polar)
     hence "Ln' (exp (\<i> * of_real x)) = Ln (exp (\<i> * of_real (x - pi / 2))) + \<i> * pi / 2"
       by (simp add: algebra_simps Ln'_def exp_diff)
     also have "\<dots> = \<i> * x"
       using x pi_gt3 by (subst Ln_exp) (auto simp: algebra_simps)
     finally have "norm (exp (-Ln' z * s)) = exp (x * Im s - ln r * Re s)"
       by simp
     also {
       have "x * Im s \<le> \<bar>x * Im s\<bar>" by (rule abs_ge_self)
       also have "\<dots> \<le> (3/2 * pi) * \<bar>Im s\<bar>" unfolding abs_mult using x
         by (intro mult_right_mono) auto
       finally have "exp (x * Im s - ln r * Re s) \<le> exp (3 / 2 * pi * \<bar>Im s\<bar> - ln r * Re s)" by simp
     }
     finally have "norm (exp (-Ln' z * s) * (exp (a * z) / (1 - exp z))) \<le>
                     exp (3 / 2 * pi * \<bar>Im s\<bar> - ln r * Re s) * (C / norm z)"
       unfolding norm_mult[of "exp t" for t] by (intro mult_mono bound') simp_all
     also have "norm z = r" using \<open>r > 0\<close> by (simp add: x norm_mult)
     also have "exp (3 / 2 * pi * \<bar>Im s\<bar> - ln r * Re s) = exp (3 / 2 * pi * \<bar>Im s\<bar>) * r powr (-Re s)"
       using r by (simp add: exp_diff powr_def exp_minus inverse_eq_divide)
     finally have "norm (f s z) \<le> C * exp (3 / 2 * pi * \<bar>Im s\<bar>) * r powr (-Re s - 1)" using r
       by (simp add: f_def exp_diff exp_minus field_simps powr_diff)
     also have "\<dots> \<le> max 0 (C * exp (3 / 2 * pi * \<bar>Im s\<bar>)) * r powr (-Re s - 1)"
       by (intro mult_right_mono max.coboundedI2) auto
     finally have "norm (f s z) \<le> \<dots>" .
   }
   with that[of "max 0 (C * exp (3 / 2 * pi * \<bar>Im s\<bar>))"] show ?thesis by auto
 qed
 
 text \<open>
   We can now relate the integral along a partial Hankel contour that is cut off at $-\pi$ to
   $\zeta(1 - s, a) / \Gamma(s)$.
 \<close>
 lemma rGamma_hurwitz_zeta_eq_contour_integral:
   fixes s :: complex and r :: real
   assumes "s \<noteq> 0" and r: "r \<in> {1..<2}" and a: "a > 0"
   defines "err1 \<equiv> (\<lambda>s r. contour_integral (part_circlepath 0 r pi 0) (f s))"
   defines "err2 \<equiv> (\<lambda>s r. cnj (contour_integral (part_circlepath 0 r pi 0) (f (cnj s))))"
   shows   "2 * \<i> * pi * rGamma s * hurwitz_zeta a (1 - s) =
              err2 s r - err1 s r + 2 * \<i> * sin (pi * s) * (CLBINT x:{r..}. g s x)"
   (is "?f s = ?g s")
 proof (rule analytic_continuation_open[where f = ?f])
   fix s :: complex assume s: "s \<in> {s. Re s < 0}"
 
   \<comment>\<open>We first show that the integrals along the Hankel contour cut off at $-\pi$ all have the
      same value, no matter what the radius of the circle is (as long as it is small enough).
      We call this value \<open>C\<close>.
 
      This argument could be done by a homotopy argument, but it is easier to simply re-use the
      above result about the contour integral along the annulus where we fix the radius of the 
      outer circle to $\pi$.\<close>
   define C where "C = -contour_integral (part_circlepath 0 pi 0 pi) (f s) +
                        cnj (contour_integral (part_circlepath 0 pi 0 pi) (f (cnj s)))"
   have integrable: "set_integrable lborel A (g s)"
     if "A \<in> sets lborel" "A \<subseteq> {0<..}" for A
   proof (rule set_integrable_subset)
     show "set_integrable lborel {0<..} (g s)"
       using Gamma_times_hurwitz_zeta_integrable[of "1 - s" a] s a
       by (simp add: g_def exp_of_real exp_minus integrable_completion set_integrable_def)
   qed (insert that, auto)
 
   {
     fix r' :: real assume r': "r' \<in> {0<..<2}"
     from hurwitz_formula_integral_semiannulus(2)[of r' s 0] and r'
     have "f s contour_integrable_on part_circlepath 0 r' pi 0"
       by (auto simp: hankel_semiannulus_def add_ac)
   } note integrable_circle = this
   {
     fix r' :: real assume r': "r' \<in> {0<..<2}"
     from hurwitz_formula_integral_semiannulus(2)[of r' "cnj s" 0] and r'
     have "f (cnj s) contour_integrable_on part_circlepath 0 r' pi 0"
       by (auto simp: hankel_semiannulus_def add_ac)
   } note integrable_circle' = this
 
   have eq: "-2 * \<i> * sin (pi * s) * (CLBINT x:{r..pi}. g s x) + (err1 s r - err2 s r) = C"
     if r: "r \<in> {0<..<2}" for r :: real
   proof -
     have eq1: "integral {r..pi} (\<lambda>x. cnj (x powr - cnj s) * (exp (- (a * x))) / (1 - (exp (- x)))) =
                integral {r..pi} (g s)" using r
       by (intro integral_cong) (auto simp: cnj_powr g_def exp_of_real exp_minus)
     have eq2: "integral {r..pi} (\<lambda>x. cnj (x powr - cnj s) * (exp (a * x)) / (1 - (exp x))) =
                integral {r..pi} (\<lambda>x. x powr - s * (exp (a * x)) / (1 - (exp x)))" using r
       by (intro integral_cong) (auto simp: cnj_powr)
   
     from hurwitz_formula_integral_semiannulus(1)[of r s 0] hurwitz_formula_integral_semiannulus(1)[of r "cnj s" 0]
     have "exp (-\<i>*pi * s) *
             integral {r..real (2*0+1) * pi} (g s) +
             integral {r..real (2*0+1) * pi} (\<lambda>x. x powr -s * exp (a * x) / (1 - exp x)) +
             contour_integral (part_circlepath 0 (real (2 * 0 + 1) * pi) 0 pi) (f s) +
             contour_integral (part_circlepath 0 r pi 0) (f s) - cnj (
           exp (-\<i>*pi * cnj s) *
             integral {r..real (2*0+1) * pi} (\<lambda>x. x powr - cnj s * exp (-a*x) / (1 - exp (-x))) +
             integral {r..real (2*0+1) * pi} (\<lambda>x. x powr - cnj s * exp (a*x) / (1 - exp x)) +
             contour_integral (part_circlepath 0 (real (2 * 0 + 1) * pi) 0 pi) (f (cnj s)) +
             contour_integral (part_circlepath 0 r pi 0) (f (cnj s))) = 0" (is "?lhs = _") 
       unfolding g_def using r by (subst (1 2) hurwitz_formula_integral_semiannulus) auto
     also have "?lhs = -2 * \<i> * sin (pi * s) * integral {r..pi} (g s) + err1 s r - err2 s r - C"
       using eq1 eq2
       by (auto simp: integral_cnj exp_cnj err1_def err2_def sin_exp_eq algebra_simps C_def)
     also have "integral {r..pi} (g s) = (CLBINT x:{r..pi}. g s x)" using r
       by (intro set_borel_integral_eq_integral(2) [symmetric] integrable) auto
     finally show "-2 * \<i> * sin (pi * s) * (CLBINT x:{r..pi}. g s x) + (err1 s r - err2 s r) = C"
       by (simp add: algebra_simps)
   qed
 
   \<comment>\<open>Next, compute the value of @{term C} by letting the radius tend to 0 so that the contribution
      of the circle vanishes.\<close>
   have "((\<lambda>r. -2 * \<i> * sin (pi * s) * (CLBINT x:{r..pi}. g s x)  + (err1 s r - err2 s r)) \<longlongrightarrow>
              -2 * \<i> * sin (pi * s) * (CLBINT x:{0<..pi}. g s x) + 0) (at_right 0)"
   proof (intro tendsto_intros tendsto_set_lebesgue_integral_at_right integrable)
     from hurwitz_formula_bound2[of s] guess C1 . note C1 = this
     from hurwitz_formula_bound2[of "cnj s"] guess C2 . note C2 = this
     have ev: "eventually (\<lambda>r::real. r \<in> {0<..<2}) (at_right 0)"
       by (intro eventually_at_right_real) auto
     show "((\<lambda>r. err1 s r - err2 s r) \<longlongrightarrow> 0) (at_right 0)"
     proof (rule Lim_null_comparison[OF eventually_mono[OF ev]])
       fix r :: real assume r: "r \<in> {0<..<2}"
       have "norm (err1 s r - err2 s r) \<le> norm (err1 s r) + norm (err2 s r)"
         by (rule norm_triangle_ineq4)
       also have "norm (err1 s r) \<le> C1 * r powr (- Re s - 1) * r * \<bar>0 - pi\<bar>"
         unfolding err1_def using C1(1) C1(2)[of r] pi_gt3 integrable_circle[of r]
           path_image_part_circlepath_subset'[of r 0 pi 0] r
         by (intro contour_integral_bound_part_circlepath) auto
       also have "\<dots> = C1 * r powr (-Re s) * pi" using r
         by (simp add: powr_diff field_simps)
       also have "norm (err2 s r) \<le> C2 * r powr (- Re s - 1) * r * \<bar>0 - pi\<bar>"
         unfolding err2_def complex_mod_cnj using C2(1) C2(2)[of r] r
           pi_gt3 integrable_circle'[of r] path_image_part_circlepath_subset'[of r 0 pi 0]
         by (intro contour_integral_bound_part_circlepath) auto
       also have "\<dots> = C2 * r powr (-Re s) * pi" using r
         by (simp add: powr_diff field_simps)
       also have "C1 * r powr (-Re s) * pi + C2 * r powr (-Re s) * pi =
                    (C1 + C2) * pi * r powr (-Re s)" by (simp add: algebra_simps)
       finally show "norm (err1 s r - err2 s r) \<le> (C1 + C2) * pi * r powr - Re s" by simp
     next
       show "((\<lambda>x. (C1 + C2) * pi * x powr - Re s) \<longlongrightarrow> 0) (at_right 0)" using s
         by (auto intro!: tendsto_eq_intros simp: eventually_at exI[of _ 1])
     qed
   qed auto
   moreover have "eventually (\<lambda>r::real. r \<in> {0<..<2}) (at_right 0)"
     by (intro eventually_at_right_real) auto
   hence "eventually (\<lambda>r. -2 * \<i> * sin (pi * s) * (CLBINT x:{r..pi}. g s x) +
            (err1 s r - err2 s r) = C) (at_right 0)" by eventually_elim (use eq in auto)
   hence "((\<lambda>r. -2 * \<i> * sin (pi * s) * (CLBINT x:{r..pi}. g s x)  + (err1 s r - err2 s r)) \<longlongrightarrow> C)
             (at_right 0)" by (rule tendsto_eventually)
   ultimately have [simp]: "C = -2 * \<i> * sin (pi * s) * (CLBINT x:{0<..pi}. g s x)"
     using tendsto_unique by force
 
   \<comment>\<open>We now rearrange everything and obtain the result.\<close>
   have "2 * \<i> * sin (pi * s) * ((CLBINT x:{0<..pi}. g s x) - (CLBINT x:{r..pi}. g s x)) =
           err2 s r - err1 s r"
     using eq[of r] r by (simp add: algebra_simps)
   also have "{0<..pi} = {0<..<r} \<union> {r..pi}" using r pi_gt3 by auto
   also have "(CLBINT x:\<dots>. g s x) - (CLBINT x:{r..pi}. g s x) = (CLBINT x:{0<..<r}. g s x)"
     using r pi_gt3 by (subst set_integral_Un[OF _ integrable integrable]) auto
   also have "(CLBINT x:{0<..<r}. g s x) =
                (CLBINT x:{0<..<r} \<union> {r..}. g s x) - (CLBINT x:{r..}. g s x)"
     using r pi_gt3 by (subst set_integral_Un[OF _ integrable integrable]) auto
   also have "{0<..<r} \<union> {r..} = {0<..}" using r by auto
   also have "(CLBINT x:{0<..}. g s x) = Gamma (1 - s) * hurwitz_zeta a (1 - s)"
     using Gamma_times_hurwitz_zeta_integral[of "1 - s" a] s a
     by (simp add: g_def exp_of_real exp_minus integral_completion set_lebesgue_integral_def)
   finally have "2 * \<i> * (sin (pi * s) * Gamma (1 - s)) * hurwitz_zeta a (1 - s) =
                   err2 s r - err1 s r + 2 * \<i> * sin (pi * s) * (CLBINT x:{r..}. g s x)"
     by (simp add: algebra_simps)
   also have "sin (pi * s) * Gamma (1 - s) = pi * rGamma s"
   proof (cases "s \<in> \<int>")
     case False
     with Gamma_reflection_complex[of s] show ?thesis
       by (auto simp: divide_simps sin_eq_0 Ints_def rGamma_inverse_Gamma mult_ac split: if_splits)
   next
     case True
     with s have "rGamma s = 0"
       by (auto simp: rGamma_eq_zero_iff nonpos_Ints_def Ints_def)
     moreover from True have "sin (pi * s) = 0"
       by (subst sin_eq_0) (auto elim!: Ints_cases)
     ultimately show ?thesis by simp
   qed
   finally show "2 * \<i> * pi * rGamma s * hurwitz_zeta a (1 - s) =
                   err2 s r - err1 s r + 2 * \<i> * sin (pi * s) * (CLBINT x:{r..}. g s x)"
     by (simp add: mult_ac)
 next
   \<comment>\<open>By analytic continuation, we lift the result to the case of any non-zero @{term s}.\<close>
   show "(\<lambda>s. 2 * \<i> * pi * rGamma s * hurwitz_zeta a (1 - s)) holomorphic_on - {0}" using a
     by (auto intro!: holomorphic_intros)
   show "(\<lambda>s. err2 s r - err1 s r + 2 * \<i> * sin (pi * s) * (CLBINT x:{r..}. g s x))
            holomorphic_on -{0}"
   proof (intro holomorphic_intros)
     have "(\<lambda>s. err2 s r) = (\<lambda>s. - cnj (integral {0..pi} (h r (cnj s))))" using r
       by (simp add: err2_def contour_integral_part_circlepath_reverse'
                     contour_integral_part_circlepath_h)
     also have "(\<lambda>s. - cnj (integral {0..pi} (h r (cnj s)))) = 
                (\<lambda>s. (integral {0..pi} (\<lambda>x. h r s (-x))))" using r
       by (simp add: integral_cnj h_def exp_cnj cis_cnj Ln_Reals_eq)
     also have "\<dots> = (\<lambda>s. integral {-pi..0} (h r s))"
       by (subst Henstock_Kurzweil_Integration.integral_reflect_real [symmetric]) simp
     finally have "(\<lambda>s. err2 s r) = \<dots>" .
     moreover have "(\<lambda>s. integral {-pi..0} (h r s)) holomorphic_on -{0}"
       using r by (intro integral_h_holomorphic) auto
     ultimately show "(\<lambda>s. err2 s r) holomorphic_on -{0}" by simp
   next
     have "(\<lambda>s. - integral {0..pi} (h r s)) holomorphic_on -{0}" using r
       by (intro holomorphic_intros integral_h_holomorphic) auto
     also have "(\<lambda>s. - integral {0..pi} (h r s)) = (\<lambda>s. err1 s r)"
       unfolding err1_def using r
       by (simp add: contour_integral_part_circlepath_reverse' contour_integral_part_circlepath_h)
     finally show "(\<lambda>s. err1 s r) holomorphic_on -{0}" .
   next
     show "(\<lambda>s. CLBINT x:{r..}. g s x) holomorphic_on -{0}"
     proof (rule holomorphic_on_balls_imp_entire')
       fix R :: real
       have "eventually (\<lambda>b. b > r) at_top" by (rule eventually_gt_at_top)
       hence 1: "eventually (\<lambda>b. continuous_on (cball 0 R) (\<lambda>s. CLBINT x:{r..b}. g s x) \<and>
                                 (\<lambda>s. CLBINT x:{r..b}. g s x) holomorphic_on ball 0 R) at_top"
       proof eventually_elim
         case (elim b)
         have integrable: "set_integrable lborel {r..b} (g s)" for s unfolding g_def using r
               by (intro borel_integrable_atLeastAtMost' continuous_intros) auto
         have "(\<lambda>s. integral {r..b} (g s)) holomorphic_on UNIV" using r
           by (intro integral_g_holomorphic) auto
         also have "(\<lambda>s. integral {r..b} (g s)) = (\<lambda>s. CLBINT x:{r..b}. g s x)"
           by (intro ext set_borel_integral_eq_integral(2)[symmetric] integrable)
         finally have "\<dots> holomorphic_on UNIV" .
         thus ?case by (auto intro!: holomorphic_on_imp_continuous_on)
       qed
 
       have 2: "uniform_limit (cball 0 R) (\<lambda>b s. CLBINT x:{r..b}. g s x)
                  (\<lambda>s. CLBINT x:{r..}. g s x) at_top"
       proof (rule uniform_limit_set_lebesgue_integral_at_top)
         fix s :: complex and x :: real
         assume s: "s \<in> cball 0 R" and x: "x \<ge> r"
         have "norm (g s x) = x powr -Re s * exp (-a * x) / (1 - exp (-x))" using x r
           by (simp add: g_def norm_mult norm_divide in_Reals_norm norm_powr_real_powr)
         also have "\<dots> \<le> x powr R * exp (-a * x) / (1 - exp (-x))" using r s x abs_Re_le_cmod[of s]
           by (intro mult_right_mono divide_right_mono powr_mono) auto
         finally show "norm (g s x) \<le> x powr R * exp (- a * x) / (1 - exp (- x))" .
       next
         show "set_integrable lborel {r..} (\<lambda>x. x powr R * exp (-a * x) / (1 - exp (-x)))"
           using r a by (intro set_integrable_Gamma_hurwitz_aux2_real) auto
       qed (simp_all add: set_borel_measurable_def g_def)
   
       show "(\<lambda>s. CLBINT x:{r..}. g s x) holomorphic_on ball 0 R"
         using holomorphic_uniform_limit[OF 1 2] by auto
     qed
   qed
 qed (insert \<open>s \<noteq> 0\<close>, 
      auto simp: connected_punctured_universe open_halfspace_Re_lt intro: exI[of _ "-1"])
     
 text \<open>
   Finally, we obtain Hurwitz's formula by letting the radius of the outer circle tend to \<open>\<infinity>\<close>.
 \<close>
 lemma hurwitz_zeta_formula_aux:
   fixes s :: complex
   assumes s: "Re s > 1"
   shows   "rGamma s * hurwitz_zeta a (1 - s) = (2 * pi) powr -s * 
                   (\<i> powr (-s) * F a s + \<i> powr s * F (-a) s)"
 proof -
   from s have [simp]: "s \<noteq> 0" by auto
   define r where "r = (1 :: real)"
   have r: "r \<in> {0<..<2}" by (simp add: r_def)
   define R where "R = (\<lambda>n. real (2 * n + 1) * pi)"
   define bigc where "bigc = (\<lambda>n. contour_integral (part_circlepath 0 (R n) 0 pi) (f s) -
                                  cnj (contour_integral (part_circlepath 0 (R n) 0 pi) (f (cnj s))))"
   define smallc where "smallc = contour_integral (part_circlepath 0 r pi 0) (f s) - 
                                 cnj (contour_integral (part_circlepath 0 r pi 0) (f (cnj s)))"
   define I where "I = (\<lambda>n. CLBINT x:{r..R n}. g s x)"
 
   define F1 and F2 where
     "F1 = (\<lambda>n. exp (-s * pi * \<i> / 2) * (\<Sum>k\<in>{0<..n}. exp (2 * real k * pi * a * \<i>) * k powr (-s)))"
     "F2 = (\<lambda>n. exp (s * pi * \<i> / 2) * (\<Sum>k\<in>{0<..n}. exp (2 * real k * pi * (-a) * \<i>) * k powr (-s)))"
   
   have R: "R n \<ge> pi" for n using r by (auto simp: R_def field_simps)
   have [simp]: "\<not>(pi \<le> 0)" using pi_gt_zero by linarith
 
   have integrable: "set_integrable lborel A (g s)"
     if "A \<in> sets lborel" "A \<subseteq> {r..}" for A
   proof -
     have "set_integrable lborel {r..} (g s)"
       using set_integrable_Gamma_hurwitz_aux2[of r a s] a r
       by (simp add: g_def exp_of_real exp_minus)
     thus ?thesis by (rule set_integrable_subset) (use that in auto)
   qed
 
   {
     fix n :: nat
     from hurwitz_formula_integral_semiannulus(2)[of "r" s n] and r R[of n]
     have "f s contour_integrable_on part_circlepath 0 (R n) 0 pi"
       by (auto simp: hankel_semiannulus_def R_def add_ac)
   } note integrable_circle = this
   {
     fix n :: nat
     from hurwitz_formula_integral_semiannulus(2)[of "r" "cnj s" n] and r R[of n]
     have "f (cnj s) contour_integrable_on part_circlepath 0 (R n) 0 pi"
       by (auto simp: hankel_semiannulus_def R_def add_ac)
   } note integrable_circle' = this
 
   {
     fix n :: nat
     have "(exp (-\<i> * pi * s) * integral {r..R n} (g s) +
             integral {r..R n} (\<lambda>x. x powr (-s) * exp (a * x) / (1 - exp x)) +
             contour_integral (part_circlepath 0 (R n) 0 pi) (f s) +
             contour_integral (part_circlepath 0 r pi 0) (f s)) - cnj (
            exp (-\<i> * pi * cnj s) * integral {r..R n} (g (cnj s)) +
             integral {r..R n} (\<lambda>x. x powr (-cnj s) * exp (a * x) / (1 - exp x)) +
             contour_integral (part_circlepath 0 (R n) 0 pi) (f (cnj s)) +
             contour_integral (part_circlepath 0 r pi 0) (f (cnj s)))
            = -2 * pi * \<i> * exp (- s * of_real pi * \<i> / 2) * (\<Sum>k\<in>{0<..n}. Res s k) -
              cnj (-2 * pi * \<i> * exp (- cnj s * of_real pi * \<i> / 2) * (\<Sum>k\<in>{0<..n}. Res (cnj s) k))"
       (is "?lhs = ?rhs") unfolding R_def g_def using r
       by (subst (1 2) hurwitz_formula_integral_semiannulus) auto
     also have "?rhs = -2 * pi * \<i> * (exp (- s * pi * \<i> / 2) * (\<Sum>k\<in>{0<..n}. Res s k) +
                                      exp (s * pi * \<i> / 2) * (\<Sum>k\<in>{0<..n}. cnj (Res (cnj s) k)))"
       by (simp add: exp_cnj sum.distrib algebra_simps sum_distrib_left sum_distrib_right sum_negf)
     also have "(\<Sum>k\<in>{0<..n}. Res s k) = 
                  (2 * pi) powr (-s) * (\<Sum>k\<in>{0<..n}. exp (2 * k * pi * a * \<i>) * k powr (-s))"
       (is "_ = ?S1") by (simp add: Res_def powr_times_real algebra_simps sum_distrib_left)
     also have "(\<Sum>k\<in>{0<..n}. cnj (Res (cnj s) k)) =
                  (2 * pi) powr (-s) * (\<Sum>k\<in>{0<..n}. exp (-2 * k * pi * a * \<i>) * k powr (-s))"
       by (simp add: Res_def cnj_powr powr_times_real algebra_simps exp_cnj sum_distrib_left)
     also have "exp (-s * pi * \<i> / 2) * ?S1 + exp (s * pi * \<i> / 2) * \<dots> =
                  (2 * pi) powr (-s) *
                    (exp (-s * pi * \<i> / 2) * (\<Sum>k\<in>{0<..n}. exp (2 * k * pi * a * \<i>) * k powr (-s)) +
                     exp (s * pi * \<i> / 2) * (\<Sum>k\<in>{0<..n}. exp (-2 * k * pi * a * \<i>) * k powr (-s)))"
       by (simp add: algebra_simps)
     also have 1: "integral {r..R n} (g s) = I n" unfolding I_def
       by (intro set_borel_integral_eq_integral(2) [symmetric] integrable) auto
     have 2: "cnj (integral {r..R n} (g (cnj s))) = integral {r..R n} (g s)" using r
       unfolding integral_cnj by (intro integral_cong) (auto simp: g_def cnj_powr)
     have 3: "integral {r..R n} (\<lambda>x. exp (x * a) * cnj (x powr - cnj s) / (1 - exp x)) =
              integral {r..R n} (\<lambda>x. exp (x * a) * of_real x powr - s / (1 - exp x))"
       unfolding I_def g_def using r R[of n] by (intro integral_cong; force simp: cnj_powr)+
     from 1 2 3 have "?lhs = (exp (-\<i> * s * pi) - exp (\<i> * s * pi)) * I n + bigc n + smallc"
       by (simp add: integral_cnj cnj_powr algebra_simps exp_cnj
                     bigc_def smallc_def g_def)
     also have "exp (-\<i> * s * pi) - exp (\<i> * s * pi) = -2 * \<i> * sin (s * pi)"
       by (simp add: sin_exp_eq' algebra_simps)
     finally have "(- 2 * \<i> * sin (s * pi) * I n + smallc) + bigc n = 
                     -2 * \<i> * pi * (2 * pi) powr (-s) * (F1 n + F2 n)"
       by (simp add: F1_F2_def algebra_simps)
   } note eq = this
 
   
   have "(\<lambda>n. - 2 * \<i> * sin (s * pi) * I n + smallc + bigc n) \<longlonglongrightarrow>
            (-2 * \<i> * sin (s * pi)) * (CLBINT x:{r..}. g s x) + smallc + 0"
     unfolding I_def
   proof (intro tendsto_intros filterlim_compose[OF tendsto_set_lebesgue_integral_at_top] integrable)
     show "filterlim R at_top sequentially" unfolding R_def
       by (intro filterlim_at_top_mult_tendsto_pos[OF tendsto_const] pi_gt_zero
                 filterlim_compose[OF filterlim_real_sequentially] filterlim_subseq) 
          (auto simp: strict_mono_Suc_iff)
 
     from hurwitz_formula_bound1[OF pi_gt_zero] guess C . note C = this
     define D where "D = C * exp (3 / 2 * pi * \<bar>Im s\<bar>)"
     from \<open>C \<ge> 0\<close> have "D \<ge> 0" by (simp add: D_def)
     show "bigc \<longlonglongrightarrow> 0"
     proof (rule Lim_null_comparison[OF always_eventually[OF allI]])
       fix n :: nat
       have bound: "norm (f s' z) \<le> D * R n powr (-Re s')"
         if z: "z \<in> sphere 0 (R n)" "Re s' = Re s" "\<bar>Im s'\<bar> = \<bar>Im s\<bar>" for z s'
       proof -
         from z and r R[of n] have [simp]: "z \<noteq> 0" by auto
         have not_in_ball: "z \<notin> ball (2 * m * pi * \<i>) pi" for m :: int
         proof -
           have "dist z (2 * m * pi * \<i>) \<ge> \<bar>dist z 0 - dist 0 (2 * m * pi * \<i>)\<bar>"
             by (rule abs_dist_diff_le)
           also have "dist 0 (2 * m * pi * \<i>) = 2 * \<bar>m\<bar> * pi"
             by (simp add: norm_mult)
           also from z have "dist z 0 = R n" by simp
           also have "R n - 2 * \<bar>m\<bar> * pi = (int (2 * n + 1) - 2 * \<bar>m\<bar>) * pi"
             by (simp add: R_def algebra_simps)
           also have "\<bar>\<dots>\<bar> = \<bar>int (2 * n + 1) - 2 * \<bar>m\<bar>\<bar> * pi"
             by (subst abs_mult) simp_all
           also have "\<bar>int (2 * n + 1) - 2 * \<bar>m\<bar>\<bar> \<ge> 1" by presburger
           hence "\<dots> * pi \<ge> 1 * pi" by (intro mult_right_mono) auto
           finally show ?thesis by (simp add: dist_commute)
         qed
 
         have "norm (f s' z) = norm (exp (-Ln' z * s')) * norm (exp (a * z) / (1 - exp z))"
           by (simp add: f_def exp_diff norm_mult norm_divide mult_ac exp_minus norm_inverse
                         divide_simps del: norm_exp_eq_Re)
         also have "\<dots> \<le> norm (exp (-Ln' z * s')) * C" using not_in_ball
           by (intro mult_left_mono C) auto
         also have "norm (exp (-Ln' z * s')) = 
                      exp (Im s' * (Im (Ln (- (\<i> * z))) + pi / 2)) / exp (Re s' * ln (R n))"
           using z r R[of n] pi_gt_zero
           by (simp add: Ln'_def norm_mult norm_divide exp_add exp_diff exp_minus
                         norm_inverse algebra_simps inverse_eq_divide)
         also have "\<dots> \<le> exp (3/2 * pi * \<bar>Im s'\<bar>) / exp (Re s' * ln (R n))"
         proof (intro divide_right_mono, subst exp_le_cancel_iff)
           have "Im s' * (Im (Ln (- (\<i> * z))) + pi / 2) \<le> \<bar>Im s' * (Im (Ln (- (\<i> * z))) + pi / 2)\<bar>"
             by (rule abs_ge_self)
           also have "\<dots> \<le> \<bar>Im s'\<bar> * (pi + pi / 2)"
             unfolding abs_mult using mpi_less_Im_Ln[of "- (\<i> * z)"] Im_Ln_le_pi[of "- (\<i> * z)"]
             by (intro mult_left_mono order.trans[OF abs_triangle_ineq] add_mono) auto
           finally show "Im s' * (Im (Ln (- (\<i> * z))) + pi / 2) \<le> 3/2 * pi * \<bar>Im s'\<bar>"
             by (simp add: algebra_simps)
         qed auto
         also have "exp (Re s' * ln (R n)) = R n powr Re s'"
           using r R[of n] by (auto simp: powr_def)
         finally show "norm (f s' z) \<le> D * R n powr (-Re s')" using \<open>C \<ge> 0\<close>
           by (simp add:  that D_def powr_minus mult_right_mono mult_left_mono field_simps)
       qed
 
       have "norm (bigc n) \<le> norm (contour_integral (part_circlepath 0 (R n) 0 pi) (f s)) +
               norm (cnj (contour_integral (part_circlepath 0 (R n) 0 pi) (f (cnj s))))"
         (is "_ \<le> norm ?err1 + norm ?err2") unfolding bigc_def by (rule norm_triangle_ineq4)
       also have "norm ?err1 \<le> D * R n powr (-Re s) * R n * \<bar>pi - 0\<bar>"
         using \<open>D \<ge> 0\<close> and r R[of n] and pi_gt3 and integrable_circle and
               path_image_part_circlepath_subset[of 0 pi "R n" 0] and bound[of _ s]
         by (intro contour_integral_bound_part_circlepath) auto
       also have "\<dots> = D * pi * R n powr (1 - Re s)" using r R[of n] pi_gt3
         by (simp add: powr_diff field_simps powr_minus)
       also have "norm ?err2 \<le> D * R n powr (-Re s) * R n * \<bar>pi - 0\<bar>"
         unfolding complex_mod_cnj
         using \<open>D \<ge> 0\<close> and r R[of n] and pi_gt3 and integrable_circle'[of n] and
               path_image_part_circlepath_subset[of 0 pi "R n" 0] and bound[of _ "cnj s"]
         by (intro contour_integral_bound_part_circlepath) auto
       also have "\<dots> = D * pi * R n powr (1 - Re s)" using r R[of n] pi_gt3
         by (simp add: powr_diff field_simps powr_minus)
       finally show "norm (bigc n) \<le> 2 * D * pi * R n powr (1 - Re s)"
         by simp
     next
       have "filterlim R at_top at_top" by fact
       hence "(\<lambda>x. 2 * D * pi * R x powr (1 - Re s)) \<longlonglongrightarrow> 2 * D * pi * 0" using s unfolding R_def
         by (intro tendsto_intros tendsto_neg_powr) auto
       thus "(\<lambda>x. 2 * D * pi * R x powr (1 - Re s)) \<longlonglongrightarrow> 0" by simp
     qed
   qed auto
   also have "(\<lambda>n. - 2 * \<i> * sin (s * pi) * I n + smallc + bigc n) =
                (\<lambda>n. -2 * \<i> * pi * (2 * pi) powr -s * (F1 n + F2 n))" by (subst eq) auto
   finally have "\<dots> \<longlonglongrightarrow> (-2 * \<i> * sin (s * pi)) * (CLBINT x:{r..}. g s x) + smallc" by simp
 
   moreover have "(\<lambda>n. -2 * \<i> * pi * (2 * pi) powr -s * (F1 n + F2 n)) \<longlonglongrightarrow>
                    -2 * \<i> * pi * (2 * pi) powr -s * 
                    (exp (-s * pi * \<i> / 2) * F a s + exp (s * pi * \<i> / 2) * F (-a) s)"
     unfolding F1_F2_def F_def using s by (intro tendsto_intros sum_tendsto_fds_perzeta)
   ultimately have "-2 * \<i> * pi * (2 * pi) powr -s * 
                        (exp (-s * pi * \<i> / 2) * F a s + exp (s * pi * \<i> / 2) * F (-a) s) =
                      (-2 * \<i> * sin (s * pi)) * (CLBINT x:{r..}. g s x) + smallc"
     by (force intro: tendsto_unique)
   also have "\<dots> = -2 * \<i> * pi * rGamma s * hurwitz_zeta a (1 - s)" using s r a
     using rGamma_hurwitz_zeta_eq_contour_integral[of s r]
     by (simp add: r_def smallc_def algebra_simps)
   also have "exp (- s * complex_of_real pi * \<i> / 2) = \<i> powr (-s)"
     by (simp add: powr_def field_simps)
   also have "exp (s * complex_of_real pi * \<i> / 2) = \<i> powr s"
     by (simp add: powr_def field_simps)
   finally show "rGamma s * hurwitz_zeta a (1 - s) = (2 * pi) powr -s * 
                   (\<i> powr (-s) * F a s + \<i> powr s * F (-a) s)" by simp
 qed
 
 end
 
 text \<open>
   We can now use Hurwitz's formula to prove the following nice formula that expresses the periodic 
   zeta function in terms of the Hurwitz zeta function:
   \[F(s, a) = (2\pi)^{s-1} i \Gamma(1 - s)
                 \left(i^{-s} \zeta(1 - s, a) - i^{s} \zeta(1 - s, 1 - a)\right)\]
   This holds for all \<open>s\<close> with \<open>\mathfrak{R}(s) > 0\<close> as long as \<open>a \<notin> \<int>\<close>. For convenience, we
   move the \<open>\<Gamma>\<close> function to the left-hand side in order to avoid having to account for its poles.
 \<close>
 lemma perzeta_conv_hurwitz_zeta_aux:
   fixes a :: real and s :: complex
   assumes a: "a \<in> {0<..<1}" and s: "Re s > 0"
   shows   "rGamma (1 - s) * eval_fds (fds_perzeta a) s = (2 * pi) powr (s - 1) * \<i> *
              (\<i> powr -s * hurwitz_zeta a (1 - s) -
               \<i> powr s * hurwitz_zeta (1 - a) (1 - s))" 
   (is "?lhs s = ?rhs s")
 proof (rule analytic_continuation_open[where f = ?lhs])
   show "connected {s. Re s > 0}"
     by (intro convex_connected convex_halfspace_Re_gt)
   show "{s. Re s > 1} \<noteq> {}" by (auto intro: exI[of _ 2])
   show "(\<lambda>s. rGamma (1 - s) * eval_fds (fds_perzeta a) s) holomorphic_on {s. 0 < Re s}"
     unfolding perzeta_def using a
     by (auto intro!: holomorphic_intros le_less_trans[OF conv_abscissa_perzeta'] elim!: Ints_cases)
   show "?rhs holomorphic_on {s. 0 < Re s}" using assms by (auto intro!: holomorphic_intros)
 next
   fix s assume s: "s \<in> {s. Re s > 1}"
   have [simp]: "fds_perzeta (1 - a) = fds_perzeta (-a)"
     using fds_perzeta.plus_of_nat[of "-a" 1] by simp
   have [simp]: "fds_perzeta (a - 1) = fds_perzeta a"
     using fds_perzeta.minus_of_nat[of a 1] by simp
   from s have [simp]: "Gamma s \<noteq> 0" by (auto simp: Gamma_eq_zero_iff elim!: nonpos_Ints_cases)
 
   have "(2 * pi) powr (-s) * (\<i> * (\<i> powr (-s) * (rGamma s * hurwitz_zeta a (1 - s)) -
                               \<i> powr s * (rGamma s * hurwitz_zeta (1 - a) (1 - s)))) =
         (2 * pi) powr (-s) * ((\<i> powr (1 - s) * (rGamma s * hurwitz_zeta a (1 - s)) +
                                \<i> powr (s - 1) * (rGamma s * hurwitz_zeta (1 - a) (1 - s))))"
     by (simp add: powr_diff field_simps powr_minus)
   also have "\<dots> = ((2 * pi) powr (-s)) ^ 2 * (
           eval_fds (fds_perzeta a) s * (\<i> powr s * \<i> powr (s - 1) + \<i> powr (-s) * \<i> powr (1 - s)) +
           eval_fds (fds_perzeta (-a)) s * (\<i> powr s * \<i> powr (1 - s) + \<i> powr (-s) * \<i> powr (s - 1)))"
     using s a by (subst (1 2) hurwitz_zeta_formula_aux) (auto simp: algebra_simps power2_eq_square)
   also have "(\<i> powr s * \<i> powr (1 - s) + \<i> powr (-s) * \<i> powr (s - 1)) = 
                exp (\<i> * complex_of_real pi / 2) + exp (- (\<i> * complex_of_real pi / 2))"
     by (simp add: powr_def exp_add [symmetric] field_simps)
   also have "\<dots> = 0" by (simp add: exp_eq_polar)
   also have "\<i> powr s * \<i> powr (s - 1) = \<i> powr (2 * s - 1)"
     by (simp add: powr_def exp_add [symmetric] field_simps)
   also have "\<i> powr (-s) * \<i> powr (1 - s) = \<i> powr (1 - 2 * s)"
     by (simp add: powr_def exp_add [symmetric] field_simps)
   also have "\<i> powr (2 * s - 1) + \<i> powr (1 - 2 * s) = 2 * cos ((2 * s - 1) * pi / 2)"
     by (simp add: powr_def cos_exp_eq algebra_simps minus_divide_left cos_sin_eq)
   also have "\<dots> = 2 * sin (pi - s * pi)" by (simp add: cos_sin_eq field_simps)
   also have "\<dots> = 2 * sin (s * pi)" by (simp add: sin_diff)
   finally have "\<i> * (rGamma s * \<i> powr (-s) * hurwitz_zeta a (1 - s) -
                      rGamma s * \<i> powr s * hurwitz_zeta (1 - a) (1 - s)) =
                 2 * (2 * pi) powr -s * sin (s * pi) * eval_fds (fds_perzeta a) s"
     by (simp add: power2_eq_square mult_ac)
   hence "(2 * pi) powr s / 2 * \<i> *
            (\<i> powr (-s) * hurwitz_zeta a (1 - s) -
             \<i> powr s * hurwitz_zeta (1 - a) (1 - s)) =
          Gamma s * sin (s * pi) * eval_fds (fds_perzeta a) s"
     by (subst (asm) (2) powr_minus) (simp add: field_simps rGamma_inverse_Gamma)
   also have "Gamma s * sin (s * pi) = pi * rGamma (1 - s)"
     using Gamma_reflection_complex[of s]
     by (auto simp: divide_simps rGamma_inverse_Gamma mult_ac split: if_splits)
   finally show "?lhs s = ?rhs s" by (simp add: powr_diff)
 qed (insert s, auto simp: open_halfspace_Re_gt)
 
 text \<open>
   We can now use the above equation as a defining equation to continue the periodic
   zeta function $F$ to the entire complex plane except at non-negative integer values for \<open>s\<close>.
   However, the positive integers are already covered by the original Dirichlet series definition
   of $F$, so we only need to take care of \<open>s = 0\<close>. We do this by cancelling the pole of \<open>\<Gamma>\<close> at \<open>0\<close>
   with the zero of $i^{-s} \zeta(1 - s, a) - i^s \zeta(1 - s, 1 - a)$.
 \<close>
 lemma
   assumes "q' \<notin> \<int>"
   shows   holomorphic_perzeta': "perzeta q' holomorphic_on A"
     and   perzeta_altdef2:   "Re s > 0 \<Longrightarrow> perzeta q' s = eval_fds (fds_perzeta q') s"
 proof -
   define q where "q = frac q'"
   from assms have q: "q \<in> {0<..<1}" by (auto simp: q_def frac_lt_1)
   hence [simp]: "q \<notin> \<int>" by (auto elim!: Ints_cases)
   have [simp]: "frac q = q" by (simp add: q_def frac_def)
   define f where "f = (\<lambda>s. complex_of_real (2 * pi) powr (s - 1) * \<i> * Gamma (1 - s) *
                         (\<i> powr (-s) * hurwitz_zeta q (1 - s) -
                          \<i> powr s * hurwitz_zeta (1 - q) (1 - s)))"
 
   {
     fix s :: complex assume "1 - s \<in> \<int>\<^sub>\<le>\<^sub>0"
     then obtain n where "1 - s = of_int n" "n \<le> 0" by (auto elim!: nonpos_Ints_cases)
     hence "s = 1 - of_int n" by (simp add: algebra_simps)
     also have "\<dots> \<in> \<nat>" using \<open>n \<le> 0\<close> by (auto simp: Nats_altdef1 intro: exI[of _ "1 - n"])
     finally have "s \<in> \<nat>" .
   } note * = this
   hence "f holomorphic_on -\<nat>" using q
     by (auto simp: f_def Nats_altdef2 nonpos_Ints_altdef not_le intro!: holomorphic_intros)
   also have "?this \<longleftrightarrow> perzeta q holomorphic_on -\<nat>" using assms
     by (intro holomorphic_cong refl) (auto simp: perzeta_def Let_def f_def)
   finally have holo: "perzeta q holomorphic_on -\<nat>" .
 
   have f_altdef: "f s = eval_fds (fds_perzeta q) s" if "Re s > 0" and "s \<notin> \<nat>" for s
     using perzeta_conv_hurwitz_zeta_aux[OF q, of s] that *
     by (auto simp: rGamma_inverse_Gamma Gamma_eq_zero_iff divide_simps f_def perzeta_def
              split: if_splits)
   show "perzeta q' s = eval_fds (fds_perzeta q') s" if "Re s > 0" for s
     using f_altdef[of s] that assms by (auto simp: f_def perzeta_def Let_def q_def)
 
   have cont: "isCont (perzeta q) s" if "s \<in> \<nat>" for s
   proof (cases "s = 0")
     case False
     with that obtain n where [simp]: "s = of_nat n" and n: "n > 0"
       by (auto elim!: Nats_cases)
     have *: "open ({s. Re s > 0} - (\<nat> - {of_nat n}))" using Nats_subset_Ints
       by (intro open_Diff closed_subset_Ints open_halfspace_Re_gt) auto
     have "eventually (\<lambda>s. s \<in> {s. Re s > 0} - (\<nat> - {of_nat n})) (nhds (of_nat n))" using \<open>n > 0\<close>
       by (intro eventually_nhds_in_open *) auto 
     hence ev: "eventually (\<lambda>s. eval_fds (fds_perzeta q) s = perzeta q s) (nhds (of_nat n))"
     proof eventually_elim
       case (elim s)
       thus ?case using q f_altdef[of s]
         by (auto simp: perzeta_def dist_of_nat f_def elim!: Nats_cases Ints_cases)
     qed
     have "isCont (eval_fds (fds_perzeta q)) (of_nat n)" using q and \<open>n > 0\<close>
       by (intro continuous_eval_fds le_less_trans[OF conv_abscissa_perzeta'])
          (auto elim!: Ints_cases)
     also have "?this \<longleftrightarrow> isCont (perzeta q) (of_nat n)" using ev
       by (intro isCont_cong ev)
     finally show ?thesis by simp
   next
     assume [simp]: "s = 0"
     define a where "a = Complex (ln q) (-pi / 2)"
     define b where "b = Complex (ln (1 - q)) (pi / 2)"
     have "eventually (\<lambda>s::complex. s \<notin> \<nat>) (at 0)"
       unfolding eventually_at_topological using Nats_subset_Ints
       by (intro exI[of _ "-(\<nat>-{0})"] conjI open_Compl closed_subset_Ints) auto
     hence ev: "eventually (\<lambda>s. perzeta q s = (2 * pi) powr (s - 1) * Gamma (1 - s) * \<i> *
                  (\<i> powr - s * pre_zeta q (1 - s) -\<i> powr s * pre_zeta (1 - q) (1 - s) +
                  (exp (b * s) - exp (a * s)) / s)) (at (0::complex))"
       (is "eventually (\<lambda>s. _ = ?f s) _")
     proof eventually_elim
       case (elim s)
       have "perzeta q s = (2 * pi) powr (s - 1) * Gamma (1 - s) * \<i> *
               (\<i> powr (-s) * hurwitz_zeta q (1 - s) -
                \<i> powr s * hurwitz_zeta (1 - q) (1 - s))" (is "_ = _ * ?T")
         using elim by (auto simp: perzeta_def powr_diff powr_minus field_simps)
       also have "?T = \<i> powr (-s) * pre_zeta q (1 - s) - \<i> powr s * pre_zeta (1 - q) (1 - s) +
                       (\<i> powr s * (1 - q) powr s - \<i> powr (-s) * q powr s) / s" using elim
         by (auto simp: hurwitz_zeta_def field_simps)
       also have "\<i> powr s * (1 - q) powr s = exp (b * s)" using q
         by (simp add: powr_def exp_add algebra_simps Ln_Reals_eq Complex_eq b_def)
       also have "\<i> powr (-s) * q powr s = exp (a * s)" using q
         by (simp add: powr_def exp_add Ln_Reals_eq exp_diff exp_minus diff_divide_distrib 
                       ring_distribs inverse_eq_divide mult_ac Complex_eq a_def)
       finally show ?case .
     qed
   
     have [simp]: "\<not>(pi \<le> 0)" using pi_gt_zero by (simp add: not_le)
     have "(\<lambda>s::complex. if s = 0 then b - a else (exp (b * s) - exp (a * s)) / s)
                 has_fps_expansion (fps_exp b - fps_exp a) / fps_X" (is "?f' has_fps_expansion _")
       by (rule fps_expansion_intros)+ (auto intro!: subdegree_geI simp: Ln_Reals_eq a_def b_def)
     hence "isCont ?f' 0" by (rule has_fps_expansion_imp_continuous)
     hence "?f' \<midarrow>0\<rightarrow> b - a" by (simp add: isCont_def)
     also have "?this \<longleftrightarrow> (\<lambda>s. (exp (b * s) - exp (a * s)) / s) \<midarrow>0\<rightarrow> b - a"
       by (intro filterlim_cong refl) (auto simp: eventually_at intro: exI[of _ 1])
     finally have "?f \<midarrow>0\<rightarrow> of_real (2 * pi) powr (0 - 1) * Gamma (1 - 0) * \<i> *
                     (\<i> powr -0 * pre_zeta q (1 - 0) -\<i> powr 0 * pre_zeta (1 - q) (1 - 0) + (b - a))"
       (is "filterlim _ (nhds ?c) _")
       using q by (intro tendsto_intros isContD)
                  (auto simp: complex_nonpos_Reals_iff intro!: continuous_intros)
     also have "?c = perzeta q 0" using q
       by (simp add: powr_minus perzeta_def Ln_Reals_eq a_def b_def
                     Complex_eq mult_ac inverse_eq_divide)
     also have "?f \<midarrow>0\<rightarrow> \<dots> \<longleftrightarrow> perzeta q \<midarrow>0\<rightarrow> \<dots>"
       by (rule sym, intro filterlim_cong refl ev)
     finally show "isCont (perzeta q) s" by (simp add: isCont_def)
   qed
 
   have "perzeta q field_differentiable at s" for s
   proof (cases "s \<in> \<nat>")
     case False
     with holo have "perzeta q field_differentiable at s within -\<nat>" 
       unfolding holomorphic_on_def by blast
     also have "at s within -\<nat> = at s" using False
       by (intro at_within_open) auto
     finally show ?thesis .
   next
     case True
     hence *: "perzeta q holomorphic_on (ball s 1 - {s})"
       by (intro holomorphic_on_subset[OF holo]) (auto elim!: Nats_cases simp: dist_of_nat)
     have "perzeta q holomorphic_on ball s 1" using cont True
       by (intro no_isolated_singularity'[OF _ *])
          (auto simp: at_within_open[of _ "ball s 1"] isCont_def)
     hence "perzeta q field_differentiable at s within ball s 1" 
       unfolding holomorphic_on_def by auto
     thus ?thesis by (simp add: at_within_open[of _ "ball s 1"])
   qed
   hence "perzeta q holomorphic_on UNIV"
     by (auto simp: holomorphic_on_def)
   also have "perzeta q = perzeta q'" by (simp add: q_def)
   finally show "perzeta q' holomorphic_on A" by auto
 qed
 
 lemma perzeta_altdef1: "Re s > 1 \<Longrightarrow> perzeta q' s = eval_fds (fds_perzeta q') s"
   by (cases "q' \<in> \<int>") (auto simp: perzeta_int eval_fds_zeta fds_perzeta_int perzeta_altdef2)
 
 lemma holomorphic_perzeta: "q \<notin> \<int> \<or> 1 \<notin> A \<Longrightarrow> perzeta q holomorphic_on A"
   by (cases "q \<in> \<int>") (auto simp: perzeta_int intro: holomorphic_perzeta' holomorphic_zeta)
 
 lemma holomorphic_perzeta'' [holomorphic_intros]:
   assumes "f holomorphic_on A" and "q \<notin> \<int> \<or> (\<forall>x\<in>A. f x \<noteq> 1)"
   shows   "(\<lambda>x. perzeta q (f x)) holomorphic_on A"
 proof -
   have "perzeta q \<circ> f holomorphic_on A" using assms 
     by (intro holomorphic_on_compose holomorphic_perzeta) auto
   thus ?thesis by (simp add: o_def)
 qed
 
 text \<open>
   Using this analytic continuation of the periodic zeta function, Hurwitz's formula now
   holds (almost) on the entire complex plane.
 \<close>
 theorem hurwitz_zeta_formula:
   fixes a :: real and s :: complex
   assumes "a \<in> {0<..1}" and "s \<noteq> 0" and "a \<noteq> 1 \<or> s \<noteq> 1"
   shows   "rGamma s * hurwitz_zeta a (1 - s) =
              (2 * pi) powr - s * (\<i> powr - s * perzeta a s + \<i> powr s * perzeta (-a) s)"
   (is "?f s = ?g s")
 proof -
   define A where "A = UNIV - (if a \<in> \<int> then {0, 1} else {0 :: complex})"
   show ?thesis
   proof (rule analytic_continuation_open[where f = ?f])
     show "?f holomorphic_on A" using assms by (auto intro!: holomorphic_intros simp: A_def)
     show "?g holomorphic_on A" using assms
       by (auto intro!: holomorphic_intros simp: A_def minus_in_Ints_iff)
   next
     fix s assume "s \<in> {s. Re s > 1}"
     thus "?f s = ?g s" using hurwitz_zeta_formula_aux[of a s] assms
       by (simp add: perzeta_altdef1)
   qed (insert assms, auto simp: open_halfspace_Re_gt A_def elim!: Ints_cases
                            intro: connected_open_delete_finite exI[of _ 2])
 qed
 
 text \<open>
   The equation expressing the periodic zeta function in terms of the Hurwitz zeta function
   can be extened similarly.
 \<close>
 theorem perzeta_conv_hurwitz_zeta:
   fixes a :: real and s :: complex
   assumes "a \<in> {0<..<1}" and "s \<noteq> 0"
   shows   "rGamma (1 - s) * perzeta a s =
              (2 * pi) powr (s - 1) * \<i> * (\<i> powr (-s) * hurwitz_zeta a (1 - s) -
                                          \<i> powr s * hurwitz_zeta (1 - a) (1 - s))"
   (is "?f s = ?g s")
 proof (rule analytic_continuation_open[where f = ?f])
   show "?f holomorphic_on -{0}" using assms by (auto intro!: holomorphic_intros elim: Ints_cases)
   show "?g holomorphic_on -{0}" using assms by (auto intro!: holomorphic_intros)
 next
   fix s assume "s \<in> {s. Re s > 1}"
   thus "?f s = ?g s" using perzeta_conv_hurwitz_zeta_aux[of a s] assms
     by (simp add: perzeta_altdef1)
 qed (insert assms, auto simp: open_halfspace_Re_gt connected_punctured_universe intro: exI[of _ 2])
 
 
 text \<open>
   As a simple corollary, we derive the reflection formula for the Riemann zeta function:
 \<close>
 corollary zeta_reflect:
   fixes s :: complex
   assumes "s \<noteq> 0" "s \<noteq> 1"
   shows   "rGamma s * zeta (1 - s) = 2 * (2 * pi) powr -s * cos (s * pi / 2) * zeta s"
   using hurwitz_zeta_formula[of 1 s] assms
   by (simp add: zeta_def cos_exp_eq powr_def perzeta_int algebra_simps)
 
 corollary zeta_reflect':
   fixes s :: complex
   assumes "s \<noteq> 0" "s \<noteq> 1"
   shows   "rGamma (1 - s) * zeta s = 2 * (2 * pi) powr (s - 1) * sin (s * pi / 2) * zeta (1 - s)"
   using zeta_reflect[of "1 - s"] assms by (simp add: cos_sin_eq field_simps)
 
 text \<open>
   It is now easy to see that all the non-trivial zeroes of the Riemann zeta function must lie
   the critical strip $(0;1)$, and they must be symmetric around the
   $\mathfrak{R}(z) = \frac{1}{2}$ line.
 \<close>
 corollary zeta_zeroD:
   assumes "zeta s = 0" "s \<noteq> 1"
   shows   "Re s \<in> {0<..<1} \<or> (\<exists>n::nat. n > 0 \<and> even n \<and> s = -real n)"
 proof (cases "Re s \<le> 0")
   case False
   with zeta_Re_ge_1_nonzero[of s] assms have "Re s < 1"
     by (cases "Re s < 1") auto
   with False show ?thesis by simp
 next
   case True
   {
     assume *: "\<And>n. n > 0 \<Longrightarrow> even n \<Longrightarrow> s \<noteq> -real n"
     have "s \<noteq> of_int n" for n :: int
     proof
       assume [simp]: "s = of_int n"
       show False
       proof (cases n "0::int" rule: linorder_cases)
         assume "n < 0"
         show False
         proof (cases "even n")
           case True
           hence "nat (-n) > 0" "even (nat (-n))" using \<open>n < 0\<close>
             by (auto simp: even_nat_iff)
           with * have "s \<noteq> -real (nat (-n))" .
           with \<open>n < 0\<close> and True show False by auto
         next
           case False
           with \<open>n < 0\<close> have "of_int n = (-of_nat (nat (-n)) :: complex)" by simp
           also have "zeta \<dots> = -(bernoulli' (Suc (nat (-n)))) / of_nat (Suc (nat (-n)))"
             using \<open>n < 0\<close> by (subst zeta_neg_of_nat) (auto)
           finally have "bernoulli' (Suc (nat (-n))) = 0" using assms
             by (auto simp del: of_nat_Suc)
           with False and \<open>n < 0\<close> show False
             by (auto simp: bernoulli'_zero_iff even_nat_iff)
         qed
       qed (insert assms True, auto)
     qed
     hence "rGamma s \<noteq> 0"
       by (auto simp: rGamma_eq_zero_iff nonpos_Ints_def)
     moreover from assms have [simp]: "s \<noteq> 0" by auto
     ultimately have "zeta (1 - s) = 0" using zeta_reflect[of s] and assms
       by auto
     with True zeta_Re_ge_1_nonzero[of "1 - s"] have "Re s > 0" by auto
   }
   with True show ?thesis by auto
 qed
 
 lemma zeta_zero_reflect:
   assumes "Re s \<in> {0<..<1}" and "zeta s = 0"
   shows   "zeta (1 - s) = 0"
 proof -
   from assms have "rGamma s \<noteq> 0"
     by (auto simp: rGamma_eq_zero_iff elim!: nonpos_Ints_cases)
   moreover from assms have "s \<noteq> 0" and "s \<noteq> 1" by auto
   ultimately show ?thesis using zeta_reflect[of s] and assms by auto
 qed
 
 corollary zeta_zero_reflect_iff:
   assumes "Re s \<in> {0<..<1}"
   shows   "zeta (1 - s) = 0 \<longleftrightarrow> zeta s = 0"
   using zeta_zero_reflect[of s] zeta_zero_reflect[of "1 - s"] assms by auto
 
 
 subsection \<open>More functional equations\<close>
 
 lemma perzeta_conv_hurwitz_zeta_multiplication:
   fixes k :: nat and a :: int and s :: complex
   assumes "k > 0" "s \<noteq> 1"
   shows   "k powr s * perzeta (a / k) s =
              (\<Sum>n=1..k. exp (2 * pi * n * a / k * \<i>) * hurwitz_zeta (n / k) s)"
   (is "?lhs s = ?rhs s")
 proof (rule analytic_continuation_open[where ?f = ?lhs and ?g = ?rhs])
   show "connected (-{1::complex})" by (rule connected_punctured_universe) auto
   show "{s. Re s > 1} \<noteq> {}" by (auto intro!: exI[of _ 2])
 next
   fix s assume s: "s \<in> {s. Re s > 1}"
   let ?f = "\<lambda>n. exp (2 * pi * n * a / k * \<i>)"
 
   show "?lhs s = ?rhs s"
   proof (rule sums_unique2)
     have "(\<lambda>m. \<Sum>n=1..k. ?f n * (of_nat m + of_real (real n / real k)) powr -s) sums
             (\<Sum>n=1..k. ?f n * hurwitz_zeta (real n / real k) s)"
       using assms s by (intro sums_sum sums_mult sums_hurwitz_zeta) auto
     also have "(\<lambda>m. \<Sum>n=1..k. ?f n * (of_nat m + of_real (real n / real k)) powr -s) =
                  (\<lambda>m. of_nat k powr s * (\<Sum>n=1..k. ?f n * of_nat (m * k + n) powr -s))"
       unfolding sum_distrib_left
     proof (intro ext sum.cong, goal_cases)
       case (2 m n)
       hence "m * k + n > 0" by (intro add_nonneg_pos) auto
       hence "of_nat 0 \<noteq> (of_nat (m * k + n) :: complex)" by (simp only: of_nat_eq_iff)
       also have "of_nat (m * k + n) = of_nat m * of_nat k + (of_nat n :: complex)" by simp
       finally have nz: "\<dots> \<noteq> 0" by auto
       
       have "of_nat m + of_real (real n / real k) = 
               (inverse (of_nat k) * of_nat (m * k + n) :: complex)" using assms
         (* TODO: Field_as_Ring messing up things again *)
         by (simp add: field_simps del: div_mult_self1 div_mult_self2 div_mult_self3 div_mult_self4)
       also from nz have "\<dots> powr -s = of_nat k powr s * of_nat (m * k + n) powr -s"
         by (subst powr_times_real) (auto simp: add_eq_0_iff powr_def exp_minus Ln_inverse)
       finally show ?case by simp
     qed auto
     finally show "\<dots> sums (\<Sum>n=1..k. ?f n * hurwitz_zeta (real n / real k) s)" .
   next
     define g where "g = (\<lambda>m. exp (2 * pi * \<i> * m * (real_of_int a / real k)))"
     have "(\<lambda>m. g (Suc m) / (Suc m) powr s) sums eval_fds (fds_perzeta (a / k)) s"
       unfolding g_def using s by (intro sums_fds_perzeta) auto
     also have "(\<lambda>m. g (Suc m) / (Suc m) powr s) = (\<lambda>m. ?f (Suc m) * (Suc m) powr -s)"
       by (simp add: powr_minus field_simps g_def)
     also have "eval_fds (fds_perzeta (a / k)) s = perzeta (a / k) s"
       using s by (simp add: perzeta_altdef1)
     finally have "(\<lambda>m. \<Sum>n=m*k..<m*k+k. ?f (Suc n) * of_nat (Suc n) powr -s) sums perzeta (a / k) s"
       using \<open>k > 0\<close> by (rule sums_group)
     also have "(\<lambda>m. \<Sum>n=m*k..<m*k+k. ?f (Suc n) * of_nat (Suc n) powr -s) = 
                  (\<lambda>m. \<Sum>n=1..k. ?f (m * k + n) * of_nat (m * k + n) powr -s)"
     proof (rule ext, goal_cases)
       case (1 m)
       show ?case using assms
         by (intro ext sum.reindex_bij_witness[of _ "\<lambda>n. m * k + n - 1" "\<lambda>n. Suc n - m * k"]) auto
     qed
     also have "(\<lambda>m n. ?f (m * k + n)) = (\<lambda>m n. ?f n)"
     proof (intro ext)
       fix m n :: nat
       have "?f (m * k + n) / ?f n = exp (2 * pi * m * a * \<i>)"
         using \<open>k > 0\<close> by (auto simp: ring_distribs add_divide_distrib exp_add mult_ac)
       also have "\<dots> = cis (2 * pi * (m * a))"
         by (simp add: exp_eq_polar mult_ac)
       also have "\<dots> = 1"
         by (rule cis_multiple_2pi) auto
       finally show "?f (m * k + n) = ?f n"
         by simp
     qed
     finally show "(\<lambda>m. of_nat k powr s * (\<Sum>n=1..k. ?f n * of_nat (m * k + n) powr -s)) sums
                     (of_nat k powr s * perzeta (a / k) s)" by (rule sums_mult)
   qed
 qed (use assms in \<open>auto intro!: holomorphic_intros simp: finite_imp_closed open_halfspace_Re_gt\<close>)
 
 lemma perzeta_conv_hurwitz_zeta_multiplication':
   fixes k :: nat and a :: int and s :: complex
   assumes "k > 0" "s \<noteq> 1"
   shows   "perzeta (a / k) s = k powr -s *
              (\<Sum>n=1..k. exp (2 * pi * n * a / k * \<i>) * hurwitz_zeta (n / k) s)"
   using perzeta_conv_hurwitz_zeta_multiplication[of k s a] assms
   by (simp add: powr_minus field_simps)
 
 lemma zeta_conv_hurwitz_zeta_multiplication:
   fixes k a :: nat and s :: complex
   assumes "k > 0" "s \<noteq> 1"
   shows   "k powr s * zeta s = (\<Sum>n=1..k. hurwitz_zeta (n / k) s)"
   using perzeta_conv_hurwitz_zeta_multiplication[of k s 0]
   using assms by (simp add: perzeta_int)
 
 lemma hurwitz_zeta_one_half_left:
   assumes "s \<noteq> 1"
   shows   "hurwitz_zeta (1 / 2) s = (2 powr s - 1) * zeta s"
   using zeta_conv_hurwitz_zeta_multiplication[of 2 s] assms
   by (simp add: eval_nat_numeral zeta_def field_simps)
 
 theorem hurwitz_zeta_functional_equation:
   fixes h k :: nat and s :: complex
   assumes hk: "k > 0" "h \<in> {0<..k}" and s: "s \<notin> {0, 1}"
   defines "a \<equiv> real h / real k"
   shows "rGamma s * hurwitz_zeta a (1 - s) =
            2 * (2 * pi * k) powr -s *
              (\<Sum>n=1..k. cos (s*pi/2 - 2*pi*n*h/k) * hurwitz_zeta (n / k) s)"
 proof -
   from hk have a: "a \<in> {0<..1}" by (auto simp: a_def)
 
   have "rGamma s * hurwitz_zeta a (1 - s) =
           (2 * pi) powr - s * (\<i> powr - s * perzeta a s + \<i> powr s * perzeta (- a) s)"
     using s a by (intro hurwitz_zeta_formula) auto
   also have "\<dots> = (2 * pi) powr - s * (\<i> powr - s * perzeta (of_int (int h) / k) s +
                                        \<i> powr s * perzeta (of_int (-int h) / k) s)"
     by (simp add: a_def)
   also have "\<dots> = (2 * pi) powr -s * k powr -s *
      ((\<Sum>n=1..k. \<i> powr -s * cis (2 * pi * n * h / k) * hurwitz_zeta (n / k) s) +
        (\<Sum>n=1..k. \<i> powr s  * cis (-2 * pi * n * h / k) * hurwitz_zeta (n / k) s))"
     (is "_ = _ * (?S1 + ?S2)") using hk a s
     by (subst (1 2) perzeta_conv_hurwitz_zeta_multiplication')
        (auto simp: field_simps sum_distrib_left sum_distrib_right exp_eq_polar)
   also have "(2 * pi) powr -s * k powr -s = (2 * k * pi) powr -s"
     using hk pi_gt_zero
     by (simp add: powr_def Ln_times_Reals field_simps exp_add exp_diff exp_minus)
   also have "?S1 + ?S2 = (\<Sum>n=1..k. (\<i> powr -s * cis (2*pi*n*h/k) + \<i> powr s * cis (-2*pi*n*h/k)) *
                                     hurwitz_zeta (n / k) s)"
     (is "_ = (\<Sum>n\<in>_. ?c n * _)") by (simp add: algebra_simps sum.distrib)
   also have "?c = (\<lambda>n. 2 * cos (s*pi/2 - 2*pi*n*h/k))"
   proof
     fix n :: nat
     have "\<i> powr -s * cis (2*pi*n*h/k) = exp (-s*pi/2*\<i> + 2*pi*n*h/k*\<i>)"
       unfolding exp_add by (simp add: powr_def cis_conv_exp mult_ac)
     moreover have "\<i> powr s * cis (-2*pi*n*h/k) = exp (s*pi/2*\<i> + -2*pi*n*h/k*\<i>)"
       unfolding exp_add by (simp add: powr_def cis_conv_exp mult_ac)
     ultimately have "?c n = exp (\<i> * (s*pi/2 - 2*pi*n*h/k)) + exp (-(\<i> * (s*pi/2 - 2*pi*n*h/k)))"
       by (simp add: mult_ac ring_distribs)
     also have "\<dots> / 2 = cos (s*pi/2 - 2*pi*n*h/k)"
       by (rule cos_exp_eq [symmetric])
     finally show "?c n = 2 * cos (s*pi/2 - 2*pi*n*h/k)" 
       by simp
   qed
   also have "(2 * k * pi) powr -s * (\<Sum>n=1..k. \<dots> n * hurwitz_zeta (n / k) s) =
                2 * (2 * pi * k) powr -s *
                (\<Sum>n=1..k. cos (s*pi/2 - 2*pi*n*h/k) * hurwitz_zeta (n / k) s)"
     by (simp add: sum_distrib_left sum_distrib_right mult_ac)
   finally show ?thesis .
 qed
 
 lemma perzeta_one_half_left: "s \<noteq> 1 \<Longrightarrow> perzeta (1 / 2) s = (2 powr (1-s) - 1) * zeta s"
   using perzeta_conv_hurwitz_zeta_multiplication'[of 2 s 1]
   by (simp add: eval_nat_numeral hurwitz_zeta_one_half_left powr_minus
                 field_simps zeta_def powr_diff)
 
 lemma perzeta_one_half_left':
   "perzeta (1 / 2) s =
          (if s = 1 then -ln 2 else (2 powr (1 - s) - 1) / (s - 1)) * ((s - 1) * pre_zeta 1 s + 1)"
   by (cases "s = 1") (auto simp: perzeta_one_half_left field_simps zeta_def hurwitz_zeta_def)
   
 end