diff --git a/thys/Affine_Arithmetic/Counterclockwise_2D_Arbitrary.thy b/thys/Affine_Arithmetic/Counterclockwise_2D_Arbitrary.thy
--- a/thys/Affine_Arithmetic/Counterclockwise_2D_Arbitrary.thy
+++ b/thys/Affine_Arithmetic/Counterclockwise_2D_Arbitrary.thy
@@ -1,939 +1,939 @@
 section \<open>CCW for Arbitrary Points in the Plane\<close>
 theory Counterclockwise_2D_Arbitrary
 imports Counterclockwise_2D_Strict
 begin
 
 subsection \<open>Interpretation of Knuth's axioms in the plane\<close>
 
 definition lex::"point \<Rightarrow> point \<Rightarrow> bool" where
   "lex p q \<longleftrightarrow> (fst p < fst q \<or> fst p = fst q \<and> snd p < snd q \<or> p = q)"
 
 definition psi::"point \<Rightarrow> point \<Rightarrow> point \<Rightarrow> bool" where
   "psi p q r \<longleftrightarrow> (lex p q \<and> lex q r)"
 
 definition ccw::"point \<Rightarrow> point \<Rightarrow> point \<Rightarrow> bool" where
   "ccw p q r \<longleftrightarrow> ccw' p q r \<or> (det3 p q r = 0 \<and> (psi p q r \<or> psi q r p \<or> psi r p q))"
 
 interpretation ccw: linorder_list0 "ccw x" for x .
 
 lemma ccw'_imp_ccw: "ccw' a b c \<Longrightarrow> ccw a b c"
   by (simp add: ccw_def)
 
 lemma ccw_ncoll_imp_ccw: "ccw a b c \<Longrightarrow> \<not>coll a b c \<Longrightarrow> ccw' a b c"
   by (simp add: ccw_def)
 
 lemma ccw_translate: "ccw p (p + q) (p + r) = ccw 0 q r"
   by (auto simp: ccw_def psi_def lex_def)
 
 lemma ccw_translate_origin: "NO_MATCH 0 p \<Longrightarrow> ccw p q r = ccw 0 (q - p) (r - p)"
   using ccw_translate[of p "q - p" "r - p"]
   by simp
 
 lemma psi_scale:
   "psi (r *\<^sub>R a) (r *\<^sub>R b) 0 = (if r > 0 then psi a b 0 else if r < 0 then psi 0 b a else True)"
   "psi (r *\<^sub>R a) 0 (r *\<^sub>R b) = (if r > 0 then psi a 0 b else if r < 0 then psi b 0 a else True)"
   "psi 0 (r *\<^sub>R a) (r *\<^sub>R b) = (if r > 0 then psi 0 a b else if r < 0 then psi b a 0 else True)"
   by (auto simp: psi_def lex_def det3_def' not_less sign_simps)
 
 lemma ccw_scale23: "ccw 0 a b \<Longrightarrow> r > 0 \<Longrightarrow> ccw 0 (r *\<^sub>R a) (r *\<^sub>R b)"
   by (auto simp: ccw_def psi_scale)
 
 lemma psi_notI: "distinct3 p q r \<Longrightarrow> psi p q r \<Longrightarrow> \<not> psi q p r"
   by (auto simp: algebra_simps psi_def lex_def)
 
 lemma not_lex_eq: "\<not> lex a b \<longleftrightarrow> lex b a \<and> a \<noteq> b"
   by (auto simp: algebra_simps lex_def prod_eq_iff)
 
 lemma lex_trans: "lex a b \<Longrightarrow> lex b c \<Longrightarrow> lex a c"
   by (auto simp: lex_def)
 
 lemma lex_sym_eqI: "lex a b \<Longrightarrow> lex b a \<Longrightarrow> a = b"
   and lex_sym_eq_iff: "lex a b \<Longrightarrow> lex b a \<longleftrightarrow> a = b"
   by (auto simp: lex_def)
 
 lemma lex_refl[simp]: "lex p p"
   by (metis not_lex_eq)
 
 lemma psi_disjuncts:
   "distinct3 p q r \<Longrightarrow> psi p q r \<or> psi p r q \<or> psi q r p \<or> psi q p r \<or> psi r p q \<or> psi r q p"
   by (auto simp: psi_def not_lex_eq)
 
 lemma nlex_ccw_left: "lex x 0 \<Longrightarrow> ccw 0 (0, 1) x"
   by (auto simp: ccw_def lex_def psi_def ccw'_def det3_def')
 
 interpretation ccw_system123 ccw
   apply unfold_locales
   subgoal by (force simp: ccw_def ccw'_def det3_def' algebra_simps)
   subgoal by (force simp: ccw_def ccw'_def det3_def' psi_def algebra_simps lex_sym_eq_iff)
   subgoal by (drule psi_disjuncts) (force simp: ccw_def ccw'_def det3_def' algebra_simps)
   done
 
 lemma lex_scaleR_nonneg: "lex a b \<Longrightarrow> r \<ge> 0 \<Longrightarrow> lex a (a + r *\<^sub>R (b - a))"
   by (auto simp: lex_def)
 
 lemma lex_scale1_zero:
     "lex (v *\<^sub>R u) 0 = (if v > 0 then lex u 0 else if v < 0 then lex 0 u else True)"
   and lex_scale2_zero:
     "lex 0 (v *\<^sub>R u) = (if v > 0 then lex 0 u else if v < 0 then lex u 0 else True)"
   by (auto simp: lex_def prod_eq_iff less_eq_prod_def sign_simps)
 
 lemma nlex_add:
   assumes "lex a 0" "lex b 0"
   shows "lex (a + b) 0"
   using assms by (auto simp: lex_def)
 
 lemma nlex_sum:
   assumes "finite X"
   assumes "\<And>x. x \<in> X \<Longrightarrow> lex (f x) 0"
   shows "lex (sum f X) 0"
   using assms
   by induction (auto intro!: nlex_add)
 
 lemma abs_add_nlex:
   assumes "coll 0 a b"
   assumes "lex a 0"
   assumes "lex b 0"
   shows "abs (a + b) = abs a + abs b"
 proof (rule antisym[OF abs_triangle_ineq])
   have "fst (\<bar>a\<bar> + \<bar>b\<bar>) \<le> fst \<bar>a + b\<bar>"
     using assms
     by (auto simp add: det3_def' abs_prod_def lex_def)
   moreover
   {
     assume H: "fst a < 0" "fst b < 0"
     hence "snd b \<le> 0 \<longleftrightarrow> snd a \<le> 0"
       using assms
       by (auto simp: lex_def det3_def' mult.commute)
         (metis mult_le_cancel_left_neg mult_zero_right)+
     hence "\<bar>snd a\<bar> + \<bar>snd b\<bar> \<le> \<bar>snd a + snd b\<bar>"
       using H by auto
   } hence "snd (\<bar>a\<bar> + \<bar>b\<bar>) \<le> snd \<bar>a + b\<bar>"
     using assms
     by (auto simp add: det3_def' abs_prod_def lex_def)
   ultimately
   show "\<bar>a\<bar> + \<bar>b\<bar> \<le> \<bar>a + b\<bar>" unfolding less_eq_prod_def ..
 qed
 
 lemma lex_sum_list: "(\<And>x. x \<in> set xs \<Longrightarrow> lex x 0) \<Longrightarrow> lex (sum_list xs) 0"
   by (induct xs) (auto simp: nlex_add)
 
 lemma
   abs_sum_list_coll:
   assumes coll: "list_all (coll 0 x) xs"
   assumes "x \<noteq> 0"
   assumes up: "list_all (\<lambda>x. lex x 0) xs"
   shows "abs (sum_list xs) = sum_list (map abs xs)"
   using assms
 proof (induct xs)
   case (Cons y ys)
   hence "coll 0 x y" "coll 0 x (sum_list ys)"
     by (auto simp: list_all_iff intro!: coll_sum_list)
   hence "coll 0 y (sum_list ys)" using \<open>x \<noteq> 0\<close>
     by (rule coll_trans)
   hence "\<bar>y + sum_list ys\<bar> = abs y + abs (sum_list ys)" using Cons
     by (subst abs_add_nlex) (auto simp: list_all_iff lex_sum_list)
   thus ?case using Cons by simp
 qed simp
 
 lemma lex_diff1: "lex (a - b) c = lex a (c + b)"
   and lex_diff2: "lex c (a - b) = lex (c + b) a"
   by (auto simp: lex_def)
 
 lemma sum_list_eq_0_iff_nonpos:
   fixes xs::"'a::ordered_ab_group_add list"
   shows "list_all (\<lambda>x. x \<le> 0) xs \<Longrightarrow> sum_list xs = 0 \<longleftrightarrow> (\<forall>n\<in>set xs. n = 0)"
   by (auto simp: list_all_iff sum_list_sum_nth sum_nonpos_eq_0_iff)
     (auto simp add: in_set_conv_nth)
 
 lemma sum_list_nlex_eq_zeroI:
   assumes nlex: "list_all (\<lambda>x. lex x 0) xs"
   assumes "sum_list xs = 0"
   assumes "x \<in> set xs"
   shows "x = 0"
 proof -
   from assms(2) have z1: "sum_list (map fst xs) = 0" and z2: "sum_list (map snd xs) = 0"
     by (auto simp: prod_eq_iff fst_sum_list snd_sum_list)
   from nlex have "list_all (\<lambda>x. x \<le> 0) (map fst xs)"
     by (auto simp: lex_def list_all_iff)
   from sum_list_eq_0_iff_nonpos[OF this] z1 nlex
   have
     z1': "list_all (\<lambda>x. x = 0) (map fst xs)"
     and "list_all (\<lambda>x. x \<le> 0) (map snd xs)"
     by (auto simp: list_all_iff lex_def)
   from sum_list_eq_0_iff_nonpos[OF this(2)] z2
   have "list_all (\<lambda>x. x = 0) (map snd xs)" by (simp add: list_all_iff)
   with z1' show "x = 0" by (auto simp: list_all_iff zero_prod_def assms prod_eq_iff)
 qed
 
 lemma sum_list_eq0I: "(\<forall>x\<in>set xs. x = 0) \<Longrightarrow> sum_list xs = 0"
   by (induct xs) auto
 
 lemma sum_list_nlex_eq_zero_iff:
   assumes nlex: "list_all (\<lambda>x. lex x 0) xs"
   shows "sum_list xs = 0 \<longleftrightarrow> list_all ((=) 0) xs"
   using assms
   by (auto intro: sum_list_nlex_eq_zeroI sum_list_eq0I simp: list_all_iff)
 
 lemma
   assumes "lex p q" "lex q r" "0 \<le> a" "0 \<le> b" "0 \<le> c" "a + b + c = 1"
   assumes comb_def: "comb = a *\<^sub>R p + b *\<^sub>R q + c *\<^sub>R r"
   shows lex_convex3: "lex p comb" "lex comb r"
 proof -
   from convex3_alt[OF assms(3-6), of p q r]
   obtain u v where
     uv: "a *\<^sub>R p + b *\<^sub>R q + c *\<^sub>R r = p + u *\<^sub>R (q - p) + v *\<^sub>R (r - p)" "0 \<le> u" "0 \<le> v" "u + v \<le> 1" .
   have "lex p r"
     using assms by (metis lex_trans)
   hence "lex (v *\<^sub>R (p - r)) 0" using uv
     by (simp add: lex_scale1_zero lex_diff1)
   also
   have "lex 0 (u *\<^sub>R (q - p))" using \<open>lex p q\<close> uv
     by (simp add: lex_scale2_zero lex_diff2)
   finally (lex_trans)
   show "lex p comb"
     unfolding comb_def uv
     by (simp add: lex_def prod_eq_iff algebra_simps)
   from comb_def have comb_def': "comb = c *\<^sub>R r + b *\<^sub>R q + a *\<^sub>R p" by simp
   from assms have "c + b + a = 1" by simp
   from convex3_alt[OF assms(5,4,3) this, of r q p]
   obtain u v where uv: "c *\<^sub>R r + b *\<^sub>R q + a *\<^sub>R p = r + u *\<^sub>R (q - r) + v *\<^sub>R (p - r)"
     "0 \<le> u" "0 \<le> v" "u + v \<le> 1"
     by auto
   have "lex (u *\<^sub>R (q - r)) 0"
     using uv \<open>lex q r\<close>
     by (simp add: lex_scale1_zero lex_diff1)
   also have "lex 0  (v *\<^sub>R (r - p))"
     using uv \<open>lex p r\<close>
     by (simp add: lex_scale2_zero lex_diff2)
   finally (lex_trans) show "lex comb r"
     unfolding comb_def' uv
     by (simp add: lex_def prod_eq_iff algebra_simps)
 qed
 
 lemma lex_convex_self2:
   assumes "lex p q" "0 \<le> a" "a \<le> 1"
   defines "r \<equiv> a *\<^sub>R p + (1 - a) *\<^sub>R q"
   shows "lex p r" (is ?th1)
     and "lex r q" (is ?th2)
   using lex_convex3[OF \<open>lex p q\<close>, of q a "1 - a" 0 r]
       assms
   by (simp_all add: r_def)
 
 lemma lex_uminus0[simp]: "lex (-a) 0 = lex 0 a"
   by (auto simp: lex_def)
 
 lemma
   lex_fst_zero_imp:
   "fst x = 0 \<Longrightarrow> lex x 0 \<Longrightarrow> lex y 0 \<Longrightarrow> \<not>coll 0 x y \<Longrightarrow> ccw' 0 y x"
   by (auto simp: ccw'_def det3_def' lex_def sign_simps)
 
 lemma lex_ccw_left: "lex x y \<Longrightarrow> r > 0 \<Longrightarrow> ccw y (y + (0, r)) x"
   by (auto simp: ccw_def ccw'_def det3_def' algebra_simps lex_def psi_def)
 
 lemma lex_translate_origin: "NO_MATCH 0 a \<Longrightarrow> lex a b = lex 0 (b - a)"
   by (auto simp: lex_def)
 
 
 subsection \<open>Order prover setup\<close>
 
 definition "lexs p q \<longleftrightarrow> (lex p q \<and> p \<noteq> q)"
 
 lemma lexs_irrefl: "\<not> lexs p p"
   and lexs_imp_lex: "lexs x y \<Longrightarrow> lex x y"
   and not_lexs: "(\<not> lexs x y) = (lex y x)"
   and not_lex: "(\<not> lex x y) = (lexs y x)"
   and eq_lex_refl: "x = y \<Longrightarrow> lex x y"
   by (auto simp: lexs_def lex_def prod_eq_iff)
 
 lemma lexs_trans: "lexs x y \<Longrightarrow> lexs y z \<Longrightarrow> lexs x z"
   and lexs_lex_trans: "lexs x y \<Longrightarrow> lex y z \<Longrightarrow> lexs x z"
   and lex_lexs_trans: "lex x y \<Longrightarrow> lexs y z \<Longrightarrow> lexs x z"
   and lex_neq_trans: "lex a b \<Longrightarrow> a \<noteq> b \<Longrightarrow> lexs a b"
   and neq_lex_trans: "a \<noteq> b \<Longrightarrow> lex a b \<Longrightarrow> lexs a b"
   and lexs_imp_neq: "lexs a b \<Longrightarrow> a \<noteq> b"
   by (auto simp: lexs_def lex_def prod_eq_iff)
 
 declare
   lexs_irrefl[THEN notE, order add less_reflE: linorder "(=) :: point => point => bool" lex lexs]
 declare lex_refl[order add le_refl: linorder "(=) :: point => point => bool" lex lexs]
 declare lexs_imp_lex[order add less_imp_le: linorder "(=) :: point => point => bool" lex lexs]
 declare
   not_lexs[THEN iffD2, order add not_lessI: linorder "(=) :: point => point => bool" lex lexs]
 declare not_lex[THEN iffD2, order add not_leI: linorder "(=) :: point => point => bool" lex lexs]
 declare
   not_lexs[THEN iffD1, order add not_lessD: linorder "(=) :: point => point => bool" lex lexs]
 declare not_lex[THEN iffD1, order add not_leD: linorder "(=) :: point => point => bool" lex lexs]
 declare lex_sym_eqI[order add eqI: linorder "(=) :: point => point => bool" lex lexs]
 declare eq_lex_refl[order add eqD1: linorder "(=) :: point => point => bool" lex lexs]
 declare sym[THEN eq_lex_refl, order add eqD2: linorder "(=) :: point => point => bool" lex lexs]
 declare lexs_trans[order add less_trans: linorder "(=) :: point => point => bool" lex lexs]
 declare lexs_lex_trans[order add less_le_trans: linorder "(=) :: point => point => bool" lex lexs]
 declare lex_lexs_trans[order add le_less_trans: linorder "(=) :: point => point => bool" lex lexs]
 declare lex_trans[order add le_trans: linorder "(=) :: point => point => bool" lex lexs]
 declare lex_neq_trans[order add le_neq_trans: linorder "(=) :: point => point => bool" lex lexs]
 declare neq_lex_trans[order add neq_le_trans: linorder "(=) :: point => point => bool" lex lexs]
 declare lexs_imp_neq[order add less_imp_neq: linorder "(=) :: point => point => bool" lex lexs]
 declare
   eq_neq_eq_imp_neq[order add eq_neq_eq_imp_neq: linorder "(=) :: point => point => bool" lex lexs]
 declare not_sym[order add not_sym: linorder "(=) :: point => point => bool" lex lexs]
 
 
 subsection \<open>Contradictions\<close>
 
 lemma
   assumes d: "distinct4 s p q r"
   shows contra1: "\<not>(lex p q \<and> lex q r \<and> lex r s \<and> indelta s p q r)" (is ?th1)
     and contra2: "\<not>(lex s p \<and> lex p q \<and> lex q r \<and> indelta s p q r)" (is ?th2)
     and contra3: "\<not>(lex p r \<and> lex p s \<and> lex q r \<and> lex q s \<and> insquare p r q s)" (is ?th3)
 proof -
   {
     assume "det3 s p q = 0" "det3 s q r = 0" "det3 s r p = 0" "det3 p q r = 0"
     hence ?th1 ?th2 ?th3 using d
       by (auto simp add: det3_def' ccw'_def ccw_def psi_def algebra_simps)
   } moreover {
     assume *: "\<not>(det3 s p q = 0 \<and> det3 s q r = 0 \<and> det3 s r p = 0 \<and> det3 p q r = 0)"
     {
       assume d0: "det3 p q r = 0"
       with d have "?th1 \<and> ?th2"
         by (force simp add: det3_def' ccw'_def ccw_def psi_def algebra_simps)
     } moreover {
       assume dp: "det3 p q r \<noteq> 0"
       have "?th1 \<and> ?th2"
         unfolding de_Morgan_disj[symmetric]
       proof (rule notI, goal_cases)
         case prems: 1
         hence **: "indelta s p q r" by auto
         hence nonnegs: "det3 p q r \<ge> 0" "0 \<le> det3 s q r" "0 \<le> det3 p s r" "0 \<le> det3 p q s"
           by (auto simp: ccw_def ccw'_def det3_def' algebra_simps)
         hence det_pos: "det3 p q r > 0" using dp by simp
         have det_eq: "det3 s q r + det3 p s r + det3 p q s = det3 p q r"
           by (auto simp: ccw_def det3_def' algebra_simps)
         hence det_div_eq:
           "det3 s q r / det3 p q r + det3 p s r / det3 p q r + det3 p q s / det3 p q r = 1"
           using det_pos by (auto simp: field_simps)
         from lex_convex3[OF _ _ _ _ _ det_div_eq convex_comb_dets[OF det_pos, of s]]
         have "lex p s" "lex s r"
           using prems by (auto simp: nonnegs)
         with prems d show False by (simp add: lex_sym_eq_iff)
       qed
     } moreover have ?th3
     proof (safe, goal_cases)
       case prems: 1
       have nonnegs: "det3 p r q \<ge> 0" "det3 r q s \<ge> 0" "det3 s p r \<ge> 0" "det3 q s p \<ge> 0"
         using prems
         by (auto simp add: ccw_def ccw'_def less_eq_real_def)
       have dets_eq: "det3 p r q + det3 q s p = det3 r q s + det3 s p r"
         by (auto simp: det3_def')
       hence **: "det3 p r q = 0 \<and> det3 q s p = 0 \<Longrightarrow> det3 r q s = 0 \<and> det3 s p r = 0"
         using prems
         by (auto simp: ccw_def ccw'_def)
       moreover
       {
         fix p r q s
         assume det_pos: "det3 p r q > 0"
         assume dets_eq: "det3 p r q + det3 q s p = det3 r q s + det3 s p r"
         assume nonnegs:"det3 r q s \<ge> 0" "det3 s p r \<ge> 0" "det3 q s p \<ge> 0"
         assume g14: "lex p r" "lex p s" "lex q r" "lex q s"
         assume d: "distinct4 s p q r"
 
         let ?sum = "(det3 p r q + det3 q s p) / det3 p r q"
         have eqs: "det3 s p r = det3 p r s" "det3 r q s = det3 s r q" "det3 q s p = - det3 p s q"
           by (auto simp: det3_def' algebra_simps)
         from convex_comb_dets[OF det_pos, of s]
         have "((det3 p r q / det3 p r q) *\<^sub>R s + (det3 q s p / det3 p r q) *\<^sub>R r) /\<^sub>R ?sum =
             ((det3 r q s / det3 p r q) *\<^sub>R p + (det3 s p r / det3 p r q) *\<^sub>R q) /\<^sub>R ?sum"
           unfolding eqs
           by (simp add: algebra_simps prod_eq_iff)
         hence srpq: "(det3 p r q / det3 p r q / ?sum) *\<^sub>R s + (det3 q s p / det3 p r q / ?sum) *\<^sub>R r =
           (det3 r q s / det3 p r q / ?sum) *\<^sub>R p + (det3 s p r / det3 p r q  / ?sum) *\<^sub>R q"
           (is "?s *\<^sub>R s + ?r *\<^sub>R r = ?p *\<^sub>R p + ?q *\<^sub>R q")
           using det_pos
           by (simp add: algebra_simps inverse_eq_divide)
         have eqs: "?s + ?r = 1" "?p + ?q = 1"
           and s: "?s \<ge> 0" "?s \<le> 1"
           and r: "?r \<ge> 0" "?r \<le> 1"
           and p: "?p \<ge> 0" "?p \<le> 1"
           and q: "?q \<ge> 0" "?q \<le> 1"
           unfolding add_divide_distrib[symmetric]
           using det_pos nonnegs dets_eq
           by (auto)
         from eqs have eqs': "1 - ?s = ?r" "1 - ?r = ?s" "1 - ?p = ?q" "1 - ?q = ?p"
           by auto
         have comm: "?r *\<^sub>R r + ?s *\<^sub>R s = ?s *\<^sub>R s + ?r *\<^sub>R r"
           "?q *\<^sub>R q + ?p *\<^sub>R p = ?p *\<^sub>R p + ?q *\<^sub>R q"
           by simp_all
         define K
           where "K = (det3 r q s / det3 p r q / ?sum) *\<^sub>R p + (det3 s p r / det3 p r q  / ?sum) *\<^sub>R q"
         note rewrs = eqs' comm srpq K_def[symmetric]
         from lex_convex_self2[OF _ s, of s r, unfolded rewrs]
            lex_convex_self2[OF _ r, of r s, unfolded rewrs]
            lex_convex_self2[OF _ p, of p q, unfolded rewrs]
            lex_convex_self2[OF _ q, of q p, unfolded rewrs]
         have False using g14 d det_pos
           by (metis lex_trans not_lex_eq)
       } note wlog = this
       from dets_eq have 1: "det3 q s p + det3 p r q = det3 s p r + det3 r q s"
         by simp
       from d have d': "distinct4 r q p s" by auto
       note wlog[of q s p r, OF _ 1 nonnegs(3,2,1) prems(4,3,2,1) d']
         wlog[of p r q s, OF _ dets_eq nonnegs(2,3,4) prems(1-4) d]
       ultimately show False using nonnegs d *
         by (auto simp: less_eq_real_def det3_def' algebra_simps)
     qed
     ultimately have ?th1 ?th2 ?th3 by blast+
   } ultimately show ?th1 ?th2 ?th3 by force+
 qed
 
 lemma ccw'_subst_psi_disj:
   assumes "det3 t r s = 0"
   assumes "psi t r s \<or> psi t s r \<or> psi s r t"
   assumes "s \<noteq> t"
   assumes "ccw' t r p"
   shows "ccw' t s p"
 proof cases
   assume "r \<noteq> s"
   from assms have "r \<noteq> t" by (auto simp: det3_def' ccw'_def algebra_simps)
   from assms have "det3 r s t = 0"
     by (auto simp: algebra_simps det3_def')
   from coll_ex_scaling[OF assms(3) this]
   obtain x where s: "r = s + x *\<^sub>R (t - s)" by auto
   from assms(4)[simplified s]
   have "0 < det3 0 (s + x *\<^sub>R (t - s) - t) (p - t)"
     by (auto simp: algebra_simps det3_def' ccw'_def)
   also have "s + x *\<^sub>R (t - s) - t = (1 - x) *\<^sub>R (s - t)"
     by (simp add: algebra_simps)
   finally have ccw': "ccw' 0 ((1 - x) *\<^sub>R (s - t)) (p - t)"
     by (simp add: ccw'_def)
   hence neq: "x \<noteq> 1" by (auto simp add: det3_def' ccw'_def)
   have tr: "fst s < fst r \<Longrightarrow> fst t = fst s \<Longrightarrow> snd t \<le> snd r"
     by (simp add: s)
   from s have "fst (r - s) = fst (x *\<^sub>R (t - s))" "snd (r - s) = snd (x *\<^sub>R (t - s))"
     by (auto simp: )
   hence "x = (if fst (t - s) = 0 then snd (r - s) / snd (t - s) else fst (r - s) / fst (t - s))"
     using \<open>s \<noteq> t\<close>
     by (auto simp add: field_simps prod_eq_iff)
   also have "\<dots> \<le> 1"
     using assms
     by (auto simp: lex_def psi_def tr)
   finally have "x < 1" using neq by simp
   thus ?thesis using ccw'
     by (auto simp: ccw'.translate_origin)
 qed (insert assms, simp)
 
 lemma lex_contr:
   assumes "distinct4 t s q r"
   assumes "lex t s" "lex s r"
   assumes "det3 t s r = 0"
   assumes "ccw' t s q"
   assumes "ccw' t q r"
   shows "False"
   using ccw'_subst_psi_disj[of t s r q] assms
   by (cases "r = t") (auto simp: det3_def' algebra_simps psi_def ccw'_def)
 
 lemma contra4:
   assumes "distinct4 s r q p"
   assumes lex: "lex q p" "lex p r" "lex r s"
   assumes ccw: "ccw r q s" "ccw r s p" "ccw r q p"
   shows False
 proof cases
   assume c: "ccw s q p"
   from c have *: "indelta s r q p"
     using assms by simp
   with contra1[OF assms(1)]
   have "\<not> (lex r q \<and> lex q p \<and> lex p s)" by blast
   hence "\<not> lex q p"
     using \<open>ccw s q p\<close> contra1 cyclic assms nondegenerate by blast
   thus False using assms by simp
 next
   assume "\<not> ccw s q p"
   with ccw have "ccw q s p \<and> ccw s p r \<and> ccw p r q \<and> ccw r q s"
     by (metis assms(1) ccw'.cyclic ccw_def not_ccw'_eq psi_disjuncts)
   moreover
   from lex have "lex q r" "lex q s" "lex p r" "lex p s" by order+
   ultimately show False using contra3[of r q p s] \<open>distinct4 s r q p\<close> by blast
 qed
 
 lemma not_coll_ordered_lexI:
   assumes "l \<noteq> x0"
     and "lex x1 r"
     and "lex x1 l"
     and "lex r x0"
     and "lex l x0"
     and "ccw' x0 l x1"
     and "ccw' x0 x1 r"
   shows "det3 x0 l r \<noteq> 0"
 proof
   assume "coll x0 l r"
   from \<open>coll x0 l r\<close> have 1: "coll 0 (l - x0) (r - x0)"
     by (simp add: det3_def' algebra_simps)
   from \<open>lex r x0\<close> have 2: "lex (r - x0) 0" by (auto simp add: lex_def)
   from \<open>lex l x0\<close> have 3: "lex (l - x0) 0" by (auto simp add: lex_def)
   from \<open>ccw' x0 l x1\<close> have 4: "ccw' 0 (l - x0) (x1 - x0)"
     by (simp add: det3_def' ccw'_def algebra_simps)
   from \<open>ccw' x0 x1 r\<close> have 5: "ccw' 0 (x1 - x0) (r - x0)"
     by (simp add: det3_def' ccw'_def algebra_simps)
   from \<open>lex x1 r\<close> have 6: "lex 0 (r - x0 - (x1 - x0))" by (auto simp: lex_def)
   from \<open>lex x1 l\<close> have 7: "lex 0 (l - x0 - (x1 - x0))" by (auto simp: lex_def)
   define r' where "r' = r - x0"
   define l' where "l' = l - x0"
   define x0' where "x0' = x1 - x0"
   from 1 2 3 4 5 6 7
   have rs: "coll 0 l' r'" "lex r' 0"
     "lex l' 0"
     "ccw' 0 l' x0'"
     "ccw' 0 x0' r'"
     "lex 0 (r' - x0')"
     "lex 0 (l' - x0')"
     unfolding r'_def[symmetric] l'_def[symmetric] x0'_def[symmetric]
     by auto
   from assms have "l' \<noteq> 0"
     by (auto simp: l'_def)
   from coll_scale[OF \<open>coll 0 l' _\<close> this]
   obtain y where y: "r' = y *\<^sub>R l'" by auto
   {
     assume "y > 0"
     with rs have False
       by (auto simp: det3_def' algebra_simps y ccw'_def)
   } moreover {
     assume "y < 0"
     with rs have False
-      by (auto simp: lex_def not_less sign_simps y ccw'_def)
+      by (auto simp: lex_def not_less algebra_simps sign_simps y ccw'_def)
   } moreover {
     assume "y = 0"
     from this rs have False
       by (simp add: ccw'_def y)
   } ultimately show False by arith
 qed
 
 interpretation ccw_system4 ccw
 proof unfold_locales
   fix p q r t
   assume ccw: "ccw t q r" "ccw p t r" "ccw p q t"
   show "ccw p q r"
   proof (cases "det3 t q r = 0 \<and> det3 p t r = 0 \<and> det3 p q t = 0")
     case True
     {
       assume "psi t q r \<or> psi q r t \<or> psi r t q"
         "psi p t r \<or> psi t r p \<or> psi r p t"
         "psi p q t \<or> psi q t p \<or> psi t p q"
       hence "psi p q r \<or> psi q r p \<or> psi r p q"
         using lex_sym_eq_iff psi_def by blast
     }
     with True ccw show ?thesis
       by (simp add: det3_def' algebra_simps ccw_def ccw'_def)
   next
     case False
     hence "0 \<le> det3 t q r" "0 \<le> det3 p t r" "0 \<le> det3 p q t"
       using ccw by (auto simp: less_eq_real_def ccw_def ccw'_def)
     with False show ?thesis
       by (auto simp: ccw_def det3_def' algebra_simps ccw'_def intro!: disjI1)
   qed
 qed
 
 lemma lex_total: "lex t q \<and> t \<noteq> q \<or> lex q t \<and> t \<noteq> q \<or> t = q"
   by auto
 
 lemma
   ccw_two_up_contra:
   assumes c: "ccw' t p q" "ccw' t q r"
   assumes ccws: "ccw t s p" "ccw t s q" "ccw t s r" "ccw t p q" "ccw t q r" "ccw t r p"
   assumes distinct: "distinct5 t s p q r"
   shows False
 proof -
   from ccws
   have nn: "det3 t s p \<ge> 0" "det3 t s q \<ge> 0" "det3 t s r \<ge> 0" "det3 t r p \<ge> 0"
     by (auto simp add: less_eq_real_def ccw_def ccw'_def)
   with c det_identity[of t p q s r]
   have tsr: "coll t s r" and tsp: "coll t s p"
     by (auto simp: add_nonneg_eq_0_iff ccw'_def)
   moreover
   have trp: "coll t r p"
     by (metis ccw'_subst_collinear distinct not_ccw'_eq tsr tsp)
   ultimately have tpr: "coll t p r"
     by (auto simp: det3_def' algebra_simps)
   moreover
   have psi: "psi t p r \<or> psi t r p \<or> psi r p t"
     unfolding psi_def
   proof -
     have ntsr: "\<not> ccw' t s r" "\<not> ccw' t r s"
       using tsr
       by (auto simp: not_ccw'_eq det3_def' algebra_simps)
     have f8: "\<not> ccw' t r s"
       using tsr not_ccw'_eq by blast
     have f9: "\<not> ccw' t r p"
       using tpr by (simp add: not_ccw'_eq)
     have f10: "(lex t r \<and> lex r p \<or> lex r p \<and> lex p t \<or> lex p t \<and> lex t r)"
       using ccw_def ccws(6) psi_def f9 by auto
 
     have "\<not> ccw' t r q"
       using c(2) not_ccw'_eq by blast
     moreover
     have "\<not>coll t q s"
       using ntsr ccw'_subst_collinear distinct c(2) by blast
     hence "ccw' t s q"
       by (meson ccw_def ccws(2) not_ccw'_eq)
     moreover
     from tsr tsp \<open>coll t r p\<close> have "coll t p s" "coll t p r" "coll t r s"
       by (auto simp add: det3_def' algebra_simps)
     ultimately
     show "lex t p \<and> lex p r \<or> lex t r \<and> lex r p \<or> lex r p \<and> lex p t"
       by (metis ccw'_subst_psi_disj distinct ccw_def ccws(3) contra4 tsp ntsr(1) f10 lex_total
         psi_def trp)
   qed
   moreover
   from distinct have "r \<noteq> t" by auto
   ultimately
   have "ccw' t r q" using c(1)
     by (rule ccw'_subst_psi_disj)
   thus False
     using c(2) by (simp add: ccw'_contra)
 qed
 
 lemma
   ccw_transitive_contr:
   fixes t s p q r
   assumes ccws: "ccw t s p" "ccw t s q" "ccw t s r" "ccw t p q" "ccw t q r" "ccw t r p"
   assumes distinct: "distinct5 t s p q r"
   shows False
 proof -
   from ccws distinct have *: "ccw p t r" "ccw p q t" by (metis cyclic)+
   with distinct have "ccw r p q" using interior[OF _ _ ccws(5) *, of UNIV]
     by (auto intro: cyclic)
 
   from ccws have nonnegs: "det3 t s p \<ge> 0" "det3 t s q \<ge> 0" "det3 t s r \<ge> 0" "det3 t p q \<ge> 0"
     "det3 t q r \<ge> 0" "det3 t r p \<ge> 0"
     by (auto simp add: less_eq_real_def ccw_def ccw'_def)
   {
     assume "ccw' t p q" "ccw' t q r" "ccw' t r p"
     hence False
       using ccw_two_up_contra ccws distinct by blast
   } moreover {
     assume c: "coll t q r" "coll t r p"
     with distinct four_points_aligned(1)[OF c, of s]
     have "coll t p q"
       by auto
     hence "(psi t p q \<or> psi p q t \<or> psi q t p)"
       "psi t q r \<or> psi q r t \<or> psi r t q"
       "psi t r p \<or> psi r p t \<or> psi p t r"
       using ccws(4,5,6) c
       by (simp_all add: ccw_def ccw'_def)
     hence False
       using distinct
       by (auto simp: psi_def ccw'_def)
   } moreover {
     assume c: "det3 t p q = 0" "det3 t q r > 0" "det3 t r p = 0"
     have "\<And>x. det3 t q r = 0 \<or> t = x \<or> r = q \<or> q = x \<or> r = p \<or> p = x \<or> r = x"
       by (meson c(1) c(3) distinct four_points_aligned(1))
     hence False
       by (metis (full_types) c(2) distinct less_irrefl)
   } moreover {
     assume c: "det3 t p q = 0" "det3 t q r = 0" "det3 t r p > 0"
     have "\<And>x. det3 t r p = 0 \<or> t = x \<or> r = x \<or> q = x \<or> p = x"
       by (meson c(1) c(2) distinct four_points_aligned(1))
     hence False
       by (metis (no_types) c(3) distinct less_numeral_extra(3))
   } moreover {
     assume c: "ccw' t p q" "ccw' t q r"
     from ccw_two_up_contra[OF this ccws distinct]
     have False .
   } moreover {
     assume c: "ccw' t p q" "ccw' t r p"
     from ccw_two_up_contra[OF this(2,1), of s] ccws distinct
     have False by auto
   } moreover {
     assume c: "ccw' t q r" "ccw' t r p"
     from ccw_two_up_contra[OF this, of s] ccws distinct
     have False by auto
   } ultimately show "False"
     using \<open>0 \<le> det3 t p q\<close>
     \<open>0 \<le> det3 t q r\<close>\<open>0 \<le> det3 t r p\<close>
     by (auto simp: less_eq_real_def ccw'_def)
 qed
 
 interpretation ccw: ccw_system ccw
   by unfold_locales (metis ccw_transitive_contr nondegenerate)
 
 lemma ccw_scaleR1:
   "det3 0 xr P \<noteq> 0 \<Longrightarrow> 0 < e \<Longrightarrow> ccw 0 xr P \<Longrightarrow> ccw 0 (e*\<^sub>Rxr) P"
   by (simp add: ccw_def)
 
 lemma ccw_scaleR2:
   "det3 0 xr P \<noteq> 0 \<Longrightarrow> 0 < e \<Longrightarrow> ccw 0 xr P \<Longrightarrow> ccw 0 xr (e*\<^sub>RP)"
   by (simp add: ccw_def)
 
 lemma ccw_translate3_aux:
   assumes "\<not>coll 0 a b"
   assumes "x < 1"
   assumes "ccw 0 (a - x*\<^sub>Ra) (b - x *\<^sub>R a)"
   shows "ccw 0 a b"
 proof -
   from assms have "\<not> coll 0 (a - x*\<^sub>Ra) (b - x *\<^sub>R a)"
     by simp
   with assms have "ccw' 0 ((1 - x) *\<^sub>R a) (b - x *\<^sub>R a)"
     by (simp add: algebra_simps ccw_def)
   thus "ccw 0 a b"
     using \<open>x < 1\<close>
     by (simp add: ccw_def)
 qed
 
 lemma ccw_translate3_minus: "det3 0 a b \<noteq> 0 \<Longrightarrow> x < 1 \<Longrightarrow> ccw 0 a (b - x *\<^sub>R a) \<Longrightarrow> ccw 0 a b"
   using ccw_translate3_aux[of a b x] ccw_scaleR1[of a "b - x *\<^sub>R a" "1-x" ]
   by (auto simp add: algebra_simps)
 
 lemma ccw_translate3: "det3 0 a b \<noteq> 0 \<Longrightarrow> x < 1 \<Longrightarrow> ccw 0 a b \<Longrightarrow> ccw 0 a (x *\<^sub>R a + b)"
   by (rule ccw_translate3_minus) (auto simp add: algebra_simps)
 
 lemma ccw_switch23: "det3 0 P Q \<noteq> 0 \<Longrightarrow> (\<not> ccw 0 Q P \<longleftrightarrow> ccw 0 P Q)"
   by (auto simp: ccw_def algebra_simps not_ccw'_eq ccw'_not_coll)
 
 lemma ccw0_upward: "fst a > 0 \<Longrightarrow> snd a = 0 \<Longrightarrow> snd b > snd a \<Longrightarrow> ccw 0 a b"
   by (auto simp: ccw_def det3_def' algebra_simps ccw'_def)
 
 lemma ccw_uminus3[simp]: "det3 a b c \<noteq> 0 \<Longrightarrow> ccw (-a) (-b) (-c) = ccw a b c"
   by (auto simp: ccw_def ccw'_def algebra_simps det3_def')
 
 lemma coll_minus_eq: "coll (x - a) (x - b) (x - c) = coll a b c"
   by (auto simp: det3_def' algebra_simps)
 
 lemma ccw_minus3: "\<not> coll a b c \<Longrightarrow> ccw (x - a) (x - b) (x - c) \<longleftrightarrow> ccw a b c"
   by (simp add: ccw_def coll_minus_eq)
 
 lemma ccw0_uminus[simp]: "\<not> coll 0 a b \<Longrightarrow> ccw 0 (-a) (-b) \<longleftrightarrow> ccw 0 a b"
   using ccw_uminus3[of 0 a b]
   by simp
 
 lemma lex_convex2:
   assumes "lex p q" "lex p r" "0 \<le> u" "u \<le> 1"
   shows "lex p (u *\<^sub>R q + (1 - u) *\<^sub>R r)"
 proof cases
   note \<open>lex p q\<close>
   also
   assume "lex q r"
   hence "lex q (u *\<^sub>R q + (1 - u) *\<^sub>R r)"
     using \<open>0 \<le> u\<close> \<open>u \<le> 1\<close>
     by (rule lex_convex_self2)
   finally (lex_trans) show ?thesis .
 next
   note \<open>lex p r\<close>
   also
   assume "\<not> lex q r"
   hence "lex r q"
     by simp
   hence "lex r ((1 - u) *\<^sub>R r + (1 - (1 - u)) *\<^sub>R q)"
     using \<open>0 \<le> u\<close> \<open>u \<le> 1\<close>
     by (intro lex_convex_self2) simp_all
   finally (lex_trans) show ?thesis by (simp add: ac_simps)
 qed
 
 lemma lex_convex2':
   assumes "lex q p" "lex r p" "0 \<le> u" "u \<le> 1"
   shows "lex (u *\<^sub>R q + (1 - u) *\<^sub>R r) p"
 proof -
   have "lex (- p) (u *\<^sub>R (-q) + (1 - u) *\<^sub>R (-r))"
     using assms
     by (intro lex_convex2) (auto simp: lex_def)
   thus ?thesis
     by (auto simp: lex_def algebra_simps)
 qed
 
 lemma psi_convex1:
   assumes "psi c a b"
   assumes "psi d a b"
   assumes "0 \<le> u" "0 \<le> v" "u + v = 1"
   shows "psi (u *\<^sub>R c + v *\<^sub>R d) a b"
 proof -
   from assms have v: "v = (1 - u)" by simp
   show ?thesis
     using assms
     by (auto simp: psi_def v intro!: lex_convex2' lex_convex2)
 qed
 
 lemma psi_convex2:
   assumes "psi a c b"
   assumes "psi a d b"
   assumes "0 \<le> u" "0 \<le> v" "u + v = 1"
   shows "psi a (u *\<^sub>R c + v *\<^sub>R d) b"
 proof -
   from assms have v: "v = (1 - u)" by simp
   show ?thesis
     using assms
     by (auto simp: psi_def v intro!: lex_convex2' lex_convex2)
 qed
 
 lemma psi_convex3:
   assumes "psi a b c"
   assumes "psi a b d"
   assumes "0 \<le> u" "0 \<le> v" "u + v = 1"
   shows "psi a b (u *\<^sub>R c + v *\<^sub>R d)"
 proof -
   from assms have v: "v = (1 - u)" by simp
   show ?thesis
     using assms
     by (auto simp: psi_def v intro!: lex_convex2)
 qed
 
 lemma coll_convex:
   assumes "coll a b c" "coll a b d"
   assumes "0 \<le> u" "0 \<le> v" "u + v = 1"
   shows "coll a b (u *\<^sub>R c + v *\<^sub>R d)"
 proof cases
   assume "a \<noteq> b"
   with assms(1, 2)
   obtain x y where xy: "c - a = x *\<^sub>R (b - a)" "d - a = y *\<^sub>R (b - a)"
     by (auto simp: det3_translate_origin dest!: coll_scale)
   from assms have "(u + v) *\<^sub>R a = a" by simp
   hence "u *\<^sub>R c + v *\<^sub>R d - a = u *\<^sub>R (c - a) + v *\<^sub>R (d - a)"
     by (simp add: algebra_simps)
   also have "\<dots> = u *\<^sub>R x *\<^sub>R (b - a) + v *\<^sub>R y *\<^sub>R (b - a)"
     by (simp add: xy)
   also have "\<dots> = (u * x + v * y) *\<^sub>R (b - a)" by (simp add: algebra_simps)
   also have "coll 0 (b - a) \<dots>"
     by (simp add: coll_scaleR_right_eq)
   finally show ?thesis
     by (auto simp: det3_translate_origin)
 qed simp
 
 lemma (in ccw_vector_space) convex3:
   assumes "u \<ge> 0" "v \<ge> 0" "u + v = 1" "ccw a b d" "ccw a b c"
   shows "ccw a b (u *\<^sub>R c + v *\<^sub>R d)"
 proof -
   have "v = 1 - u" using assms by simp
   hence "ccw 0 (b - a) (u *\<^sub>R (c - a) + v *\<^sub>R (d - a))"
     using assms
     by (cases "u = 0" "v = 0" rule: bool.exhaust[case_product bool.exhaust])
       (auto simp add: translate_origin intro!: add3)
   also
   have "(u + v) *\<^sub>R a = a" by (simp add: assms)
   hence "u *\<^sub>R (c - a) + v *\<^sub>R (d - a) = u *\<^sub>R c + v *\<^sub>R d - a"
     by (auto simp: algebra_simps)
   finally show ?thesis by (simp add: translate_origin)
 qed
 
 lemma ccw_self[simp]: "ccw a a b" "ccw b a a"
   by (auto simp: ccw_def psi_def intro: cyclic)
 
 lemma ccw_sefl'[simp]: "ccw a b a"
   by (rule cyclic) simp
 
 lemma ccw_convex':
   assumes uv: "u \<ge> 0" "v \<ge> 0" "u + v = 1"
   assumes "ccw a b c" and 1: "coll a b c"
   assumes "ccw a b d" and 2: "\<not> coll a b d"
   shows "ccw a b (u *\<^sub>R c + v *\<^sub>R d)"
 proof -
   from assms have u: "0 \<le> u" "u \<le> 1" and v: "v = 1 - u"
     by (auto simp: algebra_simps)
   let ?c = "u *\<^sub>R c + v *\<^sub>R d"
   from 1 have abd: "ccw' a b d"
     using assms by (auto simp: ccw_def)
   {
     assume 2: "\<not> coll a b c"
     from 2 have "ccw' a b c"
       using assms by (auto simp: ccw_def)
     with abd have "ccw' a b ?c"
       using assms by (auto intro!: ccw'.convex3)
     hence ?thesis
       by (simp add: ccw_def)
   } moreover {
     assume 2: "coll a b c"
     {
       assume "a = b"
       hence ?thesis by simp
     } moreover {
       assume "v = 0"
       hence ?thesis
         by (auto simp: v assms)
     } moreover {
       assume "v \<noteq> 0" "a \<noteq> b"
       have "coll c a b" using 2 by (auto simp: det3_def' algebra_simps)
       from coll_ex_scaling[OF \<open>a \<noteq> b\<close> this]
       obtain r where c: "c = a + r *\<^sub>R (b - a)" by auto
       have *: "u *\<^sub>R (a + r *\<^sub>R (b - a)) + v *\<^sub>R d - a = (u * r) *\<^sub>R (b - a)  + (1 - u) *\<^sub>R (d - a)"
         by (auto simp: algebra_simps v)
       have "ccw' a b ?c"
         using \<open>v \<noteq> 0\<close> uv abd
         by (simp add: ccw'.translate_origin c *)
       hence ?thesis by (simp add: ccw_def)
     } ultimately have ?thesis by blast
   } ultimately show ?thesis by blast
 qed
 
 lemma ccw_convex:
   assumes uv: "u \<ge> 0" "v \<ge> 0" "u + v = 1"
   assumes "ccw a b c"
   assumes "ccw a b d"
   assumes lex: "coll a b c \<Longrightarrow> coll a b d \<Longrightarrow> lex b a"
   shows "ccw a b (u *\<^sub>R c + v *\<^sub>R d)"
 proof -
   from assms have u: "0 \<le> u" "u \<le> 1" and v: "v = 1 - u"
     by (auto simp: algebra_simps)
   let ?c = "u *\<^sub>R c + v *\<^sub>R d"
   {
     assume coll: "coll a b c \<and> coll a b d"
     hence "coll a b ?c"
       by (auto intro!: coll_convex assms)
     moreover
     from coll have "psi a b c \<or> psi b c a \<or> psi c a b" "psi a b d \<or> psi b d a \<or> psi d a b"
       using assms by (auto simp add: ccw_def ccw'_not_coll)
     hence "psi a b ?c \<or> psi b ?c a \<or> psi ?c a b"
       using coll uv lex
       by (auto simp: psi_def ccw_def not_lex lexs_def v intro: lex_convex2 lex_convex2')
     ultimately have ?thesis
       by (simp add: ccw_def)
   } moreover {
     assume 1: "\<not> coll a b d" and 2: "\<not> coll a b c"
     from 1 have abd: "ccw' a b d"
       using assms by (auto simp: ccw_def)
     from 2 have "ccw' a b c"
       using assms by (auto simp: ccw_def)
     with abd have "ccw' a b ?c"
       using assms by (auto intro!: ccw'.convex3)
     hence ?thesis
       by (simp add: ccw_def)
   } moreover {
     assume "\<not> coll a b d" "coll a b c"
     have ?thesis
       by (rule ccw_convex') fact+
   } moreover {
     assume 1: "coll a b d" and 2: "\<not> coll a b c"
     have "0 \<le> 1 - u" using assms by (auto )
     from ccw_convex'[OF this \<open>0 \<le> u\<close> _ \<open>ccw a b d\<close> 1 \<open>ccw a b c\<close> 2]
     have ?thesis by (simp add: algebra_simps v)
   } ultimately show ?thesis by blast
 qed
 
 interpretation ccw: ccw_convex ccw S "\<lambda>a b. lex b a" for S
   by unfold_locales (rule ccw_convex)
 
 lemma ccw_sorted_scaleR: "ccw.sortedP 0 xs \<Longrightarrow> r > 0 \<Longrightarrow> ccw.sortedP 0 (map ((*\<^sub>R) r) xs)"
   by (induct xs)
     (auto intro!: ccw.sortedP.Cons ccw_scale23 elim!: ccw.sortedP_Cons simp del: scaleR_Pair)
 
 lemma ccw_sorted_implies_ccw'_sortedP:
   assumes nonaligned: "\<And>y z. y \<in> set Ps \<Longrightarrow> z \<in> set Ps \<Longrightarrow> y \<noteq> z \<Longrightarrow> \<not> coll 0 y z"
   assumes sorted: "linorder_list0.sortedP (ccw 0) Ps"
   assumes "distinct Ps"
   shows "linorder_list0.sortedP (ccw' 0 ) Ps"
   using assms
 proof (induction Ps)
   case (Cons P Ps)
   {
     fix p assume p: "p \<in> set Ps"
     moreover
     from p Cons.prems have "ccw 0 P p"
       by (auto elim!: linorder_list0.sortedP_Cons intro: Cons)
     ultimately
     have "ccw' 0 P p"
       using \<open>distinct (P#Ps)\<close>
       by (intro ccw_ncoll_imp_ccw Cons) auto
   }
   moreover
   have "linorder_list0.sortedP (ccw' 0) Ps"
     using Cons.prems
     by (intro Cons) (auto elim!: linorder_list0.sortedP_Cons intro: Cons)
   ultimately
   show ?case
     by (auto intro!: linorder_list0.Cons )
 qed (auto intro: linorder_list0.Nil)
 
 end
diff --git a/thys/Affine_Arithmetic/Executable_Euclidean_Space.thy b/thys/Affine_Arithmetic/Executable_Euclidean_Space.thy
--- a/thys/Affine_Arithmetic/Executable_Euclidean_Space.thy
+++ b/thys/Affine_Arithmetic/Executable_Euclidean_Space.thy
@@ -1,1077 +1,1077 @@
 section \<open>Euclidean Space: Executability\<close>
 theory Executable_Euclidean_Space
 imports
   "HOL-Analysis.Analysis"
   "List-Index.List_Index"
   "HOL-Library.Float"
   Affine_Arithmetic_Auxiliarities
 begin
 
 subsection \<open>Ordered representation of Basis and Rounding of Components\<close>
 
 class executable_euclidean_space = ordered_euclidean_space +
   fixes Basis_list eucl_down eucl_truncate_down eucl_truncate_up
   assumes eucl_down_def:
     "eucl_down p b = (\<Sum>i \<in> Basis. round_down p (b \<bullet> i) *\<^sub>R i)"
   assumes eucl_truncate_down_def:
     "eucl_truncate_down q b = (\<Sum>i \<in> Basis. truncate_down q (b \<bullet> i) *\<^sub>R i)"
   assumes eucl_truncate_up_def:
     "eucl_truncate_up q b = (\<Sum>i \<in> Basis. truncate_up q (b \<bullet> i) *\<^sub>R i)"
   assumes Basis_list[simp]: "set Basis_list = Basis"
   assumes distinct_Basis_list[simp]: "distinct Basis_list"
 begin
 
 lemma length_Basis_list:
   "length Basis_list = card Basis"
   by (metis Basis_list distinct_Basis_list distinct_card)
 
 end
 
 lemma eucl_truncate_down_zero[simp]: "eucl_truncate_down p 0 = 0"
   by (auto simp: eucl_truncate_down_def truncate_down_zero)
 
 lemma eucl_truncate_up_zero[simp]: "eucl_truncate_up p 0 = 0"
   by (auto simp: eucl_truncate_up_def)
 
 subsection \<open>Instantiations\<close>
 
 instantiation real::executable_euclidean_space
 begin
 
 definition Basis_list_real :: "real list" where
   "Basis_list_real = [1]"
 
 definition "eucl_down prec b = round_down prec b"
 definition "eucl_truncate_down prec b = truncate_down prec b"
 definition "eucl_truncate_up prec b = truncate_up prec b"
 
 instance proof qed (auto simp: Basis_list_real_def eucl_down_real_def eucl_truncate_down_real_def
   eucl_truncate_up_real_def)
 
 end
 
 instantiation prod::(executable_euclidean_space, executable_euclidean_space)
   executable_euclidean_space
 begin
 
 definition Basis_list_prod :: "('a \<times> 'b) list" where
   "Basis_list_prod =
     zip Basis_list (replicate (length (Basis_list::'a list)) 0) @
     zip (replicate (length (Basis_list::'b list)) 0) Basis_list"
 
 definition "eucl_down p a = (eucl_down p (fst a), eucl_down p (snd a))"
 definition "eucl_truncate_down p a = (eucl_truncate_down p (fst a), eucl_truncate_down p (snd a))"
 definition "eucl_truncate_up p a = (eucl_truncate_up p (fst a), eucl_truncate_up p (snd a))"
 
 instance
 proof
   show "set Basis_list = (Basis::('a*'b) set)"
     by (auto simp: Basis_list_prod_def Basis_prod_def elim!: in_set_zipE)
       (auto simp: Basis_list[symmetric] in_set_zip in_set_conv_nth simp del: Basis_list)
   show "distinct (Basis_list::('a*'b)list)"
     using distinct_Basis_list[where 'a='a] distinct_Basis_list[where 'a='b]
     by (auto simp: Basis_list_prod_def Basis_list intro: distinct_zipI1 distinct_zipI2
       elim!: in_set_zipE)
 qed
   (auto simp: eucl_down_prod_def eucl_truncate_down_prod_def eucl_truncate_up_prod_def
     sum_Basis_prod_eq inner_add_left inner_sum_left inner_Basis eucl_down_def
     eucl_truncate_down_def eucl_truncate_up_def
     intro!: euclidean_eqI[where 'a="'a*'b"])
 
 end
 
 lemma eucl_truncate_down_Basis[simp]:
   "i \<in> Basis \<Longrightarrow> eucl_truncate_down e x \<bullet> i = truncate_down e (x \<bullet> i)"
   by (simp add: eucl_truncate_down_def)
 
 lemma eucl_truncate_down_correct:
   "dist (x::'a::executable_euclidean_space) (eucl_down e x) \<in>
     {0..sqrt (DIM('a)) * 2 powr of_int (- e)}"
 proof -
   have "dist x (eucl_down e x) = sqrt (\<Sum>i\<in>Basis. (dist (x \<bullet> i) (eucl_down e x \<bullet> i))\<^sup>2)"
     unfolding euclidean_dist_l2[where 'a='a] L2_set_def ..
   also have "\<dots> \<le> sqrt (\<Sum>i\<in>(Basis::'a set). ((2 powr of_int (- e))\<^sup>2))"
     by (intro real_sqrt_le_mono sum_mono power_mono)
       (auto simp: dist_real_def eucl_down_def abs_round_down_le)
   finally show ?thesis
     by (simp add: real_sqrt_mult)
 qed
 
 lemma eucl_down: "eucl_down e (x::'a::executable_euclidean_space) \<le> x"
   by (auto simp add: eucl_le[where 'a='a] round_down eucl_down_def)
 
 lemma eucl_truncate_down: "eucl_truncate_down e (x::'a::executable_euclidean_space) \<le> x"
   by (auto simp add: eucl_le[where 'a='a] truncate_down)
 
 lemma eucl_truncate_down_le:
   "x \<le> y \<Longrightarrow> eucl_truncate_down w x \<le> (y::'a::executable_euclidean_space)"
   using eucl_truncate_down
   by (rule order.trans)
 
 lemma eucl_truncate_up_Basis[simp]: "i \<in> Basis \<Longrightarrow> eucl_truncate_up e x \<bullet> i = truncate_up e (x \<bullet> i)"
   by (simp add: eucl_truncate_up_def truncate_up_def)
 
 lemma eucl_truncate_up: "x \<le> eucl_truncate_up e (x::'a::executable_euclidean_space)"
   by (auto simp add: eucl_le[where 'a='a] round_up truncate_up_def)
 
 lemma eucl_truncate_up_le: "x \<le> y \<Longrightarrow> x \<le> eucl_truncate_up e (y::'a::executable_euclidean_space)"
   using _ eucl_truncate_up
   by (rule order.trans)
 
 lemma eucl_truncate_down_mono:
   fixes x::"'a::executable_euclidean_space"
   shows "x \<le> y \<Longrightarrow> eucl_truncate_down p x \<le> eucl_truncate_down p y"
   by (auto simp: eucl_le[where 'a='a] intro!: truncate_down_mono)
 
 lemma eucl_truncate_up_mono:
   fixes x::"'a::executable_euclidean_space"
   shows "x \<le> y \<Longrightarrow> eucl_truncate_up p x \<le> eucl_truncate_up p y"
   by (auto simp: eucl_le[where 'a='a] intro!: truncate_up_mono)
 
 lemma infnorm[code]:
   fixes x::"'a::executable_euclidean_space"
   shows "infnorm x = fold max (map (\<lambda>i. abs (x \<bullet> i)) Basis_list) 0"
   by (auto simp: Max.set_eq_fold[symmetric] infnorm_Max[symmetric] infnorm_pos_le
     intro!: max.absorb2[symmetric])
 
 declare Inf_real_def[code del]
 declare Sup_real_def[code del]
 declare Inf_prod_def[code del]
 declare Sup_prod_def[code del]
 declare [[code abort: "Inf::real set \<Rightarrow> real"]]
 declare [[code abort: "Sup::real set \<Rightarrow> real"]]
 declare [[code abort: "Inf::('a::Inf * 'b::Inf) set \<Rightarrow> 'a * 'b"]]
 declare [[code abort: "Sup::('a::Sup * 'b::Sup) set \<Rightarrow> 'a * 'b"]]
 
 lemma nth_Basis_list_in_Basis[simp]:
   "n < length (Basis_list::'a::executable_euclidean_space list) \<Longrightarrow> Basis_list ! n \<in> (Basis::'a set)"
   by (metis Basis_list nth_mem)
 
 subsection \<open>Representation as list\<close>
 
 lemma nth_eq_iff_index:
   "distinct xs \<Longrightarrow> n < length xs \<Longrightarrow> xs ! n = i \<longleftrightarrow> n = index xs i"
   using index_nth_id by fastforce
 
 lemma in_Basis_index_Basis_list: "i \<in> Basis \<Longrightarrow> i = Basis_list ! index Basis_list i"
   by simp
 
 lemmas [simp] = length_Basis_list
 
 lemma sum_Basis_sum_nth_Basis_list:
   "(\<Sum>i\<in>Basis. f i) = (\<Sum>i<DIM('a::executable_euclidean_space). f ((Basis_list::'a list) ! i))"
   apply (rule sum.reindex_cong[OF _ _ refl])
    apply (auto intro!: inj_on_nth)
   by (metis Basis_list image_iff in_Basis_index_Basis_list index_less_size_conv length_Basis_list lessThan_iff)
 
 definition "eucl_of_list xs = (\<Sum>(x, i)\<leftarrow>zip xs Basis_list. x *\<^sub>R i)"
 
 lemma eucl_of_list_nth:
   assumes "length xs = DIM('a)"
   shows "eucl_of_list xs = (\<Sum>i<DIM('a::executable_euclidean_space). (xs ! i) *\<^sub>R ((Basis_list::'a list) ! i))"
   by (auto simp: eucl_of_list_def sum_list_sum_nth length_Basis_list assms atLeast0LessThan)
 
 lemma eucl_of_list_inner:
   fixes i::"'a::executable_euclidean_space"
   assumes i: "i \<in> Basis"
   assumes l: "length xs = DIM('a)"
   shows "eucl_of_list xs \<bullet> i = xs ! (index Basis_list i)"
   by (simp add: eucl_of_list_nth[OF l] inner_sum_left assms inner_Basis
       nth_eq_iff_index sum.delta if_distrib cong: if_cong)
 
 lemma inner_eucl_of_list:
   fixes i::"'a::executable_euclidean_space"
   assumes i: "i \<in> Basis"
   assumes l: "length xs = DIM('a)"
   shows "i \<bullet> eucl_of_list xs = xs ! (index Basis_list i)"
   using eucl_of_list_inner[OF assms] by (auto simp: inner_commute)
 
 
 definition "list_of_eucl x = map ((\<bullet>) x) Basis_list"
 
 lemma index_Basis_list_nth[simp]:
   "i < DIM('a::executable_euclidean_space) \<Longrightarrow> index Basis_list ((Basis_list::'a list) ! i) = i"
   by (simp add: index_nth_id)
 
 lemma list_of_eucl_eucl_of_list[simp]:
   "length xs = DIM('a::executable_euclidean_space) \<Longrightarrow> list_of_eucl (eucl_of_list xs::'a) = xs"
   by (auto simp: list_of_eucl_def eucl_of_list_inner intro!: nth_equalityI)
 
 lemma eucl_of_list_list_of_eucl[simp]:
   "eucl_of_list (list_of_eucl x) = x"
   by (auto simp: list_of_eucl_def eucl_of_list_inner intro!: euclidean_eqI[where 'a='a])
 
 
 lemma length_list_of_eucl[simp]: "length (list_of_eucl (x::'a::executable_euclidean_space)) = DIM('a)"
   by (auto simp: list_of_eucl_def)
 
 lemma list_of_eucl_nth[simp]: "n < DIM('a::executable_euclidean_space) \<Longrightarrow> list_of_eucl x ! n = x \<bullet> (Basis_list ! n::'a)"
   by (auto simp: list_of_eucl_def)
 
 lemma nth_ge_len: "n \<ge> length xs \<Longrightarrow> xs ! n = [] ! (n - length xs)"
   by (induction xs arbitrary: n) auto
 
 lemma list_of_eucl_nth_if: "list_of_eucl x ! n = (if n < DIM('a::executable_euclidean_space) then x \<bullet> (Basis_list ! n::'a) else [] ! (n - DIM('a)))"
   apply (auto simp: list_of_eucl_def )
   apply (subst nth_ge_len)
    apply auto
   done
 
 lemma list_of_eucl_eq_iff:
   "list_of_eucl (x::'a::executable_euclidean_space) = list_of_eucl (y::'b::executable_euclidean_space) \<longleftrightarrow>
   (DIM('a) = DIM('b) \<and> (\<forall>i < DIM('b). x \<bullet> Basis_list ! i = y \<bullet> Basis_list ! i))"
   by (auto simp: list_eq_iff_nth_eq)
 
 lemma eucl_le_Basis_list_iff:
   "(x::'a::executable_euclidean_space) \<le> y \<longleftrightarrow>
   (\<forall>i<DIM('a). x \<bullet> Basis_list ! i \<le> y \<bullet> Basis_list ! i)"
   apply (auto simp:  eucl_le[where 'a='a])
   subgoal for i
     subgoal by (auto dest!: spec[where x="index Basis_list i"])
     done
   done
 
 lemma eucl_of_list_inj: "length xs = DIM('a::executable_euclidean_space) \<Longrightarrow> length ys = DIM('a) \<Longrightarrow>
   (eucl_of_list xs::'a) = eucl_of_list (ys) \<Longrightarrow> xs = ys"
   apply (auto intro!: nth_equalityI simp: euclidean_eq_iff[where 'a="'a"] eucl_of_list_inner)
   using nth_Basis_list_in_Basis[where 'a="'a"]
   by fastforce
 
 lemma eucl_of_list_map_plus[simp]:
   assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
   shows "(eucl_of_list (map (\<lambda>x. f x + g x) xs)::'a) =
     eucl_of_list (map f xs) + eucl_of_list (map g xs)"
   by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)
 
 lemma eucl_of_list_map_uminus[simp]:
   assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
   shows "(eucl_of_list (map (\<lambda>x. - f x) xs)::'a) = - eucl_of_list (map f xs)"
   by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)
 
 lemma eucl_of_list_map_mult_left[simp]:
   assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
   shows "(eucl_of_list (map (\<lambda>x. r * f x) xs)::'a) = r *\<^sub>R eucl_of_list (map f xs)"
   by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)
 
 lemma eucl_of_list_map_mult_right[simp]:
   assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
   shows "(eucl_of_list (map (\<lambda>x. f x * r) xs)::'a) = r *\<^sub>R eucl_of_list (map f xs)"
   by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)
 
 lemma eucl_of_list_map_divide_right[simp]:
   assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
   shows "(eucl_of_list (map (\<lambda>x. f x / r) xs)::'a) = eucl_of_list (map f xs) /\<^sub>R r"
   by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner divide_simps)
 
 lemma eucl_of_list_map_const[simp]:
   assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
   shows "(eucl_of_list (map (\<lambda>x. c) xs)::'a) = c *\<^sub>R One"
   by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)
 
 lemma replicate_eq_list_of_eucl_zero: "replicate DIM('a::executable_euclidean_space) 0 = list_of_eucl (0::'a)"
   by (auto intro!: nth_equalityI)
 
 lemma eucl_of_list_append_zeroes[simp]: "eucl_of_list (xs @ replicate n 0) = eucl_of_list xs"
   unfolding eucl_of_list_def
   apply (auto simp: sum_list_sum_nth)
   apply (rule sum.mono_neutral_cong_right)
   by (auto simp: nth_append)
 
 lemma Basis_prodD:
   assumes "(i, j) \<in> Basis"
   shows "i \<in> Basis \<and> j = 0 \<or> i = 0 \<and> j \<in> Basis"
   using assms
   by (auto simp: Basis_prod_def)
 
 lemma eucl_of_list_take_DIM[simp]:
   assumes "d = DIM('b::executable_euclidean_space)"
   shows "(eucl_of_list (take d xs)::'b) = (eucl_of_list xs)"
   by (auto simp: eucl_of_list_inner eucl_of_list_def fst_sum_list sum_list_sum_nth assms dest!: Basis_prodD)
 
 lemma eucl_of_list_eqI:
   assumes "take DIM('a) (xs @ replicate (DIM('a) - length xs) 0) =
     take DIM('a) (ys @ replicate (DIM('a) - length ys) 0)"
   shows "eucl_of_list xs = (eucl_of_list ys::'a::executable_euclidean_space)"
 proof -
   have "(eucl_of_list xs::'a) = eucl_of_list (take DIM('a) (xs @ replicate (DIM('a) - length xs) 0))"
     by (simp add: )
   also note assms
   also have "eucl_of_list (take DIM('a) (ys @ replicate (DIM('a) - length ys) 0)) = (eucl_of_list ys::'a)"
     by simp
   finally show ?thesis .
 qed
 
 lemma eucl_of_list_replicate_zero[simp]: "eucl_of_list (replicate E 0) = 0"
 proof -
   have "eucl_of_list (replicate E 0) = (eucl_of_list (replicate E 0 @ replicate (DIM('a) - E) 0)::'a)"
     by simp
   also have "\<dots> = eucl_of_list (replicate DIM('a) 0)"
     apply (rule eucl_of_list_eqI)
     by (auto simp: min_def nth_append intro!: nth_equalityI)
   also have "\<dots> = 0"
     by (simp add: replicate_eq_list_of_eucl_zero)
   finally show ?thesis by simp
 qed
 
 lemma eucl_of_list_Nil[simp]: "eucl_of_list [] = 0"
   using eucl_of_list_replicate_zero[of 0] by simp
 
 
 lemma fst_eucl_of_list_prod:
   shows "fst (eucl_of_list xs::'b::executable_euclidean_space  \<times> _) = (eucl_of_list (take DIM('b) xs)::'b)"
   apply (auto simp: eucl_of_list_inner eucl_of_list_def fst_sum_list dest!: Basis_prodD)
   apply (simp add: sum_list_sum_nth)
   apply (rule sum.mono_neutral_cong_right)
   subgoal by simp
   subgoal by auto
   subgoal by (auto simp: Basis_list_prod_def nth_append)
   subgoal by (auto simp: Basis_list_prod_def nth_append)
   done
 
 lemma index_zip_replicate1[simp]: "index (zip (replicate d a) bs) (a, b) = index bs b"
   if "d = length bs"
   using that
   by (induction bs arbitrary: d) auto
 
 lemma index_zip_replicate2[simp]: "index (zip as (replicate d b)) (a, b) = index as a"
   if "d = length as"
   using that
   by (induction as arbitrary: d) auto
 
 lemma index_Basis_list_prod[simp]:
   fixes a::"'a::executable_euclidean_space" and b::"'b::executable_euclidean_space"
   shows "a \<in> Basis \<Longrightarrow> index Basis_list (a, 0::'b) = index Basis_list a"
     "b \<in> Basis \<Longrightarrow> index Basis_list (0::'a, b) = DIM('a) + index Basis_list b"
   by (auto simp: Basis_list_prod_def index_append
       in_set_zip zip_replicate index_map_inj dest: spec[where x="index Basis_list a"])
 
 lemma eucl_of_list_eq_takeI:
   assumes "(eucl_of_list (take DIM('a::executable_euclidean_space) xs)::'a) = x"
   shows "eucl_of_list xs = x"
   using eucl_of_list_take_DIM[OF refl, of xs, where 'b='a] assms
   by auto
 
 lemma eucl_of_list_inner_le:
   fixes i::"'a::executable_euclidean_space"
   assumes i: "i \<in> Basis"
   assumes l: "length xs \<ge> DIM('a)"
   shows "eucl_of_list xs \<bullet> i = xs ! (index Basis_list i)"
 proof -
   have "(eucl_of_list xs::'a) = eucl_of_list (take DIM('a) (xs @ (replicate (DIM('a) - length xs) 0)))"
     by (rule eucl_of_list_eq_takeI) simp
   also have "\<dots> \<bullet> i = xs ! (index Basis_list i)"
     using assms
     by (subst eucl_of_list_inner) auto
   finally show ?thesis .
 qed
 
 lemma eucl_of_list_prod_if:
   assumes "length xs = DIM('a::executable_euclidean_space) + DIM('b::executable_euclidean_space)"
   shows "eucl_of_list xs =
     (eucl_of_list (take DIM('a) xs)::'a, eucl_of_list (drop DIM('a) xs)::'b)"
   apply (rule euclidean_eqI)
   using assms
   apply (auto simp: eucl_of_list_inner dest!: Basis_prodD)
    apply (subst eucl_of_list_inner_le)
   apply (auto simp: Basis_list_prod_def index_append in_set_zip)
   done
 
 
 lemma snd_eucl_of_list_prod:
   shows "snd (eucl_of_list xs::'b::executable_euclidean_space  \<times> 'c::executable_euclidean_space) =
     (eucl_of_list (drop DIM('b) xs)::'c)"
 proof (cases "length xs \<le> DIM('b)")
   case True
   then show ?thesis
     by (auto simp: eucl_of_list_inner eucl_of_list_def snd_sum_list dest!: Basis_prodD)
       (simp add: sum_list_sum_nth Basis_list_prod_def nth_append)
 next
   case False
   have "xs = take DIM('b) xs @ drop DIM('b) xs" by simp
   also have "eucl_of_list \<dots> = (eucl_of_list (\<dots> @ replicate (length xs - DIM('c)) 0)::'b \<times> 'c)"
     by simp
   finally have "eucl_of_list xs = (eucl_of_list (xs @ replicate (DIM('b) + DIM('c) - length xs) 0)::'b \<times> 'c)"
     by simp
   also have "\<dots> = eucl_of_list (take (DIM ('b \<times> 'c)) (xs @ replicate (DIM('b) + DIM('c) - length xs) 0))"
     by (simp add: )
   finally have *: "(eucl_of_list xs::'b\<times>'c) = eucl_of_list (take DIM('b \<times> 'c) (xs @ replicate (DIM('b) + DIM('c) - length xs) 0))"
     by simp
   show ?thesis
     apply (subst *)
     apply (subst eucl_of_list_prod_if)
     subgoal by simp
     subgoal
       apply simp
       apply (subst (2) eucl_of_list_take_DIM[OF refl, symmetric])
       apply (subst (2) eucl_of_list_take_DIM[OF refl, symmetric])
       apply (rule arg_cong[where f=eucl_of_list])
       by (auto intro!: nth_equalityI simp: nth_append min_def split: if_splits)
     done
 qed
 
 lemma eucl_of_list_prod:
   shows "eucl_of_list xs = (eucl_of_list (take DIM('b) xs)::'b::executable_euclidean_space,
     eucl_of_list (drop DIM('b) xs)::'c::executable_euclidean_space)"
   using snd_eucl_of_list_prod[of xs, where 'b='b and 'c='c]
   using fst_eucl_of_list_prod[of xs, where 'b='b and 'a='c]
   by (auto simp del: snd_eucl_of_list_prod fst_eucl_of_list_prod simp add: prod_eq_iff)
 
 lemma eucl_of_list_real[simp]: "eucl_of_list [x] = (x::real)"
   by (auto simp: eucl_of_list_def Basis_list_real_def)
 
 lemma eucl_of_list_append[simp]:
   assumes "length xs = DIM('i::executable_euclidean_space)"
   assumes "length ys = DIM('j::executable_euclidean_space)"
   shows "eucl_of_list (xs @ ys) = (eucl_of_list xs::'i, eucl_of_list ys::'j)"
   using assms
   by (auto simp: eucl_of_list_prod)
 
 lemma list_allI: "(\<And>x. x \<in> set xs \<Longrightarrow> P x) \<Longrightarrow> list_all P xs"
   by (auto simp: list_all_iff)
 
 lemma
   concat_map_nthI:
   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set (f x) \<Longrightarrow> P y"
   assumes "j < length (concat (map f xs))"
   shows "P (concat (map f xs) ! j)"
 proof -
   have "list_all P (concat (map f xs))"
     by (rule list_allI) (auto simp: assms)
   then show ?thesis
     by (auto simp: list_all_length assms)
 qed
 
 lemma map_nth_append1:
   assumes "length xs = d"
   shows "map ((!) (xs @ ys)) [0..<d] = xs"
   using assms
   by (auto simp: nth_append intro!: nth_equalityI)
 
 lemma map_nth_append2:
   assumes "length ys = d"
   shows "map ((!) (xs @ ys)) [length xs..<length xs + d] = ys"
   using assms
   by (auto simp: intro!: nth_equalityI)
 
 lemma length_map2 [simp]: "length (map2 f xs ys) = min (length xs) (length ys)"
   by simp
 
 lemma map2_nth [simp]: "map2 f xs ys ! n = f (xs ! n) (ys ! n)"
   if "n < length xs" "n < length ys"
   using that by simp
 
 lemma list_of_eucl_add: "list_of_eucl (x + y) = map2 (+) (list_of_eucl x) (list_of_eucl y)"
   by (auto intro!: nth_equalityI simp: inner_simps)
 
 lemma list_of_eucl_inj:
   "list_of_eucl z = list_of_eucl y \<Longrightarrow> y = z"
   by (metis eucl_of_list_list_of_eucl)
 
 lemma length_Basis_list_pos[simp]: "length Basis_list > 0"
   by (metis length_pos_if_in_set Basis_list SOME_Basis)
 
 lemma Basis_list_nth_nonzero:
   "i < length (Basis_list::'a::executable_euclidean_space list) \<Longrightarrow> (Basis_list::'a list) ! i \<noteq> 0"
   by (auto dest!: nth_mem simp: nonzero_Basis)
 
 lemma nth_Basis_list_prod:
   "i < DIM('a) + DIM('b) \<Longrightarrow> (Basis_list::('a::executable_euclidean_space \<times> 'b::executable_euclidean_space) list) ! i =
     (if i < DIM('a) then (Basis_list ! i, 0) else (0, Basis_list ! (i - DIM('a))))"
   by (auto simp: Basis_list_nth_nonzero prod_eq_iff Basis_list_prod_def nth_append not_less)
 
 lemma eucl_of_list_if:
   assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" "distinct xs"
   shows "eucl_of_list (map (\<lambda>xa. if xa = x then 1 else 0) (xs::nat list)) =
     (if x \<in> set xs then Basis_list ! index xs x else 0::'a)"
   by (rule euclidean_eqI) (auto simp: eucl_of_list_inner inner_Basis index_nth_id)
 
 
 lemma take_append_take_minus_idem: "take n XS @ map ((!) XS) [n..<length XS] = XS"
   by (auto intro!: nth_equalityI simp: nth_append min_def)
 
 lemma sum_list_Basis_list[simp]: "sum_list (map f Basis_list) = (\<Sum>b\<in>Basis. f b)"
   by (subst sum_list_distinct_conv_sum_set) (auto simp: Basis_list distinct_Basis_list)
 
 lemma hd_Basis_list[simp]: "hd Basis_list \<in> Basis"
   unfolding Basis_list[symmetric]
   by (rule hd_in_set) (auto simp: set_empty[symmetric])
 
 definition "inner_lv_rel a b = sum_list (map2 (*) a b)"
 
 lemma eucl_of_list_inner_eq: "(eucl_of_list xs::'a) \<bullet> eucl_of_list ys = inner_lv_rel xs ys"
   if "length xs = DIM('a::executable_euclidean_space)" "length ys = DIM('a)"
   using that
   by (subst euclidean_inner[abs_def], subst sum_list_Basis_list[symmetric])
       (auto simp: eucl_of_list_inner sum_list_sum_nth index_nth_id inner_lv_rel_def)
 
 
 lemma euclidean_vec_componentwise:
   "(\<Sum>(xa::'a::euclidean_space^'b::finite)\<in>Basis. f xa) = (\<Sum>a\<in>Basis. (\<Sum>b::'b\<in>UNIV. f (axis b a)))"
   apply (auto simp: Basis_vec_def)
   apply (subst sum.swap)
   apply (subst sum.Union_disjoint)
     apply auto
       apply (simp add: axis_eq_axis nonzero_Basis)
    apply (simp add: axis_eq_axis nonzero_Basis)
   apply (subst sum.reindex)
    apply (auto intro!: injI)
   subgoal
     apply (auto simp: set_eq_iff)
     by (metis (full_types) all_not_in_conv inner_axis_axis inner_eq_zero_iff nonempty_Basis nonzero_Basis)
   apply (rule sum.cong[OF refl])
   apply (auto )
   apply (rule sum.reindex_cong[OF _ _ refl])
   apply (auto intro!: inj_onI)
   using axis_eq_axis by blast
 
 lemma vec_nth_inner_scaleR_craziness:
   "f (x $ i \<bullet> j) *\<^sub>R j = (\<Sum>xa\<in>UNIV. f (x $ xa \<bullet> j) *\<^sub>R axis xa j) $ i"
   by vector (auto simp: axis_def if_distrib scaleR_vec_def sum.delta' cong: if_cong)
 
 instantiation vec :: ("{executable_euclidean_space}", enum) executable_euclidean_space
 begin
 
 definition Basis_list_vec :: "('a, 'b) vec list" where
   "Basis_list_vec = concat (map (\<lambda>n. map (axis n) Basis_list) enum_class.enum)"
 
 definition eucl_down_vec :: "int \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
   "eucl_down_vec p x = (\<chi> i. eucl_down p (x $ i))"
 
 definition eucl_truncate_down_vec :: "nat \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
   "eucl_truncate_down_vec p x = (\<chi> i. eucl_truncate_down p (x $ i))"
 
 definition eucl_truncate_up_vec :: "nat \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
   "eucl_truncate_up_vec p x = (\<chi> i. eucl_truncate_up p (x $ i))"
 
 instance
 proof
   show *: "set (Basis_list::('a, 'b) vec list) = Basis"
     unfolding Basis_list_vec_def Basis_vec_def
     apply (auto simp: Basis_list_vec_def vec_eq_iff distinct_map Basis_vec_def
         intro!: distinct_concat inj_onI split: if_splits)
     apply (auto simp: Basis_list_vec_def vec_eq_iff distinct_map enum_distinct
         UNIV_enum[symmetric]
         intro!: distinct_concat inj_onI split: if_splits)
     done
   have "length (Basis_list::('a, 'b) vec list) = CARD('b) * DIM('a)"
     by (auto simp: Basis_list_vec_def length_concat o_def enum_distinct
         sum_list_distinct_conv_sum_set UNIV_enum[symmetric])
   then show "distinct (Basis_list::('a, 'b) vec list)"
     using * by (auto intro!: card_distinct)
 qed (simp_all only: vector_cart[symmetric] vec_eq_iff
     eucl_down_vec_def eucl_down_def
     eucl_truncate_down_vec_def eucl_truncate_down_def
     eucl_truncate_up_vec_def eucl_truncate_up_def,
     auto simp: euclidean_vec_componentwise inner_axis Basis_list_vec_def
     vec_nth_inner_scaleR_craziness
     intro!: sum.cong[OF refl])
 end
 
 
 lemma concat_same_lengths_nth:
   assumes "\<And>xs. xs \<in> set XS \<Longrightarrow> length xs = N"
   assumes "i < length XS * N" "N > 0"
   shows "concat XS ! i = XS ! (i div N) ! (i mod N)"
   using assms
   apply (induction XS arbitrary: i)
    apply (auto simp: nth_append nth_Cons split: nat.splits)
    apply (simp add: div_eq_0_iff)
   by (metis Suc_inject div_geq mod_geq)
 
 lemma concat_map_map_index:
   shows "concat (map (\<lambda>n. map (f n) xs) ys) =
     map (\<lambda>i. f (ys ! (i div length xs)) (xs ! (i mod length xs))) [0..<length xs * length ys]"
   apply (auto intro!: nth_equalityI simp: length_concat o_def sum_list_sum_nth)
   apply (subst concat_same_lengths_nth)
      apply (auto simp: )
   apply (subst nth_map_upt)
   apply (auto simp: ac_simps)
   apply (subst nth_map)
   apply (metis div_eq_0_iff div_mult2_eq mult.commute mult_0 not_less0)
   apply (subst nth_map)
   subgoal for i
     using gr_implies_not_zero by fastforce
   subgoal by simp
   done
 
 lemma
   sum_list_zip_map:
   assumes "distinct xs"
   shows "(\<Sum>(x, y)\<leftarrow>zip xs (map g xs). f x y) = (\<Sum>x\<in>set xs. f x (g x))"
   by (force simp add: sum_list_distinct_conv_sum_set assms distinct_zipI1 split_beta'
     in_set_zip in_set_conv_nth inj_on_convol_ident
     intro!: sum.reindex_cong[where l="\<lambda>x. (x, g x)"])
 
 lemma
   sum_list_zip_map_of:
   assumes "distinct bs"
   assumes "length xs = length bs"
   shows "(\<Sum>(x, y)\<leftarrow>zip xs bs. f x y) = (\<Sum>x\<in>set bs. f (the (map_of (zip bs xs) x)) x)"
 proof -
   have "(\<Sum>(x, y)\<leftarrow>zip xs bs. f x y) = (\<Sum>(y, x)\<leftarrow>zip bs xs. f x y)"
     by (subst zip_commute) (auto simp: o_def split_beta')
   also have "\<dots> = (\<Sum>(x, y)\<leftarrow>zip bs (map (the o map_of (zip bs xs)) bs). f y x)"
   proof (rule arg_cong, rule map_cong)
     have "xs = (map (the \<circ> map_of (zip bs xs)) bs)"
       using assms
       by (auto intro!: nth_equalityI simp: map_nth map_of_zip_nth)
     then show "zip bs xs = zip bs (map (the \<circ> map_of (zip bs xs)) bs)"
       by simp
   qed auto
   also have "\<dots> = (\<Sum>x\<in>set bs. f (the (map_of (zip bs xs) x)) x)"
     using assms(1)
     by (subst sum_list_zip_map) (auto simp: o_def)
   finally show ?thesis .
 qed
 
 
 
 lemma vec_nth_matrix:
   "vec_nth (vec_nth (matrix y) i) j = vec_nth (y (axis j 1)) i"
   unfolding matrix_def by simp
 
 lemma matrix_eqI:
   assumes "\<And>x. x \<in> Basis \<Longrightarrow> A *v x = B *v x"
   shows "(A::real^'n^'n) = B"
   apply vector
   using assms
   apply (auto simp: Basis_vec_def)
   by (metis cart_eq_inner_axis matrix_vector_mul_component)
 
 lemma matrix_columnI:
   assumes "\<And>i. column i A = column i B"
   shows "(A::real^'n^'n) = B"
   using assms
   apply vector
   apply (auto simp: column_def)
   apply vector
   by (metis iso_tuple_UNIV_I vec_lambda_inject)
 
 lemma
   vec_nth_Basis:
   fixes x::"real^'n"
   shows "x \<in> Basis \<Longrightarrow> vec_nth x i = (if x = axis i 1 then 1 else 0)"
   apply (auto simp: Basis_vec_def)
   by (metis cart_eq_inner_axis inner_axis_axis)
 
 lemma vec_nth_eucl_of_list_eq: "length M = CARD('n) \<Longrightarrow>
   vec_nth (eucl_of_list M::real^'n::enum) i = M ! index Basis_list (axis i (1::real))"
   apply (auto simp: eucl_of_list_def)
   apply (subst sum_list_zip_map_of)
    apply (auto intro!: distinct_zipI2 simp: split_beta')
   apply (subst sum.cong[OF refl])
    apply (subst vec_nth_Basis)
     apply (force simp: set_zip)
   apply (rule refl)
   apply (auto simp: if_distrib sum.delta cong: if_cong)
   subgoal
     apply (cases "map_of (zip Basis_list M) (axis i 1::real^'n::enum)")
     subgoal premises prems
     proof -
       have "fst ` set (zip Basis_list M) = (Basis::(real^'n::enum) set)" using prems
         by (auto simp: in_set_zip)
       then show ?thesis
         using prems
         by (subst (asm) map_of_eq_None_iff) simp
     qed
     subgoal for a
       apply (auto simp: in_set_zip)
       subgoal premises prems for n
         by (metis DIM_cart DIM_real index_Basis_list_nth mult.right_neutral prems(2) prems(3))
       done
     done
   done
 
 lemma index_Basis_list_axis1: "index Basis_list (axis i (1::real)) = index enum_class.enum i"
   apply (auto simp: Basis_list_vec_def Basis_list_real_def )
   apply (subst index_map_inj)
   by (auto intro!: injI simp: axis_eq_axis)
 
 lemma vec_nth_eq_list_of_eucl1:
   "(vec_nth (M::real^'n::enum) i) = list_of_eucl M ! (index enum_class.enum i)"
   apply (subst eucl_of_list_list_of_eucl[of M, symmetric])
   apply (subst vec_nth_eucl_of_list_eq)
   unfolding index_Basis_list_axis1
   by auto
 
 lemma enum_3[simp]: "(enum_class.enum::3 list) = [0, 1, 2]"
   by code_simp+
 
 lemma three_eq_zero: "(3::3) = 0" by simp
 
 lemma forall_3': "(\<forall>i::3. P i) \<longleftrightarrow> P 0 \<and> P 1 \<and> P 2"
   using forall_3 three_eq_zero by auto
 
 lemma euclidean_eq_list_of_euclI: "x = y" if "list_of_eucl x = list_of_eucl y"
   using that
   by (metis eucl_of_list_list_of_eucl)
 
 lemma axis_one_neq_zero[simp]: "axis xa (1::'a::zero_neq_one) \<noteq> 0"
   by (auto simp: axis_def vec_eq_iff)
 
 
 lemma eucl_of_list_vec_nth3[simp]:
   "(eucl_of_list [g, h, i]::real^3) $ 0 = g"
   "(eucl_of_list [g, h, i]::real^3) $ 1 = h"
   "(eucl_of_list [g, h, i]::real^3) $ 2 = i"
   "(eucl_of_list [g, h, i]::real^3) $ 3 = g"
   by (auto simp: cart_eq_inner_axis eucl_of_list_inner vec_nth_eq_list_of_eucl1 index_Basis_list_axis1)
 
 type_synonym R3 = "real*real*real"
 
 lemma Basis_list_R3: "Basis_list = [(1,0,0), (0, 1, 0), (0, 0, 1)::R3]"
   by (auto simp: Basis_list_prod_def Basis_list_real_def zero_prod_def)
 
 lemma Basis_list_vec3: "Basis_list = [axis 0 1::real^3, axis 1 1, axis 2 1]"
   by (auto simp: Basis_list_vec_def Basis_list_real_def)
 
 lemma eucl_of_list3[simp]: "eucl_of_list [a, b, c] = (a, b, c)"
   by (auto simp: eucl_of_list_inner Basis_list_vec_def zero_prod_def
       Basis_prod_def Basis_list_vec3 Basis_list_R3
       intro!: euclidean_eqI[where 'a=R3])
 
 
 subsection \<open>Bounded Linear Functions\<close>
 
 subsection \<open>bounded linear functions\<close>
 
 locale blinfun_syntax
 begin
 no_notation vec_nth (infixl "$" 90)
 notation blinfun_apply (infixl "$" 999)
 end
 
 lemma bounded_linear_via_derivative:
   fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector" \<comment> \<open>TODO: generalize?\<close>
   assumes "\<And>i. ((\<lambda>x. blinfun_apply (f x) i) has_derivative (\<lambda>x. f' y x i)) (at y)"
   shows "bounded_linear (f' y x)"
 proof -
   interpret linear "f' y x"
   proof (unfold_locales, goal_cases)
     case (1 v w)
     from has_derivative_unique[OF assms[of "v + w", unfolded blinfun.bilinear_simps]
       has_derivative_add[OF assms[of v] assms[of w]], THEN fun_cong, of x]
     show ?case .
   next
     case (2 r v)
     from has_derivative_unique[OF assms[of "r *\<^sub>R v", unfolded blinfun.bilinear_simps]
       has_derivative_scaleR_right[OF assms[of v], of r], THEN fun_cong, of x]
     show ?case .
   qed
   let ?bnd = "\<Sum>i\<in>Basis. norm (f' y x i)"
   {
     fix v
     have "f' y x v = (\<Sum>i\<in>Basis. (v \<bullet> i) *\<^sub>R f' y x i)"
       by (subst euclidean_representation[symmetric]) (simp add: sum scaleR)
     also have "norm \<dots> \<le> norm v * ?bnd"
       by (auto intro!: order.trans[OF norm_sum] sum_mono mult_right_mono
         simp: sum_distrib_left Basis_le_norm)
     finally have "norm (f' y x v) \<le> norm v * ?bnd" .
   }
   then show ?thesis by unfold_locales auto
 qed
 
 definition blinfun_scaleR::"('a::real_normed_vector \<Rightarrow>\<^sub>L real) \<Rightarrow> 'b::real_normed_vector \<Rightarrow> ('a \<Rightarrow>\<^sub>L 'b)"
   where "blinfun_scaleR a b = blinfun_scaleR_left b o\<^sub>L a"
 
 lemma blinfun_scaleR_transfer[transfer_rule]:
   "rel_fun (pcr_blinfun (=) (=)) (rel_fun (=) (pcr_blinfun (=) (=)))
     (\<lambda>a b c. a c *\<^sub>R b) blinfun_scaleR"
   by (auto simp: blinfun_scaleR_def rel_fun_def pcr_blinfun_def cr_blinfun_def OO_def)
 
 lemma blinfun_scaleR_rep_eq[simp]:
   "blinfun_scaleR a b c = a c *\<^sub>R b"
   by (simp add: blinfun_scaleR_def)
 
 lemma bounded_linear_blinfun_scaleR: "bounded_linear (blinfun_scaleR a)"
   unfolding blinfun_scaleR_def[abs_def]
   by (auto intro!: bounded_linear_intros)
 
 lemma blinfun_scaleR_has_derivative[derivative_intros]:
   assumes "(f has_derivative f') (at x within s)"
   shows "((\<lambda>x. blinfun_scaleR a (f x)) has_derivative (\<lambda>x. blinfun_scaleR a (f' x))) (at x within s)"
   using bounded_linear_blinfun_scaleR assms
   by (rule bounded_linear.has_derivative)
 
 lemma blinfun_componentwise:
   fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
   shows "f = (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f x i))"
   by (auto intro!: blinfun_eqI
     simp: blinfun.sum_left euclidean_representation blinfun.scaleR_right[symmetric]
       blinfun.sum_right[symmetric])
 
 lemma
   blinfun_has_derivative_componentwiseI:
   fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
   assumes "\<And>i. i \<in> Basis \<Longrightarrow> ((\<lambda>x. f x i) has_derivative blinfun_apply (f' i)) (at x)"
   shows "(f has_derivative (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' i x))) (at x)"
   by (subst blinfun_componentwise) (force intro: derivative_eq_intros assms simp: blinfun.bilinear_simps)
 
 lemma
   has_derivative_BlinfunI:
   fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
   assumes "\<And>i. ((\<lambda>x. f x i) has_derivative (\<lambda>x. f' y x i)) (at y)"
   shows "(f has_derivative (\<lambda>x. Blinfun (f' y x))) (at y)"
 proof -
   have 1: "f = (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f x i))"
     by (rule blinfun_componentwise)
   moreover have 2: "(\<dots> has_derivative (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' y x i))) (at y)"
     by (force intro: assms derivative_eq_intros)
   moreover
   interpret f': bounded_linear "f' y x" for x
     by (rule bounded_linear_via_derivative) (rule assms)
   have 3: "(\<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' y x i)) i = f' y x i" for x i
     by (auto simp: if_distrib if_distribR blinfun.bilinear_simps
       f'.scaleR[symmetric] f'.sum[symmetric] euclidean_representation
       intro!: blinfun_euclidean_eqI)
   have 4: "blinfun_apply (Blinfun (f' y x)) = f' y x" for x
     apply (subst bounded_linear_Blinfun_apply)
     subgoal by unfold_locales
     subgoal by simp
     done
   show ?thesis
     apply (subst 1)
     apply (rule 2[THEN has_derivative_eq_rhs])
     apply (rule ext)
     apply (rule blinfun_eqI)
     apply (subst 3)
     apply (subst 4)
     apply (rule refl)
     done
 qed
 
 lemma
   has_derivative_Blinfun:
   assumes "(f has_derivative f') F"
   shows "(f has_derivative Blinfun f') F"
   using assms
   by (subst bounded_linear_Blinfun_apply) auto
 
 lift_definition flip_blinfun::
   "('a::real_normed_vector \<Rightarrow>\<^sub>L 'b::real_normed_vector \<Rightarrow>\<^sub>L 'c::real_normed_vector) \<Rightarrow> 'b \<Rightarrow>\<^sub>L 'a \<Rightarrow>\<^sub>L 'c" is
   "\<lambda>f x y. f y x"
   using bounded_bilinear.bounded_linear_left bounded_bilinear.bounded_linear_right bounded_bilinear.flip
   by auto
 
 lemma flip_blinfun_apply[simp]: "flip_blinfun f a b = f b a"
   by transfer simp
 
 lemma le_norm_blinfun:
   shows "norm (blinfun_apply f x) / norm x \<le> norm f"
   by transfer (rule le_onorm)
 
 lemma norm_flip_blinfun[simp]: "norm (flip_blinfun x) = norm x" (is "?l = ?r")
 proof (rule antisym)
   from order_trans[OF norm_blinfun, OF mult_right_mono, OF norm_blinfun, OF norm_ge_zero, of x]
   show "?l \<le> ?r"
     by (auto intro!: norm_blinfun_bound simp: ac_simps)
   have "norm (x a b) \<le> norm (flip_blinfun x) * norm a * norm b" for a b
   proof -
     have "norm (x a b) / norm a \<le> norm (flip_blinfun x b)"
       by (rule order_trans[OF _ le_norm_blinfun]) auto
     also have "\<dots> \<le> norm (flip_blinfun x) * norm b"
       by (rule norm_blinfun)
     finally show ?thesis
-      by (auto simp add: divide_simps blinfun.bilinear_simps sign_simps  split: if_split_asm)
+      by (auto simp add: divide_simps blinfun.bilinear_simps algebra_simps split: if_split_asm)
   qed
   then show "?r \<le> ?l"
     by (auto intro!: norm_blinfun_bound)
 qed
 
 lemma bounded_linear_flip_blinfun[bounded_linear]: "bounded_linear flip_blinfun"
   by unfold_locales (auto simp: blinfun.bilinear_simps intro!: blinfun_eqI exI[where x=1])
 
 lemma dist_swap2_swap2[simp]: "dist (flip_blinfun f) (flip_blinfun g) = dist f g"
   by (metis (no_types) bounded_linear_flip_blinfun dist_blinfun_def linear_simps(2)
     norm_flip_blinfun)
 
 
 context includes blinfun.lifting begin
 
 lift_definition blinfun_of_vmatrix::"(real^'m^'n) \<Rightarrow> ((real^('m::finite)) \<Rightarrow>\<^sub>L (real^('n::finite)))" is
   "matrix_vector_mult:: ((real, 'm) vec, 'n) vec \<Rightarrow> ((real, 'm) vec \<Rightarrow> (real, 'n) vec)"
   unfolding linear_linear
   by (rule matrix_vector_mul_linear)
 
 lemma matrix_blinfun_of_vmatrix[simp]: "matrix (blinfun_of_vmatrix M) = M"
   apply vector
   apply (auto simp: matrix_def)
   apply transfer
   by (metis cart_eq_inner_axis matrix_vector_mul_component)
 
 end
 
 lemma blinfun_apply_componentwise:
   "B = (\<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (blinfun_apply B i))"
   using blinfun_componentwise[of "\<lambda>x. B", unfolded fun_eq_iff]
   by blast
 
 lemma blinfun_apply_eq_sum:
   assumes [simp]: "length v = CARD('n)"
   shows "blinfun_apply (B::(real^'n::enum)\<Rightarrow>\<^sub>L(real^'m::enum)) (eucl_of_list v) =
     (\<Sum>i<CARD('m). \<Sum>j<CARD('n). ((B (Basis_list ! j) \<bullet> Basis_list ! i) * v ! j) *\<^sub>R (Basis_list ! i))"
   apply (subst blinfun_apply_componentwise[of B])
   apply (auto intro!: euclidean_eqI[where 'a="(real,'m) vec"]
       simp: blinfun.bilinear_simps eucl_of_list_inner inner_sum_left inner_Basis if_distrib
         sum_Basis_sum_nth_Basis_list nth_eq_iff_index if_distribR
         cong: if_cong)
   apply (subst sum.swap)
   by (auto simp: sum.delta algebra_simps)
 
 lemma in_square_lemma[intro, simp]: "x * C + y < D * C" if "x < D" "y < C" for x::nat
 proof -
   have "x * C + y < (D - 1) * C + C"
     apply (rule add_le_less_mono)
      apply (rule mult_right_mono)
     using that
     by auto
   also have "\<dots> \<le> D * C"
     using that
     by (auto simp: algebra_simps)
   finally show ?thesis .
 qed
 
 lemma less_square_imp_div_less[intro, simp]: "i < E * D \<Longrightarrow>  i div E < D" for i::nat
   by (metis div_eq_0_iff div_mult2_eq gr_implies_not0 mult_not_zero)
 
 lemma in_square_lemma'[intro, simp]: "i < L \<Longrightarrow> n < N \<Longrightarrow> i * N + n < N * L" for i n::nat
   by (metis in_square_lemma mult.commute)
 
 lemma
   distinct_nth_eq_iff:
   "distinct xs \<Longrightarrow> x < length xs \<Longrightarrow> y < length xs \<Longrightarrow> xs ! x = xs ! y \<longleftrightarrow> x = y"
   by (drule inj_on_nth[where I="{..<length xs}"]) (auto simp: inj_onD)
 
 lemma index_Basis_list_axis2:
   "index Basis_list (axis (j::'j::enum) (axis (i::'i::enum) (1::real))) =
     (index enum_class.enum j) * CARD('i) + index enum_class.enum i"
   apply (auto simp: Basis_list_vec_def Basis_list_real_def o_def)
   apply (subst concat_map_map_index)
   unfolding card_UNIV_length_enum[symmetric]
   subgoal
   proof -
     have index_less_cardi: "index enum_class.enum k < CARD('i)" for k::'i
       by (rule index_less) (auto simp: enum_UNIV card_UNIV_length_enum)
     have index_less_cardj: "index enum_class.enum k < CARD('j)" for k::'j
       by (rule index_less) (auto simp: enum_UNIV card_UNIV_length_enum)
     have *: "axis j (axis i 1) =
       (\<lambda>i. axis (enum_class.enum ! (i div CARD('i)))
                       (axis (enum_class.enum ! (i mod CARD('i))) 1))
       ((index enum_class.enum j) * CARD('i) + index enum_class.enum i)"
       by (auto simp: index_less_cardi enum_UNIV)
     note less=in_square_lemma[OF index_less_cardj index_less_cardi, of j i]
     show ?thesis
       apply (subst *)
       apply (subst index_map_inj_on[where S="{..<CARD('j)*CARD('i)}"])
       subgoal
         apply (auto intro!: inj_onI simp: axis_eq_axis )
          apply (subst (asm) distinct_nth_eq_iff)
         apply (auto simp: enum_distinct card_UNIV_length_enum)
         subgoal for x y
           using gr_implies_not0 by fastforce
         subgoal for x y
           using gr_implies_not0 by fastforce
         subgoal for x y
           apply (drule inj_onD[OF inj_on_nth[OF enum_distinct[where 'a='j], where I = "{..<CARD('j)}"], rotated])
              apply (auto simp: card_UNIV_length_enum mult.commute)
           subgoal
             by (metis mod_mult_div_eq)
           done
         done
       subgoal using less by (auto simp: )
       subgoal by (auto simp: card_UNIV_length_enum ac_simps)
       subgoal apply (subst index_upt)
         subgoal using less by auto
         subgoal using less by (auto simp: ac_simps)
         subgoal using less by auto
         done
       done
   qed
   done
 
 lemma
   vec_nth_Basis2:
   fixes x::"real^'n^'m"
   shows "x \<in> Basis \<Longrightarrow> vec_nth (vec_nth x i) j = ((if x = axis i (axis j 1) then 1 else 0))"
   by (auto simp: Basis_vec_def axis_def)
 
 lemma vec_nth_eucl_of_list_eq2: "length M = CARD('n) * CARD('m) \<Longrightarrow>
   vec_nth (vec_nth (eucl_of_list M::real^'n::enum^'m::enum) i) j = M ! index Basis_list (axis i (axis j (1::real)))"
   apply (auto simp: eucl_of_list_def)
   apply (subst sum_list_zip_map_of)
    apply (auto intro!: distinct_zipI2 simp: split_beta')
   apply (subst sum.cong[OF refl])
    apply (subst vec_nth_Basis2)
     apply (force simp: set_zip)
   apply (rule refl)
   apply (auto simp: if_distrib sum.delta cong: if_cong)
   subgoal
     apply (cases "map_of (zip Basis_list M) (axis i (axis j 1)::real^'n::enum^'m::enum)")
     subgoal premises prems
     proof -
       have "fst ` set (zip Basis_list M) = (Basis::(real^'n::enum^'m::enum) set)" using prems
         by (auto simp: in_set_zip)
       then show ?thesis
         using prems
         by (subst (asm) map_of_eq_None_iff) auto
     qed
     subgoal for a
       apply (auto simp: in_set_zip)
       subgoal premises prems for n
       proof -
         have "n < card (Basis::(real^'n::_^'m::_) set)"
           by (simp add: prems(4))
         then show ?thesis
           by (metis index_Basis_list_nth prems(2))
       qed
       done
     done
   done
 
 lemma vec_nth_eq_list_of_eucl2:
   "vec_nth (vec_nth (M::real^'n::enum^'m::enum) i) j =
     list_of_eucl M ! (index enum_class.enum i * CARD('n) + index enum_class.enum j)"
   apply (subst eucl_of_list_list_of_eucl[of M, symmetric])
   apply (subst vec_nth_eucl_of_list_eq2)
   unfolding index_Basis_list_axis2
   by auto
 
 theorem
   eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list:
   assumes "length M = CARD('n) * CARD('m)"
   assumes "length v = CARD('n)"
   shows "(eucl_of_list M::real^'n::enum^'m::enum) *v eucl_of_list v =
     (\<Sum>i<CARD('m).
       (\<Sum>j<CARD('n). M ! (i * CARD('n) + j) * v ! j) *\<^sub>R Basis_list ! i)"
   apply (vector matrix_vector_mult_def)
   apply (auto simp: )
   apply (subst vec_nth_eucl_of_list_eq2)
    apply (auto simp: assms)
   apply (subst vec_nth_eucl_of_list_eq)
    apply (auto simp: assms index_Basis_list_axis2 index_Basis_list_axis1 vec_nth_Basis sum.delta
       nth_eq_iff_index
       if_distrib cong: if_cong)
   subgoal for i
     apply (rule sum.reindex_cong[where l="nth enum_class.enum"])
       apply (auto simp: enum_distinct card_UNIV_length_enum distinct_nth_eq_iff intro!: inj_onI)
      apply (rule image_eqI[OF ])
       apply (rule nth_index[symmetric])
       apply (auto simp: enum_UNIV)
     by (auto simp: algebra_simps enum_UNIV enum_distinct index_nth_id)
   subgoal for i
     using index_less[of i "enum_class.enum" "CARD('n)"]
     by (auto simp: enum_UNIV card_UNIV_length_enum)
   done
 
 lemma index_enum_less[intro, simp]: "index enum_class.enum (i::'n::enum) < CARD('n)"
   by (auto intro!: index_less simp: enum_UNIV card_UNIV_length_enum)
 
 lemmas [intro, simp] = enum_distinct
 lemmas [simp] = card_UNIV_length_enum[symmetric] enum_UNIV
 
 lemma sum_index_enum_eq:
   "(\<Sum>(k::'n::enum)\<in>UNIV. f (index enum_class.enum k)) = (\<Sum>i<CARD('n). f i)"
   by (rule sum.reindex_cong[where l="nth enum_class.enum"])
     (force intro!: inj_onI simp: distinct_nth_eq_iff index_nth_id)+
 
 end
\ No newline at end of file
diff --git a/thys/Count_Complex_Roots/Extended_Sturm.thy b/thys/Count_Complex_Roots/Extended_Sturm.thy
--- a/thys/Count_Complex_Roots/Extended_Sturm.thy
+++ b/thys/Count_Complex_Roots/Extended_Sturm.thy
@@ -1,1599 +1,1598 @@
 (*
     Author:     Wenda Li <wl302@cam.ac.uk / liwenda1990@hotmail.com>
 *)
 
 section \<open>An alternative Sturm sequences\<close>
 
 theory Extended_Sturm imports 
   "Sturm_Tarski.Sturm_Tarski" 
   "Winding_Number_Eval.Cauchy_Index_Theorem"
 begin 
   
 text \<open>The main purpose of this theory is to provide an effective way to compute 
   @{term "cindexE a b f"} when @{term f} is a rational function. The idea is similar to and based
   on the evaluation of @{term cindex_poly} through @{thm cindex_poly_changes_itv_mods}.\<close>   
   
 text \<open>
 This alternative version of remainder sequences is inspired by the paper 
   "The Fundamental Theorem of Algebra made effective: 
   an elementary real-algebraic proof via Sturm chains" 
 by Michael Eisermann.
 \<close>  
   
 hide_const Permutations.sign  
   
 subsection \<open>Misc\<close>
    
 lemma is_unit_pCons_ex_iff:
   fixes p::"'a::field poly"
   shows "is_unit p \<longleftrightarrow> (\<exists>a. a\<noteq>0 \<and> p=[:a:])"
   using is_unit_poly_iff is_unit_triv by auto
 
 lemma poly_gcd_iff: 
   "poly (gcd p q) x=0 \<longleftrightarrow> poly p x=0 \<and> poly q x=0 "
   by (simp add: poly_eq_0_iff_dvd)
   
 lemma eventually_poly_nz_at_within:
   fixes x :: "'a::{idom,euclidean_space} "
   assumes "p\<noteq>0" 
   shows "eventually (\<lambda>x. poly p x\<noteq>0) (at x within S)"     
 proof -
   have "eventually (\<lambda>x. poly p x\<noteq>0) (at x within S) 
       = (\<forall>\<^sub>F x in (at x within S). \<forall>y\<in>proots p. x \<noteq> y)"
     apply (rule eventually_subst,rule eventuallyI)
     by (auto simp add:proots_def)
   also have "... = (\<forall>y\<in>proots p. \<forall>\<^sub>F x in (at x within S). x \<noteq> y)"
     apply (subst eventually_ball_finite_distrib)
     using \<open>p\<noteq>0\<close> by auto
   also have "..."
     unfolding eventually_at
     by (metis gt_ex not_less_iff_gr_or_eq zero_less_dist_iff) 
   finally show ?thesis .
 qed
     
 lemma sgn_power:
   fixes x::"'a::linordered_idom"
   shows "sgn (x^n) = (if n=0 then 1 else if even n then \<bar>sgn x\<bar> else sgn x)"
   apply (induct n)
   by (auto simp add:sgn_mult)
 
 lemma poly_divide_filterlim_at_top: 
   fixes p q::"real poly"
   defines "ll\<equiv>( if degree q<degree p then 
                     at 0 
                 else if degree q=degree p then 
                     nhds (lead_coeff q / lead_coeff p)
                 else if sgn_pos_inf q * sgn_pos_inf p > 0 then 
                     at_top
                 else 
                     at_bot)"
   assumes "p\<noteq>0" "q\<noteq>0"
   shows "filterlim (\<lambda>x. poly q x / poly p x) ll at_top"
 proof -
   define pp where "pp=(\<lambda>x. poly p x / x^(degree p))"    
   define qq where "qq=(\<lambda>x. poly q x / x^(degree q))"
   define dd where "dd=(\<lambda>x::real. if degree p>degree q then 1/x^(degree p - degree q) else 
                                 x^(degree q - degree p))"
   have divide_cong:"\<forall>\<^sub>Fx in at_top. poly q x / poly p x = qq x / pp x * dd x"
   proof (rule eventually_at_top_linorderI[of 1])
     fix x assume "(x::real)\<ge>1"
     then have "x\<noteq>0" by auto
     then show "poly q x / poly p x = qq x / pp x * dd x"
       unfolding qq_def pp_def dd_def using assms 
       by (auto simp add:field_simps power_diff) 
   qed
   have qqpp_tendsto:"((\<lambda>x. qq x / pp x) \<longlongrightarrow> lead_coeff q / lead_coeff p) at_top"
   proof -
     have "(qq \<longlongrightarrow> lead_coeff q) at_top"
       unfolding qq_def using poly_divide_tendsto_aux[of q]  
       by (auto elim!:filterlim_mono simp:at_top_le_at_infinity)
     moreover have "(pp \<longlongrightarrow> lead_coeff p) at_top"
       unfolding pp_def using poly_divide_tendsto_aux[of p]  
       by (auto elim!:filterlim_mono simp:at_top_le_at_infinity)
     ultimately show ?thesis using \<open>p\<noteq>0\<close> by (auto intro!:tendsto_eq_intros)
   qed
   
   have ?thesis when "degree q<degree p"
   proof -
     have "filterlim (\<lambda>x. poly q x / poly p x) (at 0) at_top"
     proof (rule filterlim_atI)
       show "((\<lambda>x. poly q x / poly p x) \<longlongrightarrow> 0) at_top"
         using poly_divide_tendsto_0_at_infinity[OF that]
         by (auto elim:filterlim_mono simp:at_top_le_at_infinity)
       have "\<forall>\<^sub>F x in at_top. poly q x \<noteq>0" "\<forall>\<^sub>F x in at_top. poly p x \<noteq>0"
         using poly_eventually_not_zero[OF \<open>q\<noteq>0\<close>] poly_eventually_not_zero[OF \<open>p\<noteq>0\<close>]
               filter_leD[OF at_top_le_at_infinity]
         by auto
       then show "\<forall>\<^sub>F x in at_top. poly q x / poly p x \<noteq> 0"
         apply eventually_elim
         by auto
     qed
     then show ?thesis unfolding ll_def using that by auto
   qed
   moreover have ?thesis when "degree q=degree p"
   proof -
     have "((\<lambda>x. poly q x / poly p x) \<longlongrightarrow> lead_coeff q / lead_coeff p) at_top"
       using divide_cong qqpp_tendsto that unfolding dd_def
       by (auto dest:tendsto_cong)
     then show ?thesis unfolding ll_def using that by auto
   qed
   moreover have ?thesis when "degree q>degree p" "sgn_pos_inf q * sgn_pos_inf p > 0"
   proof -
     have "filterlim (\<lambda>x. (qq x / pp x) * dd x) at_top at_top"
     proof (subst filterlim_tendsto_pos_mult_at_top_iff[OF qqpp_tendsto])
       show "0 < lead_coeff q / lead_coeff p" using that(2) unfolding sgn_pos_inf_def
         by (simp add: zero_less_divide_iff zero_less_mult_iff)
       show "filterlim dd at_top at_top"
         unfolding dd_def using that(1) 
         by (auto intro!:filterlim_pow_at_top simp:filterlim_ident)
     qed
     then have "LIM x at_top. poly q x / poly p x :> at_top" 
       using filterlim_cong[OF _ _ divide_cong] by blast
     then show ?thesis unfolding ll_def using that by auto
   qed
   moreover have ?thesis  when "degree q>degree p" "\<not> sgn_pos_inf q * sgn_pos_inf p > 0"
   proof -
     have "filterlim (\<lambda>x. (qq x / pp x) * dd x) at_bot at_top"
     proof (subst filterlim_tendsto_neg_mult_at_bot_iff[OF qqpp_tendsto])
       show "lead_coeff q / lead_coeff p < 0" 
         using that(2) \<open>p\<noteq>0\<close> \<open>q\<noteq>0\<close> unfolding sgn_pos_inf_def
         by (metis divide_eq_0_iff divide_sgn leading_coeff_0_iff 
             linorder_neqE_linordered_idom sgn_divide sgn_greater)
       show "filterlim dd at_top at_top"
         unfolding dd_def using that(1) 
         by (auto intro!:filterlim_pow_at_top simp:filterlim_ident)
     qed
     then have "LIM x at_top. poly q x / poly p x :> at_bot" 
       using filterlim_cong[OF _ _ divide_cong] by blast
     then show ?thesis unfolding ll_def using that by auto
   qed
   ultimately show ?thesis by linarith
 qed
 
 lemma poly_divide_filterlim_at_bot: 
   fixes p q::"real poly"
   defines "ll\<equiv>( if degree q<degree p then 
                     at 0 
                 else if degree q=degree p then 
                     nhds (lead_coeff q / lead_coeff p)
                 else if sgn_neg_inf q * sgn_neg_inf p > 0 then 
                     at_top
                 else 
                     at_bot)"
   assumes "p\<noteq>0" "q\<noteq>0"
   shows "filterlim (\<lambda>x. poly q x / poly p x) ll at_bot"
 proof -
   define pp where "pp=(\<lambda>x. poly p x / x^(degree p))"    
   define qq where "qq=(\<lambda>x. poly q x / x^(degree q))"
   define dd where "dd=(\<lambda>x::real. if degree p>degree q then 1/x^(degree p - degree q) else 
                                 x^(degree q - degree p))"
   have divide_cong:"\<forall>\<^sub>Fx in at_bot. poly q x / poly p x = qq x / pp x * dd x"
   proof (rule eventually_at_bot_linorderI[of "-1"])
     fix x assume "(x::real)\<le>-1"
     then have "x\<noteq>0" by auto
     then show "poly q x / poly p x = qq x / pp x * dd x"
       unfolding qq_def pp_def dd_def using assms 
       by (auto simp add:field_simps power_diff) 
   qed
   have qqpp_tendsto:"((\<lambda>x. qq x / pp x) \<longlongrightarrow> lead_coeff q / lead_coeff p) at_bot"
   proof -
     have "(qq \<longlongrightarrow> lead_coeff q) at_bot"
       unfolding qq_def using poly_divide_tendsto_aux[of q]  
       by (auto elim!:filterlim_mono simp:at_bot_le_at_infinity)
     moreover have "(pp \<longlongrightarrow> lead_coeff p) at_bot"
       unfolding pp_def using poly_divide_tendsto_aux[of p]  
       by (auto elim!:filterlim_mono simp:at_bot_le_at_infinity)
     ultimately show ?thesis using \<open>p\<noteq>0\<close> by (auto intro!:tendsto_eq_intros)
   qed
   
   have ?thesis when "degree q<degree p"
   proof -
     have "filterlim (\<lambda>x. poly q x / poly p x) (at 0) at_bot"
     proof (rule filterlim_atI)
       show "((\<lambda>x. poly q x / poly p x) \<longlongrightarrow> 0) at_bot"
         using poly_divide_tendsto_0_at_infinity[OF that]
         by (auto elim:filterlim_mono simp:at_bot_le_at_infinity)
       have "\<forall>\<^sub>F x in at_bot. poly q x \<noteq>0" "\<forall>\<^sub>F x in at_bot. poly p x \<noteq>0"
         using poly_eventually_not_zero[OF \<open>q\<noteq>0\<close>] poly_eventually_not_zero[OF \<open>p\<noteq>0\<close>]
               filter_leD[OF at_bot_le_at_infinity]
         by auto
       then show "\<forall>\<^sub>F x in at_bot. poly q x / poly p x \<noteq> 0"
         by eventually_elim auto
     qed
     then show ?thesis unfolding ll_def using that by auto
   qed
   moreover have ?thesis when "degree q=degree p"
   proof -
     have "((\<lambda>x. poly q x / poly p x) \<longlongrightarrow> lead_coeff q / lead_coeff p) at_bot"
       using divide_cong qqpp_tendsto that unfolding dd_def
       by (auto dest:tendsto_cong)
     then show ?thesis unfolding ll_def using that by auto
   qed
   moreover have ?thesis when "degree q>degree p" "sgn_neg_inf q * sgn_neg_inf p > 0"
   proof -
     define cc where "cc=lead_coeff q / lead_coeff p"
     have "(cc > 0 \<and> even (degree q - degree p)) \<or> (cc<0 \<and> odd (degree q - degree p))"
     proof -
       have "even (degree q - degree p) \<longleftrightarrow> 
             (even (degree q) \<and> even (degree p)) \<or> (odd (degree q) \<and> odd (degree p))"
         using \<open>degree q>degree p\<close> by auto
       then show ?thesis
         using that \<open>p\<noteq>0\<close> \<open>q\<noteq>0\<close> unfolding sgn_neg_inf_def cc_def zero_less_mult_iff 
           divide_less_0_iff zero_less_divide_iff 
         apply (simp add:if_split[of "(<) 0"] if_split[of "(>) 0"])
         by argo
     qed
     moreover have "filterlim (\<lambda>x. (qq x / pp x) * dd x) at_top at_bot"
       when "cc>0" "even (degree q - degree p)"
     proof (subst filterlim_tendsto_pos_mult_at_top_iff[OF qqpp_tendsto])
       show "0 < lead_coeff q / lead_coeff p" using \<open>cc>0\<close> unfolding cc_def by auto
       show "filterlim dd at_top at_bot"
         unfolding dd_def using \<open>degree q>degree p\<close> that(2)
         by (auto intro!:filterlim_pow_at_bot_even simp:filterlim_ident)
     qed
     moreover have "filterlim (\<lambda>x. (qq x / pp x) * dd x) at_top at_bot"
       when "cc<0" "odd (degree q - degree p)"
     proof (subst filterlim_tendsto_neg_mult_at_top_iff[OF qqpp_tendsto])
       show "0 > lead_coeff q / lead_coeff p" using \<open>cc<0\<close> unfolding cc_def by auto
       show "filterlim dd at_bot at_bot"
         unfolding dd_def using \<open>degree q>degree p\<close> that(2)
         by (auto intro!:filterlim_pow_at_bot_odd simp:filterlim_ident)
     qed
     ultimately have "filterlim (\<lambda>x. (qq x / pp x) * dd x) at_top at_bot"
       by blast
     then have "LIM x at_bot. poly q x / poly p x :> at_top"
       using filterlim_cong[OF _ _ divide_cong] by blast
     then show ?thesis unfolding ll_def using that by auto
   qed
   moreover have ?thesis  when "degree q>degree p" "\<not> sgn_neg_inf q * sgn_neg_inf p > 0"
   proof -
     define cc where "cc=lead_coeff q / lead_coeff p"
     have "(cc < 0 \<and> even (degree q - degree p)) \<or> (cc > 0 \<and> odd (degree q - degree p))"
     proof -
       have "even (degree q - degree p) \<longleftrightarrow> 
             (even (degree q) \<and> even (degree p)) \<or> (odd (degree q) \<and> odd (degree p))"
         using \<open>degree q>degree p\<close> by auto
       then show ?thesis
         using that \<open>p\<noteq>0\<close> \<open>q\<noteq>0\<close> unfolding sgn_neg_inf_def cc_def zero_less_mult_iff 
           divide_less_0_iff zero_less_divide_iff
         apply (simp add:if_split[of "(<) 0"] if_split[of "(>) 0"])
         by (metis leading_coeff_0_iff linorder_neqE_linordered_idom)
     qed
     moreover have "filterlim (\<lambda>x. (qq x / pp x) * dd x) at_bot at_bot"
       when "cc<0" "even (degree q - degree p)"
     proof (subst filterlim_tendsto_neg_mult_at_bot_iff[OF qqpp_tendsto])
       show "0 > lead_coeff q / lead_coeff p" using \<open>cc<0\<close> unfolding cc_def by auto
       show "filterlim dd at_top at_bot"
         unfolding dd_def using \<open>degree q>degree p\<close> that(2)
         by (auto intro!:filterlim_pow_at_bot_even simp:filterlim_ident)
     qed
     moreover have "filterlim (\<lambda>x. (qq x / pp x) * dd x) at_bot at_bot"
       when "cc>0" "odd (degree q - degree p)"
     proof (subst filterlim_tendsto_pos_mult_at_bot_iff[OF qqpp_tendsto])
       show "0 < lead_coeff q / lead_coeff p" using \<open>cc>0\<close> unfolding cc_def by auto
       show "filterlim dd at_bot at_bot"
         unfolding dd_def using \<open>degree q>degree p\<close> that(2)
         by (auto intro!:filterlim_pow_at_bot_odd simp:filterlim_ident)
     qed
     ultimately have "filterlim (\<lambda>x. (qq x / pp x) * dd x) at_bot at_bot"
       by blast
     then have "LIM x at_bot. poly q x / poly p x :> at_bot"
       using filterlim_cong[OF _ _ divide_cong] by blast
     then show ?thesis unfolding ll_def using that by auto
   qed
   ultimately show ?thesis by linarith
 qed
         
 subsection \<open>Alternative definition of cross\<close>
  
 definition cross_alt :: "real poly \<Rightarrow>real poly \<Rightarrow> real \<Rightarrow> real \<Rightarrow> int" where
   "cross_alt p q a b=\<bar>sign (poly p a) - sign (poly q a)\<bar> - \<bar>sign (poly p b) - sign(poly q b)\<bar>"  
 
 lemma cross_alt_coprime_0:
   assumes "coprime p q" "p=0\<or>q=0"
   shows "cross_alt p q a b=0" 
 proof -
   have ?thesis when "p=0" 
   proof -
     have "is_unit q" using that \<open>coprime p q\<close> 
       by simp
     then obtain a where "a\<noteq>0" "q=[:a:]" using is_unit_pCons_ex_iff by blast
     then show ?thesis using that unfolding cross_alt_def by auto
   qed
   moreover have ?thesis when "q=0" 
   proof -
     have "is_unit p" using that \<open>coprime p q\<close> 
       by simp
     then obtain a where "a\<noteq>0" "p=[:a:]" using is_unit_pCons_ex_iff by blast
     then show ?thesis using that unfolding cross_alt_def by auto
   qed 
   ultimately show ?thesis using \<open>p=0\<or>q=0\<close> by auto
 qed  
   
 lemma cross_alt_0[simp]: "cross_alt 0 0 a b=0" unfolding cross_alt_def by auto 
   
 lemma cross_alt_poly_commute:
   "cross_alt p q a b = cross_alt q p a b"
   unfolding cross_alt_def by auto
     
 lemma cross_alt_clear_n:
   assumes "coprime p q"
   shows "cross_alt p q a b = cross_alt 1 (p*q) a b"
 proof -
   have "\<bar>sign (poly p a) - sign (poly q a)\<bar>  = \<bar>1 - sign (poly p a) * sign (poly q a)\<bar>"
   proof (cases "poly p a=0 \<and> poly q a=0")
     case True
     then have False using assms using coprime_poly_0 by blast
     then show ?thesis by auto
   next
     case False
     then show ?thesis 
       unfolding Sturm_Tarski.sign_def
       by force
   qed
   moreover have "\<bar>sign (poly p b) - sign (poly q b)\<bar>  = \<bar>1 - sign (poly p b) * sign (poly q b)\<bar>"
   proof (cases "poly p b=0 \<and> poly q b=0")
     case True
     then have False using assms using coprime_poly_0 by blast
     then show ?thesis by auto
   next
     case False
     then show ?thesis 
       unfolding Sturm_Tarski.sign_def
       by force
   qed  
-  ultimately show ?thesis 
-    unfolding cross_alt_def      
-    by (simp only:sign_times poly_mult poly_1 sign_simps)
+  ultimately show ?thesis
+    by (simp add: cross_alt_def sign_times)
 qed   
   
 subsection \<open>Alternative sign variation sequencse\<close>  
   
 fun changes_alt:: "('a ::linordered_idom) list \<Rightarrow> int" where
   "changes_alt [] = 0"|
   "changes_alt [_] = 0" |
   "changes_alt (x1#x2#xs) = abs(sign x1 - sign x2) + changes_alt (x2#xs)"  
   
 definition changes_alt_poly_at::"('a ::linordered_idom) poly list \<Rightarrow> 'a \<Rightarrow> int" where
   "changes_alt_poly_at ps a= changes_alt (map (\<lambda>p. poly p a) ps)"
 
 definition changes_alt_itv_smods:: "real \<Rightarrow> real \<Rightarrow>real poly \<Rightarrow> real poly \<Rightarrow>  int" where
   "changes_alt_itv_smods a b p q= (let ps= smods p q 
                                     in changes_alt_poly_at ps a - changes_alt_poly_at ps b)"  
  
 lemma changes_alt_itv_smods_rec:
   assumes "a<b" "coprime p q" 
   shows "changes_alt_itv_smods a b p q  = cross_alt p q a b + changes_alt_itv_smods a b q (-(p mod q))"
 proof (cases "p = 0 \<or> q = 0 \<or> q dvd p")
   case True
   moreover have "p=0 \<or> q=0 \<Longrightarrow> ?thesis"
     using cross_alt_coprime_0[OF \<open>coprime p q\<close>] 
     unfolding changes_alt_itv_smods_def changes_alt_poly_at_def by fastforce
   moreover have "\<lbrakk>p\<noteq>0;q\<noteq>0;p mod q = 0\<rbrakk> \<Longrightarrow> ?thesis"  
     unfolding changes_alt_itv_smods_def changes_alt_poly_at_def cross_alt_def
     by (simp add:sign_times)
   ultimately show ?thesis
     by auto (auto elim: dvdE)
 next
   case False
   hence "p\<noteq>0" "q\<noteq>0" "p mod q\<noteq>0" by auto
   then obtain ps where ps:"smods p q=p#q#-(p mod q)#ps" "smods q (-(p mod q)) = q#-(p mod q)#ps"
     by auto
   define changes_diff where "changes_diff\<equiv>\<lambda>x. changes_alt_poly_at (p#q#-(p mod q)#ps) x 
     - changes_alt_poly_at (q#-(p mod q)#ps) x"
   have "changes_diff a - changes_diff b=cross_alt p q a b" 
     unfolding changes_diff_def changes_alt_poly_at_def cross_alt_def by simp
   thus ?thesis unfolding changes_alt_itv_smods_def changes_diff_def changes_alt_poly_at_def ps 
     by force
 qed  
   
 subsection \<open>jumpF on polynomials\<close>
 
 definition jumpF_polyR:: "real poly \<Rightarrow> real poly \<Rightarrow> real \<Rightarrow> real" where
   "jumpF_polyR q p a = jumpF (\<lambda>x. poly q x / poly p x) (at_right a)"
   
 definition jumpF_polyL:: "real poly \<Rightarrow> real poly \<Rightarrow> real \<Rightarrow> real" where
   "jumpF_polyL q p a = jumpF (\<lambda>x. poly q x / poly p x) (at_left a)"
 
 definition jumpF_poly_top:: "real poly \<Rightarrow> real poly \<Rightarrow> real" where
   "jumpF_poly_top q p = jumpF (\<lambda>x. poly q x / poly p x) at_top"
 
 definition jumpF_poly_bot:: "real poly \<Rightarrow> real poly \<Rightarrow> real" where
   "jumpF_poly_bot q p = jumpF (\<lambda>x. poly q x / poly p x) at_bot"
 
   
 lemma jumpF_polyR_0[simp]: "jumpF_polyR 0 p a = 0" "jumpF_polyR q 0 a = 0" 
   unfolding jumpF_polyR_def by auto
     
 lemma jumpF_polyL_0[simp]: "jumpF_polyL 0 p a = 0" "jumpF_polyL q 0 a = 0" 
   unfolding jumpF_polyL_def by auto
     
 lemma jumpF_polyR_mult_cancel:
   assumes "p'\<noteq>0"
   shows "jumpF_polyR (p' * q) (p' * p) a = jumpF_polyR q p a"
 unfolding jumpF_polyR_def
 proof (rule jumpF_cong)
   obtain ub where "a < ub" "\<forall>z. a < z \<and> z \<le> ub \<longrightarrow> poly p' z \<noteq> 0"
     using next_non_root_interval[OF \<open>p'\<noteq>0\<close>,of a] by auto
   then show "\<forall>\<^sub>F x in at_right a. poly (p' * q) x / poly (p' * p) x = poly q x / poly p x"
     apply (unfold eventually_at_right)
     apply (intro exI[where x=ub])
     by auto
 qed simp
   
 lemma jumpF_polyL_mult_cancel:
   assumes "p'\<noteq>0"
   shows "jumpF_polyL (p' * q) (p' * p) a = jumpF_polyL q p a"
 unfolding jumpF_polyL_def
 proof (rule jumpF_cong)
   obtain lb where "lb < a" "\<forall>z. lb \<le> z \<and> z < a \<longrightarrow> poly p' z \<noteq> 0 "
     using last_non_root_interval[OF \<open>p'\<noteq>0\<close>,of a] by auto
   then show "\<forall>\<^sub>F x in at_left a. poly (p' * q) x / poly (p' * p) x = poly q x / poly p x"
     apply (unfold eventually_at_left)
     apply (intro exI[where x=lb])
     by auto
 qed simp  
       
 lemma jumpF_poly_noroot: 
   assumes "poly p a\<noteq>0"
   shows "jumpF_polyL q p a = 0" "jumpF_polyR q p a = 0" 
   subgoal unfolding jumpF_polyL_def using assms
     apply (intro jumpF_not_infinity)
     by (auto intro!:continuous_intros)  
   subgoal unfolding jumpF_polyR_def using assms
     apply (intro jumpF_not_infinity)
     by (auto intro!:continuous_intros)
   done
   
 
 lemma jumpF_polyR_coprime:
   assumes "coprime p q"
   shows "jumpF_polyR q p x = (if p \<noteq> 0 \<and> q \<noteq> 0 \<and> poly p x=0 then 
                                 if sign_r_pos p x \<longleftrightarrow> poly q x>0 then 1/2 else - 1/2 else 0)"
 proof (cases "p=0 \<or> q=0 \<or> poly p x\<noteq>0")
   case True
   then show ?thesis using jumpF_poly_noroot by fastforce
 next
   case False
   then have asm:"p\<noteq>0" "q\<noteq>0" "poly p x=0" by auto  
   then have "poly q x\<noteq>0" using assms using coprime_poly_0 by blast
   have ?thesis when "sign_r_pos p x \<longleftrightarrow> poly q x>0"
   proof -
     have "(poly p has_sgnx sgn (poly q x)) (at_right x)"
       by (metis False \<open>poly q x \<noteq> 0\<close> add.inverse_neutral has_sgnx_imp_sgnx less_not_sym 
           neg_less_iff_less poly_has_sgnx_values(2) sgn_if sign_r_pos_sgnx_iff that 
           trivial_limit_at_right_real zero_less_one)
     then have "LIM x at_right x. poly q x / poly p x :> at_top"    
       apply (subst filterlim_divide_at_bot_at_top_iff[of _ "poly q x"])
       apply (auto simp add:\<open>poly q x\<noteq>0\<close>)
       by (metis asm(3) poly_tendsto(3))
     then have "jumpF_polyR q p x = 1/2"
       unfolding jumpF_polyR_def jumpF_def by auto
     then show ?thesis using that False by auto
   qed
   moreover have ?thesis when "\<not> (sign_r_pos p x \<longleftrightarrow> poly q x>0)"
   proof -
     have "(poly p has_sgnx - sgn (poly q x)) (at_right x)"
     proof -
       have "(0::real) < 1 \<or> \<not> (1::real) < 0 \<and> sign_r_pos p x 
           \<or> (poly p has_sgnx - sgn (poly q x)) (at_right x)"
         by simp
       then show ?thesis
         by (metis (no_types) False \<open>poly q x \<noteq> 0\<close> add.inverse_inverse has_sgnx_imp_sgnx 
             neg_less_0_iff_less poly_has_sgnx_values(2) sgn_if sgn_less sign_r_pos_sgnx_iff 
             that trivial_limit_at_right_real)
     qed
     then have "LIM x at_right x. poly q x / poly p x :> at_bot"    
       apply (subst filterlim_divide_at_bot_at_top_iff[of _ "poly q x"])
       apply (auto simp add:\<open>poly q x\<noteq>0\<close>)
       by (metis asm(3) poly_tendsto(3)) 
     then have "jumpF_polyR q p x = - 1/2"
       unfolding jumpF_polyR_def jumpF_def by auto
     then show ?thesis using that False by auto  
   qed
   ultimately show ?thesis by auto
 qed
 
 lemma jumpF_polyL_coprime:
   assumes "coprime p q"
   shows "jumpF_polyL q p x = (if p \<noteq> 0 \<and> q \<noteq> 0 \<and> poly p x=0 then 
                 if even (order x p) \<longleftrightarrow> sign_r_pos p x \<longleftrightarrow> poly q x>0 then 1/2 else - 1/2 else 0)"  
 proof (cases "p=0 \<or> q=0 \<or> poly p x\<noteq>0")
   case True
   then show ?thesis using jumpF_poly_noroot by fastforce
 next  
   case False
   then have asm:"p\<noteq>0" "q\<noteq>0" "poly p x=0" by auto  
   then have "poly q x\<noteq>0" using assms using coprime_poly_0 by blast
   have ?thesis when "even (order x p) \<longleftrightarrow> sign_r_pos p x \<longleftrightarrow> poly q x>0"
   proof -
     consider (lt) "poly q x>0" | (gt) " poly q x<0" using \<open>poly q x\<noteq>0\<close> by linarith
     then have "sgnx (poly p) (at_left x) = sgn (poly q x)"
       apply cases
       subgoal using that sign_r_pos_sgnx_iff poly_sgnx_values[OF \<open>p\<noteq>0\<close>,of x]
         apply (subst poly_sgnx_left_right[OF \<open>p\<noteq>0\<close>])
         by auto
       subgoal using that sign_r_pos_sgnx_iff poly_sgnx_values[OF \<open>p\<noteq>0\<close>,of x]
         apply (subst poly_sgnx_left_right[OF \<open>p\<noteq>0\<close>])
         by auto
       done
     then have "(poly p has_sgnx sgn (poly q x)) (at_left x)"
       by (metis sgnx_able_poly(2) sgnx_able_sgnx)
     then have "LIM x at_left x. poly q x / poly p x :> at_top"    
       apply (subst filterlim_divide_at_bot_at_top_iff[of _ "poly q x"])
       apply (auto simp add:\<open>poly q x\<noteq>0\<close>)
       by (metis asm(3) poly_tendsto(2))   
     then have "jumpF_polyL q p x = 1/2"
       unfolding jumpF_polyL_def jumpF_def by auto
     then show ?thesis using that False by auto
   qed
   moreover have ?thesis when "\<not> (even (order x p) \<longleftrightarrow> sign_r_pos p x \<longleftrightarrow> poly q x>0)"
   proof -
     consider (lt) "poly q x>0" | (gt) " poly q x<0" using \<open>poly q x\<noteq>0\<close> by linarith
     then have "sgnx (poly p) (at_left x) = - sgn (poly q x)"
       apply cases
       subgoal using that sign_r_pos_sgnx_iff poly_sgnx_values[OF \<open>p\<noteq>0\<close>,of x]
         apply (subst poly_sgnx_left_right[OF \<open>p\<noteq>0\<close>])
         by auto
       subgoal using that sign_r_pos_sgnx_iff poly_sgnx_values[OF \<open>p\<noteq>0\<close>,of x]
         apply (subst poly_sgnx_left_right[OF \<open>p\<noteq>0\<close>])
         by auto
       done
     then have "(poly p has_sgnx - sgn (poly q x)) (at_left x)"
       by (metis sgnx_able_poly(2) sgnx_able_sgnx)
     then have "LIM x at_left x. poly q x / poly p x :> at_bot"    
       apply (subst filterlim_divide_at_bot_at_top_iff[of _ "poly q x"])
       apply (auto simp add:\<open>poly q x\<noteq>0\<close>)
       by (metis asm(3) poly_tendsto(2))   
     then have "jumpF_polyL q p x = - 1/2"
       unfolding jumpF_polyL_def jumpF_def by auto
     then show ?thesis using that False by auto 
   qed
   ultimately show ?thesis by auto
 qed    
     
 lemma jumpF_times:
   assumes tendsto:"(f \<longlongrightarrow> c) F" and "c\<noteq>0" "F\<noteq>bot"
   shows "jumpF (\<lambda>x. f x * g x) F = sgn c * jumpF g F"  
 proof -
   have "c>0 \<or> c<0" using \<open>c\<noteq>0\<close> by auto
   moreover have ?thesis when "c>0"
   proof -
     note filterlim_tendsto_pos_mult_at_top_iff[OF tendsto \<open>c>0\<close>,of g]
     moreover note filterlim_tendsto_pos_mult_at_bot_iff[OF tendsto \<open>c>0\<close>,of g]
     moreover have "sgn c = 1" using \<open>c>0\<close> by auto
     ultimately show ?thesis unfolding jumpF_def by auto
   qed
   moreover have ?thesis when "c<0"
   proof -
     define atbot where "atbot = filterlim g at_bot F"
     define attop where "attop = filterlim g at_top F"    
     have "jumpF (\<lambda>x. f x * g x) F = (if atbot then 1 / 2 else if attop then - 1 / 2 else 0)"
     proof -
       note filterlim_tendsto_neg_mult_at_top_iff[OF tendsto \<open>c<0\<close>,of g]
       moreover note filterlim_tendsto_neg_mult_at_bot_iff[OF tendsto \<open>c<0\<close>,of g]
       ultimately show ?thesis unfolding jumpF_def atbot_def attop_def by auto
     qed
     also have "... = - (if attop then 1 / 2 else if atbot then - 1 / 2 else 0)"
     proof -
       have False when atbot attop
         using filterlim_at_top_at_bot[OF _ _ \<open>F\<noteq>bot\<close>] that unfolding atbot_def attop_def by auto
       then show ?thesis by fastforce    
     qed
     also have "... = sgn c * jumpF g F"
       using \<open>c<0\<close> unfolding jumpF_def attop_def atbot_def by auto
     finally show ?thesis .
   qed
   ultimately show ?thesis by auto
 qed
 
   
 lemma jumpF_polyR_inverse_add:
   assumes "coprime p q"
   shows "jumpF_polyR q p x + jumpF_polyR p q x = jumpF_polyR 1 (q*p) x"
 proof (cases "p=0 \<or> q=0")
   case True
   then show ?thesis by auto
 next
   case False
   have jumpF_add:
     "jumpF_polyR q p x= jumpF_polyR 1 (q*p) x" when "poly p x=0" "coprime p q" for p q
   proof (cases "p=0")
     case True
     then show ?thesis by auto
   next
     case False
     have "poly q x\<noteq>0" using that coprime_poly_0 by blast
     then have "q\<noteq>0" by auto
     moreover have "sign_r_pos p x = (0 < poly q x) \<longleftrightarrow> sign_r_pos (q * p) x"
       using sign_r_pos_mult[OF \<open>q\<noteq>0\<close> \<open>p\<noteq>0\<close>] sign_r_pos_rec[OF \<open>q\<noteq>0\<close>] \<open>poly q x\<noteq>0\<close>
       by auto
     ultimately show ?thesis using \<open>poly p x=0\<close>  
       unfolding jumpF_polyR_coprime[OF \<open>coprime p q\<close>,of x] jumpF_polyR_coprime[of "q*p" 1 x,simplified]
       by auto
   qed
   have False when "poly p x=0" "poly q x=0" 
     using \<open>coprime p q\<close> that coprime_poly_0 by blast
   moreover have ?thesis when "poly p x=0" "poly q x\<noteq>0" 
   proof -
     have "jumpF_polyR p q x = 0" using jumpF_poly_noroot[OF \<open>poly q x\<noteq>0\<close>] by auto
     then show ?thesis using jumpF_add[OF \<open>poly p x=0\<close> \<open>coprime p q\<close>] by auto
   qed
   moreover have ?thesis when "poly p x\<noteq>0" "poly q x=0" 
   proof -
     have "jumpF_polyR q p x = 0" using jumpF_poly_noroot[OF \<open>poly p x\<noteq>0\<close>] by auto
     then show ?thesis using jumpF_add[OF \<open>poly q x=0\<close>,of p] \<open>coprime p q\<close> 
       by (simp add: ac_simps)
   qed  
   moreover have ?thesis when "poly p x\<noteq>0" "poly q x\<noteq>0" 
     by (simp add: jumpF_poly_noroot(2) that(1) that(2))
   ultimately show ?thesis by auto
 qed
 
 lemma jumpF_polyL_inverse_add:
   assumes "coprime p q"
   shows "jumpF_polyL q p x + jumpF_polyL p q x = jumpF_polyL 1 (q*p) x"  
 proof (cases "p=0 \<or> q=0")
   case True
   then show ?thesis by auto
 next
   case False
   have jumpF_add:
     "jumpF_polyL q p x= jumpF_polyL 1 (q*p) x" when "poly p x=0" "coprime p q" for p q
   proof (cases "p=0")
     case True
     then show ?thesis by auto
   next
     case False
     have "poly q x\<noteq>0" using that coprime_poly_0 by blast
     then have "q\<noteq>0" by auto
     moreover have "sign_r_pos p x = (0 < poly q x) \<longleftrightarrow> sign_r_pos (q * p) x"
       using sign_r_pos_mult[OF \<open>q\<noteq>0\<close> \<open>p\<noteq>0\<close>] sign_r_pos_rec[OF \<open>q\<noteq>0\<close>] \<open>poly q x\<noteq>0\<close>
       by auto
     moreover have "order x p = order x (q * p)" 
       by (metis \<open>poly q x \<noteq> 0\<close> add_cancel_right_left divisors_zero order_mult order_root)
     ultimately show ?thesis using \<open>poly p x=0\<close>  
       unfolding jumpF_polyL_coprime[OF \<open>coprime p q\<close>,of x] jumpF_polyL_coprime[of "q*p" 1 x,simplified]
       by auto
   qed
   have False when "poly p x=0" "poly q x=0" 
     using \<open>coprime p q\<close> that coprime_poly_0 by blast
   moreover have ?thesis when "poly p x=0" "poly q x\<noteq>0" 
   proof -
     have "jumpF_polyL p q x = 0" using jumpF_poly_noroot[OF \<open>poly q x\<noteq>0\<close>] by auto
     then show ?thesis using jumpF_add[OF \<open>poly p x=0\<close> \<open>coprime p q\<close>] by auto
   qed
   moreover have ?thesis when "poly p x\<noteq>0" "poly q x=0" 
   proof -
     have "jumpF_polyL q p x = 0" using jumpF_poly_noroot[OF \<open>poly p x\<noteq>0\<close>] by auto
     then show ?thesis using jumpF_add[OF \<open>poly q x=0\<close>,of p] \<open>coprime p q\<close> 
       by (simp add: ac_simps)
   qed  
   moreover have ?thesis when "poly p x\<noteq>0" "poly q x\<noteq>0" 
     by (simp add: jumpF_poly_noroot that(1) that(2))
   ultimately show ?thesis by auto
 qed    
   
 
 lemma jumpF_polyL_smult_1:
   "jumpF_polyL (smult c q) p x = sgn c * jumpF_polyL q p x"
 proof (cases "c=0")
   case True
   then show ?thesis by auto
 next
   case False
   then show ?thesis 
     unfolding jumpF_polyL_def 
     apply (subst jumpF_times[of "\<lambda>_. c",symmetric])
     by auto
 qed  
 
 lemma jumpF_polyR_smult_1:
   "jumpF_polyR (smult c q) p x = sgn c * jumpF_polyR q p x"
 proof (cases "c=0")
   case True
   then show ?thesis by auto
 next
   case False
   then show ?thesis
     unfolding jumpF_polyR_def using False 
     apply (subst jumpF_times[of "\<lambda>_. c",symmetric])
     by auto
 qed  
   
 
 lemma
   shows jumpF_polyR_mod:"jumpF_polyR q p x = jumpF_polyR (q mod p) p x" and
         jumpF_polyL_mod:"jumpF_polyL q p x = jumpF_polyL (q mod p) p x"
 proof -
   define f where "f=(\<lambda>x. poly (q div p) x)"
   define g where "g=(\<lambda>x. poly (q mod p) x / poly p x)"
   have jumpF_eq:"jumpF (\<lambda>x. poly q x / poly p x) (at y within S) = jumpF g (at y within S)" 
     when "p\<noteq>0" for y S
   proof -
     let ?F = "at y within S"
     have "\<forall>\<^sub>F x in at y within S. poly p x \<noteq> 0" 
       using eventually_poly_nz_at_within[OF \<open>p\<noteq>0\<close>,of y S] .
     then have "eventually (\<lambda>x. (poly q x / poly p x) = (f x+ g x)) ?F"
     proof (rule eventually_mono)
       fix x
       assume P: "poly p x \<noteq> 0"
       have "poly q x = poly (q div p * p + q mod p) x"
         by simp
       also have "\<dots> = f x * poly p x + poly (q mod p) x"
         by (simp only: poly_add poly_mult f_def g_def)
       moreover have "poly (q mod p) x = g x * poly p x"
         using P by (simp add: g_def)
       ultimately show "poly q x / poly p x = f x + g x"
         using P by simp
     qed
     then have "jumpF (\<lambda>x. poly q x / poly p x) ?F = jumpF (\<lambda>x. f x+ g x) ?F"
       by (intro jumpF_cong,auto)
     also have "... = jumpF g ?F"  
     proof -
       have "(f \<longlongrightarrow> f y) (at y within S)"
         unfolding f_def by (intro tendsto_intros)  
       from filterlim_tendsto_add_at_bot_iff[OF this,of g] filterlim_tendsto_add_at_top_iff[OF this,of g] 
       show ?thesis unfolding jumpF_def by auto
     qed
     finally show ?thesis .
   qed
   show "jumpF_polyR q p x = jumpF_polyR (q mod p) p x"
     apply (cases "p=0")
     subgoal by auto
     subgoal using jumpF_eq unfolding g_def jumpF_polyR_def by auto
     done
   show "jumpF_polyL q p x = jumpF_polyL (q mod p) p x"
     apply (cases "p=0")
     subgoal by auto
     subgoal using jumpF_eq unfolding g_def jumpF_polyL_def by auto
     done  
 qed 
 
 
 lemma jumpF_poly_top_0[simp]: "jumpF_poly_top 0 p = 0" "jumpF_poly_top q 0 = 0"
   unfolding jumpF_poly_top_def by auto
 
 lemma jumpF_poly_bot_0[simp]: "jumpF_poly_bot 0 p = 0" "jumpF_poly_bot q 0 = 0"
   unfolding jumpF_poly_bot_def by auto
 
 lemma jumpF_poly_top_code:
   "jumpF_poly_top q p = (if p\<noteq>0 \<and> q\<noteq>0 \<and> degree q>degree p then 
           if sgn_pos_inf q * sgn_pos_inf p > 0 then 1/2 else -1/2 else 0)"
 proof (cases "p\<noteq>0 \<and> q\<noteq>0 \<and> degree q>degree p")
   case True
   have ?thesis when "sgn_pos_inf q * sgn_pos_inf p > 0"
   proof -
     have "LIM x at_top. poly q x / poly p x :> at_top"
       using poly_divide_filterlim_at_top[of p q] True that by auto
     then have "jumpF (\<lambda>x. poly q x / poly p x) at_top = 1/2"
       unfolding jumpF_def by auto
     then show ?thesis unfolding jumpF_poly_top_def using that True by auto
   qed
   moreover have ?thesis when "\<not> sgn_pos_inf q * sgn_pos_inf p > 0"
   proof -
     have "LIM x at_top. poly q x / poly p x :> at_bot"
       using poly_divide_filterlim_at_top[of p q] True that by auto
     then have "jumpF (\<lambda>x. poly q x / poly p x) at_top = - 1/2"
       unfolding jumpF_def by auto
     then show ?thesis unfolding jumpF_poly_top_def using that True by auto
   qed
   ultimately show ?thesis by auto
 next
   case False
   define P where "P= (\<not> (LIM x at_top. poly q x / poly p x :> at_bot) 
                       \<and> \<not> (LIM x at_top. poly q x / poly p x :> at_top))"
   have P when "p=0 \<or> q=0"
     unfolding P_def using that 
     by (auto elim!:filterlim_at_bot_nhds filterlim_at_top_nhds)
   moreover have P when "p\<noteq>0" "q\<noteq>0" "degree p> degree q"
   proof -
     have "LIM x at_top. poly q x / poly p x :> at 0"
       using poly_divide_filterlim_at_top[OF that(1,2)] that(3) by auto
     then show ?thesis unfolding P_def 
       by (auto elim!:filterlim_at_bot_nhds filterlim_at_top_nhds simp:filterlim_at)
   qed 
   moreover have P when "p\<noteq>0" "q\<noteq>0" "degree p = degree q"
   proof -
     have "((\<lambda>x. poly q x / poly p x) \<longlongrightarrow> lead_coeff q / lead_coeff p) at_top"
       using poly_divide_filterlim_at_top[OF that(1,2)] using that by auto
     then show ?thesis unfolding P_def 
       by (auto elim!:filterlim_at_bot_nhds filterlim_at_top_nhds)
   qed
   ultimately have P using False by fastforce
   then have "jumpF (\<lambda>x. poly q x / poly p x) at_top = 0"
     unfolding jumpF_def P_def by auto
   then show ?thesis unfolding jumpF_poly_top_def using False by presburger
 qed
 
 lemma jumpF_poly_bot_code:
   "jumpF_poly_bot q p = (if p\<noteq>0 \<and> q\<noteq>0 \<and> degree q>degree p then 
           if sgn_neg_inf q * sgn_neg_inf p > 0 then 1/2 else -1/2 else 0)"
 proof (cases "p\<noteq>0 \<and> q\<noteq>0 \<and> degree q>degree p")
   case True
   have ?thesis when "sgn_neg_inf q * sgn_neg_inf p > 0"
   proof -
     have "LIM x at_bot. poly q x / poly p x :> at_top"
       using poly_divide_filterlim_at_bot[of p q] True that by auto
     then have "jumpF (\<lambda>x. poly q x / poly p x) at_bot = 1/2"
       unfolding jumpF_def by auto
     then show ?thesis unfolding jumpF_poly_bot_def using that True by auto
   qed
   moreover have ?thesis when "\<not> sgn_neg_inf q * sgn_neg_inf p > 0"
   proof -
     have "LIM x at_bot. poly q x / poly p x :> at_bot"
       using poly_divide_filterlim_at_bot[of p q] True that by auto
     then have "jumpF (\<lambda>x. poly q x / poly p x) at_bot = - 1/2"
       unfolding jumpF_def by auto
     then show ?thesis unfolding jumpF_poly_bot_def using that True by auto
   qed
   ultimately show ?thesis by auto
 next
   case False
   define P where "P= (\<not> (LIM x at_bot. poly q x / poly p x :> at_bot) 
                       \<and> \<not> (LIM x at_bot. poly q x / poly p x :> at_top))"
   have P when "p=0 \<or> q=0"
     unfolding P_def using that 
     by (auto elim!:filterlim_at_bot_nhds filterlim_at_top_nhds)
   moreover have P when "p\<noteq>0" "q\<noteq>0" "degree p> degree q"
   proof -
     have "LIM x at_bot. poly q x / poly p x :> at 0"
       using poly_divide_filterlim_at_bot[OF that(1,2)] that(3) by auto
     then show ?thesis unfolding P_def 
       by (auto elim!:filterlim_at_bot_nhds filterlim_at_top_nhds simp:filterlim_at)
   qed 
   moreover have P when "p\<noteq>0" "q\<noteq>0" "degree p = degree q"
   proof -
     have "((\<lambda>x. poly q x / poly p x) \<longlongrightarrow> lead_coeff q / lead_coeff p) at_bot"
       using poly_divide_filterlim_at_bot[OF that(1,2)] using that by auto
     then show ?thesis unfolding P_def 
       by (auto elim!:filterlim_at_bot_nhds filterlim_at_top_nhds)
   qed
   ultimately have P using False by fastforce
   then have "jumpF (\<lambda>x. poly q x / poly p x) at_bot = 0"
     unfolding jumpF_def P_def by auto
   then show ?thesis unfolding jumpF_poly_bot_def using False by presburger
 qed
   
 subsection \<open>The extended Cauchy index on polynomials\<close>
 
 definition cindex_polyE:: "real \<Rightarrow> real \<Rightarrow> real poly \<Rightarrow> real poly \<Rightarrow> real" where
   "cindex_polyE a b q p = jumpF_polyR q p a + cindex_poly a b q p - jumpF_polyL q p b"
   
 definition cindex_poly_ubd::"real poly \<Rightarrow> real poly \<Rightarrow> int" where
   "cindex_poly_ubd q p = (THE l. (\<forall>\<^sub>F r in at_top. cindexE (-r) r (\<lambda>x. poly q x/poly p x) = of_int l))"
    
 lemma cindex_polyE_0[simp]: "cindex_polyE a b 0 p = 0" "cindex_polyE a b q 0 = 0"
   unfolding cindex_polyE_def by auto
   
 lemma cindex_polyE_mult_cancel:
   fixes p q p'::"real poly"
   assumes "p'\<noteq> 0"  
   shows "cindex_polyE a b (p' * q ) (p' * p) = cindex_polyE a b q p"
   unfolding cindex_polyE_def
   using cindex_poly_mult[OF \<open>p'\<noteq>0\<close>] jumpF_polyL_mult_cancel[OF \<open>p'\<noteq>0\<close>] 
     jumpF_polyR_mult_cancel[OF \<open>p'\<noteq>0\<close>] 
   by simp
   
 lemma cindexE_eq_cindex_polyE: 
   assumes "a<b"
   shows "cindexE a b (\<lambda>x. poly q x/poly p x) = cindex_polyE a b q p"
 proof (cases "p=0 \<or> q=0")
   case True
   then show ?thesis by (auto simp add: cindexE_constI)
 next
   case False
   then have "p\<noteq>0" "q\<noteq>0" by auto
   define g where "g=gcd p q"
   define p' q' where "p'=p div g" and "q' = q div g"
   define f' where "f'=(\<lambda>x. poly q' x / poly p' x)"
   have "g\<noteq>0" using False g_def by auto  
   have pq_f:"p=g*p'" "q=g*q'" and "coprime p' q'"
     unfolding g_def p'_def q'_def 
     apply simp_all 
     using False div_gcd_coprime by blast    
   have "cindexE a b (\<lambda>x. poly q x/poly p x) = cindexE a b (\<lambda>x. poly q' x/poly p' x)" 
   proof -
     define f where "f=(\<lambda>x. poly q x / poly p x)"
     define f' where "f'=(\<lambda>x. poly q' x / poly p' x)"
     have "jumpF f (at_right x) = jumpF f' (at_right x)" for x
     proof (rule jumpF_cong)
       obtain ub where "x < ub" "\<forall>z. x < z \<and> z \<le> ub \<longrightarrow> poly g z \<noteq> 0"
         using next_non_root_interval[OF \<open>g\<noteq>0\<close>,of x] by auto
       then show "\<forall>\<^sub>F x in at_right x. f x = f' x" 
         unfolding eventually_at_right f_def f'_def pq_f
         apply (intro exI[where x=ub])
         by auto
     qed simp
     moreover have "jumpF f (at_left x) = jumpF f' (at_left x)" for x 
     proof (rule jumpF_cong)
       obtain lb where "lb < x" "\<forall>z. lb \<le> z \<and> z < x \<longrightarrow> poly g z \<noteq> 0 "
         using last_non_root_interval[OF \<open>g\<noteq>0\<close>,of x] by auto
       then show "\<forall>\<^sub>F x in at_left x. f x = f' x" 
         unfolding eventually_at_left f_def f'_def pq_f
         apply (intro exI[where x=lb])
         by auto    
     qed simp    
     ultimately show ?thesis unfolding cindexE_def
       apply (fold f_def f'_def)
       by auto
   qed
   also have "... = jumpF f' (at_right a) + real_of_int (cindex a b f') - jumpF f' (at_left b)" 
     unfolding f'_def 
     apply (rule cindex_eq_cindexE_divide)
     subgoal using \<open>a<b\<close> .
     subgoal using False poly_roots_finite pq_f(1) pq_f(2) by fastforce
     subgoal using \<open>coprime p' q'\<close> poly_gcd_iff by force
     subgoal by (auto intro:continuous_intros)
     subgoal by (auto intro:continuous_intros)
     done
   also have "... = cindex_polyE a b q' p'"
     using cindex_eq_cindex_poly unfolding cindex_polyE_def jumpF_polyR_def jumpF_polyL_def f'_def
     by auto
   also have "... = cindex_polyE a b q p"
     using cindex_polyE_mult_cancel[OF \<open>g\<noteq>0\<close>] unfolding pq_f by auto
   finally show ?thesis .
 qed
  
 lemma cindex_polyE_cross:
   fixes p::"real poly" and a b::real
   assumes "a<b" 
   shows "cindex_polyE a b 1 p = cross_alt 1 p a b / 2" 
 proof (induct "degree p" arbitrary:p rule:nat_less_induct) 
   case induct:1
   have ?case when "p=0" 
     using that unfolding cross_alt_def by auto
   moreover have ?case when "p\<noteq>0" and noroot:"{x.  a< x\<and> x< b \<and> poly p x=0 } = {}"
   proof -
     have "cindex_polyE a b 1 p = jumpF_polyR 1 p a  - jumpF_polyL 1 p b" 
     proof -
       have "cindex_poly a b 1 p = 0" unfolding cindex_poly_def
         apply (rule sum.neutral)
         using that by auto
       then show ?thesis unfolding cindex_polyE_def by auto
     qed
     also have "... = cross_alt 1 p a b / 2"  
     proof -
       define f where "f = (\<lambda>x. 1 / poly p x)"
       define ja where "ja = jumpF f (at_right a)"  
       define jb where "jb = jumpF f (at_left b)"
       define right where "right = (\<lambda>R. R ja (0::real) \<or> (continuous (at_right a) f \<and> R (poly p a) 0))"
       define left where "left = (\<lambda>R. R jb (0::real) \<or> (continuous (at_left b) f \<and> R (poly p b) 0))" 
         
       note ja_alt=jumpF_polyR_coprime[of p 1 a,unfolded jumpF_polyR_def,simplified,folded f_def ja_def]
       note jb_alt=jumpF_polyL_coprime[of p 1 b,unfolded jumpF_polyL_def,simplified,folded f_def jb_def]  
       
       have [simp]:"0 < ja \<longleftrightarrow> jumpF_polyR 1 p a = 1/2" "0 > ja \<longleftrightarrow> jumpF_polyR 1 p a = -1/2"
            "0 < jb \<longleftrightarrow> jumpF_polyL 1 p b = 1/2" "0 > jb \<longleftrightarrow> jumpF_polyL 1 p b = -1/2"
         unfolding ja_def jb_def jumpF_polyR_def jumpF_polyL_def f_def jumpF_def
         by auto           
       have [simp]: 
           "poly p a \<noteq>0 \<Longrightarrow> continuous (at_right a) f"
           "poly p b \<noteq>0 \<Longrightarrow> continuous (at_left b) f"  
         unfolding f_def by (auto intro!: continuous_intros )  
       have not_right_left: False when "(right greater \<and> left less \<or> right less \<and> left greater)"
       proof - 
         have [simp]: "f a > 0 \<longleftrightarrow> poly p a > 0" "f a < 0 \<longleftrightarrow> poly p a < 0"
              "f b > 0 \<longleftrightarrow> poly p b > 0" "f b < 0 \<longleftrightarrow> poly p b < 0" 
            unfolding f_def by auto  
         have "continuous_on {a<..<b} f" 
           unfolding f_def using noroot by (auto intro!: continuous_intros)
         then have "\<exists>x>a. x < b \<and> f x = 0" 
           apply (elim jumpF_IVT[OF \<open>a<b\<close>,of f])
           using that unfolding right_def left_def by (fold ja_def jb_def,auto)
         then show False using noroot using f_def by auto
       qed
       have ?thesis when "poly p a>0 \<and> poly p b>0 \<or> poly p a<0 \<and> poly p b<0" 
         using that jumpF_poly_noroot unfolding cross_alt_def by auto
       moreover have False when "poly p a>0 \<and> poly p b<0 \<or> poly p a<0 \<and> poly p b>0" 
         apply (rule not_right_left)
         unfolding right_def left_def using that by auto
       moreover have ?thesis when "poly p a=0" "poly p b>0 \<or> poly p b <0" 
       proof -
         have "ja>0 \<or> ja < 0" using ja_alt \<open>p\<noteq>0\<close> \<open>poly p a=0\<close> by argo
         moreover have False when "ja > 0 \<and> poly p b<0 \<or> ja < 0 \<and> poly p b>0" 
           apply (rule not_right_left)
           unfolding right_def left_def using that by fastforce
         moreover have ?thesis when "ja >0 \<and> poly p b>0 \<or> ja < 0 \<and> poly p b<0"
           using that jumpF_poly_noroot \<open>poly p a=0\<close> unfolding cross_alt_def by auto 
         ultimately show ?thesis using that jumpF_poly_noroot unfolding cross_alt_def by auto 
       qed
       moreover have ?thesis when "poly p b=0" "poly p a>0 \<or> poly p a <0" 
       proof -
         have "jb>0 \<or> jb < 0" using jb_alt \<open>p\<noteq>0\<close> \<open>poly p b=0\<close> by argo
         moreover have False when "jb > 0 \<and> poly p a<0 \<or> jb < 0 \<and> poly p a>0" 
           apply (rule not_right_left)
           unfolding right_def left_def using that by fastforce
         moreover have ?thesis when "jb >0 \<and> poly p a>0 \<or> jb < 0 \<and> poly p a<0"
           using that jumpF_poly_noroot \<open>poly p b=0\<close> unfolding cross_alt_def by auto 
         ultimately show ?thesis using that jumpF_poly_noroot unfolding cross_alt_def by auto 
       qed  
       moreover have ?thesis when "poly p a=0" "poly p b=0"
       proof -
         have "jb>0 \<or> jb < 0" using jb_alt \<open>p\<noteq>0\<close> \<open>poly p b=0\<close> by argo
         moreover have "ja>0 \<or> ja < 0" using ja_alt \<open>p\<noteq>0\<close> \<open>poly p a=0\<close> by argo
         moreover have False when "ja>0 \<and> jb<0 \<or> ja<0 \<and> jb>0"
           apply (rule not_right_left)
           unfolding right_def left_def using that by fastforce
         moreover have ?thesis when "ja>0 \<and> jb>0 \<or> ja<0 \<and> jb<0"
           using that jumpF_poly_noroot \<open>poly p b=0\<close> \<open>poly p a=0\<close> 
           unfolding cross_alt_def by auto
         ultimately show ?thesis by blast
       qed
       ultimately show ?thesis by argo
     qed
     finally show ?thesis .
   qed    
   moreover have ?case when "p\<noteq>0" and no_empty:"{x.  a< x\<and> x< b \<and> poly p x=0 } \<noteq> {}"
   proof -
     define roots where "roots\<equiv>{x.  a< x\<and> x< b \<and> poly p x=0 }"
     have "finite roots" unfolding roots_def using poly_roots_finite[OF \<open>p\<noteq>0\<close>] by auto
     define max_r where "max_r\<equiv>Max roots"
     hence "poly p max_r=0" and "a<max_r" and "max_r<b" 
       using Max_in[OF \<open>finite roots\<close>] no_empty  unfolding roots_def by auto
     define max_rp where "max_rp\<equiv>[:-max_r,1:]^order max_r p"
     then obtain p' where p'_def:"p=p'*max_rp" and "\<not> [:-max_r,1:] dvd p'"  
       by (metis \<open>p\<noteq>0\<close> mult.commute order_decomp)
     hence "p'\<noteq>0" and "max_rp\<noteq>0" and max_r_nz:"poly p' max_r\<noteq>0"(*and "poly p' a\<noteq>0" and "poly p' b\<noteq>0" *)
       (*and  "poly max_rp a\<noteq>0" and "poly max_rp b\<noteq>0"*) 
       using \<open>p\<noteq>0\<close> by (auto simp add: dvd_iff_poly_eq_0)
         
     define max_r_sign where "max_r_sign\<equiv>if odd(order max_r p) then -1 else 1::int"
     define roots' where "roots'\<equiv>{x.  a< x\<and> x< b \<and> poly p' x=0}"
   
     have "cindex_polyE a b 1 p = jumpF_polyR 1 p a + (\<Sum>x\<in>roots. jump_poly 1 p x) - jumpF_polyL 1 p b"  
       unfolding cindex_polyE_def cindex_poly_def roots_def by (simp,meson)
     also have "... = max_r_sign * cindex_poly a b 1 p' + jump_poly 1 p max_r 
         + max_r_sign * jumpF_polyR 1 p' a - jumpF_polyL 1 p' b"
     proof -
       have "(\<Sum>x\<in>roots. jump_poly 1 p x) = max_r_sign * cindex_poly a b 1 p' + jump_poly 1 p max_r"  
       proof -
         have "(\<Sum>x\<in>roots. jump_poly 1 p x)= (\<Sum>x\<in>roots'. jump_poly 1 p x)+ jump_poly 1 p max_r"
         proof -
           have "roots = insert max_r roots'" 
             unfolding roots_def roots'_def p'_def 
             using \<open>poly p max_r=0\<close> \<open>a<max_r\<close> \<open>max_r<b\<close> \<open>p\<noteq>0\<close> order_root
             apply (subst max_rp_def)
             by auto
           moreover have "finite roots'" 
             unfolding roots'_def using poly_roots_finite[OF \<open>p'\<noteq>0\<close>] by auto 
           moreover have "max_r \<notin> roots'" 
             unfolding roots'_def using max_r_nz
             by auto
           ultimately show ?thesis using sum.insert[of roots' max_r] by auto   
         qed
         moreover have "(\<Sum>x\<in>roots'. jump_poly 1 p x) = max_r_sign * cindex_poly a b 1 p'"
         proof -
           have "(\<Sum>x\<in>roots'. jump_poly 1 p x) = (\<Sum>x\<in>roots'. max_r_sign * jump_poly 1 p' x)"
           proof (rule sum.cong,rule refl)
             fix x assume "x \<in> roots'" 
             hence "x\<noteq>max_r" using max_r_nz unfolding roots'_def 
               by auto
             hence "poly max_rp x\<noteq>0" using poly_power_n_eq unfolding max_rp_def by auto
             hence "order x max_rp=0"  by (metis order_root)
             moreover have "jump_poly 1 max_rp x=0" 
               using \<open>poly max_rp x\<noteq>0\<close> by (metis jump_poly_not_root)
             moreover have "x\<in>roots"
               using \<open>x \<in> roots'\<close> unfolding roots_def roots'_def p'_def by auto
             hence "x<max_r" 
               using Max_ge[OF \<open>finite roots\<close>,of x] \<open>x\<noteq>max_r\<close> by (fold max_r_def,auto)
             hence "sign (poly max_rp x) = max_r_sign" 
               using \<open>poly max_rp x \<noteq> 0\<close> unfolding max_r_sign_def max_rp_def sign_def
               by (subst poly_power,simp add:linorder_class.not_less zero_less_power_eq)
             ultimately show "jump_poly 1 p x = max_r_sign * jump_poly 1 p' x" 
               using jump_poly_1_mult[of p' x max_rp]  unfolding p'_def 
               by (simp add: \<open>poly max_rp x \<noteq> 0\<close>)
           qed
           also have "... = max_r_sign * (\<Sum>x\<in>roots'. jump_poly 1 p' x)" 
             by (simp add: sum_distrib_left) 
           also have "... = max_r_sign * cindex_poly a b 1 p'"
             unfolding cindex_poly_def roots'_def by meson
           finally show ?thesis .
         qed
         ultimately show ?thesis by simp
       qed
       moreover have "jumpF_polyR 1 p a = max_r_sign * jumpF_polyR 1 p' a"
       proof -
         define f where "f = (\<lambda>x. 1 / poly max_rp x)"
         define g where "g = (\<lambda>x. 1 / poly p' x)"
         have "jumpF_polyR 1 p a = jumpF (\<lambda>x. f x * g x) (at_right a)"  
           unfolding jumpF_polyR_def f_def g_def p'_def 
           by (auto simp add:field_simps)
         also have "... = sgn (f a) * jumpF g (at_right a)" 
         proof (rule jumpF_times) 
           have [simp]: "poly max_rp a \<noteq>0" 
             unfolding max_rp_def using \<open>max_r>a\<close> by auto  
           show "(f \<longlongrightarrow> f a) (at_right a)" "f a \<noteq> 0"
             unfolding f_def by (auto intro:tendsto_intros)
         qed auto      
         also have "... = max_r_sign * jumpF_polyR 1 p' a"
         proof -
           have "sgn (f a) = max_r_sign" 
             unfolding max_r_sign_def f_def max_rp_def using \<open>a<max_r\<close>
             by (auto simp add:sgn_power)
           then show ?thesis unfolding jumpF_polyR_def g_def by auto
         qed
         finally show ?thesis .
       qed
       moreover have "jumpF_polyL 1 p b =  jumpF_polyL 1 p' b"
       proof -
         define f where "f = (\<lambda>x. 1 / poly max_rp x)"
         define g where "g = (\<lambda>x. 1 / poly p' x)"
         have "jumpF_polyL 1 p b = jumpF (\<lambda>x. f x * g x) (at_left b)"  
           unfolding jumpF_polyL_def f_def g_def p'_def 
           by (auto simp add:field_simps)
         also have "... = sgn (f b) * jumpF g (at_left b)" 
         proof (rule jumpF_times) 
           have [simp]: "poly max_rp b \<noteq>0" 
             unfolding max_rp_def using \<open>max_r<b\<close> by auto  
           show "(f \<longlongrightarrow> f b) (at_left b)" "f b \<noteq> 0"
             unfolding f_def by (auto intro:tendsto_intros)
         qed auto      
         also have "... = jumpF_polyL 1 p' b"
         proof -
           have "sgn (f b) = 1" 
             unfolding max_r_sign_def f_def max_rp_def using \<open>b>max_r\<close>
             by (auto simp add:sgn_power)
           then show ?thesis unfolding jumpF_polyL_def g_def by auto
         qed
         finally show ?thesis .
       qed 
       ultimately show ?thesis by auto
     qed
     also have "... = max_r_sign * cindex_polyE a b 1 p' + jump_poly 1 p max_r 
         + (max_r_sign - 1) * jumpF_polyL 1 p' b"
       unfolding cindex_polyE_def roots'_def by (auto simp add:algebra_simps)
     also have "... = max_r_sign * cross_alt 1 p' a b / 2 + jump_poly 1 p max_r 
         + (max_r_sign - 1) * jumpF_polyL 1 p' b"
     proof -
       have "degree max_rp>0" unfolding max_rp_def degree_linear_power
         using \<open>poly p max_r=0\<close> order_root \<open>p\<noteq>0\<close> by blast
       then have "degree p'<degree p" unfolding p'_def 
         using degree_mult_eq[OF \<open>p'\<noteq>0\<close> \<open>max_rp\<noteq>0\<close>] by auto
       from induct[rule_format, OF this] 
       have "cindex_polyE a b 1 p' = real_of_int (cross_alt 1 p' a b) / 2" by auto
       then show ?thesis by auto
     qed
     also have "... = real_of_int (cross_alt 1 p a b) / 2"
     proof -
       have sjump_p:"jump_poly 1 p max_r = (if odd (order max_r p) then sign (poly p' max_r) else 0)"
       proof -
         note max_r_nz 
         moreover then have "poly max_rp max_r=0" 
           using \<open>poly p max_r = 0\<close> p'_def by auto
         ultimately have "jump_poly 1 p max_r = sign (poly p' max_r) * jump_poly 1 max_rp max_r"
           unfolding p'_def using jump_poly_1_mult[of p' max_r max_rp] 
           by auto
         also have "... = (if odd (order max_r max_rp) then sign (poly p' max_r) else 0)"  
         proof -
           have "sign_r_pos max_rp max_r"
             unfolding max_rp_def using sign_r_pos_power by auto
           then show ?thesis using \<open>max_rp\<noteq>0\<close> unfolding jump_poly_def by auto
         qed
         also have "... = (if odd (order max_r p) then sign (poly p' max_r) else 0)"
         proof -
           have "order max_r p'=0" by (simp add: \<open>poly p' max_r \<noteq> 0\<close> order_0I)
           then have "order max_r max_rp = order max_r p" 
             unfolding p'_def using \<open>p'\<noteq>0\<close> \<open>max_rp\<noteq>0\<close>
             apply (subst order_mult)
             by auto  
           then show ?thesis by auto
         qed
         finally show ?thesis .
       qed
       have ?thesis when "even (order max_r p)"
       proof -
         have "sign (poly p x) =  sign (poly p' x)" when "x\<noteq>max_r" for x
         proof -
           have "sign (poly max_rp x) = 1"
             unfolding max_rp_def using \<open>even (order max_r p)\<close> that 
             apply (simp add:sign_power )
             by (simp add: Sturm_Tarski.sign_def)
           then show ?thesis unfolding p'_def by (simp add:sign_times)
         qed    
         from this[of a] this[of b] \<open>a<max_r\<close> \<open>max_r<b\<close> 
         have "cross_alt 1 p' a b = cross_alt 1 p a b" 
           unfolding cross_alt_def by auto 
         then show ?thesis using that unfolding max_r_sign_def sjump_p by auto
       qed
       moreover have ?thesis when "odd (order max_r p)" 
       proof -
         let ?thesis2 = "sign (poly p' max_r) * 2 - cross_alt 1 p' a b - 4 * jumpF_polyL 1 p' b 
               = cross_alt 1 p a b"    
         have ?thesis2 when "poly p' b=0"
         proof -
           have "jumpF_polyL 1 p' b = 1/2 \<or> jumpF_polyL 1 p' b=-1/2"  
             using jumpF_polyL_coprime[of p' 1 b,simplified] \<open>p'\<noteq>0\<close> \<open>poly p' b=0\<close> by auto
           moreover have "poly p' max_r>0 \<or> poly p' max_r<0" 
             using max_r_nz by auto
           moreover have False when "poly p' max_r>0 \<and> jumpF_polyL 1 p' b=-1/2 
                 \<or> poly p' max_r<0 \<and> jumpF_polyL 1 p' b=1/2"
           proof -
             define f where "f= (\<lambda>x. 1/ poly p' x)"
             have noroots:"poly p' x\<noteq>0" when "x\<in>{max_r<..<b}" for x
             proof (rule ccontr)
               assume " \<not> poly p' x \<noteq> 0"
               then have "poly p x =0" unfolding p'_def by auto
               then have "x\<in>roots" unfolding roots_def using that \<open>a<max_r\<close> by auto
               then have "x\<le>max_r" using Max_ge[OF \<open>finite roots\<close>] unfolding max_r_def by auto
               moreover have "x>max_r" using that by auto
               ultimately show False by auto
             qed  
             have "continuous_on {max_r<..<b} f"
               unfolding f_def using noroots by (auto intro!:continuous_intros)
             moreover have "continuous (at_right max_r) f" 
               unfolding f_def using max_r_nz
               by (auto intro!:continuous_intros)
             moreover have "f max_r>0 \<and> jumpF f (at_left b)<0 
                 \<or> f max_r<0 \<and> jumpF f (at_left b)>0"
               using that unfolding f_def jumpF_polyL_def by auto  
             ultimately have "\<exists>x>max_r. x < b \<and> f x = 0"
               apply (intro jumpF_IVT[OF \<open>max_r<b\<close>])
               by auto
             then show False using noroots unfolding f_def by auto
           qed
           moreover have ?thesis when "poly p' max_r>0 \<and> jumpF_polyL 1 p' b=1/2
               \<or> poly p' max_r<0 \<and> jumpF_polyL 1 p' b=-1/2"
           proof -
             have "poly max_rp a < 0" "poly max_rp b>0"
               unfolding max_rp_def using \<open>odd (order max_r p)\<close> \<open>a<max_r\<close> \<open>max_r<b\<close>
               by (simp_all add:zero_less_power_eq)
             then have "cross_alt 1 p a b = - cross_alt 1 p' a b" 
               unfolding cross_alt_def p'_def using \<open>poly p' b=0\<close> 
               apply (simp add:sign_times)
               by (simp add: Sturm_Tarski.sign_def)
             with that show ?thesis by auto
           qed
           ultimately show ?thesis by blast  
         qed
         moreover have ?thesis2 when "poly p' b\<noteq>0"
         proof -
           have [simp]:"jumpF_polyL 1 p' b = 0" 
             using jumpF_polyL_coprime[of p' 1 b,simplified] \<open>poly p' b\<noteq>0\<close> by auto 
           have [simp]:"poly max_rp a < 0" "poly max_rp b>0"
             unfolding max_rp_def using \<open>odd (order max_r p)\<close> \<open>a<max_r\<close> \<open>max_r<b\<close>
             by (simp_all add:zero_less_power_eq)
           have "poly p' b>0 \<or> poly p' b<0" 
             using \<open>poly p' b\<noteq>0\<close> by auto
           moreover have "poly p' max_r>0 \<or> poly p' max_r<0" 
             using max_r_nz by auto
           moreover have ?thesis when "poly p' b>0 \<and> poly p' max_r>0 "  
             using that unfolding cross_alt_def p'_def
             apply (simp add:sign_times)
             by (simp add: Sturm_Tarski.sign_def)
           moreover have ?thesis when "poly p' b<0 \<and> poly p' max_r<0"      
             using that unfolding cross_alt_def p'_def
             apply (simp add:sign_times)
             by (simp add: Sturm_Tarski.sign_def)  
           moreover have False when "poly p' b>0 \<and> poly p' max_r<0 \<or> poly p' b<0 \<and> poly p' max_r>0"
           proof -
             have "\<exists>x>max_r. x < b \<and> poly p' x = 0"
               apply (rule poly_IVT[OF \<open>max_r<b\<close>,of p'])
               using that mult_less_0_iff by blast
             then obtain x where "max_r<x" "x<b" "poly p x=0" unfolding p'_def by auto
             then have "x\<in>roots" using \<open>a<max_r\<close> unfolding roots_def by auto
             then have "x\<le>max_r" unfolding max_r_def using Max_ge[OF \<open>finite roots\<close>] by auto    
             then show False using \<open>max_r<x\<close> by auto
           qed
           ultimately show ?thesis by blast
         qed
         ultimately have ?thesis2 by auto 
         then show ?thesis unfolding max_r_sign_def sjump_p using that by simp
       qed
       ultimately show ?thesis by auto
     qed
     finally show ?thesis . 
   qed
   ultimately show ?case by fast
 qed      
      
 lemma cindex_polyE_inverse_add:
   fixes p q::"real poly" 
   assumes cp:"coprime p q"
   shows "cindex_polyE a b q p + cindex_polyE a b p q=cindex_polyE a b 1 (q*p)"
   unfolding cindex_polyE_def
   using cindex_poly_inverse_add[OF cp,symmetric] jumpF_polyR_inverse_add[OF cp,symmetric] 
     jumpF_polyL_inverse_add[OF cp,symmetric]
   by auto    
 
 lemma cindex_polyE_inverse_add_cross:
   fixes p q::"real poly"
   assumes "a < b" "coprime p q" 
   shows "cindex_polyE a b q p  + cindex_polyE a b p q = cross_alt p q a b / 2" 
   apply (subst cindex_polyE_inverse_add[OF \<open>coprime p q\<close>])
   apply (subst cindex_polyE_cross[OF \<open>a<b\<close>])
   apply (subst mult.commute)  
   apply (subst cross_alt_clear_n[OF \<open>coprime p q\<close>])
   by simp
       
 lemma cindex_polyE_smult_1: 
   fixes p q::"real poly" and c::real
   shows "cindex_polyE a b (smult c q) p =  (sgn c) * cindex_polyE a b q p"
   unfolding cindex_polyE_def jumpF_polyL_smult_1 jumpF_polyR_smult_1 cindex_poly_smult_1 
   by (auto simp add:sgn_sign_eq[symmetric] algebra_simps)    
 
 lemma cindex_polyE_mod:
   fixes p q::"real poly" 
   shows "cindex_polyE a b q p =  cindex_polyE a b (q mod p) p"
   unfolding cindex_polyE_def
   apply (subst cindex_poly_mod)
   apply (subst jumpF_polyR_mod)
   apply (subst jumpF_polyL_mod)
   by simp
 
 lemma cindex_polyE_rec:
   fixes p q::"real poly"
   assumes "a < b" "coprime p q"
   shows "cindex_polyE a b q p  = cross_alt q p a b/2  +  cindex_polyE a b (- (p mod q)) q"  
 proof -
   note cindex_polyE_inverse_add_cross[OF assms]
   moreover have "cindex_polyE a b (- (p mod q)) q = - cindex_polyE a b p q"
     using cindex_polyE_mod cindex_polyE_smult_1[of a b "-1"]
     by auto
   ultimately show ?thesis by (auto simp add:field_simps cross_alt_poly_commute)
 qed    
   
 lemma cindex_polyE_changes_alt_itv_mods: 
   assumes "a<b" "coprime p q"
   shows "cindex_polyE a b q p = changes_alt_itv_smods a b p q / 2" using \<open>coprime p q\<close>
 proof (induct "smods p q" arbitrary:p q)
   case Nil
   then have "p=0" by (metis smods_nil_eq)
   then show ?case by (simp add:changes_alt_itv_smods_def changes_alt_poly_at_def) 
 next
   case (Cons x xs)
   then have "p\<noteq>0" by auto
   have ?case when "q=0" 
     using that by (simp add:changes_alt_itv_smods_def changes_alt_poly_at_def)
   moreover have ?case when "q\<noteq>0"
   proof -
     define r where "r\<equiv>- (p mod q)"
     obtain ps where ps:"smods p q=p#q#ps" "smods q r=q#ps" and "xs=q#ps"
       unfolding r_def using \<open>q\<noteq>0\<close> \<open>p\<noteq>0\<close> \<open>x # xs = smods p q\<close> 
       by (metis list.inject smods.simps)
     from Cons.prems \<open>q \<noteq> 0\<close> have "coprime q r" 
       by (simp add: r_def ac_simps)
     then have "cindex_polyE a b r q = real_of_int (changes_alt_itv_smods a b q r) / 2"
       apply (rule_tac Cons.hyps(1))
       using ps \<open>xs=q#ps\<close> by simp_all  
     moreover have "changes_alt_itv_smods a b p q = cross_alt p q a b + changes_alt_itv_smods a b q r" 
       using changes_alt_itv_smods_rec[OF \<open>a<b\<close> \<open>coprime p q\<close>,folded r_def] .
     moreover have "cindex_polyE a b q p = real_of_int (cross_alt q p a b) / 2 + cindex_polyE a b r q"
       using cindex_polyE_rec[OF \<open>a<b\<close> \<open>coprime p q\<close>,folded r_def] .
     ultimately show ?case 
       by (auto simp add:field_simps cross_alt_poly_commute)
   qed
   ultimately show ?case by blast
 qed
   
 lemma cindex_poly_ubd_eventually:
   shows "\<forall>\<^sub>F r in at_top. cindexE (-r) r (\<lambda>x. poly q x/poly p x) = of_int (cindex_poly_ubd q p)" 
 proof -
   define f where "f=(\<lambda>x. poly q x/poly p x)"
   obtain R where R_def: "R>0" "proots p \<subseteq> {-R<..<R}"
     if "p\<noteq>0" 
   proof (cases "p=0")
     case True
     then show ?thesis using that[of 1] by auto
   next
     case False
     then have "finite (proots p)" by auto
     from finite_ball_include[OF this,of 0] 
     obtain r where "r>0" and r_ball:"proots p \<subseteq> ball 0 r"
       by auto
     have "proots p \<subseteq> {-r<..<r}"
     proof 
       fix x assume "x \<in> proots p"
       then have "x\<in>ball 0 r" using r_ball by auto
       then have "abs x<r" using mem_ball_0 by auto
       then show "x \<in> {- r<..<r}" using \<open>r>0\<close> by auto
     qed
     then show ?thesis using that[of r] False \<open>r>0\<close> by auto
   qed
   define l where "l=(if p=0  then 0 else cindex_poly (-R) R q p)"  
   define P where "P=(\<lambda>l. (\<forall>\<^sub>F r in at_top. cindexE (-r) r f = of_int l))"
   have "P l " 
   proof (cases "p=0 ")
     case True
     then show ?thesis
       unfolding P_def f_def l_def using True
       by (auto intro!: eventuallyI cindexE_constI)
   next
     case False
     have "P l" unfolding P_def
     proof (rule eventually_at_top_linorderI[of R])  
       fix r assume "R \<le> r" 
       then have "cindexE (- r) r f =  cindex_polyE (-r) r q p"
         unfolding f_def using R_def[OF \<open>p\<noteq>0\<close>] by (auto intro: cindexE_eq_cindex_polyE)
       also have "... = of_int (cindex_poly (- r) r q p)"
       proof -
         have "jumpF_polyR q p (- r) = 0"
           apply (rule jumpF_poly_noroot)
           using \<open>R\<le>r\<close> R_def[OF \<open>p\<noteq>0\<close>] by auto
         moreover have "jumpF_polyL q p r = 0"
           apply (rule jumpF_poly_noroot)
           using \<open>R\<le>r\<close> R_def[OF \<open>p\<noteq>0\<close>] by auto
         ultimately show ?thesis unfolding cindex_polyE_def by auto
       qed  
       also have "... = of_int (cindex_poly (- R) R q p)"
       proof -
         define rs where "rs={x. poly p x = 0 \<and> - r < x \<and> x < r}"
         define Rs where "Rs={x. poly p x = 0 \<and> - R < x \<and> x < R}"
         have "rs=Rs" 
           using R_def[OF \<open>p\<noteq>0\<close>] \<open>R\<le>r\<close> unfolding rs_def Rs_def by force    
         then show ?thesis
           unfolding cindex_poly_def by (fold rs_def Rs_def,auto)
       qed
       also have "... = of_int l" unfolding l_def using False by auto
       finally show "cindexE (- r) r f = real_of_int l" .
     qed
     then show ?thesis unfolding P_def by auto
   qed
   moreover have "x=l" when "P x" for x 
   proof -
     have "\<forall>\<^sub>F r in at_top. cindexE (- r) r f = real_of_int x"
          "\<forall>\<^sub>F r in at_top. cindexE (- r) r f = real_of_int l"
       using \<open>P x\<close> \<open>P l\<close> unfolding P_def by auto
     from eventually_conj[OF this] 
     have "\<forall>\<^sub>F r::real in at_top. real_of_int x = real_of_int l"
       by (elim eventually_mono,auto)
     then have "real_of_int x = real_of_int l" by auto
     then show ?thesis by simp
   qed
   ultimately have "P (THE x. P x)" using theI[of P l] by blast
   then show ?thesis unfolding P_def f_def cindex_poly_ubd_def by auto 
 qed
   
 lemma cindex_poly_ubd_0:
   assumes "p=0 \<or> q=0"
   shows "cindex_poly_ubd q p = 0"  
 proof -
   have "\<forall>\<^sub>F r in at_top. cindexE (-r) r (\<lambda>x. poly q x/poly p x) = 0"
     apply (rule eventuallyI)
     using assms by (auto intro:cindexE_constI)
   from eventually_conj[OF this cindex_poly_ubd_eventually[of q p]]
   have "\<forall>\<^sub>F r::real in at_top.  (cindex_poly_ubd q p) = (0::int)"
     apply (elim eventually_mono)
     by auto
   then show ?thesis by auto
 qed
   
 lemma cindex_poly_ubd_code:
   shows "cindex_poly_ubd q p = changes_R_smods p q"
 proof (cases "p=0")
   case True
   then show ?thesis using cindex_poly_ubd_0 by auto
 next
   case False
   define ps where "ps\<equiv>smods p q"
   have "p\<in>set ps" using ps_def \<open>p\<noteq>0\<close> by auto
   obtain lb where lb:"\<forall>p\<in>set ps. \<forall>x. poly p x=0 \<longrightarrow> x>lb"
       and lb_sgn:"\<forall>x\<le>lb. \<forall>p\<in>set ps. sgn (poly p x) = sgn_neg_inf p"
       and "lb<0"
     using root_list_lb[OF no_0_in_smods,of p q,folded ps_def] 
     by auto
   obtain ub where ub:"\<forall>p\<in>set ps. \<forall>x. poly p x=0 \<longrightarrow> x<ub"
       and ub_sgn:"\<forall>x\<ge>ub. \<forall>p\<in>set ps. sgn (poly p x) = sgn_pos_inf p"
       and "ub>0"
     using root_list_ub[OF no_0_in_smods,of p q,folded ps_def] 
     by auto
   define f where "f=(\<lambda>t. poly q t/ poly p t)"
   define P where "P=(\<lambda>l. (\<forall>\<^sub>F r in at_top. cindexE (-r) r f = of_int l))"
   have "P (changes_R_smods p q)" unfolding P_def
   proof (rule eventually_at_top_linorderI[of "max \<bar>lb\<bar> \<bar>ub\<bar> + 1"])
     fix r assume r_asm:"r\<ge>max \<bar>lb\<bar> \<bar>ub\<bar> + 1"
     have "cindexE (- r) r f =  cindex_polyE (-r) r q p"
       unfolding f_def using r_asm by (auto intro: cindexE_eq_cindex_polyE)
     also have "... = of_int (cindex_poly (- r) r q p)"
     proof -
       have "jumpF_polyR q p (- r) = 0"
         apply (rule jumpF_poly_noroot)
         using r_asm lb[rule_format,OF \<open>p\<in>set ps\<close>,of "-r"] by linarith
       moreover have "jumpF_polyL q p r = 0"
         apply (rule jumpF_poly_noroot)
         using r_asm ub[rule_format,OF \<open>p\<in>set ps\<close>,of "r"] by linarith
       ultimately show ?thesis unfolding cindex_polyE_def by auto
     qed
     also have "... = of_int (changes_itv_smods (- r) r p q)"
       apply (rule cindex_poly_changes_itv_mods[THEN arg_cong])
       using r_asm lb[rule_format,OF \<open>p\<in>set ps\<close>,of "-r"] ub[rule_format,OF \<open>p\<in>set ps\<close>,of "r"]
       by linarith+
     also have "... = of_int (changes_R_smods p q)"
     proof -
       have "map (sgn \<circ> (\<lambda>p. poly p (-r))) ps = map sgn_neg_inf ps"
           and "map (sgn \<circ> (\<lambda>p. poly p r)) ps = map sgn_pos_inf ps"
         using lb_sgn[THEN spec,of "-r",simplified] ub_sgn[THEN spec,of r,simplified] r_asm 
         by auto
       hence "changes_poly_at ps (-r)=changes_poly_neg_inf ps
           \<and> changes_poly_at ps r=changes_poly_pos_inf ps"
         unfolding changes_poly_neg_inf_def changes_poly_at_def changes_poly_pos_inf_def
         by (subst (1 3)  changes_map_sgn_eq,metis map_map)
       thus ?thesis unfolding changes_R_smods_def changes_itv_smods_def ps_def
         by metis
     qed
     finally show "cindexE (- r) r f =  of_int (changes_R_smods p q)" .
   qed
   moreover have "x = changes_R_smods p q" when "P x" for x 
   proof -
     have "\<forall>\<^sub>F r in at_top. cindexE (- r) r f = real_of_int (changes_R_smods p q)" 
         "\<forall>\<^sub>F r in at_top. cindexE (- r) r f = real_of_int x"
       using \<open>P (changes_R_smods p q)\<close> \<open>P x\<close> unfolding P_def by auto
     from eventually_conj[OF this] 
     have "\<forall>\<^sub>F (r::real) in at_top. of_int x = of_int (changes_R_smods p q)"
       by (elim eventually_mono,auto)
     then have "of_int x = of_int (changes_R_smods p q)" 
       using eventually_const_iff by auto
     then show ?thesis using of_int_eq_iff by blast
   qed
   ultimately have "(THE x. P x) = changes_R_smods p q" 
     using the_equality[of P "changes_R_smods p q"] by blast
   then show ?thesis unfolding cindex_poly_ubd_def P_def f_def by auto
 qed  
 
 
 lemma cindexE_ubd_poly: "cindexE_ubd (\<lambda>x. poly q x/poly p x) = cindex_poly_ubd q p"
 proof (cases "p=0")
   case True
   then show ?thesis using cindex_poly_ubd_0 unfolding cindexE_ubd_def 
     by auto
 next
   case False
   define mx mn where "mx = Max {x. poly p x = 0}" and "mn = Min {x. poly p x=0}"
   define rr where "rr= 1+ (max \<bar>mx\<bar> \<bar>mn\<bar>)"
   have rr:"-rr < x \<and> x< rr" when "poly p x = 0 " for x
   proof -
     have "finite {x. poly p x = 0}" using \<open>p\<noteq>0\<close> poly_roots_finite by blast
     then have "mn \<le> x" "x\<le>mx"
       using Max_ge Min_le that unfolding mn_def mx_def by simp_all
     then show ?thesis unfolding rr_def by auto
   qed
   define f where "f=(\<lambda>x. poly q x / poly p x)"
   have "\<forall>\<^sub>F r in at_top. cindexE (- r) r f = cindexE_ubd f"
   proof (rule eventually_at_top_linorderI[of rr])
     fix r assume "r\<ge>rr"
     define R1 R2 where "R1={x. jumpF f (at_right x) \<noteq> 0 \<and> - r \<le> x \<and> x < r}"
                        and "R2 = {x. jumpF f (at_right x) \<noteq> 0}"
     define L1 L2 where "L1={x. jumpF f (at_left x) \<noteq> 0 \<and> - r < x \<and> x \<le> r}"
                        and "L2={x. jumpF f (at_left x) \<noteq> 0}"
     have "R1=R2"
     proof -
       have "jumpF f (at_right x) = 0" when "\<not> (- r \<le> x \<and> x < r)" for x 
       proof -
         have "jumpF f (at_right x) = jumpF_polyR q p x"
           unfolding f_def jumpF_polyR_def by simp
         also have "... = 0"
           apply (rule jumpF_poly_noroot)
           using  that \<open>r\<ge>rr\<close> by (auto dest:rr)
         finally show ?thesis .
       qed
       then show ?thesis unfolding R1_def R2_def by blast
     qed
     moreover have "L1=L2"
     proof -
       have "jumpF f (at_left x) = 0" when "\<not> (- r < x \<and> x \<le> r)" for x 
       proof -
         have "jumpF f (at_left x) = jumpF_polyL q p x"
           unfolding f_def jumpF_polyL_def by simp
         also have "... = 0"
           apply (rule jumpF_poly_noroot)
           using that \<open>r\<ge>rr\<close> by (auto dest:rr)
         finally show ?thesis .
       qed
       then show ?thesis unfolding L1_def L2_def by blast
     qed
     ultimately show "cindexE (- r) r f = cindexE_ubd f" 
       unfolding cindexE_def cindexE_ubd_def
       apply (fold R1_def R2_def L1_def L2_def)
       by auto
   qed
   moreover have "\<forall>\<^sub>F r in at_top. cindexE (- r) r f = cindex_poly_ubd q p"
     using cindex_poly_ubd_eventually unfolding f_def by auto
   ultimately have "\<forall>\<^sub>F r in at_top. cindexE (- r) r f = cindexE_ubd f 
                           \<and> cindexE (- r) r f = cindex_poly_ubd q p"
     using eventually_conj by auto
   then have "\<forall>\<^sub>F (r::real) in at_top. cindexE_ubd f = cindex_poly_ubd q p"
     by (elim eventually_mono) auto
   then show ?thesis unfolding f_def by auto
 qed
   
 end
diff --git a/thys/DiscretePricing/CRR_Model.thy b/thys/DiscretePricing/CRR_Model.thy
--- a/thys/DiscretePricing/CRR_Model.thy
+++ b/thys/DiscretePricing/CRR_Model.thy
@@ -1,3271 +1,3252 @@
 (*  Title:      CRR_Model.thy
     Author:     Mnacho Echenim, Univ. Grenoble Alpes
 *)
 
 section \<open>The Cox Ross Rubinstein model\<close>
 
 text \<open>This section defines the Cox-Ross-Rubinstein model of a financial market, and charcterizes a risk-neutral
 probability space for this market. This, together with the proof that every derivative is attainable, permits to
 obtain a formula to explicitely compute the fair price of any derivative.\<close>
 
 theory CRR_Model imports Fair_Price
 
 begin
 
 locale CRR_hyps = prob_grw + rsk_free_asset +
   fixes stk
 assumes stocks: "stocks Mkt = {stk, risk_free_asset}"
   and stk_price: "prices Mkt stk = geom_proc"
   and S0_positive: "0 < init"
   and down_positive: "0 < d" and down_lt_up: "d < u"
   and psgt: "0 < p"
   and pslt: "p < 1"
 
 
 locale CRR_market = CRR_hyps +
   fixes G
 assumes stock_filtration:"G = stoch_proc_filt M geom_proc borel"
 
 subsection \<open>Preliminary results on the market\<close>
 
 lemma (in CRR_market) case_asset:
   assumes "asset \<in> stocks Mkt"
   shows "asset = stk \<or> asset = risk_free_asset"
 proof (rule ccontr)
   assume "\<not> (asset = stk \<or> asset = risk_free_asset)"
   hence "asset \<noteq> stk \<and> asset \<noteq> risk_free_asset" by simp
   moreover have "asset \<in> {stk, risk_free_asset}" using assms stocks by simp
   ultimately show False by auto
 qed
 
 lemma (in CRR_market)
   assumes "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
 shows bernoulli_gen_filtration: "filtration N G"
 and bernoulli_sigma_finite: "\<forall>n. sigma_finite_subalgebra N (G n)"
 proof -
   show "filtration N G"
   proof -
     have "disc_filtr M (stoch_proc_filt M geom_proc borel)"
     proof (rule stoch_proc_filt_disc_filtr)
       fix i
       show "random_variable borel (geom_proc i)"
         by (simp add: geom_rand_walk_borel_measurable)
     qed
     hence "filtration M G" using stock_filtration  by (simp add: filtration_def disc_filtr_def)
     have "filt_equiv nat_filtration M N" using pslt psgt by (simp add: assms bernoulli_stream_equiv)
     hence "sets N = sets M" unfolding filt_equiv_def by simp
     thus ?thesis unfolding filtration_def
       by (metis filtration_def \<open>Filtration.filtration M G\<close> sets_eq_imp_space_eq subalgebra_def)
   qed
   show "\<forall>n. sigma_finite_subalgebra N (G n)" using assms unfolding subalgebra_def
     using  filtration_def  subalgebra_sigma_finite
     by (metis \<open>Filtration.filtration N G\<close> bernoulli_stream_def prob_space.prob_space_stream_space
         prob_space.subalgebra_sigma_finite prob_space_measure_pmf)
 qed
 
 
 sublocale CRR_market \<subseteq> rfr_disc_equity_market  _ G
 proof (unfold_locales)
   show  "disc_filtr M G \<and> sets (G \<bottom>) = {{}, space M}"
   proof
     show "sets (G \<bottom>) = {{}, space M}" using infinite_cts_filtration.stoch_proc_filt_triv_init stock_filtration geometric_process
         geom_rand_walk_borel_adapted
       by (meson infinite_coin_toss_space_axioms infinite_cts_filtration_axioms.intro infinite_cts_filtration_def
           init_triv_filt_def)
     show "disc_filtr M G"
       by (metis Filtration.filtration_def bernoulli bernoulli_gen_filtration disc_filtr_def psgt pslt)
   qed
   show "\<forall>asset\<in>stocks Mkt. borel_adapt_stoch_proc G (prices Mkt asset)"
   proof -
     have "borel_adapt_stoch_proc G (prices Mkt stk)" using stk_price stock_filtration stoch_proc_filt_adapt
       by (simp add: stoch_proc_filt_adapt geom_rand_walk_borel_measurable)
     moreover have "borel_adapt_stoch_proc G (prices Mkt risk_free_asset)"
       using \<open>disc_filtr M G \<and> sets (G \<bottom>) = {{}, space M}\<close> disc_filtr_prob_space.disc_rfr_proc_borel_adapted
         disc_filtr_prob_space.intro disc_filtr_prob_space_axioms.intro prob_space_axioms rf_price by fastforce
     moreover have "disc_filtr_prob_space M G" proof (unfold_locales)
       show "disc_filtr M G" by (simp add: \<open>disc_filtr M G \<and> sets (G \<bottom>) = {{}, space M}\<close>)
     qed
     ultimately show ?thesis using stocks by force
   qed
 qed
 
 
 
 
 lemma (in CRR_market) two_stocks:
 shows "stk \<noteq> risk_free_asset"
 proof (rule ccontr)
   assume "\<not>stk \<noteq> risk_free_asset"
   hence "disc_rfr_proc r = prices Mkt stk" using rf_price by simp
   also have "... = geom_proc" using stk_price by simp
   finally have eqf: "disc_rfr_proc r = geom_proc" .
   hence "\<forall>w. disc_rfr_proc r 0 w = geom_proc 0 w" by simp
   hence "1 = init" using geometric_process by simp
   have eqfs: "\<forall>w. disc_rfr_proc r (Suc 0) w = geom_proc (Suc 0) w" using eqf by simp
   hence "disc_rfr_proc r (Suc 0) (sconst True) = geom_proc (Suc 0) (sconst True)" by simp
   hence "1+r = u" using geometric_process \<open>1 = init\<close> by simp
   have "disc_rfr_proc r (Suc 0) (sconst False) = geom_proc (Suc 0) (sconst False)" using eqfs by simp
   hence "1+r = d" using geometric_process \<open>1 = init\<close> by simp
   show False using \<open>1+r = u\<close> \<open>1+r = d\<close> down_lt_up by simp
 qed
 
 
 lemma (in CRR_market) stock_pf_vp_expand:
   assumes "stock_portfolio Mkt pf"
   shows "val_process Mkt pf n w = geom_proc n w * pf stk (Suc n) w +
     disc_rfr_proc r n w * pf risk_free_asset (Suc n) w"
 proof -
   have "val_process Mkt pf n w =(sum (\<lambda>x. ((prices Mkt) x n w) * (pf x (Suc n) w)) (stocks Mkt))"
   proof (rule subset_val_process')
     show "finite (stocks Mkt)" using stocks by auto
     show "support_set pf \<subseteq> stocks Mkt" using assms unfolding stock_portfolio_def by simp
   qed
   also have "... = (\<Sum>x\<in> {stk, risk_free_asset}. ((prices Mkt) x n w) * (pf x (Suc n) w))" using stocks  by simp
   also have "... =  prices Mkt stk n w * pf stk (Suc n) w +
     (\<Sum> x\<in> {risk_free_asset}. ((prices Mkt) x n w) * (pf x (Suc n) w))" by (simp add:two_stocks)
   also have "... = prices Mkt stk n w * pf stk (Suc n) w +
     prices Mkt risk_free_asset n w * pf risk_free_asset (Suc n) w" by simp
   also have "... = geom_proc n w * pf stk (Suc n) w + disc_rfr_proc r n w * pf risk_free_asset (Suc n) w"
     using rf_price stk_price by simp
   finally show ?thesis .
 qed
 
 lemma (in CRR_market) stock_pf_uvp_expand:
   assumes "stock_portfolio Mkt pf"
   shows "cls_val_process Mkt pf (Suc n) w = geom_proc (Suc n) w * pf stk (Suc n) w +
     disc_rfr_proc r (Suc n) w * pf risk_free_asset (Suc n) w"
 proof -
   have "cls_val_process Mkt pf (Suc n) w =(sum (\<lambda>x. ((prices Mkt) x (Suc n) w) * (pf x (Suc n) w)) (stocks Mkt))"
   proof (rule subset_cls_val_process')
     show "finite (stocks Mkt)" using stocks by auto
     show "support_set pf \<subseteq> stocks Mkt" using assms unfolding stock_portfolio_def by simp
   qed
   also have "... = (\<Sum>x\<in> {stk, risk_free_asset}. ((prices Mkt) x (Suc n) w) * (pf x (Suc n) w))" using  stocks by simp
   also have "... =  prices Mkt stk (Suc n) w * pf stk (Suc n) w +
     (\<Sum> x\<in> {risk_free_asset}. ((prices Mkt) x (Suc n) w) * (pf x (Suc n) w))" by (simp add:two_stocks)
   also have "... = prices Mkt stk (Suc n) w * pf stk (Suc n) w +
     prices Mkt risk_free_asset (Suc n) w * pf risk_free_asset (Suc n) w" by simp
   also have "... = geom_proc (Suc n) w * pf stk (Suc n) w + disc_rfr_proc r (Suc n) w * pf risk_free_asset (Suc n) w"
     using rf_price stk_price by simp
   finally show ?thesis .
 qed
 
 
 
 lemma (in CRR_market) pos_pf_neg_uvp:
   assumes "stock_portfolio Mkt pf"
   and "d < 1+r"
   and "0 < pf stk (Suc n) (spick w n False)"
   and "val_process Mkt pf n (spick w n False) \<le> 0"
 shows "cls_val_process Mkt pf (Suc n) (spick w n False) < 0"
 proof -
   define wnf where "wnf = spick w n False"
   have "cls_val_process Mkt pf (Suc n) (spick w n False) =
     geom_proc (Suc n) wnf * pf stk (Suc n) wnf +
     disc_rfr_proc r (Suc n) wnf * pf risk_free_asset (Suc n) wnf" unfolding wnf_def
     using assms by (simp add:stock_pf_uvp_expand)
   also have "... = d * geom_proc n wnf * pf stk (Suc n) wnf + disc_rfr_proc r (Suc n) wnf * pf risk_free_asset (Suc n) wnf"
     unfolding wnf_def using geometric_process spickI[of n w False] by simp
   also have "... = d * geom_proc n wnf * pf stk (Suc n) wnf + (1+r) * disc_rfr_proc r n wnf * pf risk_free_asset (Suc n) wnf"
     by simp
   also have "... < (1+r) * geom_proc n wnf * pf stk (Suc n) wnf + (1+r) * disc_rfr_proc r n wnf * pf risk_free_asset (Suc n) wnf"
     unfolding wnf_def using assms geom_rand_walk_strictly_positive S0_positive
       down_positive down_lt_up by simp
   also have "... = (1+r) * (geom_proc n wnf * pf stk (Suc n) wnf + disc_rfr_proc r n wnf * pf risk_free_asset (Suc n) wnf)"
     by (simp add: distrib_left)
   also have "... = (1+r) * val_process Mkt pf n wnf" using stock_pf_vp_expand assms by simp
   also have "... \<le> 0"
   proof -
     have "0 < 1+r" using assms down_positive by simp
     moreover have "val_process Mkt pf n wnf \<le> 0" using assms unfolding wnf_def by simp
     ultimately show "(1+r) * (val_process Mkt pf n wnf) \<le>  0" unfolding wnf_def
       using less_eq_real_def[of 0 "1+r"] mult_nonneg_nonpos[of "1+r" "val_process Mkt pf n (spick w n False)"] by simp
   qed
   finally show ?thesis .
 qed
 
 
 lemma (in CRR_market) neg_pf_neg_uvp:
   assumes "stock_portfolio Mkt pf"
   and "1+r < u"
   and "pf stk (Suc n) (spick w n True) < 0"
   and "val_process Mkt pf n (spick w n True) \<le> 0"
 shows "cls_val_process Mkt pf (Suc n) (spick w n True) < 0"
 proof -
   define wnf where "wnf = spick w n True"
   have "cls_val_process Mkt pf (Suc n) (spick w n True) =
     geom_proc (Suc n) wnf * pf stk (Suc n) wnf +
     disc_rfr_proc r (Suc n) wnf * pf risk_free_asset (Suc n) wnf" unfolding wnf_def
     using assms by (simp add:stock_pf_uvp_expand)
   also have "... = u * geom_proc n wnf * pf stk (Suc n) wnf + disc_rfr_proc r (Suc n) wnf * pf risk_free_asset (Suc n) wnf"
     unfolding wnf_def using geometric_process spickI[of n w True] by simp
   also have "... = u * geom_proc n wnf * pf stk (Suc n) wnf + (1+r) * disc_rfr_proc r n wnf * pf risk_free_asset (Suc n) wnf"
     by simp
   also have "... < (1+r) * geom_proc n wnf * pf stk (Suc n) wnf + (1+r) * disc_rfr_proc r n wnf * pf risk_free_asset (Suc n) wnf"
     unfolding wnf_def using assms geom_rand_walk_strictly_positive S0_positive
       down_positive down_lt_up by simp
   also have "... = (1+r) * (geom_proc n wnf * pf stk (Suc n) wnf + disc_rfr_proc r n wnf * pf risk_free_asset (Suc n) wnf)"
     by (simp add: distrib_left)
   also have "... = (1+r) * val_process Mkt pf n wnf" using stock_pf_vp_expand assms by simp
   also have "... \<le> 0"
   proof -
     have "0 < 1+r" using acceptable_rate by simp
     moreover have "val_process Mkt pf n wnf \<le> 0" using assms unfolding wnf_def by simp
     ultimately show "(1+r) * (val_process Mkt pf n wnf) \<le>  0" unfolding wnf_def
       using less_eq_real_def[of 0 "1+r"] mult_nonneg_nonpos[of "1+r" "val_process Mkt pf n (spick w n True)"] by simp
   qed
   finally show ?thesis .
 qed
 
 
 
 
 lemma (in CRR_market) zero_pf_neg_uvp:
   assumes "stock_portfolio Mkt pf"
   and "pf stk (Suc n) w = 0"
   and "pf risk_free_asset (Suc n) w \<noteq> 0"
   and "val_process Mkt pf n w \<le> 0"
 shows "cls_val_process Mkt pf (Suc n) w < 0"
 proof -
   have "cls_val_process Mkt pf (Suc n) w =
     S (Suc n) w * pf stk (Suc n) w +
     disc_rfr_proc r (Suc n) w * pf risk_free_asset (Suc n) w"
     using assms by (simp add:stock_pf_uvp_expand)
   also have "... = disc_rfr_proc r (Suc n) w * pf risk_free_asset (Suc n) w" using assms by simp
   also have "... = (1+r) * disc_rfr_proc r n w * pf risk_free_asset (Suc n) w" by simp
   also have "... < 0"
   proof -
     have "0 < 1+r" using acceptable_rate by simp
     moreover have "0 < disc_rfr_proc r n w" using acceptable_rate by (simp add: disc_rfr_proc_positive)
     ultimately have "0 < (1+r) * disc_rfr_proc r n w" by simp
     have 1: "0< pf risk_free_asset (Suc n) w \<longrightarrow> 0 <(1+r) * disc_rfr_proc r n w * pf risk_free_asset (Suc n) w"
     proof (intro impI)
       assume "0 < pf risk_free_asset (Suc n) w"
       thus "0 < (1 + r) * disc_rfr_proc r n w * pf risk_free_asset (Suc n) w" using \<open>0 < (1+r) * disc_rfr_proc r n w\<close>
         by simp
     qed
     have 2: "pf risk_free_asset (Suc n) w < 0 \<longrightarrow> (1+r) * disc_rfr_proc r n w * pf risk_free_asset (Suc n) w < 0"
     proof (intro impI)
       assume "pf risk_free_asset (Suc n) w < 0"
       thus "(1 + r) * disc_rfr_proc r n w * pf risk_free_asset (Suc n) w < 0" using \<open>0 < (1+r) * disc_rfr_proc r n w\<close>
         by (simp add:mult_pos_neg)
     qed
     have "0 \<ge> val_process Mkt pf n w" using assms by simp
     also have "val_process Mkt pf n w = geom_proc n w * pf stk (Suc n) w +
       disc_rfr_proc r n w * pf risk_free_asset (Suc n) w" using assms by (simp add:stock_pf_vp_expand)
     also have "... = disc_rfr_proc r n w * pf risk_free_asset (Suc n) w" using assms by simp
     finally have "0\<ge> disc_rfr_proc r n w * pf risk_free_asset (Suc n) w" .
     have "0< pf risk_free_asset (Suc n) w \<or> pf risk_free_asset (Suc n) w < 0"  using assms
        by linarith
     thus ?thesis
       using "2" \<open>0 < disc_rfr_proc r n w\<close> \<open>disc_rfr_proc r n w * pf risk_free_asset (Suc n) w \<le> 0\<close>
         mult_pos_pos by fastforce
   qed
   finally show ?thesis .
 qed
 
 
 
 lemma (in CRR_market) neg_pf_exists:
   assumes "stock_portfolio Mkt pf"
   and "trading_strategy pf"
   and "1+r < u"
   and "d < 1+r"
   and "val_process Mkt pf n w \<le> 0"
   and "pf stk (Suc n) w \<noteq> 0 \<or> pf risk_free_asset (Suc n) w \<noteq> 0"
 shows "\<exists>y. cls_val_process Mkt pf (Suc n) y < 0"
 proof -
   have "borel_predict_stoch_proc G (pf stk)"
   proof (rule inc_predict_support_trading_strat')
     show "trading_strategy pf" using assms by simp
     show "stk \<in> support_set pf \<union> {stk}" by simp
   qed
   hence "pf stk (Suc n) \<in> borel_measurable (G n)" unfolding predict_stoch_proc_def by simp
   have "val_process Mkt pf n \<in> borel_measurable (G n)"
   proof -
     have "borel_adapt_stoch_proc G (val_process Mkt pf)" using assms
       using support_adapt_def ats_val_process_adapted readable unfolding  stock_portfolio_def by blast
     thus ?thesis unfolding adapt_stoch_proc_def by simp
   qed
   define wn where "wn = pseudo_proj_True n w"
   show ?thesis
   proof (cases "pf stk (Suc n) w \<noteq> 0")
     case True
     show ?thesis
     proof (cases "pf stk (Suc n) w > 0")
       case True
       have "0 <pf stk (Suc n) (spick wn n False)"
       proof -
         have "0 < pf stk (Suc n) w" using \<open>0 < pf stk (Suc n) w\<close> by simp
         also have "... = pf stk (Suc n) wn" unfolding wn_def
           using \<open>pf stk (Suc n) \<in> borel_measurable (G n)\<close> stoch_proc_subalg_nat_filt[of geom_proc] geometric_process
           nat_filtration_info stock_filtration
           by (metis comp_apply geom_rand_walk_borel_adapted measurable_from_subalg)
         also have "... = pf stk (Suc n) (spick wn n False)" using \<open>pf stk (Suc n) \<in> borel_measurable (G n)\<close> comp_def nat_filtration_info
               pseudo_proj_True_stake_image spickI stoch_proc_subalg_nat_filt[of geom_proc] geometric_process stock_filtration
           by (metis geom_rand_walk_borel_adapted measurable_from_subalg)
         finally show ?thesis .
       qed
       moreover have "0 \<ge> val_process Mkt pf n (spick wn n False)"
       proof -
         have "0 \<ge> val_process Mkt pf n w" using assms by simp
         also have "val_process Mkt pf n w = val_process Mkt pf n wn" unfolding wn_def using \<open>val_process Mkt pf n \<in> borel_measurable (G n)\<close>
           nat_filtration_info stoch_proc_subalg_nat_filt[of geom_proc] geometric_process
           stock_filtration by (metis comp_apply geom_rand_walk_borel_adapted measurable_from_subalg)
         also have "... = val_process Mkt pf n (spick wn n False)" using \<open>val_process Mkt pf n \<in> borel_measurable (G n)\<close>
           comp_def nat_filtration_info
               pseudo_proj_True_stake_image spickI stoch_proc_subalg_nat_filt[of geom_proc] geometric_process stock_filtration
           by (metis geom_rand_walk_borel_adapted measurable_from_subalg)
         finally show ?thesis .
       qed
       ultimately have "cls_val_process Mkt pf (Suc n) (spick wn n False) < 0" using assms
         by (simp add:pos_pf_neg_uvp)
       thus "\<exists>y. cls_val_process Mkt pf (Suc n) y < 0" by auto
     next
       case False
       have "0 >pf stk (Suc n) (spick wn n True)"
       proof -
         have "0 > pf stk (Suc n) w" using \<open>\<not> 0 < pf stk (Suc n) w\<close> \<open>pf stk (Suc n) w \<noteq> 0\<close> by simp
         also have "pf stk (Suc n) w = pf stk (Suc n) wn" unfolding wn_def using \<open>pf stk (Suc n) \<in> borel_measurable (G n)\<close>
           nat_filtration_info stoch_proc_subalg_nat_filt[of geom_proc] geometric_process
           stock_filtration by (metis comp_apply geom_rand_walk_borel_adapted measurable_from_subalg)
         also have "... = pf stk (Suc n) (spick wn n True)" using \<open>pf stk (Suc n) \<in> borel_measurable (G n)\<close>
           comp_def nat_filtration_info
               pseudo_proj_True_stake_image spickI stoch_proc_subalg_nat_filt[of geom_proc] geometric_process stock_filtration
           by (metis geom_rand_walk_borel_adapted measurable_from_subalg)
         finally show ?thesis .
       qed
       moreover have "0 \<ge> val_process Mkt pf n (spick wn n True)"
       proof -
         have "0 \<ge> val_process Mkt pf n w" using assms by simp
         also have "val_process Mkt pf n w = val_process Mkt pf n wn" unfolding wn_def using \<open>val_process Mkt pf n \<in> borel_measurable (G n)\<close>
           comp_def nat_filtration_info
               pseudo_proj_True_stake_image spickI stoch_proc_subalg_nat_filt[of geom_proc] geometric_process stock_filtration
           by (metis geom_rand_walk_borel_adapted measurable_from_subalg)
         also have "... = val_process Mkt pf n (spick wn n True)" using \<open>val_process Mkt pf n \<in> borel_measurable (G n)\<close>
           comp_def nat_filtration_info
               pseudo_proj_True_stake_image spickI stoch_proc_subalg_nat_filt[of geom_proc] geometric_process stock_filtration
           by (metis geom_rand_walk_borel_adapted measurable_from_subalg)
         finally show ?thesis .
       qed
       ultimately have "cls_val_process Mkt pf (Suc n) (spick wn n True) < 0" using assms
         by (simp add:neg_pf_neg_uvp)
       thus "\<exists>y. cls_val_process Mkt pf (Suc n) y < 0" by auto
     qed
   next
     case False
     hence "pf risk_free_asset (Suc n) w \<noteq> 0" using assms by simp
     hence "cls_val_process Mkt pf (Suc n) w < 0" using False assms by (auto simp add:zero_pf_neg_uvp)
     thus "\<exists>y. cls_val_process Mkt pf (Suc n) y < 0" by auto
   qed
 qed
 
 
 lemma (in CRR_market) non_zero_components:
 assumes "val_process Mkt pf n y \<noteq> 0"
 and "stock_portfolio Mkt pf"
 shows  "pf stk (Suc n) y \<noteq> 0 \<or> pf risk_free_asset (Suc n) y \<noteq> 0"
 proof (rule ccontr)
   assume "\<not>(pf stk (Suc n) y \<noteq> 0 \<or> pf risk_free_asset (Suc n) y \<noteq> 0)"
   hence "pf stk (Suc n) y = 0" "pf risk_free_asset (Suc n) y = 0" by auto
   have "val_process Mkt pf n y = geom_proc n y * pf stk (Suc n) y +
     disc_rfr_proc r n y * pf risk_free_asset (Suc n) y" using \<open>stock_portfolio Mkt pf\<close>
     stock_pf_vp_expand[of pf n]  by simp
   also have "... = 0" using \<open>pf stk (Suc n) y = 0\<close> \<open>pf risk_free_asset (Suc n) y = 0\<close> by simp
   finally have "val_process Mkt pf n y = 0" .
   moreover have "val_process Mkt pf n y \<noteq> 0" using assms by simp
   ultimately show False by simp
 qed
 
 lemma (in CRR_market) neg_pf_Suc:
   assumes "stock_portfolio Mkt pf"
   and "trading_strategy pf"
   and "self_financing Mkt pf"
   and "1+r < u"
   and "d < 1+r"
   and "cls_val_process Mkt pf n w < 0"
 shows "n \<le> m \<Longrightarrow> \<exists>y. cls_val_process Mkt pf m y < 0"
 proof (induct m)
   case 0
   assume "n \<le> 0"
   hence "n=0" by simp
   thus "\<exists>y. cls_val_process Mkt pf 0 y < 0" using assms by auto
 next
   case (Suc m)
   assume "n \<le> Suc m"
   thus "\<exists>y. cls_val_process Mkt pf (Suc m) y < 0"
   proof (cases "n < Suc m")
     case False
     hence "n = Suc m" using \<open>n \<le> Suc m\<close> by simp
     thus "\<exists>y. cls_val_process Mkt pf (Suc m) y < 0" using assms by auto
   next
     case True
     hence "n \<le> m" by simp
     hence "\<exists>y. cls_val_process Mkt pf m y < 0" using Suc by simp
     from this obtain y where "cls_val_process Mkt pf m y < 0" by auto
     hence "val_process Mkt pf m y < 0" using assms by (simp add:self_financingE)
     hence "val_process Mkt pf m y \<le> 0" by simp
     have "val_process Mkt pf m y \<noteq> 0" using \<open>val_process Mkt pf m y < 0\<close> by simp
     hence "pf stk (Suc m) y \<noteq> 0 \<or> pf risk_free_asset (Suc m) y \<noteq> 0" using assms non_zero_components by simp
     thus "\<exists>y. cls_val_process Mkt pf (Suc m) y < 0" using neg_pf_exists[of pf m y] assms
       \<open>val_process Mkt pf m y \<le> 0\<close> by simp
   qed
 qed
 
 
 
 
 lemma (in CRR_market) viable_if:
   assumes "1+r < u"
   and "d < 1+r"
 shows "viable_market Mkt" unfolding viable_market_def
 proof (rule ccontr)
   assume "\<not>(\<forall>p. stock_portfolio Mkt p \<longrightarrow> \<not> arbitrage_process Mkt p)"
   hence "\<exists>p. stock_portfolio Mkt p \<and> arbitrage_process Mkt p" by simp
   from this obtain pf where "stock_portfolio Mkt pf" and "arbitrage_process Mkt pf" by auto
   have "(\<exists> m. (self_financing Mkt pf) \<and> (trading_strategy pf) \<and>
     (\<forall>w \<in> space M. cls_val_process Mkt pf 0 w = 0) \<and>
     (AE w in M. 0 \<le> cls_val_process Mkt pf m w) \<and>
     0 < \<P>(w in M. cls_val_process Mkt pf m w > 0))" using \<open>arbitrage_process Mkt pf\<close>
     using arbitrage_processE by simp
   from this obtain m where "self_financing Mkt pf" and "(trading_strategy pf)"
     and "(\<forall>w \<in> space M. cls_val_process Mkt pf 0 w = 0)"
     and "(AE w in M. 0 \<le> cls_val_process Mkt pf m w)"
     and "0 < \<P>(w in M. cls_val_process Mkt pf m w > 0)" by auto
   have "{w\<in> space M. cls_val_process Mkt pf m w > 0} \<noteq> {}" using
     \<open>0 < \<P>(w in M. cls_val_process Mkt pf m w > 0)\<close> by force
   hence "\<exists>w\<in> space M. cls_val_process Mkt pf m w > 0" by auto
   from this obtain y where "y\<in> space M" and "cls_val_process Mkt pf m y > 0" by auto
   define A where "A = {n::nat. n \<le> m \<and> cls_val_process Mkt pf n y > 0}"
   have "finite A" unfolding A_def by auto
   have "m \<in> A" using \<open>cls_val_process Mkt pf m y > 0\<close> unfolding A_def by simp
   hence "A \<noteq> {}" by auto
   hence "Min A \<in> A" using \<open>finite A\<close> by simp
   have "Min A \<le> m" using \<open>finite A\<close> \<open>m\<in> A\<close> by simp
   have "0 < Min A"
   proof -
     have "cls_val_process Mkt pf 0 y = 0" using \<open>y\<in> space M\<close> \<open>\<forall>w \<in> space M. cls_val_process Mkt pf 0 w = 0\<close>
       by simp
     hence "0\<notin> A" unfolding A_def by simp
     moreover have "0 \<le> Min A" by simp
     ultimately show ?thesis using \<open>Min A \<in> A\<close> neq0_conv by fastforce
   qed
   hence "\<exists>l. Suc l = Min A" using Suc_diff_1 by blast
   from this obtain l where "Suc l = Min A" by auto
   have "cls_val_process Mkt pf l y \<le> 0"
   proof -
     have "l < Min A" using \<open>Suc l = Min A\<close> by simp
     hence "l\<notin> A" using \<open>finite A\<close> \<open>A \<noteq> {}\<close> by auto
     moreover have "l \<le> m" using \<open>Suc l = Min A\<close> \<open>m\<in> A\<close> \<open>finite A\<close> \<open>A \<noteq> {}\<close> \<open>l < Min A\<close> by auto
     ultimately show ?thesis unfolding A_def by auto
   qed
   hence "val_process Mkt pf l y \<le> 0" using \<open>self_financing Mkt pf\<close> by (simp add:self_financingE)
   moreover have "pf stk (Suc l) y \<noteq> 0 \<or> pf risk_free_asset (Suc l) y \<noteq> 0"
   proof (rule ccontr)
     assume "\<not>(pf stk (Suc l) y \<noteq> 0 \<or> pf risk_free_asset (Suc l) y \<noteq> 0)"
     hence "pf stk (Suc l) y = 0" "pf risk_free_asset (Suc l) y = 0" by auto
     have "cls_val_process Mkt pf (Min A) y = geom_proc (Suc l) y * pf stk (Suc l) y +
       disc_rfr_proc r (Suc l) y * pf risk_free_asset (Suc l) y" using \<open>stock_portfolio Mkt pf\<close>
       \<open>Suc l = Min A\<close> stock_pf_uvp_expand[of pf l]  by simp
     also have "... = 0" using \<open>pf stk (Suc l) y = 0\<close> \<open>pf risk_free_asset (Suc l) y = 0\<close> by simp
     finally have "cls_val_process Mkt pf (Min A) y = 0" .
     moreover have "cls_val_process Mkt pf (Min A) y > 0" using \<open>Min A \<in> A\<close> unfolding A_def by simp
     ultimately show False by simp
   qed
   ultimately have "\<exists>z. cls_val_process Mkt pf (Suc l) z < 0" using assms \<open>stock_portfolio Mkt pf\<close>
     \<open>trading_strategy pf\<close> by (simp add:neg_pf_exists)
   from this obtain z where "cls_val_process Mkt pf (Suc l) z < 0" by auto
   hence "\<exists>x'. cls_val_process Mkt pf m x' < 0" using neg_pf_Suc assms \<open>trading_strategy pf\<close>
       \<open>self_financing Mkt pf\<close> \<open>Suc l = Min A\<close> \<open>Min A \<le> m\<close> \<open>stock_portfolio Mkt pf\<close> by simp
   from this obtain x' where "cls_val_process Mkt pf m x' < 0" by auto
   have "x'\<in> space M" using bernoulli_stream_space bernoulli by auto
   hence "x'\<in> {w\<in> space M. \<not>0 \<le> cls_val_process Mkt pf m w}" using \<open>cls_val_process Mkt pf m x' < 0\<close> by auto
   from \<open>AE w in M. 0 \<le> cls_val_process Mkt pf m w\<close> obtain N where
     "{w\<in> space M. \<not>0 \<le> cls_val_process Mkt pf m w} \<subseteq> N" and "emeasure M N = 0" and "N\<in> sets M" using AE_E by auto
   have "{w\<in> space M. (stake m w = stake m x')} \<subseteq> N"
   proof
     fix x
     assume "x \<in> {w \<in> space M. stake m w = stake m x'}"
     hence "x\<in> space M" and "stake m x = stake m x'" by auto
     have "cls_val_process Mkt pf m \<in> borel_measurable (G m)"
     proof -
       have "borel_adapt_stoch_proc G (cls_val_process Mkt pf)" using \<open>trading_strategy pf\<close> \<open>stock_portfolio Mkt pf\<close>
         by (meson support_adapt_def readable  stock_portfolio_def subsetCE cls_val_process_adapted)
       thus ?thesis unfolding adapt_stoch_proc_def by simp
     qed
     hence "cls_val_process Mkt pf m x' = cls_val_process Mkt pf m x"
       using  \<open>stake m x = stake m x'\<close> borel_measurable_stake[of "cls_val_process Mkt pf m" m x x']
       pseudo_proj_True_stake_image spickI stoch_proc_subalg_nat_filt[of geom_proc] geometric_process stock_filtration
           by (metis geom_rand_walk_borel_adapted measurable_from_subalg)
     hence "cls_val_process Mkt pf m x < 0" using \<open>cls_val_process Mkt pf m x' < 0\<close> by simp
     thus "x\<in> N" using \<open>{w\<in> space M. \<not>0 \<le> cls_val_process Mkt pf m w} \<subseteq> N\<close> \<open>x\<in> space M\<close>
       \<open>cls_val_process Mkt pf (Suc l) z < 0\<close> by auto
   qed
   moreover have "emeasure M {w\<in> space M. (stake m w = stake m x')} \<noteq> 0" using bernoulli_stream_pref_prob_neq_zero psgt pslt by simp
   ultimately show False using \<open>emeasure M N = 0\<close> \<open>N \<in> events\<close> emeasure_eq_0 by blast
 qed
 
 
 lemma (in CRR_market) viable_only_if_d:
   assumes "viable_market Mkt"
   shows "d < 1+r"
 proof (rule ccontr)
   assume "\<not> d < 1+r"
   hence "1+r \<le> d" by simp
   define arb_pf where "arb_pf = (\<lambda> (x::'a) (n::nat) w. 0::real)(stk:= (\<lambda> n w. 1), risk_free_asset := (\<lambda> n w. - geom_proc 0 w))"
   have "support_set arb_pf = {stk, risk_free_asset}"
   proof
     show "support_set arb_pf \<subseteq> {stk, risk_free_asset}"
       by (simp add: arb_pf_def subset_iff support_set_def)
     have "stk\<in> support_set arb_pf" unfolding arb_pf_def support_set_def using two_stocks by simp
     moreover have "risk_free_asset\<in> support_set arb_pf" unfolding arb_pf_def support_set_def
       using two_stocks geometric_process S0_positive by simp
     ultimately show "{stk, risk_free_asset}\<subseteq> support_set arb_pf" by simp
   qed
   hence "stock_portfolio Mkt arb_pf" using stocks
     by (simp add: portfolio_def stock_portfolio_def)
   have "arbitrage_process Mkt arb_pf"
   proof (rule arbitrage_processI, intro exI conjI)
     show "self_financing Mkt arb_pf" unfolding arb_pf_def using \<open>support_set arb_pf = {stk, risk_free_asset}\<close>
       by (simp add: static_portfolio_self_financing)
     show "trading_strategy arb_pf" unfolding trading_strategy_def
     proof (intro conjI ballI)
       show "portfolio arb_pf" unfolding portfolio_def using \<open>support_set arb_pf = {stk, risk_free_asset}\<close> by simp
       fix asset
       assume "asset\<in> support_set arb_pf"
       show "borel_predict_stoch_proc G (arb_pf asset)"
       proof (cases "asset = stk")
         case True
         hence "arb_pf asset = (\<lambda> n w. 1)" unfolding arb_pf_def by (simp add: two_stocks)
         show ?thesis unfolding predict_stoch_proc_def
         proof
           show "arb_pf asset 0 \<in> borel_measurable (G 0)" using \<open>arb_pf asset = (\<lambda> n w. 1)\<close> by simp
           show "\<forall>n. arb_pf asset (Suc n) \<in> borel_measurable (G n)"
           proof
             fix n
             show "arb_pf asset (Suc n) \<in> borel_measurable (G n)" using \<open>arb_pf asset = (\<lambda> n w. 1)\<close> by simp
           qed
         qed
       next
         case False
         hence "arb_pf asset = (\<lambda> n w. - geom_proc 0 w)" using \<open>support_set arb_pf = {stk, risk_free_asset}\<close>
           \<open>asset \<in> support_set arb_pf\<close> unfolding arb_pf_def by simp
         show ?thesis unfolding predict_stoch_proc_def
         proof
           show "arb_pf asset 0 \<in> borel_measurable (G 0)" using \<open>arb_pf asset = (\<lambda> n w. - geom_proc 0 w)\<close>
             geometric_process by simp
           show "\<forall>n. arb_pf asset (Suc n) \<in> borel_measurable (G n)"
           proof
             fix n
             show "arb_pf asset (Suc n) \<in> borel_measurable (G n)" using \<open>arb_pf asset = (\<lambda> n w. - geom_proc 0 w)\<close>
               geometric_process by simp
           qed
         qed
       qed
     qed
     show "\<forall>w\<in>space M. cls_val_process Mkt arb_pf 0 w = 0"
     proof
       fix w
       assume "w\<in> space M"
       have "cls_val_process Mkt arb_pf 0 w = geom_proc 0 w * arb_pf stk (Suc 0) w +
         disc_rfr_proc r 0 w * arb_pf risk_free_asset (Suc 0) w" using stock_pf_vp_expand
         \<open>stock_portfolio Mkt arb_pf\<close>
         using \<open>self_financing Mkt arb_pf\<close> self_financingE by fastforce
       also have "... = geom_proc 0 w * (1) + disc_rfr_proc r 0 w * arb_pf risk_free_asset (Suc 0) w"
         by (simp add: arb_pf_def two_stocks)
       also have "... = geom_proc 0 w + arb_pf risk_free_asset (Suc 0) w" by simp
       also have "... = geom_proc 0 w  - geom_proc 0 w" unfolding arb_pf_def by simp
       also have "... = 0" by simp
       finally show "cls_val_process Mkt arb_pf 0 w = 0" .
     qed
     have dev: "\<forall>w\<in> space M. cls_val_process Mkt arb_pf (Suc 0) w = geom_proc (Suc 0) w - (1+r) * geom_proc 0 w"
     proof (intro ballI)
       fix w
       assume "w\<in> space M"
       have "cls_val_process Mkt arb_pf (Suc 0) w =  geom_proc (Suc 0) w * arb_pf stk (Suc 0) w +
         disc_rfr_proc r (Suc 0) w * arb_pf risk_free_asset (Suc 0) w" using stock_pf_uvp_expand
         \<open>stock_portfolio Mkt arb_pf\<close> by simp
       also have "... = geom_proc (Suc 0) w + disc_rfr_proc r (Suc 0) w * arb_pf risk_free_asset (Suc 0) w"
         by (simp add: arb_pf_def two_stocks)
       also have "... = geom_proc (Suc 0) w + (1+r) * arb_pf risk_free_asset (Suc 0) w" by simp
       also have "... = geom_proc (Suc 0) w - (1+r) * geom_proc 0 w" by (simp add:arb_pf_def)
       finally show "cls_val_process Mkt arb_pf (Suc 0) w = geom_proc (Suc 0) w - (1+r) * geom_proc 0 w" .
     qed
     have iniT: "\<forall>w\<in> space M. snth w 0 \<longrightarrow> cls_val_process Mkt arb_pf (Suc 0) w > 0"
     proof (intro ballI impI)
       fix w
       assume "w\<in> space M" and "snth w 0"
       have "cls_val_process Mkt arb_pf (Suc 0) w =  geom_proc (Suc 0) w - (1+r) * geom_proc 0 w"
         using dev \<open>w\<in> space M\<close> by simp
       also have "... = u * geom_proc 0 w - (1+r) * geom_proc 0 w" using \<open>snth w 0\<close> geometric_process by simp
       also have "... = (u - (1+r)) * geom_proc 0 w" by (simp add: left_diff_distrib)
       also have "... > 0" using S0_positive \<open>1 + r \<le> d\<close> down_lt_up geometric_process by auto
       finally show "cls_val_process Mkt arb_pf (Suc 0) w > 0" .
     qed
     have iniF: "\<forall>w\<in> space M. \<not>snth w 0 \<longrightarrow> cls_val_process Mkt arb_pf (Suc 0) w \<ge> 0"
     proof (intro ballI impI)
       fix w
       assume "w\<in> space M" and "\<not>snth w 0"
       have "cls_val_process Mkt arb_pf (Suc 0) w =  geom_proc (Suc 0) w - (1+r) * geom_proc 0 w"
         using dev \<open>w\<in> space M\<close> by simp
       also have "... = d * geom_proc 0 w - (1+r) * geom_proc 0 w" using \<open>\<not>snth w 0\<close> geometric_process by simp
       also have "... = (d - (1+r)) * geom_proc 0 w" by (simp add: left_diff_distrib)
       also have "... \<ge> 0" using S0_positive \<open>1 + r \<le> d\<close> down_lt_up geometric_process by auto
       finally show "cls_val_process Mkt arb_pf (Suc 0) w \<ge> 0" .
     qed
     have "\<forall>w\<in> space M. cls_val_process Mkt arb_pf (Suc 0) w \<ge> 0"
     proof
       fix w
       assume "w\<in> space M"
       show "cls_val_process Mkt arb_pf (Suc 0) w \<ge> 0"
       proof (cases "snth w 0")
         case True
         thus ?thesis using \<open>w\<in> space M\<close> iniT by auto
       next
         case False
         thus ?thesis using \<open>w\<in> space M\<close> iniF by simp
       qed
     qed
     thus "AE w in M. 0 \<le> cls_val_process Mkt arb_pf (Suc 0) w" by simp
     show "0 < prob {w \<in> space M. 0 < cls_val_process Mkt arb_pf (Suc 0) w}"
     proof -
       have "cls_val_process Mkt arb_pf (Suc 0) \<in> borel_measurable M" using borel_adapt_stoch_proc_borel_measurable
         cls_val_process_adapted \<open>trading_strategy arb_pf\<close> \<open>stock_portfolio Mkt arb_pf\<close>
         using support_adapt_def readable unfolding  stock_portfolio_def by blast
       hence set_event:"{w \<in> space M. 0 < cls_val_process Mkt arb_pf (Suc 0) w} \<in> sets M"
         using borel_measurable_iff_greater by blast
       have "\<forall>n. emeasure M {w \<in> space M. w !! n} = ennreal p"
         using bernoulli p_gt_0 p_lt_1 bernoulli_stream_component_probability[of M p]
         by auto
       hence "emeasure M {w \<in> space M. w !! 0} = ennreal p" by blast
       moreover have "{w \<in> space M. w !! 0} \<subseteq> {w \<in> space M. 0 < cls_val_process Mkt arb_pf 1 w}"
       proof
         fix w
         assume "w\<in> {w \<in> space M. w !! 0}"
         hence "w \<in> space M" and "w !! 0" by auto note wprops = this
         hence "0 < cls_val_process Mkt arb_pf 1 w" using iniT by simp
         thus "w\<in> {w \<in> space M. 0 < cls_val_process Mkt arb_pf 1 w}" using wprops by simp
       qed
       ultimately have "p \<le> emeasure M {w \<in> space M. 0 < cls_val_process Mkt arb_pf 1 w}"
         using emeasure_mono set_event by fastforce
       hence "p \<le> prob {w \<in> space M. 0 < cls_val_process Mkt arb_pf 1 w}" by (simp add: emeasure_eq_measure)
       thus "0 < prob {w \<in> space M. 0 < cls_val_process Mkt arb_pf (Suc 0) w}" using psgt by simp
     qed
   qed
   thus False using assms unfolding viable_market_def using \<open>stock_portfolio Mkt arb_pf\<close> by simp
 qed
 
 
 lemma (in CRR_market) viable_only_if_u:
   assumes "viable_market Mkt"
   shows "1+r < u"
 proof (rule ccontr)
   assume "\<not> 1+r < u"
   hence "u \<le> 1+r" by simp
   define arb_pf where "arb_pf = (\<lambda> (x::'a) (n::nat) w. 0::real)(stk:= (\<lambda> n w. -1), risk_free_asset := (\<lambda> n w. geom_proc 0 w))"
   have "support_set arb_pf = {stk, risk_free_asset}"
   proof
     show "support_set arb_pf \<subseteq> {stk, risk_free_asset}"
       by (simp add: arb_pf_def subset_iff support_set_def)
     have "stk\<in> support_set arb_pf" unfolding arb_pf_def support_set_def using two_stocks by simp
     moreover have "risk_free_asset\<in> support_set arb_pf" unfolding arb_pf_def support_set_def
       using two_stocks geometric_process S0_positive by simp
     ultimately show "{stk, risk_free_asset}\<subseteq> support_set arb_pf" by simp
   qed
   hence "stock_portfolio Mkt arb_pf" using stocks
     by (simp add: portfolio_def stock_portfolio_def)
   have "arbitrage_process Mkt arb_pf"
   proof (rule arbitrage_processI, intro exI conjI)
     show "self_financing Mkt arb_pf" unfolding arb_pf_def using \<open>support_set arb_pf = {stk, risk_free_asset}\<close>
       by (simp add: static_portfolio_self_financing)
     show "trading_strategy arb_pf" unfolding trading_strategy_def
     proof (intro conjI ballI)
       show "portfolio arb_pf" unfolding portfolio_def using \<open>support_set arb_pf = {stk, risk_free_asset}\<close> by simp
       fix asset
       assume "asset\<in> support_set arb_pf"
       show "borel_predict_stoch_proc G (arb_pf asset)"
       proof (cases "asset = stk")
         case True
         hence "arb_pf asset = (\<lambda> n w. -1)" unfolding arb_pf_def by (simp add: two_stocks)
         show ?thesis unfolding predict_stoch_proc_def
         proof
           show "arb_pf asset 0 \<in> borel_measurable (G 0)" using \<open>arb_pf asset = (\<lambda> n w. -1)\<close> by simp
           show "\<forall>n. arb_pf asset (Suc n) \<in> borel_measurable (G n)"
           proof
             fix n
             show "arb_pf asset (Suc n) \<in> borel_measurable (G n)" using \<open>arb_pf asset = (\<lambda> n w. -1)\<close> by simp
           qed
         qed
       next
         case False
         hence "arb_pf asset = (\<lambda> n w. geom_proc 0 w)" using \<open>support_set arb_pf = {stk, risk_free_asset}\<close>
           \<open>asset \<in> support_set arb_pf\<close> unfolding arb_pf_def by simp
         show ?thesis unfolding predict_stoch_proc_def
         proof
           show "arb_pf asset 0 \<in> borel_measurable (G 0)" using \<open>arb_pf asset = (\<lambda> n w. geom_proc 0 w)\<close>
             geometric_process by simp
           show "\<forall>n. arb_pf asset (Suc n) \<in> borel_measurable (G n)"
           proof
             fix n
             show "arb_pf asset (Suc n) \<in> borel_measurable (G n)" using \<open>arb_pf asset = (\<lambda> n w. geom_proc 0 w)\<close>
               geometric_process by simp
           qed
         qed
       qed
     qed
     show "\<forall>w\<in>space M. cls_val_process Mkt arb_pf 0 w = 0"
     proof
       fix w
       assume "w\<in> space M"
       have "cls_val_process Mkt arb_pf 0 w = geom_proc 0 w * arb_pf stk (Suc 0) w +
         disc_rfr_proc r 0 w * arb_pf risk_free_asset (Suc 0) w" using stock_pf_vp_expand
         \<open>stock_portfolio Mkt arb_pf\<close>
         using \<open>self_financing Mkt arb_pf\<close> self_financingE by fastforce
       also have "... = geom_proc 0 w * (-1) + disc_rfr_proc r 0 w * arb_pf risk_free_asset (Suc 0) w"
         by (simp add: arb_pf_def two_stocks)
       also have "... = -geom_proc 0 w + arb_pf risk_free_asset (Suc 0) w" by simp
       also have "... = geom_proc 0 w  - geom_proc 0 w" unfolding arb_pf_def by simp
       also have "... = 0" by simp
       finally show "cls_val_process Mkt arb_pf 0 w = 0" .
     qed
     have dev: "\<forall>w\<in> space M. cls_val_process Mkt arb_pf (Suc 0) w = -geom_proc (Suc 0) w + (1+r) * geom_proc 0 w"
     proof (intro ballI)
       fix w
       assume "w\<in> space M"
       have "cls_val_process Mkt arb_pf (Suc 0) w =  geom_proc (Suc 0) w * arb_pf stk (Suc 0) w +
         disc_rfr_proc r (Suc 0) w * arb_pf risk_free_asset (Suc 0) w" using stock_pf_uvp_expand
         \<open>stock_portfolio Mkt arb_pf\<close> by simp
       also have "... = -geom_proc (Suc 0) w + disc_rfr_proc r (Suc 0) w * arb_pf risk_free_asset (Suc 0) w"
         by (simp add: arb_pf_def two_stocks)
       also have "... = -geom_proc (Suc 0) w + (1+r) * arb_pf risk_free_asset (Suc 0) w" by simp
       also have "... = -geom_proc (Suc 0) w + (1+r) * geom_proc 0 w" by (simp add:arb_pf_def)
       finally show "cls_val_process Mkt arb_pf (Suc 0) w = -geom_proc (Suc 0) w + (1+r) * geom_proc 0 w" .
     qed
     have iniT: "\<forall>w\<in> space M. snth w 0 \<longrightarrow> cls_val_process Mkt arb_pf (Suc 0) w \<ge> 0"
     proof (intro ballI impI)
       fix w
       assume "w\<in> space M" and "snth w 0"
       have "cls_val_process Mkt arb_pf (Suc 0) w =  -geom_proc (Suc 0) w + (1+r) * geom_proc 0 w"
         using dev \<open>w\<in> space M\<close> by simp
       also have "... = - u * geom_proc 0 w + (1+r) * geom_proc 0 w" using \<open>snth w 0\<close> geometric_process by simp
       also have "... = (-u + (1+r)) * geom_proc 0 w" by (simp add: left_diff_distrib)
       also have "... \<ge> 0" using S0_positive \<open>u\<le> 1 + r\<close> down_lt_up geometric_process by auto
       finally show "cls_val_process Mkt arb_pf (Suc 0) w \<ge> 0" .
     qed
     have iniF: "\<forall>w\<in> space M. \<not>snth w 0 \<longrightarrow> cls_val_process Mkt arb_pf (Suc 0) w > 0"
     proof (intro ballI impI)
       fix w
       assume "w\<in> space M" and "\<not>snth w 0"
       have "cls_val_process Mkt arb_pf (Suc 0) w =  -geom_proc (Suc 0) w + (1+r) * geom_proc 0 w"
         using dev \<open>w\<in> space M\<close> by simp
       also have "... = -d * geom_proc 0 w + (1+r) * geom_proc 0 w" using \<open>\<not>snth w 0\<close> geometric_process by simp
       also have "... = (-d + (1+r)) * geom_proc 0 w" by (simp add: left_diff_distrib)
       also have "... > 0" using S0_positive \<open>u <= 1 + r\<close> down_lt_up geometric_process by auto
       finally show "cls_val_process Mkt arb_pf (Suc 0) w > 0" .
     qed
     have "\<forall>w\<in> space M. cls_val_process Mkt arb_pf (Suc 0) w \<ge> 0"
     proof
       fix w
       assume "w\<in> space M"
       show "cls_val_process Mkt arb_pf (Suc 0) w \<ge> 0"
       proof (cases "snth w 0")
         case True
         thus ?thesis using \<open>w\<in> space M\<close> iniT by simp
       next
         case False
         thus ?thesis using \<open>w\<in> space M\<close> iniF by auto
       qed
     qed
     thus "AE w in M. 0 \<le> cls_val_process Mkt arb_pf (Suc 0) w" by simp
     show "0 < prob {w \<in> space M. 0 < cls_val_process Mkt arb_pf (Suc 0) w}"
     proof -
       have "cls_val_process Mkt arb_pf (Suc 0) \<in> borel_measurable M" using borel_adapt_stoch_proc_borel_measurable
         cls_val_process_adapted \<open>trading_strategy arb_pf\<close> \<open>stock_portfolio Mkt arb_pf\<close>
          using support_adapt_def readable unfolding stock_portfolio_def by blast
       hence set_event:"{w \<in> space M. 0 < cls_val_process Mkt arb_pf (Suc 0) w} \<in> sets M"
         using borel_measurable_iff_greater by blast
       have "\<forall>n. emeasure M {w \<in> space M. \<not>w !! n} = ennreal (1-p)"
         using bernoulli p_gt_0 p_lt_1 bernoulli_stream_component_probability_compl[of M p]
         by auto
       hence "emeasure M {w \<in> space M. \<not>w !! 0} = ennreal (1-p)" by blast
       moreover have "{w \<in> space M. \<not>w !! 0} \<subseteq> {w \<in> space M. 0 < cls_val_process Mkt arb_pf 1 w}"
       proof
         fix w
         assume "w\<in> {w \<in> space M. \<not>w !! 0}"
         hence "w \<in> space M" and "\<not>w !! 0" by auto note wprops = this
         hence "0 < cls_val_process Mkt arb_pf 1 w" using iniF by simp
         thus "w\<in> {w \<in> space M. 0 < cls_val_process Mkt arb_pf 1 w}" using wprops by simp
       qed
       ultimately have "1-p \<le> emeasure M {w \<in> space M. 0 < cls_val_process Mkt arb_pf 1 w}"
         using emeasure_mono set_event by fastforce
       hence "1-p \<le> prob {w \<in> space M. 0 < cls_val_process Mkt arb_pf 1 w}" by (simp add: emeasure_eq_measure)
       thus "0 < prob {w \<in> space M. 0 < cls_val_process Mkt arb_pf (Suc 0) w}" using pslt by simp
     qed
   qed
   thus False using assms unfolding viable_market_def using \<open>stock_portfolio Mkt arb_pf\<close> by simp
 qed
 
 lemma (in CRR_market) viable_iff:
 shows "viable_market Mkt \<longleftrightarrow> (d < 1+r \<and> 1+r < u)" using viable_if viable_only_if_d viable_only_if_u by auto
 
 
 subsection \<open>Risk-neutral probability space for the geometric random walk\<close>
 
 
 
 lemma (in CRR_market) stock_price_borel_measurable:
   shows "borel_adapt_stoch_proc G (prices Mkt stk)"
 proof -
   have "borel_adapt_stoch_proc (stoch_proc_filt M geom_proc borel) (prices Mkt stk)"
     by (simp add: geom_rand_walk_borel_measurable stk_price stoch_proc_filt_adapt)
   thus ?thesis by (simp add:stock_filtration)
 qed
 
 
 lemma (in CRR_market) risk_free_asset_martingale:
   assumes "N = bernoulli_stream q"
   and "0 < q"
   and "q < 1"
   shows "martingale N G (discounted_value r (prices Mkt risk_free_asset))"
 proof -
   have "filtration N G" by (simp add: assms bernoulli_gen_filtration)
   moreover have "\<forall>n. sigma_finite_subalgebra N (G n)" by (simp add: assms bernoulli_sigma_finite)
   moreover have "finite_measure N" using assms bernoulli_stream_def prob_space.prob_space_stream_space
     prob_space_def prob_space_measure_pmf by auto
   moreover have "discounted_value r (prices Mkt risk_free_asset) = (\<lambda> n w. 1)" using discounted_rfr by auto
   ultimately show ?thesis using finite_measure.constant_martingale by simp
 qed
 
 
 lemma (in infinite_coin_toss_space) nat_filtration_from_eq_sets:
   assumes "N = bernoulli_stream q"
   and "0 < q"
   and "q < 1"
 shows "sets (infinite_coin_toss_space.nat_filtration N n) = sets (nat_filtration n)"
 proof -
   have "sigma_sets (space (bernoulli_stream q)) {pseudo_proj_True n -` B \<inter> space N |B. B \<in> sets (bernoulli_stream q)} = sigma_sets (space (bernoulli_stream p))
           {pseudo_proj_True n -` B \<inter> space M |B. B \<in> sets (bernoulli_stream p)}"
   proof -
     have "sets N = events"
       by (metis assms(1) bernoulli_stream_def infinite_coin_toss_space_axioms infinite_coin_toss_space_def sets_measure_pmf sets_stream_space_cong)
     then show ?thesis
       using assms(1) bernoulli_stream_space infinite_coin_toss_space_axioms infinite_coin_toss_space_def by auto
   qed
   thus ?thesis using infinite_coin_toss_space.nat_filtration_sets
     using assms(1) assms(2) assms(3) infinite_coin_toss_space_axioms infinite_coin_toss_space_def by auto
 qed
 
 
 
 
 lemma (in CRR_market) geom_proc_integrable:
   assumes "N = bernoulli_stream q"
 and "0 \<le> q"
 and "q \<le> 1"
 shows "integrable N (geom_proc n)"
 proof (rule infinite_coin_toss_space.nat_filtration_borel_measurable_integrable)
   show "infinite_coin_toss_space q N" using assms by unfold_locales
   show "geom_proc n \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N n)" using geometric_process
     prob_grw.geom_rand_walk_borel_adapted[of q N geom_proc u d init]
     by (metis \<open>infinite_coin_toss_space q N\<close> geom_rand_walk_pseudo_proj_True infinite_coin_toss_space.nat_filtration_borel_measurable_characterization
          prob_grw.geom_rand_walk_borel_measurable prob_grw_axioms prob_grw_def)
 qed
 
 lemma (in CRR_market) CRR_infinite_cts_filtration:
   shows "infinite_cts_filtration p M nat_filtration"
   by (unfold_locales, simp)
 
 
 lemma (in CRR_market) proj_stoch_proc_geom_disc_fct:
   shows "disc_fct (proj_stoch_proc geom_proc n)" unfolding disc_fct_def using CRR_infinite_cts_filtration
     by (simp add: countable_finite geom_rand_walk_borel_adapted infinite_cts_filtration.proj_stoch_set_finite_range)
 
 lemma (in CRR_market) proj_stoch_proc_geom_rng:
   assumes "N = bernoulli_stream q"
 shows  "proj_stoch_proc geom_proc n \<in> N \<rightarrow>\<^sub>M stream_space borel"
 proof -
   have "random_variable (stream_space borel) (proj_stoch_proc geom_proc n)" using CRR_infinite_cts_filtration
     using geom_rand_walk_borel_adapted nat_discrete_filtration proj_stoch_measurable_if_adapted by blast
   then show ?thesis
     using assms(1) bernoulli bernoulli_stream_def by auto
 qed
 
 lemma (in CRR_market) proj_stoch_proc_geom_open_set:
   shows  "\<forall>r\<in>range (proj_stoch_proc geom_proc n) \<inter> space (stream_space borel).
      \<exists>A\<in>sets (stream_space borel). range (proj_stoch_proc geom_proc n) \<inter> A = {r}"
 proof
   fix r
   assume "r\<in> range (proj_stoch_proc geom_proc n) \<inter> space (stream_space borel)"
   show "\<exists>A\<in>sets (stream_space borel). range (proj_stoch_proc geom_proc n) \<inter> A = {r}"
   proof
     show "infinite_cts_filtration.stream_space_single (proj_stoch_proc geom_proc n) r \<in> sets (stream_space borel)"
       using infinite_cts_filtration.stream_space_single_set \<open>r \<in> range (proj_stoch_proc geom_proc n) \<inter> space (stream_space borel)\<close>
         geom_rand_walk_borel_adapted CRR_infinite_cts_filtration by blast
     show "range (proj_stoch_proc geom_proc n) \<inter> infinite_cts_filtration.stream_space_single (proj_stoch_proc geom_proc n) r = {r}"
       using infinite_cts_filtration.stream_space_single_preimage \<open>r \<in> range (proj_stoch_proc geom_proc n) \<inter> space (stream_space borel)\<close>
         geom_rand_walk_borel_adapted CRR_infinite_cts_filtration by blast
   qed
 qed
 
 lemma (in CRR_market) bernoulli_AE_cond_exp:
   assumes "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
 and "integrable N X"
 shows "AE w in N. real_cond_exp N (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n)) X w =
     expl_cond_expect N (proj_stoch_proc geom_proc n) X w"
 proof (rule finite_measure.charact_cond_exp')
   have "infinite_cts_filtration p M nat_filtration"
     by (unfold_locales, simp)
   show "finite_measure N" using assms
     by (simp add: bernoulli_stream_def prob_space.finite_measure prob_space.prob_space_stream_space prob_space_measure_pmf)
   show "disc_fct (proj_stoch_proc geom_proc n)" using proj_stoch_proc_geom_disc_fct by simp
   show "integrable N X"  using assms by simp
   show "proj_stoch_proc geom_proc n \<in> N \<rightarrow>\<^sub>M stream_space borel" using assms proj_stoch_proc_geom_rng by simp
   show "\<forall>r\<in>range (proj_stoch_proc geom_proc n) \<inter> space (stream_space borel).
      \<exists>A\<in>sets (stream_space borel). range (proj_stoch_proc geom_proc n) \<inter> A = {r}"
     using proj_stoch_proc_geom_open_set by simp
 qed
 
 lemma (in CRR_market) geom_proc_cond_exp:
   assumes "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
 shows "AE w in N. real_cond_exp N (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n)) (geom_proc (Suc n)) w =
     expl_cond_expect N (proj_stoch_proc geom_proc n) (geom_proc (Suc n)) w"
 proof (rule bernoulli_AE_cond_exp)
   show "integrable N (geom_proc (Suc n))"  using assms geom_proc_integrable[of N q "Suc n"] by simp
 qed (auto simp add: assms)
 
 
 lemma (in CRR_market) expl_cond_eq_sets:
   assumes "N = bernoulli_stream q"
   shows  "expl_cond_expect N (proj_stoch_proc geom_proc n) X \<in>
         borel_measurable (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n))"
 proof (rule expl_cond_exp_borel)
   show "proj_stoch_proc geom_proc n \<in> space N \<rightarrow> space (stream_space borel)"
   proof -
     have "random_variable (stream_space borel) (proj_stoch_proc geom_proc n)"
       using CRR_infinite_cts_filtration geom_rand_walk_borel_adapted proj_stoch_measurable_if_adapted
         nat_discrete_filtration by blast
     then show ?thesis
       by (simp add: assms(1) bernoulli bernoulli_stream_space measurable_def)
   qed
   show "disc_fct (proj_stoch_proc geom_proc n)" unfolding disc_fct_def using CRR_infinite_cts_filtration
     by (simp add: countable_finite geom_rand_walk_borel_adapted infinite_cts_filtration.proj_stoch_set_finite_range)
   show "\<forall>r\<in>range (proj_stoch_proc geom_proc n) \<inter> space (stream_space borel).
     \<exists>A\<in>sets (stream_space borel). range (proj_stoch_proc geom_proc n) \<inter> A = {r}"
   proof
     fix r
     assume "r\<in>range (proj_stoch_proc geom_proc n) \<inter> space (stream_space borel)"
     show "\<exists>A\<in>sets (stream_space borel). range (proj_stoch_proc geom_proc n) \<inter> A = {r}"
     proof
       show "infinite_cts_filtration.stream_space_single (proj_stoch_proc geom_proc n) r \<in> sets (stream_space borel)"
         using infinite_cts_filtration.stream_space_single_set \<open>r \<in> range (proj_stoch_proc geom_proc n) \<inter> space (stream_space borel)\<close>
           geom_rand_walk_borel_adapted CRR_infinite_cts_filtration by blast
       show "range (proj_stoch_proc geom_proc n) \<inter> infinite_cts_filtration.stream_space_single (proj_stoch_proc geom_proc n) r = {r}"
         using infinite_cts_filtration.stream_space_single_preimage \<open>r \<in> range (proj_stoch_proc geom_proc n) \<inter> space (stream_space borel)\<close>
           geom_rand_walk_borel_adapted CRR_infinite_cts_filtration by blast
     qed
   qed
 qed
 
 
 lemma (in CRR_market) bernoulli_real_cond_exp_AE:
   assumes "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
 and "integrable N X"
 shows "real_cond_exp N (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n))
    X w = expl_cond_expect N (proj_stoch_proc geom_proc n) X w"
 proof -
   have "real_cond_exp N (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n))
    X w = expl_cond_expect N (proj_stoch_proc geom_proc n) X w"
   proof (rule infinite_coin_toss_space.nat_filtration_AE_eq)
     show "infinite_coin_toss_space q N" using assms
       by (simp add: infinite_coin_toss_space_def)
     show "AE w in N. real_cond_exp N (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n)) X w =
     expl_cond_expect N (proj_stoch_proc geom_proc n) X w"  using assms bernoulli_AE_cond_exp by simp
     show "real_cond_exp N (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n)) X
       \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N n)"
     proof -
       have "real_cond_exp N (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n)) X
         \<in> borel_measurable (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n))"
         by simp
       moreover have "subalgebra (infinite_coin_toss_space.nat_filtration N n) (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n))"
         using stock_filtration infinite_coin_toss_space.stoch_proc_subalg_nat_filt[of q N geom_proc n]
         infinite_cts_filtration.stoch_proc_filt_gen[of q N]
         by (metis \<open>infinite_coin_toss_space q N\<close> infinite_cts_filtration_axioms.intro infinite_cts_filtration_def
             prob_grw.geom_rand_walk_borel_adapted prob_grw_axioms prob_grw_def)
       ultimately show ?thesis using measurable_from_subalg by blast
     qed
     show "expl_cond_expect N (proj_stoch_proc geom_proc n) X \<in>
       borel_measurable (infinite_coin_toss_space.nat_filtration N n)"
     proof -
       have "expl_cond_expect N (proj_stoch_proc geom_proc n) X \<in>
         borel_measurable (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n))"
         by (simp add: expl_cond_eq_sets assms)
       moreover have "subalgebra (infinite_coin_toss_space.nat_filtration N n) (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n))"
       using stock_filtration infinite_coin_toss_space.stoch_proc_subalg_nat_filt[of q N geom_proc n]
         infinite_cts_filtration.stoch_proc_filt_gen[of q N]
         by (metis \<open>infinite_coin_toss_space q N\<close> infinite_cts_filtration_axioms.intro infinite_cts_filtration_def
             prob_grw.geom_rand_walk_borel_adapted prob_grw_axioms prob_grw_def)
       ultimately show ?thesis using measurable_from_subalg by blast
     qed
     show "0 < q" and "q < 1" using assms by auto
   qed
   thus ?thesis by simp
 qed
 
 lemma (in CRR_market) geom_proc_real_cond_exp_AE:
   assumes "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
 shows "real_cond_exp N (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n))
    (geom_proc (Suc n)) w = expl_cond_expect N (proj_stoch_proc geom_proc n) (geom_proc (Suc n)) w"
 proof (rule bernoulli_real_cond_exp_AE)
 show "integrable N (geom_proc (Suc n))"  using assms geom_proc_integrable[of N q "Suc n"] by simp
 qed (auto simp add: assms)
 
 
 lemma (in CRR_market) geom_proc_stoch_proc_filt:
   assumes "N= bernoulli_stream q"
 and "0 < q"
 and "q < 1"
 shows "stoch_proc_filt N geom_proc borel n = fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n)"
 proof (rule infinite_cts_filtration.stoch_proc_filt_gen)
   show "infinite_cts_filtration q N (infinite_coin_toss_space.nat_filtration N)" unfolding infinite_cts_filtration_def
   proof
     show "infinite_coin_toss_space q N" using assms
       by (simp add: infinite_coin_toss_space_def)
     show "infinite_cts_filtration_axioms N (infinite_coin_toss_space.nat_filtration N)"
       using infinite_cts_filtration_axioms_def by blast
   qed
   show "borel_adapt_stoch_proc (infinite_coin_toss_space.nat_filtration N) geom_proc"
     using \<open>infinite_cts_filtration q N (infinite_coin_toss_space.nat_filtration N)\<close>
       prob_grw.geom_rand_walk_borel_adapted prob_grw_axioms prob_grw_def
     using infinite_cts_filtration_def by auto
 qed
 
 lemma (in CRR_market) bernoulli_cond_exp:
   assumes "N = bernoulli_stream q"
   and "0 < q"
   and "q < 1"
 and "integrable N X"
 shows "real_cond_exp N (stoch_proc_filt N geom_proc borel n) X w = expl_cond_expect N (proj_stoch_proc geom_proc n) X w"
 proof -
   have aeq: "AE w in N. real_cond_exp N (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n)) X w =
     expl_cond_expect N (proj_stoch_proc geom_proc n) X w"  using assms
     bernoulli_AE_cond_exp by simp
   have "\<forall>w. real_cond_exp N (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n))
    X w = expl_cond_expect N (proj_stoch_proc geom_proc n) X w"  using assms bernoulli_real_cond_exp_AE by simp
   moreover have "stoch_proc_filt N geom_proc borel n = fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n)"
     using assms geom_proc_stoch_proc_filt by simp
   ultimately show ?thesis by simp
 qed
 
 lemma (in CRR_market) stock_cond_exp:
   assumes "N = bernoulli_stream q"
   and "0 < q"
   and "q < 1"
 shows "real_cond_exp N (stoch_proc_filt N geom_proc borel n) (geom_proc (Suc n)) w = expl_cond_expect N (proj_stoch_proc geom_proc n) (geom_proc (Suc n)) w"
 proof (rule bernoulli_cond_exp)
 show "integrable N (geom_proc (Suc n))"  using assms geom_proc_integrable[of N q "Suc n"] by simp
 qed (auto simp add: assms)
 
 
 
 
 lemma (in prob_space) discount_factor_real_cond_exp:
   assumes "integrable M X"
 and "subalgebra M G"
 and "-1 < r"
 shows "AE w in M. real_cond_exp M G (\<lambda>x. discount_factor r n x * X x) w = discount_factor r n w * (real_cond_exp M G X) w"
 proof (rule sigma_finite_subalgebra.real_cond_exp_mult)
   show "sigma_finite_subalgebra M G" using assms subalgebra_sigma_finite by simp
   show "discount_factor r n \<in> borel_measurable G" by (simp add: discount_factor_borel_measurable)
   show "random_variable borel X" using assms by simp
   show "integrable M (\<lambda>x. discount_factor r n x * X x)"  using assms discounted_integrable[of M "\<lambda>n. X"]
     unfolding discounted_value_def by simp
 qed
 
 
 lemma (in prob_space) discounted_value_real_cond_exp:
   assumes "integrable M X"
   and "-1 < r"
 and "subalgebra M G"
   shows "AE w in M. real_cond_exp M G ((discounted_value r (\<lambda> m. X)) n) w =
     discounted_value r (\<lambda>m. (real_cond_exp M G X)) n w" using  assms
   unfolding discounted_value_def  init_triv_filt_def filtration_def
   by (simp add: assms discount_factor_real_cond_exp)
 
 
 lemma (in CRR_market)
   assumes "q = (1 + r - d)/(u -d)"
   and "viable_market Mkt"
   shows gt_param: "0 < q"
     and lt_param: "q < 1"
     and risk_neutral_param: "u * q + d * (1 - q) = 1 + r"
 proof -
   show "0 < q" using  down_lt_up viable_only_if_d assms by simp
   show "q < 1" using down_lt_up viable_only_if_u assms by simp
   show "u * q + d * (1 - q) = 1 + r"
   proof -
     have "1 - q = 1 - (1 + r - d) / (u - d)" using assms by simp
     also have "... = (u - d)/(u - d) - (1 + r - d) / (u - d)" using down_lt_up by simp
     also have "... = (u - d - (1 + r - d))/(u-d)" using  diff_divide_distrib[of "u - d" "1 + r -d" "u -d"] by simp
     also have "... = (u - 1 - r)/(u-d)" by simp
     finally have "1 - q = (u - 1 - r)/(u -d)" .
     hence "u * q + d * (1 - q) = u * (1 + r - d)/(u - d) + d * (u - 1 - r)/(u - d)" using assms by simp
     also have "... = (u * (1 + r - d) + d * (u - 1 - r))/(u - d)" using add_divide_distrib[of "u * (1 + r - d)"] by simp
     also have "... = (u * (1 + r) - u * d + d * u - d * (1 + r))/(u - d)"
       by (simp add: diff_diff_add right_diff_distrib')
     also have "... = (u * (1+r) - d * (1+r))/(u - d)" by simp
     also have "... = ((u - d) * (1+r))/(u - d)" by (simp add: left_diff_distrib)
     also have "... = 1 + r" using down_lt_up by simp
     finally show ?thesis .
   qed
 qed
 
 lemma (in CRR_market) bernoulli_expl_cond_expect_adapt:
   assumes "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
   shows "expl_cond_expect N (proj_stoch_proc geom_proc n) f\<in> borel_measurable (G n)"
 proof -
   have "sets N = sets M" using assms by (simp add: bernoulli bernoulli_stream_def sets_stream_space_cong)
   have icf: "infinite_cts_filtration p M nat_filtration" by (unfold_locales, simp)
   have "G n = stoch_proc_filt M geom_proc borel n" using stock_filtration by simp
   also have "... = fct_gen_subalgebra M (stream_space borel) (proj_stoch_proc geom_proc n)"
   proof (rule infinite_cts_filtration.stoch_proc_filt_gen)
     show "infinite_cts_filtration p M nat_filtration" using icf .
     show "borel_adapt_stoch_proc nat_filtration geom_proc" using geom_rand_walk_borel_adapted .
   qed
   also have "... = fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n)"
     by (rule fct_gen_subalgebra_eq_sets, (simp add: \<open>sets N = sets M\<close>))
   finally have "G n = fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n)" .
   moreover have "expl_cond_expect N (proj_stoch_proc geom_proc n) f \<in>
     borel_measurable (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n))"
     by (simp add: expl_cond_eq_sets assms)
   ultimately show ?thesis by simp
 qed
 
 
 
 lemma (in CRR_market) real_cond_exp_discount_stock:
   assumes "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
 shows "AE w in N. real_cond_exp N (G n)
    (discounted_value r (prices Mkt stk) (Suc n)) w =
                   discounted_value r (\<lambda>m w. (q * u + (1 - q) * d) * prices Mkt stk n w) (Suc n) w"
 proof -
   have qlt: "0 < q" and qgt: "q < 1" using assms by auto
   have "G n = (fct_gen_subalgebra M (stream_space borel)
                                 (proj_stoch_proc geom_proc n))"
     using stock_filtration infinite_cts_filtration.stoch_proc_filt_gen[of p M nat_filtration geom_proc n] geometric_process
       geom_rand_walk_borel_adapted CRR_infinite_cts_filtration by simp
   also have "... = (fct_gen_subalgebra N (stream_space borel)
                                 (proj_stoch_proc geom_proc n))"
   proof (rule fct_gen_subalgebra_eq_sets)
     show "events = sets N" using assms qlt qgt
       by (simp add: bernoulli bernoulli_stream_def sets_stream_space_cong)
   qed
   finally have "G n = (fct_gen_subalgebra N (stream_space borel)
                                 (proj_stoch_proc geom_proc n))" .
   hence "AE w in N. real_cond_exp N (G n)
    (discounted_value r (prices Mkt stk) (Suc n)) w = real_cond_exp N (fct_gen_subalgebra N (stream_space borel)
                                 (proj_stoch_proc geom_proc n))
                                 (discounted_value r (prices Mkt stk) (Suc n)) w" by simp
   moreover have "AE w in N. real_cond_exp N (fct_gen_subalgebra N (stream_space borel)
                                 (proj_stoch_proc geom_proc n))
                                 (discounted_value r (prices Mkt stk) (Suc n)) w =
                             real_cond_exp N (fct_gen_subalgebra N (stream_space borel)
                                 (proj_stoch_proc geom_proc n))
                                 (discounted_value r (\<lambda>m. (prices Mkt stk) (Suc n)) (Suc n)) w"
   proof -
     have "\<forall>w. (discounted_value r (prices Mkt stk) (Suc n)) w =
       (discounted_value r (\<lambda>m. (prices Mkt stk) (Suc n)) (Suc n)) w"
     proof
       fix w
       show "discounted_value r (prices Mkt stk) (Suc n) w = discounted_value r (\<lambda>m. prices Mkt stk (Suc n)) (Suc n) w"
         by (simp add: discounted_value_def)
     qed
     hence "(discounted_value r (prices Mkt stk) (Suc n)) =
       (discounted_value r (\<lambda>m. (prices Mkt stk) (Suc n)) (Suc n))" by auto
     thus ?thesis by simp
     qed
   moreover have "AE w in N. (real_cond_exp N (fct_gen_subalgebra N (stream_space borel)
                                 (proj_stoch_proc geom_proc n))
                                 (discounted_value r (\<lambda>m. (prices Mkt stk) (Suc n)) (Suc n))) w =
                discounted_value r (\<lambda>m. real_cond_exp N (fct_gen_subalgebra N (stream_space borel)
                                                      (proj_stoch_proc geom_proc n))
                                                      ((prices Mkt stk) (Suc n))) (Suc n) w"
   proof (rule prob_space.discounted_value_real_cond_exp)
     show "-1 < r" using acceptable_rate by simp
     show "integrable N (prices Mkt stk (Suc n))" using stk_price geom_proc_integrable assms qlt qgt by simp
     show "subalgebra N (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc n))"
     proof (rule fct_gen_subalgebra_is_subalgebra)
       show "proj_stoch_proc geom_proc n \<in> N \<rightarrow>\<^sub>M stream_space borel"
       proof -
         have "proj_stoch_proc geom_proc n \<in> measurable M (stream_space borel)"
         proof (rule proj_stoch_measurable_if_adapted)
           show "borel_adapt_stoch_proc nat_filtration geom_proc" using
             geometric_process
             geom_rand_walk_borel_adapted by simp
           show "filtration M nat_filtration" using CRR_infinite_cts_filtration
             by (simp add: nat_discrete_filtration)
         qed
         thus ?thesis using assms bernoulli_stream_equiv filt_equiv_measurable qlt qgt psgt pslt by blast
       qed
     qed
     show "prob_space N" using assms
       by (simp add: bernoulli bernoulli_stream_def prob_space.prob_space_stream_space prob_space_measure_pmf)
   qed
   moreover have "AE w in N. discounted_value r (\<lambda>m. real_cond_exp N (fct_gen_subalgebra N (stream_space borel)
                                                      (proj_stoch_proc geom_proc n))
                                                      ((prices Mkt stk) (Suc n))) (Suc n) w =
                     discounted_value r (\<lambda>m w. (q * u + (1 - q) * d) * prices Mkt stk n w) (Suc n) w"
   proof (rule discounted_AE_cong)
    have "AEeq N (real_cond_exp N (fct_gen_subalgebra N (stream_space borel)
                                 (proj_stoch_proc geom_proc n))
                                 ((prices Mkt stk) (Suc n)))
                (\<lambda>w. q * (prices Mkt stk) (Suc n) (pseudo_proj_True n w) +
                 (1 - q) * (prices Mkt stk) (Suc n) (pseudo_proj_False n w))"
      proof (rule infinite_cts_filtration.f_borel_Suc_real_cond_exp)
       show icf: "infinite_cts_filtration q N (infinite_coin_toss_space.nat_filtration N)" unfolding infinite_cts_filtration_def
       proof
         show "infinite_coin_toss_space q N" using assms qlt qgt
           by (simp add: infinite_coin_toss_space_def)
         show "infinite_cts_filtration_axioms N (infinite_coin_toss_space.nat_filtration N)"
           using infinite_cts_filtration_axioms_def by blast
       qed
       have badapt: "borel_adapt_stoch_proc (infinite_coin_toss_space.nat_filtration N) (prices Mkt stk)"
         using stk_price prob_grw.geom_rand_walk_borel_adapted[of q N  geom_proc]
         unfolding adapt_stoch_proc_def
         by (metis (full_types) borel_measurable_integrable geom_proc_integrable geom_rand_walk_pseudo_proj_True icf
             infinite_coin_toss_space.nat_filtration_borel_measurable_characterization infinite_coin_toss_space_def
             infinite_cts_filtration_def)
       show "prices Mkt stk (Suc n) \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N (Suc n))"
         using badapt unfolding adapt_stoch_proc_def by simp
       show "proj_stoch_proc geom_proc n \<in> infinite_coin_toss_space.nat_filtration N n \<rightarrow>\<^sub>M stream_space borel"
       proof (rule proj_stoch_adapted_if_adapted)
         show "filtration N (infinite_coin_toss_space.nat_filtration N)" using icf
           using infinite_coin_toss_space.nat_discrete_filtration infinite_cts_filtration_def by blast
         show "borel_adapt_stoch_proc (infinite_coin_toss_space.nat_filtration N) geom_proc" using badapt stk_price by simp
       qed
       show "set_discriminating n (proj_stoch_proc geom_proc n) (stream_space borel)" unfolding set_discriminating_def
       proof (intro allI impI)
         fix w
         assume "proj_stoch_proc geom_proc n w \<noteq> proj_stoch_proc geom_proc n (pseudo_proj_True n w)"
         hence False using CRR_infinite_cts_filtration
           by (metis \<open>proj_stoch_proc geom_proc n w \<noteq> proj_stoch_proc geom_proc n (pseudo_proj_True n w)\<close>
             geom_rand_walk_borel_adapted infinite_cts_filtration.proj_stoch_proj_invariant)
         thus "\<exists>A\<in>sets (stream_space borel).
       (proj_stoch_proc geom_proc n w \<in> A) = (proj_stoch_proc geom_proc n (pseudo_proj_True n w) \<notin> A)" by simp
       qed
       show "\<forall>w. proj_stoch_proc geom_proc n -` {proj_stoch_proc geom_proc n w} \<in>
         sets (infinite_coin_toss_space.nat_filtration N n)"
       proof
         fix w
         show "proj_stoch_proc geom_proc n -` {proj_stoch_proc geom_proc n w} \<in> sets (infinite_coin_toss_space.nat_filtration N n)"
           using \<open>proj_stoch_proc geom_proc n \<in> infinite_coin_toss_space.nat_filtration N n \<rightarrow>\<^sub>M stream_space borel\<close>
           using assms geom_rand_walk_borel_adapted nat_filtration_from_eq_sets   qlt qgt
             infinite_cts_filtration.proj_stoch_singleton_set CRR_infinite_cts_filtration by blast
       qed
       show "\<forall>r\<in>range (proj_stoch_proc geom_proc n) \<inter> space (stream_space borel).
         \<exists>A\<in>sets (stream_space borel). range (proj_stoch_proc geom_proc n) \<inter> A = {r}"
       proof
         fix r
         assume asm: "r \<in> range (proj_stoch_proc geom_proc n) \<inter> space (stream_space borel)"
         define A where "A = infinite_cts_filtration.stream_space_single (proj_stoch_proc geom_proc n) r"
         have "A \<in> sets (stream_space borel)"  using infinite_cts_filtration.stream_space_single_set
           unfolding A_def using badapt icf stk_price asm by blast
         moreover have "range (proj_stoch_proc geom_proc n) \<inter> A = {r}"
           unfolding A_def using badapt icf stk_price infinite_cts_filtration.stream_space_single_preimage asm by blast
         ultimately show "\<exists>A\<in>sets (stream_space borel). range (proj_stoch_proc geom_proc n) \<inter> A = {r}" by auto
       qed
       show "\<forall>y z. proj_stoch_proc geom_proc n y = proj_stoch_proc geom_proc n z \<and> y !! n = z !! n \<longrightarrow>
         prices Mkt stk (Suc n) y = prices Mkt stk (Suc n) z"
       proof (intro allI impI)
         fix y z
         assume "proj_stoch_proc geom_proc n y = proj_stoch_proc geom_proc n z \<and> y !! n = z !! n"
         hence "geom_proc n y = geom_proc n z" using proj_stoch_proc_component(2)[of n n]
         proof -
           show ?thesis
             by (metis \<open>\<And>w f. n \<le> n \<Longrightarrow> proj_stoch_proc f n w !! n = f n w\<close> \<open>proj_stoch_proc geom_proc n y = proj_stoch_proc geom_proc n z \<and> y !! n = z !! n\<close> order_refl)
         qed
         hence "geom_proc (Suc n) y = geom_proc (Suc n) z" using geometric_process
           by (simp add: \<open>proj_stoch_proc geom_proc n y = proj_stoch_proc geom_proc n z \<and> y !! n = z !! n\<close>)
         thus "prices Mkt stk (Suc n) y = prices Mkt stk (Suc n) z" using stk_price by simp
       qed
       show "0 < q" and "q < 1" using assms by auto
     qed
     moreover have "\<forall>w. q * prices Mkt stk (Suc n) (pseudo_proj_True n w) + (1 - q) * prices Mkt stk (Suc n) (pseudo_proj_False n w) =
       (q * u + (1 - q) * d) * prices Mkt stk n w"
     proof
       fix w
       have "q * prices Mkt stk (Suc n) (pseudo_proj_True n w) + (1 - q) * prices Mkt stk (Suc n) (pseudo_proj_False n w) =
         q * geom_proc (Suc n) (pseudo_proj_True n w) + (1-q) * geom_proc (Suc n) (pseudo_proj_False n w)"
         by (simp add:stk_price)
       also have "... = q * u * geom_proc n (pseudo_proj_True n w) + (1-q) * geom_proc (Suc n) (pseudo_proj_False n w)"
         using geometric_process unfolding pseudo_proj_True_def by simp
       also have "... = q * u * geom_proc n w + (1-q) * geom_proc (Suc n) (pseudo_proj_False n w)"
         by (metis geom_rand_walk_pseudo_proj_True o_apply)
       also have "... = q * u * geom_proc n w + (1-q) * d * geom_proc n (pseudo_proj_False n w)"
         using geometric_process unfolding pseudo_proj_False_def by simp
       also have "... = q * u * geom_proc n w + (1-q) * d * geom_proc n w"
         by (metis geom_rand_walk_pseudo_proj_False o_apply)
       also have "... = (q * u + (1 - q) * d) * geom_proc n w" by (simp add: distrib_right)
       finally show "q * prices Mkt stk (Suc n) (pseudo_proj_True n w) + (1 - q) * prices Mkt stk (Suc n) (pseudo_proj_False n w) =
         (q * u + (1 - q) * d) * prices Mkt stk n w" using stk_price by simp
     qed
     ultimately show "AEeq N (real_cond_exp N (fct_gen_subalgebra N (stream_space borel)
                                   (proj_stoch_proc geom_proc n))
                                   ((prices Mkt stk) (Suc n)))
                     (\<lambda>w. (q * u + (1 - q) * d) * prices Mkt stk n w)" by simp
   qed
   ultimately show ?thesis by auto
 qed
 
 
 
 lemma (in CRR_market) risky_asset_martingale_only_if:
   assumes "N = bernoulli_stream q"
   and "0 < q"
   and "q < 1"
   and  "martingale N G (discounted_value r (prices Mkt stk))"
 shows "q = (1 + r - d) / (u - d)"
 proof -
   have "AE w in N. real_cond_exp N (G 0)
        (discounted_value r (prices Mkt stk) (Suc 0)) w =  discounted_value r (prices Mkt stk) 0 w" using assms
     unfolding martingale_def by simp
   hence "AE w in N. real_cond_exp N (G 0)
        (discounted_value r (prices Mkt stk) (Suc 0)) w =  prices Mkt stk 0 w" by (simp add: discounted_init)
   moreover have "AE w in N. real_cond_exp N (G 0) (discounted_value r (prices Mkt stk) (Suc 0)) w =
     discounted_value r (\<lambda>m w. (q * u + (1 - q) * d) * prices Mkt stk 0 w) (Suc 0) w"
     using assms real_cond_exp_discount_stock by simp
   ultimately have "AE w in N. discounted_value r (\<lambda>m w. (q * u + (1 - q) * d) * prices Mkt stk 0 w) (Suc 0) w =
     prices Mkt stk 0 w" by auto
   hence "AE w in N. discounted_value r (\<lambda>m w. (q * u + (1 - q) * d) * init) (Suc 0) w =
     (\<lambda>w. init) w" using stk_price geometric_process by simp
   hence "AE w in N. discount_factor r (Suc 0) w * (q * u + (1 - q) * d) * init =
     (\<lambda>w. init) w" unfolding discounted_value_def by simp
   hence "AE w in N. (1+r) * discount_factor r (Suc 0) w * (q * u + (1 - q) * d) * init =
     (1+r) * (\<lambda>w. init) w" by auto
   hence prev: "AE w in N. discount_factor r 0 w * (q * u + (1 - q) * d) * init =
     (1+r) * (\<lambda>w. init) w" using discount_factor_times_rfr[of r 0] acceptable_rate
   proof -
     have "\<forall>s. (1 + r) * discount_factor r (Suc 0) (s::bool stream) = discount_factor r 0 s"
     by (metis (no_types) \<open>\<And>w. - 1 < r \<Longrightarrow> (1 + r) * discount_factor r (Suc 0) w = discount_factor r 0 w\<close> acceptable_rate)
     then show ?thesis
     using \<open>AEeq N (\<lambda>w. (1 + r) * discount_factor r (Suc 0) w * (q * u + (1 - q) * d) * init) (\<lambda>w. (1 + r) * init)\<close> by presburger
   qed
   hence "\<forall>w. (\<lambda>w. discount_factor r 0 w * (q * u + (1 - q) * d) * init) w =
     (\<lambda>w. (1+r) * init) w"
   proof -
     have "(\<lambda>w. discount_factor r 0 w *  (q * u + (1 - q) * d) * init)
       \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N 0)"
     proof (rule borel_measurable_times)+
       show "(\<lambda>x. init) \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N 0)" by simp
       show "(\<lambda>x. q * u + (1 - q) * d) \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N 0)" by simp
       show "discount_factor r 0 \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N 0)"
         using discount_factor_nonrandom[of r 0 "infinite_coin_toss_space.nat_filtration N 0"] by simp
     qed
     moreover have "(\<lambda>w. (1 + r) * init) \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N 0)" by simp
     moreover have "infinite_coin_toss_space q N" using assms by (simp add: infinite_coin_toss_space_def)
     ultimately show ?thesis
       using  prev infinite_coin_toss_space.nat_filtration_AE_eq[of q N
         "(\<lambda>w. discount_factor r 0 w * (q * u + (1 - q) * d) * init)" "(\<lambda>w. (1 + r) * init)" 0] assms
       by (simp add: discount_factor_init)
   qed
   hence "(q * u + (1 - q) * d) * init = (1+r) * init" by (simp add: discount_factor_init)
   hence "q * u + (1 - q) * d = 1+r" using S0_positive by simp
   hence "q * u + d - q * d = 1+r" by (simp add: left_diff_distrib)
   hence "q * (u - d) = 1 + r - d"
     by (metis (no_types, hide_lams) add.commute add.left_commute add_diff_cancel_left' add_uminus_conv_diff left_diff_distrib mult.commute)
   thus "q = (1 + r - d) / (u - d)" using down_lt_up
     by (metis add.commute add.right_neutral diff_add_cancel nonzero_eq_divide_eq order_less_irrefl)
 qed
 
 
 
 locale CRR_market_viable = CRR_market +
   assumes CRR_viable: "viable_market Mkt"
 
 
 lemma (in CRR_market_viable) real_cond_exp_discount_stock_q_const:
   assumes "N = bernoulli_stream q"
 and "q = (1+r-d) / (u-d)"
 shows "AE w in N. real_cond_exp N (G n)
    (discounted_value r (prices Mkt stk) (Suc n)) w =
                   discounted_value r (prices Mkt stk) n w"
 proof -
   have qlt: "0 < q" and qgt: "q < 1" using assms gt_param lt_param CRR_viable by auto
   have "AE w in N. real_cond_exp N (G n) (discounted_value r (prices Mkt stk) (Suc n)) w =
                   discounted_value r (\<lambda>m w. (q * u + (1 - q) * d) * prices Mkt stk n w) (Suc n) w"
     using assms real_cond_exp_discount_stock[of N q] qlt qgt by simp
   moreover have "\<forall>w. (q * u + (1 - q) * d) * prices Mkt stk n w =
     (1+r) * prices Mkt stk n w" using risk_neutral_param assms CRR_viable
       by (simp add: mult.commute)
   ultimately have "AE w in N. real_cond_exp N (G n) (discounted_value r (prices Mkt stk) (Suc n)) w =
                   discounted_value r (\<lambda>m w. (1+r) * prices Mkt stk n w) (Suc n) w" by simp
   moreover have "\<forall>w\<in> space N. discounted_value r (\<lambda>m w. (1+r) * prices Mkt stk n w) (Suc n) w =
                      discounted_value r (\<lambda>m w. prices Mkt stk n w) n w"
     using  acceptable_rate by (simp add:discounted_mult_times_rfr)
   moreover hence "\<forall>w\<in> space N. discounted_value r (\<lambda>m w. (1+r) * prices Mkt stk n w) (Suc n) w =
                      discounted_value r (prices Mkt stk) n w"
     using  acceptable_rate by (simp add:discounted_value_def)
   ultimately show "AE w in N. real_cond_exp N (G n) (discounted_value r (prices Mkt stk) (Suc n)) w =
                     discounted_value r (prices Mkt stk) n w" by simp
 qed
 
 
 lemma (in CRR_market_viable) risky_asset_martingale_if:
   assumes "N = bernoulli_stream q"
   and "q = (1 + r - d) / (u - d)"
 shows "martingale N G (discounted_value r (prices Mkt stk))"
 proof (rule disc_martingale_charact)
   have qlt: "0 < q" and qgt: "q < 1" using assms gt_param lt_param CRR_viable by auto
   show "\<forall>n. integrable N (discounted_value r (prices Mkt stk) n)"
   proof
     fix n
     show "integrable N (discounted_value r (prices Mkt stk) n)"
     proof (rule discounted_integrable)
       show "space N = space M" using assms by (simp add: bernoulli bernoulli_stream_space)
       show "integrable N (prices Mkt stk n)"
       proof (rule infinite_coin_toss_space.nat_filtration_borel_measurable_integrable)
         show "infinite_coin_toss_space q N" using assms qlt qgt
           by (simp add: infinite_coin_toss_space_def)
         show "prices Mkt stk n \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N n)"
           using geom_rand_walk_borel_adapted stk_price  nat_filtration_from_eq_sets unfolding adapt_stoch_proc_def
           by (metis \<open>infinite_coin_toss_space q N\<close> borel_measurable_integrable geom_proc_integrable geom_rand_walk_pseudo_proj_True
               infinite_coin_toss_space.nat_filtration_borel_measurable_characterization infinite_coin_toss_space_def)
       qed
       show "-1 < r" using acceptable_rate by simp
     qed
   qed
   show "filtration N G" using qlt qgt by (simp add: bernoulli_gen_filtration assms)
   show "\<forall>n. sigma_finite_subalgebra N (G n)" using qlt qgt by (simp add: assms bernoulli_sigma_finite)
   show "\<forall>m. discounted_value r (prices Mkt stk) m \<in> borel_measurable (G m)"
   proof
     fix m
     have "discounted_value r (\<lambda>ma. prices Mkt stk m) m \<in> borel_measurable (G m)"
     proof (rule discounted_measurable)
       show "prices Mkt stk m \<in> borel_measurable (G m)" using stock_price_borel_measurable
         unfolding adapt_stoch_proc_def by simp
     qed
     thus "discounted_value r (prices Mkt stk) m \<in> borel_measurable (G m)"
       by (metis (mono_tags, lifting) discounted_value_def measurable_cong)
   qed
   show "\<forall>n. AE w in N. real_cond_exp N (G n)
        (discounted_value r (prices Mkt stk) (Suc n)) w = discounted_value r (prices Mkt stk) n w"
   proof
     fix n
     show "AE w in N. real_cond_exp N (G n)
        (discounted_value r (prices Mkt stk) (Suc n)) w = discounted_value r (prices Mkt stk) n w"
       using assms real_cond_exp_discount_stock_q_const by simp
   qed
 qed
 
 
 lemma (in CRR_market_viable) risk_neutral_iff':
   assumes "N = bernoulli_stream q"
 and "0 \<le> q"
 and "q \<le> 1"
 and "filt_equiv nat_filtration M N"
 shows "rfr_disc_equity_market.risk_neutral_prob G Mkt r N \<longleftrightarrow> q= (1 + r - d) / (u - d)"
 proof
   have "0 < q" and "q < 1" using assms filt_equiv_sgt filt_equiv_slt psgt pslt by auto note qprops = this
   have dem: "rfr_disc_equity_market M G Mkt r risk_free_asset"  by unfold_locales
   {
     assume "rfr_disc_equity_market.risk_neutral_prob G Mkt r N"
     hence "(prob_space N) \<and> (\<forall> asset \<in> stocks Mkt. martingale N G (discounted_value r (prices Mkt asset)))"
       using rfr_disc_equity_market.risk_neutral_prob_def[of M G Mkt] dem  by simp
     hence "martingale N G (discounted_value r (prices Mkt stk))" using stocks by simp
     thus "q = (1 + r - d) / (u - d)" using assms risky_asset_martingale_only_if[of N q] qprops by simp
   }
   {
     assume "q = (1 + r - d) / (u - d)"
     hence "martingale N G (discounted_value r (prices Mkt stk))" using risky_asset_martingale_if[of N q] assms by simp
     moreover have "martingale N G (discounted_value r (prices Mkt risk_free_asset))" using risk_free_asset_martingale
       assms qprops by simp
     ultimately show "rfr_disc_equity_market.risk_neutral_prob G Mkt r N" using stocks
       using assms(1) bernoulli_stream_def dem prob_space.prob_space_stream_space prob_space_measure_pmf
         rfr_disc_equity_market.risk_neutral_prob_def by fastforce
   }
 qed
 
 lemma (in CRR_market_viable) risk_neutral_iff:
   assumes "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
 shows "rfr_disc_equity_market.risk_neutral_prob G Mkt r N \<longleftrightarrow> q= (1 + r - d) / (u - d)"
   using bernoulli_stream_equiv assms risk_neutral_iff' psgt pslt by auto
 
 subsection \<open>Existence of a replicating portfolio\<close>
 
 
 
 
 fun (in CRR_market) rn_rev_price where
   "rn_rev_price N der matur 0 w = der w" |
   "rn_rev_price N der matur (Suc n) w = discount_factor r (Suc 0) w *
                                   expl_cond_expect N (proj_stoch_proc geom_proc (matur - Suc n)) (rn_rev_price N der matur n) w"
 
 
 
 
 
 
 lemma (in CRR_market) stock_filtration_eq:
   assumes "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
 shows "G n = stoch_proc_filt N geom_proc borel n"
 proof -
   have "G n= stoch_proc_filt M geom_proc borel n" using stock_filtration by simp
   also have "... = stoch_proc_filt N geom_proc borel n"
   proof (rule stoch_proc_filt_filt_equiv)
     show "filt_equiv nat_filtration M N" using assms bernoulli_stream_equiv psgt pslt by simp
   qed
   finally show ?thesis .
 qed
 
 
 
 lemma (in CRR_market) real_exp_eq:
   assumes "der\<in> borel_measurable (G matur)"
 and "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
 shows "real_cond_exp N (stoch_proc_filt N geom_proc borel n) der w =
       expl_cond_expect N (proj_stoch_proc geom_proc n) der w"
 proof -
   have "der \<in> borel_measurable (nat_filtration matur)" using assms
       using geom_rand_walk_borel_adapted measurable_from_subalg stoch_proc_subalg_nat_filt stock_filtration by blast
   have "integrable N der"
   proof (rule infinite_coin_toss_space.nat_filtration_borel_measurable_integrable)
     show "infinite_coin_toss_space q N" using assms
       by (simp add: infinite_coin_toss_space_def)
     show "der \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N matur)"
       by (metis \<open>der \<in> borel_measurable (nat_filtration matur)\<close> \<open>infinite_coin_toss_space q N\<close>
           assms(2) assms(3) assms(4) infinite_coin_toss_space.nat_filtration_space measurable_from_subalg
           nat_filtration_from_eq_sets nat_filtration_space subalgebra_def subset_eq)
   qed
   show "real_cond_exp N (stoch_proc_filt N geom_proc borel n) der w =
     expl_cond_expect N (proj_stoch_proc geom_proc n) der w"
   proof (rule bernoulli_cond_exp)
     show "N = bernoulli_stream q" "0 < q" "q < 1" using assms by auto
     show "integrable N der" using \<open>integrable N der\<close> .
   qed
 qed
 
 lemma (in CRR_market) rn_rev_price_rev_borel_adapt:
 assumes "cash_flow \<in> borel_measurable (G matur)"
 and "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
 shows "(n \<le> matur) \<Longrightarrow> (rn_rev_price N cash_flow matur n) \<in> borel_measurable (G (matur - n))"
 proof (induct n)
 case 0 thus ?case using assms by simp
 next
   case (Suc n)
   have "rn_rev_price N cash_flow matur (Suc n) =
       (\<lambda>w. discount_factor r (Suc 0) w *
         (expl_cond_expect N (proj_stoch_proc geom_proc (matur - Suc n)) (rn_rev_price N cash_flow matur n)) w)"
     using rn_rev_price.simps(2) by blast
   also have "... \<in> borel_measurable (G (matur - Suc n))"
   proof (rule borel_measurable_times)
     show "discount_factor r (Suc 0) \<in> borel_measurable (G (matur - Suc n))" by (simp add:discount_factor_borel_measurable)
     show "expl_cond_expect N (proj_stoch_proc geom_proc (matur - Suc n)) (rn_rev_price N cash_flow matur n)
       \<in> borel_measurable (G (matur - Suc n))" using assms by (simp add: bernoulli_expl_cond_expect_adapt)
   qed
   finally show "rn_rev_price N cash_flow matur (Suc n) \<in> borel_measurable (G (matur - Suc n))" .
 qed
 
 lemma (in infinite_coin_toss_space) bernoulli_discounted_integrable:
   assumes "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
   and "der \<in> borel_measurable (nat_filtration n)"
 and "-1 < r"
   shows "integrable N (discounted_value r (\<lambda>m. der) m)"
 proof -
   have "prob_space N" using assms
     by (simp add: bernoulli bernoulli_stream_def prob_space.prob_space_stream_space prob_space_measure_pmf)
   have "integrable N der"
   proof (rule infinite_coin_toss_space.nat_filtration_borel_measurable_integrable)
     show "infinite_coin_toss_space q N" using assms
       by (simp add: infinite_coin_toss_space_def)
     show "der \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N n)"
       using assms filt_equiv_filtration
       by (simp add: assms(1) measurable_def nat_filtration_from_eq_sets nat_filtration_space)
   qed
   thus ?thesis using discounted_integrable assms
     by (metis \<open>prob_space N\<close> prob_space.discounted_integrable)
 qed
 
 
 
 lemma (in CRR_market) rn_rev_expl_cond_expect:
   assumes "der\<in> borel_measurable (G matur)"
 and "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
 shows "n \<le> matur \<Longrightarrow> rn_rev_price N der matur n w =
   expl_cond_expect N (proj_stoch_proc geom_proc (matur - n)) (discounted_value r (\<lambda>m. der) n) w"
 proof (induct n arbitrary: w)
   case 0
   have "der \<in> borel_measurable (nat_filtration matur)" using assms
       using geom_rand_walk_borel_adapted measurable_from_subalg stoch_proc_subalg_nat_filt stock_filtration by blast
   have "integrable N der"
   proof (rule infinite_coin_toss_space.nat_filtration_borel_measurable_integrable)
     show "infinite_coin_toss_space q N" using assms
       by (simp add: infinite_coin_toss_space_def)
     show "der \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N matur)"
       by (metis \<open>der \<in> borel_measurable (nat_filtration matur)\<close> \<open>infinite_coin_toss_space q N\<close>
           assms(2) assms(3) assms(4) infinite_coin_toss_space.nat_filtration_space measurable_from_subalg
           nat_filtration_from_eq_sets nat_filtration_space subalgebra_def subset_eq)
   qed
   have "rn_rev_price N der matur 0 w = der w" by simp
   also have "... = expl_cond_expect N (proj_stoch_proc geom_proc matur) (discounted_value r (\<lambda>m. der) 0) w"
   proof (rule nat_filtration_AE_eq)
     show "der \<in> borel_measurable (nat_filtration matur)" using \<open>der \<in> borel_measurable (nat_filtration matur)\<close> .
     have "(discounted_value r (\<lambda>m. der) 0) = der" unfolding discounted_value_def discount_factor_def by simp
     moreover have "AEeq N (real_cond_exp N (G matur) der) der"
     proof (rule sigma_finite_subalgebra.real_cond_exp_F_meas)
       show "der \<in> borel_measurable (G matur)" using assms by simp
       show "integrable N der" using \<open>integrable N der\<close> .
       show "sigma_finite_subalgebra N (G matur)" using bernoulli_sigma_finite
         using assms by simp
     qed
     moreover have "\<forall>w. real_cond_exp N (stoch_proc_filt N geom_proc borel matur) der w =
       expl_cond_expect N (proj_stoch_proc geom_proc matur) der w" using assms real_exp_eq by simp
     ultimately have eqn: "AEeq N der (expl_cond_expect N (proj_stoch_proc geom_proc matur) (discounted_value r (\<lambda>m. der) 0))"
       using stock_filtration_eq assms by auto
     have "stoch_proc_filt M geom_proc borel matur = stoch_proc_filt N geom_proc borel matur"
       using  bernoulli_stream_equiv[of N q] assms psgt pslt by (simp add: stoch_proc_filt_filt_equiv)
     also have "stoch_proc_filt N geom_proc borel matur =
       fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc matur)"
       using assms geom_proc_stoch_proc_filt by simp
     finally have "stoch_proc_filt M geom_proc borel matur =
       fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc matur)" .
     moreover have "expl_cond_expect N (proj_stoch_proc geom_proc matur) (discounted_value r (\<lambda>m. der) 0)
       \<in> borel_measurable (fct_gen_subalgebra N (stream_space borel) (proj_stoch_proc geom_proc matur))"
     proof (rule expl_cond_exp_borel)
       show "proj_stoch_proc geom_proc matur \<in> space N \<rightarrow> space (stream_space borel)"
         using assms proj_stoch_proc_geom_rng by (simp add: measurable_def)
       show "disc_fct (proj_stoch_proc geom_proc matur)" using proj_stoch_proc_geom_disc_fct by simp
       show "\<forall>r\<in>range (proj_stoch_proc geom_proc matur) \<inter> space (stream_space borel).
         \<exists>A\<in>sets (stream_space borel). range (proj_stoch_proc geom_proc matur) \<inter> A = {r}"
         using proj_stoch_proc_geom_open_set by simp
     qed
     ultimately show ebm: "expl_cond_expect N (proj_stoch_proc geom_proc matur) (discounted_value r (\<lambda>m. der) 0)
       \<in> borel_measurable (nat_filtration matur)"
       by (metis geom_rand_walk_borel_adapted measurable_from_subalg stoch_proc_subalg_nat_filt)
     show "AEeq M der (expl_cond_expect N (proj_stoch_proc geom_proc matur) (discounted_value r (\<lambda>m. der) 0))"
     proof (rule filt_equiv_borel_AE_eq_iff[THEN iffD2])
       show "filt_equiv nat_filtration M N" using assms bernoulli_stream_equiv psgt pslt by simp
       show "der \<in> borel_measurable (nat_filtration matur)" using \<open>der \<in> borel_measurable (nat_filtration matur)\<close> .
       show "AEeq N der (expl_cond_expect N (proj_stoch_proc geom_proc matur) (discounted_value r (\<lambda>m. der) 0))"
         using eqn .
       show "expl_cond_expect N (proj_stoch_proc geom_proc matur) (discounted_value r (\<lambda>m. der) 0)
         \<in> borel_measurable (nat_filtration matur)" using ebm .
       show "prob_space N" using assms by (simp add: bernoulli_stream_def
             prob_space.prob_space_stream_space prob_space_measure_pmf)
       show "prob_space M" by (simp add: bernoulli bernoulli_stream_def
             prob_space.prob_space_stream_space prob_space_measure_pmf)
     qed
     show "0 < p" "p < 1" using psgt pslt by auto
   qed
   also have "... = expl_cond_expect N (proj_stoch_proc geom_proc (matur - 0)) (discounted_value r (\<lambda>m. der) 0) w"
     by simp
   finally show "rn_rev_price N der matur 0 w =
     expl_cond_expect N (proj_stoch_proc geom_proc (matur - 0)) (discounted_value r (\<lambda>m. der) 0) w" .
 next
   case (Suc n)
   have "rn_rev_price N der matur (Suc n) w = discount_factor r (Suc 0) w *
           expl_cond_expect N (proj_stoch_proc geom_proc (matur - Suc n)) (rn_rev_price N der matur n) w" by simp
   also have "... = discount_factor r (Suc 0) w *
     real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) (rn_rev_price N der matur n) w"
   proof -
     have "expl_cond_expect N (proj_stoch_proc geom_proc (matur - Suc n)) (rn_rev_price N der matur n) w =
      real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) (rn_rev_price N der matur n) w"
     proof (rule real_exp_eq[symmetric])
       show "rn_rev_price N der matur n \<in> borel_measurable (G (matur - n))"
         using assms rn_rev_price_rev_borel_adapt Suc by simp
       show "N = bernoulli_stream q" "0 < q" "q < 1" using assms by auto
     qed
     thus ?thesis by simp
   qed
   also have "... = discount_factor r (Suc 0) w *
     real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
     (expl_cond_expect N (proj_stoch_proc geom_proc (matur - n)) (discounted_value r (\<lambda>m. der) n)) w"
   proof -
     have "real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) (rn_rev_price N der matur n) w =
       real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
     (expl_cond_expect N (proj_stoch_proc geom_proc (matur - n)) (discounted_value r (\<lambda>m. der) n)) w"
     proof (rule infinite_coin_toss_space.nat_filtration_AE_eq)
       show "AEeq N (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) (rn_rev_price N der matur n))
         (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
         (expl_cond_expect N (proj_stoch_proc geom_proc (matur - n)) (discounted_value r (\<lambda>m. der) n)))"
       proof (rule sigma_finite_subalgebra.real_cond_exp_cong)
         show "sigma_finite_subalgebra N (stoch_proc_filt N geom_proc borel (matur - Suc n))"
           using assms(2) assms(3) assms(4) bernoulli_sigma_finite stock_filtration_eq by auto
         show "rn_rev_price N der matur n \<in> borel_measurable N"
         proof -
           have "rn_rev_price N der matur n \<in> borel_measurable (G (matur - n))"
             by (metis (full_types) Suc.prems Suc_leD assms(1) assms(2) assms(3) assms(4) rn_rev_price_rev_borel_adapt)
           then show ?thesis
             by (metis (no_types) assms(2) bernoulli bernoulli_stream_def filtration_measurable measurable_cong_sets sets_measure_pmf sets_stream_space_cong)
         qed
         show "expl_cond_expect N (proj_stoch_proc geom_proc (matur - n)) (discounted_value r (\<lambda>m. der) n) \<in> borel_measurable N"
           using Suc.hyps Suc.prems Suc_leD \<open>rn_rev_price N der matur n \<in> borel_measurable N\<close> by presburger
         show "AEeq N (rn_rev_price N der matur n)
           (expl_cond_expect N (proj_stoch_proc geom_proc (matur - n)) (discounted_value r (\<lambda>m. der) n))" using Suc by auto
       qed
       show "real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) (rn_rev_price N der matur n)
         \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N (matur - Suc n))"
         by (metis assms(2) assms(3) assms(4) borel_measurable_cond_exp infinite_coin_toss_space.intro
             infinite_coin_toss_space.stoch_proc_subalg_nat_filt linear measurable_from_subalg not_less
             prob_grw.geom_rand_walk_borel_adapted prob_grw_axioms prob_grw_def)
       show "real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
          (expl_cond_expect N (proj_stoch_proc geom_proc (matur - n)) (discounted_value r (\<lambda>m. der) n))
         \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N (matur - Suc n))"
         by (metis assms(2) assms(3) assms(4) borel_measurable_cond_exp infinite_coin_toss_space.intro
               infinite_coin_toss_space.stoch_proc_subalg_nat_filt linear measurable_from_subalg not_less
               prob_grw.geom_rand_walk_borel_adapted prob_grw_axioms prob_grw_def)
       show "0 < q" "q < 1" using assms by auto
       show "infinite_coin_toss_space q N" using assms
         by (simp add: infinite_coin_toss_space_def)
     qed
     thus ?thesis by simp
   qed
   also have "... = discount_factor r (Suc 0) w *
   real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
    (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - n)) (discounted_value r (\<lambda>m. der) n)) w"
   proof -
     have "real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
       (expl_cond_expect N (proj_stoch_proc geom_proc (matur - n)) (discounted_value r (\<lambda>m. der) n)) w =
       real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
       (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - n)) (discounted_value r (\<lambda>m. der) n)) w"
     proof (rule infinite_coin_toss_space.nat_filtration_AE_eq)
       show "AEeq N (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
              (expl_cond_expect N (proj_stoch_proc geom_proc (matur - n)) (discounted_value r (\<lambda>m. der) n)))
          (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
            (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - n)) (discounted_value r (\<lambda>m. der) n)))"
       proof (rule sigma_finite_subalgebra.real_cond_exp_cong)
         show "sigma_finite_subalgebra N (stoch_proc_filt N geom_proc borel (matur - Suc n))"
           using assms(2) assms(3) assms(4) bernoulli_sigma_finite stock_filtration_eq by auto
         show "real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - n)) (discounted_value r (\<lambda>m. der) n) \<in> borel_measurable N"
           by simp
         show "expl_cond_expect N (proj_stoch_proc geom_proc (matur - n)) (discounted_value r (\<lambda>m. der) n) \<in> borel_measurable N"
           by (metis assms(2) assms(3) assms(4) bernoulli bernoulli_expl_cond_expect_adapt bernoulli_stream_def filtration_measurable
               measurable_cong_sets sets_measure_pmf sets_stream_space_cong)
         show "AEeq N (expl_cond_expect N (proj_stoch_proc geom_proc (matur - n)) (discounted_value r (\<lambda>m. der) n))
           (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - n)) (discounted_value r (\<lambda>m. der) n))"
         proof -
           have "discounted_value r (\<lambda>m. der) n \<in> borel_measurable (G matur)" using assms discounted_measurable[of der]
             by simp
           hence "\<forall>w. (expl_cond_expect N (proj_stoch_proc geom_proc (matur - n)) (discounted_value r (\<lambda>m. der) n)) w =
             (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - n)) (discounted_value r (\<lambda>m. der) n)) w"
             using real_exp_eq[of _ matur N q "matur-n"] assms by simp
           thus ?thesis by simp
         qed
       qed
       show "real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
          (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - n)) (discounted_value r (\<lambda>m. der) n))
         \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N (matur - Suc n))"
         by (metis assms(2) assms(3) assms(4) borel_measurable_cond_exp infinite_coin_toss_space.intro
               infinite_coin_toss_space.stoch_proc_subalg_nat_filt linear measurable_from_subalg not_less
               prob_grw.geom_rand_walk_borel_adapted prob_grw_axioms prob_grw_def)
       show "real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
          (expl_cond_expect N (proj_stoch_proc geom_proc (matur - n)) (discounted_value r (\<lambda>m. der) n))
         \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N (matur - Suc n))"
         by (metis assms(2) assms(3) assms(4) borel_measurable_cond_exp infinite_coin_toss_space.intro
               infinite_coin_toss_space.stoch_proc_subalg_nat_filt linear measurable_from_subalg not_less
               prob_grw.geom_rand_walk_borel_adapted prob_grw_axioms prob_grw_def)
       show "0 < q" "q < 1" using assms by auto
       show "infinite_coin_toss_space q N" using assms
         by (simp add: infinite_coin_toss_space_def)
     qed
     thus ?thesis by simp
   qed
   also have "... = real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
     (discounted_value r (\<lambda>m. der) (Suc n)) w"
   proof (rule infinite_coin_toss_space.nat_filtration_AE_eq)
     show "real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) (discounted_value r (\<lambda>m. der) (Suc n))
       \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N (matur - Suc n))"
         by (metis assms(2) assms(3) assms(4) borel_measurable_cond_exp infinite_coin_toss_space.intro
               infinite_coin_toss_space.stoch_proc_subalg_nat_filt linear measurable_from_subalg not_less
               prob_grw.geom_rand_walk_borel_adapted prob_grw_axioms prob_grw_def)
       show "(\<lambda>a. discount_factor r (Suc 0) a *
           real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
            (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - n)) (discounted_value r (\<lambda>m. der) n)) a)
         \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N (matur - Suc n))"
       proof -
         have "real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
            (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - n)) (discounted_value r (\<lambda>m. der) n))
         \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N (matur - Suc n))"
         by (metis assms(2) assms(3) assms(4) borel_measurable_cond_exp infinite_coin_toss_space.intro
               infinite_coin_toss_space.stoch_proc_subalg_nat_filt linear measurable_from_subalg not_less
               prob_grw.geom_rand_walk_borel_adapted prob_grw_axioms prob_grw_def)
       thus ?thesis using discounted_measurable[of "real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
         (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - n)) (discounted_value r (\<lambda>m. der) n))"]
         unfolding discounted_value_def by simp
     qed
     show "0 < q" "q < 1" using assms by auto
     show "infinite_coin_toss_space q N" using assms
       by (simp add: infinite_coin_toss_space_def)
     show "AEeq N (\<lambda>w. discount_factor r (Suc 0) w *
                  real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
                   (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - n)) (discounted_value r (\<lambda>m. der) n)) w)
      (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) (discounted_value r (\<lambda>m. der) (Suc n)))"
     proof-
       have "AEeq N
         (\<lambda>w. discount_factor r (Suc 0) w *
                  real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
                   (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - n)) (discounted_value r (\<lambda>m. der) n)) w)
         (\<lambda>w. discount_factor r (Suc 0) w *
                  real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) (discounted_value r (\<lambda>m. der) n) w)"
       proof -
         have "AEeq N (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
                   (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - n)) (discounted_value r (\<lambda>m. der) n)))
                 (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) (discounted_value r (\<lambda>m. der) n))"
         proof (rule sigma_finite_subalgebra.real_cond_exp_nested_subalg)
           show "sigma_finite_subalgebra N (stoch_proc_filt N geom_proc borel (matur - Suc n))"
             using assms(2) assms(3) assms(4) bernoulli_sigma_finite stock_filtration_eq by auto
           show "subalgebra N (stoch_proc_filt N geom_proc borel (matur - n))"
             using assms(2) assms(3) assms(4) bernoulli_sigma_finite sigma_finite_subalgebra.subalg
               stock_filtration_eq by fastforce
           show "subalgebra (stoch_proc_filt N geom_proc borel (matur - n)) (stoch_proc_filt N geom_proc borel (matur - Suc n))"
           proof -
             have "init_triv_filt M (stoch_proc_filt M geom_proc borel)" using infinite_cts_filtration.stoch_proc_filt_triv_init
               using info_filtration stock_filtration by auto
             moreover have "matur - (Suc n) \<le> matur - n" by simp
             ultimately show ?thesis unfolding init_triv_filt_def filtration_def
               using assms(2) assms(3) assms(4) stock_filtration stock_filtration_eq by auto
           qed
           show "integrable N (discounted_value r (\<lambda>m. der) n) " using bernoulli_discounted_integrable[of N q der matur r n] acceptable_rate assms
             using geom_rand_walk_borel_adapted measurable_from_subalg stoch_proc_subalg_nat_filt stock_filtration by blast
         qed
         thus ?thesis  by auto
       qed
       moreover have "AEeq N
         (\<lambda>w. discount_factor r (Suc 0) w *
          real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) (discounted_value r (\<lambda>m. der) n) w)
         (\<lambda>w. discount_factor r (Suc 0) w * (discounted_value r
          (\<lambda>m. real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) der) n) w)"
       proof -
         have "AEeq N (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) (discounted_value r (\<lambda>m. der) n))
           (discounted_value r
          (\<lambda>m. real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) der) n)"
         proof (rule prob_space.discounted_value_real_cond_exp)
           show "prob_space N" using assms
             by (simp add: bernoulli bernoulli_stream_def prob_space.prob_space_stream_space prob_space_measure_pmf)
           have "der \<in> borel_measurable (nat_filtration matur)" using assms
             using geom_rand_walk_borel_adapted measurable_from_subalg stoch_proc_subalg_nat_filt stock_filtration by blast
           show "integrable N der"
           proof (rule infinite_coin_toss_space.nat_filtration_borel_measurable_integrable)
             show "infinite_coin_toss_space q N" using assms
               by (simp add: infinite_coin_toss_space_def)
             show "der \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N matur)"
               by (metis \<open>der \<in> borel_measurable (nat_filtration matur)\<close> \<open>infinite_coin_toss_space q N\<close>
                   assms(2) assms(3) assms(4) infinite_coin_toss_space.nat_filtration_space measurable_from_subalg
                   nat_filtration_from_eq_sets nat_filtration_space subalgebra_def subset_eq)
           qed
           show "-1 < r" using acceptable_rate .
           show "subalgebra N (stoch_proc_filt N geom_proc borel (matur - Suc n))"
             using assms(2) assms(3) assms(4) bernoulli_sigma_finite sigma_finite_subalgebra.subalg
               stock_filtration_eq by fastforce
         qed
         thus ?thesis  by auto
       qed
       moreover have "\<forall>w. (\<lambda>w. discount_factor r (Suc 0) w * (discounted_value r
          (\<lambda>m. real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) der) n) w) w =
         (discounted_value r
          (\<lambda>m. real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) der) (Suc n)) w"
         unfolding discounted_value_def discount_factor_def  by simp
       moreover have "AEeq N
         (real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n))
         (discounted_value r (\<lambda>m. der) (Suc n)))
         (discounted_value r
         (\<lambda>m. real_cond_exp N (stoch_proc_filt N geom_proc borel (matur - Suc n)) der) (Suc n))"
       proof (rule prob_space.discounted_value_real_cond_exp)
         show "prob_space N" using assms
             by (simp add: bernoulli bernoulli_stream_def prob_space.prob_space_stream_space prob_space_measure_pmf)
         have "der \<in> borel_measurable (nat_filtration matur)" using assms
           using geom_rand_walk_borel_adapted measurable_from_subalg stoch_proc_subalg_nat_filt stock_filtration by blast
         show "integrable N der"
         proof (rule infinite_coin_toss_space.nat_filtration_borel_measurable_integrable)
           show "infinite_coin_toss_space q N" using assms
             by (simp add: infinite_coin_toss_space_def)
           show "der \<in> borel_measurable (infinite_coin_toss_space.nat_filtration N matur)"
             by (metis \<open>der \<in> borel_measurable (nat_filtration matur)\<close> \<open>infinite_coin_toss_space q N\<close>
                 assms(2) assms(3) assms(4) infinite_coin_toss_space.nat_filtration_space measurable_from_subalg
                 nat_filtration_from_eq_sets nat_filtration_space subalgebra_def subset_eq)
         qed
         show "-1 < r" using acceptable_rate .
         show "subalgebra N (stoch_proc_filt N geom_proc borel (matur - Suc n))"
           using assms(2) assms(3) assms(4) bernoulli_sigma_finite sigma_finite_subalgebra.subalg
             stock_filtration_eq by fastforce
       qed
       ultimately show ?thesis by auto
     qed
   qed
   also have "... = expl_cond_expect N (proj_stoch_proc geom_proc (matur - Suc n))
     (discounted_value r (\<lambda>m. der) (Suc n)) w"
   proof (rule real_exp_eq)
     show "discounted_value r (\<lambda>m. der) (Suc n) \<in> borel_measurable (G matur)" using assms discounted_measurable[of der]
       by simp
     show "N = bernoulli_stream q" "0 < q" "q < 1" using assms by auto
   qed
   finally show "rn_rev_price N der matur (Suc n) w =
     expl_cond_expect N (proj_stoch_proc geom_proc (matur - Suc n)) (discounted_value r (\<lambda>m. der) (Suc n)) w" .
 qed
 
 definition (in CRR_market) rn_price where
 "rn_price N der matur n w = expl_cond_expect N (proj_stoch_proc geom_proc n) (discounted_value r (\<lambda>m. der) (matur - n)) w"
 
 
 definition (in CRR_market) rn_price_ind where
 "rn_price_ind N der matur n w = rn_rev_price N der matur (matur - n) w"
 
 lemma (in CRR_market) rn_price_eq:
   assumes "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
 and "der \<in> borel_measurable (G matur)"
 and "n \<le> matur"
 shows "rn_price N der matur n w = rn_price_ind N der matur n w" using rn_rev_expl_cond_expect
   unfolding rn_price_def rn_price_ind_def
   by (simp add: assms)
 
 
 lemma (in CRR_market) geom_proc_filt_info:
   fixes f::"bool stream \<Rightarrow> 'b::{t0_space}"
   assumes "f \<in> borel_measurable (G n)"
   shows "f w = f (pseudo_proj_True n w)"
 proof -
   have "subalgebra (nat_filtration n) (G n)" using stoch_proc_subalg_nat_filt[of geom_proc n] geometric_process
     stock_filtration geom_rand_walk_borel_adapted by simp
   hence "f\<in> borel_measurable (nat_filtration n)" using assms by (simp add: measurable_from_subalg)
   thus ?thesis using nat_filtration_info[of f n] by (metis comp_apply)
 qed
 
 lemma (in CRR_market) geom_proc_filt_info':
   fixes f::"bool stream \<Rightarrow> 'b::{t0_space}"
   assumes "f \<in> borel_measurable (G n)"
   shows "f w = f (pseudo_proj_False n w)"
 proof -
   have "subalgebra (nat_filtration n) (G n)" using stoch_proc_subalg_nat_filt[of geom_proc n] geometric_process
     stock_filtration geom_rand_walk_borel_adapted by simp
   hence "f\<in> borel_measurable (nat_filtration n)" using assms by (simp add: measurable_from_subalg)
   thus ?thesis using nat_filtration_info'[of f n] by (metis comp_apply)
 qed
 
 
 
 
 lemma (in CRR_market) rn_price_borel_adapt:
 assumes "cash_flow \<in> borel_measurable (G matur)"
 and "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
 and "n \<le> matur"
 shows "(rn_price N cash_flow matur n) \<in> borel_measurable (G n)"
 proof -
   show "(rn_price N cash_flow matur n) \<in> borel_measurable (G n)"
     using assms rn_rev_price_rev_borel_adapt[of cash_flow matur N q "matur - n"] rn_price_eq rn_price_ind_def
     by (smt add.right_neutral cancel_comm_monoid_add_class.diff_cancel diff_commute diff_le_self
         increasing_measurable_info measurable_cong nat_le_linear ordered_cancel_comm_monoid_diff_class.add_diff_inverse)
 qed
 
 
 definition (in CRR_market) delta_price where
   "delta_price N cash_flow T =
     (\<lambda> n w. if (Suc n \<le> T)
       then (rn_price N cash_flow T (Suc n) (pseudo_proj_True n w) - rn_price N cash_flow T (Suc n) (pseudo_proj_False n w))/
         (geom_proc (Suc n) (spick w n True) - geom_proc (Suc n) (spick w n False))
       else 0)"
 
 
 lemma (in CRR_market) delta_price_eq:
   assumes "Suc n \<le> T"
   shows "delta_price N cash_flow T n w = (rn_price N cash_flow T (Suc n) (spick w n True) - rn_price N cash_flow T (Suc n) (spick w n False))/
     ((geom_proc n w) * (u - d))"
 proof -
-  have "(geom_proc (Suc n) (spick w n True) - geom_proc (Suc n) (spick w n False)) = u * geom_proc n w - d * geom_proc n w"
-    using geometric_process
-    by (metis geom_rand_walk_diff_induct linordered_field_class.sign_simps(39) mult.commute)
-  also have "... = geom_proc n w * (u - d)"
-    by (simp add: linordered_field_class.sign_simps(39) mult.commute)
-  finally have "(geom_proc (Suc n) (spick w n True) - geom_proc (Suc n) (spick w n False)) = geom_proc n w * (u - d)" .
+  have "(geom_proc (Suc n) (spick w n True) - geom_proc (Suc n) (spick w n False)) = geom_proc n w * (u - d)"
+    by (simp add: geom_rand_walk_diff_induct)
   then show ?thesis unfolding delta_price_def using assms spick_eq_pseudo_proj_True spick_eq_pseudo_proj_False by simp
 qed
 
 
 
 lemma (in CRR_market) geom_proc_spick:
   shows "geom_proc (Suc n) (spick w n x)  = (if x then u else d) * geom_proc n w"
 proof -
   have "geom_proc (Suc n) (spick w n x)  = geom_rand_walk u d init (Suc n) (spick w n x)" using geometric_process by simp
   also have "... = (case (spick w n x) !! n of True \<Rightarrow> u | False \<Rightarrow> d) * geom_rand_walk u d init n (spick w n x)"
     by simp
   also have "... = (case x of True \<Rightarrow> u | False \<Rightarrow> d) * geom_rand_walk u d init n (spick w n x)"
     unfolding spick_def by simp
   also have "... = (if x then u else d) * geom_rand_walk u d init n (spick w n x)" by simp
   also have "... = (if x then u else d) * geom_rand_walk u d init n w"
     by (metis comp_def geom_rand_walk_pseudo_proj_True geometric_process pseudo_proj_True_stake_image spickI)
   finally show ?thesis using geometric_process by simp
 qed
 
 
 lemma (in CRR_market) spick_red_geom:
   shows "(\<lambda>w. spick w n x) \<in> measurable (fct_gen_subalgebra M borel (geom_proc n)) (fct_gen_subalgebra M borel (geom_proc (Suc n)))"
   unfolding measurable_def
 proof (intro CollectI conjI)
   show "(\<lambda>w. spick w n x)
     \<in> space (fct_gen_subalgebra M borel (geom_proc n)) \<rightarrow> space (fct_gen_subalgebra M borel (geom_proc (Suc n)))"
     by (simp add: bernoulli bernoulli_stream_space fct_gen_subalgebra_space)
   show "\<forall>y\<in>sets (fct_gen_subalgebra M borel (geom_proc (Suc n))).
        (\<lambda>w. spick w n x) -` y \<inter> space (fct_gen_subalgebra M borel (geom_proc n))
        \<in> sets (fct_gen_subalgebra M borel (geom_proc n))"
   proof
     fix A
     assume A: "A \<in> sets (fct_gen_subalgebra M borel (geom_proc (Suc n)))"
     show "(\<lambda>w. spick w n x) -` A \<inter> space (fct_gen_subalgebra M borel (geom_proc n)) \<in>
     sets (fct_gen_subalgebra M borel (geom_proc n))"
     proof -
       define sp where "sp = (\<lambda>w. spick w n x)"
       have "A \<in> {(geom_proc (Suc n)) -` B \<inter> space M |B. B \<in> sets borel}" using A
         by (simp add:fct_gen_subalgebra_sigma_sets)
       from this obtain C where "C\<in> sets borel" and "A = (geom_proc (Suc n)) -`C \<inter> space M" by auto
       hence "A = (geom_proc (Suc n)) -`C" using bernoulli bernoulli_stream_space by simp
       hence "sp -`A = sp -` (geom_proc (Suc n)) -`C" by simp
       also have "... = (geom_proc (Suc n) \<circ> sp) -` C" by auto
       also have "... = (\<lambda>w. (if x then u else d) * geom_proc n w) -` C" using geom_proc_spick
         sp_def by auto
       also have "... \<in> sets (fct_gen_subalgebra M borel (geom_proc n))"
       proof (cases x)
         case True
         hence "(\<lambda>w. (if x then u else d) * geom_proc n w) -` C = (\<lambda>w. u * geom_proc n w) -` C" by simp
         moreover have "(\<lambda>w. u * geom_proc n w) \<in> borel_measurable (fct_gen_subalgebra M borel (geom_proc n))"
         proof -
           have "geom_proc n \<in>borel_measurable (fct_gen_subalgebra M borel (geom_proc n))"
             using fct_gen_subalgebra_fct_measurable
             by (metis (no_types, lifting) geom_rand_walk_borel_measurable measurable_def mem_Collect_eq)
           thus ?thesis by simp
         qed
         ultimately show ?thesis using \<open>C\<in> sets borel\<close>
           by (metis bernoulli bernoulli_stream_preimage fct_gen_subalgebra_space measurable_sets)
       next
         case False
         hence "(\<lambda>w. (if x then u else d) * geom_proc n w) -` C = (\<lambda>w. d * geom_proc n w) -` C" by simp
         moreover have "(\<lambda>w. d * geom_proc n w) \<in> borel_measurable (fct_gen_subalgebra M borel (geom_proc n))"
         proof -
           have "geom_proc n \<in>borel_measurable (fct_gen_subalgebra M borel (geom_proc n))"
             using fct_gen_subalgebra_fct_measurable
             by (metis (no_types, lifting) geom_rand_walk_borel_measurable measurable_def mem_Collect_eq)
           thus ?thesis by simp
         qed
         ultimately show ?thesis using \<open>C\<in> sets borel\<close>
           by (metis bernoulli bernoulli_stream_preimage fct_gen_subalgebra_space measurable_sets)
       qed
       finally show ?thesis unfolding sp_def by (simp add: bernoulli bernoulli_stream_space fct_gen_subalgebra_space)
     qed
   qed
 qed
 
 lemma (in CRR_market) geom_spick_Suc:
   assumes "A \<in> {(geom_proc (Suc n)) -` B |B. B \<in> sets borel}"
   shows "(\<lambda>w. spick w n x) -`A \<in> {geom_proc n -`B | B. B\<in> sets borel}"
 proof -
   have "sets (fct_gen_subalgebra M borel (geom_proc n)) = {geom_proc n -` B \<inter>space M |B. B \<in> sets borel}"
     by (simp add: fct_gen_subalgebra_sigma_sets)
   also have "... =  {geom_proc n -` B |B. B \<in> sets borel}" using bernoulli bernoulli_stream_space by simp
   finally have sf: "sets (fct_gen_subalgebra M borel (geom_proc n)) = {geom_proc n -` B |B. B \<in> sets borel}" .
   define sp where "sp = (\<lambda>w. spick w n x)"
   from assms(1) obtain C where "C\<in> sets borel" and "A = (geom_proc (Suc n)) -`C" by auto
   hence "A = (geom_proc (Suc n)) -`C" using bernoulli bernoulli_stream_space by simp
   hence "sp -`A = sp -` (geom_proc (Suc n)) -`C" by simp
   also have "... = (geom_proc (Suc n) \<circ> sp) -` C" by auto
   also have "... = (\<lambda>w. (if x then u else d) * geom_proc n w) -` C" using geom_proc_spick
     sp_def by auto
   also have "... \<in> {geom_proc n -`B | B. B\<in> sets borel}"
   proof (cases x)
     case True
     hence "(\<lambda>w. (if x then u else d) * geom_proc n w) -` C = (\<lambda>w. u * geom_proc n w) -` C" by simp
     moreover have "(\<lambda>w. u * geom_proc n w) \<in> borel_measurable (fct_gen_subalgebra M borel (geom_proc n))"
     proof -
       have "geom_proc n \<in>borel_measurable (fct_gen_subalgebra M borel (geom_proc n))"
         using fct_gen_subalgebra_fct_measurable
         by (metis (no_types, lifting) geom_rand_walk_borel_measurable measurable_def mem_Collect_eq)
       thus ?thesis by simp
     qed
     ultimately show ?thesis using \<open>C\<in> sets borel\<close> sf
       by (simp add: bernoulli bernoulli_stream_preimage fct_gen_subalgebra_space in_borel_measurable_borel)
   next
     case False
     hence "(\<lambda>w. (if x then u else d) * geom_proc n w) -` C = (\<lambda>w. d * geom_proc n w) -` C" by simp
     moreover have "(\<lambda>w. d * geom_proc n w) \<in> borel_measurable (fct_gen_subalgebra M borel (geom_proc n))"
     proof -
       have "geom_proc n \<in>borel_measurable (fct_gen_subalgebra M borel (geom_proc n))"
         using fct_gen_subalgebra_fct_measurable
         by (metis (no_types, lifting) geom_rand_walk_borel_measurable measurable_def mem_Collect_eq)
       thus ?thesis by simp
     qed
     ultimately show ?thesis using \<open>C\<in> sets borel\<close> sf
       by (simp add: bernoulli bernoulli_stream_preimage fct_gen_subalgebra_space in_borel_measurable_borel)
   qed
   finally show ?thesis unfolding sp_def .
 qed
 
 
 lemma (in CRR_market) geom_spick_lt:
   assumes "m< n"
   shows "geom_proc m (spick w n x) = geom_proc m w"
 proof -
   have "geom_proc m (spick w n x) = geom_proc m (pseudo_proj_True m (spick w n x))"
     using  geom_rand_walk_pseudo_proj_True by (metis comp_apply)
   also have "... = geom_proc m (pseudo_proj_True m w)" using assms
     by (metis less_imp_le_nat pseudo_proj_True_def pseudo_proj_True_prefix spickI)
   also have "... = geom_proc m w" using  geom_rand_walk_pseudo_proj_True by (metis comp_apply)
   finally show ?thesis .
 qed
 
 lemma (in CRR_market) geom_spick_eq:
   shows "geom_proc m (spick w m x) = geom_proc m w"
 proof (cases x)
   case True
   have "geom_proc m (spick w m x) = geom_proc m (pseudo_proj_True m (spick w m x))"
     using  geom_rand_walk_pseudo_proj_True by (metis comp_apply)
   also have "... = geom_proc m (pseudo_proj_True m w)" using True
     by (metis pseudo_proj_True_def spickI)
   also have "... = geom_proc m w" using  geom_rand_walk_pseudo_proj_True by (metis comp_apply)
   finally show ?thesis .
 next
   case False
   have "geom_proc m (spick w m x) = geom_proc m (pseudo_proj_False m (spick w m x))"
     using  geom_rand_walk_pseudo_proj_False by (metis comp_apply)
   also have "... = geom_proc m (pseudo_proj_False m w)" using False
     by (metis pseudo_proj_False_def spickI)
   also have "... = geom_proc m w" using  geom_rand_walk_pseudo_proj_False by (metis comp_apply)
   finally show ?thesis .
 qed
 
 
 lemma (in CRR_market) spick_red_geom_filt:
   shows "(\<lambda>w. spick w n x) \<in> measurable (G n) (G (Suc n))" unfolding measurable_def
 proof (intro CollectI conjI)
   show "(\<lambda>w. spick w n x) \<in> space (G n) \<rightarrow> space (G (Suc n))" using stock_filtration
     by (simp add: bernoulli bernoulli_stream_space stoch_proc_filt_space)
   show "\<forall>y\<in>sets (G (Suc n)). (\<lambda>w. spick w n x) -` y \<inter> space (G n) \<in> sets (G n)"
   proof
     fix B
     assume "B\<in> sets (G (Suc n))"
     hence "B\<in> (sigma_sets (space M) (\<Union> i\<in> {m. m\<le> (Suc n)}. {(geom_proc i -`A) \<inter> (space M) | A. A\<in> sets borel }))"
       using stock_filtration stoch_proc_filt_sets geometric_process
     proof -
       have "\<forall>n. sigma_sets (space M) (\<Union>n\<in>{na. na \<le> n}. {geom_proc n -` R \<inter> space M |R. R \<in> sets borel}) = sets (G n)"
         by (simp add: geom_rand_walk_borel_measurable stoch_proc_filt_sets stock_filtration)
       then show ?thesis
         using \<open>B \<in> sets (G (Suc n))\<close> by blast
     qed
     hence "(\<lambda>w. spick w n x) -` B \<in> sets (G n)"
     proof (induct rule:sigma_sets.induct)
       {
         fix C
         assume "C \<in> (\<Union>i\<in>{m. m \<le> Suc n}. {geom_proc i -` A \<inter> space M |A. A \<in> sets borel})"
         hence "\<exists>m \<le> Suc n. C\<in> {geom_proc m -` A \<inter> space M |A. A \<in> sets borel}" by auto
         from this obtain m where "m\<le> Suc n" and "C\<in> {geom_proc m -` A \<inter> space M |A. A \<in> sets borel}" by auto
         note Cprops = this
         from this obtain D where "C = geom_proc m -` D\<inter> space M" and "D\<in> sets borel" by auto
         hence "C = geom_proc m -`D" using bernoulli bernoulli_stream_space by simp
         have "C\<in> {geom_proc m -` A |A. A \<in> sets borel}" using bernoulli bernoulli_stream_space Cprops by simp
         show "(\<lambda>w. spick w n x) -` C \<in> sets (G n)"
         proof (cases "m \<le> n")
           case True
           have "(\<lambda>w. spick w n x) -` C = (\<lambda>w. spick w n x) -` geom_proc m -`D" using \<open>C = geom_proc m -`D\<close> by simp
           also have "... = (geom_proc m \<circ> (\<lambda>w. spick w n x)) -`D" by auto
           also have "... = geom_proc m -`D" using geom_spick_lt geom_spick_eq \<open>m\<le>n\<close>
             using le_eq_less_or_eq by auto
           also have "... \<in> sets (G n)" using stock_filtration geometric_process
             \<open>D\<in> sets borel\<close>
             by (metis (no_types, lifting) True adapt_stoch_proc_def bernoulli bernoulli_stream_preimage
                 geom_rand_walk_borel_measurable increasing_measurable_info measurable_sets stoch_proc_filt_adapt
                 stoch_proc_filt_space)
           finally show "(\<lambda>w. spick w n x) -` C \<in> sets (G n)" .
         next
           case False
           hence "m = Suc n" using \<open>m \<le> Suc n\<close> by simp
           hence "(\<lambda>w. spick w n x) -` C \<in> {geom_proc n -` B |B. B \<in> sets borel}"
             using \<open>C\<in> {geom_proc m -` A |A. A \<in> sets borel}\<close> geom_spick_Suc by simp
           also have "... \<subseteq> sets (G n)"
           proof -
             have "{geom_proc n -` B |B. B \<in> sets borel} \<subseteq> {geom_proc n -` B \<inter> space M |B. B \<in> sets borel}"
               using bernoulli bernoulli_stream_space by simp
             also have "... \<subseteq> (\<Union>i\<in>{m. m \<le> n}. {geom_proc i -` A \<inter> space M |A. A \<in> sets borel})"
                by auto
             also have "... \<subseteq>  sigma_sets (space M) (\<Union>i\<in>{m. m \<le> n}. {geom_proc i -` A \<inter> space M |A. A \<in> sets borel})"
               by (rule sigma_sets_superset_generator)
             also have "... = sets (G n)" using stock_filtration geometric_process
               stoch_proc_filt_sets[of n geom_proc M borel] geom_rand_walk_borel_measurable by blast
             finally show ?thesis .
           qed
           finally show ?thesis .
         qed
       }
       show "(\<lambda>w. spick w n x) -` {} \<in> sets (G n)" by simp
       {
         fix C
         assume "C \<in> sigma_sets (space M) (\<Union>i\<in>{m. m \<le> Suc n}. {geom_proc i -` A \<inter> space M |A. A \<in> sets borel})"
           and "(\<lambda>w. spick w n x) -` C \<in> sets (G n)"
         hence "(\<lambda>w. spick w n x) -` (space M - C) = (\<lambda>w. spick w n x) -` (space M) - (\<lambda>w. spick w n x) -` C"
           by (simp add: vimage_Diff)
         also have "... = space M - (\<lambda>w. spick w n x) -` C" using bernoulli bernoulli_stream_space by simp
         also have "... \<in> sets (G n)" using \<open>(\<lambda>w. spick w n x) -` C \<in> sets (G n)\<close>
           by (metis algebra.compl_sets disc_filtr_def discrete_filtration sets.sigma_algebra_axioms
               sigma_algebra_def subalgebra_def)
         finally show "(\<lambda>w. spick w n x) -` (space M - C) \<in> sets (G n)" .
       }
       {
         fix C::"nat \<Rightarrow> bool stream set"
         assume "(\<And>i. C i \<in> sigma_sets (space M) (\<Union>i\<in>{m. m \<le> Suc n}. {geom_proc i -` A \<inter> space M |A. A \<in> sets borel}))"
           and "(\<And>i. (\<lambda>w. spick w n x) -` C i \<in> sets (G n))"
         hence "(\<lambda>w. spick w n x) -` \<Union>(C ` UNIV) = (\<Union> i\<in> UNIV. (\<lambda>w. spick w n x) -` (C i))" by blast
         also have "... \<in> sets (G n)" using \<open>\<And>i. (\<lambda>w. spick w n x) -` C i \<in> sets (G n)\<close> by simp
         finally show "(\<lambda>w. spick w n x) -` \<Union>(C ` UNIV) \<in> sets (G n)" .
       }
     qed
     thus "(\<lambda>w. spick w n x) -` B \<inter> space (G n) \<in> sets (G n)" using stock_filtration stoch_proc_filt_space
       bernoulli bernoulli_stream_space by simp
   qed
 qed
 
 lemma (in CRR_market) delta_price_adapted:
    fixes cash_flow::"bool stream \<Rightarrow> real"
    assumes "cash_flow \<in> borel_measurable (G T)"
 and "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
   shows "borel_adapt_stoch_proc G (delta_price N cash_flow T)"
 unfolding adapt_stoch_proc_def
 proof
   fix n
   show "delta_price N cash_flow T n \<in> borel_measurable (G n)"
   proof (cases "Suc n \<le> T")
     case True
     hence deleq: "\<forall>w. delta_price N cash_flow T n w = (rn_price N cash_flow T (Suc n) (spick w n True) - rn_price N cash_flow T (Suc n) (spick w n False))/
     ((geom_proc n w) * (u - d))" using delta_price_eq by simp
     have "(\<lambda>w. rn_price N cash_flow T (Suc n) (spick w n True)) \<in> borel_measurable (G n)"
     proof -
       have "rn_price N cash_flow T (Suc n) \<in> borel_measurable  (G (Suc n))" using rn_price_borel_adapt assms
         using True by blast
       moreover have "(\<lambda>w. spick w n True) \<in> G n \<rightarrow>\<^sub>M G (Suc n)" using spick_red_geom_filt by simp
       ultimately show ?thesis by simp
     qed
     moreover have "(\<lambda>w. rn_price N cash_flow T (Suc n) (spick w n False)) \<in> borel_measurable (G n)"
     proof -
       have "rn_price N cash_flow T (Suc n) \<in> borel_measurable  (G (Suc n))" using rn_price_borel_adapt assms
         using True by blast
       moreover have "(\<lambda>w. spick w n False) \<in> G n \<rightarrow>\<^sub>M G (Suc n)" using spick_red_geom_filt by simp
       ultimately show ?thesis by simp
     qed
     ultimately have "(\<lambda>w. rn_price N cash_flow T (Suc n) (spick w n True) - rn_price N cash_flow T (Suc n) (spick w n False))
       \<in> borel_measurable (G n)" by simp
     moreover have "(\<lambda>w. (geom_proc n w) * (u - d)) \<in> borel_measurable (G n)"
     proof -
       have "geom_proc n \<in> borel_measurable (G n)" using stock_filtration
         by (metis adapt_stoch_proc_def stk_price stock_price_borel_measurable)
       thus ?thesis by simp
     qed
     ultimately have "(\<lambda>w. (rn_price N cash_flow T (Suc n) (spick w n True) - rn_price N cash_flow T (Suc n) (spick w n False))/
       ((geom_proc n w) * (u - d)))\<in> borel_measurable (G n)" by simp
     thus ?thesis using deleq by presburger
   next
     case False
     thus ?thesis unfolding delta_price_def by simp
   qed
 qed
 
 fun (in CRR_market) delta_predict where
   "delta_predict N der matur 0  = (\<lambda>w. delta_price N der matur 0 w)" |
   "delta_predict N der matur (Suc n) = (\<lambda>w. delta_price N der matur n w)"
 
 lemma (in CRR_market) delta_predict_predict:
   assumes "der \<in> borel_measurable (G matur)"
 and "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
   shows "borel_predict_stoch_proc G (delta_predict N der matur)" unfolding predict_stoch_proc_def
 proof (intro conjI)
   show "delta_predict N der matur 0 \<in> borel_measurable (G 0)" using delta_price_adapted[of der matur N q]
     assms unfolding adapt_stoch_proc_def by force
   show "\<forall>n. delta_predict N der matur (Suc n) \<in> borel_measurable (G n)"
   proof
     fix n
     show "delta_predict N der matur (Suc n) \<in> borel_measurable (G n)" using delta_price_adapted[of der matur N q]
     assms unfolding adapt_stoch_proc_def by force
   qed
 qed
 
 
 definition (in CRR_market) delta_pf where
 "delta_pf N der matur = qty_single stk (delta_predict N der matur)"
 
 lemma (in CRR_market) delta_pf_support:
   shows "support_set (delta_pf N der matur) \<subseteq> {stk}" unfolding delta_pf_def
   using single_comp_support[of stk "delta_predict N der matur"] by simp
 
 definition (in CRR_market) self_fin_delta_pf where
 "self_fin_delta_pf N der matur v0 = self_finance Mkt v0 (delta_pf N der matur) risk_free_asset"
 
 lemma (in disc_equity_market) self_finance_trading_strat:
   assumes "trading_strategy pf"
 and "portfolio pf"
 and "borel_adapt_stoch_proc F (prices Mkt asset)"
 and "support_adapt Mkt pf"
 shows "trading_strategy (self_finance Mkt v pf asset)" unfolding self_finance_def
 proof (rule sum_trading_strat)
   show "trading_strategy pf" using assms by simp
   show "trading_strategy (qty_single asset (remaining_qty Mkt v pf asset))" unfolding trading_strategy_def
   proof (intro conjI ballI)
   show "portfolio (qty_single asset (remaining_qty Mkt v pf asset))"
     by (simp add: self_finance_def single_comp_portfolio)
   show "\<And>a.
        a \<in> support_set (qty_single asset (remaining_qty Mkt v pf asset)) \<Longrightarrow>
        borel_predict_stoch_proc F (qty_single asset (remaining_qty Mkt v pf asset) a)"
   proof (cases "support_set (qty_single asset (remaining_qty Mkt v pf asset)) = {}")
     case False
     hence eqasset: "support_set (qty_single asset (remaining_qty Mkt v pf asset)) = {asset}"
       using single_comp_support by fastforce
     fix a
     assume "a\<in> support_set (qty_single asset (remaining_qty Mkt v pf asset))"
     hence "a = asset" using eqasset by simp
     hence "qty_single asset (remaining_qty Mkt v pf asset) a = (remaining_qty Mkt v pf asset)"
       unfolding qty_single_def by simp
     moreover have "borel_predict_stoch_proc F (remaining_qty Mkt v pf asset)"
     proof (rule remaining_qty_predict)
       show "trading_strategy pf" using assms by simp
       show "borel_adapt_stoch_proc F (prices Mkt asset)" using assms by simp
       show "support_adapt Mkt pf" using assms by simp
     qed
     ultimately show "borel_predict_stoch_proc F (qty_single asset (remaining_qty Mkt v pf asset) a)"
       by simp
   next
     case True
     thus "\<And>a. a \<in> support_set (qty_single asset (remaining_qty Mkt v pf asset)) \<Longrightarrow>
          support_set (qty_single asset (remaining_qty Mkt v pf asset)) = {} \<Longrightarrow>
          borel_predict_stoch_proc F (qty_single asset (remaining_qty Mkt v pf asset) a)" by simp
   qed
 qed
 qed
 
 lemma (in CRR_market) self_fin_delta_pf_trad_strat:
   assumes "der\<in> borel_measurable (G matur)"
 and "N = bernoulli_stream q"
 and "0 < q"
 and "q < 1"
   shows "trading_strategy (self_fin_delta_pf N der matur v0)" unfolding self_fin_delta_pf_def
 proof (rule self_finance_trading_strat)
   show "trading_strategy (delta_pf N der matur)" unfolding trading_strategy_def
   proof (intro conjI ballI)
     show "portfolio (delta_pf N der matur)" unfolding portfolio_def using delta_pf_support
       by (meson finite.emptyI finite_insert infinite_super)
     show "\<And>asset. asset \<in> support_set (delta_pf N der matur) \<Longrightarrow> borel_predict_stoch_proc G (delta_pf N der matur asset)"
     proof (cases "support_set (delta_pf N der matur) = {}")
       case False
       fix asset
       assume "asset \<in> support_set (delta_pf N der matur)"
       hence "asset = stk" using False delta_pf_support by auto
       hence "delta_pf N der matur asset = delta_predict N der matur" unfolding delta_pf_def qty_single_def by simp
       thus "borel_predict_stoch_proc G (delta_pf N der matur asset)" using delta_predict_predict
         assms by simp
     next
       case True
       thus "\<And>asset. asset \<in> support_set (delta_pf N der matur) \<Longrightarrow>
              support_set (delta_pf N der matur) = {} \<Longrightarrow> borel_predict_stoch_proc G (delta_pf N der matur asset)" by simp
     qed
   qed
   show "portfolio (delta_pf N der matur)" using delta_pf_support unfolding portfolio_def
     by (meson finite.emptyI finite_insert infinite_super)
   show "borel_adapt_stoch_proc G (prices Mkt risk_free_asset)" using rf_price
     disc_rfr_proc_borel_adapted by simp
   show "support_adapt Mkt (delta_pf N der matur)" unfolding support_adapt_def
   proof
     show "\<And>asset. asset \<in> support_set (delta_pf N der matur) \<Longrightarrow> borel_adapt_stoch_proc G (prices Mkt asset)"
     proof (cases "support_set (delta_pf N der matur) = {}")
       case False
       fix asset
       assume "asset \<in> support_set (delta_pf N der matur)"
       hence "asset = stk" using False delta_pf_support by auto
       hence "prices Mkt asset = geom_proc" using stk_price by simp
       thus "borel_adapt_stoch_proc G (prices Mkt asset)"
         using \<open>asset = stk\<close> stock_price_borel_measurable by auto
     next
       case True
       thus "\<And>asset. asset \<in> support_set (delta_pf N der matur) \<Longrightarrow> borel_adapt_stoch_proc G (prices Mkt asset)"
         by simp
     qed
   qed
 qed
 
 definition (in CRR_market) delta_hedging where
 "delta_hedging N der matur = self_fin_delta_pf N der matur
   (prob_space.expectation N (discounted_value r (\<lambda>m. der) matur))"
 
 
 lemma (in CRR_market)  geom_proc_eq_snth:
   shows "(\<And>m. m \<le> Suc n \<Longrightarrow> geom_proc m x = geom_proc m y) \<Longrightarrow>
     (\<And>m. m \<le> n \<Longrightarrow> snth x m = snth y m)"
 proof (induct n )
   case 0
   assume asm: "(\<And>m. m \<le>Suc  0 \<Longrightarrow> geom_proc m x = geom_proc m y)" and "m\<le> 0"
   hence "m = 0" by simp
   have "geom_proc (Suc 0) x = geom_proc (Suc 0) y" using asm by simp
   have "snth x 0 = snth y 0"
   proof (rule ccontr)
     assume "snth x 0 \<noteq> snth y 0"
     show False
     proof (cases "snth x 0")
       case True
       hence "\<not> snth y 0" using \<open>snth x 0 \<noteq> snth y 0\<close> by simp
       have "geom_proc (Suc 0) x = u * init" using geometric_process True by simp
       moreover have "geom_proc (Suc 0) y = d * init" using geometric_process \<open>\<not> snth y 0\<close> by simp
       ultimately have "geom_proc (Suc 0) x \<noteq> geom_proc (Suc 0) y" using S0_positive down_lt_up by simp
       thus ?thesis using \<open>geom_proc (Suc 0) x = geom_proc (Suc 0) y\<close> by simp
     next
       case False
       hence "snth y 0" using \<open>snth x 0 \<noteq> snth y 0\<close> by simp
       have "geom_proc (Suc 0) x = d * init" using geometric_process False by simp
       moreover have "geom_proc (Suc 0) y = u * init" using geometric_process \<open>snth y 0\<close> by simp
       ultimately have "geom_proc (Suc 0) x \<noteq> geom_proc (Suc 0) y" using S0_positive down_lt_up by simp
       thus ?thesis using \<open>geom_proc (Suc 0) x = geom_proc (Suc 0) y\<close> by simp
     qed
   qed
   thus "\<And>m. (\<And>m. m \<le> Suc 0 \<Longrightarrow> geom_proc m x = geom_proc m y) \<Longrightarrow> m \<le> 0 \<Longrightarrow> x !! m = y !! m" by simp
 next
   case (Suc n)
   assume fst: "(\<And>m. (\<And>m. m \<le> Suc n \<Longrightarrow> geom_proc m x = geom_proc m y) \<Longrightarrow> m \<le> n \<Longrightarrow> x !! m = y !! m)"
     and scd: "(\<And>m. m \<le> Suc (Suc n) \<Longrightarrow> geom_proc m x = geom_proc m y)" and "m \<le> Suc n"
   show "x !! m = y !! m"
   proof (cases "m \<le> n")
     case True
     thus ?thesis using fst scd by simp
   next
     case False
     hence "m = Suc n" using \<open>m\<le> Suc n\<close> by simp
     have "geom_proc (Suc (Suc n)) x = geom_proc (Suc (Suc n)) y" using scd by simp
     show ?thesis
     proof (rule ccontr)
       assume "x !! m \<noteq> y !! m"
       thus False
       proof (cases "x !! m")
         case True
         hence "\<not> y !! m" using \<open>x !! m \<noteq> y !! m\<close> by simp
         have "geom_proc (Suc (Suc n)) x = u * geom_proc (Suc n) x" using geometric_process True
           \<open>m = Suc n\<close> by simp
         also have "... = u * geom_proc (Suc n) y" using scd \<open>m = Suc n\<close> by simp
         finally have "geom_proc (Suc (Suc n)) x = u * geom_proc (Suc n) y" .
         moreover have "geom_proc (Suc (Suc n)) y = d * geom_proc (Suc n) y" using geometric_process
           \<open>m = Suc n\<close> \<open>\<not> y !! m\<close> by simp
         ultimately have "geom_proc (Suc (Suc n)) x \<noteq> geom_proc (Suc (Suc n)) y"
           by (metis S0_positive down_lt_up down_positive geom_rand_walk_strictly_positive less_irrefl mult_cancel_right)
         thus ?thesis using \<open>geom_proc (Suc (Suc n)) x = geom_proc (Suc (Suc n)) y\<close> by simp
       next
         case False
         hence "y !! m" using \<open>x !! m \<noteq> y !! m\<close> by simp
         have "geom_proc (Suc (Suc n)) x = d * geom_proc (Suc n) x" using geometric_process False
           \<open>m = Suc n\<close> by simp
         also have "... = d * geom_proc (Suc n) y" using scd \<open>m = Suc n\<close> by simp
         finally have "geom_proc (Suc (Suc n)) x = d * geom_proc (Suc n) y" .
         moreover have "geom_proc (Suc (Suc n)) y = u * geom_proc (Suc n) y" using geometric_process
           \<open>m = Suc n\<close> \<open>y !! m\<close> by simp
         ultimately have "geom_proc (Suc (Suc n)) x \<noteq> geom_proc (Suc (Suc n)) y"
           by (metis S0_positive down_lt_up down_positive geom_rand_walk_strictly_positive less_irrefl mult_cancel_right)
         thus ?thesis using \<open>geom_proc (Suc (Suc n)) x = geom_proc (Suc (Suc n)) y\<close> by simp
       qed
     qed
   qed
 qed
 
 lemma (in CRR_market)  geom_proc_eq_pseudo_proj_True:
   shows "(\<And>m. m \<le>  n \<Longrightarrow> geom_proc m x = geom_proc m y) \<Longrightarrow>
     (pseudo_proj_True (n) x = pseudo_proj_True (n) y)"
 proof -
   assume a1: "\<And>m. m \<le> n \<Longrightarrow> geom_proc m x = geom_proc m y"
   obtain nn :: "bool stream \<Rightarrow> bool stream \<Rightarrow> nat \<Rightarrow> nat" where
     "\<forall>x1 x2 x3. (\<exists>v4<Suc (Suc x3). geom_proc v4 x2 \<noteq> geom_proc v4 x1) = (nn x1 x2 x3 < Suc (Suc x3) \<and> geom_proc (nn x1 x2 x3) x2 \<noteq> geom_proc (nn x1 x2 x3) x1)"
     by moura
   then have f2: "\<forall>n s sa na. (nn sa s n < Suc (Suc n) \<and> geom_proc (nn sa s n) s \<noteq> geom_proc (nn sa s n) sa \<or> \<not> na < Suc n) \<or> s !! na = sa !! na"
     by (meson geom_proc_eq_snth less_Suc_eq_le)
   obtain nna :: "bool stream \<Rightarrow> bool stream \<Rightarrow> nat \<Rightarrow> nat" where
     f3: "\<forall>x0 x1 x2. (\<exists>v3. Suc v3 < Suc x2 \<and> x1 !! v3 \<noteq> x0 !! v3) = (Suc (nna x0 x1 x2) < Suc x2 \<and> x1 !! nna x0 x1 x2 \<noteq> x0 !! nna x0 x1 x2)"
     by moura
   obtain nnb :: "nat \<Rightarrow> nat" where
     f4: "\<forall>x0. (\<exists>v2. x0 = Suc v2) = (x0 = Suc (nnb x0))"
     by moura
   moreover
   { assume "\<not> nn y x (nnb n) < Suc (Suc (nnb n)) \<or> geom_proc (nn y x (nnb n)) x = geom_proc (nn y x (nnb n)) y"
     moreover
     { assume "\<not> nna y x n < Suc (nnb n)"
       then have "\<not> Suc (nna y x n) < Suc n \<or> x !! nna y x n = y !! nna y x n"
         using f4 by (metis (no_types) Suc_le_D Suc_le_lessD less_Suc_eq_le) }
     ultimately have "pseudo_proj_True n x = pseudo_proj_True n y \<or> \<not> Suc (nna y x n) < Suc n \<or> x !! nna y x n = y !! nna y x n"
 using f2 by meson }
   ultimately have "pseudo_proj_True n x = pseudo_proj_True n y \<or> \<not> Suc (nna y x n) < Suc n \<or> x !! nna y x n = y !! nna y x n"
     using a1 Suc_le_D less_Suc_eq_le by presburger
   then show ?thesis
     using f3 by (meson less_Suc_eq_le pseudo_proj_True_snth')
 qed
 
 
 
 
 lemma (in CRR_market)  proj_stoch_eq_pseudo_proj_True:
   assumes "proj_stoch_proc geom_proc m x = proj_stoch_proc geom_proc m y"
   shows "pseudo_proj_True m x = pseudo_proj_True m y"
 proof -
   have "\<forall> k \<le> m. geom_proc k x = geom_proc k y"
   proof (intro allI impI)
     fix k
     assume "k \<le> m"
     thus "geom_proc k x = geom_proc k y" using proj_stoch_proc_eq_snth[of geom_proc m x y k] assms by simp
   qed
   thus ?thesis  using geom_proc_eq_pseudo_proj_True[of m x y] by auto
 qed
 
 lemma (in CRR_market_viable) rn_rev_price_cond_expect:
   assumes "N = bernoulli_stream q"
 and "0 <q"
 and "q < 1"
 and "der \<in> borel_measurable (G matur)"
 and "Suc n \<le> matur"
 shows "expl_cond_expect N (proj_stoch_proc geom_proc n) (rn_rev_price N der matur (matur - Suc n)) w=
   (q * rn_rev_price N der matur (matur - Suc n) (pseudo_proj_True n w)  +
       (1 - q) * rn_rev_price N der matur (matur - Suc n) (pseudo_proj_False n w))"
 proof (rule infinite_cts_filtration.f_borel_Suc_expl_cond_expect)
   show "infinite_cts_filtration q N nat_filtration" using  assms  pslt psgt
     bernoulli_nat_filtration by simp
   show "rn_rev_price N der matur (matur - Suc n) \<in> borel_measurable (nat_filtration (Suc n))"
     using rn_rev_price_rev_borel_adapt[of der matur N q "Suc n"]   assms
       stock_filtration stoch_proc_subalg_nat_filt[of geom_proc] geom_rand_walk_borel_adapted
     by (metis add_diff_cancel_right' diff_le_self measurable_from_subalg
         ordered_cancel_comm_monoid_diff_class.add_diff_inverse rn_rev_price_rev_borel_adapt)
   show "proj_stoch_proc geom_proc n \<in> nat_filtration n \<rightarrow>\<^sub>M stream_space borel"
     using proj_stoch_adapted_if_adapted[of M nat_filtration geom_proc borel n]
     pslt psgt bernoulli_nat_filtration[of M p] bernoulli geom_rand_walk_borel_adapted
     nat_discrete_filtration by blast
   show "set_discriminating n (proj_stoch_proc geom_proc n) (stream_space borel)"
     using infinite_cts_filtration.proj_stoch_set_discriminating
     pslt psgt bernoulli_nat_filtration[of M p] bernoulli geom_rand_walk_borel_adapted by simp
   show "proj_stoch_proc geom_proc n -` {proj_stoch_proc geom_proc n w} \<in> sets (nat_filtration n)"
     using infinite_cts_filtration.proj_stoch_singleton_set
     pslt psgt bernoulli_nat_filtration[of M p] bernoulli geom_rand_walk_borel_adapted by simp
   show "\<forall>y z. proj_stoch_proc geom_proc n y = proj_stoch_proc geom_proc n z \<and> y !! n = z !! n \<longrightarrow>
     rn_rev_price N der matur (matur - Suc n) y = rn_rev_price N der matur (matur - Suc n) z"
   proof (intro allI impI)
     fix y z
     assume as:"proj_stoch_proc geom_proc n y = proj_stoch_proc geom_proc n z \<and> y !! n = z !! n"
     hence "pseudo_proj_True n y = pseudo_proj_True n z" using proj_stoch_eq_pseudo_proj_True[of n y z] by simp
     moreover have "snth y n = snth z n" using as by simp
     ultimately have "pseudo_proj_True (Suc n) y = pseudo_proj_True (Suc n) z"
     proof -
     have f1: "\<forall>n s sa. (\<exists>na. Suc na \<le> n \<and> s !! na \<noteq> sa !! na) \<or> pseudo_proj_True n s = pseudo_proj_True n sa"
     by (meson pseudo_proj_True_snth')
       obtain nn :: "bool stream \<Rightarrow> bool stream \<Rightarrow> nat \<Rightarrow> nat" where
         "\<forall>x0 x1 x2. (\<exists>v3. Suc v3 \<le> x2 \<and> x1 !! v3 \<noteq> x0 !! v3) = (Suc (nn x0 x1 x2) \<le> x2 \<and> x1 !! nn x0 x1 x2 \<noteq> x0 !! nn x0 x1 x2)"
         by moura
         then have f2: "\<forall>n s sa. Suc (nn sa s n) \<le> n \<and> s !! nn sa s n \<noteq> sa !! nn sa s n \<or> pseudo_proj_True n s = pseudo_proj_True n sa"
           using f1 by presburger
         have f3: "stake n y = stake n (pseudo_proj_True n z)"
           by (metis \<open>pseudo_proj_True n y = pseudo_proj_True n z\<close> pseudo_proj_True_stake)
         { assume "stake (Suc n) z \<noteq> stake (Suc n) (pseudo_proj_True (Suc n) y)"
           then have "stake n y @ [y !! n] \<noteq> stake n z @ [z !! n]"
             by (metis (no_types) pseudo_proj_True_stake stake_Suc)
           then have "stake (Suc n) z = stake (Suc n) (pseudo_proj_True (Suc n) y)"
             using f3 by (simp add: \<open>y !! n = z !! n\<close> pseudo_proj_True_stake) }
         then have "\<not> Suc (nn z y (Suc n)) \<le> Suc n \<or> y !! nn z y (Suc n) = z !! nn z y (Suc n)"
         by (metis (no_types) pseudo_proj_True_stake stake_snth)
       then show ?thesis
         using f2 by blast
     qed
     have "rn_rev_price N der matur (matur - Suc n) y =
       rn_rev_price N der matur (matur - Suc n) (pseudo_proj_True (Suc n) y)" using nat_filtration_info[of "rn_rev_price N der matur (matur - Suc n)" "Suc n"]
       rn_rev_price_rev_borel_adapt[of der matur N q]
       by (metis \<open>rn_rev_price N der matur (matur - Suc n) \<in> borel_measurable (nat_filtration (Suc n))\<close> o_apply)
     also have "... = rn_rev_price N der matur (matur - Suc n) (pseudo_proj_True (Suc n) z)"
       using \<open>pseudo_proj_True (Suc n) y = pseudo_proj_True (Suc n) z\<close> by simp
     also have "... = rn_rev_price N der matur (matur - Suc n) z" using nat_filtration_info[of "rn_rev_price N der matur (matur - Suc n)" "Suc n"]
       rn_rev_price_rev_borel_adapt[of der matur N q]
       by (metis \<open>rn_rev_price N der matur (matur - Suc n) \<in> borel_measurable (nat_filtration (Suc n))\<close> o_apply)
     finally show "rn_rev_price N der matur (matur - Suc n) y = rn_rev_price N der matur (matur - Suc n) z" .
   qed
   show "0 < q" and "q < 1" using assms by auto
 qed
 
 
 
 
 lemma (in CRR_market_viable) rn_price_eq_ind:
   assumes "N = bernoulli_stream q"
 and "n < matur"
 and "0 < q"
 and "q < 1"
 and "der \<in> borel_measurable (G matur)"
 shows "(1+r) * rn_price N der matur n w = q * rn_price N der matur (Suc n) (pseudo_proj_True n w) +
   (1 - q) * rn_price N der matur (Suc n) (pseudo_proj_False n w)"
 proof -
   define V where "V = rn_price N der matur"
   let ?m = "matur - Suc n"
   have "matur -n = Suc ?m" by (simp add: assms Suc_diff_Suc Suc_le_lessD)
   have "(1+r) * V n w = (1+r) * rn_price_ind N der matur n w" using rn_price_eq assms unfolding V_def by simp
   also have "... = (1+r) * rn_rev_price N der matur (Suc ?m) w" using \<open>matur -n = Suc ?m\<close>
     unfolding rn_price_ind_def by simp
   also have "... = (1+r) * discount_factor r (Suc 0) w *
                     expl_cond_expect N (proj_stoch_proc geom_proc (matur - Suc ?m)) (rn_rev_price N der matur ?m) w"
     by simp
   also have "... = expl_cond_expect N (proj_stoch_proc geom_proc (matur - Suc ?m)) (rn_rev_price N der matur ?m) w"
     unfolding discount_factor_def using acceptable_rate by auto
   also have "... = expl_cond_expect N (proj_stoch_proc geom_proc n) (rn_rev_price N der matur ?m) w"
     using \<open>matur -n = Suc ?m\<close> by simp
   also have "... = (q * rn_rev_price N der matur ?m (pseudo_proj_True n w)  +
     (1 - q) * rn_rev_price N der matur ?m (pseudo_proj_False n w))"
     using rn_rev_price_cond_expect[of N q der matur n w] assms   by simp
   also have "... =  q * rn_price_ind N der matur (Suc n) (pseudo_proj_True n w) +
     (1 - q) * rn_price_ind N der matur (Suc n) (pseudo_proj_False n w)" unfolding rn_price_ind_def by simp
   also have "... = q * rn_price N der matur (Suc n) (pseudo_proj_True n w) +
     (1 - q) * rn_price N der matur (Suc n) (pseudo_proj_False n w)" using rn_price_eq assms  by simp
   also have "... = q * V (Suc n) (pseudo_proj_True n w) + (1 - q) *V (Suc n) (pseudo_proj_False n w)"
     unfolding V_def by simp
   finally have "(1+r) * V n w = q * V (Suc n) (pseudo_proj_True n w) + (1 - q) *V (Suc n) (pseudo_proj_False n w)" .
   thus ?thesis unfolding V_def by simp
 qed
 
 
 
 lemma self_finance_updated_suc_suc:
   assumes "portfolio pf"
   and "\<forall>n. prices Mkt asset n w \<noteq> 0"
   shows "cls_val_process Mkt (self_finance Mkt v pf asset) (Suc (Suc n)) w = cls_val_process Mkt pf (Suc (Suc n)) w +
     (prices Mkt asset (Suc (Suc n)) w / (prices Mkt asset (Suc n) w)) *
       (cls_val_process Mkt (self_finance Mkt v pf asset) (Suc n) w -
      val_process Mkt pf (Suc n) w)"
 proof -
   have "cls_val_process Mkt (self_finance Mkt v pf asset) (Suc (Suc n)) w = cls_val_process Mkt pf (Suc (Suc n)) w +
     prices Mkt asset (Suc (Suc n)) w * remaining_qty Mkt v pf asset (Suc (Suc n)) w" using assms
     by (simp add: self_finance_updated)
   also have "... = cls_val_process Mkt pf (Suc (Suc n)) w +
     prices Mkt asset (Suc (Suc n)) w * ((remaining_qty Mkt v pf asset (Suc n) w) +
     (cls_val_process Mkt pf (Suc n) w - val_process Mkt pf (Suc n) w)/(prices Mkt asset (Suc n) w))"
     by simp
   also have "... = cls_val_process Mkt pf (Suc (Suc n)) w +
     prices Mkt asset (Suc (Suc n)) w *
       ((prices Mkt asset (Suc n) w) * (remaining_qty Mkt v pf asset (Suc n) w) / (prices Mkt asset (Suc n) w) +
     (cls_val_process Mkt pf (Suc n) w - val_process Mkt pf (Suc n) w)/(prices Mkt asset (Suc n) w))" using assms
     by (metis nonzero_mult_div_cancel_left)
   also have "... = cls_val_process Mkt pf (Suc (Suc n)) w +
     prices Mkt asset (Suc (Suc n)) w * ((prices Mkt asset (Suc n) w) * (remaining_qty Mkt v pf asset (Suc n) w) +
     cls_val_process Mkt pf (Suc n) w - val_process Mkt pf (Suc n) w)/(prices Mkt asset (Suc n) w)"
     using add_divide_distrib[symmetric, of "prices Mkt asset (Suc n) w * remaining_qty Mkt v pf asset (Suc n) w"
         "prices Mkt asset (Suc n) w"]  by simp
   also have "... = cls_val_process Mkt pf (Suc (Suc n)) w +
     (prices Mkt asset (Suc (Suc n)) w / (prices Mkt asset (Suc n) w)) *
     ((prices Mkt asset (Suc n) w) * (remaining_qty Mkt v pf asset (Suc n) w) +
     cls_val_process Mkt pf (Suc n) w - val_process Mkt pf (Suc n) w)" by simp
   also have "... = cls_val_process Mkt pf (Suc (Suc n)) w +
     (prices Mkt asset (Suc (Suc n)) w / (prices Mkt asset (Suc n) w)) *
       (cls_val_process Mkt (self_finance Mkt v pf asset) (Suc n) w -
      val_process Mkt pf (Suc n) w)"
     using self_finance_updated[of Mkt asset n w pf v] assms by auto
   finally show ?thesis .
 qed
 
 lemma self_finance_updated_suc_0:
   assumes "portfolio pf"
   and "\<forall>n w. prices Mkt asset n w \<noteq> 0"
   shows "cls_val_process Mkt (self_finance Mkt v pf asset) (Suc 0) w = cls_val_process Mkt pf (Suc 0) w +
     (prices Mkt asset (Suc 0) w / (prices Mkt asset 0 w)) *
       (val_process Mkt (self_finance Mkt v pf asset) 0 w -
      val_process Mkt pf 0 w)"
 proof -
   have "cls_val_process Mkt (self_finance Mkt v pf asset) (Suc 0) w = cls_val_process Mkt pf (Suc 0) w +
     prices Mkt asset (Suc 0) w * remaining_qty Mkt v pf asset (Suc 0) w" using assms
     by (simp add: self_finance_updated)
   also have "... = cls_val_process Mkt pf (Suc 0) w +
     prices Mkt asset (Suc 0) w * ((v - val_process Mkt pf 0 w)/(prices Mkt asset 0 w))"
     by simp
   also have "... = cls_val_process Mkt pf (Suc 0) w +
     prices Mkt asset (Suc 0) w * ((remaining_qty Mkt v pf asset 0 w) +
     (v - val_process Mkt pf 0 w)/(prices Mkt asset 0 w))"
     by simp
   also have "... = cls_val_process Mkt pf (Suc 0) w +
     prices Mkt asset (Suc 0) w *
       ((prices Mkt asset 0 w) * (remaining_qty Mkt v pf asset 0 w) / (prices Mkt asset 0 w) +
     (v - val_process Mkt pf 0 w)/(prices Mkt asset 0 w))" using assms
     by (metis nonzero_mult_div_cancel_left)
   also have "... = cls_val_process Mkt pf (Suc 0) w +
     prices Mkt asset (Suc 0) w * ((prices Mkt asset 0 w) * (remaining_qty Mkt v pf asset 0 w) +
     v - val_process Mkt pf 0 w)/(prices Mkt asset 0 w)"
     using add_divide_distrib[symmetric, of "prices Mkt asset 0 w * remaining_qty Mkt v pf asset 0 w"
         "prices Mkt asset 0 w"]  by simp
   also have "... = cls_val_process Mkt pf (Suc 0) w +
     (prices Mkt asset (Suc 0) w / (prices Mkt asset 0 w)) *
     ((prices Mkt asset 0 w) * (remaining_qty Mkt v pf asset 0 w) +
     v - val_process Mkt pf 0 w)" by simp
   also have "... = cls_val_process Mkt pf (Suc 0) w +
     (prices Mkt asset (Suc 0) w / (prices Mkt asset 0 w)) *
     ((prices Mkt asset 0 w) * (remaining_qty Mkt v pf asset 0 w) +
     val_process Mkt (self_finance Mkt v pf asset) 0 w - val_process Mkt pf 0 w)"
     using self_finance_init[of Mkt asset pf v w] assms by simp
   also have "... = cls_val_process Mkt pf (Suc 0) w +
     (prices Mkt asset (Suc 0) w / (prices Mkt asset 0 w)) *
       (val_process Mkt (self_finance Mkt v pf asset) 0 w -
      val_process Mkt pf 0 w)" by simp
   finally show ?thesis .
 qed
 
 lemma self_finance_updated_ind:
   assumes "portfolio pf"
   and "\<forall>n w. prices Mkt asset n w \<noteq> 0"
   shows "cls_val_process Mkt (self_finance Mkt v pf asset) (Suc n) w = cls_val_process Mkt pf (Suc n) w +
     (prices Mkt asset (Suc n) w / (prices Mkt asset n w)) *
       (val_process Mkt (self_finance Mkt v pf asset) n w -
      val_process Mkt pf n w)"
 proof (cases "n = 0")
   case True
   thus ?thesis using assms self_finance_updated_suc_0 by simp
 next
   case False
   hence "\<exists>m. n = Suc m" by (simp add: not0_implies_Suc)
   from this obtain m where "n = Suc m" by auto
   hence "cls_val_process Mkt (self_finance Mkt v pf asset) (Suc n) w =
     cls_val_process Mkt (self_finance Mkt v pf asset) (Suc (Suc m)) w" by simp
   also have "...  = cls_val_process Mkt pf (Suc (Suc m)) w +
     (prices Mkt asset (Suc (Suc m)) w / (prices Mkt asset (Suc m) w)) *
       (cls_val_process Mkt (self_finance Mkt v pf asset) (Suc m) w -
      val_process Mkt pf (Suc m) w)" using assms self_finance_updated_suc_suc[of pf] by simp
   also have "... = cls_val_process Mkt pf (Suc (Suc m)) w +
     (prices Mkt asset (Suc (Suc m)) w / (prices Mkt asset (Suc m) w)) *
       (val_process Mkt (self_finance Mkt v pf asset) (Suc m) w -
      val_process Mkt pf (Suc m) w)" using assms self_finance_charact unfolding self_financing_def
     by (simp add: self_finance_succ self_finance_updated)
   also have "... = cls_val_process Mkt pf (Suc n) w +
     (prices Mkt asset (Suc n) w / (prices Mkt asset n w)) *
       (val_process Mkt (self_finance Mkt v pf asset) n w -
      val_process Mkt pf n w)" using \<open>n = Suc m\<close> by simp
   finally show ?thesis .
 qed
 
 
 lemma  (in rfr_disc_equity_market) self_finance_risk_free_update_ind:
   assumes "portfolio pf"
   shows "cls_val_process Mkt (self_finance Mkt v pf risk_free_asset) (Suc n) w = cls_val_process Mkt pf (Suc n) w +
     (1 + r) * (val_process Mkt (self_finance Mkt v pf risk_free_asset) n w - val_process Mkt pf n w)"
 proof -
   have "cls_val_process Mkt (self_finance Mkt v pf risk_free_asset) (Suc n) w =
     cls_val_process Mkt pf (Suc n) w +
     (prices Mkt risk_free_asset (Suc n) w / (prices Mkt risk_free_asset n w)) *
       (val_process Mkt (self_finance Mkt v pf risk_free_asset) n w -
      val_process Mkt pf n w)"
   proof (rule self_finance_updated_ind, (simp add: assms), intro allI)
     fix n w
     show "prices Mkt risk_free_asset n w \<noteq> 0" using positive by (metis less_irrefl)
   qed
   also have "... = cls_val_process Mkt pf (Suc n) w +
     (1+r) * (val_process Mkt (self_finance Mkt v pf risk_free_asset) n w -
      val_process Mkt pf n w)" using rf_price  positive
     by (metis acceptable_rate disc_rfr_proc_Suc_div)
   finally show ?thesis .
 qed
 
 
 
 lemma (in CRR_market) delta_pf_portfolio:
   shows "portfolio (delta_pf N der matur)" unfolding delta_pf_def by (simp add: single_comp_portfolio)
 
 lemma (in CRR_market) delta_pf_updated:
   shows "cls_val_process Mkt (delta_pf N der matur) (Suc n) w =
     geom_proc (Suc n) w * delta_price N der matur n w" unfolding delta_pf_def
     using stk_price qty_single_updated[of Mkt] by simp
 
 lemma (in CRR_market) delta_pf_val_process:
   shows "val_process Mkt (delta_pf N der matur) n w =
     geom_proc n w * delta_price N der matur n w" unfolding delta_pf_def
   using stk_price qty_single_val_process[of Mkt] by simp
 
 lemma (in CRR_market) delta_hedging_cls_val_process:
   shows "cls_val_process Mkt (delta_hedging N der matur) (Suc n) w =
     geom_proc (Suc n) w * delta_price N der matur n w +
     (1 + r) * (val_process Mkt (delta_hedging N der matur) n w - geom_proc n w * delta_price N der matur n w)"
 proof -
   define X where "X = delta_hedging N der matur"
   define init where "init = integral\<^sup>L N (discounted_value r (\<lambda>m. der) matur)"
   have "cls_val_process Mkt X (Suc n) w = cls_val_process Mkt (delta_pf N der matur) (Suc n) w +
     (1 + r) * (val_process Mkt X n w - val_process Mkt (delta_pf N der matur) n w)"
     unfolding X_def delta_hedging_def self_fin_delta_pf_def init_def
   proof (rule self_finance_risk_free_update_ind)
     show "portfolio (delta_pf N der matur)" unfolding  portfolio_def using delta_pf_support
       by (meson finite.simps infinite_super)
   qed
   also have "... = geom_proc (Suc n) w * delta_price N der matur n w +
     (1 + r) * (val_process Mkt X n w - val_process Mkt (delta_pf N der matur) n w)"
     using delta_pf_updated by simp
   also have "... = geom_proc (Suc n) w * delta_price N der matur n w +
     (1 + r) * (val_process Mkt X n w - geom_proc n w * delta_price N der matur n w)"
     using delta_pf_val_process by simp
   finally show ?thesis unfolding X_def .
 qed
 
 
 
 
 
 
 
 lemma (in CRR_market_viable) delta_hedging_eq_derivative_price:
   fixes der::"bool stream \<Rightarrow> real" and matur::nat
   assumes "N = bernoulli_stream ((1 + r - d) / (u - d))"
   and "der\<in> borel_measurable (G matur)"
   shows "\<And>n w. n\<le> matur \<Longrightarrow>
     val_process Mkt (delta_hedging N der matur) n w =
     (rn_price N der matur) n w"
 unfolding delta_hedging_def
 proof -
   define q where "q = (1 + r - d) / (u - d)"
   have "0 < q" and "q < 1" unfolding q_def using assms gt_param lt_param CRR_viable by auto
   note qprops = this
   define init where  "init = (prob_space.expectation N (discounted_value r (\<lambda>m. der) matur))"
   define X where "X = val_process Mkt (delta_hedging N der matur)"
   define V where "V = rn_price N der matur"
   define \<Delta> where "\<Delta> = delta_price N der matur"
   {
     fix n
     fix w
     have "n \<le> matur \<Longrightarrow> X n w = V n w"
     proof (induct n)
     case 0
     have v0: "V 0 \<in> borel_measurable (G 0)" using assms rn_price_borel_adapt "0.prems" qprops
       unfolding V_def q_def by auto
     have "X 0 w= init" using self_finance_init[of Mkt risk_free_asset "delta_pf N der matur" "integral\<^sup>L N (discounted_value r (\<lambda>m. der) matur)"]
         delta_pf_support
       unfolding  X_def init_def delta_hedging_def self_fin_delta_pf_def init_def
       by (metis finite_insert infinite_imp_nonempty infinite_super less_irrefl portfolio_def positive)
     also have "... = V 0 w" 
     proof -
       have "\<forall>x\<in>space N. real_cond_exp N (G 0) (discounted_value r (\<lambda>m. der) matur) x =
         integral\<^sup>L N (discounted_value r (\<lambda>m. der) matur)"
       proof (rule prob_space.trivial_subalg_cond_expect_eq)
         show "prob_space N" using assms qprops unfolding q_def
           by (simp add: bernoulli bernoulli_stream_def prob_space.prob_space_stream_space prob_space_measure_pmf)
         have "init_triv_filt M (stoch_proc_filt M geom_proc borel)"
         proof (rule infinite_cts_filtration.stoch_proc_filt_triv_init)
           show "borel_adapt_stoch_proc nat_filtration geom_proc" using geom_rand_walk_borel_adapted by simp
           show "infinite_cts_filtration p M nat_filtration" using bernoulli_nat_filtration[of M p] bernoulli psgt pslt
             by simp
         qed
         hence "init_triv_filt N (stoch_proc_filt M geom_proc borel)" using assms qprops
           filt_equiv_triv_init[of nat_filtration N] stock_filtration
           bernoulli_stream_equiv[of N] psgt pslt unfolding q_def by simp
         thus "subalgebra N (G 0)" and "sets (G 0) = {{}, space N}" using stock_filtration unfolding init_triv_filt_def
           filtration_def bot_nat_def by auto
         show "integrable N (discounted_value r (\<lambda>m. der) matur)"
         proof (rule bernoulli_discounted_integrable)
           show "der \<in> borel_measurable (nat_filtration matur)" using assms geom_rand_walk_borel_adapted
               measurable_from_subalg stoch_proc_subalg_nat_filt stock_filtration by blast
           show "N = bernoulli_stream q" using assms unfolding q_def by simp
           show "0 < q" "q < 1" using qprops by auto
         qed (simp add: acceptable_rate)
       qed
       hence "integral\<^sup>L N (discounted_value r (\<lambda>m. der) matur) =
         real_cond_exp N (G 0) (discounted_value r (\<lambda>m. der) matur) w" using bernoulli_stream_space[of N q]
         by (simp add: assms(1) q_def)
       also have "... = real_cond_exp N (stoch_proc_filt M geom_proc borel 0) (discounted_value r (\<lambda>m. der) matur) w"
         using stock_filtration by simp
       also have "... = real_cond_exp N (stoch_proc_filt N geom_proc borel 0) (discounted_value r (\<lambda>m. der) matur) w"
         using stoch_proc_filt_filt_equiv[of nat_filtration M N geom_proc]
           bernoulli_stream_equiv[of N] q_def qprops assms pslt psgt by auto
       also have "... = expl_cond_expect N (proj_stoch_proc geom_proc 0) (discounted_value r (\<lambda>m. der) matur) w"
       proof (rule bernoulli_cond_exp)
         show "N = bernoulli_stream q" using assms unfolding q_def by simp
         show "0 < q" "q < 1" using qprops by auto
         show "integrable N (discounted_value r (\<lambda>m. der) matur)"
         proof (rule bernoulli_discounted_integrable)
           show "der \<in> borel_measurable (nat_filtration matur)" using assms geom_rand_walk_borel_adapted
               measurable_from_subalg stoch_proc_subalg_nat_filt stock_filtration by blast
           show "N = bernoulli_stream q" using assms unfolding q_def by simp
           show "0 < q" "q < 1" using qprops by auto
         qed (simp add: acceptable_rate)
       qed
       finally show "init = V 0 w" unfolding init_def V_def rn_price_def by simp
     qed
     finally show "X 0 w = V 0 w" .
     next
       case (Suc n)
       hence "n < matur" by simp
       show ?case
       proof -
         have "X n w = V n w" using Suc by (simp add: Suc.hyps Suc.prems Suc_leD)
         have "0< 1+r" using acceptable_rate by simp
         let ?m = "matur - Suc n"
         have "matur -n = Suc ?m" by (simp add: Suc.prems Suc_diff_Suc Suc_le_lessD)
         have "(1+r) * V n w = q * V (Suc n) (pseudo_proj_True n w) + (1 - q) *V (Suc n) (pseudo_proj_False n w)"
           using rn_price_eq_ind qprops assms Suc q_def V_def by simp
         show "X (Suc n) w = V (Suc n) w"
         proof (cases "snth w n")
         case True
           hence pseq: "pseudo_proj_True (Suc n) w = pseudo_proj_True (Suc n) (spick w n True)"
             by (metis (mono_tags, lifting) pseudo_proj_True_stake_image spickI stake_Suc)
           have "X (Suc n) w = cls_val_process Mkt (delta_hedging N der matur) (Suc n) w"
             unfolding X_def delta_hedging_def self_fin_delta_pf_def using  delta_pf_portfolio
             unfolding self_financing_def
             by (metis less_irrefl positive self_finance_charact self_financingE)
           also have "... = geom_proc (Suc n) w * \<Delta> n w + (1 + r) * (X n w - geom_proc n w * \<Delta> n w)"
             using delta_hedging_cls_val_process unfolding X_def \<Delta>_def by simp
           also have "... = u * geom_proc n w * \<Delta> n w + (1 + r) * (X n w - geom_proc n w * \<Delta> n w)"
             using True geometric_process by simp
           also have "... = u * geom_proc n w * \<Delta> n w + (1 + r) * X n w - (1+r) * geom_proc n w * \<Delta> n w"
             by (simp add: right_diff_distrib)
           also have "... = (1+r) * X n w + geom_proc n w * \<Delta> n w * u - geom_proc n w * \<Delta> n w * (1 + r)"
             by (simp add: mult.commute mult.left_commute)
           also have "... = (1+r)* X n w + geom_proc n w * \<Delta> n w * (u - (1 + r))" by (simp add: right_diff_distrib)
           also have "... = (1+r) * X n w + geom_proc n w * (V (Suc n) (pseudo_proj_True n w) - V (Suc n) (pseudo_proj_False n w))/
             (geom_proc (Suc n) (spick w n True) - geom_proc (Suc n) (spick w n False)) * (u - (1 + r))"
             using Suc V_def by (simp add: \<Delta>_def delta_price_def geom_rand_walk_diff_induct)
           also have "... = (1+r) * X n w + geom_proc n w * ((V (Suc n) (pseudo_proj_True n w) - V (Suc n) (pseudo_proj_False n w))) /
             (geom_proc n w * (u - d)) * (u - (1 + r))"
           proof -
             have "geom_proc (Suc n) (spick w n True) - geom_proc (Suc n) (spick w n False) =
-              u * geom_proc n w - d * geom_proc n w"
-              using geometric_process
-              by (metis geom_rand_walk_diff_induct linordered_field_class.sign_simps(39) mult.commute)
-            also have "... = geom_proc n w * (u - d)"
-              by (simp add: linordered_field_class.sign_simps(39) mult.commute)
-            finally have "(geom_proc (Suc n) (spick w n True) - geom_proc (Suc n) (spick w n False)) =
-              geom_proc n w * (u - d)" .
-            thus ?thesis by simp
+              geom_proc n w * (u - d)"
+              by (simp add: geom_rand_walk_diff_induct)
+            then show ?thesis by simp
           qed
           also have "... = (1+r) * X n w + ((V (Suc n) (pseudo_proj_True n w) - V (Suc n) (pseudo_proj_False n w)))* (u - (1 + r))/ (u-d)"
           proof -
             have "geom_proc n w \<noteq> 0"
               by (metis S0_positive down_lt_up down_positive geom_rand_walk_strictly_positive less_irrefl)
             then show ?thesis
               by simp
           qed
           also have "... = (1+r) * X n w + ((V (Suc n) (pseudo_proj_True n w) - V (Suc n) (pseudo_proj_False n w))* (1 - q))"
           proof -
             have "1 - q = 1 - (1 + r - d)/(u -d)" unfolding q_def by simp
             also have "... = (u - d)/(u - d) - (1 + r - d)/(u -d)" using down_lt_up by simp
             also have "... = (u - d - (1 + r - d))/(u - d)" using diff_divide_distrib[of "u - d" "1 + r -d"] by simp
             also have "... = (u - (1+r))/(u-d)" by simp
             finally have "1 - q = (u - (1+r))/(u-d)" .
             thus ?thesis by simp
           qed
           also have "... = (1+r) * X n w + (1 - q) * V (Suc n) (pseudo_proj_True n w) -
             (1 - q) * V (Suc n) (pseudo_proj_False n w)"
             by (simp add: mult.commute right_diff_distrib)
           also have "... = (1+r) * V n w + (1 - q) * V (Suc n) (pseudo_proj_True n w) -
             (1 - q) * V (Suc n) (pseudo_proj_False n w)" using \<open>X n w = V n w\<close> by simp
           also have "... = q * V (Suc n) (pseudo_proj_True n w) + (1 - q) * V (Suc n) (pseudo_proj_False n w) +
             (1 - q) * V (Suc n) (pseudo_proj_True n w) - (1 - q) * V (Suc n) (pseudo_proj_False n w)"
           using assms Suc rn_price_eq_ind[of N q n matur der w] \<open>n < matur\<close> qprops unfolding V_def q_def
             by simp
           also have "... = q * V (Suc n) (pseudo_proj_True n w) + (1 - q) * V (Suc n) (pseudo_proj_True n w)" by simp
           also have "... = V (Suc n) (pseudo_proj_True n w)"
             using distrib_right[of q "1 - q"  "V (Suc n) (pseudo_proj_True n w)"] by simp
           also have "... = V (Suc n) w"
           proof -
             have "V (Suc n) \<in> borel_measurable (G (Suc n))" unfolding V_def q_def
             proof (rule rn_price_borel_adapt)
               show "der \<in> borel_measurable (G matur)" using assms by simp
               show "N = bernoulli_stream q" using assms unfolding q_def by simp
               show "0 < q" and "q < 1" using qprops by auto
               show "Suc n \<le> matur" using Suc by simp
             qed
             hence "V (Suc n) (pseudo_proj_True n w) = V (Suc n) (pseudo_proj_True (Suc n) (pseudo_proj_True n w))"
               using  geom_proc_filt_info[of "V (Suc n)" "Suc n"] by simp
             also have "... = V (Suc n) (pseudo_proj_True (Suc n) w)" using True
               by (simp add: pseq spick_eq_pseudo_proj_True)
             also have "... = V (Suc n) w" using \<open>V (Suc n) \<in> borel_measurable (G (Suc n))\<close>
               geom_proc_filt_info[of "V (Suc n)" "Suc n"] by simp
             finally show ?thesis .
           qed
           finally show "X (Suc n) w = V (Suc n) w" .
         next
         case False
           hence pseq: "pseudo_proj_True (Suc n) w = pseudo_proj_True (Suc n) (spick w n False)" using filtration
             by (metis (full_types) pseudo_proj_True_def spickI stake_Suc)
           have "X (Suc n) w = cls_val_process Mkt (delta_hedging N der matur) (Suc n) w"
             unfolding X_def delta_hedging_def self_fin_delta_pf_def using  delta_pf_portfolio
             unfolding self_financing_def
             by (metis less_irrefl positive self_finance_charact self_financingE)
           also have "... = geom_proc (Suc n) w * \<Delta> n w + (1 + r) * (X n w - geom_proc n w * \<Delta> n w)"
             using delta_hedging_cls_val_process unfolding X_def \<Delta>_def by simp
           also have "... = d * geom_proc n w * \<Delta> n w + (1 + r) * (X n w - geom_proc n w * \<Delta> n w)"
             using False geometric_process by simp
           also have "... = d * geom_proc n w * \<Delta> n w + (1 + r) * X n w - (1+r) * geom_proc n w * \<Delta> n w"
             by (simp add: right_diff_distrib)
           also have "... = (1+r) * X n w + geom_proc n w * \<Delta> n w * d - geom_proc n w * \<Delta> n w * (1 + r)"
             by (simp add: mult.commute mult.left_commute)
           also have "... = (1+r)* X n w + geom_proc n w * \<Delta> n w * (d - (1 + r))" by (simp add: right_diff_distrib)
           also have "... = (1+r) * X n w + geom_proc n w * (V (Suc n) (pseudo_proj_True n w) - V (Suc n) (pseudo_proj_False n w))/
             (geom_proc (Suc n) (spick w n True) - geom_proc (Suc n) (spick w n False)) * (d - (1 + r))"
             using Suc V_def by (simp add: \<Delta>_def delta_price_def geom_rand_walk_diff_induct)
           also have "... = (1+r) * X n w + geom_proc n w * ((V (Suc n) (pseudo_proj_True n w) - V (Suc n) (pseudo_proj_False n w))) /
             (geom_proc n w * (u - d)) * (d - (1 + r))"
-          proof -
-            have "geom_proc (Suc n) (spick w n True) - geom_proc (Suc n) (spick w n False) =
-              u * geom_proc n w - d * geom_proc n w"
-              using geometric_process
-              by (metis geom_rand_walk_diff_induct linordered_field_class.sign_simps(39) mult.commute)
-            also have "... = geom_proc n w * (u - d)"
-              by (simp add: linordered_field_class.sign_simps(39) mult.commute)
-            finally have "(geom_proc (Suc n) (spick w n True) - geom_proc (Suc n) (spick w n False)) =
-              geom_proc n w * (u - d)" .
-            thus ?thesis by simp
-          qed
+            by (simp add: geom_rand_walk_diff_induct)
           also have "... = (1+r) * X n w + ((V (Suc n) (pseudo_proj_True n w) - V (Suc n) (pseudo_proj_False n w)))* (d - (1 + r))/ (u-d)"
           proof -
             have "geom_proc n w \<noteq> 0"
               by (metis S0_positive down_lt_up down_positive geom_rand_walk_strictly_positive less_irrefl)
             then show ?thesis
               by simp
           qed
           also have "... = (1+r) * X n w + ((V (Suc n) (pseudo_proj_True n w) - V (Suc n) (pseudo_proj_False n w))* (-q))"
           proof -
             have "0-q = 0-(1 + r - d)/(u -d)" unfolding q_def by simp
             also have "... = (d - (1 + r))/(u -d)" by (simp add: minus_divide_left)
             finally have "0 - q = (d - (1+r))/(u-d)" .
             thus ?thesis by simp
           qed
           also have "... = (1+r) * X n w + (- V (Suc n) (pseudo_proj_True n w) * q + V (Suc n) (pseudo_proj_False n w)* q)"
             by (metis (no_types, hide_lams) add.inverse_inverse distrib_right minus_mult_commute minus_real_def mult_minus_left)
           also have "... = (1+r) * X n w - q * V (Suc n) (pseudo_proj_True n w) + q * V (Suc n) (pseudo_proj_False n w)" by simp
           also have "... = (1+r) * V n w -q * V (Suc n) (pseudo_proj_True n w) +
             q * V (Suc n) (pseudo_proj_False n w)" using \<open>X n w = V n w\<close> by simp
           also have "... = q * V (Suc n) (pseudo_proj_True n w) + (1 - q) * V (Suc n) (pseudo_proj_False n w) -
             q * V (Suc n) (pseudo_proj_True n w) + q * V (Suc n) (pseudo_proj_False n w)"
             using assms Suc rn_price_eq_ind[of N q n matur der w] \<open>n < matur\<close> qprops unfolding V_def q_def
             by simp
           also have "... = (1-q) * V (Suc n) (pseudo_proj_False n w) + q * V (Suc n) (pseudo_proj_False n w)" by simp
           also have "... = V (Suc n) (pseudo_proj_False n w)"
             using distrib_right[of q "1 - q"  "V (Suc n) (pseudo_proj_False n w)"] by simp
           also have "... = V (Suc n) w"
           proof -
             have "V (Suc n) \<in> borel_measurable (G (Suc n))" unfolding V_def q_def
             proof (rule rn_price_borel_adapt)
               show "der \<in> borel_measurable (G matur)" using assms by simp
               show "N = bernoulli_stream q" using assms unfolding q_def by simp
               show "0 < q" and "q < 1" using qprops by auto
               show "Suc n \<le> matur" using Suc by simp
             qed
             hence "V (Suc n) (pseudo_proj_False n w) = V (Suc n) (pseudo_proj_False (Suc n) (pseudo_proj_False n w))"
               using  geom_proc_filt_info'[of "V (Suc n)" "Suc n"] by simp
             also have "... = V (Suc n) (pseudo_proj_False (Suc n) w)" using False  spick_eq_pseudo_proj_False
               by (metis pseq pseudo_proj_True_imp_False)
             also have "... = V (Suc n) w" using \<open>V (Suc n) \<in> borel_measurable (G (Suc n))\<close>
               geom_proc_filt_info'[of "V (Suc n)" "Suc n"] by simp
             finally show ?thesis .
           qed
           finally show "X (Suc n) w = V (Suc n) w" .
         qed
       qed
     qed
   }
   thus "\<And>n w. n \<le> matur \<Longrightarrow>
            val_process Mkt (self_fin_delta_pf N der matur (integral\<^sup>L N (discounted_value r (\<lambda>m. der) matur))) n w =
             rn_price N der matur n w" by (simp add: X_def init_def V_def delta_hedging_def)
 qed
 
 
 lemma (in CRR_market_viable) delta_hedging_same_cash_flow:
   assumes "der \<in> borel_measurable (G matur)"
 and "N = bernoulli_stream ((1 + r - d) / (u - d))"
   shows "cls_val_process Mkt (delta_hedging N der matur) matur w =
     der w"
 proof  -
   define q where "q = (1 + r - d) / (u - d)"
   have "0 < q" and "q < 1" unfolding q_def using assms gt_param lt_param CRR_viable by auto
   note qprops = this
   have "cls_val_process Mkt (delta_hedging N der matur) matur w =
     val_process Mkt (delta_hedging N der matur) matur w" using self_financingE self_finance_charact
     unfolding delta_hedging_def self_fin_delta_pf_def
     by (metis delta_pf_portfolio mult_1s(1) mult_cancel_right not_real_square_gt_zero positive)
   also have "... = rn_price N der matur matur w" using delta_hedging_eq_derivative_price assms by simp
   also have "... = rn_rev_price N der matur 0 w" using rn_price_eq qprops assms
     unfolding rn_price_ind_def q_def by simp
   also have "... = der w" by simp
   finally show ?thesis .
 qed
 
 lemma (in CRR_market) delta_hedging_trading_strat:
   assumes "N = bernoulli_stream q"
   and "0 < q"
 and "q < 1"
 and "der \<in> borel_measurable (G matur)"
   shows "trading_strategy (delta_hedging N der matur)" unfolding delta_hedging_def
   by (simp add: assms self_fin_delta_pf_trad_strat)
 
 lemma (in CRR_market) delta_hedging_self_financing:
   shows "self_financing Mkt (delta_hedging N der matur)" unfolding delta_hedging_def self_fin_delta_pf_def
 proof (rule self_finance_charact)
   show "\<forall>n w. prices Mkt risk_free_asset (Suc n) w \<noteq> 0" using positive
     by (metis less_numeral_extra(3))
   show "portfolio (delta_pf N der matur)" using delta_pf_portfolio .
 qed
 
 lemma (in CRR_market_viable) delta_hedging_replicating:
   assumes "der \<in> borel_measurable (G matur)"
   and "N = bernoulli_stream ((1 + r - d) / (u - d))"
   shows "replicating_portfolio (delta_hedging N der matur) der matur"
 unfolding replicating_portfolio_def
 proof (intro conjI)
   define q where "q = (1 + r - d) / (u - d)"
   have "0 < q" and "q < 1" unfolding q_def using assms gt_param lt_param CRR_viable by auto
   note qprops = this
   let ?X = "(delta_hedging N der matur)"
   show "trading_strategy ?X" using delta_hedging_trading_strat qprops assms unfolding q_def by simp
   show "self_financing Mkt ?X" using delta_hedging_self_financing .
   show "stock_portfolio Mkt (delta_hedging N der matur)" unfolding delta_hedging_def self_fin_delta_pf_def
     stock_portfolio_def portfolio_def using stocks delta_pf_support
     by (smt Un_insert_right delta_pf_portfolio insert_commute portfolio_def self_finance_def
         self_finance_portfolio single_comp_support subset_insertI2 subset_singleton_iff
         sum_support_set sup_bot.right_neutral)
   show "AEeq M (cls_val_process Mkt (delta_hedging N der matur) matur) der"
     using delta_hedging_same_cash_flow assms by simp
 qed
 
 definition (in disc_equity_market) complete_market where
 "complete_market \<longleftrightarrow> (\<forall>matur. \<forall> der\<in> borel_measurable (F matur). (\<exists>p. replicating_portfolio p der matur))"
 
 lemma (in CRR_market_viable) CRR_market_complete:
   shows "complete_market" unfolding complete_market_def
 proof (intro allI impI)
   fix matur::nat
   show "\<forall> der \<in> borel_measurable (G matur). (\<exists>p. replicating_portfolio p der matur)"
   proof
     fix der::"bool stream\<Rightarrow>real"
     assume "der \<in> borel_measurable (G matur)"
     define N where "N = bernoulli_stream ((1 + r - d) / (u - d))"
     hence "replicating_portfolio (delta_hedging N der matur) der matur" using delta_hedging_replicating
       \<open>der \<in> borel_measurable (G matur)\<close> by simp
     thus "\<exists>pf. replicating_portfolio pf der matur" by auto
   qed
 qed
 
 
 lemma subalgebras_filtration:
   assumes "filtration M F"
 and "\<forall>t. subalgebra (F t) (G t)"
 and "\<forall> s t. s \<le> t \<longrightarrow> subalgebra (G t) (G s)"
 shows "filtration M G" unfolding filtration_def
 proof (intro conjI allI impI)
   {
     fix t
     have "subalgebra (F t) (G t)" using assms by simp
     moreover have "subalgebra M (F t)" using assms unfolding filtration_def by simp
     ultimately show "subalgebra M (G t)" by (metis subalgebra_def subsetCE subsetI)
   }
   {
     fix s t::'b
     assume "s \<le> t"
     thus "subalgebra (G t) (G s)" using assms by simp
   }
 qed
 
 
 
 lemma subfilt_filt_equiv:
   assumes "filt_equiv F M N"
 and "\<forall> t. subalgebra (F t) (G t)"
 and "\<forall> s t. s \<le> t \<longrightarrow> subalgebra (G t) (G s)"
 shows "filt_equiv G M N" unfolding filt_equiv_def
 proof (intro conjI)
   show "sets M = sets N" using assms unfolding filt_equiv_def by simp
   show "filtration M G" using assms subalgebras_filtration[of M F G] unfolding filt_equiv_def by simp
   show "\<forall>t A. A \<in> sets (G t) \<longrightarrow> (emeasure M A = 0) = (emeasure N A = 0)"
   proof (intro allI ballI impI)
     fix t
     fix A
     assume "A\<in> sets (G t)"
     hence "A \<in> sets (F t)" using assms unfolding subalgebra_def by auto
     thus "(emeasure M A = 0) = (emeasure N A = 0)" using assms unfolding filt_equiv_def by simp
   qed
 qed
 
 lemma (in CRR_market_viable) CRR_market_fair_price:
   assumes "pyf\<in> borel_measurable (G matur)"
   shows "fair_price Mkt
     (\<Sum> w\<in> range (pseudo_proj_True matur). (prod (prob_component ((1 + r - d) / (u - d)) w) {0..<matur}) *
       ((discounted_value r (\<lambda>m. pyf) matur) w))
     pyf matur"
 proof -
   define dpf where "dpf = (discounted_value r (\<lambda>m. pyf) matur)"
   define q where "q = (1 + r - d) / (u - d)"
   have "\<exists>pf. replicating_portfolio pf pyf matur" using CRR_market_complete assms unfolding complete_market_def by simp
   from this obtain pf where "replicating_portfolio pf pyf matur" by auto note pfprop = this
   define N where "N = bernoulli_stream ((1 + r - d) / (u - d))"
   have "fair_price Mkt (integral\<^sup>L N dpf) pyf matur" unfolding dpf_def
   proof (rule replicating_expectation_finite)
     show "risk_neutral_prob N" using assms risk_neutral_iff
       using CRR_viable gt_param lt_param N_def by blast
     have "filt_equiv nat_filtration M N"  using bernoulli_stream_equiv[of N "(1+r-d)/(u-d)"]
         assms gt_param lt_param CRR_viable psgt pslt N_def by simp
     thus "filt_equiv G M N" using subfilt_filt_equiv
       using Filtration.filtration_def filtration geom_rand_walk_borel_adapted
         stoch_proc_subalg_nat_filt stock_filtration by blast
     show "pyf \<in> borel_measurable (G matur)" using assms by simp
     show "viable_market Mkt" using CRR_viable by simp
     have "infinite_cts_filtration p M nat_filtration" using bernoulli_nat_filtration[of M p] bernoulli psgt pslt
       by simp
     thus "sets (G 0) = {{}, space M}" using stock_filtration
       infinite_cts_filtration.stoch_proc_filt_triv_init[of p M nat_filtration geom_proc]
       geom_rand_walk_borel_adapted bot_nat_def unfolding init_triv_filt_def by simp
     show "replicating_portfolio pf pyf matur" using pfprop .
     show "\<forall>n. \<forall>asset\<in>support_set pf. finite (prices Mkt asset n ` space M)"
     proof (intro allI ballI)
       fix n
       fix asset
       assume "asset \<in> support_set pf"
       hence "prices Mkt asset n \<in> borel_measurable (G n)" using readable pfprop
         unfolding  replicating_portfolio_def stock_portfolio_def adapt_stoch_proc_def by auto
       hence "prices Mkt asset n \<in> borel_measurable (nat_filtration n)" using stock_filtration
         stoch_proc_subalg_nat_filt geom_rand_walk_borel_adapted
         measurable_from_subalg[of "nat_filtration n" "G n" "prices Mkt asset n" borel]
         unfolding adapt_stoch_proc_def by auto
       thus "finite (prices Mkt asset n ` space M)" using nat_filtration_vimage_finite[of "prices Mkt asset n"] by simp
     qed
     show "\<forall>n. \<forall>asset\<in>support_set pf. finite (pf asset n ` space M)"
     proof (intro allI ballI)
       fix n
       fix asset
       assume "asset \<in> support_set pf"
       hence "pf asset n \<in> borel_measurable (G n)" using pfprop predict_imp_adapt[of "pf asset"]
         unfolding replicating_portfolio_def trading_strategy_def adapt_stoch_proc_def by auto
       hence "pf asset n \<in> borel_measurable (nat_filtration n)" using stock_filtration
         stoch_proc_subalg_nat_filt geom_rand_walk_borel_adapted
         measurable_from_subalg[of "nat_filtration n" "G n" "pf asset n" borel]
         unfolding adapt_stoch_proc_def by auto
       thus "finite (pf asset n ` space M)" using nat_filtration_vimage_finite[of "pf asset n"] by simp
     qed
   qed
   moreover have "integral\<^sup>L N dpf =
     (\<Sum> w\<in> range (pseudo_proj_True matur). (prod (prob_component q w) {0..<matur}) * (dpf w))"
   proof (rule infinite_cts_filtration.expect_prob_comp)
     show "infinite_cts_filtration q N nat_filtration" using  assms  pslt psgt
         bernoulli_nat_filtration unfolding q_def using gt_param lt_param CRR_viable N_def by auto
     have "dpf \<in> borel_measurable (G matur)" using assms discounted_measurable[of pyf "G matur"]
       unfolding dpf_def by simp
     thus "dpf \<in> borel_measurable (nat_filtration matur)" using stock_filtration
         stoch_proc_subalg_nat_filt geom_rand_walk_borel_adapted
         measurable_from_subalg[of "nat_filtration matur" "G matur" dpf]
       unfolding adapt_stoch_proc_def by auto
   qed
   ultimately show ?thesis unfolding dpf_def q_def by simp
 qed
 
 end
\ No newline at end of file
diff --git a/thys/Ergodic_Theory/Fekete.thy b/thys/Ergodic_Theory/Fekete.thy
--- a/thys/Ergodic_Theory/Fekete.thy
+++ b/thys/Ergodic_Theory/Fekete.thy
@@ -1,488 +1,490 @@
 (*  Author:  Sébastien Gouëzel   sebastien.gouezel@univ-rennes1.fr
     License: BSD
 *)
 
 section \<open>Subadditive and submultiplicative sequences\<close>
 
 theory Fekete
   imports "HOL-Analysis.Analysis"
 begin
 
 text \<open>A real sequence is subadditive if $u_{n+m} \leq u_n+u_m$. This implies the
 convergence of $u_n/n$ to $Inf\{u_n/n\} \in [-\infty, +\infty)$, a useful result known
 as Fekete lemma. We prove it below.
 
 Taking logarithms, the same result applies to submultiplicative sequences. We illustrate
 it with the definition of the spectral radius as the limit of $\|x^n\|^{1/n}$, the
 convergence following from Fekete lemma.\<close>
 
 
 subsection \<open>Subadditive sequences\<close>
 
 text \<open>We define subadditive sequences, either from the start or eventually.\<close>
 
 definition subadditive::"(nat\<Rightarrow>real) \<Rightarrow> bool"
   where "subadditive u = (\<forall>m n. u (m+n) \<le> u m + u n)"
 
 lemma subadditiveI:
   assumes "\<And>m n. u (m+n) \<le> u m + u n"
   shows "subadditive u"
 unfolding subadditive_def using assms by auto
 
 lemma subadditiveD:
   assumes "subadditive u"
   shows "u (m+n) \<le> u m + u n"
 using assms unfolding subadditive_def by auto
 
 lemma subadditive_un_le_nu1:
   assumes "subadditive u"
           "n > 0"
   shows "u n \<le> n * u 1"
 proof -
   have *: "n = 0 \<or> (u n \<le> n * u 1)" for n
   proof (induction n)
     case 0
     then show ?case by auto
   next
     case (Suc n)
     consider "n = 0" | "n > 0" by auto
     then show ?case
     proof (cases)
       case 1
       then show ?thesis by auto
     next
       case 2
       then have "u (Suc n) \<le> u n + u 1" using subadditiveD[OF assms(1), of n 1] by auto
       then show ?thesis using Suc.IH 2 by (auto simp add: algebra_simps)
     qed
   qed
   show ?thesis using *[of n] \<open>n > 0\<close> by auto
 qed
 
 definition eventually_subadditive::"(nat\<Rightarrow>real) \<Rightarrow> nat \<Rightarrow> bool"
   where "eventually_subadditive u N0 = (\<forall>m>N0. \<forall>n>N0. u (m+n) \<le> u m + u n)"
 
 lemma eventually_subadditiveI:
   assumes "\<And>m n. m > N0 \<Longrightarrow> n > N0 \<Longrightarrow> u (m+n) \<le> u m + u n"
   shows "eventually_subadditive u N0"
 unfolding eventually_subadditive_def using assms by auto
 
 lemma subadditive_imp_eventually_subadditive:
   assumes "subadditive u"
   shows "eventually_subadditive u 0"
 using assms unfolding subadditive_def eventually_subadditive_def by auto
 
 text \<open>The main inequality that will lead to convergence is given in the next lemma:
 given $n$, then eventually $u_m/m$ is bounded by $u_n/n$, up to an arbitrarily small error.
 This is proved by doing the euclidean division of $m$ by $n$ and using the subadditivity.
 (the remainder in the euclidean division will give the error term.)\<close>
 
 lemma eventually_subadditive_ineq:
   assumes "eventually_subadditive u N0" "e>0" "n>N0"
   shows "\<exists>N>N0. \<forall>m\<ge>N. u m/m < u n/n + e"
 proof -
   have ineq_rec: "u(a*n+r) \<le> a * u n + u r" if "n>N0" "r>N0" for a n r
   proof (induct a)
     case (Suc a)
     have "a*n+r>N0" using \<open>r>N0\<close> by simp
     have "u((Suc a)*n+r) = u(a*n+r+n)" by (simp add: algebra_simps)
     also have "... \<le> u(a*n+r)+u n" using assms \<open>n>N0\<close> \<open>a*n+r>N0\<close> eventually_subadditive_def by blast
     also have "... \<le> a*u n + u r + u n" by (simp add: Suc.hyps)
     also have "... = (Suc a) * u n + u r" by (simp add: algebra_simps)
     finally show ?case by simp
   qed (simp)
 
   have "n>0" "real n > 0" using \<open>n>N0\<close> by auto
   define C where "C = Max {abs(u i) |i. i\<le>2*n}"
   have ineq_C: "abs(u i) \<le> C" if "i \<le> 2 * n" for i
     unfolding C_def by (intro Max_ge, auto simp add: that)
 
   have ineq_all_m: "u m/m \<le> u n/n + 3*C/m" if "m\<ge>n" for m
   proof -
     have "real m>0" using \<open>m\<ge>n\<close> \<open>0 < real n\<close> by linarith
 
     obtain a0 r0 where "r0<n" "m = a0*n+r0"
       using \<open>0 < n\<close> mod_div_decomp mod_less_divisor by blast
     define a where "a = a0-1"
     define r where "r = r0+n"
     have "r<2*n" "r\<ge>n" unfolding r_def by (auto simp add: \<open>r0<n\<close>)
     have "a0>0" using \<open>m = a0*n + r0\<close> \<open>n \<le> m\<close> \<open>r0 < n\<close> not_le by fastforce
     then have "m = a * n + r" using a_def r_def \<open>m = a0*n+r0\<close> mult_eq_if by auto
     then have real_eq: "-r = real n * a - m" by simp
 
     have "r>N0" using \<open>r\<ge>n\<close> \<open>n>N0\<close> by simp
     then have "u m \<le> a * u n + u r" using ineq_rec \<open>m = a*n+r\<close> \<open>n>N0\<close> by simp
     then have "n * u m \<le> n * (a * u n + u r)" using \<open>real n>0\<close> by simp
     then have "n * u m - m * u n \<le> -r * u n + n * u r"
       unfolding real_eq by (simp add: algebra_simps)
     also have "... \<le> r * abs(u n) + n * abs(u r)"
       apply (intro add_mono mult_left_mono) using real_0_le_add_iff by fastforce+
     also have "... \<le> (2 * n) * C + n * C"
       apply (intro add_mono mult_mono ineq_C) using less_imp_le[OF \<open>r < 2 * n\<close>] by auto
     finally have "n * u m - m * u n \<le> 3*C*n" by auto
     then show "u m/m \<le> u n/n + 3*C/m"
       using \<open>0 < real n\<close> \<open>0 < real m\<close> by (simp add: divide_simps mult.commute)
   qed
 
   obtain M::nat where M: "M \<ge> 3 * C / e" using real_nat_ceiling_ge by auto
   define N where "N = M + n + N0 + 1"
   have "N > 3 * C / e" "N \<ge> n" "N > N0" unfolding N_def using M by auto
   have "u m/m < u n/n + e" if "m \<ge> N" for m
   proof -
     have "3 * C / m < e"
       using that \<open>N > 3 * C / e\<close> \<open>e > 0\<close> apply (auto simp add: algebra_simps divide_simps)
       by (meson le_less_trans linorder_not_le mult_less_cancel_left_pos of_nat_less_iff)
     then show ?thesis using ineq_all_m[of m] \<open>n \<le> N\<close> \<open>N \<le> m\<close> by auto
   qed
   then show ?thesis using \<open>N0 < N\<close> by blast
 qed
 
 text \<open>From the inequality above, we deduce the convergence of $u_n/n$ to its infimum. As this
 infimum might be $-\infty$, we formulate this convergence in the extended reals. Then, we
 specialize it to the real situation, separating the cases where $u_n/n$ is bounded below or not.\<close>
 
 lemma subadditive_converges_ereal':
   assumes "eventually_subadditive u N0"
   shows "(\<lambda>m. ereal(u m/m)) \<longlonglongrightarrow> Inf {ereal(u n/n) | n. n>N0}"
 proof -
   define v where "v = (\<lambda>m. ereal(u m/m))"
   define V where "V = {v n | n. n>N0}"
   define l where "l = Inf V"
 
   have "\<And>t. t\<in>V \<Longrightarrow> t\<ge>l" by (simp add: Inf_lower l_def)
   then have "v n \<ge> l" if "n > N0" for n using V_def that by blast
   then have lower: "eventually (\<lambda>n. a < v n) sequentially" if "a < l" for a
     by (meson that dual_order.strict_trans1 eventually_at_top_dense)
 
   have upper: "eventually (\<lambda>n. a > v n) sequentially" if "a > l" for a
   proof -
     obtain t where "t\<in>V" "t<a" by (metis \<open>a>l\<close> Inf_greatest l_def not_le)
     then obtain e::real where "e>0" "t+e < a" by (meson ereal_le_epsilon2 leD le_less_linear)
     obtain n where "n>N0" "t = u n/n" using V_def v_def \<open>t \<in> V\<close> by blast
     then have "u n/n + e < a" using \<open>t+e < a\<close> by simp
     obtain N where "\<forall>m\<ge>N. u m/m < u n/n + e"
       using eventually_subadditive_ineq[OF assms] \<open>0 < e\<close> \<open>N0 < n\<close> by blast
     then have "u m/m < a" if "m \<ge> N" for m
       using that \<open>u n/n + e < a\<close> less_ereal.simps(1) less_trans by blast
     then have "v m< a" if "m \<ge> N" for m using v_def that by blast
     then show ?thesis using eventually_at_top_linorder by auto
   qed
   show ?thesis
     using lower upper unfolding V_def l_def v_def by (simp add: order_tendsto_iff)
 qed
 
 lemma subadditive_converges_ereal:
   assumes "subadditive u"
   shows "(\<lambda>m. ereal(u m/m)) \<longlonglongrightarrow> Inf {ereal(u n/n) | n. n>0}"
 by (rule subadditive_converges_ereal'[OF subadditive_imp_eventually_subadditive[OF assms]])
 
 lemma subadditive_converges_bounded':
   assumes "eventually_subadditive u N0"
           "bdd_below {u n/n | n. n>N0}"
   shows "(\<lambda>n. u n/n) \<longlonglongrightarrow> Inf {u n/n | n. n>N0}"
 proof-
   have *: "(\<lambda>n. ereal(u n /n)) \<longlonglongrightarrow> Inf {ereal(u n/n)|n. n > N0}"
     by (simp add: assms(1) subadditive_converges_ereal')
   define V where "V = {u n/n | n. n>N0}"
   have a: "bdd_below V" "V\<noteq>{}" by (auto simp add: V_def assms(2))
   have "Inf {ereal(t)| t. t\<in>V} = ereal(Inf V)" by (subst ereal_Inf'[OF a], simp add: Setcompr_eq_image)
   moreover have "{ereal(t)| t. t\<in>V} = {ereal(u n/n)|n. n > N0}" using V_def by blast
   ultimately have "Inf {ereal(u n/n)|n. n > N0} = ereal(Inf {u n/n |n. n > N0})" using V_def by auto
   then have "(\<lambda>n. ereal(u n /n)) \<longlonglongrightarrow> ereal(Inf {u n/n | n. n>N0})" using * by auto
   then show ?thesis by simp
 qed
 
 lemma subadditive_converges_bounded:
   assumes "subadditive u"
           "bdd_below {u n/n | n. n>0}"
   shows "(\<lambda>n. u n/n) \<longlonglongrightarrow> Inf {u n/n | n. n>0}"
 by (rule subadditive_converges_bounded'[OF subadditive_imp_eventually_subadditive[OF assms(1)] assms(2)])
 
 text \<open>We reformulate the previous lemma in a more directly usable form, avoiding the infimum.\<close>
 
 lemma subadditive_converges_bounded'':
   assumes "subadditive u"
           "\<And>n. n > 0 \<Longrightarrow> u n \<ge> n * (a::real)"
   shows "\<exists>l. (\<lambda>n. u n / n) \<longlonglongrightarrow> l \<and> (\<forall>n>0. u n \<ge> n * l)"
 proof -
   have B: "bdd_below {u n/n | n. n>0}"
     apply (rule bdd_belowI[of _ a]) using assms(2)
     apply (auto simp add: divide_simps)
-    by (metis linordered_field_class.sign_simps(5) mult_left_le_imp_le of_nat_0_less_iff)
+    apply (metis mult.commute mult_left_le_imp_le of_nat_0_less_iff)
+    done
   define l where "l = Inf {u n/n | n. n>0}"
   have *: "u n / n \<ge> l" if "n > 0" for n
     unfolding l_def using that by (auto intro!: cInf_lower[OF _ B])
   show ?thesis
     apply (rule exI[of _ l], auto)
     using subadditive_converges_bounded[OF assms(1) B] apply (simp add: l_def)
     using * by (simp add: divide_simps algebra_simps)
 qed
 
 lemma subadditive_converges_unbounded':
   assumes "eventually_subadditive u N0"
           "\<not> (bdd_below {u n/n | n. n>N0})"
   shows "(\<lambda>n. ereal(u n/n)) \<longlonglongrightarrow> -\<infinity>"
 proof -
   have *: "(\<lambda>n. ereal(u n /n)) \<longlonglongrightarrow> Inf {ereal(u n/n)|n. n > N0}"
     by (simp add: assms(1) subadditive_converges_ereal')
   define V where "V = {u n/n | n. n>N0}"
   then have "\<not> bdd_below V" using assms by simp
   have "Inf {ereal(t) | t. t\<in>V} = -\<infinity>"
     by (rule ereal_bot, metis (mono_tags, lifting) \<open>\<not> bdd_below V\<close> bdd_below_def
         leI Inf_lower2 ereal_less_eq(3) le_less mem_Collect_eq)
   moreover have "{ereal(t)| t. t\<in>V} = {ereal(u n/n)|n. n > N0}" using V_def by blast
   ultimately have "Inf {ereal(u n/n)|n. n > N0} = -\<infinity>" by auto
   then show ?thesis using * by simp
 qed
 
 lemma subadditive_converges_unbounded:
   assumes "subadditive u"
           "\<not> (bdd_below {u n/n | n. n>0})"
   shows "(\<lambda>n. ereal(u n/n)) \<longlonglongrightarrow> -\<infinity>"
 by (rule subadditive_converges_unbounded'[OF subadditive_imp_eventually_subadditive[OF assms(1)] assms(2)])
 
 subsection \<open>Superadditive sequences\<close>
 
 text \<open>While most applications involve subadditive sequences, one sometimes encounters superadditive
 sequences. We reformulate quickly some of the above results in this setting.\<close>
 
 definition superadditive::"(nat\<Rightarrow>real) \<Rightarrow> bool"
   where "superadditive u = (\<forall>m n. u (m+n) \<ge> u m + u n)"
 
 lemma subadditive_of_superadditive:
   assumes "superadditive u"
   shows "subadditive (\<lambda>n. -u n)"
 using assms unfolding superadditive_def subadditive_def by (auto simp add: algebra_simps)
 
 lemma superadditive_un_ge_nu1:
   assumes "superadditive u"
           "n > 0"
   shows "u n \<ge> n * u 1"
 using subadditive_un_le_nu1[OF subadditive_of_superadditive[OF assms(1)] assms(2)] by auto
 
 lemma superadditive_converges_bounded'':
   assumes "superadditive u"
           "\<And>n. n > 0 \<Longrightarrow> u n \<le> n * (a::real)"
   shows "\<exists>l. (\<lambda>n. u n / n) \<longlonglongrightarrow> l \<and> (\<forall>n>0. u n \<le> n * l)"
 proof -
   have "\<exists>l. (\<lambda>n. -u n / n) \<longlonglongrightarrow> l \<and> (\<forall>n>0. -u n \<ge> n * l)"
     apply (rule subadditive_converges_bounded''[OF subadditive_of_superadditive[OF assms(1)], of "-a"])
     using assms(2) by auto
   then obtain l where l: "(\<lambda>n. -u n / n) \<longlonglongrightarrow> l" "(\<forall>n>0. -u n \<ge> n * l)" by blast
   have "(\<lambda>n. -((-u n)/n)) \<longlonglongrightarrow> -l"
     by (intro tendsto_intros l)
   moreover have "\<forall>n>0. u n \<le> n * (-l)"
     using l(2) by (auto simp add: algebra_simps) (metis minus_equation_iff neg_le_iff_le)
   ultimately show ?thesis
     by auto
 qed
 
 
 subsection \<open>Almost additive sequences\<close>
 
 text \<open>One often encounters sequences which are both subadditive and superadditive, but only up
 to an additive constant. Adding or subtracting this constant, one can make the sequence
 genuinely subadditive or superadditive, and thus deduce results about its convergence, as follows.
 Such sequences appear notably when dealing with quasimorphisms.\<close>
 
 lemma almost_additive_converges:
   fixes u::"nat \<Rightarrow> real"
   assumes "\<And>m n. abs(u(m+n) - u m - u n) \<le> C"
   shows "convergent (\<lambda>n. u n/n)"
         "abs(u k - k * lim (\<lambda>n. u n / n)) \<le> C"
 proof -
   have "(abs (u 0)) \<le> C" using assms[of 0 0] by auto
   then have "C \<ge> 0" by auto
 
   define v where "v = (\<lambda>n. u n + C)"
   have "subadditive v"
     unfolding subadditive_def v_def using assms by (auto simp add: algebra_simps abs_diff_le_iff)
   then have vle: "v n \<le> n * v 1" if "n > 0" for n
     using subadditive_un_le_nu1 that by auto
   define w where "w = (\<lambda>n. u n - C)"
   have "superadditive w"
     unfolding superadditive_def w_def using assms by (auto simp add: algebra_simps abs_diff_le_iff)
   then have wge: "w n \<ge> n * w 1" if "n > 0" for n
     using superadditive_un_ge_nu1 that by auto
 
   have I: "v n \<ge> w n" for n
     unfolding v_def w_def using \<open>C \<ge> 0\<close> by auto
   then have *: "v n \<ge> n * w 1" if "n > 0" for n using order_trans[OF wge[OF that]] by auto
   then obtain lv where lv: "(\<lambda>n. v n/n) \<longlonglongrightarrow> lv" "\<And>n. n > 0 \<Longrightarrow> v n \<ge> n * lv"
     using subadditive_converges_bounded''[OF \<open>subadditive v\<close> *] by auto
   have *: "w n \<le> n * v 1" if "n > 0" for n using order_trans[OF _ vle[OF that]] I by auto
   then obtain lw where lw: "(\<lambda>n. w n/n) \<longlonglongrightarrow> lw" "\<And>n. n > 0 \<Longrightarrow> w n \<le> n * lw"
     using superadditive_converges_bounded''[OF \<open>superadditive w\<close> *] by auto
 
   have *: "v n/n = w n /n + 2*C*(1/n)" for n
     unfolding v_def w_def by (auto simp add: algebra_simps divide_simps)
   have "(\<lambda>n. w n /n + 2*C*(1/n)) \<longlonglongrightarrow> lw + 2*C*0"
     by (intro tendsto_add tendsto_mult lim_1_over_n lw, auto)
   then have "lw = lv"
     unfolding *[symmetric] using lv(1) LIMSEQ_unique by auto
 
   have *: "u n/n = w n /n + C*(1/n)" for n
     unfolding w_def by (auto simp add: algebra_simps divide_simps)
   have "(\<lambda>n. u n /n) \<longlonglongrightarrow> lw + C*0"
     unfolding * by (intro tendsto_add tendsto_mult lim_1_over_n lw, auto)
   then have lu: "convergent (\<lambda>n. u n/n)" "lim (\<lambda>n. u n/n) = lw"
     by (auto simp add: convergentI limI)
   then show "convergent (\<lambda>n. u n/n)" by simp
 
   show "abs(u k - k * lim (\<lambda>n. u n / n)) \<le> C"
   proof (cases "k>0")
     case False
     then show ?thesis using assms[of 0 0] by auto
   next
     case True
     have "u k - k * lim (\<lambda>n. u n/n) = v k - C - k * lv" unfolding lu(2) \<open>lw = lv\<close> v_def by auto
     also have "... \<ge> -C" using lv(2)[OF True] by auto
     finally have A: "u k - k * lim (\<lambda>n. u n/n) \<ge> - C" by simp
     have "u k - k * lim (\<lambda>n. u n/n) = w k + C - k * lw" unfolding lu(2) w_def by auto
     also have "... \<le> C" using lw(2)[OF True] by auto
     finally show ?thesis using A by auto
   qed
 qed
 
 
 subsection \<open>Submultiplicative sequences, application to the spectral radius\<close>
 
 text \<open>In the same way as subadditive sequences, one may define submultiplicative sequences.
 Essentially, a sequence is submultiplicative if its logarithm is subadditive. A difference is
 that we allow a submultiplicative sequence to take the value $0$, as this shows up in applications.
 This implies that we have to distinguish in the proofs the situations where the value $0$
 is taken or not. In the latter situation, we can use directly the results from the
 subadditive case to deduce convergence. In the former situation, convergence to $0$ is obvious
 as the sequence vanishes eventually.\<close>
 
 lemma submultiplicative_converges:
   fixes u::"nat\<Rightarrow>real"
   assumes "\<And>n. u n \<ge> 0"
           "\<And>m n. u (m+n) \<le> u m * u n"
   shows "(\<lambda>n. root n (u n))\<longlonglongrightarrow> Inf {root n (u n) | n. n>0}"
 proof -
   define v where "v = (\<lambda> n. root n (u n))"
   define V where "V = {v n | n. n>0}"
   then have "V \<noteq> {}" by blast
   have "t \<ge> 0" if "t \<in> V" for t using that V_def v_def assms(1) by auto
   then have "Inf V \<ge> 0" by (simp add: \<open>V \<noteq> {}\<close> cInf_greatest)
   have "bdd_below V" by (meson \<open>\<And>t. t \<in> V \<Longrightarrow> 0 \<le> t\<close> bdd_below_def)
 
   show ?thesis
   proof cases
     assume "\<exists>n. u n = 0"
     then obtain n where "u n = 0" by auto
     then have "u m = 0" if "m \<ge> n" for m by (metis that antisym_conv assms(1) assms(2) le_Suc_ex mult_zero_left)
     then have *: "v m = 0" if "m \<ge> n" for m using v_def that by simp
     then have "v \<longlonglongrightarrow> 0" using tendsto_explicit by force
 
     have "v (Suc n) \<in> V" using V_def by blast
     moreover have "v (Suc n) = 0" using * by auto
     ultimately have "Inf V \<le> 0" by (simp add: \<open>bdd_below V\<close> cInf_lower)
     then have "Inf V = 0" using \<open>0 \<le> Inf V\<close> by auto
     then show ?thesis using V_def v_def \<open>v \<longlonglongrightarrow> 0\<close> by auto
   next
     assume "\<not> (\<exists>n. u n = 0)"
     then have "u n > 0" for n by (metis assms(1) less_eq_real_def)
     define w where "w n = ln (u n)" for n
     have express_vn: "v n = exp(w n/n)" if "n>0" for n
     proof -
       have "(exp(w n/n))^n = exp(n*(w n/n))" by (metis exp_of_nat_mult)
       also have "... = exp(w n)" by (simp add: \<open>0 < n\<close>)
       also have "... = u n" by (simp add: \<open>\<And>n. 0 < u n\<close> w_def)
       finally have "exp(w n/n) = root n (u n)" by (metis \<open>0 < n\<close> exp_ge_zero real_root_power_cancel)
       then show ?thesis unfolding v_def by simp
     qed
 
     have "eventually_subadditive w 0"
     proof (rule eventually_subadditiveI)
       fix m n
       have "w (m+n) = ln (u (m+n))" by (simp add: w_def)
       also have "... \<le> ln(u m * u n)"
         by (meson \<open>\<And>n. 0 < u n\<close> assms(2) zero_less_mult_iff ln_le_cancel_iff)
       also have "... = ln(u m) + ln(u n)" by (simp add: \<open>\<And>n. 0 < u n\<close> ln_mult)
       also have "... = w m + w n" by (simp add: w_def)
       finally show "w (m+n) \<le> w m + w n".
     qed
 
     define l where "l = Inf V"
     then have "v n\<ge>l" if "n > 0" for n
       using V_def that by (metis (mono_tags, lifting) \<open>bdd_below V\<close> cInf_lower mem_Collect_eq)
     then have lower: "eventually (\<lambda>n. a < v n) sequentially" if "a < l" for a
       by (meson that dual_order.strict_trans1 eventually_at_top_dense)
 
     have upper: "eventually (\<lambda>n. a > v n) sequentially" if "a > l" for a
     proof -
       obtain t where "t\<in>V" "t < a" using \<open>V \<noteq> {}\<close> cInf_lessD l_def \<open>a>l\<close> by blast
       then have "t > 0" using V_def \<open>\<And>n. 0 < u n\<close> v_def by auto
       then have "a/t > 1" using \<open>t<a\<close> by simp
       define e where "e = ln(a/t)/2"
       have "e > 0" "e < ln(a/t)" unfolding e_def by (simp_all add: \<open>1 < a / t\<close> ln_gt_zero)
       then have "exp(e) < a/t" by (metis \<open>1 < a / t\<close> exp_less_cancel_iff exp_ln less_trans zero_less_one)
 
       obtain n where "n>0" "t = v n" using V_def v_def \<open>t \<in> V\<close> by blast
-      then have "v n * exp(e) < a" using \<open>exp(e) < a/t\<close> by (metis \<open>0 < t\<close> linordered_field_class.sign_simps(24) pos_less_divide_eq)
+      with \<open>0 < t\<close> have "v n * exp(e) < a" using \<open>exp(e) < a/t\<close>
+        by (auto simp add: field_simps)
 
       obtain N where *: "N>0" "\<And>m. m\<ge>N \<Longrightarrow> w m/m < w n/n + e"
         using eventually_subadditive_ineq[OF \<open>eventually_subadditive w 0\<close>] \<open>0 < n\<close> \<open>e>0\<close> by blast
       have "v m < a" if "m \<ge> N" for m
       proof -
         have "m>0" using that \<open>N>0\<close> by simp
         have "w m/m < w n/n + e" by (simp add: \<open>N \<le> m\<close> *)
         then have "exp(w m/m) < exp(w n/n + e)" by simp
         also have "... = exp(w n/n) * exp(e)" by (simp add: mult_exp_exp)
         finally have "v m < v n * exp(e)" using express_vn \<open>m>0\<close> \<open>n>0\<close> by simp
         then show "v m < a" using \<open>v n * exp(e) < a\<close> by simp
       qed
       then show ?thesis using eventually_at_top_linorder by auto
     qed
 
     show ?thesis
       using lower upper unfolding v_def l_def V_def by (simp add: order_tendsto_iff)
   qed
 qed
 
 text \<open>An important application of submultiplicativity is to prove the existence of the
 spectral radius of a matrix, as the limit of $\|A^n\|^{1/n}$.\<close>
 
 definition spectral_radius::"'a::real_normed_algebra_1 \<Rightarrow> real"
   where "spectral_radius x = Inf {root n (norm(x^n))| n. n>0}"
 
 lemma spectral_radius_aux:
   fixes x::"'a::real_normed_algebra_1"
   defines "V \<equiv> {root n (norm(x^n))| n. n>0}"
   shows "\<And>t. t\<in>V \<Longrightarrow> t \<ge> spectral_radius x"
         "\<And>t. t\<in>V \<Longrightarrow> t \<ge> 0"
         "bdd_below V"
         "V \<noteq> {}"
         "Inf V \<ge> 0"
 proof -
   show "V\<noteq>{}" using V_def by blast
   show *: "t \<ge> 0" if "t \<in> V" for t using that unfolding V_def using real_root_pos_pos_le by auto
   then show "bdd_below V" by (meson bdd_below_def)
   then show "Inf V \<ge> 0" by (simp add: \<open>V \<noteq> {}\<close> * cInf_greatest)
   show "\<And>t. t\<in>V \<Longrightarrow> t \<ge> spectral_radius x" by (metis (mono_tags, lifting) \<open>bdd_below V\<close> assms cInf_lower spectral_radius_def)
 qed
 
 lemma spectral_radius_nonneg [simp]:
   "spectral_radius x \<ge> 0"
 by (simp add: spectral_radius_aux(5) spectral_radius_def)
 
 lemma spectral_radius_upper_bound [simp]:
   "(spectral_radius x)^n \<le> norm(x^n)"
 proof (cases)
   assume "\<not>(n = 0)"
   have "root n (norm(x^n)) \<ge> spectral_radius x"
     using spectral_radius_aux \<open>n \<noteq> 0\<close> by auto
   then show ?thesis
     by (metis \<open>n \<noteq> 0\<close> spectral_radius_nonneg norm_ge_zero not_gr0 power_mono real_root_pow_pos2)
 qed (simp)
 
 lemma spectral_radius_limit:
   "(\<lambda>n. root n (norm(x^n))) \<longlonglongrightarrow> spectral_radius x"
 proof -
   have "norm(x^(m+n)) \<le> norm(x^m) * norm(x^n)" for m n by (simp add: power_add norm_mult_ineq)
   then show ?thesis unfolding spectral_radius_def using submultiplicative_converges by auto
 qed
 
 end (*of Fekete.thy*)
diff --git a/thys/Ergodic_Theory/Gouezel_Karlsson.thy b/thys/Ergodic_Theory/Gouezel_Karlsson.thy
--- a/thys/Ergodic_Theory/Gouezel_Karlsson.thy
+++ b/thys/Ergodic_Theory/Gouezel_Karlsson.thy
@@ -1,1809 +1,1810 @@
 (*  Author:  Sébastien Gouëzel   sebastien.gouezel@univ-rennes1.fr
     License: BSD
 *)
 
 section \<open>Gouezel-Karlsson\<close>
 
 theory Gouezel_Karlsson
   imports Asymptotic_Density Kingman
 begin
 
 text \<open>This section is devoted to the proof of the main ergodic result of
 the article "Subadditive and multiplicative ergodic theorems" by Gouezel and
 Karlsson~\cite{gouezel_karlsson}. It is a version of Kingman
 theorem ensuring that, for subadditive cocycles, there are almost surely
 many times $n$ where the cocycle is nearly additive at \emph{all} times
 between $0$ and $n$.
 
 This theorem is then used in this article to construct horofunctions
 characterizing the behavior at infinity of compositions
 of semi-contractions. This requires too many further notions to be implemented
 in current Isabelle/HOL, but the main ergodic result is completely
 proved below, in Theorem~\verb+Gouezel_Karlsson+, following the arguments in the paper (but in a
 slightly more general setting here as we are not making any ergodicity assumption).
 
 To simplify the exposition, the theorem is proved assuming that the limit of the subcocycle
 vanishes almost everywhere, in the locale \verb+Gouezel_Karlsson_Kingman+.
 The final result is proved by an easy reduction to this case.
 
 The main steps of the proof are as follows:
 \begin{itemize}
 \item assume first that the map is invertible, and consider the inverse map and the corresponding
 inverse subcocycle. With combinatorial arguments that only work for this inverse subcocycle, we
 control the density of bad times given some allowed error $d>0$, in a precise quantitative way, in
 Lemmas~\verb+upper_density_all_times+ and~\verb+upper_density_large_k+. We put these estimates
 together in Lemma~\verb+upper_density_delta+.
 \item These estimates are then transfered to the original time direction and the original subcocycle in
 Lemma~\verb+upper_density_good_direction_invertible+. The fact that we have quantitative estimates
 in terms of asymptotic densities is central here, just having some infiniteness statement would not be
 enough.
 \item The invertibility assumption is removed in Lemma~\verb+upper_density_good_direction+ by
 using the result in the natural extension.
 \item Finally, the main result is deduced in Lemma~\verb+infinite_AE+ (still assuming that the
 asymptotic limit vanishes almost everywhere), and in full generality in
 Theorem~\verb+Gouezel_Karlsson_Kingman+.
 \end{itemize}
 \<close>
 
 
 lemma upper_density_eventually_measure:
   fixes a::real
   assumes [measurable]: "\<And>n. {x \<in> space M. P x n} \<in> sets M"
     and "emeasure M {x \<in> space M. upper_asymptotic_density {n. P x n} < a} > b"
   shows "\<exists>N. emeasure M {x \<in> space M. \<forall>n \<ge> N. card ({n. P x n} \<inter> {..<n}) < a * n} > b"
 proof -
   define G where "G = {x \<in> space M. upper_asymptotic_density {n. P x n} < a}"
   define H where "H = (\<lambda>N. {x \<in> space M. \<forall>n \<ge> N. card ({n. P x n} \<inter> {..<n}) < a * n})"
   have [measurable]: "G \<in> sets M" "\<And>N. H N \<in> sets M" unfolding G_def H_def by auto
   have "G \<subseteq> (\<Union>N. H N)"
   proof
     fix x assume "x \<in> G"
     then have "x \<in> space M" unfolding G_def by simp
     have "eventually (\<lambda>n. card({n. P x n} \<inter> {..<n}) < a * n) sequentially"
       using \<open>x \<in> G\<close> unfolding G_def using upper_asymptotic_densityD by auto
     then obtain N where "\<And>n. n \<ge> N \<Longrightarrow> card({n. P x n} \<inter> {..<n}) < a * n"
       using eventually_sequentially by auto
     then have "x \<in> H N" unfolding H_def using \<open>x \<in> space M\<close> by auto
     then show "x \<in> (\<Union>N. H N)" by blast
   qed
   have "b < emeasure M G" using assms(2) unfolding G_def by simp
   also have "... \<le> emeasure M (\<Union>N. H N)"
     apply (rule emeasure_mono) using \<open>G \<subseteq> (\<Union>N. H N)\<close> by auto
   finally have "emeasure M (\<Union>N. H N) > b" by simp
   moreover have "(\<lambda>N. emeasure M (H N)) \<longlonglongrightarrow> emeasure M (\<Union>N. H N)"
     apply (rule Lim_emeasure_incseq) unfolding H_def incseq_def by auto
   ultimately have "eventually (\<lambda>N. emeasure M (H N) > b) sequentially"
     by (simp add: order_tendsto_iff)
   then obtain N where "emeasure M (H N) > b"
     using eventually_False_sequentially eventually_mono by blast
   then show ?thesis unfolding H_def by blast
 qed
 
 
 locale Gouezel_Karlsson_Kingman = pmpt +
   fixes u::"nat \<Rightarrow> 'a \<Rightarrow> real"
   assumes subu: "subcocycle u"
     and subu_fin: "subcocycle_avg_ereal u > -\<infinity>"
     and subu_0: "AE x in M. subcocycle_lim u x = 0"
 begin
 
 lemma int_u [measurable]:
   "integrable M (u n)"
 using subu unfolding subcocycle_def by auto
 
 text \<open>Next lemma is Lemma 2.1 in~\cite{gouezel_karlsson}.\<close>
 
 lemma upper_density_all_times:
   assumes "d > (0::real)"
   shows "\<exists>c> (0::real).
         emeasure M {x \<in> space M. upper_asymptotic_density {n. \<exists>l \<in> {1..n}. u n x - u (n-l) x \<le> - c * l} < d} > 1 - d"
 proof -
   define f where "f = (\<lambda>x. abs (u 1 x))"
   have [measurable]: "f \<in> borel_measurable M" unfolding f_def by auto
   define G where "G = {x \<in> space M. (\<lambda>n. birkhoff_sum f n x / n) \<longlonglongrightarrow> real_cond_exp M Invariants f x
                       \<and> (\<lambda>n. u n x / n) \<longlonglongrightarrow> 0}"
   have [measurable]: "G \<in> sets M" unfolding G_def by auto
   have "AE x in M. (\<lambda>n. birkhoff_sum f n x / n) \<longlonglongrightarrow> real_cond_exp M Invariants f x"
     apply (rule birkhoff_theorem_AE_nonergodic) using subu unfolding f_def subcocycle_def by auto
   moreover have "AE x in M. (\<lambda>n. u n x / n) \<longlonglongrightarrow> 0"
     using subu_0 kingman_theorem_nonergodic(1)[OF subu subu_fin] by auto
   ultimately have "AE x in M. x \<in> G" unfolding G_def by auto
   then have "emeasure M G = 1" by (simp add: emeasure_eq_1_AE)
 
   define V where "V = (\<lambda>c x. {n. \<exists>l \<in> {1..n}. u n x - u (n-l) x \<le> - c * l})"
   define Good where "Good = (\<lambda>c. {x \<in> G. upper_asymptotic_density (V c x) < d})"
   have [measurable]: "Good c \<in> sets M" for c unfolding Good_def V_def by auto
 
   have I: "upper_asymptotic_density (V c x) \<le> real_cond_exp M Invariants f x / c" if "c>0" "x \<in> G" for c x
   proof -
     have [simp]: "c>0" "c \<noteq> 0" "c \<ge> 0" using \<open>c>0\<close> by auto
     define U where "U = (\<lambda>n. abs(u 0 x) + birkhoff_sum f n x - c * card (V c x \<inter> {1..n}))"
     have main: "u n x \<le> U n" for n
     proof (rule nat_less_induct)
       fix n assume H: "\<forall>m<n. u m x \<le> U m"
       consider "n = 0" | "n\<ge>1 \<and> n \<notin> V c x" | "n\<ge>1 \<and> n \<in> V c x" by linarith
       then show "u n x \<le> U n"
       proof (cases)
         assume "n = 0"
         then show ?thesis unfolding U_def by auto
       next
         assume A: "n\<ge>1 \<and> n \<notin> V c x"
         then have "n \<ge> 1" by simp
         then have "n-1<n" by simp
         have "{1..n} = {1..n-1} \<union> {n}" using \<open>1 \<le> n\<close> atLeastLessThanSuc by auto
         then have *: "card (V c x \<inter> {1..n}) = card (V c x \<inter> {1..n-1})" using A by auto
         have "u n x \<le> u (n-1) x + u 1 ((T^^(n-1)) x)"
           using \<open>n\<ge>1\<close> subu unfolding subcocycle_def by (metis le_add_diff_inverse2)
         also have "... \<le> U (n-1) + f ((T^^(n-1)) x)" unfolding f_def using H \<open>n-1<n\<close> by auto
         also have "... = abs(u 0 x) + birkhoff_sum f (n-1) x + f ((T^^(n-1)) x) - c * card (V c x \<inter> {1..n-1})"
           unfolding U_def by auto
         also have "... = abs(u 0 x) + birkhoff_sum f n x - c * card (V c x \<inter> {1..n})"
           using * birkhoff_sum_cocycle[of f "n-1" 1 x] \<open>1 \<le> n\<close> by auto
         also have "... = U n" unfolding U_def by simp
         finally show ?thesis by auto
       next
         assume B: "n\<ge>1 \<and> n \<in> V c x"
         then obtain l where l: "l\<in>{1..n}" "u n x - u (n-l) x \<le> - c * l" unfolding V_def by blast
         then have "n-l < n" by simp
         have m: "- (r * ra) - r * rb = - (r * (rb + ra))" for r ra rb::real
           by (simp add: algebra_simps)
 
         have "card(V c x \<inter> {1..n}) \<le> card ((V c x \<inter> {1..n-l}) \<union> {n-l+1..n})"
           by (rule card_mono, auto)
         also have "... \<le> card (V c x \<inter> {1..n-l}) + card {n-l+1..n}"
           by (rule card_Un_le)
         also have "... \<le> card (V c x \<inter> {1..n-l}) + l" by auto
         finally have "card(V c x \<inter> {1..n}) \<le> card (V c x \<inter> {1..n-l}) + real l" by auto
         then have *: "-c * card (V c x \<inter> {1..n-l}) - c * l \<le> -c * card(V c x \<inter> {1..n})"
           using m by auto
 
         have "birkhoff_sum f ((n-l) + l) x = birkhoff_sum f (n-l) x + birkhoff_sum f l ((T^^(n-l))x)"
           by (rule birkhoff_sum_cocycle)
         moreover have "birkhoff_sum f l ((T^^(n-l))x) \<ge> 0"
           unfolding f_def birkhoff_sum_def using sum_nonneg by auto
         ultimately have **: "birkhoff_sum f (n-l) x \<le> birkhoff_sum f n x" using l(1) by auto
 
         have "u n x \<le> u (n-l) x - c * l" using l by simp
         also have "... \<le> U (n-l) - c* l" using H \<open>n-l < n\<close> by auto
         also have "... = abs(u 0 x) + birkhoff_sum f (n-l) x - c * card (V c x \<inter> {1..n-l}) - c*l"
           unfolding U_def by auto
         also have "... \<le> abs(u 0 x) + birkhoff_sum f n x - c * card (V c x \<inter> {1..n})"
           using * ** by simp
         finally show ?thesis unfolding U_def by auto
       qed
     qed
 
     have "(\<lambda>n. abs(u 0 x) * (1/n) + birkhoff_sum f n x / n - u n x / n) \<longlonglongrightarrow> abs(u 0 x) * 0 + real_cond_exp M Invariants f x - 0"
       apply (intro tendsto_intros) using \<open>x \<in> G\<close> unfolding G_def by auto
     moreover have "(abs(u 0 x) + birkhoff_sum f n x - u n x)/n = abs(u 0 x) * (1/n) + birkhoff_sum f n x / n - u n x / n" for n
       by (auto simp add: add_divide_distrib diff_divide_distrib)
     ultimately have "(\<lambda>n. (abs(u 0 x) + birkhoff_sum f n x - u n x)/n) \<longlonglongrightarrow> real_cond_exp M Invariants f x"
       by auto
     then have a: "limsup (\<lambda>n. (abs(u 0 x) + birkhoff_sum f n x - u n x)/n) = real_cond_exp M Invariants f x"
       by (simp add: assms lim_imp_Limsup)
 
     have "c * card (V c x \<inter> {1..n})/n \<le> (abs(u 0 x) + birkhoff_sum f n x - u n x)/n" for n
       using main[of n] unfolding U_def by (simp add: divide_right_mono)
     then have "limsup (\<lambda>n. c * card (V c x \<inter> {1..n})/n) \<le> limsup (\<lambda>n. (abs(u 0 x) + birkhoff_sum f n x - u n x)/n)"
       by (simp add: Limsup_mono)
     then have b: "limsup (\<lambda>n. c * card (V c x \<inter> {1..n})/n) \<le> real_cond_exp M Invariants f x"
       using a by simp
 
     have "ereal(upper_asymptotic_density (V c x)) = limsup (\<lambda>n. card (V c x \<inter> {1..n})/n)"
       using upper_asymptotic_density_shift[of "V c x" 1 0] by auto
     also have "... = limsup (\<lambda>n. ereal(1/c) * ereal(c * card (V c x \<inter> {1..n})/n))"
       by auto
     also have "... = (1/c) * limsup (\<lambda>n. c * card (V c x \<inter> {1..n})/n)"
       by (rule limsup_ereal_mult_left, auto)
     also have "... \<le> ereal (1/c) * real_cond_exp M Invariants f x"
       by (rule ereal_mult_left_mono[OF b], auto)
     finally show "upper_asymptotic_density (V c x) \<le> real_cond_exp M Invariants f x / c"
       by auto
   qed
 
   {
     fix r::real
     obtain c::nat where "r / d < c" using reals_Archimedean2 by auto
     then have "r/d < real c+1" by auto
     then have "r / (real c+1) < d" using \<open>d>0\<close> by (simp add: divide_less_eq mult.commute)
     then have "\<exists>c::nat. r / (real c+1) < d" by auto
   }
   then have unG: "(\<Union>c::nat. {x \<in> G. real_cond_exp M Invariants f x / (c+1) < d}) = G"
     by auto
 
   have *: "r < d * (real n + 1)" if "m \<le> n" "r < d * (real m + 1)" for m n r
   proof -
     have "d * (real m + 1) \<le> d * (real n + 1)" using \<open>d>0\<close> \<open>m \<le> n\<close> by auto
     then show ?thesis using \<open>r < d * (real m + 1)\<close> by auto
   qed
   have "(\<lambda>c. emeasure M {x \<in> G. real_cond_exp M Invariants f x / (real c+1) < d})
           \<longlonglongrightarrow> emeasure M (\<Union>c::nat. {x \<in> G. real_cond_exp M Invariants f x / (c+1) < d})"
     apply (rule Lim_emeasure_incseq) unfolding incseq_def by (auto simp add: divide_simps *)
   then have "(\<lambda>c. emeasure M {x \<in> G. real_cond_exp M Invariants f x / (real c+1) < d}) \<longlonglongrightarrow> emeasure M G"
     using unG by auto
   then have "(\<lambda>c. emeasure M {x \<in> G. real_cond_exp M Invariants f x / (real c+1) < d}) \<longlonglongrightarrow> 1"
     using \<open>emeasure M G = 1\<close> by simp
   then have "eventually (\<lambda>c. emeasure M {x \<in> G. real_cond_exp M Invariants f x / (real c+1) < d} > 1 - d) sequentially"
     apply (rule order_tendstoD)
     apply (insert \<open>0<d\<close>, auto simp add: ennreal_1[symmetric] ennreal_lessI simp del: ennreal_1)
     done
   then obtain c0 where c0: "emeasure M {x \<in> G. real_cond_exp M Invariants f x / (real c0+1) < d} > 1 - d"
     using eventually_sequentially by auto
   define c where "c = real c0 + 1"
   then have "c > 0" by auto
   have *: "emeasure M {x \<in> G. real_cond_exp M Invariants f x / c < d} > 1 - d"
     unfolding c_def using c0 by auto
   have "{x \<in> G. real_cond_exp M Invariants f x / c < d} \<subseteq> {x \<in> space M. upper_asymptotic_density (V c x) < d}"
     apply auto
     using G_def apply blast
     using I[OF \<open>c>0\<close>] by fastforce
   then have "emeasure M {x \<in> G. real_cond_exp M Invariants f x / c < d} \<le> emeasure M {x \<in> space M. upper_asymptotic_density (V c x) < d}"
     apply (rule emeasure_mono) unfolding V_def by auto
   then have "emeasure M {x \<in> space M. upper_asymptotic_density (V c x) < d} > 1 - d" using * by auto
   then show ?thesis unfolding V_def using \<open>c>0\<close> by auto
 qed
 
 text \<open>Next lemma is Lemma 2.2 in~\cite{gouezel_karlsson}.\<close>
 
 lemma upper_density_large_k:
   assumes "d > (0::real)" "d \<le> 1"
   shows "\<exists>k::nat.
         emeasure M {x \<in> space M. upper_asymptotic_density {n. \<exists>l \<in> {k..n}. u n x - u (n-l) x \<le> - d * l} < d} > 1 - d"
 proof -
   have [simp]: "d>0" "d \<noteq> 0" "d \<ge> 0" using \<open>d>0\<close> by auto
   define rho where "rho = d * d * d / 4"
   have [simp]: "rho > 0" "rho \<noteq> 0" "rho \<ge> 0" unfolding rho_def using assms by auto
 
   text \<open>First step: choose a time scale $s$ at which all the computations will be done. the
   integral of $u_s$ should be suitably small -- how small precisely is given by $\rho$.\<close>
   have "ennreal(\<integral>x. abs(u n x / n) \<partial>M) = (\<integral>\<^sup>+x. abs(u n x /n - subcocycle_lim u x) \<partial>M)" for n
   proof -
     have "ennreal(\<integral>x. abs(u n x / n) \<partial>M) = (\<integral>\<^sup>+x. abs(u n x /n) \<partial>M)"
       apply (rule nn_integral_eq_integral[symmetric]) using int_u by auto
     also have "... = (\<integral>\<^sup>+x. abs(u n x /n - subcocycle_lim u x) \<partial>M)"
       apply (rule nn_integral_cong_AE) using subu_0 by auto
     finally show ?thesis by simp
   qed
   moreover have "(\<lambda>n. \<integral>\<^sup>+x. abs(u n x /n - subcocycle_lim u x) \<partial>M) \<longlonglongrightarrow> 0"
     by (rule kingman_theorem_nonergodic(3)[OF subu subu_fin])
   ultimately have "(\<lambda>n. ennreal(\<integral>x. abs(u n x / n) \<partial>M)) \<longlonglongrightarrow> 0"
     by auto
   then have "(\<lambda>n. (\<integral>x. abs(u n x / n) \<partial>M)) \<longlonglongrightarrow> 0"
     by (simp add: ennreal_0[symmetric] del: ennreal_0)
   then have "eventually (\<lambda>n. (\<integral>x. abs(u n x / n) \<partial>M) < rho) sequentially"
     by (rule order_tendstoD(2), auto)
   then obtain s::nat where [simp]: "s>0" and s_int: "(\<integral>x. abs(u s x / s) \<partial>M) < rho"
     by (metis (mono_tags, lifting) neq0_conv eventually_sequentially gr_implies_not0
         linorder_not_le of_nat_0_eq_iff order_refl zero_neq_one)
 
   text \<open>Second step: a truncation argument, to decompose $|u_1|$ as a sum of a constant (its
   contribution will be small if $k$ is large at the end of the argument) and of a function with
   small integral).\<close>
 
   have "(\<lambda>n. (\<integral>x. abs(u 1 x) * indicator {x \<in> space M. abs(u 1 x) \<ge> n} x \<partial>M)) \<longlonglongrightarrow> (\<integral>x. 0 \<partial>M)"
   proof (rule integral_dominated_convergence[where ?w = "\<lambda>x. abs(u 1 x)"])
     show "AE x in M. norm (abs(u 1 x) * indicator {x \<in> space M. abs(u 1 x) \<ge> n} x) \<le> abs(u 1 x)" for n
       unfolding indicator_def by auto
     {
       fix x
       have "abs(u 1 x) * indicator {x \<in> space M. abs(u 1 x) \<ge> n} x = (0::real)" if "n > abs(u 1 x)" for n::nat
         unfolding indicator_def using that by auto
       then have "eventually (\<lambda>n. abs(u 1 x) * indicator {x \<in> space M. abs(u 1 x) \<ge> n} x = 0) sequentially"
         by (metis (mono_tags, lifting) eventually_at_top_linorder reals_Archimedean2 less_le_trans of_nat_le_iff)
       then have "(\<lambda>n. abs(u 1 x) * indicator {x \<in> space M. abs(u 1 x) \<ge> n} x) \<longlonglongrightarrow> 0"
         by (rule Lim_eventually)
     }
     then show "AE x in M. (\<lambda>n. abs(u 1 x) * indicator {x \<in> space M. abs(u 1 x) \<ge> n} x) \<longlonglongrightarrow> 0"
       by simp
   qed (auto simp add: int_u)
   then have "eventually (\<lambda>n. (\<integral>x. abs(u 1 x) * indicator {x \<in> space M. abs(u 1 x) \<ge> n} x \<partial>M) < rho) sequentially"
     by (rule order_tendstoD(2), auto)
   then obtain Knat::nat where Knat: "Knat > 0" "(\<integral>x. abs(u 1 x) * indicator {x \<in> space M. abs(u 1 x) \<ge> Knat} x \<partial>M) < rho"
     by (metis (mono_tags, lifting) eventually_sequentially gr_implies_not0 neq0_conv
         linorder_not_le of_nat_0_eq_iff order_refl zero_neq_one)
   define K where "K = real Knat"
   then have [simp]: "K \<ge> 0" "K>0" and K: "(\<integral>x. abs(u 1 x) * indicator {x \<in> space M. abs(u 1 x) \<ge> K} x \<partial>M) < rho"
     using Knat by auto
 
   define F where "F = (\<lambda>x. abs(u 1 x) * indicator {x. abs(u 1 x) \<ge> K} x)"
   have int_F [measurable]: "integrable M F"
     unfolding F_def apply (rule Bochner_Integration.integrable_bound[where ?f = "\<lambda>x. abs(u 1 x)"])
     unfolding indicator_def by (auto simp add: int_u)
   have "(\<integral>x. F x \<partial>M) = (\<integral>x. abs(u 1 x) * indicator {x \<in> space M. abs(u 1 x) \<ge> K} x \<partial>M)"
     apply (rule integral_cong_AE) unfolding F_def by (auto simp add: indicator_def)
   then have F_int: "(\<integral>x. F x \<partial>M) < rho" using K by auto
   have F_pos: "F x \<ge> 0" for x unfolding F_def by auto
   have u1_bound: "abs(u 1 x) \<le> K + F x" for x
     unfolding F_def indicator_def apply (cases "x \<in> {x \<in> space M. K \<le> \<bar>u 1 x\<bar>}") by auto
 
   define F2 where "F2 = (\<lambda>x. F x + abs(u s x/s))"
   have int_F2 [measurable]: "integrable M F2"
     unfolding F2_def using int_F int_u[of s] by auto
   have F2_pos: "F2 x \<ge> 0" for x unfolding F2_def using F_pos by auto
   have "(\<integral>x. F2 x \<partial>M) = (\<integral>x. F x \<partial>M) + (\<integral>x. abs(u s x/s) \<partial>M)"
     unfolding F2_def apply (rule Bochner_Integration.integral_add) using int_F int_u by auto
   then have F2_int: "(\<integral>x. F2 x \<partial>M) < 2 * rho"
     using F_int s_int by auto
 
   text \<open>We can now choose $k$, large enough. The reason for our choice will only appear
   at the end of the proof.\<close>
   define k where "k = max (2 * s + 1) (nat(ceiling((2 * d * s + 2 * K * s)/(d/2))))"
   have "k > 2 * s" unfolding k_def by auto
   have "k \<ge> (2 * d * s + 2 * K * s)/(d/2)"
     unfolding k_def by linarith
   then have "(2 * d * s + 2 * K * s)/k \<le> d/2"
     using \<open>k > 2 * s\<close> by (simp add: divide_simps mult.commute)
 
 
   text \<open>Third step: definition of a good set $G$ where everything goes well.\<close>
 
   define G where "G = {x \<in> space M. (\<lambda>n. u n x / n) \<longlonglongrightarrow> 0
                       \<and> (\<lambda>n. birkhoff_sum (\<lambda>x. abs(u s x / s)) n x / n) \<longlonglongrightarrow> real_cond_exp M Invariants (\<lambda>x. abs(u s x / s)) x
                       \<and> (\<lambda>n. birkhoff_sum F n x / n) \<longlonglongrightarrow> real_cond_exp M Invariants F x
                       \<and> real_cond_exp M Invariants F x + real_cond_exp M Invariants (\<lambda>x. abs(u s x / s)) x = real_cond_exp M Invariants F2 x}"
   have [measurable]: "G \<in> sets M" unfolding G_def by auto
   have "AE x in M. (\<lambda>n. u n x / n) \<longlonglongrightarrow> 0"
     using kingman_theorem_nonergodic(1)[OF subu subu_fin] subu_0 by auto
   moreover have "AE x in M.(\<lambda>n. birkhoff_sum (\<lambda>x. abs(u s x / s)) n x / n) \<longlonglongrightarrow> real_cond_exp M Invariants (\<lambda>x. abs(u s x / s)) x"
     apply (rule birkhoff_theorem_AE_nonergodic) using int_u[of s] by auto
   moreover have "AE x in M. (\<lambda>n. birkhoff_sum F n x / n) \<longlonglongrightarrow> real_cond_exp M Invariants F x"
     by (rule birkhoff_theorem_AE_nonergodic[OF int_F])
   moreover have "AE x in M. real_cond_exp M Invariants F x + real_cond_exp M Invariants (\<lambda>x. abs(u s x / s)) x = real_cond_exp M Invariants F2 x"
     unfolding F2_def apply (rule AE_symmetric[OF real_cond_exp_add]) using int_u[of s] int_F int_u[of s] by auto
   ultimately have "AE x in M. x \<in> G" unfolding G_def by auto
   then have "emeasure M G = 1" by (simp add: emeasure_eq_1_AE)
 
   text \<open>Estimation of asymptotic densities of bad times, for points in $G$.
   There is a trivial part, named $U$ below, that has to be treated separately because it creates
   problematic boundary effects.\<close>
 
   define U where "U = (\<lambda>x. {n. \<exists>l \<in> {n-s<..n}. u n x - u (n-l) x \<le> - d * l})"
   define V where "V = (\<lambda>x. {n. \<exists>l \<in> {k..n-s}. u n x - u (n-l) x \<le> - d * l})"
 
   text \<open>Trivial estimate for $U(x)$: this set is finite for $x\in G$.\<close>
 
   have densU: "upper_asymptotic_density (U x) = 0" if "x \<in> G" for x
   proof -
     define C where "C = Max {abs(u m x) |m. m<s} + d * s"
     have *: "U x \<subseteq> {n. u n x \<le> C - d * n}"
     proof (auto)
       fix n assume "n \<in> U x"
       then obtain l where l: "l\<in> {n-s <..n}" "u n x - u (n-l) x \<le> - d * l" unfolding U_def by auto
       define m where "m = n-l"
       have "m < s" unfolding m_def using l by auto
       have "u n x \<le> u m x - d * l" using l m_def by auto
       also have "... \<le> abs(u m x) - d * n + d * m" unfolding m_def using l
-        by (simp add: linordered_field_class.sign_simps(38) of_nat_diff)
+        by (simp add: algebra_simps of_nat_diff)
       also have "... \<le> Max {abs(u m x) |m. m<s} - d * n + d * m"
         using \<open>m < s\<close> apply (auto) by (rule Max_ge, auto)
       also have "... \<le> Max {abs(u m x) |m. m<s} + d * s - d * n"
         using \<open>m < s\<close> \<open>d>0\<close> by auto
       finally show "u n x \<le> C - d * n"
         unfolding C_def by auto
     qed
     have "eventually (\<lambda>n. u n x / n > -d/2) sequentially"
       apply (rule order_tendstoD(1)) using \<open>x \<in> G\<close> \<open>d>0\<close> unfolding G_def by auto
     then obtain N where N: "\<And>n. n \<ge> N \<Longrightarrow> u n x / n > - d/2"
       using eventually_sequentially by auto
     {
       fix n assume *: "u n x \<le> C - d * n" "n > N"
       then have "n \<ge> N" "n > 0" by auto
       have "2 * u n x \<le> 2 * C - 2 * d * n" using * by auto
       moreover have "2 * u n x \<ge> - d * n" using N[OF \<open>n \<ge> N\<close>] \<open>n > 0\<close> by (simp add: divide_simps)
       ultimately have "- d * n \<le> 2 * C - 2 * d * n" by auto
       then have "d * n \<le> 2 * C" by auto
       then have "n \<le> 2 * C / d" using \<open>d>0\<close> by (simp add: mult.commute divide_simps)
     }
     then have "{n. u n x \<le> C - d * n} \<subseteq> {..max (nat (floor(2*C/d))) N}"
       by (auto, meson le_max_iff_disj le_nat_floor not_le)
     then have "finite {n. u n x \<le> C - d * n}"
       using finite_subset by blast
     then have "finite (U x)" using * finite_subset by blast
     then show ?thesis using upper_asymptotic_density_finite by auto
   qed
 
   text \<open>Main step: control of $u$ along the sequence $ns+t$, with a term
   $-(d/2) Card(V(x) \cap [1,ns+t])$ on the right.
   Then, after averaging in $t$, Birkhoff theorem will imply that
   $Card(V(x) \cap [1,n])$ is suitably small.\<close>
 
   define Z where "Z = (\<lambda>t n x. Max {u i x|i. i< s} + (\<Sum>i<n. abs(u s ((T^^(i * s + t))x)))
                   + birkhoff_sum F (n * s + t) x - (d/2) * card(V x \<inter> {1..n * s + t}))"
   have Main: "u (n * s + t) x \<le> Z t n x" if "t < s" for n x t
   proof (rule nat_less_induct[where ?n = n])
     fix n assume H: "\<forall>m<n. u (m * s + t) x \<le> Z t m x"
     consider "n = 0"|"n>0 \<and> V x \<inter> {(n-1) * s+t<..n * s+t} = {}"|"n>0 \<and> V x \<inter> {(n-1) * s+t<..n * s+t} \<noteq> {}" by auto
     then show "u (n * s+t) x \<le> Z t n x"
     proof (cases)
       assume "n = 0"
       then have "V x \<inter> {1..n * s + t} = {}" unfolding V_def using \<open>t<s\<close> \<open>k>2* s\<close> by auto
       then have *: "card(V x \<inter> {1..n * s+t}) = 0" by simp
       have **: "0 \<le> (\<Sum>i<t. F ((T ^^ i) x))" by (rule sum_nonneg, simp add: F_pos)
       have "u (n * s + t) x = u t x" using \<open>n = 0\<close> by auto
       also have "... \<le> Max {u i x|i. i< s}" by (rule Max_ge, auto simp add: \<open>t<s\<close>)
       also have "... \<le> Z t n x"
         unfolding Z_def birkhoff_sum_def using \<open>n = 0\<close> * ** by auto
       finally show ?thesis by simp
     next
       assume A: "n>0 \<and> V x \<inter> {(n-1) * s+t<..n * s+t} = {}"
       then have "n\<ge>1" by simp
       have "n * s + t = (n-1) * s + t + s" using \<open>n\<ge>1\<close> by (simp add: add.commute add.left_commute mult_eq_if)
       have "V x \<inter> {1..n * s + t} = V x \<inter> {1..(n-1) * s + t} \<union> V x \<inter> {(n-1) * s + t<..n * s + t}"
         using \<open>n\<ge>1\<close> by (auto, simp add: mult_eq_if)
       then have *: "card(V x \<inter> {1..n * s+t}) = card(V x \<inter> {1..(n-1) * s+t})" using A by auto
 
       have **: "birkhoff_sum F ((n-1) * s + t) x \<le> birkhoff_sum F (n * s + t) x"
         unfolding birkhoff_sum_def apply (rule sum_mono2)
         using \<open>n * s+t = (n-1) * s+t + s\<close> F_pos by auto
 
       have "(\<Sum>i<n-1. abs(u s ((T^^(i * s+t))x))) + u s ((T^^((n-1) * s+t)) x)
         \<le> (\<Sum>i<n-1. abs(u s ((T^^(i * s+t))x))) + abs(u s ((T^^((n-1) * s+t)) x))" by auto
       also have "... \<le> (\<Sum>i<n. abs(u s ((T^^(i* s+t))x)))"
         using \<open>n\<ge>1\<close> lessThan_Suc_atMost sum.lessThan_Suc[of "\<lambda>i. abs(u s ((T^^(i* s+t))x))" "n-1", symmetric] by auto
       finally have ***: "(\<Sum>i<n-1. abs(u s ((T^^(i* s+t))x))) + u s ((T^^((n-1) * s+t)) x) \<le> (\<Sum>i<n. abs(u s ((T^^(i* s+t))x)))"
         by simp
 
       have "u (n * s+t) x = u ((n-1) * s+t + s) x"
         using \<open>n\<ge>1\<close> by (simp add: add.commute add.left_commute mult_eq_if)
       also have "... \<le> u ((n-1) * s+t) x + u s ((T^^((n-1) * s+t)) x)"
         using subcocycle_ineq[OF subu, of "(n-1) * s+t" s x] by simp
       also have "... \<le> Max {u i x|i. i< s} + (\<Sum>i<n-1. abs(u s ((T^^(i* s+t))x)))
         + birkhoff_sum F ((n-1) * s+t) x - (d/2) * card(V x \<inter> {1..(n-1) * s+t}) + u s ((T^^((n-1) * s+t)) x)"
         using H \<open>n\<ge>1\<close> unfolding Z_def by auto
       also have "... \<le> Max {u i x|i. i< s} + (\<Sum>i<n. abs(u s ((T^^(i* s+t))x)))
         + birkhoff_sum F (n * s+t) x - (d/2) * card(V x \<inter> {1..n * s+t})"
         using * ** *** by auto
       also have "... \<le> Z t n x" unfolding Z_def by (auto simp add: divide_simps)
       finally show ?thesis by simp
     next
       assume B: "n>0 \<and> V x \<inter> {(n-1) * s+t<..n * s+t} \<noteq> {}"
       then have [simp]: "n>0" "n\<ge>1" "n \<noteq> 0" by auto
       obtain m where m: "m \<in> V x \<inter> {(n-1) * s + t<..n * s + t}" using B by blast
       then obtain l where l: "l \<in> {k..m-s}" "u m x - u (m-l) x \<le> - d * l" unfolding V_def by auto
       then have "m-s>0" using \<open>k>2* s\<close> by auto
       then have "m-l \<ge> s" using l by auto
       define p where "p = (m-l-t) div s"
       have p1: "m-l \<ge> p * s + t"
         unfolding p_def using \<open>m-l \<ge> s\<close> \<open>s>t\<close> minus_mod_eq_div_mult [symmetric, of "m - l - t" s]
         by simp
       have p2: "m-l < p* s + t + s"
         unfolding p_def using \<open>m-l \<ge> s\<close> \<open>s>t\<close>
         div_mult_mod_eq[of "m-l-t" s] mod_less_divisor[OF \<open>s>0\<close>, of "m-l-t"] by linarith
       then have "l \<ge> m - p * s - t -s" by auto
       then have "l \<ge> (n-1) * s + t -p * s - t- s" using m by auto
       then have "l + 2 * s\<ge> (n * s + t) - (p * s+t)" by (simp add: diff_mult_distrib)
       have "(p+1) * s + t \<le> (n-1) * s + t"
         using \<open>k> 2 * s\<close> m l(1) p1 by (auto simp add: algebra_simps)
       then have "p+1 \<le> n-1"
         using \<open>s>0\<close> by (meson add_le_cancel_right mult_le_cancel2)
       then have "p \<le> n-1" "p<n" by auto
       have "(p* s + t) + k \<le> (n * s + t)"
         using m l(1) p1 by (auto simp add: algebra_simps)
       then have "(1::real) \<le> ((n * s + t) - (p* s + t)) / k"
         using \<open>k > 2* s\<close> by auto
 
       have In: "u (n * s + t) x \<le> u m x + (\<Sum>i \<in> {(n-1) * s + t..<n * s + t}. abs(u 1 ((T^^i) x)))"
       proof (cases "m = n * s + t")
         case True
         have "(\<Sum>i \<in> {(n-1) * s+t..<n * s+t}. abs(u 1 ((T^^i) x))) \<ge> 0"
           by (rule sum_nonneg, auto)
         then show ?thesis using True by auto
       next
         case False
         then have m2: "n * s + t - m >0" "(n-1) * s+t \<le> m" using m by auto
         have "birkhoff_sum (u 1) (n * s+t-m) ((T^^m) x) = (\<Sum>i<n * s+t-m. u 1 ((T^^i)((T^^m) x)))"
           unfolding birkhoff_sum_def by auto
         also have "... = (\<Sum>i<n * s+t-m. u 1 ((T^^(i+m)) x))"
           by (simp add: funpow_add)
         also have "... = (\<Sum>j \<in> {m..<n * s+t}. u 1 ((T^^j) x))"
           by (rule sum.reindex_bij_betw, rule bij_betw_byWitness[where ?f' = "\<lambda>i. i - m"], auto)
         also have "... \<le> (\<Sum>j \<in> {m..<n * s+t}. abs(u 1 ((T^^j) x)))"
           by (rule sum_mono, auto)
         also have "... \<le> (\<Sum>j \<in> {(n-1) * s+t..<m}. abs(u 1 ((T^^j) x))) + (\<Sum>j \<in> {m..<n * s+t}. abs(u 1 ((T^^j) x)))"
           by auto
         also have "... = (\<Sum>j \<in> {(n-1) * s+t..<n * s+t}. abs(u 1 ((T^^j) x)))"
           apply (rule sum.atLeastLessThan_concat) using m2 by auto
         finally have *: "birkhoff_sum (u 1) (n * s+t-m) ((T^^m) x) \<le> (\<Sum>j \<in> {(n-1) * s+t..<n * s+t}. abs(u 1 ((T^^j) x)))"
           by auto
 
         have "u (n * s+t) x \<le> u m x + u (n * s+t-m) ((T^^m) x)"
           using subcocycle_ineq[OF subu, of m "n * s+t-m"] m2 by auto
         also have "... \<le> u m x + birkhoff_sum (u 1) (n * s+t-m) ((T^^m) x)"
           using subcocycle_bounded_by_birkhoff1[OF subu \<open>n * s+t - m >0\<close>, of "(T^^m)x"] by simp
         finally show ?thesis using * by auto
       qed
 
       have Ip: "u (m-l) x \<le> u (p* s+t) x + (\<Sum>i \<in> {p* s+t..<(p+1)* s+t}. abs(u 1 ((T^^i) x)))"
       proof (cases "m-l = p* s+t")
         case True
         have "(\<Sum>i \<in> {p* s+t..<(p+1)* s+t}. abs(u 1 ((T^^i) x))) \<ge> 0"
           by (rule sum_nonneg, auto)
         then show ?thesis using True by auto
       next
         case False
         then have "m-l - (p* s+t) > 0" using p1 by auto
         have I: "p * s + t + (m - l - (p * s + t)) = m - l" using p1 by auto
 
         have "birkhoff_sum (u 1) (m-l - (p* s+t)) ((T^^(p* s+t)) x) = (\<Sum>i<m-l - (p* s+t). u 1 ((T^^i) ((T^^(p* s+t)) x)))"
           unfolding birkhoff_sum_def by auto
         also have "... = (\<Sum>i<m-l - (p* s+t). u 1 ((T^^(i+p* s+t)) x))"
           by (simp add: funpow_add)
         also have "... = (\<Sum>j \<in> {p* s+t..<m-l}. u 1 ((T^^j) x))"
           by (rule sum.reindex_bij_betw, rule bij_betw_byWitness[where ?f' = "\<lambda>i. i - (p* s+t)"], auto)
         also have "... \<le> (\<Sum>j \<in> {p* s+t..<m-l}. abs(u 1 ((T^^j) x)))"
           by (rule sum_mono, auto)
         also have "... \<le> (\<Sum>j \<in> {p* s+t..<m-l}. abs(u 1 ((T^^j) x))) + (\<Sum>j \<in> {m-l..<(p+1)* s+t}. abs(u 1 ((T^^j) x)))"
           by auto
         also have "... = (\<Sum>j \<in> {p* s+t..<(p+1)* s+t}. abs(u 1 ((T^^j) x)))"
           apply (rule sum.atLeastLessThan_concat) using p1 p2 by auto
         finally have *: "birkhoff_sum (u 1) (m-l - (p* s+t)) ((T^^(p* s+t)) x)
           \<le> (\<Sum>j \<in> {p* s+t..<(p+1)* s+t}. abs(u 1 ((T^^j) x)))"
           by auto
 
         have "u (m-l) x \<le> u (p* s+t) x + u (m-l - (p* s+t)) ((T^^(p* s+t)) x)"
           using subcocycle_ineq[OF subu, of "p* s+t" "m-l - (p* s+t)" x] I by auto
         also have "... \<le> u (p* s+t) x + birkhoff_sum (u 1) (m-l - (p* s+t)) ((T^^(p* s+t)) x)"
           using subcocycle_bounded_by_birkhoff1[OF subu \<open>m-l - (p* s+t) > 0\<close>, of "(T^^(p* s+t)) x"] by simp
         finally show ?thesis using * by auto
       qed
 
       have "(\<Sum>i \<in> {p* s+t..<(p+1)* s+t}. abs(u 1 ((T^^i) x))) \<le> (\<Sum>i \<in> {p* s+t..<(p+1)* s+t}. K + F ((T^^i) x))"
         apply (rule sum_mono) using u1_bound by auto
       moreover have "(\<Sum>i \<in> {(n-1) * s+t..<n * s+t}. abs(u 1 ((T^^i) x))) \<le> (\<Sum>i \<in> {(n-1) * s+t..<n * s+t}. K + F ((T^^i) x))"
         apply (rule sum_mono) using u1_bound by auto
       ultimately have "(\<Sum>i \<in> {p* s+t..<(p+1)* s+t}. abs(u 1 ((T^^i) x))) + (\<Sum>i \<in> {(n-1) * s+t..<n * s+t}. abs(u 1 ((T^^i) x)))
         \<le> (\<Sum>i \<in> {p* s+t..<(p+1)* s+t}. K + F ((T^^i) x)) + (\<Sum>i \<in> {(n-1) * s+t..<n * s+t}. K + F ((T^^i) x))"
         by auto
       also have "... = 2* K* s + (\<Sum>i \<in> {p* s+t..<(p+1)* s+t}. F ((T^^i) x)) + (\<Sum>i \<in>{(n-1) * s+t..<n * s+t}. F ((T^^i) x))"
         by (auto simp add: mult_eq_if sum.distrib)
       also have "... \<le> 2* K * s + (\<Sum>i \<in> {p* s+t..<(n-1) * s+t}. F ((T^^i) x)) + (\<Sum>i \<in>{(n-1) * s+t..<n * s+t}. F ((T^^i) x))"
         apply (auto, rule sum_mono2) using \<open>(p+1)* s+t\<le>(n-1) * s+t\<close> F_pos by auto
       also have "... = 2* K * s + (\<Sum>i \<in> {p* s+t..<n * s+t}. F ((T^^i) x))"
         apply (auto, rule sum.atLeastLessThan_concat) using \<open>p\<le>n-1\<close> by auto
       finally have A0: "(\<Sum>i \<in> {p* s+t..<(p+1)* s+t}. abs(u 1 ((T^^i) x))) + (\<Sum>i \<in> {(n-1) * s+t..<n * s+t}. abs(u 1 ((T^^i) x)))
         \<le> 2* K * s + (\<Sum>i \<in> {p* s+t..<n * s+t}. F ((T^^i) x))"
         by simp
 
       have "card(V x \<inter> {p * s + t<.. n * s+t}) \<le> card {p * s + t<.. n * s+t}" by (rule card_mono, auto)
       have "2 * d * s + 2 * K * s > 0" using \<open>K>0\<close> \<open>s>0\<close> \<open>d>0\<close>
         by (metis add_pos_pos mult_2 mult_zero_left of_nat_0_less_iff pos_divide_less_eq times_divide_eq_right)
       then have "2 * d * s + 2 * K * s \<le> ((n * s + t) - (p* s + t)) * ((2 * d * s + 2 * K * s) / k)"
         using \<open>1 \<le> ((n * s + t) - (p* s + t)) / k\<close> by (simp add: le_divide_eq_1 pos_le_divide_eq)
       also have "... \<le> ((n * s + t) - (p* s + t)) * (d/2)"
         apply (rule mult_left_mono) using \<open>(2 * d * s + 2 * K * s)/k \<le> d/2\<close> by auto
       finally have "2 * d * s + 2 * K * s \<le> ((n * s + t) - (p* s + t)) * (d/2)"
         by auto
       then have "-d * ((n * s+t) - (p* s+t)) + 2 * d * s + 2 * K * s \<le> -d * ((n * s+t) - (p* s+t)) + ((n * s + t) - (p* s + t)) * (d/2)"
         by linarith
       also have "... = (-d/2) * card {p * s + t<.. n * s+t}"
         by auto
       also have "... \<le> (-d/2) * card(V x \<inter> {p * s + t<.. n * s+t})"
         using \<open>card(V x \<inter> {p * s + t<.. n * s+t}) \<le> card {p * s + t<.. n * s+t}\<close> by auto
       finally have A1: "-d * ((n * s+t) - (p* s+t)) + 2 * d * s + 2 * K * s \<le> (-d/2) * card(V x \<inter> {p * s + t<.. n * s+t})"
         by simp
 
       have "V x \<inter> {1.. n * s+t} = V x \<inter> {1..p * s + t} \<union> V x \<inter> {p * s + t<.. n * s+t}"
         using \<open>p * s + t + k \<le> n * s + t\<close> by auto
       then have "card (V x \<inter> {1.. n * s+t}) = card(V x \<inter> {1..p * s + t} \<union> V x \<inter> {p * s + t<.. n * s+t})"
         by auto
       also have "... = card (V x \<inter> {1..p * s + t}) + card (V x \<inter> {p * s + t<.. n * s+t})"
         by (rule card_Un_disjoint, auto)
       finally have A2: "card (V x \<inter> {1..p * s + t}) + card (V x \<inter> {p * s + t<.. n * s+t}) = card (V x \<inter> {1.. n * s+t})"
         by simp
 
       have A3: "(\<Sum>i<p. abs(u s ((T ^^ (i * s + t)) x))) \<le> (\<Sum>i<n. abs(u s ((T ^^ (i * s + t)) x)))"
         apply (rule sum_mono2) using \<open>p\<le>n-1\<close> by auto
 
       have A4: "birkhoff_sum F (p * s + t) x + (\<Sum>i \<in> {p* s+t..<n * s+t}. F ((T^^i) x)) = birkhoff_sum F (n * s + t) x"
         unfolding birkhoff_sum_def apply (subst atLeast0LessThan[symmetric])+ apply (rule sum.atLeastLessThan_concat)
         using \<open>p\<le>n-1\<close> by auto
 
       have "u (n * s+t) x \<le> u m x + (\<Sum>i \<in> {(n-1) * s+t..<n * s+t}. abs(u 1 ((T^^i) x)))"
         using In by simp
       also have "... \<le> (u m x - u (m-l) x) + u (m-l) x + (\<Sum>i \<in> {(n-1) * s+t..<n * s+t}. abs(u 1 ((T^^i) x)))"
         by simp
       also have "... \<le> - d * l + u (p* s+t) x + (\<Sum>i \<in> {p* s+t..<(p+1)* s+t}. abs(u 1 ((T^^i) x))) + (\<Sum>i \<in> {(n-1) * s+t..<n * s+t}. abs(u 1 ((T^^i) x)))"
         using Ip l by auto
       also have "... \<le> - d * ((n * s+t) - (p* s+t)) + 2*d* s + u (p* s+t) x + (\<Sum>i \<in> {p* s+t..<(p+1)* s+t}. abs(u 1 ((T^^i) x))) + (\<Sum>i \<in> {(n-1) * s+t..<n * s+t}. abs(u 1 ((T^^i) x)))"
         using \<open>l + 2* s\<ge> (n * s+t) - (p* s+t)\<close> apply (auto simp add: algebra_simps)
         by (metis assms(1) distrib_left mult.commute mult_2 of_nat_add of_nat_le_iff real_mult_le_cancel_iff2)
       also have "... \<le> -d * ((n * s+t) - (p* s+t)) + 2*d* s + Z t p x + 2* K * s + (\<Sum>i \<in> {p* s+t..<n * s+t}. F ((T^^i) x))"
         using A0 H \<open>p<n\<close> by auto
       also have "... \<le> Z t p x - d/2 * card(V x \<inter> {p * s + t<.. n * s+t}) + (\<Sum>i \<in> {p* s+t..<n * s+t}. F ((T^^i) x))"
         using A1 by auto
       also have "... = Max {u i x |i. i < s} + (\<Sum>i<p. abs(u s ((T ^^ (i * s + t)) x))) + birkhoff_sum F (p * s + t) x
           - d / 2 * card (V x \<inter> {1..p * s + t}) - d/2 * card(V x \<inter> {p * s + t<.. n * s+t}) + (\<Sum>i \<in> {p* s+t..<n * s+t}. F ((T^^i) x))"
         unfolding Z_def by auto
       also have "... \<le> Max {u i x |i. i < s} + (\<Sum>i<n. abs(u s ((T ^^ (i * s + t)) x)))
         + (birkhoff_sum F (p * s + t) x + (\<Sum>i \<in> {p* s+t..<n * s+t}. F ((T^^i) x)))
         - d/2 * card (V x \<inter> {1..p * s + t}) - d/2 * card(V x \<inter> {p * s + t<.. n * s+t})"
         using A3 by auto
       also have "... = Z t n x"
         unfolding Z_def using A2 A4 by (auto simp add: algebra_simps, metis distrib_left of_nat_add)
       finally show ?thesis by simp
     qed
   qed
 
   have Main2: "(d/2) * card(V x \<inter> {1..n}) \<le> Max {u i x|i. i< s} + birkhoff_sum (\<lambda>x. abs(u s x/ s)) (n+2* s) x
     + birkhoff_sum F (n + 2 * s) x + (1/s) * (\<Sum>i< 2 * s. abs(u (n+i) x))" for n x
   proof -
     define N where "N = (n div s) + 1"
     then have "n \<le> N * s"
       using \<open>s > 0\<close> dividend_less_div_times less_or_eq_imp_le by auto
     have "N * s \<le> n + s"
       by (auto simp add: N_def)
     have eq_t: "(d/2) * card(V x \<inter> {1..n}) \<le> abs(u(N* s+t) x) + (Max {u i x|i. i< s} + birkhoff_sum F (n + 2* s) x)
             + (\<Sum>i<N. abs(u s ((T^^(i * s+t))x)))"
       if "t<s" for t
     proof -
       have *: "birkhoff_sum F (N * s+t) x \<le> birkhoff_sum F (n+ 2* s) x"
         unfolding birkhoff_sum_def apply (rule sum_mono2) using F_pos \<open>N * s \<le> n + s\<close> \<open>t<s\<close> by auto
 
       have "card(V x \<inter> {1..n}) \<le> card(V x \<inter> {1..N* s+t})"
         apply (rule card_mono) using \<open>n \<le> N * s\<close> by auto
       then have "(d/2) * card(V x \<inter> {1..n}) \<le> (d/2) * card(V x \<inter> {1..N* s+t})"
         by auto
       also have "... \<le> - u (N* s+t) x + Max {u i x|i. i< s} + (\<Sum>i<N. abs(u s ((T^^(i* s+t))x))) + birkhoff_sum F (N * s+t) x"
         using Main[OF \<open>t < s\<close>, of N x] unfolding Z_def by auto
       also have "... \<le> abs(u(N* s+t) x) + Max {u i x|i. i< s} + birkhoff_sum F (n + 2* s) x + (\<Sum>i<N. abs(u s ((T^^(i* s+t))x)))"
         using * by auto
       finally show ?thesis by simp
     qed
 
     have "(\<Sum>t<s. abs(u(N* s+t) x)) = (\<Sum>i\<in>{N* s..<N* s+s}. abs (u i x))"
       by (rule sum.reindex_bij_betw, rule bij_betw_byWitness[where ?f' = "\<lambda>i. i - N* s"], auto)
     also have "... \<le> (\<Sum>i\<in>{n..<n + 2* s}. abs (u i x))"
       apply (rule sum_mono2) using \<open>n \<le> N * s\<close> \<open>N * s \<le> n + s\<close> by auto
     also have "... = (\<Sum>i<2* s. abs (u (n+i) x))"
       by (rule sum.reindex_bij_betw[symmetric], rule bij_betw_byWitness[where ?f' = "\<lambda>i. i - n"], auto)
     finally have **: "(\<Sum>t<s. abs(u(N* s+t) x)) \<le> (\<Sum>i<2* s. abs (u (n+i) x))"
       by simp
 
     have "(\<Sum>t<s. (\<Sum>i<N. abs(u s ((T^^(i* s+t))x)))) = (\<Sum>i<N* s. abs(u s ((T^^i) x)))"
       by (rule sum_arith_progression)
     also have "... \<le> (\<Sum>i<n + 2* s. abs(u s ((T^^i) x)))"
       apply (rule sum_mono2) using \<open>N * s \<le> n + s\<close> by auto
     finally have ***: "(\<Sum>t<s. (\<Sum>i<N. abs(u s ((T^^(i* s+t))x)))) \<le> s * birkhoff_sum (\<lambda>x. abs(u s x/ s)) (n+2* s) x"
       unfolding birkhoff_sum_def using \<open>s>0\<close> by (auto simp add: sum_divide_distrib[symmetric])
 
     have ****: "s * (\<Sum>i<n + 2* s. abs(u s ((T^^i) x)) /s) = (\<Sum>i<n + 2* s. abs(u s ((T^^i) x)))"
       by (auto simp add: sum_divide_distrib[symmetric])
 
     have "s * (d/2) * card(V x \<inter> {1..n}) = (\<Sum>t<s. (d/2) * card(V x \<inter> {1..n}))"
       by auto
     also have "... \<le> (\<Sum>t<s. abs(u(N* s+t) x) + (Max {u i x|i. i< s} + birkhoff_sum F (n + 2* s) x)
             + (\<Sum>i<N. abs(u s ((T^^(i* s+t))x))))"
       apply (rule sum_mono) using eq_t by auto
     also have "... = (\<Sum>t<s. abs(u(N* s+t) x)) + (\<Sum>t<s. Max {u i x|i. i< s} + birkhoff_sum F (n + 2* s) x) + (\<Sum>t<s. (\<Sum>i<N. abs(u s ((T^^(i* s+t))x))))"
       by (auto simp add: sum.distrib)
     also have "... \<le> (\<Sum>i<2* s. abs (u (n+i) x)) + s * (Max {u i x|i. i< s} + birkhoff_sum F (n + 2* s) x) + s * birkhoff_sum (\<lambda>x. abs(u s x/ s)) (n+2* s) x"
       using ** *** by auto
     also have "... = s * ((1/s) * (\<Sum>i<2* s. abs (u (n+i) x)) + Max {u i x|i. i< s} + birkhoff_sum F (n + 2* s) x + birkhoff_sum (\<lambda>x. abs(u s x/ s)) (n+2* s) x)"
       by (auto simp add: divide_simps mult.commute distrib_left)
     finally show ?thesis
       by auto
   qed
 
   have densV: "upper_asymptotic_density (V x) \<le> (2/d) * real_cond_exp M Invariants F2 x" if "x \<in> G" for x
   proof -
     have *: "(\<lambda>n. abs(u n x/n)) \<longlonglongrightarrow> 0"
       apply (rule tendsto_rabs_zero) using \<open>x\<in>G\<close> unfolding G_def by auto
 
     define Bound where "Bound = (\<lambda>n. (Max {u i x|i. i< s}*(1/n) + birkhoff_sum (\<lambda>x. abs(u s x/ s)) (n+2* s) x / n
       + birkhoff_sum F (n + 2* s) x / n + (1/s) * (\<Sum>i<2* s. abs(u (n+i) x) / n)))"
     have "Bound \<longlonglongrightarrow> (Max {u i x|i. i< s} * 0 + real_cond_exp M Invariants (\<lambda>x. abs(u s x/s)) x
                       + real_cond_exp M Invariants F x + (1/s) * (\<Sum>i < 2 * s. 0))"
       unfolding Bound_def apply (intro tendsto_intros)
       using \<open>x\<in>G\<close> * unfolding G_def by auto
     moreover have "real_cond_exp M Invariants (\<lambda>x. abs(u s x/s)) x + real_cond_exp M Invariants F x = real_cond_exp M Invariants F2 x"
       using \<open>x \<in> G\<close> unfolding G_def by auto
     ultimately have B_conv: "Bound \<longlonglongrightarrow> real_cond_exp M Invariants F2 x" by simp
 
     have *: "(d/2) * card(V x \<inter> {1..n}) / n \<le> Bound n" for n
     proof -
       have "(d/2) * card(V x \<inter> {1..n}) / n \<le> (Max {u i x|i. i< s} + birkhoff_sum (\<lambda>x. abs(u s x/ s)) (n+2* s) x
         + birkhoff_sum F (n + 2* s) x + (1/s) * (\<Sum>i<2* s. abs(u (n+i) x)))/n"
         using Main2[of x n] using divide_right_mono of_nat_0_le_iff by blast
       also have "... = Bound n"
         unfolding Bound_def by (auto simp add: add_divide_distrib sum_divide_distrib[symmetric])
       finally show ?thesis by simp
     qed
 
     have "ereal(d/2 * upper_asymptotic_density (V x)) = ereal(d/2) * ereal(upper_asymptotic_density (V x))"
       by auto
     also have "... = ereal (d/2) * limsup(\<lambda>n. card(V x \<inter> {1..n}) / n)"
       using upper_asymptotic_density_shift[of "V x" 1 0] by auto
     also have "... = limsup(\<lambda>n. ereal (d/2) * (card(V x \<inter> {1..n}) / n))"
       by (rule limsup_ereal_mult_left[symmetric], auto)
     also have "... \<le> limsup Bound"
       apply (rule Limsup_mono) using * not_eventuallyD by auto
     also have "... = ereal(real_cond_exp M Invariants F2 x)"
       using B_conv convergent_limsup_cl convergent_def convergent_real_imp_convergent_ereal limI by force
     finally have "d/2 * upper_asymptotic_density (V x) \<le> real_cond_exp M Invariants F2 x"
       by auto
     then show ?thesis
       by (simp add: divide_simps mult.commute)
   qed
 
   define epsilon where "epsilon = 2 * rho / d"
   have [simp]: "epsilon > 0" "epsilon \<noteq> 0" "epsilon \<ge> 0" unfolding epsilon_def by auto
   have "emeasure M {x\<in>space M. real_cond_exp M Invariants F2 x \<ge> epsilon} \<le> (1/epsilon) * (\<integral>x. real_cond_exp M Invariants F2 x \<partial>M)"
     apply (intro integral_Markov_inequality real_cond_exp_pos real_cond_exp_int(1))
     by (auto simp add: int_F2 F2_pos)
   also have "... = (1/epsilon) * (\<integral>x. F2 x \<partial>M)"
     apply (intro arg_cong[where f = ennreal])
     by (simp, rule real_cond_exp_int(2), simp add: int_F2)
   also have "... < (1/epsilon) * 2 * rho"
     using F2_int by (intro ennreal_lessI) (auto simp add: divide_simps)
   also have "... = d"
     unfolding epsilon_def by auto
   finally have *: "emeasure M {x\<in>space M. real_cond_exp M Invariants F2 x \<ge> epsilon} < d"
     by simp
 
   define G2 where "G2 = {x \<in> G. real_cond_exp M Invariants F2 x < epsilon}"
   have [measurable]: "G2 \<in> sets M" unfolding G2_def by simp
   have "1 = emeasure M G"
     using \<open>emeasure M G = 1\<close> by simp
   also have "... \<le> emeasure M (G2 \<union> {x\<in>space M. real_cond_exp M Invariants F2 x \<ge> epsilon})"
     apply (rule emeasure_mono) unfolding G2_def using sets.sets_into_space[OF \<open>G \<in> sets M\<close>] by auto
   also have "... \<le> emeasure M G2 + emeasure M {x\<in>space M. real_cond_exp M Invariants F2 x \<ge> epsilon}"
     by (rule emeasure_subadditive, auto)
   also have "... < emeasure M G2 + d"
     using * by auto
   finally have "1 - d < emeasure M G2"
     using emeasure_eq_measure \<open>d \<le> 1\<close> by (auto intro!: ennreal_less_iff[THEN iffD2] simp del: ennreal_plus simp add: ennreal_plus[symmetric])
 
   have "upper_asymptotic_density {n. \<exists>l \<in> {k..n}. u n x - u (n-l) x \<le> - d * l} < d"
     if "x \<in> G2" for x
   proof -
     have "x \<in> G" using \<open>x \<in> G2\<close> unfolding G2_def by auto
     have "{n. \<exists>l \<in> {k..n}. u n x - u (n-l) x \<le> - d * l} \<subseteq> U x \<union> V x"
       unfolding U_def V_def by fastforce
     then have "upper_asymptotic_density {n. \<exists>l \<in> {k..n}. u n x - u (n-l) x \<le> - d * l} \<le> upper_asymptotic_density (U x \<union> V x)"
       by (rule upper_asymptotic_density_subset)
     also have "... \<le> upper_asymptotic_density (U x) + upper_asymptotic_density (V x)"
       by (rule upper_asymptotic_density_union)
     also have "... \<le> (2/d) * real_cond_exp M Invariants F2 x"
       using densU[OF \<open>x \<in> G\<close>] densV[OF \<open>x \<in> G\<close>] by auto
     also have "... < (2/d) * epsilon"
       using \<open>x \<in> G2\<close> unfolding G2_def by (simp add: divide_simps)
     text \<open>This is where the choice of $\rho$ at the beginning of the proof is relevant:
     we choose it so that the above term is at most $d$.\<close>
     also have "... = d" unfolding epsilon_def rho_def by auto
     finally show ?thesis by simp
   qed
   then have "G2 \<subseteq> {x \<in> space M. upper_asymptotic_density {n. \<exists>l \<in> {k..n}. u n x - u (n-l) x \<le> - d * l} < d}"
     using sets.sets_into_space[OF \<open>G2 \<in> sets M\<close>] by blast
   then have "emeasure M G2 \<le> emeasure M {x \<in> space M. upper_asymptotic_density {n. \<exists>l \<in> {k..n}. u n x - u (n-l) x \<le> - d * l} < d}"
     by (rule emeasure_mono, auto)
   then have "emeasure M {x \<in> space M. upper_asymptotic_density {n. \<exists>l \<in> {k..n}. u n x - u (n-l) x \<le> - d * l} < d} > 1 -d"
     using \<open>emeasure M G2 > 1 - d\<close> by auto
   then show ?thesis by blast
 qed
 
 text \<open>The two previous lemmas are put together in the following lemma,
 corresponding to Lemma 2.3 in~\cite{gouezel_karlsson}.\<close>
 
 lemma upper_density_delta:
   fixes d::real
   assumes "d > 0" "d \<le> 1"
   shows "\<exists>delta::nat\<Rightarrow>real. (\<forall>l. delta l > 0) \<and> (delta \<longlonglongrightarrow> 0) \<and>
         emeasure M {x \<in> space M. \<forall>(N::nat). card {n \<in>{..<N}. \<exists>l \<in> {1..n}. u n x - u (n-l) x \<le> - delta l * l} \<le> d * N} > 1 - d"
 proof -
   define d2 where "d2 = d/2"
   have [simp]: "d2 > 0" unfolding d2_def using assms by simp
+  then have "\<not> d2 < 0" using not_less [of d2 0] by (simp add: less_le)
   have "d2/2 > 0" by simp
   obtain c0 where c0: "c0> (0::real)" "emeasure M {x \<in> space M. upper_asymptotic_density {n. \<exists>l \<in> {1..n}. u n x - u (n-l) x \<le> - c0 * l} < d2/2} > 1 - (d2/2)"
     using upper_density_all_times[OF \<open>d2/2 > 0\<close>] by blast
   have "\<exists>N. emeasure M {x \<in> space M. \<forall>n \<ge> N. card ({n. \<exists>l \<in> {1..n}. u n x - u (n-l) x \<le> - c0 * l} \<inter> {..<n}) < (d2/2) * n} > 1 - (d2/2)"
     apply (rule upper_density_eventually_measure) using c0(2) by auto
   then obtain N1 where N1: "emeasure M {x \<in> space M. \<forall>B \<ge> N1. card ({n. \<exists>l \<in> {1..n}. u n x - u (n-l) x \<le> - c0 * l} \<inter> {..<B}) < (d2/2) * B} > 1 - (d2/2)"
     by blast
   define O1 where "O1 = {x \<in> space M. \<forall>B \<ge> N1. card ({n. \<exists>l \<in> {1..n}. u n x - u (n-l) x \<le> - c0 * l} \<inter> {..<B}) < (d2/2) * B}"
   have [measurable]: "O1 \<in> sets M" unfolding O1_def by auto
   have "emeasure M O1 > 1 - (d2/2)" unfolding O1_def using N1 by auto
 
   have *: "\<exists>N. emeasure M {x \<in> space M. \<forall>B \<ge> N. card({n. \<exists>l \<in> {N..n}. u n x - u (n-l) x \<le> - e * l} \<inter> {..<B}) < e * B} > 1 - e"
     if "e>0" "e \<le> 1" for e::real
   proof -
     obtain k where k: "emeasure M {x \<in> space M. upper_asymptotic_density {n. \<exists>l \<in> {k..n}. u n x - u (n-l) x \<le> - e * l} < e} > 1 - e"
       using upper_density_large_k[OF \<open>e>0\<close> \<open>e \<le> 1\<close>] by blast
     then obtain N0 where N0: "emeasure M {x \<in> space M. \<forall>B \<ge> N0. card({n. \<exists>l \<in> {k..n}. u n x - u (n-l) x \<le> - e * l} \<inter> {..<B}) < e * B} > 1 - e"
       using upper_density_eventually_measure[OF _ k] by auto
     define N where "N = max k N0"
     have "emeasure M {x \<in> space M. \<forall>B \<ge> N0. card({n. \<exists>l \<in> {k..n}. u n x - u (n-l) x \<le> - e * l} \<inter> {..<B}) < e * B}
             \<le> emeasure M {x \<in> space M. \<forall>B \<ge> N. card({n. \<exists>l \<in> {N..n}. u n x - u (n-l) x \<le> - e * l} \<inter> {..<B}) < e * B}"
     proof (rule emeasure_mono, auto)
       fix x B assume H: "x \<in> space M" "\<forall>B\<ge>N0. card ({n. \<exists>l\<in>{k..n}. u n x - u (n - l) x \<le> - (e * real l)} \<inter> {..<B}) < e * B" "N \<le> B"
 
       have "card({n. \<exists>l \<in> {N..n}. u n x - u (n-l) x \<le> - (e * real l)} \<inter> {..<B}) \<le> card({n. \<exists>l \<in> {k..n}. u n x - u (n-l) x \<le> -(e * real l)} \<inter> {..<B})"
         unfolding N_def by (rule card_mono, auto)
       then have "real(card({n. \<exists>l \<in> {N..n}. u n x - u (n-l) x \<le> - (e * real l)} \<inter> {..<B})) \<le> card({n. \<exists>l \<in> {k..n}. u n x - u (n-l) x \<le> -(e * real l)} \<inter> {..<B})"
         by simp
       also have "... < e * B" using H(2) \<open>B\<ge>N\<close> unfolding N_def by auto
       finally show "card ({n. \<exists>l\<in>{N..n}. u n x - u (n - l) x \<le> - (e * real l)} \<inter> {..<B}) < e * B"
         by auto
     qed
     then have "emeasure M {x \<in> space M. \<forall>B \<ge> N. card({n. \<exists>l \<in> {N..n}. u n x - u (n-l) x \<le> - e * l} \<inter> {..<B}) < e * B} > 1 - e"
       using N0 by simp
     then show ?thesis by auto
   qed
 
   define Ne where "Ne = (\<lambda>(e::real). SOME N. emeasure M {x \<in> space M. \<forall>B \<ge> N. card({n. \<exists>l \<in> {N..n}. u n x - u (n-l) x \<le> - e * l} \<inter> {..<B}) < e * B} > 1 - e)"
   have Ne: "emeasure M {x \<in> space M. \<forall>B \<ge> Ne e. card({n. \<exists>l \<in> {Ne e..n}. u n x - u (n-l) x \<le> - e * l} \<inter> {..<B}) < e * B} > 1 - e"
     if "e>0" "e \<le> 1" for e::real
   unfolding Ne_def by (rule someI_ex[OF *[OF that]])
   define eps where "eps = (\<lambda>(n::nat). d2 * (1/2)^n)"
   have [simp]: "eps n > 0" for n unfolding eps_def by auto
   then have [simp]: "eps n \<ge> 0" for n by (rule less_imp_le)
 
   have "eps n \<le> (1 / 2) * 1" for n
     unfolding eps_def d2_def
     using \<open>d \<le> 1\<close> by (intro mult_mono power_le_one) auto
   also have "\<dots> < 1" by auto
   finally have [simp]: "eps n < 1" for n by simp
   then have [simp]: "eps n \<le> 1" for n by (rule less_imp_le)
 
   have "(\<lambda>n. d2 * (1/2)^n) \<longlonglongrightarrow> d2 * 0"
     by (rule tendsto_mult, auto simp add: LIMSEQ_realpow_zero)
   then have "eps \<longlonglongrightarrow> 0" unfolding eps_def by auto
 
   define Nf where "Nf = (\<lambda>N. (if (N = 0) then 0
                 else if (N = 1) then N1 + 1
                 else max (N1+1) (Max {Ne(eps n)|n. n \<le> N}) + N))"
   have "Nf N < Nf (N+1)" for N
   proof -
     consider "N = 0" | "N = 1" | "N>1" by fastforce
     then show ?thesis
     proof (cases)
       assume "N>1"
       have "Max {Ne (eps n) |n. n \<le> N} \<le> Max {Ne (eps n) |n. n \<le> Suc N}"
         by (rule Max_mono, auto)
       then show ?thesis unfolding Nf_def by auto
     qed (auto simp add: Nf_def)
   qed
   then have "strict_mono Nf"
     using strict_mono_Suc_iff by auto
 
   define On where "On = (\<lambda>(N::nat).
     (if (N = 1) then O1
     else {x \<in> space M. \<forall>B \<ge> Nf N. card({n. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N) * l} \<inter> {..<B}) < (eps N) * B}))"
   have [measurable]: "On N \<in> sets M" for N unfolding On_def by auto
   have "emeasure M (On N) > 1 - eps N" if "N>0" for N
   proof -
     consider "N = 1" | "N>1" using \<open>N>0\<close> by linarith
     then show ?thesis
     proof (cases)
       case 1
       then show ?thesis unfolding On_def eps_def using \<open>emeasure M O1 > 1 - (d2/2)\<close> by auto
     next
       case 2
       have "Ne (eps N) \<le> Max {Ne(eps n)|n. n \<le> N}"
         by (rule Max.coboundedI, auto)
       also have "... \<le> Nf N" unfolding Nf_def using \<open>N>1\<close> by auto
       finally have "Ne (eps N) \<le> Nf N" by simp
       have "1 - eps N < emeasure M {x \<in> space M. \<forall>B \<ge> Ne(eps N). card({n. \<exists>l \<in> {Ne(eps N)..n}. u n x - u (n-l) x \<le> - (eps N) * l} \<inter> {..<B}) < (eps N) * B}"
         by (rule Ne) simp_all
       also have "... \<le> emeasure M {x \<in> space M. \<forall>B \<ge> Nf N. card({n. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N) * l} \<inter> {..<B}) < (eps N) * B}"
       proof (rule emeasure_mono, auto)
         fix x n assume H: "x \<in> space M"
                           "\<forall>n\<ge>Ne (eps N). card ({n. \<exists>l\<in>{Ne (eps N)..n}. u n x - u (n - l) x \<le> - (eps N * l)} \<inter> {..<n}) < eps N * n"
                           "Nf N \<le> n"
         have "card({n. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<n}) \<le> card({n. \<exists>l \<in> {Ne(eps N)..n}. u n x - u (n-l) x \<le> -(eps N) * l} \<inter> {..<n})"
           apply (rule card_mono) using \<open>Ne (eps N) \<le> Nf N\<close> by auto
         then have "real(card({n. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<n})) \<le> card({n. \<exists>l \<in> {Ne(eps N)..n}. u n x - u (n-l) x \<le> -(eps N) * l} \<inter> {..<n})"
           by simp
         also have "... < (eps N) * n" using H(2) \<open>n \<ge> Nf N\<close> \<open>Ne (eps N) \<le> Nf N\<close> by auto
         finally show "real (card ({n. \<exists>l\<in>{Nf N..n}. u n x - u (n - l) x \<le> - (eps N * l)} \<inter> {..<n})) < eps N * real n"
           by auto
       qed
       also have "... = emeasure M (On N)"
         unfolding On_def using \<open>N>1\<close> by auto
       finally show ?thesis by simp
     qed
   qed
   then have *: "emeasure M (On (N+1)) > 1 - eps (N+1)" for N by simp
 
   define Ogood where "Ogood = (\<Inter>N. On (N+1))"
   have [measurable]: "Ogood \<in> sets M" unfolding Ogood_def by auto
   have "emeasure M Ogood \<ge> 1 - (\<Sum>N. eps(N+1))"
     unfolding Ogood_def
     apply (intro emeasure_intersection, auto)
     using * by (auto simp add: eps_def summable_mult summable_divide summable_geometric less_imp_le)
   moreover have "(\<Sum>N. eps(N+1)) = d2"
     unfolding eps_def apply (subst suminf_mult)
     using sums_unique[OF power_half_series, symmetric] by (auto intro!: summable_divide summable_geometric)
   finally have "emeasure M Ogood \<ge> 1 - d2" by simp
   then have "emeasure M Ogood > 1 - d" unfolding d2_def using \<open>d>0\<close> \<open>d \<le> 1\<close>
     by (simp add: emeasure_eq_measure field_sum_of_halves ennreal_less_iff)
 
   have Ogood_union: "Ogood = (\<Union>(K::nat). Ogood \<inter> {x \<in> space M. \<forall>n \<in> {1..Nf 1}. \<forall>l \<in> {1..n}. u n x - u (n-l) x > - (real K * l)})"
   apply auto using sets.sets_into_space[OF \<open>Ogood \<in> sets M\<close>] apply blast
   proof -
     fix x
     define M where "M = Max {abs(u n x - u (n-l) x)/l | n l. n \<in> {1..Nf 1} \<and> l \<in> {1..n}}"
     obtain N::nat where "N > M" using reals_Archimedean2 by blast
 
     have "finite { (n, l) | n l. n \<in> {1..Nf 1} \<and> l \<in> {1..n}}"
       by (rule finite_subset[where ?B = "{1.. Nf 1} \<times> {1..Nf 1}"], auto)
     moreover have "{abs(u n x - u (n-l) x)/l | n l. n \<in> {1..Nf 1} \<and> l \<in> {1..n}}
       = (\<lambda> (n, l). abs(u n x - u (n-l) x)/l)` { (n, l) | n l. n \<in> {1..Nf 1} \<and> l \<in> {1..n}}"
       by auto
     ultimately have fin: "finite {abs(u n x - u (n-l) x)/l | n l. n \<in> {1..Nf 1} \<and> l \<in> {1..n}}"
       by auto
     {
       fix n l assume nl: "n \<in> {1..Nf 1} \<and> l \<in> {1..n}"
       then have "real l>0" by simp
       have "abs(u n x - u (n-l) x)/l \<le> M"
         unfolding M_def apply (rule Max_ge) using fin nl by auto
       then have "abs(u n x - u (n-l) x)/l < real N" using \<open>N>M\<close> by simp
       then have "abs(u n x - u (n-l) x)< real N * l" using \<open>0 < real l\<close> pos_divide_less_eq by blast
       then have "u n x - u (n-l) x > - (real N * l)" by simp
     }
     then have "\<forall>n\<in>{Suc 0..Nf (Suc 0)}. \<forall>l\<in>{Suc 0..n}. - (real N * real l) < u n x - u (n - l) x"
       by auto
     then show "\<exists>N. \<forall>n\<in>{Suc 0..Nf (Suc 0)}. \<forall>l\<in>{Suc 0..n}. - (real N * real l) < u n x - u (n - l) x"
       by auto
   qed
   have "(\<lambda>K. emeasure M (Ogood \<inter> {x \<in> space M. \<forall>n \<in> {1..Nf 1}. \<forall>l \<in> {1..n}. u n x - u (n-l) x > - (real K * l)}))
     \<longlonglongrightarrow> emeasure M (\<Union>(K::nat). Ogood \<inter> {x \<in> space M. \<forall>n \<in> {1..Nf 1}. \<forall>l \<in> {1..n}. u n x - u (n-l) x > - (real K * l)})"
     apply (rule Lim_emeasure_incseq, auto)
     unfolding incseq_def apply auto
     proof -
       fix m n x na l
       assume "m \<le> (n::nat)" "\<forall>n\<in>{Suc 0..Nf (Suc 0)}. \<forall>l\<in>{Suc 0..n}. - (real m * real l) < u n x - u (n - l) x"
              "Suc 0 \<le> l" "l \<le> na" "na \<le> Nf (Suc 0)"
       then have "- (real m * real l) < u na x - u (na - l) x" by auto
       moreover have "- (real n * real l) \<le> - (real m * real l)" using \<open>m \<le> n\<close> by (simp add: mult_mono)
       ultimately show "- (real n * real l) < u na x - u (na - l) x" by auto
     qed
   moreover have "emeasure M (\<Union>(K::nat). Ogood \<inter> {x \<in> space M. \<forall>n \<in> {1..Nf 1}. \<forall>l \<in> {1..n}. u n x - u (n-l) x > - (real K * l)}) > 1 - d"
     using Ogood_union \<open>emeasure M Ogood > 1 - d\<close> by auto
   ultimately have a: "eventually (\<lambda>K. emeasure M (Ogood \<inter> {x \<in> space M. \<forall>n \<in> {1..Nf 1}. \<forall>l \<in> {1..n}. u n x - u (n-l) x > - (real K * l)}) > 1 - d) sequentially"
     by (rule order_tendstoD(1))
   have b: "eventually (\<lambda>K. K \<ge> max c0 d2) sequentially"
     using eventually_at_top_linorder nat_ceiling_le_eq by blast
   have "eventually (\<lambda>K. K \<ge> max c0 d2 \<and> emeasure M (Ogood \<inter> {x \<in> space M. \<forall>n \<in> {1..Nf 1}. \<forall>l \<in> {1..n}. u n x - u (n-l) x > - (real K * l)}) > 1 - d) sequentially"
     by (rule eventually_elim2[OF a b], auto)
   then obtain K where K: "K\<ge>max c0 d2" "emeasure M (Ogood \<inter> {x \<in> space M. \<forall>n \<in> {1..Nf 1}. \<forall>l \<in> {1..n}. u n x - u (n-l) x > - (real K * l)}) > 1 - d"
     using eventually_False_sequentially eventually_elim2 by blast
 
   define Og where "Og = Ogood \<inter> {x \<in> space M. \<forall>n \<in> {1..Nf 1}. \<forall>l \<in> {1..n}. u n x - u (n-l) x > - (real K * l)}"
   have [measurable]: "Og \<in> sets M" unfolding Og_def by simp
   have "emeasure M Og > 1 - d" unfolding Og_def using K by simp
 
   have fin: "finite {N. Nf N \<le> n}" for n
     using pseudo_inverse_finite_set[OF filterlim_subseq[OF \<open>strict_mono Nf\<close>]] by auto
   define prev_N where "prev_N = (\<lambda>n. Max {N. Nf N \<le> n})"
   define delta where "delta = (\<lambda>l. if (prev_N l \<le> 1) then K else eps (prev_N l))"
   have "\<forall>l. delta l > 0"
     unfolding delta_def using \<open>K\<ge>max c0 d2\<close> \<open>c0>0\<close> by auto
 
   have "LIM n sequentially. prev_N n :> at_top"
     unfolding prev_N_def apply (rule tendsto_at_top_pseudo_inverse2)
     using \<open>strict_mono Nf\<close> by (simp add: filterlim_subseq)
   then have "eventually (\<lambda>l. prev_N l > 1) sequentially"
     by (simp add: filterlim_iff)
   then have "eventually (\<lambda>l. delta l = eps(prev_N l)) sequentially"
     unfolding delta_def by (simp add: eventually_mono)
   moreover have "(\<lambda>l. eps(prev_N l)) \<longlonglongrightarrow> 0"
     by (rule filterlim_compose[OF \<open>eps \<longlonglongrightarrow> 0\<close> \<open>LIM n sequentially. prev_N n :> at_top\<close>])
   ultimately have "delta \<longlonglongrightarrow> 0" by (simp add: filterlim_cong)
 
   have "delta n \<le> K" for n
   proof -
     have *: "d2 * (1 / 2) ^ prev_N n \<le> real K * 1"
       apply (rule mult_mono') using \<open>K \<ge> max c0 d2\<close> \<open>d2>0\<close> by (auto simp add: power_le_one less_imp_le)
     then show ?thesis unfolding delta_def apply auto unfolding eps_def using * by auto
   qed
 
   define bad_times where "bad_times = (\<lambda>x. {n \<in> {Nf 1..}. \<exists>l\<in>{1..n}. u n x - u (n-l) x \<le> - (c0 * l)} \<union>
                       (\<Union>N\<in>{2..}. {n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)}))"
   have card_bad_times: "card (bad_times x \<inter> {..<B}) \<le> d2 * B" if "x \<in> Og" for x B
   proof -
     have "(\<Sum>N\<in>{..<B}. (1/(2::real))^N) \<le> (\<Sum>N. (1/2)^N)"
       by (rule sum_le_suminf, auto simp add: summable_geometric)
     also have "... = 2" using suminf_geometric[of "1/(2::real)"] by auto
     finally have *: "(\<Sum>N\<in>{..<B}. (1/(2::real))^N) \<le> 2" by simp
 
     have "(\<Sum> N \<in> {2..<B}. eps N * B) \<le> (\<Sum> N \<in> {2..<B+2}. eps N * B)"
       by (rule sum_mono2, auto)
     also have "... = (\<Sum>N\<in>{2..<B+2}. d2 * (1/2)^N * B)"
       unfolding eps_def by auto
     also have "... = (\<Sum>N\<in>{..<B}. d2 * (1/2)^(N+2) * B)"
       by (rule sum.reindex_bij_betw[symmetric],rule bij_betw_byWitness[where ?f' = "\<lambda>i. i-2"], auto)
     also have "... = (\<Sum>N\<in>{..<B}. (d2 * (1/4) * B) * (1/2)^N)"
       by (auto, metis (lifting) mult.commute mult.left_commute)
     also have "... = (d2 * (1/4) * B) * (\<Sum>N\<in>{..<B}. (1/2)^N)"
       by (rule sum_distrib_left[symmetric])
     also have "... \<le> (d2 * (1/4) * B) * 2"
       apply (rule mult_left_mono) using * \<open>d2 > 0\<close> apply auto
       by (metis \<open>0 < d2\<close> mult_eq_0_iff mult_le_0_iff not_le of_nat_eq_0_iff of_nat_le_0_iff)
     finally have I: "(\<Sum> N \<in> {2..<B}. eps N * B) \<le> d2/2 * B"
       by auto
 
     have "x \<in> On 1" using \<open>x \<in> Og\<close> unfolding Og_def Ogood_def by auto
     then have "x \<in> O1" unfolding On_def by auto
     have B1: "real(card({n \<in> {Nf 1..}. \<exists>l\<in>{1..n}. u n x - u (n-l) x \<le> - (c0 * l)} \<inter> {..<B})) \<le> (d2/2) * B" for B
     proof (cases "B \<ge> N1")
       case True
       have "card({n \<in> {Nf 1..}. \<exists>l\<in>{1..n}. u n x - u (n-l) x \<le> - (c0 * l)} \<inter> {..<B})
         \<le> card({n. \<exists>l\<in>{1..n}. u n x - u (n-l) x \<le> - (c0 * l)} \<inter> {..<B})"
         by (rule card_mono, auto)
       also have "... \<le> (d2/2) * B"
         using \<open>x \<in> O1\<close> unfolding O1_def using True by auto
       finally show ?thesis by auto
     next
       case False
       then have "B < Nf 1" unfolding Nf_def by auto
       then have "{n \<in> {Nf 1..}. \<exists>l\<in>{1..n}. u n x - u (n-l) x \<le> - (c0 * l)} \<inter> {..<B} = {}"
         by auto
       then have "card ({n \<in> {Nf 1..}. \<exists>l\<in>{1..n}. u n x - u (n-l) x \<le> - (c0 * l)} \<inter> {..<B}) = 0"
         by auto
       also have "... \<le> (d2/2) * B"
-        by (metis \<open>0 < d2 / 2\<close> divide_le_eq div_0 linordered_field_class.sign_simps(24) of_nat_0 of_nat_0_le_iff)
+        using \<open>\<not> d2 < 0\<close> by simp
       finally show ?thesis by simp
     qed
 
     have BN: "real(card ({n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B})) \<le> eps N * B" if "N \<ge> 2" for N B
     proof -
       have "x \<in> On ((N-1) + 1)" using \<open>x \<in> Og\<close> unfolding Og_def Ogood_def by auto
       then have "x \<in> On N" using \<open>N\<ge>2\<close> by auto
       show ?thesis
       proof (cases "B \<ge> Nf N")
         case True
         have "card ({n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B}) \<le>
           card ({n. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B})"
           by (rule card_mono, auto)
         also have "... \<le> eps N * B"
           using \<open>x \<in> On N\<close> \<open>N\<ge>2\<close> True unfolding On_def by auto
         finally show ?thesis by simp
       next
         case False
         then have "{n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B} = {}"
           by auto
         then have "card ({n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B}) = 0"
           by auto
         also have "... \<le> eps N * B"
           by (metis \<open>\<And>n. 0 < eps n\<close> le_less mult_eq_0_iff mult_pos_pos of_nat_0 of_nat_0_le_iff)
         finally show ?thesis by simp
       qed
     qed
 
     {
       fix N assume "N \<ge> B"
       have "Nf N \<ge> B" using seq_suble[OF \<open>strict_mono Nf\<close>, of N] \<open>N \<ge> B\<close> by simp
       then have "{Nf N..} \<inter> {..<B} = {}" by auto
       then have "{n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B} = {}" by auto
     }
     then have *: "(\<Union>N\<in>{B..}. {n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B}) = {}"
       by auto
 
     have "{2..} \<subseteq> {2..<B} \<union> {B..}" by auto
     then have "(\<Union>N\<in>{2..}. {n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B})
       \<subseteq> (\<Union>N\<in>{2..<B}. {n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B})
         \<union> (\<Union>N\<in>{B..}. {n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B})"
       by auto
     also have "... = (\<Union>N\<in>{2..<B}. {n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B})"
       using * by auto
     finally have *: "bad_times x \<inter> {..<B} \<subseteq> {n \<in> {Nf 1..}. \<exists>l\<in>{1..n}. u n x - u (n-l) x \<le> - (c0 * l)} \<inter> {..<B}
             \<union> (\<Union>N\<in>{2..<B}. {n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B})"
       unfolding bad_times_def by auto
     have "card(bad_times x \<inter> {..<B}) \<le> card({n \<in> {Nf 1..}. \<exists>l\<in>{1..n}. u n x - u (n-l) x \<le> - (c0 * l)} \<inter> {..<B}
         \<union> (\<Union>N\<in>{2..<B}. {n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B}))"
       by (rule card_mono[OF _ *], auto)
     also have "... \<le> card({n \<in> {Nf 1..}. \<exists>l\<in>{1..n}. u n x - u (n-l) x \<le> - (c0 * l)} \<inter> {..<B}) +
       card (\<Union>N\<in>{2..<B}. {n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B})"
       by (rule card_Un_le)
     also have "... \<le> card({n \<in> {Nf 1..}. \<exists>l\<in>{1..n}. u n x - u (n-l) x \<le> - (c0 * l)} \<inter> {..<B}) +
       (\<Sum> N\<in>{2..<B}. card ({n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B}))"
       by (simp del: UN_simps, rule card_finite_union, auto)
     finally have "real (card(bad_times x \<inter> {..<B})) \<le>
       real(card({n \<in> {Nf 1..}. \<exists>l\<in>{1..n}. u n x - u (n-l) x \<le> - (c0 * l)} \<inter> {..<B})
       + (\<Sum> N\<in>{2..<B}. card ({n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B})))"
       by (subst of_nat_le_iff, simp)
     also have "... = real(card({n \<in> {Nf 1..}. \<exists>l\<in>{1..n}. u n x - u (n-l) x \<le> - (c0 * l)} \<inter> {..<B}))
       + (\<Sum> N\<in>{2..<B}. real(card ({n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B})))"
       by auto
     also have "... \<le> (d2/2 * B) + (\<Sum> N\<in>{2..<B}. real(card ({n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)} \<inter> {..<B})))"
       using B1 by simp
     also have "... \<le> (d2/2 * B) + (\<Sum> N \<in> {2..<B}. eps N * B)"
       apply (simp, rule sum_mono) using BN by auto
     also have "... \<le> (d2/2 * B) + (d2/2*B)"
       using I by auto
     finally show ?thesis by simp
   qed
 
   have ineq_on_Og: "u n x - u (n-l) x > - delta l * l" if "l \<in> {1..n}" "n \<notin> bad_times x" "x \<in> Og" for n x l
   proof -
     consider "n < Nf 1" | "n \<ge> Nf 1 \<and> prev_N l \<le> 1" | "n \<ge> Nf 1 \<and> prev_N l \<ge> 2" by linarith
     then show ?thesis
     proof (cases)
       assume "n < Nf 1"
       then have "{N. Nf N \<le> n} = {0}"
         apply auto using \<open>strict_mono Nf\<close> unfolding strict_mono_def
         apply (metis le_trans less_Suc0 less_imp_le_nat linorder_neqE_nat not_less)
         unfolding Nf_def by auto
       then have "prev_N n = 0" unfolding prev_N_def by auto
       moreover have "prev_N l \<le> prev_N n"
         unfolding prev_N_def apply (rule Max_mono) using \<open>l \<in> {1..n}\<close> fin apply auto
         unfolding Nf_def by auto
       ultimately have "prev_N l = 0" using \<open>prev_N l \<le> prev_N n\<close> by auto
       then have "delta l = K" unfolding delta_def by auto
       have "1 \<notin> {N. Nf N \<le> n}" using fin[of n]
         by (metis (full_types) Max_ge \<open>prev_N n = 0\<close> fin not_one_le_zero prev_N_def)
       then have "n < Nf 1" by auto
       moreover have "n \<ge> 1" using \<open>l \<in> {1..n}\<close> by auto
       ultimately have "n \<in> {1..Nf 1}" by auto
       then have "u n x - u (n-l) x > - (real K * l)" using \<open>x \<in> Og\<close> unfolding Og_def using \<open>l \<in> {1..n}\<close> by auto
       then show ?thesis using \<open>delta l = K\<close> by auto
     next
       assume H: "n \<ge> Nf 1 \<and> prev_N l \<le> 1"
       then have "delta l = K" unfolding delta_def by auto
       have "n \<notin> {n \<in> {Nf 1..}. \<exists>l\<in>{1..n}. u n x - u (n-l) x \<le> - (c0 * l)}"
         using \<open>n \<notin> bad_times x\<close> unfolding bad_times_def by auto
       then have "u n x - u (n-l) x > - (c0 * l)"
         using H \<open>l \<in> {1..n}\<close> by force
       moreover have "- (c0 * l) \<ge> - (real K * l)" using K(1) by (simp add: mult_mono)
       ultimately show ?thesis using \<open>delta l = K\<close> by auto
     next
       assume H: "n \<ge> Nf 1 \<and> prev_N l \<ge> 2"
       define N where "N = prev_N l"
       have "N \<ge> 2" unfolding N_def using H by auto
       have "prev_N l \<in> {N. Nf N \<le> l}"
         unfolding prev_N_def apply (rule Max_in, auto simp add: fin)
         unfolding Nf_def by auto
       then have "Nf N \<le> l" unfolding N_def by auto
       then have "Nf N \<le> n" using \<open>l \<in> {1..n}\<close> by auto
       have "n \<notin> {n \<in> {Nf N..}. \<exists>l \<in> {Nf N..n}. u n x - u (n-l) x \<le> - (eps N * l)}"
         using \<open>n \<notin> bad_times x\<close> \<open>N\<ge>2\<close> unfolding bad_times_def by auto
       then have "u n x - u (n-l) x > - (eps N * l)"
         using \<open>Nf N \<le> n\<close> \<open>Nf N \<le> l\<close> \<open>l \<in> {1..n}\<close> by force
       moreover have "eps N = delta l" unfolding delta_def N_def using H by auto
       ultimately show ?thesis by auto
     qed
   qed
 
   have "Og \<subseteq> {x \<in> space M. \<forall>(B::nat). card {n \<in>{..<B}. \<exists>l \<in> {1..n}. u n x - u (n-l) x \<le> - delta l * l} \<le> d * B}"
   proof (auto)
     fix x assume "x \<in> Og"
     then show "x \<in> space M" unfolding Og_def by auto
   next
     fix x B assume "x \<in> Og"
     have *: "{n. n < B \<and> (\<exists>l\<in>{Suc 0..n}. u n x - u (n - l) x \<le> - (delta l * real l))} \<subseteq> bad_times x \<inter> {..<B}"
       using ineq_on_Og \<open>x\<in>Og\<close> by force
     have "card {n. n < B \<and> (\<exists>l\<in>{Suc 0..n}. u n x - u (n - l) x \<le> - (delta l * real l))} \<le> card (bad_times x \<inter> {..<B})"
       apply (rule card_mono, simp) using * by auto
     also have "... \<le> d2 * B" using card_bad_times \<open>x \<in> Og\<close> by auto
     also have "... \<le> d * B" unfolding d2_def using \<open>d>0\<close> by auto
     finally show "card {n. n < B \<and> (\<exists>l\<in>{Suc 0..n}. u n x - u (n - l) x \<le> - (delta l * real l))} \<le> d * B"
       by simp
   qed
   then have "emeasure M Og \<le> emeasure M {x \<in> space M. \<forall>(B::nat). card {n \<in>{..<B}. \<exists>l \<in> {1..n}. u n x - u (n-l) x \<le> - delta l * l} \<le> d * B}"
     by (rule emeasure_mono, auto)
   then have "emeasure M {x \<in> space M. \<forall>(B::nat). card {n \<in>{..<B}. \<exists>l \<in> {1..n}. u n x - u (n-l) x \<le> - delta l * l} \<le> d * B} > 1-d"
     using \<open>emeasure M Og > 1 - d\<close> by auto
   then show ?thesis using \<open>delta \<longlonglongrightarrow> 0\<close> \<open>\<forall>l. delta l > 0\<close> by auto
 qed
 
 text \<open>We go back to the natural time direction, by using the previous result for the inverse map
 and the inverse subcocycle, and a change of variables argument. The price to pay is that the
 estimates we get are weaker: we have a control on a set of upper asymptotic density close to $1$, while
 having a set of lower asymptotic density close to $1$ as before would be stronger. This will
 nevertheless be sufficient for our purposes below.\<close>
 
 lemma upper_density_good_direction_invertible:
   assumes "invertible_qmpt"
           "d>(0::real)" "d \<le> 1"
   shows "\<exists>delta::nat\<Rightarrow>real. (\<forall>l. delta l > 0) \<and> (delta \<longlonglongrightarrow> 0) \<and>
         emeasure M {x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l} \<ge> 1-d} \<ge> ennreal(1-d)"
 proof -
   interpret I: Gouezel_Karlsson_Kingman M Tinv "(\<lambda>n x. u n ((Tinv^^n) x))"
   proof
     show "Tinv \<in> quasi_measure_preserving M M"
       using Tinv_qmpt[OF \<open>invertible_qmpt\<close>] unfolding qmpt_def qmpt_axioms_def by simp
     show "Tinv \<in> measure_preserving M M"
       using Tinv_mpt[OF \<open>invertible_qmpt\<close>] unfolding mpt_def mpt_axioms_def by simp
     show "mpt.subcocycle M Tinv (\<lambda>n x. u n ((Tinv ^^ n) x))"
       using subcocycle_u_Tinv[OF subu \<open>invertible_qmpt\<close>] by simp
     show "- \<infinity> < subcocycle_avg_ereal (\<lambda>n x. u n ((Tinv ^^ n) x))"
       using subcocycle_avg_ereal_Tinv[OF subu \<open>invertible_qmpt\<close>] subu_fin by simp
     show "AE x in M. fmpt.subcocycle_lim M Tinv (\<lambda>n x. u n ((Tinv ^^ n) x)) x = 0"
       using subcocycle_lim_Tinv[OF subu \<open>invertible_qmpt\<close>] subu_0 by auto
   qed
   have bij: "bij T" using \<open>invertible_qmpt\<close> unfolding invertible_qmpt_def by simp
 
   define e where "e = d * d / 2"
   have "e>0" "e\<le>1" unfolding e_def using \<open>d>0\<close> \<open>d \<le> 1\<close>
     by (auto, meson less_imp_le mult_left_le one_le_numeral order_trans)
   obtain delta::"nat \<Rightarrow> real" where d: "\<And>l. delta l > 0"
                                        "delta \<longlonglongrightarrow> 0"
         "emeasure M {x \<in> space M. \<forall>N.
         card {n \<in> {..<N}. \<exists>l\<in>{1..n}. u n ((Tinv ^^ n) x) - u (n - l) ((Tinv ^^ (n - l)) x) \<le> - delta l * real l} \<le> e * real N}
         > 1-e"
     using I.upper_density_delta[OF \<open>e>0\<close> \<open>e\<le>1\<close>] by blast
 
   define S where "S = {x \<in> space M. \<forall>N.
           card {n \<in> {..<N}. \<exists>l\<in>{1..n}. u n ((Tinv ^^ n) x) - u (n - l) ((Tinv ^^ (n - l)) x) \<le> - delta l * real l} \<le> e * real N}"
   have [measurable]: "S \<in> sets M" unfolding S_def by auto
   have "emeasure M S > 1 - e" unfolding S_def using d(3) by simp
 
   define Og where "Og = (\<lambda>n. {x \<in> space M. \<forall>l\<in>{1..n}. u n ((Tinv ^^ n) x) - u (n - l) ((Tinv ^^ (n - l)) x) > - delta l * real l})"
   have [measurable]: "Og n \<in> sets M" for n unfolding Og_def by auto
   define Pg where "Pg = (\<lambda>n. {x \<in> space M. \<forall>l\<in>{1..n}. u n x - u (n - l) ((T^^l) x) > - delta l * real l})"
   have [measurable]: "Pg n \<in> sets M" for n unfolding Pg_def by auto
 
   define Bad where "Bad = (\<lambda>i::nat. {x \<in> space M. \<forall>N\<ge>i. card {n \<in> {..<N}. x \<in> Pg n} \<le> (1-d) * real N})"
   have [measurable]: "Bad i \<in> sets M" for i unfolding Bad_def by auto
   then have "range Bad \<subseteq> sets M" by auto
   have "incseq Bad"
     unfolding Bad_def incseq_def by auto
   have inc: "{x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l} < 1-d}
         \<subseteq> (\<Union>i. Bad i)"
   proof
     fix x assume H: "x \<in> {x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l} < 1-d}"
     then have "x \<in> space M" by simp
     define A where "A = {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l}"
     have "upper_asymptotic_density A < 1-d" using H unfolding A_def by simp
     then have "\<exists>i. \<forall>N\<ge>i. card (A \<inter> {..<N}) \<le> (1-d)* real N"
       using upper_asymptotic_densityD[of A "1-d"] by (metis (no_types, lifting) eventually_sequentially less_imp_le)
     then obtain i where "card (A \<inter> {..<N}) \<le> (1-d)* real N" if "N\<ge>i" for N by blast
     moreover have "A \<inter> {..<N} = {n. n<N \<and> (\<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l)}" for N
       unfolding A_def by auto
     ultimately have "x \<in> Bad i" unfolding Bad_def Pg_def using \<open>x \<in> space M\<close>
       by auto
     then show "x \<in> (\<Union>i. Bad i)" by blast
   qed
 
   have "emeasure M (Og n) \<le> emeasure M (Pg n)" for n
   proof -
     have *: "(T^^n)-`(Og n) \<inter> space M \<subseteq> Pg n" for n
     proof
       fix x assume x: "x \<in> (T^^n)-`(Og n) \<inter> space M"
       define y where "y = (T^^n) x"
       then have "y \<in> Og n" using x by auto
       have "y \<in> space M" using sets.sets_into_space[OF \<open>Og n \<in> sets M\<close>] \<open>y \<in> Og n\<close> by auto
       have "x = (Tinv^^n) y"
         unfolding y_def Tinv_def using inv_fn_o_fn_is_id[OF bij, of n] by (metis comp_apply)
       {
         fix l assume "l \<in> {1..n}"
         have "(T^^l) x = (T^^l) ((Tinv^^l) ((Tinv^^(n-l))y))"
           apply (subst \<open>x = (Tinv^^n) y\<close>) using funpow_add[of l "n-l" Tinv] \<open>l \<in> {1..n}\<close> by fastforce
         then have *: "(T^^l) x = (Tinv^^(n-l)) y"
           unfolding Tinv_def using fn_o_inv_fn_is_id[OF bij] by (metis comp_apply)
         then have "u n x - u (n-l) ((T^^l) x) = u n ((Tinv^^n) y) - u (n-l) ((Tinv^^(n-l)) y)"
           using \<open>x = (Tinv^^n) y\<close> by auto
         also have "... > - delta l * real l"
           using \<open>y \<in> Og n\<close> \<open>l \<in> {1..n}\<close> unfolding Og_def by auto
         finally have "u n x - u (n-l) ((T^^l) x) > - delta l * real l" by simp
       }
       then show "x \<in> Pg n"
         unfolding Pg_def using x by auto
     qed
     have "emeasure M (Og n) = emeasure M ((T^^n)-`(Og n) \<inter> space M)"
       using T_vrestr_same_emeasure(2) unfolding vimage_restr_def by auto
     also have "... \<le> emeasure M (Pg n)"
       apply (rule emeasure_mono) using * by auto
     finally show ?thesis by simp
   qed
 
   {
     fix N::nat assume "N \<ge> 1"
     have I: "card {n\<in>{..<N}. x \<in> Og n} \<ge> (1-e) * real N" if "x \<in> S" for x
     proof -
       have "x \<in> space M" using \<open>x \<in> S\<close> sets.sets_into_space[OF \<open>S \<in> sets M\<close>] by auto
       have a: "real (card {n. n < N \<and> (\<exists>l\<in>{Suc 0..n}. u n ((Tinv ^^ n) x) - u (n - l) ((Tinv ^^ (n - l)) x) \<le> - (delta l * real l))}) \<le> e * real N"
         using \<open>x \<in> S\<close> unfolding S_def by auto
       have *: "{n. n < N} = {n. n < N \<and> (\<exists>l\<in>{Suc 0..n}. u n ((Tinv ^^ n) x) - u (n - l) ((Tinv ^^ (n - l)) x) \<le> - (delta l * real l))}
               \<union> {n. n < N \<and> x \<in> Og n}" unfolding Og_def using \<open>x \<in> space M\<close>
         by (auto, meson atLeastAtMost_iff linorder_not_le)
       have "N = card {n. n < N}" by auto
       also have "... = card {n. n < N \<and> (\<exists>l\<in>{Suc 0..n}. u n ((Tinv ^^ n) x) - u (n - l) ((Tinv ^^ (n - l)) x) \<le> - (delta l * real l))}
               + card {n. n < N \<and> x \<in> Og n}"
         apply (subst *, rule card_Un_disjoint) unfolding Og_def by auto
       ultimately have "real N \<le> e * real N + card {n. n < N \<and> x \<in> Og n}"
         using a by auto
       then show ?thesis
         by (auto simp add: algebra_simps)
     qed
 
     define m where "m = measure M (Bad N)"
     have "m \<ge> 0" "1-m \<ge> 0" unfolding m_def by auto
 
     have *: "1-e \<le> emeasure M S" using \<open>emeasure M S > 1 - e\<close> by auto
     have "ennreal((1-e) * ((1-e) * real N)) = ennreal(1-e) * ennreal((1-e) * real N)"
       apply (rule ennreal_mult) using \<open>e \<le> 1\<close> by auto
     also have "... \<le> emeasure M S * ennreal((1-e) * real N)"
       using mult_right_mono[OF *] by simp
     also have "... = (\<integral>\<^sup>+ x\<in>S. ((1-e) * real N) \<partial>M)"
       by (metis \<open>S \<in> events\<close> mult.commute nn_integral_cmult_indicator)
     also have "... \<le> (\<integral>\<^sup>+x \<in> S. ennreal(card {n\<in>{..<N}. x \<in> Og n}) \<partial>M)"
       apply (rule nn_integral_mono) using I unfolding indicator_def by (simp)
     also have "... \<le> (\<integral>\<^sup>+x \<in> space M. ennreal(card {n\<in>{..<N}. x \<in> Og n}) \<partial>M)"
       by (rule nn_set_integral_set_mono, simp only: sets.sets_into_space[OF \<open>S \<in> sets M\<close>])
     also have "... = (\<integral>\<^sup>+x. ennreal(card {n\<in>{..<N}. x \<in> Og n}) \<partial>M)"
       by (rule nn_set_integral_space)
     also have "... = (\<integral>\<^sup>+x. ennreal (\<Sum>n\<in>{..<N}. ((indicator (Og n) x)::nat)) \<partial>M)"
       apply (rule nn_integral_cong) using sum_indicator_eq_card2[of "{..<N}" Og] by auto
     also have "... = (\<integral>\<^sup>+x. (\<Sum>n\<in>{..<N}. indicator (Og n) x) \<partial>M)"
       apply (rule nn_integral_cong, auto, simp only: sum_ennreal[symmetric])
       by (metis ennreal_0 ennreal_eq_1 indicator_eq_1_iff indicator_simps(2) real_of_nat_indicator)
     also have "... = (\<Sum>n \<in>{..<N}. (\<integral>\<^sup>+x. (indicator (Og n) x) \<partial>M))"
       by (rule nn_integral_sum, simp)
     also have "... = (\<Sum>n \<in>{..<N}. emeasure M (Og n))"
       by simp
     also have "... \<le> (\<Sum>n \<in>{..<N}. emeasure M (Pg n))"
       apply (rule sum_mono) using \<open>\<And>n. emeasure M (Og n) \<le> emeasure M (Pg n)\<close> by simp
     also have "... = (\<Sum>n \<in>{..<N}. (\<integral>\<^sup>+x. (indicator (Pg n) x) \<partial>M))"
       by simp
     also have "... = (\<integral>\<^sup>+x. (\<Sum>n\<in>{..<N}. indicator (Pg n) x) \<partial>M)"
       by (rule nn_integral_sum[symmetric], simp)
     also have "... = (\<integral>\<^sup>+x. ennreal (\<Sum>n\<in>{..<N}. ((indicator (Pg n) x)::nat)) \<partial>M)"
       apply (rule nn_integral_cong, auto, simp only: sum_ennreal[symmetric])
       by (metis ennreal_0 ennreal_eq_1 indicator_eq_1_iff indicator_simps(2) real_of_nat_indicator)
     also have "... = (\<integral>\<^sup>+x. ennreal(card {n\<in>{..<N}. x \<in> Pg n}) \<partial>M)"
       apply (rule nn_integral_cong) using sum_indicator_eq_card2[of "{..<N}" Pg] by auto
     also have "... = (\<integral>\<^sup>+x \<in> space M. ennreal(card {n\<in>{..<N}. x \<in> Pg n}) \<partial>M)"
       by (rule nn_set_integral_space[symmetric])
     also have "... = (\<integral>\<^sup>+x \<in> Bad N \<union> (space M - Bad N). ennreal(card {n\<in>{..<N}. x \<in> Pg n}) \<partial>M)"
       apply (rule nn_integral_cong) unfolding indicator_def by auto
     also have "... = (\<integral>\<^sup>+x \<in> Bad N. ennreal(card {n\<in>{..<N}. x \<in> Pg n}) \<partial>M)
                       + (\<integral>\<^sup>+x \<in> space M - Bad N. ennreal(card {n\<in>{..<N}. x \<in> Pg n}) \<partial>M)"
       by (rule nn_integral_disjoint_pair, auto)
     also have "... \<le> (\<integral>\<^sup>+x \<in> Bad N. ennreal((1-d) * real N) \<partial>M) + (\<integral>\<^sup>+x \<in> space M - Bad N. ennreal(real N) \<partial>M)"
       apply (rule add_mono)
       apply (rule nn_integral_mono, simp add: Bad_def indicator_def, auto)
       apply (rule nn_integral_mono, simp add: indicator_def, auto)
       using card_Collect_less_nat[of N] card_mono[of "{n. n < N}"] by (simp add: Collect_mono_iff)
     also have "... = ennreal((1-d) * real N) * emeasure M (Bad N) + ennreal(real N) * emeasure M (space M - Bad N)"
       by (simp add: nn_integral_cmult_indicator)
     also have "... = ennreal((1-d) * real N) * ennreal(m) + ennreal(real N) * ennreal(1-m)"
       unfolding m_def by (simp add: emeasure_eq_measure prob_compl)
     also have "... = ennreal((1-d) * real N * m + real N * (1-m))"
       using \<open>m \<ge> 0\<close> \<open>1-m \<ge> 0\<close> \<open>d \<le> 1\<close> ennreal_plus ennreal_mult by auto
     finally have "ennreal((1-e) * ((1-e) * real N)) \<le> ennreal((1-d) * real N * m + real N * (1-m))"
       by simp
     moreover have "(1-d) * real N * m + real N * (1-m) \<ge> 0"
       using \<open>m \<ge> 0\<close> \<open>1-m \<ge> 0\<close> \<open>d \<le> 1\<close> by auto
     ultimately have "(1-e) * ((1-e) * real N) \<le> (1-d) * real N * m + real N * (1-m)"
       using ennreal_le_iff by auto
     then have "0 \<le> (e * 2 - d * m - e * e) * real N"
       by (auto simp add: algebra_simps)
     then have "0 \<le> e * 2 - d * m - e * e"
       using \<open>N \<ge> 1\<close> by (simp add: zero_le_mult_iff)
     also have "... \<le> e * 2 - d * m"
       using \<open>e > 0\<close> by auto
     finally have "m \<le> e * 2 / d"
       using \<open>d>0\<close> by (auto simp add: algebra_simps divide_simps)
     then have "m \<le> d"
       unfolding e_def using \<open>d>0\<close> by (auto simp add: divide_simps)
     then have "emeasure M (Bad N) \<le> d"
       unfolding m_def by (simp add: emeasure_eq_measure ennreal_leI)
   }
   then have "emeasure M (\<Union>i. Bad i) \<le> d"
     using LIMSEQ_le_const2[OF Lim_emeasure_incseq[OF \<open>range Bad \<subseteq> sets M\<close> \<open>incseq Bad\<close>]] by auto
   then have "emeasure M {x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l} < 1-d} \<le> d"
     using emeasure_mono[OF inc, of M] by auto
   then have *: "measure M {x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l} < 1-d} \<le> d"
     using emeasure_eq_measure \<open>d>0\<close> by fastforce
 
   have "{x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l} \<ge> 1-d}
         = space M - {x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l} < 1-d}"
     by auto
   then have "measure M {x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l} \<ge> 1-d}
     = measure M (space M - {x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l} < 1-d})"
     by simp
   also have "... = measure M (space M)
     - measure M {x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l} < 1-d}"
     by (rule measure_Diff, auto)
   also have "... \<ge> 1 - d"
     using * prob_space by linarith
   finally have "emeasure M {x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l} \<ge> 1-d} \<ge> 1 - d"
     using emeasure_eq_measure by auto
   then show ?thesis using d(1) d(2) by blast
 qed
 
 text \<open>Now, we want to remove the invertibility assumption in the previous lemma. The idea is to
 go to the natural extension of the system, use the result there and project it back.
 However, if the system is not defined on a polish space, there is no reason why it should have
 a natural extension, so we have first to project the original system on a polish space on which
 the subcocycle is defined. This system is obtained by considering the joint distribution of the
 subcocycle and all its iterates (this is indeed a polish system, as a space of functions from
 $\mathbb{N}^2$ to $\mathbb{R}$).\<close>
 
 lemma upper_density_good_direction:
   assumes "d>(0::real)" "d \<le> 1"
   shows "\<exists>delta::nat\<Rightarrow>real. (\<forall>l. delta l > 0) \<and> (delta \<longlonglongrightarrow> 0) \<and>
         emeasure M {x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l} \<ge> 1-d} \<ge> ennreal(1-d)"
 proof -
   define U where "U = (\<lambda>x. (\<lambda>n. u n x))"
   define projJ where "projJ = (\<lambda>x. (\<lambda>n. U ((T^^n)x)))"
   define MJ where "MJ = (distr M borel (\<lambda>x. (\<lambda>n. U ((T^^n)x))))"
   define TJ::"(nat \<Rightarrow> nat \<Rightarrow> real) \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> real)" where "TJ = nat_left_shift"
   have *: "mpt_factor projJ MJ TJ"
     unfolding projJ_def MJ_def TJ_def apply (rule fmpt_factor_projection)
     unfolding U_def by (rule measurable_coordinatewise_then_product, simp)
   interpret J: polish_pmpt MJ TJ
     unfolding projJ_def polish_pmpt_def apply (auto)
     apply (rule pmpt_factor) using * apply simp
     unfolding polish_pmpt_axioms_def MJ_def by auto
   have [simp]: "projJ \<in> measure_preserving M MJ" using mpt_factorE(1)[OF *] by simp
   then have [measurable]: "projJ \<in> measurable M MJ" by (simp add: measure_preservingE(1))
 
   text \<open>We define a subcocycle $uJ$ in the projection corresponding to the original
         subcocycle $u$ above. (With the natural definition, it is only a subcocycle almost
         everywhere.) We check that it shares most properties of $u$.\<close>
 
   define uJ::"nat \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> real) \<Rightarrow> real" where "uJ = (\<lambda>n x. x 0 n)"
   have [measurable]: "uJ n \<in> borel_measurable borel" for n
     unfolding uJ_def by (metis measurable_product_coordinates measurable_product_then_coordinatewise)
   moreover have "measurable borel borel = measurable MJ borel"
     apply (rule measurable_cong_sets) unfolding MJ_def by auto
   ultimately have [measurable]: "uJ n \<in> borel_measurable MJ" for n by fast
   have uJ_proj: "u n x = uJ n (projJ x)" for n x
     unfolding uJ_def projJ_def U_def by auto
   have uJ_int: "integrable MJ (uJ n)" for n
     apply (rule measure_preserving_preserves_integral'(1)[OF \<open>projJ \<in> measure_preserving M MJ\<close>])
     apply (subst uJ_proj[of n, symmetric]) using int_u[of n] by auto
   have uJ_int2: "(\<integral>x. uJ n x \<partial>MJ) = (\<integral>x. u n x \<partial>M)" for n
     unfolding uJ_proj
     apply (rule measure_preserving_preserves_integral'(2)[OF \<open>projJ \<in> measure_preserving M MJ\<close>])
     apply (subst uJ_proj[of n, symmetric]) using int_u[of n] by auto
   have uJ_AE: "AE x in MJ. uJ (n+m) x \<le> uJ n x + uJ m ((TJ^^n) x)" for m n
   proof -
     have "AE x in M. uJ (n+m) (projJ x) \<le> uJ n (projJ x) + uJ m (projJ ((T^^n) x))"
       unfolding uJ_proj[symmetric] using subcocycle_ineq[OF subu] by auto
     moreover have "AE x in M. projJ ((T^^n) x) = (TJ^^n) (projJ x)"
       using qmpt_factor_iterates[OF mpt_factor_is_qmpt_factor[OF *]] by auto
     ultimately have *: "AE x in M. uJ (n+m) (projJ x) \<le> uJ n (projJ x) + uJ m ((TJ^^n) (projJ x))"
       by auto
     show ?thesis
       apply (rule quasi_measure_preserving_AE'[OF measure_preserving_is_quasi_measure_preserving[OF \<open>projJ \<in> measure_preserving M MJ\<close>], OF *])
       by auto
   qed
   have uJ_0: "AE x in MJ. (\<lambda>n. uJ n x / n) \<longlonglongrightarrow> 0"
   proof -
     have "AE x in M. (\<lambda>n. u n x / n) \<longlonglongrightarrow> subcocycle_lim u x"
       by (rule kingman_theorem_nonergodic(1)[OF subu subu_fin])
     moreover have "AE x in M. subcocycle_lim u x = 0"
       using subu_0 by simp
     ultimately have *: "AE x in M. (\<lambda>n. uJ n (projJ x) / n) \<longlonglongrightarrow> 0"
       unfolding uJ_proj by auto
     show ?thesis
       apply (rule quasi_measure_preserving_AE'[OF measure_preserving_is_quasi_measure_preserving[OF \<open>projJ \<in> measure_preserving M MJ\<close>], OF *])
       by auto
   qed
 
   text \<open>Then, we go to the natural extension of $TJ$, to have an invertible system.\<close>
 
   define MI where "MI = J.natural_extension_measure"
   define TI where "TI = J.natural_extension_map"
   define projI where "projI = J.natural_extension_proj"
   interpret I: pmpt MI TI unfolding MI_def TI_def by (rule J.natural_extension(1))
   have "I.mpt_factor projI MJ TJ" unfolding projI_def
     using I.mpt_factorE(1) J.natural_extension(3) MI_def TI_def by auto
   then have [simp]: "projI \<in> measure_preserving MI MJ" using I.mpt_factorE(1) by auto
   then have [measurable]: "projI \<in> measurable MI MJ" by (simp add: measure_preservingE(1))
   have "I.invertible_qmpt"
     using J.natural_extension(2) MI_def TI_def by auto
 
   text \<open>We define a natural subcocycle $uI$ there, and check its properties.\<close>
 
   define uI where uI_proj: "uI = (\<lambda>n x. uJ n (projI x))"
   have [measurable]: "uI n \<in> borel_measurable MI" for n unfolding uI_proj by auto
   have uI_int: "integrable MI (uI n)" for n
     unfolding uI_proj by (rule measure_preserving_preserves_integral(1)[OF \<open>projI \<in> measure_preserving MI MJ\<close> uJ_int])
   have "(\<integral>x. uJ n x \<partial>MJ) = (\<integral>x. uI n x \<partial>MI)" for n
     unfolding uI_proj by (rule measure_preserving_preserves_integral(2)[OF \<open>projI \<in> measure_preserving MI MJ\<close> uJ_int])
   then have uI_int2: "(\<integral>x. uI n x \<partial>MI) = (\<integral>x. u n x \<partial>M)" for n
     using uJ_int2 by simp
   have uI_AE: "AE x in MI. uI (n+m) x \<le> uI n x + uI m (((TI)^^n) x)" for m n
   proof -
     have "AE x in MI. uJ (n+m) (projI x) \<le> uJ n (projI x) + uJ m (((TJ)^^n) (projI x))"
       apply (rule quasi_measure_preserving_AE[OF measure_preserving_is_quasi_measure_preserving[OF \<open>projI \<in> measure_preserving MI MJ\<close>]])
       using uJ_AE by auto
     moreover have "AE x in MI. ((TJ)^^n) (projI x) = projI (((TI)^^n) x)"
       using I.qmpt_factor_iterates[OF I.mpt_factor_is_qmpt_factor[OF \<open>I.mpt_factor projI MJ TJ\<close>]]
       by auto
     ultimately show ?thesis unfolding uI_proj by auto
   qed
   have uI_0: "AE x in MI. (\<lambda>n. uI n x / n) \<longlonglongrightarrow> 0"
     unfolding uI_proj
     apply (rule quasi_measure_preserving_AE[OF measure_preserving_is_quasi_measure_preserving[OF \<open>projI \<in> measure_preserving MI MJ\<close>]])
     using uJ_0 by simp
 
   text \<open>As $uI$ is only a subcocycle almost everywhere, we correct it to get a genuine subcocycle,
         to which we will apply Lemma \verb+upper_density_good_direction_invertible+.\<close>
 
   obtain vI where H: "I.subcocycle vI" "AE x in MI. \<forall>n. vI n x = uI n x"
     using I.subcocycle_AE[OF uI_AE uI_int] by blast
   have [measurable]: "\<And>n. vI n \<in> borel_measurable MI" "\<And>n. integrable MI (vI n)"
     using I.subcocycle_integrable[OF H(1)] by auto
   have "(\<integral>x. vI n x \<partial>MI) = (\<integral>x. uI n x \<partial>MI)" for n
     apply (rule integral_cong_AE) using H(2) by auto
   then have "(\<integral>x. vI n x \<partial>MI) = (\<integral>x. u n x \<partial>M)" for n
     using uI_int2 by simp
   then have "I.subcocycle_avg_ereal vI = subcocycle_avg_ereal u"
     unfolding I.subcocycle_avg_ereal_def subcocycle_avg_ereal_def by auto
   then have vI_fin: "I.subcocycle_avg_ereal vI > -\<infinity>" using subu_fin by simp
   have "AE x in MI. (\<lambda>n. vI n x / n) \<longlonglongrightarrow> 0"
     using uI_0 H(2) by auto
   moreover have "AE x in MI. (\<lambda>n. vI n x / n) \<longlonglongrightarrow> I.subcocycle_lim vI x"
     by (rule I.kingman_theorem_nonergodic(1)[OF H(1) vI_fin])
   ultimately have vI_0: "AE x in MI. I.subcocycle_lim vI x = 0"
     using LIMSEQ_unique by auto
 
   interpret GKK: Gouezel_Karlsson_Kingman MI TI vI
     apply standard
     using H(1) vI_fin vI_0 by auto
   obtain delta where delta: "\<And>l. delta l > 0" "delta \<longlonglongrightarrow> 0"
       "emeasure MI {x \<in> space MI. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < vI n x - vI (n - l) ((TI ^^ l) x)} \<ge> 1 - d } \<ge> 1 - d"
     using GKK.upper_density_good_direction_invertible[OF \<open>I.invertible_qmpt\<close> \<open>d>0\<close> \<open>d\<le>1\<close>] by blast
 
   text \<open>Then, we need to go back to the original system, showing that the estimates for $TI$ carry
         over. First, we go to $TJ$.\<close>
 
   have BJ: "emeasure MJ {x \<in> space MJ. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < uJ n x - uJ (n - l) ((TJ ^^ l) x)} \<ge> 1 - d } \<ge> 1 - d"
   proof -
     have *: "AE x in MI. uJ n (projI x) = vI n x" for n
       using uI_proj H(2) by auto
     have **: "AE x in MI. \<forall>n. uJ n (projI x) = vI n x"
       by (subst AE_all_countable, auto intro: *)
     have "AE x in MI. \<forall>m n. uJ n (projI ((TI^^m) x)) = vI n ((TI^^m) x)"
       by (rule I.T_AE_iterates[OF **])
     then have "AE x in MI. (\<forall>m n. uJ n (projI ((TI^^m) x)) = vI n ((TI^^m) x)) \<and> (\<forall>n. projI ((TI^^n) x) = (TJ^^n) (projI x))"
       using I.qmpt_factor_iterates[OF I.mpt_factor_is_qmpt_factor[OF \<open>I.mpt_factor projI MJ TJ\<close>]] by auto
     then obtain ZI where ZI: "\<And>x. x \<in> space MI - ZI \<Longrightarrow> (\<forall>m n. uJ n (projI ((TI^^m) x)) = vI n ((TI^^m) x)) \<and> (\<forall>n. projI ((TI^^n) x) = (TJ^^n) (projI x))"
                              "ZI \<in> null_sets MI"
       using AE_E3 by blast
 
     have *: "uJ n (projI x) - uJ (n - l) ((TJ ^^ l) (projI x)) = vI n x - vI (n - l) ((TI ^^ l) x)" if "x \<in> space MI - ZI" for x n l
     proof -
       have "(TI^^0) x = x" "(TJ^^0) (projI x) = (projI x)" by auto
       then show ?thesis using ZI(1)[OF that] by metis
     qed
     have "projI-`{x \<in> space MJ. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < uJ n x - uJ (n - l) ((TJ ^^ l) x)} \<ge> 1 - d} \<inter> space MI - ZI
           = {x \<in> space MI - ZI. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < uJ n (projI x) - uJ (n - l) ((TJ ^^ l) (projI x))} \<ge> 1 - d}"
       by (auto simp add: measurable_space[OF \<open>projI \<in> measurable MI MJ\<close>])
     also have "... = {x \<in> space MI - ZI. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < vI n x - vI (n - l) ((TI ^^ l) x)} \<ge> 1 - d}"
       using * by auto
     also have "... = {x \<in> space MI. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < vI n x - vI (n - l) ((TI ^^ l) x)} \<ge> 1 - d} - ZI"
       by auto
     finally have *: "projI-`{x \<in> space MJ. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < uJ n x - uJ (n - l) ((TJ ^^ l) x)} \<ge> 1 - d} \<inter> space MI - ZI
       = {x \<in> space MI. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < vI n x - vI (n - l) ((TI ^^ l) x)} \<ge> 1 - d} - ZI"
       by simp
 
     have "emeasure MJ {x \<in> space MJ. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < uJ n x - uJ (n - l) ((TJ ^^ l) x)} \<ge> 1 - d}
           = emeasure MI (projI-`{x \<in> space MJ. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < uJ n x - uJ (n - l) ((TJ ^^ l) x)} \<ge> 1 - d} \<inter> space MI)"
       by (rule measure_preservingE(2)[symmetric], auto)
     also have "... = emeasure MI ((projI-`{x \<in> space MJ. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < uJ n x - uJ (n - l) ((TJ ^^ l) x)} \<ge> 1 - d} \<inter> space MI) - ZI)"
       by (rule emeasure_Diff_null_set[OF \<open>ZI \<in> null_sets MI\<close>, symmetric], measurable)
     also have "... = emeasure MI ({x \<in> space MI. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < vI n x - vI (n - l) ((TI ^^ l) x)} \<ge> 1 - d} - ZI)"
       using * by simp
     also have "... = emeasure MI {x \<in> space MI. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < vI n x - vI (n - l) ((TI ^^ l) x)} \<ge> 1 - d}"
       by (rule emeasure_Diff_null_set[OF \<open>ZI \<in> null_sets MI\<close>], measurable)
     also have "... \<ge> 1-d"
       using delta(3) by simp
     finally show ?thesis by simp
   qed
 
   text \<open>Then, we go back to $T$ with virtually the same argument.\<close>
 
   have "emeasure M {x \<in> space M. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < u n x - u (n - l) ((T ^^ l) x)} \<ge> 1 - d } \<ge> 1 - d"
   proof -
       obtain Z where Z: "\<And>x. x \<in> space M - Z \<Longrightarrow> (\<forall>n. projJ ((T^^n) x) = (TJ^^n) (projJ x))"
                         "Z \<in> null_sets M"
       using AE_E3[OF qmpt_factor_iterates[OF mpt_factor_is_qmpt_factor[OF \<open>mpt_factor projJ MJ TJ\<close>]]] by blast
 
     have *: "uJ n (projJ x) - uJ (n - l) ((TJ ^^ l) (projJ x)) = u n x - u (n - l) ((T^^ l) x)" if "x \<in> space M - Z" for x n l
     proof -
       have "(T^^0) x = x" "(TJ^^0) (projJ x) = (projJ x)" by auto
       then show ?thesis using Z(1)[OF that] uJ_proj by metis
     qed
     have "projJ-`{x \<in> space MJ. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < uJ n x - uJ (n - l) ((TJ ^^ l) x)} \<ge> 1 - d} \<inter> space M - Z
           = {x \<in> space M - Z. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < uJ n (projJ x) - uJ (n - l) ((TJ ^^ l) (projJ x))} \<ge> 1 - d}"
       by (auto simp add: measurable_space[OF \<open>projJ \<in> measurable M MJ\<close>])
     also have "... = {x \<in> space M - Z. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < u n x - u (n - l) ((T ^^ l) x)} \<ge> 1 - d}"
       using * by auto
     also have "... = {x \<in> space M. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < u n x - u (n - l) ((T ^^ l) x)} \<ge> 1 - d} - Z"
       by auto
     finally have *: "projJ-`{x \<in> space MJ. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < uJ n x - uJ (n - l) ((TJ ^^ l) x)} \<ge> 1 - d} \<inter> space M - Z
       = {x \<in> space M. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < u n x - u (n - l) ((T ^^ l) x)} \<ge> 1 - d} - Z"
       by simp
 
     have "emeasure MJ {x \<in> space MJ. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < uJ n x - uJ (n - l) ((TJ ^^ l) x)} \<ge> 1 - d}
         = emeasure M (projJ-`{x \<in> space MJ. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < uJ n x - uJ (n - l) ((TJ ^^ l) x)} \<ge> 1 - d} \<inter> space M)"
       by (rule measure_preservingE(2)[symmetric], auto)
     also have "... = emeasure M ((projJ-`{x \<in> space MJ. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < uJ n x - uJ (n - l) ((TJ ^^ l) x)} \<ge> 1 - d} \<inter> space M) - Z)"
       by (rule emeasure_Diff_null_set[OF \<open>Z \<in> null_sets M\<close>, symmetric], measurable)
     also have "... = emeasure M ({x \<in> space M. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < u n x - u (n - l) ((T ^^ l) x)} \<ge> 1 - d} - Z)"
       using * by simp
     also have "... = emeasure M {x \<in> space M. upper_asymptotic_density {n. \<forall>l\<in>{1..n}. - delta l * real l < u n x - u (n - l) ((T ^^ l) x)} \<ge> 1 - d}"
       by (rule emeasure_Diff_null_set[OF \<open>Z \<in> null_sets M\<close>], measurable)
     finally show ?thesis using BJ by simp
   qed
   then show ?thesis using delta(1) delta(2) by auto
 qed
 
 text \<open>From the quantitative lemma above, we deduce the qualitative statement we are after,
 still in the setting of the locale.\<close>
 
 lemma infinite_AE:
   shows "AE x in M. \<exists>delta::nat\<Rightarrow>real. (\<forall>l. delta l > 0) \<and> (delta \<longlonglongrightarrow> 0) \<and>
           (infinite {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l})"
 proof -
   have "\<exists>deltaf::real \<Rightarrow> nat \<Rightarrow> real. \<forall>d. ((d > 0 \<and> d \<le> 1) \<longrightarrow> ((\<forall>l. deltaf d l > 0) \<and> (deltaf d \<longlonglongrightarrow> 0) \<and>
         emeasure M {x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - (deltaf d l) * l} \<ge> 1-d} \<ge> ennreal(1-d)))"
     apply (subst choice_iff'[symmetric]) using upper_density_good_direction by auto
   then obtain deltaf::"real \<Rightarrow> nat \<Rightarrow> real" where H: "\<And>d. d > 0 \<and> d \<le>1 \<Longrightarrow> (\<forall>l. deltaf d l > 0) \<and> (deltaf d \<longlonglongrightarrow> 0) \<and>
       emeasure M {x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - (deltaf d l) * l} \<ge> 1-d} \<ge> ennreal(1-d)"
     by blast
 
   define U where "U = (\<lambda>d. {x \<in> space M. upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - (deltaf d l) * l} \<ge> 1-d})"
   have [measurable]: "U d \<in> sets M" for d
     unfolding U_def by auto
   have *: "emeasure M (U d) \<ge> 1 - d" if "d>0 \<and> d\<le> 1" for d
     unfolding U_def using H that by auto
   define V where "V = (\<Union>n::nat. U (1/(n+2)))"
   have [measurable]: "V \<in> sets M"
     unfolding V_def by auto
   have a: "emeasure M V \<ge> 1 - 1 / (n + 2)" for n::nat
   proof -
     have "1 - 1 / (n + 2) = 1 - 1 / (real n + 2)"
       by auto
     also have "... \<le> emeasure M (U (1/(real n+2)))"
       using *[of "1 / (real n + 2)"] by auto
     also have "... \<le> emeasure M V"
       apply (rule Measure_Space.emeasure_mono) unfolding V_def by auto
     finally show ?thesis by simp
   qed
   have b: "(\<lambda>n::nat. 1 - 1 / (n + 2)) \<longlonglongrightarrow> ennreal(1 - 0)"
     by (intro tendsto_intros LIMSEQ_ignore_initial_segment)
   have "emeasure M V \<ge> 1 - 0"
     apply (rule Lim_bounded) using a b by auto
   then have "emeasure M V = 1"
     by (simp add: emeasure_ge_1_iff)
   then have "AE x in M. x \<in> V"
     by (simp add: emeasure_eq_measure prob_eq_1)
   moreover
   {
     fix x assume "x \<in> V"
     then obtain n::nat where "x \<in> U (1/(real n+2))" unfolding V_def by blast
     define d where "d = 1/(real n + 2)"
     have "0 < d" "d\<le>1" unfolding d_def by auto
     have "0 < 1-d" unfolding d_def by auto
     also have "... \<le> upper_asymptotic_density {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - (deltaf d l) * l}"
       using \<open>x \<in> U (1/(real n+2))\<close> unfolding U_def d_def by auto
     finally have "infinite {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - (deltaf d l) * l}"
       using upper_asymptotic_density_finite by force
     then have "\<exists>delta::nat\<Rightarrow>real. (\<forall>l. delta l > 0) \<and> (delta \<longlonglongrightarrow> 0) \<and>
           (infinite {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) > - delta l * l})"
       using H \<open>0 < d\<close> \<open>d\<le>1\<close> by auto
   }
   ultimately show ?thesis by auto
 qed
 
 end
 
 text \<open>Finally, we obtain the full statement, by reducing to the previous situation where the
 asymptotic average vanishes.\<close>
 
 theorem (in pmpt) Gouezel_Karlsson_Kingman:
   assumes "subcocycle u" "subcocycle_avg_ereal u > -\<infinity>"
   shows "AE x in M. \<exists>delta::nat\<Rightarrow>real. (\<forall>l. delta l > 0) \<and> (delta \<longlonglongrightarrow> 0) \<and>
           (infinite {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x > - delta l * l})"
 proof -
   have [measurable]: "integrable M (u n)" "u n \<in> borel_measurable M" for n
     using subcocycle_integrable[OF assms(1)] by auto
 
   define v where "v = birkhoff_sum (\<lambda>x. -subcocycle_lim u x)"
   have int [measurable]: "integrable M (\<lambda>x. -subcocycle_lim u x)"
     using kingman_theorem_nonergodic(2)[OF assms] by auto
   have "subcocycle v" unfolding v_def
     apply (rule subcocycle_birkhoff)
     using assms \<open>integrable M (\<lambda>x. -subcocycle_lim u x)\<close> unfolding subcocycle_def by auto
   have "subcocycle_avg_ereal v > - \<infinity>"
     unfolding v_def using subcocycle_avg_ereal_birkhoff[OF int] kingman_theorem_nonergodic(2)[OF assms] by auto
   have "AE x in M. subcocycle_lim v x = real_cond_exp M Invariants (\<lambda>x. -subcocycle_lim u x) x"
     unfolding v_def by (rule subcocycle_lim_birkhoff[OF int])
   moreover have "AE x in M. real_cond_exp M Invariants (\<lambda>x. - subcocycle_lim u x) x = - subcocycle_lim u x"
     by (rule real_cond_exp_F_meas[OF int], auto)
   ultimately have AEv: "AE x in M. subcocycle_lim v x = - subcocycle_lim u x"
     by auto
 
   define w where "w = (\<lambda>n x. u n x + v n x)"
   have a: "subcocycle w"
     unfolding w_def by (rule subcocycle_add[OF assms(1) \<open>subcocycle v\<close>])
   have b: "subcocycle_avg_ereal w > -\<infinity>"
     unfolding w_def by (rule subcocycle_avg_add(1)[OF assms(1) \<open>subcocycle v\<close> assms(2) \<open>subcocycle_avg_ereal v > - \<infinity>\<close>])
   have "AE x in M. subcocycle_lim w x = subcocycle_lim u x + subcocycle_lim v x"
     unfolding w_def by (rule subcocycle_lim_add[OF assms(1) \<open>subcocycle v\<close> assms(2) \<open>subcocycle_avg_ereal v > - \<infinity>\<close>])
   then have c: "AE x in M. subcocycle_lim w x = 0"
     using AEv by auto
 
   interpret Gouezel_Karlsson_Kingman M T w
     apply standard using a b c by auto
   have "AE x in M. \<exists>delta::nat\<Rightarrow>real. (\<forall>l. delta l > 0) \<and> (delta \<longlonglongrightarrow> 0) \<and>
           (infinite {n. \<forall>l \<in> {1..n}. w n x - w (n-l) ((T^^l) x) > - delta l * l})"
     using infinite_AE by auto
   moreover
   {
     fix x assume H: "\<exists>delta::nat\<Rightarrow>real. (\<forall>l. delta l > 0) \<and> (delta \<longlonglongrightarrow> 0) \<and>
           (infinite {n. \<forall>l \<in> {1..n}. w n x - w (n-l) ((T^^l) x) > - delta l * l})"
             "x \<in> space M"
     have *: "v n x = - n * subcocycle_lim u x" for n
       unfolding v_def using birkhoff_sum_of_invariants[OF _ \<open>x \<in> space M\<close>] by auto
     have **: "v n ((T^^l) x) = - n * subcocycle_lim u x" for n l
     proof -
       have "v n ((T^^l) x) = - n * subcocycle_lim u ((T^^l) x)"
         unfolding v_def using birkhoff_sum_of_invariants[OF _ T_spaceM_stable(2)[OF \<open>x \<in> space M\<close>]] by auto
       also have "... = - n * subcocycle_lim u x"
         using Invariants_func_is_invariant_n[OF subcocycle_lim_meas_Inv(2) \<open>x \<in> space M\<close>] by auto
       finally show ?thesis by simp
     qed
     have "w n x - w (n-l) ((T^^l) x) = u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x" if "l \<in> {1..n}" for n l
       unfolding w_def using *[of n] **[of "n-l" l] that apply (auto simp add: algebra_simps)
       by (metis comm_semiring_class.distrib diff_add_inverse nat_le_iff_add of_nat_add)
     then have "\<exists>delta::nat\<Rightarrow>real. (\<forall>l. delta l > 0) \<and> (delta \<longlonglongrightarrow> 0) \<and>
           (infinite {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x > - delta l * l})"
       using H(1) by auto
   }
   ultimately show ?thesis by auto
 qed
 
 text \<open>The previous theorem only contains a lower bound. The corresponding upper bound follows
 readily from Kingman's theorem. The next statement combines both upper and lower bounds.\<close>
 
 theorem (in pmpt) Gouezel_Karlsson_Kingman':
   assumes "subcocycle u" "subcocycle_avg_ereal u > -\<infinity>"
   shows "AE x in M. \<exists>delta::nat\<Rightarrow>real. (\<forall>l. delta l > 0) \<and> (delta \<longlonglongrightarrow> 0) \<and>
           (infinite {n. \<forall>l \<in> {1..n}. abs(u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x) < delta l * l})"
 proof -
   {
     fix x assume x: "\<exists>delta::nat\<Rightarrow>real. (\<forall>l. delta l > 0) \<and> (delta \<longlonglongrightarrow> 0) \<and>
           (infinite {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x > - delta l * l})"
                     "(\<lambda>l. u l x/l) \<longlonglongrightarrow> subcocycle_lim u x"
     then obtain alpha::"nat \<Rightarrow> real" where a: "\<And>l. alpha l > 0" "alpha \<longlonglongrightarrow> 0"
         "infinite {n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x > - alpha l * l}"
       by auto
     define delta::"nat \<Rightarrow> real" where "delta = (\<lambda>l. alpha l + norm(u l x / l - subcocycle_lim u x))"
     {
       fix n assume *: "\<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x > - alpha l * l"
       have H: "x > -a \<Longrightarrow> x < a \<Longrightarrow> abs x < a" for a x::real by simp
       have "abs(u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x) < delta l * l" if "l\<in>{1..n}" for l
       proof (rule H)
         have "u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x \<le> u l x - l * subcocycle_lim u x"
           using assms(1) subcocycle_ineq[OF assms(1), of l "n-l" x] that by auto
         also have "... \<le> l * norm(u l x/l - subcocycle_lim u x)"
           using that by (auto simp add: algebra_simps divide_simps)
         also have "... < delta l * l"
           unfolding delta_def using a(1)[of l] that by auto
         finally show "u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x < delta l * l" by simp
 
         have "- (delta l * l) \<le> -alpha l * l"
           unfolding delta_def by (auto simp add: algebra_simps)
         also have "... < u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x"
           using * that by auto
         finally show "u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x > -(delta l * l)"
           by simp
       qed
       then have "\<forall>l \<in> {1..n}. abs(u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x) < delta l * l"
         by auto
     }
     then have "{n. \<forall>l \<in> {1..n}. u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x > - alpha l * l}
           \<subseteq> {n. \<forall>l \<in> {1..n}. abs(u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x) < delta l * l}"
       by auto
     then have "infinite {n. \<forall>l \<in> {1..n}. abs(u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x) < delta l * l}"
       using a(3) finite_subset by blast
     moreover have "delta \<longlonglongrightarrow> 0 + 0"
       unfolding delta_def using x(2) by (intro tendsto_intros a(2) tendsto_norm_zero LIM_zero)
     moreover have "delta l > 0" for l unfolding delta_def using a(1)[of l] by auto
     ultimately have "\<exists>delta::nat\<Rightarrow>real. (\<forall>l. delta l > 0) \<and> (delta \<longlonglongrightarrow> 0) \<and>
           (infinite {n. \<forall>l \<in> {1..n}. abs(u n x - u (n-l) ((T^^l) x) - l * subcocycle_lim u x) < delta l * l})"
       by auto
   }
   then show ?thesis
     using Gouezel_Karlsson_Kingman[OF assms] kingman_theorem_nonergodic(1)[OF assms] by auto
 qed
 
 end (*of Gouezel_Karlsson.thy*)
diff --git a/thys/Ergodic_Theory/Invariants.thy b/thys/Ergodic_Theory/Invariants.thy
--- a/thys/Ergodic_Theory/Invariants.thy
+++ b/thys/Ergodic_Theory/Invariants.thy
@@ -1,1795 +1,1795 @@
 (*  Author:  Sébastien Gouëzel   sebastien.gouezel@univ-rennes1.fr
     License: BSD
 *)
 
 section \<open>The invariant sigma-algebra, Birkhoff theorem\<close>
 
 theory Invariants
   imports Recurrence "HOL-Probability.Conditional_Expectation"
 begin
 
 subsection \<open>The sigma-algebra of invariant subsets\<close>
 
 text \<open>The invariant sigma-algebra of a qmpt is made of those sets that are invariant under the
 dynamics. When the transformation is ergodic, it is made of sets of zero or full measure. In
 general, the Birkhoff theorem is expressed in terms of the conditional expectation of an integrable
 function with respect to the invariant sigma-algebra.\<close>
 
 context qmpt begin
 
 text \<open>We define the invariant sigma-algebra, as the sigma algebra of sets which are invariant
 under the dynamics, i.e., they coincide with their preimage under $T$.\<close>
 
 definition Invariants where "Invariants = sigma (space M) {A \<in> sets M. T-`A \<inter> space M = A}"
 
 text \<open>For this definition to make sense, we need to check that it really defines a sigma-algebra:
 otherwise, the \verb+sigma+ operation would make garbage out of it. This is the content of the next
 lemma.\<close>
 
 lemma Invariants_sets: "sets Invariants = {A \<in> sets M. T-`A \<inter> space M = A}"
 proof -
   have "sigma_algebra (space M) {A \<in> sets M. T-`A \<inter> space M = A}"
   proof -
     define I where "I = {A. T-`A \<inter> space M = A}"
     have i: "\<And>A. A \<in> I \<Longrightarrow> A \<subseteq> space M" unfolding I_def by auto
     have "algebra (space M) I"
     proof (subst algebra_iff_Un)
       have a: "I \<subseteq> Pow (space M)" using i by auto
       have b: "{} \<in> I" unfolding I_def by auto
       {
         fix A assume *: "A \<in> I"
         then have "T-`(space M - A) = T-`(space M) - T-`A" by auto
         then have "T-`(space M - A) \<inter> space M = T-`(space M) \<inter> (space M) - T-`A \<inter> (space M)" by auto
         also have "... = space M - A" using * I_def by (simp add: inf_absorb2 subsetI)
         finally have "space M - A \<in> I" unfolding I_def by simp
       }
       then have c: "(\<forall>a\<in>I. space M - a \<in> I)" by simp
       have d: "(\<forall>a\<in>I. \<forall>b\<in>I. a \<union> b \<in> I)" unfolding I_def by auto
       show "I \<subseteq> Pow (space M) \<and> {} \<in> I \<and> (\<forall>a\<in>I. space M - a \<in> I) \<and> (\<forall>a\<in>I. \<forall>b\<in>I. a \<union> b \<in> I)"
         using a b c d by blast
     qed
     moreover have "(\<forall>F. range F \<subseteq> I \<longrightarrow> (\<Union>i::nat. F i) \<in> I)" unfolding I_def by auto
     ultimately have "sigma_algebra (space M) I" using sigma_algebra_iff by auto
     moreover have "sigma_algebra (space M) (sets M)" using measure_space measure_space_def by auto
     ultimately have "sigma_algebra (space M) (I \<inter> (sets M))" using sigma_algebra_intersection by auto
     moreover have "I \<inter> sets M = {A \<in> sets M. T-`A \<inter> space M = A}" unfolding I_def by auto
     ultimately show ?thesis by simp
   qed
   then show ?thesis unfolding Invariants_def using sigma_algebra.sets_measure_of_eq by blast
 qed
 
 text \<open>By definition, the invariant subalgebra is a subalgebra of the original algebra. This is
 expressed in the following lemmas.\<close>
 
 lemma Invariants_is_subalg: "subalgebra M Invariants"
   unfolding subalgebra_def
   using Invariants_sets Invariants_def by (simp add: space_measure_of_conv)
 
 lemma Invariants_in_sets:
   assumes "A \<in> sets Invariants"
   shows "A \<in> sets M"
 using Invariants_sets assms by blast
 
 lemma Invariants_measurable_func:
   assumes "f \<in> measurable Invariants N"
   shows "f \<in> measurable M N"
 using Invariants_is_subalg measurable_from_subalg assms by auto
 
 text \<open>We give several trivial characterizations of invariant sets or functions.\<close>
 
 lemma Invariants_vrestr:
   assumes "A \<in> sets Invariants"
   shows "T--`A = A"
 using assms Invariants_sets Invariants_in_sets[OF assms] by auto
 
 lemma Invariants_points:
   assumes "A \<in> sets Invariants" "x \<in> A"
   shows "T x \<in> A"
 using assms Invariants_sets by auto
 
 lemma Invariants_func_is_invariant:
   fixes f::"_ \<Rightarrow> 'b::t2_space"
   assumes "f \<in> borel_measurable Invariants" "x \<in> space M"
   shows "f (T x) = f x"
 proof -
   have "{f x} \<in> sets borel" by simp
   then have "f-`({f x}) \<inter> space M \<in> Invariants" using assms(1)
     by (metis (no_types, lifting) Invariants_def measurable_sets space_measure_of_conv)
   moreover have "x \<in> f-`({f x}) \<inter> space M" using assms(2) by blast
   ultimately have "T x \<in> f-`({f x}) \<inter> space M" by (rule Invariants_points)
   then show ?thesis by simp
 qed
 
 lemma Invariants_func_is_invariant_n:
   fixes f::"_ \<Rightarrow> 'b::t2_space"
   assumes "f \<in> borel_measurable Invariants" "x \<in> space M"
   shows "f ((T^^n) x) = f x"
 by (induction n, auto simp add: assms Invariants_func_is_invariant)
 
 lemma Invariants_func_charac:
   assumes [measurable]: "f \<in> measurable M N"
       and "\<And>x. x \<in> space M \<Longrightarrow> f(T x) = f x"
   shows "f \<in> measurable Invariants N"
 proof (rule measurableI)
   fix A assume "A \<in> sets N"
   have "space Invariants = space M" using Invariants_is_subalg subalgebra_def by force
   show "f -` A \<inter> space Invariants \<in> sets Invariants"
     apply (subst Invariants_sets)
     apply (auto simp add: assms \<open>A \<in> sets N\<close> \<open>space Invariants = space M\<close>)
     using \<open>A \<in> sets N\<close> assms(1) measurable_sets by blast
 next
   fix x assume "x \<in> space Invariants"
   have "space Invariants = space M" using Invariants_is_subalg subalgebra_def by force
   then show "f x \<in> space N" using assms(1) \<open>x \<in> space Invariants\<close> by (metis measurable_space)
 qed
 
 lemma birkhoff_sum_of_invariants:
   fixes f::" _ \<Rightarrow> real"
   assumes "f \<in> borel_measurable Invariants" "x \<in> space M"
   shows "birkhoff_sum f n x = n * f x"
 unfolding birkhoff_sum_def using Invariants_func_is_invariant_n[OF assms] by auto
 
 text \<open>There are two possible definitions of the invariant sigma-algebra, competing in the
 literature: one could also use the sets such that $T^{-1}A$ coincides with $A$ up to
 a measure $0$ set. It turns out that this is equivalent to being invariant (in our sense) up
 to a measure $0$ set. Therefore, for all interesting purposes, the two definitions would
 give the same results.
 
 For the proof, we start from an almost invariant set, and build a genuinely invariant set that
 coincides with it by adding or throwing away null parts.
 \<close>
 
 proposition Invariants_quasi_Invariants_sets:
   assumes [measurable]: "A \<in> sets M"
   shows "(\<exists>B \<in> sets Invariants. A \<Delta> B \<in> null_sets M) \<longleftrightarrow> (T--`A \<Delta> A \<in> null_sets M)"
 proof
   assume "\<exists>B \<in> sets Invariants. A \<Delta> B \<in> null_sets M"
   then obtain B where "B \<in> sets Invariants" "A \<Delta> B \<in> null_sets M" by auto
   then have [measurable]: "B \<in> sets M" using Invariants_in_sets by simp
 
   have "B = T--` B" using Invariants_vrestr \<open>B \<in> sets Invariants\<close> by simp
   then have "T--`A \<Delta> B = T--`(A \<Delta> B)" by simp
   moreover have "T--`(A \<Delta> B) \<in> null_sets M"
     by (rule T_quasi_preserves_null2(1)[OF \<open>A \<Delta> B \<in> null_sets M\<close>])
   ultimately have "T--`A \<Delta> B \<in> null_sets M" by simp
   then show "T--`A \<Delta> A \<in> null_sets M"
     by (rule null_sym_diff_transitive) (auto simp add: \<open>A \<Delta> B \<in> null_sets M\<close> Un_commute)
 next
   assume H: "T --` A \<Delta> A \<in> null_sets M"
   have [measurable]: "\<And>n. (T^^n)--`A \<in> sets M" by simp
   {
     fix K assume [measurable]: "K \<in> sets M" and "T--`K \<Delta> K \<in> null_sets M"
     fix n::nat
     have "(T^^n)--`K \<Delta> K \<in> null_sets M"
     proof (induction n)
       case 0
       have "(T^^0)--` K = K" using T_vrestr_0 by simp
       then show ?case using Diff_cancel sup.idem by (metis null_sets.empty_sets)
     next
       case (Suc n)
       have "T--`((T^^n)--`K \<Delta> K) \<in> null_sets M"
         using Suc.IH T_quasi_preserves_null(1)[of "((T^^n)--`K \<Delta> K)"] by simp
       then have *: "(T^^(Suc n))--`K \<Delta> T--`K \<in> null_sets M" using T_vrestr_composed(2)[OF \<open>K \<in> sets M\<close>] by simp
       then show ?case
         by (rule null_sym_diff_transitive, simp add: \<open>T--`K \<Delta> K \<in> null_sets M\<close> \<open>K \<in> sets M\<close>, measurable)
     qed
   } note * = this
 
   define C where "C = (\<Inter>n. (T^^n)--`A)"
   have [measurable]: "C \<in> sets M" unfolding C_def by simp
   have "C \<Delta> A \<subseteq> (\<Union>n. (T^^n)--`A \<Delta> A)" unfolding C_def by auto
   moreover have "(\<Union>n. (T^^n)--`A \<Delta> A) \<in> null_sets M"
     using * null_sets_UN assms \<open>T --` A \<Delta> A \<in> null_sets M\<close> by auto
   ultimately have CA: "C \<Delta> A \<in> null_sets M" by (meson \<open>C \<in> sets M\<close> assms sets.Diff sets.Un null_sets_subset)
   then have "T--`(C \<Delta> A) \<in> null_sets M" by (rule T_quasi_preserves_null2(1))
   then have "T--`C \<Delta> T--`A \<in> null_sets M" by simp
   then have "T--`C \<Delta> A \<in> null_sets M"
     by (rule null_sym_diff_transitive, auto simp add: H)
   then have TCC: "T--`C \<Delta> C \<in> null_sets M"
     apply (rule null_sym_diff_transitive) using CA by (auto simp add: Un_commute)
 
   have "C \<subseteq> (\<Inter>n\<in>{1..}. (T^^n)--`A)" unfolding C_def by auto
   moreover have "T--`C = (\<Inter>n\<in>{1..}. (T^^n)--`A)"
     using T_vrestr_composed(2)[OF assms] by (simp add: C_def atLeast_Suc_greaterThan greaterThan_0)
   ultimately have "C \<subseteq> T--`C" by blast
   then have "(T^^0)--`C \<subseteq> (T^^1)--`C" using T_vrestr_0 by auto
   moreover have "(T^^1)--`C \<subseteq> (\<Union>n\<in>{1..}. (T^^n)--`C)" by auto
   ultimately have "(T^^0)--`C \<subseteq> (\<Union>n\<in>{1..}. (T^^n)--`C)" by auto
   then have "(T^^0)--`C \<union> (\<Union>n\<in>{1..}. (T^^n)--`C) = (\<Union>n\<in>{1..}. (T^^n)--`C)" by auto
   moreover have "(\<Union>n. (T^^n)--`C) = (T^^0)--`C \<union> (\<Union>n\<in>{1..}. (T^^n)--`C)" by (rule union_insert_0)
   ultimately have C2: "(\<Union>n. (T^^n)--`C) = (\<Union>n\<in>{1..}. (T^^n)--`C)" by simp
 
   define B where "B = (\<Union>n. (T^^n)--`C)"
   have [measurable]: "B \<in> sets M" unfolding B_def by simp
   have "B \<Delta> C \<subseteq> (\<Union>n. (T^^n)--`C \<Delta> C)" unfolding B_def by auto
   moreover have "(\<Union>n. (T^^n)--`C \<Delta> C) \<in> null_sets M"
     using * null_sets_UN assms TCC by auto
   ultimately have "B \<Delta> C \<in> null_sets M" by (meson \<open>B \<in> sets M\<close> \<open>C \<in> sets M\<close> assms sets.Diff sets.Un null_sets_subset)
   then have "B \<Delta> A \<in> null_sets M"
     by (rule null_sym_diff_transitive, auto simp add: CA)
   then have a: "A \<Delta> B \<in> null_sets M" by (simp add: Un_commute)
 
   have "T--`B = (\<Union>n\<in>{1..}. (T^^n)--`C)"
     using T_vrestr_composed(2)[OF \<open>C \<in> sets M\<close>] by (simp add: B_def atLeast_Suc_greaterThan greaterThan_0)
   then have "T--`B = B" unfolding B_def using C2 by simp
   then have "B \<in> sets Invariants" using Invariants_sets vimage_restr_def by auto
 
   then show "\<exists>B \<in> sets Invariants. A \<Delta> B \<in> null_sets M" using a by blast
 qed
 
 text \<open>In a conservative setting, it is enough to be included in its image or its preimage to be
 almost invariant: otherwise, since the difference set has disjoint preimages, and is therefore
 null by conservativity.\<close>
 
 lemma (in conservative) preimage_included_then_almost_invariant:
   assumes [measurable]: "A \<in> sets M" and "T--`A \<subseteq> A"
   shows "A \<Delta> (T--`A) \<in> null_sets M"
 proof -
   define B where "B = A - T--`A"
   then have [measurable]: "B \<in> sets M" by simp
   have "(T^^(Suc n))--`A \<subseteq> (T^^n)--`A" for n using T_vrestr_composed(3)[OF assms(1)] vrestr_inclusion[OF assms(2)] by auto
   then have "disjoint_family (\<lambda>n. (T^^n)--`A - (T^^(Suc n))--`A)" by (rule disjoint_family_Suc2[where ?A = "\<lambda>n. (T^^n)--`A"])
   moreover have "(T^^n)--`A - (T^^(Suc n))--`A = (T^^n)--`B" for n unfolding B_def Suc_eq_plus1 using T_vrestr_composed(3)[OF assms(1)] by auto
   ultimately have "disjoint_family (\<lambda>n. (T^^n)--` B)" by simp
   then have "\<And>n. n \<noteq> 0 \<Longrightarrow> ((T^^n)--`B) \<inter> B = {}" unfolding disjoint_family_on_def by (metis UNIV_I T_vrestr_0(1)[OF \<open>B \<in> sets M\<close>])
   then have "\<And>n. n > 0 \<Longrightarrow> (T^^n)-`B \<inter> B = {}" unfolding vimage_restr_def by (simp add: Int_assoc)
   then have "B \<in> null_sets M" using disjoint_then_null[OF \<open>B \<in> sets M\<close>] Int_commute by auto
   then show ?thesis unfolding B_def using assms(2) by (simp add: Diff_mono Un_absorb2)
 qed
 
 lemma (in conservative) preimage_includes_then_almost_invariant:
   assumes [measurable]: "A \<in> sets M" and "A \<subseteq> T--`A"
   shows "A \<Delta> (T--`A) \<in> null_sets M"
 proof -
   define B where "B = T--`A - A"
   then have [measurable]: "B \<in> sets M" by simp
   have "\<And>n. (T^^(Suc n))--`A \<supseteq> (T^^n)--`A" using T_vrestr_composed(3)[OF assms(1)] vrestr_inclusion[OF assms(2)] by auto
   then have "disjoint_family (\<lambda>n. (T^^(Suc n))--`A - (T^^n)--`A)" by (rule disjoint_family_Suc[where ?A = "\<lambda>n. (T^^n)--`A"])
   moreover have "\<And>n. (T^^(Suc n))--`A - (T^^n)--`A = (T^^n)--`B" unfolding B_def Suc_eq_plus1 using T_vrestr_composed(3)[OF assms(1)] by auto
   ultimately have "disjoint_family (\<lambda>n. (T^^n)--` B)" by simp
   then have "\<And>n. n \<noteq> 0 \<Longrightarrow> ((T^^n)--`B) \<inter> B = {}" unfolding disjoint_family_on_def by (metis UNIV_I T_vrestr_0(1)[OF \<open>B \<in> sets M\<close>])
   then have "\<And>n. n > 0 \<Longrightarrow> (T^^n)-`B \<inter> B = {}" unfolding vimage_restr_def by (simp add: Int_assoc)
   then have "B \<in> null_sets M" using disjoint_then_null[OF \<open>B \<in> sets M\<close>] Int_commute by auto
   then show ?thesis unfolding B_def using assms(2) by (simp add: Diff_mono Un_absorb1)
 qed
 
 text \<open>The above properties for sets are also true for functions: if $f$ and $f \circ T$
 coincide almost everywhere, i.e., $f$ is almost invariant, then $f$ coincides almost everywhere
 with a true invariant function.
 
 The idea of the proof is straightforward: throw away the orbits on
 which $f$ is not really invariant (say this is the complement of the good set),
 and replace it by $0$ there. However, this does not work
 directly: the good set is not invariant, some points may have a non-constant value of $f$ on their
 orbit but reach the good set eventually. One can however define $g$ to be equal to the
 eventual value of $f$ along the orbit, if the orbit reaches the good set, and $0$ elsewhere.\<close>
 
 proposition Invariants_quasi_Invariants_functions:
   fixes f::"_ \<Rightarrow> 'b::{second_countable_topology, t2_space}"
   assumes f_meas [measurable]: "f \<in> borel_measurable M"
   shows "(\<exists>g \<in> borel_measurable Invariants. AE x in M. f x = g x) \<longleftrightarrow> (AE x in M. f(T x) = f x)"
 proof
   assume "\<exists>g\<in>borel_measurable Invariants. AE x in M. f x = g x"
   then obtain g where g:"g\<in>borel_measurable Invariants" "AE x in M. f x = g x" by blast
   then have [measurable]: "g \<in> borel_measurable M" using Invariants_measurable_func by auto
   define A where "A = {x \<in> space M. f x = g x}"
   have [measurable]: "A \<in> sets M" unfolding A_def by simp
   define B where "B = space M - A"
   have [measurable]: "B \<in> sets M" unfolding B_def by simp
   moreover have "AE x in M. x \<notin> B" unfolding B_def A_def using g(2) by auto
   ultimately have "B \<in> null_sets M" using AE_iff_null_sets by blast
   then have "T--`B \<in> null_sets M" by (rule T_quasi_preserves_null2(1))
   then have "B \<union> T--`B \<in> null_sets M" using \<open>B \<in> null_sets M\<close> by auto
   then have "AE x in M. x \<notin> (B \<union> T--`B)" using AE_iff_null_sets null_setsD2 by blast
   then have i: "AE x in M. x \<in> space M - (B \<union> T--`B)" by auto
   {
     fix x assume *: "x \<in> space M - (B \<union> T--`B)"
     then have "x \<in> A" unfolding B_def by blast
     then have "f x = g x" unfolding A_def by blast
     have "T x \<in> A" using * B_def by auto
     then have "f(T x) = g(T x)" unfolding A_def by blast
     moreover have "g(T x) = g x"
       apply (rule Invariants_func_is_invariant) using * by (auto simp add: assms \<open>g\<in>borel_measurable Invariants\<close>)
     ultimately have "f(T x) = f x" using \<open>f x = g x\<close> by simp
   }
   then show "AE x in M. f(T x) = f x" using i by auto
 next
   assume *: "AE x in M. f (T x) = f x"
   text \<open>\verb+good_set+ is the set of points for which $f$ is constant on their orbit. Here, we define
   $g = f$. If a point ever enters \verb+good_set+, then we take $g$ to be the value of $f$ there. Otherwise,
   $g$ takes an arbitrary value, say $y_0$.\<close>
   define good_set where "good_set = {x \<in> space M. \<forall>n. f((T^^(Suc n)) x) = f((T^^n) x)}"
   define good_time where "good_time = (\<lambda>x. Inf {n. (T^^n) x \<in> good_set})"
   have "AE x in M. x \<in> good_set" using T_AE_iterates[OF *] by (simp add: good_set_def)
   have [measurable]: "good_set \<in> sets M" unfolding good_set_def by auto
   obtain y0::'b where True by auto
   define g where "g = (\<lambda>x. if (\<exists>n. (T^^n) x \<in> good_set) then f((T^^(good_time x)) x) else y0)"
   have [measurable]: "good_time \<in> measurable M (count_space UNIV)" unfolding good_time_def by measurable
   have [measurable]: "g \<in> borel_measurable M" unfolding g_def by measurable
 
   have "f x = g x" if "x \<in> good_set" for x
   proof -
     have a: "0 \<in> {n. (T^^n) x \<in> good_set}" using that by simp
     have "good_time x = 0"
       unfolding good_time_def apply (intro cInf_eq_non_empty) using a by blast+
     moreover have "{n. (T^^n) x \<in> good_set} \<noteq> {}" using a by blast
     ultimately show "f x = g x" unfolding g_def by auto
   qed
   then have "AE x in M. f x = g x" using \<open>AE x in M. x \<in> good_set\<close> by auto
 
   have *: "f((T^^(Suc 0)) x) = f((T^^0) x)" if "x \<in> good_set" for x
     using that unfolding good_set_def by blast
   have good_1: "T x \<in> good_set \<and> f(T x) = f x" if "x \<in> good_set" for x
     using *[OF that] that unfolding good_set_def apply (auto)
     unfolding T_Tn_T_compose by blast
   then have good_k: "\<And>x. x \<in> good_set \<Longrightarrow> (T^^k) x \<in> good_set \<and> f((T^^k) x) = f x" for k
       by (induction k, auto)
 
   have "g(T x) = g x" if "x \<in> space M" for x
   proof (cases)
     assume *: "\<exists>n. (T^^n) (T x) \<in> good_set"
     define n where "n = Inf {n. (T^^n) (T x) \<in> good_set}"
     have "(T^^n)(T x) \<in> good_set" using * Inf_nat_def1 by (metis empty_iff mem_Collect_eq n_def)
     then have a: "(T^^(n+1)) x \<in> good_set" by (metis Suc_eq_plus1 comp_eq_dest_lhs funpow.simps(2) funpow_swap1)
     then have **: "\<exists>m. (T^^m) x \<in> good_set" by blast
     define m where "m = Inf {m. (T^^m) x \<in> good_set}"
     then have "(T^^m) x \<in> good_set" using ** Inf_nat_def1 by (metis empty_iff mem_Collect_eq)
     have "n+1 \<in> {m. (T^^m) x \<in> good_set}" using a by simp
     then have "m \<le> n+1" using m_def by (simp add: Inf_nat_def Least_le)
     then obtain k where "n+1 = m + k" using le_iff_add by blast
     have "g x = f((T^^m) x)" unfolding g_def good_time_def using ** m_def by simp
     also have "... = f((T^^k) ((T^^m) x))" using \<open>(T^^m) x \<in> good_set\<close> good_k by simp
     also have "... = f((T^^(n+1))x)" using \<open>n+1 = m + k\<close>[symmetric] funpow_add by (metis add.commute comp_apply)
     also have "... = f((T^^n) (T x))" using funpow_Suc_right by (metis Suc_eq_plus1 comp_apply)
     also have "... = g(T x)" unfolding g_def good_time_def using * n_def by simp
     finally show "g(T x) = g x" by simp
   next
     assume *: "\<not>(\<exists>n. (T^^n) (T x) \<in> good_set)"
     then have "g(T x) = y0" unfolding g_def by simp
     have **: "\<not>(\<exists>n. (T^^(Suc n)) x \<in> good_set)" using funpow_Suc_right * by (metis comp_apply)
     have "T x \<notin> good_set" using good_k * by blast
     then have "x \<notin> good_set" using good_1 by auto
     then have "\<not>(\<exists>n. (T^^n) x \<in> good_set)" using ** using good_1 by fastforce
     then have "g x = y0" unfolding g_def by simp
     then show "g(T x) = g x" using \<open>g(T x) = y0\<close> by simp
   qed
   then have "g \<in> borel_measurable Invariants" by (rule Invariants_func_charac[OF \<open>g \<in> borel_measurable M\<close>])
   then show "\<exists>g\<in>borel_measurable Invariants. AE x in M. f x = g x" using \<open>AE x in M. f x = g x\<close> by blast
 qed
 
 text \<open>In a conservative setting, it suffices to have an almost everywhere inequality to get
 an almost everywhere equality, as the set where there is strict inequality has $0$ measure
 as its iterates are disjoint, by conservativity.\<close>
 
 proposition (in conservative) AE_decreasing_then_invariant:
   fixes f::"_ \<Rightarrow> 'b::{linorder_topology, second_countable_topology}"
   assumes "AE x in M. f(T x) \<le> f x"
     and [measurable]: "f \<in> borel_measurable M"
   shows "AE x in M. f(T x) = f x"
 proof -
   obtain D::"'b set" where D: "countable D" "(\<forall>x y. x < y \<longrightarrow> (\<exists>d \<in> D. x \<le> d \<and> d < y))"
     using countable_separating_set_linorder2 by blast
 
   define A where "A = {x \<in> space M. f(T x) \<le> f x}"
   then have [measurable]: "A \<in> sets M" by simp
   define B where "B = {x \<in> space M. \<forall>n. f((T^^(n+1)) x) \<le> f((T^^n)x)}"
   then have [measurable]: "B \<in> sets M" by simp
 
   have "space M - A \<in> null_sets M" unfolding A_def using assms by (simp add: assms(1) AE_iff_null_sets)
   then have "(\<Union>n. (T^^n)--`(space M - A)) \<in> null_sets M" by (metis null_sets_UN T_quasi_preserves_null2(2))
   moreover have "space M - B = (\<Union>n. (T^^n)--`(space M - A))"
     unfolding B_def A_def by auto
   ultimately have "space M - B \<in> null_sets M" by simp
 
   have *: "B = (\<Inter>n. (T^^n)--`A)"
     unfolding B_def A_def by auto
   then have "T--`B = (\<Inter>n. T--` (T^^n)--`A)" by auto
   also have "... = (\<Inter>n. (T^^(n+1))--`A)" using T_vrestr_composed(2)[OF \<open>A \<in> sets M\<close>] by simp
   also have "... \<supseteq> (\<Inter>n. (T^^n)--`A)" by blast
   finally have B1: "B \<subseteq> T--`B" using * by simp
   have "B \<subseteq> A" using * T_vrestr_0[OF \<open>A \<in> sets M\<close>] by blast
   then have B2: "\<And>x. x \<in> B \<Longrightarrow> f(T x) \<le> f x" unfolding A_def by auto
 
   define C where "C = (\<lambda>t. {x \<in> B. f x \<le> t})"
   {
     fix t
     have "C t = B \<inter> f-`{..t} \<inter> space M" unfolding C_def using sets.sets_into_space[OF \<open>B \<in> sets M\<close>] by auto
     then have [measurable]: "C t \<in> sets M" using assms(2) by simp
     have "C t \<subseteq> T--`(C t)" using B1 unfolding C_def vimage_restr_def apply auto using B2 order_trans by blast
     then have "T--`(C t) - C t \<in> null_sets M" by (metis Diff_mono Un_absorb1 preimage_includes_then_almost_invariant[OF \<open>C t \<in> sets M\<close>])
   }
   then have "(\<Union>d\<in>D. T--`(C d) - C d) \<in> null_sets M" using \<open>countable D\<close> by (simp add: null_sets_UN')
   then have "(space M - B) \<union> (\<Union>d\<in>D. T--`(C d) - C d) \<in> null_sets M" using \<open>space M - B \<in> null_sets M\<close> by auto
   then have "AE x in M. x \<notin> (space M - B) \<union> (\<Union>d\<in>D. T--`(C d) - C d)" using AE_not_in by blast
   moreover
   {
     fix x assume x: "x \<in> space M" "x \<notin> (space M - B) \<union> (\<Union>d\<in>D. T--`(C d) - C d)"
     then have "x \<in> B" by simp
     then have "T x \<in> B" using B1 by auto
     have "f(T x) = f x"
     proof (rule ccontr)
       assume "f(T x) \<noteq> f x"
       then have "f(T x) < f x" using B2[OF \<open>x \<in> B\<close>] by simp
       then obtain d where d: "d \<in> D" "f(T x) \<le> d \<and> d < f x" using D by auto
       then have "T x \<in> C d" using \<open>T x \<in> B\<close> unfolding C_def by simp
       then have "x \<in> T--`(C d)" using \<open>x \<in> space M\<close> by simp
       then have "x \<in> C d" using x \<open>d \<in> D\<close> by simp
       then have "f x \<le> d" unfolding C_def by simp
       then show False using d by auto
     qed
   }
   ultimately show ?thesis by auto
 qed
 
 proposition (in conservative) AE_increasing_then_invariant:
   fixes f::"_ \<Rightarrow> 'b::{linorder_topology, second_countable_topology}"
   assumes "AE x in M. f(T x) \<ge> f x"
     and [measurable]: "f \<in> borel_measurable M"
   shows "AE x in M. f(T x) = f x"
 proof -
   obtain D::"'b set" where D: "countable D" "(\<forall>x y. x < y \<longrightarrow> (\<exists>d \<in> D. x < d \<and> d \<le> y))"
     using countable_separating_set_linorder1 by blast
 
   define A where "A = {x \<in> space M. f(T x) \<ge> f x}"
   then have [measurable]: "A \<in> sets M" by simp
   define B where "B = {x \<in> space M. \<forall>n. f((T^^(n+1)) x) \<ge> f((T^^n)x)}"
   then have [measurable]: "B \<in> sets M" by simp
 
   have "space M - A \<in> null_sets M" unfolding A_def using assms by (simp add: assms(1) AE_iff_null_sets)
   then have "(\<Union>n. (T^^n)--`(space M - A)) \<in> null_sets M" by (metis null_sets_UN T_quasi_preserves_null2(2))
   moreover have "space M - B = (\<Union>n. (T^^n)--`(space M - A))"
     unfolding B_def A_def by auto
   ultimately have "space M - B \<in> null_sets M" by simp
 
   have *: "B = (\<Inter>n. (T^^n)--`A)"
     unfolding B_def A_def by auto
   then have "T--`B = (\<Inter>n. T--` (T^^n)--`A)" by auto
   also have "... = (\<Inter>n. (T^^(n+1))--`A)" using T_vrestr_composed(2)[OF \<open>A \<in> sets M\<close>] by simp
   also have "... \<supseteq> (\<Inter>n. (T^^n)--`A)" by blast
   finally have B1: "B \<subseteq> T--`B" using * by simp
   have "B \<subseteq> A" using * T_vrestr_0[OF \<open>A \<in> sets M\<close>] by blast
   then have B2: "\<And>x. x \<in> B \<Longrightarrow> f(T x) \<ge> f x" unfolding A_def by auto
 
   define C where "C = (\<lambda>t. {x \<in> B. f x \<ge> t})"
   {
     fix t
     have "C t = B \<inter> f-`{t..} \<inter> space M" unfolding C_def using sets.sets_into_space[OF \<open>B \<in> sets M\<close>] by auto
     then have [measurable]: "C t \<in> sets M" using assms(2) by simp
     have "C t \<subseteq> T--`(C t)" using B1 unfolding C_def vimage_restr_def apply auto using B2 order_trans by blast
     then have "T--`(C t) - C t \<in> null_sets M" by (metis Diff_mono Un_absorb1 preimage_includes_then_almost_invariant[OF \<open>C t \<in> sets M\<close>])
   }
   then have "(\<Union>d\<in>D. T--`(C d) - C d) \<in> null_sets M" using \<open>countable D\<close> by (simp add: null_sets_UN')
   then have "(space M - B) \<union> (\<Union>d\<in>D. T--`(C d) - C d) \<in> null_sets M" using \<open>space M - B \<in> null_sets M\<close> by auto
   then have "AE x in M. x \<notin> (space M - B) \<union> (\<Union>d\<in>D. T--`(C d) - C d)" using AE_not_in by blast
   moreover
   {
     fix x assume x: "x \<in> space M" "x \<notin> (space M - B) \<union> (\<Union>d\<in>D. T--`(C d) - C d)"
     then have "x \<in> B" by simp
     then have "T x \<in> B" using B1 by auto
     have "f(T x) = f x"
     proof (rule ccontr)
       assume "f(T x) \<noteq> f x"
       then have "f(T x) > f x" using B2[OF \<open>x \<in> B\<close>] by simp
       then obtain d where d: "d \<in> D" "f(T x) \<ge> d \<and> d > f x" using D by auto
       then have "T x \<in> C d" using \<open>T x \<in> B\<close> unfolding C_def by simp
       then have "x \<in> T--`(C d)" using \<open>x \<in> space M\<close> by simp
       then have "x \<in> C d" using x \<open>d \<in> D\<close> by simp
       then have "f x \<ge> d" unfolding C_def by simp
       then show False using d by auto
     qed
   }
   ultimately show ?thesis by auto
 qed
 
 text \<open>For an invertible map, the invariants of $T$ and $T^{-1}$ are the same.\<close>
 
 lemma Invariants_Tinv:
   assumes "invertible_qmpt"
   shows "qmpt.Invariants M Tinv = Invariants"
 proof -
   interpret I: qmpt M Tinv using Tinv_qmpt[OF assms] by auto
   have "(T -` A \<inter> space M = A) \<longleftrightarrow> (Tinv -` A \<inter> space M = A)" if "A \<in> sets M" for A
   proof
     assume "T -` A \<inter> space M = A"
     then show "Tinv -` A \<inter> space M = A"
       using assms that unfolding Tinv_def invertible_qmpt_def
       apply auto
       apply (metis IntE UNIV_I bij_def imageE inv_f_f vimageE)
       apply (metis I.T_spaceM_stable(1) Int_iff Tinv_def bij_inv_eq_iff vimageI)
       done
   next
     assume "Tinv -` A \<inter> space M = A"
     then show "T -` A \<inter> space M = A"
       using assms that unfolding Tinv_def invertible_qmpt_def
       apply auto
       apply (metis IntE bij_def inv_f_f vimageE)
       apply (metis T_Tinv_of_set T_meas Tinv_def assms qmpt.vrestr_of_set qmpt_axioms vrestr_image(3))
       done
   qed
   then have "{A \<in> sets M. Tinv -` A \<inter> space M = A} = {A \<in> sets M. T -` A \<inter> space M = A}"
     by blast
   then show ?thesis unfolding Invariants_def I.Invariants_def by auto
 qed
 
 end
 
 sublocale fmpt \<subseteq> finite_measure_subalgebra M Invariants
   unfolding finite_measure_subalgebra_def finite_measure_subalgebra_axioms_def
   using Invariants_is_subalg by (simp add: finite_measureI)
 
 context fmpt
 begin
 
 text \<open>The conditional expectation with respect to the invariant sigma-algebra is the same
 for $f$ or $f \circ T$, essentially by definition.\<close>
 
 lemma Invariants_of_foTn:
   fixes f::"'a \<Rightarrow> real"
   assumes [measurable]: "integrable M f"
   shows "AE x in M. real_cond_exp M Invariants (f o (T^^n)) x = real_cond_exp M Invariants f x"
 proof (rule real_cond_exp_charact)
   fix A assume [measurable]: "A \<in> sets Invariants"
   then have [measurable]: "A \<in> sets M" using Invariants_in_sets by blast
   then have ind_meas [measurable]: "((indicator A)::('a \<Rightarrow> real)) \<in> borel_measurable Invariants" by auto
 
   have "set_lebesgue_integral M A (f \<circ> (T^^n)) = (\<integral>x. indicator A x * f((T^^n) x) \<partial>M)"
     by (auto simp: comp_def set_lebesgue_integral_def)
   also have "... = (\<integral>x. indicator A ((T^^n) x) * f ((T^^n) x) \<partial>M)"
     by (rule Bochner_Integration.integral_cong, auto simp add: Invariants_func_is_invariant_n[OF ind_meas])
   also have "... = (\<integral>x. indicator A x * f x \<partial>M)"
     apply (rule Tn_integral_preserving(2)) using integrable_mult_indicator[OF \<open>A \<in> sets M\<close> assms] by auto
   also have "... = (\<integral>x. indicator A x * real_cond_exp M Invariants f x \<partial>M)"
     apply (rule real_cond_exp_intg(2)[symmetric]) using integrable_mult_indicator[OF \<open>A \<in> sets M\<close> assms] by auto
   also have "... = set_lebesgue_integral M A (real_cond_exp M Invariants f)"
     by (auto simp: set_lebesgue_integral_def)
   finally show "set_lebesgue_integral M A (f \<circ> (T^^n)) = set_lebesgue_integral M A (real_cond_exp M Invariants f)"
     by simp
 qed (auto simp add: assms real_cond_exp_int Tn_integral_preserving(1)[OF assms] comp_def)
 
 lemma Invariants_of_foT:
   fixes f::"'a \<Rightarrow> real"
   assumes [measurable]: "integrable M f"
   shows "AE x in M. real_cond_exp M Invariants f x = real_cond_exp M Invariants (f o T) x"
 using Invariants_of_foTn[OF assms, where ?n = 1] by auto
 
 lemma birkhoff_sum_Invariants:
   fixes f::"'a \<Rightarrow> real"
   assumes [measurable]: "integrable M f"
   shows "AE x in M. real_cond_exp M Invariants (birkhoff_sum f n) x = n * real_cond_exp M Invariants f x"
 proof -
   define F where "F = (\<lambda>i. f o (T^^i))"
   have [measurable]: "\<And>i. F i \<in> borel_measurable M" unfolding F_def by auto
   have *: "integrable M (F i)" for i unfolding F_def
     by (subst comp_def, rule Tn_integral_preserving(1)[OF assms, of i])
 
   have "AE x in M. n * real_cond_exp M Invariants f x = (\<Sum>i\<in>{..<n}. real_cond_exp M Invariants f x)" by auto
   moreover have "AE x in M. (\<Sum>i\<in>{..<n}. real_cond_exp M Invariants f x) = (\<Sum>i\<in>{..<n}. real_cond_exp M Invariants (F i) x)"
     apply (rule AE_symmetric[OF AE_equal_sum]) unfolding F_def using Invariants_of_foTn[OF assms] by simp
   moreover have "AE x in M. (\<Sum>i\<in>{..<n}. real_cond_exp M Invariants (F i) x) = real_cond_exp M Invariants (\<lambda>x. \<Sum>i\<in>{..<n}. F i x) x"
     by (rule AE_symmetric[OF real_cond_exp_sum [OF *]])
   moreover have "AE x in M. real_cond_exp M Invariants (\<lambda>x. \<Sum>i\<in>{..<n}. F i x) x = real_cond_exp M Invariants (birkhoff_sum f n) x"
     apply (rule real_cond_exp_cong) unfolding F_def using birkhoff_sum_def[symmetric] by auto
   ultimately show ?thesis by auto
 qed
 
 end (* of context fmpt *)
 
 subsection \<open>Birkhoff theorem\<close>
 
 subsubsection \<open>Almost everywhere version of Birkhoff theorem\<close>
 
 text \<open>This paragraph is devoted to the proof of Birkhoff theorem, arguably
 the most fundamental result of ergodic theory.
 This theorem asserts that Birkhoff averages of an integrable function $f$ converge almost surely,
 to the conditional expectation of $f$ with respect to the invariant sigma algebra.
 
 This result implies for instance the strong law of large numbers (in probability theory).
 
 There are numerous proofs of this statement, but none is really easy. We follow the very efficient
 argument given in Katok-Hasselblatt. To help the reader, here is the same proof informally. The
 first part of the proof is formalized in \verb+birkhoff_lemma1+, the second one in
 \verb+birkhoff_lemma+, and the conclusion in \verb+birkhoff_theorem+.
 
 Start with an integrable function $g$. let $G_n(x) = \max_{k\leq n} S_k g(x)$. Then $\limsup S_n g/n
 \leq 0$ outside of $A$, the set where $G_n$ tends to infinity. Moreover, $G_{n+1} - G_n \circ T$ is
 bounded by $g$, and tends to $g$ on $A$. It follows from the dominated convergence theorem that
 $\int_A G_{n+1} - G_n \circ T \to \int_A g$. As $\int_A G_{n+1} - G_n \circ T = \int_A G_{n+1} - G_n
 \geq 0$, we obtain $\int_A g \geq 0$.
 
 Apply now this result to the function $g = f - E(f | I) - \epsilon$, where $\epsilon>0$ is fixed.
 Then $\int_A g = -\epsilon \mu(A)$, then have $\mu(A) = 0$. Thus, almost surely, $\limsup S_n
 g/n\leq 0$, i.e., $\limsup S_n f/n \leq E(f|I)+\epsilon$. Letting $\epsilon$ tend to $0$ gives
 $\limsup S_n f/n \leq E(f|I)$.
 
 Applying the same result to $-f$ gives $S_n f/n \to E(f|I)$.
 \<close>
 
 context fmpt
 begin
 
 lemma birkhoff_aux1:
   fixes f::"'a \<Rightarrow> real"
   assumes [measurable]: "integrable M f"
   defines "A \<equiv> {x \<in> space M. limsup (\<lambda>n. ereal(birkhoff_sum f n x)) = \<infinity>}"
     shows "A \<in> sets Invariants" "(\<integral>x. f x * indicator A x \<partial>M) \<ge> 0"
 proof -
   let ?bsf = "birkhoff_sum f"
   have [measurable]: "A \<in> sets M" unfolding A_def by simp
   have Ainv: "x \<in> A \<longleftrightarrow> T x \<in> A" if "x \<in> space M" for x
   proof -
     have "ereal(?bsf (1 + n) x) = ereal(f x) + ereal(?bsf n (T x))" for n
       unfolding birkhoff_sum_cocycle birkhoff_sum_1 by simp
     moreover have "limsup (\<lambda>n. ereal(f x) + ereal(?bsf n (T x)))
                     = ereal(f x) + limsup(\<lambda>n. ereal(?bsf n (T x)))"
       by (rule ereal_limsup_lim_add, auto)
     moreover have "limsup (\<lambda>n. ereal(?bsf (n+1) x)) = limsup (\<lambda>n. ereal(?bsf n x))" using limsup_shift by simp
     ultimately have "limsup (\<lambda>n. ereal(birkhoff_sum f n x)) = ereal(f x) + limsup (\<lambda>n. ereal(?bsf n (T x)))" by simp
     then have "limsup (\<lambda>n. ereal(?bsf n x)) = \<infinity> \<longleftrightarrow> limsup (\<lambda>n. ereal(?bsf n (T x))) = \<infinity>" by simp
     then show "x \<in> A \<longleftrightarrow> T x \<in> A" using \<open>x \<in> space M\<close> A_def by simp
   qed
   then show "A \<in> sets Invariants" using assms(2) Invariants_sets by auto
 
   define F where "F = (\<lambda>n x. MAX k \<in>{0..n}. ?bsf k x)"
   have [measurable]: "\<And>n. F n \<in> borel_measurable M" unfolding F_def by measurable
   have intFn: "integrable M (F n)" for n
     unfolding F_def by (rule integrable_MAX, auto simp add: birkhoff_sum_integral(1)[OF assms(1)])
 
   have Frec: "F (n+1) x - F n (T x) = max (-F n (T x)) (f x)" for n x
   proof -
     have "{0..n+1} = {0} \<union> {1..n+1}" by auto
     then have "(\<lambda>k. ?bsf k x) ` {0..n+1} = (\<lambda>k. ?bsf k x) ` {0} \<union> (\<lambda>k. ?bsf k x) ` {1..n+1}" by blast
     then have *: "(\<lambda>k. ?bsf k x) ` {0..n+1} = {0} \<union> (\<lambda>k. ?bsf k x) ` {1..n+1}" using birkhoff_sum_1(1) by simp
     have b: "F (n+1) x = max (Max {0}) (MAX k \<in>{1..n+1}. ?bsf k x)"
       by (subst F_def, subst *, rule Max.union, auto)
 
     have "(\<lambda>k. ?bsf k x) ` {1..n+1} = (\<lambda>k. ?bsf (1+k) x) ` {0..n}" using Suc_le_D by fastforce
     also have "... = (\<lambda>k. f x + ?bsf k (T x)) ` {0..n}"
       by (subst birkhoff_sum_cocycle, subst birkhoff_sum_1(2), auto)
     finally have c: "F (n+1) x = max 0 (MAX k \<in>{0..n}. ?bsf k (T x) + f x)" using b by (simp add: add_ac)
 
     have "{f x + birkhoff_sum f k (T x) |k. k \<in>{0..n}} = (+) (f x) ` {birkhoff_sum f k (T x) |k. k \<in>{0..n}}" by blast
     have "(MAX k \<in>{0..n}. ?bsf k (T x) + f x) = (MAX k \<in>{0..n}. ?bsf k (T x)) + f x"
       by (rule Max_add_commute) auto
     also have "... = F n (T x) + f x" unfolding F_def by simp
     finally have "(MAX k \<in>{0..n}. ?bsf k (T x) + f x) = f x + F n (T x)" by simp
     then have "F (n+1) x = max 0 (f x + F n (T x))" using c by simp
     then show "F (n+1) x - F n (T x) = max (-F n (T x)) (f x)" by auto
   qed
 
   have a: "abs((F (n+1) x - F n (T x)) * indicator A x) \<le> abs(f x)" for n x
   proof -
     have "F (n+1) x -F n (T x) \<ge> f x" using Frec by simp
     then have *: "F (n+1) x -F n (T x) \<ge> - abs(f x)" by simp
 
     have "F n (T x) \<ge> birkhoff_sum f 0 (T x)"
       unfolding F_def apply (rule Max_ge, simp) using atLeastAtMost_iff by blast
     then have "F n (T x) \<ge> 0" using birkhoff_sum_1(1) by simp
     then have "-F n (T x) \<le> abs (f x)" by simp
     moreover have "f x \<le> abs(f x)" by simp
     ultimately have "F (n+1) x -F n (T x) \<le> abs(f x)" using Frec by simp
     then have "abs(F (n+1) x - F n (T x)) \<le> abs(f x)" using * by simp
     then show "abs((F (n+1) x - F n (T x)) * indicator A x) \<le> abs(f x)" unfolding indicator_def by auto
   qed
   have b: "(\<lambda>n. (F (n+1) x - F n (T x)) * indicator A x) \<longlonglongrightarrow> f x * indicator A x" for x
   proof (rule Lim_eventually, cases)
     assume "x \<in> A"
     then have "T x \<in> A" using Ainv A_def by auto
     then have "limsup (\<lambda>n. ereal(birkhoff_sum f n (T x))) > ereal(-f x)" unfolding A_def by simp
     then obtain N where "ereal(?bsf N (T x)) > ereal(-f x)" using Limsup_obtain by blast
     then have *: "?bsf N (T x) > -f x" by simp
     {
       fix n assume "n\<ge>N"
       then have "?bsf N (T x) \<in> (\<lambda>k. ?bsf k (T x)) ` {0..n}" by auto
       then have "F n (T x) \<ge> ?bsf N (T x)" unfolding F_def by simp
       then have "F n (T x) \<ge> -f x" using * by simp
       then have "max (-F n (T x)) (f x) = f x" by simp
       then have "F (n+1) x - F n (T x) = f x" using Frec by simp
       then have "(F (n+1) x - F n (T x)) * indicator A x = f x * indicator A x" by simp
     }
     then show "eventually (\<lambda>n. (F (n+1) x - F n (T x)) * indicator A x = f x * indicator A x) sequentially"
       using eventually_sequentially by blast
   next
     assume "\<not>(x \<in> A)"
     then have "indicator A x = (0::real)" by simp
     then show "eventually (\<lambda>n. (F (n+1) x - F n (T x)) * indicator A x = f x * indicator A x) sequentially" by auto
   qed
   have lim: "(\<lambda>n. (\<integral>x. (F (n+1) x - F n (T x)) * indicator A x \<partial>M)) \<longlonglongrightarrow> (\<integral>x. f x * indicator A x \<partial>M)"
   proof (rule integral_dominated_convergence[where ?w = "(\<lambda>x. abs(f x))"])
     show "integrable M (\<lambda>x. \<bar>f x\<bar>)" using assms(1) by auto
     show "AE x in M. (\<lambda>n. (F (n + 1) x - F n (T x)) * indicator A x) \<longlonglongrightarrow> f x * indicator A x" using b by auto
     show "\<And>n. AE x in M. norm ((F (n + 1) x - F n (T x)) * indicator A x) \<le> \<bar>f x\<bar>" using a by auto
   qed (simp_all)
 
   have "(\<integral>x. (F (n+1) x - F n (T x)) * indicator A x \<partial>M) \<ge> 0" for n
   proof -
     have "(\<integral>x. F n (T x) * indicator A x \<partial>M) = (\<integral>x. (\<lambda>x. F n x * indicator A x) (T x) \<partial>M)"
       by (rule Bochner_Integration.integral_cong, auto simp add: Ainv indicator_def)
     also have "... = (\<integral>x. F n x * indicator A x \<partial>M)"
       by (rule T_integral_preserving, auto simp add: intFn integrable_real_mult_indicator)
     finally have i: "(\<integral>x. F n (T x) * indicator A x \<partial>M) = (\<integral>x. F n x * indicator A x \<partial>M)" by simp
 
     have "(\<integral>x. (F (n+1) x - F n (T x)) * indicator A x \<partial>M) = (\<integral>x. F (n+1) x * indicator A x - F n (T x) * indicator A x \<partial>M)"
       by (simp add: mult.commute right_diff_distrib)
     also have "... = (\<integral>x. F (n+1) x * indicator A x \<partial>M) - (\<integral>x. F n (T x) * indicator A x \<partial>M)"
       by (rule Bochner_Integration.integral_diff, auto simp add: intFn integrable_real_mult_indicator T_meas T_integral_preserving(1))
     also have "... = (\<integral>x. F (n+1) x * indicator A x \<partial>M) - (\<integral>x. F n x * indicator A x \<partial>M)"
       using i by simp
     also have "... = (\<integral>x. F (n+1) x * indicator A x - F n x * indicator A x \<partial>M)"
       by (rule Bochner_Integration.integral_diff[symmetric], auto simp add: intFn integrable_real_mult_indicator)
     also have "... = (\<integral>x. (F (n+1) x - F n x) * indicator A x \<partial>M)"
       by (simp add: mult.commute right_diff_distrib)
     finally have *: "(\<integral>x. (F (n+1) x - F n (T x)) * indicator A x \<partial>M) = (\<integral>x. (F (n+1) x - F n x) * indicator A x \<partial>M)"
       by simp
 
     have "F n x \<le> F (n+1) x" for x unfolding F_def by (rule Max_mono, auto)
     then have "(F (n+1) x - F n x) * indicator A x \<ge> 0" for x by simp
     then have "integral\<^sup>L M (\<lambda>x. 0) \<le> integral\<^sup>L M (\<lambda>x. (F (n+1) x - F n x) * indicator A x)"
       by (auto simp add: intFn integrable_real_mult_indicator intro: integral_mono)
     then have "(\<integral>x. (F (n+1) x - F n x) * indicator A x \<partial>M) \<ge> 0" by simp
     then show "(\<integral>x. (F (n+1) x - F n (T x)) * indicator A x \<partial>M) \<ge> 0" using * by simp
   qed
   then show "(\<integral>x. f x * indicator A x \<partial>M) \<ge> 0" using lim by (simp add: LIMSEQ_le_const)
 qed
 
 lemma birkhoff_aux2:
   fixes f::"'a \<Rightarrow> real"
   assumes [measurable]: "integrable M f"
   shows "AE x in M. limsup (\<lambda>n. ereal(birkhoff_sum f n x / n)) \<le> real_cond_exp M Invariants f x"
 proof -
   {
     fix \<epsilon> assume "\<epsilon> > (0::real)"
     define g where "g = (\<lambda>x. f x - real_cond_exp M Invariants f x - \<epsilon>)"
     then have intg: "integrable M g" using assms real_cond_exp_int(1) assms by auto
     define A where "A = {x \<in> space M. limsup (\<lambda>n. ereal(birkhoff_sum g n x)) = \<infinity>}"
     have Ag: "A \<in> sets Invariants" "(\<integral>x. g x * indicator A x \<partial>M) \<ge> 0"
       unfolding A_def by (rule birkhoff_aux1[where ?f = g, OF intg])+
     then have [measurable]: "A \<in> sets M" by (simp add: Invariants_in_sets)
 
     have eq: "(\<integral>x. indicator A x * real_cond_exp M Invariants f x \<partial>M) = (\<integral>x. indicator A x * f x \<partial>M)"
     proof (rule real_cond_exp_intg[where ?f = "\<lambda>x. (indicator A x)::real" and ?g = f])
       have "(\<lambda>x. indicator A x * f x) = (\<lambda>x. f x * indicator A x)" by auto
       then show "integrable M (\<lambda>x. indicator A x * f x)"
         using integrable_real_mult_indicator[OF \<open>A \<in> sets M\<close> assms] by simp
       show "indicator A \<in> borel_measurable Invariants" using \<open>A \<in> sets Invariants\<close> by measurable
     qed (simp)
 
     have "0 \<le> (\<integral>x. g x * indicator A x \<partial>M)" using Ag by simp
     also have "... = (\<integral>x. f x * indicator A x - real_cond_exp M Invariants f x * indicator A x - \<epsilon> * indicator A x \<partial>M)"
       unfolding g_def by (simp add: left_diff_distrib)
     also have "... = (\<integral>x. f x * indicator A x \<partial>M) - (\<integral>x. real_cond_exp M Invariants f x * indicator A x \<partial>M) - (\<integral>x. \<epsilon> * indicator A x \<partial>M)"
       using assms real_cond_exp_int(1)[OF assms] integrable_real_mult_indicator[OF \<open>A \<in> sets M\<close>] by auto
     also have "... = - (\<integral>x. \<epsilon> * indicator A x \<partial>M)"
       by (auto simp add: eq mult.commute)
     also have "... = - \<epsilon> * measure M A" by auto
     finally have "0 \<le> - \<epsilon> * measure M A" by simp
     then have "measure M A = 0" using \<open>\<epsilon> > 0\<close> by (simp add: measure_le_0_iff mult_le_0_iff)
     then have "A \<in> null_sets M" by (simp add: emeasure_eq_measure null_setsI)
     then have "AE x in M. x \<in> space M - A" by (metis (no_types, lifting) AE_cong Diff_iff AE_not_in)
     moreover
     {
       fix x assume "x \<in> space M - A"
       then have "limsup (\<lambda>n. ereal(birkhoff_sum g n x)) < \<infinity>" unfolding A_def by auto
       then obtain C where C: "\<And>n. birkhoff_sum g n x \<le> C" using limsup_finite_then_bounded by presburger
       {
         fix n::nat assume "n > 0"
         have "birkhoff_sum g n x = birkhoff_sum f n x - birkhoff_sum (real_cond_exp M Invariants f) n x - birkhoff_sum (\<lambda>x. \<epsilon>) n x"
           unfolding g_def using birkhoff_sum_add birkhoff_sum_diff by auto
         moreover have "birkhoff_sum (real_cond_exp M Invariants f) n x = n * real_cond_exp M Invariants f x"
           using birkhoff_sum_of_invariants using \<open>x \<in> space M - A\<close> by auto
         moreover have "birkhoff_sum (\<lambda>x. \<epsilon>) n x = n * \<epsilon>" unfolding birkhoff_sum_def by auto
         ultimately have "birkhoff_sum g n x = birkhoff_sum f n x - n * real_cond_exp M Invariants f x - n * \<epsilon>"
           by simp
         then have "birkhoff_sum f n x = birkhoff_sum g n x + n * real_cond_exp M Invariants f x + n * \<epsilon>"
           by simp
         then have "birkhoff_sum f n x / n = birkhoff_sum g n x / n + real_cond_exp M Invariants f x + \<epsilon>"
-          using \<open>n > 0\<close> by (simp add: add_divide_eq_iff linordered_field_class.sign_simps(27))
+          using \<open>n > 0\<close> by (simp add: field_simps)
         then have "birkhoff_sum f n x / n \<le> C/n + real_cond_exp M Invariants f x + \<epsilon>"
           using C[of n] \<open>n > 0\<close> by (simp add: divide_right_mono)
         then have "ereal(birkhoff_sum f n x / n) \<le> ereal(C/n + real_cond_exp M Invariants f x + \<epsilon>)"
           by simp
       }
       then have "eventually (\<lambda>n. ereal(birkhoff_sum f n x / n) \<le> ereal(C/n + real_cond_exp M Invariants f x + \<epsilon>)) sequentially"
         by (simp add: eventually_at_top_dense)
       then have b: "limsup (\<lambda>n. ereal(birkhoff_sum f n x / n)) \<le> limsup (\<lambda>n. ereal(C/n + real_cond_exp M Invariants f x + \<epsilon>))"
         by (simp add: Limsup_mono)
 
       have "(\<lambda>n. ereal(C*(1/real n) + real_cond_exp M Invariants f x + \<epsilon>)) \<longlonglongrightarrow> ereal(C * 0 + real_cond_exp M Invariants f x + \<epsilon>)"
         by (intro tendsto_intros)
       then have "limsup (\<lambda>n. ereal(C/real n + real_cond_exp M Invariants f x + \<epsilon>)) = real_cond_exp M Invariants f x + \<epsilon>"
         using sequentially_bot tendsto_iff_Liminf_eq_Limsup by force
       then have "limsup (\<lambda>n. ereal(birkhoff_sum f n x / n)) \<le> real_cond_exp M Invariants f x + \<epsilon>"
         using b by simp
     }
     ultimately have "AE x in M. limsup (\<lambda>n. ereal(birkhoff_sum f n x / n)) \<le> real_cond_exp M Invariants f x + \<epsilon>"
       by auto
     then have "AE x in M. limsup (\<lambda>n. ereal(birkhoff_sum f n x / n)) \<le> ereal(real_cond_exp M Invariants f x) + \<epsilon>"
       by auto
   }
   then show ?thesis
     by (rule AE_upper_bound_inf_ereal)
 qed
 
 theorem birkhoff_theorem_AE_nonergodic:
   fixes f::"'a \<Rightarrow> real"
   assumes "integrable M f"
   shows "AE x in M. (\<lambda>n. birkhoff_sum f n x / n) \<longlonglongrightarrow> real_cond_exp M Invariants f x"
 proof -
   {
     fix x assume i: "limsup (\<lambda>n. ereal(birkhoff_sum f n x /n)) \<le> real_cond_exp M Invariants f x"
              and ii: "limsup (\<lambda>n. ereal(birkhoff_sum (\<lambda>x. -f x) n x / n)) \<le> real_cond_exp M Invariants (\<lambda>x. -f x) x"
              and iii: "real_cond_exp M Invariants (\<lambda>x. -f x) x = - real_cond_exp M Invariants f x"
     have "\<And>n. birkhoff_sum (\<lambda>x. -f x) n x = - birkhoff_sum f n x"
       using birkhoff_sum_cmult[where ?c = "-1" and ?f = f] by auto
     then have "\<And>n. ereal(birkhoff_sum (\<lambda>x. -f x) n x / n) = - ereal(birkhoff_sum f n x / n)" by auto
     moreover have "limsup (\<lambda>n. - ereal(birkhoff_sum f n x / n)) = - liminf (\<lambda>n. ereal(birkhoff_sum f n x /n))"
       by (rule ereal_Limsup_uminus)
     ultimately have "-liminf (\<lambda>n. ereal(birkhoff_sum f n x /n)) = limsup (\<lambda>n. ereal(birkhoff_sum (\<lambda>x. -f x) n x / n))"
       by simp
     then have "-liminf (\<lambda>n. ereal(birkhoff_sum f n x /n)) \<le> - real_cond_exp M Invariants f x"
       using ii iii by simp
     then have "liminf (\<lambda>n. ereal(birkhoff_sum f n x /n)) \<ge> real_cond_exp M Invariants f x"
       by (simp add: ereal_uminus_le_reorder)
     then have "(\<lambda>n. birkhoff_sum f n x /n) \<longlonglongrightarrow> real_cond_exp M Invariants f x"
       using i by (simp add: limsup_le_liminf_real)
   } note * = this
   moreover have "AE x in M. limsup (\<lambda>n. ereal(birkhoff_sum f n x /n)) \<le> real_cond_exp M Invariants f x"
     using birkhoff_aux2 assms by simp
   moreover have "AE x in M. limsup (\<lambda>n. ereal(birkhoff_sum (\<lambda>x. -f x) n x / n)) \<le> real_cond_exp M Invariants (\<lambda>x. -f x) x"
     using birkhoff_aux2 assms by simp
   moreover have "AE x in M. real_cond_exp M Invariants (\<lambda>x. -f x) x = - real_cond_exp M Invariants f x"
     using real_cond_exp_cmult[where ?c = "-1"] assms by force
   ultimately show ?thesis by auto
 qed
 
 text \<open>If a function $f$ is integrable, then $E(f\circ T - f | I) = E(f\circ T | I) - E(f|I) = 0$.
 Hence, $S_n(f \circ T - f) / n$ converges almost everywhere to $0$, i.e., $f(T^n x)/n \to 0$.
 It is remarkable (and sometimes useful) that this holds under the weaker condition that
 $f\circ T - f$ is integrable (but not necessarily $f$), where this naive argument fails.
 
 The reason is that the Birkhoff sum of $f \circ T - f$ is $f\circ T^n - f$. If $n$ is such that $x$
 and $T^n(x)$ belong to a set where $f$ is bounded, it follows that this Birkhoff sum is also
 bounded. Along such a sequence of times, $S_n(f\circ T - f)/n$ tends to $0$.
 By Poincare recurrence theorem, there are such times for almost every points. As it also converges
 to $E(f \circ T - f | I)$, it follows that this function is almost everywhere $0$. Then
 $f (T^n x)/n = S_n(f\circ T^n - f)/n - f/n$ tends almost surely to $E(f\circ T-f |I) = 0$.
 \<close>
 
 lemma limit_foTn_over_n:
   fixes f::"'a \<Rightarrow> real"
   assumes [measurable]: "f \<in> borel_measurable M"
       and "integrable M (\<lambda>x. f(T x) - f x)"
   shows "AE x in M. real_cond_exp M Invariants (\<lambda>x. f(T x) - f x) x = 0"
         "AE x in M. (\<lambda>n. f((T^^n) x) / n) \<longlonglongrightarrow> 0"
 proof -
   define E::"nat \<Rightarrow> 'a set" where "E k = {x \<in> space M. \<bar>f x\<bar> \<le> k}" for k
   have [measurable]: "E k \<in> sets M" for k unfolding E_def by auto
   have *: "(\<Union>k. E k) = space M" unfolding E_def by (auto simp add: real_arch_simple)
   define F::"nat \<Rightarrow> 'a set" where "F k = recurrent_subset_infty (E k)" for k
   have [measurable]: "F k \<in> sets M" for k unfolding F_def by auto
   have **: "E k - F k \<in> null_sets M" for k unfolding F_def using Poincare_recurrence_thm by auto
   have "space M - (\<Union>k. F k) \<in> null_sets M"
     apply (rule null_sets_subset[of "(\<Union>k. E k - F k)"]) unfolding *[symmetric] using ** by auto
   with AE_not_in[OF this] have "AE x in M. x \<in> (\<Union>k. F k)" by auto
   moreover have "AE x in M. (\<lambda>n. birkhoff_sum (\<lambda>x. f(T x) - f x) n x / n)
       \<longlonglongrightarrow> real_cond_exp M Invariants (\<lambda>x. f(T x) - f x) x"
     by (rule birkhoff_theorem_AE_nonergodic[OF assms(2)])
   moreover have "real_cond_exp M Invariants (\<lambda>x. f(T x) - f x) x = 0 \<and> (\<lambda>n. f((T^^n) x) / n) \<longlonglongrightarrow> 0"
     if H: "(\<lambda>n. birkhoff_sum (\<lambda>x. f(T x) - f x) n x / n) \<longlonglongrightarrow> real_cond_exp M Invariants (\<lambda>x. f(T x) - f x) x"
           "x \<in> (\<Union>k. F k)" for x
   proof -
     have "f((T^^n) x) = birkhoff_sum (\<lambda>x. f(T x) - f x) n x + f x" for n
       unfolding birkhoff_sum_def by (induction n, auto)
     then have "f((T^^n) x) / n = birkhoff_sum (\<lambda>x. f(T x) - f x) n x / n + f x * (1/n)" for n
       by (auto simp add: divide_simps)
     moreover have "(\<lambda>n. birkhoff_sum (\<lambda>x. f(T x) - f x) n x / n + f x * (1/n)) \<longlonglongrightarrow> real_cond_exp M Invariants (\<lambda>x. f(T x) - f x) x + f x * 0"
       by (intro tendsto_intros H(1))
     ultimately have lim: "(\<lambda>n. f((T^^n) x) / n) \<longlonglongrightarrow> real_cond_exp M Invariants (\<lambda>x. f(T x) - f x) x"
       by auto
 
     obtain k where "x \<in> F k" using H(2) by auto
     then have "infinite {n. (T^^n) x \<in> E k}"
       unfolding F_def recurrent_subset_infty_inf_returns by auto
     with infinite_enumerate[OF this] obtain r :: "nat \<Rightarrow> nat"
       where r: "strict_mono r" "\<And>n. r n \<in> {n. (T^^n) x \<in> E k}"
       by auto
     have A: "(\<lambda>n. k * (1/r n)) \<longlonglongrightarrow> real k * 0"
       apply (intro tendsto_intros)
       using LIMSEQ_subseq_LIMSEQ[OF lim_1_over_n \<open>strict_mono r\<close>] unfolding comp_def by auto
     have B: "\<bar>f((T^^(r n)) x) / r n\<bar> \<le> k / (r n)" for n
       using r(2) unfolding E_def by (auto simp add: divide_simps)
     have "(\<lambda>n. f((T^^(r n)) x) / r n) \<longlonglongrightarrow> 0"
       apply (rule tendsto_rabs_zero_cancel, rule tendsto_sandwich[of "\<lambda>n. 0" _ _ "\<lambda>n. k * (1/r n)"])
       using A B by auto
     moreover have "(\<lambda>n. f((T^^(r n)) x) / r n) \<longlonglongrightarrow> real_cond_exp M Invariants (\<lambda>x. f(T x) - f x) x"
       using LIMSEQ_subseq_LIMSEQ[OF lim \<open>strict_mono r\<close>] unfolding comp_def by auto
     ultimately have *: "real_cond_exp M Invariants (\<lambda>x. f(T x) - f x) x = 0"
       using LIMSEQ_unique by auto
     then have "(\<lambda>n. f((T^^n) x) / n) \<longlonglongrightarrow> 0" using lim by auto
     then show ?thesis using * by auto
   qed
   ultimately show "AE x in M. real_cond_exp M Invariants (\<lambda>x. f(T x) - f x) x = 0"
                   "AE x in M. (\<lambda>n. f((T^^n) x) / n) \<longlonglongrightarrow> 0"
     by auto
 qed
 
 text \<open>We specialize the previous statement to the case where $f$ itself is integrable.\<close>
 
 lemma limit_foTn_over_n':
   fixes f::"'a \<Rightarrow> real"
   assumes [measurable]: "integrable M f"
   shows "AE x in M. (\<lambda>n. f((T^^n) x) / n) \<longlonglongrightarrow> 0"
 by (rule limit_foTn_over_n, simp, rule Bochner_Integration.integrable_diff)
    (auto intro: assms T_integral_preserving(1))
 
 text \<open>It is often useful to show that a function is cohomologous to a nicer function, i.e., to
 prove that a given $f$ can be written as $f = g + u - u \circ T$ where $g$ is nicer than $f$. We
 show below that any integrable function is cohomologous to a function which is arbitrarily close to
 $E(f|I)$. This is an improved version of Lemma 2.1 in [Benoist-Quint, Annals of maths, 2011]. Note
 that the function $g$ to which $f$ is cohomologous is very nice (and, in particular, integrable),
 but the transfer function is only measurable in this argument. The fact that the control on
 conditional expectation is nevertheless preserved throughout the argument follows from
 Lemma~\verb+limit_foTn_over_n+ above.\<close>
 
 text \<open>We start with the lemma (and the proof) of [BQ2011]. It shows that, if a function has a
 conditional expectation with respect to invariants which is positive, then it is cohomologous to a
 nonnegative function. The argument is the clever remark that $g = \max (0, \inf_n S_n f)$ and $u =
 \min (0, \inf_n S_n f)$ work (where these expressions are well defined as $S_n f$ tends to infinity
 thanks to our assumption).\<close>
 
 lemma cohomologous_approx_cond_exp_aux:
   fixes f::"'a \<Rightarrow> real"
   assumes [measurable]: "integrable M f"
       and "AE x in M. real_cond_exp M Invariants f x > 0"
     shows "\<exists>u g. u \<in> borel_measurable M \<and> (integrable M g) \<and> (AE x in M. g x \<ge> 0 \<and> g x \<le> max 0 (f x)) \<and> (\<forall>x. f x = g x + u x - u (T x))"
 proof -
   define h::"'a \<Rightarrow> real" where "h = (\<lambda>x. (INF n\<in>{1..}. birkhoff_sum f n x))"
   define u where "u = (\<lambda>x. min (h x) 0)"
   define g where "g = (\<lambda>x. f x - u x + u (T x))"
   have [measurable]: "h \<in> borel_measurable M" "u \<in> borel_measurable M" "g \<in> borel_measurable M"
     unfolding g_def h_def u_def by auto
   have "f x = g x + u x - u (T x)" for x unfolding g_def by auto
   {
     fix x assume H: "real_cond_exp M Invariants f x > 0"
                     "(\<lambda>n. birkhoff_sum f n x / n) \<longlonglongrightarrow> real_cond_exp M Invariants f x"
     have "eventually (\<lambda>n. ereal(birkhoff_sum f n x / n) * ereal n = ereal(birkhoff_sum f n x)) sequentially"
       unfolding eventually_sequentially by (rule exI[of _ 1], auto)
     moreover have "(\<lambda>n. ereal(birkhoff_sum f n x / n) * ereal n) \<longlonglongrightarrow> ereal(real_cond_exp M Invariants f x) * \<infinity>"
       apply (intro tendsto_intros) using H by auto
     ultimately have "(\<lambda>n. ereal(birkhoff_sum f n x)) \<longlonglongrightarrow> ereal(real_cond_exp M Invariants f x) * \<infinity>"
       by (rule Lim_transform_eventually)
     then have "(\<lambda>n. ereal(birkhoff_sum f n x)) \<longlonglongrightarrow> \<infinity>"
       using H by auto
     then have B: "\<exists>C. \<forall>n. C \<le> birkhoff_sum f n x"
       by (intro liminf_finite_then_bounded_below, simp add: liminf_PInfty)
 
     have "h x \<le> f x"
       unfolding h_def apply (rule cInf_lower) using B by force+
 
     have "{birkhoff_sum f n (T x) |n. n \<in> {1..}} = {birkhoff_sum f (1+n) (x) - f x |n. n \<in> {1..}}"
       unfolding birkhoff_sum_cocycle by auto
     also have "... = {birkhoff_sum f n x - f x |n. n \<in> {2..}}"
       by (metis (no_types, hide_lams) Suc_1 Suc_eq_plus1_left Suc_le_D Suc_le_mono atLeast_iff)
     finally have *: "{birkhoff_sum f n (T x) |n. n \<in> {1..}} = (\<lambda>t. t - (f x))`{birkhoff_sum f n x |n. n \<in> {2..}}"
       by auto
 
     have "h(T x) = Inf {birkhoff_sum f n (T x) |n. n \<in> {1..}}"
       unfolding h_def by (metis Setcompr_eq_image)
     also have "... =  (\<Sqinter>t\<in>{birkhoff_sum f n x |n. n \<in> {2..}}. t - f x)"
       by (simp only: *)
     also have "... = (\<lambda>t. t - (f x)) (Inf {birkhoff_sum f n x |n. n \<in> {2..}})"
       using B by (auto intro!: monoI bijI mono_bij_cInf [symmetric])
     finally have I: "Inf {birkhoff_sum f n x |n. n \<in> {2..}} = f x + h (T x)" by auto
     have "max 0 (h x) + u x = h x"
       unfolding u_def by auto
     also have "... = Inf {birkhoff_sum f n x |n. n \<in> {1..}}"
       unfolding h_def by (metis Setcompr_eq_image)
     also have "... = Inf ({birkhoff_sum f n x |n. n \<in> {1}} \<union> {birkhoff_sum f n x |n. n \<in> {2..}})"
       by (auto intro!: arg_cong[of _ _ Inf], metis One_nat_def Suc_1 antisym birkhoff_sum_1(2) not_less_eq_eq, force)
     also have "Inf ({birkhoff_sum f n x |n. n \<in> {1}} \<union> {birkhoff_sum f n x |n. n \<in> {2..}})
       = min (Inf {birkhoff_sum f n x |n. n \<in> {1}}) (Inf {birkhoff_sum f n x |n. n \<in> {2..}})"
       unfolding inf_min[symmetric] apply (intro cInf_union_distrib) using B by auto
     also have "... = min (f x) (f x + h (T x))" using I by auto
     also have "... = f x + u (T x)" unfolding u_def by auto
     finally have "max 0 (h x) = f x + u (T x) - u x" by auto
     then have "g x = max 0 (h x)" unfolding g_def by auto
     then have "g x \<ge> 0 \<and> g x \<le> max 0 (f x)" using \<open>h x \<le> f x\<close> by auto
   }
   then have *: "AE x in M. g x \<ge> 0 \<and> g x \<le> max 0 (f x)"
     using assms(2) birkhoff_theorem_AE_nonergodic[OF assms(1)] by auto
   moreover have "integrable M g"
     apply (rule Bochner_Integration.integrable_bound[of _ f]) using * by (auto simp add: assms)
   ultimately have "u \<in> borel_measurable M \<and> integrable M g \<and> (AE x in M. 0 \<le> g x \<and> g x \<le> max 0 (f x)) \<and> (\<forall>x. f x = g x + u x - u (T x))"
     using \<open>\<And>x. f x = g x + u x - u (T x)\<close> \<open>u \<in> borel_measurable M\<close> by auto
   then show ?thesis by blast
 qed
 
 text \<open>To deduce the stronger version that $f$ is cohomologous to an arbitrarily good approximation
 of $E(f|I)$, we apply the previous lemma twice, to control successively the negative and the
 positive side. The sign control in the conclusion of the previous lemma implies that the second step
 does not spoil the first one.\<close>
 
 lemma cohomologous_approx_cond_exp:
   fixes f::"'a \<Rightarrow> real" and B::"'a \<Rightarrow> real"
   assumes [measurable]: "integrable M f" "B \<in> borel_measurable M"
       and "AE x in M. B x > 0"
     shows "\<exists>g u. u \<in> borel_measurable M
               \<and> integrable M g
               \<and> (\<forall>x. f x = g x + u x - u (T x))
               \<and> (AE x in M. abs(g x - real_cond_exp M Invariants f x) \<le> B x)"
 proof -
   define C where "C = (\<lambda>x. min (B x) 1)"
   have [measurable]: "integrable M C"
     apply (rule Bochner_Integration.integrable_bound[of _ "\<lambda>_. (1::real)"], auto)
     unfolding C_def using assms(3) by auto
   have "C x \<le> B x" for x unfolding C_def by auto
   have "AE x in M. C x > 0" unfolding C_def using assms(3) by auto
   have AECI: "AE x in M. real_cond_exp M Invariants C x > 0"
     by (intro real_cond_exp_gr_c \<open>integrable M C\<close> \<open>AE x in M. C x > 0\<close>)
 
   define f1 where "f1 = (\<lambda>x. f x - real_cond_exp M Invariants f x)"
   have "integrable M f1"
     unfolding f1_def by (intro Bochner_Integration.integrable_diff \<open>integrable M f\<close> real_cond_exp_int(1))
   have "AE x in M. real_cond_exp M Invariants f1 x = real_cond_exp M Invariants f x - real_cond_exp M Invariants (real_cond_exp M Invariants f) x"
     unfolding f1_def apply (rule real_cond_exp_diff) by (intro Bochner_Integration.integrable_diff
                 \<open>integrable M f\<close> \<open>integrable M C\<close> real_cond_exp_int(1))+
   moreover have "AE x in M. real_cond_exp M Invariants (real_cond_exp M Invariants f) x = real_cond_exp M Invariants f x"
     by (intro real_cond_exp_nested_subalg subalg \<open>integrable M f\<close>, auto)
   ultimately have AEf1: "AE x in M. real_cond_exp M Invariants f1 x = 0" by auto
 
   have A [measurable]: "integrable M (\<lambda>x. f1 x + C x)"
     by (intro Bochner_Integration.integrable_add \<open>integrable M f1\<close> \<open>integrable M C\<close>)
   have "AE x in M. real_cond_exp M Invariants (\<lambda>x. f1 x + C x) x = real_cond_exp M Invariants f1 x + real_cond_exp M Invariants C x"
     by (intro real_cond_exp_add \<open>integrable M f1\<close> \<open>integrable M C\<close>)
   then have B: "AE x in M. real_cond_exp M Invariants (\<lambda>x. f1 x + C x) x > 0"
     using AECI AEf1 by auto
 
   obtain u2 g2 where H2: "u2 \<in> borel_measurable M" "integrable M g2" "AE x in M. g2 x \<ge> 0 \<and> g2 x \<le> max 0 (f1 x + C x)" "\<And>x. f1 x + C x = g2 x + u2 x - u2 (T x)"
     using cohomologous_approx_cond_exp_aux[OF A B] by blast
 
   define f2 where "f2 = (\<lambda>x. (g2 x - C x))"
   have *: "u2(T x) - u2 x = f2 x -f1 x" for x unfolding f2_def using H2(4)[of x] by auto
   have "AE x in M. f2 x \<ge> - C x" using H2(3) unfolding f2_def by auto
   have "integrable M f2"
     unfolding f2_def by (intro Bochner_Integration.integrable_diff \<open>integrable M g2\<close> \<open>integrable M C\<close>)
   have "AE x in M. real_cond_exp M Invariants (\<lambda>x. u2(T x) - u2 x) x = 0"
   proof (rule limit_foTn_over_n)
     show "integrable M (\<lambda>x. u2(T x) - u2 x)"
       unfolding * by (intro Bochner_Integration.integrable_diff \<open>integrable M f1\<close> \<open>integrable M f2\<close>)
   qed (simp add: \<open>u2 \<in> borel_measurable M\<close>)
   then have "AE x in M. real_cond_exp M Invariants (\<lambda>x. f2 x - f1 x) x = 0"
     unfolding * by simp
   moreover have "AE x in M. real_cond_exp M Invariants (\<lambda>x. f2 x - f1 x) x = real_cond_exp M Invariants f2 x - real_cond_exp M Invariants f1 x"
     by (intro real_cond_exp_diff \<open>integrable M f2\<close> \<open>integrable M f1\<close>)
   ultimately have AEf2: "AE x in M. real_cond_exp M Invariants f2 x = 0"
     using AEf1 by auto
 
   have A [measurable]: "integrable M (\<lambda>x. C x - f2 x)"
     by (intro Bochner_Integration.integrable_diff \<open>integrable M f2\<close> \<open>integrable M C\<close>)
   have "AE x in M. real_cond_exp M Invariants (\<lambda>x. C x - f2 x) x = real_cond_exp M Invariants C x - real_cond_exp M Invariants f2 x"
     by (intro real_cond_exp_diff \<open>integrable M f2\<close> \<open>integrable M C\<close>)
   then have B: "AE x in M. real_cond_exp M Invariants (\<lambda>x. C x - f2 x) x > 0"
     using AECI AEf2 by auto
 
   obtain u3 g3 where H3: "u3 \<in> borel_measurable M" "integrable M g3" "AE x in M. g3 x \<ge> 0 \<and> g3 x \<le> max 0 (C x - f2 x)" "\<And>x. C x - f2 x = g3 x + u3 x - u3 (T x)"
     using cohomologous_approx_cond_exp_aux[OF A B] by blast
 
   define f3 where "f3 = (\<lambda>x. C x - g3 x)"
   have "AE x in M. f3 x \<ge> min (C x) (f2 x)" unfolding f3_def using H3(3) by auto
   then have "AE x in M. f3 x \<ge> -C x" using \<open>AE x in M. f2 x \<ge> - C x\<close> \<open>AE x in M. C x > 0\<close> by auto
   moreover have "AE x in M. f3 x \<le> C x" unfolding f3_def using H3(3) by auto
   ultimately have "AE x in M. abs(f3 x) \<le> C x" by auto
   then have *: "AE x in M. abs(f3 x) \<le> B x" using order_trans[OF _ \<open>\<And>x. C x \<le> B x\<close>] by auto
 
   define g where "g = (\<lambda>x. f3 x + real_cond_exp M Invariants f x)"
   define u where "u = (\<lambda>x. u2 x - u3 x)"
   have "AE x in M. abs (g x - real_cond_exp M Invariants f x) \<le> B x"
     unfolding g_def using * by auto
   moreover have "f x = g x + u x - u(T x)" for x
     using H3(4)[of x] H2(4)[of x] unfolding u_def g_def f3_def f2_def f1_def by auto
   moreover have "u \<in> borel_measurable M"
     unfolding u_def using \<open>u2 \<in> borel_measurable M\<close> \<open>u3 \<in> borel_measurable M\<close> by auto
   moreover have "integrable M g"
     unfolding g_def f3_def by (intro Bochner_Integration.integrable_add Bochner_Integration.integrable_diff
     \<open>integrable M C\<close> \<open>integrable M g3\<close> \<open>integrable M f\<close> real_cond_exp_int(1))
   ultimately show ?thesis by auto
 qed
 
 
 subsubsection \<open>$L^1$ version of Birkhoff theorem\<close>
 
 text \<open>The $L^1$ convergence in Birkhoff theorem follows from the almost everywhere convergence and
 general considerations on $L^1$ convergence (Scheffe's lemma) explained
 in \verb+AE_and_int_bound_implies_L1_conv2+.
 This argument works neatly for nonnegative functions, the general case reduces to this one by taking
 the positive and negative parts of a given function.
 
 One could also prove it by truncation: for bounded functions, the $L^1$ convergence follows
 from the boundedness and almost sure convergence. The general case follows by density, but it
 is a little bit tedious to write as one need to make sure that the conditional expectation
 of the truncation converges to the conditional expectation of the original function. This is true
 in $L^1$ as the conditional expectation is a contraction in $L^1$, it follows almost everywhere
 after taking a subsequence. All in all, the argument based on Scheffe's lemma seems more
 economical.\<close>
 
 lemma birkhoff_lemma_L1:
   fixes f::"'a \<Rightarrow> real"
   assumes "\<And>x. f x \<ge> 0"
       and [measurable]: "integrable M f"
   shows "(\<lambda>n. \<integral>\<^sup>+x. norm(birkhoff_sum f n x / n - real_cond_exp M Invariants f x) \<partial>M) \<longlonglongrightarrow> 0"
 proof (rule Scheffe_lemma2)
   show i: "integrable M (real_cond_exp M Invariants f)" using assms by (simp add: real_cond_exp_int(1))
   show "AE x in M. (\<lambda>n. birkhoff_sum f n x / real n) \<longlonglongrightarrow> real_cond_exp M Invariants f x"
     using birkhoff_theorem_AE_nonergodic assms by simp
   fix n
   have [measurable]: "(\<lambda>x. ennreal \<bar>birkhoff_sum f n x\<bar>) \<in> borel_measurable M" by measurable
   show [measurable]: "(\<lambda>x. birkhoff_sum f n x / real n) \<in> borel_measurable M" by measurable
 
   have "AE x in M. real_cond_exp M Invariants f x \<ge> 0" using assms(1) real_cond_exp_pos by simp
   then have *: "AE x in M. norm (real_cond_exp M Invariants f x) = real_cond_exp M Invariants f x" by auto
   have **: "(\<integral> x. norm (real_cond_exp M Invariants f x) \<partial>M) = (\<integral> x. real_cond_exp M Invariants f x \<partial>M)"
     apply (rule integral_cong_AE) using * by auto
 
   have "(\<integral>\<^sup>+x. ennreal (norm (real_cond_exp M Invariants f x)) \<partial>M) = (\<integral> x. norm (real_cond_exp M Invariants f x) \<partial>M)"
     by (rule nn_integral_eq_integral) (auto simp add: i)
   also have "... = (\<integral> x. real_cond_exp M Invariants f x \<partial>M)"
     using ** by simp
   also have "... = (\<integral> x. f x \<partial>M)"
     using real_cond_exp_int(2) assms(2) by auto
   also have "... = (\<integral>x. norm(f x) \<partial>M)" using assms by auto
   also have "... = (\<integral>\<^sup>+x. norm(f x) \<partial>M)"
     by (rule nn_integral_eq_integral[symmetric], auto simp add: assms(2))
   finally have eq: "(\<integral>\<^sup>+ x. norm (real_cond_exp M Invariants f x) \<partial>M) = (\<integral>\<^sup>+ x. norm(f x) \<partial>M)" by simp
 
   {
     fix x
     have "norm(birkhoff_sum f n x) \<le> birkhoff_sum (\<lambda>x. norm(f x)) n x"
       using birkhoff_sum_abs by fastforce
     then have "norm(birkhoff_sum f n x) \<le> birkhoff_sum (\<lambda>x. ennreal(norm(f x))) n x"
       unfolding birkhoff_sum_def by auto
   }
   then have "(\<integral>\<^sup>+x. norm(birkhoff_sum f n x) \<partial>M) \<le> (\<integral>\<^sup>+x. birkhoff_sum (\<lambda>x. ennreal(norm(f x))) n x \<partial>M)"
     by (simp add: nn_integral_mono)
   also have "... = n * (\<integral>\<^sup>+x. norm(f x) \<partial>M)"
     by (rule birkhoff_sum_nn_integral, auto)
   also have "... = n * (\<integral>\<^sup>+ x. norm (real_cond_exp M Invariants f x) \<partial>M)"
     using eq by simp
   finally have *: "(\<integral>\<^sup>+x. norm(birkhoff_sum f n x) \<partial>M) \<le> n * (\<integral>\<^sup>+ x. norm (real_cond_exp M Invariants f x) \<partial>M)"
     by simp
 
   show "(\<integral>\<^sup>+ x. ennreal (norm (birkhoff_sum f n x / real n)) \<partial>M) \<le> (\<integral>\<^sup>+ x. norm (real_cond_exp M Invariants f x) \<partial>M)"
   proof (cases)
     assume "n = 0"
     then show ?thesis by auto
   next
     assume "\<not>(n = 0)"
     then have "n > 0" by simp
     then have "1/ennreal(real n) \<ge> 0" by simp
     have "(\<integral>\<^sup>+ x. ennreal (norm (birkhoff_sum f n x / real n)) \<partial>M) = (\<integral>\<^sup>+ x. ennreal (norm (birkhoff_sum f n x)) / ennreal(real n) \<partial>M)"
       using \<open>n > 0\<close> by (auto simp: divide_ennreal)
     also have "... = (\<integral>\<^sup>+ x. (1/ennreal(real n)) * ennreal (norm (birkhoff_sum f n x)) \<partial>M)"
       by (simp add: \<open>0 < n\<close> divide_ennreal_def mult.commute)
     also have "... = (1/ennreal(real n) * (\<integral>\<^sup>+ x. ennreal (norm (birkhoff_sum f n x)) \<partial>M))"
       by (subst nn_integral_cmult) auto
     also have "... \<le> (1/ennreal(real n)) * (ennreal(real n) * (\<integral>\<^sup>+ x. norm (real_cond_exp M Invariants f x) \<partial>M))"
       using * by (intro mult_mono) (auto simp: ennreal_of_nat_eq_real_of_nat)
     also have "... = (\<integral>\<^sup>+ x. norm (real_cond_exp M Invariants f x) \<partial>M)"
       using \<open>n > 0\<close>
       by (auto simp del: ennreal_1 simp add: ennreal_1[symmetric] divide_ennreal ennreal_mult[symmetric] mult.assoc[symmetric])
         simp
     finally show ?thesis by simp
   qed
 qed
 
 theorem birkhoff_theorem_L1_nonergodic:
   fixes f::"'a \<Rightarrow> real"
   assumes [measurable]: "integrable M f"
   shows "(\<lambda>n. \<integral>\<^sup>+x. norm(birkhoff_sum f n x / n - real_cond_exp M Invariants f x) \<partial>M) \<longlonglongrightarrow> 0"
 proof -
   define g where "g = (\<lambda>x. max (f x) 0)"
   have g_int [measurable]: "integrable M g" unfolding g_def using assms by auto
   define h where "h = (\<lambda>x. max (-f x) 0)"
   have h_int [measurable]: "integrable M h" unfolding h_def using assms by auto
   have "f = (\<lambda>x. g x - h x)" unfolding g_def h_def by auto
   {
     fix n::nat assume "n > 0"
     have "\<And>x. birkhoff_sum f n x = birkhoff_sum g n x - birkhoff_sum h n x" using birkhoff_sum_diff \<open>f = (\<lambda>x. g x - h x)\<close> by auto
     then have "\<And>x. birkhoff_sum f n x / n = birkhoff_sum g n x / n - birkhoff_sum h n x / n" using \<open>n > 0\<close> by (simp add: diff_divide_distrib)
     moreover have "AE x in M. real_cond_exp M Invariants g x - real_cond_exp M Invariants h x = real_cond_exp M Invariants f x"
       using AE_symmetric[OF real_cond_exp_diff] g_int h_int \<open>f = (\<lambda>x. g x - h x)\<close> by auto
     ultimately have "AE x in M. birkhoff_sum f n x / n - real_cond_exp M Invariants f x =
         (birkhoff_sum g n x / n - real_cond_exp M Invariants g x) - (birkhoff_sum h n x / n - real_cond_exp M Invariants h x)"
       by auto
     then have *: "AE x in M. norm(birkhoff_sum f n x / n - real_cond_exp M Invariants f x) \<le>
       norm(birkhoff_sum g n x / n - real_cond_exp M Invariants g x) + norm(birkhoff_sum h n x / n - real_cond_exp M Invariants h x)"
       by auto
     have "(\<integral>\<^sup>+ x. norm(birkhoff_sum f n x / n - real_cond_exp M Invariants f x) \<partial>M) \<le>
       (\<integral>\<^sup>+ x. ennreal(norm(birkhoff_sum g n x / n - real_cond_exp M Invariants g x)) + norm(birkhoff_sum h n x / n - real_cond_exp M Invariants h x) \<partial>M)"
       apply (rule nn_integral_mono_AE) using * by (simp add: ennreal_plus[symmetric] del: ennreal_plus)
     also have "... = (\<integral>\<^sup>+ x. norm(birkhoff_sum g n x / n - real_cond_exp M Invariants g x) \<partial>M) + (\<integral>\<^sup>+ x. norm(birkhoff_sum h n x / n - real_cond_exp M Invariants h x) \<partial>M)"
       apply (rule nn_integral_add) apply auto using real_cond_exp_F_meas borel_measurable_cond_exp2 by measurable
     finally have "(\<integral>\<^sup>+ x. norm(birkhoff_sum f n x / n - real_cond_exp M Invariants f x) \<partial>M) \<le>
       (\<integral>\<^sup>+ x. norm(birkhoff_sum g n x / n - real_cond_exp M Invariants g x) \<partial>M) + (\<integral>\<^sup>+ x. norm(birkhoff_sum h n x / n - real_cond_exp M Invariants h x) \<partial>M)"
       by simp
   }
   then have *: "eventually (\<lambda>n. (\<integral>\<^sup>+ x. norm(birkhoff_sum f n x / n - real_cond_exp M Invariants f x) \<partial>M) \<le>
       (\<integral>\<^sup>+ x. norm(birkhoff_sum g n x / n - real_cond_exp M Invariants g x) \<partial>M) + (\<integral>\<^sup>+ x. norm(birkhoff_sum h n x / n - real_cond_exp M Invariants h x) \<partial>M))
       sequentially"
     using eventually_at_top_dense by auto
   have **: "eventually (\<lambda>n. (\<integral>\<^sup>+ x. norm(birkhoff_sum f n x / n - real_cond_exp M Invariants f x) \<partial>M) \<ge> 0) sequentially"
     by simp
 
   have "(\<lambda>n. (\<integral>\<^sup>+ x. norm(birkhoff_sum g n x / n - real_cond_exp M Invariants g x) \<partial>M)) \<longlonglongrightarrow> 0"
     apply (rule birkhoff_lemma_L1, auto simp add: g_int) unfolding g_def by auto
   moreover have "(\<lambda>n. (\<integral>\<^sup>+ x. norm(birkhoff_sum h n x / n - real_cond_exp M Invariants h x) \<partial>M)) \<longlonglongrightarrow> 0"
     apply (rule birkhoff_lemma_L1, auto simp add: h_int) unfolding h_def by auto
   ultimately have "(\<lambda>n. (\<integral>\<^sup>+ x. norm(birkhoff_sum g n x / n - real_cond_exp M Invariants g x) \<partial>M) + (\<integral>\<^sup>+ x. norm(birkhoff_sum h n x / n - real_cond_exp M Invariants h x) \<partial>M)) \<longlonglongrightarrow> 0"
     using tendsto_add[of _ 0 _ _ 0] by auto
   then show ?thesis
     using tendsto_sandwich[OF ** *] by auto
 qed
 
 
 subsubsection \<open>Conservativity of skew products\<close>
 
 text \<open>The behaviour of skew-products of the form $(x, y) \mapsto (Tx, y + f x)$ is directly related
 to Birkhoff theorem, as the iterates involve the Birkhoff sums in the fiber. Birkhoff theorem
 implies that such a skew product is conservative when the function $f$ has vanishing conditional
 expectation.
 
 To prove the theorem, assume by contradiction that a set $A$ with positive measure does not
 intersect its preimages. Replacing $A$ with a smaller set $C$, we can assume that $C$ is bounded in
 the $y$-direction, by a constant $N$, and also that all its nonempty vertical fibers, above the
 projection $Cx$, have a measure bounded from below. Then, by Birkhoff theorem, for any $r>0$, most
 of the first $n$ preimages of $C$ are contained in the set $\{|y| \leq r n+N\}$, of measure $O(r
 n)$. Hence, they can not be disjoint if $r < \mu(C)$. To make this argument rigorous, one should
 only consider the preimages whose $x$-component belongs to a set $Dx$ where the Birkhoff sums are
 small. This condition has a positive measure if $\mu(Cx) + \mu(Dx) > \mu(M)$, which one can ensure
 by taking $Dx$ large enough.\<close>
 
 theorem (in fmpt) skew_product_conservative:
   fixes f::"'a \<Rightarrow> real"
   assumes [measurable]: "integrable M f"
     and "AE x in M. real_cond_exp M Invariants f x = 0"
   shows "conservative_mpt (M \<Otimes>\<^sub>M lborel) (\<lambda>(x,y). (T x, y + f x))"
 proof (rule conservative_mptI)
   let ?TS = "(\<lambda>(x,y). (T x, y + f x))"
   let ?MS = "M \<Otimes>\<^sub>M (lborel::real measure)"
 
   have f_meas [measurable]: "f \<in> borel_measurable M" by auto
   have "mpt M T" by (simp add: mpt_axioms)
   with mpt_skew_product_real[OF this f_meas] show "mpt ?MS ?TS" by simp
   then interpret TS: mpt ?MS ?TS by auto
 
   fix A::"('a \<times> real) set"
   assume A1 [measurable]: "A \<in> sets ?MS" and A2: "emeasure ?MS A > 0"
   have "A = (\<Union>N::nat. A \<inter> {(x,y). abs(y) \<le> N})" by (auto simp add: real_arch_simple)
   then have *: "emeasure ?MS (\<Union>N::nat. A \<inter> {(x,y). abs(y) \<le> N}) > 0"
     using A2 by simp
 
   have "space ?MS = space M \<times> space (lborel::real measure)" using space_pair_measure by auto
   then have A_inc: "A \<subseteq> space M \<times> space (lborel::real measure)" using sets.sets_into_space[OF A1] by auto
 
   {
     fix N::nat
     have "{(x, y). abs(y) \<le> real N \<and> x \<in> space M} = space M \<times> {-(real N)..(real N)}" by auto
     then have "{(x, y). \<bar>y\<bar> \<le> real N \<and> x \<in> space M} \<in> sets ?MS" by auto
     then have "A \<inter> {(x, y). \<bar>y\<bar> \<le> real N \<and> x \<in> space M} \<in> sets ?MS" using A1 by auto
     moreover have "A \<inter> {(x,y). abs(y) \<le> real N} = A \<inter> {(x, y). \<bar>y\<bar> \<le> real N \<and> x \<in> space M}"
       using A_inc by blast
     ultimately have "A \<inter> {(x,y). abs(y) \<le> real N} \<in> sets ?MS" by auto
   }
   then have [measurable]: "\<And>N::nat. A \<inter> {(x, y). \<bar>y\<bar> \<le> real N} \<in> sets (M \<Otimes>\<^sub>M borel)" by auto
 
   have "\<exists>N::nat. emeasure ?MS (A \<inter> {(x,y). abs(y) \<le> N}) > 0"
     apply (rule emeasure_pos_unionE) using * by auto
   then obtain N::nat where N: "emeasure ?MS (A \<inter> {(x,y). abs(y) \<le> N}) > 0"
     by auto
 
   define B where "B = A \<inter> {(x,y). abs(y) \<le> N}"
   have B_meas [measurable]: "B \<in> sets (M \<Otimes>\<^sub>M lborel)" unfolding B_def by auto
   have "0 < emeasure (M \<Otimes>\<^sub>M lborel) B" unfolding B_def using N by auto
   also have "... = (\<integral>\<^sup>+x. emeasure lborel (Pair x -` B) \<partial>M)"
     apply (rule sigma_finite_measure.emeasure_pair_measure_alt)
     using B_meas by (auto simp add: lborel.sigma_finite_measure_axioms)
   finally have *: "(\<integral>\<^sup>+x. emeasure lborel (Pair x -` B) \<partial>M) > 0" by simp
 
   have "\<exists>Cx\<in>sets M. \<exists>e::real>0. emeasure M Cx > 0 \<and> (\<forall>x \<in> Cx. emeasure lborel (Pair x -` B) \<ge> e)"
     by (rule not_AE_zero_int_ennreal_E, auto simp add: *)
   then obtain Cx e where [measurable]: "Cx \<in> sets M" and Cxe: "e>(0::real)" "emeasure M Cx > 0" "\<And>x. x \<in> Cx \<Longrightarrow> emeasure lborel (Pair x -` B) \<ge> e"
     by blast
   define C where "C = B \<inter> (Cx \<times> (UNIV::real set))"
   have C_meas [measurable]: "C \<in> sets (M \<Otimes>\<^sub>M lborel)" unfolding C_def using B_meas by auto
   have Cx_fibers: "\<And>x. x \<in> Cx \<Longrightarrow> emeasure lborel (Pair x -` C) \<ge> e" using Cxe(3) C_def by auto
 
   define c where "c = (measure M Cx)/2"
   have "c > 0" unfolding c_def using Cxe(2) by (simp add: emeasure_eq_measure)
 
   text \<open>We will apply Birkhoff theorem to show that most preimages of $C$ at time $n$ are contained in a cylinder
   of height roughly $r n$, for some suitably small $r$. How small $r$ should be to get a
   contradiction can be determined at the end of the proof. It turns out that the good condition
   is the following one -- this is by no means obvious now.\<close>
 
   define r where "r = (if measure M (space M) = 0 then 1 else e * c / (4 * measure M (space M)))"
   have "r > 0" using \<open>e > 0\<close> \<open>c > 0\<close> unfolding r_def
     apply auto using measure_le_0_iff by fastforce
   have pos: "e*c-2*r*measure M (space M) > 0" using \<open>e > 0\<close> \<open>c > 0\<close> unfolding r_def by auto
 
   define Bgood where "Bgood = {x \<in> space M. (\<lambda>n. birkhoff_sum f n x / n) \<longlonglongrightarrow> 0}"
   have [measurable]: "Bgood \<in> sets M" unfolding Bgood_def by auto
   have *: "AE x in M. x \<in> Bgood" unfolding Bgood_def using birkhoff_theorem_AE_nonergodic[OF assms(1)] assms(2) by auto
   then have "emeasure M Bgood = emeasure M (space M)"
     by (intro emeasure_eq_AE) auto
 
   {
     fix x assume "x \<in> Bgood"
     then have "x \<in> space M" unfolding Bgood_def by auto
     have "(\<lambda>n. birkhoff_sum f n x / n) \<longlonglongrightarrow> 0" using \<open>x \<in> Bgood\<close> unfolding Bgood_def by auto
     moreover have "0 \<in> {-r<..<r}" "open {-r<..<r}" using \<open>r>0\<close> by auto
     ultimately have "eventually (\<lambda>n. birkhoff_sum f n x / n \<in> {-r<..<r}) sequentially"
       using topological_tendstoD by blast
     then obtain n0 where n0: "n0>0" "\<And>n. n \<ge> n0 \<Longrightarrow> birkhoff_sum f n x / n \<in> {-r<..<r}"
       using eventually_sequentially by (metis (mono_tags, lifting) le0 le_simps(3) neq0_conv)
     {
       fix n assume "n \<ge> n0"
       then have "n>0" using \<open>n0>0\<close> by auto
       with n0(2)[OF \<open>n \<ge> n0\<close>] have "abs(birkhoff_sum f n x / n) \<le> r" by auto
       then have "abs(birkhoff_sum f n x) \<le> r * n" using \<open>n>0\<close> by (simp add: divide_le_eq)
     }
     then have "x \<in> (\<Union>n0. {x \<in> space M. \<forall>n\<in>{n0..}. abs(birkhoff_sum f n x) \<le> r * n})" using \<open>x \<in> space M\<close> by blast
   }
   then have "AE x in M. x \<notin> space M - (\<Union>n0. {x \<in> space M. \<forall>n\<in>{n0..}. abs(birkhoff_sum f n x) \<le> r * n})"
     using * by auto
   then have eqM: "emeasure M (\<Union>n0. {x \<in> space M. \<forall>n\<in>{n0..}. abs(birkhoff_sum f n x) \<le> r * n}) = emeasure M (space M)"
     by (intro emeasure_eq_AE) auto
 
   have "(\<lambda>n0. emeasure M {x \<in> space M. \<forall>n\<in>{n0..}. abs(birkhoff_sum f n x) \<le> r * n} + c)
           \<longlonglongrightarrow> emeasure M (\<Union>n0. {x \<in> space M. \<forall>n\<in>{n0..}. abs(birkhoff_sum f n x) \<le> r * n}) + c"
     by (intro tendsto_intros Lim_emeasure_incseq) (auto simp add: incseq_def)
   moreover have "emeasure M (\<Union>n0. {x \<in> space M. \<forall>n\<in>{n0..}. abs(birkhoff_sum f n x) \<le> r * n}) + c > emeasure M (space M)"
     using eqM \<open>c > 0\<close> emeasure_eq_measure by auto
   ultimately have "eventually (\<lambda>n0. emeasure M {x \<in> space M. \<forall>n\<in>{n0..}. abs(birkhoff_sum f n x) \<le> r * n} + c > emeasure M (space M)) sequentially"
     unfolding order_tendsto_iff by auto
   then obtain n0 where n0: "emeasure M {x \<in> space M. \<forall>n\<in>{n0..}. abs(birkhoff_sum f n x) \<le> r * n} + c > emeasure M (space M)"
     using eventually_sequentially by auto
 
   define Dx where "Dx = {x \<in> space M. \<forall>n\<in>{n0..}. abs(birkhoff_sum f n x) \<le> r * n}"
   have Dx_meas [measurable]: "Dx \<in> sets M" unfolding Dx_def by auto
   have "emeasure M Dx + c \<ge> emeasure M (space M)" using n0 Dx_def by auto
 
   obtain n1::nat where n1: "n1 > max n0 ((measure M (space M) * 2 * N + e*c*n0 - e*c) / (e*c-2*r*measure M (space M)))"
     by (metis mult.commute mult.left_neutral numeral_One reals_Archimedean3 zero_less_numeral)
   then have "n1 > n0" by auto
   have n1_ineq: "n1 * (e*c-2*r*measure M (space M)) > (measure M (space M) * 2 * N + e*c*n0 - e*c)"
     using n1 pos by (simp add: pos_divide_less_eq)
 
   define D where "D = (\<lambda>n. Dx \<times> {-r*n1-N..r*n1+N} \<inter> (?TS^^n)-`C)"
   have Dn_meas [measurable]: "D n \<in> sets (M \<Otimes>\<^sub>M lborel)" for n
     unfolding D_def apply (rule TS.T_intersec_meas(2)) using C_meas by auto
 
   have "emeasure ?MS (D n) \<ge> e * c" if "n \<in> {n0..n1}" for n
   proof -
     have "n \<ge> n0" "n \<le> n1" using that by auto
     {
       fix x assume [simp]: "x \<in> space M"
 
       define F where "F = {y \<in> {-r*n1-N..r*n1+N}. y + birkhoff_sum f n x \<in> Pair ((T^^n)x) -`C}"
       have [measurable]: "F \<in> sets lborel" unfolding F_def by measurable
       {
         fix y::real
         have "(?TS^^n)(x,y) = ((T^^n)x, y + birkhoff_sum f n x)"
           using skew_product_real_iterates by simp
         then have "(indicator C ((?TS^^n) (x,y))::ennreal) = indicator Cx ((T^^n)x) * indicator (Pair ((T^^n)x) -`C) (y + birkhoff_sum f n x)"
           using C_def by (simp add: indicator_def)
         moreover have "(indicator (D n) (x, y)::ennreal) = indicator Dx x * indicator {-r*n1-N..r*n1+N} y * indicator C ((?TS^^n) (x,y))"
           unfolding D_def by (simp add: indicator_def)
         ultimately have "(indicator (D n) (x, y)::ennreal) = indicator Dx x * indicator {-r*n1-N..r*n1+N} y
             * indicator Cx ((T^^n)x) * indicator (Pair ((T^^n)x) -`C) (y + birkhoff_sum f n x)"
           by (simp add: mult.assoc)
         then have "(indicator (D n) (x, y)::ennreal) = indicator (Dx \<inter> (T^^n)-`Cx) x * indicator F y"
           unfolding F_def by (simp add: indicator_def)
       }
       then have "(\<integral>\<^sup>+y. indicator (D n) (x, y) \<partial>lborel) = (\<integral>\<^sup>+y. indicator (Dx \<inter> (T^^n)-`Cx) x * indicator F y \<partial>lborel)"
         by auto
       also have "... = indicator (Dx \<inter> (T^^n)-`Cx) x * (\<integral>\<^sup>+y. indicator F y \<partial>lborel)"
         by (rule nn_integral_cmult, auto)
       also have "... = indicator (Dx \<inter> (T^^n)-`Cx) x * emeasure lborel F" using \<open>F \<in> sets lborel\<close> by auto
       finally have A: "(\<integral>\<^sup>+y. indicator (D n) (x, y) \<partial>lborel) = indicator (Dx \<inter> (T^^n)-`Cx) x * emeasure lborel F"
         by simp
 
       have "(\<integral>\<^sup>+y. indicator (D n) (x, y) \<partial>lborel) \<ge> ennreal e * indicator (Dx \<inter> (T^^n)-`Cx) x"
       proof (cases)
         assume "indicator (Dx \<inter> (T^^n)-`Cx) x = (0::ennreal)"
         then show ?thesis by auto
       next
         assume "\<not>(indicator (Dx \<inter> (T^^n)-`Cx) x = (0::ennreal))"
         then have "x \<in> Dx \<inter> (T^^n)-`Cx" by (simp add: indicator_eq_0_iff)
         then have "x \<in> Dx" "(T^^n) x \<in> Cx" by auto
         then have "abs(birkhoff_sum f n x) \<le> r * n" using \<open>n \<in> {n0..n1}\<close> Dx_def by auto
         then have *: "abs(birkhoff_sum f n x) \<le> r * n1" using \<open>n \<le> n1\<close> \<open>r>0\<close>
           by (meson of_nat_le_iff order_trans real_mult_le_cancel_iff2)
 
         have F_expr: "F = {-r*n1-N..r*n1+N} \<inter> (+)(birkhoff_sum f n x) -` (Pair ((T^^n)x) -`C)"
           unfolding F_def by (auto simp add: add.commute)
         have "(Pair ((T^^n)x) -`C) \<subseteq> {real_of_int (- int N)..real N}" unfolding C_def B_def by auto
         then have "((+)(birkhoff_sum f n x)) -` (Pair ((T^^n)x) -`C) \<subseteq> {-N-birkhoff_sum f n x..N-birkhoff_sum f n x}"
           by auto
         also have "... \<subseteq> {-r * n1 - N .. r * n1 + N}" using * by auto
         finally have "F = ((+)(birkhoff_sum f n x)) -` (Pair ((T^^n)x) -`C)" unfolding F_expr by auto
 
         then have "emeasure lborel F = emeasure lborel ((+)(birkhoff_sum f n x) -` (Pair ((T^^n)x) -`C))" by auto
         also have "... = emeasure lborel (((+)(birkhoff_sum f n x) -` (Pair ((T^^n)x) -`C)) \<inter> space lborel)" by simp
         also have "... = emeasure (distr lborel borel ((+) (birkhoff_sum f n x))) (Pair ((T^^n)x) -`C)"
           apply (rule emeasure_distr[symmetric]) using C_meas by auto
         also have "... = emeasure lborel (Pair ((T^^n)x) -`C)" using lborel_distr_plus[of "birkhoff_sum f n x"] by simp
         also have "... \<ge> e" using Cx_fibers \<open>(T^^n) x \<in> Cx\<close> by auto
         finally have "emeasure lborel F \<ge> e" by auto
         then show ?thesis using A by (simp add: indicator_def)
       qed
     }
     moreover have "emeasure ?MS (D n) = (\<integral>\<^sup>+x. (\<integral>\<^sup>+y. indicator (D n) (x, y) \<partial>lborel) \<partial>M)"
       using Dn_meas lborel.emeasure_pair_measure by blast
     ultimately have "emeasure ?MS (D n) \<ge> (\<integral>\<^sup>+x. ennreal e * indicator (Dx \<inter> (T ^^ n) -` Cx) x \<partial>M)"
       by (simp add: nn_integral_mono)
     also have "(\<integral>\<^sup>+x. ennreal e * indicator (Dx \<inter> (T ^^ n) -` Cx) x \<partial>M) = e * (\<integral>\<^sup>+x. indicator (Dx \<inter> (T ^^ n) -` Cx) x \<partial>M)"
       apply (rule nn_integral_cmult) using \<open>e>0\<close> by auto
     also have "... = ennreal e * emeasure M (Dx \<inter> (T ^^ n) -` Cx)" by simp
     finally have *: "emeasure ?MS (D n) \<ge> ennreal e * emeasure M (Dx \<inter> (T ^^ n) -` Cx)" by auto
 
     have "c + emeasure M (space M) \<le> emeasure M Dx + emeasure M Cx"
       using \<open>emeasure M Dx + c \<ge> emeasure M (space M)\<close> unfolding c_def
       by (auto simp: emeasure_eq_measure ennreal_plus[symmetric] simp del: ennreal_plus)
     also have "... = emeasure M Dx + emeasure M ((T^^n)--`Cx)"
       by (simp add: T_vrestr_same_emeasure(2))
     also have "... = emeasure M (Dx \<union> ((T^^n)--`Cx)) + emeasure M (Dx \<inter> ((T^^n)--`Cx))"
       by (rule emeasure_union_inter, auto)
     also have "... \<le> emeasure M (space M) + emeasure M (Dx \<inter> ((T^^n)-`Cx))"
     proof -
       have "emeasure M (Dx \<union> ((T^^n)--`Cx)) \<le> emeasure M (space M)"
         by (rule emeasure_mono, auto simp add: sets.sets_into_space)
       moreover have "Dx \<inter> ((T^^n)--`Cx) = Dx \<inter> ((T^^n)-`Cx)"
         by (simp add: vrestr_intersec_in_space)
       ultimately show ?thesis by (metis add.commute add_left_mono)
     qed
     finally have "emeasure M (Dx \<inter> ((T^^n)-`Cx)) \<ge> c" by (simp add: emeasure_eq_measure)
     then have "ennreal e * emeasure M (Dx \<inter> ((T^^n)-`Cx)) \<ge> ennreal e * c" using \<open>e > 0\<close>
       using mult_left_mono by fastforce
     with * show "emeasure ?MS (D n) \<ge> e * c"
       using \<open>0<c\<close> \<open>0<e\<close> by (auto simp: ennreal_mult[symmetric])
   qed
 
   have "\<not>(disjoint_family_on D {n0..n1})"
   proof
     assume D: "disjoint_family_on D {n0..n1}"
     have "emeasure lborel {-r*n1-N..r*n1+N} = (r * real n1 + real N) - (- r * real n1 - real N)"
       apply (rule emeasure_lborel_Icc) using \<open>r>0\<close> by auto
     then have *: "emeasure lborel {-r*n1-N..r*n1+N} = ennreal(2 * r * real n1 + 2 * real N)"
       by (auto simp: ac_simps)
 
     have "ennreal(e * c) * (real n1 - real n0 + 1) = ennreal(e*c) * card {n0..n1}"
       using \<open>n1 > n0\<close> by (auto simp: ennreal_of_nat_eq_real_of_nat Suc_diff_le ac_simps of_nat_diff)
     also have "... = (\<Sum>n\<in>{n0..n1}. ennreal(e*c))"
       by (simp add: ac_simps)
     also have "... \<le> (\<Sum>n\<in>{n0..n1}. emeasure ?MS (D n))"
       using \<open>\<And>n. n \<in> {n0..n1} \<Longrightarrow> emeasure ?MS (D n) \<ge> e * c\<close> by (meson sum_mono)
     also have "... = emeasure ?MS (\<Union>n\<in>{n0..n1}. D n)"
       apply (rule sum_emeasure) using Dn_meas by (auto simp add: D)
     also have "... \<le> emeasure ?MS (space M \<times> {-r*n1-N..r*n1+N})"
       apply (rule emeasure_mono) unfolding D_def using sets.sets_into_space[OF Dx_meas] by auto
     also have "... = emeasure M (space M) * emeasure lborel {-r*n1-N..r*n1+N}"
       by (rule sigma_finite_measure.emeasure_pair_measure_Times, auto simp add: lborel.sigma_finite_measure_axioms)
     also have "... = emeasure M (space M) * ennreal(2 * r * real n1 + 2 * real N)"
       using * by auto
     finally have "ennreal(e * c) * (real n1- real n0+1) \<le> emeasure M (space M) * ennreal(2 * r * real n1 + 2 * real N)" by simp
     then have "e*c * (real n1- real n0 + 1) \<le> measure M (space M) * (2 * r * real n1 + 2 * real N)"
       using \<open>0<r\<close> \<open>0<e\<close> \<open>0<c\<close> \<open>n0 < n1\<close> emeasure_eq_measure by (auto simp: ennreal_mult'[symmetric] simp del: ennreal_plus)
     then have "0 \<le> measure M (space M) * (2 * r * real n1 + 2 * real N) - e*c * (real n1- real n0 + 1)" by auto
     also have "... = (measure M (space M) * 2 * N + e*c*n0 - e*c) - n1 * (e*c-2*r*measure M (space M))"
       by algebra
     finally have "n1 * (e*c-2*r*measure M (space M)) \<le> measure M (space M) * 2 * N + e*c*n0 - e*c"
       by linarith
     then show False using n1_ineq by auto
   qed
   then obtain n m where nm: "n<m" "D m \<inter> D n \<noteq> {}" unfolding disjoint_family_on_def by (metis inf_sup_aci(1) linorder_cases)
   define k where "k = m-n"
   then have "k>0" "D (n+k) \<inter> D n \<noteq> {}" using nm by auto
   then have "((?TS^^(n+k))-`A) \<inter> ((?TS^^n)-`A) \<noteq> {}" unfolding D_def C_def B_def by auto
   moreover have "((?TS^^(n+k))-`A) \<inter> ((?TS^^n)-`A) = (?TS^^n)-`(((?TS^^k)-`A) \<inter> A)"
     using funpow_add by (simp add: add.commute funpow_add set.compositionality)
   ultimately have "((?TS^^k)-`A) \<inter> A \<noteq> {}" by auto
   then show "\<exists>k>0. ((?TS^^k)-`A) \<inter> A \<noteq> {}" using \<open>k>0\<close> by auto
 qed
 
 
 
 subsubsection \<open>Oscillations around the limit in Birkhoff theorem\<close>
 
 text \<open>In this paragraph, we prove that, in Birkhoff theorem with vanishing limit, the Birkhoff sums
 are infinitely many times arbitrarily close to $0$, both on the positive and the negative side.
 
 In the ergodic case, this statement implies for instance that if the Birkhoff sums of an integrable
 function tend to infinity almost everywhere, then the integral of the function can not vanish, it
 has to be strictly positive (while Birkhoff theorem per se does not exclude the convergence to
 infinity, at a rate slower than linear). This converts a qualitative information (convergence to
 infinity at an unknown rate) to a quantitative information (linear convergence to infinity). This
 result (sometimes known as Atkinson's Lemma) has been reinvented many times, for instance by Kesten
 and by Guivarch. It plays an important role in the study of random products of matrices.
 
 This is essentially a consequence of the conservativity of the corresponding skew-product, proved in
 \verb+skew_product_conservative+. Indeed, this implies that, starting from a small set $X \times
 [-e/2, e/2]$, the skew-product comes back infinitely often to itself, which implies that the
 Birkhoff sums at these times are bounded by $e$.
 
 To show that the Birkhoff sums come back to $[0,e]$ is a little bit more tricky. Argue by
 contradiction, and induce on $A \times [0,e/2]$ where $A$ is the set of points where the Birkhoff
 sums don't come back to $[0,e]$. Then the second coordinate decreases strictly when one iterates the
 skew product, which is not compatible with conservativity.\<close>
 
 lemma birkhoff_sum_small_asymp_lemma:
   assumes [measurable]: "integrable M f"
     and "AE x in M. real_cond_exp M Invariants f x = 0" "e>(0::real)"
   shows "AE x in M. infinite {n. birkhoff_sum f n x \<in> {0..e}}"
 proof -
   have [measurable]: "f \<in> borel_measurable M" by auto
   have [measurable]: "\<And>N. {x \<in> space M. \<exists>N. \<forall>n\<in>{N..}. birkhoff_sum f n x \<notin> {0..e}} \<in> sets M" by auto
 
   {
     fix N assume "N>(0::nat)"
     define Ax where "Ax = {x \<in> space M. \<forall>n\<in>{N..}. birkhoff_sum f n x \<notin> {0..e}}"
     then have [measurable]: "Ax \<in> sets M" by auto
     define A where "A = Ax \<times> {0..e/2}"
     then have A_meas [measurable]: "A \<in> sets (M \<Otimes>\<^sub>M lborel)" by auto
 
     define TN where "TN = T^^N"
     interpret TN: fmpt M TN
       unfolding TN_def using fmpt_power by auto
     define fN where "fN = birkhoff_sum f N"
     have "TN.birkhoff_sum fN n x = birkhoff_sum f (n*N) x" for n x
     proof (induction n)
       case 0
       then show ?case by auto
     next
       case (Suc n)
       have "TN.birkhoff_sum fN (Suc n) x = TN.birkhoff_sum fN n x + fN ((TN^^n) x)"
         using TN.birkhoff_sum_cocycle[of fN n 1] by auto
       also have "... = birkhoff_sum f (n*N) x + birkhoff_sum f N ((TN^^n) x)"
         using Suc.IH fN_def by auto
       also have "... = birkhoff_sum f (n*N+N) x" unfolding TN_def
         by (subst funpow_mult, subst mult.commute[of N n], rule birkhoff_sum_cocycle[of f "n*N" N x, symmetric])
       finally show ?case by (simp add: add.commute)
     qed
     then have not0e: "\<And>x n. x \<in> Ax \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> TN.birkhoff_sum fN n x \<notin> {0..e}" unfolding Ax_def by auto
 
     let ?TS = "(\<lambda>(x,y). (T x, y + f x))"
     let ?MS = "M \<Otimes>\<^sub>M (lborel::real measure)"
     interpret TS: conservative_mpt ?MS ?TS
       by (rule skew_product_conservative, auto simp add: assms)
 
     let ?TSN = "(\<lambda>(x,y). (TN x, y + fN x))"
     have *:"?TSN = ?TS^^N" unfolding TN_def fN_def using skew_product_real_iterates by auto
     interpret TSN: conservative_mpt ?MS ?TSN
       using * TS.conservative_mpt_power by auto
 
     define MA TA where "MA = restrict_space ?MS A" and "TA = TSN.induced_map A"
     interpret TA: conservative_mpt MA TA unfolding MA_def TA_def
       by (rule TSN.induced_map_conservative_mpt, measurable)
     have *: "\<And> x y. snd (TA (x,y)) = snd (x,y) + TN.birkhoff_sum fN (TSN.return_time_function A (x,y)) x"
       unfolding TA_def TSN.induced_map_def using TN.skew_product_real_iterates Pair_def by auto
     have [measurable]: "snd \<in> borel_measurable ?MS" by auto
     then have [measurable]: "snd \<in> borel_measurable MA" unfolding MA_def using measurable_restrict_space1 by blast
 
     have "AE z in MA. z \<in> TSN.recurrent_subset A"
       unfolding MA_def using TSN.induced_map_recurrent_typical(1)[OF A_meas].
     moreover
     {
       fix z assume z: "z \<in> TSN.recurrent_subset A"
       define x y where "x = fst z" and "y = snd z"
       then have "z = (x,y)" by simp
       have "z \<in> A" using z "TSN.recurrent_subset_incl"(1) by auto
       then have "x \<in> Ax" "y \<in> {0..e/2}" unfolding A_def x_def y_def by auto
       define y2 where "y2 = y + TN.birkhoff_sum fN (TSN.return_time_function A (x,y)) x"
       have "y2 = snd (TA z)" unfolding y2_def using * \<open>z = (x, y)\<close> by force
       moreover have "TA z \<in> A" unfolding TA_def using \<open>z \<in> A\<close> TSN.induced_map_stabilizes_A by auto
       ultimately have "y2 \<in> {0..e/2}" unfolding A_def by auto
 
       have "TSN.return_time_function A (x,y) \<noteq> 0"
         using \<open>z = (x,y)\<close> \<open>z \<in> TSN.recurrent_subset A\<close> TSN.return_time0[of A] by fast
       then have "TN.birkhoff_sum fN (TSN.return_time_function A (x,y)) x \<notin> {0..e}"
         using not0e[OF \<open>x \<in> Ax\<close>] by auto
       moreover have "TN.birkhoff_sum fN (TSN.return_time_function A (x,y)) x \<in> {-e..e}"
         using \<open>y \<in> {0..e/2}\<close> \<open>y2 \<in> {0..e/2}\<close> y2_def by auto
       ultimately have "TN.birkhoff_sum fN (TSN.return_time_function A (x,y)) x \<in> {-e..<0}"
         by auto
       then have "y2 < y" using y2_def by auto
       then have "snd(TA z) < snd z" unfolding y_def using \<open>y2 = snd (TA z)\<close> by auto
     }
     ultimately have a: "AE z in MA. snd(TA z) < snd z" by auto
     then have "AE z in MA. snd(TA z) \<le> snd z" by auto
     then have "AE z in MA. snd(TA z) = snd z" using TA.AE_decreasing_then_invariant[of snd] by auto
     then have "AE z in MA. False" using a by auto
     then have "space MA \<in> null_sets MA" by (simp add: AE_iff_null_sets)
     then have "emeasure MA A = 0" by (metis A_meas MA_def null_setsD1 space_restrict_space2)
     then have "emeasure ?MS A = 0" unfolding MA_def
       by (metis A_meas emeasure_restrict_space sets.sets_into_space sets.top space_restrict_space space_restrict_space2)
     moreover have "emeasure ?MS A = emeasure M Ax * emeasure lborel {0..e/2}"
       unfolding A_def by (intro lborel.emeasure_pair_measure_Times) auto
     ultimately have "emeasure M {x \<in> space M. \<forall>n\<in>{N..}. birkhoff_sum f n x \<notin> {0..e}} = 0" using \<open>e>0\<close> Ax_def by simp
     then have "{x \<in> space M. \<forall>n\<in>{N..}. birkhoff_sum f n x \<notin> {0..e}} \<in> null_sets M" by auto
   }
   then have "(\<Union>N\<in>{0<..}. {x \<in> space M. \<forall>n\<in>{N..}. birkhoff_sum f n x \<notin> {0..e}}) \<in> null_sets M" by (auto simp: greaterThan_0)
   moreover have "{x \<in> space M. \<not>(infinite {n. birkhoff_sum f n x \<in> {0..e}})} \<subseteq> (\<Union>N\<in>{0<..}. {x \<in> space M. \<forall>n\<in>{N..}. birkhoff_sum f n x \<notin> {0..e}})"
   proof
     fix x assume H: "x \<in> {x \<in> space M. \<not>(infinite {n. birkhoff_sum f n x \<in> {0..e}})}"
     then have "x \<in> space M" by auto
     have *: "finite {n. birkhoff_sum f n x \<in> {0..e}}" using H by auto
     then obtain N where "\<And>n. n \<ge> N \<Longrightarrow> n \<notin> {n. birkhoff_sum f n x \<in> {0..e}}"
       by (metis finite_nat_set_iff_bounded not_less)
     then have "x \<in> {x \<in> space M. \<forall>n\<in>{N+1..}. birkhoff_sum f n x \<notin> {0..e}}" using \<open>x \<in> space M\<close> by auto
     moreover have "N+1>0" by auto
     ultimately show "x \<in> (\<Union>N\<in>{0<..}. {x \<in> space M. \<forall>n\<in>{N..}. birkhoff_sum f n x \<notin> {0..e}})" by auto
   qed
   ultimately show ?thesis unfolding eventually_ae_filter by auto
 qed
 
 theorem birkhoff_sum_small_asymp_pos_nonergodic:
   assumes [measurable]: "integrable M f" and "e > (0::real)"
   shows "AE x in M. infinite {n. birkhoff_sum f n x \<in> {n * real_cond_exp M Invariants f x .. n * real_cond_exp M Invariants f x + e}}"
 proof -
   define g where "g = (\<lambda>x. f x - real_cond_exp M Invariants f x)"
   have g_meas [measurable]: "integrable M g" unfolding g_def using real_cond_exp_int(1)[OF assms(1)] assms(1) by auto
   have "AE x in M. real_cond_exp M Invariants (real_cond_exp M Invariants f) x = real_cond_exp M Invariants f x"
     by (rule real_cond_exp_F_meas, auto simp add: real_cond_exp_int(1)[OF assms(1)])
   then have *: "AE x in M. real_cond_exp M Invariants g x = 0"
     unfolding g_def using real_cond_exp_diff[OF assms(1) real_cond_exp_int(1)[OF assms(1)]] by auto
   have "AE x in M. infinite {n. birkhoff_sum g n x \<in> {0..e}}"
     by (rule birkhoff_sum_small_asymp_lemma, auto simp add: \<open>e>0\<close> * g_meas)
   moreover
   {
     fix x assume "x \<in> space M" "infinite {n. birkhoff_sum g n x \<in> {0..e}}"
     {
       fix n assume H: "birkhoff_sum g n x \<in> {0..e}"
       have "birkhoff_sum g n x = birkhoff_sum f n x - birkhoff_sum (real_cond_exp M Invariants f) n x"
         unfolding g_def using birkhoff_sum_diff by auto
       also have "... = birkhoff_sum f n x - n * real_cond_exp M Invariants f x"
         using birkhoff_sum_of_invariants \<open>x \<in> space M\<close> by auto
       finally have "birkhoff_sum f n x \<in> {n * real_cond_exp M Invariants f x .. n * real_cond_exp M Invariants f x + e}" using H by simp
     }
     then have "{n. birkhoff_sum g n x \<in> {0..e}} \<subseteq> {n. birkhoff_sum f n x \<in> {n * real_cond_exp M Invariants f x .. n * real_cond_exp M Invariants f x + e}}"
       by auto
     then have "infinite {n. birkhoff_sum f n x \<in> {n * real_cond_exp M Invariants f x .. n * real_cond_exp M Invariants f x + e}}"
       using \<open>infinite {n. birkhoff_sum g n x \<in> {0..e}}\<close> finite_subset by blast
   }
   ultimately show ?thesis by auto
 qed
 
 theorem birkhoff_sum_small_asymp_neg_nonergodic:
   assumes [measurable]: "integrable M f" and "e > (0::real)"
   shows "AE x in M. infinite {n. birkhoff_sum f n x \<in> {n * real_cond_exp M Invariants f x - e .. n * real_cond_exp M Invariants f x}}"
 proof -
   define g where "g = (\<lambda>x. real_cond_exp M Invariants f x - f x)"
   have g_meas [measurable]: "integrable M g" unfolding g_def using real_cond_exp_int(1)[OF assms(1)] assms(1) by auto
   have "AE x in M. real_cond_exp M Invariants (real_cond_exp M Invariants f) x = real_cond_exp M Invariants f x"
     by (rule real_cond_exp_F_meas, auto simp add: real_cond_exp_int(1)[OF assms(1)])
   then have *: "AE x in M. real_cond_exp M Invariants g x = 0"
     unfolding g_def using real_cond_exp_diff[OF real_cond_exp_int(1)[OF assms(1)] assms(1)] by auto
   have "AE x in M. infinite {n. birkhoff_sum g n x \<in> {0..e}}"
     by (rule birkhoff_sum_small_asymp_lemma, auto simp add: \<open>e>0\<close> * g_meas)
   moreover
   {
     fix x assume "x \<in> space M" "infinite {n. birkhoff_sum g n x \<in> {0..e}}"
     {
       fix n assume H: "birkhoff_sum g n x \<in> {0..e}"
       have "birkhoff_sum g n x = birkhoff_sum (real_cond_exp M Invariants f) n x - birkhoff_sum f n x"
         unfolding g_def using birkhoff_sum_diff by auto
       also have "... = n * real_cond_exp M Invariants f x - birkhoff_sum f n x"
         using birkhoff_sum_of_invariants \<open>x \<in> space M\<close> by auto
       finally have "birkhoff_sum f n x \<in> {n * real_cond_exp M Invariants f x - e .. n * real_cond_exp M Invariants f x}" using H by simp
     }
     then have "{n. birkhoff_sum g n x \<in> {0..e}} \<subseteq> {n. birkhoff_sum f n x \<in> {n * real_cond_exp M Invariants f x - e .. n * real_cond_exp M Invariants f x}}"
       by auto
     then have "infinite {n. birkhoff_sum f n x \<in> {n * real_cond_exp M Invariants f x - e .. n * real_cond_exp M Invariants f x}}"
       using \<open>infinite {n. birkhoff_sum g n x \<in> {0..e}}\<close> finite_subset by blast
   }
   ultimately show ?thesis by auto
 qed
 
 
 subsubsection \<open>Conditional expectation for the induced map\<close>
 
 text \<open>Thanks to Birkhoff theorem, one can relate conditional expectations with respect to the invariant
 sigma algebra, for a map and for a corresponding induced map, as follows.\<close>
 
 proposition Invariants_cond_exp_induced_map:
   fixes f::"'a \<Rightarrow> real"
   assumes [measurable]: "A \<in> sets M" "integrable M f"
   defines "MA \<equiv> restrict_space M A" and "TA \<equiv> induced_map A" and "fA \<equiv> induced_function A f"
   shows "AE x in MA. real_cond_exp MA (qmpt.Invariants MA TA) fA x
       = real_cond_exp M Invariants f x * real_cond_exp MA (qmpt.Invariants MA TA) (return_time_function A) x"
 proof -
   interpret A: fmpt MA TA unfolding MA_def TA_def by (rule induced_map_fmpt[OF assms(1)])
 
   have "integrable M fA" unfolding fA_def using induced_function_integral_nonergodic(1) assms by auto
   then have "integrable MA fA" unfolding MA_def
     by (metis assms(1) integrable_mult_indicator integrable_restrict_space sets.Int_space_eq2)
   then have a: "AE x in MA. (\<lambda>n. A.birkhoff_sum fA n x / n) \<longlonglongrightarrow> real_cond_exp MA A.Invariants fA x"
     using A.birkhoff_theorem_AE_nonergodic by auto
 
   have "AE x in M. (\<lambda>n. birkhoff_sum f n x / n) \<longlonglongrightarrow> real_cond_exp M Invariants f x"
     using birkhoff_theorem_AE_nonergodic assms(2) by auto
   then have b: "AE x in MA. (\<lambda>n. birkhoff_sum f n x / n) \<longlonglongrightarrow> real_cond_exp M Invariants f x"
     unfolding MA_def by (metis (mono_tags, lifting) AE_restrict_space_iff assms(1) eventually_mono sets.Int_space_eq2)
 
   define phiA where "phiA = (\<lambda>x. return_time_function A x)"
   have "integrable M phiA" unfolding phiA_def using return_time_integrable by auto
   then have "integrable MA phiA" unfolding MA_def
     by (metis assms(1) integrable_mult_indicator integrable_restrict_space sets.Int_space_eq2)
   then have c: "AE x in MA. (\<lambda>n. A.birkhoff_sum (\<lambda>x. real(phiA x)) n x / n) \<longlonglongrightarrow> real_cond_exp MA A.Invariants phiA x"
     using A.birkhoff_theorem_AE_nonergodic by auto
 
   have "A-recurrent_subset A \<in> null_sets M" using Poincare_recurrence_thm(1)[OF assms(1)] by auto
   then have "A - recurrent_subset A \<in> null_sets MA" unfolding MA_def
     by (metis Diff_subset assms(1) emeasure_restrict_space null_setsD1 null_setsD2 null_setsI sets.Int_space_eq2 sets_restrict_space_iff)
   then have "AE x in MA. x \<in> recurrent_subset A"
     by (simp add: AE_iff_null MA_def null_setsD2 set_diff_eq space_restrict_space2)
   moreover have "\<And>x. x \<in> recurrent_subset A \<Longrightarrow> phiA x > 0" unfolding phiA_def using return_time0 by fastforce
   ultimately have *: "AE x in MA. phiA x > 0" by auto
   have d: "AE x in MA. real_cond_exp MA A.Invariants phiA x > 0"
     by (rule A.real_cond_exp_gr_c, auto simp add: * \<open>integrable MA phiA\<close>)
 
   {
     fix x
     assume A: "(\<lambda>n. A.birkhoff_sum fA n x / n) \<longlonglongrightarrow> real_cond_exp MA A.Invariants fA x"
        and B: "(\<lambda>n. birkhoff_sum f n x / n) \<longlonglongrightarrow> real_cond_exp M Invariants f x"
        and C: "(\<lambda>n. A.birkhoff_sum (\<lambda>x. real(phiA x)) n x / n) \<longlonglongrightarrow> real_cond_exp MA A.Invariants phiA x"
        and D: "real_cond_exp MA A.Invariants phiA x > 0"
     define R where "R = (\<lambda>n. A.birkhoff_sum phiA n x)"
 
     have D2: "ereal(real_cond_exp MA A.Invariants phiA x) > 0" using D by simp
     have "\<And>n. real(R n)/ n = A.birkhoff_sum (\<lambda>x. real(phiA x)) n x / n" unfolding R_def A.birkhoff_sum_def by auto
     moreover have "(\<lambda>n. A.birkhoff_sum (\<lambda>x. real(phiA x)) n x / n) \<longlonglongrightarrow> real_cond_exp MA A.Invariants phiA x" using C by auto
     ultimately have Rnn: "(\<lambda>n. real(R n)/n) \<longlonglongrightarrow> real_cond_exp MA A.Invariants phiA x" by presburger
 
     have "\<And>n. ereal(real(R n))/ n = ereal(A.birkhoff_sum (\<lambda>x. real(phiA x)) n x / n)" unfolding R_def A.birkhoff_sum_def by auto
     moreover have "(\<lambda>n. ereal(A.birkhoff_sum (\<lambda>x. real(phiA x)) n x / n)) \<longlonglongrightarrow> real_cond_exp MA A.Invariants phiA x" using C by auto
     ultimately have i: "(\<lambda>n. ereal(real(R n))/n) \<longlonglongrightarrow> real_cond_exp MA A.Invariants phiA x" by auto
     have ii: "(\<lambda>n. real n) \<longlonglongrightarrow> \<infinity>" by (rule id_nat_ereal_tendsto_PInf)
     have iii: "(\<lambda>n. ereal(real(R n))/n * real n) \<longlonglongrightarrow> \<infinity>" using tendsto_mult_ereal_PInf[OF i D2 ii] by simp
     have "\<And>n. n > 0 \<Longrightarrow> ereal(real(R n))/n * real n = R n" by auto
     then have "eventually (\<lambda>n. ereal(real(R n))/n * real n = R n) sequentially" using eventually_at_top_dense by auto
     then have "(\<lambda>n. real(R n)) \<longlonglongrightarrow> \<infinity>" using iii by (simp add: filterlim_cong)
     then have "(\<lambda>n. birkhoff_sum f (R n) x / (R n)) \<longlonglongrightarrow> real_cond_exp M Invariants f x" using limit_along_weak_subseq B by auto
     then have l: "(\<lambda>n. (birkhoff_sum f (R n) x / (R n)) * ((R n)/n)) \<longlonglongrightarrow> real_cond_exp M Invariants f x * real_cond_exp MA A.Invariants phiA x"
       by (rule tendsto_mult, simp add: Rnn)
     obtain N where N: "\<And>n. n > N \<Longrightarrow> R n > 0" using \<open>(\<lambda>n. real(R n)) \<longlonglongrightarrow> \<infinity>\<close>
       by (metis (full_types) eventually_at_top_dense filterlim_iff filterlim_weak_subseq)
     then have "\<And>n. n > N \<Longrightarrow> (birkhoff_sum f (R n) x / (R n)) * ((R n)/n) = birkhoff_sum f (R n) x / n"
       by auto
     then have "eventually (\<lambda>n. (birkhoff_sum f (R n) x / (R n)) * ((R n)/n) = birkhoff_sum f (R n) x / n) sequentially"
       by simp
     with tendsto_cong[OF this] have main_limit: "(\<lambda>n. birkhoff_sum f (R n) x / n) \<longlonglongrightarrow> real_cond_exp M Invariants f x * real_cond_exp MA A.Invariants phiA x"
       using l by auto
     have "\<And>n. birkhoff_sum f (R n) x = A.birkhoff_sum fA n x"
       unfolding R_def fA_def phiA_def TA_def using induced_function_birkhoff_sum[OF assms(1)] by simp
     then have "\<And>n. birkhoff_sum f (R n) x /n = A.birkhoff_sum fA n x / n" by simp
     then have "(\<lambda>n. A.birkhoff_sum fA n x / n) \<longlonglongrightarrow> real_cond_exp M Invariants f x * real_cond_exp MA A.Invariants phiA x"
       using main_limit by presburger
     then have "real_cond_exp MA A.Invariants fA x = real_cond_exp M Invariants f x * real_cond_exp MA A.Invariants phiA x"
       using A LIMSEQ_unique by auto
   }
   then show ?thesis using a b c d unfolding phiA_def by auto
 qed
 
 corollary Invariants_cond_exp_induced_map_0:
   fixes f::"'a \<Rightarrow> real"
   assumes [measurable]: "A \<in> sets M" "integrable M f" and "AE x in M. real_cond_exp M Invariants f x = 0"
   defines "MA \<equiv> restrict_space M A" and "TA \<equiv> induced_map A" and "fA \<equiv> induced_function A f"
   shows "AE x in MA. real_cond_exp MA (qmpt.Invariants MA TA) fA x = 0"
 proof -
   have "AE x in MA. real_cond_exp M Invariants f x = 0" unfolding MA_def
     apply (subst AE_restrict_space_iff) using assms(3) by auto
   then show ?thesis unfolding MA_def TA_def fA_def using Invariants_cond_exp_induced_map[OF assms(1) assms(2)]
     by auto
 qed
 
 end (*of locale fmpt*)
 end (*of Invariants.thy*)
 
diff --git a/thys/Gromov_Hyperbolicity/Isometries.thy b/thys/Gromov_Hyperbolicity/Isometries.thy
--- a/thys/Gromov_Hyperbolicity/Isometries.thy
+++ b/thys/Gromov_Hyperbolicity/Isometries.thy
@@ -1,3158 +1,3160 @@
 (*  Author:  Sébastien Gouëzel   sebastien.gouezel@univ-rennes1.fr
     License: BSD
 *)
 
 section \<open>Isometries\<close>
 
 theory Isometries
   imports Library_Complements Hausdorff_Distance
 begin
 
 text \<open>Isometries, i.e., functions that preserve distances, show up very often in mathematics.
 We introduce a dedicated definition, and show its basic properties.\<close>
 
 definition isometry_on::"('a::metric_space) set \<Rightarrow> ('a \<Rightarrow> ('b::metric_space)) \<Rightarrow> bool"
   where "isometry_on X f = (\<forall>x \<in> X. \<forall>y \<in> X. dist (f x) (f y) = dist x y)"
 
 definition isometry :: "('a::metric_space \<Rightarrow> 'b::metric_space) \<Rightarrow> bool"
   where "isometry f \<equiv> isometry_on UNIV f \<and> range f = UNIV"
 
 lemma isometry_on_subset:
   assumes "isometry_on X f"
           "Y \<subseteq> X"
   shows "isometry_on Y f"
 using assms unfolding isometry_on_def by auto
 
 lemma isometry_onI [intro?]:
   assumes "\<And>x y. x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> dist (f x) (f y) = dist x y"
   shows "isometry_on X f"
 using assms unfolding isometry_on_def by auto
 
 lemma isometry_onD:
   assumes "isometry_on X f"
           "x \<in> X" "y \<in> X"
   shows "dist (f x) (f y) = dist x y"
 using assms unfolding isometry_on_def by auto
 
 lemma isometryI [intro?]:
   assumes "\<And>x y. dist (f x) (f y) = dist x y"
           "range f = UNIV"
   shows "isometry f"
 unfolding isometry_def isometry_on_def using assms by auto
 
 lemma
   assumes "isometry_on X f"
   shows isometry_on_lipschitz: "1-lipschitz_on X f"
     and isometry_on_uniformly_continuous: "uniformly_continuous_on X f"
     and isometry_on_continuous: "continuous_on X f"
 proof -
   show "1-lipschitz_on X f" apply (rule lipschitz_onI) using isometry_onD[OF assms] by auto
   then show "uniformly_continuous_on X f" "continuous_on X f"
     using lipschitz_on_uniformly_continuous lipschitz_on_continuous_on by auto
 qed
 
 lemma isometryD:
   assumes "isometry f"
   shows "isometry_on UNIV f"
         "dist (f x) (f y) = dist x y"
         "range f = UNIV"
         "1-lipschitz_on UNIV f"
         "uniformly_continuous_on UNIV f"
         "continuous_on UNIV f"
 using assms unfolding isometry_def isometry_on_def apply auto
 using isometry_on_lipschitz isometry_on_uniformly_continuous isometry_on_continuous assms unfolding isometry_def by blast+
 
 lemma isometry_on_injective:
   assumes "isometry_on X f"
   shows "inj_on f X"
 using assms inj_on_def isometry_on_def by force
 
 lemma isometry_on_compose:
   assumes "isometry_on X f"
           "isometry_on (f`X) g"
   shows "isometry_on X (\<lambda>x. g(f x))"
 using assms unfolding isometry_on_def by auto
 
 lemma isometry_on_cong:
   assumes "isometry_on X f"
           "\<And>x. x \<in> X \<Longrightarrow> g x = f x"
   shows "isometry_on X g"
 using assms unfolding isometry_on_def by auto
 
 lemma isometry_on_inverse:
   assumes "isometry_on X f"
   shows "isometry_on (f`X) (inv_into X f)"
         "\<And>x. x \<in> X \<Longrightarrow> (inv_into X f) (f x) = x"
         "\<And>y. y \<in> f`X \<Longrightarrow> f (inv_into X f y) = y"
         "bij_betw f X (f`X)"
 proof -
   show *: "bij_betw f X (f`X)"
     using assms unfolding bij_betw_def inj_on_def isometry_on_def by force
   show "isometry_on (f`X) (inv_into X f)"
     using assms unfolding isometry_on_def
     by (auto) (metis (mono_tags, lifting) dist_eq_0_iff inj_on_def inv_into_f_f)
   fix x assume "x \<in> X"
   then show "(inv_into X f) (f x) = x"
     using * by (simp add: bij_betw_def)
 next
   fix y assume "y \<in> f`X"
   then show "f (inv_into X f y) = y"
     by (simp add: f_inv_into_f)
 qed
 
 lemma isometry_inverse:
   assumes "isometry f"
   shows "isometry (inv f)"
         "bij f"
 using isometry_on_inverse[OF isometryD(1)[OF assms]] isometryD(3)[OF assms]
 unfolding isometry_def by (auto simp add: bij_imp_bij_inv bij_is_surj)
 
 lemma isometry_on_homeomorphism:
   assumes "isometry_on X f"
   shows "homeomorphism X (f`X) f (inv_into X f)"
         "homeomorphism_on X f"
         "X homeomorphic f`X"
 proof -
   show *: "homeomorphism X (f`X) f (inv_into X f)"
     apply (rule homeomorphismI) using uniformly_continuous_imp_continuous[OF isometry_on_uniformly_continuous]
     isometry_on_inverse[OF assms] assms by auto
   then show "X homeomorphic f`X"
     unfolding homeomorphic_def by auto
   show "homeomorphism_on X f"
     unfolding homeomorphism_on_def using * by auto
 qed
 
 lemma isometry_homeomorphism:
   fixes f::"('a::metric_space) \<Rightarrow> ('b::metric_space)"
   assumes "isometry f"
   shows "homeomorphism UNIV UNIV f (inv f)"
         "(UNIV::'a set) homeomorphic (UNIV::'b set)"
 using isometry_on_homeomorphism[OF isometryD(1)[OF assms]] isometryD(3)[OF assms] by auto
 
 lemma isometry_on_closure:
   assumes "isometry_on X f"
           "continuous_on (closure X) f"
   shows "isometry_on (closure X) f"
 proof (rule isometry_onI)
   fix x y assume "x \<in> closure X" "y \<in> closure X"
   obtain u v::"nat \<Rightarrow> 'a" where *: "\<And>n. u n \<in> X" "u \<longlonglongrightarrow> x"
                                    "\<And>n. v n \<in> X" "v \<longlonglongrightarrow> y"
     using \<open>x \<in> closure X\<close> \<open>y \<in> closure X\<close> unfolding closure_sequential by blast
   have "(\<lambda>n. f (u n)) \<longlonglongrightarrow> f x"
     using *(1) *(2) \<open>x \<in> closure X\<close> \<open>continuous_on (closure X) f\<close>
     unfolding comp_def continuous_on_closure_sequentially[of X f] by auto
   moreover have "(\<lambda>n. f (v n)) \<longlonglongrightarrow> f y"
     using *(3) *(4) \<open>y \<in> closure X\<close> \<open>continuous_on (closure X) f\<close>
     unfolding comp_def continuous_on_closure_sequentially[of X f] by auto
   ultimately have "(\<lambda>n. dist (f (u n)) (f (v n))) \<longlonglongrightarrow> dist (f x) (f y)"
     by (simp add: tendsto_dist)
   then have "(\<lambda>n. dist (u n) (v n)) \<longlonglongrightarrow> dist (f x) (f y)"
     using assms(1) *(1) *(3) unfolding isometry_on_def by auto
   moreover have "(\<lambda>n. dist (u n) (v n)) \<longlonglongrightarrow> dist x y"
     using *(2) *(4) by (simp add: tendsto_dist)
   ultimately show "dist (f x) (f y) = dist x y" using LIMSEQ_unique by auto
 qed
 
 lemma isometry_extend_closure:
   fixes f::"('a::metric_space) \<Rightarrow> ('b::complete_space)"
   assumes "isometry_on X f"
   shows "\<exists>g. isometry_on (closure X) g \<and> (\<forall>x\<in>X. g x = f x)"
 proof -
   obtain g where g: "\<And>x. x \<in> X \<Longrightarrow> g x = f x" "uniformly_continuous_on (closure X) g"
     using uniformly_continuous_on_extension_on_closure[OF isometry_on_uniformly_continuous[OF assms]] by metis
   have "isometry_on (closure X) g"
     apply (rule isometry_on_closure, rule isometry_on_cong[OF assms])
     using g uniformly_continuous_imp_continuous[OF g(2)] by auto
   then show ?thesis using g(1) by auto
 qed
 
 lemma isometry_on_complete_image:
   assumes "isometry_on X f"
           "complete X"
   shows "complete (f`X)"
 proof (rule completeI)
   fix u :: "nat \<Rightarrow> 'b" assume u: "\<forall>n. u n \<in> f`X" "Cauchy u"
   define v where "v = (\<lambda>n. inv_into X f (u n))"
   have "v n \<in> X" for n
     unfolding v_def by (simp add: inv_into_into u(1))
   have "dist (v n) (v m) = dist (u n) (u m)" for m n
     using u(1) isometry_on_inverse[OF \<open>isometry_on X f\<close>] unfolding isometry_on_def v_def by (auto simp add: inv_into_into)
   then have "Cauchy v"
     using u(2) unfolding Cauchy_def by auto
   obtain l where "l \<in> X" "v \<longlonglongrightarrow> l"
     apply (rule completeE[OF \<open>complete X\<close> _ \<open>Cauchy v\<close>]) using \<open>\<And>n. v n \<in> X\<close> by auto
   have "(\<lambda>n. f (v n)) \<longlonglongrightarrow> f l"
     apply (rule continuous_on_tendsto_compose[OF isometry_on_continuous[OF \<open>isometry_on X f\<close>]])
     using \<open>\<And>n. v n \<in> X\<close> \<open>l \<in> X\<close> \<open>v \<longlonglongrightarrow> l\<close> by auto
   moreover have "f(v n) = u n" for n
     unfolding v_def by (simp add: f_inv_into_f u(1))
   ultimately have "u \<longlonglongrightarrow> f l" by auto
   then show "\<exists>m \<in> f`X. u \<longlonglongrightarrow> m" using \<open>l \<in> X\<close> by auto
 qed
 
 lemma isometry_on_id [simp]:
   "isometry_on A (\<lambda>x. x)"
   "isometry_on A id"
 unfolding isometry_on_def by auto
 
 lemma isometry_on_add [simp]:
   "isometry_on A (\<lambda>x. x + (t::'a::real_normed_vector))"
 unfolding isometry_on_def by auto
 
 lemma isometry_on_minus [simp]:
   "isometry_on A (\<lambda>(x::'a::real_normed_vector). -x)"
 unfolding isometry_on_def by (auto simp add: dist_minus)
 
 lemma isometry_on_diff [simp]:
   "isometry_on A (\<lambda>x. (t::'a::real_normed_vector) - x)"
 unfolding isometry_on_def by (auto, metis add_uminus_conv_diff dist_add_cancel dist_minus)
 
 lemma isometry_preserves_bounded:
   assumes "isometry_on X f"
           "A \<subseteq> X"
   shows "bounded (f`A) \<longleftrightarrow> bounded A"
 unfolding bounded_two_points using assms(2) isometry_onD[OF assms(1)] by auto (metis assms(2) rev_subsetD)+
 
 lemma isometry_preserves_infdist:
   "infdist (f x) (f`A) = infdist x A"
   if "isometry_on X f" "A \<subseteq> X" "x \<in> X"
   using that by (simp add: infdist_def image_comp isometry_on_def subset_iff)
 
 lemma isometry_preserves_hausdorff_distance:
   "hausdorff_distance (f`A) (f`B) = hausdorff_distance A B"
   if "isometry_on X f" "A \<subseteq> X" "B \<subseteq> X"
   using that isometry_preserves_infdist [OF that(1) that(2)]
   isometry_preserves_infdist [OF that(1) that(3)]
   isometry_preserves_bounded [OF that(1) that(2)]
   isometry_preserves_bounded [OF that(1) that(3)]
   by (simp add: hausdorff_distance_def image_comp subset_eq)
 
 lemma isometry_on_UNIV_iterates:
   fixes f::"('a::metric_space) \<Rightarrow> 'a"
   assumes "isometry_on UNIV f"
   shows "isometry_on UNIV (f^^n)"
 by (induction n, auto, rule isometry_on_compose[of _ _ f], auto intro: isometry_on_subset[OF assms])
 
 lemma isometry_iterates:
   fixes f::"('a::metric_space) \<Rightarrow> 'a"
   assumes "isometry f"
   shows "isometry (f^^n)"
 using isometry_on_UNIV_iterates[OF isometryD(1)[OF assms], of n] bij_fn[OF isometry_inverse(2)[OF assms], of n]
 unfolding isometry_def by (simp add: bij_is_surj)
 
 section \<open>Geodesic spaces\<close>
 
 text \<open>A geodesic space is a metric space in which any pair of points can be joined by a geodesic segment,
 i.e., an isometrically embedded copy of a segment in the real line. Most spaces in geometry are
 geodesic. We introduce in this section the corresponding class of metric spaces. First, we study
 properties of general geodesic segments in metric spaces.\<close>
 
 subsection \<open>Geodesic segments in general metric spaces\<close>
 
 definition geodesic_segment_between::"('a::metric_space) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
   where "geodesic_segment_between G x y = (\<exists>g::(real \<Rightarrow> 'a). g 0 = x \<and> g (dist x y) = y \<and> isometry_on {0..dist x y} g \<and> G = g`{0..dist x y})"
 
 definition geodesic_segment::"('a::metric_space) set \<Rightarrow> bool"
   where "geodesic_segment G = (\<exists>x y. geodesic_segment_between G x y)"
 
 text \<open>We also introduce the parametrization of a geodesic segment. It is convenient to use the
 following definition, which guarantees that the point is on $G$ even without checking that $G$
 is a geodesic segment or that the parameter is in the reasonable range: this shortens some
 arguments below.\<close>
 
 definition geodesic_segment_param::"('a::metric_space) set \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> 'a"
   where "geodesic_segment_param G x t = (if \<exists>w. w \<in> G \<and> dist x w = t then SOME w. w \<in> G \<and> dist x w = t else SOME w. w \<in> G)"
 
 lemma geodesic_segment_betweenI:
   assumes "g 0 = x" "g (dist x y) = y" "isometry_on {0..dist x y} g" "G = g`{0..dist x y}"
   shows "geodesic_segment_between G x y"
 unfolding geodesic_segment_between_def apply (rule exI[of _ g]) using assms by auto
 
 lemma geodesic_segmentI [intro, simp]:
   assumes "geodesic_segment_between G x y"
   shows "geodesic_segment G"
 unfolding geodesic_segment_def using assms by auto
 
 lemma geodesic_segmentI2 [intro]:
   assumes "isometry_on {a..b} g" "a \<le> (b::real)"
   shows "geodesic_segment_between (g`{a..b}) (g a) (g b)"
         "geodesic_segment (g`{a..b})"
 proof -
   define h where "h = (\<lambda>t. g (t+a))"
   have *: "isometry_on {0..b-a} h"
     apply (rule isometry_onI)
     using \<open>isometry_on {a..b} g\<close> \<open>a \<le> b\<close> by (auto simp add: isometry_on_def h_def)
   have **: "dist (h 0) (h (b-a)) = b-a"
     using isometry_onD[OF \<open>isometry_on {0..b-a} h\<close>, of 0 "b-a"] \<open>a \<le> b\<close> unfolding dist_real_def by auto
   have "geodesic_segment_between (h`{0..b-a}) (h 0) (h (b-a))"
     unfolding geodesic_segment_between_def apply (rule exI[of _ h]) unfolding ** using * by auto
   moreover have "g`{a..b} = h`{0..b-a}"
     unfolding h_def apply (auto simp add: image_iff)
     by (metis add.commute atLeastAtMost_iff diff_ge_0_iff_ge diff_right_mono le_add_diff_inverse)
   moreover have "h 0 = g a" "h (b-a) = g b" unfolding h_def by auto
   ultimately show "geodesic_segment_between (g`{a..b}) (g a) (g b)" by auto
   then show "geodesic_segment (g`{a..b})" unfolding geodesic_segment_def by auto
 qed
 
 lemma geodesic_segmentD:
   assumes "geodesic_segment_between G x y"
   shows "\<exists>g::(real \<Rightarrow> _). (g t = x \<and> g (t + dist x y) = y \<and> isometry_on {t..t+dist x y} g \<and> G = g`{t..t+dist x y})"
 proof -
   obtain h where h: "h 0 = x" "h (dist x y) = y" "isometry_on {0..dist x y} h" "G = h`{0..dist x y}"
     by (meson \<open>geodesic_segment_between G x y\<close> geodesic_segment_between_def)
   have * [simp]: "(\<lambda>x. x - t) ` {t..t + dist x y} = {0..dist x y}" by auto
   define g where "g = (\<lambda>s. h (s - t))"
   have "g t = x" "g (t + dist x y) = y" using h assms(1) unfolding g_def by auto
   moreover have "isometry_on {t..t+dist x y} g"
     unfolding g_def apply (rule isometry_on_compose[of _ _ h])
     by (simp add: dist_real_def isometry_on_def, simp add: h(3))
   moreover have "g` {t..t + dist x y} = G" unfolding g_def h(4) using * by (metis image_image)
   ultimately show ?thesis by auto
 qed
 
 lemma geodesic_segment_endpoints [simp]:
   assumes "geodesic_segment_between G x y"
   shows "x \<in> G" "y \<in> G" "G \<noteq> {}"
 using assms unfolding geodesic_segment_between_def
   by (auto, metis atLeastAtMost_iff image_eqI less_eq_real_def zero_le_dist)
 
 lemma geodesic_segment_commute:
   assumes "geodesic_segment_between G x y"
   shows "geodesic_segment_between G y x"
 proof -
   obtain g::"real\<Rightarrow>'a" where g: "g 0 = x" "g (dist x y) = y" "isometry_on {0..dist x y} g" "G = g`{0..dist x y}"
     by (meson \<open>geodesic_segment_between G x y\<close> geodesic_segment_between_def)
   define h::"real\<Rightarrow>'a" where "h = (\<lambda>t. g(dist x y-t))"
   have "(\<lambda>t. dist x y -t)`{0..dist x y} = {0..dist x y}" by auto
   then have "h`{0..dist x y} = G" unfolding g(4) h_def by (metis image_image)
   moreover have "h 0 = y" "h (dist x y) = x" unfolding h_def using g by auto
   moreover have "isometry_on {0..dist x y} h"
     unfolding h_def apply (rule isometry_on_compose[of _ _ g]) using g(3) by auto
   ultimately show ?thesis
     unfolding geodesic_segment_between_def by (auto simp add: dist_commute)
 qed
 
 lemma geodesic_segment_dist:
   assumes "geodesic_segment_between G x y" "a \<in> G"
   shows "dist x a + dist a y = dist x y"
 proof -
   obtain g where g: "g 0 = x" "g (dist x y) = y" "isometry_on {0..dist x y} g" "G = g`{0..dist x y}"
     by (meson \<open>geodesic_segment_between G x y\<close> geodesic_segment_between_def)
   obtain t where t: "t \<in> {0..dist x y}" "a = g t"
     using g(4) assms by auto
   have "dist x a = t" using isometry_onD[OF g(3) _ t(1), of 0]
     unfolding g(1) dist_real_def t(2) using t(1) by auto
   moreover have "dist a y = dist x y - t" using isometry_onD[OF g(3) _ t(1), of "dist x y"]
     unfolding g(2) dist_real_def t(2) using t(1) by (auto simp add: dist_commute)
   ultimately show ?thesis by auto
 qed
 
 lemma geodesic_segment_dist_unique:
   assumes "geodesic_segment_between G x y" "a \<in> G" "b \<in> G" "dist x a = dist x b"
   shows "a = b"
 proof -
   obtain g where g: "g 0 = x" "g (dist x y) = y" "isometry_on {0..dist x y} g" "G = g`{0..dist x y}"
     by (meson \<open>geodesic_segment_between G x y\<close> geodesic_segment_between_def)
   obtain ta where ta: "ta \<in> {0..dist x y}" "a = g ta"
     using g(4) assms by auto
   have *: "dist x a = ta"
     unfolding g(1)[symmetric] ta(2) using isometry_onD[OF g(3), of 0 ta]
     unfolding dist_real_def using ta(1) by auto
   obtain tb where tb: "tb \<in> {0..dist x y}" "b = g tb"
     using g(4) assms by auto
   have "dist x b = tb"
     unfolding g(1)[symmetric] tb(2) using isometry_onD[OF g(3), of 0 tb]
     unfolding dist_real_def using tb(1) by auto
   then have "ta = tb" using * \<open>dist x a = dist x b\<close> by auto
   then show "a = b" using ta(2) tb(2) by auto
 qed
 
 lemma geodesic_segment_union:
   assumes "dist x z = dist x y + dist y z"
           "geodesic_segment_between G x y" "geodesic_segment_between H y z"
   shows "geodesic_segment_between (G \<union> H) x z"
         "G \<inter> H = {y}"
 proof -
   obtain g where g: "g 0 = x" "g (dist x y) = y" "isometry_on {0..dist x y} g" "G = g`{0..dist x y}"
     by (meson \<open>geodesic_segment_between G x y\<close> geodesic_segment_between_def)
   obtain h where h: "h (dist x y) = y" "h (dist x z) = z" "isometry_on {dist x y..dist x z} h" "H = h`{dist x y..dist x z}"
     unfolding \<open>dist x z = dist x y + dist y z\<close>
     using geodesic_segmentD[OF \<open>geodesic_segment_between H y z\<close>, of "dist x y"] by auto
   define f where "f = (\<lambda>t. if t \<le> dist x y then g t else h t)"
   have fg: "f t = g t" if "t \<le> dist x y" for t
     unfolding f_def using that by auto
   have fh: "f t = h t" if "t \<ge> dist x y" for t
     unfolding f_def apply (cases "t > dist x y") using that g(2) h(1) by auto
 
   have "f 0 = x" "f (dist x z) = z" using fg fh g(1) h(2) assms(1) by auto
 
   have "f`{0..dist x z} = f`{0..dist x y} \<union> f`{dist x y..dist x z}"
     unfolding assms(1) image_Un[symmetric] by (simp add: ivl_disj_un_two_touch(4))
   moreover have "f`{0..dist x y} = G"
     unfolding g(4) using fg image_cong by force
   moreover have "f`{dist x y..dist x z} = H"
     unfolding h(4) using fh image_cong by force
   ultimately have "f`{0..dist x z} = G \<union> H" by simp
 
   have Ifg: "dist (f s) (f t) = s-t" if "0 \<le> t" "t \<le> s" "s \<le> dist x y" for s t
     using that fg[of s] fg[of t] isometry_onD[OF g(3), of s t] unfolding dist_real_def by auto
   have Ifh: "dist (f s) (f t) = s-t" if "dist x y \<le> t" "t \<le> s" "s \<le> dist x z" for s t
     using that fh[of s] fh[of t] isometry_onD[OF h(3), of s t] unfolding dist_real_def by auto
 
   have I: "dist (f s) (f t) = s-t" if "0 \<le> t" "t \<le> s" "s \<le> dist x z" for s t
   proof -
     consider "t \<le> dist x y \<and> s \<ge> dist x y" | "s \<le> dist x y" | "t \<ge> dist x y" by fastforce
     then show ?thesis
     proof (cases)
       case 1
       have "dist (f t) (f s) \<le> dist (f t) (f (dist x y)) + dist (f (dist x y)) (f s)"
         using dist_triangle by auto
       also have "... \<le> (dist x y - t) + (s - dist x y)"
         using that 1 Ifg[of t "dist x y"] Ifh[of "dist x y" s] by (auto simp add: dist_commute intro: mono_intros)
       finally have *: "dist (f t) (f s) \<le> s - t" by simp
 
       have "dist x z \<le> dist (f 0) (f t) + dist (f t) (f s) + dist (f s) (f (dist x z))"
         unfolding \<open>f 0 = x\<close> \<open>f (dist x z) = z\<close> using dist_triangle4 by auto
       also have "... \<le> t + dist (f t) (f s) + (dist x z - s)"
         using that 1 Ifg[of 0 t] Ifh[of s "dist x z"] by (auto simp add: dist_commute intro: mono_intros)
       finally have "s - t \<le> dist (f t) (f s)" by auto
       then show "dist (f s) (f t) = s-t" using * dist_commute by auto
     next
       case 2
       then show ?thesis using Ifg that by auto
     next
       case 3
       then show ?thesis using Ifh that by auto
     qed
   qed
   have "isometry_on {0..dist x z} f"
     unfolding isometry_on_def dist_real_def using I
     by (auto, metis abs_of_nonneg dist_commute dist_real_def le_cases zero_le_dist)
   then show "geodesic_segment_between (G \<union> H) x z"
     unfolding geodesic_segment_between_def
     using \<open>f 0 = x\<close> \<open>f (dist x z) = z\<close> \<open>f`{0..dist x z} = G \<union> H\<close> by auto
   have "G \<inter> H \<subseteq> {y}"
   proof (auto)
     fix a assume a: "a \<in> G" "a \<in> H"
     obtain s where s: "s \<in> {0..dist x y}" "a = g s" using a g(4) by auto
     obtain t where t: "t \<in> {dist x y..dist x z}" "a = h t" using a h(4) by auto
     have "a = f s" using fg s by auto
     moreover have "a = f t" using fh t by auto
     ultimately have "s = t" using isometry_onD[OF \<open>isometry_on {0..dist x z} f\<close>, of s t] s(1) t(1) by auto
     then have "s = dist x y" using s t by auto
     then show "a = y" using s(2) g by auto
   qed
   then show "G \<inter> H = {y}" using assms by auto
 qed
 
 lemma geodesic_segment_dist_le:
   assumes "geodesic_segment_between G x y" "a \<in> G" "b \<in> G"
   shows "dist a b \<le> dist x y"
 proof -
   obtain g where g: "g 0 = x" "g (dist x y) = y" "isometry_on {0..dist x y} g" "G = g`{0..dist x y}"
     by (meson \<open>geodesic_segment_between G x y\<close> geodesic_segment_between_def)
   obtain s t where st: "s \<in> {0..dist x y}" "t \<in> {0..dist x y}" "a = g s" "b = g t"
     using g(4) assms by auto
   have "dist a b = abs(s-t)" using isometry_onD[OF g(3) st(1) st(2)]
     unfolding st(3) st(4) dist_real_def by simp
   then show "dist a b \<le> dist x y" using st(1) st(2) unfolding dist_real_def by auto
 qed
 
 lemma geodesic_segment_param [simp]:
   assumes "geodesic_segment_between G x y"
   shows "geodesic_segment_param G x 0 = x"
         "geodesic_segment_param G x (dist x y) = y"
         "t \<in> {0..dist x y} \<Longrightarrow> geodesic_segment_param G x t \<in> G"
         "isometry_on {0..dist x y} (geodesic_segment_param G x)"
         "(geodesic_segment_param G x)`{0..dist x y} = G"
         "t \<in> {0..dist x y} \<Longrightarrow> dist x (geodesic_segment_param G x t) = t"
         "s \<in> {0..dist x y} \<Longrightarrow> t \<in> {0..dist x y} \<Longrightarrow> dist (geodesic_segment_param G x s) (geodesic_segment_param G x t) = abs(s-t)"
         "z \<in> G \<Longrightarrow> z = geodesic_segment_param G x (dist x z)"
 proof -
   obtain g::"real\<Rightarrow>'a" where g: "g 0 = x" "g (dist x y) = y" "isometry_on {0..dist x y} g" "G = g`{0..dist x y}"
     by (meson \<open>geodesic_segment_between G x y\<close> geodesic_segment_between_def)
   have *: "g t \<in> G \<and> dist x (g t) = t" if "t \<in> {0..dist x y}" for t
     using isometry_onD[OF g(3), of 0 t] that g(1) g(4) unfolding dist_real_def by auto
   have G: "geodesic_segment_param G x t = g t" if "t \<in> {0..dist x y}" for t
   proof -
     have A: "geodesic_segment_param G x t \<in> G \<and> dist x (geodesic_segment_param G x t) = t"
       using *[OF that] unfolding geodesic_segment_param_def apply auto
       using *[OF that] by (metis (mono_tags, lifting) someI)+
     obtain s where s: "geodesic_segment_param G x t = g s" "s \<in> {0..dist x y}"
       using A g(4) by auto
     have "s = t" using *[OF \<open>s \<in> {0..dist x y}\<close>] A unfolding s(1) by auto
     then show ?thesis using s by auto
   qed
   show "geodesic_segment_param G x 0 = x"
        "geodesic_segment_param G x (dist x y) = y"
        "t \<in> {0..dist x y} \<Longrightarrow> geodesic_segment_param G x t \<in> G"
        "isometry_on {0..dist x y} (geodesic_segment_param G x)"
        "(geodesic_segment_param G x)`{0..dist x y} = G"
        "t \<in> {0..dist x y} \<Longrightarrow> dist x (geodesic_segment_param G x t) = t"
        "s \<in> {0..dist x y} \<Longrightarrow> t \<in> {0..dist x y} \<Longrightarrow> dist (geodesic_segment_param G x s) (geodesic_segment_param G x t) = abs(s-t)"
        "z \<in> G \<Longrightarrow> z = geodesic_segment_param G x (dist x z)"
     using G g apply (auto simp add: rev_image_eqI)
     using G isometry_on_cong * atLeastAtMost_iff apply blast
     using G isometry_on_cong * atLeastAtMost_iff apply blast
     by (auto simp add: * dist_real_def isometry_onD)
 qed
 
 lemma geodesic_segment_param_in_segment:
   assumes "G \<noteq> {}"
   shows "geodesic_segment_param G x t \<in> G"
 unfolding geodesic_segment_param_def
 apply (auto, metis (mono_tags, lifting) someI)
 using assms some_in_eq by fastforce
 
 lemma geodesic_segment_reverse_param:
   assumes "geodesic_segment_between G x y"
           "t \<in> {0..dist x y}"
   shows "geodesic_segment_param G y (dist x y - t) = geodesic_segment_param G x t"
 proof -
   have * [simp]: "geodesic_segment_between G y x"
     using geodesic_segment_commute[OF assms(1)] by simp
   have "geodesic_segment_param G y (dist x y - t) \<in> G"
     apply (rule geodesic_segment_param(3)[of _ _ x])
     using assms(2) by (auto simp add: dist_commute)
   moreover have "dist (geodesic_segment_param G y (dist x y - t)) x = t"
     using geodesic_segment_param(2)[OF *] geodesic_segment_param(7)[OF *, of "dist x y -t" "dist x y"] assms(2) by (auto simp add: dist_commute)
   moreover have "geodesic_segment_param G x t \<in> G"
     apply (rule geodesic_segment_param(3)[OF assms(1)])
     using assms(2) by auto
   moreover have "dist (geodesic_segment_param G x t) x = t"
     using geodesic_segment_param(6)[OF assms] by (simp add: dist_commute)
   ultimately show ?thesis
     using geodesic_segment_dist_unique[OF assms(1)] by (simp add: dist_commute)
 qed
 
 lemma dist_along_geodesic_wrt_endpoint:
   assumes "geodesic_segment_between G x y"
           "u \<in> G" "v \<in> G"
   shows "dist u v = abs(dist u x - dist v x)"
 proof -
   have *: "u = geodesic_segment_param G x (dist x u)" "v = geodesic_segment_param G x (dist x v)"
     using assms by auto
   have "dist u v = dist (geodesic_segment_param G x (dist x u)) (geodesic_segment_param G x (dist x v))"
     using * by auto
   also have "... = abs(dist x u - dist x v)"
     apply (rule geodesic_segment_param(7)[OF assms(1)]) using assms apply auto
     using geodesic_segment_dist_le geodesic_segment_endpoints(1) by blast+
   finally show ?thesis by (simp add: dist_commute)
 qed
 
 text \<open>One often needs to restrict a geodesic segment to a subsegment. We introduce the tools
 to express this conveniently.\<close>
 definition geodesic_subsegment::"('a::metric_space) set \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> real \<Rightarrow> 'a set"
   where "geodesic_subsegment G x s t = G \<inter> {z. dist x z \<ge> s \<and> dist x z \<le> t}"
 
 text \<open>A subsegment is always contained in the original segment.\<close>
 lemma geodesic_subsegment_subset:
   "geodesic_subsegment G x s t \<subseteq> G"
 unfolding geodesic_subsegment_def by simp
 
 text \<open>A subsegment is indeed a geodesic segment, and its endpoints and parametrization can be
 expressed in terms of the original segment.\<close>
 lemma geodesic_subsegment:
   assumes "geodesic_segment_between G x y"
           "0 \<le> s" "s \<le> t" "t \<le> dist x y"
   shows "geodesic_subsegment G x s t = (geodesic_segment_param G x)`{s..t}"
         "geodesic_segment_between (geodesic_subsegment G x s t) (geodesic_segment_param G x s) (geodesic_segment_param G x t)"
         "\<And>u. s \<le> u \<Longrightarrow> u \<le> t \<Longrightarrow> geodesic_segment_param (geodesic_subsegment G x s t) (geodesic_segment_param G x s) (u - s) = geodesic_segment_param G x u"
 proof -
   show A: "geodesic_subsegment G x s t = (geodesic_segment_param G x)`{s..t}"
   proof (auto)
     fix y assume y: "y \<in> geodesic_subsegment G x s t"
     have "y = geodesic_segment_param G x (dist x y)"
       apply (rule geodesic_segment_param(8)[OF assms(1)])
       using y geodesic_subsegment_subset by force
     moreover have "dist x y \<ge> s \<and> dist x y \<le> t"
       using y unfolding geodesic_subsegment_def by auto
     ultimately show "y \<in> geodesic_segment_param G x ` {s..t}" by auto
   next
     fix u assume H: "s \<le> u" "u \<le> t"
     have *: "dist x (geodesic_segment_param G x u) = u"
       apply (rule geodesic_segment_param(6)[OF assms(1)]) using H assms by auto
     show "geodesic_segment_param G x u \<in> geodesic_subsegment G x s t"
       unfolding geodesic_subsegment_def
       using geodesic_segment_param_in_segment[OF geodesic_segment_endpoints(3)[OF assms(1)]] by (auto simp add: * H)
   qed
 
   have *: "isometry_on {s..t} (geodesic_segment_param G x)"
     by (rule isometry_on_subset[of "{0..dist x y}"]) (auto simp add: assms)
   show B: "geodesic_segment_between (geodesic_subsegment G x s t) (geodesic_segment_param G x s) (geodesic_segment_param G x t)"
     unfolding A apply (rule geodesic_segmentI2) using * assms by auto
 
   fix u assume u: "s \<le> u" "u \<le> t"
   show "geodesic_segment_param (geodesic_subsegment G x s t) (geodesic_segment_param G x s) (u - s) = geodesic_segment_param G x u"
   proof (rule geodesic_segment_dist_unique[OF B])
     show "geodesic_segment_param (geodesic_subsegment G x s t) (geodesic_segment_param G x s) (u - s) \<in> geodesic_subsegment G x s t"
       by (rule geodesic_segment_param_in_segment[OF geodesic_segment_endpoints(3)[OF B]])
     show "geodesic_segment_param G x u \<in> geodesic_subsegment G x s t"
       unfolding A using u by auto
     have "dist (geodesic_segment_param G x s) (geodesic_segment_param (geodesic_subsegment G x s t) (geodesic_segment_param G x s) (u - s)) = u - s"
       using B assms u by auto
     moreover have "dist (geodesic_segment_param G x s) (geodesic_segment_param G x u) = u -s"
       using assms u by auto
     ultimately show "dist (geodesic_segment_param G x s) (geodesic_segment_param (geodesic_subsegment G x s t) (geodesic_segment_param G x s) (u - s)) =
         dist (geodesic_segment_param G x s) (geodesic_segment_param G x u)"
       by simp
   qed
 qed
 
 text \<open>The parameterizations of a segment and a subsegment sharing an endpoint coincide where defined.\<close>
 lemma geodesic_segment_subparam:
   assumes "geodesic_segment_between G x z" "geodesic_segment_between H x y" "H \<subseteq> G" "t \<in> {0..dist x y}"
   shows "geodesic_segment_param G x t = geodesic_segment_param H x t"
 proof -
   have "geodesic_segment_param H x t \<in> G"
     using assms(3) geodesic_segment_param(3)[OF assms(2) assms(4)] by auto
   then have "geodesic_segment_param H x t = geodesic_segment_param G x (dist x (geodesic_segment_param H x t))"
     using geodesic_segment_param(8)[OF assms(1)] by auto
   then show ?thesis using geodesic_segment_param(6)[OF assms(2) assms(4)] by auto
 qed
 
 text \<open>A segment contains a subsegment between any of its points\<close>
 lemma geodesic_subsegment_exists:
   assumes "geodesic_segment G" "x \<in> G" "y \<in> G"
   shows "\<exists>H. H \<subseteq> G \<and> geodesic_segment_between H x y"
 proof -
   obtain a0 b0 where Ga0b0: "geodesic_segment_between G a0 b0"
     using assms(1) unfolding geodesic_segment_def by auto
   text \<open>Permuting the endpoints if necessary, we can ensure that the first endpoint $a$ is closer
   to $x$ than $y$.\<close>
   have "\<exists> a b. geodesic_segment_between G a b \<and> dist x a \<le> dist y a"
   proof (cases "dist x a0 \<le> dist y a0")
     case True
     show ?thesis
       apply (rule exI[of _ a0], rule exI[of _ b0]) using True Ga0b0 by auto
   next
     case False
     show ?thesis
       apply (rule exI[of _ b0], rule exI[of _ a0])
       using Ga0b0 geodesic_segment_commute geodesic_segment_dist[OF Ga0b0 \<open>x \<in> G\<close>] geodesic_segment_dist[OF Ga0b0 \<open>y \<in> G\<close>] False
       by (auto simp add: dist_commute)
   qed
   then obtain a b where Gab: "geodesic_segment_between G a b" "dist x a \<le> dist y a"
     by auto
   have *: "0 \<le> dist x a" "dist x a \<le> dist y a" "dist y a \<le> dist a b"
     using Gab assms by (meson geodesic_segment_dist_le geodesic_segment_endpoints(1) zero_le_dist)+
   have **: "x = geodesic_segment_param G a (dist x a)" "y = geodesic_segment_param G a (dist y a)"
     using Gab \<open>x \<in> G\<close> \<open>y \<in> G\<close> by (metis dist_commute geodesic_segment_param(8))+
   define H where "H = geodesic_subsegment G a (dist x a) (dist y a)"
   have "H \<subseteq> G"
     unfolding H_def by (rule geodesic_subsegment_subset)
   moreover have "geodesic_segment_between H x y"
     unfolding H_def using geodesic_subsegment(2)[OF Gab(1) *] ** by auto
   ultimately show ?thesis by auto
 qed
 
 text \<open>A geodesic segment is homeomorphic to an interval.\<close>
 lemma geodesic_segment_homeo_interval:
   assumes "geodesic_segment_between G x y"
   shows "{0..dist x y} homeomorphic G"
 proof -
   obtain g where g: "g 0 = x" "g (dist x y) = y" "isometry_on {0..dist x y} g" "G = g`{0..dist x y}"
     by (meson \<open>geodesic_segment_between G x y\<close> geodesic_segment_between_def)
   show ?thesis using isometry_on_homeomorphism(3)[OF g(3)] unfolding g(4) by simp
 qed
 
 text \<open>Just like an interval, a geodesic segment is compact, connected, path connected, bounded,
 closed, nonempty, and proper.\<close>
 lemma geodesic_segment_topology:
   assumes "geodesic_segment G"
   shows "compact G" "connected G" "path_connected G" "bounded G" "closed G" "G \<noteq> {}" "proper G"
 proof -
   show "compact G"
     using assms geodesic_segment_homeo_interval homeomorphic_compactness
     unfolding geodesic_segment_def by force
   show "path_connected G"
     using assms is_interval_path_connected geodesic_segment_homeo_interval homeomorphic_path_connectedness
     unfolding geodesic_segment_def
     by (metis is_interval_cc)
   then show "connected G"
     using path_connected_imp_connected by auto
   show "bounded G"
     by (rule compact_imp_bounded, fact)
   show "closed G"
     by (rule compact_imp_closed, fact)
   show "G \<noteq> {}"
     using assms geodesic_segment_def geodesic_segment_endpoints(3) by auto
   show "proper G"
     using proper_of_compact \<open>compact G\<close> by auto
 qed
 
 lemma geodesic_segment_between_x_x [simp]:
   "geodesic_segment_between {x} x x"
   "geodesic_segment {x}"
   "geodesic_segment_between G x x \<longleftrightarrow> G = {x}"
 proof -
   show *: "geodesic_segment_between {x} x x"
     unfolding geodesic_segment_between_def apply (rule exI[of _ "\<lambda>_. x"]) unfolding isometry_on_def by auto
   then show "geodesic_segment {x}" by auto
   show "geodesic_segment_between G x x \<longleftrightarrow> G = {x}"
     using geodesic_segment_dist_le geodesic_segment_endpoints(2) * by fastforce
 qed
 
 lemma geodesic_segment_disconnection:
   assumes "geodesic_segment_between G x y" "z \<in> G"
   shows "(connected (G - {z})) = (z = x \<or> z = y)"
 proof -
   obtain g where g: "g 0 = x" "g (dist x y) = y" "isometry_on {0..dist x y} g" "G = g`{0..dist x y}"
     by (meson \<open>geodesic_segment_between G x y\<close> geodesic_segment_between_def)
   obtain t where t: "t \<in> {0..dist x y}" "z = g t" using \<open>z \<in> G\<close> g(4) by auto
   have "({0..dist x y} - {t}) homeomorphic (G - {g t})"
   proof -
     have *: "isometry_on ({0..dist x y} - {t}) g"
       apply (rule isometry_on_subset[OF g(3)]) by auto
     have "({0..dist x y} - {t}) homeomorphic g`({0..dist x y} - {t})"
       by (rule isometry_on_homeomorphism(3)[OF *])
     moreover have "g`({0..dist x y} - {t}) = G - {g t}"
       unfolding g(4) using isometry_on_injective[OF g(3)] t by (auto simp add: inj_onD)
     ultimately show ?thesis by auto
   qed
   moreover have "connected({0..dist x y} - {t}) = (t = 0 \<or> t = dist x y)"
     using t(1) by (auto simp add: connected_iff_interval, fastforce)
   ultimately have "connected (G - {z}) = (t = 0 \<or> t = dist x y)"
     unfolding \<open>z = g t\<close>[symmetric]using homeomorphic_connectedness by blast
   moreover have "(t = 0 \<or> t = dist x y) = (z = x \<or> z = y)"
     using t g apply auto
     by (metis atLeastAtMost_iff isometry_on_inverse(2) order_refl zero_le_dist)+
   ultimately show ?thesis by auto
 qed
 
 lemma geodesic_segment_unique_endpoints:
   assumes "geodesic_segment_between G x y"
           "geodesic_segment_between G a b"
   shows "{x, y} = {a, b}"
 by (metis geodesic_segment_disconnection assms(1) assms(2) doubleton_eq_iff geodesic_segment_endpoints(1) geodesic_segment_endpoints(2))
 
 lemma geodesic_segment_subsegment:
   assumes "geodesic_segment G" "H \<subseteq> G" "compact H" "connected H" "H \<noteq> {}"
   shows "geodesic_segment H"
 proof -
   obtain x y where "geodesic_segment_between G x y"
     using assms unfolding geodesic_segment_def by auto
   obtain g where g: "g 0 = x" "g (dist x y) = y" "isometry_on {0..dist x y} g" "G = g`{0..dist x y}"
     by (meson \<open>geodesic_segment_between G x y\<close> geodesic_segment_between_def)
   define L where "L = (inv_into {0..dist x y} g)`H"
   have "L \<subseteq> {0..dist x y}"
     unfolding L_def using isometry_on_inverse[OF \<open>isometry_on {0..dist x y} g\<close>] assms(2) g(4) by auto
   have "isometry_on G (inv_into {0..dist x y} g)"
     using isometry_on_inverse[OF \<open>isometry_on {0..dist x y} g\<close>] g(4) by auto
   then have "isometry_on H (inv_into {0..dist x y} g)"
     using \<open>H \<subseteq> G\<close> isometry_on_subset by auto
   then have "H homeomorphic L" unfolding L_def using isometry_on_homeomorphism(3) by auto
   then have "compact L \<and> connected L"
     using assms homeomorphic_compactness homeomorphic_connectedness by blast
   then obtain a b where "L = {a..b}"
     using connected_compact_interval_1[of L] by auto
   have "a \<le> b" using \<open>H \<noteq> {}\<close> \<open>L = {a..b}\<close> unfolding L_def by auto
   then have "0 \<le> a" "b \<le> dist x y" using \<open>L \<subseteq> {0..dist x y}\<close> \<open>L = {a..b}\<close> by auto
   have *: "H = g`{a..b}"
     by (metis L_def \<open>L = {a..b}\<close> assms(2) g(4) image_inv_into_cancel)
   show "geodesic_segment H"
     unfolding * apply (rule geodesic_segmentI2[OF _ \<open>a \<le> b\<close>])
     apply (rule isometry_on_subset[OF g(3)]) using \<open>0 \<le> a\<close> \<open>b \<le> dist x y\<close> by auto
 qed
 
 text \<open>The image under an isometry of a geodesic segment is still obviously a geodesic segment.\<close>
 lemma isometry_preserves_geodesic_segment_between:
   assumes "isometry_on X f"
           "G \<subseteq> X" "geodesic_segment_between G x y"
   shows "geodesic_segment_between (f`G) (f x) (f y)"
 proof -
   obtain g where g: "g 0 = x" "g (dist x y) = y" "isometry_on {0..dist x y} g" "G = g`{0..dist x y}"
     by (meson \<open>geodesic_segment_between G x y\<close> geodesic_segment_between_def)
   then have *: "f`G = (f o g) `{0..dist x y}" "f x = (f o g) 0" "f y = (f o g) (dist x y)"
     by auto
   show ?thesis
     unfolding * apply (intro geodesic_segmentI2(1))
     unfolding comp_def apply (rule isometry_on_compose[of _ g])
     using g(3) g(4) assms by (auto intro: isometry_on_subset)
 qed
 
 text \<open>The sum of distances $d(w, x) + d(w, y)$ can be controlled using the distance from $w$
 to a geodesic segment between $x$ and $y$.\<close>
 lemma geodesic_segment_distance:
   assumes "geodesic_segment_between G x y"
   shows "dist w x + dist w y \<le> dist x y + 2 * infdist w G"
 proof -
   have "\<exists>z \<in> G. infdist w G = dist w z"
     apply (rule infdist_proper_attained) using assms by (auto simp add: geodesic_segment_topology)
   then obtain z where z: "z \<in> G" "infdist w G = dist w z" by auto
   have "dist w x + dist w y \<le> (dist w z + dist z x) + (dist w z + dist z y)"
     by (intro mono_intros)
   also have "... = dist x z + dist z y + 2 * dist w z"
     by (auto simp add: dist_commute)
   also have "... = dist x y + 2 * infdist w G"
     using z(1) assms geodesic_segment_dist unfolding z(2) by auto
   finally show ?thesis by auto
 qed
 
 text \<open>If a point $y$ is on a geodesic segment between $x$ and its closest projection $p$ on a set $A$,
 then $p$ is also a closest projection of $y$, and the closest projection set of $y$ is contained in
 that of $x$.\<close>
 
 lemma proj_set_geodesic_same_basepoint:
   assumes "p \<in> proj_set x A" "geodesic_segment_between G p x" "y \<in> G"
   shows "p \<in> proj_set y A"
 proof (rule proj_setI)
   show "p \<in> A"
     using assms proj_setD by auto
   have *: "dist y p \<le> dist y q" if "q \<in> A" for q
   proof -
     have "dist p y + dist y x = dist p x"
       using assms geodesic_segment_dist by blast
     also have "... \<le> dist q x"
       using proj_set_dist_le[OF \<open>q \<in> A\<close> assms(1)] by (simp add: dist_commute)
     also have "... \<le> dist q y + dist y x"
       by (intro mono_intros)
     finally show ?thesis
       by (simp add: dist_commute)
   qed
   have "dist y p \<le> Inf (dist y ` A)"
     apply (rule cINF_greatest) using \<open>p \<in> A\<close> * by auto
   then show "dist y p \<le> infdist y A"
     unfolding infdist_def using \<open>p \<in> A\<close> by auto
 qed
 
 lemma proj_set_subset:
   assumes "p \<in> proj_set x A" "geodesic_segment_between G p x" "y \<in> G"
   shows "proj_set y A \<subseteq> proj_set x A"
 proof -
   have "z \<in> proj_set x A" if "z \<in> proj_set y A" for z
   proof (rule proj_setI)
     show "z \<in> A" using that proj_setD by auto
     have "dist x z \<le> dist x y + dist y z"
       by (intro mono_intros)
     also have "... \<le> dist x y + dist y p"
       using proj_set_dist_le[OF proj_setD(1)[OF \<open>p \<in> proj_set x A\<close>] that] by auto
     also have "... = dist x p"
       using assms geodesic_segment_commute geodesic_segment_dist by blast
     also have "... = infdist x A"
       using proj_setD(2)[OF assms(1)] by simp
     finally show "dist x z \<le> infdist x A"
       by simp
   qed
   then show ?thesis by auto
 qed
 
 lemma proj_set_thickening:
   assumes "p \<in> proj_set x Z"
           "0 \<le> D"
           "D \<le> dist p x"
           "geodesic_segment_between G p x"
   shows "geodesic_segment_param G p D \<in> proj_set x (\<Union>z\<in>Z. cball z D)"
 proof (rule proj_setI')
   have "dist p (geodesic_segment_param G p D) = D"
     using geodesic_segment_param(7)[OF assms(4), of 0 D]
     unfolding geodesic_segment_param(1)[OF assms(4)] using assms by simp
   then show "geodesic_segment_param G p D \<in> (\<Union>z\<in>Z. cball z D)"
     using proj_setD(1)[OF \<open>p \<in> proj_set x Z\<close>] by force
   show "dist x (geodesic_segment_param G p D) \<le> dist x y" if "y \<in> (\<Union>z\<in>Z. cball z D)" for y
   proof -
     obtain z where y: "y \<in> cball z D" "z \<in> Z" using \<open>y \<in> (\<Union>z\<in>Z. cball z D)\<close> by auto
     have "dist (geodesic_segment_param G p D) x + D = dist p x"
       using geodesic_segment_param(7)[OF assms(4), of D "dist p x"]
       unfolding geodesic_segment_param(2)[OF assms(4)] using assms by simp
     also have "... \<le> dist z x"
       using proj_setD(2)[OF \<open>p \<in> proj_set x Z\<close>] infdist_le[OF \<open>z \<in> Z\<close>, of x] by (simp add: dist_commute)
     also have "... \<le> dist z y + dist y x"
       by (intro mono_intros)
     also have "... \<le> D + dist y x"
       using y by simp
     finally show ?thesis by (simp add: dist_commute)
   qed
 qed
 
 lemma proj_set_thickening':
   assumes "p \<in> proj_set x Z"
           "0 \<le> D"
           "D \<le> E"
           "E \<le> dist p x"
           "geodesic_segment_between G p x"
   shows "geodesic_segment_param G p D \<in> proj_set (geodesic_segment_param G p E) (\<Union>z\<in>Z. cball z D)"
 proof -
   define H where "H = geodesic_subsegment G p D (dist p x)"
   have H1: "geodesic_segment_between H (geodesic_segment_param G p D) x"
     apply (subst geodesic_segment_param(2)[OF \<open>geodesic_segment_between G p x\<close>, symmetric])
     unfolding H_def apply (rule geodesic_subsegment(2)) using assms by auto
   have H2: "geodesic_segment_param G p E \<in> H"
     unfolding H_def using assms geodesic_subsegment(1) by force
   have "geodesic_segment_param G p D \<in> proj_set x (\<Union>z\<in>Z. cball z D)"
     apply (rule proj_set_thickening) using assms by auto
   then show ?thesis
     by (rule proj_set_geodesic_same_basepoint[OF _ H1 H2])
 qed
 
 text \<open>It is often convenient to use \emph{one} geodesic between $x$ and $y$, even if it is not unique.
 We introduce a notation for such a choice of a geodesic, denoted \verb+{x--S--y}+ for such a geodesic
 that moreover remains in the set $S$. We also enforce
 the condition \verb+{x--S--y} = {y--S--x}+. When there is no such geodesic, we simply take
 \verb+{x--S--y} = {x, y}+ for definiteness. It would be even better to enforce that, if
 $a$ is on \verb+{x--S--y}+, then \verb+{x--S--y}+ is the union of \verb+{x--S--a}+ and \verb+{a--S--y}+, but
 I do not know if such a choice is always possible -- such a choice of geodesics is
 called a geodesic bicombing.
 We also write \verb+{x--y}+ for \verb+{x--UNIV--y}+.\<close>
 
 definition some_geodesic_segment_between::"'a::metric_space \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'a set" ("(1{_--_--_})")
   where "some_geodesic_segment_between = (SOME f. \<forall> x y S. f x S y = f y S x
     \<and> (if (\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S) then (geodesic_segment_between (f x S y) x y \<and> (f x S y \<subseteq> S))
         else f x S y = {x, y}))"
 
 abbreviation some_geodesic_segment_between_UNIV::"'a::metric_space \<Rightarrow> 'a \<Rightarrow> 'a set" ("(1{_--_})")
   where "some_geodesic_segment_between_UNIV x y \<equiv> {x--UNIV--y}"
 
 text \<open>We prove that there is such a choice of geodesics, compatible with direction reversal. What
 we do is choose arbitrarily a geodesic between $x$ and $y$ if it exists, and then use the geodesic
 between $\min(x, y)$ and $\max(x,y)$, for any total order on the space, to ensure that we get the
 same result from $x$ to $y$ or from $y$ to $x$.\<close>
 
 lemma some_geodesic_segment_between_exists:
   "\<exists>f. \<forall> x y S. f x S y = f y S x
     \<and> (if (\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S) then (geodesic_segment_between (f x S y) x y \<and> (f x S y \<subseteq> S))
         else f x S y = {x, y})"
 proof -
   define g::"'a \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'a set" where
     "g = (\<lambda>x S y. if (\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S) then (SOME G. geodesic_segment_between G x y \<and> G \<subseteq> S) else {x, y})"
   have g1: "geodesic_segment_between (g x S y) x y \<and> (g x S y \<subseteq> S)" if "\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S" for x y S
     unfolding g_def using someI_ex[OF that] by auto
   have g2: "g x S y = {x, y}" if "\<not>(\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S)" for x y S
     unfolding g_def using that by auto
   obtain r::"'a rel" where r: "well_order_on UNIV r"
     using well_order_on by auto
   have A: "x = y" if "(x, y) \<in> r" "(y, x) \<in> r" for x y
     using r that unfolding well_order_on_def linear_order_on_def partial_order_on_def antisym_def by auto
   have B: "(x, y) \<in> r \<or> (y, x) \<in> r" for x y
     using r unfolding well_order_on_def linear_order_on_def total_on_def partial_order_on_def preorder_on_def refl_on_def by force
 
   define f where "f = (\<lambda>x S y. if (x, y) \<in> r then g x S y else g y S x)"
   have "f x S y = f y S x" for x y S unfolding f_def using r A B by auto
   moreover have "geodesic_segment_between (f x S y) x y \<and> (f x S y \<subseteq> S)" if "\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S" for x y S
     unfolding f_def using g1 geodesic_segment_commute that by smt
   moreover have "f x S y = {x, y}" if "\<not>(\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S)" for x y S
     unfolding f_def using g2 that geodesic_segment_commute doubleton_eq_iff by metis
   ultimately show ?thesis by metis
 qed
 
 lemma some_geodesic_commute:
   "{x--S--y} = {y--S--x}"
 unfolding some_geodesic_segment_between_def by (auto simp add: someI_ex[OF some_geodesic_segment_between_exists])
 
 lemma some_geodesic_segment_description:
   "(\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S) \<Longrightarrow> geodesic_segment_between {x--S--y} x y"
   "(\<not>(\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S)) \<Longrightarrow> {x--S--y} = {x, y}"
 unfolding some_geodesic_segment_between_def by (simp add: someI_ex[OF some_geodesic_segment_between_exists])+
 
 text \<open>Basic topological properties of our chosen set of geodesics.\<close>
 
 lemma some_geodesic_compact [simp]:
   "compact {x--S--y}"
 apply (cases "\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S")
 using some_geodesic_segment_description[of x y] geodesic_segment_topology[of "{x--S--y}"] geodesic_segment_def apply auto
   by blast
 
 lemma some_geodesic_closed [simp]:
   "closed {x--S--y}"
 by (rule compact_imp_closed[OF some_geodesic_compact[of x S y]])
 
 lemma some_geodesic_bounded [simp]:
   "bounded {x--S--y}"
 by (rule compact_imp_bounded[OF some_geodesic_compact[of x S y]])
 
 lemma some_geodesic_endpoints [simp]:
   "x \<in> {x--S--y}" "y \<in> {x--S--y}" "{x--S--y} \<noteq> {}"
 apply (cases "\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S") using some_geodesic_segment_description[of x y S] apply auto
 apply (cases "\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S") using some_geodesic_segment_description[of x y S] apply auto
 apply (cases "\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S") using geodesic_segment_endpoints(3) by (auto, blast)
 
 lemma some_geodesic_subsegment:
   assumes "H \<subseteq> {x--S--y}" "compact H" "connected H" "H \<noteq> {}"
   shows "geodesic_segment H"
 apply (cases "\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S")
 using some_geodesic_segment_description[of x y] geodesic_segment_subsegment[OF _ assms] geodesic_segment_def apply auto[1]
 using some_geodesic_segment_description[of x y] assms
 by (metis connected_finite_iff_sing finite.emptyI finite.insertI finite_subset geodesic_segment_between_x_x(2))
 
 lemma some_geodesic_in_subset:
   assumes "x \<in> S" "y \<in> S"
   shows "{x--S--y} \<subseteq> S"
 apply (cases "\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S")
 unfolding some_geodesic_segment_between_def by (simp add: assms someI_ex[OF some_geodesic_segment_between_exists])+
 
 lemma some_geodesic_same_endpoints [simp]:
   "{x--S--x} = {x}"
 apply (cases "\<exists>G. geodesic_segment_between G x x \<and> G \<subseteq> S")
 apply (meson geodesic_segment_between_x_x(3) some_geodesic_segment_description(1))
 by (simp add: some_geodesic_segment_description(2))
 
 subsection \<open>Geodesic subsets\<close>
 
 text \<open>A subset is \emph{geodesic} if any two of its points can be joined by a geodesic segment.
 We prove basic properties of such a subset in this paragraph -- notably connectedness. A basic
 example is given by convex subsets of vector spaces, as closed segments are geodesic.\<close>
 
 definition geodesic_subset::"('a::metric_space) set \<Rightarrow> bool"
   where "geodesic_subset S = (\<forall>x\<in>S. \<forall>y\<in>S. \<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S)"
 
 lemma geodesic_subsetD:
   assumes "geodesic_subset S" "x \<in> S" "y \<in> S"
   shows "geodesic_segment_between {x--S--y} x y"
 using assms some_geodesic_segment_description(1) unfolding geodesic_subset_def by blast
 
 lemma geodesic_subsetI:
   assumes "\<And>x y. x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> \<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S"
   shows "geodesic_subset S"
 using assms unfolding geodesic_subset_def by auto
 
 lemma geodesic_subset_empty:
   "geodesic_subset {}"
 using geodesic_subsetI by auto
 
 lemma geodesic_subset_singleton:
   "geodesic_subset {x}"
 by (auto intro!: geodesic_subsetI geodesic_segment_between_x_x(1))
 
 lemma geodesic_subset_path_connected:
   assumes "geodesic_subset S"
   shows "path_connected S"
 proof -
   have "\<exists>g. path g \<and> path_image g \<subseteq> S \<and> pathstart g = x \<and> pathfinish g = y" if "x \<in> S" "y \<in> S" for x y
   proof -
     define G where "G = {x--S--y}"
     have *: "geodesic_segment_between G x y" "G \<subseteq> S" "x \<in> G" "y \<in> G"
       using assms that by (auto simp add: G_def geodesic_subsetD some_geodesic_in_subset that(1) that(2))
     then have "path_connected G"
       using geodesic_segment_topology(3) unfolding geodesic_segment_def by auto
     then have "\<exists>g. path g \<and> path_image g \<subseteq> G \<and> pathstart g = x \<and> pathfinish g = y"
       using * unfolding path_connected_def by auto
     then show ?thesis using \<open>G \<subseteq> S\<close> by auto
   qed
   then show ?thesis
     unfolding path_connected_def by auto
 qed
 
 text \<open>To show that a segment in a normed vector space is geodesic, we will need to use its
 length parametrization, which is given in the next lemma.\<close>
 
 lemma closed_segment_as_isometric_image:
   "((\<lambda>t. x + (t/dist x y) *\<^sub>R (y - x))`{0..dist x y}) = closed_segment x y"
 proof (auto simp add: closed_segment_def image_iff)
   fix t assume H: "0 \<le> t" "t \<le> dist x y"
   show "\<exists>u. x + (t / dist x y) *\<^sub>R (y - x) = (1 - u) *\<^sub>R x + u *\<^sub>R y \<and> 0 \<le> u \<and> u \<le> 1"
-    apply (rule exI[of _ "t/dist x y"]) using H apply (auto simp add: algebra_simps divide_simps)
-    by (metis add_diff_cancel_left' add_divide_distrib dist_not_less_zero dist_pos_lt divide_eq_1_iff linordered_field_class.sign_simps(29) scaleR_left.add scaleR_one)
+    apply (rule exI[of _ "t/dist x y"])
+    using H apply (auto simp add: algebra_simps divide_simps)
+    apply (metis add_diff_cancel_left' add_diff_eq add_divide_distrib dist_eq_0_iff scaleR_add_left vector_fraction_eq_iff)
+    done
 next
   fix u::real assume H: "0 \<le> u" "u \<le> 1"
   show "\<exists>t\<in>{0..dist x y}. (1 - u) *\<^sub>R x + u *\<^sub>R y = x + (t / dist x y) *\<^sub>R (y - x)"
     apply (rule bexI[of _ "u * dist x y"])
     using H by (auto simp add: algebra_simps mult_left_le_one_le)
 qed
 
 proposition closed_segment_is_geodesic:
   fixes x y::"'a::real_normed_vector"
   shows "isometry_on {0..dist x y} (\<lambda>t. x + (t/dist x y) *\<^sub>R (y - x))"
         "geodesic_segment_between (closed_segment x y) x y"
         "geodesic_segment (closed_segment x y)"
 proof -
   show *: "isometry_on {0..dist x y} (\<lambda>t. x + (t/dist x y) *\<^sub>R (y - x))"
     unfolding isometry_on_def dist_norm
     apply (cases "x = y")
     by (auto simp add: scaleR_diff_left[symmetric] diff_divide_distrib[symmetric] norm_minus_commute)
   show "geodesic_segment_between (closed_segment x y) x y"
     unfolding closed_segment_as_isometric_image[symmetric]
     apply (rule geodesic_segment_betweenI[OF _ _ *]) by auto
   then show "geodesic_segment (closed_segment x y)"
     by auto
 qed
 
 text \<open>We deduce that a convex set is geodesic.\<close>
 
 proposition convex_is_geodesic:
   assumes "convex (S::'a::real_normed_vector set)"
   shows "geodesic_subset S"
 proof (rule geodesic_subsetI)
   fix x y assume H: "x \<in> S" "y \<in> S"
   show "\<exists>G. geodesic_segment_between G x y \<and> G \<subseteq> S"
     apply (rule exI[of _ "closed_segment x y"])
     apply (auto simp add: closed_segment_is_geodesic)
     using H assms convex_contains_segment by blast
 qed
 
 
 subsection \<open>Geodesic spaces\<close>
 
 text \<open>In this subsection, we define geodesic spaces (metric spaces in which there is a geodesic
 segment joining any pair of points). We specialize the previous statements on geodesic segments to
 these situations.\<close>
 
 class geodesic_space = metric_space +
   assumes geodesic: "geodesic_subset (UNIV::('a::metric_space) set)"
 
 text \<open>The simplest example of a geodesic space is a real normed vector space. Significant examples
 also include graphs (with the graph distance), Riemannian manifolds, and $CAT(\kappa)$ spaces.\<close>
 
 instance real_normed_vector \<subseteq> geodesic_space
 by (standard, simp add: convex_is_geodesic)
 
 lemma (in geodesic_space) some_geodesic_is_geodesic_segment [simp]:
   "geodesic_segment_between {x--y} x (y::'a)"
   "geodesic_segment {x--y}"
 using some_geodesic_segment_description(1)[of x y] geodesic_subsetD[OF geodesic] by (auto, blast)
 
 lemma (in geodesic_space) some_geodesic_connected [simp]:
   "connected {x--y}" "path_connected {x--y}"
 by (auto intro!: geodesic_segment_topology)
 
 text \<open>In geodesic spaces, we restate as simp rules all properties of the geodesic segment
 parametrizations.\<close>
 
 lemma (in geodesic_space) geodesic_segment_param_in_geodesic_spaces [simp]:
   "geodesic_segment_param {x--y} x 0 = x"
   "geodesic_segment_param {x--y} x (dist x y) = y"
   "t \<in> {0..dist x y} \<Longrightarrow> geodesic_segment_param {x--y} x t \<in> {x--y}"
   "isometry_on {0..dist x y} (geodesic_segment_param {x--y} x)"
   "(geodesic_segment_param {x--y} x)`{0..dist x y} = {x--y}"
   "t \<in> {0..dist x y} \<Longrightarrow> dist x (geodesic_segment_param {x--y} x t) = t"
   "s \<in> {0..dist x y} \<Longrightarrow> t \<in> {0..dist x y} \<Longrightarrow> dist (geodesic_segment_param {x--y} x s) (geodesic_segment_param {x--y} x t) = abs(s-t)"
   "z \<in> {x--y} \<Longrightarrow> z = geodesic_segment_param {x--y} x (dist x z)"
 using geodesic_segment_param[OF some_geodesic_is_geodesic_segment(1)[of x y]] by auto
 
 
 subsection \<open>Uniquely geodesic spaces\<close>
 
 text \<open>In this subsection, we define uniquely geodesic spaces, i.e., geodesic spaces in which,
 additionally, there is a unique geodesic between any pair of points.\<close>
 
 class uniquely_geodesic_space = geodesic_space +
   assumes uniquely_geodesic: "\<And>x y G H. geodesic_segment_between G x y \<Longrightarrow> geodesic_segment_between H x y \<Longrightarrow> G = H"
 
 text \<open>To prove that a geodesic space is uniquely geodesic, it suffices to show that there is no loop,
 i.e., if two geodesic segments intersect only at their endpoints, then they coincide.
 
 Indeed, assume this holds, and consider two geodesics with the same endpoints. If they differ at
 some time $t$, then consider the last time $a$ before $t$ where they coincide, and the first time
 $b$ after $t$ where they coincide. Then the restrictions of the two geodesics to $[a,b]$ give
 a loop, and a contradiction.\<close>
 
 lemma (in geodesic_space) uniquely_geodesic_spaceI:
   assumes "\<And>G H x (y::'a). geodesic_segment_between G x y \<Longrightarrow> geodesic_segment_between H x y \<Longrightarrow> G \<inter> H = {x, y} \<Longrightarrow> x = y"
           "geodesic_segment_between G x y" "geodesic_segment_between H x (y::'a)"
   shows "G = H"
 proof -
   obtain g where g: "g 0 = x" "g (dist x y) = y" "isometry_on {0..dist x y} g" "G = g`{0..dist x y}"
     by (meson \<open>geodesic_segment_between G x y\<close> geodesic_segment_between_def)
   obtain h where h: "h 0 = x" "h (dist x y) = y" "isometry_on {0..dist x y} h" "H = h`{0..dist x y}"
     by (meson \<open>geodesic_segment_between H x y\<close> geodesic_segment_between_def)
   have "g t = h t" if "t \<in> {0..dist x y}" for t
   proof (rule ccontr)
     assume "g t \<noteq> h t"
     define Z where "Z = {s \<in> {0..dist x y}. g s = h s}"
     have "0 \<in> Z" "dist x y \<in> Z" unfolding Z_def using g h by auto
     have "t \<notin> Z" unfolding Z_def using \<open>g t \<noteq> h t\<close> by auto
     have [simp]: "closed Z"
     proof -
       have *: "Z = (\<lambda>s. dist (g s) (h s))-`{0} \<inter> {0..dist x y}"
         unfolding Z_def by auto
       show ?thesis
         unfolding * apply (rule closed_vimage_Int)
         using isometry_on_continuous[OF g(3)] isometry_on_continuous[OF h(3)] continuous_on_dist by auto
     qed
     define a where "a = Sup (Z \<inter> {0..t})"
     have a: "a \<in> Z \<inter> {0..t}"
       unfolding a_def apply (rule closed_contains_Sup, auto)
       using \<open>0 \<in> Z\<close> that by auto
     then have "h a = g a" unfolding Z_def by auto
     define b where "b = Inf (Z \<inter> {t..dist x y})"
     have b: "b \<in> Z \<inter> {t..dist x y}"
       unfolding b_def apply (rule closed_contains_Inf, auto)
       using \<open>dist x y \<in> Z\<close> that by auto
     then have "h b = g b" unfolding Z_def by auto
     have notZ: "s \<notin> Z" if "s \<in> {a<..<b}" for s
     proof (rule ccontr, auto, cases "s \<le> t")
       case True
       assume "s \<in> Z"
       then have *: "s \<in> Z \<inter> {0..t}" using that a True by auto
       have "s \<le> a" unfolding a_def apply (rule cSup_upper) using * by auto
       then show False using that by auto
     next
       case False
       assume "s \<in> Z"
       then have *: "s \<in> Z \<inter> {t..dist x y}" using that b False by auto
       have "s \<ge> b" unfolding b_def apply (rule cInf_lower) using * by auto
       then show False using that by auto
     qed
     have "t \<in> {a<..<b}" using a b \<open>t \<notin> Z\<close> less_eq_real_def by auto
     then have "a \<le> b" by auto
     then have "dist (h a) (h b) = b-a"
       using isometry_onD[OF h(3), of a b] a b that unfolding dist_real_def by auto
     then have "dist (h a) (h b) > 0" using \<open>t \<in> {a<..<b}\<close> by auto
     then have "h a \<noteq> h b" by auto
 
     define G2 where "G2 = g`{a..b}"
     define H2 where "H2 = h`{a..b}"
     have "G2 \<inter> H2 \<subseteq> {h a, h b}"
     proof
       fix z assume z: "z \<in> G2 \<inter> H2"
       obtain sg where sg: "z = g sg" "sg \<in> {a..b}" using z unfolding G2_def by auto
       obtain sh where sh: "z = h sh" "sh \<in> {a..b}" using z unfolding H2_def by auto
       have "sg = dist x z"
         using isometry_onD[OF g(3), of 0 sg] a b sg(2) unfolding sg(1) g(1)[symmetric] dist_real_def by auto
       moreover have "sh = dist x z"
         using isometry_onD[OF h(3), of 0 sh] a b sh(2) unfolding sh(1) h(1)[symmetric] dist_real_def by auto
       ultimately have "sg = sh" by auto
       then have "sh \<in> Z" using sg(1) sh(1) a b sh(2) unfolding Z_def by auto
       then have "sh \<in> {a, b}" using notZ sh(2)
         by (metis IntD2 atLeastAtMost_iff atLeastAtMost_singleton greaterThanLessThan_iff inf_bot_left insertI2 insert_inter_insert not_le)
       then show "z \<in> {h a, h b}" using sh(1) by auto
     qed
     then have "G2 \<inter> H2 = {h a, h b}"
       using \<open>h a = g a\<close> \<open>h b = g b\<close> \<open>a \<le> b\<close> unfolding H2_def G2_def apply auto
       unfolding \<open>h a = g a\<close>[symmetric] \<open>h b = g b\<close>[symmetric] by auto
     moreover have "geodesic_segment_between G2 (h a) (h b)"
       unfolding G2_def \<open>h a = g a\<close> \<open>h b = g b\<close>
       apply (rule geodesic_segmentI2) apply (rule isometry_on_subset[OF g(3)])
       using a b that by auto
     moreover have "geodesic_segment_between H2 (h a) (h b)"
       unfolding H2_def apply (rule geodesic_segmentI2) apply (rule isometry_on_subset[OF h(3)])
       using a b that by auto
     ultimately have "h a = h b" using assms(1) by auto
     then show False using \<open>h a \<noteq> h b\<close> by simp
   qed
   then show "G = H" using g(4) h(4) by (simp add: image_def)
 qed
 
 context uniquely_geodesic_space
 begin
 
 lemma geodesic_segment_unique:
   "geodesic_segment_between G x y = (G = {x--(y::'a)})"
 using uniquely_geodesic[of _ x y] by (meson some_geodesic_is_geodesic_segment)
 
 lemma geodesic_segment_dist':
   assumes "dist x z = dist x y + dist y z"
   shows "y \<in> {x--z}" "{x--z} = {x--y} \<union> {y--z}"
 proof -
   have "geodesic_segment_between ({x--y} \<union> {y--z}) x z"
     using geodesic_segment_union[OF assms] by auto
   then show "{x--z} = {x--y} \<union> {y--z}"
     using geodesic_segment_unique by auto
   then show "y \<in> {x--z}" by auto
 qed
 
 lemma geodesic_segment_expression:
   "{x--z} = {y. dist x z = dist x y + dist y z}"
 using geodesic_segment_dist'(1) geodesic_segment_dist[OF some_geodesic_is_geodesic_segment(1)] by auto
 
 lemma geodesic_segment_split:
   assumes "(y::'a) \<in> {x--z}"
   shows "{x--z} = {x--y} \<union> {y--z}"
         "{x--y} \<inter> {y--z} = {y}"
 apply (metis assms geodesic_segment_dist geodesic_segment_dist'(2) some_geodesic_is_geodesic_segment(1))
 apply (rule geodesic_segment_union(2)[of x z], auto simp add: assms)
 using assms geodesic_segment_expression by blast
 
 lemma geodesic_segment_subparam':
   assumes "y \<in> {x--z}" "t \<in> {0..dist x y}"
   shows "geodesic_segment_param {x--z} x t = geodesic_segment_param {x--y} x t"
 apply (rule geodesic_segment_subparam[of _ _ z _ y]) using assms apply auto
 using geodesic_segment_split(1)[OF assms(1)] by auto
 
 end (*of context uniquely_geodesic_space*)
 
 
 subsection \<open>A complete metric space with middles is geodesic.\<close>
 
 text \<open>A complete space in which every pair of points has a middle (i.e., a point $m$ which
 is half distance of $x$ and $y$) is geodesic: to construct a geodesic between $x_0$
 and $y_0$, first choose a middle $m$, then middles of the pairs $(x_0,m)$ and $(m, y_0)$, and so
 on. This will define the geodesic on dyadic points (and this is indeed an isometry on these dyadic
 points. Then, extend it by uniform continuity to the whole segment $[0, dist x0 y0]$.
 
 The formal proof will be done in a locale where $x_0$ and $y_0$ are fixed, for notational simplicity.
 We define inductively the sequence of middles, in a function \verb+geod+ of two natural variables:
 $geod n m$ corresponds to the image of the dyadic point $m/2^n$. It is defined inductively, by
 $geod (n+1) (2m) = geod n m$, and $geod (n+1) (2m+1)$ is a middle of $geod n m$ and $geod n (m+1)$.
 This is not a completely classical inductive definition, so one has to use \verb+function+ to define
 it. Then, one checks inductively that it has all the properties we want, and use it to define the
 geodesic segment on dyadic points. We will not use a canonical
 representative for a dyadic point, but any representative (i.e., numerator and denominator
 will not have to be coprime) -- this will not create problems as $geod$ does not depend on the choice
 of the representative, by construction.\<close>
 
 locale complete_space_with_middle =
   fixes x0 y0::"'a::complete_space"
   assumes middles: "\<And>x y::'a. \<exists>z. dist x z = (dist x y)/2 \<and> dist z y = (dist x y)/2"
 begin
 
 definition middle::"'a \<Rightarrow> 'a \<Rightarrow> 'a"
   where "middle x y = (SOME z. dist x z = (dist x y)/2 \<and> dist z y = (dist x y)/2)"
 
 lemma middle:
   "dist x (middle x y) = (dist x y)/2"
   "dist (middle x y) y = (dist x y)/2"
 unfolding middle_def using middles[of x y] by (metis (mono_tags, lifting) someI_ex)+
 
 function geod::"nat \<Rightarrow> nat \<Rightarrow> 'a" where
  "geod 0 0 = x0"
 |"geod 0 (Suc m) = y0"
 |"geod (Suc n) (2 * m) = geod n m"
 |"geod (Suc n) (Suc (2*m)) = middle (geod n m) (geod n (Suc m))"
 apply (auto simp add: double_not_eq_Suc_double)
 by (metis One_nat_def dvd_mult_div_cancel list_decode.cases odd_Suc_minus_one odd_two_times_div_two_nat)
 termination by lexicographic_order
 
 text \<open>By induction, the distance between successive points is $D/2^n$.\<close>
 
 lemma geod_distance_successor:
   "\<forall>a < 2^n. dist (geod n a) (geod n (Suc a)) = dist x0 y0 / 2^n"
 proof (induction n)
   case 0
   show ?case by auto
 next
   case (Suc n)
   show ?case
   proof (auto)
     fix a::nat assume a: "a < 2 * 2^n"
     obtain m where m: "a = 2 * m \<or> a = Suc (2 * m)" by (metis geod.elims)
     then have "m < 2^n" using a by auto
     consider "a = 2 * m" | "a = Suc(2*m)" using m by auto
     then show "dist (geod (Suc n) a) (geod (Suc n) (Suc a)) = dist x0 y0 / (2 * 2 ^ n)"
     proof (cases)
       case 1
       show ?thesis
         unfolding 1 apply auto
         unfolding middle using Suc.IH \<open>m < 2^n\<close> by auto
     next
       case 2
       have *: "Suc (Suc (2 * m)) = 2 * (Suc m)" by auto
       show ?thesis
         unfolding 2 apply auto
         unfolding * geod.simps(3) middle using Suc.IH \<open>m < 2^n\<close> by auto
     qed
   qed
 qed
 
 lemma geod_mult:
   "geod n a = geod (n + k) (a * 2^k)"
 apply (induction k, auto) using geod.simps(3) by (metis mult.left_commute)
 
 lemma geod_0:
   "geod n 0 = x0"
 by (induction n, auto, metis geod.simps(3) semiring_normalization_rules(10))
 
 lemma geod_end:
   "geod n (2^n) = y0"
 by (induction n, auto)
 
 text \<open>By the triangular inequality, the distance between points separated by $(b-a)/2^n$ is at
 most $D * (b-a)/2^n$.\<close>
 
 lemma geod_upper:
   assumes "a \<le> b" "b \<le> 2^n"
   shows "dist (geod n a) (geod n b) \<le> (b-a) * dist x0 y0 / 2^n"
 proof -
   have *: "a+k > 2^n \<or> dist (geod n a) (geod n (a+k)) \<le> k * dist x0 y0 / 2^n" for k
   proof (induction k)
     case 0 then show ?case by auto
   next
     case (Suc k)
     show ?case
     proof (cases "2 ^ n < a + Suc k")
       case True then show ?thesis by auto
     next
       case False
       then have *: "a + k < 2 ^ n" by auto
       have "dist (geod n a) (geod n (a + Suc k)) \<le> dist (geod n a) (geod n (a+k)) + dist (geod n (a+k)) (geod n (a+Suc k))"
         using dist_triangle by auto
       also have "... \<le> k * dist x0 y0 / 2^n + dist x0 y0 / 2^n"
         using Suc.IH * geod_distance_successor by auto
       finally show ?thesis
         by (simp add: add_divide_distrib distrib_left mult.commute)
     qed
   qed
   show ?thesis using *[of "b-a"] assms by (simp add: of_nat_diff)
 qed
 
 text \<open>In fact, the distance is exactly $D * (b-a)/2^n$, otherwise the extremities of the interval
 would be closer than $D$, a contradiction.\<close>
 
 lemma geod_dist:
   assumes "a \<le> b" "b \<le> 2^n"
   shows "dist (geod n a) (geod n b) = (b-a) * dist x0 y0 / 2^n"
 proof -
   have "dist (geod n a) (geod n b) \<le> (real b-a) * dist x0 y0 / 2^n"
     using geod_upper[of a b n] assms by auto
   moreover have "\<not> (dist (geod n a) (geod n b) < (real b-a) * dist x0 y0 / 2^n)"
   proof (rule ccontr, simp)
     assume *: "dist (geod n a) (geod n b) < (real b-a) * dist x0 y0 / 2^n"
     have "dist x0 y0 = dist (geod n 0) (geod n (2^n))"
       using geod_0 geod_end by auto
     also have "... \<le> dist (geod n 0) (geod n a) + dist (geod n a) (geod n b) + dist (geod n b) (geod n (2^n))"
       using dist_triangle4 by auto
     also have "... < a * dist x0 y0 / 2^n + (real b-a) * dist x0 y0 / 2^n + (2^n - real b) * dist x0 y0 / 2^n"
       using * assms geod_upper[of 0 a n] geod_upper[of b "2^n" n] by (auto intro: mono_intros)
     also have "... = dist x0 y0"
       using assms by (auto simp add: algebra_simps divide_simps)
     finally show "False" by auto
   qed
   ultimately show ?thesis by auto
 qed
 
 text \<open>We deduce the same statement but for points that are not on the same level, by putting
 them on a common multiple level.\<close>
 
 lemma geod_dist2:
   assumes "a \<le> 2^n" "b \<le> 2^p" "a/2^n \<le> b / 2^p"
   shows "dist (geod n a) (geod p b) = (b/2^p - a/2^n) * dist x0 y0"
 proof -
   define r where "r = max n p"
   define ar where "ar = a * 2^(r - n)"
   have a: "ar / 2^r = a / 2^n"
     unfolding ar_def r_def by (auto simp add: divide_simps semiring_normalization_rules(26))
   have A: "geod r ar = geod n a"
     unfolding ar_def r_def using geod_mult[of n a "max n p - n"] by auto
   define br where "br = b * 2^(r - p)"
   have b: "br / 2^r = b / 2^p"
     unfolding br_def r_def by (auto simp add: divide_simps semiring_normalization_rules(26))
   have B: "geod r br = geod p b"
     unfolding br_def r_def using geod_mult[of p b "max n p - p"] by auto
 
   have "dist (geod n a) (geod p b) = dist (geod r ar) (geod r br)"
     using A B by auto
   also have "... = (real br - ar) * dist x0 y0 / 2 ^r"
     apply (rule geod_dist)
     using \<open>a/2^n \<le> b / 2^p\<close> unfolding a[symmetric] b[symmetric] apply (auto simp add: divide_simps)
     using \<open>b \<le> 2^p\<close> b apply (auto simp add: divide_simps)
     by (metis br_def le_add_diff_inverse2 max.cobounded2 mult.commute mult_le_mono2 r_def semiring_normalization_rules(26))
   also have "... = (real br / 2^r - real ar / 2^r) * dist x0 y0"
     by (auto simp add: algebra_simps divide_simps)
   finally show ?thesis using a b by auto
 qed
 
 text \<open>Same thing but without a priori ordering of the points.\<close>
 
 lemma geod_dist3:
   assumes "a \<le> 2^n" "b \<le> 2^p"
   shows "dist (geod n a) (geod p b) = abs(b/2^p - a/2^n) * dist x0 y0"
 apply (cases "a /2^n \<le> b/2^p", auto)
 apply (rule geod_dist2[OF assms], auto)
 apply (subst dist_commute, rule geod_dist2[OF assms(2) assms(1)], auto)
 done
 
 text \<open>Finally, we define a geodesic by extending what we have already defined on dyadic points,
 thanks to the result of isometric extension of isometries taking their values
 in complete spaces.\<close>
 
 lemma geod:
   shows "\<exists>g. isometry_on {0..dist x0 y0} g \<and> g 0 = x0 \<and> g (dist x0 y0) = y0"
 proof (cases "x0 = y0")
   case True
   show ?thesis apply (rule exI[of _ "\<lambda>_. x0"]) unfolding isometry_on_def using True by auto
 next
   case False
   define A where "A = {(real k/2^n) * dist x0 y0 |k n. k \<le> 2^n}"
   have "{0..dist x0 y0} \<subseteq> closure A"
   proof (auto simp add: closure_approachable dist_real_def)
     fix t::real assume t: "0 \<le> t" "t \<le> dist x0 y0"
     fix e:: real assume "e > 0"
     then obtain n::nat where n: "dist x0 y0/e < 2^n"
       using one_less_numeral_iff real_arch_pow semiring_norm(76) by blast
     define k where "k = floor (2^n * t/ dist x0 y0)"
     have "k \<le> 2^n * t/ dist x0 y0" unfolding k_def by auto
     also have "... \<le> 2^n" using t False by (auto simp add: algebra_simps divide_simps)
     finally have "k \<le> 2^n" by auto
     have "k \<ge> 0" using t False unfolding k_def by auto
     define l where "l = nat k"
     have "k = int l" "l \<le> 2^n" using \<open>k \<ge> 0\<close> \<open>k \<le> 2^n\<close> nat_le_iff unfolding l_def by auto
 
     have "abs (2^n * t/dist x0 y0 - k) \<le> 1" unfolding k_def by linarith
     then have "abs(t - k/2^n * dist x0 y0) \<le> dist x0 y0 / 2^n"
       by (auto simp add: algebra_simps divide_simps False)
     also have "... < e" using n \<open>e > 0\<close> by (auto simp add: algebra_simps divide_simps)
     finally have "abs(t - k/2^n * dist x0 y0) < e" by auto
     then have "abs(t - l/2^n * dist x0 y0) < e" using \<open>k = int l\<close> by auto
     moreover have "l/2^n * dist x0 y0 \<in> A" unfolding A_def using \<open>l \<le> 2^n\<close> by auto
     ultimately show "\<exists>u\<in>A. abs(u - t) < e" by force
   qed
 
   text \<open>For each dyadic point, we choose one representation of the form $K/2^N$, it is not important
   for us that it is the minimal one.\<close>
   define index where "index = (\<lambda>t. SOME i. t = real (fst i)/2^(snd i) * dist x0 y0 \<and> (fst i) \<le> 2^(snd i))"
   define K where "K = (\<lambda>t. fst (index t))"
   define N where "N = (\<lambda>t. snd (index t))"
   have t: "t = K t/ 2^(N t) * dist x0 y0 \<and> K t \<le> 2^(N t)" if "t \<in> A" for t
   proof -
     obtain n k::nat where "t = k/2^n * dist x0 y0" "k \<le> 2^n" using \<open>t\<in> A\<close> unfolding A_def by auto
     then have *: "\<exists>i. t = real (fst i)/2^(snd i) * dist x0 y0 \<and> (fst i) \<le> 2^(snd i)" by auto
     show ?thesis unfolding K_def N_def index_def using someI_ex[OF *] by auto
   qed
 
   text \<open>We can now define our function on dyadic points.\<close>
   define f where "f = (\<lambda>t. geod (N t) (K t))"
   have "0 \<in> A" unfolding A_def by auto
   have "f 0 = x0"
   proof -
     have "0 = K 0 /2^(N 0) * dist x0 y0" using t \<open>0 \<in> A\<close> by auto
     then have "K 0 = 0" using False by auto
     then show ?thesis unfolding f_def using geod_0 by auto
   qed
   have "dist x0 y0 = (real 1/2^0) * dist x0 y0" by auto
   then have "dist x0 y0 \<in> A" unfolding A_def by force
   have "f (dist x0 y0) = y0"
   proof -
     have "dist x0 y0 = K (dist x0 y0) / 2^(N (dist x0 y0)) * dist x0 y0"
       using t \<open>dist x0 y0 \<in> A\<close> by auto
     then have "K (dist x0 y0) = 2^(N(dist x0 y0))" using False by (auto simp add: divide_simps)
     then show ?thesis unfolding f_def using geod_end by auto
   qed
   text \<open>By construction, it is an isometry on dyadic points.\<close>
   have "isometry_on A f"
   proof (rule isometry_onI)
     fix s t assume inA: "s \<in> A" "t \<in> A"
     have "dist (f s) (f t) = abs (K t/2^(N t) - K s/2^(N s)) * dist x0 y0"
       unfolding f_def apply (rule geod_dist3) using t inA by auto
     also have "... = abs(K t/2^(N t) * dist x0 y0 - K s/2^(N s) * dist x0 y0)"
       by (auto simp add: abs_mult_pos left_diff_distrib)
     also have "... = abs(t - s)"
       using t inA by auto
     finally show "dist (f s) (f t) = dist s t" unfolding dist_real_def by auto
   qed
   text \<open>We can thus extend it to an isometry on the closure of dyadic points.
   It is the desired geodesic.\<close>
   then obtain g where g: "isometry_on (closure A) g" "\<And>t. t \<in> A \<Longrightarrow> g t = f t"
     using isometry_extend_closure by metis
   have "isometry_on {0..dist x0 y0} g"
     by (rule isometry_on_subset[OF \<open>isometry_on (closure A) g\<close> \<open>{0..dist x0 y0} \<subseteq> closure A\<close>])
   moreover have "g 0 = x0"
     using g(2)[OF \<open>0 \<in> A\<close>] \<open>f 0 = x0\<close> by simp
   moreover have "g (dist x0 y0) = y0"
     using g(2)[OF \<open>dist x0 y0 \<in> A\<close>] \<open>f (dist x0 y0) = y0\<close> by simp
   ultimately show ?thesis by auto
 qed
 
 end
 
 text \<open>We can now complete the proof that a complete space with middles is in fact geodesic:
 all the work has been done in the locale \verb+complete_space_with_middle+, in Lemma~\verb+geod+.\<close>
 
 theorem complete_with_middles_imp_geodesic:
   assumes "\<And>x y::('a::complete_space). \<exists>m. dist x m = dist x y /2 \<and> dist m y = dist x y /2"
   shows "OFCLASS('a, geodesic_space_class)"
 proof (standard, rule geodesic_subsetI)
   fix x0 y0::'a
   interpret complete_space_with_middle x0 y0
     apply standard using assms by auto
   have "\<exists>g. g 0 = x0 \<and> g (dist x0 y0) = y0 \<and> isometry_on {0..dist x0 y0} g"
     using geod by auto
   then show "\<exists>G. geodesic_segment_between G x0 y0 \<and> G \<subseteq> UNIV"
     unfolding geodesic_segment_between_def by auto
 qed
 
 
 section \<open>Quasi-isometries\<close>
 
 text \<open>A $(\lambda, C)$ quasi-isometry is a function which behaves like an isometry, up to
 an additive error $C$ and a multiplicative error $\lambda$. It can be very different from an
 isometry on small scales (for instance, the function integer part is a quasi-isometry between
 $\mathbb{R}$ and $\mathbb{Z}$), but on large scales it captures many important features of
 isometries.
 
 When the space is unbounded, one checks easily that $C \geq 0$ and $\lambda \geq 1$. As this
 is the only case of interest (any two bounded sets are quasi-isometric), we incorporate
 this requirement in the definition.\<close>
 
 definition quasi_isometry_on::"real \<Rightarrow> real \<Rightarrow> ('a::metric_space) set \<Rightarrow> ('a \<Rightarrow> ('b::metric_space)) \<Rightarrow> bool"
   ("_ _ -quasi'_isometry'_on" [1000, 999])
   where "lambda C-quasi_isometry_on X f = ((lambda \<ge> 1) \<and> (C \<ge> 0) \<and>
     (\<forall>x \<in> X. \<forall>y \<in> X. (dist (f x) (f y) \<le> lambda * dist x y + C \<and> dist (f x) (f y) \<ge> (1/lambda) * dist x y - C)))"
 
 abbreviation quasi_isometry :: "real \<Rightarrow> real \<Rightarrow> ('a::metric_space \<Rightarrow> 'b::metric_space) \<Rightarrow> bool"
   ("_ _ -quasi'_isometry" [1000, 999])
   where "quasi_isometry lambda C f \<equiv> lambda C-quasi_isometry_on UNIV f"
 
 subsection \<open>Basic properties of quasi-isometries\<close>
 
 lemma quasi_isometry_onD:
   assumes "lambda C-quasi_isometry_on X f"
   shows "\<And>x y. x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> dist (f x) (f y) \<le> lambda * dist x y + C"
         "\<And>x y. x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> dist (f x) (f y) \<ge> (1/lambda) * dist x y - C"
         "lambda \<ge> 1" "C \<ge> 0"
 using assms unfolding quasi_isometry_on_def by auto
 
 lemma quasi_isometry_onI [intro]:
   assumes "\<And>x y. x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> dist (f x) (f y) \<le> lambda * dist x y + C"
           "\<And>x y. x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> dist (f x) (f y) \<ge> (1/lambda) * dist x y - C"
           "lambda \<ge> 1" "C \<ge> 0"
   shows "lambda C-quasi_isometry_on X f"
 using assms unfolding quasi_isometry_on_def by auto
 
 lemma isometry_quasi_isometry_on:
   assumes "isometry_on X f"
   shows "1 0-quasi_isometry_on X f"
 using assms unfolding isometry_on_def quasi_isometry_on_def by auto
 
 lemma quasi_isometry_on_change_params:
   assumes "lambda C-quasi_isometry_on X f" "mu \<ge> lambda" "D \<ge> C"
   shows "mu D-quasi_isometry_on X f"
 proof (rule quasi_isometry_onI)
   have P1: "lambda \<ge> 1" "C \<ge> 0" using quasi_isometry_onD[OF assms(1)] by auto
   then show P2: "mu \<ge> 1" "D \<ge> 0" using assms by auto
   fix x y assume inX: "x \<in> X" "y \<in> X"
   have "dist (f x) (f y) \<le> lambda * dist x y + C"
     using quasi_isometry_onD[OF assms(1)] inX by auto
   also have "... \<le> mu * dist x y + D"
     using assms by (auto intro!: mono_intros)
   finally show "dist (f x) (f y) \<le> mu * dist x y + D" by simp
   have "dist (f x) (f y) \<ge> (1/lambda) * dist x y - C"
     using quasi_isometry_onD[OF assms(1)] inX by auto
   moreover have "(1/lambda) * dist x y + (- C) \<ge> (1/mu) * dist x y + (- D)"
     apply (intro mono_intros)
     using P1 P2 assms by (auto simp add: divide_simps)
   ultimately show "dist (f x) (f y) \<ge> (1/mu) * dist x y - D" by simp
 qed
 
 lemma quasi_isometry_on_subset:
   assumes "lambda C-quasi_isometry_on X f"
           "Y \<subseteq> X"
   shows "lambda C-quasi_isometry_on Y f"
 using assms unfolding quasi_isometry_on_def by auto
 
 lemma quasi_isometry_on_perturb:
   assumes "lambda C-quasi_isometry_on X f"
           "D \<ge> 0"
           "\<And>x. x \<in> X \<Longrightarrow> dist (f x) (g x) \<le> D"
   shows "lambda (C + 2 * D)-quasi_isometry_on X g"
 proof (rule quasi_isometry_onI)
   show "lambda \<ge> 1" "C + 2 * D \<ge> 0" using \<open>D \<ge> 0\<close> quasi_isometry_onD[OF assms(1)] by auto
   fix x y assume *: "x \<in> X" "y \<in> X"
   have "dist (g x) (g y) \<le> dist (f x) (f y) + 2 * D"
     using assms(3)[OF *(1)] assms(3)[OF *(2)] dist_triangle4[of "g x" "g y" "f x" "f y"] by (simp add: dist_commute)
   then show "dist (g x) (g y) \<le> lambda * dist x y + (C + 2 * D)"
     using quasi_isometry_onD(1)[OF assms(1) *] by auto
   have "dist (g x) (g y) \<ge> dist (f x) (f y) - 2 * D"
     using assms(3)[OF *(1)] assms(3)[OF *(2)] dist_triangle4[of "f x" "f y" "g x" "g y"] by (simp add: dist_commute)
   then show "dist (g x) (g y) \<ge> (1/lambda) * dist x y - (C + 2 * D)"
     using quasi_isometry_onD(2)[OF assms(1) *] by auto
 qed
 
 lemma quasi_isometry_on_compose:
   assumes "lambda C-quasi_isometry_on X f"
           "mu D-quasi_isometry_on Y g"
           "f`X \<subseteq> Y"
   shows "(lambda * mu) (C * mu + D)-quasi_isometry_on X (g o f)"
 proof (rule quasi_isometry_onI)
   have I: "lambda \<ge> 1" "C \<ge> 0" "mu \<ge> 1" "D \<ge> 0"
     using quasi_isometry_onD[OF assms(1)] quasi_isometry_onD[OF assms(2)] by auto
   then show "lambda * mu \<ge> 1" "C * mu + D \<ge> 0"
     by (auto, metis dual_order.order_iff_strict le_numeral_extra(2) mult_le_cancel_right1 order.strict_trans1)
   fix x y assume inX: "x \<in> X" "y \<in> X"
   then have inY: "f x \<in> Y" "f y \<in> Y" using \<open>f`X \<subseteq> Y\<close> by auto
   have "dist ((g o f) x) ((g o f) y) \<le> mu * dist (f x) (f y) + D"
     using quasi_isometry_onD(1)[OF assms(2) inY] by simp
   also have "... \<le> mu * (lambda * dist x y + C) + D"
     using \<open>mu \<ge> 1\<close> quasi_isometry_onD(1)[OF assms(1) inX] by auto
   finally show "dist ((g o f) x) ((g o f) y) \<le> (lambda * mu) * dist x y + (C * mu + D)"
     by (auto simp add: algebra_simps)
 
   have "(1/(lambda * mu)) * dist x y - (C * mu + D) \<le> (1/(lambda * mu)) * dist x y - (C/mu + D)"
     using \<open>mu \<ge> 1\<close> \<open>C \<ge> 0\<close> apply (auto, auto simp add: divide_simps)
     by (metis eq_iff less_eq_real_def mult.commute mult_eq_0_iff mult_le_cancel_right1 order.trans)
   also have "... = (1/mu) * ((1/lambda) * dist x y - C) - D"
     by (auto simp add: algebra_simps)
   also have "... \<le> (1/mu) * dist (f x) (f y) - D"
     using \<open>mu \<ge> 1\<close> quasi_isometry_onD(2)[OF assms(1) inX] by (auto simp add: divide_simps)
   also have "... \<le> dist ((g o f) x) ((g o f) y)"
     using quasi_isometry_onD(2)[OF assms(2) inY] by auto
   finally show "1 / (lambda * mu) * dist x y - (C * mu + D) \<le> dist ((g \<circ> f) x) ((g \<circ> f) y)"
     by auto
 qed
 
 lemma quasi_isometry_on_bounded:
   assumes "lambda C-quasi_isometry_on X f"
           "bounded X"
   shows "bounded (f`X)"
 proof (cases "X = {}")
   case True
   then show ?thesis by auto
 next
   case False
   obtain x where "x \<in> X" using False by auto
   obtain e where e: "\<And>z. z \<in> X \<Longrightarrow> dist x z \<le> e"
     using bounded_any_center assms(2) by metis
   have "dist (f x) y \<le> C + lambda * e" if "y \<in> f`X" for y
   proof -
     obtain z where *: "z \<in> X" "y = f z" using \<open>y \<in> f`X\<close> by auto
     have "dist (f x) y \<le> lambda * dist x z + C"
       unfolding \<open>y = f z\<close> using * quasi_isometry_onD(1)[OF assms(1) \<open>x \<in> X\<close> \<open>z \<in> X\<close>] by (auto simp add: add_mono)
     also have "... \<le> C + lambda * e" using e[OF \<open>z \<in> X\<close>] quasi_isometry_onD(3)[OF assms(1)] by auto
     finally show ?thesis by simp
   qed
   then show ?thesis unfolding bounded_def by auto
 qed
 
 lemma quasi_isometry_on_empty:
   assumes "C \<ge> 0" "lambda \<ge> 1"
   shows "lambda C-quasi_isometry_on {} f"
 using assms unfolding quasi_isometry_on_def by auto
 
 text \<open>Quasi-isometries change the distance to a set by at most $\lambda \cdot + C$, this follows
 readily from the fact that this inequality holds pointwise.\<close>
 
 lemma quasi_isometry_on_infdist:
   assumes "lambda C-quasi_isometry_on X f"
           "w \<in> X"
           "S \<subseteq> X"
   shows "infdist (f w) (f`S) \<le> lambda * infdist w S + C"
         "infdist (f w) (f`S) \<ge> (1/lambda) * infdist w S - C"
 proof -
   have "lambda \<ge> 1" "C \<ge> 0" using quasi_isometry_onD[OF assms(1)] by auto
   show "infdist (f w) (f`S) \<le> lambda * infdist w S + C"
   proof (cases "S = {}")
     case True
     then show ?thesis
       using \<open>C \<ge> 0\<close> unfolding infdist_def by auto
   next
     case False
     then have "(INF x\<in>S. dist (f w) (f x)) \<le> (INF x\<in>S. lambda * dist w x + C)"
       apply (rule cINF_superset_mono)
         apply (meson bdd_belowI2 zero_le_dist) using assms by (auto intro!: quasi_isometry_onD(1)[OF assms(1)])
     also have "... = (INF t\<in>(dist w)`S. lambda * t + C)"
       by (auto simp add: image_comp)
     also have "... = lambda * Inf ((dist w)`S) + C"
       apply (rule continuous_at_Inf_mono[symmetric])
       unfolding mono_def using \<open>lambda \<ge> 1\<close> False by (auto intro!: continuous_intros)
     finally show ?thesis unfolding infdist_def using False by (auto simp add: image_comp)
   qed
   show "1 / lambda * infdist w S - C \<le> infdist (f w) (f ` S)"
   proof (cases "S = {}")
     case True
     then show ?thesis
       using \<open>C \<ge> 0\<close> unfolding infdist_def by auto
   next
     case False
     then have "(1/lambda) * infdist w S - C = (1/lambda) * Inf ((dist w)`S) - C"
       unfolding infdist_def by auto
     also have "... = (INF t\<in>(dist w)`S. (1/lambda) * t - C)"
       apply (rule continuous_at_Inf_mono)
       unfolding mono_def using \<open>lambda \<ge> 1\<close> False by (auto simp add: divide_simps intro!: continuous_intros)
     also have "... = (INF x\<in>S. (1/lambda) * dist w x - C)"
       by (auto simp add: image_comp)
     also have "... \<le> (INF x\<in>S. dist (f w) (f x))"
       apply (rule cINF_superset_mono[OF False]) apply (rule bdd_belowI2[of _ "-C"])
       using assms \<open>lambda \<ge> 1\<close> apply simp apply simp apply (rule quasi_isometry_onD(2)[OF assms(1)])
       using assms by auto
     finally show ?thesis unfolding infdist_def using False by (auto simp add: image_comp)
   qed
 qed
 
 subsection \<open>Quasi-isometric isomorphisms\<close>
 
 text \<open>The notion of isomorphism for quasi-isometries is not that it should be a bijection, as it is
 a coarse notion, but that it is a bijection up to a bounded displacement. For instance, the
 inclusion of $\mathbb{Z}$ in $\mathbb{R}$ is a quasi-isometric isomorphism between these spaces,
 whose (quasi)-inverse (which is non-unique) is given by the function integer part. This is
 formalized in the next definition.\<close>
 
 definition quasi_isometry_between::"real \<Rightarrow> real \<Rightarrow> ('a::metric_space) set \<Rightarrow> ('b::metric_space) set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
   ("_ _ -quasi'_isometry'_between" [1000, 999])
   where "lambda C-quasi_isometry_between X Y f = ((lambda C-quasi_isometry_on X f) \<and> (f`X \<subseteq> Y) \<and> (\<forall>y\<in>Y. \<exists>x\<in>X. dist (f x) y \<le> C))"
 
 definition quasi_isometric::"('a::metric_space) set \<Rightarrow> ('b::metric_space) set \<Rightarrow> bool"
   where "quasi_isometric X Y = (\<exists>lambda C f. lambda C-quasi_isometry_between X Y f)"
 
 lemma quasi_isometry_betweenD:
   assumes "lambda C-quasi_isometry_between X Y f"
   shows "lambda C-quasi_isometry_on X f"
         "f`X \<subseteq> Y"
         "\<And>y. y \<in> Y \<Longrightarrow> \<exists>x\<in>X. dist (f x) y \<le> C"
         "\<And>x y. x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> dist (f x) (f y) \<le> lambda * dist x y + C"
         "\<And>x y. x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> dist (f x) (f y) \<ge> (1/lambda) * dist x y - C"
         "lambda \<ge> 1" "C \<ge> 0"
 using assms unfolding quasi_isometry_between_def quasi_isometry_on_def by auto
 
 lemma quasi_isometry_betweenI:
   assumes "lambda C-quasi_isometry_on X f"
           "f`X \<subseteq> Y"
           "\<And>y. y \<in> Y \<Longrightarrow> \<exists>x\<in>X. dist (f x) y \<le> C"
   shows "lambda C-quasi_isometry_between X Y f"
 using assms unfolding quasi_isometry_between_def by auto
 
 lemma quasi_isometry_on_between:
   assumes "lambda C-quasi_isometry_on X f"
   shows "lambda C-quasi_isometry_between X (f`X) f"
 using assms unfolding quasi_isometry_between_def quasi_isometry_on_def by force
 
 lemma quasi_isometry_between_change_params:
   assumes "lambda C-quasi_isometry_between X Y f" "mu \<ge> lambda" "D \<ge> C"
   shows "mu D-quasi_isometry_between X Y f"
 proof (rule quasi_isometry_betweenI)
   show "mu D-quasi_isometry_on X f"
     by (rule quasi_isometry_on_change_params[OF quasi_isometry_betweenD(1)[OF assms(1)] assms(2) assms(3)])
   show "f`X \<subseteq> Y" using quasi_isometry_betweenD[OF assms(1)] by auto
   fix y assume "y \<in> Y"
   show "\<exists>x\<in>X. dist (f x) y \<le> D" using quasi_isometry_betweenD(3)[OF assms(1) \<open>y \<in> Y\<close>] \<open>D \<ge> C\<close> by force
 qed
 
 lemma quasi_isometry_subset:
   assumes "X \<subseteq> Y" "\<And>y. y \<in> Y \<Longrightarrow> \<exists>x\<in>X. dist x y \<le> C" "C \<ge> 0"
   shows "1 C-quasi_isometry_between X Y (\<lambda>x. x)"
 unfolding quasi_isometry_between_def using assms by auto
 
 lemma isometry_quasi_isometry_between:
   assumes "isometry f"
   shows "1 0-quasi_isometry_between UNIV UNIV f"
 using assms unfolding quasi_isometry_between_def quasi_isometry_on_def isometry_def isometry_on_def surj_def by (auto) metis
 
 proposition quasi_isometry_inverse:
   assumes "lambda C-quasi_isometry_between X Y f"
   shows "\<exists>g. lambda (3 * C * lambda)-quasi_isometry_between Y X g
           \<and> (\<forall>x\<in>X. dist x (g (f x)) \<le> 3 * C * lambda)
           \<and> (\<forall>y\<in>Y. dist y (f (g y)) \<le> 3 * C * lambda)"
 proof -
   define g where "g = (\<lambda>y. SOME x. x \<in> X \<and> dist (f x) y \<le> C)"
   have *: "g y \<in> X \<and> dist (f (g y)) y \<le> C" if "y \<in> Y" for y
     unfolding g_def using quasi_isometry_betweenD(3)[OF assms that] by (metis (no_types, lifting) someI_ex)
   have "lambda \<ge> 1" "C \<ge> 0" using quasi_isometry_betweenD[OF assms] by auto
 
   have "C \<le> 3 * C * lambda" using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close>
-    by (metis linordered_field_class.sign_simps(24) mult_le_cancel_left1 not_less numeral_le_iff one_eq_numeral_iff order.trans semiring_norm(68))
+    by (simp add: algebra_simps mult_ge1_mono)
   then have A: "dist y (f (g y)) \<le> 3 * C * lambda" if "y \<in> Y" for y
     using *[OF that] by (simp add: dist_commute)
 
   have B: "dist x (g (f x)) \<le> 3 * C * lambda" if "x \<in> X" for x
   proof -
     have "f x \<in> Y" using that quasi_isometry_betweenD(2)[OF assms] by auto
     have "(1/lambda) * dist x (g (f x)) - C \<le> dist (f x) (f (g (f x)))"
       apply (rule quasi_isometry_betweenD(5)[OF assms]) using that *[OF \<open>f x \<in> Y\<close>] by auto
     also have "... \<le> C" using *[OF \<open>f x \<in> Y\<close>] by (simp add: dist_commute)
     finally have "dist x (g (f x)) \<le> 2 * C * lambda"
       using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> by (simp add: divide_simps)
     also have "... \<le> 3 * C * lambda"
       using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> by (simp add: divide_simps)
     finally show ?thesis by auto
   qed
 
   have "lambda (3 * C * lambda)-quasi_isometry_on Y g"
   proof (rule quasi_isometry_onI)
     show "lambda \<ge> 1" "3 * C * lambda \<ge> 0" using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> by auto
     fix y1 y2 assume inY: "y1 \<in> Y" "y2 \<in> Y"
     then have inX: "g y1 \<in> X" "g y2 \<in> X" using * by auto
     have "dist y1 y2 \<le> dist y1 (f (g y1)) + dist (f (g y1)) (f (g y2)) + dist (f (g y2)) y2"
       using dist_triangle4 by auto
     also have "... \<le> C + dist (f (g y1)) (f (g y2)) + C"
       using *[OF inY(1)] *[OF inY(2)] by (auto simp add: dist_commute intro: add_mono)
     also have "... \<le> C + (lambda * dist (g y1) (g y2) + C) + C"
       using quasi_isometry_betweenD(4)[OF assms inX] by (auto intro: add_mono)
     finally have "dist y1 y2 - 3 * C \<le> lambda * dist (g y1) (g y2)" by auto
     then have "dist (g y1) (g y2) \<ge> (1/lambda) * dist y1 y2 - 3 * C / lambda"
       using \<open>lambda \<ge> 1\<close> by (auto simp add: divide_simps mult.commute)
     moreover have "3 * C / lambda \<le> 3 * C * lambda"
       using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> apply (auto simp add: divide_simps mult_le_cancel_left1)
       by (metis dual_order.order_iff_strict less_1_mult mult.left_neutral)
     ultimately show "dist (g y1) (g y2) \<ge> (1/lambda) * dist y1 y2 - 3 * C * lambda"
       by auto
 
     have "(1/lambda) * dist (g y1) (g y2) - C \<le> dist (f (g y1)) (f (g y2))"
       using quasi_isometry_betweenD(5)[OF assms inX] by auto
     also have "... \<le> dist (f (g y1)) y1 + dist y1 y2 + dist y2 (f (g y2))"
       using dist_triangle4 by auto
     also have "... \<le> C + dist y1 y2 + C"
       using *[OF inY(1)] *[OF inY(2)] by (auto simp add: dist_commute intro: add_mono)
     finally show "dist (g y1) (g y2) \<le> lambda * dist y1 y2 + 3 * C * lambda"
       using \<open>lambda \<ge> 1\<close> by (auto simp add: divide_simps algebra_simps)
   qed
   then have "lambda (3 * C * lambda)-quasi_isometry_between Y X g"
   proof (rule quasi_isometry_betweenI)
     show "g ` Y \<subseteq> X" using * by auto
     fix x assume "x \<in> X"
     have "f x \<in> Y" "dist (g (f x)) x \<le> 3 * C * lambda"
       using B[OF \<open>x \<in> X\<close>] quasi_isometry_betweenD(2)[OF assms] \<open>x \<in> X\<close> by (auto simp add: dist_commute)
     then show "\<exists>y\<in>Y. dist (g y) x \<le> 3 * C * lambda" by blast
   qed
   then show ?thesis using A B by blast
 qed
 
 proposition quasi_isometry_compose:
   assumes "lambda C-quasi_isometry_between X Y f"
           "mu D-quasi_isometry_between Y Z g"
   shows "(lambda * mu) (C * mu + 2 * D)-quasi_isometry_between X Z (g o f)"
 proof (rule quasi_isometry_betweenI)
   have "(lambda * mu) (C * mu + D)-quasi_isometry_on X (g \<circ> f)"
     by (rule quasi_isometry_on_compose[OF quasi_isometry_betweenD(1)[OF assms(1)]
         quasi_isometry_betweenD(1)[OF assms(2)] quasi_isometry_betweenD(2)[OF assms(1)]])
   then show "(lambda * mu) (C * mu + 2 * D)-quasi_isometry_on X (g \<circ> f)"
     apply (rule quasi_isometry_on_change_params) using quasi_isometry_betweenD(7)[OF assms(2)] by auto
 
   show "(g \<circ> f) ` X \<subseteq> Z"
     using quasi_isometry_betweenD(2)[OF assms(1)] quasi_isometry_betweenD(2)[OF assms(2)]
     by auto
   fix z assume "z \<in> Z"
   obtain y where y: "y \<in> Y" "dist (g y) z \<le> D"
     using quasi_isometry_betweenD(3)[OF assms(2) \<open>z \<in> Z\<close>] by auto
   obtain x where x: "x \<in> X" "dist (f x) y \<le> C"
     using quasi_isometry_betweenD(3)[OF assms(1) \<open>y \<in> Y\<close>] by auto
   have "dist ((g o f) x) z \<le> dist (g (f x)) (g y) + dist (g y) z"
     using dist_triangle by auto
   also have "... \<le> (mu * dist (f x) y + D) + D"
     apply (rule add_mono, rule quasi_isometry_betweenD(4)[OF assms(2)])
     using x y quasi_isometry_betweenD(2)[OF assms(1)] by auto
   also have "... \<le> C * mu + 2 * D"
     using x(2) quasi_isometry_betweenD(6)[OF assms(2)] by auto
   finally show "\<exists>x\<in>X. dist ((g \<circ> f) x) z \<le> C * mu + 2 * D"
     using x(1) by auto
 qed
 
 theorem quasi_isometric_equiv_rel:
   "quasi_isometric X X"
   "quasi_isometric X Y \<Longrightarrow> quasi_isometric Y Z \<Longrightarrow> quasi_isometric X Z"
   "quasi_isometric X Y \<Longrightarrow> quasi_isometric Y X"
 proof -
   show "quasi_isometric X X"
     unfolding quasi_isometric_def using quasi_isometry_subset[of X X 0] by auto
   assume H: "quasi_isometric X Y"
   then show "quasi_isometric Y X"
     unfolding quasi_isometric_def using quasi_isometry_inverse by blast
   assume "quasi_isometric Y Z"
   then show "quasi_isometric X Z"
     using H unfolding quasi_isometric_def using quasi_isometry_compose by blast
 qed
 
 text \<open>Many interesting properties in geometric group theory are invariant under quasi-isometry.
 We prove the most basic ones here.\<close>
 
 lemma quasi_isometric_empty:
   assumes "X = {}" "quasi_isometric X Y"
   shows "Y = {}"
 using assms unfolding quasi_isometric_def quasi_isometry_between_def quasi_isometry_on_def by blast
 
 lemma quasi_isometric_bounded:
   assumes "bounded X" "quasi_isometric X Y"
   shows "bounded Y"
 proof (cases "X = {}")
   case True
   show ?thesis using quasi_isometric_empty[OF True assms(2)] by auto
 next
   case False
   obtain lambda C f where QI: "lambda C-quasi_isometry_between X Y f"
     using assms(2) unfolding quasi_isometric_def by auto
   obtain x where "x \<in> X" using False by auto
   obtain e where e: "\<And>z. z \<in> X \<Longrightarrow> dist x z \<le> e"
     using bounded_any_center assms(1) by metis
   have "dist (f x) y \<le> 2 * C + lambda * e" if "y \<in> Y" for y
   proof -
     obtain z where *: "z \<in> X" "dist (f z) y \<le> C"
       using quasi_isometry_betweenD(3)[OF QI \<open>y \<in> Y\<close>] by auto
     have "dist (f x) y \<le> dist (f x) (f z) + dist (f z) y" using dist_triangle by auto
     also have "... \<le> (lambda * dist x z + C) + C"
       using * quasi_isometry_betweenD(4)[OF QI \<open>x \<in> X\<close> \<open>z \<in> X\<close>] by (auto simp add: add_mono)
     also have "... \<le> 2 * C + lambda * e"
       using quasi_isometry_betweenD(6)[OF QI] e[OF \<open>z \<in> X\<close>] by (auto simp add: algebra_simps)
     finally show ?thesis by simp
   qed
   then show ?thesis unfolding bounded_def by auto
 qed
 
 lemma quasi_isometric_bounded_iff:
   assumes "bounded X" "X \<noteq> {}" "bounded Y" "Y \<noteq> {}"
   shows "quasi_isometric X Y"
 proof -
   obtain x y where "x \<in> X" "y \<in> Y" using assms by auto
   obtain C where C: "\<And>z. z \<in> Y \<Longrightarrow> dist y z \<le> C"
     using \<open>bounded Y\<close> bounded_any_center by metis
   have "C \<ge> 0" using C[OF \<open>y \<in> Y\<close>] by auto
   obtain D where D: "\<And>z. z \<in> X \<Longrightarrow> dist x z \<le> D"
     using \<open>bounded X\<close> bounded_any_center by metis
   have "D \<ge> 0" using D[OF \<open>x \<in> X\<close>] by auto
 
   define f::"'a \<Rightarrow> 'b" where "f = (\<lambda>_. y)"
   have "1 (C + 2 * D)-quasi_isometry_between X Y f"
   proof (rule quasi_isometry_betweenI)
     show "f`X \<subseteq> Y" unfolding f_def using \<open>y \<in> Y\<close> by auto
     show "1 (C + 2 * D)-quasi_isometry_on X f"
     proof (rule quasi_isometry_onI, auto simp add: \<open>C \<ge> 0\<close> \<open>D \<ge> 0\<close> f_def)
       fix a b assume "a \<in> X" "b \<in> X"
       have "dist a b \<le> dist a x + dist x b"
         using dist_triangle by auto
       also have "... \<le> D + D"
         using D[OF \<open>a \<in> X\<close>] D[OF \<open>b \<in> X\<close>] by (auto simp add: dist_commute)
       finally show "dist a b \<le> C + 2 * D" using \<open>C \<ge> 0\<close> by auto
     qed
     show "\<exists>a\<in>X. dist (f a) z \<le> C + 2 * D" if "z \<in> Y" for z
       unfolding f_def using \<open>x \<in> X\<close> C[OF \<open>z \<in> Y\<close>] \<open>D \<ge> 0\<close> by auto
   qed
   then show ?thesis unfolding quasi_isometric_def by auto
 qed
 
 subsection \<open>Quasi-isometries of Euclidean spaces.\<close>
 
 text \<open>A less trivial fact is that the dimension of euclidean spaces is invariant under
 quasi-isometries. It is proved below using growth argument, as quasi-isometries preserve the
 growth rate.
 
 The growth of the space is asymptotic behavior of the number of well-separated points that
 fit in a ball of radius $R$, when $R$ tends to infinity. Up to a suitable equivalence, it is
 clearly a quasi-isometry invariance. We show below that, in a Euclidean space of dimension $d$,
 the growth is like $R^d$: the upper bound is obtained by using the fact that we have disjoint balls
 inside a big ball, hence volume controls conclude the argument, while the lower bound is obtained
 by considering integer points.\<close>
 
 text \<open>First, we show that the growth rate of a Euclidean space of dimension $d$ is bounded
 from above by $R^d$, using the control on measure of disjoint balls and a volume argument.\<close>
 
 proposition growth_rate_euclidean_above:
   fixes D::real
   assumes "D > (0::real)"
       and H: "F \<subseteq> cball (0::'a::euclidean_space) R" "R \<ge> 0"
           "\<And>x y. x \<in> F \<Longrightarrow> y \<in> F \<Longrightarrow> x \<noteq> y \<Longrightarrow> dist x y \<ge> D"
   shows "finite F \<and> card F \<le> 1 + ((6/D)^(DIM('a))) * R^(DIM('a))"
 proof -
   define C::real where "C = ((6/D)^(DIM('a)))"
   have "C \<ge> 0" unfolding C_def using \<open>D > 0\<close> by auto
   have "D/3 \<ge> 0" using assms by auto
   have "finite F \<and> card F \<le> 1 + C * R^(DIM('a))"
   proof (cases "R < D/2")
     case True
     have "x = y" if "x \<in> F" "y \<in> F" for x y
     proof (rule ccontr)
       assume "\<not>(x = y)"
       then have "D \<le> dist x y" using H \<open>x \<in> F\<close> \<open>y \<in> F\<close> by auto
       also have "... \<le> dist x 0 + dist 0 y" by (rule dist_triangle)
       also have "... \<le> R + R"
         using H(1) \<open>x \<in> F\<close> \<open>y \<in> F\<close> by (intro add_mono, auto)
       also have "... < D" using \<open>R < D/2\<close> by auto
       finally show False by simp
     qed
     then have "finite F \<and> card F \<le> 1" using finite_at_most_singleton by auto
     moreover have "1 + 0 * R^(DIM('a)) \<le> 1 + C * R^(DIM('a))"
       using \<open>C \<ge> 0\<close> \<open>R \<ge> 0\<close> by (auto intro: mono_intros)
     ultimately show ?thesis by auto
   next
     case False
     have "card G \<le> 1 + C * R^(DIM('a))" if "G \<subseteq> F" "finite G" for G
     proof -
       have "norm y \<le> 2*R" if "y \<in> cball x (D/3)" "x \<in> G" for x y
       proof -
         have "norm y = dist 0 y" by auto
         also have "... \<le> dist 0 x + dist x y" by (rule dist_triangle)
         also have "... \<le> R + D/3"
           using \<open>x \<in> G\<close> \<open>G \<subseteq> F\<close> \<open>y \<in> cball x (D/3)\<close> \<open>F \<subseteq> cball 0 R\<close> by (auto intro: add_mono)
         finally show ?thesis using False \<open>D > 0\<close> by auto
       qed
       then have I: "(\<Union>x\<in>G. cball x (D/3)) \<subseteq> cball 0 (2*R)"
         by auto
       have "disjoint_family_on (\<lambda>x. cball x (D/3)) G"
         unfolding disjoint_family_on_def proof (auto)
         fix a b x assume *: "a \<in> G" "b \<in> G" "a \<noteq> b" "dist a x * 3 \<le> D" "dist b x * 3 \<le> D"
         then have "D \<le> dist a b" using H \<open>G \<subseteq> F\<close> by auto
         also have "... \<le> dist a x + dist x b" by (rule dist_triangle)
         also have "... \<le> D/3 + D/3"
           using * by (auto simp add: dist_commute intro: mono_intros)
         also have "... < D" using \<open>D > 0\<close> by auto
         finally show False by simp
       qed
 
       have "2 * R \<ge> 0" using \<open>R \<ge> 0\<close> by auto
       define A where "A = measure lborel (cball (0::'a) 1)"
       have "A > 0" unfolding A_def using lebesgue_measure_ball_pos by auto
       have "card G * ((D/3)^(DIM('a)) * A) = (\<Sum>x\<in>G. ((D/3)^(DIM('a)) * A))"
         by auto
       also have "... = (\<Sum>x\<in>G. measure lborel (cball x (D/3)))"
         unfolding lebesgue_measure_ball[OF \<open>D/3 \<ge> 0\<close>] A_def by auto
       also have "... = measure lborel (\<Union>x\<in>G. cball x (D/3))"
         apply (rule measure_finite_Union[symmetric, OF \<open>finite G\<close> _ \<open>disjoint_family_on (\<lambda>x. cball x (D/3)) G\<close>])
         apply auto using emeasure_bounded_finite less_imp_neq by auto
       also have "... \<le> measure lborel (cball (0::'a) (2*R))"
         apply (rule measure_mono_fmeasurable) using I \<open>finite G\<close> emeasure_bounded_finite
         unfolding fmeasurable_def by auto
       also have "... = (2*R)^(DIM('a)) * A"
         unfolding A_def using lebesgue_measure_ball[OF \<open>2*R \<ge> 0\<close>] by auto
       finally have "card G * (D/3)^(DIM('a)) \<le> (2*R)^(DIM('a))"
         using \<open>A > 0\<close> by (auto simp add: divide_simps)
       then have "card G \<le> C * R^(DIM('a))"
         unfolding C_def using \<open>D > 0\<close> apply (auto simp add: algebra_simps divide_simps)
         by (metis numeral_times_numeral power_mult_distrib semiring_norm(12) semiring_norm(14))
       then show ?thesis by auto
     qed
     then show "finite F \<and> card F \<le> 1 + C * R^(DIM('a))"
       by (rule finite_finite_subset_caract')
   qed
   then show ?thesis unfolding C_def by blast
 qed
 
 text \<open>Then, we show that the growth rate of a Euclidean space of dimension $d$ is bounded
 from below by $R^d$, using integer points.\<close>
 
 proposition growth_rate_euclidean_below:
   fixes D::real
   assumes "R \<ge> 0"
   shows "\<exists>F. (F \<subseteq> cball (0::'a::euclidean_space) R
             \<and> (\<forall>x\<in>F. \<forall>y\<in>F. x = y \<or> dist x y \<ge> D) \<and> finite F \<and> card F \<ge> (1/((max D 1) * DIM('a)))^(DIM('a)) * R^(DIM('a)))"
 proof -
   define E where "E = max D 1"
   have "E > 0" unfolding E_def by auto
   define c where "c = (1/(E * DIM('a)))^(DIM('a))"
   have "c > 0" unfolding c_def using \<open>E > 0\<close> by auto
 
   define n where "n = nat (floor (R/(E * DIM('a)))) + 1"
   then have "n > 0" using \<open>R \<ge> 0\<close> by auto
 
   have "R/(E * DIM('a)) \<le> n" unfolding n_def by linarith
   then have "c * R^(DIM('a)) \<le> n^(DIM('a))"
     unfolding c_def power_mult_distrib[symmetric] by (auto simp add: \<open>0 < E\<close> \<open>0 \<le> R\<close> less_imp_le power_mono)
   have "n-1 \<le> R/(E * DIM('a))"
     unfolding n_def using \<open>R \<ge> 0\<close> \<open>E > 0\<close> by auto
   then have "E * DIM('a) * (n-1) \<le> R"
     using \<open>R \<ge> 0\<close> \<open>E > 0\<close> by (simp add: mult.commute pos_le_divide_eq)
 
   text \<open>We want to consider the set of linear combinations of basis elements with integer
   coefficients bounded by $n$ (multiplied by $E$ to guarantee the $D$ separation).
   The formal way to write these elements is to consider all
   the functions from the basis to $\{0,\dotsc, n-1\}$, and associate to such a function
   $f$ the point $\sum E f(i) \cdot i$ where the sum is over all basis elements $i$. This is
   what the next definition does.\<close>
   define F::"'a set" where "F = (\<lambda>f. (\<Sum>i\<in>Basis. (E * real (f i)) *\<^sub>R i))`((Basis::('a set)) \<rightarrow>\<^sub>E {0..<n})"
 
   have "f = g" if "f \<in> (Basis::('a set)) \<rightarrow>\<^sub>E {0..<n}" "g \<in> Basis \<rightarrow>\<^sub>E {0..<n}"
                   "(\<Sum>i\<in>Basis. (E * real (f i)) *\<^sub>R i) = (\<Sum>i\<in>Basis. (E * real (g i)) *\<^sub>R i)" for f g
   proof (rule ext)
     fix i show "f i = g i"
     proof (cases "i \<in> Basis")
       case True
       then have "E * real(f i) = E * real(g i)"
         using inner_sum_left_Basis[OF True, of "\<lambda>i. E * real(f i)"] inner_sum_left_Basis[OF True, of "\<lambda>i. E * real(g i)"] that(3)
         by auto
       then show "f i = g i" using \<open>E > 0\<close> by auto
     next
       case False
       then have "f i = undefined" "g i = undefined" using that by auto
       then show "f i = g i" by auto
     qed
   qed
   then have "inj_on (\<lambda>f. (\<Sum>i\<in>Basis. (E * real (f i)) *\<^sub>R i)) ((Basis::('a set)) \<rightarrow>\<^sub>E {0..<n})"
     by (simp add: inj_onI)
   then have "card F = card ((Basis::('a set)) \<rightarrow>\<^sub>E {0..<n})" unfolding F_def
     using card_image by blast
   also have "... = n^(DIM('a))"
     unfolding card_PiE[OF finite_Basis] by (auto simp add: prod_constant)
   finally have "card F = n^(DIM('a))" by auto
   then have "finite F" using \<open>n > 0\<close>
     using card_infinite by force
   have "card F \<ge> c * R^(DIM('a))"
     using \<open>c * R^(DIM('a)) \<le> n^(DIM('a))\<close> \<open>card F = n^(DIM('a))\<close> by auto
 
   have separation: "dist x y \<ge> D" if "x \<in> F" "y \<in> F" "x \<noteq> y" for x y
   proof -
     obtain f where x: "f \<in> (Basis::('a set)) \<rightarrow>\<^sub>E {0..<n}" "x = (\<Sum>i\<in>Basis. (E * real (f i)) *\<^sub>R i)"
       using \<open>x \<in> F\<close> unfolding F_def by auto
     obtain g where y: "g \<in> (Basis::('a set)) \<rightarrow>\<^sub>E {0..<n}" "y = (\<Sum>i\<in>Basis. (E * real (g i)) *\<^sub>R i)"
       using \<open>y \<in> F\<close> unfolding F_def by auto
     obtain i where "f i \<noteq> g i" using x y \<open>x \<noteq>y\<close> by force
     moreover have "f j = g j" if "j \<notin> Basis" for j
       using x(1) y(1) that by fastforce
     ultimately have "i \<in> Basis" by auto
     have "D \<le> E" unfolding E_def by auto
     also have "... \<le> abs(E * (real (f i) - real (g i)))" using \<open>E > 0\<close>
       using \<open>f i \<noteq> g i\<close> by (auto simp add: divide_simps abs_mult)
     also have "... = abs(inner x i - inner y i)"
       unfolding x(2) y(2) inner_sum_left_Basis[OF \<open>i \<in> Basis\<close>] by (auto simp add: algebra_simps)
     also have "... = abs(inner (x-y) i)"
       by (simp add: inner_diff_left)
     also have "... \<le> norm (x-y)" using Basis_le_norm[OF \<open>i \<in> Basis\<close>] by blast
     finally show "dist x y \<ge> D" by (simp add: dist_norm)
   qed
 
   have "norm x \<le> R" if "x \<in> F" for x
   proof -
     obtain f where x: "f \<in> (Basis::('a set)) \<rightarrow>\<^sub>E {0..<n}" "x = (\<Sum>i\<in>Basis. (E * real (f i)) *\<^sub>R i)"
       using \<open>x \<in> F\<close> unfolding F_def by auto
     then have "norm x = norm (\<Sum>i\<in>Basis. (E * real (f i)) *\<^sub>R i)" by simp
     also have "... \<le> (\<Sum>i\<in>Basis. norm((E * real (f i)) *\<^sub>R i))"
       by (rule norm_sum)
     also have "... = (\<Sum>i\<in>Basis. abs(E * real (f i)))" by auto
     also have "... = (\<Sum>i\<in>Basis. E * real (f i))" using \<open>E > 0\<close> by auto
     also have "... \<le> (\<Sum>i\<in>(Basis::'a set). E * (n-1))"
       apply (rule sum_mono) using PiE_mem[OF x(1)] \<open>E > 0\<close> apply (auto simp add: divide_simps)
       using \<open>n > 0\<close> by fastforce
     also have "... = DIM('a) * E * (n-1)"
       by auto
     finally show "norm x \<le> R" using \<open>E * DIM('a) * (n-1) \<le> R\<close> by (auto simp add: algebra_simps)
   qed
   then have "F \<subseteq> cball 0 R" by auto
   then show ?thesis using \<open>card F \<ge> c * R^(DIM('a))\<close> \<open>finite F\<close> separation c_def E_def by blast
 qed
 
 text \<open>As the growth is invariant under quasi-isometries, we deduce that it is impossible
 to map quasi-isometrically a Euclidean space in a space of strictly smaller dimension.\<close>
 
 proposition quasi_isometry_on_euclidean:
   fixes f::"'a::euclidean_space\<Rightarrow>'b::euclidean_space"
   assumes "lambda C-quasi_isometry_on UNIV f"
   shows "DIM('a) \<le> DIM('b)"
 proof -
   have C: "lambda \<ge> 1" "C \<ge> 0" using quasi_isometry_onD[OF assms] by auto
   define D where "D = lambda * (C+1)"
   define Ca where "Ca = (1/((max D 1) * DIM('a)))^(DIM('a))"
   have "Ca > 0" unfolding Ca_def by auto
   have A: "\<And>R::real. R \<ge> 0 \<Longrightarrow> (\<exists>F. (F \<subseteq> cball (0::'a::euclidean_space) R
         \<and> (\<forall>x\<in>F. \<forall>y\<in>F. x = y \<or> dist x y \<ge> D) \<and> finite F \<and> card F \<ge> Ca * R^(DIM('a))))"
     using growth_rate_euclidean_below[of _ D] unfolding Ca_def by blast
   define Cb::real where "Cb = ((6/1)^(DIM('b)))"
   have B: "\<And>F (R::real). (F \<subseteq> cball (0::'b::euclidean_space) R \<Longrightarrow> R \<ge> 0 \<Longrightarrow> (\<forall>x\<in>F. \<forall>y\<in>F. x = y \<or> dist x y \<ge> 1) \<Longrightarrow> (finite F \<and> card F \<le> 1 + Cb * R^(DIM('b))))"
     using growth_rate_euclidean_above[of 1] unfolding Cb_def by fastforce
 
   have M: "Ca * R^(DIM('a)) \<le> 1 + Cb * (lambda * R + C + norm(f 0))^(DIM('b))" if "R \<ge> 0" for R::real
   proof -
     obtain F::"'a set" where F: "F \<subseteq> cball 0 R" "\<forall>x\<in>F. \<forall>y\<in>F. x = y \<or> dist x y \<ge> D"
                                 "finite F" "card F \<ge> Ca * R^(DIM('a))"
       using A[OF \<open>R \<ge> 0\<close>] by auto
     define G where "G = f`F"
     have *: "dist (f x) (f y) \<ge> 1" if "x \<noteq> y" "x \<in> F" "y \<in> F" for x y
     proof -
       have "dist x y \<ge> D" using that F(2) by auto
       have "1 = (1/lambda) * D - C" using \<open>lambda \<ge> 1\<close> unfolding D_def by auto
       also have "... \<le> (1/lambda) * dist x y - C"
         using \<open>dist x y \<ge> D\<close> \<open>lambda \<ge> 1\<close> by (auto simp add: divide_simps)
       also have "... \<le> dist (f x) (f y)"
         using quasi_isometry_onD[OF assms] by auto
       finally show ?thesis by simp
     qed
     then have "inj_on f F" unfolding inj_on_def by force
     then have "card G = card F" unfolding G_def by (simp add: card_image)
     then have "card G \<ge> Ca * R^(DIM('a))" using F by auto
 
     moreover have "finite G \<and> card G \<le> 1 + Cb * (lambda * R + C + norm(f 0))^(DIM('b))"
     proof (rule B)
       show "0 \<le> lambda * R + C + norm (f 0)" using \<open>R \<ge> 0\<close> \<open>C \<ge> 0\<close> \<open>lambda \<ge> 1\<close> by auto
       show "\<forall>x\<in>G. \<forall>y\<in>G. x = y \<or> 1 \<le> dist x y" using * unfolding G_def by (auto, metis)
       show "G \<subseteq> cball 0 (lambda * R + C + norm (f 0))"
       unfolding G_def proof (auto)
         fix x assume "x \<in> F"
         have "norm (f x) \<le> norm (f 0) + dist (f x) (f 0)"
           by (metis dist_0_norm dist_triangle2)
         also have "... \<le> norm (f 0) + (lambda * dist x 0 + C)"
           by (intro mono_intros quasi_isometry_onD(1)[OF assms]) auto
         also have "... \<le> norm (f 0) + lambda * R + C"
           using \<open>x \<in> F\<close> \<open>F \<subseteq> cball 0 R\<close> \<open>lambda \<ge> 1\<close> by auto
         finally show "norm (f x) \<le> lambda * R + C + norm (f 0)" by auto
       qed
     qed
     ultimately show "Ca * R^(DIM('a)) \<le> 1 + Cb * (lambda * R + C + norm(f 0))^(DIM('b))"
       by auto
   qed
   define CB where "CB = max Cb 0"
   have "CB \<ge> 0" "CB \<ge> Cb" unfolding CB_def by auto
   define D::real where "D = (1 + CB * (lambda + C + norm(f 0))^(DIM('b)))/Ca"
   have Rineq: "R^(DIM('a)) \<le> D * R^(DIM('b))" if "R \<ge> 1" for R::real
   proof -
     have "Ca * R^(DIM('a)) \<le> 1 + Cb * (lambda * R + C + norm(f 0))^(DIM('b))"
       using M \<open>R \<ge> 1\<close> by auto
     also have "... \<le> 1 + CB * (lambda * R + C + norm(f 0))^(DIM('b))"
       using \<open>CB \<ge> Cb\<close> \<open>lambda \<ge> 1\<close> \<open>R \<ge> 1\<close> \<open>C \<ge> 0\<close> by (auto intro!: mult_right_mono)
     also have "... \<le> R^(DIM('b)) + CB * (lambda * R + C * R + norm(f 0) * R)^(DIM('b))"
       using \<open>lambda \<ge> 1\<close> \<open>R \<ge> 1\<close> \<open>C \<ge> 0\<close> \<open>CB \<ge> 0\<close> by (auto intro!: mono_intros)
     also have "... = (1 + CB * (lambda + C + norm(f 0))^(DIM('b))) * R^(DIM('b))"
       by (auto simp add: algebra_simps power_mult_distrib[symmetric])
     finally show ?thesis
       using \<open>Ca > 0\<close> unfolding D_def by (auto simp add: divide_simps algebra_simps)
   qed
   show "DIM('a) \<le> DIM('b)"
   proof (rule ccontr)
     assume "\<not>(DIM('a) \<le> DIM('b))"
     then obtain n where "DIM('a) = DIM('b) + n" "n > 0"
       by (metis less_imp_add_positive not_le)
     have "D \<ge> 1" using Rineq[of 1] by auto
     define R where "R = 2 * D"
     then have "R \<ge> 1" using \<open>D \<ge> 1\<close> by auto
     have "R^n * R^(DIM('b)) = R^(DIM('a))"
       unfolding \<open>DIM('a) = DIM('b) + n\<close> by (auto simp add: power_add)
     also have "... \<le> D * R^(DIM('b))" using Rineq[OF \<open>R \<ge> 1\<close>] by auto
     finally have "R^n \<le> D" using \<open>R \<ge> 1\<close> by auto
     moreover have "2 * D \<le> R^n" unfolding R_def using \<open>D \<ge> 1\<close> \<open>n > 0\<close>
       by (metis One_nat_def Suc_leI \<open>1 \<le> R\<close> \<open>R \<equiv> 2 * D\<close> less_eq_real_def power_increasing_iff power_one power_one_right)
     ultimately show False using \<open>D \<ge> 1\<close> by auto
   qed
 qed
 
 text \<open>As a particular case, we deduce that two quasi-isometric Euclidean spaces have the
 same dimension.\<close>
 
 theorem quasi_isometric_euclidean:
   assumes "quasi_isometric (UNIV::'a::euclidean_space set) (UNIV::'b::euclidean_space set)"
   shows "DIM('a) = DIM('b)"
 proof -
   obtain lambda C and f::"'a \<Rightarrow>'b" where "lambda C-quasi_isometry_on UNIV f"
     using assms unfolding quasi_isometric_def quasi_isometry_between_def by auto
   then have *: "DIM('a) \<le> DIM('b)" using quasi_isometry_on_euclidean by auto
 
   have "quasi_isometric (UNIV::'b::euclidean_space set) (UNIV::'a::euclidean_space set)"
     using quasi_isometric_equiv_rel(3)[OF assms] by auto
   then obtain lambda C and f::"'b \<Rightarrow>'a" where "lambda C-quasi_isometry_on UNIV f"
     unfolding quasi_isometric_def quasi_isometry_between_def by auto
   then have "DIM('b) \<le> DIM('a)" using quasi_isometry_on_euclidean by auto
   then show ?thesis using * by auto
 qed
 
 text \<open>A different (and important) way to prove the above statement would be to use asymptotic
 cones. Here, it can be done in an elementary way: start with a quasi-isometric map $f$, and
 consider a limit (defined with a ultrafilter) of $x\mapsto f(n x)/n$. This is a map which
 contracts and expands the distances by at most $\lambda$. In particular, it is a homeomorphism
 on its image. No such map exists if the dimension of the target is smaller than the dimension
 of the source (invariance of domain theorem, already available in the library).
 
 The above argument using growth is more elementary to write, though.\<close>
 
 
 subsection \<open>Quasi-geodesics\<close>
 
 text \<open>A quasi-geodesic is a quasi-isometric embedding of a real segment into a metric space. As the
 embedding need not be continuous, a quasi-geodesic does not have to be compact, nor connected, which
 can be a problem. However, in a geodesic space, it is always possible to deform a quasi-geodesic
 into a continuous one (at the price of worsening the quasi-isometry constants). This is the content
 of the proposition \verb+quasi_geodesic_made_lipschitz+ below, which is a variation around Lemma
 III.H.1.11 in~\cite{bridson_haefliger}. The strategy of the proof is simple: assume that the
 quasi-geodesic $c$ is defined on $[a,b]$. Then, on the points $a$, $a+C/\lambda$, $\cdots$,
 $a+ N \cdot C/\lambda$, $b$, take $d$ equal to $c$, where $N$ is chosen so that the distance
 between the last point and $b$ is in $[C/\lambda, 2C/\lambda)$. In the intervals, take $d$ to
 be geodesic.\<close>
 
 proposition (in geodesic_space) quasi_geodesic_made_lipschitz:
   fixes c::"real \<Rightarrow> 'a"
   assumes "lambda C-quasi_isometry_on {a..b} c" "dist (c a) (c b) \<ge> 2 * C"
   shows "\<exists>d. continuous_on {a..b} d \<and> d a = c a \<and> d b = c b
               \<and> (\<forall>x\<in>{a..b}. dist (c x) (d x) \<le> 4 * C)
               \<and> lambda (4 * C)-quasi_isometry_on {a..b} d
               \<and> (2 * lambda)-lipschitz_on {a..b} d
               \<and> hausdorff_distance (c`{a..b}) (d`{a..b}) \<le> 2 * C"
 proof -
   consider "C = 0" | "C > 0 \<and> b \<le> a" | "C > 0 \<and> a < b \<and> b \<le> a + 2 * C/lambda" | "C > 0 \<and> a +2 * C/lambda < b"
     using quasi_isometry_onD(4)[OF assms(1)] by fastforce
   then show ?thesis
   proof (cases)
     text \<open>If the original function is Lipschitz, we can use it directly.\<close>
     case 1
     have "lambda-lipschitz_on {a..b} c"
       apply (rule lipschitz_onI) using 1 quasi_isometry_onD[OF assms(1)] by auto
     then have a: "(2 * lambda)-lipschitz_on {a..b} c"
       apply (rule lipschitz_on_mono) using quasi_isometry_onD[OF assms(1)] assms by (auto simp add: divide_simps)
     then have b: "continuous_on {a..b} c"
       using lipschitz_on_continuous_on by blast
     have "continuous_on {a..b} c \<and> c a = c a \<and> c b = c b
                 \<and> (\<forall>x\<in>{a..b}. dist (c x) (c x) \<le> 4 * C)
                 \<and> lambda (4 * C)-quasi_isometry_on {a..b} c
                 \<and> (2 * lambda)-lipschitz_on {a..b} c
                 \<and> hausdorff_distance (c`{a..b}) (c`{a..b}) \<le> 2 * C"
       using 1 a b assms(1) by auto
     then show ?thesis by blast
   next
     text \<open>If the original interval is empty, anything will do.\<close>
     case 2
     then have "b < a" using assms(2) less_eq_real_def by auto
     then have *: "{a..b} = {}" by auto
     have a: "(2 * lambda)-lipschitz_on {a..b} c"
       unfolding * apply (rule lipschitz_intros) using quasi_isometry_onD[OF assms(1)] assms by (auto simp add: divide_simps)
     then have b: "continuous_on {a..b} c"
       using lipschitz_on_continuous_on by blast
     have "continuous_on {a..b} c \<and> c a = c a \<and> c b = c b
                 \<and> (\<forall>x\<in>{a..b}. dist (c x) (c x) \<le> 4 * C)
                 \<and> lambda (4 * C)-quasi_isometry_on {a..b} c
                 \<and> (2 * lambda)-lipschitz_on {a..b} c
                 \<and> hausdorff_distance (c`{a..b}) (c`{a..b}) \<le> 2 * C"
       using a b quasi_isometry_on_empty assms(1) quasi_isometry_onD[OF assms(1)] * assms by auto
     then show ?thesis by blast
   next
     text \<open>If the original interval is short, we can use a direct geodesic interpolation between
     its endpoints\<close>
     case 3
     then have C: "C > 0" "lambda \<ge> 1" using quasi_isometry_onD[OF assms(1)] by auto
     have [mono_intros]: "1/lambda \<le> lambda" using C by (simp add: divide_simps mult_ge1_powers(1))
     have "a < b" using 3 by simp
     have "2 * C \<le> dist (c a) (c b)" using assms by auto
     also have "... \<le> lambda * dist a b + C"
       using quasi_isometry_onD[OF assms(1)] \<open>a < b\<close> by auto
     also have "... = lambda * (b-a) + C"
       using \<open>a < b\<close> dist_real_def by auto
     finally have *: "C \<le> (b-a) * lambda" by (auto simp add: algebra_simps)
     define d where "d = (\<lambda>x. geodesic_segment_param {(c a)--(c b)} (c a) ((dist (c a) (c b) /(b-a)) * (x-a)))"
     have dend: "d a = c a" "d b = c b" unfolding d_def using \<open>a < b\<close> by auto
 
     have Lip: "(2 * lambda)-lipschitz_on {a..b} d"
     proof -
       have "(1 * (((2 * lambda)) * (1+0)))-lipschitz_on {a..b} (\<lambda>x. geodesic_segment_param {(c a)--(c b)} (c a) ((dist (c a) (c b) /(b-a)) * (x-a)))"
       proof (rule lipschitz_on_compose2[of _ _ "\<lambda>x. ((dist (c a) (c b) /(b-a)) * (x-a))"], intro lipschitz_intros)
         have "(\<lambda>x. dist (c a) (c b) / (b-a) * (x - a)) ` {a..b} \<subseteq> {0..dist (c a) (c b)}"
           apply auto using \<open>a < b\<close> by (auto simp add: algebra_simps divide_simps intro: mult_right_mono)
         moreover have "1-lipschitz_on {0..dist (c a) (c b)} (geodesic_segment_param {c a--c b} (c a))"
           by (rule isometry_on_lipschitz, simp)
         ultimately show "1-lipschitz_on ((\<lambda>x. dist (c a) (c b) / (b-a) * (x - a)) ` {a..b}) (geodesic_segment_param {c a--c b} (c a))"
           using lipschitz_on_subset by auto
 
         have "dist (c a) (c b) \<le> lambda * dist a b + C"
           apply (rule quasi_isometry_onD(1)[OF assms(1)])
           using \<open>a < b\<close> by auto
         also have "... = lambda * (b - a) + C"
           unfolding dist_real_def using \<open>a < b\<close> by auto
         also have "... \<le> 2 * lambda * (b-a)"
           using * by (auto simp add: algebra_simps)
         finally show "\<bar>dist (c a) (c b) / (b - a)\<bar> \<le> 2 * lambda"
           using \<open>a < b\<close> by (auto simp add: divide_simps)
       qed
       then show ?thesis unfolding d_def by auto
     qed
     have dist_c_d: "dist (c x) (d x) \<le> 4 * C" if H: "x \<in> {a..b}" for x
     proof -
       have "(x-a) + (b - x) \<le> 2 * C/lambda"
         using that 3 by auto
       then consider "x-a \<le> C/lambda" | "b - x \<le> C/lambda" by linarith
       then have "\<exists>v\<in>{a,b}. dist x v \<le> C/lambda"
       proof (cases)
         case 1
         show ?thesis
           apply (rule bexI[of _ a]) using 1 H by (auto simp add: dist_real_def)
       next
         case 2
         show ?thesis
           apply (rule bexI[of _ b]) using 2 H by (auto simp add: dist_real_def)
       qed
       then obtain v where v: "v \<in> {a,b}" "dist x v \<le> C/lambda" by auto
       have "dist (c x) (d x) \<le> dist (c x) (c v) + dist (c v) (d v) + dist (d v) (d x)"
         by (intro mono_intros)
       also have "... \<le> (lambda * dist x v + C) + 0 + ((2 * lambda) * dist v x)"
         apply (intro mono_intros quasi_isometry_onD(1)[OF assms(1)] that lipschitz_onD[OF Lip])
         using v \<open>a < b\<close> dend by auto
       also have "... \<le> (lambda * (C/lambda) + C) + 0 + ((2 * lambda) * (C/lambda))"
         apply (intro mono_intros) using C v by (auto simp add: metric_space_class.dist_commute)
       finally show ?thesis
         using C by (auto simp add: algebra_simps divide_simps)
     qed
     text \<open>A similar argument shows that the Hausdorff distance between the images is bounded by $2C$.\<close>
     have "hausdorff_distance (c`{a..b}) (d`{a..b}) \<le> 2 * C"
     proof (rule hausdorff_distanceI2)
       show "0 \<le> 2 * C" using C by auto
       fix z assume "z \<in> c`{a..b}"
       then obtain x where x: "x \<in> {a..b}" "z = c x" by auto
       have "(x-a) + (b - x) \<le> 2 * C/lambda"
         using x 3 by auto
       then consider "x-a \<le> C/lambda" | "b - x \<le> C/lambda" by linarith
       then have "\<exists>v\<in>{a,b}. dist x v \<le> C/lambda"
       proof (cases)
         case 1
         show ?thesis
           apply (rule bexI[of _ a]) using 1 x by (auto simp add: dist_real_def)
       next
         case 2
         show ?thesis
           apply (rule bexI[of _ b]) using 2 x by (auto simp add: dist_real_def)
       qed
       then obtain v where v: "v \<in> {a,b}" "dist x v \<le> C/lambda" by auto
       have "dist z (d v) = dist (c x) (c v)" unfolding x(2) using v dend by auto
       also have "... \<le> lambda * dist x v + C"
         apply (rule quasi_isometry_onD(1)[OF assms(1)]) using v(1) x(1) by auto
       also have "... \<le> lambda * (C/lambda) + C"
         apply (intro mono_intros) using C v(2) by auto
       also have "... = 2 * C"
         using C by (simp add: divide_simps)
       finally have *: "dist z (d v) \<le> 2 * C" by simp
       show "\<exists>y\<in>d ` {a..b}. dist z y \<le> 2 * C"
         apply (rule bexI[of _ "d v"]) using * v(1) \<open>a < b\<close> by auto
     next
       fix z assume "z \<in> d`{a..b}"
       then obtain x where x: "x \<in> {a..b}" "z = d x" by auto
       have "(x-a) + (b - x) \<le> 2 * C/lambda"
         using x 3 by auto
       then consider "x-a \<le> C/lambda" | "b - x \<le> C/lambda" by linarith
       then have "\<exists>v\<in>{a,b}. dist x v \<le> C/lambda"
       proof (cases)
         case 1
         show ?thesis
           apply (rule bexI[of _ a]) using 1 x by (auto simp add: dist_real_def)
       next
         case 2
         show ?thesis
           apply (rule bexI[of _ b]) using 2 x by (auto simp add: dist_real_def)
       qed
       then obtain v where v: "v \<in> {a,b}" "dist x v \<le> C/lambda" by auto
       have "dist z (c v) = dist (d x) (d v)" unfolding x(2) using v dend by auto
       also have "... \<le> 2 * lambda * dist x v"
         apply (rule lipschitz_onD(1)[OF Lip]) using v(1) x(1) by auto
       also have "... \<le> 2 * lambda * (C/lambda)"
         apply (intro mono_intros) using C v(2) by auto
       also have "... = 2 * C"
         using C by (simp add: divide_simps)
       finally have *: "dist z (c v) \<le> 2 * C" by simp
       show "\<exists>y\<in>c`{a..b}. dist z y \<le> 2 * C"
         apply (rule bexI[of _ "c v"]) using * v(1) \<open>a < b\<close> by auto
     qed
     have "lambda (4 * C)-quasi_isometry_on {a..b} d"
     proof
       show "1 \<le> lambda" using C by auto
       show "0 \<le> 4 * C" using C by auto
       show "dist (d x) (d y) \<le> lambda * dist x y + 4 * C" if "x \<in> {a..b}" "y \<in> {a..b}" for x y
       proof -
         have "dist (d x) (d y) \<le> 2 * lambda * dist x y"
           apply (rule lipschitz_onD[OF Lip]) using that by auto
         also have "... = lambda * dist x y + lambda * dist x y"
           by auto
         also have "... \<le> lambda * dist x y + lambda * (2 * C/lambda)"
           apply (intro mono_intros) using 3 that C unfolding dist_real_def by auto
         also have "... = lambda * dist x y + 2 * C"
           using C by (simp add: algebra_simps divide_simps)
         finally show ?thesis using C by auto
       qed
       show "1 / lambda * dist x y - 4 * C \<le> dist (d x) (d y)" if "x \<in> {a..b}" "y \<in> {a..b}" for x y
       proof -
         have "1/lambda * dist x y - 4 * C \<le> lambda * dist x y - 2 * C"
           apply (intro mono_intros) using C by auto
         also have "... \<le> lambda * (2 * C/lambda) - 2 * C"
           apply (intro mono_intros) using that 3 C unfolding dist_real_def by auto
         also have "... = 0"
           using C by (auto simp add: algebra_simps divide_simps)
         also have "... \<le> dist (d x) (d y)" by auto
         finally show ?thesis by simp
       qed
     qed
 
     then have "continuous_on {a..b} d \<and> d a = c a \<and> d b = c b
           \<and> lambda (4 * C)-quasi_isometry_on {a..b} d
           \<and> (\<forall>x\<in>{a..b}. dist (c x) (d x) \<le> 4 *C)
           \<and> (2*lambda)-lipschitz_on {a..b} d
           \<and> hausdorff_distance (c`{a..b}) (d`{a..b}) \<le> 2 * C"
       using dist_c_d \<open>d a = c a\<close> \<open>d b = c b\<close> \<open>(2*lambda)-lipschitz_on {a..b} d\<close>
             \<open>hausdorff_distance (c`{a..b}) (d`{a..b}) \<le> 2 * C\<close> lipschitz_on_continuous_on by auto
     then show ?thesis by auto
   next
     text \<open>Now, for the only nontrivial case, we use geodesic interpolation between the points
     $a$, $a + C/\lambda$, $\cdots$, $a+N\cdot C/\lambda$, $b'$, $b$ where $N$ is chosen so that
     the distance between $a+N C/\lambda$ and $b$ belongs to $[2C/\lambda, 3C/\lambda)$, and
     $b'$ is the middle of this interval. This gives a decomposition into intervals of length
     at most $3/2\cdot C/\lambda$.\<close>
     case 4
     then have C: "C > 0" "lambda \<ge> 1" using quasi_isometry_onD[OF assms(1)] by auto
     have "a < b" using 4 C by (smt divide_pos_pos)
 
     have [mono_intros]: "1/lambda \<le> lambda" using C by (simp add: divide_simps mult_ge1_powers(1))
     define N where "N = floor((b-a)/(C/lambda)) - 2"
     have N: "N \<le> (b-a)/(C/lambda)-2" "(b-a)/(C/lambda) \<le> N + (3::real)"
       unfolding N_def by linarith+
 
     have "2 < (b-a)/(C/lambda)"
       using C 4 by (auto simp add: divide_simps algebra_simps)
     then have N0 : "0 \<le> N" unfolding N_def by auto
     define p where "p = (\<lambda>t::int. a + (C/lambda) * t)"
     have pmono: "p i \<le> p j" if "i \<le> j" for i j
       unfolding p_def using that C by (auto simp add: algebra_simps divide_simps)
     have pmono': "p i < p j" if "i < j" for i j
       unfolding p_def using that C by (auto simp add: algebra_simps divide_simps)
     have "p (N+1) \<le> b"
       unfolding p_def using C N by (auto simp add: algebra_simps divide_simps)
     then have pb: "p i \<le> b" if "i \<in> {0..N}" for i
       using that pmono by (meson atLeastAtMost_iff linear not_le order_trans zle_add1_eq_le)
     have bpN: "b - p N \<in> {2 * C/lambda .. 3 * C/lambda}"
       unfolding p_def using C N apply (auto simp add: divide_simps)
       by (auto simp add: algebra_simps)
     have "p N < b" using pmono'[of N "N+1"] \<open>p (N+1) \<le> b\<close> by auto
     define b' where "b' = (b + p N)/2"
     have b': "p N < b'" "b' < b" using \<open>p N < b\<close> unfolding b'_def by auto
     have pb': "p i \<le> b'" if "i \<in> {0..N}" for i
       using pmono[of i N] b' that by auto
 
     text \<open>Introduce the set $A$ along which one will discretize.\<close>
     define A where "A = p`{0..N} \<union> {b', b}"
     have "finite A" unfolding A_def by auto
     have "b \<in> A" unfolding A_def by auto
     have "p 0 \<in> A" unfolding A_def using \<open>0 \<le> N\<close> by auto
     moreover have pa: "p 0 = a" unfolding p_def by auto
     ultimately have "a \<in> A" by auto
     have "A \<subseteq> {a..b}"
       unfolding A_def using \<open>a < b\<close> b' pa pb pmono N0 by fastforce
     then have "b' \<in> {a..<b}" unfolding A_def using \<open>b' < b\<close> by auto
 
     have A : "finite A" "A \<subseteq> {a..b}" "a \<in> A" "b \<in> A" "a < b" by fact+
 
     have nx: "next_in A x = x + C/lambda" if "x \<in> A" "x \<noteq> b" "x \<noteq> b'" "x \<noteq> p N" for x
     proof (rule next_inI[OF A])
       show "x \<in> {a..<b}" using \<open>x \<in> A\<close> \<open>A \<subseteq> {a..b}\<close> \<open>x \<noteq> b\<close> by auto
       obtain i where i: "x = p i" "i \<in> {0..N}"
         using \<open>x \<in> A\<close> \<open>x \<noteq> b\<close> \<open>x \<noteq> b'\<close> unfolding A_def by auto
       have *: "p (i+1) = x + C/lambda" unfolding i(1) p_def by (auto simp add: algebra_simps)
       have "i \<noteq> N" using that i by auto
       then have "i + 1 \<in> {0..N}" using \<open>i \<in> {0..N}\<close> by auto
       then have "p (i+1) \<in> A" unfolding A_def by fastforce
       then show "x + C/lambda \<in> A" unfolding * by auto
       show "x < x + C / lambda" using C by auto
       show "{x<..<x + C / lambda} \<inter> A = {}"
       proof (auto)
         fix y assume y: "y \<in> A" "x < y" "y < x + C/lambda"
         consider "y = b" | "y = b'" | "\<exists>j\<le>i. y = p j" | "\<exists>j>i. y = p j"
           using \<open>y \<in> A\<close> not_less unfolding A_def by auto
         then show False
         proof (cases)
           case 1
           have "x + C/lambda \<le> b" unfolding *[symmetric] using \<open>i + 1 \<in> {0..N}\<close> pb by auto
           then show False using y(3) unfolding 1 i(1) by auto
         next
           case 2
           have "x + C/lambda \<le> b'" unfolding *[symmetric] using \<open>i + 1 \<in> {0..N}\<close> pb' by auto
           then show False using y(3) unfolding 2 i(1) by auto
         next
           case 3
           then obtain j where j: "j \<le> i" "y = p j" by auto
           have "y \<le> x" unfolding j(2) i(1) using pmono[OF \<open>j \<le> i\<close>] by simp
           then show False using \<open>x < y\<close> by auto
         next
           case 4
           then obtain j where j: "j > i" "y = p j" by auto
           then have "i+1 \<le> j" by auto
           have "x + C/lambda \<le> y" unfolding j(2) *[symmetric] using pmono[OF \<open>i+1 \<le> j\<close>] by auto
           then show False using \<open>y < x + C/lambda\<close> by auto
         qed
       qed
     qed
     have npN: "next_in A (p N) = b'"
     proof (rule next_inI[OF A])
       show "p N \<in> {a..<b}" using pa pmono \<open>0 \<le> N\<close> \<open>p N < b\<close> by auto
       show "p N < b'" by fact
       show "b' \<in> A" unfolding A_def by auto
       show "{p N<..<b'} \<inter> A = {}"
         unfolding A_def using pmono b' by force
     qed
     have nb': "next_in A (b') = b"
     proof (rule next_inI[OF A])
       show "b' \<in> {a..<b}" using A_def A \<open>b' < b\<close> by auto
       show "b' < b" by fact
       show "b \<in> A" by fact
       show "{b'<..<b} \<inter> A = {}"
         unfolding A_def using pmono b' by force
     qed
     have gap: "next_in A x - x \<in> {C/lambda.. 3/2 * C/lambda}" if "x \<in> A - {b}" for x
     proof (cases "x = p N \<or> x = b'")
       case True
       then show ?thesis using npN nb' bpN b'_def by force
     next
       case False
       have *: "next_in A x = x + C/lambda"
         apply (rule nx) using that False by auto
       show ?thesis unfolding * using C by (auto simp add: algebra_simps divide_simps)
     qed
 
     text \<open>We can now define the function $d$, by geodesic interpolation between points in $A$.\<close>
     define d where "d x = (if x \<in> A then c x
         else geodesic_segment_param {c (prev_in A x) -- c (next_in A x)} (c (prev_in A x))
             ((x - prev_in A x)/(next_in A x - prev_in A x) * dist (c(prev_in A x)) (c(next_in A x))))" for x
     have "d a = c a" "d b = c b" unfolding d_def using \<open>a \<in> A\<close> \<open>b \<in> A\<close> by auto
 
     text \<open>To prove the Lipschitz continuity, we argue that $d$ is Lipschitz on finitely many intervals,
     that cover the interval $[a,b]$, the intervals between points in $A$.
     There is a formula for $d$ on them (the nontrivial point is that the above formulas for $d$
     match at the boundaries).\<close>
 
     have *: "d x = geodesic_segment_param {(c u)--(c v)} (c u) ((dist (c u) (c v) /(v-u)) * (x-u))"
       if "u \<in> A - {b}" "v = next_in A u" "x \<in> {u..v}" for x u v
     proof -
       have "u \<in> {a..<b}" using that \<open>A \<subseteq> {a..b}\<close> by fastforce
       have H: "u \<in> A" "v \<in> A" "u < v" "A \<inter> {u<..<v} = {}" using that next_in_basics[OF A \<open>u \<in> {a..<b}\<close>] by auto
       consider "x = u" | "x = v" | "x \<in> {u<..<v}" using \<open>x \<in> {u..v}\<close> by fastforce
       then show ?thesis
       proof (cases)
         case 1
         then have "d x = c u" unfolding d_def using \<open>u \<in> A- {b}\<close> \<open>A \<subseteq> {a..b}\<close> by auto
         then show ?thesis unfolding 1 by auto
       next
         case 2
         then have "d x = c v" unfolding d_def using \<open>v \<in> A\<close> \<open>A \<subseteq> {a..b}\<close> by auto
         then show ?thesis unfolding 2 using \<open>u < v\<close> by auto
       next
         case 3
         have *: "prev_in A x = u"
           apply (rule prev_inI[OF A]) using 3 H \<open>A \<subseteq> {a..b}\<close> by auto
         have **: "next_in A x = v"
           apply (rule next_inI[OF A]) using 3 H \<open>A \<subseteq> {a..b}\<close> by auto
         show ?thesis unfolding d_def * ** using 3 H \<open>A \<inter> {u<..<v} = {}\<close> \<open>A \<subseteq> {a..b}\<close>
           by (auto simp add: algebra_simps)
       qed
     qed
 
     text \<open>From the above formula, we deduce that $d$ is Lipschitz on those intervals.\<close>
     have lip0: "(lambda + C / (next_in A u - u))-lipschitz_on {u..next_in A u} d" if "u \<in> A - {b}" for u
     proof -
       define v where "v = next_in A u"
       have "u \<in> {a..<b}" using that \<open>A \<subseteq> {a..b}\<close> by fastforce
       have "u \<in> A" "v \<in> A" "u < v" "A \<inter> {u<..<v} = {}"
         unfolding v_def using that next_in_basics[OF A \<open>u \<in> {a..<b}\<close>] by auto
 
       have "(1 * (((lambda + C / (next_in A u - u))) * (1+0)))-lipschitz_on {u..v} (\<lambda>x. geodesic_segment_param {(c u)--(c v)} (c u) ((dist (c u) (c v) /(v-u)) * (x-u)))"
       proof (rule lipschitz_on_compose2[of _ _ "\<lambda>x. ((dist (c u) (c v) /(v-u)) * (x-u))"], intro lipschitz_intros)
         have "(\<lambda>x. dist (c u) (c v) / (v - u) * (x - u)) ` {u..v} \<subseteq> {0..dist (c u) (c v)}"
           apply auto using \<open>u < v\<close> by (auto simp add: algebra_simps divide_simps intro: mult_right_mono)
         moreover have "1-lipschitz_on {0..dist (c u) (c v)} (geodesic_segment_param {c u--c v} (c u))"
           by (rule isometry_on_lipschitz, simp)
         ultimately show "1-lipschitz_on ((\<lambda>x. dist (c u) (c v) / (v - u) * (x - u)) ` {u..v}) (geodesic_segment_param {c u--c v} (c u))"
           using lipschitz_on_subset by auto
 
         have "dist (c u) (c v) \<le> lambda * dist u v + C"
           apply (rule quasi_isometry_onD(1)[OF assms(1)])
           using \<open>u \<in> A\<close> \<open>v \<in> A\<close> \<open>A \<subseteq> {a..b}\<close> by auto
         also have "... = lambda * (v - u) + C"
           unfolding dist_real_def using \<open>u < v\<close> by auto
         finally show "\<bar>dist (c u) (c v) / (v - u)\<bar> \<le> lambda + C / (next_in A u - u)"
           using \<open>u < v\<close> unfolding v_def by (auto simp add: divide_simps)
       qed
       then show ?thesis
         using *[OF \<open>u \<in> A -{b}\<close> \<open>v = next_in A u\<close>] unfolding v_def
         by (auto intro: lipschitz_on_transform)
     qed
     have lip: "(2 * lambda)-lipschitz_on {u..next_in A u} d" if "u \<in> A - {b}" for u
     proof (rule lipschitz_on_mono[OF lip0[OF that]], auto)
       define v where "v = next_in A u"
       have "u \<in> {a..<b}" using that \<open>A \<subseteq> {a..b}\<close> by fastforce
       have "u \<in> A" "v \<in> A" "u < v" "A \<inter> {u<..<v} = {}"
         unfolding v_def using that next_in_basics[OF A \<open>u \<in> {a..<b}\<close>] by auto
       have Duv: "v - u \<in> {C/lambda .. 2 * C/lambda}"
         unfolding v_def using gap[OF \<open>u \<in> A - {b}\<close>] by simp
       then show " C / (next_in A u - u) \<le> lambda"
         using \<open>u < v\<close> C unfolding v_def by (auto simp add: algebra_simps divide_simps)
     qed
 
     text \<open>The Lipschitz continuity of $d$ now follows from its Lipschitz continuity on each
     subinterval in $I$.\<close>
     have Lip: "(2 * lambda)-lipschitz_on {a..b} d"
       apply (rule lipschitz_on_closed_Union[of "{{u..next_in A u} |u. u \<in> A - {b}}" _ "\<lambda>x. x"])
       using lip \<open>finite A\<close> C intervals_decomposition[OF A] using assms by auto
     then have "continuous_on {a..b} d"
       using lipschitz_on_continuous_on by auto
 
     text \<open>$d$ has good upper controls on each basic interval.\<close>
     have QI0: "dist (d x) (d y) \<le> lambda * dist x y + C"
       if H: "u \<in> A - {b}" "x \<in> {u..next_in A u}" "y \<in> {u..next_in A u}" for u x y
     proof -
       have "u < next_in A u" using H(1) A next_in_basics(2)[OF A] by auto
       moreover have "dist x y \<le> next_in A u - u" unfolding dist_real_def using H by auto
       ultimately have *: "dist x y / (next_in A u - u) \<le> 1" by (simp add: divide_simps)
       have "dist (d x) (d y) \<le> (lambda + C / (next_in A u - u)) * dist x y"
         by (rule lipschitz_onD[OF lip0[OF H(1)] H(2) H(3)])
       also have "... = lambda * dist x y + C * (dist x y / (next_in A u - u))"
         by (simp add: algebra_simps)
       also have "... \<le> lambda * dist x y + C * 1"
         apply (intro mono_intros) using C * by auto
       finally show ?thesis by simp
     qed
 
     text \<open>We can now show that $c$ and $d$ are pointwise close. This follows from the fact that they
     coincide on $A$ and are well controlled in between (for $c$, this is a consequence of the choice
     of $A$. For $d$, it follows from the fact that it is geodesic in the intervals).\<close>
 
     have dist_c_d: "dist (c x) (d x) \<le> 4 * C" if "x \<in> {a..b}" for x
     proof -
       obtain u where u: "u \<in> A - {b}" "x \<in> {u..next_in A u}"
         using \<open>x \<in> {a..b}\<close> intervals_decomposition[OF A] by blast
       have "(x-u) + (next_in A u - x) \<le> 2 * C/lambda"
         using gap[OF u(1)] by auto
       then consider "x-u \<le> C/lambda" | "next_in A u - x \<le> C/lambda" by linarith
       then have "\<exists>v\<in>A. dist x v \<le> C/lambda"
       proof (cases)
         case 1
         show ?thesis
           apply (rule bexI[of _ u]) using 1 u by (auto simp add: dist_real_def)
       next
         case 2
         show ?thesis
           apply (rule bexI[of _ "next_in A u"]) using 2 u A(2)
           by (auto simp add: dist_real_def intro!:next_in_basics[OF A])
       qed
       then obtain v where v: "v \<in> A" "dist x v \<le> C/lambda" by auto
       have "dist (c x) (d x) \<le> dist (c x) (c v) + dist (c v) (d v) + dist (d v) (d x)"
         by (intro mono_intros)
       also have "... \<le> (lambda * dist x v + C) + 0 + ((2 * lambda) * dist v x)"
         apply (intro mono_intros quasi_isometry_onD(1)[OF assms(1)] that lipschitz_onD[OF Lip])
         using A(2) \<open>v \<in> A\<close> apply blast
         using \<open>v \<in> A\<close> d_def apply auto[1]
         using A(2) \<open>v \<in> A\<close> by blast
       also have "... \<le> (lambda * (C/lambda) + C) + 0 + ((2 * lambda) * (C/lambda))"
         apply (intro mono_intros) using v(2) C by (auto simp add: metric_space_class.dist_commute)
       finally show ?thesis
         using C by (auto simp add: algebra_simps divide_simps)
     qed
     text \<open>A similar argument shows that the Hausdorff distance between the images is bounded by $2C$.\<close>
     have "hausdorff_distance (c`{a..b}) (d`{a..b}) \<le> 2 * C"
     proof (rule hausdorff_distanceI2)
       show "0 \<le> 2 * C" using C by auto
       fix z assume "z \<in> c`{a..b}"
       then obtain x where x: "x \<in> {a..b}" "z = c x" by auto
       then obtain u where u: "u \<in> A - {b}" "x \<in> {u..next_in A u}"
         using intervals_decomposition[OF A] by blast
       have "(x-u) + (next_in A u - x) \<le> 2 * C/lambda"
         using gap[OF u(1)] by auto
       then consider "x-u \<le> C/lambda" | "next_in A u - x \<le> C/lambda" by linarith
       then have "\<exists>v\<in>A. dist x v \<le> C/lambda"
       proof (cases)
         case 1
         show ?thesis
           apply (rule bexI[of _ u]) using 1 u by (auto simp add: dist_real_def)
       next
         case 2
         show ?thesis
           apply (rule bexI[of _ "next_in A u"]) using 2 u A(2)
           by (auto simp add: dist_real_def intro!:next_in_basics[OF A])
       qed
       then obtain v where v: "v \<in> A" "dist x v \<le> C/lambda" by auto
       have "dist z (d v) = dist (c x) (c v)" unfolding x(2) d_def using \<open>v \<in> A\<close> by auto
       also have "... \<le> lambda * dist x v + C"
         apply (rule quasi_isometry_onD(1)[OF assms(1)]) using v(1) A(2) x(1) by auto
       also have "... \<le> lambda * (C/lambda) + C"
         apply (intro mono_intros) using C v(2) by auto
       also have "... = 2 * C"
         using C by (simp add: divide_simps)
       finally have *: "dist z (d v) \<le> 2 * C" by simp
       show "\<exists>y\<in>d ` {a..b}. dist z y \<le> 2 * C"
         apply (rule bexI[of _ "d v"]) using * v(1) A(2) by auto
     next
       fix z assume "z \<in> d`{a..b}"
       then obtain x where x: "x \<in> {a..b}" "z = d x" by auto
       then obtain u where u: "u \<in> A - {b}" "x \<in> {u..next_in A u}"
         using intervals_decomposition[OF A] by blast
       have "(x-u) + (next_in A u - x) \<le> 2 * C/lambda"
         using gap[OF u(1)] by auto
       then consider "x-u \<le> C/lambda" | "next_in A u - x \<le> C/lambda" by linarith
       then have "\<exists>v\<in>A. dist x v \<le> C/lambda"
       proof (cases)
         case 1
         show ?thesis
           apply (rule bexI[of _ u]) using 1 u by (auto simp add: dist_real_def)
       next
         case 2
         show ?thesis
           apply (rule bexI[of _ "next_in A u"]) using 2 u A(2)
           by (auto simp add: dist_real_def intro!:next_in_basics[OF A])
       qed
       then obtain v where v: "v \<in> A" "dist x v \<le> C/lambda" by auto
       have "dist z (c v) = dist (d x) (d v)" unfolding x(2) d_def using \<open>v \<in> A\<close> by auto
       also have "... \<le> 2 * lambda * dist x v"
         apply (rule lipschitz_onD(1)[OF Lip]) using v(1) A(2) x(1) by auto
       also have "... \<le> 2 * lambda * (C/lambda)"
         apply (intro mono_intros) using C v(2) by auto
       also have "... = 2 * C"
         using C by (simp add: divide_simps)
       finally have *: "dist z (c v) \<le> 2 * C" by simp
       show "\<exists>y\<in>c`{a..b}. dist z y \<le> 2 * C"
         apply (rule bexI[of _ "c v"]) using * v(1) A(2) by auto
     qed
 
     text \<open>From the above controls, we check that $d$ is a quasi-isometry, with explicit constants.\<close>
     have "lambda (4 * C)-quasi_isometry_on {a..b} d"
     proof
       show "1 \<le> lambda" using C by auto
       show "0 \<le> 4 * C" using C by auto
       have I : "dist (d x) (d y) \<le> lambda * dist x y + 4 * C" if H: "x \<in> {a..b}" "y \<in> {a..b}" "x < y" for x y
       proof -
         obtain u where u: "u \<in> A - {b}" "x \<in> {u..next_in A u}"
           using intervals_decomposition[OF A] H(1) by force
         have "u \<in> {a..<b}" using u(1) A by auto
         have "next_in A u \<in> A" using next_in_basics(1)[OF A \<open>u \<in> {a..<b}\<close>] by auto
         obtain v where v: "v \<in> A - {b}" "y \<in> {v..next_in A v}"
           using intervals_decomposition[OF A] H(2) by force
         have "v \<in> {a..<b}" using v(1) A by auto
         have "u < next_in A v" using H(3) u(2) v(2) by auto
         then have "u \<le> v"
           using u(1) next_in_basics(3)[OF A, OF \<open>v \<in> {a..<b}\<close>] by auto
         show ?thesis
         proof (cases "u = v")
           case True
           have "dist (d x) (d y) \<le> lambda * dist x y + C"
             apply (rule QI0[OF u]) using v(2) True by auto
           also have "... \<le> lambda * dist x y + 4 * C"
             using C by auto
           finally show ?thesis by simp
         next
           case False
           then have "u < v" using \<open>u \<le> v\<close> by auto
           then have "next_in A u \<le> v" using v(1) next_in_basics(3)[OF A, OF \<open>u \<in> {a..<b}\<close>] by auto
           have d1: "d (next_in A u) = c (next_in A u)"
             using \<open>next_in A u \<in> A\<close> unfolding d_def by auto
           have d2: "d v = c v"
             using v(1) unfolding d_def by auto
           have "dist (d x) (d y) \<le> dist (d x) (d (next_in A u)) + dist (d (next_in A u)) (d v) + dist (d v) (d y)"
             by (intro mono_intros)
           also have "... \<le> (lambda * dist x (next_in A u) + C) + (lambda * dist (next_in A u) v + C)
                             + (lambda * dist v y + C)"
             apply (intro mono_intros)
               apply (rule QI0[OF u]) using u(2) apply simp
              apply (simp add: d1 d2) apply (rule quasi_isometry_onD(1)[OF assms(1)])
             using \<open>next_in A u \<in> A\<close> \<open>A \<subseteq> {a..b}\<close> apply auto[1]
             using \<open>v \<in> A - {b}\<close> \<open>A \<subseteq> {a..b}\<close> apply auto[1]
             apply (rule QI0[OF v(1)]) using v(2) by auto
           also have "... = lambda * dist x y + 3 * C"
             unfolding dist_real_def
             using \<open>x \<in> {u..next_in A u}\<close> \<open>y \<in> {v..next_in A v}\<close> \<open>x < y\<close> \<open>next_in A u \<le> v\<close>
             by (auto simp add: algebra_simps)
           finally show ?thesis using C by simp
         qed
       qed
       show "dist (d x) (d y) \<le> lambda * dist x y + 4 * C" if H: "x \<in> {a..b}" "y \<in> {a..b}" for x y
       proof -
         consider "x < y" | "x = y" | "x > y" by linarith
         then show ?thesis
         proof (cases)
           case 1
           then show ?thesis using I[OF H(1) H(2) 1] by simp
         next
           case 2
           show ?thesis unfolding 2 using C by auto
         next
           case 3
           show ?thesis using I [OF H(2) H(1) 3] by (simp add: metric_space_class.dist_commute)
         qed
       qed
       text \<open>The lower bound is more tricky. We separate the case where $x$ and $y$ are in the same
       interval, when they are in different nearby intervals, and when they are in different
       separated intervals. The latter case is more difficult. In this case, one of the intervals
       has length $C/\lambda$ and the other one has length at most $3/2\cdot C/\lambda$. There,
       we approximate $dist (d x) (d y)$ by $dist (d u') (d v')$ where $u'$ and $v'$ are suitable
       endpoints of the intervals containing respectively $x$ and $y$. We use the inner endpoint
       (between $x$ and $y$) if the distance between $x$ or $y$ and this point is less than $2/5$
       of the length of the interval, and the outer endpoint otherwise. The reason is that, with
       the outer endpoints, we get right away an upper bound for the distance between $x$ and $y$,
       while this is not the case with the inner endpoints where there is an additional error.
       The equilibrium is reached at proportion $2/5$. \<close>
       have J : "dist (d x) (d y) \<ge> (1/lambda) * dist x y - 4 * C" if H: "x \<in> {a..b}" "y \<in> {a..b}" "x < y" for x y
       proof -
         obtain u where u: "u \<in> A - {b}" "x \<in> {u..next_in A u}"
           using intervals_decomposition[OF A] H(1) by force
         have "u \<in> {a..<b}" using u(1) A by auto
         have "next_in A u \<in> A" using next_in_basics(1)[OF A \<open>u \<in> {a..<b}\<close>] by auto
         obtain v where v: "v \<in> A - {b}" "y \<in> {v..next_in A v}"
           using intervals_decomposition[OF A] H(2) by force
         have "v \<in> {a..<b}" using v(1) A by auto
         have "next_in A v \<in> A" using next_in_basics(1)[OF A \<open>v \<in> {a..<b}\<close>] by auto
         have "u < next_in A v" using H(3) u(2) v(2) by auto
         then have "u \<le> v"
           using u(1) next_in_basics(3)[OF A, OF \<open>v \<in> {a..<b}\<close>] by auto
         consider "v = u" | "v = next_in A u" | "v \<noteq> u \<and> v \<noteq> next_in A u" by auto
         then show ?thesis
         proof (cases)
           case 1
           have "(1/lambda) * dist x y - 4 * C \<le> lambda * dist x y - 4 * C"
             apply (intro mono_intros) by auto
           also have "... \<le> lambda * (3/2 * C/lambda) - 3/2 * C"
             apply (intro mono_intros)
             using u(2) v(2) unfolding 1 using C gap[OF u(1)] dist_real_def \<open>x < y\<close> by auto
           also have "... = 0"
             using C by auto
           also have "... \<le> dist (d x) (d y)"
             by auto
           finally show ?thesis by simp
         next
           case 2
           have "dist x y \<le> dist x (next_in A u) + dist v y"
             unfolding 2 by (intro mono_intros)
           also have "... \<le> 3/2 * C/lambda + 3/2 * C/lambda"
             apply (intro mono_intros)
             unfolding dist_real_def using u(2) v(2) gap[OF u(1)] gap[OF v(1)] by auto
           finally have *: "dist x y \<le> 3 * C/lambda" by auto
           have "(1/lambda) * dist x y - 4 * C \<le> lambda * dist x y - 4 * C"
             apply (intro mono_intros) by auto
           also have "... \<le> lambda * (3 * C/lambda) - 3 * C"
             apply (intro mono_intros)
             using * C by auto
           also have "... = 0"
             using C by auto
           also have "... \<le> dist (d x) (d y)"
             by auto
           finally show ?thesis by simp
         next
           case 3
           then have "u < v" using \<open>u \<le> v\<close> by auto
           then have *: "next_in A u < v" using v(1) next_in_basics(3)[OF A \<open>u \<in> {a..<b}\<close>] 3 by auto
           have nu: "next_in A u = u + C/lambda"
           proof (rule nx)
             show "u \<in> A" using u(1) by auto
             show "u \<noteq> b" using u(1) by auto
             show "u \<noteq> b'"
             proof
               assume H: "u = b'"
               have "b < v" using * unfolding H nb' by simp
               then show False using \<open>v \<in> {a..<b}\<close> by auto
             qed
             show "u \<noteq> p N"
             proof
               assume H: "u = p N"
               have "b' < v" using * unfolding H npN by simp
               then have "next_in A b' \<le> v" using next_in_basics(3)[OF A \<open>b' \<in> {a..<b}\<close>] v by force
               then show False unfolding nb' using \<open>v \<in> {a..<b}\<close> by auto
             qed
           qed
           have nv: "next_in A v \<le> v + 3/2 * C/lambda" using gap[OF v(1)] by auto
 
           have d: "d u = c u" "d (next_in A u) = c (next_in A u)" "d v = c v" "d (next_in A v) = c (next_in A v)"
             using \<open>u \<in> A - {b}\<close> \<open>next_in A u \<in> A\<close> \<open>v \<in> A - {b}\<close> \<open>next_in A v \<in> A\<close> unfolding d_def by auto
 
           text \<open>The interval containing $x$ has length $C/\lambda$, while the interval containing
           $y$ has length at most $\leq 3/2 C/\lambda$. Therefore, $x$ is at proportion $2/5$ of the inner point
           if $x > u + (3/5) C/\lambda$, and $y$ is at proportion $2/5$ of the inner point if
           $y < v + (2/5) \cdot 3/2 \cdot C/\lambda = v + (3/5)C/\lambda$.\<close>
           consider "x \<le> u + (3/5) * C/lambda \<and> y \<le> v + (3/5) * C/lambda"
                  | "x \<ge> u + (3/5) * C/lambda \<and> y \<le> v + (3/5) * C/lambda"
                  | "x \<le> u + (3/5) * C/lambda \<and> y \<ge> v + (3/5) * C/lambda"
                  | "x \<ge> u + (3/5) * C/lambda \<and> y \<ge> v + (3/5) * C/lambda"
             by linarith
           then show ?thesis
           proof (cases)
             case 1
             have "(1/lambda) * dist u v - C \<le> dist (c u) (c v)"
               apply (rule quasi_isometry_onD(2)[OF assms(1)])
               using \<open>u \<in> A - {b}\<close> \<open>v \<in> A - {b}\<close> \<open>A \<subseteq> {a..b}\<close> by auto
             also have "... = dist (d u) (d v)"
               using d by auto
             also have "... \<le> dist (d u) (d x) + dist (d x) (d y) + dist (d y) (d v)"
               by (intro mono_intros)
             also have "... \<le> (2 * lambda * dist u x) + dist (d x) (d y) + (2 * lambda * dist y v)"
               apply (intro mono_intros)
               apply (rule lipschitz_onD[OF lip[OF u(1)]]) using u(2) apply auto[1] using u(2) apply auto[1]
               apply (rule lipschitz_onD[OF lip[OF v(1)]]) using v(2) by auto
             also have "... \<le> (2 * lambda * (3/5 * C/lambda)) + dist (d x) (d y) + (2 * lambda * (3/5 * C/lambda))"
               apply (intro mono_intros)
               unfolding dist_real_def using 1 u v C by auto
             also have "... = 12/5 * C + dist (d x) (d y)"
               using C by (auto simp add: algebra_simps divide_simps)
             finally have *: "(1/lambda) * dist u v \<le> dist (d x) (d y) + 17/5 * C" by auto
 
             have "(1/lambda) * dist x y \<le> (1/lambda) * (dist u v + dist v y)"
               apply (intro mono_intros)
               unfolding dist_real_def using C u(2) v(2) \<open>x < y\<close> by auto
             also have "... \<le> (1/lambda) * (dist u v + 3/5 * C/lambda)"
               apply (intro mono_intros)
               unfolding dist_real_def using 1 v(2) C by auto
             also have "... = (1/lambda) * dist u v + 3/5 * C * (1/(lambda * lambda))"
               using C by (auto simp add: algebra_simps divide_simps)
             also have "... \<le> (1/lambda) * dist u v + 3/5 * C * 1"
               apply (intro mono_intros)
               using C by (auto simp add: divide_simps algebra_simps mult_ge1_powers(1))
             also have "... \<le> (dist (d x) (d y) + 17/5 * C) + 3/5 * C * 1"
               using * by auto
             finally show ?thesis by auto
           next
             case 2
             have "(1/lambda) * dist (next_in A u) v - C \<le> dist (c (next_in A u)) (c v)"
               apply (rule quasi_isometry_onD(2)[OF assms(1)])
               using \<open>next_in A u \<in> A\<close> \<open>v \<in> A - {b}\<close> \<open>A \<subseteq> {a..b}\<close> by auto
             also have "... = dist (d (next_in A u)) (d v)"
               using d by auto
             also have "... \<le> dist (d (next_in A u)) (d x) + dist (d x) (d y) + dist (d y) (d v)"
               by (intro mono_intros)
             also have "... \<le> (2 * lambda * dist (next_in A u) x) + dist (d x) (d y) + (2 * lambda * dist y v)"
               apply (intro mono_intros)
               apply (rule lipschitz_onD[OF lip[OF u(1)]]) using u(2) apply auto[1] using u(2) apply auto[1]
               apply (rule lipschitz_onD[OF lip[OF v(1)]]) using v(2) by auto
             also have "... \<le> (2 * lambda * (2/5 * C/lambda)) + dist (d x) (d y) + (2 * lambda * (3/5 * C/lambda))"
               apply (intro mono_intros)
               unfolding dist_real_def using 2 u v C nu by auto
             also have "... = 2 * C + dist (d x) (d y)"
               using C by (auto simp add: algebra_simps divide_simps)
             finally have *: "(1/lambda) * dist (next_in A u) v \<le> dist (d x) (d y) + 3 * C" by auto
 
             have "(1/lambda) * dist x y \<le> (1/lambda) * (dist x (next_in A u) + dist (next_in A u) v + dist v y)"
               apply (intro mono_intros)
               unfolding dist_real_def using C u(2) v(2) \<open>x < y\<close> by auto
             also have "... \<le> (1/lambda) * ((2/5 * C/lambda) + dist (next_in A u) v  + (3/5 * C/lambda))"
               apply (intro mono_intros)
               unfolding dist_real_def using 2 u(2) v(2) C nu by auto
             also have "... = (1/lambda) * dist (next_in A u) v + C * (1/(lambda * lambda))"
               using C by (auto simp add: algebra_simps divide_simps)
             also have "... \<le> (1/lambda) * dist (next_in A u) v + C * 1"
               apply (intro mono_intros)
               using C by (auto simp add: divide_simps algebra_simps mult_ge1_powers(1))
             also have "... \<le> (dist (d x) (d y) + 3 * C) + C * 1"
               using * by auto
             finally show ?thesis by auto
           next
             case 3
             have "(1/lambda) * dist u (next_in A v) - C \<le> dist (c u) (c (next_in A v))"
               apply (rule quasi_isometry_onD(2)[OF assms(1)])
               using \<open>u \<in> A - {b}\<close> \<open>next_in A v \<in> A\<close> \<open>A \<subseteq> {a..b}\<close> by auto
             also have "... = dist (d u) (d (next_in A v))"
               using d by auto
             also have "... \<le> dist (d u) (d x) + dist (d x) (d y) + dist (d y) (d (next_in A v))"
               by (intro mono_intros)
             also have "... \<le> (2 * lambda * dist u x) + dist (d x) (d y) + (2 * lambda * dist y (next_in A v))"
               apply (intro mono_intros)
               apply (rule lipschitz_onD[OF lip[OF u(1)]]) using u(2) apply auto[1] using u(2) apply auto[1]
               apply (rule lipschitz_onD[OF lip[OF v(1)]]) using v(2) by auto
             also have "... \<le> (2 * lambda * (3/5 * C/lambda)) + dist (d x) (d y) + (2 * lambda * (9/10 * C/lambda))"
               apply (intro mono_intros)
               unfolding dist_real_def using 3 u v C nv by auto
             also have "... = 3 * C + dist (d x) (d y)"
               using C by (auto simp add: algebra_simps divide_simps)
             finally have *: "(1/lambda) * dist u (next_in A v) \<le> dist (d x) (d y) + 4 * C" by auto
 
             have "(1/lambda) * dist x y \<le> (1/lambda) * dist u (next_in A v)"
               apply (intro mono_intros)
               unfolding dist_real_def using C u(2) v(2) \<open>x < y\<close> by auto
             also have "... \<le> dist (d x) (d y) + 4 * C"
               using * by auto
             finally show ?thesis by auto
           next
             case 4
             have "(1/lambda) * dist (next_in A u) (next_in A v) - C \<le> dist (c (next_in A u)) (c (next_in A v))"
               apply (rule quasi_isometry_onD(2)[OF assms(1)])
               using \<open>next_in A u \<in> A\<close> \<open>next_in A v \<in> A\<close> \<open>A \<subseteq> {a..b}\<close> by auto
             also have "... = dist (d (next_in A u)) (d (next_in A v))"
               using d by auto
             also have "... \<le> dist (d (next_in A u)) (d x) + dist (d x) (d y) + dist (d y) (d (next_in A v))"
               by (intro mono_intros)
             also have "... \<le> (2 * lambda * dist (next_in A u) x) + dist (d x) (d y) + (2 * lambda * dist y (next_in A v))"
               apply (intro mono_intros)
               apply (rule lipschitz_onD[OF lip[OF u(1)]]) using u(2) apply auto[1] using u(2) apply auto[1]
               apply (rule lipschitz_onD[OF lip[OF v(1)]]) using v(2) by auto
             also have "... \<le> (2 * lambda * (2/5 * C/lambda)) + dist (d x) (d y) + (2 * lambda * (9/10 * C/lambda))"
               apply (intro mono_intros)
               unfolding dist_real_def using 4 u v C nu nv by auto
             also have "... = 13/5 * C + dist (d x) (d y)"
               using C by (auto simp add: algebra_simps divide_simps)
             finally have *: "(1/lambda) * dist (next_in A u) (next_in A v) \<le> dist (d x) (d y) + 18/5 * C" by auto
 
             have "(1/lambda) * dist x y \<le> (1/lambda) * (dist x (next_in A u) + dist (next_in A u) (next_in A v))"
               apply (intro mono_intros)
               unfolding dist_real_def using C u(2) v(2) \<open>x < y\<close> by auto
             also have "... \<le> (1/lambda) * ((2/5 *C/lambda) + dist (next_in A u) (next_in A v))"
               apply (intro mono_intros)
               unfolding dist_real_def using 4 u(2) v(2) C nu by auto
             also have "... = (1/lambda) * dist (next_in A u) (next_in A v) + 2/5 * C * (1/(lambda * lambda))"
               using C by (auto simp add: algebra_simps divide_simps)
             also have "... \<le> (1/lambda) * dist (next_in A u) (next_in A v) + 2/5 * C * 1"
               apply (intro mono_intros)
               using C by (auto simp add: divide_simps algebra_simps mult_ge1_powers(1))
             also have "... \<le> (dist (d x) (d y) + 18/5 * C) + 2/5 * C * 1"
               using * by auto
             finally show ?thesis by auto
           qed
         qed
       qed
       show "dist (d x) (d y) \<ge> (1/lambda) * dist x y - 4 * C" if H: "x \<in> {a..b}" "y \<in> {a..b}" for x y
       proof -
         consider "x < y" | "x = y" | "x > y" by linarith
         then show ?thesis
         proof (cases)
           case 1
           then show ?thesis using J[OF H(1) H(2) 1] by simp
         next
           case 2
           show ?thesis unfolding 2 using C by auto
         next
           case 3
           show ?thesis using J[OF H(2) H(1) 3] by (simp add: metric_space_class.dist_commute)
         qed
       qed
     qed
 
     text \<open>We have proved that $d$ has all the properties we wanted.\<close>
     then have "continuous_on {a..b} d \<and> d a = c a \<and> d b = c b
           \<and> lambda (4 * C)-quasi_isometry_on {a..b} d
           \<and> (\<forall>x\<in>{a..b}. dist (c x) (d x) \<le> 4 *C)
           \<and> (2*lambda)-lipschitz_on {a..b} d
           \<and> hausdorff_distance (c`{a..b}) (d`{a..b}) \<le> 2 * C"
       using dist_c_d \<open>continuous_on {a..b} d\<close> \<open>d a = c a\<close> \<open>d b = c b\<close> \<open>(2*lambda)-lipschitz_on {a..b} d\<close>
             \<open>hausdorff_distance (c`{a..b}) (d`{a..b}) \<le> 2 * C\<close> by auto
     then show ?thesis by auto
   qed
 qed
 
 end (*of theory Isometries*)
diff --git a/thys/Gromov_Hyperbolicity/Isometries_Classification.thy b/thys/Gromov_Hyperbolicity/Isometries_Classification.thy
--- a/thys/Gromov_Hyperbolicity/Isometries_Classification.thy
+++ b/thys/Gromov_Hyperbolicity/Isometries_Classification.thy
@@ -1,1115 +1,1117 @@
 (*  Author:  Sébastien Gouëzel   sebastien.gouezel@univ-rennes1.fr
     License: BSD
 *)
 
 section \<open>Classification of isometries on a Gromov hyperbolic space\<close>
 
 theory Isometries_Classification
   imports Gromov_Boundary Busemann_Function
 begin
 
 text \<open>Isometries of Gromov hyperbolic spaces are of three types:
 \begin{itemize}
 \item Elliptic ones, for which orbits are bounded.
 \item Parabolic ones, which are not elliptic and have exactly one fixed point
 at infinity.
 \item Loxodromic ones, which are not elliptic and have exactly two fixed points
 at infinity.
 \end{itemize}
 In this file, we show that all isometries are indeed of this form, and give
 further properties for each type.
 
 For the definition, we use another characterization in terms of stable translation length: for
 isometries which are not elliptic, then they are parabolic if the stable translation length is $0$,
 loxodromic if it is positive. This gives a very efficient definition, and it is clear from this
 definition that the three categories of isometries are disjoint. All the work is then to go from
 this general definition to the dynamical properties in terms of fixed points on the boundary.
 \<close>
 
 
 subsection \<open>The translation length\<close>
 
 text \<open>The translation length is the minimal translation distance of an isometry. The stable
 translation length is the limit of the translation length of $f^n$ divided by $n$.\<close>
 
 definition translation_length::"(('a::metric_space) \<Rightarrow> 'a) \<Rightarrow> real"
   where "translation_length f = Inf {dist x (f x)|x. True}"
 
 lemma translation_length_nonneg [simp, mono_intros]:
   "translation_length f \<ge> 0"
 unfolding translation_length_def by (rule cInf_greatest, auto)
 
 lemma translation_length_le [mono_intros]:
   "translation_length f \<le> dist x (f x)"
 unfolding translation_length_def apply (rule cInf_lower) by (auto intro: bdd_belowI[of _ 0])
 
 definition stable_translation_length::"(('a::metric_space) \<Rightarrow> 'a) \<Rightarrow> real"
   where "stable_translation_length f = Inf {translation_length (f^^n)/n |n. n > 0}"
 
 lemma stable_translation_length_nonneg [simp]:
   "stable_translation_length f \<ge> 0"
 unfolding stable_translation_length_def by (rule cInf_greatest, auto)
 
 lemma stable_translation_length_le_translation_length [mono_intros]:
   "n * stable_translation_length f \<le> translation_length (f^^n)"
 proof -
   have *: "stable_translation_length f \<le> translation_length (f^^n)/n" if "n > 0" for n
     unfolding stable_translation_length_def apply (rule cInf_lower) using that by (auto intro: bdd_belowI[of _ 0])
   show ?thesis
     apply (cases "n = 0") using * by (auto simp add: divide_simps algebra_simps)
 qed
 
 lemma semicontraction_iterates:
   fixes f::"('a::metric_space) \<Rightarrow> 'a"
   assumes "1-lipschitz_on UNIV f"
   shows "1-lipschitz_on UNIV (f^^n)"
 by (induction n, auto intro!: lipschitz_onI lipschitz_on_compose2[of 1 UNIV _ 1 f, simplified] lipschitz_on_subset[OF assms])
 
 text \<open>If $f$ is a semicontraction, then its stable translation length is the limit of $d(x, f^n x)/n$
 for any $n$. While it is obvious that the liminf of this quantity is at least the stable translation
 length (which is defined as an inf over all points and all times), the opposite inequality is more
 interesting. One may find a point $y$ and a time $k$ for which $d(y, f^k y)/k$ is very close to the
 stable translation length. By subadditivity of the sequence $n \mapsto f(y, f^n y)$ and Fekete's
 Lemma, it follows that, for any large $n$, then $d(y, f^n y)/n$ is also very close to the stable
 translation length. Since this is equal to $d(x, f^n x)/n$ up to $\pm 2 d(x,y)/n$, the result
 follows.\<close>
 
 proposition stable_translation_length_as_pointwise_limit:
   assumes "1-lipschitz_on UNIV f"
   shows "(\<lambda>n. dist x ((f^^n) x)/n) \<longlonglongrightarrow> stable_translation_length f"
 proof -
   have *: "subadditive (\<lambda>n. dist y ((f^^n) y))" for y
   proof (rule subadditiveI)
     fix m n::nat
     have "dist y ((f ^^ (m + n)) y) \<le> dist y ((f^^m) y) + dist ((f^^m) y) ((f^^(m+n)) y)"
       by (rule dist_triangle)
     also have "... = dist y ((f^^m) y) + dist ((f^^m) y) ((f^^m) ((f^^n) y))"
       by (auto simp add: funpow_add)
     also have "... \<le> dist y ((f^^m) y) + dist y ((f^^n) y)"
       using semicontraction_iterates[OF assms, of m] unfolding lipschitz_on_def by auto
     finally show "dist y ((f ^^ (m + n)) y) \<le> dist y ((f ^^ m) y) + dist y ((f ^^ n) y)"
       by simp
   qed
   have Ly: "(\<lambda>n. dist y ((f^^n) y) / n) \<longlonglongrightarrow> Inf {dist y ((f^^n) y) / n |n. n > 0}" for y
     by (auto intro!: bdd_belowI[of _ 0] subadditive_converges_bounded'[OF subadditive_imp_eventually_subadditive[OF *]])
   have "eventually (\<lambda>n. dist x ((f^^n) x)/n < l) sequentially" if "stable_translation_length f < l" for l
   proof -
     obtain m where m: "stable_translation_length f < m" "m < l"
       using \<open>stable_translation_length f < l\<close> dense by auto
     have "\<exists>t \<in> {translation_length (f^^n)/n |n. n > 0}. t < m"
       apply (subst cInf_less_iff[symmetric])
       using m unfolding stable_translation_length_def by (auto intro!: bdd_belowI[of _ 0])
     then obtain k where k: "k > 0" "translation_length (f^^k)/k < m"
       by auto
     have "translation_length (f^^k) < k * m"
       using k by (simp add: divide_simps algebra_simps)
     then have "\<exists>t \<in> {dist y ((f^^k) y) |y. True}. t < k * m"
       apply (subst cInf_less_iff[symmetric])
       unfolding translation_length_def by (auto intro!: bdd_belowI[of _ 0])
     then obtain y where y: "dist y ((f^^k) y) < k * m"
       by auto
     have A: "eventually (\<lambda>n. dist y ((f^^n) y)/n < m) sequentially"
       apply (auto intro!: order_tendstoD[OF Ly] iffD2[OF cInf_less_iff] bdd_belowI[of _ 0] exI[of _ "dist y ((f^^k) y)/k"])
       using y k by (auto simp add: algebra_simps divide_simps)
     have B: "eventually (\<lambda>n. dist x y * (1/n) < (l-m)/2) sequentially"
       apply (intro order_tendstoD[of _ "dist x y * 0"] tendsto_intros)
       using \<open>m < l\<close> by simp
     have C: "dist x ((f^^n) x)/n < l" if "n > 0" "dist y ((f^^n) y)/n < m" "dist x y * (1/n) < (l-m)/2" for n
     proof -
       have "dist x ((f^^n) x) \<le> dist x y + dist y ((f^^n) y) + dist ((f^^n) y) ((f^^n) x)"
         by (intro mono_intros)
       also have "... \<le> dist x y + dist y ((f^^n) y) + dist y x"
         using semicontraction_iterates[OF assms, of n] unfolding lipschitz_on_def by auto
       also have "... = 2 * dist x y + dist y ((f^^n) y)"
         by (simp add: dist_commute)
       also have "... < 2 * real n * (l-m)/2 + n * m"
         apply (intro mono_intros) using that by (auto simp add: algebra_simps divide_simps)
       also have "... = n * l"
         by (simp add: algebra_simps divide_simps)
       finally show ?thesis
         using that by (simp add: algebra_simps divide_simps)
     qed
     show "eventually (\<lambda>n. dist x ((f^^n) x)/n < l) sequentially"
       by (rule eventually_mono[OF eventually_conj[OF eventually_conj[OF A B] eventually_gt_at_top[of 0]] C], auto)
   qed
   moreover have "eventually (\<lambda>n. dist x ((f^^n) x)/n > l) sequentially" if "stable_translation_length f > l" for l
   proof -
     have *: "dist x ((f^^n) x)/n > l" if "n > 0" for n
     proof -
       have "n * l < n * stable_translation_length f"
         using \<open>stable_translation_length f > l\<close> \<open>n > 0\<close> by auto
       also have "... \<le> translation_length (f^^n)"
         by (intro mono_intros)
       also have "... \<le> dist x ((f^^n) x)"
         by (intro mono_intros)
       finally show ?thesis
         using \<open>n > 0\<close> by (auto simp add: algebra_simps divide_simps)
     qed
     then show ?thesis
       by (rule eventually_mono[rotated], auto)
   qed
   ultimately show ?thesis
     by (rule order_tendstoI[rotated])
 qed
 
 text \<open>It follows from the previous proposition that the stable translation length is also the limit
 of the renormalized translation length of $f^n$.\<close>
 
 proposition stable_translation_length_as_limit:
   assumes "1-lipschitz_on UNIV f"
   shows "(\<lambda>n. translation_length (f^^n) / n) \<longlonglongrightarrow> stable_translation_length f"
 proof -
   obtain x::'a where True by auto
   show ?thesis
   proof (rule tendsto_sandwich[of "\<lambda>n. stable_translation_length f" _ _ "\<lambda>n. dist x ((f^^n) x)/n"])
     have "stable_translation_length f \<le> translation_length (f ^^ n) / real n" if "n > 0" for n
       using stable_translation_length_le_translation_length[of n f] that by (simp add: divide_simps algebra_simps)
     then show "eventually (\<lambda>n. stable_translation_length f \<le> translation_length (f ^^ n) / real n) sequentially"
       by (rule eventually_mono[rotated], auto)
     have "translation_length (f ^^ n) / real n \<le> dist x ((f ^^ n) x) / real n" for n
       using translation_length_le[of "f^^n" x] by (auto simp add: divide_simps)
     then show "eventually (\<lambda>n. translation_length (f ^^ n) / real n \<le> dist x ((f ^^ n) x) / real n) sequentially"
       by auto
   qed (auto simp add: stable_translation_length_as_pointwise_limit[OF assms])
 qed
 
 lemma stable_translation_length_inv:
   assumes "isometry f"
   shows "stable_translation_length (inv f) = stable_translation_length f"
 proof -
   have *: "dist basepoint (((inv f)^^n) basepoint) = dist basepoint ((f^^n) basepoint)" for n
   proof -
     have "basepoint = (f^^n) (((inv f)^^n) basepoint)"
       by (metis assms comp_apply fn_o_inv_fn_is_id isometry_inverse(2))
     then have "dist basepoint ((f^^n) basepoint) = dist ((f^^n) (((inv f)^^n) basepoint)) ((f^^n) basepoint)"
       by auto
     also have "... = dist (((inv f)^^n) basepoint) basepoint"
       unfolding isometryD(2)[OF isometry_iterates[OF assms]] by simp
     finally show ?thesis by (simp add: dist_commute)
   qed
 
   have "(\<lambda>n. dist basepoint ((f^^n) basepoint)/n) \<longlonglongrightarrow> stable_translation_length f"
     using stable_translation_length_as_pointwise_limit[OF isometryD(4)[OF assms]] by simp
   moreover have "(\<lambda>n. dist basepoint ((f^^n) basepoint)/n) \<longlonglongrightarrow> stable_translation_length (inv f)"
     unfolding *[symmetric]
     using stable_translation_length_as_pointwise_limit[OF isometryD(4)[OF isometry_inverse(1)[OF assms]]] by simp
   ultimately show ?thesis
     using LIMSEQ_unique by auto
 qed
 
 subsection \<open>The strength of an isometry at a fixed point at infinity\<close>
 
 text \<open>The additive strength of an isometry at a fixed point at infinity is the asymptotic average
 every point is moved towards the fixed point at each step. It is measured using the Busemann
 function.\<close>
 
 definition additive_strength::"('a::Gromov_hyperbolic_space \<Rightarrow> 'a) \<Rightarrow> ('a Gromov_completion) \<Rightarrow> real"
   where "additive_strength f xi = lim (\<lambda>n. (Busemann_function_at xi ((f^^n) basepoint) basepoint)/n)"
 
 text \<open>For additivity reasons, as the Busemann function is a quasi-morphism, the additive strength
 measures the deplacement even at finite times. It is also uniform in terms of the basepoint. This
 shows that an isometry sends horoballs centered at a fixed point to horoballs, up to a uniformly
 bounded error depending only on $\delta$.\<close>
 
 lemma Busemann_function_eq_additive_strength:
   assumes "isometry f" "Gromov_extension f xi = xi"
   shows "\<bar>Busemann_function_at xi ((f^^n) x) (x::'a::Gromov_hyperbolic_space) - real n * additive_strength f xi\<bar> \<le> 2 * deltaG(TYPE('a))"
 proof -
   define u where "u = (\<lambda>y n. Busemann_function_at xi ((f^^n) y) y)"
   have *: "abs(u y (m+n) - u y m - u y n) \<le> 2 * deltaG(TYPE('a))" for n m y
   proof -
     have P: "Gromov_extension (f^^m) xi = xi"
       unfolding Gromov_extension_isometry_iterates[OF assms(1)] apply (induction m) using assms by auto
     have *: "u y n = Busemann_function_at xi ((f^^m) ((f^^n) y)) ((f^^m) y)"
       apply (subst P[symmetric]) unfolding Busemann_function_isometry[OF isometry_iterates[OF \<open>isometry f\<close>]] u_def by auto
     show ?thesis
       unfolding * unfolding u_def using Busemann_function_quasi_morphism[of xi "(f^^(m+n)) y" "(f^^m) y" y]
       unfolding funpow_add comp_def by auto
   qed
   define l where "l = (\<lambda>y. lim (\<lambda>n. u y n/n))"
   have A: "abs(u y k - k * l y) \<le> 2 * deltaG(TYPE('a))" for y k
     unfolding l_def using almost_additive_converges(2) * by auto
   then have *: "abs(Busemann_function_at xi ((f^^k) y) y - k * l y) \<le> 2 * deltaG(TYPE('a))" for y k
     unfolding u_def by auto
   have "l basepoint = additive_strength f xi"
     unfolding l_def u_def additive_strength_def by auto
 
   have "abs(k * l basepoint - k * l x) \<le> 4 * deltaG(TYPE('a)) + 2 * dist basepoint x" for k::nat
   proof -
     have "abs(k * l basepoint - k * l x) = abs((Busemann_function_at xi ((f^^k) x) x - k * l x) - (Busemann_function_at xi ((f^^k) basepoint) basepoint - k * l basepoint)
                                                 + (Busemann_function_at xi ((f^^k) basepoint) basepoint - Busemann_function_at xi ((f^^k) x) x))"
       by auto
     also have "... \<le> abs (Busemann_function_at xi ((f^^k) x) x - k * l x) + abs (Busemann_function_at xi ((f^^k) basepoint) basepoint - k * l basepoint)
                       + abs (Busemann_function_at xi ((f^^k) basepoint) basepoint - Busemann_function_at xi ((f^^k) x) x)"
       by auto
     also have "... \<le> 2 * deltaG(TYPE('a)) + 2 * deltaG(TYPE('a)) + (dist ((f^^k) basepoint) ((f^^k) x) + dist basepoint x)"
       by (intro mono_intros *)
     also have "... = 4 * deltaG(TYPE('a)) + 2 * dist basepoint x"
       unfolding isometryD[OF isometry_iterates[OF assms(1)]] by auto
     finally show ?thesis by auto
   qed
   moreover have "u = v" if H: "\<And>k::nat. abs(k * u - k * v) \<le> C" for u v C::real
   proof -
     have "(\<lambda>n. abs(u - v)) \<longlonglongrightarrow> 0"
     proof (rule tendsto_sandwich[of "\<lambda>n. 0" _ _ "\<lambda>n::nat. C/n"], auto)
       have "(\<lambda>n. C*(1/n)) \<longlonglongrightarrow> C * 0" by (intro tendsto_intros)
       then show "(\<lambda>n. C/n) \<longlonglongrightarrow> 0" by auto
       have "\<bar>u - v\<bar> \<le> C / real n" if "n \<ge> 1" for n
         using H[of n] that apply (simp add: divide_simps algebra_simps)
         by (metis H abs_mult abs_of_nat right_diff_distrib')
       then show "\<forall>\<^sub>F n in sequentially. \<bar>u - v\<bar> \<le> C / real n"
         unfolding eventually_sequentially by auto
     qed
     then show ?thesis
       by (metis LIMSEQ_const_iff abs_0_eq eq_iff_diff_eq_0)
   qed
   ultimately have "l basepoint = l x" by auto
   show ?thesis
     using A[of x n] unfolding u_def \<open>l basepoint = l x\<close>[symmetric] \<open>l basepoint = additive_strength f xi\<close> by auto
 qed
 
 lemma additive_strength_as_limit [tendsto_intros]:
   assumes "isometry f" "Gromov_extension f xi = xi"
   shows "(\<lambda>n. Busemann_function_at xi ((f^^n) x) x/n) \<longlonglongrightarrow> additive_strength f xi"
 proof -
   have "(\<lambda>n. abs(Busemann_function_at xi ((f^^n) x) x/n - additive_strength f xi)) \<longlonglongrightarrow> 0"
     apply (rule tendsto_sandwich[of "\<lambda>n. 0" _ _ "\<lambda>n. (2 * deltaG(TYPE('a))) * (1/real n)"], auto)
     unfolding eventually_sequentially apply (rule exI[of _ 1])
     using Busemann_function_eq_additive_strength[OF assms] apply (simp add: divide_simps algebra_simps)
     using tendsto_mult[OF _ lim_1_over_n] by auto
   then show ?thesis
     using LIM_zero_iff tendsto_rabs_zero_cancel by blast
 qed
 
 text \<open>The additive strength measures the amount of displacement towards a fixed point at infinity.
 Therefore, the distance from $x$ to $f^n x$ is at least $n$ times the additive strength, but one
 might think that it might be larger, if there is displacement along the horospheres. It turns out
 that this is not the case: the displacement along the horospheres is at most logarithmic (this is
 a classical property of parabolic isometries in hyperbolic spaces), and in fact it is bounded for
 loxodromic elements.
 We prove here that the growth is at most logarithmic in all cases, using a small computation based
 on the hyperbolicity inequality, expressed in Lemma \verb+dist_minus_Busemann_max_ineq+ above.
 This lemma will be used below to show that the translation length is the absolute value of the
 additive strength.\<close>
 
 lemma dist_le_additive_strength:
   assumes "isometry (f::'a::Gromov_hyperbolic_space \<Rightarrow> 'a)" "Gromov_extension f xi = xi" "additive_strength f xi \<ge> 0" "n \<ge> 1"
   shows "dist x ((f^^n) x) \<le> dist x (f x) + real n * additive_strength f xi + ceiling (log 2 n) * 16 * deltaG(TYPE('a))"
 proof -
   have A: "\<And>n. n \<in> {1..2^k} \<Longrightarrow> dist x ((f^^n) x) - real n * additive_strength f xi \<le> dist x (f x) + k * 16 * deltaG(TYPE('a))" for k
   proof (induction k)
     case 0
     fix n::nat assume "n \<in> {1..2^0}"
     then have "n = 1" by auto
     then show "dist x ((f^^n) x) - real n * additive_strength f xi \<le> dist x (f x) + real 0 * 16 * deltaG(TYPE('a))"
       using assms(3) by auto
   next
     case (Suc k)
     fix N::nat assume "N \<in> {1..2^(Suc k)}"
     then consider "N \<in> {1..2^k}" | "N \<in> {2^k<..2^(Suc k)}" using not_le by auto
     then show "dist x ((f ^^ N) x) - real N * additive_strength f xi \<le> dist x (f x) + real (Suc k) * 16 * deltaG TYPE('a)"
     proof (cases)
       case 1
       show ?thesis by (rule order_trans[OF Suc.IH[OF 1]], auto simp add: algebra_simps)
     next
       case 2
       define m::nat where "m = N - 2^k"
       define n::nat where "n = 2^k"
       have nm: "N = n+m" "m \<in> {1..2^k}" "n \<in> {1..2^k}"unfolding m_def n_def using 2 by auto
       have *: "(f^^(n+m)) x = (f^^n) ((f^^m) x)"
         unfolding funpow_add comp_def by auto
       have **: "(f^^(n+m)) x = (f^^m) ((f^^n) x)"
         apply (subst add.commute) unfolding funpow_add comp_def by auto
 
       have "dist x ((f^^N) x) - N * additive_strength f xi - 2 * deltaG(TYPE('a)) \<le> dist x ((f^^(n+m)) x) - Busemann_function_at xi ((f^^(n+m)) x) x"
         unfolding nm(1) using Busemann_function_eq_additive_strength[OF assms(1) assms(2), of "n+m" x] by auto
       also have "... \<le> max (dist x ((f^^n) x) - Busemann_function_at xi ((f^^n) x) x) (dist ((f^^n) x) ((f^^(n+m)) x) - Busemann_function_at xi ((f^^(n+m)) x) ((f^^n) x) - 2 * Busemann_function_at xi ((f^^n) x) x) + 8 * deltaG(TYPE('a))"
         using dist_minus_Busemann_max_ineq by auto
       also have "... \<le> max (dist x ((f^^n) x) - (n * additive_strength f xi - 2 * deltaG(TYPE('a)))) (dist ((f^^n) x) ((f^^(n+m)) x) - (m * additive_strength f xi - 2 * deltaG(TYPE('a))) - 2 * (n * additive_strength f xi - 2 * deltaG(TYPE('a)))) + 8 * deltaG(TYPE('a))"
         unfolding ** apply (intro mono_intros)
         using Busemann_function_eq_additive_strength[OF assms(1) assms(2), of n x] Busemann_function_eq_additive_strength[OF assms(1) assms(2), of m "(f^^n) x"] by auto
       also have "... \<le> max (dist x ((f^^n) x) - n * additive_strength f xi + 6 * deltaG(TYPE('a))) (dist x ((f^^m) x) - m * additive_strength f xi + 6 * deltaG(TYPE('a))) + 8 * deltaG(TYPE('a))"
         unfolding * isometryD(2)[OF isometry_iterates[OF assms(1)], of n] using assms(3) by (intro mono_intros, auto)
       also have "... = max (dist x ((f^^n) x) - n * additive_strength f xi) (dist x ((f^^m) x) - m * additive_strength f xi) + 14 * deltaG(TYPE('a))"
         unfolding max_add_distrib_left[symmetric] by auto
       also have "... \<le> dist x (f x) + k * 16 * deltaG(TYPE('a)) + 14 * deltaG(TYPE('a))"
         using nm by (auto intro!: Suc.IH)
       finally show ?thesis by (auto simp add: algebra_simps)
     qed
   qed
   define k::nat where "k = nat(ceiling (log 2 n))"
   have "n \<le> 2^k" unfolding k_def
     by (meson less_log2_of_power not_le real_nat_ceiling_ge)
   then have "dist x ((f^^n) x) - real n * additive_strength f xi \<le> dist x (f x) + k * 16 * deltaG(TYPE('a))"
     using A[of n k] \<open>n \<ge> 1\<close> by auto
   moreover have "real (nat \<lceil>log 2 (real n)\<rceil>) = real_of_int \<lceil>log 2 (real n)\<rceil>"
     by (metis Transcendental.log_one \<open>n \<le> 2 ^ k\<close> assms(4) ceiling_zero int_ops(2) k_def le_antisym nat_eq_iff2 of_int_1 of_int_of_nat_eq order_refl power_0)
   ultimately show ?thesis unfolding k_def by (auto simp add: algebra_simps)
 qed
 
 text \<open>The strength of the inverse of a map is the opposite of the strength of the map.\<close>
 
 lemma additive_strength_inv:
   assumes "isometry (f::'a::Gromov_hyperbolic_space \<Rightarrow> 'a)" "Gromov_extension f xi = xi"
   shows "additive_strength (inv f) xi = - additive_strength f xi"
 proof -
   have *: "(inv f ^^ n) ((f ^^ n) x) = x" for n x
     by (metis assms(1) comp_apply funpow_code_def inv_fn_o_fn_is_id isometry_inverse(2))
   have A: "abs(real n * additive_strength f xi + real n * additive_strength (inv f) xi) \<le> 6 * deltaG (TYPE('a))" for n::nat and x::'a
     using Busemann_function_quasi_morphism[of xi x "(f^^n) x" x] Busemann_function_eq_additive_strength[OF assms, of n x] Busemann_function_eq_additive_strength[OF isometry_inverse(1)[OF assms(1)]
     Gromov_extension_inv_fixed_point[OF assms], of n "(f^^n) x"] unfolding * by auto
   have B: "abs(additive_strength f xi + additive_strength (inv f) xi) \<le> 6 * deltaG(TYPE('a)) * (1/n)" if "n \<ge> 1" for n::nat
     using that A[of n] apply (simp add: divide_simps algebra_simps) unfolding distrib_left[symmetric] by auto
   have "(\<lambda>n. abs(additive_strength f xi + additive_strength (inv f) xi)) \<longlonglongrightarrow> 6 * deltaG(TYPE('a)) * 0"
     apply (rule tendsto_sandwich[of "\<lambda>n. 0" _ _ "\<lambda>n. 6 * deltaG(TYPE('a)) * (1/real n)"], simp)
     unfolding eventually_sequentially apply (rule exI[of _ 1]) using B apply simp
     by (simp, intro tendsto_intros)
   then show ?thesis
     using LIMSEQ_unique mult_zero_right tendsto_const by fastforce
 qed
 
 text \<open>We will now prove that the stable translation length of an isometry is given by the absolute
 value of its strength at any fixed point. We start with the case where the strength is nonnegative,
 and then reduce to this case by considering the map or its inverse.\<close>
 
 lemma stable_translation_length_eq_additive_strength_aux:
   assumes "isometry (f::'a::Gromov_hyperbolic_space \<Rightarrow> 'a)" "Gromov_extension f xi = xi" "additive_strength f xi \<ge> 0"
   shows "stable_translation_length f = additive_strength f xi"
 proof -
   have "(\<lambda>n. dist x ((f^^n) x)/n) \<longlonglongrightarrow> additive_strength f xi" for x
   proof (rule tendsto_sandwich[of "\<lambda>n. (n * additive_strength f xi - 2 * deltaG(TYPE('a)))/real n" _ _ "\<lambda>n. (dist x (f x) + n * additive_strength f xi + ceiling (log 2 n) * 16 * deltaG(TYPE('a)))/ n"])
     have "n * additive_strength f xi - 2 * deltaG TYPE('a) \<le> dist x ((f ^^ n) x)" for n
       using Busemann_function_eq_additive_strength[OF assms(1) assms(2), of n x] Busemann_function_le_dist[of xi "(f^^n) x" x]
       by (simp add: dist_commute)
     then have "(n * additive_strength f xi - 2 * deltaG TYPE('a)) / n \<le> dist x ((f ^^ n) x) / n" if "n \<ge> 1" for n
       using that by (simp add: divide_simps)
     then show "\<forall>\<^sub>F n in sequentially. (real n * additive_strength f xi - 2 * deltaG TYPE('a)) / real n \<le> dist x ((f ^^ n) x) / real n"
       unfolding eventually_sequentially by auto
 
     have A: "eventually (\<lambda>n. additive_strength f xi - (2 * deltaG(TYPE('a))) * (1/n) = (real n * additive_strength f xi - 2 * deltaG TYPE('a)) / real n) sequentially"
       unfolding eventually_sequentially apply (rule exI[of _ 1]) by (simp add: divide_simps)
     have B: "(\<lambda>n. additive_strength f xi - (2 * deltaG(TYPE('a))) * (1/n)) \<longlonglongrightarrow> additive_strength f xi - (2 * deltaG(TYPE('a))) * 0"
       by (intro tendsto_intros)
     show "(\<lambda>n. (real n * additive_strength f xi - 2 * deltaG TYPE('a)) / real n) \<longlonglongrightarrow> additive_strength f xi"
       using Lim_transform_eventually[OF A B] by simp
 
     have "dist x ((f^^n) x) \<le> dist x (f x) + n * additive_strength f xi + ceiling (log 2 n) * 16 * deltaG(TYPE('a))" if "n \<ge> 1" for n
       using dist_le_additive_strength[OF assms that] by simp
     then have "(dist x ((f^^n) x))/n \<le> (dist x (f x) + n * additive_strength f xi + ceiling (log 2 n) * 16 * deltaG(TYPE('a)))/n" if "n \<ge> 1" for n
       using that by (simp add: divide_simps)
     then show "\<forall>\<^sub>F n in sequentially. dist x ((f ^^ n) x) / real n \<le> (dist x (f x) + real n * additive_strength f xi + real_of_int (\<lceil>log 2 (real n)\<rceil> * 16) * deltaG TYPE('a)) / real n"
       unfolding eventually_sequentially by auto
 
     have A: "eventually (\<lambda>n. dist x (f x) * (1/n) + additive_strength f xi + 16 * deltaG TYPE('a) * (\<lceil>log 2 n\<rceil> / n) = (dist x (f x) + real n * additive_strength f xi + real_of_int (\<lceil>log 2 (real n)\<rceil> * 16) * deltaG TYPE('a)) / real n) sequentially"
       unfolding eventually_sequentially apply (rule exI[of _ 1]) by (simp add: algebra_simps divide_simps)
     have B: "(\<lambda>n. dist x (f x) * (1/n) + additive_strength f xi + 16 * deltaG TYPE('a) * (\<lceil>log 2 n\<rceil> / n)) \<longlonglongrightarrow> dist x (f x) * 0 + additive_strength f xi + 16 * deltaG TYPE('a) * 0"
       by (intro tendsto_intros)
     show "(\<lambda>n. (dist x (f x) + n * additive_strength f xi + real_of_int (\<lceil>log 2 n\<rceil> * 16) * deltaG TYPE('a)) / real n) \<longlonglongrightarrow> additive_strength f xi"
       using Lim_transform_eventually[OF A B] by simp
   qed
   then show ?thesis
     using LIMSEQ_unique stable_translation_length_as_pointwise_limit[OF isometryD(4)[OF assms(1)]] by blast
 qed
 
 lemma stable_translation_length_eq_additive_strength:
   assumes "isometry (f::'a::Gromov_hyperbolic_space \<Rightarrow> 'a)" "Gromov_extension f xi = xi"
   shows "stable_translation_length f = abs(additive_strength f xi)"
 proof (cases "additive_strength f xi \<ge> 0")
   case True
   then show ?thesis using stable_translation_length_eq_additive_strength_aux[OF assms] by auto
 next
   case False
   then have *: "abs(additive_strength f xi) = additive_strength (inv f) xi"
     unfolding additive_strength_inv[OF assms] by auto
   show ?thesis
     unfolding * stable_translation_length_inv[OF assms(1), symmetric]
     using stable_translation_length_eq_additive_strength_aux[OF isometry_inverse(1)[OF assms(1)] Gromov_extension_inv_fixed_point[OF assms]] * by auto
 qed
 
 
 subsection \<open>Elliptic isometries\<close>
 
 text \<open>Elliptic isometries are the simplest ones: they have bounded orbits.\<close>
 
 definition elliptic_isometry::"('a::Gromov_hyperbolic_space \<Rightarrow> 'a) \<Rightarrow> bool"
   where "elliptic_isometry f = (isometry f \<and> (\<forall>x. bounded {(f^^n) x|n. True}))"
 
 lemma elliptic_isometryD:
   assumes "elliptic_isometry f"
   shows "bounded {(f^^n) x |n. True}"
         "isometry f"
 using assms unfolding elliptic_isometry_def by auto
 
 lemma elliptic_isometryI [intro]:
   assumes "bounded {(f^^n) x |n. True}"
           "isometry f"
   shows "elliptic_isometry f"
 proof -
   have "bounded {(f^^n) y |n. True}" for y
   proof -
     obtain c e where c: "\<And>n. dist c ((f^^n) x) \<le> e"
       using assms(1) unfolding bounded_def by auto
     have "dist c ((f^^n) y) \<le> e + dist x y" for n
     proof -
       have "dist c ((f^^n) y) \<le> dist c ((f^^n) x) + dist ((f^^n) x) ((f^^n) y)"
         by (intro mono_intros)
       also have "... \<le> e + dist x y"
         using c[of n] isometry_iterates[OF assms(2), of n] by (intro mono_intros, auto simp add: isometryD)
       finally show ?thesis by simp
     qed
     then show ?thesis
       unfolding bounded_def by auto
   qed
   then show ?thesis unfolding elliptic_isometry_def using assms by auto
 qed
 
 text \<open>The inverse of an elliptic isometry is an elliptic isometry.\<close>
 
 lemma elliptic_isometry_inv:
   assumes "elliptic_isometry f"
   shows "elliptic_isometry (inv f)"
 proof -
   obtain c e where A: "\<And>n. dist c ((f^^n) basepoint) \<le> e"
     using elliptic_isometryD(1)[OF assms, of basepoint] unfolding bounded_def by auto
   have "c = (f^^n) (((inv f)^^n) c)" for n
     using fn_o_inv_fn_is_id[OF isometry_inverse(2)[OF elliptic_isometryD(2)[OF assms]], of n]
     unfolding comp_def by metis
   then have "dist ((f^^n) (((inv f)^^n) c)) ((f^^n) basepoint) \<le> e" for n
     using A by auto
   then have B: "dist basepoint (((inv f)^^n) c) \<le> e" for n
     unfolding isometryD(2)[OF isometry_iterates[OF elliptic_isometryD(2)[OF assms]]] by (auto simp add: dist_commute)
   show ?thesis
     apply (rule elliptic_isometryI[of _ c])
     using isometry_inverse(1)[OF elliptic_isometryD(2)[OF assms]] B unfolding bounded_def by auto
 qed
 
 text \<open>The inverse of a bijective map is an elliptic isometry if and only if the original map is.\<close>
 
 lemma elliptic_isometry_inv_iff:
   assumes "bij f"
   shows "elliptic_isometry (inv f) \<longleftrightarrow> elliptic_isometry f"
 using elliptic_isometry_inv[of f] elliptic_isometry_inv[of "inv f"] inv_inv_eq[OF assms] by auto
 
 text \<open>The identity is an elliptic isometry.\<close>
 
 lemma elliptic_isometry_id:
   "elliptic_isometry id"
 by (intro elliptic_isometryI isometryI, auto)
 
 text \<open>The translation length of an elliptic isometry is $0$.\<close>
 
 lemma elliptic_isometry_stable_translation_length:
   assumes "elliptic_isometry f"
   shows "stable_translation_length f = 0"
 proof -
   obtain x::'a where True by auto
   have "bounded {(f^^n) x|n. True}"
     using elliptic_isometryD[OF assms] by auto
   then obtain c C where cC: "\<And>n. dist c ((f^^n) x) \<le> C"
     unfolding bounded_def by auto
   have "(\<lambda>n. dist x ((f^^n) x)/n) \<longlonglongrightarrow> 0"
   proof (rule tendsto_sandwich[of "\<lambda>_. 0" _ sequentially "\<lambda>n. 2 * C / n"])
     have "(\<lambda>n. 2 * C * (1 / real n)) \<longlonglongrightarrow> 2 * C * 0" by (intro tendsto_intros)
     then show "(\<lambda>n. 2 * C / real n) \<longlonglongrightarrow> 0" by auto
     have "dist x ((f ^^ n) x) / real n \<le> 2 * C / real n" for n
       using cC[of 0] cC[of n] dist_triangle[of x "(f^^n) x" c] by (auto simp add: algebra_simps divide_simps dist_commute)
     then show "eventually (\<lambda>n. dist x ((f ^^ n) x) / real n \<le> 2 * C / real n) sequentially"
       by auto
   qed (auto)
   moreover have "(\<lambda>n. dist x ((f^^n) x)/n) \<longlonglongrightarrow> stable_translation_length f"
     by (rule stable_translation_length_as_pointwise_limit[OF isometry_on_lipschitz[OF isometryD(1)[OF elliptic_isometryD(2)[OF assms]]]])
   ultimately show ?thesis
     using LIMSEQ_unique by auto
 qed
 
 text \<open>If an isometry has a fixed point, then it is elliptic.\<close>
 
 lemma isometry_with_fixed_point_is_elliptic:
   assumes "isometry f" "f x = x"
   shows "elliptic_isometry f"
 proof -
   have *: "(f^^n) x = x" for n
     apply (induction n) using assms(2) by auto
   show ?thesis
     apply (rule elliptic_isometryI[of _ x, OF _ assms(1)]) unfolding * by auto
 qed
 
 
 subsection \<open>Parabolic and loxodromic isometries\<close>
 
 text \<open>An isometry is parabolic if it is not elliptic and if its translation length vanishes.\<close>
 
 definition parabolic_isometry::"('a::Gromov_hyperbolic_space \<Rightarrow> 'a) \<Rightarrow> bool"
   where "parabolic_isometry f = (isometry f \<and> \<not>elliptic_isometry f \<and> stable_translation_length f = 0)"
 
 text \<open>An isometry is loxodromic if it is not elliptic and if its translation length is nonzero.\<close>
 
 definition loxodromic_isometry::"('a::Gromov_hyperbolic_space \<Rightarrow> 'a) \<Rightarrow> bool"
   where "loxodromic_isometry f = (isometry f \<and> \<not>elliptic_isometry f \<and> stable_translation_length f \<noteq> 0)"
 
 text \<open>The main features of such isometries are expressed in terms of their fixed points at infinity.
 We define them now, but proving that the definitions make sense will take some work.\<close>
 
 definition neutral_fixed_point::"('a::Gromov_hyperbolic_space \<Rightarrow> 'a) \<Rightarrow> 'a Gromov_completion"
   where "neutral_fixed_point f = (SOME xi. xi \<in> Gromov_boundary \<and> Gromov_extension f xi = xi \<and> additive_strength f xi = 0)"
 
 definition attracting_fixed_point::"('a::Gromov_hyperbolic_space \<Rightarrow> 'a) \<Rightarrow> 'a Gromov_completion"
   where "attracting_fixed_point f = (SOME xi. xi \<in> Gromov_boundary \<and> Gromov_extension f xi = xi \<and> additive_strength f xi < 0)"
 
 definition repelling_fixed_point::"('a::Gromov_hyperbolic_space \<Rightarrow> 'a) \<Rightarrow> 'a Gromov_completion"
   where "repelling_fixed_point f = (SOME xi. xi \<in> Gromov_boundary \<and> Gromov_extension f xi = xi \<and> additive_strength f xi > 0)"
 
 
 lemma parabolic_isometryD:
   assumes "parabolic_isometry f"
   shows "isometry f"
         "\<not>bounded {(f^^n) x|n. True}"
         "stable_translation_length f = 0"
         "\<not>elliptic_isometry f"
 using assms unfolding parabolic_isometry_def by auto
 
 lemma parabolic_isometryI:
   assumes "isometry f"
           "\<not>bounded {(f^^n) x|n. True}"
           "stable_translation_length f = 0"
   shows "parabolic_isometry f"
 using assms unfolding parabolic_isometry_def elliptic_isometry_def by auto
 
 lemma loxodromic_isometryD:
   assumes "loxodromic_isometry f"
   shows "isometry f"
         "\<not>bounded {(f^^n) x|n. True}"
         "stable_translation_length f > 0"
         "\<not>elliptic_isometry f"
 using assms unfolding loxodromic_isometry_def
 by (auto, meson dual_order.antisym not_le stable_translation_length_nonneg)
 
 text \<open>To have a loxodromic isometry, it suffices to know that the stable translation length is
 nonzero, as elliptic isometries have zero translation length.\<close>
 
 lemma loxodromic_isometryI:
   assumes "isometry f"
           "stable_translation_length f \<noteq> 0"
   shows "loxodromic_isometry f"
 using assms elliptic_isometry_stable_translation_length unfolding loxodromic_isometry_def by auto
 
 text \<open>Any isometry is elliptic, or parabolic, or loxodromic, and these possibilities are mutually
 exclusive.\<close>
 
 lemma elliptic_or_parabolic_or_loxodromic:
   assumes "isometry f"
   shows "elliptic_isometry f \<or> parabolic_isometry f \<or> loxodromic_isometry f"
 using assms unfolding parabolic_isometry_def loxodromic_isometry_def by auto
 
 lemma elliptic_imp_not_parabolic_loxodromic:
   assumes "elliptic_isometry f"
   shows "\<not>parabolic_isometry f"
         "\<not>loxodromic_isometry f"
 using assms unfolding parabolic_isometry_def loxodromic_isometry_def by auto
 
 lemma parabolic_imp_not_elliptic_loxodromic:
   assumes "parabolic_isometry f"
   shows "\<not>elliptic_isometry f"
         "\<not>loxodromic_isometry f"
 using assms unfolding parabolic_isometry_def loxodromic_isometry_def by auto
 
 lemma loxodromic_imp_not_elliptic_parabolic:
   assumes "loxodromic_isometry f"
   shows "\<not>elliptic_isometry f"
         "\<not>parabolic_isometry f"
 using assms unfolding parabolic_isometry_def loxodromic_isometry_def by auto
 
 text \<open>The inverse of a parabolic isometry is parabolic.\<close>
 
 lemma parabolic_isometry_inv:
   assumes "parabolic_isometry f"
   shows "parabolic_isometry (inv f)"
 unfolding parabolic_isometry_def using isometry_inverse[of f] elliptic_isometry_inv_iff[of f]
 parabolic_isometryD[OF assms] stable_translation_length_inv[of f] by auto
 
 text \<open>The inverse of a loxodromic isometry is loxodromic.\<close>
 
 lemma loxodromic_isometry_inv:
   assumes "loxodromic_isometry f"
   shows "loxodromic_isometry (inv f)"
 unfolding loxodromic_isometry_def using isometry_inverse[of f] elliptic_isometry_inv_iff[of f]
 loxodromic_isometryD[OF assms] stable_translation_length_inv[of f] by auto
 
 text \<open>We will now prove that an isometry which is not elliptic has a fixed point at infinity. This
 is very easy if the space is proper (ensuring that the Gromov completion is compact), but in fact
 this holds in general. One constructs it by considering a sequence $r_n$ such that $f^{r_n} 0$ tends
 to infinity, and additionally $d(f^l 0, 0) < d(f^{r_n} 0, 0)$ for $l < r_n$: this implies the
 convergence at infinity of $f^{r_n} 0$, by an argument based on a Gromov product computation -- and
 the limit is a fixed point. Moreover, it has nonpositive additive strength, essentially by
 construction.\<close>
 
 lemma high_scores:
   fixes u::"nat \<Rightarrow> real" and i::nat and C::real
   assumes "\<not>(bdd_above (range u))"
   shows "\<exists>n. (\<forall>l \<le> n. u l \<le> u n) \<and> u n \<ge> C \<and> n \<ge> i"
 proof -
   define M where "M = max C (Max {u l|l. l < i})"
   define n where "n = Inf {m. u m > M}"
   have "\<not>(range u \<subseteq> {..M})"
     using assms by (meson bdd_above_Iic bdd_above_mono)
   then have "{m. u m > M} \<noteq> {}"
     using assms by (simp add: image_subset_iff not_less)
   then have "n \<in> {m. u m > M}" unfolding n_def using Inf_nat_def1 by metis
   then have "u n > M" by simp
   have "n \<ge> i"
   proof (rule ccontr)
     assume "\<not> i \<le> n"
     then have *: "n < i" by simp
     have "u n \<le> Max {u l|l. l < i}" apply (rule Max_ge) using * by auto
     then show False using \<open>u n > M\<close> M_def by auto
   qed
   moreover have "u l \<le> u n" if "l \<le> n" for l
   proof (cases "l = n")
     case True
     then show ?thesis by simp
   next
     case False
     then have "l < n" using \<open>l \<le> n\<close> by auto
     then have "l \<notin> {m. u m > M}"
       unfolding n_def by (meson bdd_below_def cInf_lower not_le zero_le)
     then show ?thesis using \<open>u n > M\<close> by auto
   qed
   ultimately show ?thesis
     using \<open>u n > M\<close> M_def less_eq_real_def by auto
 qed
 
 lemma isometry_not_elliptic_has_attracting_fixed_point:
   assumes "isometry f"
           "\<not>(elliptic_isometry f)"
   shows "\<exists>xi \<in> Gromov_boundary. Gromov_extension f xi = xi \<and> additive_strength f xi \<le> 0"
 proof -
   define u where "u = (\<lambda>n. dist basepoint ((f^^n) basepoint))"
   have NB: "\<not>(bdd_above (range u))"
   proof
     assume "bdd_above (range u)"
     then obtain C where *: "\<And>n. u n \<le> C" unfolding bdd_above_def by auto
     have "bounded {(f^^n) basepoint|n. True}"
       unfolding bounded_def apply (rule exI[of _ basepoint], rule exI[of _ C])
       using * unfolding u_def by auto
     then show False
       using elliptic_isometryI assms by auto
   qed
   have "\<exists>r. \<forall>n. ((\<forall>l \<le> r n. u l \<le> u (r n)) \<and> u (r n) \<ge> 2 * n) \<and> r (Suc n) \<ge> r n + 1"
     apply (rule dependent_nat_choice) using high_scores[OF NB] by (auto) blast
   then obtain r::"nat \<Rightarrow> nat" where r: "\<And>n l. l \<le> r n \<Longrightarrow> u l \<le> u (r n)"
                                        "\<And>n. u (r n) \<ge> 2 * n" "\<And>n. r (Suc n) \<ge> r n + 1"
     by auto
   then have "strict_mono r"
     by (metis Suc_eq_plus1 Suc_le_lessD strict_monoI_Suc)
   then have "r n \<ge> n" for n
     by (simp add: seq_suble)
 
   have A: "dist ((f^^(r p)) basepoint) ((f^^(r n)) basepoint) \<le> dist basepoint ((f^^(r n)) basepoint)" if "n \<ge> p" for n p
   proof -
     have "r n \<ge> r p" using \<open>n \<ge> p\<close> \<open>strict_mono r\<close> by (simp add: strict_mono_less_eq)
     then have *: "f^^((r n)) = (f^^(r p)) o (f^^(r n - r p))"
       unfolding funpow_add[symmetric] by auto
     have "dist ((f^^(r p)) basepoint) ((f^^(r n)) basepoint) = dist ((f^^(r p)) basepoint) ((f^^(r p)) ((f^^(r n - r p)) basepoint))"
       unfolding * comp_def by auto
     also have "... = dist basepoint ((f^^(r n - r p)) basepoint)"
       using isometry_iterates[OF assms(1), of "r p"] isometryD by auto
     also have "... \<le> dist basepoint ((f^^(r n)) basepoint)"
       using r(1)[of "r n - r p" n] unfolding u_def by auto
     finally show ?thesis
       by simp
   qed
 
   have *: "Gromov_product_at basepoint ((f^^(r p)) basepoint) ((f^^(r n)) basepoint) \<ge> p" if "n \<ge> p" for n p
   proof -
     have "2 * Gromov_product_at basepoint ((f^^(r p)) basepoint) ((f^^(r n)) basepoint)
             = dist basepoint ((f^^(r p)) basepoint) + dist basepoint ((f^^(r n)) basepoint)
               - dist ((f^^(r p)) basepoint) ((f^^(r n)) basepoint)"
       unfolding Gromov_product_at_def by auto
     also have "... \<ge> dist basepoint ((f^^(r p)) basepoint)"
       using A[OF that] by auto
     finally show "Gromov_product_at basepoint ((f^^(r p)) basepoint) ((f^^(r n)) basepoint) \<ge> p"
       using r(2)[of p] unfolding u_def by auto
   qed
   have *: "Gromov_product_at basepoint ((f^^(r p)) basepoint) ((f^^(r n)) basepoint) \<ge> N" if "n \<ge> N" "p \<ge> N" for n p N
     using *[of n p] *[of p n] that by (auto simp add: Gromov_product_commute intro: le_cases[of n p])
   have "Gromov_converging_at_boundary (\<lambda>n. (f^^(r n)) basepoint)"
     apply (rule Gromov_converging_at_boundaryI[of basepoint]) using * by (meson dual_order.trans real_arch_simple)
   with Gromov_converging_at_boundary_converges[OF this]
   obtain xi where xi: "(\<lambda>n. to_Gromov_completion ((f^^(r n)) basepoint)) \<longlonglongrightarrow> xi" "xi \<in> Gromov_boundary"
     by auto
   then have *: "(\<lambda>n. Gromov_extension f (to_Gromov_completion ((f^^(r n)) basepoint))) \<longlonglongrightarrow> xi"
     apply (simp, rule Gromov_converging_at_boundary_bounded_perturbation[of _ _ _ "dist basepoint (f basepoint)"])
     by (simp add: assms(1) funpow_swap1 isometryD(2) isometry_iterates)
   moreover have "(\<lambda>n. Gromov_extension f (to_Gromov_completion ((f^^(r n)) basepoint))) \<longlonglongrightarrow> Gromov_extension f xi"
     using continuous_on_tendsto_compose[OF Gromov_extension_isometry(2)[OF assms(1)] xi(1)] by auto
   ultimately have fxi: "Gromov_extension f xi = xi"
     using LIMSEQ_unique by auto
 
   have "Busemann_function_at (to_Gromov_completion ((f^^(r n)) basepoint)) ((f^^(r p)) basepoint) basepoint \<le> 0" if "n \<ge> p" for n p
     unfolding Busemann_function_inner using A[OF that] by auto
   then have A: "eventually (\<lambda>n. Busemann_function_at (to_Gromov_completion ((f^^(r n)) basepoint)) ((f^^(r p)) basepoint) basepoint \<le> 0) sequentially" for p
     unfolding eventually_sequentially by auto
   have B: "eventually (\<lambda>n. Busemann_function_at (to_Gromov_completion ((f^^(r n)) basepoint)) ((f^^(r p)) basepoint) basepoint \<ge> Busemann_function_at xi ((f^^(r p)) basepoint) basepoint - 2 * deltaG(TYPE('a)) - 1) sequentially" for p
     by (rule eventually_mono[OF Busemann_function_inside_approx[OF _ xi(1), of 1 "((f^^(r p)) basepoint)" basepoint, simplified]], simp)
   have "eventually (\<lambda>n. Busemann_function_at xi ((f^^(r p)) basepoint) basepoint - 2 * deltaG(TYPE('a)) - 1 \<le> 0) sequentially" for p
     by (rule eventually_mono[OF eventually_conj[OF A[of p] B[of p]]], simp)
   then have *: "Busemann_function_at xi ((f^^(r p)) basepoint) basepoint - 2 * deltaG(TYPE('a)) - 1 \<le> 0" for p
     by auto
   then have A: "Busemann_function_at xi ((f^^(r p)) basepoint) basepoint / (r p) - (2 * deltaG(TYPE('a)) + 1) * (1/r p) \<le> 0" if "p \<ge> 1" for p
     using order_trans[OF that \<open>p \<le> r p\<close>] by (auto simp add: algebra_simps divide_simps)
   have B: "(\<lambda>p. Busemann_function_at xi ((f^^(p)) basepoint) basepoint / p - (2 * deltaG(TYPE('a)) + 1) * (1/p)) \<longlonglongrightarrow> additive_strength f xi - (2 * deltaG(TYPE('a)) + 1) * 0"
     by (intro tendsto_intros assms fxi)
   have "additive_strength f xi - (2 * deltaG TYPE('a) + 1) * 0 \<le> 0"
     apply (rule LIMSEQ_le_const2[OF LIMSEQ_subseq_LIMSEQ[OF B \<open>strict_mono r\<close>]]) using A unfolding comp_def by auto
   then show ?thesis using xi fxi by auto
 qed
 
 text \<open>Applying the previous result to the inverse map, we deduce that there is also a fixed point
 with nonnegative strength.\<close>
 
 lemma isometry_not_elliptic_has_repelling_fixed_point:
   assumes "isometry f"
           "\<not>(elliptic_isometry f)"
   shows "\<exists>xi \<in> Gromov_boundary. Gromov_extension f xi = xi \<and> additive_strength f xi \<ge> 0"
 proof -
   have *: "\<not>elliptic_isometry (inv f)"
     using elliptic_isometry_inv_iff isometry_inverse(2)[OF assms(1)] assms(2) by auto
   obtain xi where xi: "xi \<in> Gromov_boundary" "Gromov_extension (inv f) xi = xi" "additive_strength (inv f) xi \<le> 0"
     using isometry_not_elliptic_has_attracting_fixed_point[OF isometry_inverse(1)[OF assms(1)] *] by auto
   have *: "Gromov_extension f xi = xi"
     using Gromov_extension_inv_fixed_point[OF isometry_inverse(1)[OF assms(1)] xi(2)] inv_inv_eq[OF isometry_inverse(2)[OF assms(1)]] by auto
   moreover have "additive_strength f xi \<ge> 0"
     using additive_strength_inv[OF assms(1) *] xi(3) by auto
   ultimately show ?thesis
     using xi(1) by auto
 qed
 
 subsubsection \<open>Parabolic isometries\<close>
 
 text \<open>We show that a parabolic isometry has (at least) one neutral fixed point at infinity.\<close>
 
 lemma parabolic_fixed_point:
   assumes "parabolic_isometry f"
   shows "neutral_fixed_point f \<in> Gromov_boundary"
         "Gromov_extension f (neutral_fixed_point f) = neutral_fixed_point f"
         "additive_strength f (neutral_fixed_point f) = 0"
 proof -
   obtain xi where xi: "xi \<in> Gromov_boundary" "Gromov_extension f xi = xi"
     using isometry_not_elliptic_has_attracting_fixed_point parabolic_isometryD[OF assms] by blast
   moreover have "additive_strength f xi = 0"
     using stable_translation_length_eq_additive_strength[OF parabolic_isometryD(1)[OF assms] xi(2)]
     parabolic_isometryD(3)[OF assms] by auto
   ultimately have A: "\<exists>xi. xi \<in> Gromov_boundary \<and> Gromov_extension f xi = xi \<and> additive_strength f xi = 0"
     by auto
   show "neutral_fixed_point f \<in> Gromov_boundary"
         "Gromov_extension f (neutral_fixed_point f) = neutral_fixed_point f"
         "additive_strength f (neutral_fixed_point f) = 0"
     unfolding neutral_fixed_point_def using someI_ex[OF A] by auto
 qed
 
 text \<open>Parabolic isometries have exactly one fixed point, the neutral fixed point at infinity. The
 proof goes as follows: if it has another fixed point, then the orbit of a basepoint would stay
 on the horospheres centered at both fixed points. But the intersection of two horospheres based
 at different points is a a bounded set. Hence, the map has a bounded orbit, and is therefore
 elliptic.\<close>
 
 theorem parabolic_unique_fixed_point:
   assumes "parabolic_isometry f"
   shows "Gromov_extension f xi = xi \<longleftrightarrow> xi = neutral_fixed_point f"
 proof (auto simp add: parabolic_fixed_point[OF assms])
   assume H: "Gromov_extension f xi = xi"
   have *: "additive_strength f xi = 0"
     using stable_translation_length_eq_additive_strength[OF parabolic_isometryD(1)[OF assms] H]
     parabolic_isometryD(3)[OF assms] by auto
   show "xi = neutral_fixed_point f"
   proof (rule ccontr)
     assume N: "xi \<noteq> neutral_fixed_point f"
     define C where "C = 2 * real_of_ereal (extended_Gromov_product_at basepoint xi (neutral_fixed_point f)) + 4 * deltaG(TYPE('a))"
     have A: "dist basepoint ((f^^n) basepoint) \<le> C" for n
     proof -
       have "dist ((f^^n) basepoint) basepoint - 2 * real_of_ereal (extended_Gromov_product_at basepoint xi (neutral_fixed_point f)) - 2 * deltaG(TYPE('a))
             \<le> max (Busemann_function_at xi ((f^^n) basepoint) basepoint) (Busemann_function_at (neutral_fixed_point f) ((f^^n) basepoint) basepoint)"
         using dist_le_max_Busemann_functions[OF N] by (simp add: algebra_simps)
       also have "... \<le> max (n * additive_strength f xi + 2 * deltaG(TYPE('a))) (n * additive_strength f (neutral_fixed_point f) + 2 * deltaG(TYPE('a)))"
         apply (intro mono_intros)
         using Busemann_function_eq_additive_strength[OF parabolic_isometryD(1)[OF assms] H, of n basepoint]
         Busemann_function_eq_additive_strength[OF parabolic_isometryD(1)[OF assms] parabolic_fixed_point(2)[OF assms], of n basepoint]
         by auto
       also have "... = 2 * deltaG(TYPE('a))"
         unfolding * parabolic_fixed_point[OF assms] by auto
       finally show ?thesis
         unfolding C_def by (simp add: algebra_simps dist_commute)
     qed
     have "elliptic_isometry f"
       apply (rule elliptic_isometryI[of _ basepoint])
       using parabolic_isometryD(1)[OF assms] A unfolding bounded_def by auto
     then show False
       using elliptic_imp_not_parabolic_loxodromic assms by auto
   qed
 qed
 
 text \<open>When one iterates a parabolic isometry, the distance to the starting point can grow at most
 logarithmically.\<close>
 
 lemma parabolic_logarithmic_growth:
   assumes "parabolic_isometry (f::'a::Gromov_hyperbolic_space \<Rightarrow> 'a)" "n \<ge> 1"
   shows "dist x ((f^^n) x) \<le> dist x (f x) + ceiling (log 2 n) * 16 * deltaG(TYPE('a))"
 using dist_le_additive_strength[OF parabolic_isometryD(1)[OF assms(1)] parabolic_fixed_point(2)[OF assms(1)] _ assms(2)]
 parabolic_isometryD(3)[OF assms(1)] stable_translation_length_eq_additive_strength[OF parabolic_isometryD(1)[OF assms(1)] parabolic_fixed_point(2)[OF assms(1)]]
 by auto
 
 text \<open>It follows that there is no parabolic isometry in trees, since the formula in the previous
 lemma shows that there is no orbit growth as $\delta = 0$, and therefore orbits are bounded,
 contradicting the parabolicity of the isometry.\<close>
 
 lemma tree_no_parabolic_isometry:
   assumes "isometry (f::'a::Gromov_hyperbolic_space_0 \<Rightarrow> 'a)"
   shows "elliptic_isometry f \<or> loxodromic_isometry f"
 proof -
   have "\<not>parabolic_isometry f"
   proof
     assume P: "parabolic_isometry f"
     have "dist basepoint ((f^^n) basepoint) \<le> dist basepoint (f basepoint)" if "n \<ge> 1" for n
       using parabolic_logarithmic_growth[OF P that, of basepoint] by auto
     then have *: "dist basepoint ((f^^n) basepoint) \<le> dist basepoint (f basepoint)" for n
       by (cases "n \<ge> 1", auto simp add: not_less_eq_eq)
     have "elliptic_isometry f"
       apply (rule elliptic_isometryI[OF _ assms, of basepoint]) using * unfolding bounded_def by auto
     then show False
       using elliptic_imp_not_parabolic_loxodromic P by auto
   qed
   then show ?thesis
     using elliptic_or_parabolic_or_loxodromic[OF assms] by auto
 qed
 
 
 subsubsection \<open>Loxodromic isometries\<close>
 
 text \<open>A loxodromic isometry has (at least) two fixed points at infinity, one attracting
 and one repelling. We have already constructed fixed points with nonnegative and nonpositive
 strengths. Since the strength is nonzero (its absolute value is the stable translation length),
 then these fixed points correspond to what we want.\<close>
 
 lemma loxodromic_attracting_fixed_point:
   assumes "loxodromic_isometry f"
   shows "attracting_fixed_point f \<in> Gromov_boundary"
         "Gromov_extension f (attracting_fixed_point f) = attracting_fixed_point f"
         "additive_strength f (attracting_fixed_point f) < 0"
 proof -
   obtain xi where xi: "xi \<in> Gromov_boundary" "Gromov_extension f xi = xi" "additive_strength f xi \<le> 0"
     using isometry_not_elliptic_has_attracting_fixed_point loxodromic_isometryD[OF assms] by blast
   moreover have "additive_strength f xi < 0"
     using stable_translation_length_eq_additive_strength[OF loxodromic_isometryD(1)[OF assms] xi(2)]
     loxodromic_isometryD(3)[OF assms] xi(3) by auto
   ultimately have A: "\<exists>xi. xi \<in> Gromov_boundary \<and> Gromov_extension f xi = xi \<and> additive_strength f xi < 0"
     by auto
   show "attracting_fixed_point f \<in> Gromov_boundary"
        "Gromov_extension f (attracting_fixed_point f) = attracting_fixed_point f"
        "additive_strength f (attracting_fixed_point f) < 0"
     unfolding attracting_fixed_point_def using someI_ex[OF A] by auto
 qed
 
 lemma loxodromic_repelling_fixed_point:
   assumes "loxodromic_isometry f"
   shows "repelling_fixed_point f \<in> Gromov_boundary"
         "Gromov_extension f (repelling_fixed_point f) = repelling_fixed_point f"
         "additive_strength f (repelling_fixed_point f) > 0"
 proof -
   obtain xi where xi: "xi \<in> Gromov_boundary" "Gromov_extension f xi = xi" "additive_strength f xi \<ge> 0"
     using isometry_not_elliptic_has_repelling_fixed_point loxodromic_isometryD[OF assms] by blast
   moreover have "additive_strength f xi > 0"
     using stable_translation_length_eq_additive_strength[OF loxodromic_isometryD(1)[OF assms] xi(2)]
     loxodromic_isometryD(3)[OF assms] xi(3) by auto
   ultimately have A: "\<exists>xi. xi \<in> Gromov_boundary \<and> Gromov_extension f xi = xi \<and> additive_strength f xi > 0"
     by auto
   show "repelling_fixed_point f \<in> Gromov_boundary"
        "Gromov_extension f (repelling_fixed_point f) = repelling_fixed_point f"
        "additive_strength f (repelling_fixed_point f) > 0"
     unfolding repelling_fixed_point_def using someI_ex[OF A] by auto
 qed
 
 text \<open>The attracting and repelling fixed points of a loxodromic isometry are distinct -- precisely
 since one is attracting and the other is repelling.\<close>
 
 lemma attracting_fixed_point_neq_repelling_fixed_point:
   assumes "loxodromic_isometry f"
   shows "attracting_fixed_point f \<noteq> repelling_fixed_point f"
 using loxodromic_repelling_fixed_point[OF assms] loxodromic_attracting_fixed_point[OF assms] by auto
 
 text \<open>The attracting fixed point of a loxodromic isometry is indeed attracting. Moreover, the
 convergence is uniform away from the repelling fixed point. This is expressed in the following
 proposition, where neighborhoods of the repelling and attracting fixed points are given by the property
 that the Gromov product with the fixed point is large.
 
 The proof goes as follows. First, the Busemann function with respect to the fixed points at infinity
 evolves like the strength. Therefore, $f^n e$ tends to the repulsive fixed point in negative time,
 and to the attracting one in positive time. Consider now a general point $x$ with
 $(\xi^-, x)_e \leq K$. This means that the geodesics from $e$ to $x$ and $\xi^-$ diverge before
 time $K$. For large $n$, since $f^{-n} e$ is close to $\xi^-$, we also get the inequality
 $(f^{-n} e, x)_e \leq K$. Applying $f^n$ and using the invariance of the Gromov product under
 isometries yields $(e, f^n x)_{f^n e} \leq K$. But this Gromov product is equal to
 $d(e, f^n e) - (f^n e, f^n x)_e$ (this is a general property of Gromov products). In particular,
 $(f^n e, f^n x) \geq d(e, f^n e) - K$, and moreover $d(e, f^n e)$ is large.
 Since $f^n e$ is close to $\xi^+$, it follows that $f^n x$
 is also close to $\xi^+$, as desired.
 
 The real proof requires some more care as everything should be done in ereal, and moreover every
 inequality is only true up to some multiple of $\delta$. But everything works in the way just
 described above.
 \<close>
 
 proposition loxodromic_attracting_fixed_point_attracts_uniformly:
   assumes "loxodromic_isometry f"
   shows "\<exists>N. \<forall>n \<ge> N. \<forall>x. extended_Gromov_product_at basepoint x (repelling_fixed_point f) \<le> ereal K
           \<longrightarrow> extended_Gromov_product_at basepoint (((Gromov_extension f)^^n) x) (attracting_fixed_point f) \<ge> ereal M"
 proof -
   have I: "isometry f"
     using loxodromic_isometryD(1)[OF assms] by simp
   have J: "\<bar>ereal r\<bar> \<noteq> \<infinity>" for r by auto
 
   text \<open>We show that $f^n e$ tends to the repelling fixed point in negative time.\<close>
   have "(\<lambda>n. ereal (Busemann_function_at (repelling_fixed_point f) ((inv f ^^ n) basepoint) basepoint)) \<longlonglongrightarrow> - \<infinity>"
   proof (rule tendsto_sandwich[of "\<lambda>n. -\<infinity>" _ _ "\<lambda>n. ereal(- real n * additive_strength f (repelling_fixed_point f) + 2 * deltaG(TYPE('a)))", OF _ always_eventually], auto)
     fix n
     have "Busemann_function_at (repelling_fixed_point f) ((inv f ^^ n) basepoint) basepoint \<le> real n * additive_strength (inv f) (repelling_fixed_point f) + 2 * deltaG(TYPE('a))"
       using Busemann_function_eq_additive_strength[OF isometry_inverse(1)[OF I]
       Gromov_extension_inv_fixed_point[OF I loxodromic_repelling_fixed_point(2)[OF assms]], of n basepoint] by auto
     then show "Busemann_function_at (repelling_fixed_point f) ((inv f ^^ n) basepoint) basepoint \<le> 2 * deltaG(TYPE('a)) - real n * additive_strength f (repelling_fixed_point f)"
       by (simp add: I additive_strength_inv assms loxodromic_repelling_fixed_point(2))
   next
     have "(\<lambda>n. ereal (2 * deltaG TYPE('a)) + ereal (- real n) * additive_strength f (repelling_fixed_point f)) \<longlonglongrightarrow> ereal (2 * deltaG (TYPE('a))) + (- \<infinity>) * additive_strength f (repelling_fixed_point f)"
       apply (intro tendsto_intros) using loxodromic_repelling_fixed_point(3)[OF assms] by auto
     then show "(\<lambda>n. ereal (2 * deltaG TYPE('a) - real n * additive_strength f (repelling_fixed_point f))) \<longlonglongrightarrow> - \<infinity>"
       using loxodromic_repelling_fixed_point(3)[OF assms] by auto
   qed
   then have "(\<lambda>n. to_Gromov_completion (((inv f)^^n) basepoint)) \<longlonglongrightarrow> repelling_fixed_point f"
     by (rule Busemann_function_minus_infinity_imp_convergent[of _ _ basepoint])
   then have "(\<lambda>n. extended_Gromov_product_at basepoint (to_Gromov_completion (((inv f)^^n) basepoint)) (repelling_fixed_point f)) \<longlonglongrightarrow> \<infinity>"
     unfolding Gromov_completion_boundary_limit[OF loxodromic_repelling_fixed_point(1)[OF assms]] by simp
   then obtain Nr where Nr: "\<And>n. n \<ge> Nr \<Longrightarrow> extended_Gromov_product_at basepoint (to_Gromov_completion (((inv f)^^n) basepoint)) (repelling_fixed_point f) \<ge> ereal (K + deltaG(TYPE('a)) + 1)"
     unfolding Lim_PInfty by auto
 
   text \<open>We show that $f^n e$ tends to the attracting fixed point in positive time.\<close>
   have "(\<lambda>n. ereal (Busemann_function_at (attracting_fixed_point f) ((f ^^ n) basepoint) basepoint)) \<longlonglongrightarrow> - \<infinity>"
   proof (rule tendsto_sandwich[of "\<lambda>n. -\<infinity>" _ _ "\<lambda>n. ereal(real n * additive_strength f (attracting_fixed_point f) + 2 * deltaG(TYPE('a)))", OF _ always_eventually], auto)
     fix n
     show "Busemann_function_at (attracting_fixed_point f) ((f ^^ n) basepoint) basepoint \<le> real n * additive_strength f (attracting_fixed_point f) + 2 * deltaG(TYPE('a))"
       using Busemann_function_eq_additive_strength[OF I loxodromic_attracting_fixed_point(2)[OF assms], of n basepoint] by auto
   next
     have "(\<lambda>n. ereal (2 * deltaG TYPE('a)) + ereal (real n) * additive_strength f (attracting_fixed_point f)) \<longlonglongrightarrow> ereal (2 * deltaG (TYPE('a))) + (\<infinity>) * additive_strength f (attracting_fixed_point f)"
       apply (intro tendsto_intros) using loxodromic_attracting_fixed_point(3)[OF assms] by auto
     then show "(\<lambda>n. ereal (real n * additive_strength f (attracting_fixed_point f) + 2 * deltaG TYPE('a))) \<longlonglongrightarrow> - \<infinity>"
       using loxodromic_attracting_fixed_point(3)[OF assms] by (auto simp add: algebra_simps)
   qed
   then have *: "(\<lambda>n. to_Gromov_completion (((f)^^n) basepoint)) \<longlonglongrightarrow> attracting_fixed_point f"
     by (rule Busemann_function_minus_infinity_imp_convergent[of _ _ basepoint])
   then have "(\<lambda>n. extended_Gromov_product_at basepoint (to_Gromov_completion (((f)^^n) basepoint)) (attracting_fixed_point f)) \<longlonglongrightarrow> \<infinity>"
     unfolding Gromov_completion_boundary_limit[OF loxodromic_attracting_fixed_point(1)[OF assms]] by simp
   then obtain Na where Na: "\<And>n. n \<ge> Na \<Longrightarrow> extended_Gromov_product_at basepoint (to_Gromov_completion (((f)^^n) basepoint)) (attracting_fixed_point f) \<ge> ereal (M + deltaG(TYPE('a)))"
     unfolding Lim_PInfty by auto
 
   text \<open>We show that the distance between $e$ and $f^n e$ tends to infinity.\<close>
   have "(\<lambda>n. extended_Gromov_distance (to_Gromov_completion basepoint) (to_Gromov_completion ((f^^n) basepoint))) \<longlonglongrightarrow>
           extended_Gromov_distance (to_Gromov_completion basepoint) (attracting_fixed_point f)"
     using * extended_Gromov_distance_continuous[of "to_Gromov_completion basepoint"]
     by (metis UNIV_I continuous_on filterlim_compose tendsto_at_iff_tendsto_nhds)
   then have "(\<lambda>n. extended_Gromov_distance (to_Gromov_completion basepoint) (to_Gromov_completion ((f^^n) basepoint))) \<longlonglongrightarrow> \<infinity>"
     using loxodromic_attracting_fixed_point(1)[OF assms] by simp
   then obtain Nd where Nd: "\<And>n. n \<ge> Nd \<Longrightarrow> dist basepoint ((f^^n) basepoint) \<ge> M + K + 3 * deltaG(TYPE('a))"
     unfolding Lim_PInfty by auto
 
   text \<open>Now, if $n$ is large enough so that all the convergences to infinity above are almost
   realized, we show that a point $x$ which is not too close to $\xi^-$ is sent by $f^n$ to a point
   close to $\xi^+$, uniformly.\<close>
   define N where "N = Nr + Na + Nd"
   have "extended_Gromov_product_at basepoint (((Gromov_extension f)^^n) x) (attracting_fixed_point f) \<ge> ereal M" if H: "extended_Gromov_product_at basepoint x (repelling_fixed_point f) \<le> K" "n \<ge> N" for n x
   proof -
     have n: "n \<ge> Nr" "n \<ge> Na" "n \<ge> Nd" using that unfolding N_def by auto
     have "min (extended_Gromov_product_at basepoint x (to_Gromov_completion (((inv f)^^n) basepoint)))
               (extended_Gromov_product_at basepoint (to_Gromov_completion (((inv f)^^n) basepoint)) (repelling_fixed_point f))
           \<le> extended_Gromov_product_at basepoint x (repelling_fixed_point f) + deltaG(TYPE('a))"
       by (intro mono_intros)
     also have "... \<le> ereal K + deltaG(TYPE('a))"
       apply (intro mono_intros) using H by auto
     finally have "min (extended_Gromov_product_at basepoint x (to_Gromov_completion (((inv f)^^n) basepoint)))
               (extended_Gromov_product_at basepoint (to_Gromov_completion (((inv f)^^n) basepoint)) (repelling_fixed_point f))
                 \<le> ereal K + deltaG(TYPE('a))"
       by simp
     moreover have "extended_Gromov_product_at basepoint (to_Gromov_completion (((inv f)^^n) basepoint)) (repelling_fixed_point f) > ereal K + deltaG(TYPE('a))"
       using Nr[OF n(1)] ereal_le_less by auto
     ultimately have A: "extended_Gromov_product_at basepoint x (to_Gromov_completion (((inv f)^^n) basepoint)) \<le> ereal K + deltaG(TYPE('a))"
       using not_le by fastforce
     have *: "((inv f)^^n) ((f^^n) z) = z" for z
       by (metis I bij_is_inj inj_fn inv_f_f inv_fn isometry_inverse(2))
     have **: "x = Gromov_extension ((inv f)^^n) (Gromov_extension (f^^n) x)"
       using Gromov_extension_isometry_composition[OF isometry_iterates[OF I] isometry_iterates[OF isometry_inverse(1)[OF I]], of n n]
       unfolding comp_def * apply auto by meson
     have "extended_Gromov_product_at (((inv f)^^n) ((f^^n) basepoint)) (Gromov_extension ((inv f)^^n) (Gromov_extension (f^^n) x)) (Gromov_extension (((inv f)^^n)) (to_Gromov_completion basepoint)) \<le> ereal K + deltaG(TYPE('a))"
       using A by (simp add: * **[symmetric])
     then have B: "extended_Gromov_product_at ((f^^n) basepoint) (Gromov_extension (f^^n) x) (to_Gromov_completion basepoint) \<le> ereal K + deltaG(TYPE('a))"
       unfolding Gromov_extension_preserves_extended_Gromov_product[OF isometry_iterates[OF isometry_inverse(1)[OF I]]] by simp
 
     have "dist basepoint ((f^^n) basepoint) - deltaG(TYPE('a)) \<le>
         extended_Gromov_product_at ((f^^n) basepoint) (Gromov_extension (f^^n) x) (to_Gromov_completion basepoint) + extended_Gromov_product_at basepoint (Gromov_extension (f^^n) x) (to_Gromov_completion ((f^^n) basepoint))"
       using extended_Gromov_product_add_ge[of basepoint "(f^^n) basepoint" "Gromov_extension (f^^n) x"] by (auto simp add: algebra_simps)
     also have "... \<le> (ereal K + deltaG(TYPE('a))) + extended_Gromov_product_at basepoint (Gromov_extension (f^^n) x) (to_Gromov_completion ((f^^n) basepoint))"
       by (intro mono_intros B)
     finally have "extended_Gromov_product_at basepoint (Gromov_extension (f^^n) x) (to_Gromov_completion ((f^^n) basepoint)) \<ge> dist basepoint ((f^^n) basepoint) - (2 * deltaG(TYPE('a)) + K)"
-      unfolding ereal_minus(1)[symmetric] apply (simp only: ereal_minus_le[OF J]) apply (auto simp add: algebra_simps)
-      by (metis (no_types, hide_lams) linordered_field_class.sign_simps(1) linordered_field_class.sign_simps(3) mult_2_right plus_ereal.simps(1))
+      apply (simp only: ereal_minus_le [OF J] ereal_minus(1) [symmetric])
+      apply (auto simp add: algebra_simps)
+      apply (metis (no_types, hide_lams) add.assoc add.left_commute mult_2_right plus_ereal.simps(1))
+      done
     moreover have "dist basepoint ((f ^^ n) basepoint) - (2 * deltaG TYPE('a) + K) \<ge> M + deltaG(TYPE('a))"
       using Nd[OF n(3)] by auto
     ultimately have "extended_Gromov_product_at basepoint (Gromov_extension (f^^n) x) (to_Gromov_completion ((f^^n) basepoint)) \<ge> ereal (M + deltaG(TYPE('a)))"
       using order_trans ereal_le_le by auto
     then have "ereal (M + deltaG(TYPE('a))) \<le> min (extended_Gromov_product_at basepoint (Gromov_extension (f^^n) x) (to_Gromov_completion ((f^^n) basepoint)))
                                                   (extended_Gromov_product_at basepoint (to_Gromov_completion ((f^^n) basepoint)) (attracting_fixed_point f))"
       using Na[OF n(2)] by (simp add: extended_Gromov_product_at_commute)
     also have "... \<le> extended_Gromov_product_at basepoint (Gromov_extension (f^^n) x) (attracting_fixed_point f) + deltaG(TYPE('a))"
       by (intro mono_intros)
     finally have "ereal M \<le> extended_Gromov_product_at basepoint (Gromov_extension (f^^n) x) (attracting_fixed_point f)"
       unfolding plus_ereal.simps(1)[symmetric] ereal_add_le_add_iff2 by auto
     then show ?thesis
       by (simp add: Gromov_extension_isometry_iterates I)
   qed
   then show ?thesis
     by auto
 qed
 
 text \<open>We deduce pointwise convergence from the previous result.\<close>
 
 lemma loxodromic_attracting_fixed_point_attracts:
   assumes "loxodromic_isometry f"
           "xi \<noteq> repelling_fixed_point f"
   shows "(\<lambda>n. ((Gromov_extension f)^^n) xi) \<longlonglongrightarrow> attracting_fixed_point f"
 proof -
   have "(\<lambda>n. extended_Gromov_product_at basepoint (((Gromov_extension f)^^n) xi) (attracting_fixed_point f)) \<longlonglongrightarrow> \<infinity>"
     unfolding Lim_PInfty using loxodromic_attracting_fixed_point_attracts_uniformly[OF assms(1)]
     by (metis Gromov_boundary_extended_product_PInf assms(2) ereal_top funpow_code_def infinity_ereal_def linear)
   then show ?thesis
     unfolding Gromov_completion_boundary_limit[OF loxodromic_attracting_fixed_point(1)[OF assms(1)]] by simp
 qed
 
 text \<open>Finally, we show that a loxodromic isometry has exactly two fixed points, its attracting and
 repelling fixed points defined above. Indeed, we already know that these points are fixed. It
 remains to see that there is no other fixed point. But a fixed point which is not the repelling one
 is both stationary and attracted to the attracting fixed point by the previous lemma, hence it has
 to coincide with the attracting fixed point.\<close>
 
 theorem loxodromic_unique_fixed_points:
   assumes "loxodromic_isometry f"
   shows "Gromov_extension f xi = xi \<longleftrightarrow> xi = attracting_fixed_point f \<or> xi = repelling_fixed_point f"
 proof -
   have "xi = attracting_fixed_point f" if H: "Gromov_extension f xi = xi" "xi \<noteq> repelling_fixed_point f" for xi
   proof -
     have "((Gromov_extension f)^^n) xi = xi" for n
       apply (induction n) using H(1) by auto
     then have "(\<lambda>n. ((Gromov_extension f)^^n) xi) \<longlonglongrightarrow> xi"
       by auto
     then show ?thesis
       using loxodromic_attracting_fixed_point_attracts[OF assms H(2)] LIMSEQ_unique by auto
   qed
   then show ?thesis
     using loxodromic_attracting_fixed_point(2)[OF assms] loxodromic_repelling_fixed_point(2)[OF assms] by auto
 qed
 
 end (*of theory Isometries_Classification*)
diff --git a/thys/Gromov_Hyperbolicity/Metric_Completion.thy b/thys/Gromov_Hyperbolicity/Metric_Completion.thy
--- a/thys/Gromov_Hyperbolicity/Metric_Completion.thy
+++ b/thys/Gromov_Hyperbolicity/Metric_Completion.thy
@@ -1,482 +1,482 @@
 (*  Author:  Sébastien Gouëzel   sebastien.gouezel@univ-rennes1.fr
     License: BSD
 *)
 
 section \<open>The metric completion of a metric space\<close>
 
 theory Metric_Completion
   imports Isometries
 begin
 
 text \<open>Any metric space can be completed, by adding the missing limits of Cauchy sequences.
 Formally, there exists an isometric embedding of the space in a complete space, with dense image.
 In this paragraph, we construct this metric completion. This is exactly the same construction
 as the way in which real numbers are constructed from rational numbers.\<close>
 
 subsection \<open>Definition of the metric completion\<close>
 
 quotient_type (overloaded) 'a metric_completion =
   "nat \<Rightarrow> ('a::metric_space)" / partial: "\<lambda>u v. (Cauchy u) \<and> (Cauchy v) \<and> (\<lambda>n. dist (u n) (v n)) \<longlonglongrightarrow> 0"
 unfolding part_equivp_def proof(auto intro!: ext)
   show "\<exists>x. Cauchy x"
     by (rule exI[of _ "\<lambda>_. undefined"]) (simp add: convergent_Cauchy convergent_const)
   fix x y z::"nat \<Rightarrow> 'a" assume H: "(\<lambda>n. dist (x n) (y n)) \<longlonglongrightarrow> 0"
                                    "(\<lambda>n. dist (x n) (z n)) \<longlonglongrightarrow> 0"
   have *: "(\<lambda>n. dist (x n) (y n) + dist (x n) (z n)) \<longlonglongrightarrow> 0 + 0"
     by (rule tendsto_add) (auto simp add: H)
   show "(\<lambda>n. dist (y n) (z n)) \<longlonglongrightarrow> 0"
     apply (rule tendsto_sandwich[of "\<lambda>_. 0" _ _ "\<lambda>n. dist (x n) (y n) + dist (x n) (z n)"])
     using * by (auto simp add: dist_triangle3)
 next
   fix x y z::"nat \<Rightarrow> 'a" assume H: "(\<lambda>n. dist (x n) (y n)) \<longlonglongrightarrow> 0"
                                    "(\<lambda>n. dist (y n) (z n)) \<longlonglongrightarrow> 0"
   have *: "(\<lambda>n. dist (x n) (y n) + dist (y n) (z n)) \<longlonglongrightarrow> 0 + 0"
     by (rule tendsto_add) (auto simp add: H)
   show "(\<lambda>n. dist (x n) (z n)) \<longlonglongrightarrow> 0"
     apply (rule tendsto_sandwich[of "\<lambda>_. 0" _ _ "\<lambda>n. dist (x n) (y n) + dist (y n) (z n)"])
     using * by (auto simp add: dist_triangle)
 next
   fix x y::"nat \<Rightarrow> 'a" assume H: "Cauchy x"
     "(\<lambda>v. Cauchy v \<and> (\<lambda>n. dist (x n) (v n)) \<longlonglongrightarrow> 0) = (\<lambda>v. Cauchy v \<and> (\<lambda>n. dist (y n) (v n)) \<longlonglongrightarrow> 0)"
   have "Cauchy x \<and> (\<lambda>n. dist (x n) (x n)) \<longlonglongrightarrow> 0" using H by auto
   then have "(\<lambda>n. dist (y n) (x n))\<longlonglongrightarrow> 0" using H by meson
   moreover have "dist (x n) (y n) = dist (y n) (x n)" for n using dist_commute by auto
   ultimately show "(\<lambda>n. dist (x n) (y n)) \<longlonglongrightarrow> 0" by auto
 qed
 
 text \<open>We have to show that the metric completion is indeed a metric space, that
 the original space embeds isometrically into it, and that it is complete. Before we prove these
 statements, we start with two simple lemmas that will be needed later on.\<close>
 
 lemma convergent_Cauchy_dist:
   fixes u v::"nat \<Rightarrow> ('a::metric_space)"
   assumes "Cauchy u" "Cauchy v"
   shows "convergent (\<lambda>n. dist (u n) (v n))"
 proof (rule real_Cauchy_convergent, intro CauchyI)
   fix e::real assume "e > 0"
   obtain Nu where Nu: "\<forall>n \<ge> Nu. \<forall>m \<ge> Nu. dist (u n) (u m) < e/2" using assms(1)
     by (metis \<open>0 < e\<close> less_divide_eq_numeral1(1) metric_CauchyD mult_zero_left)
   obtain Nv where Nv: "\<forall>n \<ge> Nv. \<forall>m \<ge> Nv. dist (v n) (v m) < e/2" using assms(2)
     by (metis \<open>0 < e\<close> less_divide_eq_numeral1(1) metric_CauchyD mult_zero_left)
   define M where "M = max Nu Nv"
   {
     fix n m assume H: "n \<ge> M" "m \<ge> M"
     have *: "dist (u n) (u m) < e/2" "dist (v n) (v m) < e/2"
       using Nu Nv H unfolding M_def by auto
     have "dist (u m) (v m) - dist (u n) (v n) \<le> dist (u m) (u n) + dist (v n) (v m)"
-      by (metis add.commute add.left_commute add_left_mono dist_commute dist_triangle2 dist_triangle_le linordered_field_class.sign_simps(42))
+      by (simp add: algebra_simps) (metis add_le_cancel_left dist_commute dist_triangle2 dist_triangle_le)
     also have "... < e/2 + e/2"
       using * by (simp add: dist_commute)
     finally have A: "dist (u m) (v m) - dist (u n) (v n) < e" by simp
 
     have "dist (u n) (v n) - dist (u m) (v m) \<le> dist (u m) (u n) + dist (v n) (v m)"
-      by (metis add.commute add.left_commute add_left_mono dist_commute dist_triangle2 dist_triangle_le linordered_field_class.sign_simps(42))
+      by (simp add: algebra_simps) (metis add_le_cancel_left dist_commute dist_triangle2 dist_triangle_le)
     also have "... < e/2 + e/2"
       using * by (simp add: dist_commute)
     finally have "dist (u n) (v n) - dist (u m) (v m) < e" by simp
     then have "norm(dist (u m) (v m) - dist (u n) (v n)) < e" using A by auto
   }
   then show "\<exists>M. \<forall>m \<ge> M. \<forall>n \<ge> M. norm (dist (u m) (v m) - dist (u n) (v n)) < e"
     by auto
 qed
 
 lemma convergent_add_null:
   fixes u v::"nat \<Rightarrow> ('a::real_normed_vector)"
   assumes "convergent u"
           "(\<lambda>n. v n - u n) \<longlonglongrightarrow> 0"
   shows "convergent v" "lim v = lim u"
 proof -
   have "(\<lambda>n. u n + (v n - u n)) \<longlonglongrightarrow> lim u + 0"
     apply (rule tendsto_add) using assms convergent_LIMSEQ_iff by auto
   then have *: "v \<longlonglongrightarrow> lim u" by auto
   show "convergent v" using * by (simp add: Lim_def convergentI)
   show "lim v = lim u" using * by (simp add: limI)
 qed
 
 text \<open>Let us now prove that the metric completion is a metric space: the distance between two
 Cauchy sequences is the limit of the distances of points in the sequence. The convergence follows
 from Lemma~\verb+convergent_Cauchy_dist+ above.\<close>
 
 instantiation metric_completion :: (metric_space) metric_space
 begin
 
 lift_definition dist_metric_completion::"('a::metric_space) metric_completion \<Rightarrow> 'a metric_completion \<Rightarrow> real"
   is "\<lambda>x y. lim (\<lambda>n. dist (x n) (y n))"
 proof -
   fix x y z t::"nat \<Rightarrow> 'a" assume H: "Cauchy x \<and> Cauchy y \<and> (\<lambda>n. dist (x n) (y n)) \<longlonglongrightarrow> 0"
                                      "Cauchy z \<and> Cauchy t \<and> (\<lambda>n. dist (z n) (t n)) \<longlonglongrightarrow> 0"
   show "lim (\<lambda>n. dist (x n) (z n)) = lim (\<lambda>n. dist (y n) (t n))"
   proof (rule convergent_add_null(2))
     show "convergent (\<lambda>n. dist (y n) (t n))"
       apply (rule convergent_Cauchy_dist) using H by auto
 
     have a: "(\<lambda>n. - dist (t n) (z n) - dist (x n) (y n)) \<longlonglongrightarrow> -0 -0"
       apply (intro tendsto_intros) using H by (auto simp add: dist_commute)
     have b:"(\<lambda>n. dist (t n) (z n) + dist (x n) (y n)) \<longlonglongrightarrow> 0 + 0"
       apply (rule tendsto_add) using H by (auto simp add: dist_commute)
     have I: "dist (x n) (z n) \<le> dist (t n) (y n) + (dist (t n) (z n) + dist (x n) (y n))" for n
       using dist_triangle[of "x n" "z n" "y n"] dist_triangle[of "y n" "z n" "t n"]
       by (auto simp add: dist_commute add.commute)
     show "(\<lambda>n. dist (x n) (z n) - dist (y n) (t n)) \<longlonglongrightarrow> 0"
       apply (rule tendsto_sandwich[of "\<lambda>n. -(dist (x n) (y n) + dist (z n) (t n))" _ _ "\<lambda>n. dist (x n) (y n) + dist (z n) (t n)"])
       apply (auto intro!: always_eventually simp add: algebra_simps dist_commute I)
       apply (meson add_left_mono dist_triangle3 dist_triangle_le)
       using a b by auto
   qed
 qed
 
 lemma dist_metric_completion_limit:
   fixes x y::"'a metric_completion"
   shows "(\<lambda>n. dist (rep_metric_completion x n) (rep_metric_completion y n)) \<longlonglongrightarrow> dist x y"
 proof -
   have C: "Cauchy (rep_metric_completion x)" "Cauchy (rep_metric_completion y)"
     using Quotient3_metric_completion Quotient3_rep_reflp by fastforce+
   show ?thesis
     unfolding dist_metric_completion_def using C apply auto
     using convergent_Cauchy_dist[OF C] convergent_LIMSEQ_iff by force
 qed
 
 lemma dist_metric_completion_limit':
   fixes x y::"nat \<Rightarrow> 'a"
   assumes "Cauchy x" "Cauchy y"
   shows "(\<lambda>n. dist (x n) (y n)) \<longlonglongrightarrow> dist (abs_metric_completion x) (abs_metric_completion y)"
 apply (subst dist_metric_completion.abs_eq)
 using assms convergent_Cauchy_dist[OF assms] by (auto simp add: convergent_LIMSEQ_iff)
 
 text \<open>To define a metric space in the current library of Isabelle/HOL, one should also introduce
 a uniformity structure and a topology, as follows (they are prescribed by the distance):\<close>
 
 definition uniformity_metric_completion::"(('a metric_completion) \<times> ('a metric_completion)) filter"
   where "uniformity_metric_completion = (INF e\<in>{0 <..}. principal {(x, y). dist x y < e})"
 
 definition open_metric_completion :: "'a metric_completion set \<Rightarrow> bool"
   where "open_metric_completion U = (\<forall>x\<in>U. eventually (\<lambda>(x', y). x' = x \<longrightarrow> y \<in> U) uniformity)"
 
 instance proof
   fix x y::"'a metric_completion"
   have C: "Cauchy (rep_metric_completion x)" "Cauchy (rep_metric_completion y)"
     using Quotient3_metric_completion Quotient3_rep_reflp by fastforce+
   show "(dist x y = 0) = (x = y)"
     apply (subst Quotient3_rel_rep[OF Quotient3_metric_completion, symmetric])
     unfolding dist_metric_completion_def using C apply auto
     using convergent_Cauchy_dist[OF C] convergent_LIMSEQ_iff apply force
     by (simp add: limI)
 next
   fix x y z::"'a metric_completion"
   have a: "(\<lambda>n. dist (rep_metric_completion x n) (rep_metric_completion y n)) \<longlonglongrightarrow> dist x y"
     using dist_metric_completion_limit by auto
   have b: "(\<lambda>n. dist (rep_metric_completion x n) (rep_metric_completion z n) + dist (rep_metric_completion y n) (rep_metric_completion z n))
       \<longlonglongrightarrow> dist x z + dist y z"
     apply (rule tendsto_add) using dist_metric_completion_limit by auto
   show "dist x y \<le> dist x z + dist y z"
     by (rule LIMSEQ_le[OF a b], rule exI[of _ 0], auto simp add: dist_triangle2)
 qed (auto simp add: uniformity_metric_completion_def open_metric_completion_def)
 end
 
 text \<open>Let us now show that the distance thus defined on the metric completion is indeed complete.
 This is essentially by design.\<close>
 
 instance metric_completion :: (metric_space) complete_space
 proof
   fix X::"nat \<Rightarrow> 'a metric_completion" assume "Cauchy X"
   have *: "\<exists>N. \<forall>n \<ge> N. dist (rep_metric_completion (X k) N) (rep_metric_completion (X k) n) < (1/Suc k)" for k
   proof -
     have "Cauchy (rep_metric_completion (X k))"
       using Quotient3_metric_completion Quotient3_rep_reflp by fastforce+
     then have "\<exists>N. \<forall>m \<ge> N. \<forall>n \<ge> N. dist (rep_metric_completion (X k) m) (rep_metric_completion (X k) n) < (1/Suc k)"
       unfolding Cauchy_def by auto
     then show ?thesis by auto
   qed
   have "\<exists>N. \<forall>k. \<forall>n \<ge> N k. dist (rep_metric_completion (X k) (N k)) (rep_metric_completion (X k) n) < (1/Suc k)"
     apply (rule choice) using * by auto
   then obtain N::"nat \<Rightarrow> nat" where
     N: "dist (rep_metric_completion (X k) (N k)) (rep_metric_completion (X k) n) < (1/Suc k)" if "n \<ge> N k" for n k
     by auto
   define u where "u = (\<lambda>k. rep_metric_completion (X k) (N k))"
 
   have "Cauchy u"
   proof (rule metric_CauchyI)
     fix e::real assume "e > 0"
     obtain K::nat where "K > 4/e" using reals_Archimedean2 by blast
     obtain L::nat where L: "\<forall>m \<ge> L. \<forall>n \<ge> L. dist (X m) (X n) < e/2"
       using metric_CauchyD[OF \<open>Cauchy X\<close>, of "e/2"] \<open>e > 0\<close> by auto
     {
       fix m n assume "m \<ge> max K L" "n \<ge> max K L"
       then have "dist (X m) (X n) < e/2" using L by auto
       then have "eventually (\<lambda>p. dist (rep_metric_completion (X m) p) (rep_metric_completion (X n) p) < e/2) sequentially"
         using dist_metric_completion_limit[of "X m" "X n"] by (metis order_tendsto_iff)
       then obtain p where p: "p \<ge> max (N m) (N n)" "dist (rep_metric_completion (X m) p) (rep_metric_completion (X n) p) < e/2"
         using eventually_False_sequentially eventually_elim2 eventually_ge_at_top by blast
       have "dist (u m) (rep_metric_completion (X m) p) < 1 / real (Suc m)"
         unfolding u_def using N[of m p] p(1) by auto
       also have "... < e/4"
         using \<open>m \<ge> max K L\<close> \<open>K > 4/e\<close> \<open>e > 0\<close> apply (auto simp add: divide_simps algebra_simps)
         by (metis leD le_less_trans less_add_same_cancel2 linear of_nat_le_iff real_mult_le_cancel_iff2)
       finally have Im: "dist (u m) (rep_metric_completion (X m) p) < e/4" by simp
       have "dist (u n) (rep_metric_completion (X n) p) < 1 / real (Suc n)"
         unfolding u_def using N[of n p] p(1) by auto
       also have "... < e/4"
         using \<open>n \<ge> max K L\<close> \<open>K > 4/e\<close> \<open>e > 0\<close> apply (auto simp add: divide_simps algebra_simps)
         by (metis leD le_less_trans less_add_same_cancel2 linear of_nat_le_iff real_mult_le_cancel_iff2)
       finally have In: "dist (u n) (rep_metric_completion (X n) p) < e/4" by simp
 
       have "dist (u m) (u n) \<le> dist (u m) (rep_metric_completion (X m) p)
           + dist (rep_metric_completion (X m) p) (rep_metric_completion (X n) p) + dist (rep_metric_completion (X n) p) (u n)"
         by (metis add.commute add_left_mono dist_commute dist_triangle_le dist_triangle)
       also have "... < e/4 + e/2 + e/4"
         using In Im p(2) by (simp add: dist_commute)
       also have "... = e" by auto
       finally have "dist (u m) (u n) < e" by auto
     }
     then show "\<exists>M. \<forall>m \<ge> M. \<forall>n \<ge> M. dist (u m) (u n) < e" by meson
   qed
   have *: "(\<lambda>n. dist (abs_metric_completion u) (X n)) \<longlonglongrightarrow> 0"
   proof (rule order_tendstoI, auto simp add: less_le_trans eventually_sequentially)
     fix e::real assume "e > 0"
     obtain K::nat where "K > 4/e" using reals_Archimedean2 by blast
     obtain L::nat where L: "\<forall>m \<ge> L. \<forall>n \<ge> L. dist (u m) (u n) < e/4"
       using metric_CauchyD[OF \<open>Cauchy u\<close>, of "e/4"] \<open>e > 0\<close> by auto
     {
       fix n assume n: "n \<ge> max K L"
       {
         fix p assume p: "p \<ge> max (N n) L"
         have "dist (u n) (rep_metric_completion (X n) p) < 1/(Suc n)"
           unfolding u_def using N p by simp
         also have "... < e/4"
           using \<open>n \<ge> max K L\<close> \<open>K > 4/e\<close> \<open>e > 0\<close> apply (auto simp add: divide_simps algebra_simps)
           by (metis leD le_less_trans less_add_same_cancel2 linear of_nat_le_iff real_mult_le_cancel_iff2)
         finally have *: "dist (u n) (rep_metric_completion (X n) p) < e/4"
           by fastforce
 
         have "dist (u p) (rep_metric_completion (X n) p) \<le> dist (u p) (u n) + dist (u n) (rep_metric_completion (X n) p)"
           using dist_triangle by auto
         also have "... < e/4 + e/4" using * L n p by force
         finally have "dist (u p) (rep_metric_completion (X n) p) \<le> e/2" by auto
       }
       then have A: "eventually (\<lambda>p. dist (u p) (rep_metric_completion (X n) p) \<le> e/2) sequentially"
         using eventually_at_top_linorder by blast
       have B: "(\<lambda>p. dist (u p) (rep_metric_completion (X n) p)) \<longlonglongrightarrow> dist (abs_metric_completion u) (X n)"
         using dist_metric_completion_limit'[OF \<open>Cauchy u\<close>, of "rep_metric_completion (X n)"]
         unfolding Quotient3_abs_rep[OF Quotient3_metric_completion, of "X n"]
         using Quotient3_rep_reflp[OF Quotient3_metric_completion] by auto
       have "dist (abs_metric_completion u) (X n) \<le> e/2"
         apply (rule LIMSEQ_le_const2[OF B]) using A unfolding eventually_sequentially by auto
       then have "dist (abs_metric_completion u) (X n) < e" using \<open>e > 0\<close> by auto
     }
     then show "\<exists>N. \<forall>n \<ge> N. dist (abs_metric_completion u) (X n) < e"
       by blast
   qed
   have "X \<longlonglongrightarrow> abs_metric_completion u"
     apply (rule tendstoI) using * by (auto simp add: order_tendsto_iff dist_commute)
   then show "convergent X" unfolding convergent_def by auto
 qed
 
 subsection \<open>Isometric embedding of a space in its metric completion\<close>
 
 text \<open>The canonical embedding of a space into its metric completion is obtained by taking
 the Cauchy sequence which is constant, equal to the given point. This is indeed an isometric
 embedding with dense image, as we prove in the lemmas below.\<close>
 
 definition to_metric_completion::"('a::metric_space) \<Rightarrow> 'a metric_completion"
   where "to_metric_completion x = abs_metric_completion (\<lambda>n. x)"
 
 lemma to_metric_completion_isometry:
   "isometry_on UNIV to_metric_completion"
 proof (rule isometry_onI)
   fix x y::'a
   have "(\<lambda>n. dist (x) (y)) \<longlonglongrightarrow> dist (to_metric_completion x) (to_metric_completion y)"
     unfolding to_metric_completion_def apply (rule dist_metric_completion_limit')
     unfolding Cauchy_def by auto
   then show "dist (to_metric_completion x) (to_metric_completion y) = dist x y"
     by (simp add: LIMSEQ_const_iff)
 qed
 
 lemma to_metric_completion_dense:
   assumes "open U" "U \<noteq> {}"
   shows "\<exists>x. to_metric_completion x \<in> U"
 proof -
   obtain y where "y \<in> U" using \<open>U \<noteq> {}\<close> by auto
   obtain e::real where e: "e > 0" "\<And>z. dist z y < e \<Longrightarrow> z \<in> U"
     using \<open>y \<in> U\<close> \<open>open U\<close> by (metis open_dist)
   have *: "Cauchy (rep_metric_completion y)"
     using Quotient3_metric_completion Quotient3_rep_reflp by fastforce
   then obtain N where N: "\<forall>n \<ge> N. \<forall>m \<ge> N. dist (rep_metric_completion y n) (rep_metric_completion y m) < e/2"
     using \<open>e > 0\<close> unfolding Cauchy_def by (meson divide_pos_pos zero_less_numeral)
   define x where "x = rep_metric_completion y N"
   have "(\<lambda>n. dist x (rep_metric_completion y n)) \<longlonglongrightarrow> dist (to_metric_completion x) (abs_metric_completion (rep_metric_completion y))"
     unfolding to_metric_completion_def apply (rule dist_metric_completion_limit')
     using * unfolding Cauchy_def by auto
   then have "(\<lambda>n. dist x (rep_metric_completion y n)) \<longlonglongrightarrow> dist (to_metric_completion x) y"
     unfolding Quotient3_abs_rep[OF Quotient3_metric_completion] by simp
   moreover have "eventually (\<lambda>n. dist x (rep_metric_completion y n) \<le> e/2) sequentially"
     unfolding eventually_sequentially x_def apply (rule exI[of _ N]) using N less_imp_le by auto
   ultimately have "dist (to_metric_completion x) y \<le> e/2"
     using LIMSEQ_le_const2 unfolding eventually_sequentially by metis
   then have "to_metric_completion x \<in> U"
     using e by auto
   then show ?thesis by auto
 qed
 
 lemma to_metric_completion_dense':
   "closure (range to_metric_completion) = UNIV"
 apply (auto simp add: closure_iff_nhds_not_empty) using to_metric_completion_dense by fastforce
 
 text \<open>The main feature of the completion is that a uniformly continuous function on the original space can be extended
 to a uniformly continuous function on the completion, i.e., it can be written as the composition of
 a new function and of the inclusion \verb+to_metric_completion+.\<close>
 
 lemma lift_to_metric_completion:
   fixes f::"('a::metric_space) \<Rightarrow> ('b::complete_space)"
   assumes "uniformly_continuous_on UNIV f"
   shows "\<exists>g. (uniformly_continuous_on UNIV g)
             \<and> (f = g o to_metric_completion)
             \<and> (\<forall>x \<in> range to_metric_completion. g x = f (inv to_metric_completion x))"
 proof -
   define I::"'a metric_completion \<Rightarrow> 'a" where "I = inv to_metric_completion"
   have "uniformly_continuous_on (range to_metric_completion) I"
     using isometry_on_uniformly_continuous[OF isometry_on_inverse(1)[OF to_metric_completion_isometry]] I_def
     by auto
   then have UC: "uniformly_continuous_on (range to_metric_completion) (\<lambda>x. f (I x))"
     using assms uniformly_continuous_on_compose
     by (metis I_def bij_betw_imp_surj_on bij_betw_inv_into isometry_on_inverse(4) to_metric_completion_isometry)
   obtain g where g: "uniformly_continuous_on (closure(range to_metric_completion)) g"
                     "\<And>x. x \<in> range to_metric_completion \<Longrightarrow> f (I x) = g x"
     using uniformly_continuous_on_extension_on_closure[OF UC] by metis
   have "uniformly_continuous_on UNIV g"
     using to_metric_completion_dense' g(1) by metis
   moreover have "f x = g (to_metric_completion x)" for x
     using g(2) by (metis I_def UNIV_I isometry_on_inverse(2) range_eqI to_metric_completion_isometry)
   moreover have "g x = f (inv to_metric_completion x)" if "x \<in> range to_metric_completion" for x
     using I_def g(2) that by auto
   ultimately show ?thesis unfolding comp_def by auto
 qed
 
 text \<open>When the function is an isometry, the lifted function is also an isometry (and its range is
 the closure of the range of the original function).
 This shows that the metric completion is unique, up to isometry:\<close>
 
 lemma lift_to_metric_completion_isometry:
   fixes f::"('a::metric_space) \<Rightarrow> ('b::complete_space)"
   assumes "isometry_on UNIV f"
   shows "\<exists>g. isometry_on UNIV g
           \<and> range g = closure(range f)
           \<and> f = g o to_metric_completion
           \<and> (\<forall>x \<in> range to_metric_completion. g x = f (inv to_metric_completion x))"
 proof -
   have *: "uniformly_continuous_on UNIV f" using assms isometry_on_uniformly_continuous by force
   obtain g where g: "uniformly_continuous_on UNIV g"
                     "f = g o to_metric_completion"
                     "\<And>x. x \<in> range to_metric_completion \<Longrightarrow> g x = f (inv to_metric_completion x)"
     using lift_to_metric_completion[OF *] by blast
   have *: "isometry_on (range to_metric_completion) g"
     apply (rule isometry_on_cong[OF _ g(3)], rule isometry_on_compose[of _ _ f])
     using assms isometry_on_inverse[OF to_metric_completion_isometry] isometry_on_subset by (auto) (fastforce)
   then have "isometry_on UNIV g"
     unfolding to_metric_completion_dense'[symmetric] apply (rule isometry_on_closure)
     using continuous_on_subset[OF uniformly_continuous_imp_continuous[OF g(1)]] by auto
 
   have "g`(range to_metric_completion) \<subseteq> range f"
     using g unfolding comp_def by auto
   moreover have "g`(closure (range to_metric_completion)) \<subseteq> closure (g`(range to_metric_completion))"
     using uniformly_continuous_imp_continuous[OF g(1)]
     by (meson closed_closure closure_subset continuous_on_subset image_closure_subset top_greatest)
   ultimately have "range g \<subseteq> closure (range f)"
     unfolding to_metric_completion_dense' by (simp add: g(2) image_comp)
 
   have "range f \<subseteq> range g"
     using g(2) by auto
   moreover have "closed (range g)"
     using isometry_on_complete_image[OF \<open>isometry_on UNIV g\<close>] by (simp add: complete_eq_closed)
   ultimately have "closure (range f) \<subseteq> range g"
     by (simp add: closure_minimal)
   then have "range g = closure (range f)"
     using \<open>range g \<subseteq> closure (range f)\<close> by auto
   then show ?thesis using \<open>isometry_on UNIV g\<close> g by metis
 qed
 
 subsection \<open>The metric completion of a second countable space is second countable\<close>
 
 text \<open>We want to show that the metric completion of a second countable space is still
 second countable. This is most easily expressed using the fact that a metric
 space is second countable if and only if there exists a dense countable subset. We prove
 the equivalence in the next lemma, and use it then to prove that the metric completion is
 still second countable.\<close>
 
 lemma second_countable_iff_dense_countable_subset:
   "(\<exists>B::'a::metric_space set set. countable B \<and> topological_basis B)
     \<longleftrightarrow> (\<exists>A::'a set. countable A \<and> closure A = UNIV)"
 proof
   assume "\<exists>B::'a set set. countable B \<and> topological_basis B"
   then obtain B::"'a set set" where "countable B" "topological_basis B" by auto
   define A where "A = (\<lambda>U. SOME x. x \<in> U)`B"
   have "countable A" unfolding A_def using \<open>countable B\<close> by auto
   moreover have "closure A = UNIV"
   proof (auto simp add: closure_approachable)
     fix x::'a and e::real assume "e > 0"
     obtain U where "U \<in> B" "x \<in> U" "U \<subseteq> ball x e"
       by (rule topological_basisE[OF \<open>topological_basis B\<close>, of "ball x e" x], auto simp add: \<open>e > 0\<close>)
     define y where "y = (\<lambda>U. SOME x. x \<in> U) U"
     have "y \<in> U" unfolding y_def using \<open>x \<in> U\<close> some_in_eq by fastforce
     then have "dist y x < e"
       using \<open>U \<subseteq> ball x e\<close> by (metis dist_commute mem_ball subset_iff)
     moreover have "y \<in> A" unfolding A_def y_def using \<open>U \<in> B\<close> by auto
     ultimately show "\<exists>y\<in>A. dist y x < e" by auto
   qed
   ultimately show "\<exists>A::'a set. countable A \<and> closure A = UNIV" by auto
 next
   assume "\<exists>A::'a set. countable A \<and> closure A = UNIV"
   then obtain A::"'a set" where "countable A" "closure A = UNIV" by auto
   define B where "B = (\<lambda>(x, (n::nat)). ball x (1/n))`(A \<times> UNIV)"
   have "countable B" unfolding B_def using \<open>countable A\<close> by auto
   moreover have "topological_basis B"
   proof (rule topological_basisI)
     fix x::'a and U assume "x \<in> U" "open U"
     then obtain e where "e > 0" "ball x e \<subseteq> U"
       using openE by blast
     obtain n::nat where "n > 2/e" using reals_Archimedean2 by auto
     then have "n > 0" using \<open>e > 0\<close> not_less by fastforce
     then have "1/n > 0" using zero_less_divide_iff by fastforce
     then obtain y where y: "y \<in> A" "dist x y < 1/n"
       by (metis \<open>closure A = UNIV\<close> UNIV_I closure_approachable dist_commute)
     then have "ball y (1/n) \<in> B" unfolding B_def by auto
     moreover have "x \<in> ball y (1/n)" using y(2) by (auto simp add: dist_commute)
     moreover have "ball y (1/n) \<subseteq> U"
     proof (auto)
       fix z assume z: "dist y z < 1/n"
       have "dist z x \<le> dist z y + dist y x" using dist_triangle by auto
       also have "... < 1/n + 1/n" using z y(2) by (auto simp add: dist_commute)
       also have "... < e"
         using \<open>n > 2/e\<close> \<open>e > 0\<close> \<open>n > 0\<close> by (auto simp add: divide_simps mult.commute)
       finally have "z \<in> ball x e" by (auto simp add: dist_commute)
       then show "z \<in> U" using \<open>ball x e \<subseteq> U\<close> by auto
     qed
     ultimately show "\<exists>V\<in>B. x \<in> V \<and> V \<subseteq> U" by metis
   qed (auto simp add: B_def)
   ultimately show "\<exists>B::'a set set. countable B \<and> topological_basis B" by auto
 qed
 
 lemma second_countable_metric_dense_subset:
   "\<exists>A::'a::{metric_space, second_countable_topology} set. countable A \<and> closure A = UNIV"
 using ex_countable_basis by (auto simp add: second_countable_iff_dense_countable_subset[symmetric])
 
 instance metric_completion::("{metric_space, second_countable_topology}") second_countable_topology
 proof
   obtain A::"'a set" where "countable A" "closure A = UNIV"
     using second_countable_metric_dense_subset by auto
   define Ab where "Ab = to_metric_completion`A"
   have "range to_metric_completion \<subseteq> closure Ab"
     unfolding Ab_def
     by (metis \<open>closure A = UNIV\<close> isometry_on_continuous[OF to_metric_completion_isometry] closed_closure closure_subset image_closure_subset)
   then have "closure Ab = UNIV"
     by (metis (no_types) to_metric_completion_dense'[symmetric] \<open>range to_metric_completion \<subseteq> closure Ab\<close> closure_closure closure_mono top.extremum_uniqueI)
   moreover have "countable Ab" unfolding Ab_def using \<open>countable A\<close> by auto
   ultimately have "\<exists>Ab::'a metric_completion set. countable Ab \<and> closure Ab = UNIV"
     by auto
   then show "\<exists>B::'a metric_completion set set. countable B \<and> open = generate_topology B"
     using second_countable_iff_dense_countable_subset topological_basis_imp_subbasis by auto
 qed
 
 instance metric_completion::("{metric_space, second_countable_topology}") polish_space
 by standard
 
 end (*of theory Metric_Completion*)
diff --git a/thys/IEEE_Floating_Point/IEEE_Properties.thy b/thys/IEEE_Floating_Point/IEEE_Properties.thy
--- a/thys/IEEE_Floating_Point/IEEE_Properties.thy
+++ b/thys/IEEE_Floating_Point/IEEE_Properties.thy
@@ -1,1032 +1,1030 @@
 (* Author: Lei Yu, University of Cambridge
    Author: Fabian Hellauer
            Fabian Immler
 *)
 
 section \<open>Proofs of Properties about Floating Point Arithmetic\<close>
 
 theory IEEE_Properties
 imports IEEE
 begin
 
 subsection \<open>Theorems derived from definitions\<close>
 
 
 lemma valof_eq:
   "valof x =
     (if exponent x = 0
        then (- 1) ^ sign x * (2 / 2 ^ bias TYPE(('a, 'b) float)) *
             (real (fraction x) / 2 ^ LENGTH('b))
        else (- 1) ^ sign x * (2 ^ exponent x / 2 ^ bias TYPE(('a, 'b) float)) *
             (1 + real (fraction x) / 2 ^ LENGTH('b)))"
   for x::"('a, 'b) float"
   unfolding Let_def
   by transfer (auto simp: bias_def divide_simps unat_eq_0)
 
 lemma exponent_le[simp]:
   "exponent a \<le> unat (max_word::'a word)" for a::"('a, _)float"
   by transfer (auto intro!: unat_mono simp: word_le_nat_alt[symmetric])
 
 lemma
   max_word_le_exponent_iff[simp]:
   "unat (max_word::'a word) \<le> exponent a \<longleftrightarrow> unat (max_word::'a word) = exponent a"
   for a::"('a, _)float"
   using le_antisym by fastforce
 
 lemma infinity_simps:
   "sign (plus_infinity::('e, 'f)float) = 0"
   "sign (minus_infinity::('e, 'f)float) = 1"
   "exponent (plus_infinity::('e, 'f)float) = emax TYPE(('e, 'f)float)"
   "exponent (minus_infinity::('e, 'f)float) = emax TYPE(('e, 'f)float)"
   "fraction (plus_infinity::('e, 'f)float) = 0"
   "fraction (minus_infinity::('e, 'f)float) = 0"
   subgoal by transfer auto
   subgoal by transfer auto
   subgoal by transfer (auto simp: emax_def)
   subgoal by transfer (auto simp: emax_def)
   subgoal by transfer auto
   subgoal by transfer auto
   done
 
 lemma zero_simps:
   "sign (0::('e, 'f)float) = 0"
   "sign (- 0::('e, 'f)float) = 1"
   "exponent (0::('e, 'f)float) = 0"
   "exponent (- 0::('e, 'f)float) = 0"
   "fraction (0::('e, 'f)float) = 0"
   "fraction (- 0::('e, 'f)float) = 0"
   subgoal by transfer auto
   subgoal by transfer auto
   subgoal by transfer auto
   subgoal by transfer auto
   subgoal by transfer auto
   subgoal by transfer auto
   done
 
 lemma topfloat_simps:
   "sign (topfloat::('e, 'f)float) = 0"
   "exponent (topfloat::('e, 'f)float) = emax TYPE(('e, 'f)float) - 1"
   "fraction (topfloat::('e, 'f)float) = 2^fracwidth TYPE(('e, 'f)float) - 1"
   and bottomfloat_simps:
   "sign (bottomfloat::('e, 'f)float) = 1"
   "exponent (bottomfloat::('e, 'f)float) = emax TYPE(('e, 'f)float) - 1"
   "fraction (bottomfloat::('e, 'f)float) = 2^fracwidth TYPE(('e, 'f)float) - 1"
   subgoal by transfer auto
   subgoal by transfer (auto simp: emax_def unat_sub)
   subgoal
     apply transfer
     apply safe
     by (metis One_nat_def diff_less lessI minus_one_norm minus_one_word unat_0 unat_lt2p
         unat_of_nat_len)
   subgoal by transfer auto
   subgoal by transfer (auto simp: emax_def unat_sub)
   subgoal
     apply transfer
     apply safe
     by (metis One_nat_def diff_less lessI minus_one_norm minus_one_word unat_0 unat_lt2p
         unat_of_nat_len)
   done
 
 lemma emax_eq: "emax x = 2^LENGTH('e) - 1"
   for x::"('e, 'f)float itself"
   unfolding bias_def emax_def
   by (auto simp: max_word_eq unat_minus word_size)
 
 lemmas float_defs =
   is_finite_def is_infinity_def is_zero_def is_nan_def
   is_normal_def is_denormal_def valof_eq
   less_eq_float_def less_float_def
   flt_def fgt_def fle_def fge_def feq_def
   fcompare_def
   infinity_simps
   zero_simps
   topfloat_simps
   bottomfloat_simps
   float_eq_def
 
 lemma float_cases: "is_nan a \<or> is_infinity a \<or> is_normal a \<or> is_denormal a \<or> is_zero a"
   by (auto simp: emax_def float_defs not_less)
 
 lemma float_cases_finite: "is_nan a \<or> is_infinity a \<or> is_finite a"
   by (simp add: float_cases is_finite_def)
 
 lemma float_zero1[simp]: "is_zero 0"
   unfolding float_defs
   by transfer auto
 
 lemma float_zero2[simp]: "is_zero (- x) \<longleftrightarrow> is_zero x"
   unfolding float_defs
   by transfer auto
 
 lemma emax_pos[simp]: "0 < emax x" "emax x \<noteq> 0"
   by (auto simp: emax_def)
 
 text \<open>The types of floating-point numbers are mutually distinct.\<close>
 lemma float_distinct:
   "\<not> (is_nan a \<and> is_infinity a)"
   "\<not> (is_nan a \<and> is_normal a)"
   "\<not> (is_nan a \<and> is_denormal a)"
   "\<not> (is_nan a \<and> is_zero a)"
   "\<not> (is_infinity a \<and> is_normal a)"
   "\<not> (is_infinity a \<and> is_denormal a)"
   "\<not> (is_infinity a \<and> is_zero a)"
   "\<not> (is_normal a \<and> is_denormal a)"
   "\<not> (is_denormal a \<and> is_zero a)"
   by (auto simp: float_defs)
 
 lemma denormal_imp_not_zero: "is_denormal f \<Longrightarrow> \<not>is_zero f"
   by (simp add: is_denormal_def is_zero_def)
 
 lemma normal_imp_not_zero: "is_normal f \<Longrightarrow> \<not>is_zero f"
   by (simp add: is_normal_def is_zero_def)
 
 lemma normal_imp_not_denormal: "is_normal f \<Longrightarrow> \<not>is_denormal f"
   by (simp add: is_normal_def is_denormal_def)
 
 lemma denormal_zero[simp]: "\<not>is_denormal 0" "\<not>is_denormal minus_zero"
   using denormal_imp_not_zero float_zero1 float_zero2 by blast+
 
 lemma normal_zero[simp]: "\<not>is_normal 0" "\<not>is_normal minus_zero"
   using normal_imp_not_zero float_zero1 float_zero2 by blast+
 
 lemma float_distinct_finite: "\<not> (is_nan a \<and> is_finite a)" "\<not>(is_infinity a \<and> is_finite a)"
   by (auto simp: float_defs)
 
 lemma finite_infinity: "is_finite a \<Longrightarrow> \<not> is_infinity a"
   by (auto simp: float_defs)
 
 lemma finite_nan: "is_finite a \<Longrightarrow> \<not> is_nan a"
   by (auto simp: float_defs)
 
 text \<open>For every real number, the floating-point numbers closest to it always exist.\<close>
 lemma is_closest_exists:
   fixes v :: "('e, 'f)float \<Rightarrow> real"
     and s :: "('e, 'f)float set"
   assumes finite: "finite s"
     and non_empty: "s \<noteq> {}"
   shows "\<exists>a. is_closest v s x a"
   using finite non_empty
 proof (induct s rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert z s)
   show ?case
   proof (cases "s = {}")
     case True
     then have "is_closest v (insert z s) x z"
       by (auto simp: is_closest_def)
     then show ?thesis by metis
   next
     case False
     then obtain a where a: "is_closest v s x a"
       using insert by metis
     then show ?thesis
     proof (cases "\<bar>v a - x\<bar>" "\<bar>v z - x\<bar>" rule: le_cases)
       case le
       then show ?thesis
         by (metis insert_iff a is_closest_def)
     next
       case ge
       have "\<forall>b. b \<in> s \<longrightarrow> \<bar>v a - x\<bar> \<le> \<bar>v b - x\<bar>"
         by (metis a is_closest_def)
       then have "\<forall>b. b \<in> insert z s \<longrightarrow> \<bar>v z - x\<bar> \<le> \<bar>v b - x\<bar>"
         by (metis eq_iff ge insert_iff order.trans)
       then show ?thesis using is_closest_def a
         by (metis insertI1)
     qed
   qed
 qed
 
 lemma closest_is_everything:
   fixes v :: "('e, 'f)float \<Rightarrow> real"
     and s :: "('e, 'f)float set"
   assumes finite: "finite s"
     and non_empty: "s \<noteq> {}"
   shows "is_closest v s x (closest v p s x) \<and>
     ((\<exists>b. is_closest v s x b \<and> p b) \<longrightarrow> p (closest v p s x))"
   unfolding closest_def
   by (rule someI_ex) (metis assms is_closest_exists [of s v x])
 
 lemma closest_in_set:
   fixes v :: "('e, 'f)float \<Rightarrow> real"
   assumes "finite s" and "s \<noteq> {}"
   shows "closest v p s x \<in> s"
   by (metis assms closest_is_everything is_closest_def)
 
 lemma closest_is_closest_finite:
   fixes v :: "('e, 'f)float \<Rightarrow> real"
   assumes "finite s" and "s \<noteq> {}"
   shows "is_closest v s x (closest v p s x)"
   by (metis closest_is_everything assms)
 
 instance float::(len, len) finite proof qed (transfer, simp)
 
 lemma is_finite_nonempty: "{a. is_finite a} \<noteq> {}"
 proof -
   have "0 \<in> {a. is_finite a}"
     unfolding float_defs
     by transfer auto
   then show ?thesis by (metis empty_iff)
 qed
 
 lemma closest_is_closest:
   fixes v :: "('e, 'f)float \<Rightarrow> real"
   assumes "s \<noteq> {}"
   shows "is_closest v s x (closest v p s x)"
   by (rule closest_is_closest_finite) (auto simp: assms)
 
 
 subsection \<open>Properties about ordering and bounding\<close>
 
 text \<open>Lifting of non-exceptional comparisons.\<close>
 lemma float_lt [simp]:
   assumes "is_finite a" "is_finite b"
   shows "a < b \<longleftrightarrow> valof a < valof b"
 proof
   assume "valof a < valof b"
   moreover have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
     using assms by (auto simp: finite_nan finite_infinity)
   ultimately have "fcompare a b = Lt"
     by (auto simp add: is_infinity_def is_nan_def valof_def fcompare_def)
   then show "a < b" by (auto simp: float_defs)
 next
   assume "a < b"
   then have lt: "fcompare a b = Lt"
     by (simp add: float_defs)
   have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
     using assms by (auto simp: finite_nan finite_infinity)
   then show "valof a < valof b"
     using lt assms
     by (simp add: fcompare_def is_nan_def is_infinity_def valof_def split: if_split_asm)
 qed
 
 lemma float_eq [simp]:
   assumes "is_finite a" "is_finite b"
   shows "a \<doteq> b \<longleftrightarrow> valof a = valof b"
 proof
   assume *: "valof a = valof b"
   have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
     using assms float_distinct_finite by auto
   with * have "fcompare a b = Eq"
     by (auto simp add: is_infinity_def is_nan_def valof_def fcompare_def)
   then show "a \<doteq> b" by (auto simp: float_defs)
 next
   assume "a \<doteq> b"
   then have eq: "fcompare a b = Eq"
     by (simp add: float_defs)
   have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
     using assms float_distinct_finite by auto
   then show "valof a = valof b"
     using eq assms
     by (simp add: fcompare_def is_nan_def is_infinity_def valof_def split: if_split_asm)
 qed
 
 lemma float_le [simp]:
   assumes "is_finite a" "is_finite b"
   shows "a \<le> b \<longleftrightarrow> valof a \<le> valof b"
 proof -
   have "a \<le> b \<longleftrightarrow>  a < b \<or> a \<doteq> b"
     by (auto simp add: float_defs)
   then show ?thesis
     by (auto simp add: assms)
 qed
 
 text \<open>Reflexivity of equality for non-NaNs.\<close>
 lemma float_eq_refl [simp]: "a \<doteq> a \<longleftrightarrow> \<not> is_nan a"
   by (auto simp: float_defs)
 
 text \<open>Properties about Ordering.\<close>
 lemma float_lt_trans: "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> is_finite c \<Longrightarrow> a < b \<Longrightarrow> b < c \<Longrightarrow> a < c"
   by (auto simp: le_trans)
 
 lemma float_le_less_trans: "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> is_finite c \<Longrightarrow> a \<le> b \<Longrightarrow> b < c \<Longrightarrow> a < c"
   by (auto simp: le_trans)
 
 lemma float_le_trans: "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> is_finite c \<Longrightarrow> a \<le> b \<Longrightarrow> b \<le> c \<Longrightarrow> a \<le> c"
   by (auto simp: le_trans)
 
 lemma float_le_neg: "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> \<not> a < b \<longleftrightarrow> b \<le> a"
   by auto
 
 
 text \<open>Properties about bounding.\<close>
 
 lemma float_le_infinity [simp]: "\<not> is_nan a \<Longrightarrow> a \<le> plus_infinity"
   unfolding float_defs
   by auto
 
 lemma zero_le_topfloat[simp]: "0 \<le> topfloat" "- 0 \<le> topfloat"
-  unfolding float_defs
-  by (auto simp: sign_simps divide_simps power_gt1_lemma)
+  by (auto simp: float_defs field_simps power_gt1_lemma)
 
 lemma LENGTH_contr:
   "Suc 0 < LENGTH('e) \<Longrightarrow> 2 ^ LENGTH('e::len) \<le> Suc (Suc 0) \<Longrightarrow> False"
   by (metis le_antisym len_gt_0 n_less_equal_power_2 not_less_eq numeral_2_eq_2 one_le_numeral
       self_le_power)
 
 lemma valof_topfloat: "valof (topfloat::('e, 'f)float) = largest TYPE(('e, 'f)float)"
   if "LENGTH('e) > 1"
   using that LENGTH_contr
   by (auto simp add: emax_eq largest_def divide_simps float_defs )
 
 lemma float_frac_le: "fraction a \<le> 2^LENGTH('f) - 1"
   for a::"('e, 'f)float"
   unfolding float_defs
   using less_Suc_eq_le
   by transfer fastforce
 
 lemma float_exp_le: "is_finite a \<Longrightarrow> exponent a \<le> emax TYPE(('e, 'f)float) - 1"
   for a::"('e, 'f)float"
   unfolding float_defs
   by auto
 
 lemma float_sign_le: "(-1::real)^(sign a) = 1 \<or> (-1::real)^(sign a) = -1"
   by (metis neg_one_even_power neg_one_odd_power)
 
 lemma exp_less: "a \<le> b \<Longrightarrow> (2::real)^a \<le> 2^b" for a b :: nat
   by auto
 
 lemma div_less: "a \<le> b \<and> c > 0 \<Longrightarrow> a/c \<le> b/c" for a b c :: "'a::linordered_field"
   by (metis divide_le_cancel less_asym)
 
 lemma finite_topfloat: "is_finite topfloat"
   unfolding float_defs
   by auto
 
 lemmas float_leI = float_le[THEN iffD2]
 
 lemma factor_minus: "x * a - x = x * (a - 1)"
   for x a::"'a::comm_semiring_1_cancel"
   by (simp add: algebra_simps)
 
 lemma real_le_power_numeral_diff: "real a \<le> numeral b ^ n - 1 \<longleftrightarrow> a \<le> numeral b ^ n - 1"
   by (metis (mono_tags, lifting) of_nat_1 of_nat_diff of_nat_le_iff of_nat_numeral
       one_le_numeral one_le_power semiring_1_class.of_nat_power)
 
 definition denormal_exponent::"('e, 'f)float itself \<Rightarrow> int" where
   "denormal_exponent x = 1 - (int (LENGTH('f)) + int (bias TYPE(('e, 'f)float)))"
 
 definition normal_exponent::"('e, 'f)float \<Rightarrow> int" where
   "normal_exponent x = int (exponent x) - int (bias TYPE(('e, 'f)float)) - int (LENGTH('f))"
 
 definition denormal_mantissa::"('e, 'f)float \<Rightarrow> int" where
   "denormal_mantissa x = (-1::int)^sign x * int (fraction x)"
 
 definition normal_mantissa::"('e, 'f)float \<Rightarrow> int" where
   "normal_mantissa x = (-1::int)^sign x * (2^LENGTH('f) + int (fraction x))"
 
 lemma unat_one_word_le: "unat a \<le> Suc 0" for a::"1 word"
   using unat_lt2p[of a]
   by auto
 
 lemma one_word_le: "a \<le> 1" for a::"1 word"
   by (auto simp: word_le_nat_alt unat_one_word_le)
 
 lemma sign_cases[case_names pos neg]:
   obtains "sign x = 0" | "sign x = 1"
 proof cases
   assume "sign x = 0"
   then show ?thesis ..
 next
   assume "sign x \<noteq> 0"
   have "sign x \<le> 1"
     by transfer (auto simp: unat_one_word_le)
   then have "sign x = 1" using \<open>sign x \<noteq> 0\<close>
     by auto
   then show ?thesis ..
 qed
 
 lemma is_infinity_cases:
   assumes "is_infinity x"
   obtains "x = plus_infinity" | "x = minus_infinity"
 proof (cases rule: sign_cases[of x])
   assume "sign x = 0"
   then have "x = plus_infinity" using assms
     unfolding float_defs
     by transfer (auto simp: emax_def unat_eq_0)
   then show ?thesis ..
 next
   assume "sign x = 1"
   then have "x = minus_infinity" using assms
     unfolding float_defs
     by transfer (auto simp: emax_def unat_eq_of_nat)
   then show ?thesis ..
 qed
 
 lemma is_zero_cases:
   assumes "is_zero x"
   obtains "x = 0" | "x = - 0"
 proof (cases rule: sign_cases[of x])
   assume "sign x = 0"
   then have "x = 0" using assms
     unfolding float_defs
     by transfer (auto simp: emax_def unat_eq_0)
   then show ?thesis ..
 next
   assume "sign x = 1"
   then have "x = minus_zero" using assms
     unfolding float_defs
     by transfer (auto simp: emax_def unat_eq_of_nat)
   then show ?thesis ..
 qed
 
 lemma minus_minus_float[simp]: "- (-f) = f" for f::"('e, 'f)float"
   by transfer auto
 
 lemma sign_minus_float: "sign (-f) = (1 - sign f)" for f::"('e, 'f)float"
   by transfer (auto simp: unat_eq_1 one_word_le unat_sub)
 
 lemma exponent_uminus[simp]: "exponent (- f) = exponent f" by transfer auto
 lemma fraction_uminus[simp]: "fraction (- f) = fraction f" by transfer auto
 
 lemma is_normal_minus_float[simp]: "is_normal (-f) = is_normal f" for f::"('e, 'f)float"
   by (auto simp: is_normal_def)
 
 lemma is_denormal_minus_float[simp]: "is_denormal (-f) = is_denormal f" for f::"('e, 'f)float"
   by (auto simp: is_denormal_def)
 
 lemma bitlen_normal_mantissa:
   "bitlen (abs (normal_mantissa x)) = Suc LENGTH('f)" for x::"('e, 'f)float"
 proof -
   have "fraction x < 2 ^ LENGTH('f)"
     using float_frac_le[of x]
     by (metis One_nat_def Suc_pred le_imp_less_Suc pos2 zero_less_power)
   moreover have "- int (fraction x) \<le> 2 ^ LENGTH('f)"
     using negative_zle_0 order_trans zero_le_numeral zero_le_power by blast
   ultimately show ?thesis
     by (cases x rule: sign_cases)
-      (auto simp: bitlen_le_iff_power bitlen_ge_iff_power nat_add_distrib abs_mult sign_simps
-        add_nonneg_pos normal_mantissa_def intro!: antisym)
+      (auto simp: bitlen_le_iff_power bitlen_ge_iff_power nat_add_distrib
+        normal_mantissa_def intro!: antisym)
 qed
 
 lemma less_int_natI: "x < y" if "0 \<le> x" "nat x < nat y"
   using that by arith
 
 lemma normal_exponent_bounds_int:
   "2 - 2 ^ (LENGTH('e) - 1) - int LENGTH('f) \<le> normal_exponent x"
   "normal_exponent x \<le> 2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1"
   if "is_normal x"
   for x::"('e, 'f)float"
   using that
   unfolding normal_exponent_def is_normal_def emax_eq bias_def
   by (auto simp del: zless_nat_conj intro!: less_int_natI
       simp: nat_add_distrib nat_mult_distrib nat_power_eq
       power_Suc[symmetric])
 
 lemmas of_int_leI = of_int_le_iff[THEN iffD2]
 
 lemma normal_exponent_bounds_real:
   "2 - 2 ^ (LENGTH('e) - 1) - real LENGTH('f) \<le> normal_exponent x"
   "normal_exponent x \<le> 2 ^ (LENGTH('e) - 1) - real LENGTH('f) - 1"
   if "is_normal x"
   for x::"('e, 'f)float"
   subgoal by (rule order_trans[OF _ of_int_leI[OF normal_exponent_bounds_int(1)[OF that]]]) auto
   subgoal by (rule order_trans[OF of_int_leI[OF normal_exponent_bounds_int(2)[OF that]]]) auto
   done
 
 lemma float_eqI:
   "x = y" if "sign x = sign y" "fraction x = fraction y" "exponent x = exponent y"
   using that
   by transfer auto
 
 lemma float_induct[induct type:float, case_names normal denormal neg zero infinity nan]:
   fixes a::"('e, 'f)float"
   assumes normal:
     "\<And>x. is_normal x \<Longrightarrow> valof x = normal_mantissa x * 2 powr normal_exponent x \<Longrightarrow> P x"
   assumes denormal:
     "\<And>x. is_denormal x \<Longrightarrow>
       valof x = denormal_mantissa x * 2 powr denormal_exponent TYPE(('e, 'f)float) \<Longrightarrow>
       P x"
   assumes zero: "P 0" "P minus_zero"
   assumes infty: "P plus_infinity" "P minus_infinity"
   assumes nan: "\<And>x. is_nan x \<Longrightarrow> P x"
   shows "P a"
 proof -
   from float_cases[of a]
   consider "is_nan a" | "is_infinity a" | "is_normal a" | "is_denormal a" | "is_zero a" by blast
   then show ?thesis
   proof cases
     case 1
     then show ?thesis by (rule nan)
   next
     case 2
     then consider "a = plus_infinity" | "a = minus_infinity" by (rule is_infinity_cases)
     then show ?thesis
       by cases (auto intro: infty)
   next
     case hyps: 3
     from hyps have "valof a = normal_mantissa a * 2 powr normal_exponent a"
       by (cases a rule: sign_cases)
         (auto simp: valof_eq normal_mantissa_def normal_exponent_def is_normal_def
           powr_realpow[symmetric] powr_diff powr_add divide_simps algebra_simps)
     from hyps this show ?thesis
       by (rule normal)
   next
     case hyps: 4
     from hyps have "valof a = denormal_mantissa a * 2 powr denormal_exponent TYPE(('e, 'f)float)"
       by (cases a rule: sign_cases)
         (auto simp: valof_eq denormal_mantissa_def denormal_exponent_def is_denormal_def
           powr_realpow[symmetric] powr_diff powr_add divide_simps algebra_simps)
     from hyps this show ?thesis
       by (rule denormal)
   next
     case 5
     then consider "a = 0" | "a = minus_zero" by (rule is_zero_cases)
     then show ?thesis
       by cases (auto intro: zero)
   qed
 qed
 
 lemma infinite_infinity[simp]: "\<not> is_finite plus_infinity" "\<not> is_finite minus_infinity"
   by (auto simp: is_finite_def is_normal_def infinity_simps is_denormal_def is_zero_def)
 
 lemma nan_not_finite[simp]: "is_nan x \<Longrightarrow> \<not> is_finite x"
   using float_distinct_finite(1) by blast
 
 lemma valof_nonneg:
   "valof x \<ge> 0" if "sign x = 0" for x::"('e, 'f)float"
   by (auto simp: valof_eq that)
 
 lemma valof_nonpos:
   "valof x \<le> 0" if "sign x = 1" for x::"('e, 'f)float"
   using that
   by (auto simp: valof_eq is_finite_def)
 
 lemma real_le_intI: "x \<le> y" if "floor x \<le> floor y" "x \<in> \<int>" for x y::real
   using that(2,1)
   by (induction rule: Ints_induct) (auto elim!: Ints_induct simp: le_floor_iff)
 
 lemma real_of_int_le_2_powr_bitlenI:
   "real_of_int x \<le> 2 powr n - 1" if "bitlen (abs x) \<le> m" "m \<le> n"
 proof -
   have "real_of_int x \<le> abs (real_of_int x)" by simp
   also have "\<dots> < 2 powr (bitlen (abs x))"
     by (rule abs_real_le_2_powr_bitlen)
   finally have "real_of_int x \<le> 2 powr (bitlen (abs x)) - 1"
     by (auto simp: powr_real_of_int bitlen_nonneg intro!: real_le_intI)
   also have "\<dots> \<le> 2 powr m - 1"
     by (simp add: that)
   also have "\<dots> \<le> 2 powr n - 1"
     by (simp add: that)
   finally show ?thesis .
 qed
 
 lemma largest_eq:
   "largest TYPE(('e, 'f)float) =
     (2 ^ (LENGTH('f) + 1) - 1) * 2 powr real_of_int (2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1)"
 proof -
   have "2 ^ LENGTH('e) - 1 - 1 = (2::nat) ^ LENGTH('e) - 2"
     by arith
   then have "largest TYPE(('e, 'f)float) =
     (2 ^ (LENGTH('f) + 1) - 1) *
     2 powr (real (2 ^ LENGTH('e) - 2) + 1 - real (2 ^ (LENGTH('e) - 1)) - LENGTH('f))"
     unfolding largest_def emax_eq bias_def
     by (auto simp: largest_def powr_realpow[symmetric]
         powr_minus divide_simps algebra_simps powr_diff powr_add)
   also
   have "2 ^ LENGTH('e) \<ge> (2::nat)"
     by (simp add: self_le_power)
   then have "(real (2 ^ LENGTH('e) - 2) + 1 - real (2 ^ (LENGTH('e) - 1)) - LENGTH('f)) =
     (real (2 ^ LENGTH('e)) - 2 ^ (LENGTH('e) - 1) - LENGTH('f)) - 1"
     by auto
   also have "real (2 ^ LENGTH('e)) = 2 ^ LENGTH('e)" by auto
   also have "(2 ^ LENGTH('e) - 2 ^ (LENGTH('e) - 1) - real LENGTH('f) - 1) =
     real_of_int ((2 ^ (LENGTH('e) - 1) - int (LENGTH('f)) - 1))"
     by (simp, subst power_Suc[symmetric], simp)
   finally show ?thesis by simp
 qed
 
 lemma bitlen_denormal_mantissa:
   "bitlen (abs (denormal_mantissa x)) \<le> LENGTH('f)" for x::"('e, 'f)float"
 proof -
   have "fraction x < 2 ^ LENGTH('f)"
     using float_frac_le[of x]
     by (metis One_nat_def Suc_pred le_imp_less_Suc pos2 zero_less_power)
   moreover have "- int (fraction x) \<le> 2 ^ LENGTH('f)"
     using negative_zle_0 order_trans zero_le_numeral zero_le_power by blast
   ultimately show ?thesis
     by (cases x rule: sign_cases)
-      (auto simp: bitlen_le_iff_power nat_add_distrib abs_mult sign_simps
-        add_nonneg_pos denormal_mantissa_def intro!: antisym)
+      (auto simp: bitlen_le_iff_power denormal_mantissa_def intro!: antisym)
 qed
 
 lemma float_le_topfloat:
   fixes a::"('e, 'f)float"
   assumes "is_finite a" "LENGTH('e) > 1"
   shows "a \<le> topfloat"
   using assms(1)
 proof (induction a rule: float_induct)
   case (normal x)
   note normal(2)
   also have "real_of_int (normal_mantissa x) * 2 powr real_of_int (normal_exponent x) \<le>
     (2 powr (LENGTH('f) + 1) - 1) * 2 powr (2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1)"
     using normal_exponent_bounds_real(2)[OF \<open>is_normal x\<close>]
     by (auto intro!: mult_mono real_of_int_le_2_powr_bitlenI
         simp: bitlen_normal_mantissa powr_realpow[symmetric] ge_one_powr_ge_zero)
   also have "\<dots> = largest TYPE(('e, 'f) IEEE.float)"
     unfolding largest_eq
     by (auto simp: powr_realpow powr_add)
   also have "\<dots> = valof (topfloat::('e, 'f) float)"
     using assms
     by (simp add: valof_topfloat)
   finally show ?case
     by (intro float_leI normal finite_topfloat)
 next
   case (denormal x)
   note denormal(2)
   also
   have "3 \<le> 2 powr (1 + real (LENGTH('e) - Suc 0))"
   proof -
     have "3 \<le> 2 powr (2::real)" by simp
     also have "\<dots> \<le> 2 powr (1 + real (LENGTH('e) - Suc 0))"
       using assms
       by (subst powr_le_cancel_iff) auto
     finally show ?thesis .
   qed
   then have "real_of_int (denormal_mantissa x) * 2 powr real_of_int (denormal_exponent TYPE(('e, 'f)float)) \<le>
     (2 powr (LENGTH('f) + 1) - 1) * 2 powr (2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1)"
     using bitlen_denormal_mantissa[of x]
     by (auto intro!: mult_mono real_of_int_le_2_powr_bitlenI
         simp: bitlen_normal_mantissa powr_realpow[symmetric] ge_one_powr_ge_zero
         denormal_exponent_def bias_def powr_mult_base)
   also have "\<dots> \<le> largest TYPE(('e, 'f) IEEE.float)"
     unfolding largest_eq
     by (rule mult_mono)
       (auto simp: powr_realpow powr_add power_Suc[symmetric] simp del: power_Suc)
   also have "\<dots> = valof (topfloat::('e, 'f) float)"
     using assms
     by (simp add: valof_topfloat)
   finally show ?case
     by (intro float_leI denormal finite_topfloat)
 qed auto
 
 lemma float_val_le_largest:
   "valof a \<le> largest TYPE(('e, 'f)float)"
   if "is_finite a" "LENGTH('e) > 1"
   for a::"('e, 'f)float"
   by (metis that finite_topfloat float_le float_le_topfloat valof_topfloat)
 
 lemma float_val_lt_threshold:
   "valof a < threshold TYPE(('e, 'f)float)"
   if "is_finite a" "LENGTH('e) > 1"
   for a::"('e, 'f)float"
 proof -
   have "valof a \<le> largest TYPE(('e, 'f)float)"
     by (rule float_val_le_largest [OF that])
   also have "\<dots> < threshold TYPE(('e, 'f)float)"
     by (auto simp: largest_def threshold_def divide_simps)
   finally show ?thesis .
 qed
 
 
 subsection \<open>Algebraic properties about basic arithmetic\<close>
 
 text \<open>Commutativity of addition.\<close>
 lemma
   assumes "is_finite a" "is_finite b"
   shows float_plus_comm_eq: "a + b = b + a"
     and float_plus_comm: "is_finite (a + b) \<Longrightarrow> (a + b) \<doteq> (b + a)"
 proof -
   have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
     using assms by (auto simp: finite_nan finite_infinity)
   then show "a + b = b + a"
     by (simp add: float_defs fadd_def plus_float_def add.commute)
   then show "is_finite (a + b) \<Longrightarrow> (a + b) \<doteq> (b + a)"
     by (metis float_eq)
 qed
 
 text \<open>The floating-point number a falls into the same category as the negation of \<open>a\<close>.\<close>
 lemma is_zero_uminus[simp]: "is_zero (- a) \<longleftrightarrow> is_zero a"
   by (simp add: is_zero_def)
 
 lemma is_infinity_uminus [simp]: "is_infinity (- a) = is_infinity a"
   by (simp add: is_infinity_def)
 
 lemma is_finite_uminus[simp]: "is_finite (- a) \<longleftrightarrow> is_finite a"
   by (simp add: is_finite_def)
 
 lemma is_nan_uminus[simp]: "is_nan (- a) \<longleftrightarrow> is_nan a"
   by (simp add: is_nan_def)
 
 text \<open>The sign of a and the sign of a's negation is different.\<close>
 lemma float_neg_sign: "(sign a) \<noteq> (sign (- a))"
   by (cases a rule: sign_cases) (auto simp: sign_minus_float)
 
 lemma float_neg_sign1: "sign a = sign (- b) \<longleftrightarrow> sign a \<noteq> sign b"
   by (metis float_neg_sign sign_cases)
 
 lemma valof_uminus:
   assumes "is_finite a"
   shows "valof (- a) = - valof a" (is "?L = ?R")
   by (cases a rule: sign_cases)  (auto simp: valof_eq sign_minus_float)
 
 
 text \<open>Showing \<open>a + (- b) = a - b\<close>.\<close>
 lemma float_neg_add:
   "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> is_finite (a - b) \<Longrightarrow> valof a + valof (- b) = valof a - valof b"
   by (simp add: valof_uminus)
 
 lemma float_plus_minus:
   assumes "is_finite a" "is_finite b" "is_finite (a - b)"
   shows "(a + - b) \<doteq> (a - b)"
 proof -
   have nab: "\<not> is_nan a" "\<not> is_nan (- b)" "\<not> is_infinity a" "\<not> is_infinity (-  b)"
     using assms by (auto simp: finite_nan finite_infinity)
   have "a - b = (zerosign
         (if is_zero a \<and> is_zero b \<and> sign a \<noteq> sign b then (sign a) else 0)
         (round To_nearest (valof a - valof b)))"
     using nab
     by (auto simp: minus_float_def fsub_def)
   also have "\<dots> =
     (zerosign
         (if is_zero a \<and> is_zero (- b) \<and> sign a = sign (- b) then sign a else 0)
         (round To_nearest (valof a + valof (- b))))"
     using assms
     by (simp add: float_neg_sign1 float_neg_add)
   also have "\<dots> = a + - b"
     using nab by (auto simp: float_defs fadd_def plus_float_def)
   finally show ?thesis
     using assms by (metis float_eq)
 qed
 
 lemma finite_bottomfloat: "is_finite bottomfloat"
   by (simp add: finite_topfloat)
 
 lemma bottomfloat_eq_m_largest: "valof (bottomfloat::('e, 'f)float) = - largest TYPE(('e, 'f)float)"
   if "LENGTH('e) > 1"
   using that
   by (auto simp: valof_topfloat valof_uminus finite_topfloat)
 
 lemma float_val_ge_bottomfloat: "valof a \<ge> valof (bottomfloat::('e, 'f)float)"
   if "LENGTH('e) > 1" "is_finite a"
   for a::"('e,'f)float"
 proof -
   have "- a \<le> topfloat"
     using that
     by (auto intro: float_le_topfloat)
   then show ?thesis
     using that
     by (auto simp: valof_uminus finite_topfloat)
 qed
 
 lemma float_ge_bottomfloat: "is_finite a \<Longrightarrow> a \<ge> bottomfloat"
   if "LENGTH('e) > 1" "is_finite a"
   for a::"('e,'f)float"
   by (metis finite_bottomfloat float_le float_val_ge_bottomfloat that)
 
 lemma float_val_ge_largest:
   fixes a::"('e,'f)float"
   assumes "LENGTH('e) > 1" "is_finite a"
   shows "valof a \<ge> - largest TYPE(('e,'f)float)"
 proof -
   have "- largest TYPE(('e,'f)float) = valof (bottomfloat::('e,'f)float)"
     using assms
     by (simp add: bottomfloat_eq_m_largest)
   also have "\<dots> \<le> valof a"
     using assms by (simp add: float_val_ge_bottomfloat)
   finally show ?thesis .
 qed
 
 lemma float_val_gt_threshold:
   fixes a::"('e,'f)float"
   assumes "LENGTH('e) > 1" "is_finite a"
   shows "valof a > - threshold TYPE(('e,'f)float)"
 proof -
   have largest: "valof a \<ge> -largest TYPE(('e,'f)float)"
     using assms by (metis float_val_ge_largest)
   then have "-largest TYPE(('e,'f)float) > - threshold TYPE(('e,'f)float)"
     by (auto simp: bias_def threshold_def largest_def divide_simps)
   then show ?thesis
     by (metis largest less_le_trans)
 qed
 
 text \<open>Showing \<open>abs (- a) = abs a\<close>.\<close>
 lemma float_abs [simp]: "\<not> is_nan a \<Longrightarrow> abs (- a) = abs a"
   by (metis IEEE.abs_float_def float_neg_sign1 minus_minus_float zero_simps(1))
 
 lemma neg_zerosign: "- (zerosign s a) = zerosign (1 - s) (- a)"
   by (auto simp: zerosign_def)
 
 
 subsection \<open>Properties about Rounding Errors\<close>
 
 definition error :: "('e, 'f)float itself \<Rightarrow> real \<Rightarrow> real"
   where "error _ x = valof (round To_nearest x::('e, 'f)float) - x"
 
 lemma bound_at_worst_lemma:
   fixes a::"('e, 'f)float"
   assumes threshold: "\<bar>x\<bar> < threshold TYPE(('e, 'f)float)"
   assumes finite: "is_finite a"
   shows "\<bar>valof (round To_nearest x::('e, 'f)float) - x\<bar> \<le> \<bar>valof a - x\<bar>"
 proof -
   have *: "(round To_nearest x::('e,'f)float) =
       closest valof (\<lambda>a. even (fraction a)) {a. is_finite a} x"
     using threshold finite
     by auto
   have "is_closest (valof) {a. is_finite a} x (round To_nearest x::('e,'f)float)"
     using is_finite_nonempty
     unfolding *
     by (intro closest_is_closest) auto
   then show ?thesis
     using finite is_closest_def by (metis mem_Collect_eq)
 qed
 
 lemma error_at_worst_lemma:
   fixes a::"('e, 'f)float"
   assumes threshold: "\<bar>x\<bar> < threshold TYPE(('e, 'f)float)"
     and "is_finite a"
   shows "\<bar>error TYPE(('e, 'f)float) x\<bar> \<le> \<bar>valof a - x\<bar> "
   unfolding error_def
   by (rule bound_at_worst_lemma; fact)
 
 lemma error_is_zero [simp]:
   fixes a::"('e, 'f)float"
   assumes "is_finite a" "1 < LENGTH('e)"
   shows "error TYPE(('e, 'f)float) (valof a) = 0"
 proof -
   have "\<bar>valof a\<bar> < threshold TYPE(('e, 'f)float)"
     by (metis abs_less_iff minus_less_iff float_val_gt_threshold float_val_lt_threshold assms)
   then show ?thesis
     by (metis abs_le_zero_iff abs_zero diff_self error_at_worst_lemma assms(1))
 qed
 
 lemma is_finite_zerosign[simp]: "is_finite (zerosign s a) \<longleftrightarrow> is_finite a"
   by (auto simp: zerosign_def is_finite_def)
 
 lemma is_finite_closest: "is_finite (closest (v::_\<Rightarrow>real) p {a. is_finite a} x)"
   using closest_is_closest[OF is_finite_nonempty, of v x p]
   by (auto simp: is_closest_def)
 
 lemma defloat_float_zerosign_round_finite:
   assumes threshold: "\<bar>x\<bar> < threshold TYPE(('e, 'f)float)"
   shows "is_finite (zerosign s (round To_nearest x::('e, 'f)float))"
 proof -
   have "(round To_nearest x::('e, 'f)float) =
       (closest valof (\<lambda>a. even (fraction a)) {a. is_finite a} x)"
     using threshold by (metis (full_types) abs_less_iff leD le_minus_iff round.simps(1))
   then have "is_finite (round To_nearest x::('e, 'f)float)"
     by (metis is_finite_closest)
   then show ?thesis
     using is_finite_zerosign by auto
 qed
 
 lemma valof_zero[simp]: "valof 0 = 0" "valof minus_zero = 0"
   by (auto simp add: zerosign_def valof_eq zero_simps)
 
 lemma signzero_zero:
   "is_zero a \<Longrightarrow> valof (zerosign s a) = 0"
   by (auto simp add: zerosign_def)
 
 lemma val_zero: "is_zero a \<Longrightarrow> valof a = 0"
   by (cases a rule: is_zero_cases) auto
 
 lemma float_add:
   fixes a b::"('e, 'f)float"
   assumes "is_finite a"
     and "is_finite b"
     and threshold: "\<bar>valof a + valof b\<bar> < threshold TYPE(('e, 'f)float)"
   shows finite_float_add: "is_finite (a + b)"
     and error_float_add:  "valof (a + b) = valof a + valof b + error TYPE(('e, 'f)float) (valof a + valof b)"
 proof -
   have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
     using assms float_distinct_finite by auto
   then have ab: "(a + b) =
     (zerosign
       (if is_zero a \<and> is_zero b \<and> sign a = sign b then (sign a) else 0)
       (round To_nearest (valof a + valof b)))"
     using assms by (auto simp add: float_defs fadd_def plus_float_def)
   then show "is_finite ((a + b))"
     by (metis threshold defloat_float_zerosign_round_finite)
   have val_ab: "valof (a + b) =
     valof (zerosign
       (if is_zero a \<and> is_zero b \<and> sign a = sign b then (sign a) else 0)
       (round To_nearest (valof a + valof b)::('e, 'f)float))"
     by (auto simp: ab is_infinity_def is_nan_def valof_def)
   show "valof (a + b) = valof a + valof b + error TYPE(('e, 'f)float) (valof a + valof b)"
   proof (cases "is_zero (round To_nearest (valof a + valof b)::('e, 'f)float)")
     case True
     have "valof a + valof b + error TYPE(('e, 'f)float) (valof a + valof b) =
         valof (round To_nearest (valof a + valof b)::('e, 'f)float)"
       unfolding error_def
       by simp
     then show ?thesis
       by (metis True signzero_zero val_zero val_ab)
   next
     case False
     then show ?thesis
       by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
   qed
 qed
 
 lemma float_sub:
   fixes a b::"('e, 'f)float"
   assumes "is_finite a"
     and "is_finite b"
     and threshold: "\<bar>valof a - valof b\<bar> < threshold TYPE(('e, 'f)float)"
   shows finite_float_sub: "is_finite (a - b)"
     and error_float_sub: "valof (a - b) = valof a - valof b + error TYPE(('e, 'f)float) (valof a - valof b)"
 proof -
   have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
     using assms by (auto simp: finite_nan finite_infinity)
   then have ab: "a - b =
     (zerosign
       (if is_zero a \<and> is_zero b \<and> sign a \<noteq> sign b then sign a else 0)
       (round To_nearest (valof a - valof b)))"
     using assms by (auto simp add: float_defs fsub_def minus_float_def)
   then show "is_finite (a - b)"
    by (metis threshold defloat_float_zerosign_round_finite)
   have val_ab: "valof (a - b) =
     valof (zerosign
       (if is_zero a \<and> is_zero b \<and> sign a \<noteq> sign b then sign a else 0)
       (round To_nearest (valof a - valof b)::('e, 'f)float))"
     by (auto simp: ab is_infinity_def is_nan_def valof_def)
   show "valof (a - b) = valof a - valof b + error TYPE(('e, 'f)float) (valof a - valof b)"
   proof (cases "is_zero (round To_nearest (valof a - valof b)::('e, 'f)float)")
     case True
     have "valof a - valof b + error TYPE(('e, 'f)float) (valof a - valof b) =
         valof (round To_nearest (valof a - valof b)::('e, 'f)float)"
       unfolding error_def by simp
     then show ?thesis
       by (metis True signzero_zero val_zero val_ab)
   next
     case False
     then show ?thesis
       by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
   qed
 qed
 
 lemma float_mul:
   fixes a b::"('e, 'f)float"
   assumes "is_finite a"
     and "is_finite b"
     and threshold: "\<bar>valof a * valof b\<bar> < threshold TYPE(('e, 'f)float)"
   shows finite_float_mul: "is_finite (a * b)"
     and error_float_mul: "valof (a * b) = valof a * valof b + error TYPE(('e, 'f)float) (valof a * valof b)"
 proof -
   have non: "\<not> is_nan a" "\<not> is_nan b" "\<not> is_infinity a" "\<not> is_infinity b"
     using assms float_distinct_finite by auto
   then have ab: "a * b =
     (zerosign (of_bool (sign a \<noteq> sign b))
       (round To_nearest (valof a * valof b)::('e, 'f)float))"
     using assms by (auto simp: float_defs fmul_def times_float_def)
   then show "is_finite (a * b)"
     by (metis threshold defloat_float_zerosign_round_finite)
   have val_ab: "valof (a * b) =
       valof (zerosign (of_bool (sign a \<noteq> sign b))
         (round To_nearest (valof a * valof b)::('e, 'f)float))"
     by (auto simp: ab float_defs of_bool_def)
   show "valof (a * b) = valof a * valof b + error TYPE(('e, 'f)float) (valof a * valof b)"
   proof (cases "is_zero (round To_nearest (valof a * valof b)::('e, 'f)float)")
     case True
     have "valof a * valof b + error TYPE(('e, 'f)float)  (valof a * valof b) =
         valof (round To_nearest (valof a * valof b)::('e, 'f)float)"
       unfolding error_def
       by simp
     then show ?thesis
       by (metis True signzero_zero val_zero val_ab)
   next
     case False then show ?thesis
       by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
   qed
 qed
 
 lemma float_div:
   fixes a b::"('e, 'f)float"
   assumes "is_finite a"
     and "is_finite b"
     and not_zero: "\<not> is_zero b"
     and threshold: "\<bar>valof a / valof b\<bar> < threshold TYPE(('e, 'f)float)"
   shows finite_float_div: "is_finite (a / b)"
     and error_float_div: "valof (a / b) = valof a / valof b + error TYPE(('e, 'f)float) (valof a / valof b)"
 proof -
   have ab: "a / b =
     (zerosign (of_bool (sign a \<noteq> sign b))
       (round To_nearest (valof a / valof b)))"
      using assms
      by (simp add: divide_float_def fdiv_def finite_infinity finite_nan not_zero float_defs [symmetric])
   then show "is_finite (a / b)"
     by (metis threshold defloat_float_zerosign_round_finite)
   have val_ab: "valof (a / b) =
       valof (zerosign (of_bool (sign a \<noteq> sign b))
         (round To_nearest (valof a / valof b))::('e, 'f)float)"
     by (auto simp: ab float_defs of_bool_def)
   show "valof (a / b) = valof a / valof b + error TYPE(('e, 'f)float)  (valof a / valof b)"
   proof (cases "is_zero (round To_nearest (valof a / valof b)::('e, 'f)float)")
     case True
     have "valof a / valof b + error TYPE(('e, 'f)float) (valof a / valof b) =
         valof (round To_nearest (valof a / valof b)::('e, 'f)float)"
       unfolding error_def
       by simp
     then show ?thesis
       by (metis True signzero_zero val_zero val_ab)
   next
     case False then show ?thesis
       by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
   qed
 qed
 
 lemma valof_one[simp]: "valof (1::('e, 'f)float) = (if LENGTH('e) \<le> 1 then 0 else 1)"
   by transfer (auto simp: bias_def unat_sub word_1_le_power p2_eq_1)
 
 end
diff --git a/thys/Irrationality_J_Hancl/Irrationality_J_Hancl.thy b/thys/Irrationality_J_Hancl/Irrationality_J_Hancl.thy
--- a/thys/Irrationality_J_Hancl/Irrationality_J_Hancl.thy
+++ b/thys/Irrationality_J_Hancl/Irrationality_J_Hancl.thy
@@ -1,1092 +1,1092 @@
 (*
   File: Irrationality_J_Hancl.thy
   Authors:  Angeliki Koutsoukou-Argyraki and Wenda Li,
             Computer Laboratory, University of Cambridge, UK.
   Email: ak2110@cam.ac.uk, wl302@cam.ac.uk  
 *)
 
 section \<open>Irrational Rapidly Convergent Series\<close>
 theory Irrationality_J_Hancl
   imports "HOL-Analysis.Analysis" "HOL-Decision_Procs.Approximation"
 begin
 
 text \<open>This is the formalisation of a proof by J. Hancl, in particular of the proof of his Theorem 3 in
 the paper: Irrational Rapidly Convergent Series, Rend. Sem. Mat. Univ. Padova, Vol 107 (2002).
 
 The statement asserts the irrationality of the sum of a series consisting of rational numbers
 defined using sequences that fulfill certain properties. Even though the statement
 is number-theoretic, the proof uses only arguments from introductory Analysis.\<close>
 
 text \<open>We show the central result (theorem Hancl3) by proof by contradiction, by making use of some of 
  the auxiliary lemmas. To this end, assuming that the sum is a rational number, for a quantity 
  $\textrm{ALPHA}(n)$ we show that $\textrm{ALPHA}(n) \geq 1$ for all $n \in \mathbb{N}$. After that we show that we can find an 
   $n \in \mathbb{N}$ for which $\textrm{ALPHA}(n) < 1$ which yields a contradiction and we thus conclude that the 
   sum of the series is a rational number. We finally give an immediate application of theorem Hancl3
  for a specific series (corollary Hancl3corollary, requiring lemma
  summable\_ln\_plus) which corresponds to Corollary 2 in the original
 paper by J. Hancl. 
 \<close>
 
 hide_const floatarith.Max
 
 subsection \<open>Misc\<close>
 
 lemma filterlim_sequentially_iff:
   "filterlim f F1 sequentially \<longleftrightarrow> filterlim (\<lambda>x. f (x+k)) F1 sequentially"
   unfolding filterlim_iff
   apply (subst eventually_sequentially_seg)
   by auto
 
 lemma filterlim_realpow_sequentially_at_top:
   "(x::real) > 1 \<Longrightarrow> filterlim ((^) x) at_top sequentially"
   apply (rule LIMSEQ_divide_realpow_zero[THEN filterlim_inverse_at_top,of _ 1,simplified])
   by auto
 
 lemma filterlim_at_top_powr_real:
   fixes g::"'b \<Rightarrow> real"
   assumes "filterlim f at_top F" "(g \<longlongrightarrow> g') F" "g'>1"
   shows "filterlim (\<lambda>x. g x powr f x) at_top F"
 proof -
   have "filterlim (\<lambda>x. ((g'+1)/2) powr f x) at_top F" 
   proof (subst filterlim_at_top_gt[of _ _ 1],rule+)
     fix Z assume "Z>(1::real)"
     have "\<forall>\<^sub>F x in F. ln Z \<le> ln (((g' + 1) / 2) powr f x)"
       using assms(1)[unfolded filterlim_at_top,rule_format,of "ln Z / ln ((g' + 1) / 2)"]
       apply (eventually_elim)
       using \<open>g'>1\<close> by (auto simp:ln_powr divide_simps)
     then show "\<forall>\<^sub>F x in F. Z \<le> ((g' + 1) / 2) powr f x"
       apply (eventually_elim)
       apply (subst (asm) ln_le_cancel_iff)
       using \<open>Z>1\<close> \<open>g'>1\<close> by auto
   qed
   moreover have "\<forall>\<^sub>F x in F. ((g'+1)/2) powr f x \<le> g x powr f x" 
   proof -
     have "\<forall>\<^sub>F x in F. g x > (g'+1)/2"
       apply (rule order_tendstoD[OF assms(2)])
       using \<open>g'>1\<close> by auto
     moreover have "\<forall>\<^sub>F x in F. f x>0" 
       using assms(1)[unfolded filterlim_at_top_dense,rule_format,of 0] .
     ultimately show ?thesis
       apply eventually_elim
       using \<open>g'>1\<close> by (auto intro!: powr_mono2)
   qed
   ultimately show ?thesis using filterlim_at_top_mono by fast
 qed
 
 lemma powrfinitesum:
   fixes a::real and s::nat assumes  "s \<le> n"
   shows " (\<Prod>j=s..(n::nat).(a powr (2^j)))  = a powr (\<Sum>j=s..(n::nat).(2^j)) "
   using \<open>s \<le> n\<close> 
 proof(induct n)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   have ?case when "s\<le>n" using Suc.hyps 
     by (metis Suc.prems add.commute linorder_not_le powr_add prod.nat_ivl_Suc' sum.cl_ivl_Suc that)
   moreover have ?case when "s=Suc n"   
   proof-
     have "(\<Prod>j = s..Suc n. a powr 2 ^ j) =(a powr 2 ^(Suc n))  " 
       using \<open>s=Suc n\<close> by simp
     also have "(a powr 2 ^(Suc n) ) =  a powr sum ((^) 2) {s..Suc n}   " using that by auto
     ultimately show " (\<Prod>j = s..Suc n. a powr 2 ^ j) = a powr sum ((^) 2) {s..Suc n}"
       using \<open>s\<le>Suc n\<close> by linarith
   qed
   ultimately show ?case using \<open>s\<le>Suc n\<close> by linarith
 qed
 
 lemma summable_ratio_test_tendsto:
   fixes f :: "nat \<Rightarrow> 'a::banach"
   assumes "c < 1" and "\<forall>n. f n\<noteq>0" and "(\<lambda>n. norm (f (Suc n)) / norm (f n)) \<longlonglongrightarrow> c"
   shows "summable f"
 proof -
   obtain N where N_dist:"\<forall>n\<ge>N. dist (norm (f (Suc n)) / norm (f n)) c < (1-c)/2"
     using assms unfolding tendsto_iff eventually_sequentially 
     by (meson diff_gt_0_iff_gt zero_less_divide_iff zero_less_numeral)
   have "norm (f (Suc n)) / norm (f n) \<le> (1+c)/2" when "n\<ge>N" for n
     using N_dist[rule_format,OF that] \<open>c<1\<close> 
     apply (auto simp add:field_simps dist_norm)
     by argo
   then have "norm (f (Suc n))  \<le> (1+c)/2 * norm (f n)" when "n\<ge>N" for n
     using that assms(2)[rule_format, of n] by (auto simp add:divide_simps)
   moreover have "(1+c)/2 < 1" using \<open>c<1\<close> by auto 
   ultimately show ?thesis
     using summable_ratio_test[of _ N f] by blast
 qed
 
 lemma summable_ln_plus:
   fixes f::"nat \<Rightarrow> real" 
   assumes "summable f" "\<forall>n. f n>0"
   shows "summable (\<lambda>n. ln (1+f n))"
 proof (rule summable_comparison_test_ev[OF _ assms(1)])
   have "ln (1 + f n) > 0" for n by (simp add: assms(2) ln_gt_zero)
   moreover have "ln (1 + f n) \<le> f n" for n 
     apply (rule ln_add_one_self_le_self2)
     using assms(2)[rule_format,of n] by auto 
   ultimately show "\<forall>\<^sub>F n in sequentially. norm (ln (1 + f n)) \<le> f n"
     by (auto intro!: eventuallyI simp add:less_imp_le) 
 qed
 
 lemma suminf_real_offset_le:
   fixes f :: "nat \<Rightarrow> real"
   assumes f: "\<And>i. 0 \<le> f i" and "summable f"
   shows "(\<Sum>i. f (i + k)) \<le> suminf f"
 proof -
   have "(\<lambda>n. \<Sum>i<n. f (i + k)) \<longlonglongrightarrow> (\<Sum>i. f (i + k))"
     using summable_sums[OF \<open>summable f\<close>] 
     by (simp add: assms(2) summable_LIMSEQ summable_ignore_initial_segment)
   moreover have "(\<lambda>n. \<Sum>i<n. f i) \<longlonglongrightarrow> (\<Sum>i. f i)"
     using summable_sums[OF \<open>summable f\<close>] by (simp add: sums_def atLeast0LessThan f)
   then have "(\<lambda>n. \<Sum>i<n + k. f i) \<longlonglongrightarrow> (\<Sum>i. f i)"
     by (rule LIMSEQ_ignore_initial_segment)
   ultimately show ?thesis
   proof (rule LIMSEQ_le, safe intro!: exI[of _ k])
     fix n assume "k \<le> n"
     have "(\<Sum>i<n. f (i + k)) = (\<Sum>i<n. (f \<circ> (\<lambda>i. i + k)) i)"
       by simp
     also have "\<dots> = (\<Sum>i\<in>(\<lambda>i. i + k) ` {..<n}. f i)"
       by (subst sum.reindex) auto
     also have "\<dots> \<le> sum f {..<n + k}"
       by (intro sum_mono2) (auto simp: f)
     finally show "(\<Sum>i<n. f (i + k)) \<le> sum f {..<n + k}" .
   qed
 qed
 
 
 
 lemma factt:
   fixes s n ::nat assumes "s \<le> n" 
   shows " (\<Sum>i=s..n. 2^i) < (2^(n+1) :: real) " using assms
 proof (induct n)
   case 0
   show ?case by  auto 
 next
   case (Suc n)
   have ?case when  "s=n+1" using that by auto
   moreover have ?case when  "s \<noteq> n+1" 
   proof -
     have"(\<Sum>i=s..(n+1). 2^i ) = (\<Sum>i=s..n. 2^i ) + (2::real)^(n+1) "
       using sum.cl_ivl_Suc \<open>s \<le> Suc n \<close>
       by (auto simp add:add.commute)
     also have "... < (2) ^ (n +1) + (2)^(n+1)" 
     proof -
       have "s \<le>n" using that  \<open>s \<le> Suc n \<close> by auto
       then show ?thesis
         using Suc.hyps \<open>s \<le> n\<close> by linarith
     qed
     also have "... = 2^(n+2)" by simp
     finally show "(\<Sum>i=s..(Suc n). 2^i )< (2::real)^(Suc n+1)" by auto
   qed
   ultimately show ?case by blast
 qed
 
 subsection \<open>Auxiliary lemmas and the main proof\<close>
 
 lemma showpre7:
   fixes a b ::"nat\<Rightarrow>int " and q p::int
   assumes "q>0" and "p>0"and a: "\<forall>n. a n>0" and "\<forall>n. b n>0" and 
     assumerational:"(\<lambda> n. b (n+1) / a (n+1) )  sums (p/q)"
   shows "q*((\<Prod>j=1..n. of_int( a j)))*(suminf (\<lambda>(j::nat). (b (j+n+1)/ a (j+n+1 )))) 
         = ((\<Prod>j=1..n. of_int( a j)))*(p -q* (\<Sum>j=1..n. b j / a j))       " 
 proof -
   define aa where "aa=(\<Prod>j = 1..n. real_of_int (a j))"
   define ff where "ff=(\<lambda>i. real_of_int (b (i+1)) / real_of_int (a (i+1)))"
 
   have "(\<Sum>j. ff (j+n)) =  (\<Sum>n. ff n) - sum ff {..<n}"
     apply (rule suminf_minus_initial_segment)
     using assumerational unfolding ff_def by (simp add: sums_summable)
   also have "... = p/q - sum ff {..<n}"
     using assumerational unfolding ff_def by (simp add: sums_iff)
   also have "... = p/q - (\<Sum>j=1..n. ff (j-1))"
   proof -
     have "sum ff {..<n} = (\<Sum>j=1..n. ff (j-1))"
       apply (subst sum_bounds_lt_plus1[symmetric])
       by simp
     then show ?thesis unfolding ff_def by auto
   qed
   finally have "(\<Sum>j. ff (j + n)) = p / q - (\<Sum>j = 1..n. ff (j - 1))" .
   then have "q*(\<Sum>j. ff (j + n)) = p - q*(\<Sum>j = 1..n. ff (j - 1))"
     using \<open>q>0\<close> by (auto simp add:field_simps)
   then have "aa*q*(\<Sum>j. ff (j + n)) = aa*(p - q*(\<Sum>j = 1..n. ff (j - 1)))" 
     by auto
   then show ?thesis unfolding aa_def ff_def by auto
 qed
 
 lemma show7:
   fixes d::"nat\<Rightarrow>real" and a b::"nat\<Rightarrow>int " and q p::int
   assumes "q \<ge>1" and "p \<ge> 1" and a: "\<forall>n. a n \<ge> 1" and "\<forall>n. b n \<ge> 1"
     and assumerational:"(\<lambda> n. b (n+1) / a (n+1) ) sums (p/q)"
   shows "q*((\<Prod>j=1..n. of_int( a j)))*( suminf (\<lambda> (j::nat). (b (j+n+1)/ a (j+n+1 )))) \<ge> 1 "
     (is "?L \<ge> _")
 proof-
   define LL where "LL=?L"
   define aa where "aa=(\<Prod>j = 1..n. real_of_int (a j))"
   define ff where "ff=(\<lambda>i. real_of_int (b (i+1)) / real_of_int (a (i+1)))"
 
   have "?L > 0"
   proof -
     have "aa > 0"
       unfolding aa_def using a
       apply (induct n,auto)
       by (simp add: int_one_le_iff_zero_less prod_pos)
     moreover have "(\<Sum>j. ff (j + n)) > 0"
     proof (rule suminf_pos)
       have "summable ff" unfolding ff_def using assumerational
         using summable_def by blast
       then show " summable (\<lambda>j. ff (j + n))" using summable_iff_shift[of ff n] by auto
       show " \<forall>i. 0 < ff (i + n)" unfolding ff_def using a assms(4) int_one_le_iff_zero_less by auto
     qed
     ultimately show ?thesis unfolding aa_def ff_def using \<open>q\<ge>1\<close> by auto
   qed
   moreover have "?L \<in> \<int>"
   proof -
     have "?L = aa *(p -q* ( \<Sum>j=1..n. b j / a j))"
       unfolding aa_def
       apply (rule showpre7)
       using assms int_one_le_iff_zero_less by auto
     also have "... = aa * p - q * (\<Sum>j=1..n. aa * b j / a j)"
       by (auto simp add:algebra_simps sum_distrib_left)
     also have "... = prod a {1..n} * p - q * (\<Sum>j = 1..n. b j * prod a ({1..n} - {j}))"
     proof -
       have "(\<Sum>j=1..n. aa * b j / a j) = (\<Sum>j=1..n. b j * prod a ({1..n} - {j}))"
         unfolding of_int_sum
       proof (rule sum.cong)
         fix x assume "x \<in> {1..n}"
         then have "(\<Prod>i = 1..n. real_of_int (a i)) = a x * (\<Prod>i\<in>{1..n} - {x}. real_of_int (a i))"
           apply (rule_tac prod.remove)
           by auto
         then have "aa / real_of_int (a x) = prod a ({1..n} - {x})"
           unfolding aa_def using a[rule_format,of x] by (auto simp add:field_simps)
         then show "aa * b x / a x = b x * prod a ({1..n} - {x})"
           by (metis mult.commute of_int_mult times_divide_eq_right)
       qed simp
       moreover have "aa * p = (\<Prod>j = 1..n.  (a j)) *  p"
         unfolding aa_def by auto
       ultimately show ?thesis by force
     qed
     also have "... \<in> \<int>" using Ints_of_int by blast
     finally show ?thesis .
   qed
   ultimately show ?thesis 
     apply (fold LL_def)
     by (metis Ints_cases int_one_le_iff_zero_less not_less of_int_0_less_iff of_int_less_1_iff)
 qed
 
 lemma show8:
   fixes d ::"nat\<Rightarrow>real " and a :: "nat\<Rightarrow>int" and s k::nat 
   assumes "A > 1" and d: "\<forall>n. d n> 1"  and a:"\<forall>n. a n>0" and "s>0"
     and "convergent_prod d"
     and assu2: "\<forall>n \<ge> s. ( A/ (of_int (a n)) powr(1/of_int (2^n)))> prodinf (\<lambda>j. d(n +j))"
   shows "\<forall>n\<ge>s. prodinf (\<lambda>j. d(j+n)) < A/(Max ((\<lambda>(j::nat). 
                   (of_int (a j)) powr(1 /of_int (2^j))) ` {s..n}))"
 proof(rule,rule)
   fix n assume "s \<le> n"
   define sp where "sp = (\<lambda>n. prodinf (\<lambda>j. d(j+n)))"
   define ff where "ff = (\<lambda>(j::nat). (real_of_int (a j)) powr(1 /of_int (2^j)))"
   have "sp i \<ge> sp n" when "i\<le>n" for i
   proof -
     have "(\<Prod>j. d (j + i)) = (\<Prod>ia. d (ia + (n - i) + i)) * (\<Prod>ia<n - i. d (ia + i))"
       apply (rule prodinf_split_initial_segment) 
       subgoal using \<open>convergent_prod d\<close> convergent_prod_iff_shift[of d i] by simp
       subgoal for j using d[rule_format,of "j+i"] by auto
       done
     then have "sp i = sp n * (\<Prod>j<n - i. d (i + j))"
       unfolding sp_def using \<open>n\<ge>i\<close> by (auto simp:algebra_simps)
     moreover have "sp i>1" "sp n>1" 
       unfolding sp_def using convergent_prod_iff_shift \<open>convergent_prod d\<close> d 
       by (auto intro!:less_1_prodinf)
     moreover have "(\<Prod>j<n - i. d (i + j)) \<ge>1" 
       apply (rule prod_ge_1)
       using d less_imp_le by auto
     ultimately show ?thesis by auto
   qed
   moreover have "\<forall>j\<ge>s. A / ff j > sp j" 
     unfolding ff_def sp_def using assu2 by (auto simp:algebra_simps)
   ultimately have "\<forall>j. s\<le>j \<and> j\<le>n \<longrightarrow> A / ff j > sp n" by force
   then show "sp n< A / Max (ff ` {s..n})" 
     by (metis (mono_tags, hide_lams) Max_in \<open>n\<ge>s\<close> atLeastAtMost_iff empty_iff 
         finite_atLeastAtMost finite_imageI imageE image_is_empty order_refl)
 qed
 
 lemma auxiliary1_9:
   fixes d ::"nat\<Rightarrow>real" and a::"nat\<Rightarrow>int " and s m::nat 
   assumes d: "\<forall>n. d n> 1"  and a: "\<forall>n. a n>0" and "s>0" and "n \<ge> m" and " m \<ge> s"
     and auxifalse_assu: "\<forall>n\<ge>m. (of_int (a (n+1))) powr(1 /of_int (2^(n+1))) <
               (d (n+1))* (Max ((\<lambda> (j::nat). (of_int (a j)) powr(1 /of_int (2^j))) ` {s..n} ))"
   shows "(of_int (a (n+1))) powr(1 /of_int (2^(n+1))) <
     (\<Prod>j=(m+1)..(n+1). d j) * (Max ((\<lambda> (j::nat). (of_int (a j)) powr(1 /of_int (2^j))) ` {s..m}))"
 proof-
   define ff where "ff = (\<lambda>(j::nat). (real_of_int (a j)) powr(1 /of_int (2^j)))"
   have [simp]:"ff j > 0" for j
     unfolding ff_def by (metis a less_numeral_extra(3) of_int_0_less_iff powr_gt_zero)
 
   have ff_asm:"ff (n+1) < d (n+1) * Max (ff ` {s..n})" when "n\<ge>m" for n
     using auxifalse_assu that unfolding ff_def by simp
   from \<open>n\<ge>m\<close>
   have Q: "(Max( ff ` {s..n} )) \<le> (\<Prod>j=(m+1)..n. d j)* (Max (ff ` {s..m}))"
   proof(induct n)
     case 0
     then show ?case using \<open>m\<ge>s\<close> by simp 
   next
     case (Suc n)
     have ?case when "m=Suc n"
       using that by auto
     moreover have ?case when "m\<noteq>Suc n" 
     proof -
       have "m \<le> n" using that Suc(2) by simp
       then have IH:"Max (ff ` {s..n}) \<le> prod d {m + 1..n} * Max (ff ` {s..m})"
         using Suc(1) by linarith
       have "Max (ff ` {s..Suc n}) = Max (ff ` {s..n} \<union> {ff (Suc n)})"
         using Suc.prems assms(5) atLeastAtMostSuc_conv by auto
       also have "... = max (Max (ff ` {s..n})) (ff (Suc n))"
         using Suc.prems assms(5) max_def sup_assoc that by auto
       also have "... \<le> max (Max (ff ` {s..n})) (d (n+1) * Max (ff ` {s..n}))"
         apply (rule max.mono)
         using ff_asm[of n] \<open> m \<le> Suc n\<close> that \<open>s\<le>m\<close> by auto
       also have "... \<le> Max (ff ` {s..n}) * max 1 (d (n+1))"
       proof -
         have "Max (ff ` {s..n}) \<ge>0" 
           by (metis (mono_tags, hide_lams) Max_in \<open>\<And>j. 0 < ff j\<close> \<open>m \<le> n\<close> assms(5) 
               atLeastAtMost_iff empty_iff finite_atLeastAtMost finite_imageI imageE 
               image_is_empty less_eq_real_def)
         then show ?thesis using max_mult_distrib_right 
           by (simp add: max_mult_distrib_right mult.commute)
       qed
       also have "... = Max (ff ` {s..n}) * d (n+1)"
         using d[rule_format, of "n+1"] by auto
       also have "... \<le>  prod d {m + 1..n} * Max (ff ` {s..m}) * d (n+1)"
         using IH d[rule_format, of "n+1"] by auto
       also have "... = prod d {m + 1..n+1} * Max (ff ` {s..m})"
         using \<open>n\<ge>m\<close> by (simp add:prod.nat_ivl_Suc' algebra_simps)
       finally show ?case by simp
     qed
     ultimately show ?case by blast
   qed
   then have "d (n+1) * Max (ff ` {s..n} ) \<le> (\<Prod>j=(m+1)..(n+1). d j)* (Max (ff ` {s..m}))"
     using \<open>m\<le>n\<close> d[rule_format,of "Suc n"] by (simp add:prod.nat_ivl_Suc')
   then show ?thesis using ff_asm[of n] \<open>s\<le>m\<close> \<open>m\<le>n\<close> unfolding ff_def by auto
 qed
 
 lemma show9:
   fixes d ::"nat\<Rightarrow>real " and a :: "nat\<Rightarrow>int " and s ::nat and A::real
   assumes   "A > 1" and  d: "\<forall>n. d n> 1"  and a: "\<forall>n. a n>0" and "s>0"  
     and assu1: "(( \<lambda> n. (of_int (a n)) powr(1 /of_int (2^n)))\<longlongrightarrow> A) sequentially "
     and "convergent_prod d"
     and 8: "\<forall>n\<ge>s. prodinf (\<lambda>j. d( n+j)) 
                   < A/(Max ((\<lambda>(j::nat). (of_int (a j)) powr(1 /of_int (2^j))) ` {s..n})) "
   shows "\<forall>m \<ge>s. \<exists>n\<ge>m.  ( (of_int (a (n+1))) powr(1 /of_int (2^(n+1))) \<ge>
           (d (n+1))* (Max ( ( \<lambda> (j::nat). (of_int (a j)) powr(1 /of_int (2^j))) ` {s..n} )))"
 proof (rule ccontr)
   define ff where "ff = (\<lambda>(j::nat). (real_of_int (a j)) powr(1 /of_int (2^j)))"
   assume assumptioncontra: " \<not> (\<forall>m \<ge>s. \<exists>n\<ge>m.  ( (ff (n+1)) \<ge> (d (n+1))* (Max ( ff  ` {s..n}))))"
 
   then obtain  t where "t\<ge>s" and
     ttt: "  \<forall>n\<ge>t.  ( (ff (n+1)) < (d (n+1))* (Max ( ff ` {s..n} ) ))"               
     by fastforce
   define B where "B=prodinf (\<lambda>j. d(t+1+j))"
   have "B>0" unfolding B_def 
     apply (rule less_0_prodinf)
     subgoal using convergent_prod_iff_shift[of d "t+1"] \<open>convergent_prod d\<close> 
       by (auto simp:algebra_simps)
     subgoal using d le_less_trans zero_le_one by blast
     done
 
   have "A \<le> B * Max ( ff ` {s..t})"
   proof (rule tendsto_le[of sequentially "\<lambda>n. (\<Prod>j=(t+1)..(n+1). d j) * Max ( ff ` {s..t})" _ 
         "\<lambda>n. ff (n+1)"])
     show "(\<lambda>n. ff (n + 1)) \<longlonglongrightarrow> A"
       using assu1[folded ff_def] LIMSEQ_ignore_initial_segment by blast
     have "(\<lambda>n. prod d {t + 1..n + 1}) \<longlonglongrightarrow> B"
     proof -
       have "(\<lambda>n. \<Prod>i\<le>n. d (t + 1 + i)) \<longlonglongrightarrow> B"
         apply (rule convergent_prod_LIMSEQ[of "(\<lambda>j. d(t+1+j))",folded B_def])
         using \<open>convergent_prod d\<close> convergent_prod_iff_shift[of d "t+1"] by (simp add:algebra_simps)
       then have "(\<lambda>n. \<Prod>i\<in>{0..n}. d (i+(t + 1))) \<longlonglongrightarrow> B"
         using atLeast0AtMost by (auto simp:algebra_simps)
       then have "(\<lambda>n. prod d {(t + 1)..n + (t + 1)}) \<longlonglongrightarrow> B" 
         apply (subst (asm) prod.shift_bounds_cl_nat_ivl[symmetric])
         by simp
       from seq_offset_neg[OF this,of "t"]
       show "(\<lambda>n. prod d {t + 1..n+1}) \<longlonglongrightarrow> B"
         apply (elim Lim_transform)
         apply (rule LIMSEQ_I)
         apply (rule exI[where x="t+1"])
         by auto
     qed
     then show "(\<lambda>n. prod d {t + 1..n + 1} * Max (ff ` {s..t})) \<longlonglongrightarrow> B * Max (ff ` {s..t})" 
       by (auto intro:tendsto_eq_intros)
     have "\<forall>\<^sub>F n in sequentially. (ff (n+1)) < (\<Prod>j=(t+1)..(n+1). d j) * (Max ( ff ` {s..t}))"
       unfolding eventually_sequentially ff_def
       using auxiliary1_9[OF d a \<open>s>0\<close> _ \<open>t\<ge>s\<close> ttt[unfolded ff_def]]
       by blast
     then show "\<forall>\<^sub>F n in sequentially. (ff (n+1)) \<le> (\<Prod>j=(t+1)..(n+1). d j) * (Max ( ff ` {s..t}))"
       by (eventually_elim,simp)
   qed simp
   also have "... \<le> B * Max ( ff ` {s..t+1})"
   proof -
     have "Max (ff ` {s..t}) \<le> Max (ff ` {s..t + 1})"
       apply (rule Max_mono)
       using \<open>t\<ge>s\<close> by auto
     then show ?thesis using \<open>B>0\<close> by auto
   qed
   finally have "A \<le> B * Max (ff ` {s..t + 1})" 
     unfolding B_def .
   moreover have "B < A / Max (ff ` {s..t + 1})"
     using 8[rule_format, of "t+1",folded ff_def B_def] \<open>s\<le>t\<close> by auto
   moreover have "Max (ff ` {s..t+1})>0"
     using \<open>A \<le> B * Max (ff ` {s..t + 1})\<close> \<open>B>0\<close> \<open>A>1\<close>
-    by (smt linordered_field_class.sign_simps(44))
+      zero_less_mult_pos [of B "Max (ff ` {s..Suc t})"]
+    by simp
   ultimately show False by (auto simp add:field_simps)
 qed
 
 lemma show10:
   fixes d ::"nat\<Rightarrow>real " and  a ::"nat\<Rightarrow>int " and s::nat
   assumes d: "\<forall>n. d n> 1" and a: "\<forall>n. a n>0"  and " s>0"
     and 9: "\<forall>m \<ge>s. \<exists>n\<ge>m.  ((of_int (a (n+1))) powr(1 /of_int (2^(n+1))) \<ge>
           (d (n+1))* (Max ((\<lambda>(j::nat). (of_int (a j)) powr(1 /of_int (2^j))) ` {s..n} )))"
   shows "\<forall>m\<ge>s. \<exists>n\<ge>m. (((d (n+1))powr(2^(n+1))) * (\<Prod>j=1..n. of_int( a j)) * 
             (1/ (\<Prod>j=1..s-1. (of_int( a j) )))) \<le> (a (n+1)) "
 proof (rule,rule)
   fix m assume "s \<le> m" 
   from 9[rule_format,OF this]
   obtain n where "n\<ge>m" and asm_9:"( (of_int (a (n+1))) powr(1 /of_int (2^(n+1))) \<ge>
           (d (n+1))* (Max ( ( \<lambda> (j::nat). (of_int (a j)) powr(1 /of_int (2^j))) ` {s..n} )))"
     by auto
   with \<open>s\<le>m\<close> have "s\<le>n" by auto
 
   have prod:"(\<Prod>j=1..n. real_of_int( a j)) * ( 1/ (\<Prod>j=1..s-1. (of_int( a j) )))
           = (\<Prod>j=s..n. of_int( a j))"
   proof -
     define f where "f= (\<lambda>j. real_of_int( a j))"
     have "{Suc 0..n}= {Suc 0..s - Suc 0} \<union> {s..n}" using \<open>n\<ge>s\<close>  \<open>s >0\<close>
       by auto
     then have "(\<Prod>j=1..n. f j) = (\<Prod>j=1..s-1. f j) * (\<Prod>j=s..n. f j)"
       apply (subst prod.union_disjoint[symmetric])
       by auto
     moreover have "(\<Prod>j=1..s-1. f j) > 0 "
       apply (rule linordered_semidom_class.prod_pos)
       using a unfolding f_def by auto
     then have "(\<Prod>j=1..s-1. f j) \<noteq> 0" by argo
     ultimately show ?thesis unfolding f_def by auto 
   qed
   then have " (((d (n+1))powr(2^(n+1) )) * (\<Prod>j=1..n. of_int( a j)) * ( 1/ (\<Prod>j=1..s-1. (of_int( a j) ))))
                 =(((d (n+1))powr(2^(n+1) )) * (\<Prod>j=s..n. of_int( a j)))" 
   proof -
     define f where "f= (\<lambda>j. real_of_int( a j))"
     define c where "c = (d (n+1))powr(2^(n+1))"
     show ?thesis using prod
       apply (fold f_def c_def)
       by (metis mult.assoc) 
   qed
   also have
     "... \<le> ((d (n+1))powr(2^(n+1) ) * (\<Prod>i=s..n. (Max(( \<lambda> (j::nat). ( of_int( a j) powr(1 /real_of_int (2^j)) )) ` {s..n  } ))   powr(2^i)) )"
   proof (rule mult_left_mono)
     show "0 \<le> (d (n + 1)) powr 2 ^ (n + 1)"
       by auto
     show "(\<Prod>j = s..n. real_of_int (a j))
     \<le> (\<Prod>i = s..n.
            Max ((\<lambda>j. real_of_int (a j) powr (1 / real_of_int (2 ^ j))) `
                 {s..n}) powr
            2 ^ i)"
     proof (rule prod_mono)
       fix i assume i: "i \<in> {s..n}"
       have "real_of_int (a i) = (real_of_int (a i) powr (1 / real_of_int (2 ^ i))) powr 2 ^ i"
         unfolding powr_powr by (simp add: a less_eq_real_def)
       also have  "\<dots> \<le>  (Max(( \<lambda> (j::nat). ( real_of_int( a j) powr(1 /real_of_int (2^j)))) ` {s..n}))powr(2^i)" 
       proof (rule powr_mono2)
         show "real_of_int (a i) powr (1 / real_of_int (2 ^ i))
                   \<le> Max ((\<lambda>j. real_of_int (a j) powr (1 / real_of_int (2 ^ j))) ` {s..n})" 
           apply (rule Max_ge)
            apply auto
           using i by blast
       qed simp_all
       finally have "real_of_int (a i) \<le> Max ((\<lambda>j. real_of_int (a j) powr (1 / real_of_int (2 ^ j))) ` {s..n}) powr 2 ^ i" .
       then show "0 \<le> real_of_int (a i) \<and>
          real_of_int (a i)
          \<le> Max ((\<lambda>j. real_of_int (a j) powr (1 / real_of_int (2 ^ j))) `
                  {s..n}) powr
             2 ^ i"
         using a i
         by (metis \<open>real_of_int (a i) = (real_of_int (a i) powr (1 / real_of_int (2 ^ i))) powr 2 ^ i\<close> 
             powr_ge_pzero)
     qed
   qed
   also have "... = ((d (n+1))powr(2^(n+1) )) * (Max(( \<lambda> (j::nat). ( of_int( a j) powr 
                       (1 /of_int (2^j)) )) ` {s..n  } )) powr (\<Sum>i=s..n. 2^i ) "
   proof-
     have  "((d (n+1))powr(2^(n+1) ))\<ge>1  "
       by (metis Transcendental.log_one  d le_powr_iff zero_le_numeral zero_le_power zero_less_one)
     moreover have "(\<Prod>i=s..n. (Max(( \<lambda> (j::nat). ( of_int( a j) powr(1 /real_of_int (2^j)) )) ` {s..n  } ) )   powr(2^i))     = (Max(( \<lambda> (j::nat). ( of_int( a j) powr(1 /of_int (2^j)) )) ` {s..n  } )) powr (\<Sum>i=s..n. 2^i )  "
     proof -
       define ff where "ff = Max (( \<lambda> (j::nat). ( of_int( a j) powr(1 /real_of_int (2^j)) )) ` {s..n  } )"
       show ?thesis apply (fold ff_def)
         using \<open>s\<le>n\<close>  powrfinitesum by auto
     qed 
     ultimately show ?thesis by auto
   qed
   also have "... \<le>   ((d (n+1))powr(2^(n+1) )) * 
                 (Max(( \<lambda> (j::nat).( of_int( a j) powr(1 /of_int (2^j)) )) ` {s..n  })) powr(2^(n+1))   "
 
   proof -
     define ff where "ff = Max (( \<lambda> (j::nat). ( of_int( a j) powr(1 /real_of_int (2^j)) )) ` {s..n  } )"
     have " sum ((^) 2) {s..n} < (2::real) ^ (n + 1)" using factt \<open>s\<le>n\<close>  by auto
     moreover have "1 \<le> ff" 
     proof -
       define S where "S=(\<lambda>(j::nat). ( of_int( a j) powr(1 /real_of_int (2^j)) )) ` {s..n  }"
       have "finite S" unfolding S_def by auto
       moreover have "S\<noteq>{}" unfolding S_def using \<open>s\<le>n\<close>  by auto
       moreover have "\<exists>x\<in>S. x\<ge>1"
       proof-
         have " ( of_int( a s) powr(1 /real_of_int (2^s)) ) \<ge> 1  "  
           apply (rule ge_one_powr_ge_zero)
            apply auto
           by (simp add: a int_one_le_iff_zero_less)
         moreover have " ( of_int( a s) powr(1 /real_of_int (2^s)) ) \<in> S" 
           unfolding S_def
           apply (rule rev_image_eqI[where x=s])
           using \<open>s\<le>n\<close> by auto
         ultimately show ?thesis by auto
       qed
       ultimately show ?thesis 
         using Max_ge_iff[of S 1] unfolding S_def ff_def by blast
     qed
     moreover have "0 \<le> (d (n + 1)) powr 2 ^ (n + 1)" by auto
     ultimately show ?thesis
       apply(fold ff_def)
       apply (rule mult_left_mono)
        apply (rule powr_mono)
       by auto
   qed
 
   also have "... =  ((d (n+1)) * 
                       (Max((\<lambda>j. (of_int( a j) powr(1 /of_int (2^j)))) ` {s..n}))) powr(2^(n+1))"
   proof -
     define ss where "ss = (\<lambda>j. real_of_int (a j) powr (1 / real_of_int (2 ^ j))) ` {s..n}"
     have "d (n + 1) \<ge>0" using d[rule_format,of "n+1"] by argo
     moreover have "Max ss \<ge>0" 
     proof -
       have "(a s) powr (1 /  (2 ^ s)) \<ge> 0" by auto
       moreover have "(a s) powr (1 /  (2 ^ s)) \<in> ss" unfolding ss_def 
         apply (rule_tac x=s in rev_image_eqI)
         using \<open>s\<le>n\<close> by auto
       moreover have "finite ss" "ss \<noteq> {}" unfolding ss_def using \<open>s\<le>n\<close> by auto
       ultimately show ?thesis using Max_ge_iff[of ss 0] by blast
     qed
     ultimately show ?thesis 
       apply (fold ss_def)
       using powr_mult by auto
   qed
   also have "... \<le> (real_of_int (a (n + 1)) powr (1 / real_of_int (2 ^ (n + 1)))) powr 2 ^ (n + 1)"
   proof - 
     define ss where "ss = (\<lambda>j. real_of_int (a j) powr (1 / real_of_int (2 ^ j))) ` {s..n}"
     show ?thesis 
     proof (fold ss_def,rule powr_mono2)
       have "Max ss \<ge>0" \<comment> \<open>NOTE: we are repeating the same proof, so it may be a good idea to put 
                             this conclusion in an outer block so that it can be reused 
                             (without reproving).\<close>
       proof -
         have "(a s) powr (1 /  (2 ^ s)) \<ge> 0" by auto
         moreover have "(a s) powr (1 /  (2 ^ s)) \<in> ss" unfolding ss_def 
           apply (rule_tac x=s in rev_image_eqI)
           using \<open>s\<le>n\<close> by auto
         moreover have "finite ss" "ss \<noteq> {}" unfolding ss_def using \<open>s\<le>n\<close> by auto
         ultimately show ?thesis using Max_ge_iff[of ss 0] by blast
       qed
       moreover have "d (n + 1) \<ge>0" 
         using d[rule_format,of "n+1"] by argo
       ultimately show "0 \<le> (d (n + 1)) * Max ss" by auto
       show "(d (n + 1)) * Max ss \<le> real_of_int (a (n + 1)) powr (1 / real_of_int (2 ^ (n + 1)))"
         using asm_9[folded ss_def] .
     qed simp    
   qed
   also have "... =  (of_int (a (n+1)))" 
     by (simp add: a less_eq_real_def pos_add_strict powr_powr)
   finally show "\<exists>n\<ge>m. d (n + 1) powr 2 ^ (n + 1) * (\<Prod>j = 1..n. real_of_int (a j)) *
                 (1 / (\<Prod>j = 1..s - 1. real_of_int (a j)))
                 \<le> real_of_int (a (n + 1))" using \<open>n\<ge>m\<close> \<open>m\<ge>s\<close> 
     apply (rule_tac x=n in exI)
     by auto
 qed
 
 lemma lasttoshow:
   fixes d ::"nat\<Rightarrow>real " and a b ::"nat\<Rightarrow>int " and q::int and s::nat
   assumes d: "\<forall>n. d n> 1" and a:"\<forall>n. a n>0" and "s>0" and "q>0"  
     and "A > 1" and b:"\<forall>n. b n>0" and 9:
     "\<forall>m\<ge>s. \<exists>n\<ge>m. ((of_int (a (n+1))) powr(1 /of_int (2^(n+1))) \<ge>
           (d (n+1))* (Max ((\<lambda>(j::nat). (of_int (a j)) powr(1 /of_int (2^j))) ` {s..n} )))"
     and assu3: "filterlim( \<lambda> n. (d n)^(2^n)/ b n) at_top sequentially "
     and 5: "\<forall>\<^sub>F n in sequentially. (\<Sum>j. (b (n + j)) /  (a (n + j))) \<le> 2 * b n / a n"
   shows "\<exists>n. q*((\<Prod>j=1..n. real_of_int(a j))) * suminf (\<lambda>(j::nat). (b (j+n+1)/ a (j+n+1)))<1"
 proof-
   define as where "as=(\<Prod>j = 1..s - 1. real_of_int (a j))"
   obtain n where "n\<ge>s" and n_def1:"real_of_int q * as * 2 
       * real_of_int (b (n + 1)) / d (n + 1) powr 2 ^ (n + 1) < 1"
     and n_def2:"d (n + 1) powr 2 ^ (n + 1) * (\<Prod>j = 1..n. real_of_int (a j)) * (1 / as) 
           \<le> real_of_int (a (n + 1))"
     and n_def3:"(\<Sum>j. (b (n+1 + j)) /  (a (n+1 + j))) \<le> 2 * b (n+1) / a (n+1)"
   proof -
     have *:"(\<lambda>n. real_of_int (b n) / d n ^ 2 ^ n) \<longlonglongrightarrow> 0"
       using tendsto_inverse_0_at_top[OF assu3] by auto
     then have "(\<lambda>n. real_of_int (b n) / d n powr 2 ^ n) \<longlonglongrightarrow> 0"
     proof -
       have "d n ^ 2 ^ n = d n powr (of_nat (2 ^ n))" for n 
         apply (subst powr_realpow)
         using d[rule_format, of n] by auto
       then show ?thesis using * by auto
     qed
     from tendsto_mult_right_zero[OF this,of "q * as * 2"] 
     have "(\<lambda>n. q * as * 2 * b n / d n powr 2 ^ n) \<longlonglongrightarrow> 0"
       by auto
     then have "\<forall>\<^sub>F n in sequentially. q * as * 2 * b n / d n powr 2 ^ n < 1"
       by (elim order_tendstoD) simp
     then have "\<forall>\<^sub>F n in sequentially. q * as * 2 * b n / d n powr 2 ^ n < 1 
                   \<and> (\<Sum>j. (b (n + j)) /  (a (n + j))) \<le> 2 * b n / a n"
       using 5 by eventually_elim auto
     then obtain N where N_def:"\<forall>n\<ge>N. q * as * 2 * b n / d n powr 2 ^ n < 1 
             \<and> (\<Sum>j. (b (n + j)) /  (a (n + j))) \<le> 2 * b n / a n"
       unfolding eventually_sequentially by auto
     obtain n where "n\<ge>s" and "n\<ge>N" and n_def:"d (n + 1) powr 2 ^ (n + 1) 
                 * (\<Prod>j = 1..n. of_int (a j)) * (1 / as) \<le> real_of_int (a (n + 1))"
       using show10[OF d a \<open>s>0\<close> 9,folded as_def,rule_format,of "max s N"] by auto
     with N_def[rule_format, of "n+1"] that[of n]  show ?thesis by auto
   qed
 
   define pa where "pa = (\<Prod>j = 1..n. real_of_int (a j))"
   define dn where "dn = d (n + 1) powr 2 ^ (n + 1)"
   have [simp]:"dn >0" "as > 0" 
     subgoal unfolding dn_def by (metis d not_le numeral_One powr_gt_zero zero_le_numeral)
     subgoal unfolding as_def by (simp add: a prod_pos)
     done
   have [simp]:"pa>0"
     unfolding pa_def using a by (simp add: prod_pos)
 
   have K: "q* (\<Prod>j=1..n. real_of_int (a j)) * suminf (\<lambda> (j::nat). (b (j+n+1)/ a (j+n+1)))
               \<le>q* (\<Prod>j=1..n. real_of_int (a j)) *2* (b (n+1))/(a( n+1))"
     apply (fold pa_def)
     using mult_left_mono[OF n_def3,of "real_of_int q * pa"] 
       \<open>n\<ge>s\<close> \<open>pa>0\<close> \<open>q>0\<close> by (auto simp add:algebra_simps) 
   also have KK:"... \<le> 2*q* (\<Prod>j=1..n. real_of_int (a j)) * (b(n+1))*
       ((\<Prod>j=1..s-1. real_of_int( a j))/((d (n+1))powr(2^(n+1)) * (\<Prod>j=1..n. real_of_int ( a j))))" 
   proof -
     have " dn * pa * (1 / as) \<le> real_of_int (a (n + 1))"
       using n_def2 unfolding dn_def pa_def .
     then show ?thesis 
       apply (fold pa_def dn_def as_def)
       using \<open>pa>0\<close> \<open>q>0\<close> a[rule_format, of "Suc n"] b[rule_format, of "Suc n"]
       by (auto simp add:divide_simps algebra_simps)
   qed
   also have KKK: "... = (q* ((\<Prod>j=1..(s-1). real_of_int( a j)))*2
                                 * (b (n+1)))/ ((d (n+1))powr(2^(n+1)))"
     apply (fold as_def pa_def dn_def)
     apply simp
     using \<open>0 < pa\<close> by blast
   also have KKKK: "... < 1" using n_def1 unfolding as_def by simp
   finally show ?thesis by auto
 qed
 
 lemma 
   fixes d ::"nat\<Rightarrow>real " and  a b ::"nat\<Rightarrow>int " and A::real
   assumes "A > 1" and d: "\<forall>n. d n> 1" and a: "\<forall>n. a n>0" and b:"\<forall>n. b n>0" 
     and assu1: "(( \<lambda> n. (of_int (a n)) powr(1 /of_int (2^n)))\<longlongrightarrow> A) sequentially "
     and assu3: "filterlim ( \<lambda> n. (d n)^(2^n)/ b n) at_top sequentially"
     and "convergent_prod d"
   shows issummable: "summable (\<lambda>j. b j / a j)"
     and show5: "\<forall>\<^sub>F n in sequentially. (\<Sum>j. (b (n + j)) / (a (n + j))) \<le> 2 * b n / a n"
 proof-
   define c where "c = (\<lambda>j. b j / a j)"
   have c_pos:"c j>0" for j 
     using a b unfolding c_def by simp
   have c_ratio_tendsto:"(\<lambda>n. c (n+1) / c n ) \<longlonglongrightarrow> 0"
   proof -
     define nn where "nn=(\<lambda>n. (2::int)^ (Suc n))"
     define ff where "ff=(\<lambda> n. (a n / a (Suc n)) powr(1 /nn n)*(d(Suc n)))"
     have nn_pos:"nn n>0" and ff_pos:"ff n>0" for n
       subgoal unfolding nn_def by simp
       subgoal unfolding ff_def
         using d[rule_format, of "Suc n"] a[rule_format, of n] a[rule_format, of "Suc n"]
         by auto
       done
     have ff_tendsto:"ff \<longlonglongrightarrow> 1/ sqrt A" 
     proof -
       have "(of_int (a n)) powr(1 / (nn n)) = sqrt(of_int (a n) powr(1 /of_int (2^n)))" for n
         unfolding nn_def using a
-        apply (simp add: powr_half_sqrt [symmetric])
-        by (simp add: powr_half_sqrt [symmetric] linordered_field_class.sign_simps(24) powr_powr)
+        by (simp add: powr_half_sqrt [symmetric] powr_powr ac_simps)
       moreover have "(( \<lambda> n. sqrt(of_int (a n) powr(1 /of_int (2^n))))\<longlongrightarrow> sqrt A) sequentially " 
         using assu1 tendsto_real_sqrt by blast
       ultimately have "(( \<lambda> n. (of_int (a n)) powr(1 /of_int (nn n)))\<longlongrightarrow> sqrt A) sequentially " 
         by auto
       from tendsto_divide[OF this assu1[THEN LIMSEQ_ignore_initial_segment[where k=1]]] 
       have "(\<lambda>n. (a n / a (Suc n)) powr(1 /nn n)) \<longlonglongrightarrow> 1/sqrt A"
         using \<open>A>1\<close> a unfolding nn_def
         by (auto simp add:powr_divide inverse_eq_divide sqrt_divide_self_eq)
       moreover have "(\<lambda>n. d (Suc n))\<longlonglongrightarrow> 1" 
         apply (rule convergent_prod_imp_LIMSEQ)
         using convergent_prod_iff_shift[of d 1] \<open>convergent_prod d\<close> by auto
       ultimately show ?thesis
         unfolding ff_def by (auto intro:tendsto_eq_intros)
     qed
     have "(\<lambda>n. (ff n) powr nn n) \<longlonglongrightarrow> 0" 
     proof -
       define aa where "aa=(1+1/sqrt A) / 2"
       have "eventually (\<lambda>n. ff n<aa) sequentially"
         apply (rule order_tendstoD[OF ff_tendsto])
         unfolding aa_def using \<open>A>1\<close> by (auto simp add:field_simps)
       moreover have "(\<lambda>n. aa powr nn n) \<longlonglongrightarrow> 0" 
       proof -
         have "(\<lambda>y. aa ^ (nat \<circ> nn) y) \<longlonglongrightarrow> 0"
           apply (rule tendsto_power_zero)
           subgoal unfolding nn_def comp_def
             apply (rule filterlim_subseq)
             by (auto intro:strict_monoI)
           subgoal unfolding aa_def using \<open>A>1\<close> by auto
           done
         then show ?thesis
         proof (elim filterlim_mono_eventually)
           have "aa>0" unfolding aa_def using \<open>A>1\<close> 
             by  (auto simp add:field_simps pos_add_strict)
           then show " \<forall>\<^sub>F x in sequentially. aa ^ (nat \<circ> nn) x = aa powr real_of_int (nn x)"
             by (auto simp: powr_int order.strict_implies_order[OF nn_pos])
         qed auto
       qed
       ultimately show ?thesis
         apply (elim metric_tendsto_imp_tendsto)
         apply (auto intro!:powr_mono2 elim!:eventually_mono)
         using nn_pos ff_pos by (meson le_cases not_le)+
     qed
     then have "(\<lambda>n. (d (Suc n))^(nat (nn n)) * (a n / a (Suc n))) \<longlonglongrightarrow> 0" 
     proof (elim filterlim_mono_eventually)
       show "\<forall>\<^sub>F x in sequentially. ff x powr  (nn x) = d (Suc x) ^ nat (nn x) * (a x / a (Suc x))" 
         apply (rule eventuallyI)
         subgoal for x
           unfolding ff_def
           using a[rule_format,of x] a[rule_format,of "Suc x"] d[rule_format,of "Suc x"] nn_pos[of x]
           apply (auto simp add:field_simps powr_divide powr_powr powr_mult )
           by (simp add: powr_int)
         done
     qed auto 
     moreover have "(\<lambda>n. b (Suc n) / (d (Suc n))^(nat (nn n))) \<longlonglongrightarrow> 0"
       using tendsto_inverse_0_at_top[OF assu3,THEN LIMSEQ_ignore_initial_segment[where k=1]]
       unfolding nn_def by (auto simp add:field_simps nat_mult_distrib nat_power_eq)
     ultimately have "(\<lambda>n. b (Suc n) * (a n / a (Suc n))) \<longlonglongrightarrow> 0" 
       apply -
       subgoal premises asm
         using tendsto_mult[OF asm,simplified]
         apply (elim filterlim_mono_eventually)
         using d by (auto simp add:algebra_simps,metis (mono_tags, lifting) always_eventually 
             not_one_less_zero)
       done
     then have "(\<lambda>n. (b (Suc n) / b n) * (a n / a (Suc n))) \<longlonglongrightarrow> 0" 
       apply (elim Lim_transform_bound[rotated])
       apply (rule eventuallyI)
       subgoal for x using a[rule_format, of x] a[rule_format, of "Suc x"] 
           b[rule_format, of x] b[rule_format, of "Suc x"]
         by (auto simp add:field_simps)
       done
     then show ?thesis unfolding c_def by (auto simp add:algebra_simps)
   qed
   from c_ratio_tendsto
   have "(\<lambda>n. norm (b (Suc n) / a (Suc n)) / norm (b n / a n)) \<longlonglongrightarrow> 0" 
     unfolding c_def
     apply (elim Lim_transform_eventually[rotated])
     apply (rule eventuallyI)
     using a b by (auto simp add:divide_simps abs_of_pos)
   from summable_ratio_test_tendsto[OF _ _ this] a b 
   show "summable c" unfolding c_def
     apply auto 
     by (metis less_irrefl)
   have "\<forall>\<^sub>F n in sequentially. (\<Sum>j. c (n + j)) \<le> 2 * c n"
   proof -
     obtain N where N_ratio:"\<forall>n\<ge>N. c (n + 1) / c n < 1 / 2" 
     proof -
       have "eventually (\<lambda>n. c (n+1) / c n < 1/2) sequentially" 
         using c_ratio_tendsto[unfolded tendsto_iff,rule_format, of "1/2",simplified]
         apply eventually_elim
         subgoal for n using c_pos[of n] c_pos[of "Suc n"] by auto
         done
       then show ?thesis using that unfolding eventually_sequentially by auto
     qed
     have "(\<Sum>j. c (j + n)) \<le> 2 * c n" when "n\<ge>N" for n
     proof -
       have "(\<Sum>j<m. c (j + n)) \<le> 2*c n * (1 - 1 / 2^(m+1))" for m
       proof (induct m)
         case 0
         then show ?case using c_pos[of n] by simp
       next
         case (Suc m)
         have "(\<Sum>j<Suc m. c (j + n)) = c n + (\<Sum>i<m. c (Suc i + n)) "
           unfolding sum.lessThan_Suc_shift by simp
         also have "... \<le> c n + (\<Sum>i<m. c (i + n) / 2)"
         proof -
           have "c (Suc i + n) \<le> c (i + n) / 2" for i
             using N_ratio[rule_format,of "i+n"] \<open>n\<ge>N\<close> c_pos[of "i+n"]  by simp
           then show ?thesis by (auto intro:sum_mono)
         qed
         also have "... = c n + (\<Sum>i<m. c (i + n)) / 2"
           unfolding sum_divide_distrib by simp
         also have "... \<le> c n + c n * (1 - 1 / 2 ^ (m + 1))"
           using Suc by auto
         also have "... = 2 * c n * (1 - 1 / 2 ^ (Suc m + 1))"
           by (auto simp add:field_simps)
         finally show ?case .
       qed
       then have "(\<Sum>j<m. c (j + n)) \<le> 2*c n" for m
         using c_pos[of n] 
         by (smt divide_le_eq_1_pos divide_pos_pos nonzero_mult_div_cancel_left zero_less_power)
       moreover have "summable (\<lambda>j. c (j + n))" 
         using \<open>summable c\<close> by (simp add: summable_iff_shift)
       ultimately show ?thesis using suminf_le_const[of "\<lambda>j. c (j+n)" "2*c n"] by auto
     qed
     then show ?thesis unfolding eventually_sequentially by (auto simp add:algebra_simps)
   qed
   then show "\<forall>\<^sub>F n in sequentially. (\<Sum>j. (b (n + j)) /  (a (n + j))) \<le> 2 * b n / a n"
     unfolding c_def by simp
 qed
 
 
 theorem Hancl3:
   fixes d ::"nat\<Rightarrow>real " and  a b ::"nat\<Rightarrow>int "
   assumes "A > 1" and d:"\<forall>n. d n> 1" and a: "\<forall>n. a n>0" and b:"\<forall>n. b n>0" and "s>0"
     and assu1: "(( \<lambda> n. (of_int (a n)) powr(1 /of_int (2^n)))\<longlongrightarrow> A) sequentially "
     and assu2: "\<forall>n \<ge> s. (A/ (of_int (a n)) powr(1 /of_int (2^n)))> prodinf (\<lambda>j. d(n +j))"
     and assu3: "filterlim (\<lambda> n. (d n)^(2^n)/ b n) at_top sequentially"
     and "convergent_prod d" 
   shows "suminf(\<lambda> n. b n / a n ) \<notin> Rats"
 proof(rule ccontr)
   assume asm:"\<not> (suminf(\<lambda> n. b n / a n ) \<notin> Rats)"
   have ab_sum:"summable (\<lambda>j. b j / a j)"
     using issummable[OF \<open>A>1\<close> d a b assu1 assu3 \<open>convergent_prod d\<close>] .
   obtain p q ::int where "q>0" and pq_def:"(\<lambda> n. b (n+1) / a (n+1) ) sums (p/q)"
   proof -
     from asm have "suminf(\<lambda> n. b n / a n ) \<in> Rats" by auto
     then have "suminf(\<lambda> n. b (n+1) / a (n+1)) \<in> Rats" 
       apply (subst suminf_minus_initial_segment[OF ab_sum,of 1])
       by auto   
     then obtain p' q' ::int where "q'\<noteq>0" and pq_def:"(\<lambda> n. b (n+1) / a (n+1) ) sums (p'/q')"
       unfolding Rats_eq_int_div_int
       using summable_ignore_initial_segment[OF ab_sum,of 1,THEN summable_sums]
       by force
     define p q where "p=(if q'<0 then - p' else p')" and "q=(if q'<0 then - q' else q')"
     have "p'/q'=p/q" "q>0" using \<open>q'\<noteq>0\<close> unfolding p_def q_def by auto
     then show ?thesis using that[of q p] pq_def by auto
   qed
 
   define ALPHA where 
     "ALPHA = (\<lambda>n. (of_int q)*((\<Prod>j=1..n. of_int(a j)))*(suminf (\<lambda> (j::nat). 
                       (b (j+n+1)/a (j+n+1)))))"
   have "ALPHA n \<ge> 1" for n 
   proof -
     have "suminf(\<lambda> n. b (n+1) / a (n+1)) > 0"
       apply (rule suminf_pos)
       subgoal using summable_ignore_initial_segment[OF ab_sum,of 1] by auto
       subgoal using a b by simp
       done
     then have "p/q > 0" using sums_unique[OF pq_def,symmetric] by auto
     then have "q\<ge>1" "p\<ge>1" using \<open>q>0\<close> by (auto simp add:divide_simps)
     moreover have "\<forall>n. 1 \<le> a n" "\<forall>n. 1 \<le> b n" using a b 
       by (auto simp add: int_one_le_iff_zero_less)
     ultimately show ?thesis unfolding ALPHA_def
       using show7[OF _ _ _ _ pq_def] by auto
   qed
   moreover have "\<exists>n. ALPHA n < 1" unfolding ALPHA_def
   proof (rule lasttoshow[OF d a \<open>s>0\<close> \<open>q>0\<close> \<open>A>1\<close> b _ assu3])
     show "\<forall>\<^sub>F n in sequentially. (\<Sum>j. real_of_int (b (n + j)) / real_of_int (a (n + j)))
                     \<le> real_of_int (2 * b n) / real_of_int (a n)"
       using show5[OF \<open>A>1\<close> d a b assu1 assu3 \<open>convergent_prod d\<close>] by simp
     show "\<forall>m\<ge>s. \<exists>n\<ge>m. d (n + 1) * Max ((\<lambda>j. real_of_int (a j) powr (1 / real_of_int (2 ^ j))) ` {s..n})
                  \<le> real_of_int (a (n + 1)) powr (1 / real_of_int (2 ^ (n + 1)))"
       apply (rule show9[OF \<open>A>1\<close> d a \<open>s>0\<close> assu1 \<open>convergent_prod d\<close>])
       using show8[OF \<open>A>1\<close> d a \<open>s>0\<close> \<open>convergent_prod d\<close> assu2] by (simp add:algebra_simps)
   qed
   ultimately show False using not_le by blast
 qed
 
 corollary Hancl3corollary:
   fixes A::real and  a b ::"nat\<Rightarrow>int "
   assumes "A > 1" and a: "\<forall>n. a n>0" and b:"\<forall>n. b n>0"
     and assu1: "((\<lambda> n. (of_int (a n)) powr(1 /of_int (2^n)))\<longlongrightarrow> A) sequentially "
     and asscor2: "\<forall>n \<ge>6. (of_int (a n)) powr(1 /of_int (2^n ))*(1+ 4*(2/3)^n) \<le> A
                     \<and> (b n \<le>2 powr((4/3)^(n-1)) )   "
   shows "suminf(\<lambda> n. b n / a n ) \<notin> Rats"
 proof-
   define d::"nat\<Rightarrow>real" where "d= (\<lambda> n. 1+(2/3)^(n+1))" 
 
   have dgt1:"\<forall>n. 1 < d n " unfolding d_def by auto
   moreover have "convergent_prod d"
     unfolding d_def
     apply (rule abs_convergent_prod_imp_convergent_prod)
     apply (rule summable_imp_abs_convergent_prod)
     using summable_ignore_initial_segment[OF complete_algebra_summable_geometric
           [of "2/3::real",simplified],of 1] by simp
   moreover have "\<forall>n\<ge>6. (\<Prod>j. d (n + j)) 
                     < A / real_of_int (a n) powr (1 / real_of_int (2 ^ n))"
   proof rule+
     fix n::nat assume "6 \<le> n"
     have d_sum:"summable (\<lambda>j. ln (d j))" unfolding d_def
       apply (rule summable_ln_plus)
       apply (rule summable_ignore_initial_segment[OF complete_algebra_summable_geometric
           [of "2/3::real",simplified],of 1])
       by simp 
 
     have "(\<Sum>j. ln (d (n + j))) < ln (1+4 * (2 / 3) ^ n)"
     proof -
       define c::real where "c=(2 / 3) ^ n"
       have "0<c" "c<1/8" 
       proof -
         have "c=(2 / 3)^6 * (2 / 3)  ^ (n-6)"
           unfolding c_def using \<open>n\<ge>6\<close>
           apply (subst power_add[symmetric])
           by auto
         also have "... \<le> (2 / 3)^6" by (auto intro:power_le_one)
         also have "... < 1/8" by (auto simp add:field_simps)
         finally show "c<1/8" .
       qed (simp add:c_def)
 
       have "(\<Sum>j. ln (d (n + j))) \<le> (\<Sum>j. (2 / 3) ^ (n + j + 1))"
         apply (rule suminf_le)
         subgoal unfolding d_def 
           apply (intro allI ln_add_one_self_le_self2 )
           apply (rule order.strict_trans[of _ 0])
           by auto
         subgoal using summable_ignore_initial_segment[OF d_sum,of n] 
           by (auto simp add:algebra_simps)
         subgoal using summable_geometric[THEN summable_ignore_initial_segment,of "2/3" "n+1"]
           by (auto simp add:algebra_simps)
         done
       also have "... = (\<Sum>j. (2 / 3)^(n+1)*(2 / 3) ^ j)"
         by (auto simp add:algebra_simps power_add)
       also have "... = (2 / 3)^(n+1) * (\<Sum>j. (2 / 3) ^ j)"
         apply (rule suminf_mult)
         by (auto intro:summable_geometric)
       also have "... = 2 * c"
         unfolding c_def
         apply (subst suminf_geometric)
         by auto
       also have "... <  4 * c - (4 * c)\<^sup>2"
         using \<open>0<c\<close> \<open>c<1/8\<close>
         by (sos "((((A<0 * A<1) * R<1) + ((A<=0 * R<1) * (R<1/16 * [1]^2))))")
       also have "... \<le> ln (1 + 4 * c)"
         apply (rule ln_one_plus_pos_lower_bound)
         using \<open>0<c\<close> \<open>c<1/8\<close> by auto
       finally show ?thesis unfolding c_def by simp
     qed
     then have "exp (\<Sum>j. ln (d (n + j))) < 1 + 4 * (2 / 3) ^ n"
       by (metis Groups.mult_ac(2) add.right_neutral add_mono_thms_linordered_field(5) 
           divide_inverse divide_less_eq_numeral1(1) divide_pos_pos exp_gt_zero less_eq_real_def
           ln_exp ln_less_cancel_iff mult_zero_left rel_simps(27) rel_simps(76) zero_less_one
           zero_less_power)
     moreover have "exp (\<Sum>j. ln (d (n + j))) = (\<Prod>j. d (n + j))"
     proof (subst exp_suminf_prodinf_real [symmetric])
       show "\<And>k. 0 \<le> ln (d (n + k))" 
         using dgt1 by (simp add: less_imp_le)
       show "abs_convergent_prod (\<lambda>na. exp (ln (d (n + na))))"
         apply (subst exp_ln)
         subgoal for j using dgt1[rule_format,of "n+j"] by auto
         subgoal unfolding abs_convergent_prod_def real_norm_def
           apply (subst abs_of_nonneg)
           using convergent_prod_iff_shift[of d n] \<open>convergent_prod d\<close> 
           by (auto simp add: dgt1 less_imp_le algebra_simps)
         done
       show "(\<Prod>na. exp (ln (d (n + na)))) = (\<Prod>j. d (n + j))"
         apply (subst exp_ln)
         subgoal using dgt1 le_less_trans zero_le_one by blast
         subgoal by simp
         done
     qed
     ultimately have "(\<Prod>j. d (n + j))  < 1 + 4 * (2 / 3) ^ n"
       by simp
     also have "... \<le> A / (a n) powr (1 / of_int (2 ^ n))" 
     proof -
       have "a n powr (1 / real_of_int (2 ^ n)) > 0"
         using a[rule_format,of n] by auto
       then show ?thesis using asscor2[rule_format,OF \<open>6\<le>n\<close>] 
         by (auto simp add:field_simps)
     qed
     finally show "(\<Prod>j. d (n + j)) < A / real_of_int (a n) powr (1 / of_int (2 ^ n))" .
   qed
   moreover have "LIM n sequentially. d n ^ 2 ^ n / real_of_int (b n) :> at_top" 
   proof -
     have "LIM n sequentially. d n ^ 2 ^ n / 2 powr((4/3)^(n-1)) :> at_top"
     proof -
       define n1 where "n1=(\<lambda>n. (2::real)* (3/2)^(n-1))"
       define n2 where "n2=(\<lambda>n. ((4::real)/3)^(n-1))"
       have "LIM n sequentially. (((1+(8/9)/(n1 n)) powr (n1 n))/2) powr (n2 n) :> at_top" 
       proof (rule filterlim_at_top_powr_real[where g'="exp (8/9) / (2::real)"])
         define e1 where "e1=exp (8/9) / (2::real)"
         show "e1>1" unfolding e1_def by (approximation 4)
         show "(\<lambda>n. ((1+(8/9)/(n1 n)) powr (n1 n))/2) \<longlonglongrightarrow> e1"
         proof -
           have "(\<lambda>n. (1+(8/9)/(n1 n)) powr (n1 n)) \<longlonglongrightarrow> exp (8/9)"
             apply (rule filterlim_compose[OF tendsto_exp_limit_at_top])
             unfolding n1_def
             by (auto intro!: filterlim_tendsto_pos_mult_at_top 
                 filterlim_realpow_sequentially_at_top
                 simp:filterlim_sequentially_iff[of "\<lambda>x. (3 / 2) ^ (x - Suc 0)" _ 1])
           then show ?thesis unfolding e1_def
             by (intro tendsto_intros,auto)
         qed
         show "filterlim n2 at_top sequentially"
           unfolding n2_def
           apply (subst filterlim_sequentially_iff[of "\<lambda>n. (4 / 3) ^ (n - 1)" _ 1])
           by (auto intro:filterlim_realpow_sequentially_at_top)
       qed
       moreover have "\<forall>\<^sub>F n in sequentially. (((1+(8/9)/(n1 n)) powr (n1 n))/2) powr (n2 n)
         = d n ^ 2 ^ n / 2 powr((4/3)^(n-1))"
       proof (rule eventually_sequentiallyI[of 1])
         fix x assume "x\<ge>(1::nat)"
         have " ((1 + 8 / 9 / n1 x) powr n1 x / 2) powr n2 x 
                     = (((1 + 8 / 9 / n1 x) powr n1 x) powr n2 x) / 2 powr (4 / 3) ^ (x - 1)"
           apply (subst powr_divide)
             apply (simp_all add:n1_def n2_def)
           by (smt divide_nonneg_nonneg zero_le_power)
         also have "... = (1 + 8 / 9 / n1 x) powr (n1 x * n2 x) / 2 powr (4 / 3) ^ (x - 1)"
           apply (subst powr_powr)
           by simp
         also have "... = (1 + 8 / 9 / n1 x) powr (2 ^ x) / 2 powr (4 / 3) ^ (x - 1)"
         proof -
           have "n1 x * n2 x = 2 ^ x" 
             unfolding n1_def n2_def
             apply (subst mult.assoc)
             apply (subst power_mult_distrib[symmetric])
             using \<open>x\<ge>1\<close> by (auto simp add:power_Suc[symmetric] simp del:power_Suc)
           then show ?thesis by simp
         qed
         also have "... = (1 + 8 / 9 / n1 x) ^ (2 ^ x) / 2 powr (4 / 3) ^ (x - 1)"
           apply (subst (3) powr_realpow[symmetric])
            apply (simp_all add: n1_def)
           by (smt zero_le_divide_iff zero_le_power)
         also have "... = d x ^ 2 ^ x / 2 powr (4 / 3) ^ (x - 1)"
         proof -
           define x1 where "x1=x-1"
           have *:"x=x1+1" unfolding x1_def using \<open>x\<ge>1\<close> by simp
           have **: "8 / 9 / n1 x = (2 / 3) ^ (x + 1)" 
             unfolding n1_def using \<open>x\<ge>1\<close>
             apply (fold x1_def *[symmetric])
             by (auto simp add:divide_simps)
           then show ?thesis 
             unfolding d_def 
             apply (subst **)
             by auto
         qed
         finally show "((1 + 8 / 9 / n1 x) powr n1 x / 2) powr n2 x 
                         = d x ^ 2 ^ x / 2 powr (4 / 3) ^ (x - 1) " .
       qed
       ultimately show ?thesis using filterlim_cong by fast
     qed
     moreover have "\<forall>\<^sub>F n in sequentially. d n ^ 2 ^ n / 2 powr((4/3)^(n-1)) 
         \<le> d n ^ 2 ^ n / real_of_int (b n)"
       apply (rule eventually_sequentiallyI[of 6])
       apply (rule divide_left_mono)
       subgoal for x
         using asscor2[rule_format,of x] by auto
       subgoal for x
         using \<open>\<forall>n. 1 < d n\<close>[rule_format, of x] by auto
       subgoal for x
         using b by auto
       done
     ultimately show ?thesis by (auto elim: filterlim_at_top_mono)
   qed
   ultimately show ?thesis using Hancl3[OF \<open>A>1\<close> _ a b _ assu1,of d 6] by force
 qed
 
 end
diff --git a/thys/LTL_Master_Theorem/LTL_to_DRA/DRA_Instantiation.thy b/thys/LTL_Master_Theorem/LTL_to_DRA/DRA_Instantiation.thy
--- a/thys/LTL_Master_Theorem/LTL_to_DRA/DRA_Instantiation.thy
+++ b/thys/LTL_Master_Theorem/LTL_to_DRA/DRA_Instantiation.thy
@@ -1,419 +1,419 @@
 (*
     Author:   Benedikt Seidl
     License:  BSD
 *)
 
 section \<open>Instantiation of the LTL to DRA construction\<close>
 
 theory DRA_Instantiation
 imports
   DRA_Construction
   LTL.Equivalence_Relations
   "HOL-Library.Log_Nat"
 begin
 
 text \<open>We instantiate the construction locale with propositional equivalence
       and obtain a function converting a formula into an abstract automaton.\<close>
 
 global_interpretation ltl_to_dra: dra_construction "(\<sim>\<^sub>P)" rep_ltln\<^sub>P abs_ltln\<^sub>P
   defines ltl_to_dra = ltl_to_dra.ltl_to_dra
     and ltl_to_dra_alphabet = ltl_to_dra.ltl_to_dra_alphabet
     and \<AA>' = ltl_to_dra.\<AA>'
     and \<AA>\<^sub>1 = ltl_to_dra.\<AA>\<^sub>1
     and \<AA>\<^sub>2 = ltl_to_dra.\<AA>\<^sub>2
     and \<AA>\<^sub>3 = ltl_to_dra.\<AA>\<^sub>3
     and \<AA>\<^sub>\<nu>_FG = ltl_to_dra.\<AA>\<^sub>\<nu>_FG
     and \<AA>\<^sub>\<mu>_GF = ltl_to_dra.\<AA>\<^sub>\<mu>_GF
     and af_letter\<^sub>G = ltl_to_dra.af_letter\<^sub>G
     and af_letter\<^sub>F = ltl_to_dra.af_letter\<^sub>F
     and af_letter\<^sub>G_lifted = ltl_to_dra.af_letter\<^sub>G_lifted
     and af_letter\<^sub>F_lifted = ltl_to_dra.af_letter\<^sub>F_lifted
     and af_letter\<^sub>\<nu>_lifted = ltl_to_dra.af_letter\<^sub>\<nu>_lifted
     and \<CC> = ltl_to_dra.\<CC>
     and af_letter\<^sub>\<nu> = ltl_to_dra.af_letter\<^sub>\<nu>
   by unfold_locales (meson Quotient_abs_rep Quotient_ltln\<^sub>P, simp add: Quotient_abs_rep Quotient_ltln\<^sub>P ltln\<^sub>P.abs_eq_iff)
 
 text \<open>We obtain the following theorem:\<close>
 
 thm ltl_to_dra.ltl_to_dra_language
 
 
 text \<open>Furthermore, we verify the size bound of the automaton to be double-exponential.\<close>
 
 lemma prop_equiv_nested_prop_atoms_finite:
   "finite {abs_ltln\<^sub>P \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms \<phi>}"
   using prop_equiv_finite'[OF nested_prop_atoms_finite] .
 
 lemma prop_equiv_nested_prop_atoms_card:
   "card {abs_ltln\<^sub>P \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms \<phi>} \<le> 2 ^ 2 ^ card (nested_prop_atoms \<phi>)"
   using prop_equiv_card'[OF nested_prop_atoms_finite] .
 
 
 lemma prop_equiv_nested_prop_atoms\<^sub>\<nu>_finite:
   "finite {abs_ltln\<^sub>P \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms\<^sub>\<nu> \<phi> X}"
   using prop_equiv_finite'[OF nested_prop_atoms\<^sub>\<nu>_finite] by fast
 
 lemma prop_equiv_nested_prop_atoms\<^sub>\<nu>_card:
   "card {abs_ltln\<^sub>P \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms\<^sub>\<nu> \<phi> X} \<le> 2 ^ 2 ^ card (nested_prop_atoms \<phi>)" (is "?lhs \<le> ?rhs")
 proof -
   have "finite {abs_ltln\<^sub>P \<psi> | \<psi>. prop_atoms \<psi> \<subseteq> nested_prop_atoms\<^sub>\<nu> \<phi> X}"
     by (simp add: prop_equiv_nested_prop_atoms\<^sub>\<nu>_finite nested_prop_atoms\<^sub>\<nu>_finite prop_equiv_finite)
 
   then have "?lhs \<le> card {abs_ltln\<^sub>P \<psi> | \<psi>. prop_atoms \<psi> \<subseteq> (nested_prop_atoms\<^sub>\<nu> \<phi> X)}"
     using card_mono prop_equiv_subset by blast
 
   also have "\<dots> \<le> 2 ^ 2 ^ card (nested_prop_atoms\<^sub>\<nu> \<phi> X)"
     using prop_equiv_card[OF nested_prop_atoms\<^sub>\<nu>_finite] by fast
 
   also have "\<dots> \<le> ?rhs"
     using nested_prop_atoms\<^sub>\<nu>_card by auto
 
   finally show ?thesis .
 qed
 
 
 lemma \<AA>\<^sub>\<mu>_GF_nodes_finite:
   "finite (DBA.nodes (\<AA>\<^sub>\<mu>_GF \<phi>))"
   using finite_subset[OF ltl_to_dra.\<AA>\<^sub>\<mu>_GF_nodes prop_equiv_nested_prop_atoms_finite] .
 
 lemma \<AA>\<^sub>\<nu>_FG_nodes_finite:
   "finite (DCA.nodes (\<AA>\<^sub>\<nu>_FG \<phi>))"
   using finite_subset[OF ltl_to_dra.\<AA>\<^sub>\<nu>_FG_nodes prop_equiv_nested_prop_atoms_finite] .
 
 lemma \<AA>\<^sub>\<mu>_GF_nodes_card:
   "card (DBA.nodes (\<AA>\<^sub>\<mu>_GF \<phi>)) \<le> 2 ^ 2 ^ card (nested_prop_atoms (F\<^sub>n \<phi>))"
   using le_trans[OF card_mono[OF prop_equiv_nested_prop_atoms_finite ltl_to_dra.\<AA>\<^sub>\<mu>_GF_nodes] prop_equiv_nested_prop_atoms_card] .
 
 lemma \<AA>\<^sub>\<nu>_FG_nodes_card:
   "card (DCA.nodes (\<AA>\<^sub>\<nu>_FG \<phi>)) \<le> 2 ^ 2 ^ card (nested_prop_atoms (G\<^sub>n \<phi>))"
   using le_trans[OF card_mono[OF prop_equiv_nested_prop_atoms_finite ltl_to_dra.\<AA>\<^sub>\<nu>_FG_nodes] prop_equiv_nested_prop_atoms_card] .
 
 
 lemma \<AA>\<^sub>2_nodes_finite_helper:
   "list_all (finite \<circ> DBA.nodes) (map (\<lambda>\<psi>. \<AA>\<^sub>\<mu>_GF (\<psi>[set ys]\<^sub>\<mu>)) xs)"
   by (auto simp: list.pred_map list_all_iff \<AA>\<^sub>\<mu>_GF_nodes_finite)
 
 lemma \<AA>\<^sub>2_nodes_finite:
   "finite (DBA.nodes (\<AA>\<^sub>2 xs ys))"
   unfolding ltl_to_dra.\<AA>\<^sub>2_def using dbail_nodes_finite \<AA>\<^sub>2_nodes_finite_helper .
 
 lemma \<AA>\<^sub>3_nodes_finite_helper:
   "list_all (finite \<circ> DCA.nodes) (map (\<lambda>\<psi>. \<AA>\<^sub>\<nu>_FG (\<psi>[set xs]\<^sub>\<nu>)) ys)"
   by (auto simp: list.pred_map list_all_iff \<AA>\<^sub>\<nu>_FG_nodes_finite)
 
 lemma \<AA>\<^sub>3_nodes_finite:
   "finite (DCA.nodes (\<AA>\<^sub>3 xs ys))"
   unfolding ltl_to_dra.\<AA>\<^sub>3_def using dcail_finite \<AA>\<^sub>3_nodes_finite_helper .
 
 (* TODO add to HOL/Groups_List.thy *)
 lemma list_prod_mono:
   "f \<le> g \<Longrightarrow> (\<Prod>x\<leftarrow>xs. f x) \<le> (\<Prod>x\<leftarrow>xs. g x)" for f g :: "'a \<Rightarrow> nat"
   by (induction xs) (auto simp: le_funD mult_le_mono)
 
 (* TODO add to HOL/Groups_List.thy *)
 lemma list_prod_const:
   "(\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> c) \<Longrightarrow> (\<Prod>x\<leftarrow>xs. f x) \<le> c ^ length xs" for f :: "'a \<Rightarrow> nat"
   by (induction xs) (auto simp: mult_le_mono)
 
 (* TODO add to HOL/Finite_Set.thy *)
 lemma card_insert_Suc:
   "card (insert x S) \<le> Suc (card S)"
   by (metis Suc_n_not_le_n card.infinite card_insert_if finite_insert linear)
 
 (* TODO add to HOL/Power.thy *)
 lemma nat_power_le_imp_le:
   "0 < a \<Longrightarrow> a \<le> b \<Longrightarrow> x ^ a \<le> x ^ b" for x :: nat
   by (metis leD linorder_le_less_linear nat_power_less_imp_less neq0_conv power_eq_0_iff)
 
 (* TODO add to HOL/Power.thy *)
 lemma const_less_power:
   "n < x ^ n" if "x > 1"
   using that by (induction n) (auto simp: less_trans_Suc)
 
 (* TODO add to HOL-Library/Log_Nat.thy *)
 lemma floorlog_le_const:
   "floorlog x n \<le> n"
   by (induction n) (simp add: floorlog_eq_zero_iff, metis Suc_lessI floorlog_le_iff le_SucI power_inject_exp)
 
 lemma \<AA>\<^sub>2_nodes_card:
   assumes
     "length xs \<le> n"
   and
     "\<And>\<psi>. \<psi> \<in> set xs \<Longrightarrow> card (nested_prop_atoms \<psi>) \<le> n"
   shows
     "card (DBA.nodes (\<AA>\<^sub>2 xs ys)) \<le> 2 ^ 2 ^ (n + floorlog 2 n + 2)"
 proof -
   have 1: "\<And>\<psi>. \<psi> \<in> set xs \<Longrightarrow> card (nested_prop_atoms (F\<^sub>n \<psi>[set ys]\<^sub>\<mu>)) \<le> Suc n"
   proof -
     fix \<psi>
     assume "\<psi> \<in> set xs"
 
     have "card (nested_prop_atoms (F\<^sub>n (\<psi>[set ys]\<^sub>\<mu>)))
           \<le> Suc (card (nested_prop_atoms (\<psi>[set ys]\<^sub>\<mu>)))"
       by (simp add: card_insert_Suc)
 
     also have "\<dots> \<le> Suc (card (nested_prop_atoms \<psi>))"
       by (simp add: FG_advice_nested_prop_atoms_card)
 
     also have "\<dots> \<le> Suc n"
       by (simp add: assms(2) \<open>\<psi> \<in> set xs\<close>)
 
     finally show "card (nested_prop_atoms (F\<^sub>n (\<psi>[set ys]\<^sub>\<mu>))) \<le> Suc n" .
   qed
 
   have "(\<Prod>\<psi>\<leftarrow>xs. card (DBA.nodes (\<AA>\<^sub>\<mu>_GF (\<psi>[set ys]\<^sub>\<mu>))))
         \<le> (\<Prod>\<psi>\<leftarrow>xs. 2 ^ 2 ^ card (nested_prop_atoms (F\<^sub>n (\<psi>[set ys]\<^sub>\<mu>))))"
     by (rule list_prod_mono) (insert \<AA>\<^sub>\<mu>_GF_nodes_card le_fun_def, blast)
 
   also have "\<dots> \<le> (2 ^ 2 ^ Suc n) ^ length xs"
     by (rule list_prod_const) (metis 1 Suc_leI nat_power_le_imp_le nat_power_eq_Suc_0_iff neq0_conv pos2 zero_less_power)
 
   also have "\<dots> \<le> (2 ^ 2 ^ Suc n) ^ n"
     using assms(1) nat_power_le_imp_le by fastforce
 
   also have "\<dots> = 2 ^ (n * 2 ^ Suc n)"
     by (metis Groups.mult_ac(2) power_mult)
 
   also have "\<dots> \<le> 2 ^ (2 ^ floorlog 2 n * 2 ^ Suc n)"
     by (cases "n = 0") (auto simp: floorlog_bounds less_imp_le_nat)
 
   also have "\<dots> = 2 ^ 2 ^ (Suc n + floorlog 2 n)"
     by (simp add: power_add)
 
   finally have 2: "(\<Prod>\<psi>\<leftarrow>xs. card (DBA.nodes (\<AA>\<^sub>\<mu>_GF (\<psi>[set ys]\<^sub>\<mu>)))) \<le> 2 ^ 2 ^ (Suc n + floorlog 2 n)" .
 
   have "card (DBA.nodes (\<AA>\<^sub>2 xs ys)) \<le> max 1 (length xs) * (\<Prod>\<psi>\<leftarrow>xs. card (DBA.nodes (\<AA>\<^sub>\<mu>_GF (\<psi>[set ys]\<^sub>\<mu>))))"
     using dbail_nodes_card[OF \<AA>\<^sub>2_nodes_finite_helper]
     by (auto simp: ltl_to_dra.\<AA>\<^sub>2_def comp_def)
 
   also have "\<dots> \<le> max 1 n * 2 ^ 2 ^ (Suc n + floorlog 2 n)"
     using assms(1) 2 by (simp add: mult_le_mono)
 
   also have "\<dots> \<le> 2 ^ (floorlog 2 n) * 2 ^ 2 ^ (Suc n + floorlog 2 n)"
     by (cases "n = 0") (auto simp: floorlog_bounds less_imp_le_nat)
 
   also have "\<dots> = 2 ^ (floorlog 2 n + 2 ^ (Suc n + floorlog 2 n))"
     by (simp add: power_add)
 
   also have "\<dots> \<le> 2 ^ (n + 2 ^ (Suc n + floorlog 2 n))"
     by (simp add: floorlog_le_const)
 
   also have "\<dots> \<le> 2 ^ 2 ^ (n + floorlog 2 n + 2)"
     by simp (metis const_less_power Suc_1 add_Suc_right add_leE lessI less_imp_le_nat power_Suc)
 
   finally show ?thesis .
 qed
 
 
 lemma \<AA>\<^sub>3_nodes_card:
   assumes
     "length ys \<le> n"
   and
     "\<And>\<psi>. \<psi> \<in> set ys \<Longrightarrow> card (nested_prop_atoms \<psi>) \<le> n"
   shows
     "card (DCA.nodes (\<AA>\<^sub>3 xs ys)) \<le> 2 ^ 2 ^ (n + floorlog 2 n + 1)"
 proof -
   have 1: "\<And>\<psi>. \<psi> \<in> set ys \<Longrightarrow> card (DCA.nodes (\<AA>\<^sub>\<nu>_FG (\<psi>[set xs]\<^sub>\<nu>))) \<le> 2 ^ 2 ^ Suc n"
   proof -
     fix \<psi>
     assume "\<psi> \<in> set ys"
 
     have "card (nested_prop_atoms (G\<^sub>n \<psi>[set xs]\<^sub>\<nu>))
           \<le> Suc (card (nested_prop_atoms (\<psi>[set xs]\<^sub>\<nu>)))"
       by (simp add: card_insert_Suc)
 
     also have "\<dots> \<le> Suc (card (nested_prop_atoms \<psi>))"
       by (simp add: GF_advice_nested_prop_atoms_card)
 
     also have "\<dots> \<le> Suc n"
       by (simp add: assms(2) \<open>\<psi> \<in> set ys\<close>)
 
     finally have 2: "card (nested_prop_atoms (G\<^sub>n \<psi>[set xs]\<^sub>\<nu>)) \<le> Suc n" .
 
     then show "?thesis \<psi>"
       by (intro le_trans[OF \<AA>\<^sub>\<nu>_FG_nodes_card]) (meson one_le_numeral power_increasing)
   qed
 
 
   have "card (DCA.nodes (\<AA>\<^sub>3 xs ys)) \<le> (\<Prod>\<psi>\<leftarrow>ys. card (DCA.nodes (\<AA>\<^sub>\<nu>_FG (\<psi>[set xs]\<^sub>\<nu>))))"
     unfolding ltl_to_dra.\<AA>\<^sub>3_def using dcail_nodes_card[OF \<AA>\<^sub>3_nodes_finite_helper]
     by (auto simp: comp_def)
 
   also have "\<dots> \<le> (2 ^ 2 ^ Suc n) ^ length ys"
     by (rule list_prod_const) (rule 1)
 
   also have "\<dots> \<le> (2 ^ 2 ^ Suc n) ^ n"
     by (simp add: assms(1) power_increasing)
 
   also have "\<dots> \<le> 2 ^ (n * 2 ^ Suc n)"
     by (metis le_refl mult.commute power_mult)
 
   also have "\<dots> \<le> 2 ^ (2 ^ floorlog 2 n * 2 ^ Suc n)"
     by (cases \<open>n > 0\<close>) (simp_all add: floorlog_bounds less_imp_le_nat)
 
   also have "\<dots> = 2 ^ 2 ^ (n + floorlog 2 n + 1)"
     by (simp add: power_add)
 
   finally show ?thesis .
 qed
 
 
 lemma \<AA>\<^sub>1_nodes_finite:
   "finite (DCA.nodes (\<AA>\<^sub>1 \<phi> xs))"
   unfolding ltl_to_dra.\<AA>\<^sub>1_def
   by (metis (no_types, lifting) finite_subset ltl_to_dra.\<CC>_nodes finite_SigmaI prop_equiv_nested_prop_atoms\<^sub>\<nu>_finite prop_equiv_nested_prop_atoms_finite)
 
 lemma \<AA>\<^sub>1_nodes_card:
   assumes
     "card (subfrmlsn \<phi>) \<le> n"
   shows
     "card (DCA.nodes (\<AA>\<^sub>1 \<phi> xs)) \<le> 2 ^ 2 ^ (n + 1)"
 proof -
   let ?fst = "{abs_ltln\<^sub>P \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms \<phi>}"
   let ?snd = "{abs_ltln\<^sub>P \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms\<^sub>\<nu> \<phi> (set xs)}"
 
   have 1: "card (nested_prop_atoms \<phi>) \<le> n"
     by (meson card_mono[OF subfrmlsn_finite nested_prop_atoms_subfrmlsn] assms le_trans)
 
 
   have "card (DCA.nodes (\<AA>\<^sub>1 \<phi> xs)) \<le> card (?fst \<times> ?snd)"
     unfolding ltl_to_dra.\<AA>\<^sub>1_def
     by (rule card_mono) (simp_all add: ltl_to_dra.\<CC>_nodes prop_equiv_nested_prop_atoms\<^sub>\<nu>_finite prop_equiv_nested_prop_atoms_finite)
 
   also have "\<dots> = card ?fst * card ?snd"
     using prop_equiv_nested_prop_atoms\<^sub>\<nu>_finite card_cartesian_product by blast
 
   also have "\<dots> \<le> 2 ^ 2 ^ card (nested_prop_atoms \<phi>) * 2 ^ 2 ^ card (nested_prop_atoms \<phi>)"
     using prop_equiv_nested_prop_atoms\<^sub>\<nu>_card prop_equiv_nested_prop_atoms_card mult_le_mono by blast
 
   also have "\<dots> = 2 ^ 2 ^ (card (nested_prop_atoms \<phi>) + 1)"
     by (simp add: semiring_normalization_rules(36))
 
   also have "\<dots> \<le> 2 ^ 2 ^ (n + 1)"
     using assms 1 by simp
 
   finally show ?thesis .
 qed
 
 
 lemma \<AA>'_nodes_finite:
   "finite (DRA.nodes (\<AA>' \<phi> xs ys))"
   unfolding ltl_to_dra.\<AA>'_def
   using dcai_nodes_finite dbcrai_nodes_finite
   using \<AA>\<^sub>1_nodes_finite \<AA>\<^sub>2_nodes_finite \<AA>\<^sub>3_nodes_finite
   by fast
 
 lemma \<AA>'_nodes_card:
   assumes
     "length xs \<le> n"
   and
     "\<And>\<psi>. \<psi> \<in> set xs \<Longrightarrow> card (nested_prop_atoms \<psi>) \<le> n"
   and
     "length ys \<le> n"
   and
     "\<And>\<psi>. \<psi> \<in> set ys \<Longrightarrow> card (nested_prop_atoms \<psi>) \<le> n"
   and
     "card (subfrmlsn \<phi>) \<le> n"
   shows
     "card (DRA.nodes (\<AA>' \<phi> xs ys)) \<le> 2 ^ 2 ^ (n + floorlog 2 n + 4)"
 proof -
   have "n + 1 \<le> n + floorlog 2 n + 2"
     by auto
 
   then have 1: "(2::nat) ^ (n + 1) \<le> 2 ^ (n + floorlog 2 n + 2)"
     using one_le_numeral power_increasing by blast
 
 
   have "card (DRA.nodes (\<AA>' \<phi> xs ys)) \<le> card (DCA.nodes (\<AA>\<^sub>1 \<phi> xs)) * card (DBA.nodes (\<AA>\<^sub>2 xs ys)) * card (DCA.nodes (\<AA>\<^sub>3 xs ys))" (is "?lhs \<le> ?rhs")
   proof (unfold ltl_to_dra.\<AA>'_def)
     have "card (DBA.nodes (\<AA>\<^sub>2 xs ys)) * card (DCA.nodes (dcai (\<AA>\<^sub>1 \<phi> xs) (\<AA>\<^sub>3 xs ys))) \<le> ?rhs"
       by (simp add: dcai_nodes_card[OF \<AA>\<^sub>1_nodes_finite \<AA>\<^sub>3_nodes_finite])
     then show "card (DRA.nodes (dbcrai (\<AA>\<^sub>2 xs ys) (dcai (\<AA>\<^sub>1 \<phi> xs) (\<AA>\<^sub>3 xs ys)))) \<le> ?rhs"
       by (meson dbcrai_nodes_card[OF \<AA>\<^sub>2_nodes_finite dcai_nodes_finite[OF \<AA>\<^sub>1_nodes_finite \<AA>\<^sub>3_nodes_finite]] basic_trans_rules(23))
   qed
 
   also have "\<dots> \<le> 2 ^ 2 ^ (n + 1) * 2 ^ 2 ^ (n + floorlog 2 n + 2) * 2 ^ 2 ^ (n + floorlog 2 n + 1)"
     using \<AA>\<^sub>1_nodes_card[OF assms(5)] \<AA>\<^sub>2_nodes_card[OF assms(1,2)] \<AA>\<^sub>3_nodes_card[OF assms(3,4)]
     by (metis mult_le_mono)
 
   also have "\<dots> = 2 ^ (2 ^ (n + 1) + 2 ^ (n + floorlog 2 n + 2) + 2 ^ (n + floorlog 2 n + 1))"
     by (metis power_add)
 
   also have "\<dots> \<le> 2 ^ (4 * 2 ^ (n + floorlog 2 n + 2))"
     using 1 by auto
 
   finally show ?thesis
     by (simp add: numeral.simps(2) power_add)
 qed
 
 lemma subformula_nested_prop_atoms_subfrmlsn:
   "\<psi> \<in> subfrmlsn \<phi> \<Longrightarrow> nested_prop_atoms \<psi> \<subseteq> subfrmlsn \<phi>"
   using nested_prop_atoms_subfrmlsn subfrmlsn_subset by blast
 
 
 lemma ltl_to_dra_nodes_finite:
   "finite (DRA.nodes (ltl_to_dra \<phi>))"
   unfolding ltl_to_dra.ltl_to_dra_def
   apply (rule draul_nodes_finite)
   apply (simp add: split_def ltl_to_dra.\<AA>'_alphabet advice_sets_not_empty)
   apply (simp add: list.pred_set split_def \<AA>'_nodes_finite)
   done
 
 lemma ltl_to_dra_nodes_card:
   assumes
     "card (subfrmlsn \<phi>) \<le> n"
   shows
     "card (DRA.nodes (ltl_to_dra \<phi>)) \<le> 2 ^ 2 ^ (2 * n + floorlog 2 n + 4)"
 proof -
   let ?map = "map (\<lambda>(x, y). \<AA>' \<phi> x y) (advice_sets \<phi>)"
 
   have 1: "\<And>x::nat. x > 0 \<Longrightarrow> x ^ length (advice_sets \<phi>) \<le> x ^ 2 ^ card (subfrmlsn \<phi>)"
     by (metis advice_sets_length linorder_not_less nat_power_less_imp_less)
 
   have "card (DRA.nodes (ltl_to_dra \<phi>)) \<le> prod_list (map (card \<circ> DRA.nodes) ?map)"
     unfolding ltl_to_dra.ltl_to_dra_def
     apply (rule draul_nodes_card)
     unfolding set_map image_image split_def ltl_to_dra.\<AA>'_alphabet
     apply (simp add: advice_sets_not_empty)
     unfolding split_def list.pred_set using \<AA>'_nodes_finite by auto
 
   also have "\<dots> = (\<Prod>(x, y)\<leftarrow>advice_sets \<phi>. card (DRA.nodes (\<AA>' \<phi> x y)))"
     by (induction "advice_sets \<phi>") (auto, metis (no_types, lifting) comp_apply split_def)
 
   also have "\<dots> \<le> (2 ^ 2 ^ (n + floorlog 2 n + 4)) ^ length (advice_sets \<phi>)"
   proof (rule list_prod_const, unfold split_def, rule \<AA>'_nodes_card)
     show "\<And>x. x \<in> set (advice_sets \<phi>) \<Longrightarrow> length (fst x) \<le> n"
       using advice_sets_element_length assms by fastforce
 
     show "\<And>x \<psi>. \<lbrakk>x \<in> set (advice_sets \<phi>); \<psi> \<in> set (fst x)\<rbrakk> \<Longrightarrow> card (nested_prop_atoms \<psi>) \<le> n"
       using advice_sets_element_subfrmlsn(1) assms subformula_nested_prop_atoms_subfrmlsn subformulas\<^sub>\<mu>_subfrmlsn
       by (metis (no_types, lifting) card_mono subfrmlsn_finite subset_iff sup.absorb_iff2 sup.coboundedI1 surjective_pairing)
 
     show "\<And>x. x \<in> set (advice_sets \<phi>) \<Longrightarrow> length (snd x) \<le> n"
       using advice_sets_element_length assms by fastforce
 
     show "\<And>x \<psi>. \<lbrakk>x \<in> set (advice_sets \<phi>); \<psi> \<in> set (snd x)\<rbrakk> \<Longrightarrow> card (nested_prop_atoms \<psi>) \<le> n"
       using advice_sets_element_subfrmlsn(2) assms subformula_nested_prop_atoms_subfrmlsn subformulas\<^sub>\<nu>_subfrmlsn
       by (metis (no_types, lifting) card_mono subfrmlsn_finite subset_iff sup.absorb_iff2 sup.coboundedI1 surjective_pairing)
   qed (insert assms, blast)
 
   also have "\<dots> \<le> (2 ^ 2 ^ (n + floorlog 2 n + 4)) ^ (2 ^ card (subfrmlsn \<phi>))"
     by (simp add: 1)
 
   also have "\<dots> \<le> (2 ^ 2 ^ (n + floorlog 2 n + 4)) ^ (2 ^ n)"
     by (simp add: assms power_increasing)
 
   also have "\<dots> = 2 ^ (2 ^ n * 2 ^ (n + floorlog 2 n + 4))"
-    by (metis Rat.sign_simps(5) power_mult)
+    by (simp add: ac_simps power_mult [symmetric])
 
   also have "\<dots> = 2 ^ 2 ^ (2 * n + floorlog 2 n + 4)"
-    by (simp add: semiring_normalization_rules(26))
+    by (simp add: power_add) (simp add: mult_2 power_add)
 
   finally show ?thesis .
 qed
 
 theorem ltl_to_dra_size:
   "card (DRA.nodes (ltl_to_dra \<phi>)) \<le> 2 ^ 2 ^ (2 * size \<phi> + floorlog 2 (size \<phi>) + 4)"
   using ltl_to_dra_nodes_card subfrmlsn_card by blast
 
 end
diff --git a/thys/LinearQuantifierElim/Thys/FRE.thy b/thys/LinearQuantifierElim/Thys/FRE.thy
--- a/thys/LinearQuantifierElim/Thys/FRE.thy
+++ b/thys/LinearQuantifierElim/Thys/FRE.thy
@@ -1,204 +1,205 @@
 (*  Author:     Tobias Nipkow, 2007  *)
 
 theory FRE
 imports LinArith
 begin
 
 subsection\<open>Ferrante-Rackoff \label{sec:FRE}\<close>
 
 text\<open>This section formalizes a slight variant of Ferrante and
 Rackoff's algorithm~\cite{FerranteR-SIAM75}. We consider equalities
 separately, which improves performance.\<close>
 
 fun between :: "real * real list \<Rightarrow> real * real list \<Rightarrow> real * real list"
 where "between (r,cs) (s,ds) = ((r+s)/2, (1/2) *\<^sub>s (cs+ds))"
 
 definition FR\<^sub>1 :: "atom fm \<Rightarrow> atom fm" where
 "FR\<^sub>1 \<phi> =
 (let as = R.atoms\<^sub>0 \<phi>; lbs = lbounds as; ubs = ubounds as; ebs = ebounds as;
      intrs = [subst \<phi> (between l u) . l \<leftarrow> lbs, u \<leftarrow> ubs]
  in list_disj (inf\<^sub>- \<phi> # inf\<^sub>+ \<phi> # intrs @ map (subst \<phi>) ebs))"
 
 
 lemma dense_interval:
 assumes "finite L" "finite U" "l \<in> L" "u \<in> U" "l < x" "x < u" "P(x::real)"
 and dense: "\<And>y l u. \<lbrakk> \<forall>y\<in>{l<..<x}. y \<notin> L;  \<forall>y\<in>{x<..<u}. y \<notin> U;
                        l<x;x<u; l<y;y<u \<rbrakk> \<Longrightarrow> P y"
 shows "\<exists>l\<in>L.\<exists>u\<in>U. l<u \<and> (\<forall>y. l<y \<and> y<u \<longrightarrow> P y)"
 proof -
   let ?L = "{l:L. l < x}" let ?U = "{u:U. x < u}"
   let ?ll = "Max ?L" let ?uu = "Min ?U"
   have "?L \<noteq> {}" using \<open>l \<in> L\<close> \<open>l<x\<close> by (blast intro:order_less_imp_le)
   moreover have "?U \<noteq> {}" using \<open>u:U\<close> \<open>x<u\<close> by (blast intro:order_less_imp_le)
   ultimately have "\<forall>y. ?ll<y \<and> y<x \<longrightarrow> y \<notin> L" "\<forall>y. x<y \<and> y<?uu \<longrightarrow> y \<notin> U"
     using \<open>finite L\<close> \<open>finite U\<close> by force+
   moreover have "?ll \<in> L"
   proof
     show "?ll \<in> ?L" using \<open>finite L\<close> Max_in[OF _ \<open>?L \<noteq> {}\<close>] by simp
     show "?L \<subseteq> L" by blast
   qed
   moreover have "?uu \<in> U"
   proof
     show "?uu \<in> ?U" using \<open>finite U\<close> Min_in[OF _ \<open>?U \<noteq> {}\<close>] by simp
     show "?U \<subseteq> U" by blast
   qed
   moreover have "?ll < x" using \<open>finite L\<close> \<open>?L \<noteq> {}\<close> by simp
   moreover have "x < ?uu" using \<open>finite U\<close> \<open>?U \<noteq> {}\<close> by simp
   moreover have "?ll < ?uu" using \<open>?ll<x\<close> \<open>x<?uu\<close> by arith
   ultimately show ?thesis using \<open>l < x\<close> \<open>x < u\<close> \<open>?L \<noteq> {}\<close> \<open>?U \<noteq> {}\<close>
     by(blast intro!:dense greaterThanLessThan_iff[THEN iffD1])
 qed
 
 lemma dense:
   "\<lbrakk> nqfree f; \<forall>y\<in>{l<..<x}. y \<notin> LB f xs; \<forall>y\<in>{x<..<u}. y \<notin> UB f xs;
      l < x; x < u; x \<notin> EQ f xs;  R.I f (x#xs); l < y; y < u\<rbrakk>
    \<Longrightarrow> R.I f (y#xs)"
 proof(induct f)
   case (Atom a)
   show ?case
   proof (cases a)
     case (Less r cs)
     show ?thesis
     proof (cases cs)
       case Nil thus ?thesis using Atom Less by (simp add:depends\<^sub>R_def)
     next
       case (Cons c cs)
       hence "r < c*x + \<langle>cs,xs\<rangle>" using Atom Less by simp
       { assume "c=0" hence ?thesis using Atom Less Cons by simp }
       moreover
       { assume "c<0"
         hence "x < (r - \<langle>cs,xs\<rangle>)/c" (is "_ < ?u") using \<open>r < c*x + \<langle>cs,xs\<rangle>\<close>
           by (simp add: field_simps)
         have ?thesis
         proof (rule ccontr)
           assume "\<not> R.I (Atom a) (y#xs)"
           hence "?u \<le> y" using Atom Less Cons \<open>c<0\<close>
             by (auto simp add: field_simps)
           hence "?u < u" using \<open>y<u\<close> by simp
           with \<open>x<?u\<close> show False using Atom Less Cons \<open>c<0\<close>
             by(auto simp:depends\<^sub>R_def)
         qed } moreover
       { assume "c>0"
         hence "x > (r - \<langle>cs,xs\<rangle>)/c" (is "_ > ?l") using \<open>r < c*x + \<langle>cs,xs\<rangle>\<close>
           by (simp add: field_simps)
         have ?thesis
         proof (rule ccontr)
           assume "\<not> R.I (Atom a) (y#xs)"
           hence "?l \<ge> y" using Atom Less Cons \<open>c>0\<close>
             by (auto simp add: field_simps)
           hence "?l > l" using \<open>y>l\<close> by simp
           with \<open>?l<x\<close> show False using Atom Less Cons \<open>c>0\<close>
             by (auto simp:depends\<^sub>R_def)
         qed }
       ultimately show ?thesis by force
     qed
   next
     case (Eq r cs)
     show ?thesis
     proof (cases cs)
       case Nil thus ?thesis using Atom Eq by (simp add:depends\<^sub>R_def)
     next
       case (Cons c cs)
       hence "r = c*x + \<langle>cs,xs\<rangle>" using Atom Eq by simp
       { assume "c=0" hence ?thesis using Atom Eq Cons by simp }
       moreover
       { assume "c\<noteq>0"
         hence ?thesis using \<open>r = c*x + \<langle>cs,xs\<rangle>\<close> Atom Eq Cons \<open>l<y\<close> \<open>y<u\<close>
           by(auto simp: ac_simps depends\<^sub>R_def split:if_splits) }
       ultimately show ?thesis by force
     qed
   qed
 next
   case (And f1 f2) thus ?case
     by auto (metis (no_types, hide_lams))+
 next
   case (Or f1 f2) thus ?case
     by auto (metis (no_types, hide_lams))+
 qed fastforce+
 
 theorem I_FR\<^sub>1:
 assumes "nqfree \<phi>" shows "R.I (FR\<^sub>1 \<phi>) xs = (\<exists>x. R.I \<phi> (x#xs))"
   (is "?FR = ?EX")
 proof
   assume ?FR
   { assume "R.I (inf\<^sub>- \<phi>) xs"
     hence ?EX using \<open>?FR\<close> min_inf[OF \<open>nqfree \<phi>\<close>, where xs=xs]
       by(auto simp add:FR\<^sub>1_def)
   } moreover
   { assume "R.I (inf\<^sub>+ \<phi>) xs"
     hence ?EX using \<open>?FR\<close> plus_inf[OF \<open>nqfree \<phi>\<close>, where xs=xs]
       by(auto simp add:FR\<^sub>1_def)
   } moreover
   { assume "\<exists>x \<in> EQ \<phi> xs. R.I \<phi> (x#xs)"
     hence ?EX using \<open>?FR\<close> by(auto simp add:FR\<^sub>1_def)
   } moreover
   { assume "\<not>R.I (inf\<^sub>- \<phi>) xs \<and> \<not>R.I (inf\<^sub>+ \<phi>) xs \<and>
             (\<forall>x\<in>EQ \<phi> xs. \<not>R.I \<phi> (x#xs))"
     with \<open>?FR\<close> obtain r cs s ds
       where "R.I (subst \<phi> (between (r,cs) (s,ds))) xs"
       by(auto simp: FR\<^sub>1_def eval_def
         diff_divide_distrib set_ebounds I_subst \<open>nqfree \<phi>\<close>) blast
     hence "R.I \<phi> (eval (between (r,cs) (s,ds)) xs # xs)"
       by(simp add:I_subst \<open>nqfree \<phi>\<close>)
     hence ?EX .. }
   ultimately show ?EX by blast
 next
   assume ?EX
   then obtain x where x: "R.I \<phi> (x#xs)" ..
   { assume "R.I (inf\<^sub>- \<phi>) xs \<or> R.I (inf\<^sub>+ \<phi>) xs"
     hence ?FR by(auto simp:FR\<^sub>1_def)
   } moreover
   { assume "x \<in> EQ \<phi> xs"
     then obtain r cs
       where "(r,cs) \<in> set(ebounds(R.atoms\<^sub>0 \<phi>)) \<and> x = r + \<langle>cs,xs\<rangle>"
       by(force simp:set_ebounds field_simps)
     moreover hence "R.I (subst \<phi> (r,cs)) xs" using x
       by(auto simp: I_subst \<open>nqfree \<phi>\<close> eval_def)
     ultimately have ?FR by(force simp:FR\<^sub>1_def) } moreover
   { assume "\<not> R.I (inf\<^sub>- \<phi>) xs" and "\<not> R.I (inf\<^sub>+ \<phi>) xs" and "x \<notin> EQ \<phi> xs"
     obtain l where "l \<in> LB \<phi> xs" "l < x"
       using LBex[OF \<open>nqfree \<phi>\<close> x \<open>\<not> R.I (inf\<^sub>- \<phi>) xs\<close> \<open>x \<notin> EQ \<phi> xs\<close>] ..
     obtain u where "u \<in> UB \<phi> xs" "x < u"
       using UBex[OF \<open>nqfree \<phi>\<close> x \<open>\<not> R.I (inf\<^sub>+ \<phi>) xs\<close> \<open>x \<notin> EQ \<phi> xs\<close>] ..
     have "\<exists>l\<in>LB \<phi> xs. \<exists>u\<in>UB \<phi> xs. l<u \<and> (\<forall>y. l < y \<and> y < u \<longrightarrow> R.I \<phi> (y#xs))"
       using dense_interval[where P = "\<lambda>x. R.I \<phi> (x#xs)", OF finite_LB finite_UB \<open>l:LB \<phi> xs\<close> \<open>u:UB \<phi> xs\<close> \<open>l<x\<close> \<open>x<u\<close> x] x dense[OF \<open>nqfree \<phi>\<close> _ _ _ _ \<open>x \<notin> EQ \<phi> xs\<close>] by simp
     then obtain r c cs s d ds
       where "Less r (c # cs) \<in> set (R.atoms\<^sub>0 \<phi>)" "Less s (d # ds) \<in> set (R.atoms\<^sub>0 \<phi>)"
           "\<And>y. (r - \<langle>cs,xs\<rangle>) / c < y \<Longrightarrow> y < (s - \<langle>ds,xs\<rangle>) / d \<Longrightarrow> R.I \<phi> (y # xs)"
         and *: "c > 0" "d < 0" "(r - \<langle>cs,xs\<rangle>) / c < (s - \<langle>ds,xs\<rangle>) / d"
       by blast
     moreover
       have "(r - \<langle>cs,xs\<rangle>) / c < eval (between (r / c, (-1 / c) *\<^sub>s cs) (s / d, (-1 / d) *\<^sub>s ds)) xs" (is ?P)
         and "eval (between (r / c, (-1 / c) *\<^sub>s cs) (s / d, (-1 / d) *\<^sub>s ds)) xs < (s - \<langle>ds,xs\<rangle>) / d" (is ?Q)
     proof -
-      from * have [simp]: "c * (c * (d * (d * 4))) > 0" by (auto simp add: sign_simps)
+      from * have [simp]: "c * (c * (d * (d * 4))) > 0"
+        by (simp add: sign_simps)
       from * have "c * s + d * \<langle>cs,xs\<rangle> < d * r + c * \<langle>ds,xs\<rangle>"
         by (simp add: field_simps)
       with * have "(2 * c * c * d) * (d * r + c * \<langle>ds,xs\<rangle>)
         < (2 * c * c * d) * (c * s + d * \<langle>cs,xs\<rangle>)"
         and "(2 * c * d * d) * (c * s + d * \<langle>cs,xs\<rangle>)
         < (2 * c * d * d) * (d * r + c * \<langle>ds,xs\<rangle>)" by simp_all
       with * show ?P and ?Q by (auto simp add: field_simps eval_def iprod_left_add_distrib)
     qed
     ultimately have ?FR
       by (fastforce simp: FR\<^sub>1_def bex_Un set_lbounds set_ubounds set_ebounds I_subst \<open>nqfree \<phi>\<close>)
   } ultimately show ?FR by blast
 qed
 
 
 definition "FR = R.lift_nnf_qe FR\<^sub>1"
 
 
 lemma qfree_FR\<^sub>1: "nqfree \<phi> \<Longrightarrow> qfree (FR\<^sub>1 \<phi>)"
 apply(simp add:FR\<^sub>1_def)
 apply(rule qfree_list_disj)
 apply(auto simp:qfree_min_inf qfree_plus_inf set_ubounds set_lbounds set_ebounds image_def qfree_map_fm)
 done
 
 theorem I_FR: "R.I (FR \<phi>) xs = R.I \<phi> xs"
 by(simp add:I_FR\<^sub>1 FR_def R.I_lift_nnf_qe qfree_FR\<^sub>1)
 
 theorem qfree_FR: "qfree (FR \<phi>)"
 by(simp add:FR_def R.qfree_lift_nnf_qe qfree_FR\<^sub>1)
 
 end
diff --git a/thys/Multi_Party_Computation/Secure_Multiplication.thy b/thys/Multi_Party_Computation/Secure_Multiplication.thy
--- a/thys/Multi_Party_Computation/Secure_Multiplication.thy
+++ b/thys/Multi_Party_Computation/Secure_Multiplication.thy
@@ -1,799 +1,800 @@
 subsection \<open>Secure multiplication protocol\<close>
 
 theory Secure_Multiplication imports
   CryptHOL.Cyclic_Group_SPMF   
   Uniform_Sampling 
   Semi_Honest_Def
 begin
 
 locale secure_mult =
   fixes q :: nat
   assumes q_gt_0: "q > 0"
     and "prime q"
 begin
 
 type_synonym real_view = "nat \<Rightarrow> nat \<Rightarrow> ((nat \<times> nat \<times> nat \<times> nat) \<times> nat \<times> nat) spmf"
 type_synonym sim = "nat \<Rightarrow> nat \<Rightarrow> ((nat \<times> nat \<times> nat \<times> nat) \<times> nat \<times> nat) spmf"
 
 lemma samp_uni_set_spmf [simp]: "set_spmf (sample_uniform q) = {..< q}" 
   by(simp add: sample_uniform_def)
 
 definition funct :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) spmf"
   where "funct x y = do {
     s \<leftarrow> sample_uniform q;
     return_spmf (s, (x*y + (q - s)) mod q)}"
 
 definition TI :: "((nat \<times> nat) \<times> (nat \<times> nat)) spmf"
   where "TI = do {
     a \<leftarrow> sample_uniform q;  
     b \<leftarrow> sample_uniform q;
     r \<leftarrow> sample_uniform q;
     return_spmf ((a, r), (b, ((a*b + (q - r)) mod q)))}"
 
 definition out :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) spmf"
   where "out x y = do {
     ((c1,d1),(c2,d2)) \<leftarrow> TI;
     let e2 = (x + c1) mod q;
     let e1 = (y + (q - c2)) mod q;
     return_spmf (((x*e1 + (q - d1)) mod q), ((e2 * c2 + (q - d2)) mod q))}"
 
 definition R1 :: "real_view"
   where "R1 x y = do {
     ((c1, d1), (c2, d2)) \<leftarrow> TI;
     let e2 = (x + c1) mod q;
     let e1 = (y + (q - c2)) mod q;
     let s1 = (x*e1 + (q - d1)) mod q;
     let s2 = (e2 * c2 + (q - d2)) mod q;
     return_spmf ((x, c1, d1, e1), s1, s2)}"
 
 definition S1 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<times> nat \<times> nat) spmf" 
   where "S1 x s1 = do {
     a :: nat \<leftarrow> sample_uniform q;  
     e1 \<leftarrow> sample_uniform q;
     let d1 = (x*e1 + (q - s1)) mod q;
     return_spmf (x, a, d1, e1)}"
 
 definition Out1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) spmf"
   where "Out1 x y s1 = do {
     let s2 = (x*y + (q - s1)) mod q;
     return_spmf (s1,s2)}"
 
 definition R2 :: "real_view"
   where "R2 x y = do {
     ((c1, d1), (c2, d2)) \<leftarrow> TI;
     let e2 = (x + c1) mod q;
     let e1 = (y + (q - c2)) mod q;
     let s1 = (x*e1 + (q - d1)) mod q;
     let s2 = (e2 * c2 + (q - d2)) mod q;
     return_spmf ((y, c2, d2, e2), s1, s2)}"
 
 definition S2 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<times> nat \<times> nat) spmf"
   where "S2 y s2 = do { 
     b \<leftarrow> sample_uniform q;
     e2 \<leftarrow> sample_uniform q;
     let d2 = (e2*b + (q - s2)) mod q;
     return_spmf (y, b, d2, e2)}"
 
 definition Out2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) spmf"
   where "Out2 y x s2 = do {
     let s1 = (x*y + (q - s2)) mod q;
     return_spmf (s1,s2)}"
 
 definition Ideal2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ((nat \<times> nat \<times> nat \<times> nat) \<times> (nat \<times> nat)) spmf"
   where "Ideal2 y x out2 = do {
     view2 :: (nat \<times> nat \<times> nat \<times> nat) \<leftarrow> S2 y out2;
     out2 \<leftarrow> Out2 y x out2;
     return_spmf (view2, out2)}"
 
 sublocale sim_non_det_def: sim_non_det_def R1 S1 Out1 R2 S2 Out2 funct .
 
 lemma minus_mod:
   assumes "a > b"
   shows "[a - b mod q = a - b] (mod q)"
   by(metis cong_diff_nat  cong_def le_trans less_or_eq_imp_le assms mod_less_eq_dividend mod_mod_trivial)
 
 lemma q_cong:"[a = q + a] (mod q)" 
   by (simp add: cong_def)
 
 lemma q_cong_reverse: "[q + a = a] (mod q)" 
   by (simp add: cong_def)
 
 lemma qq_cong: "[a = q*q + a] (mod q)" 
   by (simp add: cong_def)
 
 lemma minus_q_mult_cancel: 
   assumes "[a = e + b - q * c - d] (mod q)" 
     and "e + b - d > 0" 
     and "e + b - q * c - d > 0"
   shows  "[a = e + b  - d] (mod q)" 
 proof-
   have "a mod q = (e + b - q * c - d) mod q"
     using assms(1) cong_def by blast
   then have "a mod q = (e + b - d) mod q"
     by (metis (no_types) add_cancel_left_left assms(3) diff_commute diff_is_0_eq' linordered_semidom_class.add_diff_inverse mod_add_left_eq mod_mult_self1_is_0 nat_less_le)
   then show ?thesis
     using cong_def by blast
 qed
 
 lemma s1_s2:
   assumes "x < q" "a < q" "b < q" and r:"r < q" "y < q"
   shows "((x + a) mod q * b + q - (a * b + q - r) mod q) mod q =
           (x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q"
 proof-
   have s: "(x * y + (q - (x * ((y + (q - b)) mod q) + (q - r)) mod q)) mod q 
                  = ((x + a) mod q * b + (q - (a * b + (q - r)) mod q)) mod q"
   proof-
     have lhs: "(x * y + (q - (x * ((y + (q - b)) mod q) + (q - r)) mod q)) mod q = (x*b + r) mod q"
     proof-
       let ?h = "(x * y + (q - (x * ((y + (q - b)) mod q) + (q - r)) mod q)) mod q"
       have "[?h = x * y + q - (x * ((y + (q - b)) mod q) + (q - r)) mod q] (mod q)" 
         by(simp add: assms(1) cong_def q_gt_0)
       then have "[?h = x * y + q - (x * (y + (q - b)) + (q - r)) mod q] (mod q)" 
         by (metis mod_add_left_eq mod_mult_right_eq)
       then have no_qq: "[?h = x * y + q - (x * y + x * (q - b) + (q - r)) mod q] (mod q)" 
         by(metis distrib_left)
       then have "[?h = q*q + x * y + q - (x * y + x * (q - b) + (q - r)) mod q] (mod q)"  
       proof-
         have "[x * y + q - (x * y + x * (q - b) + (q - r)) mod q = q*q + x * y + q - (x * y + x * (q - b) + (q - r)) mod q] (mod q)"
           by (smt qq_cong  add.assoc cong_diff_nat cong_def le_add2 le_trans mod_le_divisor q_gt_0)
         then show ?thesis using cong_trans no_qq by blast
       qed
       then have mod: "[?h = q + q*q + x * y + q - (x * y + x * (q - b) + (q - r)) mod q] (mod q)"  
         by (smt Nat.add_diff_assoc cong_def add.assoc add.commute le_add2 le_trans mod_add_self2 mod_le_divisor q_gt_0)
       then have "[?h = q + q*q + x * y + q - (x * y + x * (q - b) + (q - r))] (mod q)"
       proof-
         have 1: "q \<ge> q - b" using assms by simp 
         then have  "q*q \<ge> x*(q-b)" "q \<ge> q - r" using 1  assms   
            apply (auto simp add: mult_strict_mono)  
           by (simp add: mult_le_mono)
         then have "q + q*q + x * y + q  > x * y + x * (q - b) + (q - r)" 
           using assms(5) by linarith
         then have "[q + q*q + x * y + q - (x * y + x * (q - b) + (q - r)) mod q = q + q*q + x * y + q - (x * y + x * (q - b) + (q - r))] (mod q)"
           using minus_mod by blast
         then show ?thesis using mod using cong_trans by blast  
       qed
       then have "[?h = q + q*q + x * y + q - (x * y + (x * q - x*b) + (q - r))] (mod q)"  
         by (simp add: right_diff_distrib')
       then have "[?h = q + q*q + x * y + q - x * y - (x * q - x*b) - (q - r)] (mod q)" 
         by simp
       then have mod': "[?h = q + q*q + q - (x * q - x*b) - (q - r)] (mod q)" 
         by(simp add: add.commute)
       then have neg: "[?h = q + q*q + q - x * q +  x*b - (q - r)] (mod q)" 
       proof-
         have "[q + q*q + q - (x * q - x*b) - (q - r) = q + q*q + q - x * q + x*b - (q - r)] (mod q)"
         proof(cases "x = 0")
           case True
           then show ?thesis by simp
         next
           case False
           have "x * q - x*b > 0" using False assms by simp
           also have "q + q*q + q - x * q > 0"  
             by (metis assms(1) add.commute diff_mult_distrib2 less_Suc_eq mult.commute mult_Suc_right nat_0_less_mult_iff q_gt_0 zero_less_diff)
           ultimately show ?thesis by simp
         qed
         then show ?thesis using mod' cong_trans by blast  
       qed
       then have "[?h = q + q*q + q +  x*b - (q - r)] (mod q)" 
       proof-
         have "[q + q*q + q - x * q +  x*b - (q - r) = q + q*q + q +  x*b - (q - r)] (mod q)"
         proof(cases "x = 0")
           case True
           then show ?thesis by simp
         next
           case False
           have "q*q > x*q" 
             using False assms 
             by (simp add: mult_strict_mono) 
           then have 1: "q + q*q + q - x * q +  x*b - (q - r) > 0" 
             by linarith
           then have 2: "q + q*q + q +  x*b - (q - r) > 0" by simp
           then show ?thesis 
             by (smt 1 2 Nat.add_diff_assoc2 \<open>x * q < q * q\<close> add_cancel_left_left add_diff_inverse_nat 
                 le_add1 le_add2 le_trans less_imp_add_positive less_numeral_extra(3) minus_mod 
                 minus_q_mult_cancel mod_if mult.commute q_gt_0)
         qed
         then show ?thesis using cong_trans neg by blast
       qed
       then have "[?h = q + q*q + q +  x*b - q + r] (mod q)" 
         by (metis r(1) Nat.add_diff_assoc2 Nat.diff_diff_right le_add2 less_imp_le_nat semiring_normalization_rules(23))   
       then have "[?h = q + q*q + q +  x*b + r] (mod q)" 
         apply(simp add: cong_def)  
         by (metis (no_types, lifting) add.assoc add.commute add_diff_cancel_right' diff_is_0_eq' mod_if mod_le_divisor q_gt_0)
       then have "[?h = x*b + r] (mod q)" 
         apply(simp add: cong_def) 
         by (metis mod_add_cong mod_add_self1 mod_mult_self1) 
       then show ?thesis by (simp add: cong_def assms)
     qed
     also have rhs: "((x + a) mod q * b + (q - (a * b + (q - r)) mod q)) mod q = (x*b + r) mod q"
     proof-
       let ?h = "((x + a) mod q * b + (q - (a * b + (q - r)) mod q)) mod q"
       have "[?h =  (x + a) mod q * b + q - (a * b + (q - r)) mod q] (mod q)" 
         by (simp add: q_gt_0  assms(1) cong_def)
       then have "[?h = (x + a) * b + q - (a * b + (q - r)) mod q] (mod q)" 
         by (smt Nat.add_diff_assoc cong_def mod_add_cong mod_le_divisor mod_mult_left_eq q_gt_0 assms)
       then have "[?h = x*b + a*b + q - (a * b + (q - r)) mod q] (mod q)" 
         by(metis distrib_right) 
       then have mod: "[?h = q + x*b + a*b + q - (a * b + (q - r)) mod q] (mod q)" 
         by (smt Nat.add_diff_assoc cong_def add.assoc add.commute le_add2 le_trans mod_add_self2 mod_le_divisor q_gt_0)
       then have "[?h =  q + x*b + a*b + q - (a * b + (q - r))] (mod q)" using  q_cong assms(1) 
       proof-
         have ge: "q + x*b + a*b + q  > (a * b + (q - r))" using assms by simp
         then have "[ q + x*b + a*b + q - (a * b + (q - r)) mod q =  q + x*b + a*b + q - (a * b + (q - r))] (mod q)"
           using Divides.mod_less_eq_dividend cong_diff_nat  cong_def le_trans less_not_refl2
                   less_or_eq_imp_le q_gt_0 minus_mod by presburger
         then show ?thesis using mod cong_trans by blast  
       qed
       then have "[?h =  q + x*b + q - (q - r)] (mod q)" 
         by (simp add: add.commute)
       then have "[?h =  q + x*b + q - q + r] (mod q)" 
         by (metis Nat.add_diff_assoc2 Nat.diff_diff_right r(1) le_add2 less_imp_le_nat)
       then have "[?h = q + x*b + r] (mod q)" by simp
       then have "[?h = q + (x*b + r)] (mod q)" 
         using add.assoc by metis
       then have "[?h = x*b + r] (mod q)" 
         using cong_def q_cong_reverse by metis 
       then show ?thesis by (simp add: cong_def assms(1))
     qed
     ultimately show ?thesis by simp
   qed
   have lhs:"((x + a) mod q * b + q - (a * b + q - r) mod q) mod q = ((x + a) mod q * b + (q - (a * b + (q - r)) mod q)) mod q"
     using assms by simp
   have rhs: "(x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q = (x * y + (q - (x * ((y + (q - b)) mod q) + (q - r)) mod q)) mod q " 
     using assms by simp
   have " ((x + a) mod q * b + (q - (a * b + (q - r)) mod q)) mod q = (x * y + (q - (x * ((y + (q - b)) mod q) + (q - r)) mod q)) mod q"
     using assms s[symmetric] by blast
   then show ?thesis using lhs rhs 
     by metis
 qed
 
 lemma s1_s2_P2:
   assumes "x < q" "xa < q" "xb < q" "xc < q" "y < q"
   shows "((y, xa, (xb * xa + q - xc) mod q, (x + xb) mod q), (x * ((y + q - xa) mod q) + q - xc) mod q, ((x + xb) mod q * xa + q - (xb * xa + q - xc) mod q) mod q) =
          ((y, xa, (xb * xa + q - xc) mod q, (x + xb) mod q), (x * ((y + q - xa) mod q) + q - xc) mod q, (x * y + q - (x * ((y + q - xa) mod q) + q - xc) mod q) mod q)"
   using assms s1_s2 by metis
 
 lemma c1: 
   assumes "e2 = (x + c1) mod q" 
     and  "x < q" "c1 < q"
   shows "c1 = (e2 + q - x) mod q"
 proof-
   have "[e2 + q = x + c1] (mod q)" by(simp add: assms cong_def)
   then have "[e2 + q - x  =  c1] (mod q)" 
   proof-
     have "e2 + q \<ge> x" using assms by simp
     then show ?thesis 
       by (metis \<open>[e2 + q = x + c1] (mod q)\<close> cong_add_lcancel_nat le_add_diff_inverse)
   qed
   then show ?thesis by(simp add: cong_def assms)
 qed
 
 lemma c1_P2:
   assumes "xb < q" "xa < q" "xc < q" "x < q" 
   shows "((y, xa, (xb * xa + q - xc) mod q, (x + xb) mod q), (x * ((y + q - xa) mod q) + q - xc) mod q, (x * y + q - (x * ((y + q - xa) mod q) + q - xc) mod q) mod q) = 
           ((y, xa, (((x + xb) mod q + q - x) mod q * xa + q - xc) mod q, (x + xb) mod q), (x * ((y + q - xa) mod q) + q - xc) mod q, (x * y + q - (x * ((y + q - xa) mod q) + q - xc) mod q) mod q)"
 proof-
   have "(xb * xa + q - xc) mod q = (((x + xb) mod q + q - x) mod q * xa + q - xc) mod q"
     using assms c1 by simp
   then show ?thesis
     using assms by metis
 qed
 
 lemma minus_mod_cancel:
   assumes "a - b > 0" "a - b mod q > 0" 
   shows "[a - b + c = a - b mod q + c] (mod q)" 
 proof-
   have "(b - b mod q + (a - b)) mod q = (0 + (a - b)) mod q"
     using  cong_def mod_add_cong neq0_conv q_gt_0 
     by (simp add: minus_mod_eq_mult_div)
   then show ?thesis
     by (metis (no_types) Divides.mod_less_eq_dividend Nat.add_diff_assoc2 add_diff_inverse_nat assms(1) cong_def diff_is_0_eq' less_or_eq_imp_le mod_add_cong neq0_conv)
 qed
 
 lemma d2: 
   assumes d2: "d2 = (((e2 + q - x) mod q)*b + (q - r)) mod q"
     and s1: "s1 = (x*((y + (q - b)) mod q) + (q - r)) mod q" 
     and s2: "s2 = (x*y + (q - s1)) mod q"
     and x: "x < q"
     and y: "y < q" 
     and r: "r < q" 
     and b: "b < q" 
     and e2: "e2 < q"
   shows "d2  = (e2*b + (q - s2)) mod q" 
 proof-
   have s1_le_q: "s1 < q" 
     using s1 q_gt_0 by simp
   have s2_le_q: "s2 < q" 
     using s2 q_gt_0 by simp
   have xb: "(x*b) mod q = (s2  + (q - r)) mod q"
   proof-
     have "s1 = (x*(y + (q - b)) + (q - r)) mod q" using s1 b 
       by (metis mod_add_left_eq mod_mult_right_eq)
     then have s1_dist: "s1 = (x*y + x*(q - b) + (q - r)) mod q" 
       by(metis distrib_left)
     then have "s1 = (x*y + x*q - x*b + (q - r)) mod q" 
       using distrib_left b diff_mult_distrib2 by auto
     then have "[s1 = x*y + x*q - x*b + (q - r)] (mod q)" 
       by(simp add: cong_def)
     then have "[s1 + x * b = x*y + x*q - x*b + x*b + (q - r)] (mod q)" 
       by (metis add.commute add.left_commute cong_add_lcancel_nat)
     then have "[s1 + x*b = x*y + x*q + (q - r)] (mod q)" 
-      by (metis add.commute add_lessD1 add_mult_distrib b left_diff_distrib' less_imp_le linordered_field_class.sign_simps(18) linordered_semidom_class.add_diff_inverse mult.commute not_less)
+      using b by (simp add: algebra_simps)
+        (metis add_diff_inverse_nat diff_diff_left diff_mult_distrib2 less_imp_add_positive mult.commute not_add_less1 zero_less_diff)
     then have s1_xb: "[s1 + x*b = q + x*y + x*q + (q - r)] (mod q)" 
       by (smt mod_add_cong mod_add_self1 cong_def)
     then have "[x*b = q + x*y + x*q + (q - r) - s1] (mod q)"
     proof-
       have "q + x*y + x*q + (q - r) - s1 > 0" using s1_le_q by simp
       then show ?thesis 
         by (metis add_diff_inverse_nat less_numeral_extra(3) s1_xb cong_add_lcancel_nat nat_diff_split)
     qed
     then have "[x*b = x*y + x*q + (q - r) + q - s1] (mod q)" 
       by (metis add.assoc add.commute)
     then have "[x*b = x*y + (q - r) + q - s1] (mod q)" 
       by (smt Nat.add_diff_assoc cong_def less_imp_le_nat mod_mult_self1 s1_le_q semiring_normalization_rules(23))
     then have "(x*b) mod q = (x*y  + (q - r) + q - s1) mod q" 
       by(simp add: cong_def) 
     then have "(x*b) mod q = (x*y  + (q - r) + (q - s1)) mod q" 
       using add.assoc s1_le_q by auto
     then have "(x*b) mod q = (x*y  + (q - s1) + (q - r)) mod q" 
       using add.commute by presburger
     then show ?thesis using s2 by presburger
   qed 
   have "d2 = (((e2 + q - x) mod q)*b + (q - r)) mod q" 
     using d2 by simp
   then have "d2 = (((e2 + q - x))*b + (q - r)) mod q" 
     using mod_add_cong mod_mult_left_eq by blast
   then have "d2 = (e2*b + q*b - x*b + (q - r)) mod q"  
     by (simp add: distrib_right diff_mult_distrib)
   then have a: "[d2 = e2*b + q*b - x*b + (q - r)] (mod q)" 
     by(simp add: cong_def)
   then have b:"[d2 = q + q + e2*b + q*b - x*b + (q - r)] (mod q)" 
   proof-
     have "[e2*b + q*b - x*b + (q - r) = q + q + e2*b + q*b - x*b + (q - r)] (mod q)"
       by (smt assms Nat.add_diff_assoc add.commute cong_def less_imp_le_nat mod_add_self2 
           mult.commute nat_mult_le_cancel_disj semiring_normalization_rules(23))
     then show ?thesis using cong_trans a by blast
   qed
   then have "[d2 = q + q + e2*b + q*b - (x*b) mod q + (q - r)] (mod q)" 
   proof-
     have "[q + q + e2*b + q*b - (x*b)  + (q - r) = q + q + e2*b + q*b - (x*b) mod q + (q - r)] (mod q)"
     proof(cases "b = 0")
       case True
       then show ?thesis by simp
     next
       case False
       have "q*b - (x*b) > 0"
         using False x by simp
       then have 1: "q + q + e2*b + q*b - (x*b) > 0" by linarith
       then have 2:"q + q + e2*b + q*b - (x*b) mod q > 0" 
         by (simp add: q_gt_0 trans_less_add1)
       then show ?thesis using 1 2 minus_mod_cancel by simp
     qed
     then show ?thesis using cong_trans b by blast
   qed
   then have c: "[d2 = q + q + e2*b + q*b - (s2  + (q - r)) mod q + (q - r)] (mod q)" 
     using xb by simp
   then have "[d2 = q + q + e2*b + q*b - (s2  + (q - r)) + (q - r)] (mod q)"
   proof-
     have "[q + q + e2*b + q*b - (s2  + (q - r)) mod q + (q - r) = q + q + e2*b + q*b - (s2  + (q - r)) + (q - r)] (mod q)"
     proof-
       have "q + q + e2*b + q*b - (s2  + (q - r)) mod q > 0"  
         by (metis diff_is_0_eq gr0I le_less_trans mod_less_divisor not_add_less1 q_gt_0 semiring_normalization_rules(23) trans_less_add2)
       moreover have"q + q + e2*b + q*b - (s2  + (q - r)) > 0" 
         using s2_le_q by simp
       ultimately show ?thesis 
         using minus_mod_cancel cong_sym by blast
     qed
     then show ?thesis using cong_trans c by blast
   qed
   then have d: "[d2 = q + q + e2*b + q*b - s2 - (q - r) + (q - r)] (mod q)" by simp
   then have "[d2 = q + q + e2*b + q*b - s2 ] (mod q)" 
   proof-
     have "q + q + e2*b + q*b - s2 - (q - r) > 0" 
       using s2_le_q by simp
     then show ?thesis using d cong_trans by simp
   qed
   then have "[d2 = q + q + e2*b - s2] (mod q)" 
     by (smt Nat.add_diff_assoc2 cong_def less_imp_le_nat mod_mult_self1 mult.commute s2_le_q semiring_normalization_rules(23) trans_less_add2)
   then have "[d2 = q + e2*b + q - s2] (mod q)" 
     by(simp add: add.commute add.assoc) 
   then have "[d2 = e2*b + q - s2] (mod q)" 
     by (smt Nat.add_diff_assoc2 add.commute cong_def less_imp_le_nat mod_add_self2 s2_le_q trans_less_add2)
   then have "[d2 = e2*b + (q - s2)] (mod q)"
     by (simp add: less_imp_le_nat s2_le_q) 
   then show ?thesis by(simp add: cong_def d2)
 qed
 
 lemma d2_P2:
   assumes x: "x < q" and y: "y < q" and r: "b < q" and b: "e2 < q" and e2: "r < q"
   shows "((y, b, ((e2 + q - x) mod q * b + q - r) mod q, e2), (x * ((y + q - b) mod q) + q - r) mod q, (x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q) =
                 ((y, b, (e2 * b + q - (x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q) mod q, e2), (x * ((y + q - b) mod q) + q - r) mod q, 
                       (x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q)"
 proof-
   have "((e2 + q - x) mod q * b + q - r) mod q = (e2 * b + q - (x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q) mod q"
     (is "?lhs = ?rhs")
   proof-
     have d2: "(((e2 + q - x) mod q)*b + (q - r)) mod q  = (e2*b + (q - ((x*y + (q - ((x*((y + (q - b)) mod q) + (q - r)) mod q))) mod q))) mod q" 
       using assms d2 by blast
     have "?lhs = (((e2 + q - x) mod q)*b + (q - r)) mod q" 
       using assms by simp
     also have "?rhs = (e2*b + (q - ((x*y + (q - ((x*((y + (q - b)) mod q) + (q - r)) mod q))) mod q))) mod q" 
       using assms by simp
     ultimately show ?thesis using assms d2 by metis
   qed 
   then show ?thesis using assms by metis
 qed
 
 lemma s1: 
   assumes s2: "s2 = (x*y + q - s1) mod q" 
     and x: "x < q" 
     and y: "y < q" 
     and s1: "s1 < q"
   shows "s1 = (x*y + q - s2) mod q"
 proof-
   have s2_le_q:"s2 < q" using s2 q_gt_0 by simp
   have "[s2 = x*y + q - s1] (mod q)" by(simp add: cong_def s2)
   then have "[s2 = x*y + q - s1] (mod q)" using add.assoc 
     by (simp add: less_imp_le_nat s1)
   then have s1_s2: "[s2 + s1 = x*y + q] (mod q)" 
     by (metis (mono_tags, lifting) cong_def le_add2 le_add_diff_inverse2 le_trans mod_add_left_eq order.strict_implies_order s1)
   then have "[s1 = x*y + q - s2] (mod q)" 
   proof-
     have "x*y + q - s2 > 0" using s2_le_q by simp
     then show ?thesis 
       by (metis s1_s2 add_diff_cancel_left' cong_diff_nat cong_def le_add1 less_imp_le_nat zero_less_diff)
   qed
   then show ?thesis by(simp add: cong_def s1)
 qed
 
 lemma s1_P2: 
   assumes x: "x < q" 
     and y: "y < q" 
     and "b < q" 
     and "e2 < q" 
     and "r < q" 
     and "s1 < q"
   shows "((y, b, (e2 * b + q - (x * y + q - r) mod q) mod q, e2), r, (x * y + q - r) mod q) =
                 ((y, b, (e2 * b + q - (x * y + q - r) mod q) mod q, e2), (x * y + q - (x * y + q - r) mod q) mod q, (x * y + q - r) mod q)"
 proof-
   have "s1 = (x*y + q - ((x*y + q - s1) mod q)) mod q"
     using assms secure_mult.s1 secure_mult_axioms by blast
   then show ?thesis using assms s1 by blast 
 qed
 
 theorem P2_security:
   assumes "x < q" "y < q"
   shows "sim_non_det_def.inf_theoretic_P2 x y"
   including monad_normalisation
 proof-
   have "((funct x y) \<bind> (\<lambda> (s1',s2'). (sim_non_det_def.Ideal2 y x s2'))) = R2 x y"
   proof-
     have "R2 x y = do {
       a :: nat \<leftarrow> sample_uniform q;  
       b :: nat \<leftarrow> sample_uniform q;
       r :: nat \<leftarrow> sample_uniform q;
       let c1 = a;
       let d1 = r;
       let c2 = b;
       let d2 = ((a*b + (q - r)) mod q);
       let e2 = (x + c1) mod q;
       let e1 = (y + (q - c2)) mod q;
       let s1 = (x*e1 + (q - r)) mod q;
       let s2 = (e2 * c2 + (q - d2)) mod q;
       return_spmf ((y, c2, d2, e2), s1, s2)}"
       by(simp add: R2_def TI_def Let_def)
     also have "... = do {
       a :: nat \<leftarrow> sample_uniform q;  
       b :: nat \<leftarrow> sample_uniform q;
       r :: nat \<leftarrow> sample_uniform q;
       let c1 = a;
       let d1 = r;
       let c2 = b;
       let e2 = (x + c1) mod q;
       let d2 = ((((e2 + q - x) mod q)*b + (q - r)) mod q);
       let s1 = (x*((y + (q - c2)) mod q) + (q - r)) mod q;
       return_spmf ((y, c2, d2, e2), (s1, (x*y + (q - s1)) mod q))}"
       by(simp add: Let_def s1_s2_P2 assms c1_P2 cong: bind_spmf_cong_simp)
     also have "... = do {
       b :: nat \<leftarrow> sample_uniform q;
       r :: nat \<leftarrow> sample_uniform q;
       let d1 = r;
       let c2 = b;
       e2 \<leftarrow> map_spmf (\<lambda> c1. (x + c1) mod q) (sample_uniform q);
       let d2 = ((((e2 + q - x) mod q)*b + (q - r)) mod q);
       let s1 = (x*((y + (q - c2)) mod q) + (q - r)) mod q;
       return_spmf ((y, c2, d2, e2), s1, (x*y + (q - s1)) mod q)}"
       by(simp add: bind_map_spmf o_def Let_def)
     also have "... = do {
       b :: nat \<leftarrow> sample_uniform q;
       r :: nat \<leftarrow> sample_uniform q;
       let d1 = r;
       let c2 = b;
       e2 \<leftarrow> sample_uniform q;
       let d2 = (((e2 + q - x) mod q)*b + (q - r)) mod q;
       let s1 = (x*((y + (q - c2)) mod q) + (q - r)) mod q;
       return_spmf ((y, c2, d2, e2), s1, (x*y + (q - s1)) mod q)}"
       by(simp add: samp_uni_plus_one_time_pad)
     also have "... = do {
       b :: nat \<leftarrow> sample_uniform q;
       r :: nat \<leftarrow> sample_uniform q;
       e2 \<leftarrow> sample_uniform q;
       let s1 = (x*((y + (q - b)) mod q) + (q - r)) mod q;
       let s2 = (x*y + (q - s1)) mod q;
       let d2 = (((e2 + q - x) mod q)*b + (q - r)) mod q;
       return_spmf ((y, b, d2, e2), s1, s2)}"
       by(simp)
     also have "... = do {
       b :: nat \<leftarrow> sample_uniform q;
       r :: nat \<leftarrow> sample_uniform q;
       e2 \<leftarrow> sample_uniform q;
       let s1 = (x*((y + (q - b)) mod q) + (q - r)) mod q;
       let s2 = (x*y + (q - s1)) mod q;
       let d2 = (e2*b + (q - s2)) mod q;
       return_spmf ((y, b, d2, e2), s1, s2)}"
       by(simp add: d2_P2 assms Let_def cong: bind_spmf_cong_simp)
     also have "... = do {
       b :: nat \<leftarrow> sample_uniform q;
       e2 \<leftarrow> sample_uniform q;
       s1 \<leftarrow> map_spmf (\<lambda> r. (x*((y + (q - b)) mod q) + (q - r)) mod q) (sample_uniform q);
       let s2 = (x*y + (q - s1)) mod q;
       let d2 = (e2*b + (q - s2)) mod q;
       return_spmf ((y, b, d2, e2), s1, s2)}"
       by(simp add: bind_map_spmf o_def Let_def)
     also have "... = do {
       b :: nat \<leftarrow> sample_uniform q;
       e2 \<leftarrow> sample_uniform q;
       s1 \<leftarrow> sample_uniform q;
       let s2 = (x*y + (q - s1)) mod q;
       let d2 = (e2*b + (q - s2)) mod q;
       return_spmf ((y, b, d2, e2), s1, s2)}"
       by(simp add: samp_uni_minus_one_time_pad)
     also have "... = do {
       b :: nat \<leftarrow> sample_uniform q;
       e2 \<leftarrow> sample_uniform q;
       s1 \<leftarrow> sample_uniform q;
       let s2 = (x*y + (q - s1)) mod q;
       let d2 = (e2*b + (q - s2)) mod q;
       return_spmf ((y, b, d2, e2), (x*y + (q - s2)) mod q, s2)}"
       by(simp add: s1_P2 assms Let_def cong: bind_spmf_cong_simp)
     ultimately show ?thesis by(simp add: funct_def Let_def sim_non_det_def.Ideal2_def Out2_def S2_def R2_def)
   qed
   then show ?thesis by(simp add: sim_non_det_def.inf_theoretic_P2_def)
 qed
 
 lemma s1_s2_P1:  assumes "x < q" "xa < q" "xb < q" "xc < q" "y < q"
   shows "((x, xa, xb, (y + q - xc) mod q), (x * ((y + q - xc) mod q) + q - xb) mod q, ((x + xa) mod q * xc + q - (xa * xc + q - xb) mod q) mod q) = 
          ((x, xa, xb, (y + q - xc) mod q), (x * ((y + q - xc) mod q) + q - xb) mod q, (x * y + q - (x * ((y + q - xc) mod q) + q - xb) mod q) mod q)"
   using assms s1_s2 by metis
 
 lemma mod_minus: assumes "a - b > 0" and "c - d > 0" 
   shows "(a - b + (c - d mod q)) mod q = (a - b + (c - d)) mod q"
-  using assms 
+  using assms
   by (metis cong_def minus_mod mod_add_right_eq zero_less_diff)
 
 lemma r: 
   assumes e1: "e1 = (y + (q - b)) mod q" 
     and s1: "s1 = (x*((y + (q - b)) mod q) + (q - r)) mod q"
     and b: "b < q"
     and x: "x < q" 
     and y: "y < q" 
     and r: "r < q" 
   shows "r = (x*e1 + (q - s1)) mod q"
     (is "?lhs = ?rhs")
 proof-
   have "s1 = (x*((y + (q - b))) + (q - r)) mod q" using s1 b 
     by (metis mod_add_left_eq mod_mult_right_eq)
   then have s1_dist: "s1 = (x*y + x*(q - b) + (q - r)) mod q" 
     by(metis distrib_left)
   then have "?rhs = (x*((y + (q - b)) mod q) + (q - (x*y + x*(q - b) + (q - r)) mod q)) mod q" 
     using e1  by simp
   then have "?rhs = (x*((y + (q - b))) + (q - (x*y + x*(q - b) + (q - r)) mod q)) mod q" 
     by (metis mod_add_left_eq mod_mult_right_eq)
   then have "?rhs = (x*y + x*(q - b) + (q - (x*y + x*(q - b) + (q - r)) mod q)) mod q" 
     by(metis distrib_left)
   then have a: "?rhs = (x*y + x*q - x*b + (q - (x*y + x*(q - b) + (q - r)) mod q)) mod q" 
     using distrib_left b diff_mult_distrib2 by auto
   then have b: "?rhs = (x*y + x*q - x*b + (q*q + q*q + q  - (x*y + x*(q - b) + (q - r)) mod q)) mod q" 
   proof -
     have "(x*y + x*q - x*b + (q - (x*y + x*(q - b) + (q - r)) mod q)) mod q = (x*y + x*q - x*b + (q*q + q*q + q - (x*y + x*(q - b) + (q - r)) mod q)) mod q"
     proof -
       have f1: "\<forall>n na nb nc nd. (n::nat) mod na \<noteq> nb mod na \<or> nc mod na \<noteq> nd mod na \<or> (n + nc) mod na = (nb + nd) mod na"
         by (meson mod_add_cong)
       then have "(q - (x * y + x*(q - b) + (q - r)) mod q) mod q = (q * q + q * q + q - (x * y + x*(q - b) + (q - r)) mod q) mod q"
         by (metis Nat.diff_add_assoc mod_le_divisor q_gt_0 mod_mult_self4)
       then show ?thesis
         using f1 by blast
     qed
     then show ?thesis using a by simp
   qed
   then have "?rhs = (x*y + x*q - x*b + (q*q + q*q + q  - (x*y + x*(q - b) + (q - r)))) mod q" 
   proof-
     have "(x*y + x*q - x*b + (q*q + q*q + q - (x*y + x*(q - b) + (q - r)) mod q)) mod q =
          (x*y + x*q - x*b + (q*q + q*q + q - (x*y + x*(q - b)+ (q - r)))) mod q" 
     proof(cases "x = 0")
       case True
       then show ?thesis  
         by (metis (no_types, lifting) assms(2) assms(4) True Nat.add_diff_assoc add.left_neutral 
             cong_def diff_le_self minus_mod mult_is_0 not_gr_zero zero_eq_add_iff_both_eq_0 zero_less_diff)
     next
       case False
       have qb: "q - b \<le> q" 
         using b by simp
       then have qb':"x*(q - b) < q*q" 
         using x by (metis mult_less_le_imp_less nat_0_less_mult_iff nat_less_le neq0_conv)   
       have a: "x*y + x*(q - b) > 0" 
         using False assms by simp
       have 1: "q*q > x*y" 
         using False by (simp add: mult_strict_mono q_gt_0 x y)
       have 2: "q*q > x*q" using False 
         by (simp add: mult_strict_mono q_gt_0 x y)
       have b: "(q*q + q*q + q - (x*y + x*(q - b) + (q - r))) > 0" 
         using 1 qb' by simp
       then show ?thesis using a b mod_minus[of "x*y + x*q" "x*b" "q*q + q*q + q" "x*y + x*(q - b) + (q - r)"]
         by (smt add.left_neutral cong_def gr0I minus_mod zero_less_diff)
     qed
     then show ?thesis using b by simp
   qed
   then have d: "?rhs = (x*y + x*q - x*b + (q*q + q*q + q - x*y - x*(q - b) - (q - r))) mod q" 
     by simp
   then have e: "?rhs = (x*y + x*q - x*b + q*q + q*q + q - x*y - x*(q - b) - (q - r)) mod q" 
   proof(cases "x = 0")
     case True
     then show ?thesis using True d by simp
   next
     case False
     have qb: "q - b \<le> q" using b by simp
     then have qb':"x*(q - b) < q*q"  
       using x by (metis mult_less_le_imp_less nat_0_less_mult_iff nat_less_le neq0_conv)   
     have a: "x*y + x*(q - b) > 0" using False assms by simp
     have 1: "q*q > x*y" using False 
       by (simp add: mult_strict_mono q_gt_0 x y)
     have 2: "q*q > x*q" using False 
       by (simp add: mult_strict_mono q_gt_0 x y)
     have b: "q*q + q*q + q  - x*y - x*(q - b) - (q - r) > 0" using 1 qb' by simp
     then show ?thesis using b d 
       by (smt Nat.add_diff_assoc add.assoc diff_diff_left less_imp_le_nat zero_less_diff)
   qed
   then have "?rhs = (x*q - x*b + q*q + q*q + q - x*(q - b) - (q - r)) mod q" 
   proof-
     have "(x*y + x*q - x*b + q*q + q*q + q - x*y - x*(q - b) - (q - r)) mod q = (x*q - x*b + q*q + q*q + q - x*(q - b) - (q - r)) mod q"
     proof -
       have 1: "q + n - b = q - b + n" for n 
         by (simp add: assms(3) less_imp_le)
       have 2: "(c::nat) * b + (c * a + n) = c * (b + a) + n" 
         for n a b c by (simp add: distrib_left)
       have "(c::nat) + (b + a) - (n + a) = c + b - n" for n a b c
         by auto
       then have "(q + (q * q + (q * q + x * (q + y - b))) - (q - r + x * (y + (q - b)))) mod q = (q + (q * q + (q * q + x * (q - b))) - (q - r + x * (q - b))) mod q"
         by (metis (no_types) add.commute 1 2)
       then show ?thesis
         by (simp add: add.commute diff_mult_distrib2 distrib_left)
     qed
     then show ?thesis using e by simp
   qed
   then have "?rhs = (x*(q - b) + q*q + q*q + q - x*(q - b) - (q - r)) mod q" 
     by(metis diff_mult_distrib2)
   then have "?rhs = (q*q + q*q + q - (q - r)) mod q" 
     using assms(6) by simp
   then have "?rhs = (q*q + q*q + q - q + r) mod q" 
     using assms(6) by(simp add: Nat.diff_add_assoc2 less_imp_le)
   then have "?rhs = (q*q + q*q  + r) mod q" 
     by simp
   then have "?rhs = r mod q" 
     by (metis add.commute distrib_right mod_mult_self1)
   then show ?thesis using assms(6) by simp
 qed
 
 lemma r_P2:
   assumes b: "b < q" and x: "x < q" and y: "y < q" and r: "r < q"
   shows 
     "((x, a, r, (y + q - b) mod q), (x * ((y + q - b) mod q) + q - r) mod q, (x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q) =
               ((x, a, (x * ((y + q - b) mod q) + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q, (y + q - b) mod q), (x * ((y + q - b) mod q) + q - r) mod q,     
                       (x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q)"
 proof-
   have  "(x * ((y + q - b) mod q) + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q = r" 
     (is "?lhs = ?rhs")
   proof-
     have 1:"r = (x*((y + (q - b)) mod q) + (q - ((x*((y + (q - b)) mod q) + (q - r)) mod q))) mod q"
       using assms secure_mult.r secure_mult_axioms by blast
     also have "?rhs = (x*((y + (q - b)) mod q) + (q - ((x*((y + (q - b)) mod q) + (q - r)) mod q))) mod q" using assms 1 by blast
     ultimately show ?thesis using assms 1 by simp
   qed
   then show ?thesis using assms by simp
 qed
 
 theorem P1_security:
   assumes "x < q" "y < q"
   shows "sim_non_det_def.inf_theoretic_P1 x y"
   including monad_normalisation
 proof-
   have "(funct x y) \<bind> (\<lambda> (s1',s2'). (sim_non_det_def.Ideal1 x y s1')) = R1 x y"
   proof-
     have "R1 x y = do {
     a :: nat \<leftarrow> sample_uniform q;  
     b :: nat \<leftarrow> sample_uniform q;
     r :: nat \<leftarrow> sample_uniform q;    
     let c1 = a;
     let d1 = r;
     let c2 = b;
     let d2 = ((a*b + (q - r)) mod q);
     let e2 = (x + c1) mod q;
     let e1 = (y + (q - c2)) mod q;
     let s1 = (x*e1 + (q - d1)) mod q;
     let s2 = (e2 * c2 + (q - d2)) mod q;
     return_spmf ((x, c1, d1, e1), s1, s2)}"
       by(simp add: R1_def TI_def Let_def)
     also have "... = do {
     a :: nat \<leftarrow> sample_uniform q;  
     b :: nat \<leftarrow> sample_uniform q;
     r :: nat \<leftarrow> sample_uniform q;    
     let c1 = a;
     let c2 = b;
     let e1 = (y + (q - b)) mod q;
     let s1 = (x*((y + (q - b)) mod q) + (q - r)) mod q;
     let d1 = (x*e1 + (q - s1)) mod q;
     return_spmf ((x, c1, d1, e1), s1, (x*y + (q - s1)) mod q)}"
       by(simp add: Let_def assms s1_s2_P1  r_P2 cong: bind_spmf_cong_simp)
     also have "... = do {
     a :: nat \<leftarrow> sample_uniform q;  
     b :: nat \<leftarrow> sample_uniform q;
     let c1 = a;
     let c2 = b;
     let e1 = (y + (q - b)) mod q;
     s1 \<leftarrow> map_spmf (\<lambda> r. (x*((y + (q - b)) mod q) + (q - r)) mod q) (sample_uniform q);
     let d1 = (x*e1 + (q - s1)) mod q;
     return_spmf ((x, c1, d1, e1), s1, (x*y + (q - s1)) mod q)}"
       by(simp add: bind_map_spmf Let_def o_def)
     also have "... = do {
     a :: nat \<leftarrow> sample_uniform q;  
     b :: nat \<leftarrow> sample_uniform q;
     let c1 = a;
     let c2 = b;
     let e1 = (y + (q - b)) mod q;
     s1 \<leftarrow> sample_uniform q;
     let d1 = (x*e1 + (q - s1)) mod q;
     return_spmf ((x, c1, d1, e1), s1, (x*y + (q - s1)) mod q)}"
       by(simp add: samp_uni_minus_one_time_pad)
     also have "... = do {
     a :: nat \<leftarrow> sample_uniform q;  
     let c1 = a;
     e1 \<leftarrow> map_spmf (\<lambda>b. (y + (q - b)) mod q) (sample_uniform q);
     s1 \<leftarrow> sample_uniform q;
     let d1 = (x*e1 + (q - s1)) mod q;
     return_spmf ((x, c1, d1, e1), s1, (x*y + (q - s1)) mod q)}"
       by(simp add: bind_map_spmf Let_def o_def)
     also have "... = do {
     a :: nat \<leftarrow> sample_uniform q;  
     let c1 = a;
     e1 \<leftarrow> sample_uniform q;
     s1 \<leftarrow> sample_uniform q;
     let d1 = (x*e1 + (q - s1)) mod q;
     return_spmf ((x, c1, d1, e1), s1, (x*y + (q - s1)) mod q)}"      
       by(simp add: samp_uni_minus_one_time_pad)
     ultimately show ?thesis by(simp add: funct_def sim_non_det_def.Ideal1_def Let_def R1_def TI_def Out1_def S1_def)
   qed
   thus ?thesis by(simp add: sim_non_det_def.inf_theoretic_P1_def)
 qed
 
 end
 
 locale secure_mult_asymp = 
   fixes q :: "nat \<Rightarrow> nat"
   assumes "\<And> n. secure_mult (q n)"
 begin
 
 sublocale secure_mult "q n" for n 
   using secure_mult_asymp_axioms secure_mult_asymp_def by blast
 
 theorem P1_secure:
   assumes "x < q n" "y < q n"
   shows "sim_non_det_def.inf_theoretic_P1 n x y"
   by (metis P1_security assms)
 
 theorem P2_secure:
   assumes "x < q n" "y < q n"
   shows "sim_non_det_def.inf_theoretic_P2 n x y"
   by (metis P2_security assms)
 
 end 
 
 end
\ No newline at end of file
diff --git a/thys/Neumann_Morgenstern_Utility/PMF_Composition.thy b/thys/Neumann_Morgenstern_Utility/PMF_Composition.thy
--- a/thys/Neumann_Morgenstern_Utility/PMF_Composition.thy
+++ b/thys/Neumann_Morgenstern_Utility/PMF_Composition.thy
@@ -1,448 +1,448 @@
 (* License: LGPL *)
 (* Author: Julian Parsert *)
 
 
 theory PMF_Composition
   imports
     "HOL-Probability.Probability"
 begin
 
 
 section \<open> Composition of Probability Mass functions \<close>
 
 definition mix_pmf :: "real \<Rightarrow> 'a pmf \<Rightarrow> 'a pmf \<Rightarrow> 'a pmf" where
   "mix_pmf \<alpha> p q = (bernoulli_pmf \<alpha>)\<bind> (\<lambda>X. if X then p else q)"
 
 lemma pmf_mix: "a \<in> {0..1} \<Longrightarrow> pmf (mix_pmf a p q) x = a * pmf p x + (1 - a) * pmf q x"
   by (simp add: mix_pmf_def pmf_bind)
 
 lemma pmf_mix_deeper: "a \<in> {0..1} \<Longrightarrow> pmf (mix_pmf a p q) x = a * pmf p x + pmf q x - a * pmf q x"
   by (simp add: left_diff_distrib' pmf_mix)
 
 lemma bernoulli_pmf_0 [simp]: "bernoulli_pmf 0 = return_pmf False"
   by (intro pmf_eqI) (auto simp: bernoulli_pmf.rep_eq)
 
 lemma bernoulli_pmf_1 [simp]: "bernoulli_pmf 1 = return_pmf True"
   by (intro pmf_eqI) (auto simp: bernoulli_pmf.rep_eq)
 
 lemma pmf_mix_0 [simp]: "mix_pmf 0 p q = q"
   by (simp add: mix_pmf_def bind_return_pmf)
 
 lemma pmf_mix_1 [simp]: "mix_pmf 1 p q = p"
   by (simp add: mix_pmf_def bind_return_pmf)
 
 lemma set_pmf_mix: "a \<in> {0<..<1} \<Longrightarrow> set_pmf (mix_pmf a p q) = set_pmf p \<union> set_pmf q"
   by (auto simp add: mix_pmf_def split: if_splits)
 
 lemma set_pmf_mix_eq: "a \<in> {0..1} \<Longrightarrow> mix_pmf a p p = p"
   by (simp add: mix_pmf_def)
 
 lemma pmf_equiv_intro[intro]:
   assumes "\<And>e. e \<in> set_pmf p \<Longrightarrow> pmf p e = pmf q e"
   assumes "\<And>e. e \<in> set_pmf q \<Longrightarrow> pmf q e = pmf p e"
   shows "p = q"
   by (metis assms(2) less_irrefl pmf_neq_exists_less pmf_not_neg set_pmf_iff)
 
 lemma pmf_equiv_intro1[intro]:
   assumes "\<And>e. e \<in> set_pmf p \<Longrightarrow> pmf p e = pmf q e"
   shows "p = q"
   by (standard, auto simp: assms, metis assms set_pmf_iff assms 
       linorder_not_le order_refl pmf_neq_exists_less pmf_not_neg set_pmf_iff)
 
 lemma pmf_inverse_switch_eqals:  
   assumes "a \<in> {0..1}"
   shows "mix_pmf a p q = mix_pmf (1-a) q p"
 proof -
   have fst: "\<forall>x \<in> set_pmf p. pmf (mix_pmf a p q) x = pmf (mix_pmf (1-a) q p) x"
   proof
     fix x 
     assume "x \<in> set_pmf p"
     have "pmf (mix_pmf a p q) x = a * pmf p x + (1 - a) * pmf q x"
       using pmf_mix[of a p q x] assms by blast
     also have "... = a * pmf p x +  pmf q x - a * pmf q x"
       by (simp add: left_diff_distrib)
     from pmf_mix[of "1-a" q p x] assms 
     have "pmf (mix_pmf (1 - a) q p) x = (1 - a) * pmf q x + (1 - (1 - a)) * pmf p x"
       by auto
     then show "pmf (mix_pmf a p q) x = pmf (mix_pmf (1 - a) q p) x"
       using calculation by auto
   qed
   have "\<forall>x \<in> set_pmf q. pmf (mix_pmf a p q) x =  pmf (mix_pmf (1-a) q p) x"
   proof
     fix x 
     assume "x \<in> set_pmf q"
     have "pmf (mix_pmf a p q) x = a * pmf p x + (1 - a) * pmf q x"
       using pmf_mix[of a p q x] assms by blast
     also have "... = a * pmf p x +  pmf q x - a * pmf q x"
       by (simp add: left_diff_distrib)
     from pmf_mix[of "1-a" q p x] assms
     show "pmf (mix_pmf a p q) x = pmf (mix_pmf (1 - a) q p) x"
       using calculation by auto
   qed
   then have "\<forall>x \<in> set_pmf (mix_pmf a p q). pmf (mix_pmf a p q) x =  pmf (mix_pmf (1-a) q p) x"
     by (metis (no_types) fst add_0_left assms mult_eq_0_iff pmf_mix set_pmf_iff)
   thus ?thesis
     by (simp add: pmf_equiv_intro1)
 qed
 
 lemma mix_pmf_comp_left_div:
   assumes "\<alpha> \<in> {0..(1::real)}"
     and "\<beta> \<in> {0..(1::real)}"
   assumes "\<alpha> > \<beta>"
   shows "pmf (mix_pmf (\<beta>/\<alpha>) (mix_pmf \<alpha> p q) q) e = \<beta> * pmf p e + pmf q e - \<beta> * pmf q e"
 proof-
   let ?l = "(mix_pmf (\<beta>/\<alpha>) (mix_pmf \<alpha> p q) q)"
   have fst: "pmf ?l e = (\<beta>/\<alpha>) * pmf (mix_pmf \<alpha> p q) e + (1-\<beta>/\<alpha>) * pmf q e"
     by (meson assms(1) assms(2) assms(3) atLeastAtMost_iff less_divide_eq_1 
         less_eq_real_def not_less pmf_mix zero_le_divide_iff)
   then have "pmf (mix_pmf \<alpha> p q) e = \<alpha> * pmf p e + (1 - \<alpha>) * pmf q e"
     using pmf_mix[of "\<alpha>" p q] assms(2) assms(3) assms(1) by blast
   have "pmf ?l e = (\<beta>/\<alpha>) * (\<alpha> * pmf p e + (1 - \<alpha>) * pmf q e) + (1-\<beta>/\<alpha>) * pmf q e"
     using fst assms(1) pmf_mix by fastforce
   then have "pmf ?l e = ((\<beta>/\<alpha>) *\<alpha> * pmf p e + (\<beta>/\<alpha>) *(1 - \<alpha>) * pmf q e) + (1-\<beta>/\<alpha>) * pmf q e"
     using fst assms(1) by (metis  mult.assoc  ring_class.ring_distribs(1))
   then have *: "pmf ?l e = (\<beta> * pmf p e + (\<beta>/\<alpha>) *(1 - \<alpha>) * pmf q e) + (1-\<beta>/\<alpha>) * pmf q e"
     using fst assms(1) assms(2) assms(3) by auto
   then have "pmf ?l e = (\<beta> * pmf p e + ((\<beta>/\<alpha>) - (\<beta>/\<alpha>)*\<alpha>) * pmf q e) + (1-\<beta>/\<alpha>) * pmf q e"
     using fst assms(1) assms(2) assms(3) by (simp add: * diff_divide_distrib right_diff_distrib')
   then have "pmf ?l e = (\<beta> * pmf p e + ((\<beta>/\<alpha>) - \<beta>) * pmf q e) + (1-\<beta>/\<alpha>) * pmf q e"
     using fst assms(1) assms(2) assms(3) by auto
   then have "pmf ?l e = (\<beta> * pmf p e + (\<beta>/\<alpha>) * pmf q e - \<beta> * pmf q e) + 1* pmf q e-\<beta>/\<alpha>* pmf q e"
     by (simp add: left_diff_distrib)
   thus ?thesis
     by linarith
 qed
 
 lemma mix_pmf_comp_with_dif_equiv:
   assumes "\<alpha> \<in> {0..(1::real)}"
     and "\<beta> \<in> {0..(1::real)}"
   assumes "\<alpha> > \<beta>"
   shows "mix_pmf (\<beta>/\<alpha>) (mix_pmf \<alpha> p q) q = mix_pmf \<beta> p q" (is "?l = ?r")
 proof (rule pmf_equiv_intro1[symmetric])
   fix e
   assume a: "e \<in> set_pmf ?r" 
   have "e \<in> set_pmf ?l"
     using a pmf_mix_deeper by (metis assms(1) assms(2) assms(3) mix_pmf_comp_left_div pmf_eq_0_set_pmf)
   then have "pmf ?l e = \<beta> * pmf p e - \<beta> * pmf q e + pmf q e"
     using pmf_mix_deeper[of "\<beta>/\<alpha>" p q e] mix_pmf_comp_left_div[of \<alpha> \<beta> p q e] assms by auto  
   then show "pmf (mix_pmf \<beta> p q) e = pmf (mix_pmf (\<beta> / \<alpha>) (mix_pmf \<alpha> p q) q) e"
     by (metis (full_types) assms(1) assms(2) assms(3) mix_pmf_comp_left_div pmf_mix_deeper)
 qed
 
 lemma product_mix_pmf_prob_distrib:
   assumes "a \<in> {0..1}"
     and "b \<in> {0..1}"
   shows "mix_pmf a (mix_pmf b p q) q = mix_pmf (a*b) p q"
 proof -
   define \<gamma> where g: "\<gamma> = (a * b)"
   define l where l: "l = (mix_pmf b p q)"
   define r where r: "r =  mix_pmf (a*b) p q"
   have y: "\<gamma> \<in> {0..1}"
     using assms(2) mult_le_one assms g by auto
   have alt_: "\<forall>e \<in> set_pmf l. pmf r e = \<gamma> * pmf p e + pmf q e - \<gamma> * pmf q e"
   proof
     fix e 
     have "pmf r e = \<gamma> * pmf p e + (1-\<gamma>) * pmf q e"
       using \<open>\<gamma> \<in> {0..1}\<close> g pmf_mix r by fastforce
     moreover have "... = \<gamma> * pmf p e + 1 * pmf q e - \<gamma> * pmf q e"
-      by (simp add: linordered_field_class.sign_simps(37))
+      by (simp add: algebra_simps)
     moreover have "... = pmf (mix_pmf \<gamma> p q) e"
       using calculation g r by auto
     moreover have "... = \<gamma>  * pmf p e + pmf q e - \<gamma> * pmf q e"
       using calculation by auto
     ultimately show "pmf r e = \<gamma> * pmf p e + pmf q e - \<gamma> * pmf q e" 
       by auto
   qed
   have "\<forall>e \<in> set_pmf r. pmf l e = b * pmf p e + pmf q e - b * pmf q e"
     using allI pmf_mix_deeper assms(2) l by fastforce
   have "mix_pmf a (mix_pmf b p q) q = mix_pmf (a * b) p q" 
   proof (rule ccontr)
     assume neg:"\<not>mix_pmf a (mix_pmf b p q) q = mix_pmf (a * b) p q"
     then have b: "b \<noteq> 0"
       by (metis (no_types) assms(1) mult_cancel_right2 pmf_mix_0 set_pmf_mix_eq)
     have f3: "b - (a * b) > 0 \<longrightarrow> mix_pmf a (mix_pmf b p q) q = mix_pmf (a * b) p q"  
       by (metis assms(2) diff_le_0_iff_le g mix_pmf_comp_with_dif_equiv mult_eq_0_iff 
           nonzero_mult_div_cancel_right not_le order_refl y)
     thus False
       using b neg assms(1) assms(2) by auto
   qed
   then show ?thesis by auto
 qed
 
 lemma mix_pmf_subset_of_original:
   assumes "a \<in> {0..1}"
   shows "(set_pmf (mix_pmf a p q)) \<subseteq> set_pmf p \<union> set_pmf q"
 proof -
   have "a \<in> {0<..<1} \<Longrightarrow> ?thesis"
     by (simp add: set_pmf_mix)
   moreover have "a = 1 \<Longrightarrow> ?thesis"
     by simp
   moreover have "a = 0 \<Longrightarrow> ?thesis"
     by simp
   ultimately show ?thesis
     using assms less_eq_real_def by auto
 qed
 
 lemma mix_pmf_preserves_finite_support:
   assumes "a \<in> {0..1}"
   assumes "finite (set_pmf p)"
     and "finite (set_pmf q)"
   shows "finite (set_pmf (mix_pmf a p q))"
   by (meson assms(1) assms(2) assms(3) finite_Un finite_subset mix_pmf_subset_of_original)
 
 lemma ex_certain_iff_singleton_support:
   shows "(\<exists>x. pmf p x = 1) \<longleftrightarrow> card (set_pmf p) = 1"
 proof (rule iffI, goal_cases)
   case 1
   show ?case 
   proof (rule ccontr)
     assume neg: "\<not> card (set_pmf p) = 1"
     then have "card (set_pmf p) \<noteq> 1"
       by blast
     have "finite (set_pmf p)"  
       by (metis "1" empty_iff finite.emptyI finite_insert insert_iff 
           not_le pmf_le_1 pmf_neq_exists_less pmf_nonneg set_pmf_iff set_return_pmf)
     then have sumeq_1: "(\<Sum>i \<in> set_pmf p. pmf p i) = 1"
       using sum_pmf_eq_1[of "set_pmf p" p] by auto
     have set_pmf_nemtpy: "set_pmf p \<noteq> {}"
       by (simp add: set_pmf_not_empty)
     then have g1: "card (set_pmf p) > 1"
       by (metis card_0_eq less_one nat_neq_iff neg sum.infinite sumeq_1 zero_neq_one)
     have "card (set_pmf p) > 1 \<longrightarrow> (\<Sum>i \<in> set_pmf p. pmf p i) > 1"
     proof
       assume "card (set_pmf p) > 1"     
       have "\<exists>x y. pmf p x = 1 \<and> y \<noteq> x \<and> y \<in> set_pmf p"
         using  set_pmf_nemtpy is_singletonI' is_singleton_altdef
         by (metis "1" neg)
       then show "(\<Sum>i \<in> set_pmf p. pmf p i) > 1"
         by (metis AE_measure_pmf_iff UNIV_I empty_iff insert_iff
             measure_pmf.prob_eq_1 pmf.rep_eq sets_measure_pmf)
     qed
     then have "card (set_pmf p) < 1"
       using sumeq_1 neg by linarith
     then show False
       using g1 by linarith
   qed
 qed (metis card_1_singletonE less_numeral_extra(1) pmf.rep_eq subset_eq
     sum_pmf_eq_1[of "set_pmf p" p]  card_gt_0_iff[of "set_pmf p"] 
     measure_measure_pmf_finite[of "set_pmf p"])
 
 
 text \<open> We thank Manuel Eberl for suggesting the following two lemmas. \<close>
 
 lemma mix_pmf_partition:
   fixes p :: "'a pmf"
   assumes "y \<in> set_pmf p" "set_pmf p - {y} \<noteq> {}"
   obtains a q where "a \<in> {0<..<1}" "set_pmf q = set_pmf p - {y}" 
     "p = mix_pmf a q (return_pmf y)"
 proof -
   from assms obtain x where x: "x \<in> set_pmf p - {y}" by auto
   define a where "a = 1 - pmf p y"
   have a_n1:"a \<noteq> 1"
     by (simp add: a_def assms(1) pmf_eq_0_set_pmf)
   have "pmf p y \<noteq> 1"
     using ex_certain_iff_singleton_support by (metis (full_types) 
         Diff_cancel assms(1) assms(2) card_1_singletonE singletonD)
   hence y: "pmf p y < 1" using pmf_le_1[of p y] unfolding a_def by linarith
   hence a: "a > 0" by (simp add: a_def)
   define q where "q = embed_pmf (\<lambda>z. if z = y then 0 else pmf p z / a)"
   have q: "pmf q z = (if z = y then 0 else pmf p z / a)" for z
     unfolding q_def
   proof (rule pmf_embed_pmf)
     have "1 = (\<integral>\<^sup>+ x. ennreal (pmf p x) \<partial>count_space UNIV)"
       by (rule nn_integral_pmf_eq_1 [symmetric])
     also have "\<dots> = (\<integral>\<^sup>+ x. ennreal (pmf p x) * indicator {y} x + 
                       ennreal (pmf p x) * indicator (-{y}) x \<partial>count_space UNIV)"
       by (intro nn_integral_cong) (auto simp: indicator_def)
     also have "\<dots> = (\<integral>\<^sup>+ x. ennreal (pmf p x) * indicator {y} x \<partial>count_space UNIV) + 
                     (\<integral>\<^sup>+ x. ennreal (pmf p x) * indicator (-{y}) x \<partial>count_space UNIV)"
       by (subst nn_integral_add) auto
     also have "(\<integral>\<^sup>+ x. ennreal (pmf p x) * indicator {y} x \<partial>count_space UNIV) = pmf p y"
       by (subst nn_integral_indicator_finite) auto
     also have "ennreal (pmf p y) + (\<integral>\<^sup>+ x. ennreal (pmf p x) * indicator (-{y}) x \<partial>count_space UNIV)
                  - ennreal (pmf p y) = (\<integral>\<^sup>+ x. ennreal (pmf p x) * indicator (-{y}) x \<partial>count_space UNIV)"
       by simp
     also have "1 - ennreal (pmf p y) = ennreal (1 - pmf p y)"
       by (subst ennreal_1 [symmetric], subst ennreal_minus) auto
     finally have eq: "(\<integral>\<^sup>+x\<in>-{y}. ennreal (pmf p x)\<partial>count_space UNIV) = 1 - pmf p y" ..
     have "(\<integral>\<^sup>+ x. ennreal (if x = y then 0 else pmf p x / a) \<partial>count_space UNIV) =
             (\<integral>\<^sup>+ x. inverse a * (ennreal (pmf p x) * indicator (-{y}) x) \<partial>count_space UNIV)"
       using a by (intro nn_integral_cong) (auto simp: divide_simps ennreal_mult' [symmetric])
     also have "\<dots> = inverse a * (\<integral>\<^sup>+ x\<in>-{y}. ennreal (pmf p x) \<partial>count_space UNIV)"
       using a by (subst nn_integral_cmult [symmetric]) (auto simp: ennreal_mult')
     also note eq
     also have "ennreal (inverse a) * ennreal (1 - pmf p y) = ennreal ((1 - pmf p y) / a)"
       using a by (subst ennreal_mult' [symmetric]) (auto simp: field_simps)
     also have "(1 - pmf p y) / a = 1" using y by (simp add: a_def)
     finally show "(\<integral>\<^sup>+ x. ennreal (if x = y then 0 else pmf p x / a) \<partial>count_space UNIV) = 1"
       by simp
   qed (insert a, auto)
   have "mix_pmf (1 - pmf p y) q (return_pmf y) = p"
     using y by (intro pmf_eqI) (auto simp: q pmf_mix pmf_le_1 a_def)
   moreover have "set_pmf q = set_pmf p - {y}"
     using y by (auto simp: q set_pmf_eq a_def)
   ultimately show ?thesis using that[of "1 - pmf p y" q] y assms by (auto simp: set_pmf_eq)
 qed
 
 lemma pmf_mix_induct [consumes 2, case_names degenerate mix]:
   assumes "finite A" "set_pmf p \<subseteq> A"
   assumes degenerate: "\<And>x. x \<in> A \<Longrightarrow> P (return_pmf x)"
   assumes mix:        "\<And>p a y. set_pmf p \<subseteq> A \<Longrightarrow> a \<in> {0<..<1} \<Longrightarrow> y \<in> A \<Longrightarrow> 
                          P p \<Longrightarrow> P (mix_pmf a p (return_pmf y))"
   shows "P p"
 proof -
   have "finite (set_pmf p)" "set_pmf p \<noteq> {}" "set_pmf p \<subseteq> A"
     using assms(1,2) by (auto simp: set_pmf_not_empty dest: finite_subset)
   thus ?thesis
   proof (induction "set_pmf p" arbitrary: p rule: finite_ne_induct)
     case (singleton x p)
     hence "p = return_pmf x" using set_pmf_subset_singleton[of p x] by auto
     thus ?case using singleton by (auto intro: degenerate)
   next
     case (insert x B p)
     from insert.hyps have "x \<in> set_pmf p" "set_pmf p - {x} \<noteq> {}" by auto
     from mix_pmf_partition[OF this] obtain a q
       where decomp: "a \<in> {0<..<1}" "set_pmf q = set_pmf p - {x}" 
         "p = mix_pmf a q (return_pmf x)" by blast
     have "P (mix_pmf a q (return_pmf x))"
       using insert.prems decomp(1) insert.hyps
       by (intro mix insert) (auto simp: decomp(2))
     with decomp(3) show ?case by simp
   qed
 qed
 
 lemma pmf_mix_induct' [consumes 2, case_names degenerate mix]:
   assumes "finite A" "set_pmf p \<subseteq> A"
   assumes degenerate: "\<And>x. x \<in> A \<Longrightarrow> P (return_pmf x)"
   assumes mix:        "\<And>p q a. set_pmf p \<subseteq> A \<Longrightarrow> set_pmf q \<subseteq> A \<Longrightarrow> a \<in> {0<..<1} \<Longrightarrow> 
                          P p \<Longrightarrow> P q \<Longrightarrow> P (mix_pmf a p q)"
   shows "P p"
   using assms by (induct p rule: pmf_mix_induct)(auto)+
 
 lemma finite_sum_distribute_mix_pmf:
   assumes "finite (set_pmf (mix_pmf a p q))"
   assumes "finite (set_pmf p)"
   assumes "finite (set_pmf q)"
   shows "(\<Sum>i \<in> set_pmf (mix_pmf a p q). pmf (mix_pmf a p q) i) = (\<Sum>i\<in>set_pmf p.  a * pmf p i) + (\<Sum>i\<in>set_pmf q. (1-a) * pmf q i)"
 proof -
   have fst: "(\<Sum>i \<in> set_pmf (mix_pmf a p q). pmf (mix_pmf a p q) i) = 1"
     using sum_pmf_eq_1 assms by auto
   have "(\<Sum>i\<in>set_pmf p.  a * pmf p i) = a * (\<Sum>i\<in>set_pmf p. pmf p i)"
     by (simp add: sum_distrib_left)
   also have "... = a * 1"
     using assms sum_pmf_eq_1 by (simp add: sum_pmf_eq_1)
   then show ?thesis 
     by (metis fst add.assoc add_diff_cancel_left' add_uminus_conv_diff assms(3) 
         mult.right_neutral order_refl sum_distrib_left sum_pmf_eq_1)
 qed
 
 lemma distribute_alpha_over_sum:
   shows "(\<Sum>i\<in>set_pmf T. a * pmf p i * f i) = a * (\<Sum>i\<in>set_pmf T. pmf p i * f i)"
   by (metis (mono_tags, lifting) semiring_normalization_rules(18) sum.cong sum_distrib_left)
 
 lemma sum_over_subset_pmf_support:
   assumes "finite T"
   assumes "set_pmf p \<subseteq> T"
   shows "(\<Sum>i\<in>T. a * pmf p i * f i) = (\<Sum>i\<in>set_pmf p. a * pmf p i * f i)"
 proof -
   consider (eq) "set_pmf p = T" | (sub) "set_pmf p \<subset> T"
     using assms by blast
   then show ?thesis
   proof (cases)
   next
     case sub
     define A where "A = T - (set_pmf p)"
     have "finite (set_pmf p)" 
       using assms(1) assms(2) finite_subset by auto
     moreover have "finite A"
       using A_def assms(1) by blast
     moreover have "A \<inter> set_pmf p = {}"
       using A_def assms(1) by blast
     ultimately have *: "(\<Sum>i\<in>T. a * pmf p i * f i) = (\<Sum>i\<in>set_pmf p. a * pmf p i * f i) + (\<Sum>i\<in>A. a * pmf p i * f i)"
       using sum.union_disjoint by (metis (no_types) A_def Un_Diff_cancel2 
           Un_absorb2 assms(2) inf.commute inf_sup_aci(5) sum.union_disjoint)
     have "\<forall>e \<in> A. pmf p e = 0"
       by (simp add: A_def pmf_eq_0_set_pmf)
     hence "(\<Sum>i\<in>A. a * pmf p i * f i) = 0"
       by simp
     then show ?thesis
       by (simp add: "*")
   qed (auto)
 qed
 
 lemma expected_value_mix_pmf_distrib:
   assumes "finite (set_pmf p)"
     and "finite (set_pmf q)"
   assumes "a \<in> {0<..<1}"
   shows "measure_pmf.expectation (mix_pmf a p q) f = a * measure_pmf.expectation p f + (1-a) * measure_pmf.expectation q f"
 proof -
   have fn: "finite (set_pmf (mix_pmf a p q))"
     using mix_pmf_preserves_finite_support assms less_eq_real_def  by auto
   have subsets: "set_pmf p \<subseteq> set_pmf (mix_pmf a p q)" "set_pmf q \<subseteq> set_pmf (mix_pmf a p q)" 
     using assms assms set_pmf_mix by(fastforce)+
   have *: "(\<Sum>i \<in> set_pmf (mix_pmf a p q). a * pmf p i * f i) = a * (\<Sum>i \<in> set_pmf (mix_pmf a p q). pmf p i * f i)"
     by (metis (mono_tags, lifting) mult.assoc sum.cong sum_distrib_left)
   have **: "(\<Sum>i \<in> set_pmf (mix_pmf a p q). (1-a) * pmf q i * f i) = (1-a) * (\<Sum>i \<in> set_pmf (mix_pmf a p q). pmf q i * f i)"
     using distribute_alpha_over_sum[of "(1 - a)" q f "(mix_pmf a p q)"] by auto
   have ***: "measure_pmf.expectation (mix_pmf a p q) f = (\<Sum>i \<in> set_pmf (mix_pmf a p q). pmf (mix_pmf a p q) i * f i)"
     by (metis fn pmf_integral_code_unfold pmf_integral_pmf_set_integral
         pmf_set_integral_code_alt_finite)
   also have g: "... = (\<Sum>i \<in> set_pmf (mix_pmf a p q). (a * pmf p i + (1-a) * pmf q i) * f i)"
     using pmf_mix[of a p q] assms(3) by auto
   also have ****: "... =  (\<Sum>i \<in> set_pmf (mix_pmf a p q). a * pmf p i * f i + (1-a) * pmf q i * f i)"
     by (simp add: mult.commute ring_class.ring_distribs(1))
   also have f: "... = (\<Sum>i \<in> set_pmf (mix_pmf a p q). a * pmf p i * f i) + (\<Sum>i \<in> set_pmf (mix_pmf a p q). (1-a) * pmf q i * f i)"
     by (simp add: sum.distrib)
   also have "... = a * (\<Sum>i \<in> set_pmf (mix_pmf a p q). pmf p i * f i) + (1-a) * (\<Sum>i \<in> set_pmf (mix_pmf a p q). pmf q i * f i)"
     using * ** by simp
   also have h: "... =  a * (\<Sum>i \<in> set_pmf p. pmf p i * f i) + (1-a) * (\<Sum>i \<in> set_pmf q. pmf q i * f i)"
   proof -
     have "(\<Sum>i \<in> set_pmf (mix_pmf a p q). pmf p i * f i) = (\<Sum>i \<in> set_pmf p. pmf p i * f i)"
       using subsets sum_over_subset_pmf_support[of "(mix_pmf a p q)" p 1 f] fn by auto
     moreover have "(\<Sum>i \<in> set_pmf (mix_pmf a p q). pmf q i * f i) = (\<Sum>i \<in> set_pmf q. pmf q i * f i)"
       using subsets sum_over_subset_pmf_support[of "(mix_pmf a p q)" q 1 f] fn by auto
     ultimately show ?thesis
       by (simp)
   qed
   finally show ?thesis 
   proof -
     have "(\<Sum>i\<in>set_pmf q. pmf q i * f i) = measure_pmf.expectation q f"
       by (metis (full_types) assms(2) pmf_integral_code_unfold pmf_integral_pmf_set_integral pmf_set_integral_code_alt_finite)
     moreover have "(\<Sum>i\<in>set_pmf p. pmf p i * f i) = measure_pmf.expectation p f"
       by (metis (full_types) assms(1) pmf_integral_code_unfold pmf_integral_pmf_set_integral pmf_set_integral_code_alt_finite)
     ultimately show ?thesis
       by (simp add: "*" "**" "***" "****" f g h)
   qed
 qed
 
 lemma expected_value_mix_pmf:
   assumes "finite (set_pmf p)"
     and "finite (set_pmf q)"
   assumes "a \<in> {0..1}"
   shows "measure_pmf.expectation (mix_pmf a p q) f = a * measure_pmf.expectation p f + (1-a) * measure_pmf.expectation q f"
 proof -
   consider (0) "a = 0" | (b) "a \<in> {0<..<1}" | (1) "a = 1"
     using assms(3) less_eq_real_def by auto
   then show ?thesis
   proof (cases)
     case 0
     have "(mix_pmf a p q) = q"
       using 0 pmf_mix_0 by blast
     have "measure_pmf.expectation q f = (1-a) * measure_pmf.expectation q f"
       by (simp add: 0)
     show ?thesis
       using 0 by auto
   next
     case b
     show ?thesis
       using assms(1) assms(2) b expected_value_mix_pmf_distrib by blast
   next
     case 1
     have "(mix_pmf a p q) = p"
       using 1 pmf_mix_0 by simp
     then show ?thesis
       by (simp add: "1")
   qed
 qed
 
 end
diff --git a/thys/Ordinary_Differential_Equations/IVP/Cones.thy b/thys/Ordinary_Differential_Equations/IVP/Cones.thy
--- a/thys/Ordinary_Differential_Equations/IVP/Cones.thy
+++ b/thys/Ordinary_Differential_Equations/IVP/Cones.thy
@@ -1,694 +1,694 @@
 theory Cones
 imports
   "HOL-Analysis.Analysis"
   Triangle.Triangle
   "../ODE_Auxiliarities"
 begin
 
 lemma arcsin_eq_zero_iff[simp]: "-1 \<le> x \<Longrightarrow> x \<le> 1 \<Longrightarrow> arcsin x = 0 \<longleftrightarrow> x = 0"
   using sin_arcsin by fastforce
 
 definition conemem :: "'a::real_vector \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> 'a" where "conemem u v t = cos t *\<^sub>R u + sin t *\<^sub>R v"
 definition "conesegment u v = conemem u v ` {0.. pi / 2}"
 
 lemma
   bounded_linear_image_conemem:
   assumes "bounded_linear F"
   shows "F (conemem u v t) = conemem (F u) (F v) t"
 proof -
   from assms interpret bounded_linear F .
   show ?thesis
     by (auto simp: conemem_def[abs_def] cone_hull_expl closed_segment_def add scaleR)
 qed
 
 lemma
   bounded_linear_image_conesegment:
   assumes "bounded_linear F"
   shows "F ` conesegment u v = conesegment (F u) (F v)"
 proof -
   from assms interpret bounded_linear F .
   show ?thesis
     apply (auto simp: conesegment_def conemem_def[abs_def] cone_hull_expl closed_segment_def add scaleR)
     apply (auto simp: add[symmetric] scaleR[symmetric])
     done
 qed
 
 (* This is vangle in $AFP/Triangles/Angles *)
 
 lemma discriminant: "a * x\<^sup>2 + b * x + c = (0::real) \<Longrightarrow> 0 \<le> b\<^sup>2 - 4 * a * c" 
   by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [2*a*x + b]^2))))")
 
 lemma quadratic_eq_factoring:
   assumes D: "D = b\<^sup>2 - 4 * a * c"
   assumes nn: "0 \<le> D"
   assumes x1: "x\<^sub>1 = (-b + sqrt D) / (2 * a)"
   assumes x2: "x\<^sub>2 = (-b - sqrt D) / (2 * a)"
   assumes a: "a \<noteq> 0"
   shows "a * x\<^sup>2 + b * x + c = a * (x - x\<^sub>1) * (x - x\<^sub>2)"
   using nn
   by (simp add: D x1 x2)
     (simp add: assms algebra_simps power2_eq_square power3_eq_cube divide_simps)
 
 lemma quadratic_eq_zeroes_iff:
   assumes D: "D = b\<^sup>2 - 4 * a * c"
   assumes x1: "x\<^sub>1 = (-b + sqrt D) / (2 * a)"
   assumes x2: "x\<^sub>2 = (-b - sqrt D) / (2 * a)"
   assumes a: "a \<noteq> 0"
   shows "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow> (D \<ge> 0 \<and> (x = x\<^sub>1 \<or> x = x\<^sub>2))" (is "?z \<longleftrightarrow> _")
   using quadratic_eq_factoring[OF D _ x1 x2 a, of x] discriminant[of a x b c] a
   by (auto simp: D)
 
 lemma quadratic_ex_zero_iff:
   "(\<exists>x. a * x\<^sup>2 + b * x + c = 0) \<longleftrightarrow> (a \<noteq> 0 \<and> b\<^sup>2 - 4 * a * c \<ge> 0 \<or> a = 0 \<and> (b = 0 \<longrightarrow> c = 0))"
   for a b c::real
   apply (cases "a = 0")
   subgoal by (auto simp: intro: exI[where x="- c / b"])
   subgoal by (subst quadratic_eq_zeroes_iff[OF refl refl refl]) auto
   done
 
 lemma Cauchy_Schwarz_eq_iff:
   shows "(inner x y)\<^sup>2 = inner x x * inner y y \<longleftrightarrow> ((\<exists>k. x = k *\<^sub>R y) \<or> y = 0)"
 proof safe
   assume eq: "(x \<bullet> y)\<^sup>2 = x \<bullet> x * (y \<bullet> y)" and "y \<noteq> 0"
   define f where "f \<equiv> \<lambda>l. inner (x - l *\<^sub>R y) (x - l *\<^sub>R y)"
   have f_quadratic: "f l = inner y y * l\<^sup>2 + - 2 * inner x y * l + inner x x" for l
     by (auto simp: f_def algebra_simps power2_eq_square inner_commute)
   have "\<exists>l. f l = 0"
     unfolding f_quadratic quadratic_ex_zero_iff
     using \<open>y \<noteq> 0\<close>
     by (auto simp: eq)
   then show "(\<exists>k. x = k *\<^sub>R y)"
     by (auto simp: f_def)
 qed (auto simp: power2_eq_square)
 
 lemma Cauchy_Schwarz_strict_ineq:
   "(inner x y)\<^sup>2 < inner x x * inner y y" if "y \<noteq> 0" "\<And>k. x \<noteq> k *\<^sub>R y"
   apply (rule neq_le_trans)
   subgoal
     using that
     unfolding Cauchy_Schwarz_eq_iff
     by auto
   subgoal by (rule Cauchy_Schwarz_ineq)
   done
 
 lemma Cauchy_Schwarz_eq2_iff:
   "\<bar>inner x y\<bar> = norm x * norm y \<longleftrightarrow> ((\<exists>k. x = k *\<^sub>R y) \<or> y = 0)"
   using Cauchy_Schwarz_eq_iff[of x y]
   by (subst power_eq_iff_eq_base[symmetric, where n = 2])
      (simp_all add: dot_square_norm power_mult_distrib)
 
 lemma Cauchy_Schwarz_strict_ineq2:
   "\<bar>inner x y\<bar> < norm x * norm y" if "y \<noteq> 0" "\<And>k. x \<noteq> k *\<^sub>R y"
   apply (rule neq_le_trans)
   subgoal
     using that
     unfolding Cauchy_Schwarz_eq2_iff
     by auto
   subgoal by (rule Cauchy_Schwarz_ineq2)
   done
 
 lemma gt_minus_one_absI: "abs k < 1 \<Longrightarrow> - 1 < k" for k::real
   by auto
 lemma gt_one_absI: "abs k < 1 \<Longrightarrow> k < 1" for k::real
   by auto
 
 lemma abs_impossible:
   "\<bar>y1\<bar> < x1 \<Longrightarrow> \<bar>y2\<bar> < x2 \<Longrightarrow> x1 * x2 + y1 * y2 \<noteq> 0" for x1 x2::real
 proof goal_cases
   case 1
   have "- y1 * y2 \<le> abs y1 * abs y2"
     by (metis abs_ge_minus_self abs_mult mult.commute mult_minus_right)
   also have "\<dots> < x1 * x2"
     apply (rule mult_strict_mono)
     using 1 by auto
   finally show ?case by auto
 qed
 
 lemma vangle_eq_arctan_minus:\<comment> \<open>TODO: generalize?!\<close>
   assumes ij: "i \<in> Basis" "j \<in> Basis" and ij_neq: "i \<noteq> j"
   assumes xy1: "\<bar>y1\<bar> < x1"
   assumes xy2: "\<bar>y2\<bar> < x2"
   assumes less: "y2 / x2 > y1 / x1"
   shows "vangle (x1 *\<^sub>R i + y1 *\<^sub>R j) (x2 *\<^sub>R i + y2 *\<^sub>R j) = arctan (y2 / x2) - arctan (y1 / x1)"
     (is "vangle ?u ?v = _")
 proof -
   from assms have less2: "x2 * y1 - x1 * y2 < 0"
     by (auto simp: divide_simps abs_real_def algebra_simps split: if_splits)
   have norm_eucl: "norm (x *\<^sub>R i + y *\<^sub>R j) = sqrt ((norm x)\<^sup>2 + (norm y)\<^sup>2)" for x y
     apply (subst norm_eq_sqrt_inner)
     using ij ij_neq
     by (auto simp: inner_simps inner_Basis power2_eq_square)
   have nonzeroes: "x1 *\<^sub>R i + y1 *\<^sub>R j \<noteq> 0" "x2 *\<^sub>R i + y2 *\<^sub>R j \<noteq> 0"
      apply (auto simp: euclidean_eq_iff[where 'a='a] inner_simps intro!: bexI[where x=i])
     using assms
     by (auto simp: inner_Basis)
   have indep: "x1 *\<^sub>R i + y1 *\<^sub>R j \<noteq> k *\<^sub>R (x2 *\<^sub>R i + y2 *\<^sub>R j)" for k
   proof
     assume "x1 *\<^sub>R i + y1 *\<^sub>R j = k *\<^sub>R (x2 *\<^sub>R i + y2 *\<^sub>R j)"
     then have "x1 / x2 = k" "y1 = k * y2"
       using ij ij_neq xy1 xy2
        apply (auto simp: abs_real_def divide_simps algebra_simps euclidean_eq_iff[where 'a='a] inner_simps
           split: if_splits)
       by (auto simp: inner_Basis split: if_splits)
     then have "y1 = x1 / x2 * y2" by simp
     with less show False using xy1 by (auto split: if_splits)
   qed
   have "((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2) *
           (1 - ((x1 *\<^sub>R i + y1 *\<^sub>R j) \<bullet> (x2 *\<^sub>R i + y2 *\<^sub>R j))\<^sup>2 / ((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2)))) =
     ((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2) *
           (1 - (x1 * x2 + y1 * y2)\<^sup>2 / ((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2))))"
     using ij_neq ij
     by (auto simp: algebra_simps divide_simps inner_simps inner_Basis)
   also have "\<dots> = (x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2) - (x1 * x2 + y1 * y2)\<^sup>2"
     unfolding right_diff_distrib by simp
   also have "\<dots> = (x2 * y1 - x1 * y2)^2"
     by (auto simp: algebra_simps power2_eq_square)
   also have "sqrt \<dots> = \<bar>x2 * y1 - x1 * y2\<bar>"
     by simp
   also have "\<dots> = x1 * y2 - x2 * y1"
     using less2
     by (simp add: abs_real_def)
   finally have sqrt_eq: "sqrt ((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2) *
         (1 - ((x1 *\<^sub>R i + y1 *\<^sub>R j) \<bullet> (x2 *\<^sub>R i + y2 *\<^sub>R j))\<^sup>2 / ((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2)))) =
     x1 * y2 - x2 * y1"
     .
   show ?thesis
     using ij xy1 xy2
     unfolding vangle_def
     apply (subst arccos_arctan)
     subgoal
       apply (rule gt_minus_one_absI)
       apply (simp add: )
       apply (subst pos_divide_less_eq)
       subgoal
         apply (rule mult_pos_pos)
         using nonzeroes
         by auto
       subgoal
         apply simp
         apply (rule Cauchy_Schwarz_strict_ineq2)
         using nonzeroes indep
         by auto
       done
     subgoal
       apply (rule gt_one_absI)
       apply (simp add: )
       apply (subst pos_divide_less_eq)
       subgoal
         apply (rule mult_pos_pos)
         using nonzeroes
         by auto
       subgoal
         apply simp
         apply (rule Cauchy_Schwarz_strict_ineq2)
         using nonzeroes indep
         by auto
       done
     subgoal
       apply (auto simp: nonzeroes)
       apply (subst (3) diff_conv_add_uminus)
       apply (subst arctan_minus[symmetric])
       apply (subst arctan_add)
         apply force
        apply force
       apply (subst arctan_inverse[symmetric])
       subgoal
         apply (rule divide_pos_pos)
         subgoal
           apply (auto simp add: inner_simps inner_Basis algebra_simps )
            apply (thin_tac "_ \<in> Basis")+ apply (thin_tac "j = i")
            apply (sos "((((A<0 * (A<1 * (A<2 * A<3))) * R<1) + ((A<=0 * (A<0 * (A<2 * R<1))) * (R<1 * [1]^2))))")
           apply (thin_tac "_ \<in> Basis")+ apply (thin_tac "j \<noteq> i")
           by (sos "((((A<0 * (A<1 * (A<2 * A<3))) * R<1) + (((A<2 * (A<3 * R<1)) * (R<1/3 * [y1]^2)) + (((A<1 * (A<3 * R<1)) * ((R<1/12 * [x2 + y1]^2) + (R<1/12 * [x1 + y2]^2))) + (((A<1 * (A<2 * R<1)) * (R<1/12 * [~1*x1 + x2 + y1 + y2]^2)) + (((A<0 * (A<3 * R<1)) * (R<1/12 * [~1*x1 + x2 + ~1*y1 + ~1*y2]^2)) + (((A<0 * (A<2 * R<1)) * ((R<1/12 * [x2 + ~1*y1]^2) + (R<1/12 * [~1*x1 + y2]^2))) + (((A<0 * (A<1 * R<1)) * (R<1/3 * [y2]^2)) + ((A<=0 * R<1) * (R<1/3 * [x1 + x2]^2))))))))))")
         subgoal
           apply (intro mult_pos_pos)
           using nonzeroes indep
             apply auto
           apply (rule gt_one_absI)
           apply (simp add: power_divide power_mult_distrib power2_norm_eq_inner)
           apply (rule Cauchy_Schwarz_strict_ineq)
            apply auto
           done
         done
       subgoal
         apply (rule arg_cong[where f=arctan])
         using nonzeroes ij_neq
         apply (auto simp: norm_eucl)
         apply (subst real_sqrt_mult[symmetric])
         apply (subst real_sqrt_mult[symmetric])
         apply (subst real_sqrt_mult[symmetric])
         apply (subst power_divide)
         apply (subst real_sqrt_pow2)
          apply simp
         apply (subst nonzero_divide_eq_eq)
         subgoal
           apply (auto simp: algebra_simps inner_simps inner_Basis)
           by (auto simp: algebra_simps divide_simps abs_real_def abs_impossible)
         apply (subst sqrt_eq)
         apply (auto simp: algebra_simps inner_simps inner_Basis)
         apply (auto simp: algebra_simps divide_simps abs_real_def abs_impossible)
         by (auto split: if_splits)
       done
     done
 qed
 
 lemma vangle_le_pi2: "0 \<le> u \<bullet> v \<Longrightarrow> vangle u v \<le> pi/2"
   unfolding vangle_def atLeastAtMost_iff
   apply (simp del: le_divide_eq_numeral1)
   apply (intro impI arccos_le_pi2 arccos_lbound)
   using Cauchy_Schwarz_ineq2[of u v]
-  by (auto simp: divide_simps sign_simps)
+  by (auto simp: algebra_simps)
 
 lemma inner_eq_vangle: "u \<bullet> v = cos (vangle u v) * (norm u * norm v)"
   by (simp add: cos_vangle)
 
 lemma vangle_scaleR_self:
   "vangle (k *\<^sub>R v) v = (if k = 0 \<or> v = 0 then pi / 2 else if k > 0 then 0 else pi)"
   "vangle v (k *\<^sub>R v) = (if k = 0 \<or> v = 0 then pi / 2 else if k > 0 then 0 else pi)"
   by (auto simp: vangle_def dot_square_norm power2_eq_square)
 
 lemma vangle_scaleR:
   "vangle (k *\<^sub>R v) w = vangle v w" "vangle w (k *\<^sub>R v) = vangle w v" if "k > 0"
   using that
   by (auto simp: vangle_def)
 
 lemma cos_vangle_eq_zero_iff_vangle:
   "cos (vangle u v) = 0 \<longleftrightarrow> (u = 0 \<or> v = 0 \<or> u \<bullet> v = 0)"
   using Cauchy_Schwarz_ineq2[of u v]
   by (auto simp: vangle_def divide_simps sign_simps split: if_splits)
 
 lemma ortho_imp_angle_pi_half: "u \<bullet> v = 0 \<Longrightarrow> vangle u v = pi / 2"
   using orthogonal_iff_vangle[of u v]
   by (auto simp: orthogonal_def)
 
 lemma arccos_eq_zero_iff: "arccos x = 0 \<longleftrightarrow> x = 1" if "-1 \<le> x" "x \<le> 1"
   using that
   apply auto
   using cos_arccos by fastforce
 
 
 lemma vangle_eq_zeroD: "vangle u v = 0 \<Longrightarrow> (\<exists>k. v = k *\<^sub>R u)"
   apply (auto simp: vangle_def split: if_splits)
    apply (subst (asm) arccos_eq_zero_iff)
   apply (auto simp: divide_simps mult_less_0_iff split: if_splits)
   apply (metis Real_Vector_Spaces.norm_minus_cancel inner_minus_left minus_le_iff norm_cauchy_schwarz)
     apply (metis norm_cauchy_schwarz)
   by (metis Cauchy_Schwarz_eq2_iff abs_of_pos inner_commute mult.commute mult_sign_intros(5) zero_less_norm_iff)
 
 lemma less_one_multI:\<comment> \<open>TODO: also in AA!\<close>
   fixes e x::real
   shows "e \<le> 1 \<Longrightarrow> 0 < x \<Longrightarrow> x < 1 \<Longrightarrow> e * x < 1"
   by (metis (erased, hide_lams) less_eq_real_def monoid_mult_class.mult.left_neutral
     mult_strict_mono zero_less_one)
 
 lemma conemem_expansion_estimate:
   fixes u v u' v'::"'a::euclidean_space"
   assumes "t \<in> {0 .. pi / 2}"
   assumes angle_pos: "0 < vangle u v" "vangle u v < pi / 2"
   assumes angle_le: "(vangle u' v') \<le> (vangle u v)"
   assumes "norm u = 1" "norm v = 1"
   shows "norm (conemem u' v' t) \<ge> min (norm u') (norm v') * norm (conemem u v t)"
 proof -
   define e_pre where "e_pre = min (norm u') (norm v')"
   let ?w = "conemem u v"
   let ?w' = "conemem u' v'"
   have cos_angle_le: "cos (vangle u' v') \<ge> cos (vangle u v)"
     using angle_pos vangle_bounds
     by (auto intro!: cos_monotone_0_pi_le angle_le)
   have e_pre_le: "e_pre\<^sup>2 \<le> norm u' * norm v'"
     by (auto simp: e_pre_def min_def power2_eq_square intro: mult_left_mono mult_right_mono)
   have lt: "0 < 1 + 2 * (u \<bullet> v) * sin t * cos t"
   proof -
     have "\<bar>u \<bullet> v\<bar> < norm u * norm v"
       apply (rule Cauchy_Schwarz_strict_ineq2)
       using assms
        apply auto
       apply (subst (asm) vangle_scaleR_self)+
       by (auto simp: split: if_splits)
     then have "abs (u \<bullet> v * sin (2 * t)) < 1"
       using assms
       apply (auto simp add: abs_mult)
       apply (subst mult.commute)
       apply (rule less_one_multI)
       apply (auto simp add: abs_mult inner_eq_vangle )
       by (auto simp: cos_vangle_eq_zero_iff_vangle dest!: ortho_imp_angle_pi_half)
     then show ?thesis
       by (subst mult.assoc sin_times_cos)+ auto
   qed
   have le: "0 \<le> 1 + 2 * (u \<bullet> v) * sin t * cos t"
   proof -
     have "\<bar>u \<bullet> v\<bar> \<le> norm u * norm v"
       by (rule Cauchy_Schwarz_ineq2)
     then have "abs (u \<bullet> v * sin (2 * t)) \<le> 1"
       by (auto simp add: abs_mult assms intro!: mult_le_one)
     then show ?thesis
       by (subst mult.assoc sin_times_cos)+ auto
   qed
   have "(norm (?w t))\<^sup>2 = (cos t)\<^sup>2 *\<^sub>R (norm u)\<^sup>2 + (sin t)\<^sup>2 *\<^sub>R (norm v)\<^sup>2 + 2 * (u \<bullet> v) * sin t * cos t"
     by (auto simp: conemem_def algebra_simps power2_norm_eq_inner)
       (auto simp: power2_eq_square inner_commute)
   also have "\<dots> = 1 + 2 * (u \<bullet> v) * sin t * cos t"
     by (auto simp: sin_squared_eq algebra_simps assms)
   finally have "(norm (conemem u v t))\<^sup>2 = 1 + 2 * (u \<bullet> v) * sin t * cos t" by simp
   moreover
   have "(norm (?w' t))\<^sup>2 = (cos t)\<^sup>2 *\<^sub>R (norm u')\<^sup>2 + (sin t)\<^sup>2 *\<^sub>R (norm v')\<^sup>2 + 2 * (u' \<bullet> v') * sin t * cos t"
     by (auto simp: conemem_def algebra_simps power2_norm_eq_inner)
       (auto simp: power2_eq_square inner_commute)
   ultimately
   have "(norm (?w' t) / norm (?w t))\<^sup>2 =
     ((cos t)\<^sup>2 *\<^sub>R (norm u')\<^sup>2 + (sin t)\<^sup>2 *\<^sub>R (norm v')\<^sup>2 + 2 * (u' \<bullet> v') * sin t * cos t) /
     (1 + 2 * (u \<bullet> v) * sin t * cos t)"
     (is "_ = (?a + ?b) / ?c")
     by (auto simp: divide_inverse power_mult_distrib) (auto simp: inverse_eq_divide power2_eq_square)
   also have "\<dots> \<ge> (e_pre\<^sup>2 + ?b) / ?c"
     apply (rule divide_right_mono)
      apply (rule add_right_mono)
     subgoal using assms e_pre_def
       apply (auto simp: min_def)
       subgoal by (auto simp: algebra_simps cos_squared_eq intro!: mult_right_mono power_mono)
       subgoal by (auto simp: algebra_simps sin_squared_eq intro!: mult_right_mono power_mono)
       done
     subgoal by (rule le)
     done
   also (xtrans)
   have inner_nonneg: "u' \<bullet> v' \<ge> 0"
     using angle_le(1) angle_pos vangle_bounds[of u' v']
     by (auto simp: inner_eq_vangle intro!: mult_nonneg_nonneg cos_ge_zero)
   from vangle_bounds[of u' v'] vangle_le_pi2[OF this]
   have u'v'e_pre: "u' \<bullet> v' \<ge> cos (vangle u' v') * e_pre\<^sup>2"
     apply (subst inner_eq_vangle)
     apply (rule mult_left_mono)
      apply (rule e_pre_le)
     apply (rule cos_ge_zero)
     by auto
   have "(e_pre\<^sup>2 + ?b) / ?c \<ge> (e_pre\<^sup>2 + 2 * (cos (vangle u' v') * e_pre\<^sup>2) * sin t * cos t) / ?c"
     (is "_ \<ge> ?ddd")
     apply (intro divide_right_mono add_left_mono mult_right_mono mult_left_mono u'v'e_pre)
     using \<open>t \<in> _\<close>
     by (auto intro!: mult_right_mono sin_ge_zero divide_right_mono le cos_ge_zero
         simp: sin_times_cos u'v'e_pre)
   also (xtrans) have "?ddd = e_pre\<^sup>2 * ((1 + 2 * cos (vangle u' v') * sin t * cos t) / ?c)" (is "_ = ?ddd")
     by (auto simp add: divide_simps algebra_simps)
   also (xtrans)
   have sc_ge_0: "0 \<le> sin t * cos t"
     using \<open>t \<in> _\<close>
     by (auto simp: assms cos_angle_le intro!: mult_nonneg_nonneg sin_ge_zero cos_ge_zero)
   have "?ddd \<ge> e_pre\<^sup>2"
     apply (subst mult_le_cancel_left1)
     apply (auto simp add: divide_simps split: if_splits)
       apply (rule mult_right_mono)
     using lt
     by (auto simp: assms inner_eq_vangle intro!: mult_right_mono sc_ge_0 cos_angle_le)
   finally (xtrans)
   have "(norm (conemem u' v' t))\<^sup>2 \<ge> (e_pre * norm (conemem u v t))\<^sup>2"
     by (simp add: divide_simps power_mult_distrib split: if_splits)
   then show "norm (conemem u' v' t) \<ge> e_pre * norm (conemem u v t)"
     using norm_imp_pos_and_ge power2_le_imp_le by blast
 qed
 
 lemma conemem_commute: "conemem a b t = conemem b a (pi / 2 - t)" if "0 \<le> t" "t \<le> pi / 2"
   using that by (auto simp: conemem_def cos_sin_eq algebra_simps)
 
 lemma conesegment_commute: "conesegment a b = conesegment b a"
   apply (auto simp: conesegment_def )
    apply (subst conemem_commute)
   apply auto
    apply (subst conemem_commute)
     apply auto
   done
 
 
 definition "conefield u v = cone hull (conesegment u v)"
 
 lemma conefield_alt_def: "conefield u v = cone hull {u--v}"
   apply (auto simp: conesegment_def conefield_def cone_hull_expl in_segment)
   subgoal premises prems for c t
   proof -
     from prems
     have sc_pos: "sin t + cos t > 0"
       apply (cases "t = 0")
       subgoal
         by (rule add_nonneg_pos) auto
       subgoal
          by (auto intro!: add_pos_nonneg sin_gt_zero cos_ge_zero)
        done
     then have 1: "(sin t / (sin t + cos t) + cos t / (sin t + cos t)) = 1"
       by (auto simp: divide_simps)
     have "\<exists>c x. c > 0 \<and> 0 \<le> x \<and> x \<le> 1 \<and> c *\<^sub>R conemem u v t = (1 - x) *\<^sub>R u + x *\<^sub>R v"
       apply (auto simp: algebra_simps conemem_def)
       apply (rule exI[where x="1 / (sin t + cos t)"])
       using prems
       by (auto intro!: exI[where x="(1 / (sin t + cos t) * sin t)"] sc_pos
           divide_nonneg_nonneg sin_ge_zero add_nonneg_nonneg cos_ge_zero
           simp: scaleR_add_left[symmetric] 1 divide_le_eq_1)
     then obtain d x where dx: "d > 0" "conemem u v t = (1 / d) *\<^sub>R ((1 - x) *\<^sub>R u + x *\<^sub>R v)"
         "0 \<le> x" "x \<le> 1"
       by (auto simp: eq_vector_fraction_iff)
     show ?thesis
       apply (rule exI[where x="c / d"])
       using dx
       by (auto simp: intro!: divide_nonneg_nonneg prems )
   qed
   subgoal premises prems for c t
   proof -
     let ?x = "arctan (t / (1 - t))"
     let ?s = "t / sin ?x"
     have *: "c *\<^sub>R ((1 - t) *\<^sub>R u + t *\<^sub>R v) = (c * ?s) *\<^sub>R (cos ?x *\<^sub>R u + sin ?x *\<^sub>R v)"
       if "0 < t" "t < 1"
       using that
       by (auto simp: scaleR_add_right sin_arctan cos_arctan divide_simps)
     show ?thesis
       apply (cases "t = 0")
       subgoal
         apply simp
         apply (rule exI[where x=c])
         apply (rule exI[where x=u])
         using prems
         by (auto simp: conemem_def[abs_def] intro!: image_eqI[where x=0])
       subgoal apply (cases "t = 1")
         subgoal
           apply simp
           apply (rule exI[where x=c])
           apply (rule exI[where x=v])
           using prems
           by (auto simp: conemem_def[abs_def] intro!: image_eqI[where x="pi/2"])
         subgoal
           apply (rule exI[where x="(c * ?s)"])
           apply (rule exI[where x="(cos ?x *\<^sub>R u + sin ?x *\<^sub>R v)"])
           using prems * arctan_ubound[of "t / (1 - t)"] 
           apply (auto simp: conemem_def[abs_def]  intro!: imageI)
           by (auto simp: scaleR_add_right sin_arctan)
         done
       done
   qed
   done
 
 lemma
   bounded_linear_image_cone_hull:
   assumes "bounded_linear F"
   shows "F ` (cone hull T) = cone hull (F ` T)"
 proof -
   from assms interpret bounded_linear F .
   show ?thesis
     apply (auto simp: conefield_def cone_hull_expl closed_segment_def add scaleR)
      apply (auto simp: )
     apply (auto simp: add[symmetric] scaleR[symmetric])
     done
 qed
 
 lemma
   bounded_linear_image_conefield:
   assumes "bounded_linear F"
   shows "F ` conefield u v = conefield (F u) (F v)"
   unfolding conefield_def
   using assms
   by (auto simp: bounded_linear_image_conesegment bounded_linear_image_cone_hull)
 
 lemma conefield_commute: "conefield x y = conefield y x"
   by (auto simp: conefield_def conesegment_commute)
 
 lemma convex_conefield: "convex (conefield x y)"
   by (auto simp: conefield_alt_def convex_cone_hull)
 
 lemma conefield_scaleRI: "v \<in> conefield (r *\<^sub>R x) y" if "v \<in> conefield x y" "r > 0"
   using that
   using \<open>r > 0\<close>
   unfolding conefield_alt_def cone_hull_expl
   apply (auto simp: in_segment)
 proof goal_cases
   case (1 c u)
   let ?d = "c * (1 - u) / r + c * u"
   let ?t = "c * u / ?d"
   have "c * (1 - u) = ?d * (1 - ?t) * r" if "0 < u"
     using \<open>0 < r\<close> that(1) 1(3,5) mult_pos_pos
     by (force simp: divide_simps ac_simps ring_distribs[symmetric])
   then have eq1: "(c * (1 - u)) *\<^sub>R x = (?d * (1 - ?t) * r) *\<^sub>R x" if "0 < u"
     using that by simp
   have "c * u = ?d * ?t" if "u < 1"
     using \<open>0 < r\<close> that(1) 1(3,4,5) mult_pos_pos
     apply (auto simp: divide_simps ac_simps ring_distribs[symmetric])
   proof -
     assume "0 \<le> u"
       "0 < r"
       "1 - u + r * u = 0"
       "u < 1"
     then have False
       by (sos "((((A<0 * A<1) * R<1) + (([~1*r] * A=0) + ((A<=0 * R<1) * (R<1 * [r]^2)))))")
     then show "u = 0"
       by metis
   qed
   then have eq2: "(c * u) *\<^sub>R y = (?d * ?t) *\<^sub>R y" if "u < 1"
     using that by simp
   have *: "c *\<^sub>R ((1 - u) *\<^sub>R x + u *\<^sub>R y) = ?d *\<^sub>R ((1 - ?t) *\<^sub>R r *\<^sub>R x + ?t *\<^sub>R y)"
     if "0 < u" "u < 1"
     using that eq1 eq2
     by (auto simp: algebra_simps)
   show ?case
     apply (cases "u = 0")
     subgoal using 1 by (intro exI[where x="c / r"] exI[where x="r *\<^sub>R x"]) auto
     apply (cases "u = 1")
     subgoal using 1 by (intro exI[where x="c"] exI[where x="y"]) (auto intro!: exI[where x=1])
     subgoal
       apply (rule exI[where x="?d"])
       apply (rule exI[where x="((1 - ?t) *\<^sub>R r *\<^sub>R x + ?t *\<^sub>R y)"])
       apply (subst *)
       using 1
         apply (auto intro!: exI[where x = ?t])
       apply (auto simp: algebra_simps divide_simps)
       defer
     proof -
       assume a1: "c + c * (r * u) < c * u"
       assume a2: "0 \<le> c"
       assume a3: "0 \<le> u"
       assume a4: "u \<noteq> 0"
       assume a5: "0 < r"
       have "c + c * (r * u) \<le> c * u"
         using a1 less_eq_real_def by blast
       then show "c \<le> c * u"
         using a5 a4 a3 a2 by (metis (no_types) less_add_same_cancel1 less_eq_real_def
             mult_pos_pos order_trans real_scaleR_def real_vector.scale_zero_left)
     next
       assume a1: "0 \<le> c"
       assume a2: "u \<le> 1"
       have f3: "\<forall>x0. ((x0::real) < 1) = (\<not> 1 \<le> x0)"
         by auto
       have f4: "\<forall>x0. ((1::real) < x0) = (\<not> x0 \<le> 1)"
         by fastforce
       have "\<forall>x0 x1. ((x1::real) < x1 * x0) = (\<not> 0 \<le> x1 + - 1 * (x1 * x0))"
         by auto
       then have "(\<forall>r ra. ((r::real) < r * ra) = ((0 \<le> r \<longrightarrow> 1 < ra) \<and> (r \<le> 0 \<longrightarrow> ra < 1))) = (\<forall>r ra. (\<not> (0::real) \<le> r + - 1 * (r * ra)) = ((\<not> 0 \<le> r \<or> \<not> ra \<le> 1) \<and> (\<not> r \<le> 0 \<or> \<not> 1 \<le> ra)))"
         using f4 f3 by presburger
       then have "0 \<le> c + - 1 * (c * u)"
         using a2 a1 mult_less_cancel_left1 by blast
       then show "c * u \<le> c"
         by auto
     qed
     done
 qed
 
 lemma conefield_scaleRD: "v \<in> conefield x y" if "v \<in> conefield (r *\<^sub>R x) y" "r > 0"
   using conefield_scaleRI[OF that(1) positive_imp_inverse_positive[OF that(2)]] that(2)
   by auto
 
 lemma conefield_scaleR: "conefield (r *\<^sub>R x) y = conefield x y" if "r > 0"
   using conefield_scaleRD conefield_scaleRI that
   by blast
 
 lemma conefield_expansion_estimate:
   fixes u v::"'a::euclidean_space" and F::"'a \<Rightarrow> 'a"
   assumes "t \<in> {0 .. pi / 2}"
   assumes angle_pos: "0 < vangle u v" "vangle u v < pi / 2"
   assumes angle_le: "vangle (F u) (F v) \<le> vangle u v"
   assumes "bounded_linear F"
   assumes "x \<in> conefield u v"
   shows "norm (F x) \<ge> min (norm (F u)/norm u) (norm (F v)/norm v) * norm x"
 proof cases
   assume [simp]: "x \<noteq> 0"
   from assms have [simp]: "u \<noteq> 0" "v \<noteq> 0" by auto
   interpret bounded_linear F by fact
   define u1 where "u1 = u /\<^sub>R norm u"
   define v1 where "v1 = v /\<^sub>R norm v"
   note \<open>x \<in> conefield u v\<close>
   also have \<open>conefield u v = conefield u1 v1\<close>
     by (auto simp: u1_def v1_def conefield_scaleR conefield_commute[of u])
   finally obtain c t where x: "x = c *\<^sub>R conemem u1 v1 t" "t \<in> {0 .. pi / 2}" "c \<ge> 0"
     by (auto simp: conefield_def cone_hull_expl conesegment_def)
   then have xc: "x /\<^sub>R c = conemem u1 v1 t"
     by (auto simp: divide_simps)
   also have "F \<dots> = conemem (F u1) (F v1) t"
     by (simp add: bounded_linear_image_conemem assms)
   also have "norm \<dots> \<ge> min (norm (F u1)) (norm (F v1)) * norm (conemem u1 v1 t)"
     apply (rule conemem_expansion_estimate)
     subgoal by fact
     subgoal using angle_pos by (simp add: u1_def v1_def vangle_scaleR)
     subgoal using angle_pos by (simp add: u1_def v1_def vangle_scaleR)
     subgoal using angle_le by (simp add: u1_def v1_def scaleR vangle_scaleR)
     subgoal using angle_le by (simp add: u1_def v1_def scaleR vangle_scaleR)
     subgoal using angle_le by (simp add: u1_def v1_def scaleR vangle_scaleR)
     done
   finally show "norm (F x) \<ge> min (norm (F u)/norm u) (norm (F v)/norm v) * norm x"
     unfolding xc[symmetric] scaleR u1_def v1_def norm_scaleR x
     using \<open>c \<ge> 0\<close>
     by (simp add: divide_simps split: if_splits)
 qed simp
 
 lemma conefield_rightI:
   assumes ij: "i \<in> Basis" "j \<in> Basis" and ij_neq: "i \<noteq> j"
   assumes "y \<in> {y1 .. y2}"
   shows "(i + y *\<^sub>R j) \<in> conefield (i + y1 *\<^sub>R j) (i + y2 *\<^sub>R j)"
   unfolding conefield_alt_def
   apply (rule hull_inc)
   using assms
   by (auto simp: in_segment divide_simps inner_Basis algebra_simps
       intro!: exI[where x="(y - y1) / (y2 - y1)"] euclidean_eqI[where 'a='a] )
 
 lemma conefield_right_vangleI:
   assumes ij: "i \<in> Basis" "j \<in> Basis" and ij_neq: "i \<noteq> j"
   assumes "y \<in> {y1 .. y2}" "y1 < y2"
   shows "(i + y *\<^sub>R j) \<in> conefield (i + y1 *\<^sub>R j) (i + y2 *\<^sub>R j)"
   unfolding conefield_alt_def
   apply (rule hull_inc)
   using assms
   by (auto simp: in_segment divide_simps inner_Basis algebra_simps
       intro!: exI[where x="(y - y1) / (y2 - y1)"] euclidean_eqI[where 'a='a] )
 
 lemma cone_conefield[intro, simp]: "cone (conefield x y)"
   unfolding conefield_def
   by (rule cone_cone_hull)
 
 lemma conefield_mk_rightI:
   assumes ij: "i \<in> Basis" "j \<in> Basis" and ij_neq: "i \<noteq> j"
   assumes "(i + (y / x) *\<^sub>R j) \<in> conefield (i + (y1 / x1) *\<^sub>R j) (i + (y2 / x2) *\<^sub>R j)"
   assumes "x > 0" "x1 > 0" "x2 > 0"
   shows "(x *\<^sub>R i + y *\<^sub>R j) \<in> conefield (x1 *\<^sub>R i + y1 *\<^sub>R j) (x2 *\<^sub>R i + y2 *\<^sub>R j)"
 proof -
   have rescale: "(x *\<^sub>R i + y *\<^sub>R j) = x *\<^sub>R (i + (y / x) *\<^sub>R j)" if "x > 0" for x y
     using that by (auto simp: algebra_simps)
   show ?thesis
     unfolding rescale[OF \<open>x > 0\<close>] rescale[OF \<open>x1 > 0\<close>] rescale[OF \<open>x2 > 0\<close>]
       conefield_scaleR[OF \<open>x1 > 0\<close>]
     apply (subst conefield_commute)
     unfolding conefield_scaleR[OF \<open>x2 > 0\<close>]
     apply (rule mem_cone)
       apply simp
      apply (subst conefield_commute)
     by (auto intro!: assms less_imp_le)
 qed
 
 lemma conefield_prod3I:
   assumes "x > 0" "x1 > 0" "x2 > 0"
   assumes "y1 / x1 \<le> y / x" "y / x \<le> y2 / x2"
   shows "(x, y, 0) \<in> (conefield (x1, y1, 0) (x2, y2, 0)::(real*real*real) set)"
 proof -
   have "(x *\<^sub>R (1, 0, 0) + y *\<^sub>R (0, 1, 0)) \<in>
     (conefield (x1 *\<^sub>R (1, 0, 0) + y1 *\<^sub>R (0, 1, 0)) (x2 *\<^sub>R (1, 0, 0) + y2 *\<^sub>R (0, 1, 0))::(real*real*real) set)"
     apply (rule conefield_mk_rightI)
     subgoal by (auto simp: Basis_prod_def zero_prod_def)
     subgoal by (auto simp: Basis_prod_def zero_prod_def)
     subgoal by (auto simp: Basis_prod_def zero_prod_def)
     subgoal using assms by (intro conefield_rightI) (auto simp: Basis_prod_def zero_prod_def)
     by (auto intro: assms)
   then show ?thesis by simp
 qed
 
 end
diff --git a/thys/Planarity_Certificates/Planarity/Digraph_Map_Impl.thy b/thys/Planarity_Certificates/Planarity/Digraph_Map_Impl.thy
--- a/thys/Planarity_Certificates/Planarity/Digraph_Map_Impl.thy
+++ b/thys/Planarity_Certificates/Planarity/Digraph_Map_Impl.thy
@@ -1,412 +1,412 @@
 theory Digraph_Map_Impl
 imports
   Graph_Genus
   Executable_Permutations
   "Transitive-Closure.Transitive_Closure_Impl"
 begin
 
 section \<open>Enumerating Maps\<close>
 
 definition grouped_by_fst :: "('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list list" where
   "grouped_by_fst xs = map (\<lambda>u. filter (\<lambda>x. fst x = u) xs) (remdups (map fst xs))"
 
 fun grouped_out_arcs :: "'a list \<times> ('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list list" where
   "grouped_out_arcs (vs,as) = grouped_by_fst as"
 
 definition all_maps_list :: "('a list \<times> ('a \<times> 'a) list) \<Rightarrow> ('a \<times> 'a) list list list" where
   "all_maps_list G_list = (cyc_permutationss o grouped_out_arcs) G_list"
 
 definition "list_digraph_ext ext G_list  \<equiv> \<lparr> pverts = set (fst G_list), parcs = set (snd G_list), \<dots> = ext \<rparr>"
 abbreviation "list_digraph \<equiv> list_digraph_ext ()"
 
 code_datatype list_digraph_ext
 
 
 lemma list_digraph_simps:
   "pverts (list_digraph G_list) = set (fst G_list)"
   "parcs (list_digraph G_list) = set (snd G_list)"
   by (auto simp: list_digraph_ext_def)
 
 
 
 lemma union_grouped_by_fst:
   "(\<Union>xs \<in> set (grouped_by_fst ys). set xs) = set ys"
   by (auto simp: grouped_by_fst_def)
 
 lemma union_grouped_out_arcs:
   "(\<Union>xs \<in> set (grouped_out_arcs G_list). set xs) = set (snd G_list)"
   by (cases G_list) (simp add: union_grouped_by_fst)
 
 lemma nil_not_in_grouped_out_arcs: "[] \<notin> set (grouped_out_arcs G_list)"
   apply (cases G_list) apply (auto simp: grouped_by_fst_def )
   by (metis (mono_tags) filter_empty_conv fst_conv)
 
 lemma set_grouped_out_arcs:
   assumes "pair_wf_digraph (list_digraph G_list)"
   shows "set ` set (grouped_out_arcs G_list) = {out_arcs (list_digraph G_list) v | v. v \<in> pverts (list_digraph G_list) \<and> out_arcs (list_digraph G_list) v \<noteq> {} }"
     (is "?L = ?R")
 proof -
   interpret pair_wf_digraph "list_digraph G_list" by fact
   define vs where "vs = remdups (map fst (snd G_list))"
   have "set vs = {v. out_arcs (list_digraph G_list) v \<noteq> {}}"
     by (auto simp: out_arcs_def list_digraph_ext_def vs_def intro: rev_image_eqI )
   then have vs: "set vs = {v \<in> pverts (list_digraph G_list). out_arcs (list_digraph G_list) v \<noteq> {}}"
     by (auto dest: in_arcsD1)
   have goa: "grouped_out_arcs G_list = map (\<lambda>u. filter (\<lambda>x. fst x = u) (snd G_list)) vs"
     by (cases G_list) (auto simp: grouped_by_fst_def vs_def)
   have filter: "set \<circ> (\<lambda>u. filter (\<lambda>x. fst x = u) (snd G_list)) = out_arcs (list_digraph G_list)"
     by (rule ext) (auto simp: list_digraph_ext_def)
     
   have "set (map set (grouped_out_arcs G_list)) = ?R" by (auto simp add: goa filter vs)
   then show ?thesis by simp
 qed
 
 lemma distincts_grouped_by_fst:
   assumes "distinct xs" shows "distincts (grouped_by_fst xs)"
 proof -
   have list_eq_setD: "\<And>xs ys. xs = ys \<Longrightarrow> set xs = set ys" by auto
   have inj: "inj_on (\<lambda>u. filter (\<lambda>x. fst x = u) xs) (fst ` set xs)"
     by (rule inj_onI) (drule list_eq_setD, auto)
   with assms show ?thesis
     by (auto simp: grouped_by_fst_def distincts_def distinct_map filter_empty_conv)
 qed
 
 lemma distincts_grouped_arcs:
   assumes "distinct (snd G_list)" shows "distincts (grouped_out_arcs G_list)"
   using assms by (cases G_list) (simp add: distincts_grouped_by_fst)
 
 lemma distincts_in_all_maps_list:
   "distinct (snd X) \<Longrightarrow> xss \<in> set (all_maps_list X) \<Longrightarrow> distincts xss"
   by (simp add: all_maps_list_def distincts_grouped_arcs in_set_cyc_permutationss)
 
 
 
 definition to_map :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a \<Rightarrow> 'a \<times> 'a) \<Rightarrow> ('a \<times> 'a) pre_map" where
   "to_map A f = \<lparr> edge_rev = swap_in A, edge_succ = f \<rparr>"
 
 abbreviation "to_map' as xss \<equiv> to_map (set as) (lists_succ xss)"
 
 
 definition all_maps :: "'a pair_pre_digraph \<Rightarrow> ('a \<times> 'a) pre_map set" where
   "all_maps G \<equiv> to_map (arcs G) ` {f. f permutes arcs G \<and> (\<forall>v \<in> verts G. out_arcs G v \<noteq> {} \<longrightarrow> cyclic_on f (out_arcs G v))}"
 
 definition maps_all_maps_list :: "('a list \<times> ('a \<times> 'a) list) \<Rightarrow> ('a \<times> 'a) pre_map list" where
   "maps_all_maps_list G_list = map (to_map (set (snd G_list)) o lists_succ) (all_maps_list G_list)"
 
 lemma (in pair_graph) all_maps_correct:
   shows "all_maps G = {M. digraph_map G M}"
 proof (intro set_eqI iffI)
   fix M assume A:"M \<in> all_maps G"
   then have [simp]: "edge_rev M = swap_in (arcs G)" "edge_succ M permutes parcs G"
     by (auto simp: all_maps_def to_map_def)
 
   have "digraph_map G M"
   proof (rule digraph_mapI)
     fix a assume "a \<notin> parcs G" then show "edge_rev M a = a" by (auto simp: swap_in_def)
   next
     fix a assume "a \<in> parcs G"
     then show "edge_rev M (edge_rev M a) = a" "fst (edge_rev M a) = snd a" "edge_rev M a \<noteq> a"
       by (case_tac [!] "a") (auto intro: arcs_symmetric simp: swap_in_def dest: no_loops)
   next
     show "edge_succ M permutes parcs G" by simp
   next
     fix v assume "v \<in> pverts G" "out_arcs (with_proj G) v \<noteq> {}"
     then show "cyclic_on (edge_succ M) (out_arcs (with_proj G) v)"
       using A unfolding all_maps_def by (auto simp: to_map_def)
   qed
   then show "M \<in> {M. digraph_map G M}" by simp
 next
   fix M assume A: "M \<in> {M. digraph_map G M}"
   then interpret M: digraph_map G M by simp
   from A have "\<And>x. fst (edge_rev M x) = fst (swap_in (arcs G) x)"
       "\<And>x. snd (edge_rev M x) = snd (swap_in (arcs G) x)"
     using M.tail_arev M.head_arev by (auto simp: fun_eq_iff swap_in_def M.arev_eq)
   then have "edge_rev M = swap_in (arcs G)"
     by (metis prod.collapse fun_eq_iff)
   then show "M \<in> all_maps G"
     using M.edge_succ_permutes M.edge_succ_cyclic
     unfolding all_maps_def
     by (auto simp: to_map_def intro!: image_eqI[where x="edge_succ M"])
 qed
 
 
 lemma set_maps_all_maps_list:
   assumes "pair_wf_digraph (list_digraph G_list)" "distinct (snd G_list)"
   shows "all_maps (list_digraph G_list) = set (maps_all_maps_list G_list)"
 proof -
   let ?G = "list_digraph G_list"
 
   { fix f
     have "(\<forall>x\<in>set (grouped_out_arcs G_list). cyclic_on f (set x))
         \<longleftrightarrow> (\<forall>x\<in>set ` set (grouped_out_arcs G_list). cyclic_on f x)" (is "?all1 = _")
       by simp
     also have "\<dots> \<longleftrightarrow> (\<forall>v\<in>pverts ?G. out_arcs ?G v \<noteq> {} \<longrightarrow> cyclic_on f (out_arcs ?G v))" (is "_ = ?all2")
       using assms by (auto simp: set_grouped_out_arcs)
     finally have "?all1 = ?all2" .
   } note all_eq = this
 
   have "lists_succ ` set (all_maps_list G_list)
       = {f. f permutes arcs ?G \<and> (\<forall>v \<in> pverts ?G. out_arcs ?G v \<noteq> {} \<longrightarrow> cyclic_on f (out_arcs ?G v))}"
     unfolding all_maps_list_def using assms all_eq
     by (simp add: lists_succ_set_cyc_permutationss distincts_grouped_arcs union_grouped_out_arcs list_digraph_simps)
   then have *: "lists_succ ` set (all_maps_list G_list) = {f. f permutes set (snd G_list) \<and> (\<forall>v\<in>set (fst G_list). out_arcs (with_proj \<lparr>pverts = set (fst G_list), parcs = set (snd G_list)\<rparr>) v \<noteq> {} \<longrightarrow> cyclic_on f (out_arcs (with_proj \<lparr>pverts = set (fst G_list), parcs = set (snd G_list)\<rparr>) v))}"
     by (auto simp add: maps_all_maps_list_def all_maps_def list_digraph_simps list_digraph_ext_def)
   then have **: "\<And>f. \<not> (f permutes set (snd G_list) \<and> (\<forall>a. a \<in> set (fst G_list) \<longrightarrow> out_arcs (with_proj \<lparr>pverts = set (fst G_list), parcs = set (snd G_list)\<rparr>) a \<noteq> {} \<longrightarrow> cyclic_on f (out_arcs (with_proj \<lparr>pverts = set (fst G_list), parcs = set (snd G_list)\<rparr>) a))) \<or> f \<in> lists_succ ` set (all_maps_list G_list)"
     by force
   from * show ?thesis
     by (auto simp add: maps_all_maps_list_def all_maps_def list_digraph_simps list_digraph_ext_def) (use ** in blast)
 qed
 
 
 section \<open>Compute Face Cycles\<close>
 
 definition lists_fc_succ :: "('a \<times> 'a) list list \<Rightarrow> ('a \<times> 'a) \<Rightarrow> ('a \<times> 'a)" where
   "lists_fc_succ xss = (let sxss = \<Union>(sset xss) in (\<lambda>x. lists_succ xss (swap_in sxss x)))"
 
 locale lists_digraph_map =
   fixes G_list :: "'b list \<times> ('b \<times> 'b) list"
     and xss :: "('b \<times> 'b) list list"
   assumes digraph_map: "digraph_map (list_digraph G_list) (to_map' (snd G_list) xss)"
   assumes no_loops: "\<And>a. a \<in> parcs (list_digraph G_list) \<Longrightarrow> fst a \<noteq> snd a"
   assumes distincts_xss: "distincts xss"
   assumes parcs_xss: "parcs (list_digraph G_list) = \<Union>(sset xss)"
 begin
 
 abbreviation (input) "G \<equiv> list_digraph G_list"
 abbreviation (input) "M \<equiv> to_map' (snd G_list) xss"
 
 lemma edge_rev_simps:
   assumes "(u,v) \<in> parcs G" shows "edge_rev M (u,v) = (v,u)"
   using assms
   unfolding to_map_def list_digraph_ext_def by (auto simp: swap_in_def to_map_def)
 
 end
 
 sublocale lists_digraph_map \<subseteq> digraph_map G M by (rule local.digraph_map)
 
 sublocale lists_digraph_map \<subseteq> pair_graph G
 proof
   fix e assume "e \<in> parcs G"
   then have "e \<in> arcs G" by simp
   then have "head G e \<in> verts G" "tail G e \<in> verts G" by (blast dest: wellformed)+
   then show "fst e \<in> pverts G" "snd e \<in> pverts G" by auto
 next
   fix e assume "e \<in> parcs G" then show "fst e \<noteq> snd e" using no_loops by simp
 next
   show "finite (pverts G)" "finite (parcs G)"
     unfolding list_digraph_ext_def by simp_all
 next
   { fix u v assume "(u,v) \<in> parcs G"
     then have "edge_rev M (u,v) \<in> parcs G"
       using edge_rev_in_arcs by simp
     then have "(v,u) \<in> parcs G" using \<open>(u,v) \<in> _ \<close> by (simp add: edge_rev_simps) }
   then show "symmetric G"
     unfolding symmetric_def by (auto intro: symI)
 qed
 
 context lists_digraph_map begin
 
 definition "lists_fcs \<equiv> orbits_list (lists_fc_succ xss)"
 
 lemma M_simps:
   "edge_succ M = lists_succ xss"
   unfolding to_map_def by (cases G_list) auto
 
 lemma lists_fc_succ_permutes: "lists_fc_succ xss permutes (\<Union>(sset xss))"
 proof -
   have "\<forall>(u,v) \<in> \<Union>(sset xss). (v,u) \<in> \<Union>(sset xss)"
     using sym_arcs unfolding parcs_xss[symmetric] symmetric_def by (auto elim: symE)
   then have "swap_in (\<Union>(sset xss)) permutes \<Union>(sset xss)"
     using distincts_xss
     apply (auto simp: permutes_def split: if_splits)
     unfolding swap_in_def
     apply (simp_all split: if_splits prod.splits)
     apply metis+
     done
   moreover
   have "lists_succ xss permutes (\<Union>(sset xss))"
     using lists_succ_permutes[OF distincts_xss] by simp
   moreover
   have "lists_fc_succ xss = lists_succ xss o swap_in (\<Union>(sset xss))"
     by (simp add: fun_eq_iff lists_fc_succ_def)
   ultimately
   show ?thesis by (metis permutes_compose)
 qed
 
 lemma permutation_lists_fc_succ[intro, simp]: "permutation (lists_fc_succ xss)"
   using lists_fc_succ_permutes by (auto simp: permutation_permutes)
 
 lemma face_cycle_succ_conv: "face_cycle_succ = lists_fc_succ xss"
   using parcs_xss unfolding face_cycle_succ_def
   by (simp add: fun_eq_iff to_map_def lists_fc_succ_def swap_in_def list_digraph_ext_def)
 
 lemma sset_lists_fcs:
   "sset (lists_fcs as) = {face_cycle_set a | a. a \<in> set as}"
   by (auto simp: lists_fcs_def sset_orbits_list face_cycle_set_def face_cycle_succ_conv)
 
 lemma distincts_lists_fcs: "distinct as \<Longrightarrow>distincts (lists_fcs as)"
   by (simp add: lists_fcs_def distincts_orbits_list)
 
 lemma face_cycle_set_ss: "a \<in> parcs G \<Longrightarrow> face_cycle_set a \<subseteq> parcs G"
   using in_face_cycle_setD with_proj_simps(2) by blast
 
 lemma face_cycle_succ_neq:
   assumes "a \<in> parcs G" shows "face_cycle_succ a \<noteq> a"
   using assms no_loops by (intro face_cycle_succ_neq) auto
 
 lemma card_face_cycle_sets_conv:
   shows "card (pre_digraph_map.face_cycle_sets G M) = length (lists_fcs (remdups (snd G_list)))"
 proof -
   interpret digraph_map G M by (rule digraph_map)
 
   have "face_cycle_sets = {face_cycle_set a | a. a \<in> parcs G}"
     by (auto simp: face_cycle_sets_def)
   also have "\<dots> = sset (lists_fcs (remdups (snd G_list)))"
     unfolding sset_lists_fcs by (simp add: list_digraph_simps)
   also have "card \<dots> = length (lists_fcs (remdups (snd G_list)))"
     by (simp add: card_image distincts_inj_on_set distinct_card distincts_distinct distincts_lists_fcs)
   finally show ?thesis .
 qed
 
 end
 
 
 definition "gen_succ \<equiv> \<lambda>as xs. [b. (a,b) <- as, a \<in> set xs]"
 interpretation RTLI: set_access_gen set "\<lambda>x xs. x \<in> set xs" "[]" "\<lambda>xs ys. remdups (xs @ ys)" "gen_succ"
   by standard (auto simp: gen_succ_def)
 hide_const (open) gen_succ
 
 text \<open>
   It would suffice to check that @{term "set (RTLI.rtrancl_i A [u]) = set V"}. We don't do
   this here, since it makes the proof more complicated (and is not necessary for the graphs
   we care about
 \<close>
 definition sccs_verts_impl :: "'a list \<times> ('a \<times> 'a) list \<Rightarrow> 'a set set" where
   "sccs_verts_impl G \<equiv> set ` (\<lambda>x. RTLI.rtrancl_i (snd G) [x]) ` set (fst G)"
 
 definition isolated_verts_impl :: "'a list \<times> ('a \<times> 'a) list \<Rightarrow> 'a list" where
   "isolated_verts_impl G = [v \<leftarrow> (fst G). \<not>(\<exists>e \<in> set (snd G). fst e = v)]"
 
 definition pair_graph_impl :: "'a list \<times> ('a \<times> 'a) list \<Rightarrow> bool" where
   "pair_graph_impl G \<equiv> case G of (V,A) \<Rightarrow> (\<forall>(u,v) \<in> set A. u \<noteq> v \<and> u \<in> set V \<and> v \<in> set V \<and> (v,u) \<in> set A)"
 
 definition genus_impl :: "'a list \<times> ('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list list \<Rightarrow> int" where
   "genus_impl G M \<equiv> case G of (V,A) \<Rightarrow>
     (int (2*card (sccs_verts_impl G)) - int (length (isolated_verts_impl G))
       - (int (length V) - int (length A) div 2
       + int (length (orbits_list_impl (lists_fc_succ M) A)))) div 2"
 
 definition comb_planar_impl :: "'a list \<times> ('a \<times> 'a) list \<Rightarrow> bool" where
   "comb_planar_impl G \<equiv> case G of (V,A) \<Rightarrow>
     let i = int (2*card (sccs_verts_impl G)) - int (length (isolated_verts_impl G))
       - int (length V) + int (length A) div 2
     in (\<exists>M\<in>set (all_maps_list G). (i - int (length (orbits_list_impl (lists_fc_succ M) A))) div 2 = 0)"
 
 (*
 definition comb_planar_impl :: "'a list \<times> ('a \<times> 'a) list \<Rightarrow> bool" where
   "comb_planar_impl G \<equiv> \<exists>M\<in>set (all_maps_list G). genus_impl G M = 0"
 *)
 
 lemma sccs_verts_impl_correct:
   assumes "pair_pseudo_graph (list_digraph G)"
   shows "pre_digraph.sccs_verts (list_digraph G) = sccs_verts_impl G"
 proof -
   interpret pair_pseudo_graph "list_digraph G" by fact
   { fix u assume "u \<in> set (fst G)"
     then have "\<And>x. (u, x) \<in> (set (snd G))\<^sup>* \<Longrightarrow> x \<in> set (fst G)"
       by (metis in_arcsD2 list_digraph_simps rtrancl.cases)
     then have "set (RTLI.rtrancl_i (snd G) [u]) = {v. u \<rightarrow>\<^sup>*\<^bsub>list_digraph G\<^esub> v }"
       unfolding RTLI.rtrancl_impl reachable_conv by (auto simp: list_digraph_simps \<open>u \<in> _\<close>)
     also have "\<dots> = scc_of u"
       unfolding scc_of_def by (auto intro: symmetric_reachable')
     finally have "scc_of u = set (RTLI.rtrancl_i (snd G) [u])" by simp
   }
   then have "pre_digraph.sccs_verts (list_digraph G) = set ` (\<lambda>x. RTLI.rtrancl_i (snd G) [x]) ` set (fst G)"
     unfolding sccs_verts_conv_scc_of list_digraph_simps
     by (force intro: rev_image_eqI)
   then show ?thesis unfolding sccs_verts_impl_def by simp
 qed
 
 lemma isolated_verts_impl_correct:
   "pre_digraph.isolated_verts (list_digraph G) = set (isolated_verts_impl G)"
   by (auto simp: pre_digraph.isolated_verts_def isolated_verts_impl_def list_digraph_simps out_arcs_def)
 
 lemma pair_graph_impl_correct[code]:
   "pair_graph (list_digraph G) = pair_graph_impl G" (is "?L = ?R")
   unfolding pair_graph_def pair_digraph_def pair_fin_digraph_def pair_wf_digraph_def
     pair_fin_digraph_axioms_def pair_loopfree_digraph_def pair_loopfree_digraph_axioms_def
     pair_sym_digraph_def pair_sym_digraph_axioms_def pair_pseudo_graph_def
     pair_graph_impl_def
   by (auto simp: pair_graph_impl_def list_digraph_simps symmetric_def intro: symI dest: symD split: prod.splits)
 
 lemma genus_impl_correct:
   assumes dist_V: "distinct (fst G)" and dist_A: "distinct (snd G)"
   assumes "lists_digraph_map G M"
   shows "pre_digraph_map.euler_genus (list_digraph G) (to_map' (snd G) M) = genus_impl G M"
 proof -
   interpret lists_digraph_map G M by fact
   obtain V A where G_eq: "G = (V,A)" by (cases G)
   moreover
   have "distinct (isolated_verts_impl G)"
     using dist_V by (auto simp: isolated_verts_impl_def )
   moreover
   have faces: "card face_cycle_sets = length (orbits_list_impl (lists_fc_succ M) (snd G))"
     using dist_A
     by (simp add: card_face_cycle_sets_conv lists_fcs_def orbits_list_conv_impl distinct_remdups_id)
   ultimately show ?thesis
     using pair_pseudo_graph dist_V dist_A
     unfolding euler_genus_def euler_char_def genus_impl_def card_sccs_verts[symmetric] 
     by (simp add: sccs_verts_impl_correct isolated_verts_impl_correct
       distinct_card list_digraph_simps zdiv_int)
 qed
 
 lemma elems_all_maps_list:
   assumes "M \<in> set (all_maps_list G)" "distinct (snd G)"
   shows "\<Union>(sset M) = set (snd G)"
     using assms
     by (simp add: all_maps_list_def in_set_cyc_permutationss distincts_grouped_arcs union_grouped_out_arcs[symmetric])
        (metis set_map)
 
 lemma comb_planar_impl_altdef: "comb_planar_impl G = (\<exists>M\<in>set (all_maps_list G). genus_impl G M = 0)"
-  unfolding comb_planar_impl_def Let_def genus_impl_def by (cases G) (simp add:  sign_simps)
+  unfolding comb_planar_impl_def Let_def genus_impl_def by (cases G) (simp add: algebra_simps)
 
 lemma comb_planar_impl_correct:
   assumes "pair_graph (list_digraph G)"
   assumes dist_V: "distinct (fst G)" and dist_A: "distinct (snd G)"
   shows "comb_planar (list_digraph G) = comb_planar_impl G" (is "?L = ?R")
 proof -
   interpret G: pair_graph "list_digraph G" by fact
   let ?G = "list_digraph G"
   have *: "all_maps (list_digraph G) = set (maps_all_maps_list G)"
     by (rule set_maps_all_maps_list) (unfold_locales, simp add: dist_A)
 
   obtain V A where "G = (V,A)" by (cases G)
 
   { fix M assume "M \<in> set (all_maps_list G)"
     have "digraph_map (list_digraph G) (to_map' (snd G) M)"
       using \<open>M \<in> _\<close> G.all_maps_correct by (auto simp: * maps_all_maps_list_def)
     then interpret G: digraph_map "list_digraph G" "to_map' (snd G) M" .
 
     have "distincts M" using \<open>M \<in> _\<close>
       using dist_A distincts_in_all_maps_list by blast
 
     have "lists_digraph_map G M"
       using elems_all_maps_list[OF \<open>M \<in> _\<close> \<open>distinct (snd G)\<close>]
       apply unfold_locales
       by (auto intro: \<open>distincts M\<close> dest: G.adj_not_same) (auto simp: list_digraph_simps)
   } note ldm = this
 
   have "comb_planar ?G = (\<exists>M \<in> {M. digraph_map ?G M}. pre_digraph_map.euler_genus ?G M = 0)"
     unfolding comb_planar_def by simp
   also have "\<dots> = (\<exists>M\<in>set (all_maps_list G). pre_digraph_map.euler_genus (list_digraph G)
       (to_map (set (snd G)) (lists_succ M)) = 0)"
     unfolding comb_planar_def comb_planar_impl_def Let_def G.all_maps_correct[symmetric]
       set_maps_all_maps_list[OF G.pair_wf_digraph dist_A] maps_all_maps_list_def by simp
   also have "\<dots> = (\<exists>M\<in>set (all_maps_list G). genus_impl G M = 0)"
     using ldm assms by (simp add: genus_impl_correct)
   also have "\<dots> = comb_planar_impl G"
-    unfolding comb_planar_impl_def genus_impl_def Let_def by (simp add: \<open>G = (V,A)\<close> sign_simps)
+    unfolding comb_planar_impl_def genus_impl_def Let_def by (simp add: \<open>G = (V,A)\<close> algebra_simps)
   finally show ?thesis .
 qed
 
 end
diff --git a/thys/Polynomial_Interpolation/Missing_Polynomial.thy b/thys/Polynomial_Interpolation/Missing_Polynomial.thy
--- a/thys/Polynomial_Interpolation/Missing_Polynomial.thy
+++ b/thys/Polynomial_Interpolation/Missing_Polynomial.thy
@@ -1,1401 +1,1401 @@
 (*  
     Author:      René Thiemann 
                  Akihisa Yamada
                  Jose Divason
     License:     BSD
 *)
 section \<open>Missing Polynomial\<close>
 
 text \<open>The theory contains some basic results on polynomials which have not been detected in
   the distribution, especially on linear factors and degrees.\<close>
 
 theory Missing_Polynomial
 imports 
   "HOL-Computational_Algebra.Polynomial_Factorial"
   Missing_Unsorted
 begin
 
 subsection \<open>Basic Properties\<close>
 
 lemma degree_0_id: assumes "degree p = 0"
   shows "[: coeff p 0 :] = p" 
 proof -
   have "\<And> x. 0 \<noteq> Suc x" by auto 
   thus ?thesis using assms
   by (metis coeff_pCons_0 degree_pCons_eq_if pCons_cases)
 qed
 
 lemma degree0_coeffs: "degree p = 0 \<Longrightarrow>
   \<exists> a. p = [: a :]"
   by (metis degree_pCons_eq_if old.nat.distinct(2) pCons_cases)
 
 lemma degree1_coeffs: "degree p = 1 \<Longrightarrow>
   \<exists> a b. p = [: b, a :] \<and> a \<noteq> 0" 
   by (metis One_nat_def degree_pCons_eq_if nat.inject old.nat.distinct(2) pCons_0_0 pCons_cases)
 
 lemma degree2_coeffs: "degree p = 2 \<Longrightarrow>
   \<exists> a b c. p = [: c, b, a :] \<and> a \<noteq> 0"
   by (metis Suc_1 Suc_neq_Zero degree1_coeffs degree_pCons_eq_if nat.inject pCons_cases)
 
 lemma poly_zero:
   fixes p :: "'a :: comm_ring_1 poly"
   assumes x: "poly p x = 0" shows "p = 0 \<longleftrightarrow> degree p = 0"
 proof
   assume degp: "degree p = 0"
   hence "poly p x = coeff p (degree p)" by(subst degree_0_id[OF degp,symmetric], simp)
   hence "coeff p (degree p) = 0" using x by auto
   thus "p = 0" by auto
 qed auto
 
 lemma coeff_monom_Suc: "coeff (monom a (Suc d) * p) (Suc i) = coeff (monom a d * p) i"
   by (simp add: monom_Suc)
 
 lemma coeff_sum_monom:
   assumes n: "n \<le> d"
   shows "coeff (\<Sum>i\<le>d. monom (f i) i) n = f n" (is "?l = _")
 proof -
   have "?l = (\<Sum>i\<le>d. coeff (monom (f i) i) n)" (is "_ = sum ?cmf _")
     using coeff_sum.
   also have "{..d} = insert n ({..d}-{n})" using n by auto
     hence "sum ?cmf {..d} = sum ?cmf ..." by auto
   also have "... = sum ?cmf ({..d}-{n}) + ?cmf n" by (subst sum.insert,auto)
   also have "sum ?cmf ({..d}-{n}) = 0" by (subst sum.neutral, auto)
   finally show ?thesis by simp
 qed
 
 lemma linear_poly_root: "(a :: 'a :: comm_ring_1) \<in> set as \<Longrightarrow> poly (\<Prod> a \<leftarrow> as. [: - a, 1:]) a = 0"
 proof (induct as)
   case (Cons b as)
   show ?case
   proof (cases "a = b")
     case False
     with Cons have "a \<in> set as" by auto
     from Cons(1)[OF this] show ?thesis by simp
   qed simp
 qed simp
 
 lemma degree_lcoeff_sum: assumes deg: "degree (f q) = n"
   and fin: "finite S" and q: "q \<in> S" and degle: "\<And> p . p \<in> S - {q} \<Longrightarrow> degree (f p) < n"
   and cong: "coeff (f q) n = c"
   shows "degree (sum f S) = n \<and> coeff (sum f S) n = c"
 proof (cases "S = {q}")
   case True
   thus ?thesis using deg cong by simp
 next
   case False
   with q obtain p where "p \<in> S - {q}" by auto
   from degle[OF this] have n: "n > 0" by auto
   have "degree (sum f S) = degree (f q + sum f (S - {q}))"
     unfolding sum.remove[OF fin q] ..
   also have "\<dots> = degree (f q)"
   proof (rule degree_add_eq_left)
     have "degree (sum f (S - {q})) \<le> n - 1"
     proof (rule degree_sum_le)
       fix p
       show "p \<in> S - {q} \<Longrightarrow> degree (f p) \<le> n - 1"
         using degle[of p] by auto
     qed (insert fin, auto)
     also have "\<dots> < n" using n by simp
     finally show "degree (sum f (S - {q})) < degree (f q)" unfolding deg .
   qed
   finally show ?thesis unfolding deg[symmetric] cong[symmetric]
   proof (rule conjI)
     have id: "(\<Sum>x\<in>S - {q}. coeff (f x) (degree (f q))) = 0"
       by (rule sum.neutral, rule ballI, rule coeff_eq_0[OF degle[folded deg]])
     show "coeff (sum f S) (degree (f q)) = coeff (f q) (degree (f q))"
       unfolding coeff_sum
       by (subst sum.remove[OF _ q], unfold id, insert fin, auto)
   qed
 qed
 
 lemma degree_sum_list_le: "(\<And> p . p \<in> set ps \<Longrightarrow> degree p \<le> n)
   \<Longrightarrow> degree (sum_list ps) \<le> n"
 proof (induct ps)
   case (Cons p ps)
   hence "degree (sum_list ps) \<le> n" "degree p \<le> n" by auto
   thus ?case unfolding sum_list.Cons by (metis degree_add_le)
 qed simp
 
 lemma degree_prod_list_le: "degree (prod_list ps) \<le> sum_list (map degree ps)"
 proof (induct ps)
   case (Cons p ps)
   show ?case unfolding prod_list.Cons
     by (rule order.trans[OF degree_mult_le], insert Cons, auto)
 qed simp
 
 lemma smult_sum: "smult (\<Sum>i \<in> S. f i) p = (\<Sum>i \<in> S. smult (f i) p)"
   by (induct S rule: infinite_finite_induct, auto simp: smult_add_left)
 
 
 lemma range_coeff: "range (coeff p) = insert 0 (set (coeffs p))" 
   by (metis nth_default_coeffs_eq range_nth_default)
 
 lemma smult_power: "(smult a p) ^ n = smult (a ^ n) (p ^ n)"
   by (induct n, auto simp: field_simps)
 
 lemma poly_sum_list: "poly (sum_list ps) x = sum_list (map (\<lambda> p. poly p x) ps)"
   by (induct ps, auto)
 
 lemma poly_prod_list: "poly (prod_list ps) x = prod_list (map (\<lambda> p. poly p x) ps)"
   by (induct ps, auto)
 
 lemma sum_list_neutral: "(\<And> x. x \<in> set xs \<Longrightarrow> x = 0) \<Longrightarrow> sum_list xs = 0"
   by (induct xs, auto)
 
 lemma prod_list_neutral: "(\<And> x. x \<in> set xs \<Longrightarrow> x = 1) \<Longrightarrow> prod_list xs = 1"
   by (induct xs, auto)
 
 lemma (in comm_monoid_mult) prod_list_map_remove1:
   "x \<in> set xs \<Longrightarrow> prod_list (map f xs) = f x * prod_list (map f (remove1 x xs))"
   by (induct xs) (auto simp add: ac_simps)
 
 lemma poly_as_sum:
   fixes p :: "'a::comm_semiring_1 poly"
   shows "poly p x = (\<Sum>i\<le>degree p. x ^ i * coeff p i)"
   unfolding poly_altdef by (simp add: ac_simps)
 
 lemma poly_prod_0: "finite ps \<Longrightarrow> poly (prod f ps) x = (0 :: 'a :: field) \<longleftrightarrow> (\<exists> p \<in> ps. poly (f p) x = 0)"
   by (induct ps rule: finite_induct, auto)
 
 lemma coeff_monom_mult:
   shows "coeff (monom a d * p) i =
     (if d \<le> i then a * coeff p (i-d) else 0)" (is "?l = ?r")
 proof (cases "d \<le> i")
   case False thus ?thesis unfolding coeff_mult by simp
   next case True
     let ?f = "\<lambda>j. coeff (monom a d) j * coeff p (i - j)"
     have "\<And>j. j \<in> {0..i} - {d} \<Longrightarrow> ?f j = 0" by auto
     hence "0 = (\<Sum>j \<in> {0..i} - {d}. ?f j)" by auto
     also have "... + ?f d = (\<Sum>j \<in> insert d ({0..i} - {d}). ?f j)"
       by(subst sum.insert, auto)
     also have "... = (\<Sum>j \<in> {0..i}. ?f j)" by (subst insert_Diff, insert True, auto)
     also have "... = (\<Sum>j\<le>i. ?f j)" by (rule sum.cong, auto)
     also have "... = ?l" unfolding coeff_mult ..
     finally show ?thesis using True by auto
 qed
 
 lemma poly_eqI2:
   assumes "degree p = degree q" and "\<And>i. i \<le> degree p \<Longrightarrow> coeff p i = coeff q i"
   shows "p = q"
   apply(rule poly_eqI) by (metis assms le_degree)
 
 text \<open>A nice extension rule for polynomials.\<close>
 lemma poly_ext[intro]:
   fixes p q :: "'a :: {ring_char_0, idom} poly"
   assumes "\<And>x. poly p x = poly q x" shows "p = q"
   unfolding poly_eq_poly_eq_iff[symmetric]
   using assms by (rule ext)
 
 text \<open>Copied from non-negative variants.\<close>
 lemma coeff_linear_power_neg[simp]:
   fixes a :: "'a::comm_ring_1"
   shows "coeff ([:a, -1:] ^ n) n = (-1)^n"
 apply (induct n, simp_all)
 apply (subst coeff_eq_0)
 apply (auto intro: le_less_trans degree_power_le)
 done
 
 lemma degree_linear_power_neg[simp]:
   fixes a :: "'a::{idom,comm_ring_1}"
   shows "degree ([:a, -1:] ^ n) = n"
 apply (rule order_antisym)
 apply (rule ord_le_eq_trans [OF degree_power_le], simp)
 apply (rule le_degree)
 unfolding coeff_linear_power_neg
 apply (auto)
 done
 
 
 subsection \<open>Polynomial Composition\<close>
 
 lemmas [simp] = pcompose_pCons
 
 lemma pcompose_eq_0: fixes q :: "'a :: idom poly"
   assumes q: "degree q \<noteq> 0"
   shows "p \<circ>\<^sub>p q = 0 \<longleftrightarrow> p = 0"
 proof (induct p)
   case 0
   show ?case by auto
 next
   case (pCons a p)
   have id: "(pCons a p) \<circ>\<^sub>p q = [:a:] + q * (p \<circ>\<^sub>p q)" by simp
   show ?case 
   proof (cases "p = 0")
     case True
     show ?thesis unfolding id unfolding True by simp
   next
     case False
     with pCons(2) have "p \<circ>\<^sub>p q \<noteq> 0" by auto
     from degree_mult_eq[OF _ this, of q] q have "degree (q * (p \<circ>\<^sub>p q)) \<noteq> 0" by force
     hence deg: "degree ([:a:] + q * (p \<circ>\<^sub>p q)) \<noteq> 0"
       by (subst degree_add_eq_right, auto)
     show ?thesis unfolding id using False deg by auto
   qed
 qed
 
 declare degree_pcompose[simp]
 
 subsection \<open>Monic Polynomials\<close>
 
 abbreviation monic where "monic p \<equiv> coeff p (degree p) = 1"
 
 lemma unit_factor_field [simp]: 
   "unit_factor (x :: 'a :: {field,normalization_semidom}) = x"
   by (cases "is_unit x") (auto simp: is_unit_unit_factor dvd_field_iff)
 
 lemma poly_gcd_monic: 
   fixes p :: "'a :: {field,factorial_ring_gcd} poly"
   assumes "p \<noteq> 0 \<or> q \<noteq> 0"
   shows   "monic (gcd p q)"
 proof -
   from assms have "1 = unit_factor (gcd p q)" by (auto simp: unit_factor_gcd)
   also have "\<dots> = [:lead_coeff (gcd p q):]" unfolding unit_factor_poly_def
     by (simp add: monom_0)
   finally show ?thesis
     by (metis coeff_pCons_0 degree_1 lead_coeff_1)
 qed
 
 lemma normalize_monic: "monic p \<Longrightarrow> normalize p = p"
   by (simp add: normalize_poly_eq_map_poly is_unit_unit_factor)
 
 lemma lcoeff_monic_mult: assumes monic: "monic (p :: 'a :: comm_semiring_1 poly)"
   shows "coeff (p * q) (degree p + degree q) = coeff q (degree q)"
 proof -
   let ?pqi = "\<lambda> i. coeff p i * coeff q (degree p + degree q - i)" 
   have "coeff (p * q) (degree p + degree q) = 
     (\<Sum>i\<le>degree p + degree q. ?pqi i)"
     unfolding coeff_mult by simp
   also have "\<dots> = ?pqi (degree p) + (sum ?pqi ({.. degree p + degree q} - {degree p}))"
     by (subst sum.remove[of _ "degree p"], auto)
   also have "?pqi (degree p) = coeff q (degree q)" unfolding monic by simp
   also have "(sum ?pqi ({.. degree p + degree q} - {degree p})) = 0"
   proof (rule sum.neutral, intro ballI)
     fix d
     assume d: "d \<in> {.. degree p + degree q} - {degree p}"
     show "?pqi d = 0"
     proof (cases "d < degree p")
       case True
       hence "degree p + degree q - d > degree q" by auto
       hence "coeff q (degree p + degree q - d) = 0" by (rule coeff_eq_0)
       thus ?thesis by simp
     next
       case False
       with d have "d > degree p" by auto
       hence "coeff p d = 0" by (rule coeff_eq_0)
       thus ?thesis by simp
     qed
   qed
   finally show ?thesis by simp
 qed
 
 lemma degree_monic_mult: assumes monic: "monic (p :: 'a :: comm_semiring_1 poly)"
   and q: "q \<noteq> 0"
   shows "degree (p * q) = degree p + degree q"
 proof -
   have "degree p + degree q \<ge> degree (p * q)" by (rule degree_mult_le)
   also have "degree p + degree q \<le> degree (p * q)"
   proof -
     from q have cq: "coeff q (degree q) \<noteq> 0" by auto
     hence "coeff (p * q) (degree p + degree q) \<noteq> 0" unfolding lcoeff_monic_mult[OF monic] .
     thus "degree (p * q) \<ge> degree p + degree q" by (rule le_degree)
   qed
   finally show ?thesis .
 qed
 
 lemma degree_prod_sum_monic: assumes
   S: "finite S"
   and nzd: "0 \<notin> (degree o f) ` S"
   and monic: "(\<And> a . a \<in> S \<Longrightarrow> monic (f a))"
   shows "degree (prod f S) = (sum (degree o f) S) \<and> coeff (prod f S) (sum (degree o f) S) = 1"
 proof -
   from S nzd monic 
   have "degree (prod f S) = sum (degree \<circ> f) S 
   \<and> (S \<noteq> {} \<longrightarrow> degree (prod f S) \<noteq> 0 \<and> prod f S \<noteq> 0) \<and> coeff (prod f S) (sum (degree o f) S) = 1"
   proof (induct S rule: finite_induct)
     case (insert a S)
     have IH1: "degree (prod f S) = sum (degree o f) S"
       using insert by auto
     have IH2: "coeff (prod f S) (degree (prod f S)) = 1"
       using insert by auto
     have id: "degree (prod f (insert a S)) = sum (degree \<circ> f) (insert a S)
       \<and> coeff (prod f (insert a S)) (sum (degree o f) (insert a S)) = 1"
     proof (cases "S = {}")
       case False
       with insert have nz: "prod f S \<noteq> 0" by auto
       from insert have monic: "coeff (f a) (degree (f a)) = 1" by auto
       have id: "(degree \<circ> f) a = degree (f a)" by simp
       show ?thesis unfolding prod.insert[OF insert(1-2)] sum.insert[OF insert(1-2)] id
         unfolding degree_monic_mult[OF monic nz] 
         unfolding IH1[symmetric]
         unfolding lcoeff_monic_mult[OF monic] IH2 by simp
     qed (insert insert, auto)
     show ?case using id unfolding sum.insert[OF insert(1-2)] using insert by auto
   qed simp
   thus ?thesis by auto
 qed 
 
 lemma degree_prod_monic: 
   assumes "\<And> i. i < n \<Longrightarrow> degree (f i :: 'a :: comm_semiring_1 poly) = 1"
     and "\<And> i. i < n \<Longrightarrow> coeff (f i) 1 = 1"
   shows "degree (prod f {0 ..< n}) = n \<and> coeff (prod f {0 ..< n}) n = 1"
 proof -
   from degree_prod_sum_monic[of "{0 ..< n}" f] show ?thesis using assms by force
 qed
 
 lemma degree_prod_sum_lt_n: assumes "\<And> i. i < n \<Longrightarrow> degree (f i :: 'a :: comm_semiring_1 poly) \<le> 1"
   and i: "i < n" and fi: "degree (f i) = 0"
   shows "degree (prod f {0 ..< n}) < n"
 proof -
   have "degree (prod f {0 ..< n}) \<le> sum (degree o f) {0 ..< n}"
     by (rule degree_prod_sum_le, auto)
   also have "sum (degree o f) {0 ..< n} = (degree o f) i + sum (degree o f) ({0 ..< n} - {i})"
     by (rule sum.remove, insert i, auto)
   also have "(degree o f) i = 0" using fi by simp
   also have "sum (degree o f) ({0 ..< n} - {i}) \<le> sum (\<lambda> _. 1) ({0 ..< n} - {i})"
     by (rule sum_mono, insert assms, auto)
   also have "\<dots> = n - 1" using i by simp
   also have "\<dots> < n" using i by simp
   finally show ?thesis by simp
 qed
 
 lemma degree_linear_factors: "degree (\<Prod> a \<leftarrow> as. [: f a, 1:]) = length as"
 proof (induct as)
   case (Cons b as) note IH = this
   have id: "(\<Prod>a\<leftarrow>b # as. [:f a, 1:]) = [:f b,1 :] * (\<Prod>a\<leftarrow>as. [:f a, 1:])" by simp
   show ?case unfolding id
     by (subst degree_monic_mult, insert IH, auto)
 qed simp
 
 lemma monic_mult:
   fixes p q :: "'a :: idom poly"
   assumes "monic p" "monic q"
   shows "monic (p * q)"
 proof -
   from assms have nz: "p \<noteq> 0" "q \<noteq> 0" by auto
   show ?thesis unfolding degree_mult_eq[OF nz] coeff_mult_degree_sum
     using assms by simp
 qed
 
 lemma monic_factor:
   fixes p q :: "'a :: idom poly"
   assumes "monic (p * q)" "monic p"
   shows "monic q"
 proof -
   from assms have nz: "p \<noteq> 0" "q \<noteq> 0" by auto
   from assms[unfolded degree_mult_eq[OF nz] coeff_mult_degree_sum \<open>monic p\<close>]
   show ?thesis by simp
 qed
 
 lemma monic_prod:
   fixes f :: "'a \<Rightarrow> 'b :: idom poly"
   assumes "\<And> a. a \<in> as \<Longrightarrow> monic (f a)"
   shows "monic (prod f as)" using assms
 proof (induct as rule: infinite_finite_induct)
   case (insert a as)
   hence id: "prod f (insert a as) = f a * prod f as" 
     and *: "monic (f a)" "monic (prod f as)" by auto
   show ?case unfolding id by (rule monic_mult[OF *])
 qed auto
 
 lemma monic_prod_list:
   fixes as :: "'a :: idom poly list"
   assumes "\<And> a. a \<in> set as \<Longrightarrow> monic a"
   shows "monic (prod_list as)" using assms
   by (induct as, auto intro: monic_mult)
 
 lemma monic_power:
   assumes "monic (p :: 'a :: idom poly)"
   shows "monic (p ^ n)"
   by (induct n, insert assms, auto intro: monic_mult)
 
 lemma monic_prod_list_pow: "monic (\<Prod>(x::'a::idom, i)\<leftarrow>xis. [:- x, 1:] ^ Suc i)"
 proof (rule monic_prod_list, goal_cases)
   case (1 a)
   then obtain x i where a: "a = [:-x, 1:]^Suc i" by force
   show "monic a" unfolding a
     by (rule monic_power, auto)
 qed
 
 lemma monic_degree_0: "monic p \<Longrightarrow> (degree p = 0) = (p = 1)"
   using le_degree poly_eq_iff by force
 
 subsection \<open>Roots\<close>
 
 text \<open>The following proof structure is completely similar to the one
   of @{thm poly_roots_finite}.\<close>
 
 lemma poly_roots_degree:
   fixes p :: "'a::idom poly"
   shows "p \<noteq> 0 \<Longrightarrow> card {x. poly p x = 0} \<le> degree p"
 proof (induct n \<equiv> "degree p" arbitrary: p)
   case (0 p)
   then obtain a where "a \<noteq> 0" and "p = [:a:]"
     by (cases p, simp split: if_splits)
   then show ?case by simp
 next
   case (Suc n p)
   show ?case
   proof (cases "\<exists>x. poly p x = 0")
     case True
     then obtain a where a: "poly p a = 0" ..
     then have "[:-a, 1:] dvd p" by (simp only: poly_eq_0_iff_dvd)
     then obtain k where k: "p = [:-a, 1:] * k" ..
     with \<open>p \<noteq> 0\<close> have "k \<noteq> 0" by auto
     with k have "degree p = Suc (degree k)"
       by (simp add: degree_mult_eq del: mult_pCons_left)
     with \<open>Suc n = degree p\<close> have "n = degree k" by simp
     from Suc.hyps(1)[OF this \<open>k \<noteq> 0\<close>]
     have le: "card {x. poly k x = 0} \<le> degree k" .
     have "card {x. poly p x = 0} = card {x. poly ([:-a, 1:] * k) x = 0}" unfolding k ..
     also have "{x. poly ([:-a, 1:] * k) x = 0} = insert a {x. poly k x = 0}"
       by auto
     also have "card \<dots> \<le> Suc (card {x. poly k x = 0})" 
       unfolding card_insert_if[OF poly_roots_finite[OF \<open>k \<noteq> 0\<close>]] by simp
     also have "\<dots> \<le> Suc (degree k)" using le by auto
     finally show ?thesis using \<open>degree p = Suc (degree k)\<close> by simp
   qed simp
 qed
 
 lemma poly_root_factor: "(poly ([: r, 1:] * q) (k :: 'a :: idom) = 0) = (k = -r \<or> poly q k = 0)" (is ?one)
   "(poly (q * [: r, 1:]) k = 0) = (k = -r \<or> poly q k = 0)" (is ?two)
   "(poly [: r, 1 :] k = 0) = (k = -r)" (is ?three)
 proof -
   have [simp]: "r + k = 0 \<Longrightarrow> k = - r" by (simp add: minus_unique)
   show ?one unfolding poly_mult by auto
   show ?two unfolding poly_mult by auto
   show ?three by auto
 qed
 
 lemma poly_root_constant: "c \<noteq> 0 \<Longrightarrow> (poly (p * [:c:]) (k :: 'a :: idom) = 0) = (poly p k = 0)"
   unfolding poly_mult by auto
 
 
 lemma poly_linear_exp_linear_factors_rev: 
   "([:b,1:])^(length (filter ((=) b) as)) dvd (\<Prod> (a :: 'a :: comm_ring_1) \<leftarrow> as. [: a, 1:])"
 proof (induct as)
   case (Cons a as)
   let ?ls = "length (filter ((=) b) (a # as))"
   let ?l = "length (filter ((=) b) as)"
   have prod: "(\<Prod> a \<leftarrow> Cons a as. [: a, 1:]) = [: a, 1 :] * (\<Prod> a \<leftarrow> as. [: a, 1:])" by simp
   show ?case
   proof (cases "a = b")
     case False
     hence len: "?ls = ?l" by simp
     show ?thesis unfolding prod len using Cons by (rule dvd_mult)
   next
     case True
     hence len: "[: b, 1 :] ^ ?ls = [: a, 1 :] * [: b, 1 :] ^ ?l" by simp
     show ?thesis unfolding prod len using Cons using dvd_refl mult_dvd_mono by blast
   qed
 qed simp
 
 lemma order_max: assumes dvd: "[: -a, 1 :] ^ k dvd p" and p: "p \<noteq> 0"
   shows "k \<le> order a p"
 proof (rule ccontr)
   assume "\<not> ?thesis"
   hence "\<exists> j. k = Suc (order a p + j)" by arith
   then obtain j where k: "k = Suc (order a p + j)" by auto
   have "[: -a, 1 :] ^ Suc (order a p) dvd p"
     by (rule power_le_dvd[OF dvd[unfolded k]], simp)
   with order_2[OF p, of a] show False by blast
 qed
 
 
 subsection \<open>Divisibility\<close>
 
 context
   assumes "SORT_CONSTRAINT('a :: idom)"
 begin
 lemma poly_linear_linear_factor: assumes 
   dvd: "[:b,1:] dvd (\<Prod> (a :: 'a) \<leftarrow> as. [: a, 1:])"
   shows "b \<in> set as"
 proof -
   let ?p = "\<lambda> as. (\<Prod> a \<leftarrow> as. [: a, 1:])"
   let ?b = "[:b,1:]"
   from assms[unfolded dvd_def] obtain p where id: "?p as = ?b * p" ..
   from arg_cong[OF id, of "\<lambda> p. poly p (-b)"]
   have "poly (?p as) (-b) = 0" by simp
   thus ?thesis
   proof (induct as)
     case (Cons a as)
     have "?p (a # as) = [:a,1:] * ?p as" by simp
     from Cons(2)[unfolded this] have "poly (?p as) (-b) = 0 \<or> (a - b) = 0" by simp
     with Cons(1) show ?case by auto
   qed simp
 qed
 
 lemma poly_linear_exp_linear_factors: 
   assumes dvd: "([:b,1:])^n dvd (\<Prod> (a :: 'a) \<leftarrow> as. [: a, 1:])"
   shows "length (filter ((=) b) as) \<ge> n"
 proof -
   let ?p = "\<lambda> as. (\<Prod> a \<leftarrow> as. [: a, 1:])"
   let ?b = "[:b,1:]"
   from dvd show ?thesis
   proof (induct n arbitrary: as)
     case (Suc n as)
     have bs: "?b ^ Suc n = ?b * ?b ^ n" by simp
     from poly_linear_linear_factor[OF dvd_mult_left[OF Suc(2)[unfolded bs]], 
       unfolded in_set_conv_decomp]
     obtain as1 as2 where as: "as = as1 @ b # as2" by auto
     have "?p as = [:b,1:] * ?p (as1 @ as2)" unfolding as
     proof (induct as1)
       case (Cons a as1)
       have "?p (a # as1 @ b # as2) = [:a,1:] * ?p (as1 @ b # as2)" by simp
       also have "?p (as1 @ b # as2) = [:b,1:] * ?p (as1 @ as2)" unfolding Cons by simp
       also have "[:a,1:] * \<dots> = [:b,1:] * ([:a,1:] * ?p (as1 @ as2))" 
         by (metis (no_types, lifting) mult.left_commute)
       finally show ?case by simp
     qed simp
     from Suc(2)[unfolded bs this dvd_mult_cancel_left]
     have "?b ^ n dvd ?p (as1 @ as2)" by simp
     from Suc(1)[OF this] show ?case unfolding as by simp
   qed simp    
 qed
 end
 
 lemma const_poly_dvd: "([:a:] dvd [:b:]) = (a dvd b)"
 proof
   assume "a dvd b"
   then obtain c where "b = a * c" unfolding dvd_def by auto
   hence "[:b:] = [:a:] * [: c:]" by (auto simp: ac_simps)
   thus "[:a:] dvd [:b:]" unfolding dvd_def by blast
 next
   assume "[:a:] dvd [:b:]"
   then obtain pc where "[:b:] =  [:a:] * pc" unfolding dvd_def by blast
   from arg_cong[OF this, of "\<lambda> p. coeff p 0", unfolded coeff_mult]
   have "b = a * coeff pc 0" by auto
   thus "a dvd b" unfolding dvd_def by blast
 qed
 
 lemma const_poly_dvd_1 [simp]:
   "[:a:] dvd 1 \<longleftrightarrow> a dvd 1"
   by (metis const_poly_dvd one_poly_eq_simps(2))
 
 lemma poly_dvd_1:
   fixes p :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
   shows "p dvd 1 \<longleftrightarrow> degree p = 0 \<and> coeff p 0 dvd 1"
 proof (cases "degree p = 0")
   case False
   with divides_degree[of p 1] show ?thesis by auto
 next
   case True
   from degree0_coeffs[OF this] obtain a where p: "p = [:a:]" by auto
   show ?thesis unfolding p by auto
 qed
 
 text \<open>Degree based version of irreducibility.\<close>
 
 definition irreducible\<^sub>d :: "'a :: comm_semiring_1 poly \<Rightarrow> bool" where
   "irreducible\<^sub>d p = (degree p > 0 \<and> (\<forall> q r. degree q < degree p \<longrightarrow> degree r < degree p \<longrightarrow> p \<noteq> q * r))"
 
 lemma irreducible\<^sub>dI [intro]:
   assumes 1: "degree p > 0"
     and 2: "\<And>q r. degree q > 0 \<Longrightarrow> degree q < degree p \<Longrightarrow> degree r > 0 \<Longrightarrow> degree r < degree p \<Longrightarrow> p = q * r \<Longrightarrow> False"
   shows "irreducible\<^sub>d p"
 proof (unfold irreducible\<^sub>d_def, intro conjI allI impI notI 1)
   fix q r
   assume "degree q < degree p" and "degree r < degree p" and "p = q * r"
   with degree_mult_le[of q r]
   show False by (intro 2, auto)
 qed
 
 lemma irreducible\<^sub>dI2:
   fixes p :: "'a::{comm_semiring_1,semiring_no_zero_divisors} poly"
   assumes deg: "degree p > 0" and ndvd: "\<And> q. degree q > 0 \<Longrightarrow> degree q \<le> degree p div 2 \<Longrightarrow> \<not> q dvd p"
   shows "irreducible\<^sub>d p"
 proof (rule ccontr)
   assume "\<not> ?thesis"
   from this[unfolded irreducible\<^sub>d_def] deg obtain q r where dq: "degree q < degree p" and dr: "degree r < degree p"
     and p: "p = q * r" by auto
   from deg have p0: "p \<noteq> 0" by auto
   with p have "q \<noteq> 0" "r \<noteq> 0" by auto
   from degree_mult_eq[OF this] p have dp: "degree p = degree q + degree r" by simp
   show False
   proof (cases "degree q \<le> degree p div 2")
     case True
     from ndvd[OF _ True] dq dr dp p show False by auto
   next
     case False
     with dp have dr: "degree r \<le> degree p div 2" by auto
     from p have dvd: "r dvd p" by auto
     from ndvd[OF _ dr] dvd dp dq show False by auto
   qed
 qed
 
 lemma reducible\<^sub>dI:
   assumes "degree p > 0 \<Longrightarrow> \<exists>q r. degree q < degree p \<and> degree r < degree p \<and> p = q * r"
   shows "\<not> irreducible\<^sub>d p"
   using assms by (auto simp: irreducible\<^sub>d_def)
 
 lemma irreducible\<^sub>dE [elim]:
   assumes "irreducible\<^sub>d p"
     and "degree p > 0 \<Longrightarrow> (\<And>q r. degree q < degree p \<Longrightarrow> degree r < degree p \<Longrightarrow> p \<noteq> q * r) \<Longrightarrow> thesis"
   shows thesis
   using assms by (auto simp: irreducible\<^sub>d_def)
 
 lemma reducible\<^sub>dE [elim]:
   assumes red: "\<not> irreducible\<^sub>d p"
     and 1: "degree p = 0 \<Longrightarrow> thesis"
     and 2: "\<And>q r. degree q > 0 \<Longrightarrow> degree q < degree p \<Longrightarrow> degree r > 0 \<Longrightarrow> degree r < degree p \<Longrightarrow> p = q * r \<Longrightarrow> thesis"
   shows thesis
   using red[unfolded irreducible\<^sub>d_def de_Morgan_conj not_not not_all not_imp]
 proof (elim disjE exE conjE)
   show "\<not>degree p > 0 \<Longrightarrow> thesis" using 1 by auto
 next
   fix q r
   assume "degree q < degree p" and "degree r < degree p" and "p = q * r"
   with degree_mult_le[of q r]
   show thesis by (intro 2, auto)
 qed
 
 lemma irreducible\<^sub>dD:
   assumes "irreducible\<^sub>d p"
   shows "degree p > 0" "\<And>q r. degree q < degree p \<Longrightarrow> degree r < degree p \<Longrightarrow> p \<noteq> q * r"
   using assms unfolding irreducible\<^sub>d_def by auto
 
 theorem irreducible\<^sub>d_factorization_exists:
   assumes "degree p > 0"
   shows "\<exists>fs. fs \<noteq> [] \<and> (\<forall>f \<in> set fs. irreducible\<^sub>d f \<and> degree f \<le> degree p) \<and> p = prod_list fs"
     and "\<not>irreducible\<^sub>d p \<Longrightarrow> \<exists>fs. length fs > 1 \<and> (\<forall>f \<in> set fs. irreducible\<^sub>d f \<and> degree f < degree p) \<and> p = prod_list fs"
 proof (atomize(full), insert assms, induct "degree p" arbitrary:p rule: less_induct)
   case less
   then have deg_f: "degree p > 0" by auto
   show ?case
   proof (cases "irreducible\<^sub>d p")
     case True
     then have "set [p] \<subseteq> Collect irreducible\<^sub>d" "p = prod_list [p]" by auto
     with True show ?thesis by (auto intro: exI[of _ "[p]"])
   next
     case False
     with deg_f obtain g h
     where deg_g: "degree g < degree p" "degree g > 0"
       and deg_h: "degree h < degree p" "degree h > 0"
       and f_gh: "p = g * h" by auto
     from less.hyps[OF deg_g] less.hyps[OF deg_h]
     obtain gs hs
     where emp: "length gs > 0" "length hs > 0"
       and "\<forall>f \<in> set gs. irreducible\<^sub>d f \<and> degree f \<le> degree g" "g = prod_list gs"
       and "\<forall>f \<in> set hs. irreducible\<^sub>d f \<and> degree f \<le> degree h" "h = prod_list hs" by auto
     with f_gh deg_g deg_h
     have len: "length (gs@hs) > 1"
      and mem: "\<forall>f \<in> set (gs@hs). irreducible\<^sub>d f \<and> degree f < degree p"
      and p: "p = prod_list (gs@hs)" by (auto simp del: length_greater_0_conv)
     with False show ?thesis by (auto intro!: exI[of _ "gs@hs"] simp: less_imp_le)
   qed
 qed
 
 lemma irreducible\<^sub>d_factor:
   fixes p :: "'a::{comm_semiring_1,semiring_no_zero_divisors} poly"
   assumes "degree p > 0"
   shows "\<exists> q r. irreducible\<^sub>d q \<and> p = q * r \<and> degree r < degree p" using assms
 proof (induct "degree p" arbitrary: p rule: less_induct)
   case (less p)
   show ?case
   proof (cases "irreducible\<^sub>d p")
     case False
     with less(2) obtain q r
     where q: "degree q < degree p" "degree q > 0"
       and r: "degree r < degree p" "degree r > 0"
       and p: "p = q * r"
       by auto
     from less(1)[OF q] obtain s t where IH: "irreducible\<^sub>d s" "q = s * t" by auto
     from p have p: "p = s * (t * r)" unfolding IH by (simp add: ac_simps)
     from less(2) have "p \<noteq> 0" by auto
     hence "degree p = degree s + (degree (t * r))" unfolding p 
       by (subst degree_mult_eq, insert p, auto)
     with irreducible\<^sub>dD[OF IH(1)] have "degree p > degree (t * r)" by auto
     with p IH show ?thesis by auto
   next
     case True
     show ?thesis
       by (rule exI[of _ p], rule exI[of _ 1], insert True less(2), auto)
   qed
 qed
 
 context mult_zero begin (* least class with times and zero *)
 
 definition zero_divisor where "zero_divisor a \<equiv> \<exists>b. b \<noteq> 0 \<and> a * b = 0"
 
 lemma zero_divisorI[intro]:
   assumes "b \<noteq> 0" and "a * b = 0" shows "zero_divisor a"
   using assms by (auto simp: zero_divisor_def)
 
 lemma zero_divisorE[elim]:
   assumes "zero_divisor a"
     and "\<And>b. b \<noteq> 0 \<Longrightarrow> a * b = 0 \<Longrightarrow> thesis"
   shows thesis
   using assms by (auto simp: zero_divisor_def)
 
 end
 
 lemma zero_divisor_0[simp]:
   "zero_divisor (0::'a::{mult_zero,zero_neq_one})" (* No need for one! *)
   by (auto intro!: zero_divisorI[of 1])
 
 lemma not_zero_divisor_1:
   "\<not> zero_divisor (1 :: 'a :: {monoid_mult,mult_zero})" (* No need for associativity! *)
   by auto
 
 lemma zero_divisor_iff_eq_0[simp]:
   fixes a :: "'a :: {semiring_no_zero_divisors, zero_neq_one}"
   shows "zero_divisor a \<longleftrightarrow> a = 0" by auto
 
 lemma mult_eq_0_not_zero_divisor_left[simp]:
   fixes a b :: "'a :: mult_zero"
   assumes "\<not> zero_divisor a"
   shows "a * b = 0 \<longleftrightarrow> b = 0"
   using assms unfolding zero_divisor_def by force
 
 lemma mult_eq_0_not_zero_divisor_right[simp]:
   fixes a b :: "'a :: {ab_semigroup_mult,mult_zero}" (* No need for associativity! *)
   assumes "\<not> zero_divisor b"
   shows "a * b = 0 \<longleftrightarrow> a = 0"
   using assms unfolding zero_divisor_def by (force simp: ac_simps)
 
 lemma degree_smult_not_zero_divisor_left[simp]:
   assumes "\<not> zero_divisor c"
   shows "degree (smult c p) = degree p"
 proof(cases "p = 0")
   case False
   then have "coeff (smult c p) (degree p) \<noteq> 0" using assms by auto
   from le_degree[OF this] degree_smult_le[of c p]
   show ?thesis by auto
 qed auto
 
 lemma degree_smult_not_zero_divisor_right[simp]:
   assumes "\<not> zero_divisor (lead_coeff p)"
   shows "degree (smult c p) = (if c = 0 then 0 else degree p)"
 proof(cases "c = 0")
   case False
   then have "coeff (smult c p) (degree p) \<noteq> 0" using assms by auto
   from le_degree[OF this] degree_smult_le[of c p]
   show ?thesis by auto
 qed auto
 
 
 lemma irreducible\<^sub>d_smult_not_zero_divisor_left:
   assumes c0: "\<not> zero_divisor c"
   assumes L: "irreducible\<^sub>d (smult c p)"
   shows "irreducible\<^sub>d p"
 proof (intro irreducible\<^sub>dI)
   from L have "degree (smult c p) > 0" by auto
   also note degree_smult_le
   finally show "degree p > 0" by auto
   fix q r
   assume deg_q: "degree q < degree p"
     and deg_r: "degree r < degree p"
     and p_qr: "p = q * r"
   then have 1: "smult c p = smult c q * r" by auto
   note degree_smult_le[of c q]
   also note deg_q
   finally have 2: "degree (smult c q) < degree (smult c p)" using c0 by auto
   from deg_r have 3: "degree r < \<dots>" using c0 by auto
   from irreducible\<^sub>dD(2)[OF L 2 3] 1 show False by auto
 qed
 
 lemmas irreducible\<^sub>d_smultI =
   irreducible\<^sub>d_smult_not_zero_divisor_left
   [where 'a = "'a :: {comm_semiring_1,semiring_no_zero_divisors}", simplified]
 
 lemma irreducible\<^sub>d_smult_not_zero_divisor_right:
   assumes p0: "\<not> zero_divisor (lead_coeff p)" and L: "irreducible\<^sub>d (smult c p)"
   shows "irreducible\<^sub>d p"
 proof-
   from L have "c \<noteq> 0" by auto
   with p0 have [simp]: "degree (smult c p) = degree p" by simp
   show "irreducible\<^sub>d p"
   proof (intro iffI irreducible\<^sub>dI conjI)
     from L show "degree p > 0" by auto
     fix q r
     assume deg_q: "degree q < degree p"
       and deg_r: "degree r < degree p"
       and p_qr: "p = q * r"
     then have 1: "smult c p = smult c q * r" by auto
     note degree_smult_le[of c q]
     also note deg_q
     finally have 2: "degree (smult c q) < degree (smult c p)" by simp
     from deg_r have 3: "degree r < \<dots>" by simp
     from irreducible\<^sub>dD(2)[OF L 2 3] 1 show False by auto
   qed
 qed
 
 lemma zero_divisor_mult_left:
   fixes a b :: "'a :: {ab_semigroup_mult, mult_zero}"
   assumes "zero_divisor a"
   shows "zero_divisor (a * b)"
 proof-
   from assms obtain c where c0: "c \<noteq> 0" and [simp]: "a * c = 0" by auto
   have "a * b * c = a * c * b" by (simp only: ac_simps)
   with c0 show ?thesis by auto
 qed
 
 lemma zero_divisor_mult_right:
   fixes a b :: "'a :: {semigroup_mult, mult_zero}"
   assumes "zero_divisor b"
   shows "zero_divisor (a * b)"
 proof-
   from assms obtain c where c0: "c \<noteq> 0" and [simp]: "b * c = 0" by auto
   have "a * b * c = a * (b * c)" by (simp only: ac_simps)
   with c0 show ?thesis by auto
 qed
 
 lemma not_zero_divisor_mult:
   fixes a b :: "'a :: {ab_semigroup_mult, mult_zero}"
   assumes "\<not> zero_divisor (a * b)"
   shows "\<not> zero_divisor a" and "\<not> zero_divisor b"
   using assms by (auto dest: zero_divisor_mult_right zero_divisor_mult_left)
 
 lemma zero_divisor_smult_left:
   assumes "zero_divisor a"
   shows "zero_divisor (smult a f)"
 proof-
   from assms obtain b where b0: "b \<noteq> 0" and "a * b = 0" by auto
   then have "smult a f * [:b:] = 0" by (simp add: ac_simps)
   with b0 show ?thesis by (auto intro!: zero_divisorI[of "[:b:]"])
 qed
 
 lemma unit_not_zero_divisor:
   fixes a :: "'a :: {comm_monoid_mult, mult_zero}"
   assumes "a dvd 1"
   shows "\<not>zero_divisor a"
 proof
   from assms obtain b where ab: "1 = a * b" by (elim dvdE)
   assume "zero_divisor a"
   then have "zero_divisor (1::'a)" by (unfold ab, intro zero_divisor_mult_left)
   then show False by auto
 qed
 
 
 lemma linear_irreducible\<^sub>d: assumes "degree p = 1"
   shows "irreducible\<^sub>d p"
   by (rule irreducible\<^sub>dI, insert assms, auto)
 
 lemma irreducible\<^sub>d_dvd_smult:
   fixes p :: "'a::{comm_semiring_1,semiring_no_zero_divisors} poly"
   assumes "degree p > 0" "irreducible\<^sub>d q" "p dvd q"
   shows "\<exists> c. c \<noteq> 0 \<and> q = smult c p"
 proof -
   from assms obtain r where q: "q = p * r" by (elim dvdE, auto)
   from degree_mult_eq[of p r] assms(1) q
   have "\<not> degree p < degree q" and nz: "p \<noteq> 0" "q \<noteq> 0"
     apply (metis assms(2) degree_mult_eq_0 gr_implies_not_zero irreducible\<^sub>dD(2) less_add_same_cancel2)
     using assms by auto
   hence deg: "degree p \<ge> degree q" by auto
   from \<open>p dvd q\<close> obtain k where q: "q = k * p" unfolding dvd_def by (auto simp: ac_simps)
   with nz have "k \<noteq> 0" by auto
   from deg[unfolded q degree_mult_eq[OF \<open>k \<noteq> 0\<close> \<open>p \<noteq> 0\<close> ]] have "degree k = 0" 
     unfolding q by auto 
   then obtain c where k: "k = [: c :]" by (metis degree_0_id)
   with \<open>k \<noteq> 0\<close> have "c \<noteq> 0" by auto
   have "q = smult c p" unfolding q k by simp
   with \<open>c \<noteq> 0\<close> show ?thesis by auto
 qed
 
 subsection \<open>Map over Polynomial Coefficients\<close>
 lemma map_poly_simps:
   shows "map_poly f (pCons c p) =
     (if c = 0 \<and> p = 0 then 0 else pCons (f c) (map_poly f p))"
 proof (cases "c = 0")
   case True note c0 = this show ?thesis
     proof (cases "p = 0")
       case True thus ?thesis using c0 unfolding map_poly_def by simp
       next case False thus ?thesis
         unfolding map_poly_def by auto
     qed
   next case False thus ?thesis
     unfolding map_poly_def by auto
 qed
 
 lemma map_poly_pCons[simp]:
   assumes "c \<noteq> 0 \<or> p \<noteq> 0"
   shows "map_poly f (pCons c p) = pCons (f c) (map_poly f p)"
   unfolding map_poly_simps using assms by auto
 
 lemma map_poly_map_poly:
   assumes f0: "f 0 = 0"
   shows "map_poly f (map_poly g p) = map_poly (f \<circ> g) p"
 proof (induct p)
   case (pCons a p) show ?case
   proof(cases "g a \<noteq> 0 \<or> map_poly g p \<noteq> 0")
     case True show ?thesis
       unfolding map_poly_pCons[OF pCons(1)]
       unfolding map_poly_pCons[OF True]
       unfolding pCons(2)
       by simp
   next
     case False then show ?thesis
       unfolding map_poly_pCons[OF pCons(1)]
       unfolding pCons(2)[symmetric]
       by (simp add: f0)
   qed
 qed simp
 
 lemma map_poly_zero:
   assumes f: "\<forall>c. f c = 0 \<longrightarrow> c = 0"
   shows [simp]: "map_poly f p = 0 \<longleftrightarrow> p = 0"
   by (induct p; auto simp: map_poly_simps f)
 
 lemma map_poly_add:
   assumes h0: "h 0 = 0"
       and h_add: "\<forall>p q. h (p + q) = h p + h q"
   shows "map_poly h (p + q) = map_poly h p + map_poly h q"
 proof (induct p arbitrary: q)
   case (pCons a p) note pIH = this
     show ?case
     proof(induct "q")
       case (pCons b q) note qIH = this
         show ?case
           unfolding map_poly_pCons[OF qIH(1)]
           unfolding map_poly_pCons[OF pIH(1)]
           unfolding add_pCons
           unfolding pIH(2)[symmetric]
           unfolding h_add[rule_format,symmetric]
           unfolding map_poly_simps using h0 by auto
     qed auto
 qed auto
 
 subsection \<open>Morphismic properties of @{term "pCons 0"}\<close>
 
 lemma monom_pCons_0_monom:
   "monom (pCons 0 (monom a n)) d = map_poly (pCons 0) (monom (monom a n) d)"
   apply (induct d)
   unfolding monom_0 unfolding map_poly_simps apply simp
   unfolding monom_Suc map_poly_simps by auto
 
 lemma pCons_0_add: "pCons 0 (p + q) = pCons 0 p + pCons 0 q" by auto
 
 lemma sum_pCons_0_commute:
   "sum (\<lambda>i. pCons 0 (f i)) S = pCons 0 (sum f S)"
   by(induct S rule: infinite_finite_induct;simp)
 
 lemma pCons_0_as_mult:
   fixes p:: "'a :: comm_semiring_1 poly"
   shows "pCons 0 p = [:0,1:] * p" by auto
 
 
 
 subsection \<open>Misc\<close>
 
 fun expand_powers :: "(nat \<times> 'a)list \<Rightarrow> 'a list" where
   "expand_powers [] = []"
 | "expand_powers ((Suc n, a) # ps) = a # expand_powers ((n,a) # ps)"
 | "expand_powers ((0,a) # ps) = expand_powers ps"
 
 lemma expand_powers: fixes f :: "'a \<Rightarrow> 'b :: comm_ring_1"
   shows "(\<Prod> (n,a) \<leftarrow> n_as. f a ^ n) = (\<Prod> a \<leftarrow> expand_powers n_as. f a)"
   by (rule sym, induct n_as rule: expand_powers.induct, auto)
 
 lemma poly_smult_zero_iff: fixes x :: "'a :: idom" 
   shows "(poly (smult a p) x = 0) = (a = 0 \<or> poly p x = 0)"
   by simp
 
 lemma poly_prod_list_zero_iff: fixes x :: "'a :: idom" 
   shows "(poly (prod_list ps) x = 0) = (\<exists> p \<in> set ps. poly p x = 0)"
   by (induct ps, auto)
 
 lemma poly_mult_zero_iff: fixes x :: "'a :: idom" 
   shows "(poly (p * q) x = 0) = (poly p x = 0 \<or> poly q x = 0)"
   by simp
 
 lemma poly_power_zero_iff: fixes x :: "'a :: idom" 
   shows "(poly (p^n) x = 0) = (n \<noteq> 0 \<and> poly p x = 0)"
   by (cases n, auto)
 
 
 lemma sum_monom_0_iff: assumes fin: "finite S"
   and g: "\<And> i j. g i = g j \<Longrightarrow> i = j"
   shows "sum (\<lambda> i. monom (f i) (g i)) S = 0 \<longleftrightarrow> (\<forall> i \<in> S. f i = 0)" (is "?l = ?r")
 proof -
   {
     assume "\<not> ?r"
     then obtain i where i: "i \<in> S" and fi: "f i \<noteq> 0" by auto
     let ?g = "\<lambda> i. monom (f i) (g i)"
     have "coeff (sum ?g S) (g i) = f i + sum (\<lambda> j. coeff (?g j) (g i)) (S - {i})"
       by (unfold sum.remove[OF fin i], simp add: coeff_sum)
     also have "sum (\<lambda> j. coeff (?g j) (g i)) (S - {i}) = 0"
       by (rule sum.neutral, insert g, auto)
     finally have "coeff (sum ?g S) (g i) \<noteq> 0" using fi by auto
     hence "\<not> ?l" by auto
   }
   thus ?thesis by auto
 qed
 
 lemma degree_prod_list_eq: assumes "\<And> p. p \<in> set ps \<Longrightarrow> (p :: 'a :: idom poly) \<noteq> 0"
   shows "degree (prod_list ps) = sum_list (map degree ps)" using assms
 proof (induct ps)
   case (Cons p ps)
   show ?case unfolding prod_list.Cons
     by (subst degree_mult_eq, insert Cons, auto simp: prod_list_zero_iff)
 qed simp
 
 lemma degree_power_eq: assumes p: "p \<noteq> 0"
   shows "degree (p ^ n) = degree (p :: 'a :: idom poly) * n"
 proof (induct n)
   case (Suc n)
   from p have pn: "p ^ n \<noteq> 0" by auto
   show ?case using degree_mult_eq[OF p pn] Suc by auto
 qed simp
 
 lemma coeff_Poly: "coeff (Poly xs) i = (nth_default 0 xs i)"
   unfolding nth_default_coeffs_eq[of "Poly xs", symmetric] coeffs_Poly by simp
 
 lemma rsquarefree_def': "rsquarefree p = (p \<noteq> 0 \<and> (\<forall>a. order a p \<le> 1))"
 proof -
   have "\<And> a. order a p \<le> 1 \<longleftrightarrow> order a p = 0 \<or> order a p = 1" by linarith
   thus ?thesis unfolding rsquarefree_def by auto
 qed
 
 lemma order_prod_list: "(\<And> p. p \<in> set ps \<Longrightarrow> p \<noteq> 0) \<Longrightarrow> order x (prod_list ps) = sum_list (map (order x) ps)"
   by (induct ps, auto, subst order_mult, auto simp: prod_list_zero_iff)
 
 lemma irreducible\<^sub>d_dvd_eq:
   fixes a b :: "'a::{comm_semiring_1,semiring_no_zero_divisors} poly"
   assumes "irreducible\<^sub>d a" and "irreducible\<^sub>d b"
     and "a dvd b"
     and "monic a" and "monic b" 
   shows "a = b"
   using assms
   by (metis (no_types, lifting) coeff_smult degree_smult_eq irreducible\<^sub>dD(1) irreducible\<^sub>d_dvd_smult 
     mult.right_neutral smult_1_left)
 
 lemma monic_gcd_dvd:
   assumes fg: "f dvd g" and mon: "monic f" and gcd: "gcd g h \<in> {1, g}"
   shows "gcd f h \<in> {1, f}"
 proof (cases "coprime g h")
   case True
   with dvd_refl have "coprime f h"
     using fg by (blast intro: coprime_divisors)
   then show ?thesis
     by simp
 next
   case False
   with gcd have gcd: "gcd g h = g"
     by (simp add: coprime_iff_gcd_eq_1)
   with fg have "f dvd gcd g h"
     by simp
   then have "f dvd h"
     by simp
   then have "gcd f h = normalize f"
     by (simp add: gcd_proj1_iff)
   also have "normalize f = f"
     using mon by (rule normalize_monic)
   finally show ?thesis
     by simp
 qed
 
 lemma monom_power: "(monom a b)^n = monom (a^n) (b*n)" 
   by (induct n, auto simp add: mult_monom)
 
 lemma poly_const_pow: "[:a:]^b = [:a^b:]"
   by (metis Groups.mult_ac(2) monom_0 monom_power mult_zero_right)
 
 lemma degree_pderiv_le: "degree (pderiv f) \<le> degree f - 1" 
 proof (rule ccontr)
   assume "\<not> ?thesis"
   hence ge: "degree (pderiv f) \<ge> Suc (degree f - 1)" by auto
   hence "pderiv f \<noteq> 0" by auto
   hence "coeff (pderiv f) (degree (pderiv f)) \<noteq> 0" by auto
   from this[unfolded coeff_pderiv]
   have "coeff f (Suc (degree (pderiv f))) \<noteq> 0" by auto
   moreover have "Suc (degree (pderiv f)) > degree f" using ge by auto
   ultimately show False by (simp add: coeff_eq_0)
 qed
 
 lemma map_div_is_smult_inverse: "map_poly (\<lambda>x. x / (a :: 'a :: field)) p = smult (inverse a) p" 
   unfolding smult_conv_map_poly
   by (simp add: divide_inverse_commute)
 
 lemma normalize_poly_old_def:
   "normalize (f :: 'a :: {normalization_semidom,field} poly) = smult (inverse (unit_factor (lead_coeff f))) f"
   by (simp add: normalize_poly_eq_map_poly map_div_is_smult_inverse)
 
 (* was in Euclidean_Algorithm in Number_Theory before, but has been removed *)
 lemma poly_dvd_antisym:
   fixes p q :: "'b::idom poly"
   assumes coeff: "coeff p (degree p) = coeff q (degree q)"
   assumes dvd1: "p dvd q" and dvd2: "q dvd p" shows "p = q"
 proof (cases "p = 0")
   case True with coeff show "p = q" by simp
 next
   case False with coeff have "q \<noteq> 0" by auto
   have degree: "degree p = degree q"
     using \<open>p dvd q\<close> \<open>q dvd p\<close> \<open>p \<noteq> 0\<close> \<open>q \<noteq> 0\<close>
     by (intro order_antisym dvd_imp_degree_le)
 
   from \<open>p dvd q\<close> obtain a where a: "q = p * a" ..
   with \<open>q \<noteq> 0\<close> have "a \<noteq> 0" by auto
   with degree a \<open>p \<noteq> 0\<close> have "degree a = 0"
     by (simp add: degree_mult_eq)
   with coeff a show "p = q"
     by (cases a, auto split: if_splits)
 qed
 
 lemma coeff_f_0_code[code_unfold]: "coeff f 0 = (case coeffs f of [] \<Rightarrow> 0 | x # _ \<Rightarrow> x)" 
   by (cases f, auto simp: cCons_def)
 
 lemma poly_compare_0_code[code_unfold]: "(f = 0) = (case coeffs f of [] \<Rightarrow> True | _ \<Rightarrow> False)" 
   using coeffs_eq_Nil list.disc_eq_case(1) by blast
 
 text \<open>Getting more efficient code for abbreviation @{term lead_coeff}"\<close>
 
 definition leading_coeff
   where [code_abbrev, simp]: "leading_coeff = lead_coeff" 
 
 lemma leading_coeff_code [code]:
   "leading_coeff f = (let xs = coeffs f in if xs = [] then 0 else last xs)"
   by (simp add: last_coeffs_eq_coeff_degree)
 
 lemma nth_coeffs_coeff: "i < length (coeffs f) \<Longrightarrow> coeffs f ! i = coeff f i"
   by (metis nth_default_coeffs_eq nth_default_def)
 
 lemma degree_prod_eq_sum_degree:
 fixes A :: "'a set"
 and f :: "'a \<Rightarrow> 'b::field poly"
 assumes f0: "\<forall>i\<in>A. f i \<noteq> 0"
 shows "degree (\<Prod>i\<in>A. (f i)) = (\<Sum>i\<in>A. degree (f i))"
 using f0
 proof (induct A rule: infinite_finite_induct)
   case (insert x A)
   have "(\<Sum>i\<in>insert x A. degree (f i)) = degree (f x) + (\<Sum>i\<in>A. degree (f i))"
     by (simp add: insert.hyps(1) insert.hyps(2))
   also have "... = degree (f x) + degree (\<Prod>i\<in>A. (f i))"
     by (simp add: insert.hyps insert.prems)
   also have "... = degree (f x * (\<Prod>i\<in>A. (f i)))"
   proof (rule degree_mult_eq[symmetric])
     show "f x \<noteq> 0" using insert.prems by auto
     show "prod f A \<noteq> 0" by (simp add: insert.hyps(1) insert.prems)
   qed
   also have "... = degree (\<Prod>i\<in>insert x A. (f i))"
     by (simp add: insert.hyps)
   finally show ?case ..
 qed auto
 
 definition monom_mult :: "nat \<Rightarrow> 'a :: comm_semiring_1 poly \<Rightarrow> 'a poly"
   where "monom_mult n f = monom 1 n * f" 
 
 lemma monom_mult_unfold [code_unfold]:
   "monom 1 n * f = monom_mult n f"
   "f * monom 1 n = monom_mult n f" 
   by (auto simp: monom_mult_def ac_simps)
 
 lemma monom_mult_code [code abstract]:
   "coeffs (monom_mult n f) = (let xs = coeffs f in
     if xs = [] then xs else replicate n 0 @ xs)" 
   by (rule coeffs_eqI)
     (auto simp add: Let_def monom_mult_def coeff_monom_mult nth_default_append nth_default_coeffs_eq)
 
 lemma coeff_pcompose_monom: fixes f :: "'a :: comm_ring_1 poly" 
   assumes n: "j < n" 
   shows "coeff (f \<circ>\<^sub>p monom 1 n) (n * i + j) = (if j = 0 then coeff f i else 0)"     
 proof (induct f arbitrary: i)
   case (pCons a f i)
   note d = pcompose_pCons coeff_add coeff_monom_mult coeff_pCons
   show ?case 
   proof (cases i)
     case 0
     show ?thesis unfolding d 0 using n by (cases j, auto)
   next
     case (Suc ii)
     have id: "n * Suc ii + j - n = n * ii + j" using n by (simp add: diff_mult_distrib2)
     have id1: "(n \<le> n * Suc ii + j) = True" by auto
     have id2: "(case n * Suc ii + j of 0 \<Rightarrow> a | Suc x \<Rightarrow> coeff 0 x) = 0" using n
       by (cases "n * Suc ii + j", auto)
     show ?thesis unfolding d Suc id id1 id2 pCons(2) if_True by auto
   qed
 qed auto
 
 lemma coeff_pcompose_x_pow_n: fixes f :: "'a :: comm_ring_1 poly" 
   assumes n: "n \<noteq> 0" 
   shows "coeff (f \<circ>\<^sub>p monom 1 n) (n * i) = coeff f i"     
   using coeff_pcompose_monom[of 0 n f i] n by auto
         
 lemma dvd_dvd_smult: "a dvd b \<Longrightarrow> f dvd g \<Longrightarrow> smult a f dvd smult b g"
   unfolding dvd_def by (metis mult_smult_left mult_smult_right smult_smult)
 
 definition sdiv_poly :: "'a :: idom_divide poly \<Rightarrow> 'a \<Rightarrow> 'a poly" where
   "sdiv_poly p a = (map_poly (\<lambda> c. c div a) p)"  
 
 lemma smult_map_poly: "smult a = map_poly ((*) a)"
   by (rule ext, rule poly_eqI, subst coeff_map_poly, auto)
   
 lemma smult_exact_sdiv_poly: assumes "\<And> c. c \<in> set (coeffs p) \<Longrightarrow> a dvd c"
   shows "smult a (sdiv_poly p a) = p" 
   unfolding smult_map_poly sdiv_poly_def
   by (subst map_poly_map_poly,simp,rule map_poly_idI, insert assms, auto)
 
 lemma coeff_sdiv_poly: "coeff (sdiv_poly f a) n = coeff f n div a" 
   unfolding sdiv_poly_def by (rule coeff_map_poly, auto)    
 
 lemma poly_pinfty_ge:
   fixes p :: "real poly"
   assumes "lead_coeff p > 0" "degree p \<noteq> 0" 
   shows "\<exists>n. \<forall> x \<ge> n. poly p x \<ge> b"
 proof -
   let ?p = "p - [:b - lead_coeff p :]" 
   have id: "lead_coeff ?p = lead_coeff p" using assms(2)
     by (cases p, auto)
   with assms(1) have "lead_coeff ?p > 0" by auto
   from poly_pinfty_gt_lc[OF this, unfolded id] obtain n
     where "\<And> x. x \<ge> n \<Longrightarrow> 0 \<le> poly p x - b" by auto
   thus ?thesis by auto
 qed
 
 lemma pderiv_sum: "pderiv (sum f I) = sum (\<lambda> i. (pderiv (f i))) I" 
   by (induct I rule: infinite_finite_induct, auto simp: pderiv_add)
 
 lemma smult_sum2: "smult m (\<Sum>i \<in> S. f i) = (\<Sum>i \<in> S. smult m (f i))"
   by (induct S rule: infinite_finite_induct, auto simp add: smult_add_right)
 
 lemma degree_mult_not_eq:
   "degree (f * g) \<noteq> degree f + degree g \<Longrightarrow> lead_coeff f * lead_coeff g = 0"
   by (rule ccontr, auto simp: coeff_mult_degree_sum degree_mult_le le_antisym le_degree)
 
 lemma irreducible\<^sub>d_multD:
   fixes a b :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
   assumes l: "irreducible\<^sub>d (a*b)"
   shows "degree a = 0 \<and> a \<noteq> 0 \<and> irreducible\<^sub>d b \<or> degree b = 0 \<and> b \<noteq> 0 \<and> irreducible\<^sub>d a"
 proof-
   from l have a0: "a \<noteq> 0" and b0: "b \<noteq> 0" by auto
   note [simp] = degree_mult_eq[OF this]
   from l have "degree a = 0 \<or> degree b = 0" apply (unfold irreducible\<^sub>d_def) by force
   then show ?thesis
   proof(elim disjE)
     assume a: "degree a = 0"
     with l a0 have "irreducible\<^sub>d b"
-      unfolding irreducible\<^sub>d_def
-      by (smt add.left_neutral degree_mult_not_eq leading_coeff_0_iff sign_simps(4) mult_eq_0_iff)
+      by (simp add: irreducible\<^sub>d_def)
+        (metis degree_mult_eq degree_mult_eq_0 mult.left_commute plus_nat.add_0)
     with a a0 show ?thesis by auto
   next
     assume b: "degree b = 0"
     with l b0 have "irreducible\<^sub>d a"
       unfolding irreducible\<^sub>d_def
       by (smt add_cancel_left_right degree_mult_eq degree_mult_eq_0 neq0_conv semiring_normalization_rules(16))
     with b b0 show ?thesis by auto
   qed
 qed
 
 lemma irreducible_connect_field[simp]:
   fixes f :: "'a :: field poly"
   shows "irreducible\<^sub>d f = irreducible f" (is "?l = ?r")
 proof
   show "?r \<Longrightarrow> ?l"
     apply (intro irreducible\<^sub>dI, force simp:is_unit_iff_degree)
     by (auto dest!: irreducible_multD simp: poly_dvd_1)
 next
   assume l: ?l
   show ?r
   proof (rule irreducibleI)
     from l show "f \<noteq> 0" "\<not> is_unit f" by (auto simp: poly_dvd_1)
     fix a b assume "f = a * b"
     from l[unfolded this]
     show "a dvd 1 \<or> b dvd 1" by (auto dest!: irreducible\<^sub>d_multD simp:is_unit_iff_degree)
   qed
 qed
 
 lemma is_unit_field_poly[simp]:
   fixes p :: "'a::field poly"
   shows "is_unit p \<longleftrightarrow> p \<noteq> 0 \<and> degree p = 0"
   by (cases "p=0", auto simp: is_unit_iff_degree)
 
 lemma irreducible_smult_field[simp]:
   fixes c :: "'a :: field"
   shows "irreducible (smult c p) \<longleftrightarrow> c \<noteq> 0 \<and> irreducible p" (is "?L \<longleftrightarrow> ?R")
 proof (intro iffI conjI irreducible\<^sub>d_smult_not_zero_divisor_left[of c p, simplified])
   assume "irreducible (smult c p)"
   then show "c \<noteq> 0" by auto
 next
   assume ?R
   then have c0: "c \<noteq> 0" and irr: "irreducible p" by auto
   show ?L
   proof (fold irreducible_connect_field, intro irreducible\<^sub>dI, unfold degree_smult_eq if_not_P[OF c0])
     show "degree p > 0" using irr by auto
     fix q r
     from c0 have "p = smult (1/c) (smult c p)" by simp
     also assume "smult c p = q * r"
     finally have [simp]: "p = smult (1/c) \<dots>".
     assume main: "degree q < degree p" "degree r < degree p"
     have "\<not>irreducible\<^sub>d p" by (rule reducible\<^sub>dI, rule exI[of _ "smult (1/c) q"], rule exI[of _ r], insert irr c0 main, simp)
     with irr show False by auto
   qed
 qed auto
 
 lemma irreducible_monic_factor: fixes p :: "'a :: field poly" 
   assumes "degree p > 0" 
   shows "\<exists> q r. irreducible q \<and> p = q * r \<and> monic q"
 proof -
   from irreducible\<^sub>d_factorization_exists[OF assms]
   obtain fs where "fs \<noteq> []" and "set fs \<subseteq> Collect irreducible" and "p = prod_list fs" by auto
   then have q: "irreducible (hd fs)" and p: "p = hd fs * prod_list (tl fs)" by (atomize(full), cases fs, auto)
   define c where "c = coeff (hd fs) (degree (hd fs))"
   from q have c: "c \<noteq> 0" unfolding c_def irreducible\<^sub>d_def by auto
   show ?thesis
     by (rule exI[of _ "smult (1/c) (hd fs)"], rule exI[of _ "smult c (prod_list (tl fs))"], unfold p,
     insert q c, auto simp: c_def)
 qed
 
 lemma monic_irreducible_factorization: fixes p :: "'a :: field poly" 
   shows "monic p \<Longrightarrow> 
   \<exists> as f. finite as \<and> p = prod (\<lambda> a. a ^ Suc (f a)) as \<and> as \<subseteq> {q. irreducible q \<and> monic q}"
 proof (induct "degree p" arbitrary: p rule: less_induct)
   case (less p)
   show ?case
   proof (cases "degree p > 0")
     case False
     with less(2) have "p = 1" by (simp add: coeff_eq_0 poly_eq_iff)
     thus ?thesis by (intro exI[of _ "{}"], auto)
   next
     case True
     from irreducible\<^sub>d_factor[OF this] obtain q r where p: "p = q * r"
       and q: "irreducible q" and deg: "degree r < degree p" by auto
     hence q0: "q \<noteq> 0" by auto
     define c where "c = coeff q (degree q)"
     let ?q = "smult (1/c) q"
     let ?r = "smult c r"
     from q0 have c: "c \<noteq> 0" "1 / c \<noteq> 0" unfolding c_def by auto
     hence p: "p = ?q * ?r" unfolding p by auto
     have deg: "degree ?r < degree p" using c deg by auto
     let ?Q = "{q. irreducible q \<and> monic (q :: 'a poly)}"
     have mon: "monic ?q" unfolding c_def using q0 by auto
     from monic_factor[OF \<open>monic p\<close>[unfolded p] this] have "monic ?r" .
     from less(1)[OF deg this] obtain f as
       where as: "finite as" "?r = (\<Prod> a \<in>as. a ^ Suc (f a))"
         "as \<subseteq> ?Q" by blast
     from q c have irred: "irreducible ?q" by simp
     show ?thesis
     proof (cases "?q \<in> as")
       case False
       let ?as = "insert ?q as"
       let ?f = "\<lambda> a. if a = ?q then 0 else f a"
       have "p = ?q * (\<Prod> a \<in>as. a ^ Suc (f a))" unfolding p as by simp
       also have "(\<Prod> a \<in>as. a ^ Suc (f a)) = (\<Prod> a \<in>as. a ^ Suc (?f a))"
         by (rule prod.cong, insert False, auto)
       also have "?q * \<dots> = (\<Prod> a \<in> ?as. a ^ Suc (?f a))"
         by (subst prod.insert, insert as False, auto)
       finally have p: "p = (\<Prod> a \<in> ?as. a ^ Suc (?f a))" .
       from as(1) have fin: "finite ?as" by auto
       from as mon irred have Q: "?as \<subseteq> ?Q" by auto
       from fin p Q show ?thesis 
         by(intro exI[of _ ?as] exI[of _ ?f], auto)
     next
       case True
       let ?f = "\<lambda> a. if a = ?q then Suc (f a) else f a"
       have "p = ?q * (\<Prod> a \<in>as. a ^ Suc (f a))" unfolding p as by simp
       also have "(\<Prod> a \<in>as. a ^ Suc (f a)) = ?q ^ Suc (f ?q) * (\<Prod> a \<in>(as - {?q}). a ^ Suc (f a))"
         by (subst prod.remove[OF _ True], insert as, auto)
       also have "(\<Prod> a \<in>(as - {?q}). a ^ Suc (f a)) = (\<Prod> a \<in>(as - {?q}). a ^ Suc (?f a))"
         by (rule prod.cong, auto)
       also have "?q * (?q ^ Suc (f ?q) * \<dots> ) = ?q ^ Suc (?f ?q) * \<dots>"
         by (simp add: ac_simps)
       also have "\<dots> = (\<Prod> a \<in> as. a ^ Suc (?f a))"
         by (subst prod.remove[OF _ True], insert as, auto)
       finally have "p = (\<Prod> a \<in> as. a ^ Suc (?f a))" .
       with as show ?thesis 
         by (intro exI[of _ as] exI[of _ ?f], auto)
     qed
   qed
 qed
 
 lemma monic_irreducible_gcd: 
   "monic (f::'a::{field,euclidean_ring_gcd} poly) \<Longrightarrow> irreducible f \<Longrightarrow> gcd f u \<in> {1,f}"
   by (metis gcd_dvd1 irreducible_altdef insertCI is_unit_gcd_iff poly_dvd_antisym poly_gcd_monic)
 end
diff --git a/thys/Polynomial_Interpolation/Missing_Unsorted.thy b/thys/Polynomial_Interpolation/Missing_Unsorted.thy
--- a/thys/Polynomial_Interpolation/Missing_Unsorted.thy
+++ b/thys/Polynomial_Interpolation/Missing_Unsorted.thy
@@ -1,651 +1,652 @@
 (*  
     Author:      René Thiemann 
                  Akihisa Yamada
                  Jose Divason
     License:     BSD
 *)
 section \<open>Missing Unsorted\<close>
 
 text \<open>This theory contains several lemmas which might be of interest to the Isabelle distribution.
   For instance, we prove that $b^n \cdot n^k$ is bounded by a constant whenever $0 < b < 1$.\<close>
 
 theory Missing_Unsorted
 imports
   HOL.Complex "HOL-Computational_Algebra.Factorial_Ring"
 begin
 
 lemma bernoulli_inequality: assumes x: "-1 \<le> (x :: 'a :: linordered_field)"
   shows "1 + of_nat n * x \<le> (1 + x) ^ n"
 proof (induct n)
   case (Suc n)
   have "1 + of_nat (Suc n) * x = 1 + x + of_nat n * x" by (simp add: field_simps)
   also have "\<dots> \<le> \<dots> + of_nat n * x ^ 2" by simp
   also have "\<dots> = (1 + of_nat n * x) * (1 + x)" by (simp add: field_simps power2_eq_square)
   also have "\<dots> \<le> (1 + x) ^ n * (1 + x)"
     by (rule mult_right_mono[OF Suc], insert x, auto)
   also have "\<dots> = (1 + x) ^ (Suc n)" by simp
   finally show ?case .
 qed simp
 
 context
   fixes b :: "'a :: archimedean_field"
   assumes b: "0 < b" "b < 1"
 begin
 private lemma pow_one: "b ^ x \<le> 1" using power_Suc_less_one[OF b, of "x - 1"] by (cases x, auto)
 
 private lemma pow_zero: "0 < b ^ x" using b(1) by simp
 
 lemma exp_tends_to_zero: assumes c: "c > 0"
   shows "\<exists> x. b ^ x \<le> c" 
 proof (rule ccontr)
   assume not: "\<not> ?thesis"
   define bb where "bb = inverse b"
   define cc where "cc = inverse c"
   from b have bb: "bb > 1" unfolding bb_def by (rule one_less_inverse)  
   from c have cc: "cc > 0" unfolding cc_def by simp
   define bbb where "bbb = bb - 1"
   have id: "bb = 1 + bbb" and bbb: "bbb > 0" and bm1: "bbb \<ge> -1" unfolding bbb_def using bb by auto
   have "\<exists> n. cc / bbb < of_nat n" by (rule reals_Archimedean2)
   then obtain n where lt: "cc / bbb < of_nat n" by auto
   from not have "\<not> b ^ n \<le> c" by auto
   hence bnc: "b ^ n > c" by simp
   have "bb ^ n = inverse (b ^ n)" unfolding bb_def by (rule power_inverse)
   also have "\<dots> < cc" unfolding cc_def
     by (rule less_imp_inverse_less[OF bnc c])
   also have "\<dots> < bbb * of_nat n" using lt bbb by (metis mult.commute pos_divide_less_eq)
   also have "\<dots> \<le> bb ^ n"
     using bernoulli_inequality[OF bm1, folded id, of n] by (simp add: ac_simps)
   finally show False by simp
 qed
 
 lemma linear_exp_bound: "\<exists> p. \<forall> x. b ^ x * of_nat x \<le> p"
 proof -
   from b have "1 - b > 0" by simp
   from exp_tends_to_zero[OF this]
   obtain x0 where x0: "b ^ x0 \<le> 1 - b" ..
   {
     fix x
     assume "x \<ge> x0"
     hence "\<exists> y. x = x0 + y" by arith
     then obtain y where x: "x = x0 + y" by auto
     have "b ^ x = b ^ x0 * b ^ y" unfolding x by (simp add: power_add)
     also have "\<dots> \<le> b ^ x0" using pow_one[of y] pow_zero[of x0] by auto
     also have "\<dots> \<le> 1 - b" by (rule x0)
     finally have "b ^ x \<le> 1 - b" .
   } note x0 = this
   define bs where "bs = insert 1 { b ^ Suc x * of_nat (Suc x) | x . x \<le> x0}"
   have bs: "finite bs" unfolding bs_def by auto
   define p where "p = Max bs"
   have bs: "\<And> b. b \<in> bs \<Longrightarrow> b \<le> p" unfolding p_def using bs by simp
   hence p1: "p \<ge> 1" unfolding bs_def by auto
   show ?thesis
   proof (rule exI[of _ p], intro allI)
     fix x
     show "b ^ x * of_nat x \<le> p"
     proof (induct x)
       case (Suc x)
       show ?case
       proof (cases "x \<le> x0")
         case True
         show ?thesis 
           by (rule bs, unfold bs_def, insert True, auto)
       next
         case False
         let ?x = "of_nat x :: 'a"
         have "b ^ (Suc x) * of_nat (Suc x) = b * (b ^ x * ?x) + b ^ Suc x" by (simp add: field_simps)
         also have "\<dots> \<le> b * p + b ^ Suc x"
           by (rule add_right_mono[OF mult_left_mono[OF Suc]], insert b, auto)
         also have "\<dots> = p - ((1 - b) * p - b ^ (Suc x))" by (simp add: field_simps)
         also have "\<dots> \<le> p - 0"
         proof -
           have "b ^ Suc x \<le> 1 - b" using x0[of "Suc x"] False by auto
           also have "\<dots> \<le> (1 - b) * p" using b p1 by auto
           finally show ?thesis
             by (intro diff_left_mono, simp)
         qed
         finally show ?thesis by simp
       qed
     qed (insert p1, auto)
   qed
 qed
 
 lemma poly_exp_bound: "\<exists> p. \<forall> x. b ^ x * of_nat x ^ deg \<le> p" 
 proof -
   show ?thesis
   proof (induct deg)
     case 0
     show ?case
       by (rule exI[of _ 1], intro allI, insert pow_one, auto)
   next
     case (Suc deg)
     then obtain q where IH: "\<And> x. b ^ x * (of_nat x) ^ deg \<le> q" by auto
     define p where "p = max 0 q"
     from IH have IH: "\<And> x. b ^ x * (of_nat x) ^ deg \<le> p" unfolding p_def using le_max_iff_disj by blast
     have p: "p \<ge> 0" unfolding p_def by simp
     show ?case
     proof (cases "deg = 0")
       case True
       thus ?thesis using linear_exp_bound by simp
     next
       case False note deg = this
       define p' where "p' = p*p * 2 ^ Suc deg * inverse b"
       let ?f = "\<lambda> x. b ^ x * (of_nat x) ^ Suc deg"
       define f where "f = ?f"
       {
         fix x
         let ?x = "of_nat x :: 'a"
         have "f (2 * x) \<le> (2 ^ Suc deg) * (p * p)"
         proof (cases "x = 0")
           case False
           hence x1: "?x \<ge> 1" by (cases x, auto)
           from x1 have x: "?x ^ (deg - 1) \<ge> 1" by simp
           from x1 have xx: "?x ^ Suc deg \<ge> 1" by (rule one_le_power)
           define c where "c = b ^ x * b ^ x * (2 ^ Suc deg)"
           have c: "c > 0" unfolding c_def using b by auto
           have "f (2 * x) = ?f (2 * x)" unfolding f_def by simp
           also have "b ^ (2 * x) = (b ^ x) * (b ^ x)" by (simp add: power2_eq_square power_even_eq)
           also have "of_nat (2 * x) = 2 * ?x" by simp
           also have "(2 * ?x) ^ Suc deg = 2 ^ Suc deg * ?x ^ Suc deg" by simp
           finally have "f (2 * x) = c * ?x ^ Suc deg" unfolding c_def by (simp add: ac_simps)
           also have "\<dots> \<le> c * ?x ^ Suc deg * ?x ^ (deg - 1)"
           proof -
             have "c * ?x ^ Suc deg > 0" using c xx by simp
             thus ?thesis unfolding mult_le_cancel_left1 using x by simp
           qed
           also have "\<dots> = c * ?x ^ (Suc deg + (deg - 1))" by (simp add: power_add)
           also have "Suc deg + (deg - 1) = deg + deg" using deg by simp
           also have "?x ^ (deg + deg) = (?x ^ deg) * (?x ^ deg)" by (simp add: power_add)
           also have "c * \<dots> = (2 ^ Suc deg) * ((b ^ x * ?x ^ deg) * (b ^ x * ?x ^ deg))" 
             unfolding c_def by (simp add: ac_simps)  
           also have "\<dots> \<le> (2 ^ Suc deg) * (p * p)"
             by (rule mult_left_mono[OF mult_mono[OF IH IH p]], insert pow_zero[of x], auto)
           finally show "f (2 * x) \<le> (2 ^ Suc deg) * (p * p)" .
         qed (auto simp: f_def)
         hence "?f (2 * x) \<le> (2 ^ Suc deg) * (p * p)" unfolding f_def .
       } note even = this
       show ?thesis
       proof (rule exI[of _ p'], intro allI)
         fix y
         show "?f y \<le> p'"
         proof (cases "even y")
           case True
           define x where "x = y div 2"
           have "y = 2 * x" unfolding x_def using True by simp
           from even[of x, folded this] have "?f y \<le> 2 ^ Suc deg * (p * p)" .
           also have "\<dots> \<le> \<dots> * inverse b"
-            unfolding mult_le_cancel_left1 using b p by (simp add:sign_simps one_le_inverse)
+            unfolding mult_le_cancel_left1 using b p
+            by (simp add: sign_simps one_le_inverse)
           also have "\<dots> = p'" unfolding p'_def by (simp add: ac_simps)
           finally show "?f y \<le> p'" .
         next
           case False
           define x where "x = y div 2"
           have "y = 2 * x + 1" unfolding x_def using False by simp
           hence "?f y = ?f (2 * x + 1)" by simp
           also have "\<dots> \<le> b ^ (2 * x + 1) * of_nat (2 * x + 2) ^ Suc deg"
             by (rule mult_left_mono[OF power_mono], insert b, auto) 
           also have "b ^ (2 * x + 1) = b ^ (2 * x + 2) * inverse b" using b by auto
           also have "b ^ (2 * x + 2) * inverse b * of_nat (2 * x + 2) ^ Suc deg = 
             inverse b * ?f (2 * (x + 1))" by (simp add: ac_simps)
           also have "\<dots> \<le> inverse b * ((2 ^ Suc deg) * (p * p))"
             by (rule mult_left_mono[OF even], insert b, auto)
           also have "\<dots> = p'" unfolding p'_def by (simp add: ac_simps)
           finally show "?f y \<le> p'" .
         qed
       qed
     qed
   qed
 qed
 end
 
 lemma prod_list_replicate[simp]: "prod_list (replicate n a) = a ^ n"
   by (induct n, auto)
 
 lemma prod_list_power: fixes xs :: "'a :: comm_monoid_mult list"
   shows "prod_list xs ^ n = (\<Prod>x\<leftarrow>xs. x ^ n)"
   by (induct xs, auto simp: power_mult_distrib)
 
 lemma set_upt_Suc: "{0 ..< Suc i} = insert i {0 ..< i}"
   by (fact atLeast0_lessThan_Suc)
 
 lemma prod_pow[simp]: "(\<Prod>i = 0..<n. p) = (p :: 'a :: comm_monoid_mult) ^ n"
   by (induct n, auto simp: set_upt_Suc)
 
 
 (* GCD and LCM part *)
 
 lemma dvd_abs_mult_left_int [simp]:
   "\<bar>a\<bar> * y dvd x \<longleftrightarrow> a * y dvd x" for x y a :: int
   using abs_dvd_iff [of "a * y"] abs_dvd_iff [of "\<bar>a\<bar> * y"]
   by (simp add: abs_mult)
   
 lemma gcd_abs_mult_right_int [simp]:
   "gcd x (\<bar>a\<bar> * y) = gcd x (a * y)" for x y a :: int
   using gcd_abs2_int [of _ "a * y"] gcd_abs2_int [of _ "\<bar>a\<bar> * y"]
   by (simp add: abs_mult)
 
 lemma lcm_abs_mult_right_int [simp]:
   "lcm x (\<bar>a\<bar> * y) = lcm x (a * y)" for x y a :: int
   using lcm_abs2_int [of _ "a * y"] lcm_abs2_int [of _ "\<bar>a\<bar> * y"]
   by (simp add: abs_mult)
 
 lemma gcd_abs_mult_left_int [simp]:
   "gcd x (a * \<bar>y\<bar>) = gcd x (a * y)" for x y a :: int
   using gcd_abs2_int [of _ "a * \<bar>y\<bar>"] gcd_abs2_int [of _ "a * y"]
   by (simp add: abs_mult)
 
 lemma lcm_abs_mult_left_int [simp]:
   "lcm x (a * \<bar>y\<bar>) = lcm x (a * y)" for x y a :: int
   using lcm_abs2_int [of _ "a * \<bar>y\<bar>"] lcm_abs2_int [of _ "a * y"]
   by (simp add: abs_mult)
 
 
 abbreviation (input) list_gcd :: "'a :: semiring_gcd list \<Rightarrow> 'a" where
   "list_gcd \<equiv> gcd_list"
 
 abbreviation (input) list_lcm :: "'a :: semiring_gcd list \<Rightarrow> 'a" where
   "list_lcm \<equiv> lcm_list"
 
 
 lemma list_gcd_simps: "list_gcd [] = 0" "list_gcd (x # xs) = gcd x (list_gcd xs)"
   by simp_all
 
 lemma list_gcd: "x \<in> set xs \<Longrightarrow> list_gcd xs dvd x"
   by (fact Gcd_fin_dvd)
 
 lemma list_gcd_greatest: "(\<And> x. x \<in> set xs \<Longrightarrow> y dvd x) \<Longrightarrow> y dvd (list_gcd xs)"
   by (fact gcd_list_greatest)
 
 lemma list_gcd_mult_int [simp]: 
   fixes xs :: "int list"
   shows "list_gcd (map (times a) xs) = \<bar>a\<bar> * list_gcd xs"
   by (simp add: Gcd_mult)
 
 lemma list_lcm_simps: "list_lcm [] = 1" "list_lcm (x # xs) = lcm x (list_lcm xs)"
   by simp_all
 
 lemma list_lcm: "x \<in> set xs \<Longrightarrow> x dvd list_lcm xs" 
   by (fact dvd_Lcm_fin)
 
 lemma list_lcm_least: "(\<And> x. x \<in> set xs \<Longrightarrow> x dvd y) \<Longrightarrow> list_lcm xs dvd y"
   by (fact lcm_list_least)
 
 lemma lcm_mult_distrib_nat: "(k :: nat) * lcm m n = lcm (k * m) (k * n)"
   by (simp add: lcm_mult_left)
 
 lemma lcm_mult_distrib_int: "abs (k::int) * lcm m n = lcm (k * m) (k * n)"
   by (simp add: lcm_mult_left)
 
 lemma list_lcm_mult_int [simp]:
   fixes xs :: "int list"
   shows "list_lcm (map (times a) xs) = (if xs = [] then 1 else \<bar>a\<bar> * list_lcm xs)"
   by (simp add: Lcm_mult)
 
 lemma list_lcm_pos:
   "list_lcm xs \<ge> (0 :: int)"
   "0 \<notin> set xs \<Longrightarrow> list_lcm xs \<noteq> 0"
   "0 \<notin> set xs \<Longrightarrow> list_lcm xs > 0" 
 proof -
   have "0 \<le> \<bar>Lcm (set xs)\<bar>"
     by (simp only: abs_ge_zero)
   then have "0 \<le> Lcm (set xs)"
     by simp
   then show "list_lcm xs \<ge> 0"
     by simp
   assume "0 \<notin> set xs"
   then show "list_lcm xs \<noteq> 0"
     by (simp add: Lcm_0_iff)
   with \<open>list_lcm xs \<ge> 0\<close> show "list_lcm xs > 0"
     by (simp add: le_less)
 qed
 
 lemma quotient_of_nonzero: "snd (quotient_of r) > 0" "snd (quotient_of r) \<noteq> 0"
   using quotient_of_denom_pos' [of r] by simp_all
 
 lemma quotient_of_int_div: assumes q: "quotient_of (of_int x / of_int y) = (a, b)"
   and y: "y \<noteq> 0" 
   shows "\<exists> z. z \<noteq> 0 \<and> x = a * z \<and> y = b * z"
 proof -
   let ?r = "rat_of_int"
   define z where "z = gcd x y"
   define x' where "x' = x div z"
   define y' where "y' = y div z"
   have id: "x = z * x'" "y = z * y'" unfolding x'_def y'_def z_def by auto
   from y have y': "y' \<noteq> 0" unfolding id by auto
   have z: "z \<noteq> 0" unfolding z_def using y by auto
   have cop: "coprime x' y'" unfolding x'_def y'_def z_def 
     using div_gcd_coprime y by blast
   have "?r x / ?r y = ?r x' / ?r y'" unfolding id using z y y' by (auto simp: field_simps) 
   from assms[unfolded this] have quot: "quotient_of (?r x' / ?r y') = (a, b)" by auto
   from quotient_of_coprime[OF quot] have cop': "coprime a b" .
   hence cop: "coprime b a"
     by (simp add: ac_simps)
   from quotient_of_denom_pos[OF quot] have b: "b > 0" "b \<noteq> 0" by auto
   from quotient_of_div[OF quot] quotient_of_denom_pos[OF quot] y'
   have "?r x' * ?r b = ?r a * ?r y'" by (auto simp: field_simps)
   hence id': "x' * b = a * y'" unfolding of_int_mult[symmetric] by linarith
   from id'[symmetric] have "b dvd y' * a" unfolding mult.commute[of y'] by auto
   with cop y' have "b dvd y'"
     by (simp add: coprime_dvd_mult_left_iff) 
   then obtain z' where ybz: "y' = b * z'" unfolding dvd_def by auto
   from id[unfolded y' this] have y: "y = b * (z * z')" by auto
   with \<open>y \<noteq> 0\<close> have zz: "z * z' \<noteq> 0" by auto
   from quotient_of_div[OF q] \<open>y \<noteq> 0\<close> \<open>b \<noteq> 0\<close> 
   have "?r x * ?r b = ?r y * ?r a" by (auto simp: field_simps)
   hence id': "x * b = y * a" unfolding of_int_mult[symmetric] by linarith
   from this[unfolded y] b have x: "x = a * (z * z')" by auto
   show ?thesis unfolding x y using zz by blast
 qed
 
 fun max_list_non_empty :: "('a :: linorder) list \<Rightarrow> 'a" where
   "max_list_non_empty [x] = x"
 | "max_list_non_empty (x # xs) = max x (max_list_non_empty xs)"
 
 lemma max_list_non_empty: "x \<in> set xs \<Longrightarrow> x \<le> max_list_non_empty xs"
 proof (induct xs)
   case (Cons y ys) note oCons = this
   show ?case 
   proof (cases ys)
     case (Cons z zs)
     hence id: "max_list_non_empty (y # ys) = max y (max_list_non_empty ys)" by simp
     from oCons show ?thesis unfolding id by (auto simp: max.coboundedI2)
   qed (insert oCons, auto)
 qed simp
 
 lemma cnj_reals[simp]: "(cnj c \<in> \<real>) = (c \<in> \<real>)"
   using Reals_cnj_iff by fastforce
 
 lemma sgn_real_mono: "x \<le> y \<Longrightarrow> sgn x \<le> sgn (y :: real)"
   unfolding sgn_real_def
   by (auto split: if_splits)
 
 lemma sgn_minus_rat: "sgn (- (x :: rat)) = - sgn x"
   by (fact Rings.sgn_minus)
 
 lemma real_of_rat_sgn: "sgn (of_rat x) = real_of_rat (sgn x)"
   unfolding sgn_real_def sgn_rat_def by auto
 
 lemma inverse_le_iff_sgn: assumes sgn: "sgn x = sgn y"
   shows "(inverse (x :: real) \<le> inverse y) = (y \<le> x)"
 proof (cases "x = 0")
   case True
   with sgn have "sgn y = 0" by simp
   hence "y = 0" unfolding sgn_real_def by (cases "y = 0"; cases "y < 0"; auto)
   thus ?thesis using True by simp
 next
   case False note x = this
   show ?thesis
   proof (cases "x < 0")
     case True
     with x sgn have "sgn y = -1" by simp
     hence "y < 0" unfolding sgn_real_def by (cases "y = 0"; cases "y < 0", auto)
     show ?thesis
       by (rule inverse_le_iff_le_neg[OF True \<open>y < 0\<close>])
   next
     case False
     with x have x: "x > 0" by auto
     with sgn have "sgn y = 1" by auto
     hence "y > 0" unfolding sgn_real_def by (cases "y = 0"; cases "y < 0", auto)
     show ?thesis
       by (rule inverse_le_iff_le[OF x \<open>y > 0\<close>])
   qed
 qed
 
 lemma inverse_le_sgn: assumes sgn: "sgn x = sgn y" and xy: "x \<le> (y :: real)"
   shows "inverse y \<le> inverse x"
   using xy inverse_le_iff_sgn[OF sgn] by auto
 
 lemma set_list_update: "set (xs [i := k]) = 
   (if i < length xs then insert k (set (take i xs) \<union> set (drop (Suc i) xs)) else set xs)"
 proof (induct xs arbitrary: i)
   case (Cons x xs i) 
   thus ?case
     by (cases i, auto)
 qed simp
 
 lemma prod_list_dvd: assumes "(x :: 'a :: comm_monoid_mult) \<in> set xs"
   shows "x dvd prod_list xs"
 proof -
   from assms[unfolded in_set_conv_decomp] obtain ys zs where xs: "xs = ys @ x # zs" by auto
   show ?thesis unfolding xs dvd_def by (intro exI[of _ "prod_list (ys @ zs)"], simp add: ac_simps)
 qed
 
 lemma dvd_prod: 
 fixes A::"'b set" 
 assumes "\<exists>b\<in>A. a dvd f b" "finite A"
 shows "a dvd prod f A" 
 using assms(2,1)
 proof (induct A)
   case (insert x A)
   thus ?case 
     using comm_monoid_mult_class.dvd_mult dvd_mult2 insert_iff prod.insert by auto
 qed auto
 
 context
   fixes xs :: "'a :: comm_monoid_mult list"
 begin
 lemma prod_list_filter: "prod_list (filter f xs) * prod_list (filter (\<lambda> x. \<not> f x) xs) = prod_list xs"
   by (induct xs, auto simp: ac_simps)
 
 lemma prod_list_partition: assumes "partition f xs = (ys, zs)"
   shows "prod_list xs = prod_list ys * prod_list zs"
   using assms by (subst prod_list_filter[symmetric, of f], auto simp: o_def)
 end
 
 lemma dvd_imp_mult_div_cancel_left[simp]:
   assumes "(a :: 'a :: semidom_divide) dvd b"
   shows "a * (b div a) = b"
 proof(cases "b = 0")
   case True then show ?thesis by auto
 next
   case False
   with dvdE[OF assms] obtain c where *: "b = a * c" by auto
   also with False have "a \<noteq> 0" by auto
   then have "a * c div a = c" by auto
   also note *[symmetric]
   finally show ?thesis.
 qed
 
 lemma (in semidom) prod_list_zero_iff[simp]: 
   "prod_list xs = 0 \<longleftrightarrow> 0 \<in> set xs" by (induction xs, auto)
 
 
 context comm_monoid_mult begin
 
 lemma unit_prod [intro]:
   shows "a dvd 1 \<Longrightarrow> b dvd 1 \<Longrightarrow> (a * b) dvd 1"
   by (subst mult_1_left [of 1, symmetric]) (rule mult_dvd_mono)
 
 lemma is_unit_mult_iff[simp]:
   shows "(a * b) dvd 1 \<longleftrightarrow> a dvd 1 \<and> b dvd 1"
   by (auto dest: dvd_mult_left dvd_mult_right)
 
 end
 
 context comm_semiring_1
 begin
 lemma irreducibleE[elim]:
   assumes "irreducible p"
       and "p \<noteq> 0 \<Longrightarrow> \<not> p dvd 1 \<Longrightarrow> (\<And>a b. p = a * b \<Longrightarrow> a dvd 1 \<or> b dvd 1) \<Longrightarrow> thesis"
   shows thesis using assms by (auto simp: irreducible_def)
 
 lemma not_irreducibleE:
   assumes "\<not> irreducible x"
       and "x = 0 \<Longrightarrow> thesis"
       and "x dvd 1 \<Longrightarrow> thesis"
       and "\<And>a b. x = a * b \<Longrightarrow> \<not> a dvd 1 \<Longrightarrow> \<not> b dvd 1 \<Longrightarrow> thesis"
   shows thesis using assms unfolding irreducible_def by auto
 
 lemma prime_elem_dvd_prod_list:
   assumes p: "prime_elem p" and pA: "p dvd prod_list A" shows "\<exists>a \<in> set A. p dvd a"
 proof(insert pA, induct A)
   case Nil
   with p show ?case by (simp add: prime_elem_not_unit)
 next
   case (Cons a A)
   then show ?case by (auto simp: prime_elem_dvd_mult_iff[OF p])
 qed
 
 lemma prime_elem_dvd_prod_mset:
   assumes p: "prime_elem p" and pA: "p dvd prod_mset A" shows "\<exists>a \<in># A. p dvd a"
 proof(insert pA, induct A)
   case empty
   with p show ?case by (simp add: prime_elem_not_unit)
 next
   case (add a A)
   then show ?case by (auto simp: prime_elem_dvd_mult_iff[OF p])
 qed
 
 lemma mult_unit_dvd_iff[simp]:
   assumes "b dvd 1"
   shows "a * b dvd c \<longleftrightarrow> a dvd c"
 proof
   assume "a * b dvd c"
   with assms show "a dvd c" using dvd_mult_left[of a b c] by simp
 next
   assume "a dvd c"
   with assms mult_dvd_mono show "a * b dvd c" by fastforce
 qed
 
 lemma mult_unit_dvd_iff'[simp]: "a dvd 1 \<Longrightarrow> (a * b) dvd c \<longleftrightarrow> b dvd c"
   using mult_unit_dvd_iff [of a b c] by (simp add: ac_simps)
 
 lemma irreducibleD':
   assumes "irreducible a" "b dvd a"
   shows   "a dvd b \<or> b dvd 1"
 proof -
   from assms obtain c where c: "a = b * c" by (elim dvdE)
   from irreducibleD[OF assms(1) this] have "b dvd 1 \<or> c dvd 1" .
   thus ?thesis by (auto simp: c)
 qed
 
 end
 
 
 
 context idom
 begin
 
 text \<open>
   Following lemmas are adapted and generalized so that they don't use "algebraic" classes.
 \<close>
 
 lemma dvd_times_left_cancel_iff [simp]:
   assumes "a \<noteq> 0"
   shows "a * b dvd a * c \<longleftrightarrow> b dvd c"
     (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   then obtain d where "a * c = a * b * d" ..
   with assms have "c = b * d" by (auto simp add: ac_simps)
   then show ?rhs ..
 next
   assume ?rhs
   then obtain d where "c = b * d" ..
   then have "a * c = a * b * d" by (simp add: ac_simps)
   then show ?lhs ..
 qed
 
 lemma dvd_times_right_cancel_iff [simp]:
   assumes "a \<noteq> 0"
   shows "b * a dvd c * a \<longleftrightarrow> b dvd c"
   using dvd_times_left_cancel_iff [of a b c] assms by (simp add: ac_simps)
 
 
 lemma irreducibleI':
   assumes "a \<noteq> 0" "\<not> a dvd 1" "\<And>b. b dvd a \<Longrightarrow> a dvd b \<or> b dvd 1"
   shows   "irreducible a"
 proof (rule irreducibleI)
   fix b c assume a_eq: "a = b * c"
   hence "a dvd b \<or> b dvd 1" by (intro assms) simp_all
   thus "b dvd 1 \<or> c dvd 1"
   proof
     assume "a dvd b"
     hence "b * c dvd b * 1" by (simp add: a_eq)
     moreover from \<open>a \<noteq> 0\<close> a_eq have "b \<noteq> 0" by auto
     ultimately show ?thesis using dvd_times_left_cancel_iff by fastforce
   qed blast
 qed (simp_all add: assms(1,2))
 
 lemma irreducible_altdef:
   shows "irreducible x \<longleftrightarrow> x \<noteq> 0 \<and> \<not> x dvd 1 \<and> (\<forall>b. b dvd x \<longrightarrow> x dvd b \<or> b dvd 1)"
   using irreducibleI'[of x] irreducibleD'[of x] irreducible_not_unit[of x] by auto
 
 lemma dvd_mult_unit_iff:
   assumes b: "b dvd 1"
   shows "a dvd c * b \<longleftrightarrow> a dvd c"
 proof-
   from b obtain b' where 1: "b * b' = 1" by (elim dvdE, auto)
   then have b0: "b \<noteq> 0" by auto
   from 1 have "a = (a * b') * b" by (simp add: ac_simps)
   also have "\<dots> dvd c * b \<longleftrightarrow> a * b' dvd c" using b0 by auto
   finally show ?thesis by (auto intro: dvd_mult_left)
 qed
 
 lemma dvd_mult_unit_iff': "b dvd 1 \<Longrightarrow> a dvd b * c \<longleftrightarrow> a dvd c"
   using dvd_mult_unit_iff [of b a c] by (simp add: ac_simps)
 
 lemma irreducible_mult_unit_left:
   shows "a dvd 1 \<Longrightarrow> irreducible (a * p) \<longleftrightarrow> irreducible p"
   by (auto simp: irreducible_altdef mult.commute[of a] dvd_mult_unit_iff)
 
 lemma irreducible_mult_unit_right:
   shows "a dvd 1 \<Longrightarrow> irreducible (p * a) \<longleftrightarrow> irreducible p"
   by (auto simp: irreducible_altdef mult.commute[of a] dvd_mult_unit_iff)
 
 lemma prime_elem_imp_irreducible:
   assumes "prime_elem p"
   shows   "irreducible p"
 proof (rule irreducibleI)
   fix a b
   assume p_eq: "p = a * b"
   with assms have nz: "a \<noteq> 0" "b \<noteq> 0" by auto
   from p_eq have "p dvd a * b" by simp
   with \<open>prime_elem p\<close> have "p dvd a \<or> p dvd b" by (rule prime_elem_dvd_multD)
   with \<open>p = a * b\<close> have "a * b dvd 1 * b \<or> a * b dvd a * 1" by auto
   thus "a dvd 1 \<or> b dvd 1"
     by (simp only: dvd_times_left_cancel_iff[OF nz(1)] dvd_times_right_cancel_iff[OF nz(2)])
 qed (insert assms, simp_all add: prime_elem_def)
 
 lemma unit_imp_dvd [dest]: "b dvd 1 \<Longrightarrow> b dvd a"
   by (rule dvd_trans [of _ 1]) simp_all
 
 lemma unit_mult_left_cancel: "a dvd 1 \<Longrightarrow> a * b = a * c \<longleftrightarrow> b = c"
   using mult_cancel_left [of a b c] by auto
 
 lemma unit_mult_right_cancel: "a dvd 1 \<Longrightarrow> b * a = c * a \<longleftrightarrow> b = c"
   using unit_mult_left_cancel [of a b c] by (auto simp add: ac_simps)
 
 text \<open>New parts from here\<close>
 
 lemma irreducible_multD:
   assumes l: "irreducible (a*b)"
   shows "a dvd 1 \<and> irreducible b \<or> b dvd 1 \<and> irreducible a"
 proof-
   from l have "a dvd 1 \<or> b dvd 1" using irreducibleD by auto
   then show ?thesis
   proof(elim disjE)
     assume a: "a dvd 1"
     with l have "irreducible b"
       unfolding irreducible_def
       by (metis is_unit_mult_iff mult.left_commute mult_not_zero)
     with a show ?thesis by auto
   next
     assume a: "b dvd 1"
     with l have "irreducible a"
       unfolding irreducible_def
       by (meson is_unit_mult_iff mult_not_zero semiring_normalization_rules(16))
     with a show ?thesis by auto
   qed
 qed
 
 end
 
 lemma (in field) irreducible_field[simp]:
   "irreducible x \<longleftrightarrow> False" by (auto simp: dvd_field_iff irreducible_def)
 
 lemma (in idom) irreducible_mult:
   shows "irreducible (a*b) \<longleftrightarrow> a dvd 1 \<and> irreducible b \<or> b dvd 1 \<and> irreducible a"
   by (auto dest: irreducible_multD simp: irreducible_mult_unit_left irreducible_mult_unit_right)
 
 
 end
diff --git a/thys/Source_Coding_Theorem/Source_Coding_Theorem.thy b/thys/Source_Coding_Theorem/Source_Coding_Theorem.thy
--- a/thys/Source_Coding_Theorem/Source_Coding_Theorem.thy
+++ b/thys/Source_Coding_Theorem/Source_Coding_Theorem.thy
@@ -1,603 +1,603 @@
 (* Title:       One Part of Shannon's Source Coding Theorem
    Author:      Quentin Hibon <qh225@cl.cam.ac.uk>, Lawrence Paulson <lp15@cam.ac.uk>, 2014
    Maintainer:  Quentin Hibon <qh225@cl.cam.ac.uk>
 *)
 
 theory Source_Coding_Theorem
 imports "HOL-Probability.Information"
 begin
 section\<open>Basic types\<close>
 
 type_synonym bit = bool
 type_synonym bword = "bit list"
 type_synonym letter = nat
 type_synonym 'b word = "'b list"
 
 type_synonym 'b encoder = "'b word \<Rightarrow> bword"
 type_synonym 'b decoder = "bword \<Rightarrow> 'b word option"
 
 section\<open>Locale for the source coding theorem\<close>
 locale source_code = information_space +
   fixes fi :: "'b \<Rightarrow> real"
   fixes X :: "'a \<Rightarrow> 'b"
 
   assumes distr_i: "simple_distributed M X fi"
   assumes b_val: "b = 2"
 
   fixes enc::"'b encoder"
   fixes dec::"'b decoder"
   assumes real_code:
   "dec (enc x) = Some x"
   "enc w = [] \<longleftrightarrow> w = []"
   "x \<noteq> [] \<longrightarrow> enc x = enc [hd x] @ enc (tl x)"
 
 section\<open>Source coding theorem, direct: the entropy is a lower bound of the code rate\<close>
 context source_code
 begin
 subsection\<open>The letter set\<close>
 
 definition L :: "'b set" where
   "L \<equiv> X ` space M"
 
 lemma fin_L: "finite L"
     using L_def distr_i
     by auto
 
 lemma emp_L: "L \<noteq> {}"
     using L_def subprob_not_empty
     by auto
 
 subsection\<open>Codes and words\<close>
 
 abbreviation real_word :: "'b word \<Rightarrow> bool" where
   "real_word w \<equiv> (set w \<subseteq> L)"
 
 abbreviation k_words :: "nat \<Rightarrow> ('b word) set" where
   "k_words k \<equiv> {w. length w = k \<and> real_word w}"
 
 lemma rw_tail:
   assumes "real_word w"
 shows "w = [] \<or> real_word (tl w)"
     by (meson assms list.set_sel(2) subset_code(1))
 
 definition code_word_length :: "'e encoder \<Rightarrow> 'e \<Rightarrow> nat" where
   "code_word_length e l = length (e [l])"
 
 abbreviation cw_len :: "'b \<Rightarrow> nat" where
   "cw_len l \<equiv> code_word_length enc l"
 
 definition code_rate :: "'e encoder \<Rightarrow> ('a \<Rightarrow> 'e) \<Rightarrow> real" where
   "code_rate e Xo = expectation (\<lambda>a. (code_word_length e ((Xo) a)))"
 
 lemma fi_pos: "i\<in> L \<Longrightarrow> 0 \<le> fi i"
     using simple_distributed_nonneg[OF distr_i] L_def by auto
 
 lemma (in prob_space) simp_exp_composed:
   assumes X: "simple_distributed M X Px"
 shows "expectation (\<lambda>a. f (X a)) = (\<Sum>x \<in> X`space M. f x * Px x)"
   using distributed_integral[OF simple_distributed[OF X], of f]
     simple_distributed_nonneg[OF X]
     lebesgue_integral_count_space_finite[OF simple_distributed_finite[OF X], of "\<lambda>x. f x * Px x"]
   by (simp add:  ac_simps)
 
 lemma cr_rw:
   "code_rate enc X = (\<Sum>i \<in> X ` space M. fi i * cw_len i)"
     using simp_exp_composed[OF distr_i, of "cw_len"]
     by (simp add: mult.commute code_rate_def)
 
 abbreviation cw_len_concat :: "'b word \<Rightarrow> nat" where
   "cw_len_concat w \<equiv> foldr (\<lambda>x s. (cw_len x) + s) w 0"
 
 lemma cw_len_length: "cw_len_concat w = length (enc w)"
 proof (induction w)
     case Nil
     show ?case using real_code by simp
     case (Cons a w)
     have "cw_len_concat (a # w) = cw_len a + cw_len_concat w" by simp
     thus ?case using code_word_length_def real_code Cons
       by (metis length_append list.distinct(1) list.sel(1) list.sel(3))
 qed
 
 lemma maj_fold:
   assumes "\<And>l. l\<in>L \<Longrightarrow> f l \<le> bound"
   assumes "real_word w"
 shows "foldr (\<lambda>x s. f x + s) w 0 \<le> length w * bound"
     using assms
     by(induction w) (simp,fastforce)
 
 definition max_len :: "nat" where
   "max_len = Max ((\<lambda>x. cw_len x) ` L)"
 
 lemma max_cw:
   "l \<in> L \<Longrightarrow> cw_len l \<le> max_len"
     by (simp add: max_len_def fin_L)
 
 subsection\<open>Related to the Kraft theorem\<close>
 definition \<K> :: "real" where
   "\<K> = (\<Sum>i\<in>L. 1 / b ^ (cw_len i))"
 
 lemma pos_cw_len: "0 < 1 / b ^ cw_len i" using b_gt_1 by simp
 
 lemma \<K>_pos: "0 < \<K>"
     using emp_L fin_L pos_cw_len sum_pos \<K>_def
     by metis
 
 lemma \<K>_pow: "\<K> = (\<Sum>i\<in>L. 1 / b powr cw_len i)"
     using powr_realpow b_gt_1
     by (simp add: \<K>_def)
 
 lemma k_words_rel:
   "k_words (Suc k) = {w. (hd w \<in> L \<and> tl w \<in> k_words k \<and> w \<noteq> [])}"
 proof
     fix k
     show "k_words (Suc k) \<subseteq> {w. (hd w \<in> L \<and> tl w \<in> k_words k \<and> w \<noteq> [] )}" (is "?l \<subseteq> ?r")
   proof
       fix w
       assume w_kw: "w \<in> k_words (Suc k)"
       hence "real_word w" by simp
       hence "hd w \<in> L"
         by (metis (mono_tags) w_kw hd_in_set list.size(3) mem_Collect_eq nat.distinct(1) subset_code(1))
       moreover have "length w = Suc k" using w_kw by simp
       moreover hence "w \<noteq> []" by auto
       moreover have "real_word (tl w)" using \<open>real_word w\<close> calculation(3) rw_tail by auto
       ultimately show "w \<in> ?r" using w_kw by simp
   qed
 next
     fix k
     show "k_words (Suc k) \<supseteq> {w. (hd w \<in> L \<and> tl w \<in> k_words k \<and> w \<noteq> [])}"
   proof
       fix w
       assume asm: "w \<in> {w. hd w \<in> L \<and> tl w \<in> {w. length w = k \<and> real_word w} \<and> w \<noteq> []}"
       hence "hd w \<in> L \<and> length (tl w) = k \<and> real_word (tl w)" by simp
       hence "real_word w"
         by (metis empty_iff insert_subset list.collapse list.set(1) set_simps(2) subsetI)
       moreover hence "length w = Suc k" using asm by auto
       ultimately show "w \<in> k_words (Suc k)" by simp
   qed
 qed
 
 lemma bij_k_words:
 shows "bij_betw (\<lambda>wi. Cons (fst wi) (snd wi)) (L \<times> k_words k) (k_words (Suc k))"
     unfolding bij_betw_def
 proof
     fix k
     let ?f = "(\<lambda>wi. Cons (fst wi) (snd wi))"
     let ?S = "L \<times> (k_words k)"
     let ?T = "k_words (Suc k)"
     show "inj_on ?f ?S" by (simp add: inj_on_def)
     show "?f`?S = ?T"
   proof (rule ccontr)
       assume "?f ` ?S \<noteq> ?T"
       hence "\<exists>w. w\<in> ?T \<and> w \<notin> ?f`?S" by auto
       then obtain w where asm: "w\<in> ?T \<and> w \<notin> ?f`?S" by blast
       hence "w = ?f (hd w,tl w)" using k_words_rel by simp
       moreover have "(hd w,tl w) \<in> ?S" using k_words_rel asm by simp
       ultimately have "w \<in> ?f`?S" by blast
       thus "False" using asm by simp
   qed
 qed
 
 lemma finite_k_words: "finite (k_words k)"
 proof (induct k)
     case 0
     show ?case by simp
     case (Suc n)
     thus ?case using bij_k_words bij_betw_finite fin_L by blast
 qed
 
 lemma cartesian_product:
   fixes f::"('c \<Rightarrow> real)"
   fixes g::"('d \<Rightarrow> real)"
   assumes "finite A"
   assumes "finite B"
 shows "(\<Sum>b\<in>B. g b) * (\<Sum>a\<in>A. f a) = (\<Sum>ab\<in>A\<times>B. f (fst ab) * g (snd ab))"
     using bilinear_times bilinear_sum[where h="(\<lambda>x y. x * y)" and f="f" and g="g"] assms
     by (metis (erased, lifting) sum.cong split_beta' Groups.ab_semigroup_mult_class.mult.commute)
 
 lemma \<K>_power:
 shows "\<K>^k = (\<Sum>w \<in> (k_words k). 1 / b^(cw_len_concat w))"
 proof (induct k)
     case 0
     have "k_words 0 = {[]}" by auto
     thus ?case by simp
 next
     case (Suc n)
     have " \<K> ^Suc n = \<K> ^n * \<K> " by simp
     also have "\<dots> = (\<Sum>w \<in> k_words n. 1 / b^cw_len_concat w) * (\<Sum>i\<in>L. 1 / b^cw_len i)"
       using Suc.hyps \<K>_def by auto
     also have "\<dots> = (\<Sum>wi \<in> L \<times> k_words n. 1/b^cw_len (fst wi) * (1 / b^cw_len_concat (snd wi)))"
       using fin_L finite_k_words cartesian_product
       by blast
     also have "\<dots> = (\<Sum>wi \<in> L \<times> k_words n. 1 / b^(cw_len_concat (snd wi) + cw_len (fst wi)))"
       by (metis (no_types, lifting) power_add add.commute power_one_over)
     also have "\<dots> = (\<Sum>wi \<in> L \<times> k_words n. 1 / b^cw_len_concat (fst wi # snd wi))"
       by (metis (erased, lifting) add.commute comp_apply foldr.simps(2))
     also have "\<dots> = (\<Sum>w \<in> (k_words (Suc n)). 1 / b^(cw_len_concat w))"
       using bij_k_words sum.reindex_bij_betw by fastforce
     finally show ?case by simp
 qed
 
 lemma bound_len_concat:
 shows "w \<in> k_words k \<Longrightarrow> cw_len_concat w \<le> k * max_len"
     using max_cw maj_fold by blast
 
 subsection\<open>Inequality of the kraft sum (source coding theorem, direct)\<close>
 subsubsection\<open>Sum manipulation lemmas and McMillan theorem\<close>
 
 lemma sum_vimage_proof:
   fixes g::"nat \<Rightarrow> real"
   assumes "\<And>w. f w < bd"
 shows "finite S \<Longrightarrow> (\<Sum>w\<in>S. g (f w)) = (\<Sum> m=0..<bd. (card ((f-`{m}) \<inter> S) )* g m)"
 (is "_ \<Longrightarrow> _ = (\<Sum> m=0..<bd. ?ff m S)")
 proof (induct S rule: finite_induct)
     case empty
     show ?case by simp
 next
     case (insert x F)
     let ?rr = "(\<Sum>m = 0..<bd. ?ff m (insert x F))"
     have "(f x) \<in> {0..<bd}" using assms by simp
     hence "\<And>h::(nat \<Rightarrow> real). (\<Sum>m=0..<bd. h m) = (\<Sum>y\<in>({0..<bd} - {f x}).h y) + h (f x)"
       by (metis diff_add_cancel finite_atLeastLessThan sum_diff1)
     moreover hence
     "(\<Sum>m = 0..<bd. ?ff m (insert x F))
     = (\<Sum>m\<in>{0..<bd} - {f x}. ?ff m (insert x F)) + card (f -` {f x} \<inter> F) * g (f x) + g (f x)"
       by (simp add: semiring_normalization_rules(2), simp add: insert)
     ultimately have "(\<Sum>m = 0..<bd. ?ff m (insert x F)) = (\<Sum>m\<in>{0..<bd}. ?ff m F) + g (f x)"
       by fastforce
     thus ?case using insert by simp
 qed
 
 lemma sum_vimage:
   fixes g::"nat \<Rightarrow> real"
   assumes bounded: "\<And>w. w \<in> S \<Longrightarrow> f w < bd" and "0 < bd"
   assumes finite: "finite S"
 shows "(\<Sum>w\<in>S. g (f w)) = (\<Sum> m=0..<bd. (card ((f-`{m}) \<inter> S) ) * g m)"
 (is "?s1 = ?s2")
 proof -
     let ?ff = "(\<lambda>x. if x\<in>S then f x else 0)"
     let ?ss1 = "(\<Sum>w\<in>S. g (?ff w))"
     let ?ss2 = "(\<Sum> m=0..<bd. (card ((?ff-`{m}) \<inter> S) ) * g m)"
     have "?s1 =?ss1" by simp
     moreover have"\<And>m. ?ff -`{m} \<inter> S = f-`{m} \<inter> S" by auto
     moreover hence "?s2 = ?ss2" by simp
     moreover have "\<And>w . ?ff w < bd" using assms by simp
     moreover hence "?ss1 = ?ss2" using sum_vimage_proof[of "?ff"] finite by blast
     ultimately show "?s1 = ?s2" by metis
 qed
 
 lemma \<K>_rw:
   "(\<Sum>w \<in> (k_words k). 1 / b^(cw_len_concat w)) = (\<Sum>m=0..<Suc (k*max_len). card (k_words k \<inter>
 ((cw_len_concat) -` {m})) * (1 / b^m))" (is "?L = ?R")
 proof -
     have "\<And>w. w \<in> k_words k \<Longrightarrow> cw_len_concat w < Suc ( k * max_len)"
       by (simp add: bound_len_concat le_imp_less_Suc)
     moreover have
     "?R = (\<Sum>m = 0..<Suc (k * max_len).
   (card (cw_len_concat -` {m} \<inter> k_words k)) * (1 / b ^ m))"
       by (metis Int_commute)
     moreover have "0 < Suc (k*max_len)" by simp
     ultimately show ?thesis
       using finite_k_words
     sum_vimage[where f="cw_len_concat" and g = "\<lambda>i. 1/ (b^i)"]
       by fastforce
 qed
 
 definition set_of_k_words_length_m :: "nat \<Rightarrow> nat \<Rightarrow> 'b word set" where
   "set_of_k_words_length_m k m = {xk. xk \<in> k_words k} \<inter> (cw_len_concat)-`{m}"
 
 lemma am_inj_code: "inj_on enc ((cw_len_concat)-`{m})" (is "inj_on _ ?s")
   using inj_on_def[of enc "?s"] real_code
   by (metis option.inject)
 
 lemma img_inc: "enc`cw_len_concat-`{m} \<subseteq> {bl. length bl = m}" using cw_len_length by auto
 
 lemma bool_lists_card: "card {bl::bool list. length bl = m} = b^m"
  using card_lists_length_eq[of "UNIV::bool set"]
   by (simp add: b_val)
 
 lemma bool_list_fin: "finite {bl::bool list. length bl = m}"
   using finite_lists_length_eq[of "UNIV::bool set"]
   by (simp add: b_val)
 
 lemma set_of_k_words_bound:
 shows "card (set_of_k_words_length_m k m) \<le> b^m" (is "?c \<le> ?b")
 proof -
     have card_w_len_m_bound: "card (cw_len_concat-`{m}) \<le> b^m"
       by (metis (no_types, lifting) am_inj_code bool_list_fin bool_lists_card card_image card_mono
     img_inc of_nat_le_iff)
     have "set_of_k_words_length_m k m \<subseteq> (cw_len_concat)-`{m}"
       by (simp add: set_of_k_words_length_m_def)
     hence "card (set_of_k_words_length_m k m) \<le> card ((cw_len_concat)-`{m})"
       by (metis (no_types, lifting) am_inj_code bool_list_fin card.infinite card_0_eq
     card_image card_mono empty_iff finite_subset img_inc inf_img_fin_dom)
     thus ?thesis using card_w_len_m_bound by simp
 qed
 
 lemma empty_set_k_words:
   assumes "0 < k"
 shows "set_of_k_words_length_m k 0 = {}"
 proof(rule ccontr)
     assume "\<not> set_of_k_words_length_m k 0 = {}"
     hence "\<exists>x. x \<in> set_of_k_words_length_m k 0" by auto
     then obtain x where x_def: "x \<in> set_of_k_words_length_m k 0" by auto
     hence "x \<noteq> []" unfolding set_of_k_words_length_m_def using assms by auto
     moreover have "cw_len_concat (hd x#tl x) = cw_len_concat (tl x) + cw_len (hd x)"
       by (metis add.commute comp_apply foldr.simps(2))
     moreover have "enc [(hd x)] \<noteq> []" using assms real_code by blast
     moreover hence "0 < cw_len (hd x)" unfolding code_word_length_def by simp
     ultimately have "x \<notin> set_of_k_words_length_m k 0" by (simp add:set_of_k_words_length_m_def)
     thus "False" using x_def by simp
 qed
 
 lemma \<K>_rw2:
   assumes "0 < k"
 shows "(\<Sum>m=0..<Suc (k * max_len). card (set_of_k_words_length_m k m)/ b^m) \<le> (k * max_len)"
 proof -
     have
     "(\<Sum>m=1..<Suc (k * max_len). card (set_of_k_words_length_m k m) / b^m)
     \<le> (\<Sum>m=1..<Suc(k * max_len). b^m / b^m)"
       using set_of_k_words_bound b_val
     Groups_Big.sum_mono[of "{1..<Suc(k * max_len)}"
     "(\<lambda>m. (card (set_of_k_words_length_m k m))/b^m)" "\<lambda>m. b^m /b^m"]
       by simp
     moreover have"(\<Sum>m=1..<Suc(k * max_len). b^m / b^m) = (\<Sum>m=1..<Suc(k *max_len). 1)"
       using b_gt_1 by simp
     moreover have "(\<Sum>m=1..<Suc(k * max_len). 1) = (k * max_len)"
       by simp
     ultimately have
     "(\<Sum>m = 1..<Suc (k * max_len). card (set_of_k_words_length_m k m) / b ^ m) \<le> k * max_len"
       by (metis One_nat_def card_atLeastLessThan card_eq_sum diff_Suc_Suc real_of_card)
     thus ?thesis using empty_set_k_words assms
       by (simp add: sum_shift_lb_Suc0_0_upt split: if_split_asm)
 qed
 
 lemma \<K>_power_bound :
   assumes "0 < k"
 shows " \<K>^k \<le> k * max_len"
     using assms \<K>_power \<K>_rw \<K>_rw2
     by (simp add: set_of_k_words_length_m_def)
 
 theorem McMillan :
 shows "\<K> \<le> 1"
 proof -
     have ineq: "\<And>k. 0 < k \<Longrightarrow> \<K> \<le> root k k * root k max_len"
       using \<K>_pos \<K>_power_bound
       by (metis (no_types, hide_lams) not_less of_nat_0_le_iff of_nat_mult power_strict_mono real_root_mult real_root_pos_pos_le real_root_pos_unique real_root_power)
     hence "0 < max_len \<Longrightarrow> (\<lambda>k. root k k * root k max_len) \<longlonglongrightarrow> 1"
       by (auto intro!: tendsto_eq_intros LIMSEQ_root LIMSEQ_root_const)
     moreover have "\<forall>n\<ge>1. \<K> \<le> root n n * root n max_len"
       using ineq by simp
     moreover have "max_len = 0 \<Longrightarrow> \<K> \<le> 1" using ineq by fastforce
     ultimately show " \<K> \<le> 1" using LIMSEQ_le_const by blast
 qed
 
 lemma entropy_rw: "\<H>(X) = -(\<Sum>i \<in> L. fi i * log b (fi i))"
     using entropy_simple_distributed[OF distr_i]
     by (simp add: L_def)
 
 subsubsection\<open>Technical lemmas about the logarithm\<close>
 lemma log_mult_ext3:
   "0 \<le> x \<Longrightarrow> 0 < y \<Longrightarrow> 0 < z \<Longrightarrow> x * log b (x*y*z) = x * log b (x*y) + x * log b z"
     by(cases "x=0")(simp add: log_mult_eq abs_of_pos distrib_left less_eq_real_def)+
 
 lemma log_mult_ext2:
   "0 \<le> x \<Longrightarrow> 0 < y \<Longrightarrow> x * log b (x*y) = x * log b x + x * log b y"
     using log_mult_ext3[where y=1] by simp
 
 subsubsection \<open>KL divergence and properties\<close>
 definition KL_div ::"'b set \<Rightarrow> ('b \<Rightarrow> real) \<Rightarrow> ('b \<Rightarrow> real) \<Rightarrow> real" where
   "KL_div S a d = (\<Sum> i \<in> S. a i * log b (a i / d i))"
 
 lemma KL_div_mul:
   assumes "0 < d" "d \<le> 1"
   assumes "\<And>i. i\<in>S \<Longrightarrow> 0 \<le> a i"
   assumes "\<And>i. i\<in>S \<Longrightarrow> 0 < e i"
 shows "KL_div S a e \<ge> KL_div S a (\<lambda>i. e i / d)"
     unfolding KL_div_def
 proof -
     {
     fix i
     assume "i\<in>S"
     hence "a i / (e i / d) \<le> a i / e i" using assms
       by (metis (no_types) div_by_1 frac_le less_imp_triv not_less)
     hence "log b (a i / (e i / d)) \<le> log b (a i / e i)" using assms(1)
       by (metis (full_types) b_gt_1 divide_divide_eq_left inverse_divide le_less_linear log_le
     log_neg_const order_refl times_divide_eq_right zero_less_mult_iff)
     }
     thus "(\<Sum>i\<in>S. a i * log b (a i / (e i / d))) \<le> (\<Sum>i\<in>S. a i * log b (a i / e i))"
       by (meson mult_left_mono assms sum_mono)
 qed
 
 lemma KL_div_pos:
   fixes a e::"'b \<Rightarrow> real"
   assumes fin: "finite S"
   assumes nemp: "S \<noteq> {}"
   assumes non_null: "\<And>i. i\<in>S \<Longrightarrow> 0 < a i" "\<And>i. i\<in> S \<Longrightarrow> 0 < e i"
   assumes sum_a_one: "(\<Sum> i \<in> S. a i) = 1"
   assumes sum_c_one: "(\<Sum> i \<in> S. e i) = 1"
 shows "0 \<le> KL_div S a e"
     unfolding KL_div_def
 proof -
     let ?f = "\<lambda>i. e i / a i"
     have f_pos: "\<And>i. i\<in>S \<Longrightarrow> 0 < ?f i"
       using non_null
       by simp
     have a_pos: "\<And>i. i\<in> S \<Longrightarrow> 0 \<le> a i"
       using non_null
       by (simp add: order.strict_implies_order)
     have "- log b (\<Sum>i\<in>S. a i * e i / a i) \<le> (\<Sum>i\<in>S. a i * - log b (e i / a i))"
       using convex_on_sum[OF fin nemp  minus_log_convex[OF b_gt_1] convex_real_interval(3)
                              sum_a_one a_pos, of "\<lambda>i. e i / a i"] f_pos by simp
     also have "-log b (\<Sum>i\<in>S. a i * e i / a i) = -log b (\<Sum>i\<in>S. e i)"
   proof -
       from non_null(1) have "\<And>i. i \<in> S \<Longrightarrow> a i * e i / a i = e i" by force
       thus ?thesis by simp
   qed
     finally have "0 \<le> (\<Sum>i\<in>S. a i * - log b (e i / a i))"
       by (simp add: sum_c_one)
     thus "0 \<le> (\<Sum>i\<in>S. a i * log b (a i / e i))"
       using b_gt_1 log_divide non_null
       by simp
 qed
 
 lemma KL_div_pos_emp:
   "0 \<le> KL_div {} a e" by (simp add: KL_div_def)
 
 lemma KL_div_pos_gen:
   fixes a d::"'b \<Rightarrow> real"
   assumes fin: "finite S"
   assumes non_null: "\<And>i. i\<in>S \<Longrightarrow> 0 < a i" "\<And>i. i\<in> S \<Longrightarrow> 0 < d i"
   assumes sum_a_one: "(\<Sum> i \<in> S. a i) = 1"
   assumes sum_d_one: "(\<Sum> i \<in> S. d i) = 1"
 shows "0 \<le> KL_div S a d"
     using KL_div_pos KL_div_pos_emp assms by metis
 
 theorem KL_div_pos2:
   fixes a d::"'b \<Rightarrow> real"
   assumes fin: "finite S"
   assumes non_null: "\<And>i. i\<in>S \<Longrightarrow> 0 \<le> a i" "\<And>i. i\<in> S \<Longrightarrow> 0 < d i"
   assumes sum_a_one: "(\<Sum> i \<in> S. a i) = 1"
   assumes sum_c_one: "(\<Sum> i \<in> S. d i) = 1"
 shows "0 \<le> KL_div S a d"
 proof -
     have "S = (S \<inter> {i. 0 < a i}) \<union> (S \<inter> {i. 0 = a i})" using non_null(1) by fastforce
     moreover have "(S \<inter> {i. 0 < a i}) \<inter> (S \<inter> {i. 0 = a i}) = {}" by auto
     ultimately have
     eq: "KL_div S a d = KL_div (S \<inter> {i. 0 < a i}) a d + KL_div (S \<inter> {i. 0 = a i}) a d"
       unfolding KL_div_def
       by (metis (mono_tags, lifting) fin finite_Un sum.union_disjoint)
     have "KL_div (S \<inter> {i. 0 = a i}) a d = 0" unfolding KL_div_def by simp
     hence "KL_div S a d = KL_div (S \<inter> {i. 0 < a i}) a d" using eq by simp
     moreover have "0 \<le> KL_div (S \<inter> {i. 0 < a i}) a d"
   proof(cases "(S \<inter> {i. 0 < a i}) = {}")
       case True
       thus ?thesis unfolding KL_div_def by simp
   next
       case False
       let ?c = "\<lambda>i. d i / (\<Sum>j \<in>(S \<inter> {i. 0 < a i}). d j)"
       have 1: "(\<And>i. i \<in> S \<inter> {i. 0 < a i} \<Longrightarrow> 0 < a i)" by simp
       have 2: "(\<And>i. i \<in> S \<inter> {i. 0 < a i} \<Longrightarrow> 0 < ?c i)"
         by (metis False IntD1 divide_pos_pos fin finite_Int non_null(2) sum_pos)
       have 3: "(\<Sum>i\<in> (S \<inter> {i. 0 < a i}). a i) = 1"
         using sum.cong[of S, of S, of "(\<lambda>x. if x \<in> {i. 0 < a i} then a x else 0)", of a]
       sum.inter_restrict[OF fin, of a] non_null(1) sum_a_one
         by fastforce
       have "(\<Sum>i\<in>S \<inter> {j. 0 < a j}. ?c i) = (\<Sum>i\<in>S \<inter> {j. 0 < a j}. d i) / (\<Sum>i\<in>S \<inter> {j. 0 < a j}. d i)"
         by (metis sum_divide_distrib)
       hence 5: "(\<Sum>i\<in>S \<inter> {j. 0 < a j}. ?c i) = 1" using 2 False by force
       hence "0 \<le> KL_div (S \<inter> {j. 0 < a j}) a ?c"
         using KL_div_pos_gen[
       OF finite_Int[OF disjI1, of S, of "{j. 0 < a j}"], of a, of ?c
       ] 1 2 3
         by (metis fin)
       have fstdb: "0 < (\<Sum>i\<in>S \<inter> {i. 0 < a i}. d i)" using non_null(2) False
         by (metis Int_Collect fin finite_Int sum_pos)
       have 6: "0 \<le> KL_div (S \<inter> {i. 0 < a i}) a (\<lambda>i. d i / (\<Sum>i\<in>(S \<inter> {i. 0 < a i}). d i))"
         using 2 3 5
         KL_div_pos_gen[
       OF finite_Int[OF disjI1, OF fin], of "{i. 0 < a i}", of "a", of "?c"
       ]
         by simp
       hence
       "KL_div (S \<inter> {j. 0 < a j}) a (\<lambda>i. d i / (\<Sum>i\<in>(S \<inter> {i. 0 < a i}). d i)) \<le> KL_div (S \<inter> {j. 0 < a j}) a d"
         using non_null sum.inter_restrict[OF fin, of d, of "{i. 0 < a i}"]
         sum_mono[of S, of "(\<lambda>x. if x \<in> {i. 0 < a i} then d x else 0)", of d] non_null(2) sum_c_one
         non_null(2) fstdb KL_div_mul
         by force
       moreover have "0 \<le> KL_div (S \<inter> {j. 0 < a j}) a (\<lambda>i. d i / (\<Sum>i\<in>(S \<inter> {i. 0 < a i}). d i))"
         using KL_div_pos_gen[ OF finite_Int[OF disjI1, OF fin]] using 2 3 5 by fastforce
       ultimately show "0 \<le> KL_div (S \<inter> {j. 0 < a j}) a d" by simp
   qed
     ultimately show ?thesis by simp
 qed
 
 lemma sum_div_1:
   fixes f::"'b \<Rightarrow> 'c::field"
   assumes "(\<Sum>i\<in>A. f i) \<noteq> 0"
 shows "(\<Sum>i\<in>A. f i / (\<Sum>j\<in>A. f j)) = 1"
     by (metis (no_types) assms right_inverse_eq sum_divide_distrib)
 
 theorem rate_lower_bound:
 shows "\<H>(X) \<le> code_rate enc X"
 proof -
     let ?cr = "code_rate enc X"
     let ?r = "(\<lambda>i. 1 / ((b powr cw_len i) * \<K>))"
     have pos_pi: "\<And>i. i \<in> L \<Longrightarrow> 0 \<le> fi i" using fi_pos by simp
     {
     fix i
     assume "i \<in> L"
     hence
     "fi i * (log b (1 / (1 / b powr (cw_len i))) + log b (fi i))
     = fi i * log b (fi i / (1 / b powr (cw_len i)))"
-      using log_mult_ext2[OF pos_pi] b_gt_1
-      by (simp add: linordered_field_class.sign_simps(36))
+      using log_mult_ext2 [OF pos_pi, of i] b_gt_1
+      by simp (simp add: algebra_simps)
     }
     hence eqpi:
     "\<And>i. i\<in> L \<Longrightarrow> fi i * (log b (1 / (1 / b powr (cw_len i))) + log b (fi i))
     = fi i * log b (fi i / (1 / b powr (cw_len i)))"
       by simp
     have sum_one_L: "(\<Sum> i \<in> L. fi i) = 1"
       using simple_distributed_sum_space[OF distr_i] by (simp add: L_def)
     {
     fix i
     assume "i \<in> L"
     hence h1: "0 \<le> fi i" using pos_pi by blast
     have h2: "0 < \<K> / (1/b powr cw_len i)" using b_gt_1 \<K>_pos by auto
     have h3: "0 < 1 / \<K>" using \<K>_pos by simp
     have
     "fi i * log b (fi i * \<K> / (1/b powr cw_len i) * (1/ \<K>)) =
     fi i * log b (fi i * \<K> / (1/b powr cw_len i)) + fi i * log b (1/ \<K>)"
       using log_mult_ext3[OF h1 h2 h3]
       by (metis times_divide_eq_right)
     } hence big_eq:
     "\<And>i. i \<in> L \<Longrightarrow> fi i * log b (fi i * \<K> / (1/b powr cw_len i) * (1 / \<K>)) =
     fi i * log b (fi i * \<K> / (1/b powr cw_len i)) + fi i * log b (1 / \<K>)"
       by (simp add: inverse_eq_divide)
     have 1: "?cr - \<H>(X) = (\<Sum>i \<in> L. fi i * cw_len i) + (\<Sum>i \<in> L. fi i * log b (fi i))"
       using \<K>_def entropy_rw cr_rw L_def by simp
     also have 2: "(\<Sum>i\<in>L. fi i * cw_len i) = (\<Sum>i \<in> L. fi i * (-log b (1/(b powr (cw_len i)))))"
       using b_gt_1 log_divide by simp
     also have "\<dots> = -1 * (\<Sum>i \<in> L. fi i * (log b (1/(b powr (cw_len i)))))"
       using sum_distrib_left[of "-1" "(\<lambda>i. fi i * (- 1 * log b (1 / b powr (cw_len i))))" L]
       by simp
     finally have
     "?cr - \<H>(X) = -(\<Sum>i \<in> L. fi i * log b (1/b powr cw_len i)) + (\<Sum>i \<in> L. fi i * log b (fi i))"
       by simp
     have "?cr - \<H>(X) = (\<Sum>i \<in> L. fi i * ((log b (1/ (1/(b powr (cw_len i))))) + log b (fi i)))"
       using b_gt_1 1
       by (simp add: distrib_left sum.distrib)
     also have "\<dots> = (\<Sum>i \<in> L. fi i *((log b (fi i / (1/(b powr (cw_len i)))))))"
       using Finite_Cartesian_Product.sum_cong_aux[OF eqpi] by simp
     also from big_eq have
     "\<dots> = (\<Sum>i\<in>L. fi i * (log b (fi i * \<K> / (1 / b powr (cw_len i))))) + (\<Sum>i \<in> L. fi i) * log b (1/ \<K>)"
       using \<K>_pos
       by (simp add: sum_distrib_right sum.distrib)
     also have "\<dots> = (\<Sum>i\<in>L. fi i * (log b (fi i * \<K> / (1 / b powr (cw_len i))))) - log b (\<K>)"
       using \<K>_pos
       by (simp add: log_inverse_eq divide_inverse sum_one_L)
     also have "\<dots> = (\<Sum> i \<in> L. fi i * log b (fi i / ?r i)) - log b (\<K>)"
       by (metis (mono_tags, hide_lams) divide_divide_eq_left divide_divide_eq_right)
     also have "\<dots> = KL_div L fi ?r - log b ( \<K>)"
       using b_gt_1 \<K>_pos log_inverse KL_div_def
       by simp
     also have "\<dots> = KL_div L fi ?r + log b (1 / \<K>)"
       using log_inverse b_val \<K>_pos
       by (simp add: inverse_eq_divide)
     finally have code_ent_kl_log: "?cr - \<H>(X) = KL_div L fi ?r + log b (1 / \<K>)" by simp
     have "(\<Sum>i\<in>L. ?r i) = 1"
       using sum_div_1[of "\<lambda>i. 1 / (b powr (cw_len i))"] \<K>_pos \<K>_pow
       by simp
     moreover have "\<And>i. 0 < ?r i" using b_gt_1 \<K>_pos by simp
     moreover have "(\<Sum>i\<in>L. fi i) = 1" using sum_one_L by simp
     ultimately have "0 \<le> KL_div L fi ?r"
       using KL_div_pos2[OF fin_L fi_pos] by simp
     hence "log b (1 / \<K>) \<le> ?cr - \<H>(X)" using code_ent_kl_log by simp
     moreover from McMillan have "0 \<le> log b (1 / \<K>)"
       using \<K>_pos
       by (simp add: b_gt_1)
     ultimately show ?thesis by simp
 qed
 
 end
 
 end
diff --git a/thys/Taylor_Models/Interval.thy b/thys/Taylor_Models/Interval.thy
--- a/thys/Taylor_Models/Interval.thy
+++ b/thys/Taylor_Models/Interval.thy
@@ -1,840 +1,840 @@
 (* Author:     Christoph Traut, TU Muenchen
                 Fabian Immler, TU Muenchen
 *)
 section \<open>Interval Type\<close>
 theory Interval
   imports
     "HOL-Analysis.Analysis"
     "HOL-Library.Set_Algebras"
     "HOL-Library.Float"
 begin
 
 text \<open>A type of non-empty, closed intervals.\<close>
 
 typedef (overloaded) 'a interval =
   "{(a::'a::preorder, b). a \<le> b}"
   morphisms bounds_of_interval Interval
   by auto
 
 setup_lifting type_definition_interval
 
 lift_definition lower::"('a::preorder) interval \<Rightarrow> 'a" is fst .
 
 lift_definition upper::"('a::preorder) interval \<Rightarrow> 'a" is snd .
 
 lemma interval_eq_iff: "a = b \<longleftrightarrow> lower a = lower b \<and> upper a = upper b"
   by transfer auto
 
 lemma interval_eqI: "lower a = lower b \<Longrightarrow> upper a = upper b \<Longrightarrow> a = b"
   by (auto simp: interval_eq_iff)
 
 lemma lower_le_upper[simp]: "lower i \<le> upper i"
   by transfer auto
 
 lift_definition set_of :: "'a::preorder interval \<Rightarrow> 'a set" is "\<lambda>x. {fst x .. snd x}" .
 
 lemma set_of_eq: "set_of x = {lower x .. upper x}"
   by transfer simp
 
 context notes [[typedef_overloaded]] begin
 
 lift_definition(code_dt) Interval'::"'a::preorder \<Rightarrow> 'a::preorder \<Rightarrow> 'a interval option"
   is "\<lambda>a b. if a \<le> b then Some (a, b) else None"
   by auto
 
 end
 
 instantiation "interval" :: ("{preorder,equal}") equal
 begin
 
 definition "equal_class.equal a b \<equiv> (lower a = lower b) \<and> (upper a = upper b)"
 
 instance proof qed (simp add: equal_interval_def interval_eq_iff)
 end
 
 instantiation interval :: ("preorder") ord begin
 
 definition less_eq_interval :: "'a interval \<Rightarrow> 'a interval \<Rightarrow> bool"
   where "less_eq_interval a b \<longleftrightarrow> lower b \<le> lower a \<and> upper a \<le> upper b"
 
 definition less_interval :: "'a interval \<Rightarrow> 'a interval \<Rightarrow> bool"
   where  "less_interval x y = (x \<le> y \<and> \<not> y \<le> x)"
 
 instance proof qed
 end
 
 instantiation interval :: ("lattice") semilattice_sup
 begin
 
 lift_definition sup_interval :: "'a interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval"
   is "\<lambda>(a, b) (c, d). (inf a c, sup b d)"
   by (auto simp: le_infI1 le_supI1)
 
 lemma lower_sup[simp]: "lower (sup A B) = inf (lower A) (lower B)"
   by transfer auto
 
 lemma upper_sup[simp]: "upper (sup A B) = sup (upper A) (upper B)"
   by transfer auto
 
 instance proof qed (auto simp: less_eq_interval_def less_interval_def interval_eq_iff)
 end
 
 lemma set_of_interval_union: "set_of A \<union> set_of B \<subseteq> set_of (sup A B)" for A::"'a::lattice interval"
   by (auto simp: set_of_eq)
 
 lemma interval_union_commute: "sup A B = sup B A" for A::"'a::lattice interval"
   by (auto simp add: interval_eq_iff inf.commute sup.commute)
 
 lemma interval_union_mono1: "set_of a \<subseteq> set_of (sup a A)" for A :: "'a::lattice interval"
   using set_of_interval_union by blast
 
 lemma interval_union_mono2: "set_of A \<subseteq> set_of (sup a A)" for A :: "'a::lattice interval"
   using set_of_interval_union by blast
 
 lift_definition interval_of :: "'a::preorder \<Rightarrow> 'a interval" is "\<lambda>x. (x, x)"
   by auto
 
 lemma lower_interval_of[simp]: "lower (interval_of a) = a"
   by transfer auto
 
 lemma upper_interval_of[simp]: "upper (interval_of a) = a"
   by transfer auto
 
 definition width :: "'a::{preorder,minus} interval \<Rightarrow> 'a"
   where "width i = upper i - lower i"
 
 
 instantiation "interval" :: ("ordered_ab_semigroup_add") ab_semigroup_add
 begin
 
 lift_definition plus_interval::"'a interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval"
   is "\<lambda>(a, b). \<lambda>(c, d). (a + c, b + d)"
   by (auto intro!: add_mono)
 lemma lower_plus[simp]: "lower (plus A B) = plus (lower A) (lower B)"
   by transfer auto
 lemma upper_plus[simp]: "upper (plus A B) = plus (upper A) (upper B)"
   by transfer auto
 
 instance proof qed (auto simp: interval_eq_iff less_eq_interval_def ac_simps)
 end
 
 instance "interval" :: ("{ordered_ab_semigroup_add, lattice}") ordered_ab_semigroup_add
 proof qed (auto simp: less_eq_interval_def intro!: add_mono)
 
 instantiation "interval" :: ("{preorder,zero}") zero
 begin
 
 lift_definition zero_interval::"'a interval" is "(0, 0)" by auto
 lemma lower_zero[simp]: "lower 0 = 0"
   by transfer auto
 lemma upper_zero[simp]: "upper 0 = 0"
   by transfer auto
 instance proof qed
 end
 
 instance "interval" :: ("{ordered_comm_monoid_add}") comm_monoid_add
 proof qed (auto simp: interval_eq_iff)
 
 instance "interval" :: ("{ordered_comm_monoid_add,lattice}") ordered_comm_monoid_add ..
 
 instantiation "interval" :: ("{ordered_ab_group_add}") uminus
 begin
 
 lift_definition uminus_interval::"'a interval \<Rightarrow> 'a interval" is "\<lambda>(a, b). (-b, -a)" by auto
 lemma lower_uminus[simp]: "lower (- A) = - upper A"
   by transfer auto
 lemma upper_uminus[simp]: "upper (- A) = - lower A"
   by transfer auto
 instance ..
 end
 
 instantiation "interval" :: ("{ordered_ab_group_add}") minus
 begin
 
 definition minus_interval::"'a interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval"
   where "minus_interval a b = a + - b"
 lemma lower_minus[simp]: "lower (minus A B) = minus (lower A) (upper B)"
   by (auto simp: minus_interval_def)
 lemma upper_minus[simp]: "upper (minus A B) = minus (upper A) (lower B)"
   by (auto simp: minus_interval_def)
 
 instance ..
 end
 
 instantiation "interval" :: (linordered_semiring) times
 begin
 
 lift_definition times_interval :: "'a interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval"
   is "\<lambda>(a1, a2). \<lambda>(b1, b2).
     (let x1 = a1 * b1; x2 = a1 * b2; x3 = a2 * b1; x4 = a2 * b2
     in (min x1 (min x2 (min x3 x4)), max x1 (max x2 (max x3 x4))))"
   by (auto simp: Let_def intro!: min.coboundedI1 max.coboundedI1)
 
 lemma lower_times:
   "lower (times A B) = Min {lower A * lower B, lower A * upper B, upper A * lower B, upper A * upper B}"
   by transfer (auto simp: Let_def)
 
 lemma upper_times:
   "upper (times A B) = Max {lower A * lower B, lower A * upper B, upper A * lower B, upper A * upper B}"
   by transfer (auto simp: Let_def)
 
 instance ..
 end
 
 lemma interval_eq_set_of_iff: "X = Y \<longleftrightarrow> set_of X = set_of Y" for X Y::"'a::order interval"
   by (auto simp: set_of_eq interval_eq_iff)
 
 
 subsection \<open>Membership\<close>
 
 abbreviation (in preorder) in_interval ("(_/ \<in>\<^sub>i _)" [51, 51] 50)
   where "in_interval x X \<equiv> x \<in> set_of X"
 
 lemma in_interval_to_interval[intro!]: "a \<in>\<^sub>i interval_of a"
   by (auto simp: set_of_eq)
 
 lemma plus_in_intervalI:
   fixes x y :: "'a :: ordered_ab_semigroup_add"
   shows "x \<in>\<^sub>i X \<Longrightarrow> y \<in>\<^sub>i Y \<Longrightarrow> x + y \<in>\<^sub>i X + Y"
   by (simp add: add_mono_thms_linordered_semiring(1) set_of_eq)
 
 lemma connected_set_of[intro, simp]:
   "connected (set_of X)" for X::"'a::linear_continuum_topology interval"
   by (auto simp: set_of_eq )
 
 lemma ex_sum_in_interval_lemma: "\<exists>xa\<in>{la .. ua}. \<exists>xb\<in>{lb .. ub}. x = xa + xb"
   if "la \<le> ua" "lb \<le> ub" "la + lb \<le> x" "x \<le> ua + ub"
     "ua - la \<le> ub - lb"
   for la b c d::"'a::linordered_ab_group_add"
 proof -
   define wa where "wa = ua - la"
   define wb where "wb = ub - lb"
   define w where "w = wa + wb"
   define d where "d = x - la - lb"
   define da where "da = max 0 (min wa (d - wa))"
   define db where "db = d - da"
   from that have nonneg: "0 \<le> wa" "0 \<le> wb" "0 \<le> w" "0 \<le> d" "d \<le> w"
     by (auto simp add: wa_def wb_def w_def d_def add.commute le_diff_eq)
   have "0 \<le> db"
     by (auto simp: da_def nonneg db_def intro!: min.coboundedI2)
   have "x = (la + da) + (lb + db)"
     by (simp add: da_def db_def d_def)
   moreover
   have "x - la - ub \<le> da"
     using that
     unfolding da_def
     by (intro max.coboundedI2) (auto simp: wa_def d_def diff_le_eq diff_add_eq)
   then have "db \<le> wb"
     by (auto simp: db_def d_def wb_def algebra_simps)
   with \<open>0 \<le> db\<close> that nonneg have "lb + db \<in> {lb..ub}"
     by (auto simp: wb_def algebra_simps)
   moreover
   have "da \<le> wa"
     by (auto simp: da_def nonneg)
   then have "la + da \<in> {la..ua}"
     by (auto simp: da_def wa_def algebra_simps)
   ultimately show ?thesis
     by force
 qed
 
 
 lemma ex_sum_in_interval: "\<exists>xa\<ge>la. xa \<le> ua \<and> (\<exists>xb\<ge>lb. xb \<le> ub \<and> x = xa + xb)"
   if a: "la \<le> ua" and b: "lb \<le> ub" and x: "la + lb \<le> x" "x \<le> ua + ub"
   for la b c d::"'a::linordered_ab_group_add"
 proof -
   from linear consider "ua - la \<le> ub - lb" | "ub - lb \<le> ua - la"
     by blast
   then show ?thesis
   proof cases
     case 1
     from ex_sum_in_interval_lemma[OF that 1]
     show ?thesis by auto
   next
     case 2
     from x have "lb + la \<le> x" "x \<le> ub + ua" by (simp_all add: ac_simps)
     from ex_sum_in_interval_lemma[OF b a this 2]
     show ?thesis by auto
   qed
 qed
 
 lemma Icc_plus_Icc:
   "{a .. b} + {c .. d} = {a + c .. b + d}"
   if "a \<le> b" "c \<le> d"
   for a b c d::"'a::linordered_ab_group_add"
   using ex_sum_in_interval[OF that]
   by (auto intro: add_mono simp: atLeastAtMost_iff Bex_def set_plus_def)
 
 lemma set_of_plus:
   fixes A :: "'a::linordered_ab_group_add interval"
   shows "set_of (A + B) = set_of A + set_of B"
   using Icc_plus_Icc[of "lower A" "upper A" "lower B" "upper B"]
   by (auto simp: set_of_eq)
 
 lemma plus_in_intervalE:
   fixes xy :: "'a :: linordered_ab_group_add"
   assumes "xy \<in>\<^sub>i X + Y"
   obtains x y where "xy = x + y" "x \<in>\<^sub>i X" "y \<in>\<^sub>i Y"
   using assms
   unfolding set_of_plus set_plus_def
   by auto
 
 lemma set_of_uminus: "set_of (-X) = {- x | x. x \<in> set_of X}"
   for X :: "'a :: ordered_ab_group_add interval"
   by (auto simp: set_of_eq simp: le_minus_iff minus_le_iff
       intro!: exI[where x="-x" for x])
 
 lemma uminus_in_intervalI:
   fixes x :: "'a :: ordered_ab_group_add"
   shows "x \<in>\<^sub>i X \<Longrightarrow> -x \<in>\<^sub>i -X"
   by (auto simp: set_of_uminus)
 
 lemma uminus_in_intervalD:
   fixes x :: "'a :: ordered_ab_group_add"
   shows "x \<in>\<^sub>i - X \<Longrightarrow> - x \<in>\<^sub>i X"
   by (auto simp: set_of_uminus)
 
 lemma minus_in_intervalI:
   fixes x y :: "'a :: ordered_ab_group_add"
   shows "x \<in>\<^sub>i X \<Longrightarrow> y \<in>\<^sub>i Y \<Longrightarrow> x - y \<in>\<^sub>i X - Y"
   by (metis diff_conv_add_uminus minus_interval_def plus_in_intervalI uminus_in_intervalI)
 
 lemma set_of_minus: "set_of (X - Y) = {x - y | x y . x \<in> set_of X \<and> y \<in> set_of Y}"
   for X Y :: "'a :: linordered_ab_group_add interval"
   unfolding minus_interval_def set_of_plus set_of_uminus set_plus_def
   by force
 
 lemma times_in_intervalI:
   fixes x y::"'a::linordered_ring"
   assumes "x \<in>\<^sub>i X" "y \<in>\<^sub>i Y"
   shows "x * y \<in>\<^sub>i X * Y"
 proof -
   define X1 where "X1 \<equiv> lower X"
   define X2 where "X2 \<equiv> upper X"
   define Y1 where "Y1 \<equiv> lower Y"
   define Y2 where "Y2 \<equiv> upper Y"
   from assms have assms: "X1 \<le> x" "x \<le> X2" "Y1 \<le> y" "y \<le> Y2"
     by (auto simp: X1_def X2_def Y1_def Y2_def set_of_eq)
   have "(X1 * Y1 \<le> x * y \<or> X1 * Y2 \<le> x * y \<or> X2 * Y1 \<le> x * y \<or> X2 * Y2 \<le> x * y) \<and>
         (X1 * Y1 \<ge> x * y \<or> X1 * Y2 \<ge> x * y \<or> X2 * Y1 \<ge> x * y \<or> X2 * Y2 \<ge> x * y)"
   proof (cases x "0::'a" rule: linorder_cases)
     case x0: less
     show ?thesis
     proof (cases "y < 0")
       case y0: True
       from y0 x0 assms have "x * y \<le> X1 * y" by (intro mult_right_mono_neg, auto)
       also from x0 y0 assms have "X1 * y \<le> X1 * Y1" by (intro mult_left_mono_neg, auto)
       finally have 1: "x * y \<le> X1 * Y1".
       show ?thesis proof(cases "X2 \<le> 0")
         case True
         with assms have "X2 * Y2 \<le> X2 * y" by (auto intro: mult_left_mono_neg)
         also from assms y0 have "... \<le> x * y" by (auto intro: mult_right_mono_neg)
         finally have "X2 * Y2 \<le> x * y".
         with 1 show ?thesis by auto
       next
         case False
         with assms have "X2 * Y1 \<le> X2 * y" by (auto intro: mult_left_mono)
         also from assms y0 have "... \<le> x * y" by (auto intro: mult_right_mono_neg)
         finally have "X2 * Y1 \<le> x * y".
         with 1 show ?thesis by auto
       qed
     next
       case False
       then have y0: "y \<ge> 0" by auto
       from x0 y0 assms have "X1 * Y2 \<le> x * Y2" by (intro mult_right_mono, auto)
       also from y0 x0 assms have "... \<le> x * y" by (intro mult_left_mono_neg, auto)
       finally have 1: "X1 * Y2 \<le> x * y".
       show ?thesis
       proof(cases "X2 \<le> 0")
         case X2: True
         from assms y0 have "x * y \<le> X2 * y" by (intro mult_right_mono)
         also from assms X2 have "... \<le> X2 * Y1" by (auto intro: mult_left_mono_neg)
         finally have "x * y \<le> X2 * Y1".
         with 1 show ?thesis by auto
       next
         case X2: False
         from assms y0 have "x * y \<le> X2 * y" by (intro mult_right_mono)
         also from assms X2 have "... \<le> X2 * Y2" by (auto intro: mult_left_mono)
         finally have "x * y \<le> X2 * Y2".
         with 1 show ?thesis by auto
       qed
     qed
   next
     case [simp]: equal
     with assms show ?thesis by (cases "Y2 \<le> 0", auto intro:mult_sign_intros)
   next
     case x0: greater
     show ?thesis
     proof (cases "y < 0")
       case y0: True
       from x0 y0 assms have "X2 * Y1 \<le> X2 * y" by (intro mult_left_mono, auto)
       also from y0 x0 assms have "X2 * y \<le> x * y" by (intro mult_right_mono_neg, auto)
       finally have 1: "X2 * Y1 \<le> x * y".
       show ?thesis
       proof(cases "Y2 \<le> 0")
         case Y2: True
         from x0 assms have "x * y \<le> x * Y2" by (auto intro: mult_left_mono)
         also from assms Y2 have "... \<le> X1 * Y2" by (auto intro: mult_right_mono_neg)
         finally have "x * y \<le> X1 * Y2".
         with 1 show ?thesis by auto
       next
         case Y2: False
         from x0 assms have "x * y \<le> x * Y2" by (auto intro: mult_left_mono)
         also from assms Y2 have "... \<le> X2 * Y2" by (auto intro: mult_right_mono)
         finally have "x * y \<le> X2 * Y2".
         with 1 show ?thesis by auto
       qed
     next
       case y0: False
       from x0 y0 assms have "x * y \<le> X2 * y" by (intro mult_right_mono, auto)
       also from y0 x0 assms have "... \<le> X2 * Y2" by (intro mult_left_mono, auto)
       finally have 1: "x * y \<le> X2 * Y2".
       show ?thesis
       proof(cases "X1 \<le> 0")
         case True
         with assms have "X1 * Y2 \<le> X1 * y" by (auto intro: mult_left_mono_neg)
         also from assms y0 have "... \<le> x * y" by (auto intro: mult_right_mono)
         finally have "X1 * Y2 \<le> x * y".
         with 1 show ?thesis by auto
       next
         case False
         with assms have "X1 * Y1 \<le> X1 * y" by (auto intro: mult_left_mono)
         also from assms y0 have "... \<le> x * y" by (auto intro: mult_right_mono)
         finally have "X1 * Y1 \<le> x * y".
         with 1 show ?thesis by auto
       qed
     qed
   qed
   hence min:"min (X1 * Y1) (min (X1 * Y2) (min (X2 * Y1) (X2 * Y2))) \<le> x * y"
     and max:"x * y \<le> max (X1 * Y1) (max (X1 * Y2) (max (X2 * Y1) (X2 * Y2)))"
     by (auto simp:min_le_iff_disj le_max_iff_disj)
   show ?thesis using min max
     by (auto simp: Let_def X1_def X2_def Y1_def Y2_def set_of_eq lower_times upper_times)
 qed
 
 lemma times_in_intervalE:
   fixes xy :: "'a :: {linordered_semiring, real_normed_algebra, linear_continuum_topology}"
     \<comment> \<open>TODO: linear continuum topology is pretty strong\<close>
   assumes "xy \<in>\<^sub>i X * Y"
   obtains x y where "xy = x * y" "x \<in>\<^sub>i X" "y \<in>\<^sub>i Y"
 proof -
   let ?mult = "\<lambda>(x, y). x * y"
   let ?XY = "set_of X \<times> set_of Y"
   have cont: "continuous_on ?XY ?mult"
     by (auto intro!: tendsto_eq_intros simp: continuous_on_def split_beta')
   have conn: "connected (?mult ` ?XY)"
     by (rule connected_continuous_image[OF cont]) auto
   have "lower (X * Y) \<in> ?mult ` ?XY" "upper (X * Y) \<in> ?mult ` ?XY"
     by (auto simp: set_of_eq lower_times upper_times min_def max_def split: if_splits)
   from connectedD_interval[OF conn this, of xy] assms
   obtain x y where "xy = x * y" "x \<in>\<^sub>i X" "y \<in>\<^sub>i Y" by (auto simp: set_of_eq)
   then show ?thesis ..
 qed
 
 lemma set_of_times: "set_of (X * Y) = {x * y | x y. x \<in> set_of X \<and> y \<in> set_of Y}"
   for X Y::"'a :: {linordered_ring, real_normed_algebra, linear_continuum_topology} interval"
   by (auto intro!: times_in_intervalI elim!: times_in_intervalE)
 
 instance "interval" :: (linordered_idom) cancel_semigroup_add
 proof qed (auto simp: interval_eq_iff)
 
 lemma interval_mul_commute: "A * B = B * A" for A B:: "'a::linordered_idom interval"
   by (simp add: interval_eq_iff lower_times upper_times ac_simps)
 
 lemma interval_times_zero_right[simp]: "A * 0 = 0" for A :: "'a::linordered_ring interval"
   by (simp add: interval_eq_iff lower_times upper_times ac_simps)
 
 lemma interval_times_zero_left[simp]:
   "0 * A = 0" for A :: "'a::linordered_ring interval"
   by (simp add: interval_eq_iff lower_times upper_times ac_simps)
 
 instantiation "interval" :: ("{preorder,one}") one
 begin
 
 lift_definition one_interval::"'a interval" is "(1, 1)" by auto
 lemma lower_one[simp]: "lower 1 = 1"
   by transfer auto
 lemma upper_one[simp]: "upper 1 = 1"
   by transfer auto
 instance proof qed
 end
 
 instance interval :: ("{one, preorder, linordered_semiring}") power
 proof qed
 
 lemma set_of_one[simp]: "set_of (1::'a::{one, order} interval) = {1}"
   by (auto simp: set_of_eq)
 
 instance "interval" ::
   ("{linordered_idom,linordered_ring, real_normed_algebra, linear_continuum_topology}") monoid_mult
   apply standard
   unfolding interval_eq_set_of_iff set_of_times
   subgoal for a b c 
     by (auto simp: interval_eq_set_of_iff set_of_times; metis mult.assoc)
   by auto
 
 lemma one_times_ivl_left[simp]: "1 * A = A" for A :: "'a::linordered_idom interval"
   by (simp add: interval_eq_iff lower_times upper_times ac_simps min_def max_def)
 
 lemma one_times_ivl_right[simp]: "A * 1 = A" for A :: "'a::linordered_idom interval"
   by (metis interval_mul_commute one_times_ivl_left)
 
 lemma set_of_power_mono: "a^n \<in> set_of (A^n)" if "a \<in> set_of A"
   for a :: "'a::linordered_idom"
   using that
   by (induction n) (auto intro!: times_in_intervalI)
 
 lemma set_of_add_cong:
   "set_of (A + B) = set_of (A' + B')"
   if "set_of A = set_of A'" "set_of B = set_of B'"
   for A :: "'a::linordered_ab_group_add interval"
   unfolding set_of_plus that ..
 
 lemma set_of_add_inc_left:
   "set_of (A + B) \<subseteq> set_of (A' + B)"
   if "set_of A \<subseteq> set_of A'"
   for A :: "'a::linordered_ab_group_add interval"
   unfolding set_of_plus using that by (auto simp: set_plus_def)
 
 lemma set_of_add_inc_right:
   "set_of (A + B) \<subseteq> set_of (A + B')"
   if "set_of B \<subseteq> set_of B'"
   for A :: "'a::linordered_ab_group_add interval"
   using set_of_add_inc_left[OF that]
   by (simp add: add.commute)
 
 lemma set_of_add_inc:
   "set_of (A + B) \<subseteq> set_of (A' + B')"
   if "set_of A \<subseteq> set_of A'" "set_of B \<subseteq> set_of B'"
   for A :: "'a::linordered_ab_group_add interval"
   using set_of_add_inc_left[OF that(1)] set_of_add_inc_right[OF that(2)]
   by auto
 
 lemma set_of_neg_inc:
   "set_of (-A) \<subseteq> set_of (-A')"
   if "set_of A \<subseteq> set_of A'"
   for A :: "'a::ordered_ab_group_add interval"
   using that
   unfolding set_of_uminus
   by auto
 
 lemma set_of_sub_inc_left:
   "set_of (A - B) \<subseteq> set_of (A' - B)"
   if "set_of A \<subseteq> set_of A'"
   for A :: "'a::linordered_ab_group_add interval"
   using that
   unfolding set_of_minus
   by auto
 
 lemma set_of_sub_inc_right:
   "set_of (A - B) \<subseteq> set_of (A - B')"
   if "set_of B \<subseteq> set_of B'"
   for A :: "'a::linordered_ab_group_add interval"
   using that
   unfolding set_of_minus
   by auto
 
 lemma set_of_sub_inc:
   "set_of (A - B) \<subseteq> set_of (A' - B')"
   if "set_of A \<subseteq> set_of A'" "set_of B \<subseteq> set_of B'"
   for A :: "'a::linordered_idom interval"
   using set_of_sub_inc_left[OF that(1)] set_of_sub_inc_right[OF that(2)]
   by auto
 
 lemma set_of_mul_inc_right:
   "set_of (A * B) \<subseteq> set_of (A * B')"
   if "set_of B \<subseteq> set_of B'"
   for A :: "'a::linordered_ring interval"
   using that
   apply transfer
   apply (auto simp: Let_def)
   apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
   apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
   apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
   apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
   apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
   apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
   apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
   apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
   done
 
 lemma set_of_distrib_left:
   "set_of (B * (A1 + A2)) \<subseteq> set_of (B * A1 + B * A2)"
   for A1 :: "'a::linordered_ring interval"
   apply transfer
   apply (auto simp: Let_def add_mono distrib_left distrib_right)
   apply (metis add_mono min.cobounded1 min.left_commute)
   apply (metis add_mono min.cobounded1 min.left_commute)
   apply (metis add_mono min.assoc min.cobounded2)
   apply (meson add_mono_thms_linordered_semiring(1) dual_order.trans max.cobounded1 max.cobounded2)
   apply (meson add_mono_thms_linordered_semiring(1) dual_order.trans max.cobounded1 max.cobounded2)
   apply (meson add_mono_thms_linordered_semiring(1) dual_order.trans max.cobounded1 max.cobounded2)
   done
 
 lemma set_of_distrib_right:
   "set_of ((A1 + A2) * B) \<subseteq> set_of (A1 * B + A2 * B)"
   for A1 A2 B :: "'a::{linordered_ring, real_normed_algebra, linear_continuum_topology} interval"
   unfolding set_of_times set_of_plus set_plus_def
   apply clarsimp
   subgoal for b a1 a2
     apply (rule exI[where x="a1 * b"])
     apply (rule conjI)
     subgoal by force
     subgoal
       apply (rule exI[where x="a2 * b"])
       apply (rule conjI)
       subgoal by force
       subgoal by (simp add: algebra_simps)
       done
     done
   done
 
 lemma set_of_mul_inc_left:
   "set_of (A * B) \<subseteq> set_of (A' * B)"
   if "set_of A \<subseteq> set_of A'"
   for A :: "'a::{linordered_ring, real_normed_algebra, linear_continuum_topology} interval"
   using that
   unfolding set_of_times
   by auto
 
 lemma set_of_mul_inc:
   "set_of (A * B) \<subseteq> set_of (A' * B')"
   if "set_of A \<subseteq> set_of A'" "set_of B \<subseteq> set_of B'"
   for A :: "'a::{linordered_ring, real_normed_algebra, linear_continuum_topology} interval"
   using that unfolding set_of_times by auto
 
 lemma set_of_pow_inc:
   "set_of (A^n) \<subseteq> set_of (A'^n)"
   if "set_of A \<subseteq> set_of A'"
   for A :: "'a::{linordered_idom, real_normed_algebra, linear_continuum_topology} interval"
   using that
   by (induction n, simp_all add: set_of_mul_inc)
 
 lemma set_of_distrib_right_left:
   "set_of ((A1 + A2) * (B1 + B2)) \<subseteq> set_of (A1 * B1 + A1 * B2 + A2 * B1 + A2 * B2)"
   for A1 :: "'a::{linordered_idom, real_normed_algebra, linear_continuum_topology} interval"
 proof-
   have "set_of ((A1 + A2) * (B1 + B2)) \<subseteq> set_of (A1 * (B1 + B2) + A2 * (B1 + B2))"
     by (rule set_of_distrib_right)
   also have "... \<subseteq> set_of ((A1 * B1 + A1 * B2) + A2 * (B1 + B2))"
     by (rule set_of_add_inc_left[OF set_of_distrib_left])
   also have "... \<subseteq> set_of ((A1 * B1 + A1 * B2) + (A2 * B1 + A2 * B2))"
     by (rule set_of_add_inc_right[OF set_of_distrib_left])
   finally show ?thesis
     by (simp add: add.assoc)
 qed
 
 lemma mult_bounds_enclose_zero1:
   "min (la * lb) (min (la * ub) (min (lb * ua) (ua * ub))) \<le> 0"
   "0 \<le> max (la * lb) (max (la * ub) (max (lb * ua) (ua * ub)))"
   if "la \<le> 0" "0 \<le> ua"
   for la lb ua ub:: "'a::linordered_idom"
   subgoal by (metis (no_types, hide_lams) that eq_iff min_le_iff_disj mult_zero_left
         mult_zero_right zero_le_mult_iff)
   subgoal by (metis that le_max_iff_disj mult_zero_right order_refl zero_le_mult_iff)
   done
 
 lemma mult_bounds_enclose_zero2:
   "min (la * lb) (min (la * ub) (min (lb * ua) (ua * ub))) \<le> 0"
   "0 \<le> max (la * lb) (max (la * ub) (max (lb * ua) (ua * ub)))"
   if "lb \<le> 0" "0 \<le> ub"
   for la lb ua ub:: "'a::linordered_idom"
   using mult_bounds_enclose_zero1[OF that, of la ua]
   by (simp_all add: ac_simps)
 
 lemma set_of_mul_contains_zero:
   "0 \<in> set_of (A * B)"
   if "0 \<in> set_of A \<or> 0 \<in> set_of B"
   for A :: "'a::linordered_idom interval"
   using that
-  by (auto simp: set_of_eq lower_times upper_times sign_simps mult_le_0_iff
+  by (auto simp: set_of_eq lower_times upper_times algebra_simps mult_le_0_iff
       mult_bounds_enclose_zero1 mult_bounds_enclose_zero2)
 
 instance "interval" :: (linordered_semiring) mult_zero
   apply standard
   subgoal by transfer auto
   subgoal by transfer auto
   done
 
 lift_definition min_interval::"'a::linorder interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval" is
   "\<lambda>(l1, u1). \<lambda>(l2, u2). (min l1 l2, min u1 u2)"
   by (auto simp: min_def)
 lemma lower_min_interval[simp]: "lower (min_interval x y) = min (lower x) (lower y)"
   by transfer auto
 lemma upper_min_interval[simp]: "upper (min_interval x y) = min (upper x) (upper y)"
   by transfer auto
 
 lemma min_intervalI:
   "a \<in>\<^sub>i A \<Longrightarrow> b \<in>\<^sub>i B \<Longrightarrow> min a b \<in>\<^sub>i min_interval A B"
   by (auto simp: set_of_eq min_def)
 
 lift_definition max_interval::"'a::linorder interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval" is
   "\<lambda>(l1, u1). \<lambda>(l2, u2). (max l1 l2, max u1 u2)"
   by (auto simp: max_def)
 lemma lower_max_interval[simp]: "lower (max_interval x y) = max (lower x) (lower y)"
   by transfer auto
 lemma upper_max_interval[simp]: "upper (max_interval x y) = max (upper x) (upper y)"
   by transfer auto
 
 lemma max_intervalI:
   "a \<in>\<^sub>i A \<Longrightarrow> b \<in>\<^sub>i B \<Longrightarrow> max a b \<in>\<^sub>i max_interval A B"
   by (auto simp: set_of_eq max_def)
 
 lift_definition abs_interval::"'a::linordered_idom interval \<Rightarrow> 'a interval" is
   "(\<lambda>(l,u). (if l < 0 \<and> 0 < u then 0 else min \<bar>l\<bar> \<bar>u\<bar>, max \<bar>l\<bar> \<bar>u\<bar>))"
   by auto
 
 lemma lower_abs_interval[simp]:
   "lower (abs_interval x) = (if lower x < 0 \<and> 0 < upper x then 0 else min \<bar>lower x\<bar> \<bar>upper x\<bar>)"
   by transfer auto
 lemma upper_abs_interval[simp]: "upper (abs_interval x) = max \<bar>lower x\<bar> \<bar>upper x\<bar>"
   by transfer auto
 
 lemma in_abs_intervalI1:
   "lx < 0 \<Longrightarrow> 0 < ux \<Longrightarrow> 0 \<le> xa \<Longrightarrow> xa \<le> max (- lx) (ux) \<Longrightarrow> xa \<in> abs ` {lx..ux}"
   for xa::"'a::linordered_idom"
   by (metis abs_minus_cancel abs_of_nonneg atLeastAtMost_iff image_eqI le_less le_max_iff_disj
       le_minus_iff neg_le_0_iff_le order_trans)
 
 lemma in_abs_intervalI2:
   "min (\<bar>lx\<bar>) \<bar>ux\<bar> \<le> xa \<Longrightarrow> xa \<le> max \<bar>lx\<bar> \<bar>ux\<bar> \<Longrightarrow> lx \<le> ux \<Longrightarrow> 0 \<le> lx \<or> ux \<le> 0 \<Longrightarrow>
     xa \<in> abs ` {lx..ux}"
   for xa::"'a::linordered_idom"
   by (force intro: image_eqI[where x="-xa"] image_eqI[where x="xa"])
 
 lemma set_of_abs_interval: "set_of (abs_interval x) = abs ` set_of x"
   by (auto simp: set_of_eq not_less intro: in_abs_intervalI1 in_abs_intervalI2 cong del: image_cong_simp)
 
 fun split_domain :: "('a::preorder interval \<Rightarrow> 'a interval list) \<Rightarrow> 'a interval list \<Rightarrow> 'a interval list list"
   where "split_domain split [] = [[]]"
   | "split_domain split (I#Is) = (
          let S = split I;
              D = split_domain split Is
          in concat (map (\<lambda>d. map (\<lambda>s. s # d) S) D)
        )"
 
 context notes [[typedef_overloaded]] begin
 lift_definition(code_dt) split_interval::"'a::linorder interval \<Rightarrow> 'a \<Rightarrow> ('a interval \<times> 'a interval)"
   is "\<lambda>(l, u) x. ((min l x, max l x), (min u x, max u x))"
   by (auto simp: min_def)
 end
 
 lemma split_domain_nonempty:
   assumes "\<And>I. split I \<noteq> []"
   shows "split_domain split I \<noteq> []"
   using last_in_set assms
   by (induction I, auto)
 
 
 lemma split_intervalD: "split_interval X x = (A, B) \<Longrightarrow> set_of X \<subseteq> set_of A \<union> set_of B"
   unfolding set_of_eq
   by transfer (auto simp: min_def max_def split: if_splits)
 
 definition "split_float_interval x = split_interval x ((lower x + upper x) * Float 1 (-1))"
 
 lemma split_float_intervalD: "split_float_interval X = (A, B) \<Longrightarrow> set_of X \<subseteq> set_of A \<union> set_of B"
   by (auto dest!: split_intervalD simp: split_float_interval_def)
 
 lemmas float_round_down_le[intro] = order_trans[OF float_round_down]
   and float_round_up_ge[intro] = order_trans[OF _ float_round_up]
 
 instantiation interval :: ("{topological_space, preorder}") topological_space
 begin
 
 definition open_interval_def[code del]: "open (X::'a interval set) =
   (\<forall>x\<in>X.
       \<exists>A B.
          open A \<and>
          open B \<and>
          lower x \<in> A \<and> upper x \<in> B \<and> Interval ` (A \<times> B) \<subseteq> X)"
 
 instance
 proof
   show "open (UNIV :: ('a interval) set)"
     unfolding open_interval_def by auto
 next
   fix S T :: "('a interval) set"
   assume "open S" "open T"
   show "open (S \<inter> T)"
     unfolding open_interval_def
   proof (safe)
     fix x assume "x \<in> S" "x \<in> T"
     from \<open>x \<in> S\<close> \<open>open S\<close> obtain Sl Su where S:
       "open Sl" "open Su" "lower x \<in> Sl" "upper x \<in> Su" "Interval ` (Sl \<times> Su) \<subseteq> S"
       by (auto simp: open_interval_def)
     from \<open>x \<in> T\<close> \<open>open T\<close> obtain Tl Tu where T:
       "open Tl" "open Tu" "lower x \<in> Tl" "upper x \<in> Tu" "Interval ` (Tl \<times> Tu) \<subseteq> T"
       by (auto simp: open_interval_def)
 
     let ?L = "Sl \<inter> Tl" and ?U = "Su \<inter> Tu" 
     have "open ?L \<and> open ?U \<and> lower x \<in> ?L \<and> upper x \<in> ?U \<and> Interval ` (?L \<times> ?U) \<subseteq> S \<inter> T"
       using S T by (auto simp add: open_Int)
     then show "\<exists>A B. open A \<and> open B \<and> lower x \<in> A \<and> upper x \<in> B \<and> Interval ` (A \<times> B) \<subseteq> S \<inter> T"
       by fast
   qed
 qed (unfold open_interval_def, fast)
 
 end
 
 
 definition mid :: "float interval \<Rightarrow> float"
   where "mid i = (lower i + upper i) * Float 1 (-1)"
 
 lemma mid_in_interval: "mid i \<in>\<^sub>i i"
   using lower_le_upper[of i]
   by (auto simp: mid_def set_of_eq powr_minus)
 
 definition centered :: "float interval \<Rightarrow> float interval"
   where "centered i = i - interval_of (mid i)"
 
 
 subsection \<open>Quickcheck\<close>
 
 lift_definition Ivl::"'a \<Rightarrow> 'a::preorder \<Rightarrow> 'a interval" is "\<lambda>a b. (min a b, b)"
   by (auto simp: min_def)
 
 instantiation interval :: ("{exhaustive,preorder}") exhaustive
 begin
 
 definition exhaustive_interval::"('a interval \<Rightarrow> (bool \<times> term list) option)
      \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
   where
     "exhaustive_interval f d =
     Quickcheck_Exhaustive.exhaustive (\<lambda>x. Quickcheck_Exhaustive.exhaustive (\<lambda>y. f (Ivl x y)) d) d"
 
 instance ..
 
 end
 
 definition (in term_syntax) [code_unfold]:
   "valtermify_interval x y = Code_Evaluation.valtermify (Ivl::'a::{preorder,typerep}\<Rightarrow>_) {\<cdot>} x {\<cdot>} y"
 
 instantiation interval :: ("{full_exhaustive,preorder,typerep}") full_exhaustive
 begin
 
 definition full_exhaustive_interval::
   "('a interval \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option)
      \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option" where
   "full_exhaustive_interval f d =
     Quickcheck_Exhaustive.full_exhaustive
       (\<lambda>x. Quickcheck_Exhaustive.full_exhaustive (\<lambda>y. f (valtermify_interval x y)) d) d"
 
 instance ..
 
 end
 
 instantiation interval :: ("{random,preorder,typerep}") random
 begin
 
 definition random_interval ::
   "natural
   \<Rightarrow> natural \<times> natural
      \<Rightarrow> ('a interval \<times> (unit \<Rightarrow> term)) \<times> natural \<times> natural" where
   "random_interval i =
   scomp (Quickcheck_Random.random i)
     (\<lambda>man. scomp (Quickcheck_Random.random i) (\<lambda>exp. Pair (valtermify_interval man exp)))"
 
 instance ..
 
 end
 
 end
diff --git a/thys/Taylor_Models/Interval_Approximation.thy b/thys/Taylor_Models/Interval_Approximation.thy
--- a/thys/Taylor_Models/Interval_Approximation.thy
+++ b/thys/Taylor_Models/Interval_Approximation.thy
@@ -1,774 +1,774 @@
 section \<open>Approximate Operations on Intervals of Floating Point Numbers\<close>
 theory Interval_Approximation
   imports
     "HOL-Decision_Procs.Approximation_Bounds"
     Interval
 begin
 
 lifting_update float.lifting \<comment> \<open>TODO: in Float!\<close>
 lifting_forget float.lifting
 
 text \<open>TODO: many of the lemmas should move to theories Float or Approximation
   (the latter should be based on type @{type interval}.\<close>
 
 subsection "Intervals with Floating Point Bounds"
 
 lift_definition round_interval :: "nat \<Rightarrow> float interval \<Rightarrow> float interval"
   is "\<lambda>p. \<lambda>(l, u). (float_round_down p l, float_round_up p u)"
   by (auto simp: intro!: float_round_down_le float_round_up_le)
 
 lemma lower_round_ivl[simp]: "lower (round_interval p x) = float_round_down p (lower x)"
   by transfer auto
 lemma upper_round_ivl[simp]: "upper (round_interval p x) = float_round_up p (upper x)"
   by transfer auto
 
 lemma round_ivl_correct: "set_of A \<subseteq> set_of (round_interval prec A)"
   by (auto simp: set_of_eq float_round_down_le float_round_up_le)
 
 lift_definition truncate_ivl :: "nat \<Rightarrow> real interval \<Rightarrow> real interval"
   is "\<lambda>p. \<lambda>(l, u). (truncate_down p l, truncate_up p u)"
   by (auto intro!: truncate_down_le truncate_up_le)
 
 lemma lower_truncate_ivl[simp]: "lower (truncate_ivl p x) = truncate_down p (lower x)"
   by transfer auto
 lemma upper_truncate_ivl[simp]: "upper (truncate_ivl p x) = truncate_up p (upper x)"
   by transfer auto
 
 lemma truncate_ivl_correct: "set_of A \<subseteq> set_of (truncate_ivl prec A)"
   by (auto simp: set_of_eq intro!: truncate_down_le truncate_up_le)
 
 lift_definition real_interval::"float interval \<Rightarrow> real interval"
   is "\<lambda>(l, u). (real_of_float l, real_of_float u)"
   by auto
 
 lemma lower_real_interval[simp]: "lower (real_interval x) = lower x"
   by transfer auto
 lemma upper_real_interval[simp]: "upper (real_interval x) = upper x"
   by transfer auto
 
 definition "set_of' x = (case x of None \<Rightarrow> UNIV | Some i \<Rightarrow> set_of (real_interval i))"
 
 lemma real_interval_min_interval[simp]:
   "real_interval (min_interval a b) = min_interval (real_interval a) (real_interval b)"
   by (auto simp: interval_eq_set_of_iff set_of_eq real_of_float_min)
 
 lemma real_interval_max_interval[simp]:
   "real_interval (max_interval a b) = max_interval (real_interval a) (real_interval b)"
   by (auto simp: interval_eq_set_of_iff set_of_eq real_of_float_max)
 
 subsection \<open>Intervals for standard functions\<close>
 
 lift_definition power_float_interval :: "nat \<Rightarrow> nat \<Rightarrow> float interval \<Rightarrow> float interval"
   is "\<lambda>p n (l, u). float_power_bnds p n l u"
   using float_power_bnds
   by (auto simp: bnds_power dest!: float_power_bnds[OF sym])
 
 lemma lower_power_float_interval[simp]:
   "lower (power_float_interval p n x) = fst (float_power_bnds p n (lower x) (upper x))"
   by transfer auto
 lemma upper_power_float_interval[simp]:
   "upper (power_float_interval p n x) = snd (float_power_bnds p n (lower x) (upper x))"
   by transfer auto
 
 lemma power_float_intervalI: "x \<in>\<^sub>i real_interval X \<Longrightarrow> x ^ n \<in>\<^sub>i real_interval (power_float_interval p n X)"
   using float_power_bnds[OF prod.collapse]
   by (auto simp: set_of_eq )
 
 lift_definition mult_float_interval::"nat \<Rightarrow> float interval \<Rightarrow> float interval \<Rightarrow> float interval"
   is "\<lambda>prec. \<lambda>(a1, a2). \<lambda>(b1, b2). bnds_mult prec a1 a2 b1 b2"
   by (auto dest!: bnds_mult[OF sym])
 
 lemma lower_mult_float_interval[simp]:
   "lower (mult_float_interval p x y) = fst (bnds_mult p (lower x) (upper x) (lower y) (upper y))"
   by transfer auto
 lemma upper_mult_float_interval[simp]:
   "upper (mult_float_interval p x y) = snd (bnds_mult p (lower x) (upper x) (lower y) (upper y))"
   by transfer auto
 
 lemma mult_float_interval:
   "set_of (real_interval A) * set_of (real_interval B) \<subseteq>
     set_of (real_interval (mult_float_interval prec A B))"
 proof -
   let ?bm = "bnds_mult prec (lower A) (upper A) (lower B) (upper B)"
   show ?thesis
     using bnds_mult[of "fst ?bm" "snd ?bm", simplified, OF refl]
     by (auto simp: set_of_eq set_times_def)
 qed
 
 lemma mult_float_intervalI:
   "x * y \<in>\<^sub>i (real_interval (mult_float_interval prec A B))"
   if "x \<in>\<^sub>i real_interval A" "y \<in>\<^sub>i real_interval B"
   using mult_float_interval[of A B] that
   by (auto simp: )
 
 lift_definition sqrt_float_interval::"nat \<Rightarrow> float interval \<Rightarrow> float interval"
   is "\<lambda>prec. \<lambda>(lx, ux). (lb_sqrt prec lx, ub_sqrt prec ux)"
   using bnds_sqrt'
   by auto (meson order_trans real_sqrt_le_iff)
 
 lemma lower_float_interval[simp]: "lower (sqrt_float_interval prec X) = lb_sqrt prec (lower X)"
   by transfer auto
 
 lemma upper_float_interval[simp]: "upper (sqrt_float_interval prec X) = ub_sqrt prec (upper X)"
   by transfer auto
 
 lemma sqrt_float_interval:
   "sqrt ` set_of (real_interval X) \<subseteq> set_of (real_interval (sqrt_float_interval prec X))"
   using bnds_sqrt
   by (auto simp: set_of_eq)
 
 lemma sqrt_float_intervalI:
   "sqrt x \<in>\<^sub>i real_interval (sqrt_float_interval p X)"
   if "x \<in> set_of (real_interval X)"
   using sqrt_float_interval[of X p] that
   by auto
 
 lemmas [simp del] = lb_arctan.simps ub_arctan.simps
 
 lemma lb_arctan: "arctan (real_of_float x) \<le> y \<Longrightarrow> real_of_float (lb_arctan prec x) \<le> y"
   and ub_arctan: "y \<le> arctan x \<Longrightarrow> y \<le> ub_arctan prec x"
   for x::float and y::real
   using arctan_boundaries[of x prec] by auto
 
 lift_definition arctan_float_interval :: "nat \<Rightarrow> float interval \<Rightarrow> float interval"
   is "\<lambda>prec. \<lambda>(lx, ux). (lb_arctan prec lx, ub_arctan prec ux)"
   by (auto intro!: lb_arctan ub_arctan arctan_monotone')
 
 lemma lower_arctan_float_interval[simp]: "lower (arctan_float_interval p x) = lb_arctan p (lower x)"
   by transfer auto
 lemma upper_arctan_float_interval[simp]: "upper (arctan_float_interval p x) = ub_arctan p (upper x)"
   by transfer auto
 
 lemma arctan_float_interval:
   "arctan ` set_of (real_interval x) \<subseteq> set_of (real_interval (arctan_float_interval p x))"
   by (auto simp: set_of_eq intro!: lb_arctan ub_arctan arctan_monotone')
 
 lemma arctan_float_intervalI:
   "arctan x \<in>\<^sub>i real_interval (arctan_float_interval p X)"
   if "x \<in> set_of (real_interval X)"
   using arctan_float_interval[of X p] that
   by auto
 
 lemma bnds_cos_lower: "\<And>x. real_of_float xl \<le> x \<Longrightarrow> x \<le> real_of_float xu \<Longrightarrow> cos x \<le> y \<Longrightarrow> real_of_float (fst (bnds_cos prec xl xu)) \<le> y"
   and bnds_cos_upper: "\<And>x. real_of_float xl \<le> x \<Longrightarrow> x \<le> real_of_float xu \<Longrightarrow> y \<le> cos x \<Longrightarrow> y \<le> real_of_float (snd (bnds_cos prec xl xu))"
   for xl xu::float and y::real
   using bnds_cos[of "fst (bnds_cos prec xl xu)" "snd (bnds_cos prec xl xu)" prec]
   by force+
 
 lift_definition cos_float_interval :: "nat \<Rightarrow> float interval \<Rightarrow> float interval"
   is "\<lambda>prec. \<lambda>(lx, ux). bnds_cos prec lx ux"
   using bnds_cos
   by auto (metis (full_types) order_refl order_trans)
 
 lemma lower_cos_float_interval[simp]: "lower (cos_float_interval p x) = fst (bnds_cos p (lower x) (upper x))"
   by transfer auto
 lemma upper_cos_float_interval[simp]: "upper (cos_float_interval p x) = snd (bnds_cos p (lower x) (upper x))"
   by transfer auto
 
 lemma cos_float_interval:
   "cos ` set_of (real_interval x) \<subseteq> set_of (real_interval (cos_float_interval p x))"
   by (auto simp: set_of_eq bnds_cos_lower bnds_cos_upper)
 
 lemma cos_float_intervalI:
   "cos x \<in>\<^sub>i real_interval (cos_float_interval p X)"
   if "x \<in> set_of (real_interval X)"
   using cos_float_interval[of X p] that
   by auto
 
 lemma lb_exp: "exp x \<le> y \<Longrightarrow> lb_exp prec x \<le> y"
   and ub_exp: "y \<le> exp x \<Longrightarrow> y \<le> ub_exp prec x"
   for x::float and y::real using exp_boundaries[of x prec] by auto
 
 lift_definition exp_float_interval :: "nat \<Rightarrow> float interval \<Rightarrow> float interval"
   is "\<lambda>prec. \<lambda>(lx, ux). (lb_exp prec lx, ub_exp prec ux)"
   by (auto simp: lb_exp ub_exp)
 
 lemma lower_exp_float_interval[simp]: "lower (exp_float_interval p x) = lb_exp p (lower x)"
   by transfer auto
 lemma upper_exp_float_interval[simp]: "upper (exp_float_interval p x) = ub_exp p (upper x)"
   by transfer auto
 
 lemma exp_float_interval:
   "exp ` set_of (real_interval x) \<subseteq> set_of (real_interval (exp_float_interval p x))"
   using exp_boundaries apply (auto simp: set_of_eq)
   apply (smt exp_le_cancel_iff)
   apply (smt exp_le_cancel_iff)
   done
 
 lemma exp_float_intervalI:
   "exp x \<in>\<^sub>i real_interval (exp_float_interval p X)"
   if "x \<in> set_of (real_interval X)"
   using exp_float_interval[of X p] that
   by auto
 
 lemmas [simp del] = lb_ln.simps ub_ln.simps
 
 lemma lb_lnD:
   "y \<le> ln x \<and> 0 < real_of_float x" if "lb_ln prec x = Some y"
   using lb_ln[OF that[symmetric]] by auto
 
 lemma ub_lnD:
   "ln x \<le> y\<and> 0 < real_of_float x" if "ub_ln prec x = Some y"
   using ub_ln[OF that[symmetric]] by auto
 
 lift_definition(code_dt) ln_float_interval :: "nat \<Rightarrow> float interval \<Rightarrow> float interval option"
   is "\<lambda>prec. \<lambda>(lx, ux).
     Option.bind (lb_ln prec lx) (\<lambda>l.
       Option.bind (ub_ln prec ux) (\<lambda>u. Some (l, u)))"
   by (auto simp: pred_option_def bind_eq_Some_conv ln_le_cancel_iff[symmetric]
       simp del: ln_le_cancel_iff dest!: lb_lnD ub_lnD)
 
 lemma ln_float_interval_eq_Some_conv[simp]:
   "ln_float_interval p x = Some y \<longleftrightarrow>
     lb_ln p (lower x) = Some (lower y) \<and> ub_ln p (upper x) = Some (upper y)"
   by transfer (auto simp: bind_eq_Some_conv)
 
 lemma ln_float_interval: "ln ` set_of (real_interval x) \<subseteq> set_of (real_interval y)"
   if "ln_float_interval p x = Some y"
   using that
   by (simp add: set_of_eq)
     (smt atLeastAtMost_iff bnds_ln image_subset_iff)
 
 lemma ln_float_intervalI:
   "ln x \<in> set_of' (ln_float_interval p X)"
   if "x \<in>\<^sub>i (real_interval X)"
   using ln_float_interval[of p X] that
   by (auto simp: set_of'_def split: option.splits)
 
 lift_definition(code_dt) powr_float_interval :: "nat \<Rightarrow> float interval \<Rightarrow> float interval \<Rightarrow> float interval option"
   is "\<lambda>prec. \<lambda>(l1, u1). \<lambda>(l2, u2). bnds_powr prec l1 u1 l2 u2"
   by (auto simp: pred_option_def dest!: bnds_powr[OF sym])
 
 lemma powr_float_interval:
   "{x powr y | x y. x \<in> set_of (real_interval X) \<and> y \<in> set_of (real_interval Y)}
     \<subseteq> set_of (real_interval R)"
   if "powr_float_interval prec X Y = Some R"
   using that
   by transfer (auto dest!: bnds_powr[OF sym])
 
 lemma powr_float_intervalI:
   "x powr y \<in> set_of' (powr_float_interval p X Y)"
   if "x \<in>\<^sub>i real_interval X" "y \<in>\<^sub>i real_interval Y"
   using powr_float_interval[of p X Y] that
   by (auto simp: set_of'_def split: option.splits)
 
 lift_definition(code_dt) inverse_float_interval::"nat \<Rightarrow> float interval \<Rightarrow> float interval option" is
   "\<lambda>prec (l, u). if (0 < l \<or> u < 0) then Some (float_divl prec 1 u, float_divr prec 1 l) else None"
   by (auto intro!: order_trans[OF float_divl] order_trans[OF _ float_divr]
       simp: divide_simps)
 
 lemma inverse_float_interval_eq_Some_conv[simp]:
   defines "one \<equiv> (1::float)"
   shows 
     "inverse_float_interval p X = Some R \<longleftrightarrow>
     (lower X > 0 \<or> upper X < 0) \<and>
     lower R = float_divl p one (upper X) \<and>
     upper R = float_divr p one (lower X)"
   by clarsimp (transfer fixing: one, force simp: one_def split: if_splits)
 
 lemma inverse_float_interval:
   "inverse ` set_of (real_interval X) \<subseteq> set_of (real_interval Y)"
   if "inverse_float_interval p X = Some Y"
   using that
   apply (clarsimp simp: set_of_eq)
   by (intro order_trans[OF float_divl] order_trans[OF _ float_divr] conjI)
     (auto simp: divide_simps)
 
 lemma inverse_float_intervalI:
   "x \<in> set_of (real_interval X) \<Longrightarrow> inverse x \<in> set_of' (inverse_float_interval p X)"
   using inverse_float_interval[of p X]
   by (auto simp: set_of'_def split: option.splits)
 
 
 lift_definition pi_float_interval::"nat \<Rightarrow> float interval" is "\<lambda>prec. (lb_pi prec, ub_pi prec)"
   using pi_boundaries
   by (auto intro: order_trans)
 
 lemma lower_pi_float_interval[simp]: "lower (pi_float_interval prec) = lb_pi prec"
   by transfer auto
 lemma upper_pi_float_interval[simp]: "upper (pi_float_interval prec) = ub_pi prec"
   by transfer auto
 lemma pi_float_interval: "pi \<in> set_of (real_interval (pi_float_interval prec))"
   using pi_boundaries
   by (auto simp: set_of_eq)
 
 lemma real_interval_abs_interval[simp]:
   "real_interval (abs_interval x) = abs_interval (real_interval x)"
   by (auto simp: interval_eq_set_of_iff set_of_eq real_of_float_max real_of_float_min)
 
 lift_definition floor_float_interval::"float interval \<Rightarrow> float interval" is
   "\<lambda>(l, u). (floor_fl l, floor_fl u)"
   by (auto intro!: floor_mono simp: floor_fl.rep_eq)
 
 lemma lower_floor_float_interval[simp]: "lower (floor_float_interval x) = floor_fl (lower x)"
   by transfer auto
 lemma upper_floor_float_interval[simp]: "upper (floor_float_interval x) = floor_fl (upper x)"
   by transfer auto
 
 lemma floor_float_intervalI: "\<lfloor>x\<rfloor> \<in>\<^sub>i real_interval (floor_float_interval X)"
   if "x \<in>\<^sub>i real_interval X"
   using that by (auto simp: set_of_eq floor_fl_def floor_mono)
 
 
 lemma in_intervalI:
   "x \<in>\<^sub>i X" if "lower X \<le> x" "x \<le> upper X"
   using that by (auto simp: set_of_eq)
 
 abbreviation in_real_interval ("(_/ \<in>\<^sub>r _)" [51, 51] 50) where
   "x \<in>\<^sub>r X \<equiv> x \<in>\<^sub>i real_interval X"
 
 lemma in_real_intervalI:
   "x \<in>\<^sub>r X" if "lower X \<le> x" "x \<le> upper X" for x::real and X::"float interval"
   using that
   by (intro in_intervalI) auto
 
 lemma lower_Interval: "lower (Interval x) = fst x"
   and upper_Interval: "upper (Interval x) = snd x"
   if "fst x \<le> snd x"
   using that
   by (auto simp: lower_def upper_def Interval_inverse split_beta')
 
 definition all_in_i :: "'a::preorder list \<Rightarrow> 'a interval list \<Rightarrow> bool"
   (infix "(all'_in\<^sub>i)" 50)
   where "x all_in\<^sub>i I = (length x = length I \<and> (\<forall>i < length I. x ! i \<in>\<^sub>i I ! i))"
 
 definition all_in :: "real list \<Rightarrow> float interval list \<Rightarrow> bool"
   (infix "(all'_in)" 50)
   where "x all_in I = (length x = length I \<and> (\<forall>i < length I. x ! i \<in>\<^sub>r I ! i))"
 
 definition all_subset :: "'a::order interval list \<Rightarrow> 'a interval list \<Rightarrow> bool"
   (infix "(all'_subset)" 50)
   where "I all_subset J = (length I = length J \<and> (\<forall>i < length I. set_of (I!i) \<subseteq> set_of (J!i)))"
 
 lemmas [simp] = all_in_def all_subset_def
 
 lemma all_subsetD:
   assumes "I all_subset J"
   assumes "x all_in I"
   shows "x all_in J"
   using assms
   by (auto simp: set_of_eq; fastforce)
 
 lemma plus_down_mono: "plus_down p a b \<le> plus_down p c d" if "a + b \<le> c + d"
   by (auto simp: plus_down_def intro!: truncate_down_mono that)
 
 lemma plus_up_mono: "plus_up p a b \<le> plus_up p c d" if "a + b \<le> c + d"
   by (auto simp: plus_up_def intro!: truncate_up_mono that)
 
 lemma round_interval_mono: "set_of (round_interval prec X) \<subseteq> set_of (round_interval prec Y)"
   if "set_of X \<subseteq> set_of Y"
   using that
   by transfer
     (auto simp: float_round_down.rep_eq float_round_up.rep_eq truncate_down_mono truncate_up_mono)
 
 lemma mult_mono_nonpos_nonneg: "a * b \<le> c * d"
   if  "a \<le> c" "a \<le> 0" "0 \<le> d" "d \<le> b" for a b c d::"'a::ordered_ring"
   apply (rule order_trans[OF mult_left_mono_neg[OF \<open>d \<le> b\<close>]])
   subgoal using that by auto
   by (rule mult_right_mono; fact)
 
 lemma mult_mono_nonneg_nonpos: "b * a \<le> d * c"
   if  "a \<le> c" "c \<le> 0" "0 \<le> d" "d \<le> b" for a b c d::"'a::ordered_ring"
   apply (rule order_trans[OF mult_right_mono_neg[OF \<open>d \<le> b\<close>]])
   subgoal using that by auto
   by (rule mult_left_mono; fact)
 
 lemma mult_mono_nonpos_nonpos: "a * b \<le> c * d"
   if  "a \<ge> c" "a \<le> 0" "b \<ge> d" "d \<le> 0" for a b c d::real
   apply (rule order_trans[OF mult_left_mono_neg[OF \<open>d \<le> b\<close>]])
   subgoal using that by auto
   by (rule mult_right_mono_neg; fact)
 
 lemma mult_float_mono1:
   notes mono_rules = plus_down_mono add_mono nprt_mono nprt_le_zero zero_le_pprt pprt_mono
   shows "a \<le> b \<Longrightarrow> ab \<le> bb \<Longrightarrow>
        aa \<le> a \<Longrightarrow>
        b \<le> ba \<Longrightarrow>
        ac \<le> ab \<Longrightarrow>
        bb \<le> bc \<Longrightarrow>
        plus_down prec (nprt aa * pprt bc)
         (plus_down prec (nprt ba * nprt bc)
           (plus_down prec (pprt aa * pprt ac)
             (pprt ba * nprt ac)))
        \<le> plus_down prec (nprt a * pprt bb)
            (plus_down prec (nprt b * nprt bb)
              (plus_down prec (pprt a * pprt ab)
                (pprt b * nprt ab)))"
   apply (rule order_trans)
   apply (rule mono_rules | assumption)+
   apply (rule mult_mono_nonpos_nonneg)
   apply (rule mono_rules | assumption)+
   apply (rule mult_mono_nonpos_nonpos)
   apply (rule mono_rules | assumption)+
   apply (rule mult_mono)
   apply (rule mono_rules | assumption)+
   apply (rule mult_mono_nonneg_nonpos)
   apply (rule mono_rules | assumption)+
   by (rule order_refl)+
 
 lemma mult_float_mono2:
   notes mono_rules = plus_up_mono add_mono nprt_mono nprt_le_zero zero_le_pprt pprt_mono
   shows "a \<le> b \<Longrightarrow>
        ab \<le> bb \<Longrightarrow>
        aa \<le> a \<Longrightarrow>
        b \<le> ba \<Longrightarrow>
        ac \<le> ab \<Longrightarrow>
        bb \<le> bc \<Longrightarrow>
        plus_up prec (pprt b * pprt bb)
         (plus_up prec (pprt a * nprt bb)
           (plus_up prec (nprt b * pprt ab)
             (nprt a * nprt ab)))
        \<le> plus_up prec (pprt ba * pprt bc)
            (plus_up prec (pprt aa * nprt bc)
              (plus_up prec (nprt ba * pprt ac)
                (nprt aa * nprt ac)))"
   apply (rule order_trans)
   apply (rule mono_rules | assumption)+
   apply (rule mult_mono)
   apply (rule mono_rules | assumption)+
   apply (rule mult_mono_nonneg_nonpos)
   apply (rule mono_rules | assumption)+
   apply (rule mult_mono_nonpos_nonneg)
   apply (rule mono_rules | assumption)+
   apply (rule mult_mono_nonpos_nonpos)
   apply (rule mono_rules | assumption)+
   by (rule order_refl)+
 
 lemma mult_float_interval_mono: "set_of (mult_float_interval prec A B) \<subseteq> set_of (mult_float_interval prec X Y)"
   if "set_of A \<subseteq> set_of X" "set_of B \<subseteq> set_of Y"
   using that
   apply transfer
   unfolding bnds_mult_def atLeastatMost_subset_iff float_plus_down.rep_eq float_plus_up.rep_eq
   by (auto simp: float_plus_down.rep_eq float_plus_up.rep_eq mult_float_mono1 mult_float_mono2)
 
 lemma Ivl_simps[simp]: "lower (Ivl a b) = min a b" "upper (Ivl a b) = b"
   subgoal by transfer simp
   subgoal by transfer simp
   done
 
 lemmas [simp del] = power_down.simps(2) power_up.simps(2)
 lemmas power_down_simp = power_down.simps(2)
 lemmas power_up_simp = power_up.simps(2)
 
 lemma power_down_even_nonneg: "even n \<Longrightarrow> 0 \<le> power_down p x n"
   by (induct p x n rule: power_down.induct)
     (auto simp: power_down_simp simp del: odd_Suc_div_two intro!: truncate_down_nonneg )
 
 lemma truncate_down_less_zero_iff[simp]: "truncate_down p x < 0 \<longleftrightarrow> x < 0"
   by (metis le_less_trans not_less_iff_gr_or_eq truncate_down truncate_down_pos truncate_down_zero)
 
 lemma truncate_down_nonneg_iff[simp]: "truncate_down p x \<ge> 0 \<longleftrightarrow> x \<ge> 0"
   using truncate_down_less_zero_iff[of p x] truncate_down_nonneg[of x p]
   by linarith
 
 lemma truncate_down_eq_zero_iff[simp]: "truncate_down prec x = 0 \<longleftrightarrow> x = 0"
   by (metis not_less_iff_gr_or_eq truncate_down_less_zero_iff truncate_down_pos truncate_down_zero)
 
 lemma power_down_eq_zero_iff[simp]: "power_down prec b n = 0 \<longleftrightarrow> b = 0 \<and> n \<noteq> 0"
 proof (induction n arbitrary: b rule: less_induct)
   case (less x)
   then show ?case
     using power_down_simp[of _ _ "x - 1"]
-    by (cases x) (auto simp: sign_simps zero_le_mult_iff div2_less_self)
+    by (cases x) (auto simp add: div2_less_self)
 qed
 
 lemma power_down_nonneg_iff[simp]:
   "power_down prec b n \<ge> 0 \<longleftrightarrow> even n \<or> b \<ge> 0"
 proof (induction n arbitrary: b rule: less_induct)
   case (less x)
   show ?case
     using less(1)[of "x - 1" b] power_down_simp[of _ _ "x - 1"]
     by (cases x) (auto simp: sign_simps zero_le_mult_iff)
 qed
 
 lemma power_down_neg_iff[simp]:
   "power_down prec b n < 0 \<longleftrightarrow>
     b < 0 \<and> odd n"
   using power_down_nonneg_iff[of prec b n] by (auto simp del: power_down_nonneg_iff)
 
 lemma power_down_nonpos_iff[simp]:
   notes [simp del] = power_down_neg_iff power_down_eq_zero_iff
   shows "power_down prec b n \<le> 0 \<longleftrightarrow> b < 0 \<and> odd n \<or> b = 0 \<and> n \<noteq> 0"
   using power_down_neg_iff[of prec b n] power_down_eq_zero_iff[of prec b n]
   by auto
 
 lemma power_down_mono:
   "power_down prec a n \<le> power_down prec b n"
   if "((0 \<le> a \<and> a \<le> b)\<or>(odd n \<and> a \<le> b) \<or> (even n \<and> a \<le> 0 \<and> b \<le> a))"
   using that
 proof (induction n arbitrary: a b rule: less_induct)
   case (less i)
   show ?case
   proof (cases i)
     case j: (Suc j)
     note IH = less[unfolded j even_Suc not_not]
     note [simp del] = power_down.simps
     show ?thesis
     proof cases
       assume [simp]: "even j"
       have "a * power_down prec a j \<le> b * power_down prec b j"
         by (smt IH(1) IH(2) \<open>even j\<close> lessI mult_mono' mult_mono_nonpos_nonneg power_down_even_nonneg)
       then have "truncate_down (Suc prec) (a * power_down prec a j) \<le> truncate_down (Suc prec) (b * power_down prec b j)"
         by (auto intro!: truncate_down_mono simp: abs_le_square_iff[symmetric] abs_real_def)
       then show ?thesis
         unfolding j
         by (simp add: power_down_simp)
     next
       assume [simp]: "odd j"
       have "power_down prec 0 (Suc (j div 2)) \<le> - power_down prec b (Suc (j div 2))"
         if "b < 0" "even (j div 2)"
         apply (rule order_trans[where y=0])
         using IH that by (auto simp: div2_less_self)
       then have "truncate_down (Suc prec) ((power_down prec a (Suc (j div 2)))\<^sup>2)
         \<le> truncate_down (Suc prec) ((power_down prec b (Suc (j div 2)))\<^sup>2)"
         using IH
         by (auto intro!: truncate_down_mono intro: order_trans[where y=0]
             simp: abs_le_square_iff[symmetric] abs_real_def
             div2_less_self)
       then show ?thesis
         unfolding j
         by (simp add: power_down_simp)
     qed
   qed simp
 qed
 
 lemma truncate_up_nonneg: "0 \<le> truncate_up p x" if "0 \<le> x"
   by (simp add: that truncate_up_le)
 
 lemma truncate_up_pos: "0 < truncate_up p x" if "0 < x"
   by (meson less_le_trans that truncate_up)
 
 lemma truncate_up_less_zero_iff[simp]: "truncate_up p x < 0 \<longleftrightarrow> x < 0"
 proof -
   have f1: "\<forall>n r. truncate_up n r + truncate_down n (- 1 * r) = 0"
     by (simp add: truncate_down_uminus_eq)
   have f2: "(\<forall>v0 v1. truncate_up v0 v1 + truncate_down v0 (- 1 * v1) = 0) = (\<forall>v0 v1. truncate_up v0 v1 = - 1 * truncate_down v0 (- 1 * v1))"
     by (auto simp: truncate_up_eq_truncate_down)
   have f3: "\<forall>x1. ((0::real) < x1) = (\<not> x1 \<le> 0)"
     by fastforce
   have "(- 1 * x \<le> 0) = (0 \<le> x)"
     by force
   then have "0 \<le> x \<or> \<not> truncate_down p (- 1 * x) \<le> 0"
     using f3 by (meson truncate_down_pos)
   then have "(0 \<le> truncate_up p x) \<noteq> (\<not> 0 \<le> x)"
     using f2 f1 truncate_up_nonneg by force
   then show ?thesis
     by linarith
 qed
 
 lemma truncate_up_nonneg_iff[simp]: "truncate_up p x \<ge> 0 \<longleftrightarrow> x \<ge> 0"
   using truncate_up_less_zero_iff[of p x] truncate_up_nonneg[of x]
   by linarith
 
 lemma power_up_even_nonneg: "even n \<Longrightarrow> 0 \<le> power_up p x n"
   by (induct p x n rule: power_up.induct)
     (auto simp: power_up.simps simp del: odd_Suc_div_two intro!: )
 
 lemma truncate_up_eq_zero_iff[simp]: "truncate_up prec x = 0 \<longleftrightarrow> x = 0"
   by (metis not_less_iff_gr_or_eq truncate_up_less_zero_iff truncate_up_pos truncate_up_zero)
 
 lemma power_up_eq_zero_iff[simp]: "power_up prec b n = 0 \<longleftrightarrow> b = 0 \<and> n \<noteq> 0"
 proof (induction n arbitrary: b rule: less_induct)
   case (less x)
   then show ?case
     using power_up_simp[of _ _ "x - 1"]
     by (cases x) (auto simp: sign_simps zero_le_mult_iff div2_less_self)
 qed
 
 lemma power_up_nonneg_iff[simp]:
   "power_up prec b n \<ge> 0 \<longleftrightarrow> even n \<or> b \<ge> 0"
 proof (induction n arbitrary: b rule: less_induct)
   case (less x)
   show ?case
     using less(1)[of "x - 1" b] power_up_simp[of _ _ "x - 1"]
     by (cases x) (auto simp: sign_simps zero_le_mult_iff)
 qed
 
 lemma power_up_neg_iff[simp]:
   "power_up prec b n < 0 \<longleftrightarrow> b < 0 \<and> odd n"
   using power_up_nonneg_iff[of prec b n] by (auto simp del: power_up_nonneg_iff)
 
 lemma power_up_nonpos_iff[simp]:
   notes [simp del] = power_up_neg_iff power_up_eq_zero_iff
   shows "power_up prec b n \<le> 0 \<longleftrightarrow> b < 0 \<and> odd n \<or> b = 0 \<and> n \<noteq> 0"
   using power_up_neg_iff[of prec b n] power_up_eq_zero_iff[of prec b n]
   by auto
 
 lemma power_up_mono:
   "power_up prec a n \<le> power_up prec b n"
   if "((0 \<le> a \<and> a \<le> b)\<or>(odd n \<and> a \<le> b) \<or> (even n \<and> a \<le> 0 \<and> b \<le> a))"
   using that
 proof (induction n arbitrary: a b rule: less_induct)
   case (less i)
   show ?case
   proof (cases i)
     case j: (Suc j)
     note IH = less[unfolded j even_Suc not_not]
     note [simp del] = power_up.simps
     show ?thesis
     proof cases
       assume [simp]: "even j"
       have "a * power_up prec a j \<le> b * power_up prec b j"
         by (smt IH(1) IH(2) \<open>even j\<close> lessI mult_mono' mult_mono_nonpos_nonneg power_up_even_nonneg)
       then have "truncate_up prec (a * power_up prec a j) \<le> truncate_up prec (b * power_up prec b j)"
         by (auto intro!: truncate_up_mono simp: abs_le_square_iff[symmetric] abs_real_def)
       then show ?thesis
         unfolding j
         by (simp add: power_up_simp)
     next
       assume [simp]: "odd j"
       have "power_up prec 0 (Suc (j div 2)) \<le> - power_up prec b (Suc (j div 2))"
         if "b < 0" "even (j div 2)"
         apply (rule order_trans[where y=0])
         using IH that by (auto simp: div2_less_self)
       then have "truncate_up prec ((power_up prec a (Suc (j div 2)))\<^sup>2)
         \<le> truncate_up prec ((power_up prec b (Suc (j div 2)))\<^sup>2)"
         using IH
         by (auto intro!: truncate_up_mono intro: order_trans[where y=0]
             simp: abs_le_square_iff[symmetric] abs_real_def
             div2_less_self)
       then show ?thesis
         unfolding j
         by (simp add: power_up_simp)
     qed
   qed simp
 qed
 
 lemma set_of_subset_iff: "set_of X \<subseteq> set_of Y \<longleftrightarrow> lower Y \<le> lower X \<and> upper X \<le> upper Y"
   for X Y::"'a::linorder interval"
   by (auto simp: set_of_eq subset_iff)
 
 lemma power_float_interval_mono:
   "set_of (power_float_interval prec n A)
     \<subseteq> set_of (power_float_interval prec n B)"
   if "set_of A \<subseteq> set_of B"
 proof -
   define la where "la = real_of_float (lower A)"
   define ua where "ua = real_of_float (upper A)"
   define lb where "lb = real_of_float (lower B)"
   define ub where "ub = real_of_float (upper B)"
   have ineqs: "lb \<le> la" "la \<le> ua" "ua \<le> ub" "lb \<le> ub"
     using that lower_le_upper[of A] lower_le_upper[of B]
     by (auto simp: la_def ua_def lb_def ub_def set_of_eq)
   show ?thesis
     using ineqs
     by (simp add: set_of_subset_iff float_power_bnds_def max_def
         power_down_fl.rep_eq power_up_fl.rep_eq
         la_def[symmetric] ua_def[symmetric] lb_def[symmetric] ub_def[symmetric])
       (auto intro!: power_down_mono power_up_mono intro: order_trans[where y=0])
 qed
 
 lemma bounds_of_interval_eq_lower_upper:
   "bounds_of_interval ivl = (lower ivl, upper ivl)" if "lower ivl \<le> upper ivl"
   using that
   by (auto simp: lower.rep_eq upper.rep_eq)
 
 lemma real_interval_Ivl: "real_interval (Ivl a b) = Ivl a b"
   by transfer (auto simp: min_def)
 
 lemma set_of_mul_contains_real_zero:
   "0 \<in>\<^sub>r (A * B)" if "0 \<in>\<^sub>r A \<or> 0 \<in>\<^sub>r B"
   using that set_of_mul_contains_zero[of A B]
   by (auto simp: set_of_eq)
 
 fun subdivide_interval :: "nat \<Rightarrow> float interval \<Rightarrow> float interval list"
   where "subdivide_interval 0 I = [I]"
   | "subdivide_interval (Suc n) I = (
          let m = mid I
          in (subdivide_interval n (Ivl (lower I) m)) @ (subdivide_interval n (Ivl m (upper I)))
        )"
 
 lemma subdivide_interval_length:
   shows "length (subdivide_interval n I) = 2^n"
   by(induction n arbitrary: I, simp_all add: Let_def)
 
 lemma lower_le_mid: "lower x \<le> mid x" "real_of_float (lower x) \<le> mid x"
   and mid_le_upper: "mid x \<le> upper x" "real_of_float (mid x) \<le> upper x"
   unfolding mid_def
   subgoal by transfer auto
   subgoal by transfer auto
   subgoal by transfer auto
   subgoal by transfer auto
   done
 
 lemma subdivide_interval_correct:
   "list_ex (\<lambda>i. x \<in>\<^sub>r i) (subdivide_interval n I)" if "x \<in>\<^sub>r I" for x::real
   using that
 proof(induction n arbitrary: x I)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   from \<open>x \<in>\<^sub>r I\<close> consider "x \<in>\<^sub>r Ivl (lower I) (mid I)" | "x \<in>\<^sub>r Ivl (mid I) (upper I)"
     by (cases "x \<le> real_of_float (mid I)")
       (auto simp: set_of_eq min_def lower_le_mid mid_le_upper)
   from this[case_names lower upper] show ?case
     by cases (use Suc.IH in \<open>auto simp: Let_def\<close>)
 qed
 
 fun interval_list_union :: "'a::lattice interval list \<Rightarrow> 'a interval"
   where "interval_list_union [] = undefined"
   | "interval_list_union [I] = I"
   | "interval_list_union (I#Is) = sup I (interval_list_union Is)"
 
 lemma interval_list_union_correct:
   assumes "S \<noteq> []"
   assumes "i < length S"
   shows "set_of (S!i) \<subseteq> set_of (interval_list_union S)"
   using assms
 proof(induction S arbitrary: i)
   case (Cons a S i)
   thus ?case
   proof(cases S)
     fix b S'
     assume "S = b # S'"
     hence "S \<noteq> []"
       by simp
     show ?thesis
     proof(cases i)
       case 0
       show ?thesis
         apply(cases S)
         using interval_union_mono1
         by (auto simp add: 0)
     next
       case (Suc i_prev)
       hence "i_prev < length S"
         using Cons(3) by simp
 
       from Cons(1)[OF \<open>S \<noteq> []\<close> this] Cons(1)
       have "set_of ((a # S) ! i) \<subseteq> set_of (interval_list_union S)"
         by (simp add: \<open>i = Suc i_prev\<close>)
       also have "... \<subseteq> set_of (interval_list_union (a # S))"
         using \<open>S \<noteq> []\<close>
         apply(cases S)
         using interval_union_mono2
         by auto
       finally show ?thesis .
     qed
   qed simp
 qed simp
 
 lemma split_domain_correct:
   fixes x :: "real list"
   assumes "x all_in I"
   assumes split_correct: "\<And>x a I. x \<in>\<^sub>r I \<Longrightarrow> list_ex (\<lambda>i::float interval. x \<in>\<^sub>r i) (split I)"
   shows "list_ex (\<lambda>s. x all_in s) (split_domain split I)"
   using assms(1)
 proof(induction I arbitrary: x)
   case (Cons I Is x)
   have "x \<noteq> []"
     using Cons(2) by auto
   obtain x' xs where x_decomp: "x = x' # xs"
     using \<open>x \<noteq> []\<close> list.exhaust by auto
   hence "x' \<in>\<^sub>r I" "xs all_in Is"
     using Cons(2)
     by auto
   show ?case
     using Cons(1)[OF \<open>xs all_in Is\<close>]
       split_correct[OF \<open>x' \<in>\<^sub>r I\<close>]
-    apply(simp add: list_ex_iff set_of_eq)
+    apply (auto simp add: list_ex_iff set_of_eq)
     by (smt length_Cons less_Suc_eq_0_disj nth_Cons_0 nth_Cons_Suc x_decomp)
 qed simp
 
 end
\ No newline at end of file
diff --git a/thys/Winding_Number_Eval/Missing_Topology.thy b/thys/Winding_Number_Eval/Missing_Topology.thy
--- a/thys/Winding_Number_Eval/Missing_Topology.thy
+++ b/thys/Winding_Number_Eval/Missing_Topology.thy
@@ -1,739 +1,740 @@
 (*
     Author:     Wenda Li <wl302@cam.ac.uk / liwenda1990@hotmail.com>
 *)
 
 section \<open>Some useful lemmas in topology\<close>
 
 theory Missing_Topology imports "HOL-Analysis.Analysis"
 begin
 
 subsection \<open>Misc\<close>    
  
 lemma open_times_image:
   fixes S::"'a::real_normed_field set"
   assumes "open S" "c\<noteq>0"
   shows "open (((*) c) ` S)" 
 proof -
   let ?f = "\<lambda>x. x/c" and ?g="((*) c)"
   have "continuous_on UNIV ?f" using \<open>c\<noteq>0\<close> by (auto intro:continuous_intros)
   then have "open (?f -` S)" using \<open>open S\<close> by (auto elim:open_vimage)
   moreover have "?g ` S = ?f -` S" using \<open>c\<noteq>0\<close>
     apply auto
     using image_iff by fastforce
   ultimately show ?thesis by auto
 qed   
  
 lemma image_linear_greaterThan:
   fixes x::"'a::linordered_field"
   assumes "c\<noteq>0"
   shows "((\<lambda>x. c*x+b) ` {x<..}) = (if c>0 then {c*x+b <..} else {..< c*x+b})"
 using \<open>c\<noteq>0\<close>
   apply (auto simp add:image_iff field_simps)    
   subgoal for y by (rule bexI[where x="(y-b)/c"],auto simp add:field_simps)
   subgoal for y by (rule bexI[where x="(y-b)/c"],auto simp add:field_simps)
 done
 
 lemma image_linear_lessThan:
   fixes x::"'a::linordered_field"
   assumes "c\<noteq>0"
   shows "((\<lambda>x. c*x+b) ` {..<x}) = (if c>0 then {..<c*x+b} else {c*x+b<..})"
 using \<open>c\<noteq>0\<close>
   apply (auto simp add:image_iff field_simps)    
   subgoal for y by (rule bexI[where x="(y-b)/c"],auto simp add:field_simps)
   subgoal for y by (rule bexI[where x="(y-b)/c"],auto simp add:field_simps)
 done    
  
 lemma continuous_on_neq_split:
   fixes f :: "'a::linear_continuum_topology \<Rightarrow> 'b::linorder_topology"
   assumes "\<forall>x\<in>s. f x\<noteq>y" "continuous_on s f" "connected s"
   shows "(\<forall>x\<in>s. f x>y) \<or> (\<forall>x\<in>s. f x<y)" 
 proof -
   { fix aa :: 'a and aaa :: 'a
     have "y \<notin> f ` s"
       using assms(1) by blast
     then have "(aa \<notin> s \<or> y < f aa) \<or> aaa \<notin> s \<or> f aaa < y"
       by (meson Topological_Spaces.connected_continuous_image assms(2) assms(3) 
           connectedD_interval image_eqI linorder_not_le) }
   then show ?thesis
     by blast
 qed
 
 lemma
   fixes f::"'a::linorder_topology \<Rightarrow> 'b::topological_space"
   assumes "continuous_on {a..b} f" "a<b"
   shows continuous_on_at_left:"continuous (at_left b) f" 
     and continuous_on_at_right:"continuous (at_right a) f"
 proof -
   have "at b within {..a} = bot" 
   proof -
     have "closed {..a}" by auto
     then have "closure ({..a} - {b}) = {..a}" by (simp add: assms(2) not_le)
     then have "b\<notin>closure ({..a} - {b})" using \<open>a<b\<close> by auto
     then show ?thesis using at_within_eq_bot_iff by auto
   qed
   then have "(f \<longlongrightarrow> f b) (at b within {..a})" by auto
   moreover have "(f \<longlongrightarrow> f b) (at b within {a..b})"
     using assms unfolding continuous_on by auto
   moreover have "{..a} \<union> {a..b} = {..b}"
     using \<open>a<b\<close> by auto
   ultimately have "(f \<longlongrightarrow> f b) (at b within {..b})" 
     using Lim_Un[of f "f b" b "{..a}" "{a..b}"] by presburger
   then have "(f \<longlongrightarrow> f b) (at b within {..<b})"
     apply (elim tendsto_within_subset)
     by auto
   then show "continuous (at_left b) f" using continuous_within by auto
 next
   have "at a within {b..} = bot" 
   proof -
     have "closed {b..}" by auto
     then have "closure ({b..} - {a}) = {b..}" by (simp add: assms(2) not_le)
     then have "a\<notin>closure ({b..} - {a})" using \<open>a<b\<close> by auto
     then show ?thesis using at_within_eq_bot_iff by auto
   qed
   then have "(f \<longlongrightarrow> f a) (at a within {b..})" by auto
   moreover have "(f \<longlongrightarrow> f a) (at a within {a..b})"
     using assms unfolding continuous_on by auto
   moreover have "{b..} \<union> {a..b} = {a..}"
     using \<open>a<b\<close> by auto
   ultimately have "(f \<longlongrightarrow> f a) (at a within {a..})" 
     using Lim_Un[of f "f a" a "{b..}" "{a..b}"] by presburger
   then have "(f \<longlongrightarrow> f a) (at a within {a<..})"
     apply (elim tendsto_within_subset)
     by auto
   then show "continuous (at_right a) f" using continuous_within by auto
 qed 
   
 subsection \<open>More about @{term eventually}\<close>    
     
 lemma eventually_comp_filtermap:
     "eventually (P o f) F \<longleftrightarrow> eventually P (filtermap f F)"
   unfolding comp_def using eventually_filtermap by auto
  
 lemma eventually_uminus_at_top_at_bot:
   fixes P::"'a::{ordered_ab_group_add,linorder} \<Rightarrow> bool"
   shows "eventually (P o uminus) at_bot \<longleftrightarrow> eventually P at_top"
     "eventually (P o uminus) at_top \<longleftrightarrow> eventually P at_bot"
   unfolding eventually_comp_filtermap
   by (fold at_top_mirror at_bot_mirror,auto)
     
 lemma eventually_at_infinityI:
   fixes P::"'a::real_normed_vector \<Rightarrow> bool"
   assumes "\<And>x. c \<le> norm x \<Longrightarrow> P x"
   shows "eventually P at_infinity"  
 unfolding eventually_at_infinity using assms by auto
    
 lemma eventually_at_bot_linorderI:
   fixes c::"'a::linorder"
   assumes "\<And>x. x \<le> c \<Longrightarrow> P x"
   shows "eventually P at_bot"
   using assms by (auto simp: eventually_at_bot_linorder)     
 
 lemma eventually_times_inverse_1:
   fixes f::"'a \<Rightarrow> 'b::{field,t2_space}"
   assumes "(f \<longlongrightarrow> c) F" "c\<noteq>0"
   shows "\<forall>\<^sub>F x in F. inverse (f x) * f x = 1"
 proof -
   have "\<forall>\<^sub>F x in F. f x\<noteq>0" 
     using assms tendsto_imp_eventually_ne by blast
   then show ?thesis
     apply (elim eventually_mono)
     by auto
 qed  
   
 subsection \<open>More about @{term filtermap}\<close> 
 
 lemma filtermap_linear_at_within:
   assumes "bij f" and cont: "isCont f a" and open_map: "\<And>S. open S \<Longrightarrow> open (f`S)"
   shows "filtermap f (at a within S) = at (f a) within f`S"
   unfolding filter_eq_iff
 proof safe
   fix P
   assume "eventually P (filtermap f (at a within S))"
   then obtain T where "open T" "a \<in> T" and impP:"\<forall>x\<in>T. x\<noteq>a \<longrightarrow> x\<in>S\<longrightarrow> P (f x)"
     by (auto simp: eventually_filtermap eventually_at_topological)
   then show "eventually P (at (f a) within f ` S)"
     unfolding eventually_at_topological
     apply (intro exI[of _ "f`T"])
     using \<open>bij f\<close> open_map by (metis bij_pointE imageE imageI)  
 next
   fix P
   assume "eventually P (at (f a) within f ` S)"
   then obtain T1 where "open T1" "f a \<in> T1" and impP:"\<forall>x\<in>T1. x\<noteq>f a \<longrightarrow> x\<in>f`S\<longrightarrow> P (x)"
     unfolding eventually_at_topological by auto
   then obtain T2 where "open T2" "a \<in> T2" "(\<forall>x'\<in>T2. f x' \<in> T1)" 
     using cont[unfolded continuous_at_open,rule_format,of T1] by blast 
   then have "\<forall>x\<in>T2. x\<noteq>a \<longrightarrow> x\<in>S\<longrightarrow> P (f x)"
     using impP by (metis assms(1) bij_pointE imageI)
   then show "eventually P (filtermap f (at a within S))" 
     unfolding eventually_filtermap eventually_at_topological 
     apply (intro exI[of _ T2])
     using \<open>open T2\<close> \<open>a \<in> T2\<close> by auto
 qed
   
 lemma filtermap_at_bot_linear_eq:
   fixes c::"'a::linordered_field"
   assumes "c\<noteq>0"
   shows "filtermap (\<lambda>x. x * c + b) at_bot = (if c>0 then at_bot else at_top)"
 proof (cases "c>0")
   case True
   then have "filtermap (\<lambda>x. x * c + b) at_bot = at_bot" 
     apply (intro filtermap_fun_inverse[of "\<lambda>x. (x-b) / c"])
     subgoal unfolding eventually_at_bot_linorder filterlim_at_bot
-      by (meson linordered_field_class.sign_simps(42) pos_divide_le_eq)
+      by (auto simp add: field_simps)
     subgoal unfolding eventually_at_bot_linorder filterlim_at_bot
-      by (metis linordered_field_class.sign_simps(24) real_affinity_le)
+      by (metis mult.commute real_affinity_le)
     by auto
   then show ?thesis using \<open>c>0\<close> by auto
 next
   case False
   then have "c<0" using \<open>c\<noteq>0\<close> by auto
   then have "filtermap (\<lambda>x. x * c + b) at_bot = at_top"
     apply (intro filtermap_fun_inverse[of "\<lambda>x. (x-b) / c"])
     subgoal unfolding eventually_at_top_linorder filterlim_at_bot
       by (meson le_diff_eq neg_divide_le_eq)
     subgoal unfolding eventually_at_bot_linorder filterlim_at_top
-      using linordered_field_class.sign_simps(42) neg_le_divide_eq by blast
+      using \<open>c < 0\<close> by (meson False diff_le_eq le_divide_eq)
     by auto
   then show ?thesis using \<open>c<0\<close> by auto
 qed  
   
 lemma filtermap_linear_at_left:
   fixes c::"'a::{linordered_field,linorder_topology,real_normed_field}"
   assumes "c\<noteq>0"
   shows "filtermap (\<lambda>x. c*x+b) (at_left x) = (if c>0 then at_left (c*x+b) else at_right (c*x+b))"
 proof -
   let ?f = "\<lambda>x. c*x+b"
   have "filtermap (\<lambda>x. c*x+b) (at_left x) = (at (?f x) within ?f ` {..<x})"
   proof (subst filtermap_linear_at_within)
     show "bij ?f" using \<open>c\<noteq>0\<close> 
       by (auto intro!: o_bij[of "\<lambda>x. (x-b)/c"])
     show "isCont ?f x" by auto
     show "\<And>S. open S \<Longrightarrow> open (?f ` S)" 
       using open_times_image[OF _ \<open>c\<noteq>0\<close>,THEN open_translation,of _ b]  
       by (simp add:image_image add.commute)
     show "at (?f x) within ?f ` {..<x} = at (?f x) within ?f ` {..<x}" by simp
   qed
   moreover have "?f ` {..<x} =  {..<?f x}" when "c>0" 
     using image_linear_lessThan[OF \<open>c\<noteq>0\<close>,of b x] that by auto
   moreover have "?f ` {..<x} =  {?f x<..}" when "\<not> c>0" 
     using image_linear_lessThan[OF \<open>c\<noteq>0\<close>,of b x] that by auto
   ultimately show ?thesis by auto
 qed
     
 lemma filtermap_linear_at_right:
   fixes c::"'a::{linordered_field,linorder_topology,real_normed_field}"
   assumes "c\<noteq>0"
   shows "filtermap (\<lambda>x. c*x+b) (at_right x) = (if c>0 then at_right (c*x+b) else at_left (c*x+b))" 
 proof -
   let ?f = "\<lambda>x. c*x+b"
   have "filtermap ?f (at_right x) = (at (?f x) within ?f ` {x<..})"
   proof (subst filtermap_linear_at_within)
     show "bij ?f" using \<open>c\<noteq>0\<close> 
       by (auto intro!: o_bij[of "\<lambda>x. (x-b)/c"])
     show "isCont ?f x" by auto
     show "\<And>S. open S \<Longrightarrow> open (?f ` S)" 
       using open_times_image[OF _ \<open>c\<noteq>0\<close>,THEN open_translation,of _ b]  
       by (simp add:image_image add.commute)
     show "at (?f x) within ?f ` {x<..} = at (?f x) within ?f ` {x<..}" by simp
   qed
   moreover have "?f ` {x<..} =  {?f x<..}" when "c>0" 
     using image_linear_greaterThan[OF \<open>c\<noteq>0\<close>,of b x] that by auto
   moreover have "?f ` {x<..} =  {..<?f x}" when "\<not> c>0" 
     using image_linear_greaterThan[OF \<open>c\<noteq>0\<close>,of b x] that by auto
   ultimately show ?thesis by auto
 qed
  
 lemma filtermap_at_top_linear_eq:
   fixes c::"'a::linordered_field"
   assumes "c\<noteq>0"
   shows "filtermap (\<lambda>x. x * c + b) at_top = (if c>0 then at_top else at_bot)"
 proof (cases "c>0")
   case True
   then have "filtermap (\<lambda>x. x * c + b) at_top = at_top" 
     apply (intro filtermap_fun_inverse[of "\<lambda>x. (x-b) / c"])
     subgoal unfolding eventually_at_top_linorder filterlim_at_top 
       by (meson le_diff_eq pos_le_divide_eq)
     subgoal unfolding eventually_at_top_linorder filterlim_at_top
-      by (metis linordered_field_class.sign_simps(24) real_le_affinity)  
+      apply auto
+      by (metis mult.commute real_le_affinity) 
     by auto
   then show ?thesis using \<open>c>0\<close> by auto
 next
   case False
   then have "c<0" using \<open>c\<noteq>0\<close> by auto
   then have "filtermap (\<lambda>x. x * c + b) at_top = at_bot"
     apply (intro filtermap_fun_inverse[of "\<lambda>x. (x-b) / c"])
-    subgoal unfolding eventually_at_bot_linorder filterlim_at_top 
-      by (meson linordered_field_class.sign_simps(42) neg_le_divide_eq)
+    subgoal unfolding eventually_at_bot_linorder filterlim_at_top
+      by (auto simp add: field_simps)
     subgoal unfolding eventually_at_top_linorder filterlim_at_bot
       by (meson le_diff_eq neg_divide_le_eq)
     by auto
   then show ?thesis using \<open>c<0\<close> by auto
 qed
 
   
 lemma filtermap_nhds_open_map:
   assumes cont: "isCont f a"
     and open_map: "\<And>S. open S \<Longrightarrow> open (f`S)"
   shows "filtermap f (nhds a) = nhds (f a)"
   unfolding filter_eq_iff
 proof safe
   fix P
   assume "eventually P (filtermap f (nhds a))"
   then obtain S where "open S" "a \<in> S" "\<forall>x\<in>S. P (f x)"
     by (auto simp: eventually_filtermap eventually_nhds)
   then show "eventually P (nhds (f a))"
     unfolding eventually_nhds 
     apply (intro exI[of _ "f`S"]) 
     by (auto intro!: open_map)
 qed (metis filterlim_iff tendsto_at_iff_tendsto_nhds isCont_def eventually_filtermap cont)
   
 subsection \<open>More about @{term filterlim}\<close>
   
 lemma filterlim_at_infinity_times:
   fixes f :: "'a \<Rightarrow> 'b::real_normed_field"
   assumes "filterlim f at_infinity F" "filterlim g at_infinity F"
   shows "filterlim (\<lambda>x. f x * g x) at_infinity F"  
 proof -
   have "((\<lambda>x. inverse (f x) * inverse (g x)) \<longlongrightarrow> 0 * 0) F"
     by (intro tendsto_mult tendsto_inverse assms filterlim_compose[OF tendsto_inverse_0])
   then have "filterlim (\<lambda>x. inverse (f x) * inverse (g x)) (at 0) F"
     unfolding filterlim_at using assms
     by (auto intro: filterlim_at_infinity_imp_eventually_ne tendsto_imp_eventually_ne eventually_conj)
   then show ?thesis
     by (subst filterlim_inverse_at_iff[symmetric]) simp_all
 qed   
   
 lemma filterlim_at_top_at_bot[elim]:
   fixes f::"'a \<Rightarrow> 'b::unbounded_dense_linorder" and F::"'a filter"
   assumes top:"filterlim f at_top F" and bot: "filterlim f at_bot F" and "F\<noteq>bot"
   shows False
 proof -
   obtain c::'b where True by auto
   have "\<forall>\<^sub>F x in F. c < f x" 
     using top unfolding filterlim_at_top_dense by auto
   moreover have "\<forall>\<^sub>F x in F. f x < c" 
     using bot unfolding filterlim_at_bot_dense by auto
   ultimately have "\<forall>\<^sub>F x in F. c < f x \<and> f x < c" 
     using eventually_conj by auto
   then have "\<forall>\<^sub>F x in F. False" by (auto elim:eventually_mono)
   then show False using \<open>F\<noteq>bot\<close> by auto
 qed  
 
 lemma filterlim_at_top_nhds[elim]:      
   fixes f::"'a \<Rightarrow> 'b::{unbounded_dense_linorder,order_topology}" and F::"'a filter"
   assumes top:"filterlim f at_top F" and tendsto: "(f \<longlongrightarrow> c) F" and "F\<noteq>bot"
   shows False
 proof -
   obtain c'::'b where "c'>c" using gt_ex by blast
   have "\<forall>\<^sub>F x in F. c' < f x" 
     using top unfolding filterlim_at_top_dense by auto
   moreover have "\<forall>\<^sub>F x in F. f x < c'" 
     using order_tendstoD[OF tendsto,of c'] \<open>c'>c\<close> by auto
   ultimately have "\<forall>\<^sub>F x in F. c' < f x \<and> f x < c'" 
     using eventually_conj by auto
   then have "\<forall>\<^sub>F x in F. False" by (auto elim:eventually_mono)
   then show False using \<open>F\<noteq>bot\<close> by auto
 qed
 
 lemma filterlim_at_bot_nhds[elim]:      
   fixes f::"'a \<Rightarrow> 'b::{unbounded_dense_linorder,order_topology}" and F::"'a filter"
   assumes top:"filterlim f at_bot F" and tendsto: "(f \<longlongrightarrow> c) F" and "F\<noteq>bot"
   shows False
 proof -
   obtain c'::'b where "c'<c" using lt_ex by blast
   have "\<forall>\<^sub>F x in F. c' > f x" 
     using top unfolding filterlim_at_bot_dense by auto
   moreover have "\<forall>\<^sub>F x in F. f x > c'" 
     using order_tendstoD[OF tendsto,of c'] \<open>c'<c\<close> by auto
   ultimately have "\<forall>\<^sub>F x in F. c' < f x \<and> f x < c'" 
     using eventually_conj by auto
   then have "\<forall>\<^sub>F x in F. False" by (auto elim:eventually_mono)
   then show False using \<open>F\<noteq>bot\<close> by auto
 qed  
   
 lemma filterlim_at_top_linear_iff:
   fixes f::"'a::linordered_field \<Rightarrow> 'b"
   assumes "c\<noteq>0"
   shows "(LIM x at_top. f (x * c + b) :> F2) \<longleftrightarrow> (if c>0 then (LIM x at_top. f x :> F2) 
             else (LIM x at_bot. f x :> F2))"
   unfolding filterlim_def
   apply (subst filtermap_filtermap[of f "\<lambda>x. x * c + b",symmetric])
   using assms by (auto simp add:filtermap_at_top_linear_eq)
     
 lemma filterlim_at_bot_linear_iff:
   fixes f::"'a::linordered_field \<Rightarrow> 'b"
   assumes "c\<noteq>0"
   shows "(LIM x at_bot. f (x * c + b) :> F2) \<longleftrightarrow> (if c>0 then (LIM x at_bot. f x :> F2) 
             else (LIM x at_top. f x :> F2)) "
   unfolding filterlim_def 
   apply (subst filtermap_filtermap[of f "\<lambda>x. x * c + b",symmetric])
   using assms by (auto simp add:filtermap_at_bot_linear_eq)      
   
   
 lemma filterlim_tendsto_add_at_top_iff:
   assumes f: "(f \<longlongrightarrow> c) F"
   shows "(LIM x F. (f x + g x :: real) :> at_top) \<longleftrightarrow> (LIM x F. g x :> at_top)"
 proof     
   assume "LIM x F. f x + g x :> at_top" 
   moreover have "((\<lambda>x. - f x) \<longlongrightarrow> - c) F"
     using f by (intro tendsto_intros,simp)
   ultimately show "filterlim g at_top F" using filterlim_tendsto_add_at_top 
     by fastforce
 qed (auto simp add:filterlim_tendsto_add_at_top[OF f])    
     
   
 lemma filterlim_tendsto_add_at_bot_iff:
   fixes c::real
   assumes f: "(f \<longlongrightarrow> c) F"
   shows "(LIM x F. f x + g x :> at_bot) \<longleftrightarrow> (LIM x F. g x :> at_bot)" 
 proof -
   have "(LIM x F. f x + g x :> at_bot) 
         \<longleftrightarrow>  (LIM x F. - f x + (- g x)  :> at_top)"
     apply (subst filterlim_uminus_at_top)
     by (rule filterlim_cong,auto)
   also have "... = (LIM x F. - g x  :> at_top)"
     apply (subst filterlim_tendsto_add_at_top_iff[of _ "-c"])
     by (auto intro:tendsto_intros simp add:f)
   also have "... = (LIM x F. g x  :> at_bot)"
     apply (subst filterlim_uminus_at_top)
     by (rule filterlim_cong,auto)
   finally show ?thesis .
 qed
   
 lemma tendsto_inverse_0_at_infinity: 
     "LIM x F. f x :> at_infinity \<Longrightarrow> ((\<lambda>x. inverse (f x) :: real) \<longlongrightarrow> 0) F"
   by (metis filterlim_at filterlim_inverse_at_iff)
 
 lemma filterlim_at_infinity_divide_iff:
   fixes f::"'a \<Rightarrow> 'b::real_normed_field"
   assumes "(f \<longlongrightarrow> c) F" "c\<noteq>0"
   shows "(LIM x F. f x / g x :> at_infinity) \<longleftrightarrow> (LIM x F. g x :> at 0)"
 proof 
   assume asm:"LIM x F. f x / g x :> at_infinity"
   have "LIM x F. inverse (f x) * (f x / g x) :> at_infinity"
     apply (rule tendsto_mult_filterlim_at_infinity[of _ "inverse c", OF _ _ asm])
     by (auto simp add: assms(1) assms(2) tendsto_inverse)
   then have "LIM x F. inverse (g x) :> at_infinity"
     apply (elim filterlim_mono_eventually)
     using eventually_times_inverse_1[OF assms] 
     by (auto elim:eventually_mono simp add:field_simps)
   then show "filterlim g (at 0) F" using filterlim_inverse_at_iff[symmetric] by force 
 next
   assume "filterlim g (at 0) F" 
   then have "filterlim (\<lambda>x. inverse (g x)) at_infinity F"
     using filterlim_compose filterlim_inverse_at_infinity by blast
   then have "LIM x F. f x * inverse (g x) :> at_infinity"
     using tendsto_mult_filterlim_at_infinity[OF assms, of "\<lambda>x. inverse(g x)"] 
     by simp
   then show "LIM x F. f x / g x :> at_infinity" by (simp add: divide_inverse)
 qed  
   
 lemma filterlim_tendsto_pos_mult_at_top_iff:
   fixes f::"'a \<Rightarrow> real"
   assumes "(f \<longlongrightarrow> c) F" and "0 < c"
   shows "(LIM x F. (f x * g x) :> at_top) \<longleftrightarrow> (LIM x F. g x :> at_top)"
 proof 
   assume "filterlim g at_top F"
   then show "LIM x F. f x * g x :> at_top" 
     using filterlim_tendsto_pos_mult_at_top[OF assms] by auto
 next
   assume asm:"LIM x F. f x * g x :> at_top"
   have "((\<lambda>x. inverse (f x)) \<longlongrightarrow> inverse c) F" 
     using tendsto_inverse[OF assms(1)] \<open>0<c\<close> by auto
   moreover have "inverse c >0" using assms(2) by auto
   ultimately have "LIM x F. inverse (f x) * (f x * g x) :> at_top"
     using filterlim_tendsto_pos_mult_at_top[OF _ _ asm,of "\<lambda>x. inverse (f x)" "inverse c"] by auto
   then show "LIM x F. g x :> at_top"
     apply (elim filterlim_mono_eventually)
       apply simp_all[2]
     using eventually_times_inverse_1[OF assms(1)] \<open>c>0\<close> eventually_mono by fastforce
 qed  
 
 lemma filterlim_tendsto_pos_mult_at_bot_iff:
   fixes c :: real
   assumes "(f \<longlongrightarrow> c) F" "0 < c" 
   shows "(LIM x F. f x * g x :> at_bot) \<longleftrightarrow> filterlim g at_bot F"
   using filterlim_tendsto_pos_mult_at_top_iff[OF assms(1,2), of "\<lambda>x. - g x"] 
   unfolding filterlim_uminus_at_bot by simp    
 
 lemma filterlim_tendsto_neg_mult_at_top_iff:
   fixes f::"'a \<Rightarrow> real"
   assumes "(f \<longlongrightarrow> c) F" and "c < 0"
   shows "(LIM x F. (f x * g x) :> at_top) \<longleftrightarrow> (LIM x F. g x :> at_bot)"  
 proof -
   have "(LIM x F. f x * g x :> at_top) = (LIM x F. - g x :> at_top)"
     apply (rule filterlim_tendsto_pos_mult_at_top_iff[of "\<lambda>x. - f x" "-c" F "\<lambda>x. - g x", simplified])
     using assms by (auto intro: tendsto_intros )
   also have "... = (LIM x F. g x :> at_bot)" 
     using filterlim_uminus_at_bot[symmetric] by auto
   finally show ?thesis .
 qed
 
 lemma filterlim_tendsto_neg_mult_at_bot_iff:
   fixes c :: real
   assumes "(f \<longlongrightarrow> c) F" "0 > c" 
   shows "(LIM x F. f x * g x :> at_bot) \<longleftrightarrow> filterlim g at_top F"
   using filterlim_tendsto_neg_mult_at_top_iff[OF assms(1,2), of "\<lambda>x. - g x"] 
   unfolding filterlim_uminus_at_top by simp    
 
 lemma Lim_add:
   fixes f g::"_ \<Rightarrow> 'a::{t2_space,topological_monoid_add}"
   assumes "\<exists>y. (f \<longlongrightarrow> y) F" and "\<exists>y. (g \<longlongrightarrow> y) F" and "F\<noteq>bot"
   shows "Lim F f + Lim F g = Lim F (\<lambda>x. f x+g x)"
   apply (rule tendsto_Lim[OF \<open>F\<noteq>bot\<close>, symmetric])
   apply (auto intro!:tendsto_eq_intros)
   using assms tendsto_Lim by blast+
 
 (*
 lemma filterlim_at_top_tendsto[elim]:
   fixes f::"'a \<Rightarrow> 'b::{unbounded_dense_linorder,order_topology}" and F::"'a filter"
   assumes top:"filterlim f at_top F" and tendsto: "(f \<longlongrightarrow> c) F" 
           and "F\<noteq>bot"
   shows False
 proof -
   obtain cc where "cc>c" using gt_ex by blast
   have "\<forall>\<^sub>F x in F. cc < f x" 
     using top unfolding filterlim_at_top_dense by auto
   moreover have "\<forall>\<^sub>F x in F. f x < cc" 
     using tendsto order_tendstoD(2)[OF _ \<open>cc>c\<close>] by auto
   ultimately have "\<forall>\<^sub>F x in F. cc < f x \<and> f x < cc" 
     using eventually_conj by auto
   then have "\<forall>\<^sub>F x in F. False" by (auto elim:eventually_mono)
   then show False using \<open>F\<noteq>bot\<close> by auto
 qed
 
 lemma filterlim_at_bot_tendsto[elim]:
   fixes f::"'a \<Rightarrow> 'b::{unbounded_dense_linorder,order_topology}" and F::"'a filter"
   assumes top:"filterlim f at_bot F" and tendsto: "(f \<longlongrightarrow> c) F" 
           and "F\<noteq>bot"
   shows False
 proof -
   obtain cc where "cc<c" using lt_ex by blast
   have "\<forall>\<^sub>F x in F. cc > f x" 
     using top unfolding filterlim_at_bot_dense by auto
   moreover have "\<forall>\<^sub>F x in F. f x > cc" 
     using tendsto order_tendstoD(1)[OF _ \<open>cc<c\<close>] by auto
   ultimately have "\<forall>\<^sub>F x in F. cc < f x \<and> f x < cc" 
     using eventually_conj by auto
   then have "\<forall>\<^sub>F x in F. False" by (auto elim:eventually_mono)
   then show False using \<open>F\<noteq>bot\<close> by auto
 qed
 *)
   
 subsection \<open>Isolate and discrete\<close>  
   
 definition (in topological_space) isolate:: "'a \<Rightarrow> 'a set \<Rightarrow> bool"  (infixr "isolate" 60)
   where "x isolate S \<longleftrightarrow> (x\<in>S \<and> (\<exists>T. open T \<and> T \<inter> S = {x}))"  
     
 definition (in topological_space) discrete:: "'a set \<Rightarrow> bool" 
   where "discrete S \<longleftrightarrow> (\<forall>x\<in>S. x isolate S)"  
     
 definition (in metric_space) uniform_discrete :: "'a set \<Rightarrow> bool" where
   "uniform_discrete S \<longleftrightarrow> (\<exists>e>0. \<forall>x\<in>S. \<forall>y\<in>S. dist x y < e \<longrightarrow> x = y)"
   
 lemma uniformI1:
   assumes "e>0" "\<And>x y. \<lbrakk>x\<in>S;y\<in>S;dist x y<e\<rbrakk> \<Longrightarrow> x =y "
   shows "uniform_discrete S"  
 unfolding uniform_discrete_def using assms by auto
 
 lemma uniformI2:
   assumes "e>0" "\<And>x y. \<lbrakk>x\<in>S;y\<in>S;x\<noteq>y\<rbrakk> \<Longrightarrow> dist x y\<ge>e "
   shows "uniform_discrete S"  
 unfolding uniform_discrete_def using assms not_less by blast
   
 lemma isolate_islimpt_iff:"(x isolate S) \<longleftrightarrow> (\<not> (x islimpt S) \<and> x\<in>S)"
   unfolding isolate_def islimpt_def by auto
   
 lemma isolate_dist_Ex_iff:
   fixes x::"'a::metric_space"
   shows "x isolate S \<longleftrightarrow> (x\<in>S \<and> (\<exists>e>0. \<forall>y\<in>S. dist x y < e \<longrightarrow> y=x))"
 unfolding isolate_islimpt_iff islimpt_approachable by (metis dist_commute)
   
 lemma discrete_empty[simp]: "discrete {}"
   unfolding discrete_def by auto
 
 lemma uniform_discrete_empty[simp]: "uniform_discrete {}"
   unfolding uniform_discrete_def by (simp add: gt_ex)
   
 lemma isolate_insert: 
   fixes x :: "'a::t1_space"
   shows "x isolate (insert a S) \<longleftrightarrow> x isolate S \<or> (x=a \<and> \<not> (x islimpt S))"
 by (meson insert_iff islimpt_insert isolate_islimpt_iff)
     
 (*
 TODO. 
 Other than 
 
   uniform_discrete S \<longrightarrow> discrete S
   uniform_discrete S \<longrightarrow> closed S
 
 , we should be able to prove
 
   discrete S \<and> closed S \<longrightarrow> uniform_discrete S
 
 but the proof (based on Tietze Extension Theorem) seems not very trivial to me. Informal proofs can be found in
 
 http://topology.auburn.edu/tp/reprints/v30/tp30120.pdf
 http://msp.org/pjm/1959/9-2/pjm-v9-n2-p19-s.pdf
 *)  
   
 lemma uniform_discrete_imp_closed:
   "uniform_discrete S \<Longrightarrow> closed S" 
   by (meson discrete_imp_closed uniform_discrete_def) 
     
 lemma uniform_discrete_imp_discrete:
   "uniform_discrete S \<Longrightarrow> discrete S"
   by (metis discrete_def isolate_dist_Ex_iff uniform_discrete_def)
   
 lemma isolate_subset:"x isolate S \<Longrightarrow> T \<subseteq> S \<Longrightarrow> x\<in>T \<Longrightarrow> x isolate T"
   unfolding isolate_def by fastforce
 
 lemma discrete_subset[elim]: "discrete S \<Longrightarrow> T \<subseteq> S \<Longrightarrow> discrete T"
   unfolding discrete_def using islimpt_subset isolate_islimpt_iff by blast
     
 lemma uniform_discrete_subset[elim]: "uniform_discrete S \<Longrightarrow> T \<subseteq> S \<Longrightarrow> uniform_discrete T"
   by (meson subsetD uniform_discrete_def)
         
 lemma continuous_on_discrete: "discrete S \<Longrightarrow> continuous_on S f" 
   unfolding continuous_on_topological by (metis discrete_def islimptI isolate_islimpt_iff)
    
 (* Is euclidean_space really necessary?*)    
 lemma uniform_discrete_insert:
   fixes S :: "'a::euclidean_space set"
   shows "uniform_discrete (insert a S) \<longleftrightarrow> uniform_discrete S"
 proof 
   assume asm:"uniform_discrete S" 
   let ?thesis = "uniform_discrete (insert a S)"
   have ?thesis when "a\<in>S" using that asm by (simp add: insert_absorb)
   moreover have ?thesis when "S={}" using that asm by (simp add: uniform_discrete_def)
   moreover have ?thesis when "a\<notin>S" "S\<noteq>{}"
   proof -
     obtain e1 where "e1>0" and e1_dist:"\<forall>x\<in>S. \<forall>y\<in>S. dist y x < e1 \<longrightarrow> y = x"
       using asm unfolding uniform_discrete_def by auto
     define e2 where "e2 \<equiv> min (setdist {a} S) e1"
     have "closed S" using asm uniform_discrete_imp_closed by auto
     then have "e2>0" by (simp add: \<open>0 < e1\<close> e2_def setdist_gt_0_compact_closed that(1) that(2))
     moreover have "x = y" when "x\<in>insert a S" "y\<in>insert a S" "dist x y < e2 " for x y
     proof -
       have ?thesis when "x=a" "y=a" using that by auto
       moreover have ?thesis when "x=a" "y\<in>S"
         using that setdist_le_dist[of x "{a}" y S] \<open>dist x y < e2\<close> unfolding e2_def
         by fastforce
       moreover have ?thesis when "y=a" "x\<in>S"
         using that setdist_le_dist[of y "{a}" x S] \<open>dist x y < e2\<close> unfolding e2_def
         by (simp add: dist_commute)
       moreover have ?thesis when "x\<in>S" "y\<in>S"
         using e1_dist[rule_format, OF that] \<open>dist x y < e2\<close> unfolding e2_def
         by (simp add: dist_commute)
       ultimately show ?thesis using that by auto
     qed
     ultimately show ?thesis unfolding uniform_discrete_def by meson
   qed
   ultimately show ?thesis by auto
 qed (simp add: subset_insertI uniform_discrete_subset)
     
 lemma discrete_compact_finite_iff:
   fixes S :: "'a::t1_space set"
   shows "discrete S \<and> compact S \<longleftrightarrow> finite S"
 proof 
   assume "finite S"
   then have "compact S" using finite_imp_compact by auto
   moreover have "discrete S"
     unfolding discrete_def using isolate_islimpt_iff islimpt_finite[OF \<open>finite S\<close>] by auto 
   ultimately show "discrete S \<and> compact S" by auto
 next
   assume "discrete S \<and> compact S"
   then show "finite S" 
     by (meson discrete_def Heine_Borel_imp_Bolzano_Weierstrass isolate_islimpt_iff order_refl)
 qed
   
 lemma uniform_discrete_finite_iff:
   fixes S :: "'a::heine_borel set"
   shows "uniform_discrete S \<and> bounded S \<longleftrightarrow> finite S"
 proof 
   assume "uniform_discrete S \<and> bounded S"
   then have "discrete S" "compact S"
     using uniform_discrete_imp_discrete uniform_discrete_imp_closed compact_eq_bounded_closed
     by auto
   then show "finite S" using discrete_compact_finite_iff by auto
 next
   assume asm:"finite S"
   let ?thesis = "uniform_discrete S \<and> bounded S"
   have ?thesis when "S={}" using that by auto
   moreover have ?thesis when "S\<noteq>{}"
   proof -
     have "\<forall>x. \<exists>d>0. \<forall>y\<in>S. y \<noteq> x \<longrightarrow> d \<le> dist x y"
       using finite_set_avoid[OF \<open>finite S\<close>] by auto
     then obtain f where f_pos:"f x>0" 
         and f_dist: "\<forall>y\<in>S. y \<noteq> x \<longrightarrow> f x \<le> dist x y"
         if "x\<in>S" for x 
       by metis
     define f_min where "f_min \<equiv> Min (f ` S)" 
     have "f_min > 0"
       unfolding f_min_def 
       by (simp add: asm f_pos that)
     moreover have "\<forall>x\<in>S. \<forall>y\<in>S. f_min > dist x y \<longrightarrow> x=y"
       using f_dist unfolding f_min_def 
       by (metis Min_gr_iff all_not_in_conv asm dual_order.irrefl eq_iff finite_imageI imageI 
           less_eq_real_def)
     ultimately have "uniform_discrete S" 
       unfolding uniform_discrete_def by auto
     moreover have "bounded S" using \<open>finite S\<close> by auto
     ultimately show ?thesis by auto
   qed
   ultimately show ?thesis by blast
 qed
   
 lemma uniform_discrete_image_scale:
   fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
   assumes "uniform_discrete S" and dist:"\<forall>x\<in>S. \<forall>y\<in>S. dist x y = c * dist (f x) (f y)"
   shows "uniform_discrete (f ` S)"  
 proof -
   have ?thesis when "S={}" using that by auto
   moreover have ?thesis when "S\<noteq>{}" "c\<le>0"
   proof -
     obtain x1 where "x1\<in>S" using \<open>S\<noteq>{}\<close> by auto
     have ?thesis when "S-{x1} = {}"
     proof -
       have "S={x1}" using that \<open>S\<noteq>{}\<close> by auto
       then show ?thesis using uniform_discrete_insert[of "f x1"] by auto
     qed
     moreover have ?thesis when "S-{x1} \<noteq> {}"
     proof -
       obtain x2 where "x2\<in>S-{x1}" using \<open>S-{x1} \<noteq> {}\<close> by auto
       then have "x2\<in>S" "x1\<noteq>x2" by auto
       then have "dist x1 x2 > 0" by auto
       moreover have "dist x1 x2 = c * dist (f x1) (f x2)"
         using dist[rule_format, OF \<open>x1\<in>S\<close> \<open>x2\<in>S\<close>] .
       moreover have "dist (f x2) (f x2) \<ge> 0" by auto
       ultimately have False using \<open>c\<le>0\<close> by (simp add: zero_less_mult_iff)
       then show ?thesis by auto
     qed
     ultimately show ?thesis by auto
   qed
   moreover have ?thesis when "S\<noteq>{}" "c>0"
   proof -
     obtain e1 where "e1>0" and e1_dist:"\<forall>x\<in>S. \<forall>y\<in>S. dist y x < e1 \<longrightarrow> y = x"
       using \<open>uniform_discrete S\<close> unfolding uniform_discrete_def by auto
     define e where "e= e1/c"
     have "x1 = x2" when "x1\<in> f ` S" "x2\<in> f ` S" "dist x1 x2 < e " for x1 x2 
     proof -
       obtain y1 where y1:"y1\<in>S" "x1=f y1" using \<open>x1\<in> f ` S\<close> by auto
       obtain y2 where y2:"y2\<in>S" "x2=f y2" using \<open>x2\<in> f ` S\<close> by auto    
       have "dist y1 y2 < e1"
         using dist[rule_format, OF y1(1) y2(1)] \<open>c>0\<close> \<open>dist x1 x2 < e\<close> unfolding e_def
         apply (fold y1(2) y2(2))
         by (auto simp add:divide_simps mult.commute) 
       then have "y1=y2"    
         using e1_dist[rule_format, OF y2(1) y1(1)] by simp
       then show "x1=x2" using y1(2) y2(2) by auto
     qed
     moreover have "e>0" using \<open>e1>0\<close> \<open>c>0\<close> unfolding e_def by auto
     ultimately show ?thesis unfolding uniform_discrete_def by meson
   qed
   ultimately show ?thesis by fastforce
 qed
  
 
   
 end
diff --git a/thys/Winding_Number_Eval/Winding_Number_Eval_Examples.thy b/thys/Winding_Number_Eval/Winding_Number_Eval_Examples.thy
--- a/thys/Winding_Number_Eval/Winding_Number_Eval_Examples.thy
+++ b/thys/Winding_Number_Eval/Winding_Number_Eval_Examples.thy
@@ -1,97 +1,97 @@
 (*
     Author:     Wenda Li <wl302@cam.ac.uk / liwenda1990@hotmail.com>
 *)
 
 section \<open>Some examples of applying the method winding\_eval\<close>
 
 theory Winding_Number_Eval_Examples imports Winding_Number_Eval
 begin
   
 lemma example1:
   assumes "R>1"
   shows "winding_number (part_circlepath 0 R 0 pi +++ linepath (-R) R) \<i> = 1"
 proof (eval_winding,simp_all)
   define CR where  "CR \<equiv>part_circlepath 0 R 0 pi"
   define L where "L\<equiv> linepath (- (complex_of_real R)) R"
   show "\<i> \<notin> path_image CR" unfolding CR_def using \<open>R>1\<close>
     by (intro not_on_circlepathI,auto)  
   show *:"\<i> \<notin> closed_segment (- (of_real R)) R" using \<open>R>1\<close> complex_eq_iff
     by (intro not_on_closed_segmentI,auto)
   from cindex_pathE_linepath[OF this] have "cindex_pathE L \<i> = -1"
     unfolding L_def using \<open>R>1\<close> by auto
   moreover have "cindex_pathE CR \<i> = -1"
     unfolding CR_def using \<open>R>1\<close> 
     apply (subst cindex_pathE_part_circlepath)
     by (simp_all add:jumpF_pathstart_part_circlepath jumpF_pathfinish_part_circlepath)
   ultimately show "- complex_of_real (cindex_pathE CR \<i>) - cindex_pathE L \<i> = 2"
     unfolding L_def CR_def by auto
 qed
 
 lemma example2:
   assumes "R>1"
   shows "winding_number (part_circlepath 0 R 0 pi +++ linepath (-R) R) (-\<i>) = 0"
 proof (eval_winding,simp_all)
   define CR where  "CR \<equiv>part_circlepath 0 R 0 pi"
   define L where "L\<equiv> linepath (- (complex_of_real R)) R"
   show "-\<i> \<notin> path_image CR" unfolding CR_def using \<open>R>1\<close>
     by (intro not_on_circlepathI,auto)  
   show *:"-\<i> \<notin> closed_segment (- (of_real R)) R" using \<open>R>1\<close> complex_eq_iff
     by (intro not_on_closed_segmentI,auto)
   from cindex_pathE_linepath[OF this] have "cindex_pathE L (-\<i>) = 1"
     unfolding L_def using \<open>R>1\<close> by auto
   moreover have "cindex_pathE CR (-\<i>) = -1"
     unfolding CR_def using \<open>R>1\<close> 
     apply (subst cindex_pathE_part_circlepath)
     by (simp_all add:jumpF_pathstart_part_circlepath jumpF_pathfinish_part_circlepath)
   ultimately show "-cindex_pathE CR (-\<i>) = cindex_pathE L (-\<i>)"
     unfolding L_def CR_def by auto    
 qed
  
 lemma example3:
   fixes lb ub z :: complex
   defines "rec \<equiv>  linepath lb (Complex (Re ub) (Im lb)) +++ linepath (Complex (Re ub) (Im lb)) ub 
               +++ linepath ub (Complex (Re lb) (Im ub)) +++ linepath (Complex (Re lb) (Im ub)) lb"
   assumes order_asms:"Re lb < Re z" "Re z < Re ub" "Im lb < Im z" "Im z < Im ub"
   shows "winding_number rec z = 1"
   unfolding rec_def
 proof (eval_winding)    
   let ?l1 = "linepath lb (Complex (Re ub) (Im lb))"
   and ?l2 = "linepath (Complex (Re ub) (Im lb)) ub"
   and ?l3 = "linepath ub (Complex (Re lb) (Im ub))"
   and ?l4 = "linepath (Complex (Re lb) (Im ub)) lb"
   show l1: "z \<notin> path_image ?l1" 
     apply (auto intro!: not_on_closed_segmentI_complex)
-    using order_asms by (metis diff_gt_0_iff_gt mult_pos_pos order.asym zero_less_mult_pos2)
+    using order_asms by (simp add: algebra_simps crossproduct_eq)
   show l2:"z \<notin> path_image ?l2" 
     apply (auto intro!: not_on_closed_segmentI_complex)      
-    using order_asms by (metis diff_gt_0_iff_gt linordered_field_class.sign_simps(44) order.asym)
+    using order_asms by (simp add: algebra_simps crossproduct_eq)
   show l3:"z \<notin> path_image ?l3" 
     apply (auto intro!: not_on_closed_segmentI_complex)      
-    using order_asms by (metis diff_less_0_iff_less linordered_field_class.sign_simps(44) order.asym)
+    using order_asms by (simp add: algebra_simps crossproduct_eq)
   show l4:"z \<notin> path_image ?l4"  
     apply (auto intro!: not_on_closed_segmentI_complex)      
-    using order_asms by (metis diff_less_0_iff_less linordered_field_class.sign_simps(44) order.asym)
+    using order_asms by (simp add: algebra_simps crossproduct_eq)
   show "- complex_of_real (cindex_pathE ?l1 z + (cindex_pathE ?l2 z + (cindex_pathE ?l3 z +
           cindex_pathE ?l4 z))) = 2 * 1"  
   proof -
     have "(Im z - Im ub) * (Re ub - Re lb) < 0" 
       using mult_less_0_iff order_asms(1) order_asms(2) order_asms(4) by fastforce
     then have "cindex_pathE ?l3 z = -1"
       apply (subst cindex_pathE_linepath)
       using l3 order_asms by (auto simp add:algebra_simps)
     moreover have "(Im lb - Im z) * (Re ub - Re lb) <0" 
       using mult_less_0_iff order_asms(1) order_asms(2) order_asms(3) by fastforce
     then have "cindex_pathE ?l1 z = -1"    
       apply (subst cindex_pathE_linepath)
       using l1 order_asms by (auto simp add:algebra_simps)  
     moreover have "cindex_pathE ?l2 z = 0"    
       apply (subst cindex_pathE_linepath)
       using l2 order_asms by (auto simp add:algebra_simps)  
     moreover have "cindex_pathE ?l4 z = 0"
       apply (subst cindex_pathE_linepath)
       using l4 order_asms by (auto simp add:algebra_simps) 
     ultimately show ?thesis by auto
   qed
 qed
    
 end
diff --git a/thys/Word_Lib/Word_Lemmas.thy b/thys/Word_Lib/Word_Lemmas.thy
--- a/thys/Word_Lib/Word_Lemmas.thy
+++ b/thys/Word_Lib/Word_Lemmas.thy
@@ -1,5729 +1,5728 @@
 (*
  * Copyright 2014, NICTA
  *
  * This software may be distributed and modified according to the terms of
  * the BSD 2-Clause license. Note that NO WARRANTY is provided.
  * See "LICENSE_BSD2.txt" for details.
  *
  * @TAG(NICTA_BSD)
  *)
 
 section "Lemmas with Generic Word Length"
 
 theory Word_Lemmas
   imports
     Complex_Main
     Word_Next
     Word_Enum
     "HOL-Library.Sublist"
 begin
 
 text \<open>Set up quickcheck to support words\<close>
 
 quickcheck_generator word
   constructors:
     "zero_class.zero :: ('a::len) word",
     "numeral :: num \<Rightarrow> ('a::len) word",
     "uminus :: ('a::len) word \<Rightarrow> ('a::len) word"
 
 instantiation Enum.finite_1 :: len
 begin
   definition "len_of_finite_1 (x :: Enum.finite_1 itself) \<equiv> (1 :: nat)"
   instance
     by (standard, auto simp: len_of_finite_1_def)
 end
 
 instantiation Enum.finite_2 :: len
 begin
   definition "len_of_finite_2 (x :: Enum.finite_2 itself) \<equiv> (2 :: nat)"
   instance
     by (standard, auto simp: len_of_finite_2_def)
 end
 
 instantiation Enum.finite_3 :: len
 begin
   definition "len_of_finite_3 (x :: Enum.finite_3 itself) \<equiv> (4 :: nat)"
   instance
     by (standard, auto simp: len_of_finite_3_def)
 end
 
 (* Provide wf and less_induct for word.
    wf may be more useful in loop proofs, less_induct in recursion proofs. *)
 lemma word_less_wf: "wf {(a, b). a < (b :: ('a::len) word)}"
   apply (rule wf_subset)
   apply (rule wf_measure)
   apply safe
   apply (subst in_measure)
   apply (erule unat_mono)
   done
 
 lemma word_less_induct:
   "\<lbrakk> \<And>x::('a::len) word. (\<And>y. y < x \<Longrightarrow> P y) \<Longrightarrow> P x \<rbrakk> \<Longrightarrow> P a"
   using word_less_wf  by induct blast
 
 instantiation word :: (len) wellorder
 begin
 instance by (intro_classes) (metis word_less_induct)
 end
 
 
 lemma word_plus_mono_left:
   fixes x :: "'a :: len word"
   shows "\<lbrakk>y \<le> z; x \<le> x + z\<rbrakk> \<Longrightarrow> y + x \<le> z + x"
   by unat_arith
 
 lemma word_2p_mult_inc:
   assumes x: "2 * 2 ^ n < (2::'a::len word) * 2 ^ m"
   assumes suc_n: "Suc n < LENGTH('a::len)"
   assumes suc_m: "Suc m < LENGTH('a::len)"
   assumes 2: "unat (2::'a::len word) = 2"
   shows "2^n < (2::'a::len word)^m"
 proof -
   from suc_n
   have "(2::nat) * 2 ^ n mod 2 ^ LENGTH('a::len) = 2 * 2^n"
     apply (subst mod_less)
      apply (subst power_Suc[symmetric])
      apply (rule power_strict_increasing)
       apply simp
      apply simp
     apply simp
     done
   moreover
   from suc_m
   have "(2::nat) * 2 ^ m mod 2 ^ LENGTH('a::len) = 2 * 2^m"
     apply (subst mod_less)
      apply (subst power_Suc[symmetric])
      apply (rule power_strict_increasing)
       apply simp
      apply simp
     apply simp
     done
   ultimately
   have "2 * 2 ^ n < (2::nat) * 2 ^ m" using x
     apply (unfold word_less_nat_alt)
     apply simp
     apply (subst (asm) unat_word_ariths(2))+
     apply (subst (asm) 2)+
     apply (subst (asm) word_unat_power, subst (asm) unat_of_nat)+
     apply (simp add: mod_mult_right_eq)
     done
   with suc_n suc_m
   show ?thesis
     unfolding word_less_nat_alt
     apply (subst word_unat_power, subst unat_of_nat)+
     apply simp
     done
 qed
 
 lemma word_power_increasing:
   assumes x: "2 ^ x < (2 ^ y::'a::len word)" "x < LENGTH('a::len)" "y < LENGTH('a::len)"
   assumes 2: "unat (2::'a::len word) = 2"
   shows "x < y" using x
   apply (induct x arbitrary: y)
    apply (case_tac y; simp)
   apply (case_tac y; clarsimp)
    apply (subst (asm) power_Suc [symmetric])
    apply (subst (asm) p2_eq_0)
    apply simp
   apply (drule (2) word_2p_mult_inc, rule 2)
   apply simp
   done
 
 lemma word_shiftl_add_distrib:
   fixes x :: "'a :: len word"
   shows "(x + y) << n = (x << n) + (y << n)"
   by (simp add: shiftl_t2n ring_distribs)
 
 lemma less_Suc_unat_less_bound:
   "n < Suc (unat (x :: 'a :: len word)) \<Longrightarrow> n < 2 ^ LENGTH('a)"
   by (auto elim!: order_less_le_trans intro: Suc_leI)
 
 lemma up_ucast_inj:
   "\<lbrakk> ucast x = (ucast y::'b::len word); LENGTH('a) \<le> len_of TYPE ('b) \<rbrakk> \<Longrightarrow> x = (y::'a::len word)"
   by (subst (asm) bang_eq) (fastforce simp: nth_ucast word_size intro: word_eqI)
 
 lemmas ucast_up_inj = up_ucast_inj
 
 lemma up_ucast_inj_eq:
   "LENGTH('a) \<le> len_of TYPE ('b) \<Longrightarrow> (ucast x = (ucast y::'b::len word)) = (x = (y::'a::len word))"
   by (fastforce dest: up_ucast_inj)
 
 lemma no_plus_overflow_neg:
   "(x :: 'a :: len word) < -y \<Longrightarrow> x \<le> x + y"
   apply (simp add: no_plus_overflow_uint_size word_less_alt uint_word_ariths word_size)
   apply (subst(asm) zmod_zminus1_eq_if)
   apply (simp split: if_split_asm)
   done
 
 lemma ucast_ucast_eq:
   fixes x :: "'a::len word"
   fixes y :: "'b::len word"
   shows
     "\<lbrakk> ucast x = (ucast (ucast y::'a::len word)::'c::len word);
       LENGTH('a) \<le> LENGTH('b);
       LENGTH('b) \<le> LENGTH('c) \<rbrakk> \<Longrightarrow>
     x = ucast y"
   by (fastforce intro: word_eqI simp: bang_eq nth_ucast word_size)
 
 
 text \<open>right-padding a word to a certain length\<close>
 
 definition
   "bl_pad_to bl sz \<equiv> bl @ (replicate (sz - length bl) False)"
 
 lemma bl_pad_to_length:
   assumes lbl: "length bl \<le> sz"
   shows   "length (bl_pad_to bl sz) = sz"
   using lbl by (simp add: bl_pad_to_def)
 
 lemma bl_pad_to_prefix:
   "prefix bl (bl_pad_to bl sz)"
   by (simp add: bl_pad_to_def)
 
 lemma same_length_is_parallel:
   assumes len: "\<forall>y \<in> set as. length y = x"
   shows  "\<forall>x \<in> set as. \<forall>y \<in> set as - {x}. x \<parallel> y"
 proof (rule, rule)
   fix x y
   assume xi: "x \<in> set as" and yi: "y \<in> set as - {x}"
   from len obtain q where len': "\<forall>y \<in> set as. length y = q" ..
 
   show "x \<parallel> y"
   proof (rule not_equal_is_parallel)
     from xi yi show "x \<noteq> y" by auto
     from xi yi len' show "length x = length y" by (auto dest: bspec)
   qed
 qed
 
 text \<open>Lemmas about words\<close>
 
 lemmas and_bang = word_and_nth
 
 lemma of_drop_to_bl:
   "of_bl (drop n (to_bl x)) = (x && mask (size x - n))"
   apply (clarsimp simp: bang_eq test_bit_of_bl rev_nth cong: rev_conj_cong)
   apply (safe, simp_all add: word_size to_bl_nth)
   done
 
 lemma word_add_offset_less:
   fixes x :: "'a :: len word"
   assumes yv: "y < 2 ^ n"
   and     xv: "x < 2 ^ m"
   and     mnv: "sz < LENGTH('a :: len)"
   and    xv': "x < 2 ^ (LENGTH('a :: len) - n)"
   and     mn: "sz = m + n"
   shows   "x * 2 ^ n + y < 2 ^ sz"
 proof (subst mn)
   from mnv mn have nv: "n < LENGTH('a)" and mv: "m < LENGTH('a)"  by auto
 
   have uy: "unat y < 2 ^ n"
      by (rule order_less_le_trans [OF unat_mono [OF yv] order_eq_refl],
        rule unat_power_lower[OF nv])
 
   have ux: "unat x < 2 ^ m"
      by (rule order_less_le_trans [OF unat_mono [OF xv] order_eq_refl],
        rule unat_power_lower[OF mv])
 
   then show "x * 2 ^ n + y < 2 ^ (m + n)" using ux uy nv mnv xv'
   apply (subst word_less_nat_alt)
   apply (subst unat_word_ariths)+
   apply (subst mod_less)
    apply simp
    apply (subst mult.commute)
    apply (rule nat_less_power_trans [OF _ order_less_imp_le [OF nv]])
     apply (rule order_less_le_trans [OF unat_mono [OF xv']])
     apply (cases "n = 0")
        apply simp
       apply simp
     apply (subst unat_power_lower[OF nv])
     apply (subst mod_less)
    apply (erule order_less_le_trans [OF nat_add_offset_less], assumption)
     apply (rule mn)
    apply simp
   apply (simp add: mn mnv)
   apply (erule nat_add_offset_less)
   apply simp+
   done
 qed
 
 lemma word_less_power_trans:
   fixes n :: "'a :: len word"
   assumes nv: "n < 2 ^ (m - k)"
   and     kv: "k \<le> m"
   and     mv: "m < len_of TYPE ('a)"
   shows "2 ^ k * n < 2 ^ m"
   using nv kv mv
   apply -
   apply (subst word_less_nat_alt)
   apply (subst unat_word_ariths)
   apply (subst mod_less)
    apply simp
    apply (rule nat_less_power_trans)
     apply (erule order_less_trans [OF unat_mono])
     apply simp
    apply simp
   apply simp
   apply (rule nat_less_power_trans)
    apply (subst unat_power_lower[where 'a = 'a, symmetric])
     apply simp
    apply (erule unat_mono)
   apply simp
   done
 
 lemma word_less_sub_le[simp]:
   fixes x :: "'a :: len word"
   assumes nv: "n < LENGTH('a)"
   shows "(x \<le> 2 ^ n - 1) = (x < 2 ^ n)"
 proof -
   have "Suc (unat ((2::'a word) ^ n - 1)) = unat ((2::'a word) ^ n)" using nv
     by (metis Suc_pred' power_2_ge_iff unat_gt_0 unat_minus_one word_not_simps(1))
 
   then show ?thesis using nv
     apply -
     apply (subst word_le_nat_alt)
     apply (subst less_Suc_eq_le [symmetric])
     apply (erule ssubst)
     apply (subst word_less_nat_alt)
     apply (rule refl)
     done
 qed
 
 lemma Suc_unat_diff_1:
   fixes x :: "'a :: len word"
   assumes lt: "1 \<le> x"
   shows "Suc (unat (x - 1)) = unat x"
 proof -
   have "0 < unat x"
     by (rule order_less_le_trans [where y = 1], simp, subst unat_1 [symmetric], rule iffD1 [OF word_le_nat_alt lt])
 
   then show ?thesis
     by ((subst unat_sub [OF lt])+, simp only:  unat_1)
 qed
 
 lemma word_div_sub:
   fixes x :: "'a :: len word"
   assumes yx: "y \<le> x"
   and     y0: "0 < y"
   shows "(x - y) div y = x div y - 1"
   apply (rule word_unat.Rep_eqD)
   apply (subst unat_div)
   apply (subst unat_sub [OF yx])
   apply (subst unat_sub)
    apply (subst word_le_nat_alt)
    apply (subst unat_div)
    apply (subst le_div_geq)
      apply (rule order_le_less_trans [OF _ unat_mono [OF y0]])
      apply simp
     apply (subst word_le_nat_alt [symmetric], rule yx)
    apply simp
   apply (subst unat_div)
   apply (subst le_div_geq [OF _ iffD1 [OF word_le_nat_alt yx]])
    apply (rule order_le_less_trans [OF _ unat_mono [OF y0]])
    apply simp
   apply simp
   done
 
 lemma word_mult_less_mono1:
   fixes i :: "'a :: len word"
   assumes ij: "i < j"
   and    knz: "0 < k"
   and    ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "i * k < j * k"
 proof -
   from ij ujk knz have jk: "unat i * unat k < 2 ^ len_of TYPE ('a)"
     by (auto intro: order_less_subst2 simp: word_less_nat_alt elim: mult_less_mono1)
 
   then show ?thesis using ujk knz ij
     by (auto simp: word_less_nat_alt iffD1 [OF unat_mult_lem])
 qed
 
 lemma word_mult_less_dest:
   fixes i :: "'a :: len word"
   assumes ij: "i * k < j * k"
   and    uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
   and    ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "i < j"
   using uik ujk ij
   by (auto simp: word_less_nat_alt iffD1 [OF unat_mult_lem] elim: mult_less_mono1)
 
 lemma word_mult_less_cancel:
   fixes k :: "'a :: len word"
   assumes knz: "0 < k"
   and    uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
   and    ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows "(i * k < j * k) = (i < j)"
   by (rule iffI [OF word_mult_less_dest [OF _ uik ujk] word_mult_less_mono1 [OF _ knz ujk]])
 
 lemma Suc_div_unat_helper:
   assumes szv: "sz < LENGTH('a :: len)"
   and   usszv: "us \<le> sz"
   shows "2 ^ (sz - us) = Suc (unat (((2::'a :: len word) ^ sz - 1) div 2 ^ us))"
 proof -
   note usv = order_le_less_trans [OF usszv szv]
 
   from usszv obtain q where qv: "sz = us + q" by (auto simp: le_iff_add)
 
   have "Suc (unat (((2:: 'a word) ^ sz - 1) div 2 ^ us)) =
     (2 ^ us + unat ((2:: 'a word) ^ sz - 1)) div 2 ^ us"
     apply (subst unat_div unat_power_lower[OF usv])+
     apply (subst div_add_self1, simp+)
     done
 
   also have "\<dots> = ((2 ^ us - 1) + 2 ^ sz) div 2 ^ us" using szv
     by (simp add: unat_minus_one)
 
   also have "\<dots> = 2 ^ q + ((2 ^ us - 1) div 2 ^ us)"
     apply (subst qv)
     apply (subst power_add)
     apply (subst div_mult_self2; simp)
     done
 
   also have "\<dots> = 2 ^ (sz - us)" using qv by simp
 
   finally show ?thesis ..
 qed
 
 
 lemma set_enum_word8_def:
   "(set enum::word8 set) = {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
                             20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36,
                             37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53,
                             54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70,
                             71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87,
                             88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103,
                             104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117,
                             118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131,
                             132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145,
                             146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159,
                             160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173,
                             174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187,
                             188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201,
                             202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215,
                             216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229,
                             230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243,
                             244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255}"
   by eval
 
 lemma set_strip_insert: "\<lbrakk> x \<in> insert a S; x \<noteq> a \<rbrakk> \<Longrightarrow> x \<in> S"
   by simp
 
 lemma word8_exhaust:
   fixes x :: word8
   shows "\<lbrakk>x \<noteq> 0; x \<noteq> 1; x \<noteq> 2; x \<noteq> 3; x \<noteq> 4; x \<noteq> 5; x \<noteq> 6; x \<noteq> 7; x \<noteq> 8; x \<noteq> 9; x \<noteq> 10; x \<noteq> 11; x \<noteq>
           12; x \<noteq> 13; x \<noteq> 14; x \<noteq> 15; x \<noteq> 16; x \<noteq> 17; x \<noteq> 18; x \<noteq> 19; x \<noteq> 20; x \<noteq> 21; x \<noteq> 22; x \<noteq>
           23; x \<noteq> 24; x \<noteq> 25; x \<noteq> 26; x \<noteq> 27; x \<noteq> 28; x \<noteq> 29; x \<noteq> 30; x \<noteq> 31; x \<noteq> 32; x \<noteq> 33; x \<noteq>
           34; x \<noteq> 35; x \<noteq> 36; x \<noteq> 37; x \<noteq> 38; x \<noteq> 39; x \<noteq> 40; x \<noteq> 41; x \<noteq> 42; x \<noteq> 43; x \<noteq> 44; x \<noteq>
           45; x \<noteq> 46; x \<noteq> 47; x \<noteq> 48; x \<noteq> 49; x \<noteq> 50; x \<noteq> 51; x \<noteq> 52; x \<noteq> 53; x \<noteq> 54; x \<noteq> 55; x \<noteq>
           56; x \<noteq> 57; x \<noteq> 58; x \<noteq> 59; x \<noteq> 60; x \<noteq> 61; x \<noteq> 62; x \<noteq> 63; x \<noteq> 64; x \<noteq> 65; x \<noteq> 66; x \<noteq>
           67; x \<noteq> 68; x \<noteq> 69; x \<noteq> 70; x \<noteq> 71; x \<noteq> 72; x \<noteq> 73; x \<noteq> 74; x \<noteq> 75; x \<noteq> 76; x \<noteq> 77; x \<noteq>
           78; x \<noteq> 79; x \<noteq> 80; x \<noteq> 81; x \<noteq> 82; x \<noteq> 83; x \<noteq> 84; x \<noteq> 85; x \<noteq> 86; x \<noteq> 87; x \<noteq> 88; x \<noteq>
           89; x \<noteq> 90; x \<noteq> 91; x \<noteq> 92; x \<noteq> 93; x \<noteq> 94; x \<noteq> 95; x \<noteq> 96; x \<noteq> 97; x \<noteq> 98; x \<noteq> 99; x \<noteq>
           100; x \<noteq> 101; x \<noteq> 102; x \<noteq> 103; x \<noteq> 104; x \<noteq> 105; x \<noteq> 106; x \<noteq> 107; x \<noteq> 108; x \<noteq> 109; x \<noteq>
           110; x \<noteq> 111; x \<noteq> 112; x \<noteq> 113; x \<noteq> 114; x \<noteq> 115; x \<noteq> 116; x \<noteq> 117; x \<noteq> 118; x \<noteq> 119; x \<noteq>
           120; x \<noteq> 121; x \<noteq> 122; x \<noteq> 123; x \<noteq> 124; x \<noteq> 125; x \<noteq> 126; x \<noteq> 127; x \<noteq> 128; x \<noteq> 129; x \<noteq>
           130; x \<noteq> 131; x \<noteq> 132; x \<noteq> 133; x \<noteq> 134; x \<noteq> 135; x \<noteq> 136; x \<noteq> 137; x \<noteq> 138; x \<noteq> 139; x \<noteq>
           140; x \<noteq> 141; x \<noteq> 142; x \<noteq> 143; x \<noteq> 144; x \<noteq> 145; x \<noteq> 146; x \<noteq> 147; x \<noteq> 148; x \<noteq> 149; x \<noteq>
           150; x \<noteq> 151; x \<noteq> 152; x \<noteq> 153; x \<noteq> 154; x \<noteq> 155; x \<noteq> 156; x \<noteq> 157; x \<noteq> 158; x \<noteq> 159; x \<noteq>
           160; x \<noteq> 161; x \<noteq> 162; x \<noteq> 163; x \<noteq> 164; x \<noteq> 165; x \<noteq> 166; x \<noteq> 167; x \<noteq> 168; x \<noteq> 169; x \<noteq>
           170; x \<noteq> 171; x \<noteq> 172; x \<noteq> 173; x \<noteq> 174; x \<noteq> 175; x \<noteq> 176; x \<noteq> 177; x \<noteq> 178; x \<noteq> 179; x \<noteq>
           180; x \<noteq> 181; x \<noteq> 182; x \<noteq> 183; x \<noteq> 184; x \<noteq> 185; x \<noteq> 186; x \<noteq> 187; x \<noteq> 188; x \<noteq> 189; x \<noteq>
           190; x \<noteq> 191; x \<noteq> 192; x \<noteq> 193; x \<noteq> 194; x \<noteq> 195; x \<noteq> 196; x \<noteq> 197; x \<noteq> 198; x \<noteq> 199; x \<noteq>
           200; x \<noteq> 201; x \<noteq> 202; x \<noteq> 203; x \<noteq> 204; x \<noteq> 205; x \<noteq> 206; x \<noteq> 207; x \<noteq> 208; x \<noteq> 209; x \<noteq>
           210; x \<noteq> 211; x \<noteq> 212; x \<noteq> 213; x \<noteq> 214; x \<noteq> 215; x \<noteq> 216; x \<noteq> 217; x \<noteq> 218; x \<noteq> 219; x \<noteq>
           220; x \<noteq> 221; x \<noteq> 222; x \<noteq> 223; x \<noteq> 224; x \<noteq> 225; x \<noteq> 226; x \<noteq> 227; x \<noteq> 228; x \<noteq> 229; x \<noteq>
           230; x \<noteq> 231; x \<noteq> 232; x \<noteq> 233; x \<noteq> 234; x \<noteq> 235; x \<noteq> 236; x \<noteq> 237; x \<noteq> 238; x \<noteq> 239; x \<noteq>
           240; x \<noteq> 241; x \<noteq> 242; x \<noteq> 243; x \<noteq> 244; x \<noteq> 245; x \<noteq> 246; x \<noteq> 247; x \<noteq> 248; x \<noteq> 249; x \<noteq>
           250; x \<noteq> 251; x \<noteq> 252; x \<noteq> 253; x \<noteq> 254; x \<noteq> 255\<rbrakk> \<Longrightarrow> P"
   apply (subgoal_tac "x \<in> set enum", subst (asm) set_enum_word8_def)
     apply (drule set_strip_insert, assumption)+
    apply (erule emptyE)
   apply (subst enum_UNIV, rule UNIV_I)
   done
 
 lemma upto_enum_red':
   assumes lt: "1 \<le> X"
   shows "[(0::'a :: len word) .e. X - 1] =  map of_nat [0 ..< unat X]"
 proof -
   have lt': "unat X < 2 ^ LENGTH('a)"
     by (rule unat_lt2p)
 
   show ?thesis
     apply (subst upto_enum_red)
     apply (simp del: upt.simps)
     apply (subst Suc_unat_diff_1 [OF lt])
     apply (rule map_cong [OF refl])
     apply (rule toEnum_of_nat)
     apply simp
     apply (erule order_less_trans [OF _ lt'])
     done
 qed
 
 lemma upto_enum_red2:
   assumes szv: "sz < LENGTH('a :: len)"
   shows "[(0:: 'a :: len word) .e. 2 ^ sz - 1] =
   map of_nat [0 ..< 2 ^ sz]" using szv
   apply (subst unat_power_lower[OF szv, symmetric])
   apply (rule upto_enum_red')
   apply (subst word_le_nat_alt, simp)
   done
 
 lemma upto_enum_step_red:
   assumes szv: "sz < len_of (TYPE('a))"
   and   usszv: "us \<le> sz"
   shows "[0 :: 'a :: len word , 2 ^ us .e. 2 ^ sz - 1] =
   map (\<lambda>x. of_nat x * 2 ^ us) [0 ..< 2 ^ (sz - us)]" using szv
   unfolding upto_enum_step_def
   apply (subst if_not_P)
    apply (rule leD)
    apply (subst word_le_nat_alt)
    apply (subst unat_minus_one)
     apply simp
    apply simp
   apply simp
   apply (subst upto_enum_red)
   apply (simp del: upt.simps)
   apply (subst Suc_div_unat_helper [where 'a = 'a, OF szv usszv, symmetric])
   apply clarsimp
   apply (subst toEnum_of_nat)
    apply (erule order_less_trans)
    using szv
    apply simp
   apply simp
   done
 
 lemma upto_enum_word:
   "[x .e. y] = map of_nat [unat x ..< Suc (unat y)]"
   apply (subst upto_enum_red)
   apply clarsimp
   apply (subst toEnum_of_nat)
    prefer 2
    apply (rule refl)
   apply (erule disjE, simp)
   apply clarsimp
   apply (erule order_less_trans)
   apply simp
   done
 
 lemma word_upto_Cons_eq:
   "\<lbrakk>x = z; x < y; Suc (unat y) < 2 ^ LENGTH('a)\<rbrakk>
    \<Longrightarrow> [x::'a::len word .e. y] = z # [x + 1 .e. y]"
   apply (subst upto_enum_red)
   apply (subst upt_conv_Cons)
    apply (simp)
    apply (drule unat_mono)
    apply arith
   apply (simp only: list.map)
   apply (subst list.inject)
   apply rule
    apply (rule to_from_enum)
    apply (subst upto_enum_red)
   apply (rule map_cong [OF _ refl])
   apply (rule arg_cong2 [where f = "\<lambda>x y. [x ..< y]"])
    apply unat_arith
   apply simp
   done
 
 lemma distinct_enum_upto:
   "distinct [(0 :: 'a::len word) .e. b]"
 proof -
   have "\<And>(b::'a word). [0 .e. b] = nths enum {..< Suc (fromEnum b)}"
     apply (subst upto_enum_red)
     apply (subst nths_upt_eq_take)
     apply (subst enum_word_def)
     apply (subst take_map)
     apply (subst take_upt)
      apply (simp only: add_0 fromEnum_unat)
      apply (rule order_trans [OF _ order_eq_refl])
       apply (rule Suc_leI [OF unat_lt2p])
      apply simp
     apply clarsimp
     apply (rule toEnum_of_nat)
     apply (erule order_less_trans [OF _ unat_lt2p])
     done
 
   then show ?thesis
     by (rule ssubst) (rule distinct_nthsI, simp)
 qed
 
 lemma upto_enum_set_conv [simp]:
   fixes a :: "'a :: len word"
   shows "set [a .e. b] = {x. a \<le> x \<and> x \<le> b}"
   apply (subst upto_enum_red)
   apply (subst set_map)
   apply safe
     apply simp
     apply clarsimp
     apply (erule disjE)
      apply simp
      apply (erule iffD2 [OF word_le_nat_alt])
     apply clarsimp
     apply (erule word_unat.Rep_cases [OF unat_le [OF order_less_imp_le]])
     apply simp
     apply (erule iffD2 [OF word_le_nat_alt])
    apply simp
 
    apply clarsimp
    apply (erule disjE)
     apply simp
    apply clarsimp
    apply (rule word_unat.Rep_cases [OF unat_le  [OF order_less_imp_le]])
     apply assumption
    apply simp
    apply (erule order_less_imp_le [OF iffD2 [OF word_less_nat_alt]])
   apply clarsimp
   apply (rule_tac x="fromEnum x" in image_eqI)
    apply clarsimp
   apply clarsimp
   apply (rule conjI)
    apply (subst word_le_nat_alt [symmetric])
    apply simp
   apply safe
    apply (simp add: word_le_nat_alt [symmetric])
   apply (simp add: word_less_nat_alt [symmetric])
   done
 
 lemma upto_enum_less:
   assumes xin: "x \<in> set [(a::'a::len word).e.2 ^ n - 1]"
   and     nv:  "n < LENGTH('a::len)"
   shows   "x < 2 ^ n"
 proof (cases n)
   case 0
   then show ?thesis using xin by simp
 next
   case (Suc m)
   show ?thesis using xin nv by simp
 qed
 
 lemma upto_enum_len_less:
   "\<lbrakk> n \<le> length [a, b .e. c]; n \<noteq> 0 \<rbrakk> \<Longrightarrow> a \<le> c"
   unfolding upto_enum_step_def
   by (simp split: if_split_asm)
 
 lemma length_upto_enum_step:
   fixes x :: "'a :: len word"
   shows "x \<le> z \<Longrightarrow> length [x , y .e. z] = (unat ((z - x) div (y - x))) + 1"
   unfolding upto_enum_step_def
   by (simp add: upto_enum_red)
 
 lemma map_length_unfold_one:
   fixes x :: "'a::len word"
   assumes xv: "Suc (unat x) < 2 ^ LENGTH('a)"
   and     ax: "a < x"
   shows   "map f [a .e. x] = f a # map f [a + 1 .e. x]"
   by (subst word_upto_Cons_eq, auto, fact+)
 
 lemma upto_enum_set_conv2:
   fixes a :: "'a::len word"
   shows "set [a .e. b] = {a .. b}"
   by auto
 
 lemma of_nat_unat [simp]:
   "of_nat \<circ> unat = id"
   by (rule ext, simp)
 
 lemma Suc_unat_minus_one [simp]:
   "x \<noteq> 0 \<Longrightarrow> Suc (unat (x - 1)) = unat x"
   by (metis Suc_diff_1 unat_gt_0 unat_minus_one)
 
 lemma word_add_le_dest:
   fixes i :: "'a :: len word"
   assumes le: "i + k \<le> j + k"
   and    uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
   and    ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "i \<le> j"
   using uik ujk le
   by (auto simp: word_le_nat_alt iffD1 [OF unat_add_lem] elim: add_le_mono1)
 
 lemma mask_shift:
   "(x && ~~ mask y) >> y = x >> y"
   apply (rule word_eqI)
   apply (simp add: nth_shiftr word_size)
   apply safe
   apply (drule test_bit.Rep[simplified, rule_format])
   apply (simp add: word_size word_ops_nth_size)
   done
 
 lemma word_add_le_mono1:
   fixes i :: "'a :: len word"
   assumes ij: "i \<le> j"
   and    ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "i + k \<le> j + k"
 proof -
   from ij ujk have jk: "unat i + unat k < 2 ^ len_of TYPE ('a)"
     by (auto elim: order_le_less_subst2 simp: word_le_nat_alt elim: add_le_mono1)
 
   then show ?thesis using ujk ij
     by (auto simp: word_le_nat_alt iffD1 [OF unat_add_lem])
 qed
 
 lemma word_add_le_mono2:
   fixes i :: "'a :: len word"
   shows "\<lbrakk>i \<le> j; unat j + unat k < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow> k + i \<le> k + j"
   by (subst field_simps, subst field_simps, erule (1) word_add_le_mono1)
 
 lemma word_add_le_iff:
   fixes i :: "'a :: len word"
   assumes uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
   and     ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "(i + k \<le> j + k) = (i \<le> j)"
 proof
   assume "i \<le> j"
   show "i + k \<le> j + k" by (rule word_add_le_mono1) fact+
 next
   assume "i + k \<le> j + k"
   show "i \<le> j" by (rule word_add_le_dest) fact+
 qed
 
 lemma word_add_less_mono1:
   fixes i :: "'a :: len word"
   assumes ij: "i < j"
   and    ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "i + k < j + k"
 proof -
   from ij ujk have jk: "unat i + unat k < 2 ^ len_of TYPE ('a)"
     by (auto elim: order_le_less_subst2 simp: word_less_nat_alt elim: add_less_mono1)
 
   then show ?thesis using ujk ij
     by (auto simp: word_less_nat_alt iffD1 [OF unat_add_lem])
 qed
 
 lemma word_add_less_dest:
   fixes i :: "'a :: len word"
   assumes le: "i + k < j + k"
   and    uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
   and    ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "i < j"
   using uik ujk le
   by (auto simp: word_less_nat_alt iffD1 [OF unat_add_lem] elim: add_less_mono1)
 
 lemma word_add_less_iff:
   fixes i :: "'a :: len word"
   assumes uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
   and     ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "(i + k < j + k) = (i < j)"
 proof
   assume "i < j"
   show "i + k < j + k" by (rule word_add_less_mono1) fact+
 next
   assume "i + k < j + k"
   show "i < j" by (rule word_add_less_dest) fact+
 qed
 
 lemma shiftr_div_2n':
   "unat (w >> n) = unat w div 2 ^ n"
   apply (unfold unat_def)
   apply (subst shiftr_div_2n)
   apply (subst nat_div_distrib)
    apply simp
   apply (simp add: nat_power_eq)
   done
 
 lemma shiftl_shiftr_id:
   assumes nv: "n < LENGTH('a)"
   and     xv: "x < 2 ^ (LENGTH('a) - n)"
   shows "x << n >> n = (x::'a::len word)"
   apply (simp add: shiftl_t2n)
   apply (rule word_unat.Rep_eqD)
   apply (subst shiftr_div_2n')
   apply (cases n)
    apply simp
   apply (subst iffD1 [OF unat_mult_lem])+
    apply (subst unat_power_lower[OF nv])
    apply (rule nat_less_power_trans [OF _ order_less_imp_le [OF nv]])
    apply (rule order_less_le_trans [OF unat_mono [OF xv] order_eq_refl])
    apply (rule unat_power_lower)
    apply simp
   apply (subst unat_power_lower[OF nv])
   apply simp
   done
 
 lemma word_mult_less_iff:
   fixes i :: "'a :: len word"
   assumes knz: "0 < k"
   and     uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
   and     ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "(i * k < j * k) = (i < j)"
   using assms by (rule word_mult_less_cancel)
 
 lemma word_le_imp_diff_le:
   fixes n :: "'a::len word"
   shows "\<lbrakk>k \<le> n; n \<le> m\<rbrakk> \<Longrightarrow> n - k \<le> m"
   by (auto simp: unat_sub word_le_nat_alt)
 
 lemma word_less_imp_diff_less:
   fixes n :: "'a::len word"
   shows "\<lbrakk>k \<le> n; n < m\<rbrakk> \<Longrightarrow> n - k < m"
   by (clarsimp simp: unat_sub word_less_nat_alt
              intro!: less_imp_diff_less)
 
 lemma word_mult_le_mono1:
   fixes i :: "'a :: len word"
   assumes ij: "i \<le> j"
   and    knz: "0 < k"
   and    ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "i * k \<le> j * k"
 proof -
   from ij ujk knz have jk: "unat i * unat k < 2 ^ len_of TYPE ('a)"
     by (auto elim: order_le_less_subst2 simp: word_le_nat_alt elim: mult_le_mono1)
 
   then show ?thesis using ujk knz ij
     by (auto simp: word_le_nat_alt iffD1 [OF unat_mult_lem])
 qed
 
 lemma word_mult_le_iff:
   fixes i :: "'a :: len word"
   assumes knz: "0 < k"
   and     uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
   and     ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "(i * k \<le> j * k) = (i \<le> j)"
 proof
   assume "i \<le> j"
   show "i * k \<le> j * k" by (rule word_mult_le_mono1) fact+
 next
   assume p: "i * k \<le> j * k"
 
   have "0 < unat k" using knz by (simp add: word_less_nat_alt)
   then show "i \<le> j" using p
     by (clarsimp simp: word_le_nat_alt iffD1 [OF unat_mult_lem uik]
       iffD1 [OF unat_mult_lem ujk])
 qed
 
 lemma word_diff_less:
   fixes n :: "'a :: len word"
   shows "\<lbrakk>0 < n; 0 < m; n \<le> m\<rbrakk> \<Longrightarrow> m - n < m"
   apply (subst word_less_nat_alt)
   apply (subst unat_sub)
    apply assumption
   apply (rule diff_less)
    apply (simp_all add: word_less_nat_alt)
    done
 
 lemma MinI:
   assumes fa: "finite A"
   and     ne: "A \<noteq> {}"
   and     xv: "m \<in> A"
   and    min: "\<forall>y \<in> A. m \<le> y"
   shows "Min A = m" using fa ne xv min
 proof (induct A arbitrary: m rule: finite_ne_induct)
   case singleton then show ?case by simp
 next
   case (insert y F)
 
   from insert.prems have yx: "m \<le> y" and fx: "\<forall>y \<in> F. m \<le> y" by auto
   have "m \<in> insert y F" by fact
   then show ?case
   proof
     assume mv: "m = y"
 
     have mlt: "m \<le> Min F"
       by (rule iffD2 [OF Min_ge_iff [OF insert.hyps(1) insert.hyps(2)] fx])
 
     show ?case
       apply (subst Min_insert [OF insert.hyps(1) insert.hyps(2)])
       apply (subst mv [symmetric])
       apply (auto simp: min_def mlt)
       done
   next
     assume "m \<in> F"
     then have mf: "Min F = m"
       by (rule insert.hyps(4) [OF _ fx])
 
     show ?case
       apply (subst Min_insert [OF insert.hyps(1) insert.hyps(2)])
       apply (subst mf)
       apply (rule iffD2 [OF _ yx])
       apply (auto simp: min_def)
       done
   qed
 qed
 
 lemma length_upto_enum [simp]:
   fixes a :: "'a :: len word"
   shows "length [a .e. b] = Suc (unat b) - unat a"
   apply (simp add: word_le_nat_alt upto_enum_red)
   apply (clarsimp simp: Suc_diff_le)
   done
 
 lemma length_upto_enum_less_one:
   "\<lbrakk>a \<le> b; b \<noteq> 0\<rbrakk>
   \<Longrightarrow> length [a .e. b - 1] = unat (b - a)"
   apply clarsimp
   apply (subst unat_sub[symmetric], assumption)
   apply clarsimp
   done
 
 lemma drop_upto_enum:
   "drop (unat n) [0 .e. m] = [n .e. m]"
   apply (clarsimp simp: upto_enum_def)
   apply (induct m, simp)
   by (metis drop_map drop_upt plus_nat.add_0)
 
 lemma distinct_enum_upto' [simp]:
   "distinct [a::'a::len word .e. b]"
   apply (subst drop_upto_enum [symmetric])
   apply (rule distinct_drop)
   apply (rule distinct_enum_upto)
   done
 
 lemma length_interval:
   "\<lbrakk>set xs = {x. (a::'a::len word) \<le> x \<and> x \<le> b}; distinct xs\<rbrakk>
   \<Longrightarrow> length xs = Suc (unat b) - unat a"
   apply (frule distinct_card)
   apply (subgoal_tac "set xs = set [a .e. b]")
    apply (cut_tac distinct_card [where xs="[a .e. b]"])
     apply (subst (asm) length_upto_enum)
     apply clarsimp
    apply (rule distinct_enum_upto')
   apply simp
   done
 
 lemma not_empty_eq:
   "(S \<noteq> {}) = (\<exists>x. x \<in> S)"
   by auto
 
 lemma range_subset_lower:
   fixes c :: "'a ::linorder"
   shows "\<lbrakk> {a..b} \<subseteq> {c..d}; x \<in> {a..b} \<rbrakk> \<Longrightarrow> c \<le> a"
   apply (frule (1) subsetD)
   apply (rule classical)
   apply clarsimp
   done
 
 lemma range_subset_upper:
   fixes c :: "'a ::linorder"
   shows "\<lbrakk> {a..b} \<subseteq> {c..d}; x \<in> {a..b} \<rbrakk> \<Longrightarrow> b \<le> d"
   apply (frule (1) subsetD)
   apply (rule classical)
   apply clarsimp
   done
 
 lemma range_subset_eq:
   fixes a::"'a::linorder"
   assumes non_empty: "a \<le> b"
   shows "({a..b} \<subseteq> {c..d}) = (c \<le> a \<and> b \<le> d)"
   apply (insert non_empty)
   apply (rule iffI)
    apply (frule range_subset_lower [where x=a], simp)
    apply (drule range_subset_upper [where x=a], simp)
    apply simp
   apply auto
   done
 
 lemma range_eq:
   fixes a::"'a::linorder"
   assumes non_empty: "a \<le> b"
   shows "({a..b} = {c..d}) = (a = c \<and> b = d)"
   by (metis atLeastatMost_subset_iff eq_iff non_empty)
 
 lemma range_strict_subset_eq:
   fixes a::"'a::linorder"
   assumes non_empty: "a \<le> b"
   shows "({a..b} \<subset> {c..d}) = (c \<le> a \<and> b \<le> d \<and> (a = c \<longrightarrow> b \<noteq> d))"
   apply (insert non_empty)
   apply (subst psubset_eq)
   apply (subst range_subset_eq, assumption+)
   apply (subst range_eq, assumption+)
   apply simp
   done
 
 lemma range_subsetI:
   fixes x :: "'a :: order"
   assumes xX: "X \<le> x"
   and     yY: "y \<le> Y"
   shows   "{x .. y} \<subseteq> {X .. Y}"
   using xX yY by auto
 
 lemma set_False [simp]:
   "(set bs \<subseteq> {False}) = (True \<notin> set bs)" by auto
 
 declare of_nat_power [simp del]
 
 (* TODO: move to word *)
 lemma unat_of_bl_length:
   "unat (of_bl xs :: 'a::len word) < 2 ^ (length xs)"
 proof (cases "length xs < LENGTH('a)")
   case True
   then have "(of_bl xs::'a::len word) < 2 ^ length xs"
     by (simp add: of_bl_length_less)
   with True
   show ?thesis
     by (simp add: word_less_nat_alt word_unat_power unat_of_nat)
 next
   case False
   have "unat (of_bl xs::'a::len word) < 2 ^ LENGTH('a)"
     by (simp split: unat_split)
   also
   from False
   have "LENGTH('a) \<le> length xs" by simp
   then have "2 ^ LENGTH('a) \<le> (2::nat) ^ length xs"
     by (rule power_increasing) simp
   finally
   show ?thesis .
 qed
 
 lemma is_aligned_0'[simp]:
   "is_aligned 0 n"
   by (simp add: is_aligned_def)
 
 lemma p_assoc_help:
   fixes p :: "'a::{ring,power,numeral,one}"
   shows "p + 2^sz - 1 = p + (2^sz - 1)"
   by simp
 
 lemma word_add_increasing:
   fixes x :: "'a :: len word"
   shows "\<lbrakk> p + w \<le> x; p \<le> p + w \<rbrakk> \<Longrightarrow> p \<le> x"
   by unat_arith
 
 lemma word_random:
   fixes x :: "'a :: len word"
   shows "\<lbrakk> p \<le> p + x'; x \<le> x' \<rbrakk> \<Longrightarrow> p \<le> p + x"
   by unat_arith
 
 lemma word_sub_mono:
   "\<lbrakk> a \<le> c; d \<le> b; a - b \<le> a; c - d \<le> c \<rbrakk>
     \<Longrightarrow> (a - b) \<le> (c - d :: 'a :: len word)"
   by unat_arith
 
 lemma power_not_zero:
   "n < LENGTH('a::len) \<Longrightarrow> (2 :: 'a word) ^ n \<noteq> 0"
   by (metis p2_gt_0 word_neq_0_conv)
 
 lemma word_gt_a_gt_0:
   "a < n \<Longrightarrow> (0 :: 'a::len word) < n"
   apply (case_tac "n = 0")
    apply clarsimp
   apply (clarsimp simp: word_neq_0_conv)
   done
 
 lemma word_shift_nonzero:
   "\<lbrakk> (x::'a::len word) \<le> 2 ^ m; m + n < LENGTH('a::len); x \<noteq> 0\<rbrakk>
    \<Longrightarrow> x << n \<noteq> 0"
   apply (simp only: word_neq_0_conv word_less_nat_alt
                     shiftl_t2n mod_0 unat_word_ariths
                     unat_power_lower word_le_nat_alt)
   apply (subst mod_less)
    apply (rule order_le_less_trans)
     apply (erule mult_le_mono2)
    apply (subst power_add[symmetric])
    apply (rule power_strict_increasing)
     apply simp
    apply simp
   apply simp
   done
 
 lemma word_power_less_1 [simp]:
   "sz < LENGTH('a::len) \<Longrightarrow> (2::'a word) ^ sz - 1 < 2 ^ sz"
   apply (simp add: word_less_nat_alt)
   apply (subst unat_minus_one)
   apply (simp add: word_unat.Rep_inject [symmetric])
   apply simp
   done
 
 lemma nasty_split_lt:
   "\<lbrakk> (x :: 'a:: len word) < 2 ^ (m - n); n \<le> m; m < LENGTH('a::len) \<rbrakk>
      \<Longrightarrow> x * 2 ^ n + (2 ^ n - 1) \<le> 2 ^ m - 1"
   apply (simp only: add_diff_eq)
   apply (subst mult_1[symmetric], subst distrib_right[symmetric])
   apply (rule word_sub_mono)
      apply (rule order_trans)
       apply (rule word_mult_le_mono1)
         apply (rule inc_le)
         apply assumption
        apply (subst word_neq_0_conv[symmetric])
        apply (rule power_not_zero)
        apply simp
       apply (subst unat_power_lower, simp)+
       apply (subst power_add[symmetric])
       apply (rule power_strict_increasing)
        apply simp
       apply simp
      apply (subst power_add[symmetric])
      apply simp
     apply simp
    apply (rule word_sub_1_le)
    apply (subst mult.commute)
    apply (subst shiftl_t2n[symmetric])
    apply (rule word_shift_nonzero)
      apply (erule inc_le)
     apply simp
    apply (unat_arith)
   apply (drule word_power_less_1)
   apply simp
   done
 
 lemma nasty_split_less:
   "\<lbrakk>m \<le> n; n \<le> nm; nm < LENGTH('a::len); x < 2 ^ (nm - n)\<rbrakk>
    \<Longrightarrow> (x :: 'a word) * 2 ^ n + (2 ^ m - 1) < 2 ^ nm"
   apply (simp only: word_less_sub_le[symmetric])
   apply (rule order_trans [OF _ nasty_split_lt])
      apply (rule word_plus_mono_right)
       apply (rule word_sub_mono)
          apply (simp add: word_le_nat_alt)
         apply simp
        apply (simp add: word_sub_1_le[OF power_not_zero])
       apply (simp add: word_sub_1_le[OF power_not_zero])
      apply (rule is_aligned_no_wrap')
       apply (rule is_aligned_mult_triv2)
      apply simp
     apply (erule order_le_less_trans, simp)
    apply simp+
   done
 
 lemma int_not_emptyD:
   "A \<inter> B \<noteq> {} \<Longrightarrow> \<exists>x. x \<in> A \<and> x \<in> B"
   by (erule contrapos_np, clarsimp simp: disjoint_iff_not_equal)
 
 lemma unat_less_power:
   fixes k :: "'a::len word"
   assumes szv: "sz < LENGTH('a)"
   and     kv:  "k < 2 ^ sz"
   shows   "unat k < 2 ^ sz"
   using szv unat_mono [OF kv] by simp
 
 lemma unat_mult_power_lem:
   assumes kv: "k < 2 ^ (LENGTH('a::len) - sz)"
   shows "unat (2 ^ sz * of_nat k :: (('a::len) word)) = 2 ^ sz * k"
 proof cases
   assume szv: "sz < LENGTH('a::len)"
   show ?thesis
   proof (cases "sz = 0")
     case True
     then show ?thesis using kv szv
      by (simp add: unat_of_nat)
   next
     case False
     then have sne: "0 < sz" ..
 
     have uk: "unat (of_nat k :: 'a word) = k"
       apply (subst unat_of_nat)
       apply (simp add: nat_mod_eq less_trans[OF kv] sne)
       done
 
     show ?thesis using szv
       apply (subst iffD1 [OF unat_mult_lem])
       apply (simp add: uk nat_less_power_trans[OF kv order_less_imp_le [OF szv]])+
       done
   qed
 next
   assume "\<not> sz < LENGTH('a)"
   with kv show ?thesis by (simp add: not_less power_overflow)
 qed
 
 lemma aligned_add_offset_no_wrap:
   fixes off :: "('a::len) word"
   and     x :: "'a word"
   assumes al: "is_aligned x sz"
   and   offv: "off < 2 ^ sz"
   shows  "unat x + unat off < 2 ^ LENGTH('a)"
 proof cases
   assume szv: "sz < LENGTH('a)"
   from al obtain k where xv: "x = 2 ^ sz * (of_nat k)"
     and kl: "k < 2 ^ (LENGTH('a) - sz)"
     by (auto elim: is_alignedE)
 
   show ?thesis using szv
     apply (subst xv)
     apply (subst unat_mult_power_lem[OF kl])
     apply (subst mult.commute, rule nat_add_offset_less)
       apply (rule less_le_trans[OF unat_mono[OF offv, simplified]])
       apply (erule eq_imp_le[OF unat_power_lower])
      apply (rule kl)
     apply simp
    done
 next
   assume "\<not> sz < LENGTH('a)"
   with offv show ?thesis by (simp add: not_less power_overflow )
 qed
 
 lemma aligned_add_offset_mod:
   fixes x :: "('a::len) word"
   assumes al: "is_aligned x sz"
   and     kv: "k < 2 ^ sz"
   shows   "(x + k) mod 2 ^ sz = k"
 proof cases
   assume szv: "sz < LENGTH('a)"
 
   have ux: "unat x + unat k < 2 ^ LENGTH('a)"
     by (rule aligned_add_offset_no_wrap) fact+
 
   show ?thesis using al szv
     apply -
     apply (erule is_alignedE)
     apply (subst word_unat.Rep_inject [symmetric])
     apply (subst unat_mod)
     apply (subst iffD1 [OF unat_add_lem], rule ux)
     apply simp
     apply (subst unat_mult_power_lem, assumption+)
     apply (simp)
     apply (rule mod_less[OF less_le_trans[OF unat_mono], OF kv])
     apply (erule eq_imp_le[OF unat_power_lower])
     done
 next
   assume "\<not> sz < LENGTH('a)"
   with al show ?thesis
     by (simp add: not_less power_overflow is_aligned_mask mask_def
                   word_mod_by_0)
 qed
 
 lemma word_plus_mcs_4:
   "\<lbrakk>v + x \<le> w + x; x \<le> v + x\<rbrakk> \<Longrightarrow> v \<le> (w::'a::len word)"
   by uint_arith
 
 lemma word_plus_mcs_3:
   "\<lbrakk>v \<le> w; x \<le> w + x\<rbrakk> \<Longrightarrow> v + x \<le> w + (x::'a::len word)"
   by unat_arith
 
 lemma aligned_neq_into_no_overlap:
   fixes x :: "'a::len word"
   assumes neq: "x \<noteq> y"
   and     alx: "is_aligned x sz"
   and     aly: "is_aligned y sz"
   shows  "{x .. x + (2 ^ sz - 1)} \<inter> {y .. y + (2 ^ sz - 1)} = {}"
 proof cases
   assume szv: "sz < LENGTH('a)"
   show ?thesis
   proof (rule equals0I, clarsimp)
     fix z
     assume xb: "x \<le> z" and xt: "z \<le> x + (2 ^ sz - 1)"
       and yb: "y \<le> z" and yt: "z \<le> y + (2 ^ sz - 1)"
 
     have rl: "\<And>(p::'a word) k w. \<lbrakk>uint p + uint k < 2 ^ LENGTH('a); w = p + k; w \<le> p + (2 ^ sz - 1) \<rbrakk>
       \<Longrightarrow> k < 2 ^ sz"
       apply -
       apply simp
       apply (subst (asm) add.commute, subst (asm) add.commute, drule word_plus_mcs_4)
       apply (subst add.commute, subst no_plus_overflow_uint_size)
       apply (simp add: word_size_bl)
       apply (erule iffD1 [OF word_less_sub_le[OF szv]])
       done
 
     from xb obtain kx where
       kx: "z = x + kx" and
       kxl: "uint x + uint kx < 2 ^ LENGTH('a)"
       by (clarsimp dest!: word_le_exists')
 
     from yb obtain ky where
       ky: "z = y + ky" and
       kyl: "uint y + uint ky < 2 ^ LENGTH('a)"
       by (clarsimp dest!: word_le_exists')
 
     have "x = y"
     proof -
       have "kx = z mod 2 ^ sz"
       proof (subst kx, rule sym, rule aligned_add_offset_mod)
         show "kx < 2 ^ sz" by (rule rl) fact+
       qed fact+
 
       also have "\<dots> = ky"
       proof (subst ky, rule aligned_add_offset_mod)
         show "ky < 2 ^ sz"
           using kyl ky yt by (rule rl)
       qed fact+
 
       finally have kxky: "kx = ky" .
       moreover have "x + kx = y + ky" by (simp add: kx [symmetric] ky [symmetric])
       ultimately show ?thesis by simp
     qed
 
     then show False using neq by simp
   qed
 next
   assume "\<not> sz < LENGTH('a)"
   with neq alx aly
   have False by (simp add: is_aligned_mask mask_def power_overflow)
   then show ?thesis ..
 qed
 
 lemma less_two_pow_divD:
   "\<lbrakk> (x :: nat) < 2 ^ n div 2 ^ m \<rbrakk>
     \<Longrightarrow> n \<ge> m \<and> (x < 2 ^ (n - m))"
   apply (rule context_conjI)
    apply (rule ccontr)
    apply (simp add: power_strict_increasing)
   apply (simp add: power_sub)
   done
 
 lemma less_two_pow_divI:
   "\<lbrakk> (x :: nat) < 2 ^ (n - m); m \<le> n \<rbrakk> \<Longrightarrow> x < 2 ^ n div 2 ^ m"
   by (simp add: power_sub)
 
 lemma word_less_two_pow_divI:
   "\<lbrakk> (x :: 'a::len word) < 2 ^ (n - m); m \<le> n; n < LENGTH('a) \<rbrakk> \<Longrightarrow> x < 2 ^ n div 2 ^ m"
   apply (simp add: word_less_nat_alt)
   apply (subst unat_word_ariths)
   apply (subst mod_less)
    apply (rule order_le_less_trans [OF div_le_dividend])
    apply (rule unat_lt2p)
   apply (simp add: power_sub)
   done
 
 lemma word_less_two_pow_divD:
   "\<lbrakk> (x :: 'a::len word) < 2 ^ n div 2 ^ m \<rbrakk>
      \<Longrightarrow> n \<ge> m \<and> (x < 2 ^ (n - m))"
   apply (cases "n < LENGTH('a)")
    apply (cases "m < LENGTH('a)")
     apply (simp add: word_less_nat_alt)
     apply (subst(asm) unat_word_ariths)
     apply (subst(asm) mod_less)
      apply (rule order_le_less_trans [OF div_le_dividend])
      apply (rule unat_lt2p)
     apply (clarsimp dest!: less_two_pow_divD)
    apply (simp add: power_overflow)
    apply (simp add: word_div_def)
   apply (simp add: power_overflow word_div_def)
   done
 
 lemma of_nat_less_two_pow_div_set:
   "\<lbrakk> n < LENGTH('a) \<rbrakk> \<Longrightarrow>
    {x. x < (2 ^ n div 2 ^ m :: 'a::len word)}
       = of_nat ` {k. k < 2 ^ n div 2 ^ m}"
   apply (simp add: image_def)
   apply (safe dest!: word_less_two_pow_divD less_two_pow_divD
              intro!: word_less_two_pow_divI)
    apply (rule_tac x="unat x" in exI)
    apply (simp add: power_sub[symmetric])
    apply (subst unat_power_lower[symmetric, where 'a='a])
     apply simp
    apply (erule unat_mono)
   apply (subst word_unat_power)
   apply (rule of_nat_mono_maybe)
    apply (rule power_strict_increasing)
     apply simp
    apply simp
   apply assumption
   done
 
 lemma  word_less_power_trans2:
   fixes n :: "'a::len word"
   shows "\<lbrakk>n < 2 ^ (m - k); k \<le> m; m < LENGTH('a)\<rbrakk> \<Longrightarrow> n * 2 ^ k < 2 ^ m"
   by (subst field_simps, rule word_less_power_trans)
 
 lemma ucast_less:
   "LENGTH('b) < LENGTH('a) \<Longrightarrow>
    (ucast (x :: 'b :: len word) :: ('a :: len word)) < 2 ^ LENGTH('b)"
   apply (subst mask_eq_iff_w2p[symmetric])
    apply (simp add: word_size)
   apply (rule word_eqI)
   apply (simp add: word_size nth_ucast)
   apply safe
   apply (simp add: test_bit.Rep[simplified])
   done
 
 lemma ucast_range_less:
   "LENGTH('a :: len) < LENGTH('b :: len) \<Longrightarrow>
    range (ucast :: 'a word \<Rightarrow> 'b word)
        = {x. x < 2 ^ len_of TYPE ('a)}"
   apply safe
    apply (erule ucast_less)
   apply (simp add: image_def)
   apply (rule_tac x="ucast x" in exI)
   apply (drule less_mask_eq)
   apply (rule word_eqI)
   apply (drule_tac x=n in word_eqD)
   apply (clarsimp simp: word_size nth_ucast)
   done
 
 lemma word_power_less_diff:
   "\<lbrakk>2 ^ n * q < (2::'a::len word) ^ m; q < 2 ^ (LENGTH('a) - n)\<rbrakk> \<Longrightarrow> q < 2 ^ (m - n)"
   apply (case_tac "m \<ge> LENGTH('a)")
    apply (simp add: power_overflow)
   apply (case_tac "n \<ge> LENGTH('a)")
    apply (simp add: power_overflow)
   apply (cases "n = 0")
    apply simp
   apply (subst word_less_nat_alt)
   apply (subst unat_power_lower)
    apply simp
   apply (rule nat_power_less_diff)
   apply (simp add: word_less_nat_alt)
   apply (subst (asm) iffD1 [OF unat_mult_lem])
    apply (simp add:nat_less_power_trans)
   apply simp
   done
 
 lemmas word_diff_ls'' = word_diff_ls [where xa=x and x=x for x]
 lemmas word_diff_ls' = word_diff_ls'' [simplified]
 
 lemmas word_l_diffs' = word_l_diffs [where xa=x and x=x for x]
 lemmas word_l_diffs = word_l_diffs' [simplified]
 
 lemma is_aligned_diff:
   fixes m :: "'a::len word"
   assumes alm: "is_aligned m s1"
   and     aln: "is_aligned n s2"
   and    s2wb: "s2 < LENGTH('a)"
   and      nm: "m \<in> {n .. n + (2 ^ s2 - 1)}"
   and    s1s2: "s1 \<le> s2"
   and     s10: "0 < s1" (* Probably can be folded into the proof \<dots> *)
   shows  "\<exists>q. m - n = of_nat q * 2 ^ s1 \<and> q < 2 ^ (s2 - s1)"
 proof -
   have rl: "\<And>m s. \<lbrakk> m < 2 ^ (LENGTH('a) - s); s < LENGTH('a) \<rbrakk> \<Longrightarrow> unat ((2::'a word) ^ s * of_nat m) = 2 ^ s * m"
   proof -
     fix m :: nat and  s
     assume m: "m < 2 ^ (LENGTH('a) - s)" and s: "s < LENGTH('a)"
     then have "unat ((of_nat m) :: 'a word) = m"
       apply (subst unat_of_nat)
       apply (subst mod_less)
        apply (erule order_less_le_trans)
        apply (rule power_increasing)
         apply simp_all
       done
 
     then show "?thesis m s" using s m
       apply (subst iffD1 [OF unat_mult_lem])
       apply (simp add: nat_less_power_trans)+
       done
   qed
   have s1wb: "s1 < LENGTH('a)" using s2wb s1s2 by simp
   from alm obtain mq where mmq: "m = 2 ^ s1 * of_nat mq" and mq: "mq < 2 ^ (LENGTH('a) - s1)"
     by (auto elim: is_alignedE simp: field_simps)
   from aln obtain nq where nnq: "n = 2 ^ s2 * of_nat nq" and nq: "nq < 2 ^ (LENGTH('a) - s2)"
     by (auto elim: is_alignedE simp: field_simps)
   from s1s2 obtain sq where sq: "s2 = s1 + sq" by (auto simp: le_iff_add)
 
   note us1 = rl [OF mq s1wb]
   note us2 = rl [OF nq s2wb]
 
   from nm have "n \<le> m" by clarsimp
   then have "(2::'a word) ^ s2 * of_nat nq \<le> 2 ^ s1 * of_nat mq" using nnq mmq by simp
   then have "2 ^ s2 * nq \<le> 2 ^ s1 * mq" using s1wb s2wb
     by (simp add: word_le_nat_alt us1 us2)
   then have nqmq: "2 ^ sq * nq \<le> mq" using sq by (simp add: power_add)
 
   have "m - n = 2 ^ s1 * of_nat mq - 2 ^ s2 * of_nat nq" using mmq nnq by simp
   also have "\<dots> = 2 ^ s1 * of_nat mq - 2 ^ s1 * 2 ^ sq * of_nat nq" using sq by (simp add: power_add)
   also have "\<dots> = 2 ^ s1 * (of_nat mq - 2 ^ sq * of_nat nq)" by (simp add: field_simps)
   also have "\<dots> = 2 ^ s1 * of_nat (mq - 2 ^ sq * nq)" using s1wb s2wb us1 us2 nqmq
     by (simp add:  word_unat_power)
   finally have mn: "m - n = of_nat (mq - 2 ^ sq * nq) * 2 ^ s1" by simp
   moreover
   from nm have "m - n \<le> 2 ^ s2 - 1"
     by - (rule word_diff_ls', (simp add: field_simps)+)
   then have "(2::'a word) ^ s1 * of_nat (mq - 2 ^ sq * nq) < 2 ^ s2" using mn s2wb by (simp add: field_simps)
   then have "of_nat (mq - 2 ^ sq * nq) < (2::'a word) ^ (s2 - s1)"
   proof (rule word_power_less_diff)
     have mm: "mq - 2 ^ sq * nq < 2 ^ (LENGTH('a) - s1)" using mq by simp
     moreover from s10 have "LENGTH('a) - s1 < LENGTH('a)"
       by (rule diff_less, simp)
     ultimately show "of_nat (mq - 2 ^ sq * nq) < (2::'a word) ^ (LENGTH('a) - s1)"
       apply (simp add: word_less_nat_alt)
       apply (subst unat_of_nat)
       apply (subst mod_less)
        apply (erule order_less_le_trans)
        apply simp+
       done
   qed
   then have "mq - 2 ^ sq * nq < 2 ^ (s2 - s1)" using mq s2wb
     apply (simp add: word_less_nat_alt)
     apply (subst (asm) unat_of_nat)
     apply (subst (asm) mod_less)
     apply (rule order_le_less_trans)
     apply (rule diff_le_self)
     apply (erule order_less_le_trans)
     apply simp
     apply assumption
     done
   ultimately show ?thesis by auto
 qed
 
 lemma word_less_sub_1:
   "x < (y :: 'a :: len word) \<Longrightarrow> x \<le> y - 1"
   apply (erule udvd_minus_le')
    apply (simp add: udvd_def)+
   done
 
 lemma word_sub_mono2:
   "\<lbrakk> a + b \<le> c + d; c \<le> a; b \<le> a + b; d \<le> c + d \<rbrakk>
     \<Longrightarrow> b \<le> (d :: 'a :: len word)"
   apply (drule(1) word_sub_mono)
     apply simp
    apply simp
   apply simp
   done
 
 lemma word_not_le:
   "(\<not> x \<le> (y :: 'a :: len word)) = (y < x)"
   by fastforce
 
 lemma word_subset_less:
   "\<lbrakk> {x .. x + r - 1} \<subseteq> {y .. y + s - 1};
      x \<le> x + r - 1; y \<le> y + (s :: 'a :: len word) - 1;
      s \<noteq> 0 \<rbrakk>
      \<Longrightarrow> r \<le> s"
   apply (frule subsetD[where c=x])
    apply simp
   apply (drule subsetD[where c="x + r - 1"])
    apply simp
   apply (clarsimp simp: add_diff_eq[symmetric])
   apply (drule(1) word_sub_mono2)
     apply (simp_all add: olen_add_eqv[symmetric])
   apply (erule word_le_minus_cancel)
   apply (rule ccontr)
   apply (simp add: word_not_le)
   done
 
 lemma uint_power_lower:
   "n < LENGTH('a) \<Longrightarrow> uint (2 ^ n :: 'a :: len word) = (2 ^ n :: int)"
   by (rule uint_2p_alt)
 
 lemma power_le_mono:
   "\<lbrakk>2 ^ n \<le> (2::'a::len word) ^ m; n < LENGTH('a); m < LENGTH('a)\<rbrakk>
    \<Longrightarrow> n \<le> m"
   apply (clarsimp simp add: le_less)
   apply safe
   apply (simp add: word_less_nat_alt)
   apply (simp only: uint_arith_simps(3))
   apply (drule uint_power_lower)+
   apply simp
   done
 
 lemma sublist_equal_part:
   "prefix xs ys \<Longrightarrow> take (length xs) ys = xs"
   by (clarsimp simp: prefix_def)
 
 lemma two_power_eq:
   "\<lbrakk>n < LENGTH('a); m < LENGTH('a)\<rbrakk>
    \<Longrightarrow> ((2::'a::len word) ^ n = 2 ^ m) = (n = m)"
   apply safe
   apply (rule order_antisym)
    apply (simp add: power_le_mono[where 'a='a])+
   done
 
 lemma prefix_length_less:
   "strict_prefix xs ys \<Longrightarrow> length xs < length ys"
   apply (clarsimp simp: strict_prefix_def)
   apply (frule prefix_length_le)
   apply (rule ccontr, simp)
   apply (clarsimp simp: prefix_def)
   done
 
 lemmas take_less = take_strict_prefix
 
 lemma not_prefix_longer:
   "\<lbrakk> length xs > length ys \<rbrakk> \<Longrightarrow> \<not> prefix xs ys"
   by (clarsimp dest!: prefix_length_le)
 
 lemma of_bl_length:
   "length xs < LENGTH('a) \<Longrightarrow> of_bl xs < (2 :: 'a::len word) ^ length xs"
   by (simp add: of_bl_length_less)
 
 lemma unat_of_nat_eq:
   "x < 2 ^ LENGTH('a) \<Longrightarrow> unat (of_nat x ::'a::len word) = x"
   by (rule unat_of_nat_len)
 
 lemma unat_eq_of_nat:
   "n < 2 ^ LENGTH('a) \<Longrightarrow> (unat (x :: 'a::len word) = n) = (x = of_nat n)"
   by (subst unat_of_nat_eq[where x=n, symmetric], simp+)
 
 lemma unat_less_helper:
   "x < of_nat n \<Longrightarrow> unat x < n"
   apply (simp add: word_less_nat_alt)
   apply (erule order_less_le_trans)
   apply (simp add: unat_of_nat)
   done
 
 lemma of_nat_0:
   "\<lbrakk>of_nat n = (0::('a::len) word); n < 2 ^ len_of (TYPE('a))\<rbrakk> \<Longrightarrow> n = 0"
   by (drule unat_of_nat_eq, simp)
 
 lemma minus_one_helper3:
   "x < y \<Longrightarrow> x \<le> (y :: 'a :: len word) - 1"
   apply (simp add: word_less_nat_alt word_le_nat_alt)
   apply (subst unat_minus_one)
    apply clarsimp
   apply arith
   done
 
 lemma minus_one_helper:
   "\<lbrakk> x \<le> y; x \<noteq> 0 \<rbrakk> \<Longrightarrow> x - 1 < (y :: 'a :: len word)"
   apply (simp add: word_less_nat_alt word_le_nat_alt)
   apply (subst unat_minus_one)
    apply assumption
   apply (cases "unat x")
    apply (simp add: unat_eq_zero)
   apply arith
   done
 
 lemma minus_one_helper5:
   fixes x :: "'a::len word"
   shows "\<lbrakk>y \<noteq> 0; x \<le> y - 1 \<rbrakk> \<Longrightarrow> x < y"
   using le_m1_iff_lt word_neq_0_conv by blast
 
 lemma not_greatest_aligned:
   "\<lbrakk> x < y; is_aligned x n; is_aligned y n \<rbrakk>
       \<Longrightarrow> x + 2 ^ n \<noteq> 0"
   apply (rule notI)
   apply (erule is_aligned_get_word_bits[where p=y])
    apply (simp add: eq_diff_eq[symmetric])
    apply (frule minus_one_helper3)
    apply (drule le_minus'[where a="x" and c="y - x" and b="- 1" for x y, simplified])
    apply (simp add: field_simps)
    apply (frule is_aligned_less_sz[where a=y])
      apply clarsimp
    apply (erule notE)
    apply (rule minus_one_helper5)
     apply simp
    apply (metis is_aligned_no_overflow minus_one_helper3 order_le_less_trans)
   apply simp
   done
 
 lemma of_nat_inj:
   "\<lbrakk>x < 2 ^ LENGTH('a); y < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow>
    (of_nat x = (of_nat y :: 'a :: len word)) = (x = y)"
   by (simp add: word_unat.norm_eq_iff [symmetric])
 
 lemma map_prefixI:
   "prefix xs ys \<Longrightarrow> prefix (map f xs) (map f ys)"
   by (clarsimp simp: prefix_def)
 
 lemma if_Some_None_eq_None:
   "((if P then Some v else None) = None) = (\<not> P)"
   by simp
 
 lemma CollectPairFalse [iff]:
   "{(a,b). False} = {}"
   by (simp add: split_def)
 
 lemma if_conj_dist:
   "((if b then w else x) \<and> (if b then y else z) \<and> X) =
   ((if b then w \<and> y else x \<and> z) \<and> X)"
   by simp
 
 lemma if_P_True1:
   "Q \<Longrightarrow> (if P then True else Q)"
   by simp
 
 lemma if_P_True2:
   "Q \<Longrightarrow> (if P then Q else True)"
   by simp
 
 lemma list_all2_induct [consumes 1, case_names Nil Cons]:
   assumes lall: "list_all2 Q xs ys"
   and     nilr: "P [] []"
   and    consr: "\<And>x xs y ys. \<lbrakk>list_all2 Q xs ys; Q x y; P xs ys\<rbrakk> \<Longrightarrow> P (x # xs) (y # ys)"
   shows  "P xs ys"
   using lall
 proof (induct rule: list_induct2 [OF list_all2_lengthD [OF lall]])
   case 1 then show ?case by auto fact+
 next
   case (2 x xs y ys)
 
   show ?case
   proof (rule consr)
     from "2.prems" show "list_all2 Q xs ys" and "Q x y" by simp_all
     then show "P xs ys" by (intro "2.hyps")
   qed
 qed
 
 lemma list_all2_induct_suffixeq [consumes 1, case_names Nil Cons]:
   assumes lall: "list_all2 Q as bs"
   and     nilr: "P [] []"
   and    consr: "\<And>x xs y ys.
   \<lbrakk>list_all2 Q xs ys; Q x y; P xs ys; suffix (x # xs) as; suffix (y # ys) bs\<rbrakk>
   \<Longrightarrow> P (x # xs) (y # ys)"
   shows  "P as bs"
 proof -
   define as' where "as' == as"
   define bs' where "bs' == bs"
 
   have "suffix as as' \<and> suffix bs bs'" unfolding as'_def bs'_def by simp
   then show ?thesis using lall
   proof (induct rule: list_induct2 [OF list_all2_lengthD [OF lall]])
     case 1 show ?case by fact
   next
     case (2 x xs y ys)
 
     show ?case
     proof (rule consr)
       from "2.prems" show "list_all2 Q xs ys" and "Q x y" by simp_all
       then show "P xs ys" using "2.hyps" "2.prems" by (auto dest: suffix_ConsD)
       from "2.prems" show "suffix (x # xs) as" and "suffix (y # ys) bs"
       by (auto simp: as'_def bs'_def)
     qed
   qed
 qed
 
 lemma upto_enum_step_shift:
   "\<lbrakk> is_aligned p n \<rbrakk> \<Longrightarrow>
   ([p , p + 2 ^ m .e. p + 2 ^ n - 1])
       = map ((+) p) [0, 2 ^ m .e. 2 ^ n - 1]"
   apply (erule is_aligned_get_word_bits)
    prefer 2
    apply (simp add: map_idI)
   apply (clarsimp simp: upto_enum_step_def)
   apply (frule is_aligned_no_overflow)
   apply (simp add: linorder_not_le [symmetric])
   done
 
 lemma upto_enum_step_shift_red:
   "\<lbrakk> is_aligned p sz; sz < len_of (TYPE('a)); us \<le> sz \<rbrakk>
      \<Longrightarrow> [p :: 'a :: len word, p + 2 ^ us .e. p + 2 ^ sz - 1]
           = map (\<lambda>x. p + of_nat x * 2 ^ us) [0 ..< 2 ^ (sz - us)]"
   apply (subst upto_enum_step_shift, assumption)
   apply (simp add: upto_enum_step_red)
   done
 
 lemma div_to_mult_word_lt:
   "\<lbrakk> (x :: 'a :: len word) \<le> y div z \<rbrakk> \<Longrightarrow> x * z \<le> y"
   apply (cases "z = 0")
    apply simp
   apply (simp add: word_neq_0_conv)
   apply (rule order_trans)
    apply (erule(1) word_mult_le_mono1)
    apply (simp add: unat_div)
    apply (rule order_le_less_trans [OF div_mult_le])
    apply simp
   apply (rule word_div_mult_le)
   done
 
 lemma upto_enum_step_subset:
   "set [x, y .e. z] \<subseteq> {x .. z}"
   apply (clarsimp simp: upto_enum_step_def linorder_not_less)
   apply (drule div_to_mult_word_lt)
   apply (rule conjI)
    apply (erule word_random[rotated])
    apply simp
   apply (rule order_trans)
    apply (erule word_plus_mono_right)
    apply simp
   apply simp
   done
 
 lemma shiftr_less_t2n':
   fixes x :: "'a :: len word"
   shows "\<lbrakk> x && mask (n + m) = x; m < LENGTH('a) \<rbrakk>
               \<Longrightarrow> (x >> n) < 2 ^ m"
   apply (subst mask_eq_iff_w2p[symmetric])
    apply (simp add: word_size)
   apply (rule word_eqI)
   apply (drule_tac x="na + n" in word_eqD)
   apply (simp add: nth_shiftr word_size)
   apply safe
   done
 
 lemma shiftr_less_t2n:
   fixes x :: "'a :: len word"
   shows "x < 2 ^ (n + m) \<Longrightarrow> (x >> n) < 2 ^ m"
   apply (rule shiftr_less_t2n')
    apply (erule less_mask_eq)
   apply (rule ccontr)
   apply (simp add: not_less)
   apply (subst (asm) p2_eq_0[symmetric])
   apply (simp add: power_add)
   done
 
 lemma shiftr_eq_0:
   "n \<ge> LENGTH('a) \<Longrightarrow> ((w::'a::len word) >> n) = 0"
   apply (cut_tac shiftr_less_t2n'[of w n 0], simp)
    apply (simp add: mask_eq_iff)
   apply (simp add: lt2p_lem)
   apply simp
   done
 
 lemma shiftr_not_mask_0:
   "n+m \<ge> LENGTH('a :: len) \<Longrightarrow> ((w::'a::len word) >> n) && ~~ mask m = 0"
   apply (simp add: and_not_mask shiftr_less_t2n shiftr_shiftr)
   apply (subgoal_tac "w >> n + m = 0", simp)
   apply (simp add: le_mask_iff[symmetric] mask_def le_def)
   apply (subst (asm) p2_gt_0[symmetric])
   apply (simp add: power_add not_less)
   done
 
 lemma shiftl_less_t2n:
   fixes x :: "'a :: len word"
   shows "\<lbrakk> x < (2 ^ (m - n)); m < LENGTH('a) \<rbrakk> \<Longrightarrow> (x << n) < 2 ^ m"
   apply (subst mask_eq_iff_w2p[symmetric])
    apply (simp add: word_size)
   apply (drule less_mask_eq)
   apply (rule word_eqI)
   apply (drule_tac x="na - n" in word_eqD)
   apply (simp add: nth_shiftl word_size)
   apply (cases "n \<le> m")
    apply safe
    apply simp
   apply simp
   done
 
 lemma shiftl_less_t2n':
   "(x::'a::len word) < 2 ^ m \<Longrightarrow> m+n < LENGTH('a) \<Longrightarrow> x << n < 2 ^ (m + n)"
   by (rule shiftl_less_t2n) simp_all
 
 lemma ucast_ucast_mask:
   "(ucast :: 'a :: len word \<Rightarrow> 'b :: len word) (ucast x) = x && mask (len_of TYPE ('a))"
   apply (rule word_eqI)
   apply (simp add: nth_ucast word_size)
   done
 
 lemma ucast_ucast_len:
   "\<lbrakk> x < 2 ^ LENGTH('b) \<rbrakk> \<Longrightarrow> ucast (ucast x::'b::len word) = (x::'a::len word)"
   apply (subst ucast_ucast_mask)
   apply (erule less_mask_eq)
   done
 
 lemma unat_ucast:
   "unat (ucast x :: ('a :: len0) word) = unat x mod 2 ^ (LENGTH('a))"
   apply (simp add: unat_def ucast_def)
   apply (subst word_uint.eq_norm)
   apply (subst nat_mod_distrib)
     apply simp
    apply simp
   apply (subst nat_power_eq)
    apply simp
   apply simp
   done
 
 lemma ucast_less_ucast:
   "LENGTH('a) < LENGTH('b) \<Longrightarrow>
    (ucast x < ((ucast (y :: 'a::len word)) :: 'b::len word)) = (x < y)"
   apply (simp add: word_less_nat_alt unat_ucast)
   apply (subst mod_less)
    apply(rule less_le_trans[OF unat_lt2p], simp)
   apply (subst mod_less)
    apply(rule less_le_trans[OF unat_lt2p], simp)
   apply simp
   done
 
 lemma sints_subset:
   "m \<le> n \<Longrightarrow> sints m \<subseteq> sints n"
   apply (simp add: sints_num)
   apply clarsimp
   apply (rule conjI)
    apply (erule order_trans[rotated])
    apply simp
   apply (erule order_less_le_trans)
   apply simp
   done
 
 lemma up_scast_inj:
       "\<lbrakk> scast x = (scast y :: 'b :: len word); size x \<le> LENGTH('b) \<rbrakk>
          \<Longrightarrow> x = y"
   apply (simp add: scast_def)
   apply (subst(asm) word_sint.Abs_inject)
     apply (erule subsetD [OF sints_subset])
     apply (simp add: word_size)
    apply (erule subsetD [OF sints_subset])
    apply (simp add: word_size)
   apply simp
   done
 
 lemma up_scast_inj_eq:
   "LENGTH('a) \<le> len_of TYPE ('b) \<Longrightarrow>
   (scast x = (scast y::'b::len word)) = (x = (y::'a::len word))"
   by (fastforce dest: up_scast_inj simp: word_size)
 
 lemma nth_bounded:
   "\<lbrakk>(x :: 'a :: len word) !! n; x < 2 ^ m; m \<le> len_of TYPE ('a)\<rbrakk> \<Longrightarrow> n < m"
   apply (frule test_bit_size)
   apply (clarsimp simp: test_bit_bl word_size)
   apply (simp add: nth_rev)
   apply (subst(asm) is_aligned_add_conv[OF is_aligned_0',
                                         simplified add_0_left, rotated])
    apply assumption+
   apply (simp only: to_bl_0)
   apply (simp add: nth_append split: if_split_asm)
   done
 
 lemma is_aligned_add_or:
   "\<lbrakk>is_aligned p n; d < 2 ^ n\<rbrakk> \<Longrightarrow> p + d = p || d"
   apply (rule word_plus_and_or_coroll)
   apply (erule is_aligned_get_word_bits)
    apply (rule word_eqI)
    apply (clarsimp simp add: is_aligned_nth)
    apply (frule(1) nth_bounded)
     apply simp+
   done
 
 lemma two_power_increasing:
   "\<lbrakk> n \<le> m; m < LENGTH('a) \<rbrakk> \<Longrightarrow> (2 :: 'a :: len word) ^ n \<le> 2 ^ m"
   by (simp add: word_le_nat_alt)
 
 lemma is_aligned_add_less_t2n:
   "\<lbrakk>is_aligned (p::'a::len word) n; d < 2^n; n \<le> m; p < 2^m\<rbrakk> \<Longrightarrow> p + d < 2^m"
   apply (case_tac "m < LENGTH('a)")
    apply (subst mask_eq_iff_w2p[symmetric])
     apply (simp add: word_size)
    apply (simp add: is_aligned_add_or word_ao_dist less_mask_eq)
    apply (subst less_mask_eq)
     apply (erule order_less_le_trans)
     apply (erule(1) two_power_increasing)
    apply simp
   apply (simp add: power_overflow)
   done
 
 
 lemma aligned_offset_non_zero:
   "\<lbrakk> is_aligned x n; y < 2 ^ n; x \<noteq> 0 \<rbrakk> \<Longrightarrow> x + y \<noteq> 0"
   apply (cases "y = 0")
    apply simp
   apply (subst word_neq_0_conv)
   apply (subst gt0_iff_gem1)
   apply (erule is_aligned_get_word_bits)
    apply (subst field_simps[symmetric], subst plus_le_left_cancel_nowrap)
      apply (rule is_aligned_no_wrap')
       apply simp
      apply (rule minus_one_helper)
       apply simp
      apply assumption
     apply (erule (1) is_aligned_no_wrap')
    apply (simp add: gt0_iff_gem1 [symmetric] word_neq_0_conv)
   apply simp
   done
 
 lemmas mask_inner_mask = mask_eqs(1)
 
 lemma mask_add_aligned:
   "is_aligned p n \<Longrightarrow> (p + q) && mask n = q && mask n"
   apply (simp add: is_aligned_mask)
   apply (subst mask_inner_mask [symmetric])
   apply simp
   done
 
 lemma take_prefix:
   "(take (length xs) ys = xs) = prefix xs ys"
 proof (induct xs arbitrary: ys)
   case Nil then show ?case by simp
 next
   case Cons then show ?case by (cases ys) auto
 qed
 
 lemma cart_singleton_empty:
   "(S \<times> {e} = {}) = (S = {})"
   by blast
 
 lemma word_div_1:
   "(n :: 'a :: len word) div 1 = n"
   by (simp add: word_div_def)
 
 lemma word_minus_one_le:
   "-1 \<le> (x :: 'a :: len word) = (x = -1)"
   apply (insert word_n1_ge[where y=x])
   apply safe
   apply (erule(1) order_antisym)
   done
 
 lemma mask_out_sub_mask:
   "(x && ~~ mask n) = x - (x && mask n)"
   by (simp add: field_simps word_plus_and_or_coroll2)
 
 lemma is_aligned_addD1:
   assumes al1: "is_aligned (x + y) n"
   and     al2: "is_aligned (x::'a::len word) n"
   shows "is_aligned y n"
   using al2
 proof (rule is_aligned_get_word_bits)
   assume "x = 0" then show ?thesis using al1 by simp
 next
   assume nv: "n < LENGTH('a)"
   from al1 obtain q1
     where xy: "x + y = 2 ^ n * of_nat q1" and "q1 < 2 ^ (LENGTH('a) - n)"
     by (rule is_alignedE)
   moreover from al2 obtain q2
     where x: "x = 2 ^ n * of_nat q2" and "q2 < 2 ^ (LENGTH('a) - n)"
     by (rule is_alignedE)
   ultimately have "y = 2 ^ n * (of_nat q1 - of_nat q2)"
     by (simp add: field_simps)
   then show ?thesis using nv by (simp add: is_aligned_mult_triv1)
 qed
 
 lemmas is_aligned_addD2 =
        is_aligned_addD1[OF subst[OF add.commute,
                                  of "%x. is_aligned x n" for n]]
 
 lemma is_aligned_add:
   "\<lbrakk>is_aligned p n; is_aligned q n\<rbrakk> \<Longrightarrow> is_aligned (p + q) n"
   by (simp add: is_aligned_mask mask_add_aligned)
 
 lemma word_le_add:
   fixes x :: "'a :: len word"
   shows "x \<le> y \<Longrightarrow> \<exists>n. y = x + of_nat n"
   by (rule exI [where x = "unat (y - x)"]) simp
 
 lemma word_plus_mcs_4':
   fixes x :: "'a :: len word"
   shows "\<lbrakk>x + v \<le> x + w; x \<le> x + v\<rbrakk> \<Longrightarrow> v \<le> w"
   apply (rule word_plus_mcs_4)
    apply (simp add: add.commute)
   apply (simp add: add.commute)
   done
 
 lemma shiftl_mask_is_0[simp]:
   "(x << n) && mask n = 0"
   apply (rule iffD1 [OF is_aligned_mask])
   apply (rule is_aligned_shiftl_self)
   done
 
 definition
   sum_map :: "('a \<Rightarrow> 'b) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> 'a + 'c \<Rightarrow> 'b + 'd" where
  "sum_map f g x \<equiv> case x of Inl v \<Rightarrow> Inl (f v) | Inr v' \<Rightarrow> Inr (g v')"
 
 lemma sum_map_simps[simp]:
   "sum_map f g (Inl v) = Inl (f v)"
   "sum_map f g (Inr w) = Inr (g w)"
   by (simp add: sum_map_def)+
 
 lemma if_and_helper:
   "(If x v v') && v'' = If x (v && v'') (v' && v'')"
   by (rule if_distrib)
 
 lemma unat_Suc2:
   fixes n :: "'a :: len word"
   shows
   "n \<noteq> -1 \<Longrightarrow> unat (n + 1) = Suc (unat n)"
   apply (subst add.commute, rule unatSuc)
   apply (subst eq_diff_eq[symmetric], simp add: minus_equation_iff)
   done
 
 lemmas word_unat_Rep_inject1 = word_unat.Rep_inject[where y=1]
 lemmas unat_eq_1 = unat_eq_0 word_unat_Rep_inject1[simplified]
 
 
 lemma rshift_sub_mask_eq:
   "(a >> (size a - b)) && mask b = a >> (size a - b)"
   using shiftl_shiftr2[where a=a and b=0 and c="size a - b"]
   apply (cases "b < size a")
    apply simp
   apply (simp add: linorder_not_less mask_def word_size
                    p2_eq_0[THEN iffD2])
   done
 
 lemma shiftl_shiftr3:
   "b \<le> c \<Longrightarrow> a << b >> c = (a >> c - b) && mask (size a - c)"
   apply (cases "b = c")
    apply (simp add: shiftl_shiftr1)
   apply (simp add: shiftl_shiftr2)
   done
 
 lemma and_mask_shiftr_comm:
   "m\<le>size w \<Longrightarrow> (w && mask m) >> n = (w >> n) && mask (m-n)"
   by (simp add: and_mask shiftr_shiftr) (simp add: word_size shiftl_shiftr3)
 
 lemma and_mask_shiftl_comm:
   "m+n \<le> size w \<Longrightarrow> (w && mask m) << n = (w << n) && mask (m+n)"
   by (simp add: and_mask word_size shiftl_shiftl) (simp add: shiftl_shiftr1)
 
 lemma le_mask_shiftl_le_mask: "s = m + n \<Longrightarrow> x \<le> mask n \<Longrightarrow> x << m \<le> mask s"
   by (simp add: le_mask_iff shiftl_shiftr3)
 
 lemma and_not_mask_twice:
   "(w && ~~ mask n) && ~~ mask m = w && ~~ mask (max m n)"
   apply (simp add: and_not_mask)
   apply (case_tac "n<m";
          simp add: shiftl_shiftr2 shiftl_shiftr1 not_less max_def shiftr_shiftr shiftl_shiftl)
    apply (cut_tac and_mask_shiftr_comm [where w=w and m="size w" and n=m, simplified,symmetric])
    apply (simp add: word_size mask_def)
   apply (cut_tac and_mask_shiftr_comm [where w=w and m="size w" and n=n, simplified,symmetric])
   apply (simp add: word_size mask_def)
   done
 
 lemma word_less_cases:
   "x < y \<Longrightarrow> x = y - 1 \<or> x < y - (1 ::'a::len word)"
   apply (drule word_less_sub_1)
   apply (drule order_le_imp_less_or_eq)
   apply auto
   done
 
 lemma eq_eqI:
   "a = b \<Longrightarrow> (a = x) = (b = x)"
   by simp
 
 lemma mask_and_mask:
   "mask a && mask b = mask (min a b)"
   by (rule word_eqI) (simp add: word_size)
 
 lemma mask_eq_0_eq_x:
   "(x && w = 0) = (x && ~~ w = x)"
   using word_plus_and_or_coroll2[where x=x and w=w]
   by auto
 
 lemma mask_eq_x_eq_0:
   "(x && w = x) = (x && ~~ w = 0)"
   using word_plus_and_or_coroll2[where x=x and w=w]
   by auto
 
 definition
   "limited_and (x :: 'a :: len word) y = (x && y = x)"
 
 lemma limited_and_eq_0:
   "\<lbrakk> limited_and x z; y && ~~ z = y \<rbrakk> \<Longrightarrow> x && y = 0"
   unfolding limited_and_def
   apply (subst arg_cong2[where f="(&&)"])
     apply (erule sym)+
   apply (simp(no_asm) add: word_bw_assocs word_bw_comms word_bw_lcs)
   done
 
 lemma limited_and_eq_id:
   "\<lbrakk> limited_and x z; y && z = z \<rbrakk> \<Longrightarrow> x && y = x"
   unfolding limited_and_def
   by (erule subst, fastforce simp: word_bw_lcs word_bw_assocs word_bw_comms)
 
 lemma lshift_limited_and:
   "limited_and x z \<Longrightarrow> limited_and (x << n) (z << n)"
   unfolding limited_and_def
   by (simp add: shiftl_over_and_dist[symmetric])
 
 lemma rshift_limited_and:
   "limited_and x z \<Longrightarrow> limited_and (x >> n) (z >> n)"
   unfolding limited_and_def
   by (simp add: shiftr_over_and_dist[symmetric])
 
 lemmas limited_and_simps1 = limited_and_eq_0 limited_and_eq_id
 
 lemmas is_aligned_limited_and
     = is_aligned_neg_mask_eq[unfolded mask_def, folded limited_and_def]
 
 lemma compl_of_1: "~~ 1 = (-2 :: 'a :: len word)"
   by simp
 
 lemmas limited_and_simps = limited_and_simps1
        limited_and_simps1[OF is_aligned_limited_and]
        limited_and_simps1[OF lshift_limited_and]
        limited_and_simps1[OF rshift_limited_and]
        limited_and_simps1[OF rshift_limited_and, OF is_aligned_limited_and]
        compl_of_1 shiftl_shiftr1[unfolded word_size mask_def]
        shiftl_shiftr2[unfolded word_size mask_def]
 
 lemma split_word_eq_on_mask:
   "(x = y) = (x && m = y && m \<and> x && ~~ m = y && ~~ m)"
   apply safe
   apply (rule word_eqI)
   apply (drule_tac x=n in word_eqD)+
   by (auto simp: word_size word_ops_nth_size)
 
 lemma map2_Cons_2_3:
   "(map2 f xs (y # ys) = (z # zs)) = (\<exists>x xs'. xs = x # xs' \<and> f x y = z \<and> map2 f xs' ys = zs)"
   by (case_tac xs, simp_all)
 
 lemma map2_xor_replicate_False:
   "map2 (\<lambda>x y. x \<longleftrightarrow> \<not> y) xs (replicate n False) = take n xs"
   apply (induct xs arbitrary: n)
    apply simp
   apply (case_tac n)
    apply simp_all
   done
 
 lemma word_or_zero:
   "(a || b = 0) = (a = 0 \<and> b = 0)"
   apply (safe, simp_all)
    apply (rule word_eqI, drule_tac x=n in word_eqD, simp)+
   done
 
 lemma word_and_1_shiftl:
   fixes x :: "'a :: len word" shows
   "x && (1 << n) = (if x !! n then (1 << n) else 0)"
   apply (rule word_eqI)
   apply (simp add: word_size nth_shiftl del: shiftl_1)
   apply auto
   done
 
 lemmas word_and_1_shiftls'
     = word_and_1_shiftl[where n=0]
       word_and_1_shiftl[where n=1]
       word_and_1_shiftl[where n=2]
 
 lemmas word_and_1_shiftls = word_and_1_shiftls' [simplified]
 
 lemma word_and_mask_shiftl:
   "x && (mask n << m) = ((x >> m) && mask n) << m"
   apply (rule word_eqI)
   apply (simp add: word_size nth_shiftl nth_shiftr)
   apply auto
   done
 
 lemma plus_Collect_helper:
   "(+) x ` {xa. P (xa :: 'a :: len word)} = {xa. P (xa - x)}"
   by (fastforce simp add: image_def)
 
 lemma plus_Collect_helper2:
   "(+) (- x) ` {xa. P (xa :: 'a :: len word)} = {xa. P (x + xa)}"
   using plus_Collect_helper [of "- x" P] by (simp add: ac_simps)
 
 lemma word_FF_is_mask:
   "0xFF = mask 8"
   by (simp add: mask_def)
 
 lemma word_1FF_is_mask:
   "0x1FF = mask 9"
   by (simp add: mask_def)
 
 lemma ucast_of_nat_small:
   "x < 2 ^ LENGTH('a) \<Longrightarrow> ucast (of_nat x :: 'a :: len word) = (of_nat x :: 'b :: len word)"
   apply (rule sym, subst word_unat.inverse_norm)
   apply (simp add: ucast_def word_of_int[symmetric]
                    of_nat_nat[symmetric] unat_def[symmetric])
   apply (simp add: unat_of_nat)
   done
 
 lemma word_le_make_less:
   fixes x :: "'a :: len word"
   shows "y \<noteq> -1 \<Longrightarrow> (x \<le> y) = (x < (y + 1))"
   apply safe
   apply (erule plus_one_helper2)
   apply (simp add: eq_diff_eq[symmetric])
   done
 
 lemmas finite_word = finite [where 'a="'a::len word"]
 
 lemma word_to_1_set:
   "{0 ..< (1 :: 'a :: len word)} = {0}"
   by fastforce
 
 lemma range_subset_eq2:
   "{a :: 'a :: len word .. b} \<noteq> {} \<Longrightarrow> ({a .. b} \<subseteq> {c .. d}) = (c \<le> a \<and> b \<le> d)"
   by simp
 
 lemma word_count_from_top:
   "n \<noteq> 0 \<Longrightarrow> {0 ..< n :: 'a :: len word} = {0 ..< n - 1} \<union> {n - 1}"
   apply (rule set_eqI, rule iffI)
    apply simp
    apply (drule minus_one_helper3)
    apply (rule disjCI)
    apply simp
   apply simp
   apply (erule minus_one_helper5)
   apply fastforce
   done
 
 lemma minus_one_helper2:
   "\<lbrakk> x - 1 < y \<rbrakk> \<Longrightarrow> x \<le> (y :: 'a :: len word)"
   apply (cases "x = 0")
    apply simp
   apply (simp add: word_less_nat_alt word_le_nat_alt)
   apply (subst(asm) unat_minus_one)
    apply (simp add: word_less_nat_alt)
   apply (cases "unat x")
    apply (simp add: unat_eq_zero)
   apply arith
   done
 
 lemma mod_mod_power:
   fixes k :: nat
   shows "k mod 2 ^ m mod 2 ^ n = k mod 2 ^ (min m n)"
 proof (cases "m \<le> n")
   case True
 
   then have "k mod 2 ^ m mod 2 ^ n = k mod 2 ^ m"
     apply -
     apply (subst mod_less [where n = "2 ^ n"])
     apply (rule order_less_le_trans [OF mod_less_divisor])
     apply simp+
     done
   also have "\<dots> = k mod  2 ^ (min m n)" using True by simp
   finally show ?thesis .
 next
   case False
   then have "n < m" by simp
   then obtain d where md: "m = n + d"
     by (auto dest: less_imp_add_positive)
   then have "k mod 2 ^ m = 2 ^ n * (k div 2 ^ n mod 2 ^ d) + k mod 2 ^ n"
     by (simp add: mod_mult2_eq power_add)
   then have "k mod 2 ^ m mod 2 ^ n = k mod 2 ^ n"
     by (simp add: mod_add_left_eq)
   then show ?thesis using False
     by simp
 qed
 
 lemma word_div_less:
   fixes m :: "'a :: len word"
   shows "m < n \<Longrightarrow> m div n = 0"
   apply (rule word_unat.Rep_eqD)
   apply (simp add: word_less_nat_alt unat_div)
   done
 
 lemma word_must_wrap:
   "\<lbrakk> x \<le> n - 1; n \<le> x \<rbrakk> \<Longrightarrow> n = (0 :: 'a :: len word)"
   apply (rule ccontr)
   apply (drule(1) order_trans)
   apply (drule word_sub_1_le)
   apply (drule(1) order_antisym)
   apply simp
   done
 
 lemma range_subset_card:
   "\<lbrakk> {a :: 'a :: len word .. b} \<subseteq> {c .. d}; b \<ge> a \<rbrakk>
      \<Longrightarrow> d \<ge> c \<and> d - c \<ge> b - a"
   apply (subgoal_tac "a \<in> {a .. b}")
    apply (frule(1) range_subset_lower)
    apply (frule(1) range_subset_upper)
    apply (rule context_conjI, simp)
    apply (rule word_sub_mono, assumption+)
     apply (erule word_sub_le)
    apply (erule word_sub_le)
   apply simp
   done
 
 lemma less_1_simp:
   "n - 1 < m = (n \<le> (m :: 'a :: len word) \<and> n \<noteq> 0)"
   by unat_arith
 
 lemma alignUp_div_helper:
   fixes a :: "'a::len word"
   assumes kv: "k < 2 ^ (LENGTH('a) - n)"
   and     xk: "x = 2 ^ n * of_nat k"
   and    le: "a \<le> x"
   and    sz: "n < LENGTH('a)"
   and   anz: "a mod 2 ^ n \<noteq> 0"
   shows "a div 2 ^ n < of_nat k"
 proof -
   have kn: "unat (of_nat k :: 'a word) * unat ((2::'a word) ^ n)
             < 2 ^ LENGTH('a)"
     using xk kv sz
     apply (subst unat_of_nat_eq)
      apply (erule order_less_le_trans)
      apply simp
     apply (subst unat_power_lower, simp)
     apply (subst mult.commute)
     apply (rule nat_less_power_trans)
      apply simp
     apply simp
     done
 
   have "unat a div 2 ^ n * 2 ^ n \<noteq> unat a"
   proof -
     have "unat a = unat a div 2 ^ n * 2 ^ n + unat a mod 2 ^ n"
       by (simp add: div_mult_mod_eq)
     also have "\<dots> \<noteq> unat a div 2 ^ n * 2 ^ n" using sz anz
       by (simp add: unat_arith_simps)
     finally show ?thesis ..
   qed
 
   then have "a div 2 ^ n * 2 ^ n < a" using sz anz
     apply (subst word_less_nat_alt)
     apply (subst unat_word_ariths)
     apply (subst unat_div)
     apply simp
     apply (rule order_le_less_trans [OF mod_less_eq_dividend])
     apply (erule order_le_neq_trans [OF div_mult_le])
     done
 
   also from xk le have "\<dots> \<le> of_nat k * 2 ^ n" by (simp add: field_simps)
   finally show ?thesis using sz kv
     apply -
     apply (erule word_mult_less_dest [OF _ _ kn])
     apply (simp add: unat_div)
     apply (rule order_le_less_trans [OF div_mult_le])
     apply (rule unat_lt2p)
     done
 qed
 
 lemma nat_mod_power_lem:
   fixes a :: nat
   shows "1 < a \<Longrightarrow> a ^ n mod a ^ m = (if m \<le> n then 0 else a ^ n)"
   apply (clarsimp)
   apply (clarsimp simp add: le_iff_add power_add)
   done
 
 lemma power_mod_div:
   fixes x :: "nat"
   shows "x mod 2 ^ n div 2 ^ m = x div 2 ^ m mod 2 ^ (n - m)" (is "?LHS = ?RHS")
 proof (cases "n \<le> m")
   case True
   then have "?LHS = 0"
     apply -
     apply (rule div_less)
     apply (rule order_less_le_trans [OF mod_less_divisor])
      apply simp
     apply simp
     done
   also have "\<dots> = ?RHS" using True
     by simp
   finally show ?thesis .
 next
   case False
   then have lt: "m < n" by simp
   then obtain q where nv: "n = m + q" and "0 < q"
     by (auto dest: less_imp_Suc_add)
 
   then have "x mod 2 ^ n = 2 ^ m * (x div 2 ^ m mod 2 ^ q) + x mod 2 ^ m"
     by (simp add: power_add mod_mult2_eq)
 
   then have "?LHS = x div 2 ^ m mod 2 ^ q"
     by (simp add: div_add1_eq)
 
   also have "\<dots> = ?RHS" using nv
     by simp
 
   finally show ?thesis .
 qed
 
 lemma word_power_mod_div:
   fixes x :: "'a::len word"
   shows "\<lbrakk> n < LENGTH('a); m < LENGTH('a)\<rbrakk>
   \<Longrightarrow> x mod 2 ^ n div 2 ^ m = x div 2 ^ m mod 2 ^ (n - m)"
   apply (simp add: word_arith_nat_div unat_mod power_mod_div)
   apply (subst unat_arith_simps(3))
   apply (subst unat_mod)
   apply (subst unat_of_nat)+
   apply (simp add: mod_mod_power min.commute)
   done
 
 lemma word_range_minus_1':
   fixes a :: "'a :: len word"
   shows "a \<noteq> 0 \<Longrightarrow> {a - 1<..b} = {a..b}"
   by (simp add: greaterThanAtMost_def atLeastAtMost_def greaterThan_def atLeast_def less_1_simp)
 
 lemma word_range_minus_1:
   fixes a :: "'a :: len word"
   shows "b \<noteq> 0 \<Longrightarrow> {a..b - 1} = {a..<b}"
   apply (simp add: atLeastLessThan_def atLeastAtMost_def atMost_def lessThan_def)
   apply (rule arg_cong [where f = "\<lambda>x. {a..} \<inter> x"])
   apply rule
    apply clarsimp
    apply (erule contrapos_pp)
    apply (simp add: linorder_not_less linorder_not_le word_must_wrap)
   apply (clarsimp)
   apply (drule minus_one_helper3)
   apply (auto simp: word_less_sub_1)
   done
 
 lemma ucast_nat_def:
   "of_nat (unat x) = (ucast :: 'a :: len word \<Rightarrow> 'b :: len word) x"
   by (simp add: ucast_def word_of_int_nat unat_def)
 
 lemmas if_fun_split = if_apply_def2
 
 lemma i_hate_words_helper:
   "i \<le> (j - k :: nat) \<Longrightarrow> i \<le> j"
   by simp
 
 lemma i_hate_words:
   "unat (a :: 'a word) \<le> unat (b :: 'a :: len word) - Suc 0
     \<Longrightarrow> a \<noteq> -1"
   apply (frule i_hate_words_helper)
   apply (subst(asm) word_le_nat_alt[symmetric])
   apply (clarsimp simp only: word_minus_one_le)
   apply (simp only: linorder_not_less[symmetric])
   apply (erule notE)
   apply (rule diff_Suc_less)
   apply (subst neq0_conv[symmetric])
   apply (subst unat_eq_0)
   apply (rule notI, drule arg_cong[where f="(+) 1"])
   apply simp
   done
 
 lemma overflow_plus_one_self:
   "(1 + p \<le> p) = (p = (-1 :: 'a :: len word))"
   apply (safe, simp_all)
   apply (rule ccontr)
   apply (drule plus_one_helper2)
    apply (rule notI)
    apply (drule arg_cong[where f="\<lambda>x. x - 1"])
    apply simp
   apply (simp add: field_simps)
   done
 
 lemma plus_1_less:
   "(x + 1 \<le> (x :: 'a :: len word)) = (x = -1)"
   apply (rule iffI)
    apply (rule ccontr)
    apply (cut_tac plus_one_helper2[where x=x, OF order_refl])
     apply simp
    apply clarsimp
    apply (drule arg_cong[where f="\<lambda>x. x - 1"])
    apply simp
   apply simp
   done
 
 lemma pos_mult_pos_ge:
   "[|x > (0::int); n>=0 |] ==> n * x >= n*1"
   apply (simp only: mult_left_mono)
   done
 
 lemma If_eq_obvious:
   "x \<noteq> z \<Longrightarrow> ((if P then x else y) = z) = (\<not> P \<and> y = z)"
   by simp
 
 lemma Some_to_the:
   "v = Some x \<Longrightarrow> x = the v"
   by simp
 
 lemma dom_if_Some:
   "dom (\<lambda>x. if P x then Some (f x) else g x) = {x. P x} \<union> dom g"
   by fastforce
 
 lemma dom_insert_absorb:
   "x \<in> dom f \<Longrightarrow> insert x (dom f) = dom f" by auto
 
 lemma emptyE2:
   "\<lbrakk> S = {}; x \<in> S \<rbrakk> \<Longrightarrow> P"
   by simp
 
 lemma mod_div_equality_div_eq:
   "a div b * b = (a - (a mod b) :: int)"
   by (simp add: field_simps)
 
 lemma zmod_helper:
   "n mod m = k \<Longrightarrow> ((n :: int) + a) mod m = (k + a) mod m"
   by (metis add.commute mod_add_right_eq)
 
 lemma int_div_sub_1:
   "\<lbrakk> m \<ge> 1 \<rbrakk> \<Longrightarrow> (n - (1 :: int)) div m = (if m dvd n then (n div m) - 1 else n div m)"
   apply (subgoal_tac "m = 0 \<or> (n - (1 :: int)) div m = (if m dvd n then (n div m) - 1 else n div m)")
    apply fastforce
   apply (subst mult_cancel_right[symmetric])
   apply (simp only: left_diff_distrib split: if_split)
   apply (simp only: mod_div_equality_div_eq)
   apply (clarsimp simp: field_simps)
   apply (clarsimp simp: dvd_eq_mod_eq_0)
   apply (cases "m = 1")
    apply simp
   apply (subst mod_diff_eq[symmetric], simp add: zmod_minus1)
   apply clarsimp
   apply (subst diff_add_cancel[where b=1, symmetric])
   apply (subst mod_add_eq[symmetric])
   apply (simp add: field_simps)
   apply (rule mod_pos_pos_trivial)
    apply (subst add_0_right[where a=0, symmetric])
    apply (rule add_mono)
     apply simp
    apply simp
   apply (cases "(n - 1) mod m = m - 1")
    apply (drule zmod_helper[where a=1])
    apply simp
   apply (subgoal_tac "1 + (n - 1) mod m \<le> m")
    apply simp
   apply (subst field_simps, rule zless_imp_add1_zle)
   apply simp
   done
 
 lemma ptr_add_image_multI:
   "\<lbrakk> \<And>x y. (x * val = y * val') = (x * val'' = y); x * val'' \<in> S \<rbrakk> \<Longrightarrow>
      ptr_add ptr (x * val) \<in> (\<lambda>p. ptr_add ptr (p * val')) ` S"
   apply (simp add: image_def)
   apply (erule rev_bexI)
   apply (rule arg_cong[where f="ptr_add ptr"])
   apply simp
   done
 
 lemma shift_times_fold:
   "(x :: 'a :: len word) * (2 ^ n) << m = x << (m + n)"
   by (simp add: shiftl_t2n ac_simps power_add)
 
 lemma word_plus_strict_mono_right:
   fixes x :: "'a :: len word"
   shows "\<lbrakk>y < z; x \<le> x + z\<rbrakk> \<Longrightarrow> x + y < x + z"
   by unat_arith
 
 lemma replicate_minus:
   "k < n \<Longrightarrow> replicate n False = replicate (n - k) False @ replicate k False"
   by (subst replicate_add [symmetric]) simp
 
 lemmas map_prod_split_imageI'
   = map_prod_imageI[where f="case_prod f" and g="case_prod g"
                     and a="(a, b)" and b="(c, d)" for a b c d f g]
 lemmas map_prod_split_imageI = map_prod_split_imageI'[simplified]
 
 lemma word_div_mult:
   "0 < c \<Longrightarrow> a < b * c \<Longrightarrow> a div c < b" for a b c :: "'a::len word"
   by (rule classical)
      (use div_to_mult_word_lt [of b a c] in
       \<open>auto simp add: word_less_nat_alt word_le_nat_alt unat_div\<close>)
 
 lemma word_less_power_trans_ofnat:
   "\<lbrakk>n < 2 ^ (m - k); k \<le> m; m < LENGTH('a)\<rbrakk>
    \<Longrightarrow> of_nat n * 2 ^ k < (2::'a::len word) ^ m"
   apply (subst mult.commute)
   apply (rule word_less_power_trans)
     apply (simp add: word_less_nat_alt)
     apply (subst unat_of_nat_eq)
      apply (erule order_less_trans)
      apply simp+
     done
 
 lemma word_1_le_power:
   "n < LENGTH('a) \<Longrightarrow> (1 :: 'a :: len word) \<le> 2 ^ n"
   by (rule inc_le[where i=0, simplified], erule iffD2[OF p2_gt_0])
 
 lemma enum_word_div:
   fixes v :: "'a :: len word" shows
   "\<exists>xs ys. enum = xs @ [v] @ ys
              \<and> (\<forall>x \<in> set xs. x < v)
              \<and> (\<forall>y \<in> set ys. v < y)"
   apply (simp only: enum_word_def)
   apply (subst upt_add_eq_append'[where j="unat v"])
     apply simp
    apply (rule order_less_imp_le, simp)
   apply (simp add: upt_conv_Cons)
   apply (intro exI conjI)
     apply fastforce
    apply clarsimp
    apply (drule of_nat_mono_maybe[rotated, where 'a='a])
     apply simp
    apply simp
   apply (clarsimp simp: Suc_le_eq)
   apply (drule of_nat_mono_maybe[rotated, where 'a='a])
    apply simp
   apply simp
   done
 
 lemma of_bool_nth:
   "of_bool (x !! v) = (x >> v) && 1"
   apply (rule word_eqI)
   apply (simp add: nth_shiftr cong: rev_conj_cong)
   done
 
 lemma unat_1_0:
   "1 \<le> (x::'a::len word) = (0 < unat x)"
   by (auto simp add: word_le_nat_alt)
 
 lemma x_less_2_0_1':
   fixes x :: "'a::len word"
   shows "\<lbrakk>LENGTH('a) \<noteq> 1; x < 2\<rbrakk> \<Longrightarrow> x = 0 \<or> x = 1"
   apply (induct x)
    apply clarsimp+
   by (metis Suc_eq_plus1 add_lessD1 less_irrefl one_add_one unatSuc word_less_nat_alt)
 
 lemmas word_add_le_iff2 = word_add_le_iff [folded no_olen_add_nat]
 
 lemma of_nat_power:
   shows "\<lbrakk> p < 2 ^ x; x < len_of TYPE ('a) \<rbrakk> \<Longrightarrow> of_nat p < (2 :: 'a :: len word) ^ x"
   apply (rule order_less_le_trans)
    apply (rule of_nat_mono_maybe)
     apply (erule power_strict_increasing)
     apply simp
    apply assumption
   apply (simp add: word_unat_power)
   done
 
 lemma of_nat_n_less_equal_power_2:
   "n < LENGTH('a::len) \<Longrightarrow> ((of_nat n)::'a word) < 2 ^ n"
   apply (induct n)
    apply clarsimp
   apply clarsimp
   apply (metis of_nat_power n_less_equal_power_2 of_nat_Suc power_Suc)
   done
 
 lemma eq_mask_less:
   fixes w :: "'a::len word"
   assumes eqm: "w = w && mask n"
   and      sz: "n < len_of TYPE ('a)"
   shows "w < (2::'a word) ^ n"
   by (subst eqm, rule and_mask_less' [OF sz])
 
 lemma of_nat_mono_maybe':
   fixes Y :: "nat"
   assumes xlt: "x < 2 ^ len_of TYPE ('a)"
   assumes ylt: "y < 2 ^ len_of TYPE ('a)"
   shows   "(y < x) = (of_nat y < (of_nat x :: 'a :: len word))"
   apply (subst word_less_nat_alt)
   apply (subst unat_of_nat)+
   apply (subst mod_less)
    apply (rule ylt)
   apply (subst mod_less)
    apply (rule xlt)
   apply simp
   done
 
 lemma shiftr_mask_eq:
   fixes x :: "'a :: len word"
   shows "(x >> n) && mask (size x - n) = x >> n"
   apply (rule word_eqI)
   apply (clarsimp simp: word_size nth_shiftr)
   apply (rule iffI)
    apply clarsimp
   apply (clarsimp)
   apply (drule test_bit_size)
   apply (simp add: word_size)
   done
 
 lemma shiftr_mask_eq':
   fixes x :: "'a :: len word"
   shows "m = (size x - n) \<Longrightarrow> (x >> n) && mask m = x >> n"
   by (simp add: shiftr_mask_eq)
 
 lemma bang_big: "n \<ge> size (x::'a::len0 word) \<Longrightarrow> (x !! n) = False"
   by (simp add: test_bit_bl word_size)
 
 lemma bang_conj_lt:
   fixes x :: "'a :: len word"
   shows "(x !! m \<and> m < LENGTH('a)) = x !! m"
   apply (cases "m < LENGTH('a)")
    apply simp
   apply (simp add: not_less bang_big  word_size)
   done
 
 lemma dom_if:
   "dom (\<lambda>a. if a \<in> addrs then Some (f a) else g a)  = addrs \<union> dom g"
   by (auto simp: dom_def split: if_split)
 
 lemma less_is_non_zero_p1:
   fixes a :: "'a :: len word"
   shows "a < k \<Longrightarrow> a + 1 \<noteq> 0"
   apply (erule contrapos_pn)
   apply (drule max_word_wrap)
   apply (simp add: not_less)
   done
 
 lemma of_nat_mono_maybe_le:
   "\<lbrakk>x < 2 ^ LENGTH('a); y < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow>
   (y \<le> x) = ((of_nat y :: 'a :: len word) \<le> of_nat x)"
   apply (clarsimp simp: le_less)
   apply (rule disj_cong)
    apply (rule of_nat_mono_maybe', assumption+)
   apply (simp add: word_unat.norm_eq_iff [symmetric])
   done
 
 lemma neg_mask_bang:
   "(~~ mask n :: 'a :: len word) !! m = (n \<le> m \<and> m < LENGTH('a))"
   apply (cases "m < LENGTH('a)")
    apply (simp add: word_ops_nth_size word_size not_less)
   apply (simp add: not_less bang_big  word_size)
   done
 
 lemma mask_AND_NOT_mask:
   "(w && ~~ mask n) && mask n = 0"
 by (rule word_eqI) (clarsimp simp add: word_size neg_mask_bang)
 
 lemma AND_NOT_mask_plus_AND_mask_eq:
   "(w && ~~ mask n) + (w && mask n) = w"
 apply (rule word_eqI)
 apply (rename_tac m)
 apply (simp add: word_size)
 apply (cut_tac word_plus_and_or_coroll[of "w && ~~ mask n" "w && mask n"])
  apply (simp add: word_ao_dist2[symmetric] word_size neg_mask_bang)
 apply (rule word_eqI)
 apply (rename_tac m)
 apply (simp add: word_size neg_mask_bang)
 done
 
 lemma mask_eqI:
   fixes x :: "'a :: len word"
   assumes m1: "x && mask n = y && mask n"
   and     m2: "x && ~~ mask n = y && ~~ mask n"
   shows "x = y"
 proof (subst bang_eq, rule allI)
   fix m
 
   show "x !! m = y !! m"
   proof (cases "m < n")
     case True
     then have "x !! m = ((x && mask n) !! m)"
       by (simp add: word_size bang_conj_lt)
     also have "\<dots> = ((y && mask n) !! m)" using m1 by simp
     also have "\<dots> = y !! m" using True
       by (simp add: word_size bang_conj_lt)
     finally show ?thesis .
   next
     case False
     then have "x !! m = ((x && ~~ mask n) !! m)"
       by (simp add: neg_mask_bang bang_conj_lt)
     also have "\<dots> = ((y && ~~ mask n) !! m)" using m2 by simp
     also have "\<dots> = y !! m" using False
       by (simp add: neg_mask_bang bang_conj_lt)
     finally show ?thesis .
   qed
 qed
 
 lemma nat_less_power_trans2:
   fixes n :: nat
   shows "\<lbrakk>n < 2 ^ (m - k); k \<le> m\<rbrakk> \<Longrightarrow> n * 2 ^ k  < 2 ^ m"
   by (subst mult.commute, erule (1) nat_less_power_trans)
 
 lemma nat_move_sub_le: "(a::nat) + b \<le> c \<Longrightarrow> a \<le> c - b" by arith
 
 lemma neq_0_no_wrap:
   fixes x :: "'a :: len word"
   shows "\<lbrakk> x \<le> x + y; x \<noteq> 0 \<rbrakk> \<Longrightarrow> x + y \<noteq> 0"
   by clarsimp
 
 lemma plus_minus_one_rewrite:
   "v + (- 1 :: ('a :: {ring, one, uminus})) \<equiv> v - 1"
   by (simp add: field_simps)
 
 lemma power_minus_is_div:
   "b \<le> a \<Longrightarrow> (2 :: nat) ^ (a - b) = 2 ^ a div 2 ^ b"
   apply (induct a arbitrary: b)
    apply simp
   apply (erule le_SucE)
    apply (clarsimp simp:Suc_diff_le le_iff_add power_add)
   apply simp
   done
 
 lemma two_pow_div_gt_le:
   "v < 2 ^ n div (2 ^ m :: nat) \<Longrightarrow> m \<le> n"
   by (clarsimp dest!: less_two_pow_divD)
 
 lemma unatSuc2:
   fixes n :: "'a :: len word"
   shows "n + 1 \<noteq> 0 \<Longrightarrow> unat (n + 1) = Suc (unat n)"
   by (simp add: add.commute unatSuc)
 
 lemma word_of_nat_less:
   "\<lbrakk> n < unat x \<rbrakk> \<Longrightarrow> of_nat n < x"
   apply (simp add: word_less_nat_alt)
   apply (erule order_le_less_trans[rotated])
   apply (simp add: unat_of_nat)
   done
 
 lemma word_of_nat_le:
   "n \<le> unat x \<Longrightarrow> of_nat n \<le> x"
   apply (simp add: word_le_nat_alt unat_of_nat)
   apply (erule order_trans[rotated])
   apply simp
   done
 
 lemma word_unat_less_le:
    "a \<le> of_nat b \<Longrightarrow> unat a \<le> b"
    by (metis eq_iff le_cases le_unat_uoi word_of_nat_le)
 
 lemma and_eq_0_is_nth:
   fixes x :: "'a :: len word"
   shows "y = 1 << n \<Longrightarrow> ((x && y) = 0) = (\<not> (x !! n))"
   apply safe
    apply (drule_tac u="(x && (1 << n))" and x=n in word_eqD)
    apply (simp add: nth_w2p)
    apply (simp add: test_bit_bin)
   apply (rule word_eqI)
   apply (simp add: nth_w2p)
   done
 
 lemmas arg_cong_Not = arg_cong [where f=Not]
 lemmas and_neq_0_is_nth = arg_cong_Not [OF and_eq_0_is_nth, simplified]
 
 lemma nth_is_and_neq_0:
   "(x::'a::len word) !! n = (x && 2 ^ n \<noteq> 0)"
   by (subst and_neq_0_is_nth; rule refl)
 
 lemma mask_Suc_0 : "mask (Suc 0) = 1"
   by (simp add: mask_def)
 
 lemma ucast_ucast_add:
   fixes x :: "'a :: len word"
   fixes y :: "'b :: len word"
   shows
   "LENGTH('b) \<ge> LENGTH('a) \<Longrightarrow>
     ucast (ucast x + y) = x + ucast y"
   apply (rule word_unat.Rep_eqD)
   apply (simp add: unat_ucast unat_word_ariths mod_mod_power
                    min.absorb2 unat_of_nat)
   apply (subst mod_add_left_eq[symmetric])
   apply (simp add: mod_mod_power min.absorb2)
   apply (subst mod_add_right_eq)
   apply simp
   done
 
 lemma word_shift_zero:
   "\<lbrakk> x << n = 0; x \<le> 2^m; m + n < LENGTH('a)\<rbrakk> \<Longrightarrow> (x::'a::len word) = 0"
   apply (rule ccontr)
   apply (drule (2) word_shift_nonzero)
   apply simp
   done
 
 lemma neg_mask_mono_le:
   "(x :: 'a :: len word) \<le> y \<Longrightarrow> x && ~~ mask n \<le> y && ~~ mask n"
 proof (rule ccontr, simp add: linorder_not_le, cases "n < LENGTH('a)")
   case False
   show "y && ~~ mask n < x && ~~ mask n \<Longrightarrow> False"
     using False
     by (simp add: mask_def linorder_not_less
                   power_overflow)
 next
   case True
   assume a: "x \<le> y" and b: "y && ~~ mask n < x && ~~ mask n"
   have word_bits:
     "n < LENGTH('a)"
     using True by assumption
   have "y \<le> (y && ~~ mask n) + (y && mask n)"
     by (simp add: word_plus_and_or_coroll2 add.commute)
   also have "\<dots> \<le> (y && ~~ mask n) + 2 ^ n"
     apply (rule word_plus_mono_right)
      apply (rule order_less_imp_le, rule and_mask_less_size)
      apply (simp add: word_size word_bits)
     apply (rule is_aligned_no_overflow'',
            simp_all add: is_aligned_neg_mask word_bits)
     apply (rule not_greatest_aligned, rule b)
      apply (simp_all add: is_aligned_neg_mask)
     done
   also have "\<dots> \<le> x && ~~ mask n"
     using b
     apply -
     apply (subst add.commute, rule le_plus)
      apply (rule aligned_at_least_t2n_diff,
             simp_all add: is_aligned_neg_mask)
     apply (rule ccontr, simp add: linorder_not_le)
     apply (drule aligned_small_is_0[rotated], simp_all add: is_aligned_neg_mask)
     done
   also have "\<dots> \<le> x" by (rule word_and_le2)
   also have "x \<le> y" by fact
   finally
   show "False" using b by simp
 qed
 
 lemma bool_mask':
   fixes x :: "'a :: len word"
   shows "2 < LENGTH('a) \<Longrightarrow> (0 < x && 1) = (x && 1 = 1)"
   apply (rule iffI)
    prefer 2
    apply simp
   apply (subgoal_tac "x && mask 1 < 2^1")
    prefer 2
    apply (rule and_mask_less_size)
    apply (simp add: word_size)
   apply (simp add: mask_def)
   apply (drule word_less_cases [where y=2])
   apply (erule disjE, simp)
   apply simp
   done
 
 lemma sint_eq_uint:
   "\<not> msb x \<Longrightarrow> sint x = uint x"
   apply (rule word_uint.Abs_eqD, subst word_sint.Rep_inverse)
     apply simp_all
   apply (cut_tac x=x in word_sint.Rep)
   apply (clarsimp simp add: uints_num sints_num)
   apply (rule conjI)
    apply (rule ccontr)
    apply (simp add: linorder_not_le word_msb_sint[symmetric])
   apply (erule order_less_le_trans)
   apply simp
   done
 
 lemma scast_eq_ucast:
   "\<not> msb x \<Longrightarrow> scast x = ucast x"
   by (simp add: scast_def ucast_def sint_eq_uint)
 
 lemma lt1_neq0:
   fixes x :: "'a :: len word"
   shows "(1 \<le> x) = (x \<noteq> 0)" by unat_arith
 
 lemma word_plus_one_nonzero:
   fixes x :: "'a :: len word"
   shows "\<lbrakk>x \<le> x + y; y \<noteq> 0\<rbrakk> \<Longrightarrow> x + 1 \<noteq> 0"
   apply (subst lt1_neq0 [symmetric])
   apply (subst olen_add_eqv [symmetric])
   apply (erule word_random)
   apply (simp add: lt1_neq0)
   done
 
 lemma word_sub_plus_one_nonzero:
   fixes n :: "'a :: len word"
   shows "\<lbrakk>n' \<le> n; n' \<noteq> 0\<rbrakk> \<Longrightarrow> (n - n') + 1 \<noteq> 0"
   apply (subst lt1_neq0 [symmetric])
   apply (subst olen_add_eqv [symmetric])
   apply (rule word_random [where x' = n'])
    apply simp
    apply (erule word_sub_le)
   apply (simp add: lt1_neq0)
   done
 
 lemma word_le_minus_mono_right:
   fixes x :: "'a :: len word"
   shows "\<lbrakk> z \<le> y; y \<le> x; z \<le> x \<rbrakk> \<Longrightarrow> x - y \<le> x - z"
   apply (rule word_sub_mono)
      apply simp
     apply assumption
    apply (erule word_sub_le)
   apply (erule word_sub_le)
   done
 
 lemma drop_append_miracle:
   "n = length xs \<Longrightarrow> drop n (xs @ ys) = ys"
   by simp
 
 lemma foldr_does_nothing_to_xf:
   "\<lbrakk> \<And>x s. x \<in> set xs \<Longrightarrow> xf (f x s) = xf s \<rbrakk> \<Longrightarrow> xf (foldr f xs s) = xf s"
   by (induct xs, simp_all)
 
 lemma nat_less_mult_monoish: "\<lbrakk> a < b; c < (d :: nat) \<rbrakk> \<Longrightarrow> (a + 1) * (c + 1) <= b * d"
   apply (drule Suc_leI)+
   apply (drule(1) mult_le_mono)
   apply simp
   done
 
 lemma word_0_sle_from_less[unfolded word_size]:
   "\<lbrakk> x < 2 ^ (size x - 1) \<rbrakk>  \<Longrightarrow> 0 <=s x"
   apply (clarsimp simp: word_sle_msb_le)
   apply (simp add: word_msb_nth)
   apply (subst (asm) word_test_bit_def [symmetric])
   apply (drule less_mask_eq)
   apply (drule_tac x="size x - 1" in word_eqD)
   apply (simp add: word_size)
   done
 
 lemma not_msb_from_less:
   "(v :: 'a word) < 2 ^ (LENGTH('a :: len) - 1) \<Longrightarrow> \<not> msb v"
   apply (clarsimp simp add: msb_nth)
   apply (drule less_mask_eq)
   apply (drule word_eqD, drule(1) iffD2)
   apply simp
   done
 
 lemma distinct_lemma: "f x \<noteq> f y \<Longrightarrow> x \<noteq> y" by auto
 
 
 lemma ucast_sub_ucast:
   fixes x :: "'a::len word"
   assumes "y \<le> x"
   assumes T: "LENGTH('a) \<le> LENGTH('b)"
   shows "ucast (x - y) = (ucast x - ucast y :: 'b::len word)"
 proof -
   from T
   have P: "unat x < 2 ^ LENGTH('b)" "unat y < 2 ^ LENGTH('b)"
     by (fastforce intro!: less_le_trans[OF unat_lt2p])+
   then show ?thesis
     by (simp add: unat_arith_simps unat_ucast assms[simplified unat_arith_simps])
 qed
 
 lemma word_1_0:
   "\<lbrakk>a + (1::('a::len) word) \<le> b; a < of_nat x\<rbrakk> \<Longrightarrow> a < b"
   by unat_arith
 
 lemma unat_of_nat_less:"\<lbrakk> a < b; unat b = c \<rbrakk> \<Longrightarrow> a < of_nat c"
   by fastforce
 
 lemma word_le_plus_1: "\<lbrakk> (y::('a::len) word) < y + n; a < n \<rbrakk> \<Longrightarrow> y + a \<le> y + a + 1"
   by unat_arith
 
 lemma word_le_plus:"\<lbrakk>(a::('a::len) word) < a + b; c < b\<rbrakk> \<Longrightarrow> a \<le> a + c"
 by (metis order_less_imp_le word_random)
 
 (*
  * Basic signed arithemetic properties.
  *)
 
 lemma sint_minus1 [simp]: "(sint x = -1) = (x = -1)"
   by (metis sint_n1 word_sint.Rep_inverse')
 
 lemma sint_0 [simp]: "(sint x = 0) = (x = 0)"
   by (metis sint_0 word_sint.Rep_inverse')
 
 (* It is not always that case that "sint 1 = 1", because of 1-bit word sizes.
  * This lemma produces the different cases. *)
 lemma sint_1_cases:
   "\<lbrakk> \<lbrakk> len_of TYPE ('a::len) = 1; (a::'a word) = 0; sint a = 0 \<rbrakk> \<Longrightarrow> P;
      \<lbrakk> len_of TYPE ('a) = 1; a = 1; sint (1 :: 'a word) = -1 \<rbrakk> \<Longrightarrow> P;
       \<lbrakk> len_of TYPE ('a) > 1; sint (1 :: 'a word) = 1 \<rbrakk> \<Longrightarrow> P \<rbrakk>
                 \<Longrightarrow> P"
    apply atomize_elim
   apply (case_tac "len_of TYPE ('a) = 1")
    apply clarsimp
    apply (subgoal_tac "(UNIV :: 'a word set) = {0, 1}")
     apply (metis UNIV_I insert_iff singletonE)
    apply (subst word_unat.univ)
    apply (clarsimp simp: unats_def image_def)
    apply (rule set_eqI, rule iffI)
     apply clarsimp
     apply (metis One_nat_def less_2_cases of_nat_1 semiring_1_class.of_nat_0)
    apply clarsimp
    apply (metis Abs_fnat_hom_0 Suc_1 lessI of_nat_1 zero_less_Suc)
   apply clarsimp
   apply (metis One_nat_def arith_is_1 le_def len_gt_0)
   done
 
 lemma sint_int_min:
   "sint (- (2 ^ (LENGTH('a) - Suc 0)) :: ('a::len) word) = - (2 ^ (LENGTH('a) - Suc 0))"
   apply (subst word_sint.Abs_inverse' [where r="- (2 ^ (LENGTH('a) - Suc 0))"])
     apply (clarsimp simp: sints_num)
    apply (clarsimp simp: wi_hom_syms word_of_int_2p)
   apply clarsimp
   done
 
 lemma sint_int_max_plus_1:
   "sint (2 ^ (LENGTH('a) - Suc 0) :: ('a::len) word) = - (2 ^ (LENGTH('a) - Suc 0))"
   apply (subst word_of_int_2p [symmetric])
   apply (subst int_word_sint)
   apply clarsimp
   apply (metis Suc_pred int_word_uint len_gt_0 power_Suc uint_eq_0 word_of_int_2p word_pow_0)
   done
 
 lemma sbintrunc_eq_in_range:
   "(sbintrunc n x = x) = (x \<in> range (sbintrunc n))"
   "(x = sbintrunc n x) = (x \<in> range (sbintrunc n))"
   apply (simp_all add: image_def)
   apply (metis sbintrunc_sbintrunc)+
   done
 
 lemma sbintrunc_If:
   "- 3 * (2 ^ n) \<le> x \<and> x < 3 * (2 ^ n)
     \<Longrightarrow> sbintrunc n x = (if x < - (2 ^ n) then x + 2 * (2 ^ n)
         else if x \<ge> 2 ^ n then x - 2 * (2 ^ n) else x)"
   apply (simp add: no_sbintr_alt2, safe)
    apply (simp add: mod_pos_geq)
   apply (subst mod_add_self1[symmetric], simp)
   done
 
 lemma signed_arith_eq_checks_to_ord:
   "(sint a + sint b = sint (a + b ))
     = ((a <=s a + b) = (0 <=s b))"
   "(sint a - sint b = sint (a - b ))
     = ((0 <=s a - b) = (b <=s a))"
   "(- sint a = sint (- a)) = (0 <=s (- a) = (a <=s 0))"
   using sint_range'[where x=a] sint_range'[where x=b]
   by (simp_all add: sint_word_ariths word_sle_def word_sless_alt sbintrunc_If)
 
 (* Basic proofs that signed word div/mod operations are
  * truncations of their integer counterparts. *)
 
 lemma signed_div_arith:
     "sint ((a::('a::len) word) sdiv b) = sbintrunc (LENGTH('a) - 1) (sint a sdiv sint b)"
   apply (subst word_sbin.norm_Rep [symmetric])
   apply (subst bin_sbin_eq_iff' [symmetric])
    apply simp
   apply (subst uint_sint [symmetric])
   apply (clarsimp simp: sdiv_int_def sdiv_word_def)
   apply (metis word_ubin.eq_norm)
   done
 
 lemma signed_mod_arith:
     "sint ((a::('a::len) word) smod b) = sbintrunc (LENGTH('a) - 1) (sint a smod sint b)"
   apply (subst word_sbin.norm_Rep [symmetric])
   apply (subst bin_sbin_eq_iff' [symmetric])
    apply simp
   apply (subst uint_sint [symmetric])
   apply (clarsimp simp: smod_int_def smod_word_def)
   apply (metis word_ubin.eq_norm)
   done
 
 (* Signed word arithmetic overflow constraints. *)
 
 lemma signed_arith_ineq_checks_to_eq:
   "((- (2 ^ (size a - 1)) \<le> (sint a + sint b)) \<and> (sint a + sint b \<le> (2 ^ (size a - 1) - 1)))
     = (sint a + sint b = sint (a + b ))"
   "((- (2 ^ (size a - 1)) \<le> (sint a - sint b)) \<and> (sint a - sint b \<le> (2 ^ (size a - 1) - 1)))
     = (sint a - sint b = sint (a - b))"
   "((- (2 ^ (size a - 1)) \<le> (- sint a)) \<and> (- sint a) \<le> (2 ^ (size a - 1) - 1))
     = ((- sint a) = sint (- a))"
   "((- (2 ^ (size a - 1)) \<le> (sint a * sint b)) \<and> (sint a * sint b \<le> (2 ^ (size a - 1) - 1)))
     = (sint a * sint b = sint (a * b))"
   "((- (2 ^ (size a - 1)) \<le> (sint a sdiv sint b)) \<and> (sint a sdiv sint b \<le> (2 ^ (size a - 1) - 1)))
     = (sint a sdiv sint b = sint (a sdiv b))"
   "((- (2 ^ (size a - 1)) \<le> (sint a smod sint b)) \<and> (sint a smod sint b \<le> (2 ^ (size a - 1) - 1)))
     = (sint a smod sint b = sint (a smod b))"
   by (auto simp: sint_word_ariths word_size signed_div_arith signed_mod_arith
                     sbintrunc_eq_in_range range_sbintrunc)
 
 lemma signed_arith_sint:
   "((- (2 ^ (size a - 1)) \<le> (sint a + sint b)) \<and> (sint a + sint b \<le> (2 ^ (size a - 1) - 1)))
     \<Longrightarrow> sint (a + b) = (sint a + sint b)"
   "((- (2 ^ (size a - 1)) \<le> (sint a - sint b)) \<and> (sint a - sint b \<le> (2 ^ (size a - 1) - 1)))
     \<Longrightarrow> sint (a - b) = (sint a - sint b)"
   "((- (2 ^ (size a - 1)) \<le> (- sint a)) \<and> (- sint a) \<le> (2 ^ (size a - 1) - 1))
     \<Longrightarrow> sint (- a) = (- sint a)"
   "((- (2 ^ (size a - 1)) \<le> (sint a * sint b)) \<and> (sint a * sint b \<le> (2 ^ (size a - 1) - 1)))
     \<Longrightarrow> sint (a * b) = (sint a * sint b)"
   "((- (2 ^ (size a - 1)) \<le> (sint a sdiv sint b)) \<and> (sint a sdiv sint b \<le> (2 ^ (size a - 1) - 1)))
     \<Longrightarrow> sint (a sdiv b) = (sint a sdiv sint b)"
   "((- (2 ^ (size a - 1)) \<le> (sint a smod sint b)) \<and> (sint a smod sint b \<le> (2 ^ (size a - 1) - 1)))
     \<Longrightarrow> sint (a smod b) = (sint a smod sint b)"
   by (subst (asm) signed_arith_ineq_checks_to_eq; simp)+
 
 lemma signed_mult_eq_checks_double_size:
   assumes mult_le: "(2 ^ (len_of TYPE ('a) - 1) + 1) ^ 2 \<le> (2 :: int) ^ (len_of TYPE ('b) - 1)"
            and le: "2 ^ (LENGTH('a) - 1) \<le> (2 :: int) ^ (len_of TYPE ('b) - 1)"
   shows "(sint (a :: 'a :: len word) * sint b = sint (a * b))
        = (scast a * scast b = (scast (a * b) :: 'b :: len word))"
 proof -
   have P: "sbintrunc (size a - 1) (sint a * sint b) \<in> range (sbintrunc (size a - 1))"
     by simp
 
   have abs: "!! x :: 'a word. abs (sint x) < 2 ^ (size a - 1) + 1"
     apply (cut_tac x=x in sint_range')
     apply (simp add: abs_le_iff word_size)
     done
   have abs_ab: "abs (sint a * sint b) < 2 ^ (LENGTH('b) - 1)"
     using abs_mult_less[OF abs[where x=a] abs[where x=b]] mult_le
     by (simp add: abs_mult power2_eq_square word_size)
   show ?thesis
     using P[unfolded range_sbintrunc] abs_ab le
     apply (simp add: sint_word_ariths scast_def)
     apply (simp add: wi_hom_mult)
     apply (subst word_sint.Abs_inject, simp_all)
      apply (simp add: sints_def range_sbintrunc abs_less_iff)
     apply clarsimp
     apply (simp add: sints_def range_sbintrunc word_size)
     apply (auto elim: order_less_le_trans order_trans[rotated])
     done
 qed
 
 (* Properties about signed division. *)
 
 lemma int_sdiv_simps [simp]:
     "(a :: int) sdiv 1 = a"
     "(a :: int) sdiv 0 = 0"
     "(a :: int) sdiv -1 = -a"
   apply (auto simp: sdiv_int_def sgn_if)
   done
 
 lemma sgn_div_eq_sgn_mult:
     "a div b \<noteq> 0 \<Longrightarrow> sgn ((a :: int) div b) = sgn (a * b)"
   apply (clarsimp simp: sgn_if zero_le_mult_iff neg_imp_zdiv_nonneg_iff not_less)
   apply (metis less_le mult_le_0_iff neg_imp_zdiv_neg_iff not_less pos_imp_zdiv_neg_iff zdiv_eq_0_iff)
   done
 
 lemma sgn_sdiv_eq_sgn_mult:
   "a sdiv b \<noteq> 0 \<Longrightarrow> sgn ((a :: int) sdiv b) = sgn (a * b)"
   by (auto simp: sdiv_int_def sgn_div_eq_sgn_mult sgn_mult)
 
 lemma int_sdiv_same_is_1 [simp]:
     "a \<noteq> 0 \<Longrightarrow> ((a :: int) sdiv b = a) = (b = 1)"
   apply (rule iffI)
    apply (clarsimp simp: sdiv_int_def)
    apply (subgoal_tac "b > 0")
     apply (case_tac "a > 0")
-     apply (clarsimp simp: sgn_if sign_simps)
+     apply (clarsimp simp: sgn_if)
     apply (clarsimp simp: sign_simps not_less)
     apply (metis int_div_same_is_1 le_neq_trans minus_minus neg_0_le_iff_le neg_equal_0_iff_equal)
    apply (case_tac "a > 0")
     apply (case_tac "b = 0")
-     apply (clarsimp simp: sign_simps)
+     apply clarsimp
     apply (rule classical)
-    apply (clarsimp simp: sign_simps sgn_mult not_less)
+    apply (clarsimp simp: sgn_mult not_less)
     apply (metis le_less neg_0_less_iff_less not_less_iff_gr_or_eq pos_imp_zdiv_neg_iff)
    apply (rule classical)
    apply (clarsimp simp: sign_simps sgn_mult not_less sgn_if split: if_splits)
    apply (metis antisym less_le neg_imp_zdiv_nonneg_iff)
   apply (clarsimp simp: sdiv_int_def sgn_if)
   done
 
 lemma int_sdiv_negated_is_minus1 [simp]:
     "a \<noteq> 0 \<Longrightarrow> ((a :: int) sdiv b = - a) = (b = -1)"
   apply (clarsimp simp: sdiv_int_def)
   apply (rule iffI)
    apply (subgoal_tac "b < 0")
     apply (case_tac "a > 0")
      apply (clarsimp simp: sgn_if sign_simps not_less)
     apply (case_tac "sgn (a * b) = -1")
      apply (clarsimp simp: not_less sign_simps)
     apply (clarsimp simp: sign_simps not_less)
    apply (rule classical)
    apply (case_tac "b = 0")
-    apply (clarsimp simp: sign_simps not_less sgn_mult)
+    apply (clarsimp simp: not_less sgn_mult)
    apply (case_tac "a > 0")
-    apply (clarsimp simp: sign_simps not_less sgn_mult)
+    apply (clarsimp simp: not_less sgn_mult)
     apply (metis less_le neg_less_0_iff_less not_less_iff_gr_or_eq pos_imp_zdiv_neg_iff)
-   apply (clarsimp simp: sign_simps not_less sgn_mult)
+   apply (clarsimp simp: not_less sgn_mult)
    apply (metis antisym_conv div_minus_right neg_imp_zdiv_nonneg_iff neg_le_0_iff_le not_less)
   apply (clarsimp simp: sgn_if)
   done
 
 lemma sdiv_int_range:
     "(a :: int) sdiv b \<in> { - (abs a) .. (abs a) }"
   apply (unfold sdiv_int_def)
   apply (subgoal_tac "(abs a) div (abs b) \<le> (abs a)")
    apply (clarsimp simp: sgn_if)
    apply (meson abs_ge_zero neg_le_0_iff_le nonneg_mod_div order_trans)
   apply (metis abs_eq_0 abs_ge_zero div_by_0 zdiv_le_dividend zero_less_abs_iff)
   done
 
 lemma word_sdiv_div1 [simp]:
     "(a :: ('a::len) word) sdiv 1 = a"
   apply (rule sint_1_cases [where a=a])
     apply (clarsimp simp: sdiv_word_def sdiv_int_def)
    apply (clarsimp simp: sdiv_word_def sdiv_int_def simp del: sint_minus1)
   apply (clarsimp simp: sdiv_word_def)
   done
 
 lemma sdiv_int_div_0 [simp]:
   "(x :: int) sdiv 0 = 0"
   by (clarsimp simp: sdiv_int_def)
 
 lemma sdiv_int_0_div [simp]:
   "0 sdiv (x :: int) = 0"
   by (clarsimp simp: sdiv_int_def)
 
 lemma word_sdiv_div0 [simp]:
     "(a :: ('a::len) word) sdiv 0 = 0"
   apply (auto simp: sdiv_word_def sdiv_int_def sgn_if)
   done
 
 lemma word_sdiv_div_minus1 [simp]:
     "(a :: ('a::len) word) sdiv -1 = -a"
   apply (auto simp: sdiv_word_def sdiv_int_def sgn_if)
   apply (metis wi_hom_neg word_sint.Rep_inverse')
   done
 
 lemmas word_sdiv_0 = word_sdiv_div0
 
 lemma sdiv_word_min:
     "- (2 ^ (size a - 1)) \<le> sint (a :: ('a::len) word) sdiv sint (b :: ('a::len) word)"
   apply (clarsimp simp: word_size)
   apply (cut_tac sint_range' [where x=a])
   apply (cut_tac sint_range' [where x=b])
   apply clarsimp
   apply (insert sdiv_int_range [where a="sint a" and b="sint b"])
   apply (clarsimp simp: max_def abs_if split: if_split_asm)
   done
 
 lemma sdiv_word_max:
     "(sint (a :: ('a::len) word) sdiv sint (b :: ('a::len) word) < (2 ^ (size a - 1))) =
           ((a \<noteq> - (2 ^ (size a - 1)) \<or> (b \<noteq> -1)))"
     (is "?lhs = (\<not> ?a_int_min \<or> \<not> ?b_minus1)")
 proof (rule classical)
   assume not_thesis: "\<not> ?thesis"
 
   have not_zero: "b \<noteq> 0"
     using not_thesis
     by (clarsimp)
 
   have result_range: "sint a sdiv sint b \<in> (sints (size a)) \<union> {2 ^ (size a - 1)}"
     apply (cut_tac sdiv_int_range [where a="sint a" and b="sint b"])
     apply (erule rev_subsetD)
     using sint_range' [where x=a]  sint_range' [where x=b]
     apply (auto simp: max_def abs_if word_size sints_num)
     done
 
   have result_range_overflow: "(sint a sdiv sint b = 2 ^ (size a - 1)) = (?a_int_min \<and> ?b_minus1)"
     apply (rule iffI [rotated])
      apply (clarsimp simp: sdiv_int_def sgn_if word_size sint_int_min)
     apply (rule classical)
     apply (case_tac "?a_int_min")
      apply (clarsimp simp: word_size sint_int_min)
      apply (metis diff_0_right
               int_sdiv_negated_is_minus1 minus_diff_eq minus_int_code(2)
               power_eq_0_iff sint_minus1 zero_neq_numeral)
     apply (subgoal_tac "abs (sint a) < 2 ^ (size a - 1)")
      apply (insert sdiv_int_range [where a="sint a" and b="sint b"])[1]
      apply (clarsimp simp: word_size)
     apply (insert sdiv_int_range [where a="sint a" and b="sint b"])[1]
     apply (insert word_sint.Rep [where x="a"])[1]
     apply (clarsimp simp: minus_le_iff word_size abs_if sints_num split: if_split_asm)
     apply (metis minus_minus sint_int_min word_sint.Rep_inject)
     done
 
   have result_range_simple: "(sint a sdiv sint b \<in> (sints (size a))) \<Longrightarrow> ?thesis"
     apply (insert sdiv_int_range [where a="sint a" and b="sint b"])
     apply (clarsimp simp: word_size sints_num sint_int_min)
     done
 
   show ?thesis
     apply (rule UnE [OF result_range result_range_simple])
      apply simp
     apply (clarsimp simp: word_size)
     using result_range_overflow
     apply (clarsimp simp: word_size)
     done
 qed
 
 lemmas sdiv_word_min' = sdiv_word_min [simplified word_size, simplified]
 lemmas sdiv_word_max' = sdiv_word_max [simplified word_size, simplified]
 
 lemmas word_sdiv_numerals_lhs = sdiv_word_def[where a="numeral x" for x]
     sdiv_word_def[where a=0] sdiv_word_def[where a=1]
 
 lemmas word_sdiv_numerals = word_sdiv_numerals_lhs[where b="numeral y" for y]
     word_sdiv_numerals_lhs[where b=0] word_sdiv_numerals_lhs[where b=1]
 
 (*
  * Signed modulo properties.
  *)
 
 lemma smod_int_alt_def:
      "(a::int) smod b = sgn (a) * (abs a mod abs b)"
   apply (clarsimp simp: smod_int_def sdiv_int_def)
   apply (clarsimp simp: minus_div_mult_eq_mod [symmetric] abs_sgn sgn_mult sgn_if sign_simps)
   done
 
 lemma smod_int_range:
   "b \<noteq> 0 \<Longrightarrow> (a::int) smod b \<in> { - abs b + 1 .. abs b - 1 }"
   apply (case_tac  "b > 0")
    apply (insert pos_mod_conj [where a=a and b=b])[1]
    apply (insert pos_mod_conj [where a="-a" and b=b])[1]
-   apply (clarsimp simp: smod_int_alt_def sign_simps sgn_if
-              abs_if not_less add1_zle_eq [simplified add.commute])
-   apply (metis add_le_cancel_left monoid_add_class.add.right_neutral
-             int_one_le_iff_zero_less less_le_trans mod_minus_right neg_less_0_iff_less
-             neg_mod_conj not_less pos_mod_conj)
+   apply (auto simp: smod_int_alt_def algebra_simps sgn_if
+              abs_if not_less add1_zle_eq [simplified add.commute])[1]
+    apply (metis add_nonneg_nonneg int_one_le_iff_zero_less le_less less_add_same_cancel2 not_le pos_mod_conj)
+  apply (metis (full_types) add.inverse_inverse eucl_rel_int eucl_rel_int_iff le_less_trans neg_0_le_iff_le)
   apply (insert neg_mod_conj [where a=a and b="b"])[1]
   apply (insert neg_mod_conj [where a="-a" and b="b"])[1]
-  apply (clarsimp simp: smod_int_alt_def sign_simps sgn_if
+  apply (clarsimp simp: smod_int_alt_def algebra_simps sgn_if
             abs_if not_less add1_zle_eq [simplified add.commute])
   apply (metis neg_0_less_iff_less neg_mod_conj not_le not_less_iff_gr_or_eq order_trans pos_mod_conj)
   done
 
 lemma smod_int_compares:
    "\<lbrakk> 0 \<le> a; 0 < b \<rbrakk> \<Longrightarrow> (a :: int) smod b < b"
    "\<lbrakk> 0 \<le> a; 0 < b \<rbrakk> \<Longrightarrow> 0 \<le> (a :: int) smod b"
    "\<lbrakk> a \<le> 0; 0 < b \<rbrakk> \<Longrightarrow> -b < (a :: int) smod b"
    "\<lbrakk> a \<le> 0; 0 < b \<rbrakk> \<Longrightarrow> (a :: int) smod b \<le> 0"
    "\<lbrakk> 0 \<le> a; b < 0 \<rbrakk> \<Longrightarrow> (a :: int) smod b < - b"
    "\<lbrakk> 0 \<le> a; b < 0 \<rbrakk> \<Longrightarrow> 0 \<le> (a :: int) smod b"
    "\<lbrakk> a \<le> 0; b < 0 \<rbrakk> \<Longrightarrow> (a :: int) smod b \<le> 0"
    "\<lbrakk> a \<le> 0; b < 0 \<rbrakk> \<Longrightarrow> b \<le> (a :: int) smod b"
   apply (insert smod_int_range [where a=a and b=b])
   apply (auto simp: add1_zle_eq smod_int_alt_def sgn_if)
   done
 
 lemma smod_int_mod_0 [simp]:
   "x smod (0 :: int) = x"
   by (clarsimp simp: smod_int_def)
 
 lemma smod_int_0_mod [simp]:
   "0 smod (x :: int) = 0"
   by (clarsimp simp: smod_int_alt_def)
 
 lemma smod_word_mod_0 [simp]:
   "x smod (0 :: ('a::len) word) = x"
   by (clarsimp simp: smod_word_def)
 
 lemma smod_word_0_mod [simp]:
   "0 smod (x :: ('a::len) word) = 0"
   by (clarsimp simp: smod_word_def)
 
 lemma smod_word_max:
     "sint (a::'a word) smod sint (b::'a word) < 2 ^ (LENGTH('a::len) - Suc 0)"
   apply (case_tac "b = 0")
    apply (insert word_sint.Rep [where x=a, simplified sints_num])[1]
    apply (clarsimp)
   apply (insert word_sint.Rep [where x="b", simplified sints_num])[1]
   apply (insert smod_int_range [where a="sint a" and b="sint b"])
   apply (clarsimp simp: abs_if split: if_split_asm)
   done
 
 lemma smod_word_min:
     "- (2 ^ (LENGTH('a::len) - Suc 0)) \<le> sint (a::'a word) smod sint (b::'a word)"
   apply (case_tac "b = 0")
    apply (insert word_sint.Rep [where x=a, simplified sints_num])[1]
    apply clarsimp
   apply (insert word_sint.Rep [where x=b, simplified sints_num])[1]
   apply (insert smod_int_range [where a="sint a" and b="sint b"])
   apply (clarsimp simp: abs_if add1_zle_eq split: if_split_asm)
   done
 
 lemma smod_word_alt_def:
   "(a :: ('a::len) word) smod b = a - (a sdiv b) * b"
   apply (case_tac "a \<noteq> - (2 ^ (LENGTH('a) - 1)) \<or> b \<noteq> -1")
    apply (clarsimp simp: smod_word_def sdiv_word_def smod_int_def
              minus_word.abs_eq [symmetric] times_word.abs_eq [symmetric])
   apply (clarsimp simp: smod_word_def smod_int_def)
   done
 
 lemmas word_smod_numerals_lhs = smod_word_def[where a="numeral x" for x]
     smod_word_def[where a=0] smod_word_def[where a=1]
 
 lemmas word_smod_numerals = word_smod_numerals_lhs[where b="numeral y" for y]
     word_smod_numerals_lhs[where b=0] word_smod_numerals_lhs[where b=1]
 
 lemma sint_of_int_eq:
   "\<lbrakk> - (2 ^ (LENGTH('a) - 1)) \<le> x; x < 2 ^ (LENGTH('a) - 1) \<rbrakk> \<Longrightarrow> sint (of_int x :: ('a::len) word) = x"
   apply (clarsimp simp: word_of_int int_word_sint)
   apply (subst int_mod_eq')
     apply simp
    apply (subst (2) power_minus_simp)
     apply clarsimp
    apply clarsimp
   apply clarsimp
   done
 
 lemma of_int_sint [simp]:
     "of_int (sint a) = a"
   apply (insert word_sint.Rep [where x=a])
   apply (clarsimp simp: word_of_int)
   done
 
 lemma nth_w2p_scast [simp]:
   "((scast ((2::'a::len signed word) ^ n) :: 'a word) !! m)
          \<longleftrightarrow> ((((2::'a::len  word) ^ n) :: 'a word) !! m)"
   apply (subst nth_w2p)
   apply (case_tac "n \<ge> LENGTH('a)")
    apply (subst power_overflow, simp)
    apply clarsimp
   apply (metis nth_w2p scast_def bang_conj_lt
                len_signed nth_word_of_int word_sint.Rep_inverse)
   done
 
 lemma scast_2_power [simp]: "scast ((2 :: 'a::len signed word) ^ x) = ((2 :: 'a word) ^ x)"
   by (clarsimp simp: word_eq_iff)
 
 lemma scast_bit_test [simp]:
     "scast ((1 :: 'a::len signed word) << n) = (1 :: 'a word) << n"
   by (clarsimp simp: word_eq_iff)
 
 lemma ucast_nat_def':
   "of_nat (unat x) = (ucast :: 'a :: len word \<Rightarrow> ('b :: len) signed word) x"
   by (simp add: ucast_def word_of_int_nat unat_def)
 
 lemma mod_mod_power_int:
   fixes k :: int
   shows "k mod 2 ^ m mod 2 ^ n = k mod 2 ^ (min m n)"
   by (metis bintrunc_bintrunc_min bintrunc_mod2p min.commute)
 
 (* Normalise combinations of scast and ucast. *)
 
 lemma ucast_distrib:
   fixes M :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word"
   fixes M' :: "'b::len word \<Rightarrow> 'b::len word \<Rightarrow> 'b::len word"
   fixes L :: "int \<Rightarrow> int \<Rightarrow> int"
   assumes lift_M: "\<And>x y. uint (M x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('a)"
   assumes lift_M': "\<And>x y. uint (M' x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('b)"
   assumes distrib: "\<And>x y. (L (x mod (2 ^ LENGTH('b))) (y mod (2 ^ LENGTH('b)))) mod (2 ^ LENGTH('b))
                                = (L x y) mod (2 ^ LENGTH('b))"
   assumes is_down: "is_down (ucast :: 'a word \<Rightarrow> 'b word)"
   shows "ucast (M a b) = M' (ucast a) (ucast b)"
   apply (clarsimp simp: word_of_int ucast_def)
   apply (subst lift_M)
   apply (subst of_int_uint [symmetric], subst lift_M')
   apply (subst (1 2) int_word_uint)
   apply (subst word_of_int)
   apply (subst word.abs_eq_iff)
   apply (subst (1 2) bintrunc_mod2p)
   apply (insert is_down)
   apply (unfold is_down_def)
   apply (clarsimp simp: target_size source_size)
   apply (clarsimp simp: mod_mod_power_int min_def)
   apply (rule distrib [symmetric])
   done
 
 lemma ucast_down_add:
     "is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  ucast ((a :: 'a::len word) + b) = (ucast a + ucast b :: 'b::len word)"
   by (rule ucast_distrib [where L="(+)"], (clarsimp simp: uint_word_ariths)+, presburger, simp)
 
 lemma ucast_down_minus:
     "is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  ucast ((a :: 'a::len word) - b) = (ucast a - ucast b :: 'b::len word)"
   apply (rule ucast_distrib [where L="(-)"], (clarsimp simp: uint_word_ariths)+)
   apply (metis mod_diff_left_eq mod_diff_right_eq)
   apply simp
   done
 
 lemma ucast_down_mult:
     "is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  ucast ((a :: 'a::len word) * b) = (ucast a * ucast b :: 'b::len word)"
   apply (rule ucast_distrib [where L="(*)"], (clarsimp simp: uint_word_ariths)+)
   apply (metis mod_mult_eq)
   apply simp
   done
 
 lemma scast_distrib:
   fixes M :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word"
   fixes M' :: "'b::len word \<Rightarrow> 'b::len word \<Rightarrow> 'b::len word"
   fixes L :: "int \<Rightarrow> int \<Rightarrow> int"
   assumes lift_M: "\<And>x y. uint (M x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('a)"
   assumes lift_M': "\<And>x y. uint (M' x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('b)"
   assumes distrib: "\<And>x y. (L (x mod (2 ^ LENGTH('b))) (y mod (2 ^ LENGTH('b)))) mod (2 ^ LENGTH('b))
                                = (L x y) mod (2 ^ LENGTH('b))"
   assumes is_down: "is_down (scast :: 'a word \<Rightarrow> 'b word)"
   shows "scast (M a b) = M' (scast a) (scast b)"
   apply (subst (1 2 3) down_cast_same [symmetric])
    apply (insert is_down)
    apply (clarsimp simp: is_down_def target_size source_size is_down)
   apply (rule ucast_distrib [where L=L, OF lift_M lift_M' distrib])
   apply (insert is_down)
   apply (clarsimp simp: is_down_def target_size source_size is_down)
   done
 
 lemma scast_down_add:
     "is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  scast ((a :: 'a::len word) + b) = (scast a + scast b :: 'b::len word)"
   by (rule scast_distrib [where L="(+)"], (clarsimp simp: uint_word_ariths)+, presburger, simp)
 
 lemma scast_down_minus:
     "is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  scast ((a :: 'a::len word) - b) = (scast a - scast b :: 'b::len word)"
   apply (rule scast_distrib [where L="(-)"], (clarsimp simp: uint_word_ariths)+)
   apply (metis mod_diff_left_eq mod_diff_right_eq)
   apply simp
   done
 
 lemma scast_down_mult:
     "is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  scast ((a :: 'a::len word) * b) = (scast a * scast b :: 'b::len word)"
   apply (rule scast_distrib [where L="(*)"], (clarsimp simp: uint_word_ariths)+)
   apply (metis mod_mult_eq)
   apply simp
   done
 
 lemma scast_ucast_1:
   "\<lbrakk> is_down (ucast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
          (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
   by (metis down_cast_same ucast_def ucast_down_wi)
 
 lemma scast_ucast_3:
   "\<lbrakk> is_down (ucast :: 'a word \<Rightarrow> 'c word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
          (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
   by (metis down_cast_same ucast_def ucast_down_wi)
 
 lemma scast_ucast_4:
   "\<lbrakk> is_up (ucast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
          (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
   by (metis down_cast_same ucast_def ucast_down_wi)
 
 lemma scast_scast_b:
   "\<lbrakk> is_up (scast :: 'a word \<Rightarrow> 'b word) \<rbrakk> \<Longrightarrow>
      (scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
   by (metis scast_def sint_up_scast)
 
 lemma ucast_scast_1:
   "\<lbrakk> is_down (scast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
             (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
   by (metis scast_def ucast_down_wi)
 
 lemma ucast_scast_3:
   "\<lbrakk> is_down (scast :: 'a word \<Rightarrow> 'c word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
      (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
   by (metis scast_def ucast_down_wi)
 
 lemma ucast_scast_4:
   "\<lbrakk> is_up (scast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
      (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
   by (metis down_cast_same scast_def sint_up_scast)
 
 lemma ucast_ucast_a:
   "\<lbrakk> is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
         (ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
   by (metis down_cast_same ucast_def ucast_down_wi)
 
 lemma ucast_ucast_b:
   "\<lbrakk> is_up (ucast :: 'a word \<Rightarrow> 'b word) \<rbrakk> \<Longrightarrow>
      (ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
   by (metis ucast_up_ucast)
 
 lemma scast_scast_a:
   "\<lbrakk> is_down (scast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
             (scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
   apply (clarsimp simp: scast_def)
   apply (metis down_cast_same is_up_down scast_def ucast_down_wi)
   done
 
 lemma scast_down_wi [OF refl]:
   "uc = scast \<Longrightarrow> is_down uc \<Longrightarrow> uc (word_of_int x) = word_of_int x"
   by (metis down_cast_same is_up_down ucast_down_wi)
 
 lemmas cast_simps =
   is_down is_up
   scast_down_add scast_down_minus scast_down_mult
   ucast_down_add ucast_down_minus ucast_down_mult
   scast_ucast_1 scast_ucast_3 scast_ucast_4
   ucast_scast_1 ucast_scast_3 ucast_scast_4
   ucast_ucast_a ucast_ucast_b
   scast_scast_a scast_scast_b
   ucast_down_bl
   ucast_down_wi scast_down_wi
   ucast_of_nat scast_of_nat
   uint_up_ucast sint_up_scast
   up_scast_surj up_ucast_surj
 
 lemma smod_mod_positive:
     "\<lbrakk> 0 \<le> (a :: int); 0 \<le> b \<rbrakk> \<Longrightarrow> a smod b = a mod b"
   by (clarsimp simp: smod_int_alt_def zsgn_def)
 
 lemma nat_mult_power_less_eq:
   "b > 0 \<Longrightarrow> (a * b ^ n < (b :: nat) ^ m) = (a < b ^ (m - n))"
   using mult_less_cancel2[where m = a and k = "b ^ n" and n="b ^ (m - n)"]
         mult_less_cancel2[where m="a * b ^ (n - m)" and k="b ^ m" and n=1]
   apply (simp only: power_add[symmetric] nat_minus_add_max)
   apply (simp only: power_add[symmetric] nat_minus_add_max ac_simps)
   apply (simp add: max_def split: if_split_asm)
   done
 
 lemma signed_shift_guard_to_word:
   "\<lbrakk> n < len_of TYPE ('a); n > 0 \<rbrakk>
     \<Longrightarrow> (unat (x :: 'a :: len word) * 2 ^ y < 2 ^ n)
     = (x = 0 \<or> x < (1 << n >> y))"
   apply (simp only: nat_mult_power_less_eq)
   apply (cases "y \<le> n")
    apply (simp only: shiftl_shiftr1)
    apply (subst less_mask_eq)
     apply (simp add: word_less_nat_alt word_size)
     apply (rule order_less_le_trans[rotated], rule power_increasing[where n=1])
       apply simp
      apply simp
     apply simp
    apply (simp add: nat_mult_power_less_eq word_less_nat_alt word_size)
    apply auto[1]
   apply (simp only: shiftl_shiftr2, simp add: unat_eq_0)
   done
 
 lemma sint_ucast_eq_uint:
     "\<lbrakk> \<not> is_down (ucast :: ('a::len word \<Rightarrow> 'b::len word)) \<rbrakk>
             \<Longrightarrow> sint ((ucast :: ('a::len word \<Rightarrow> 'b::len word)) x) = uint x"
   apply (subst sint_eq_uint)
    apply (clarsimp simp: msb_nth nth_ucast is_down)
    apply (metis Suc_leI Suc_pred bang_conj_lt len_gt_0)
   apply (clarsimp simp: uint_up_ucast is_up is_down)
   done
 
 lemma word_less_nowrapI':
   "(x :: 'a :: len0 word) \<le> z - k \<Longrightarrow> k \<le> z \<Longrightarrow> 0 < k \<Longrightarrow> x < x + k"
   by uint_arith
 
 lemma mask_plus_1:
   "mask n + 1 = 2 ^ n"
   by (clarsimp simp: mask_def)
 
 lemma unat_inj: "inj unat"
   by (metis eq_iff injI word_le_nat_alt)
 
 lemma unat_ucast_upcast:
   "is_up (ucast :: 'b word \<Rightarrow> 'a word)
       \<Longrightarrow> unat (ucast x :: ('a::len) word) = unat (x :: ('b::len) word)"
   unfolding ucast_def unat_def
   apply (subst int_word_uint)
   apply (subst mod_pos_pos_trivial)
     apply simp
    apply (rule lt2p_lem)
    apply (clarsimp simp: is_up)
   apply simp
   done
 
 lemma ucast_mono:
   "\<lbrakk> (x :: 'b :: len word) < y; y < 2 ^ LENGTH('a) \<rbrakk>
    \<Longrightarrow> ucast x < ((ucast y) :: 'a :: len word)"
   apply (simp add: ucast_nat_def [symmetric])
   apply (rule of_nat_mono_maybe)
   apply (rule unat_less_helper)
   apply (simp add: Power.of_nat_power)
   apply (simp add: word_less_nat_alt)
   done
 
 lemma ucast_mono_le:
   "\<lbrakk>x \<le> y; y < 2 ^ LENGTH('b)\<rbrakk> \<Longrightarrow> (ucast (x :: 'a :: len word) :: 'b :: len word) \<le> ucast y"
   apply (simp add: ucast_nat_def [symmetric])
   apply (subst of_nat_mono_maybe_le[symmetric])
     apply (rule unat_less_helper)
     apply (simp add: Power.of_nat_power)
    apply (rule unat_less_helper)
    apply (erule le_less_trans)
    apply (simp add: Power.of_nat_power)
   apply (simp add: word_le_nat_alt)
   done
 
 lemma ucast_mono_le':
   "\<lbrakk> unat y < 2 ^ LENGTH('b); LENGTH('b::len) < LENGTH('a::len); x \<le> y \<rbrakk>
    \<Longrightarrow> UCAST('a \<rightarrow> 'b) x \<le> UCAST('a \<rightarrow> 'b) y"
   by (auto simp: word_less_nat_alt intro: ucast_mono_le)
 
 lemma zero_sle_ucast_up:
   "\<not> is_down (ucast :: 'a word \<Rightarrow> 'b signed word) \<Longrightarrow>
           (0 <=s ((ucast (b::('a::len) word)) :: ('b::len) signed word))"
   apply (subgoal_tac "\<not> msb (ucast b :: 'b signed word)")
    apply (clarsimp simp: word_sle_msb_le)
   apply (clarsimp simp: is_down not_le msb_nth nth_ucast)
   apply (subst (asm) bang_conj_lt [symmetric])
   apply clarsimp
   apply arith
   done
 
 lemma word_le_ucast_sless:
   "\<lbrakk> x \<le> y; y \<noteq> -1; LENGTH('a) < LENGTH('b) \<rbrakk> \<Longrightarrow>
     UCAST (('a :: len) \<rightarrow> ('b :: len) signed) x <s ucast (y + 1)"
   by (clarsimp simp: word_le_make_less word_sless_alt sint_ucast_eq_uint is_down word_less_def)
 
 lemma msb_ucast_eq:
     "LENGTH('a) = LENGTH('b) \<Longrightarrow>
          msb (ucast x :: ('a::len) word) = msb (x :: ('b::len) word)"
   apply (clarsimp simp: word_msb_alt)
   apply (subst ucast_down_drop [where n=0])
    apply (clarsimp simp: source_size_def target_size_def word_size)
   apply clarsimp
   done
 
 lemma msb_big:
      "msb (a :: ('a::len) word) = (a \<ge> 2 ^ (LENGTH('a)  - Suc 0))"
   apply (rule iffI)
    apply (clarsimp simp: msb_nth)
    apply (drule bang_is_le)
    apply simp
   apply (rule ccontr)
   apply (subgoal_tac "a = a && mask (LENGTH('a) - Suc 0)")
    apply (cut_tac and_mask_less' [where w=a and n="LENGTH('a) - Suc 0"])
     apply (clarsimp simp: word_not_le [symmetric])
    apply clarsimp
   apply (rule sym, subst and_mask_eq_iff_shiftr_0)
   apply (clarsimp simp: msb_shift)
   done
 
 lemma zero_sle_ucast:
   "(0 <=s ((ucast (b::('a::len) word)) :: ('a::len) signed word))
                 = (uint b < 2 ^ (len_of (TYPE('a)) - 1))"
   apply (case_tac "msb b")
    apply (clarsimp simp: word_sle_msb_le not_less msb_ucast_eq del: notI)
    apply (clarsimp simp: msb_big word_le_def uint_2p_alt)
   apply (clarsimp simp: word_sle_msb_le not_less msb_ucast_eq del: notI)
   apply (clarsimp simp: msb_big word_le_def uint_2p_alt)
   done
 
 
 (* to_bool / from_bool. *)
 
 definition
   from_bool :: "bool \<Rightarrow> 'a::len word" where
   "from_bool b \<equiv> case b of True \<Rightarrow> of_nat 1
                          | False \<Rightarrow> of_nat 0"
 
 lemma from_bool_0:
   "(from_bool x = 0) = (\<not> x)"
   by (simp add: from_bool_def split: bool.split)
 
 definition
   to_bool :: "'a::len word \<Rightarrow> bool" where
   "to_bool \<equiv> (\<noteq>) 0"
 
 lemma to_bool_and_1:
   "to_bool (x && 1) = (x !! 0)"
   apply (simp add: to_bool_def)
   apply (rule iffI)
    apply (rule classical, erule notE, rule word_eqI)
    apply clarsimp
    apply (case_tac n, simp_all)[1]
   apply (rule notI, drule word_eqD[where x=0])
   apply simp
   done
 
 lemma to_bool_from_bool [simp]:
   "to_bool (from_bool r) = r"
   unfolding from_bool_def to_bool_def
   by (simp split: bool.splits)
 
 lemma from_bool_neq_0 [simp]:
   "(from_bool b \<noteq> 0) = b"
   by (simp add: from_bool_def split: bool.splits)
 
 lemma from_bool_mask_simp [simp]:
   "(from_bool r :: 'a::len word) && 1 = from_bool r"
   unfolding from_bool_def
   by (clarsimp split: bool.splits)
 
 lemma from_bool_1 [simp]:
   "(from_bool P = 1) = P"
   by (simp add: from_bool_def split: bool.splits)
 
 lemma ge_0_from_bool [simp]:
   "(0 < from_bool P) = P"
   by (simp add: from_bool_def split: bool.splits)
 
 lemma limited_and_from_bool:
   "limited_and (from_bool b) 1"
   by (simp add: from_bool_def limited_and_def split: bool.split)
 
 lemma to_bool_1 [simp]: "to_bool 1" by (simp add: to_bool_def)
 lemma to_bool_0 [simp]: "\<not>to_bool 0" by (simp add: to_bool_def)
 
 lemma from_bool_eq_if:
   "(from_bool Q = (if P then 1 else 0)) = (P = Q)"
   by (simp add: case_bool_If from_bool_def split: if_split)
 
 lemma to_bool_eq_0:
   "(\<not> to_bool x) = (x = 0)"
   by (simp add: to_bool_def)
 
 lemma to_bool_neq_0:
   "(to_bool x) = (x \<noteq> 0)"
   by (simp add: to_bool_def)
 
 lemma from_bool_all_helper:
   "(\<forall>bool. from_bool bool = val \<longrightarrow> P bool)
       = ((\<exists>bool. from_bool bool = val) \<longrightarrow> P (val \<noteq> 0))"
   by (auto simp: from_bool_0)
 
 lemma from_bool_to_bool_iff:
   "w = from_bool b \<longleftrightarrow> to_bool w = b \<and> (w = 0 \<or> w = 1)"
   by (cases b) (auto simp: from_bool_def to_bool_def)
 
 lemma word_rsplit_upt:
   "\<lbrakk> size x = LENGTH('a :: len) * n; n \<noteq> 0 \<rbrakk>
     \<Longrightarrow> word_rsplit x = map (\<lambda>i. ucast (x >> i * len_of TYPE ('a)) :: 'a word) (rev [0 ..< n])"
   apply (subgoal_tac "length (word_rsplit x :: 'a word list) = n")
    apply (rule nth_equalityI, simp)
    apply (intro allI word_eqI impI)
    apply (simp add: test_bit_rsplit_alt word_size)
    apply (simp add: nth_ucast nth_shiftr nth_rev field_simps)
   apply (simp add: length_word_rsplit_exp_size)
   apply (metis mult.commute given_quot_alt word_size word_size_gt_0)
   done
 
 lemma aligned_shift:
   "\<lbrakk>x < 2 ^ n; is_aligned (y :: 'a :: len word) n;n \<le> LENGTH('a)\<rbrakk>
    \<Longrightarrow> x + y >> n = y >> n"
   apply (subst word_plus_and_or_coroll)
    apply (rule word_eqI)
    apply (clarsimp simp: is_aligned_nth)
    apply (drule(1) nth_bounded)
     apply simp
    apply simp
   apply (rule word_eqI)
   apply (simp add: nth_shiftr)
   apply safe
   apply (drule(1) nth_bounded)
   apply simp+
   done
 
 lemma aligned_shift':
   "\<lbrakk>x < 2 ^ n; is_aligned (y :: 'a :: len word) n;n \<le> LENGTH('a)\<rbrakk>
    \<Longrightarrow> y + x >> n = y >> n"
   apply (subst word_plus_and_or_coroll)
    apply (rule word_eqI)
    apply (clarsimp simp: is_aligned_nth)
    apply (drule(1) nth_bounded)
     apply simp
    apply simp
   apply (rule word_eqI)
   apply (simp add: nth_shiftr)
   apply safe
   apply (drule(1) nth_bounded)
   apply simp+
   done
 
 lemma neg_mask_add_mask:
   "((x:: 'a :: len word) && ~~ mask n) + (2 ^ n - 1) = x || mask n"
   apply (simp add:mask_2pm1[symmetric])
   apply (rule word_eqI[rule_format])
   apply (rule iffI)
     apply (clarsimp simp:word_size not_less)
     apply (cut_tac w = "((x && ~~ mask n) + mask n)" and
       m = n and n = "na - n" in nth_shiftr[symmetric])
     apply clarsimp
     apply (subst (asm) aligned_shift')
   apply (simp add:mask_lt_2pn nth_shiftr is_aligned_neg_mask word_size)+
   apply (case_tac "na<n")
     apply clarsimp
     apply (subst word_plus_and_or_coroll)
     apply (rule iffD1[OF is_aligned_mask])
     apply (simp add:is_aligned_neg_mask word_size not_less)+
   apply (cut_tac w = "((x && ~~ mask n) + mask n)" and
       m = n and n = "na - n" in nth_shiftr[symmetric])
   apply clarsimp
   apply (subst (asm) aligned_shift')
   apply (simp add:mask_lt_2pn is_aligned_neg_mask nth_shiftr neg_mask_bang)+
 done
 
 lemma subtract_mask:
   "p - (p && mask n) = (p && ~~ mask n)"
   "p - (p && ~~ mask n) = (p && mask n)"
   by (simp add: field_simps word_plus_and_or_coroll2)+
 
 lemma and_neg_mask_plus_mask_mono: "(p && ~~ mask n) + mask n \<ge> p"
   apply (rule word_le_minus_cancel[where x = "p && ~~ mask n"])
    apply (clarsimp simp: subtract_mask)
    using word_and_le1[where a = "mask n" and y = p]
    apply (clarsimp simp: mask_def word_le_less_eq)
   apply (rule is_aligned_no_overflow'[folded mask_2pm1])
   apply (clarsimp simp: is_aligned_neg_mask)
   done
 
 lemma word_neg_and_le:
   "ptr \<le> (ptr && ~~ mask n) + (2 ^ n - 1)"
   by (simp add: and_neg_mask_plus_mask_mono mask_2pm1[symmetric])
 
 lemma aligned_less_plus_1:
   "\<lbrakk> is_aligned x n; n > 0 \<rbrakk> \<Longrightarrow> x < x + 1"
   apply (rule plus_one_helper2)
    apply (rule order_refl)
   apply (clarsimp simp: field_simps)
   apply (drule arg_cong[where f="\<lambda>x. x - 1"])
   apply (clarsimp simp: is_aligned_mask)
   apply (drule word_eqD[where x=0])
   apply simp
   done
 
 lemma aligned_add_offset_less:
   "\<lbrakk>is_aligned x n; is_aligned y n; x < y; z < 2 ^ n\<rbrakk> \<Longrightarrow> x + z < y"
   apply (cases "y = 0")
    apply simp
   apply (erule is_aligned_get_word_bits[where p=y], simp_all)
   apply (cases "z = 0", simp_all)
   apply (drule(2) aligned_at_least_t2n_diff[rotated -1])
   apply (drule plus_one_helper2)
    apply (rule less_is_non_zero_p1)
    apply (rule aligned_less_plus_1)
     apply (erule aligned_sub_aligned[OF _ _ order_refl],
            simp_all add: is_aligned_triv)[1]
    apply (cases n, simp_all)[1]
   apply (simp only: trans[OF diff_add_eq diff_diff_eq2[symmetric]])
   apply (drule word_less_add_right)
    apply (rule ccontr, simp add: linorder_not_le)
    apply (drule aligned_small_is_0, erule order_less_trans)
     apply (clarsimp simp: power_overflow)
    apply simp
   apply (erule order_le_less_trans[rotated],
          rule word_plus_mono_right)
    apply (erule minus_one_helper3)
   apply (simp add: is_aligned_no_wrap' is_aligned_no_overflow field_simps)
   done
 
 lemma is_aligned_add_helper:
   "\<lbrakk> is_aligned p n; d < 2 ^ n \<rbrakk>
      \<Longrightarrow> (p + d && mask n = d) \<and> (p + d && (~~ mask n) = p)"
   apply (subst(asm) is_aligned_mask)
   apply (drule less_mask_eq)
   apply (rule context_conjI)
    apply (subst word_plus_and_or_coroll)
     apply (rule word_eqI)
     apply (drule_tac x=na in word_eqD)+
     apply (simp add: word_size)
     apply blast
    apply (rule word_eqI)
    apply (drule_tac x=na in word_eqD)+
    apply (simp add: word_ops_nth_size word_size)
    apply blast
   apply (insert word_plus_and_or_coroll2[where x="p + d" and w="mask n"])
   apply simp
   done
 
 lemma is_aligned_sub_helper:
   "\<lbrakk> is_aligned (p - d) n; d < 2 ^ n \<rbrakk>
      \<Longrightarrow> (p && mask n = d) \<and> (p && (~~ mask n) = p - d)"
   by (drule(1) is_aligned_add_helper, simp)
 
 lemma mask_twice:
   "(x && mask n) && mask m = x && mask (min m n)"
   apply (rule word_eqI)
   apply (simp add: word_size conj_comms)
   done
 
 lemma is_aligned_after_mask:
   "\<lbrakk>is_aligned k m;m\<le> n\<rbrakk> \<Longrightarrow> is_aligned (k && mask n) m"
   by (rule is_aligned_andI1)
 
 lemma and_mask_plus:
   "\<lbrakk>is_aligned ptr m; m \<le> n; a < 2 ^ m\<rbrakk>
    \<Longrightarrow> ptr + a && mask n = (ptr && mask n) + a"
   apply (rule mask_eqI[where n = m])
    apply (simp add:mask_twice min_def)
     apply (simp add:is_aligned_add_helper)
     apply (subst is_aligned_add_helper[THEN conjunct1])
       apply (erule is_aligned_after_mask)
      apply simp
     apply simp
    apply simp
   apply (subgoal_tac "(ptr + a && mask n) && ~~ mask m
      = (ptr + a && ~~ mask m ) && mask n")
    apply (simp add:is_aligned_add_helper)
    apply (subst is_aligned_add_helper[THEN conjunct2])
      apply (simp add:is_aligned_after_mask)
     apply simp
    apply simp
   apply (simp add:word_bw_comms word_bw_lcs)
   done
 
 lemma le_step_down_word:"\<lbrakk>(i::('a::len) word) \<le> n; i = n \<longrightarrow> P; i \<le> n - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   by unat_arith
 
 lemma le_step_down_word_2:
   fixes x :: "'a::len word"
   shows "\<lbrakk>x \<le>  y; x \<noteq> y\<rbrakk> \<Longrightarrow> x \<le> y - 1"
   by (subst (asm) word_le_less_eq,
       clarsimp,
       simp add: minus_one_helper3)
 
 lemma NOT_mask_AND_mask[simp]: "(w && mask n) && ~~ mask n = 0"
   apply (clarsimp simp:mask_def)
   by (metis word_bool_alg.conj_cancel_right word_bool_alg.conj_zero_right word_bw_comms(1) word_bw_lcs(1))
 
 lemma and_and_not[simp]:"(a && b) && ~~ b = 0"
   apply (subst word_bw_assocs(1))
   apply clarsimp
   done
 
 lemma mask_shift_and_negate[simp]:"(w && mask n << m) && ~~ (mask n << m) = 0"
   apply (clarsimp simp:mask_def)
   by (metis (erased, hide_lams) mask_eq_x_eq_0 shiftl_over_and_dist word_bool_alg.conj_absorb word_bw_assocs(1))
 
 lemma le_step_down_nat:"\<lbrakk>(i::nat) \<le> n; i = n \<longrightarrow> P; i \<le> n - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   by arith
 
 lemma le_step_down_int:"\<lbrakk>(i::int) \<le> n; i = n \<longrightarrow> P; i \<le> n - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   by arith
 
 lemma mask_1[simp]: "(\<exists>x. mask x = 1)"
   apply (rule_tac x=1 in exI)
   apply (simp add:mask_def)
   done
 
 lemma not_switch:"~~ a = x \<Longrightarrow> a = ~~ x"
   by auto
 
 (* The seL4 bitfield generator produces functions containing mask and shift operations, such that
  * invoking two of them consecutively can produce something like the following.
  *)
 lemma bitfield_op_twice:
   "(x && ~~ (mask n << m) || ((y && mask n) << m)) && ~~ (mask n << m) = x && ~~ (mask n << m)"
   by (induct n arbitrary: m) (auto simp: word_ao_dist)
 
 lemma bitfield_op_twice'':
   "\<lbrakk>~~ a = b << c; \<exists>x. b = mask x\<rbrakk> \<Longrightarrow> (x && a || (y && b << c)) && a = x && a"
   apply clarsimp
   apply (cut_tac n=xa and m=c and x=x and y=y in bitfield_op_twice)
   apply (clarsimp simp:mask_def)
   apply (drule not_switch)
   apply clarsimp
   done
 
 lemma bit_twiddle_min:
   "(y::'a::len word) xor (((x::'a::len word) xor y) && (if x < y then -1 else 0)) = min x y"
   by (metis (mono_tags) min_def word_bitwise_m1_simps(2) word_bool_alg.xor_left_commute
              word_bool_alg.xor_self word_bool_alg.xor_zero_right word_bw_comms(1)
              word_le_less_eq word_log_esimps(7))
 
 lemma bit_twiddle_max:
   "(x::'a::len word) xor (((x::'a::len word) xor y) && (if x < y then -1 else 0)) = max x y"
   by (metis (mono_tags) max_def word_bitwise_m1_simps(2) word_bool_alg.xor_left_self
             word_bool_alg.xor_zero_right word_bw_comms(1) word_le_less_eq word_log_esimps(7))
 
 lemma swap_with_xor:
   "\<lbrakk>(x::'a::len word) = a xor b; y = b xor x; z = x xor y\<rbrakk> \<Longrightarrow> z = b \<and> y = a"
   by (metis word_bool_alg.xor_assoc word_bool_alg.xor_commute word_bool_alg.xor_self
             word_bool_alg.xor_zero_right)
 
 lemma scast_nop_1:
   "((scast ((of_int x)::('a::len) word))::'a sword) = of_int x"
   apply (clarsimp simp:scast_def word_of_int)
   by (metis len_signed sint_sbintrunc' word_sint.Rep_inverse)
 
 lemma scast_nop_2:
   "((scast ((of_int x)::('a::len) sword))::'a word) = of_int x"
   apply (clarsimp simp:scast_def word_of_int)
   by (metis len_signed sint_sbintrunc' word_sint.Rep_inverse)
 
 lemmas scast_nop[simp] = scast_nop_1 scast_nop_2 scast_id
 
 lemma le_mask_imp_and_mask:
   "(x::'a::len word) \<le> mask n \<Longrightarrow> x && mask n = x"
   by (metis and_mask_eq_iff_le_mask)
 
 lemma or_not_mask_nop:
   "((x::'a::len word) || ~~ mask n) && mask n = x && mask n"
   by (metis word_and_not word_ao_dist2 word_bw_comms(1) word_log_esimps(3))
 
 lemma mask_subsume:
   "\<lbrakk>n \<le> m\<rbrakk> \<Longrightarrow> ((x::'a::len word) || y && mask n) && ~~ mask m = x && ~~ mask m"
   apply (subst word_ao_dist)
   apply (subgoal_tac "(y && mask n) && ~~ mask m = 0")
    apply simp
   by (metis (no_types, hide_lams) is_aligned_mask is_aligned_weaken word_and_not
             word_bool_alg.conj_zero_right word_bw_comms(1) word_bw_lcs(1))
 
 lemma mask_twice2:
   "n \<le> m \<Longrightarrow> ((x::'a::len word) && mask m) && mask n = x && mask n"
   by (metis mask_twice min_def)
 
 lemma uint_2_id:
   "LENGTH('a) \<ge> 2 \<Longrightarrow> uint (2::('a::len) word) = 2"
   apply clarsimp
   apply (subgoal_tac "2 \<in> uints (LENGTH('a))")
    apply (subst (asm) Word.word_ubin.set_iff_norm)
    apply simp
   apply (subst word_uint.set_iff_norm)
   apply clarsimp
   apply (rule int_mod_eq')
    apply simp
   apply (rule pow_2_gt)
   apply simp
   done
 
 lemma bintrunc_id:
   "\<lbrakk>m \<le> of_nat n; 0 < m\<rbrakk> \<Longrightarrow> bintrunc n m = m"
   by (simp add: bintrunc_mod2p le_less_trans)
 
 lemma shiftr1_unfold: "shiftr1 x = x >> 1"
   by (metis One_nat_def comp_apply funpow.simps(1) funpow.simps(2) id_apply shiftr_def)
 
 lemma shiftr1_is_div_2: "(x::('a::len) word) >> 1 = x div 2"
   apply (case_tac "LENGTH('a) = 1")
    apply simp
  apply (subgoal_tac "x = 0 \<or> x = 1")
     apply (erule disjE)
      apply (clarsimp simp:word_div_def)+
    apply (metis One_nat_def less_irrefl_nat sint_1_cases)
   apply clarsimp
   apply (subst word_div_def)
   apply clarsimp
   apply (subst bintrunc_id)
     apply (subgoal_tac "2 \<le> LENGTH('a)")
      apply simp
     apply (metis (no_types) le_0_eq le_SucE lens_not_0(2) not_less_eq_eq numeral_2_eq_2)
    apply simp
   apply (subst bin_rest_def[symmetric])
   apply (subst shiftr1_def[symmetric])
   apply (clarsimp simp:shiftr1_unfold)
   done
 
 lemma shiftl1_is_mult: "(x << 1) = (x :: 'a::len word) * 2"
   by (metis One_nat_def mult_2 mult_2_right one_add_one
         power_0 power_Suc shiftl_t2n)
 
 lemma div_of_0_id[simp]:"(0::('a::len) word) div n = 0"
   by (simp add: word_div_def)
 
 lemma degenerate_word:"LENGTH('a) = 1 \<Longrightarrow> (x::('a::len) word) = 0 \<or> x = 1"
   by (metis One_nat_def less_irrefl_nat sint_1_cases)
 
 lemma div_by_0_word:"(x::('a::len) word) div 0 = 0"
   by (metis div_0 div_by_0 unat_0 word_arith_nat_defs(6) word_div_1)
 
 lemma div_less_dividend_word:"\<lbrakk>x \<noteq> 0; n \<noteq> 1\<rbrakk> \<Longrightarrow> (x::('a::len) word) div n < x"
   apply (case_tac "n = 0")
    apply clarsimp
    apply (subst div_by_0_word)
    apply (simp add:word_neq_0_conv)
   apply (subst word_arith_nat_div)
   apply (rule word_of_nat_less)
   apply (rule div_less_dividend)
    apply (metis (poly_guards_query) One_nat_def less_one nat_neq_iff unat_eq_1(2) unat_eq_zero)
   apply (simp add:unat_gt_0)
   done
 
 lemma shiftr1_lt:"x \<noteq> 0 \<Longrightarrow> (x::('a::len) word) >> 1 < x"
   apply (subst shiftr1_is_div_2)
   apply (rule div_less_dividend_word)
    apply simp+
   done
 
 lemma word_less_div:
   fixes x :: "('a::len) word"
     and y :: "('a::len) word"
   shows "x div y = 0 \<Longrightarrow> y = 0 \<or> x < y"
   apply (case_tac "y = 0", clarsimp+)
   by (metis One_nat_def Suc_le_mono le0 le_div_geq not_less unat_0 unat_div unat_gt_0 word_less_nat_alt zero_less_one)
 
 lemma not_degenerate_imp_2_neq_0:"LENGTH('a) > 1 \<Longrightarrow> (2::('a::len) word) \<noteq> 0"
   by (metis numerals(1) power_not_zero power_zero_numeral)
 
 lemma shiftr1_0_or_1:"(x::('a::len) word) >> 1 = 0 \<Longrightarrow> x = 0 \<or> x = 1"
   apply (subst (asm) shiftr1_is_div_2)
   apply (drule word_less_div)
   apply (case_tac "LENGTH('a) = 1")
    apply (simp add:degenerate_word)
   apply (erule disjE)
    apply (subgoal_tac "(2::'a word) \<noteq> 0")
     apply simp
    apply (rule not_degenerate_imp_2_neq_0)
    apply (subgoal_tac "LENGTH('a) \<noteq> 0")
     apply arith
    apply simp
   apply (rule x_less_2_0_1', simp+)
   done
 
 lemma word_overflow:"(x::('a::len) word) + 1 > x \<or> x + 1 = 0"
   apply clarsimp
   by (metis diff_0 eq_diff_eq less_x_plus_1 max_word_max plus_1_less)
 
 lemma word_overflow_unat:"unat ((x::('a::len) word) + 1) = unat x + 1 \<or> x + 1 = 0"
   by (metis Suc_eq_plus1 add.commute unatSuc)
 
 lemma even_word_imp_odd_next:"even (unat (x::('a::len) word)) \<Longrightarrow> x + 1 = 0 \<or> odd (unat (x + 1))"
   apply (cut_tac x=x in word_overflow_unat)
   apply clarsimp
   done
 
 lemma odd_word_imp_even_next:"odd (unat (x::('a::len) word)) \<Longrightarrow> x + 1 = 0 \<or> even (unat (x + 1))"
   apply (cut_tac x=x in word_overflow_unat)
   apply clarsimp
   done
 
 lemma overflow_imp_lsb:"(x::('a::len) word) + 1 = 0 \<Longrightarrow> x !! 0"
   by (metis add.commute add_left_cancel max_word_max not_less word_and_1 word_bool_alg.conj_one_right word_bw_comms(1) word_overflow zero_neq_one)
 
 lemma word_lsb_nat:"lsb w = (unat w mod 2 = 1)"
   unfolding word_lsb_def bin_last_def
   by (metis (no_types, hide_lams) nat_mod_distrib nat_numeral not_mod_2_eq_1_eq_0 numeral_One uint_eq_0 uint_nonnegative unat_0 unat_def zero_le_numeral)
 
 lemma odd_iff_lsb:"odd (unat (x::('a::len) word)) = x !! 0"
   apply (simp add:even_iff_mod_2_eq_zero)
   apply (subst word_lsb_nat[unfolded One_nat_def, symmetric])
   apply (rule word_lsb_alt)
   done
 
 lemma of_nat_neq_iff_word:
       "x mod 2 ^ LENGTH('a) \<noteq> y mod 2 ^ LENGTH('a) \<Longrightarrow>
          (((of_nat x)::('a::len) word) \<noteq> of_nat y) = (x \<noteq> y)"
   apply (rule iffI)
    apply (case_tac "x = y")
    apply (subst (asm) of_nat_eq_iff[symmetric])
    apply simp+
   apply (case_tac "((of_nat x)::('a::len) word) = of_nat y")
    apply (subst (asm) word_unat.norm_eq_iff[symmetric])
    apply simp+
   done
 
 lemma shiftr1_irrelevant_lsb:"(x::('a::len) word) !! 0 \<or> x >> 1 = (x + 1) >> 1"
   apply (case_tac "LENGTH('a) = 1")
    apply clarsimp
    apply (drule_tac x=x in degenerate_word[unfolded One_nat_def])
    apply (erule disjE)
     apply clarsimp+
   apply (subst (asm) shiftr1_is_div_2[unfolded One_nat_def])+
   apply (subst (asm) word_arith_nat_div)+
   apply clarsimp
   apply (subst (asm) bintrunc_id)
     apply (subgoal_tac "LENGTH('a) > 0")
      apply linarith
     apply clarsimp+
   apply (subst (asm) bintrunc_id)
     apply (subgoal_tac "LENGTH('a) > 0")
      apply linarith
     apply clarsimp+
   apply (case_tac "x + 1 = 0")
    apply (clarsimp simp:overflow_imp_lsb)
   apply (cut_tac x=x in word_overflow_unat)
   apply clarsimp
   apply (case_tac "even (unat x)")
    apply (subgoal_tac "unat x div 2 = Suc (unat x) div 2")
     apply metis
    apply (subst numeral_2_eq_2)+
    apply simp
   apply (simp add:odd_iff_lsb)
   done
 
 lemma shiftr1_0_imp_only_lsb:"((x::('a::len) word) + 1) >> 1 = 0 \<Longrightarrow> x = 0 \<or> x + 1 = 0"
   by (metis One_nat_def shiftr1_0_or_1 word_less_1 word_overflow)
 
 lemma shiftr1_irrelevant_lsb':"\<not>((x::('a::len) word) !! 0) \<Longrightarrow> x >> 1 = (x + 1) >> 1"
   by (metis shiftr1_irrelevant_lsb)
 
 lemma lsb_this_or_next:"\<not>(((x::('a::len) word) + 1) !! 0) \<Longrightarrow> x !! 0"
   by (metis (poly_guards_query) even_word_imp_odd_next odd_iff_lsb overflow_imp_lsb)
 
 (* Perhaps this one should be a simp lemma, but it seems a little dangerous. *)
 lemma cast_chunk_assemble_id:
   "\<lbrakk>n = LENGTH('a::len); m = LENGTH('b::len); n * 2 = m\<rbrakk> \<Longrightarrow>
   (((ucast ((ucast (x::'b word))::'a word))::'b word) || (((ucast ((ucast (x >> n))::'a word))::'b word) << n)) = x"
   apply (subgoal_tac "((ucast ((ucast (x >> n))::'a word))::'b word) = x >> n")
    apply clarsimp
    apply (subst and_not_mask[symmetric])
    apply (subst ucast_ucast_mask)
    apply (subst word_ao_dist2[symmetric])
    apply clarsimp
   apply (rule ucast_ucast_len)
   apply (rule shiftr_less_t2n')
    apply (subst and_mask_eq_iff_le_mask)
    apply (clarsimp simp:mask_def)
    apply (metis max_word_eq max_word_max mult_2_right)
   apply (metis add_diff_cancel_left' diff_less len_gt_0 mult_2_right)
   done
 
 lemma cast_chunk_scast_assemble_id:
   "\<lbrakk>n = LENGTH('a::len); m = LENGTH('b::len); n * 2 = m\<rbrakk> \<Longrightarrow>
   (((ucast ((scast (x::'b word))::'a word))::'b word) ||
    (((ucast ((scast (x >> n))::'a word))::'b word) << n)) = x"
   apply (subgoal_tac "((scast x)::'a word) = ((ucast x)::'a word)")
    apply (subgoal_tac "((scast (x >> n))::'a word) = ((ucast (x >> n))::'a word)")
     apply (simp add:cast_chunk_assemble_id)
    apply (subst down_cast_same[symmetric], subst is_down, arith, simp)+
   done
 
 lemma mask_or_not_mask:
   "x && mask n || x && ~~ mask n = x"
   apply (subst word_oa_dist, simp)
   apply (subst word_oa_dist2, simp)
   done
 
 lemma is_aligned_add_not_aligned:
   "\<lbrakk>is_aligned (p::'a::len word) n; \<not> is_aligned (q::'a::len word) n\<rbrakk> \<Longrightarrow> \<not> is_aligned (p + q) n"
   by (metis is_aligned_addD1)
 
 lemma word_gr0_conv_Suc: "(m::'a::len word) > 0 \<Longrightarrow> \<exists>n. m = n + 1"
   by (metis add.commute add_minus_cancel)
 
 lemma neg_mask_add_aligned:
   "\<lbrakk> is_aligned p n; q < 2 ^ n \<rbrakk> \<Longrightarrow> (p + q) && ~~ mask n = p && ~~ mask n"
   by (metis is_aligned_add_helper is_aligned_neg_mask_eq)
 
 lemma word_sless_sint_le:"x <s y \<Longrightarrow> sint x \<le> sint y - 1"
   by (metis word_sless_alt zle_diff1_eq)
 
 
 lemma upper_trivial:
   fixes x :: "'a::len word"
   shows "x \<noteq> 2 ^ LENGTH('a) - 1 \<Longrightarrow> x < 2 ^ LENGTH('a) - 1"
   by (cut_tac n=x and 'a='a in max_word_max,
       clarsimp simp:max_word_def,
       simp add: less_le)
 
 lemma constraint_expand:
   fixes x :: "'a::len word"
   shows "x \<in> {y. lower \<le> y \<and> y \<le> upper} = (lower \<le> x \<and> x \<le> upper)"
   by (rule mem_Collect_eq)
 
 lemma card_map_elide:
   "card ((of_nat :: nat \<Rightarrow> 'a::len word) ` {0..<n}) = card {0..<n}"
     if "n \<le> CARD('a::len word)"
 proof -
   let ?of_nat = "of_nat :: nat \<Rightarrow> 'a word"
   from word_unat.Abs_inj_on
   have "inj_on ?of_nat {i. i < CARD('a word)}"
     by (simp add: unats_def card_word)
   moreover have "{0..<n} \<subseteq> {i. i < CARD('a word)}"
     using that by auto
   ultimately have "inj_on ?of_nat {0..<n}"
     by (rule inj_on_subset)
   then show ?thesis
     by (simp add: card_image)
 qed
 
 lemma card_map_elide2:
   "n \<le> CARD('a::len word) \<Longrightarrow> card ((of_nat::nat \<Rightarrow> 'a::len word) ` {0..<n}) = n"
   by (subst card_map_elide) clarsimp+
 
 lemma le_max_word_ucast_id:
   assumes "(x::'a::len word) \<le> ucast (max_word::'b::len word)"
   shows "ucast ((ucast x)::'b word) = x"
 proof -
   {
     assume a1: "x \<le> word_of_int (uint (word_of_int (2 ^ len_of (TYPE('b)) - 1)::'b word))"
     have f2: "((\<exists>i ia. (0::int) \<le> i \<and> \<not> 0 \<le> i + - 1 * ia \<and> i mod ia \<noteq> i) \<or>
               \<not> (0::int) \<le> - 1 + 2 ^ LENGTH('b) \<or> (0::int) \<le> - 1 + 2 ^ LENGTH('b) + - 1 * 2 ^ LENGTH('b) \<or>
               (- (1::int) + 2 ^ LENGTH('b)) mod 2 ^ LENGTH('b) =
                 - 1 + 2 ^ LENGTH('b)) = ((\<exists>i ia. (0::int) \<le> i \<and> \<not> 0 \<le> i + - 1 * ia \<and> i mod ia \<noteq> i) \<or>
               \<not> (1::int) \<le> 2 ^ LENGTH('b) \<or>
               2 ^ LENGTH('b) + - (1::int) * ((- 1 + 2 ^ LENGTH('b)) mod 2 ^ LENGTH('b)) = 1)"
       by force
     have f3: "\<forall>i ia. \<not> (0::int) \<le> i \<or> 0 \<le> i + - 1 * ia \<or> i mod ia = i"
       using mod_pos_pos_trivial by force
     have "(1::int) \<le> 2 ^ LENGTH('b)"
       by simp
     then have "2 ^ LENGTH('b) + - (1::int) * ((- 1 + 2 ^ LENGTH('b)) mod 2 ^ len_of TYPE ('b)) = 1"
       using f3 f2 by blast
     then have f4: "- (1::int) + 2 ^ LENGTH('b) = (- 1 + 2 ^ LENGTH('b)) mod 2 ^ LENGTH('b)"
       by linarith
     have f5: "x \<le> word_of_int (uint (word_of_int (- 1 + 2 ^ LENGTH('b))::'b word))"
       using a1 by force
     have f6: "2 ^ len_of (TYPE('b)::'b itself) + - (1::int) = - 1 + 2 ^ len_of (TYPE('b))"
       by force
     have f7: "- (1::int) * 1 = - 1"
       by auto
     have "\<forall>x0 x1. (x1::int) - x0 = x1 + - 1 * x0"
       by force
     then have "x \<le> 2 ^ LENGTH('b) - 1"
       using f7 f6 f5 f4 by (metis uint_word_of_int wi_homs(2) word_arith_wis(8) word_of_int_2p)
   }
   with assms show ?thesis
     unfolding ucast_def
     apply (subst word_ubin.eq_norm)
     apply (subst and_mask_bintr[symmetric])
     apply (subst and_mask_eq_iff_le_mask)
     apply (clarsimp simp: max_word_def mask_def)
     done
 qed
 
 lemma remdups_enum_upto:
   fixes s::"'a::len word"
   shows "remdups [s .e. e] = [s .e. e]"
   by simp
 
 lemma card_enum_upto:
   fixes s::"'a::len word"
   shows "card (set [s .e. e]) = Suc (unat e) - unat s"
   by (subst List.card_set) (simp add: remdups_enum_upto)
 
 lemma unat_mask:
   "unat (mask n :: 'a :: len word) = 2 ^ (min n (LENGTH('a))) - 1"
   apply (subst min.commute)
   apply (simp add: mask_def not_less min_def  split: if_split_asm)
   apply (intro conjI impI)
    apply (simp add: unat_sub_if_size)
    apply (simp add: power_overflow word_size)
   apply (simp add: unat_sub_if_size)
   done
 
 lemma word_shiftr_lt:
   fixes w :: "'a::len word"
   shows "unat (w >> n) < (2 ^ (len_of(TYPE('a)) - n))"
   apply (subst shiftr_div_2n')
   by (metis nat_mod_lem nat_zero_less_power_iff power_mod_div
       word_unat.Rep_inverse word_unat.eq_norm zero_less_numeral)
 
 lemma complement_nth_w2p:
   shows "n' < len_of(TYPE('a)) \<Longrightarrow> (~~ (2 ^ n :: ('a::len word))) !! n' = (n' \<noteq> n)"
   by (fastforce simp: word_ops_nth_size word_size nth_w2p)
 
 lemma word_unat_and_lt:
   "unat x < n \<or> unat y < n \<Longrightarrow> unat (x && y) < n"
   by (meson le_less_trans word_and_le1 word_and_le2 word_le_nat_alt)
 
 lemma word_unat_mask_lt:
   "m \<le> size w \<Longrightarrow> unat ((w::'a::len word) && mask m) < 2 ^ m"
   by (rule word_unat_and_lt) (simp add: unat_mask word_size)
 
 lemma unat_shiftr_less_t2n:
   fixes x :: "'a :: len word"
   shows "unat x < 2 ^ (n + m) \<Longrightarrow> unat (x >> n) < 2 ^ m"
   by (simp add: shiftr_div_2n' power_add mult.commute td_gal_lt)
 
 lemma le_or_mask:
   "w \<le> w' \<Longrightarrow> w || mask x \<le> w' || mask x"
   by (metis neg_mask_add_mask add.commute le_word_or1 mask_2pm1 neg_mask_mono_le word_plus_mono_left)
 
 lemma le_shiftr1':
   "\<lbrakk> shiftr1 u \<le> shiftr1 v ; shiftr1 u \<noteq> shiftr1 v \<rbrakk> \<Longrightarrow> u \<le> v"
   apply (unfold word_le_def shiftr1_def word_ubin.eq_norm)
   apply (unfold bin_rest_trunc_i
                 trans [OF bintrunc_bintrunc_l word_ubin.norm_Rep,
                           unfolded word_ubin.norm_Rep,
                        OF order_refl [THEN le_SucI]])
   apply (case_tac "uint u" rule: bin_exhaust)
   apply (rename_tac bs bit)
   apply (case_tac "uint v" rule: bin_exhaust)
   apply (rename_tac bs' bit')
   apply (case_tac "bit")
    apply (case_tac "bit'", auto simp: less_eq_int_code le_Bits intro: basic_trans_rules)[1]
   apply (case_tac bit')
    apply (simp add: le_Bits less_eq_int_code)
   apply (auto simp: le_Bits less_eq_int_code)
   done
 
 lemma le_shiftr':
   "\<lbrakk> u >> n \<le> v >> n ; u >> n \<noteq> v >> n \<rbrakk> \<Longrightarrow> (u::'a::len0 word) \<le> v"
   apply (induct n, simp)
   apply (unfold shiftr_def)
   apply (case_tac "(shiftr1 ^^ n) u = (shiftr1 ^^ n) v")
    apply simp
   apply (fastforce dest: le_shiftr1')
   done
 
 lemma word_log2_nth_same:
   "w \<noteq> 0 \<Longrightarrow> w !! word_log2 w"
   unfolding word_log2_def
   using nth_length_takeWhile[where P=Not and xs="to_bl w"]
   apply (simp add: word_clz_def word_size to_bl_nth)
   apply (fastforce simp: linorder_not_less eq_zero_set_bl
                    dest: takeWhile_take_has_property)
   done
 
 lemma word_log2_nth_not_set:
   "\<lbrakk> word_log2 w < i ; i < size w \<rbrakk> \<Longrightarrow> \<not> w !! i"
   unfolding word_log2_def word_clz_def
   using takeWhile_take_has_property_nth[where P=Not and xs="to_bl w" and n="size w - Suc i"]
   by (fastforce simp add: to_bl_nth word_size)
 
 lemma word_log2_highest:
   assumes a: "w !! i"
   shows "i \<le> word_log2 w"
 proof -
   from a have "i < size w" by - (rule test_bit_size)
   with a show ?thesis
     by - (rule ccontr, simp add: word_log2_nth_not_set)
 qed
 
 lemma word_log2_max:
   "word_log2 w < size w"
   unfolding word_log2_def word_clz_def
   by simp
 
 lemma word_clz_0[simp]:
   "word_clz (0::'a::len word) \<equiv> len_of (TYPE('a))"
   unfolding word_clz_def
   by (simp add: takeWhile_replicate)
 
 lemma word_clz_minus_one[simp]:
   "word_clz (-1::'a::len word) \<equiv> 0"
   unfolding word_clz_def
   by (simp add: max_word_bl[simplified max_word_minus] takeWhile_replicate)
 
 lemma word_add_no_overflow:"(x::'a::len word) < max_word \<Longrightarrow> x < x + 1"
   using less_x_plus_1 order_less_le by blast
 
 lemma lt_plus_1_le_word:
   fixes x :: "'a::len word"
   assumes bound:"n < unat (maxBound::'a word)"
   shows "x < 1 + of_nat n = (x \<le> of_nat n)"
   apply (subst le_less)
   apply (rule iffI)
    apply clarsimp
    apply (subst (asm) add.commute)
    apply (subst (asm) less_x_plus_1)
     apply (cut_tac ?'a='a and y=n and x="unat (maxBound::'a word) - 1" in of_nat_mono_maybe')
       apply clarsimp
       apply (simp add: less_imp_diff_less)
      apply (insert bound[unfolded maxBound_word, simplified])
      using order_less_trans apply blast
     apply (metis max_word_minus word_not_simps(3) word_of_nat_less)
    apply clarsimp
   apply (erule disjE)
    apply (subgoal_tac "x < of_nat (1 + n)")
     prefer 2
     apply (cut_tac ?'a='a and y="unat x" and x="1 + n" in of_nat_mono_maybe)
       apply clarsimp
       apply (simp add: less_trans_Suc)
      apply (simp add: less_Suc_eq unat_less_helper)
     apply clarsimp
    apply clarsimp
   apply clarsimp
   apply (cut_tac y="(of_nat n)::'a word" and x="(of_nat n)::'a word" in less_x_plus_1)
    apply (cut_tac ?'a='a and y=n and x="unat (maxBound::'a word) - 1" in of_nat_mono_maybe')
      apply clarsimp
      apply (simp add: less_imp_diff_less)
     apply (insert bound[unfolded maxBound_word, simplified])
     using order_less_trans apply blast
    apply (metis max_word_minus word_not_simps(3) word_of_nat_less)
   apply (clarsimp simp: add.commute)
   done
 
 lemma unat_ucast_up_simp:
   fixes x :: "'a::len word"
   assumes uc :"LENGTH('a) \<le> LENGTH('b)"
   shows "unat (ucast x :: 'b::len word) = unat x"
   unfolding ucast_def unat_def
   apply (subst int_word_uint)
   apply (subst mod_pos_pos_trivial)
     apply simp
    apply (rule lt2p_lem)
    apply (simp add: uc)
   apply simp
   done
 
 lemma unat_ucast_less_no_overflow:
   "\<lbrakk>n < 2 ^ LENGTH('a); unat f < n\<rbrakk> \<Longrightarrow> (f::('a::len) word) < of_nat n"
   apply (erule order_le_less_trans[OF _ of_nat_mono_maybe,rotated])
    apply assumption
   apply simp
   done
 
 lemma unat_ucast_less_no_overflow_simp:
   "n < 2 ^ LENGTH('a) \<Longrightarrow> (unat f < n) = ((f::('a::len) word) < of_nat n)"
   apply (rule iffI)
    apply (simp add:unat_ucast_less_no_overflow)
   apply (simp add:unat_less_helper)
   done
 
 lemma unat_ucast_no_overflow_le:
   assumes no_overflow : "unat b < (2 :: nat) ^ LENGTH('a)"
   and upward_cast: "LENGTH('a) < LENGTH('b)"
   shows  "(ucast (f::('a::len) word) < (b :: 'b :: len word)) = (unat f < unat b)"
   proof -
     have LR: "ucast f < b \<Longrightarrow> unat f < unat b"
       apply (rule unat_less_helper)
       apply (simp add:ucast_nat_def)
       apply (rule_tac 'b1 = 'b in  ucast_less_ucast[THEN iffD1])
        apply (rule upward_cast)
       apply (simp add: ucast_ucast_mask less_mask_eq word_less_nat_alt
                        unat_power_lower[OF upward_cast] no_overflow)
       done
     have RL: "unat f < unat b \<Longrightarrow> ucast f < b"
       proof-
       assume ineq: "unat f < unat b"
       have ucast_rewrite: "ucast (f::('a::len) word) <
           ((ucast (ucast b ::('a::len) word)) :: 'b :: len word)"
         apply (simp add: ucast_less_ucast upward_cast)
         apply (simp add: ucast_nat_def[symmetric])
         apply (rule unat_ucast_less_no_overflow[OF no_overflow ineq])
         done
       then show ?thesis
         apply (rule order_less_le_trans)
         apply (simp add:ucast_ucast_mask word_and_le2)
         done
    qed
    then show ?thesis by (simp add:RL LR iffI)
 qed
 
 (* casting a long word to a shorter word and casting back to the long word
    is equal to the original long word -- if the word is small enough.
   'l is the longer word.
   's is the shorter word.
 *)
 lemma bl_cast_long_short_long_ingoreLeadingZero_generic:
 "length (dropWhile Not (to_bl w)) \<le> LENGTH('s) \<Longrightarrow>
  LENGTH('s) \<le> LENGTH('l) \<Longrightarrow>
   (of_bl:: bool list \<Rightarrow> 'l::len word) (to_bl ((of_bl:: bool list \<Rightarrow> 's::len word) (to_bl w))) = w"
   apply(rule word_uint_eqI)
   apply(subst uint_of_bl_is_bl_to_bin)
    apply(simp; fail)
   apply(subst to_bl_bin)
   apply(subst uint_of_bl_is_bl_to_bin_drop)
    apply blast
   apply(simp)
   done
 
 (*
  Casting between longer and shorter word.
   'l is the longer word.
   's is the shorter word.
  For example: 'l::len word is 128 word (full ipv6 address)
               's::len word is 16 word (address piece of ipv6 address in colon-text-representation)
 *)
 corollary ucast_short_ucast_long_ingoreLeadingZero:
   "length (dropWhile Not (to_bl w)) \<le> LENGTH('s) \<Longrightarrow>
    LENGTH('s) \<le> LENGTH('l) \<Longrightarrow>
    (ucast:: 's::len word \<Rightarrow> 'l::len word) ((ucast:: 'l::len word \<Rightarrow> 's::len word) w) = w"
   apply(subst Word.ucast_bl)+
   apply(rule bl_cast_long_short_long_ingoreLeadingZero_generic)
    apply(simp_all)
   done
 
 lemma length_drop_mask:
   fixes w::"'a::len word"
   shows "length (dropWhile Not (to_bl (w AND mask n))) \<le> n"
 proof -
   have "length (takeWhile Not (replicate n False @ ls)) = n + length (takeWhile Not ls)"
     for ls n by(subst takeWhile_append2) simp+
   then show ?thesis
     unfolding bl_and_mask by (simp add: dropWhile_eq_drop)
 qed
 
 lemma minus_one_word:
   "(-1 :: 'a :: len word) = 2 ^ LENGTH('a) - 1"
   by simp
 
 lemma mask_exceed:
   "n \<ge> LENGTH('a) \<Longrightarrow> (x::'a::len word) && ~~ mask n = 0"
   by (simp add: and_not_mask shiftr_eq_0)
 
 lemma two_power_strict_part_mono:
   "strict_part_mono {..LENGTH('a) - 1} (\<lambda>x. (2 :: 'a :: len word) ^ x)"
 proof -
   { fix n
     have "n < LENGTH('a) \<Longrightarrow> strict_part_mono {..n} (\<lambda>x. (2 :: 'a :: len word) ^ x)"
     proof (induct n)
       case 0 then show ?case by simp
     next
       case (Suc n)
       from Suc.prems
       have "2 ^ n < (2 :: 'a :: len word) ^ Suc n"
         using power_strict_increasing unat_power_lower word_less_nat_alt by fastforce
       with Suc
       show ?case by (subst strict_part_mono_by_steps) simp
     qed
   }
   then show ?thesis by simp
 qed
 
 lemma word_shift_by_2:
   "x * 4 = (x::'a::len word) << 2"
   by (simp add: shiftl_t2n)
 
 (* simp normal form would be "nat (bintrunc (LENGTH('a)) 2) = 2" *)
 lemma word_len_min_2:
   "Suc 0 < LENGTH('a) \<Longrightarrow> unat (2::'a::len word) = 2"
   by (metis less_trans_Suc n_less_equal_power_2 numeral_2_eq_2 of_nat_numeral unat_of_nat_len)
 
 lemma upper_bits_unset_is_l2p:
   "n < LENGTH('a) \<Longrightarrow>
   (\<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> p !! n') = ((p::'a::len word) < 2 ^ n)"
   apply (cases "Suc 0 < LENGTH('a)")
    prefer 2
    apply (subgoal_tac "LENGTH('a) = 1", auto simp: word_eq_iff)[1]
   apply (rule iffI)
    apply (subst mask_eq_iff_w2p [symmetric])
     apply (clarsimp simp: word_size)
    apply (rule word_eqI, rename_tac n')
    apply (case_tac "n' < n"; simp add: word_size)
   apply clarify
   apply (drule bang_is_le)
   apply (drule_tac y=p in order_le_less_trans, assumption)
   apply (drule word_power_increasing; simp add: word_len_min_2[simplified])
   done
 
 lemma less_2p_is_upper_bits_unset:
   "((p::'a::len word) < 2 ^ n)
     = (n < LENGTH('a) \<and> (\<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> p !! n'))"
   apply (cases "n < LENGTH('a)")
    apply (simp add: upper_bits_unset_is_l2p)
   apply (simp add: power_overflow)
   done
 
 lemma le_2p_upper_bits:
   "\<lbrakk> (p::'a::len word) \<le> 2^n - 1; n < LENGTH('a) \<rbrakk> \<Longrightarrow>
   \<forall>n'\<ge>n. n' < LENGTH('a) \<longrightarrow> \<not> p !! n'"
   by (subst upper_bits_unset_is_l2p; simp)
 
 lemma le2p_bits_unset:
   "p \<le> 2 ^ n - 1 \<Longrightarrow> \<forall>n'\<ge>n. n' < LENGTH('a) \<longrightarrow> \<not> (p::'a::len word) !! n'"
   using upper_bits_unset_is_l2p [where p=p]
   by (cases "n < LENGTH('a)") auto
 
 lemma ucast_less_shiftl_helper:
   "\<lbrakk> LENGTH('b) + 2 < LENGTH('a); 2 ^ (LENGTH('b) + 2) \<le> n\<rbrakk>
     \<Longrightarrow> (ucast (x :: 'b::len word) << 2) < (n :: 'a::len word)"
   apply (erule order_less_le_trans[rotated])
   using ucast_less[where x=x and 'a='a]
   apply (simp only: shiftl_t2n field_simps)
   apply (rule word_less_power_trans2; simp)
   done
 
 lemma word_power_nonzero:
   "\<lbrakk> (x :: 'a::len word) < 2 ^ (LENGTH('a) - n); n < LENGTH('a); x \<noteq> 0 \<rbrakk>
   \<Longrightarrow> x * 2 ^ n \<noteq> 0"
   apply (cases "n = 0", simp)
   apply (simp only: word_neq_0_conv word_less_nat_alt shiftl_t2n mod_0 unat_word_ariths
                     unat_power_lower word_le_nat_alt)
   apply (subst mod_less)
    apply (subst mult.commute, erule nat_less_power_trans)
    apply simp
   apply simp
   done
 
 lemma less_1_helper:
   "n \<le> m \<Longrightarrow> (n - 1 :: int) < m"
   by arith
 
 lemma div_power_helper:
   "\<lbrakk> x \<le> y; y < LENGTH('a) \<rbrakk> \<Longrightarrow> (2 ^ y - 1) div (2 ^ x :: 'a::len word) = 2 ^ (y - x) - 1"
   apply (rule word_uint.Rep_eqD)
   apply (simp only: uint_word_ariths uint_div uint_power_lower)
   apply (subst mod_pos_pos_trivial, fastforce, fastforce)+
   apply (subst mod_pos_pos_trivial)
     apply (simp add: le_diff_eq uint_2p_alt)
    apply (rule less_1_helper)
    apply (rule power_increasing; simp)
   apply (subst mod_pos_pos_trivial)
     apply (simp add: uint_2p_alt)
    apply (rule less_1_helper)
    apply (rule power_increasing; simp)
   apply (subst int_div_sub_1; simp add: uint_2p_alt)
   apply (subst power_0[symmetric])
   apply (simp add: uint_2p_alt le_imp_power_dvd power_sub_int)
   done
 
 
 lemma word_add_power_off:
   fixes a :: "'a :: len word"
   assumes ak: "a < k"
   and kw: "k < 2 ^ (LENGTH('a) - m)"
   and mw: "m < LENGTH('a)"
   and off: "off < 2 ^ m"
   shows "(a * 2 ^ m) + off < k * 2 ^ m"
 proof (cases "m = 0")
   case True
   then show ?thesis using off ak by simp
 next
   case False
 
   from ak have ak1: "a + 1 \<le> k" by (rule inc_le)
   then have "(a + 1) * 2 ^ m \<noteq> 0"
     apply -
     apply (rule word_power_nonzero)
     apply (erule order_le_less_trans  [OF _ kw])
     apply (rule mw)
     apply (rule less_is_non_zero_p1 [OF ak])
     done
   then have "(a * 2 ^ m) + off < ((a + 1) * 2 ^ m)" using kw mw
     apply -
     apply (simp add: distrib_right)
     apply (rule word_plus_strict_mono_right [OF off])
     apply (rule is_aligned_no_overflow'')
     apply (rule is_aligned_mult_triv2)
     apply assumption
     done
   also have "\<dots> \<le> k * 2 ^ m" using ak1 mw kw False
     apply -
     apply (erule word_mult_le_mono1)
     apply (simp add: p2_gt_0)
     apply (simp add: word_less_nat_alt)
     apply (rule nat_less_power_trans2[simplified])
     apply (simp add: word_less_nat_alt)
     apply simp
     done
   finally show ?thesis .
 qed
 
 lemma offset_not_aligned:
   "\<lbrakk> is_aligned (p::'a::len word) n; i > 0; i < 2 ^ n; n < LENGTH('a)\<rbrakk> \<Longrightarrow>
   \<not> is_aligned (p + of_nat i) n"
   apply (erule is_aligned_add_not_aligned)
   unfolding is_aligned_def
   apply clarsimp
   apply (subst (asm) unat_of_nat_len)
    apply (metis order_less_trans unat_lt2p unat_power_lower)
   apply (metis nat_dvd_not_less)
   done
 
 lemma length_upto_enum_one:
   fixes x :: "'a :: len word"
   assumes lt1: "x < y" and lt2: "z < y" and lt3: "x \<le> z"
   shows "[x , y .e. z] = [x]"
 unfolding upto_enum_step_def
 proof (subst upto_enum_red, subst if_not_P [OF leD [OF lt3]], clarsimp, rule conjI)
   show "unat ((z - x) div (y - x)) = 0"
   proof (subst unat_div, rule div_less)
     have syx: "unat (y - x) = unat y - unat x"
       by (rule unat_sub [OF order_less_imp_le]) fact
     moreover have "unat (z - x) = unat z - unat x"
       by (rule unat_sub) fact
 
     ultimately show "unat (z - x) < unat (y - x)"
       using lt3
       apply simp
       apply (rule diff_less_mono[OF unat_mono, OF lt2])
       apply (simp add: word_le_nat_alt[symmetric])
       done
   qed
 
   then show "(z - x) div (y - x) * (y - x) = 0"
     by (metis mult_zero_left unat_0 word_unat.Rep_eqD)
 qed
 
 lemma max_word_mask:
   shows "(max_word :: 'a::len word) = mask (LENGTH('a))"
   unfolding mask_def by (metis max_word_eq shiftl_1)
 
 lemma is_aligned_alignUp[simp]:
   "is_aligned (alignUp p n) n"
   by (simp add: alignUp_def complement_def is_aligned_mask mask_def word_bw_assocs)
 
 lemma alignUp_le[simp]:
   "alignUp p n \<le> p + 2 ^ n - 1"
   unfolding alignUp_def by (rule word_and_le2)
 
 lemma complement_mask:
   "complement (2 ^ n - 1) = ~~ mask n"
   unfolding complement_def mask_def by simp
 
 lemma alignUp_idem:
   fixes a :: "'a::len word"
   assumes al: "is_aligned a n"
   and   sz: "n < LENGTH('a)"
   shows "alignUp a n = a"
   using sz al unfolding alignUp_def
   apply (simp add: complement_mask)
   apply (subst x_power_minus_1)
   apply (subst neg_mask_is_div)
   apply (simp only: word_arith_nat_div  unat_word_ariths)
   apply (simp only: unat_power_lower)
   apply (subst power_mod_div)
   apply (erule is_alignedE)
   apply simp
   apply (subst unat_mult_power_lem)
    apply simp
   apply (subst unat_sub)
    apply (subst unat_arith_simps)
    apply simp
   apply (simp add: del: unat_1)
   apply simp
   done
 
 lemma alignUp_not_aligned_eq:
   fixes a :: "'a :: len word"
   assumes al: "\<not> is_aligned a n"
   and     sz: "n < LENGTH('a)"
   shows   "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
 proof -
   have anz: "a mod 2 ^ n \<noteq> 0"
     by (rule not_aligned_mod_nz) fact+
 
   then have um: "unat (a mod 2 ^ n - 1) div 2 ^ n = 0" using sz
     apply -
     apply (rule div_less)
     apply (simp add: unat_minus_one)
     apply (rule order_less_trans)
      apply (rule diff_Suc_less)
      apply (erule contrapos_np)
      apply (simp add: unat_eq_zero)
     apply (subst unat_power_lower [symmetric, OF sz])
     apply (subst word_less_nat_alt [symmetric])
     apply (rule word_mod_less_divisor)
     apply (simp add: p2_gt_0)
     done
 
   have "a + 2 ^ n - 1 = (a div 2 ^ n) * 2 ^ n + (a mod 2 ^ n) + 2 ^ n - 1"
     by (simp add: word_mod_div_equality)
   also have "\<dots> = (a mod 2 ^ n - 1) + (a div 2 ^ n + 1) * 2 ^ n"
     by (simp add: field_simps)
   finally show "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n" using sz
     unfolding alignUp_def
     apply (subst complement_mask)
     apply (erule ssubst)
     apply (subst neg_mask_is_div)
     apply (simp add: word_arith_nat_div)
     apply (subst unat_word_ariths(1) unat_word_ariths(2))+
     apply (subst uno_simps)
     apply (subst unat_1)
     apply (subst mod_add_right_eq)
     apply simp
     apply (subst power_mod_div)
     apply (subst div_mult_self1)
      apply simp
     apply (subst um)
     apply simp
     apply (subst mod_mod_power)
     apply simp
     apply (subst word_unat_power, subst Abs_fnat_hom_mult)
     apply (subst mult_mod_left)
     apply (subst power_add [symmetric])
     apply simp
     apply (subst Abs_fnat_hom_1)
     apply (subst Abs_fnat_hom_add)
     apply (subst word_unat_power, subst Abs_fnat_hom_mult)
     apply (subst word_unat.Rep_inverse[symmetric], subst Abs_fnat_hom_mult)
     apply simp
     done
 qed
 
 lemma alignUp_ge:
   fixes a :: "'a :: len word"
   assumes sz: "n < LENGTH('a)"
   and nowrap: "alignUp a n \<noteq> 0"
   shows "a \<le> alignUp a n"
 proof (cases "is_aligned a n")
   case True
   then show ?thesis using sz
     by (subst alignUp_idem, simp_all)
 next
   case False
 
   have lt0: "unat a div 2 ^ n < 2 ^ (LENGTH('a) - n)" using sz
     apply -
     apply (subst td_gal_lt [symmetric])
      apply simp
     apply (simp add: power_add [symmetric])
     done
 
   have"2 ^ n * (unat a div 2 ^ n + 1) \<le> 2 ^ LENGTH('a)" using sz
     apply -
     apply (rule nat_le_power_trans)
     apply simp
     apply (rule Suc_leI [OF lt0])
     apply simp
     done
   moreover have "2 ^ n * (unat a div 2 ^ n + 1) \<noteq> 2 ^ LENGTH('a)" using nowrap sz
     apply -
     apply (erule contrapos_nn)
     apply (subst alignUp_not_aligned_eq [OF False sz])
     apply (subst unat_arith_simps)
     apply (subst unat_word_ariths)
     apply (subst unat_word_ariths)
     apply simp
     apply (subst mult_mod_left)
     apply (simp add: unat_div field_simps power_add[symmetric] mod_mod_power min.absorb2)
     done
   ultimately have lt: "2 ^ n * (unat a div 2 ^ n + 1) < 2 ^ LENGTH('a)" by simp
 
   have "a = a div 2 ^ n * 2 ^ n + a mod 2 ^ n" by (rule word_mod_div_equality [symmetric])
   also have "\<dots> < (a div 2 ^ n + 1) * 2 ^ n" using sz lt
     apply (simp add: field_simps)
     apply (rule word_add_less_mono1)
     apply (rule word_mod_less_divisor)
     apply (simp add: word_less_nat_alt)
     apply (subst unat_word_ariths)
     apply (simp add: unat_div)
     done
   also have "\<dots> =  alignUp a n"
     by (rule alignUp_not_aligned_eq [symmetric]) fact+
   finally show ?thesis by (rule order_less_imp_le)
 qed
 
 lemma alignUp_le_greater_al:
   fixes x :: "'a :: len word"
   assumes le: "a \<le> x"
   and     sz: "n < LENGTH('a)"
   and     al: "is_aligned x n"
   shows   "alignUp a n \<le> x"
 proof (cases "is_aligned a n")
   case True
   then show ?thesis using sz le by (simp add: alignUp_idem)
 next
   case False
 
   then have anz: "a mod 2 ^ n \<noteq> 0"
     by (rule not_aligned_mod_nz)
 
   from al obtain k where xk: "x = 2 ^ n * of_nat k" and kv: "k < 2 ^ (LENGTH('a) - n)"
     by (auto elim!: is_alignedE)
 
   then have kn: "unat (of_nat k :: 'a word) * unat ((2::'a word) ^ n) < 2 ^ LENGTH('a)"
     using sz
     apply (subst unat_of_nat_eq)
      apply (erule order_less_le_trans)
      apply simp
     apply (subst mult.commute)
     apply simp
     apply (rule nat_less_power_trans)
      apply simp
     apply simp
     done
 
   have au: "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
     by (rule alignUp_not_aligned_eq) fact+
   also have "\<dots> \<le> of_nat k * 2 ^ n"
   proof (rule word_mult_le_mono1 [OF inc_le _ kn])
     show "a div 2 ^ n < of_nat k" using kv xk le sz anz
       by (simp add: alignUp_div_helper)
 
     show "(0:: 'a word) < 2 ^ n" using sz by (simp add: p2_gt_0 sz)
   qed
 
   finally show ?thesis using xk by (simp add: field_simps)
 qed
 
 lemma alignUp_is_aligned_nz:
   fixes a :: "'a :: len word"
   assumes al: "is_aligned x n"
   and     sz: "n < LENGTH('a)"
   and     ax: "a \<le> x"
   and     az: "a \<noteq> 0"
   shows   "alignUp (a::'a :: len word) n \<noteq> 0"
 proof (cases "is_aligned a n")
   case True
   then have "alignUp a n = a" using sz by (simp add: alignUp_idem)
   then show ?thesis using az by simp
 next
   case False
   then have anz: "a mod 2 ^ n \<noteq> 0"
     by (rule not_aligned_mod_nz)
 
   {
     assume asm: "alignUp a n = 0"
 
     have lt0: "unat a div 2 ^ n < 2 ^ (LENGTH('a) - n)" using sz
       apply -
       apply (subst td_gal_lt [symmetric])
       apply simp
       apply (simp add: power_add [symmetric])
       done
 
     have leq: "2 ^ n * (unat a div 2 ^ n + 1) \<le> 2 ^ LENGTH('a)" using sz
       apply -
       apply (rule nat_le_power_trans)
       apply simp
       apply (rule Suc_leI [OF lt0])
       apply simp
       done
 
     from al obtain k where  kv: "k < 2 ^ (LENGTH('a) - n)" and xk: "x = 2 ^ n * of_nat k"
       by (auto elim!: is_alignedE)
 
     then have "a div 2 ^ n < of_nat k" using ax sz anz
       by (rule alignUp_div_helper)
 
     then have r: "unat a div 2 ^ n < k" using sz
       apply (simp add: unat_div word_less_nat_alt)
       apply (subst (asm) unat_of_nat)
       apply (subst (asm) mod_less)
        apply (rule order_less_le_trans [OF kv])
        apply simp+
       done
 
     have "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
       by (rule alignUp_not_aligned_eq) fact+
 
     then have "\<dots> = 0" using asm by simp
     then have "2 ^ LENGTH('a) dvd 2 ^ n * (unat a div 2 ^ n + 1)"
       using sz by (simp add: unat_arith_simps ac_simps)
                   (simp add: unat_word_ariths mod_simps mod_eq_0_iff_dvd)
     with leq have "2 ^ n * (unat a div 2 ^ n + 1) = 2 ^ LENGTH('a)"
       by (force elim!: le_SucE)
     then have "unat a div 2 ^ n = 2 ^ LENGTH('a) div 2 ^ n - 1"
       by (metis (no_types, hide_lams) Groups.add_ac(2) add.right_neutral
                 add_diff_cancel_left' div_le_dividend div_mult_self4 gr_implies_not0
                 le_neq_implies_less power_eq_0_iff unat_def zero_neq_numeral)
     then have "unat a div 2 ^ n = 2 ^ (LENGTH('a) - n) - 1"
       using sz by (simp add: power_sub)
     then have "2 ^ (LENGTH('a) - n) - 1 < k" using r
       by simp
     then have False using kv by simp
   } then show ?thesis by clarsimp
 qed
 
 lemma alignUp_ar_helper:
   fixes a :: "'a :: len word"
   assumes al: "is_aligned x n"
   and     sz: "n < LENGTH('a)"
   and    sub: "{x..x + 2 ^ n - 1} \<subseteq> {a..b}"
   and    anz: "a \<noteq> 0"
   shows "a \<le> alignUp a n \<and> alignUp a n + 2 ^ n - 1 \<le> b"
 proof
   from al have xl: "x \<le> x + 2 ^ n - 1" by (simp add: is_aligned_no_overflow)
 
   from xl sub have ax: "a \<le> x"
     by (clarsimp elim!: range_subset_lower [where x = x])
 
   show "a \<le> alignUp a n"
   proof (rule alignUp_ge)
     show "alignUp a n \<noteq> 0" using al sz ax anz
       by (rule alignUp_is_aligned_nz)
   qed fact+
 
   show "alignUp a n + 2 ^ n - 1 \<le> b"
   proof (rule order_trans)
     from xl show tp: "x + 2 ^ n - 1 \<le> b" using sub
       by (clarsimp elim!: range_subset_upper [where x = x])
 
     from ax have "alignUp a n \<le> x"
       by (rule alignUp_le_greater_al) fact+
     then have "alignUp a n + (2 ^ n - 1) \<le> x + (2 ^ n - 1)"
       using xl al is_aligned_no_overflow' olen_add_eqv word_plus_mcs_3 by blast
     then show "alignUp a n + 2 ^ n - 1 \<le> x + 2 ^ n - 1"
       by (simp add: field_simps)
   qed
 qed
 
 lemma alignUp_def2:
   "alignUp a sz = a + 2 ^ sz - 1 && ~~ mask sz"
   unfolding alignUp_def[unfolded complement_def]
   by (simp add:mask_def[symmetric,unfolded shiftl_t2n,simplified])
 
 lemma mask_out_first_mask_some:
   "\<lbrakk> x && ~~ mask n = y; n \<le> m \<rbrakk> \<Longrightarrow> x && ~~ mask m = y && ~~ mask m"
   apply (rule word_eqI, rename_tac n')
   apply (drule_tac x=n' in word_eqD)
   apply (auto simp: word_ops_nth_size word_size)
   done
 
 lemma gap_between_aligned:
   "\<lbrakk>a < (b :: 'a ::len word); is_aligned a n; is_aligned b n; n < LENGTH('a) \<rbrakk>
   \<Longrightarrow> a + (2^n - 1) < b"
   apply (rule ccontr,simp add:not_less)
   apply (drule le_shiftr[where n = n])
   apply (simp add: aligned_shift')
   apply (case_tac "b >> n = a >> n")
    apply (drule arg_cong[where f = "\<lambda>x. x<<n"])
    apply (drule le_shiftr')
     apply (clarsimp simp:is_aligned_shiftr_shiftl)
    apply fastforce
   apply (drule(1) le_shiftr')
   apply simp
   done
 
 lemma mask_out_add_aligned:
   assumes al: "is_aligned p n"
   shows "p + (q && ~~ mask n) = (p + q) && ~~ mask n"
   using mask_add_aligned [OF al]
   by (simp add: mask_out_sub_mask)
 
 lemma alignUp_def3:
   "alignUp a sz = 2^ sz + (a - 1 && ~~ mask sz)" (is "?lhs = ?rhs")
   apply (simp add:alignUp_def2)
   apply (subgoal_tac "2 ^ sz + a - 1 && ~~ mask sz = ?rhs")
    apply (clarsimp simp:field_simps)
   apply (subst mask_out_add_aligned)
    apply (rule is_aligned_triv)
   apply (simp add:field_simps)
   done
 
 lemma  alignUp_plus:
   "is_aligned w us \<Longrightarrow> alignUp (w + a) us  = w + alignUp a us"
   apply (clarsimp simp:alignUp_def2 add.assoc)
   apply (simp add: mask_out_add_aligned field_simps)
   done
 
 lemma mask_lower_twice:
   "n \<le> m \<Longrightarrow> (x && ~~ mask n) && ~~ mask m = x && ~~ mask m"
   apply (rule word_eqI)
   apply (simp add: word_size word_ops_nth_size)
   apply safe
   apply simp
   done
 
 lemma mask_lower_twice2:
   "(a && ~~ mask n) && ~~ mask m = a && ~~ mask (max n m)"
   by (rule word_eqI, simp add: neg_mask_bang conj_comms)
 
 lemma ucast_and_neg_mask:
   "ucast (x && ~~ mask n) = ucast x && ~~ mask n"
   apply (rule word_eqI)
   apply (simp add: word_size neg_mask_bang nth_ucast)
   apply (auto simp add: test_bit_bl word_size)
   done
 
 lemma ucast_and_mask:
   "ucast (x && mask n) = ucast x && mask n"
   apply (rule word_eqI)
   apply (simp add: nth_ucast)
   apply (auto simp add: test_bit_bl word_size)
   done
 
 lemma ucast_mask_drop:
   "LENGTH('a :: len) \<le> n \<Longrightarrow> (ucast (x && mask n) :: 'a word) = ucast x"
   apply (rule word_eqI)
   apply (simp add: nth_ucast word_size)
   apply safe
   apply (simp add: test_bit_bl word_size)
   done
 
 lemma alignUp_distance:
   "alignUp (q :: 'a :: len word) sz - q \<le> mask sz"
   apply (case_tac "LENGTH('a) \<le> sz")
    apply (simp add:alignUp_def2 mask_def power_overflow)
   apply (case_tac "is_aligned q sz")
    apply (clarsimp simp:alignUp_def2 p_assoc_help)
    apply (subst mask_out_add_aligned[symmetric],simp)+
    apply (simp add:mask_lower_twice word_and_le2)
    apply (simp add:and_not_mask)
    apply (subst le_mask_iff[THEN iffD1])
     apply (simp add:mask_def)
    apply simp
   apply (clarsimp simp:alignUp_def3)
   apply (subgoal_tac "2 ^ sz - (q - (q - 1 && ~~ mask sz)) \<le> 2 ^ sz - 1")
    apply (simp add:field_simps mask_def)
   apply (rule word_sub_mono)
      apply simp
     apply (rule ccontr)
     apply (clarsimp simp:not_le)
     apply (drule eq_refl)
     apply (drule order_trans[OF _ word_and_le2])
     apply (subgoal_tac "q \<noteq>  0")
      apply (drule minus_one_helper[rotated])
       apply simp
      apply simp
     apply (fastforce)
    apply (simp add: word_sub_le_iff)
    apply (subgoal_tac "q - 1 && ~~ mask sz = (q - 1) - (q - 1 && mask sz)")
     apply simp
     apply (rule order_trans)
      apply (rule word_add_le_mono2)
       apply (rule word_and_le1)
      apply (subst unat_plus_simple[THEN iffD1,symmetric])
       apply (simp add:not_le mask_def)
       apply (rule word_sub_1_le)
       apply simp
      apply (rule unat_lt2p)
     apply (simp add:mask_def)
    apply (simp add:mask_out_sub_mask)
   apply (rule word_sub_1_le)
   apply simp
   done
 
 lemma is_aligned_diff_neg_mask:
   "is_aligned p sz \<Longrightarrow> (p - q && ~~ mask sz) = (p - ((alignUp q sz) && ~~ mask sz))"
   apply (clarsimp simp only:word_and_le2 diff_conv_add_uminus)
   apply (subst mask_out_add_aligned[symmetric])
    apply simp+
   apply (rule sum_to_zero)
   apply (subst add.commute)
   apply (subst  mask_out_add_aligned)
    apply (simp add:is_aligned_neg_mask)
   apply simp
   apply (subst and_not_mask[where w = "(alignUp q sz && ~~ mask sz) - q "])
   apply (subst le_mask_iff[THEN iffD1])
    apply (simp add:is_aligned_neg_mask_eq)
    apply (rule alignUp_distance)
   apply simp
   done
 
 lemma map_bits_rev_to_bl:
   "map ((!!) x) [0..<size x] = rev (to_bl x)"
   by (auto simp: list_eq_iff_nth_eq test_bit_bl word_size)
 
 (* negating a mask which has been shifted to the very left *)
 lemma NOT_mask_shifted_lenword:
   "~~ ((mask len << (len_of(TYPE('a)) - len))::'a::len word) = mask (len_of(TYPE('a)) - len)"
   apply(rule Word.word_bool_alg.compl_unique)
    subgoal using mask_shift_and_negate by simp
   apply (rule word_eqI)
   apply (simp add: word_size nth_shiftl nth_shiftr)
   by auto
 
 (* Comparisons between different word sizes. *)
 
 lemma eq_ucast_ucast_eq:
   fixes x :: "'a::len word"
     and y :: "'b::len word"
   assumes "LENGTH('b) \<le> LENGTH('a)"
   shows   "x = ucast y \<Longrightarrow> ucast x = y"
   using assms
   by (simp add: is_down ucast_id ucast_ucast_a)
 
 lemma le_ucast_ucast_le:
   fixes x :: "'a::len word"
     and y :: "'b::len word"
   assumes "LENGTH('b) \<le> LENGTH('a)"
   shows   "x \<le> ucast y \<Longrightarrow> ucast x \<le> y"
   using assms
   apply (simp add: word_le_nat_alt unat_ucast_up_simp[where x=y])
   apply (simp add: unat_ucast)
   by (rule le_trans; fastforce)
 
 lemma less_ucast_ucast_less:
   fixes x :: "'a::len word"
     and y :: "'b::len word"
   assumes "LENGTH('b) \<le> LENGTH('a)"
   shows   "x < ucast y \<Longrightarrow> ucast x < y"
   using assms
   apply (simp add: word_less_nat_alt unat_ucast_up_simp[where x=y])
   apply (simp add: unat_ucast)
   by (rule le_less_trans; fastforce)
 
 lemma ucast_le_ucast:
   fixes x :: "'a::len word"
     and y :: "'a::len word"
   assumes "LENGTH('a) \<le> LENGTH('b)"
   shows "(ucast x \<le> (ucast y::'b::len word)) = (x \<le> y)"
   using assms
   apply (simp add: word_le_nat_alt unat_ucast)
   apply (subst mod_less)
    apply(rule less_le_trans[OF unat_lt2p], simp)
   apply (subst mod_less)
    apply(rule less_le_trans[OF unat_lt2p], simp)
   apply simp
   done
 
 lemma ucast_le_ucast_eq:
   fixes x y :: "'a::len word"
   assumes x: "x < 2 ^ n"
   assumes y: "y < 2 ^ n"
   assumes n: "n = LENGTH('b::len)"
   shows "(UCAST('a \<rightarrow> 'b) x \<le> UCAST('a \<rightarrow> 'b) y) = (x \<le> y)"
   apply (rule iffI)
    apply (cases "LENGTH('b) < LENGTH('a)")
     apply (subst less_mask_eq[OF x, symmetric])
     apply (subst less_mask_eq[OF y, symmetric])
     apply (unfold n)
     apply (subst ucast_ucast_mask[symmetric])+
     apply (simp add: ucast_le_ucast)+
   apply (erule ucast_mono_le[OF _ y[unfolded n]])
   done
 
 (* High bits w.r.t. mask operations. *)
 
 lemma and_neg_mask_eq_iff_not_mask_le:
   "w && ~~ mask n = ~~ mask n \<longleftrightarrow> ~~ mask n \<le> w"
   by (metis (full_types) dual_order.antisym neg_mask_mono_le word_and_le1 word_and_le2
                          word_bool_alg.conj_absorb)
 
 lemma le_mask_high_bits:
   shows "w \<le> mask n \<longleftrightarrow> (\<forall> i \<in> {n ..< size w}. \<not> w !! i)"
   by (auto simp: word_size and_mask_eq_iff_le_mask[symmetric] word_eq_iff)
 
 lemma neg_mask_le_high_bits:
   shows "~~ mask n \<le> w \<longleftrightarrow> (\<forall> i \<in> {n ..< size w}. w !! i)"
   by (auto simp: word_size and_neg_mask_eq_iff_not_mask_le[symmetric]
                  word_eq_iff neg_mask_bang)
 
 lemma word_le_not_less:
   "((b::'a::len word) \<le> a) = (\<not>(a < b))"
   by fastforce
 
 lemma ucast_or_distrib:
   fixes x :: "'a::len word"
   fixes y :: "'a::len word"
   shows "(ucast (x || y) :: ('b::len) word) = ucast x || ucast y"
   unfolding ucast_def Word.bitOR_word.abs_eq uint_or
   by blast
 
 lemma shiftr_less:
   "(w::'a::len word) < k \<Longrightarrow> w >> n < k"
   apply (simp add: word_less_nat_alt shiftr_div_2n')
   apply (blast intro: div_le_dividend le_less_trans)
   done
 
 lemma word_and_notzeroD:
   "w && w' \<noteq> 0 \<Longrightarrow> w \<noteq> 0 \<and> w' \<noteq> 0"
   by auto
 
 lemma word_clz_max:
   "word_clz w \<le> size (w::'a::len word)"
   unfolding word_clz_def
   apply (simp add: word_size)
   apply (rule_tac y="length (to_bl w)" in order_trans)
    apply (rule List.length_takeWhile_le)
   apply simp
   done
 
 lemma word_clz_nonzero_max:
   fixes w :: "'a::len word"
   assumes nz: "w \<noteq> 0"
   shows "word_clz w < size (w::'a::len word)"
 proof -
   {
     assume a: "word_clz w = size (w::'a::len word)"
     hence "length (takeWhile Not (to_bl w)) = length (to_bl w)"
       by (simp add: word_clz_def word_size)
     hence allj: "\<forall>j\<in>set(to_bl w). \<not> j"
       using takeWhile_take_has_property[where n="length (to_bl w)" and xs="to_bl w" and P=Not]
       by simp
     hence "to_bl w = replicate (length (to_bl w)) False"
       by (fastforce intro!: list_of_false)
     hence "w = 0"
      apply simp
      apply (subst (asm) to_bl_0[symmetric])
      apply (drule Word.word_bl.Rep_eqD, assumption)
      done
     with nz have False by simp
   }
   thus ?thesis using word_clz_max
     by (fastforce intro: le_neq_trans)
 qed
 
 lemma unat_add_lem':
   "(unat x + unat y < 2 ^ LENGTH('a)) \<Longrightarrow>
     (unat (x + y :: 'a :: len word) = unat x + unat y)"
   by (subst unat_add_lem[symmetric], assumption)
 
 lemma from_bool_eq_if':
   "((if P then 1 else 0) = from_bool Q) = (P = Q)"
   by (simp add: case_bool_If from_bool_def split: if_split)
 
 lemma word_exists_nth:
   "(w::'a::len word) \<noteq> 0 \<Longrightarrow> \<exists>i. w !! i"
   using word_log2_nth_same by blast
 
 lemma shiftr_le_0:
   "unat (w::'a::len word) < 2 ^ n \<Longrightarrow> w >> n = (0::'a::len word)"
   by (rule word_unat.Rep_eqD) (simp add: shiftr_div_2n')
 
 lemma of_nat_shiftl:
   "(of_nat x << n) = (of_nat (x * 2 ^ n) :: ('a::len) word)"
 proof -
   have "(of_nat x::'a word) << n = of_nat (2 ^ n) * of_nat x"
     using shiftl_t2n by (metis word_unat_power)
   thus ?thesis by simp
 qed
 
 lemma shiftl_1_not_0:
   "n < LENGTH('a) \<Longrightarrow> (1::'a::len word) << n \<noteq> 0"
   by (simp add: shiftl_t2n)
 
 lemma max_word_not_0[simp]:
   "max_word \<noteq> 0"
   by (simp add: max_word_minus)
 
 lemma ucast_zero_is_aligned:
   "UCAST('a::len \<rightarrow> 'b::len) w = 0 \<Longrightarrow> n \<le> LENGTH('b) \<Longrightarrow> is_aligned w n"
   by (clarsimp simp: is_aligned_mask word_eq_iff word_size nth_ucast)
 
 lemma unat_ucast_eq_unat_and_mask:
   "unat (UCAST('b::len \<rightarrow> 'a::len) w) = unat (w && mask LENGTH('a))"
   proof -
     have "unat (UCAST('b \<rightarrow> 'a) w) = unat (UCAST('a \<rightarrow> 'b) (UCAST('b \<rightarrow> 'a) w))"
       by (cases "LENGTH('a) < LENGTH('b)"; simp add: is_down ucast_ucast_a unat_ucast_up_simp)
     thus ?thesis using ucast_ucast_mask by simp
   qed
 
 lemma unat_max_word_pos[simp]: "0 < unat max_word"
   by (auto simp: unat_gt_0)
 
 
 (* Miscellaneous conditional injectivity rules. *)
 
 lemma mult_pow2_inj:
   assumes ws: "m + n \<le> LENGTH('a)"
   assumes le: "x \<le> mask m" "y \<le> mask m"
   assumes eq: "x * 2^n = y * (2^n::'a::len word)"
   shows "x = y"
 proof (cases n)
   case 0 thus ?thesis using eq by simp
 next
   case (Suc n')
   have m_lt: "m < LENGTH('a)" using Suc ws by simp
   have xylt: "x < 2^m" "y < 2^m" using le m_lt unfolding mask_2pm1 by auto
   have lenm: "n \<le> LENGTH('a) - m" using ws by simp
   show ?thesis
     using eq xylt
     apply (fold shiftl_t2n[where n=n, simplified mult.commute])
     apply (simp only: word_bl.Rep_inject[symmetric] bl_shiftl)
     apply (erule ssubst[OF less_is_drop_replicate])+
     apply (clarsimp elim!: drop_eq_mono[OF lenm])
     done
 qed
 
 lemma word_of_nat_inj:
   assumes bounded: "x < 2 ^ LENGTH('a)" "y < 2 ^ LENGTH('a)"
   assumes of_nats: "of_nat x = (of_nat y :: 'a::len word)"
   shows "x = y"
   by (rule contrapos_pp[OF of_nats]; cases "x < y"; cases "y < x")
      (auto dest: bounded[THEN of_nat_mono_maybe])
 
 (* Sign extension from bit n. *)
 
 lemma sign_extend_bitwise_if:
   "i < size w \<Longrightarrow> sign_extend e w !! i \<longleftrightarrow> (if i < e then w !! i else w !! e)"
   by (simp add: sign_extend_def neg_mask_bang word_size)
 
 lemma sign_extend_bitwise_disj:
   "i < size w \<Longrightarrow> sign_extend e w !! i \<longleftrightarrow> i \<le> e \<and> w !! i \<or> e \<le> i \<and> w !! e"
   by (auto simp: sign_extend_bitwise_if)
 
 lemma sign_extend_bitwise_cases:
   "i < size w \<Longrightarrow> sign_extend e w !! i \<longleftrightarrow> (i \<le> e \<longrightarrow> w !! i) \<and> (e \<le> i \<longrightarrow> w !! e)"
   by (auto simp: sign_extend_bitwise_if)
 
 lemmas sign_extend_bitwise_if' = sign_extend_bitwise_if[simplified word_size]
 lemmas sign_extend_bitwise_disj' = sign_extend_bitwise_disj[simplified word_size]
 lemmas sign_extend_bitwise_cases' = sign_extend_bitwise_cases[simplified word_size]
 
 (* Often, it is easier to reason about an operation which does not overwrite
    the bit which determines which mask operation to apply. *)
 lemma sign_extend_def':
   "sign_extend n w = (if w !! n then w || ~~ mask (Suc n) else w && mask (Suc n))"
   by (rule word_eqI[rule_format])
      (auto simp: sign_extend_bitwise_if' word_size word_ops_nth_size dest: less_antisym)
 
 lemma sign_extended_sign_extend:
   "sign_extended n (sign_extend n w)"
   by (clarsimp simp: sign_extended_def word_size sign_extend_bitwise_if')
 
 lemma sign_extended_iff_sign_extend:
   "sign_extended n w \<longleftrightarrow> sign_extend n w = w"
   apply (rule iffI)
    apply (rule word_eqI[rule_format], rename_tac i)
    apply (case_tac "n < i"; simp add: sign_extended_def word_size sign_extend_bitwise_if')
   apply (erule subst, rule sign_extended_sign_extend)
   done
 
 lemma sign_extended_weaken:
   "sign_extended n w \<Longrightarrow> n \<le> m \<Longrightarrow> sign_extended m w"
   unfolding sign_extended_def by (cases "n < m") auto
 
 lemma sign_extend_sign_extend_eq:
   "sign_extend m (sign_extend n w) = sign_extend (min m n) w"
   by (cases "m < n") (auto intro!: word_eqI simp: word_size sign_extend_bitwise_cases')
 
 lemma sign_extended_high_bits:
   "\<lbrakk> sign_extended e p; j < size p; e \<le> i; i < j \<rbrakk> \<Longrightarrow> p !! i = p !! j"
   by (drule (1) sign_extended_weaken; simp add: sign_extended_def)
 
 lemma sign_extend_eq:
   "w && mask (Suc n) = v && mask (Suc n) \<Longrightarrow> sign_extend n w = sign_extend n v"
   by (rule word_eqI, fastforce dest: word_eqD simp: sign_extend_bitwise_if' word_size)
 
 
 lemma sign_extended_add:
   assumes p: "is_aligned p n"
   assumes f: "f < 2 ^ n"
   assumes e: "n \<le> e"
   assumes "sign_extended e p"
   shows "sign_extended e (p + f)"
 proof (cases "e < size p")
   case True
   note and_or = is_aligned_add_or[OF p f]
   have "\<not> f !! e"
     using True e less_2p_is_upper_bits_unset[THEN iffD1, OF f]
     by (fastforce simp: word_size)
   hence i: "(p + f) !! e = p !! e"
     by (simp add: and_or)
   have fm: "f && mask e = f"
     by (fastforce intro: subst[where P="\<lambda>f. f && mask e = f", OF less_mask_eq[OF f]]
                   simp: mask_twice e)
   show ?thesis
     using assms
      apply (simp add: sign_extended_iff_sign_extend sign_extend_def i)
      apply (simp add: and_or word_bw_comms[of p f])
      apply (clarsimp simp: word_ao_dist fm word_bw_assocs split: if_splits)
     done
 next
   case False thus ?thesis
     by (simp add: sign_extended_def word_size)
 qed
 
 lemma sign_extended_neq_mask:
   "\<lbrakk>sign_extended n ptr; m \<le> n\<rbrakk> \<Longrightarrow> sign_extended n (ptr && ~~ mask m)"
   by (fastforce simp: sign_extended_def word_size neg_mask_bang)
 
 (* Uints *)
 
 lemma uints_mono_iff: "uints l \<subseteq> uints m \<longleftrightarrow> l \<le> m"
   using power_increasing_iff[of "2::int" l m]
   apply (auto simp: uints_num subset_iff simp del: power_increasing_iff)
   by (meson less_irrefl not_less zle2p)
 
 lemmas uints_monoI = uints_mono_iff[THEN iffD2]
 
 lemma Bit_in_uints_Suc: "w BIT c \<in> uints (Suc m)" if "w \<in> uints m"
   using that
   by (auto simp: uints_num Bit_def)
 
 lemma Bit_in_uintsI: "w BIT c \<in> uints m" if "w \<in> uints (m - 1)" "m > 0"
   using Bit_in_uints_Suc[OF that(1)] that(2)
   by auto
 
 lemma bin_cat_in_uintsI: "bin_cat a n b \<in> uints m" if "a \<in> uints l" "m \<ge> l + n"
   using that
 proof (induction n arbitrary: b m)
   case 0
   then have "uints l \<subseteq> uints m"
     by (intro uints_monoI) auto
   then show ?case using 0 by auto
 next
   case (Suc n)
   then show ?case
     by (auto intro!: Bit_in_uintsI)
 qed
 
 lemma bin_cat_cong: "bin_cat a n b = bin_cat c m d"
   if "n = m" "a = c" "bintrunc m b = bintrunc m d"
   using that(3) unfolding that(1,2)
 proof (induction m arbitrary: b d)
   case (Suc m)
   show ?case
     using Suc.prems by (auto intro: Suc.IH)
 qed simp
 
 lemma bin_cat_eqD1: "bin_cat a n b = bin_cat c n d \<Longrightarrow> a = c"
   by (induction n arbitrary: b d) auto
 
 lemma bin_cat_eqD2: "bin_cat a n b = bin_cat c n d \<Longrightarrow> bintrunc n b = bintrunc n d"
   by (induction n arbitrary: b d) auto
 
 lemma bin_cat_inj: "(bin_cat a n b) = bin_cat c n d \<longleftrightarrow> a = c \<and> bintrunc n b = bintrunc n d"
   by (auto intro: bin_cat_cong bin_cat_eqD1 bin_cat_eqD2)
 
 lemma word_of_int_bin_cat_eq_iff:
   "(word_of_int (bin_cat (uint a) LENGTH('b) (uint b))::'c::len0 word) =
   word_of_int (bin_cat (uint c) LENGTH('b) (uint d)) \<longleftrightarrow> b = d \<and> a = c"
   if "LENGTH('a) + LENGTH('b) \<le> LENGTH('c)"
   for a::"'a::len0 word" and b::"'b::len0 word"
   by (subst word_uint.Abs_inject)
      (auto simp: bin_cat_inj intro!: that bin_cat_in_uintsI)
 
 lemma word_cat_inj: "(word_cat a b::'c::len0 word) = word_cat c d \<longleftrightarrow> a = c \<and> b = d"
   if "LENGTH('a) + LENGTH('b) \<le> LENGTH('c)"
   for a::"'a::len0 word" and b::"'b::len0 word"
   by (auto simp: word_cat_def word_uint.Abs_inject word_of_int_bin_cat_eq_iff that)
 
 lemma p2_eq_1: "2 ^ n = (1::'a::len word) \<longleftrightarrow> n = 0"
 proof -
   have "2 ^ n = (1::'a word) \<Longrightarrow> n = 0"
     by (metis One_nat_def not_less one_less_numeral_iff p2_eq_0 p2_gt_0 power_0 power_0
         power_inject_exp semiring_norm(76) unat_power_lower zero_neq_one)
   then show ?thesis by auto
 qed
 
 (* usually: x,y = (len_of TYPE ('a)) *)
 lemma bitmagic_zeroLast_leq_or1Last:
   "(a::('a::len) word) AND (mask len << x - len) \<le> a OR mask (y - len)"
   by (meson le_word_or2 order_trans word_and_le2)
 
 
 lemma zero_base_lsb_imp_set_eq_as_bit_operation:
   fixes base ::"'a::len word"
   assumes valid_prefix: "mask (LENGTH('a) - len) AND base = 0"
   shows "(base = NOT mask (LENGTH('a) - len) AND a) \<longleftrightarrow>
          (a \<in> {base .. base OR mask (LENGTH('a) - len)})"
 proof
   have helper3: "x OR y = x OR y AND NOT x" for x y ::"'a::len word" by (simp add: word_oa_dist2)
   from assms show "base = NOT mask (LENGTH('a) - len) AND a \<Longrightarrow>
                     a \<in> {base..base OR mask (LENGTH('a) - len)}"
     apply(simp add: word_and_le1)
     apply(metis helper3 le_word_or2 word_bw_comms(1) word_bw_comms(2))
   done
 next
   assume "a \<in> {base..base OR mask (LENGTH('a) - len)}"
   hence a: "base \<le> a \<and> a \<le> base OR mask (LENGTH('a) - len)" by simp
   show "base = NOT mask (LENGTH('a) - len) AND a"
   proof -
     have f2: "\<forall>x\<^sub>0. base AND NOT mask x\<^sub>0 \<le> a AND NOT mask x\<^sub>0"
       using a neg_mask_mono_le by blast
     have f3: "\<forall>x\<^sub>0. a AND NOT mask x\<^sub>0 \<le> (base OR mask (LENGTH('a) - len)) AND NOT mask x\<^sub>0"
       using a neg_mask_mono_le by blast
     have f4: "base = base AND NOT mask (LENGTH('a) - len)"
       using valid_prefix by (metis mask_eq_0_eq_x word_bw_comms(1))
     hence f5: "\<forall>x\<^sub>6. (base OR x\<^sub>6) AND NOT mask (LENGTH('a) - len) =
                       base OR x\<^sub>6 AND NOT mask (LENGTH('a) - len)"
       using word_ao_dist by (metis)
     have f6: "\<forall>x\<^sub>2 x\<^sub>3. a AND NOT mask x\<^sub>2 \<le> x\<^sub>3 \<or>
                       \<not> (base OR mask (LENGTH('a) - len)) AND NOT mask x\<^sub>2 \<le> x\<^sub>3"
       using f3 dual_order.trans by auto
     have "base = (base OR mask (LENGTH('a) - len)) AND NOT mask (LENGTH('a) - len)"
       using f5 by auto
     hence "base = a AND NOT mask (LENGTH('a) - len)"
       using f2 f4 f6 by (metis eq_iff)
     thus "base = NOT mask (LENGTH('a) - len) AND a"
       by (metis word_bw_comms(1))
   qed
 qed
 
 lemma unat_minus_one_word:
   "unat (-1 :: 'a :: len word) = 2 ^ LENGTH('a) - 1"
   by (subst minus_one_word)
      (subst unat_sub_if', clarsimp)
 
 lemma of_nat_eq_signed_scast:
   "(of_nat x = (y :: ('a::len) signed word))
    = (of_nat x = (scast y :: 'a word))"
   by (metis scast_of_nat scast_scast_id(2))
 
 lemma word_ctz_le:
   "word_ctz (w :: ('a::len word)) \<le> LENGTH('a)"
   apply (clarsimp simp: word_ctz_def)
   apply (rule nat_le_Suc_less_imp[where y="LENGTH('a) + 1" , simplified])
   apply (rule order_le_less_trans[OF List.length_takeWhile_le])
   apply simp
   done
 
 lemma word_ctz_less:
   "w \<noteq> 0 \<Longrightarrow> word_ctz (w :: ('a::len word)) < LENGTH('a)"
   apply (clarsimp simp: word_ctz_def eq_zero_set_bl)
   apply (rule order_less_le_trans[OF length_takeWhile_less])
    apply fastforce+
   done
 
 lemma word_ctz_not_minus_1:
   "1 < LENGTH('a) \<Longrightarrow> of_nat (word_ctz (w :: ('a :: len) word)) \<noteq> (- 1 :: ('a::len) word)"
   apply (cut_tac w=w in word_ctz_le)
   apply (subst word_unat.Rep_inject[symmetric])
   apply (subst unat_of_nat_eq)
    apply (erule order_le_less_trans, fastforce)
   apply (subst unat_minus_one_word)
   apply (rule less_imp_neq)
   apply (erule order_le_less_trans)
   apply (subst less_eq_Suc_le)
   apply (subst le_diff_conv2, fastforce)
   apply (clarsimp simp: le_diff_conv2 less_eq_Suc_le[symmetric] suc_le_pow_2)
   done
 
 lemmas word_ctz_not_minus_1_32 = word_ctz_not_minus_1[where 'a=32, simplified]
 
 end
diff --git a/thys/pGCL/Algebra.thy b/thys/pGCL/Algebra.thy
--- a/thys/pGCL/Algebra.thy
+++ b/thys/pGCL/Algebra.thy
@@ -1,1247 +1,1248 @@
 (*
  * Copyright (C) 2014 NICTA
  * All rights reserved.
  *)
 
 (* Author: David Cock - David.Cock@nicta.com.au *)
 
 section "The Algebra of pGCL"
 
 theory Algebra imports WellDefined begin
 
 text_raw \<open>\label{s:Algebra}\<close>
 
 text \<open>Programs in pGCL have a rich algebraic structure, largely mirroring that for GCL. We show
 that programs form a lattice under refinement, with @{term "a \<Sqinter> b"} and @{term "a \<Squnion> b"} as the meet
 and join operators, respectively. We also take advantage of the algebraic structure to establish a
 framwork for the modular decomposition of proofs.\<close>
 
 subsection \<open>Program Refinement\<close>
 
 text_raw \<open>\label{s:progref}\<close>
 
 text \<open>Refinement in pGCL relates to refinement in GCL exactly as probabilistic entailment relates
 to implication. It turns out to have a very similar algebra, the rules of which we establish
 shortly.\<close>
 
 definition
   refines :: "'s prog \<Rightarrow> 's prog \<Rightarrow> bool" (infix "\<sqsubseteq>" 70)
 where
   "prog \<sqsubseteq> prog' \<equiv> \<forall>P. sound P \<longrightarrow> wp prog P \<tturnstile> wp prog' P"
 
 lemma refinesI[intro]:
   "\<lbrakk> \<And>P. sound P \<Longrightarrow> wp prog P \<tturnstile> wp prog' P \<rbrakk> \<Longrightarrow> prog \<sqsubseteq> prog'"
   unfolding refines_def by(simp)
 
 lemma refinesD[dest]:
   "\<lbrakk> prog \<sqsubseteq> prog'; sound P \<rbrakk> \<Longrightarrow> wp prog P \<tturnstile> wp prog' P"
   unfolding refines_def by(simp)
 
 text \<open>The equivalence relation below will turn out to be that induced by refinement. It is also
 the application of @{term equiv_trans} to the weakest precondition.\<close>
 
 definition
   pequiv :: "'s prog \<Rightarrow> 's prog \<Rightarrow> bool" (infix "\<simeq>" 70)
 where
   "prog \<simeq> prog' \<equiv> \<forall>P. sound P \<longrightarrow> wp prog P = wp prog' P"
 
 lemma pequivI[intro]:
   "\<lbrakk> \<And>P. sound P \<Longrightarrow> wp prog P = wp prog' P \<rbrakk> \<Longrightarrow> prog \<simeq> prog'"
   unfolding pequiv_def by(simp)
 
 lemma pequivD[dest,simp]:
   "\<lbrakk> prog \<simeq> prog'; sound P \<rbrakk> \<Longrightarrow> wp prog P = wp prog' P"
   unfolding pequiv_def by(simp)
 
 lemma pequiv_equiv_trans:
   "a \<simeq> b \<longleftrightarrow> equiv_trans (wp a) (wp b)"
   by(auto)
 
 subsection \<open>Simple Identities\<close>
 
 text \<open>The following identities involve only the primitive operations as defined in
 \autoref{s:syntax}, and refinement as defined above.\<close>
 
 subsubsection \<open>Laws following from the basic arithmetic of the operators seperately\<close>
 
 lemma DC_comm[ac_simps]:
   "a \<Sqinter> b = b \<Sqinter> a"
   unfolding DC_def by(simp add:ac_simps)
 
 lemma DC_assoc[ac_simps]:
   "a \<Sqinter> (b \<Sqinter> c) = (a \<Sqinter> b) \<Sqinter> c"
   unfolding DC_def by(simp add:ac_simps)
 
 lemma DC_idem:
   "a \<Sqinter> a = a"
   unfolding DC_def by(simp)
 
 lemma AC_comm[ac_simps]:
   "a \<Squnion> b = b \<Squnion> a"
   unfolding AC_def by(simp add:ac_simps)
 
 lemma AC_assoc[ac_simps]:
   "a \<Squnion> (b \<Squnion> c) = (a \<Squnion> b) \<Squnion> c"
   unfolding AC_def by(simp add:ac_simps)
 
 lemma AC_idem:
   "a \<Squnion> a = a"
   unfolding AC_def by(simp)
 
 lemma PC_quasi_comm:
   "a \<^bsub>p\<^esub>\<oplus> b = b \<^bsub>(\<lambda>s. 1 - p s)\<^esub>\<oplus> a"
   unfolding PC_def by(simp add:algebra_simps)
 
 lemma PC_idem:
   "a \<^bsub>p\<^esub>\<oplus> a = a"
   unfolding PC_def by(simp add:algebra_simps)
 
 lemma Seq_assoc[ac_simps]:
   "A ;; (B ;; C) = A ;; B ;; C"
   by(simp add:Seq_def o_def)
 
 lemma Abort_refines[intro]:
   "well_def a \<Longrightarrow> Abort \<sqsubseteq> a"
   by(rule refinesI, unfold wp_eval, auto dest!:well_def_wp_healthy)
 
 subsubsection \<open>Laws relating demonic choice and refinement\<close>
 
 lemma left_refines_DC:
   "(a \<Sqinter> b) \<sqsubseteq> a"
   by(auto intro!:refinesI simp:wp_eval)
 
 lemma right_refines_DC:
   "(a \<Sqinter> b) \<sqsubseteq> b"
   by(auto intro!:refinesI simp:wp_eval)
 
 lemma DC_refines:
   fixes a::"'s prog" and b and c
   assumes rab: "a \<sqsubseteq> b" and rac: "a \<sqsubseteq> c"
   shows "a \<sqsubseteq> (b \<Sqinter> c)"
 proof
   fix P::"'s \<Rightarrow> real" assume sP: "sound P"
   with assms have "wp a P \<tturnstile> wp b P" and "wp a P \<tturnstile> wp c P"
     by(auto dest:refinesD)
   thus "wp a P \<tturnstile> wp (b \<Sqinter> c) P"
     by(auto simp:wp_eval intro:min.boundedI)
 qed
 
 lemma DC_mono:
   fixes a::"'s prog"
   assumes rab: "a \<sqsubseteq> b" and rcd: "c \<sqsubseteq> d"
   shows "(a \<Sqinter> c) \<sqsubseteq> (b \<Sqinter> d)"
 proof(rule refinesI, unfold wp_eval, rule le_funI)
   fix P::"'s \<Rightarrow> real" and s::'s
   assume sP: "sound P"
   with assms have "wp a P s \<le> wp b P s" and "wp c P s \<le> wp d P s"
     by(auto)
   thus "min (wp a P s) (wp c P s) \<le> min (wp b P s) (wp d P s)"
     by(auto)
 qed
 
 subsubsection \<open>Laws relating angelic choice and refinement\<close>
 
 lemma left_refines_AC:
   "a \<sqsubseteq> (a \<Squnion> b)"
   by(auto intro!:refinesI simp:wp_eval)
 
 lemma right_refines_AC:
   "b \<sqsubseteq> (a \<Squnion> b)"
   by(auto intro!:refinesI simp:wp_eval)
 
 lemma AC_refines:
   fixes a::"'s prog" and b and c
   assumes rac: "a \<sqsubseteq> c" and rbc: "b \<sqsubseteq> c"
   shows "(a \<Squnion> b) \<sqsubseteq> c"
 proof
   fix P::"'s \<Rightarrow> real" assume sP: "sound P"
   with assms have "\<And>s. wp a P s \<le> wp c P s"
               and "\<And>s. wp b P s \<le> wp c P s"
     by(auto dest:refinesD)
   thus "wp (a \<Squnion> b) P \<tturnstile> wp c P"
     unfolding wp_eval by(auto)
 qed
 
 lemma AC_mono:
   fixes a::"'s prog"
   assumes rab: "a \<sqsubseteq> b" and rcd: "c \<sqsubseteq> d"
   shows "(a \<Squnion> c) \<sqsubseteq> (b \<Squnion> d)"
 proof(rule refinesI, unfold wp_eval, rule le_funI)
   fix P::"'s \<Rightarrow> real" and s::'s
   assume sP: "sound P"
   with assms have "wp a P s \<le> wp b P s" and "wp c P s \<le> wp d P s"
     by(auto)
   thus "max (wp a P s) (wp c P s) \<le> max (wp b P s) (wp d P s)"
     by(auto)
 qed
 
 subsubsection \<open>Laws depending on the arithmetic of @{term "a \<^bsub>p\<^esub>\<oplus> b"} and @{term "a \<Sqinter> b"}
 together\<close>
 
 lemma DC_refines_PC:
   assumes unit: "unitary p"
   shows "(a \<Sqinter> b) \<sqsubseteq> (a \<^bsub>p\<^esub>\<oplus> b)"
 proof(rule refinesI, unfold wp_eval, rule le_funI)
   fix s and P::"'a \<Rightarrow> real" assume sound: "sound P"
   from unit have nn_p: "0 \<le> p s" by(blast)
   from unit have "p s \<le> 1" by(blast)
   hence nn_np: "0 \<le> 1 - p s" by(simp)
   show "min (wp a P s) (wp b P s) \<le> p s * wp a P s + (1 - p s) * wp b P s"
   proof(cases "wp a P s \<le> wp b P s",
       simp_all add:min.absorb1 min.absorb2)
     case True note le = this
     have "wp a P s = (p s + (1 - p s)) * wp a P s" by(simp)
     also have "... = p s * wp a P s + (1 - p s) * wp a P s"
       by(simp only: distrib_right)
     also {
       from le and nn_np have "(1 - p s) * wp a P s \<le> (1 - p s) * wp b P s"
         by(rule mult_left_mono)
       hence "p s * wp a P s + (1 - p s) * wp a P s \<le>
         p s * wp a P s + (1 - p s) * wp b P s"
         by(rule add_left_mono)
     }
     finally show "wp a P s \<le> p s * wp a P s + (1 - p s) * wp b P s" .
   next
     case False
     then have le: "wp b P s \<le> wp a P s" by(simp)
     have "wp b P s = (p s + (1 - p s)) * wp b P s" by(simp)
     also have "... = p s * wp b P s + (1 - p s) * wp b P s"
       by(simp only:distrib_right)
     also {
       from le and nn_p have "p s * wp b P s \<le> p s * wp a P s"
         by(rule mult_left_mono)
       hence "p s * wp b P s + (1 - p s) * wp b P s \<le>
         p s * wp a P s + (1 - p s) * wp b P s"
         by(rule add_right_mono)
     }
     finally show "wp b P s \<le> p s * wp a P s + (1 - p s) * wp b P s" .
   qed
 qed
 
 subsubsection \<open>Laws depending on the arithmetic of @{term "a \<^bsub>p\<^esub>\<oplus> b"} and @{term "a \<Squnion> b"}
 together\<close>
 
 lemma PC_refines_AC:
   assumes unit: "unitary p"
   shows "(a \<^bsub>p\<^esub>\<oplus> b) \<sqsubseteq> (a \<Squnion> b)"
 proof(rule refinesI, unfold wp_eval, rule le_funI)
   fix s and P::"'a \<Rightarrow> real" assume sound: "sound P"
 
   from unit have "p s \<le> 1" by(blast)
   hence nn_np: "0 \<le> 1 - p s" by(simp)
 
   show "p s * wp a P s + (1 - p s) * wp b P s \<le>
         max (wp a P s) (wp b P s)"
   proof(cases "wp a P s \<le> wp b P s")
     case True note leab = this
     with unit nn_np
     have "p s * wp a P s + (1 - p s) * wp b P s \<le>
           p s * wp b P s + (1 - p s) * wp b P s"
       by(auto intro:add_mono mult_left_mono)
     also have "... = wp b P s"
       by(auto simp:field_simps)
     also from leab
     have "... = max (wp a P s) (wp b P s)"
       by(auto)
     finally show ?thesis .
   next
     case False note leba = this
     with unit nn_np
     have "p s * wp a P s + (1 - p s) * wp b P s \<le>
           p s * wp a P s + (1 - p s) * wp a P s"
       by(auto intro:add_mono mult_left_mono)
     also have "... = wp a P s"
       by(auto simp:field_simps)
     also from leba
     have "... = max (wp a P s) (wp b P s)"
       by(auto)
     finally show ?thesis .
   qed
 qed
 
 subsubsection \<open>Laws depending on the arithmetic of @{term "a \<Squnion> b"} and @{term "a \<Sqinter> b"} together
 \<close>
 
 lemma DC_refines_AC:
   "(a \<Sqinter> b) \<sqsubseteq> (a \<Squnion> b)"
   by(auto intro!:refinesI simp:wp_eval)
 
 subsubsection \<open>Laws Involving Refinement and Equivalence\<close>
 
 lemma pr_trans[trans]:
   fixes A::"'a prog"
   assumes prAB: "A \<sqsubseteq> B"
       and prBC: "B \<sqsubseteq> C"
   shows "A \<sqsubseteq> C"
 proof
   fix P::"'a \<Rightarrow> real" assume sP: "sound P"
   with prAB have "wp A P \<tturnstile> wp B P" by(blast)
   also from sP and prBC have "... \<tturnstile> wp C P" by(blast)
   finally show "wp A P \<tturnstile> ..." .
 qed
 
 lemma pequiv_refl[intro!,simp]:
   "a \<simeq> a"
   by(auto)
 
 lemma pequiv_comm[ac_simps]:
   "a \<simeq> b \<longleftrightarrow> b \<simeq> a"
   unfolding pequiv_def
   by(rule iffI, safe, simp_all)
 
 lemma pequiv_pr[dest]:
   "a \<simeq> b \<Longrightarrow> a \<sqsubseteq> b"
   by(auto)
 
 lemma pequiv_trans[intro,trans]:
   "\<lbrakk> a \<simeq> b; b \<simeq> c \<rbrakk> \<Longrightarrow> a \<simeq> c"
   unfolding pequiv_def by(auto intro!:order_trans)
 
 lemma pequiv_pr_trans[intro,trans]:
   "\<lbrakk> a \<simeq> b; b \<sqsubseteq> c \<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
   unfolding pequiv_def refines_def by(simp)
 
 lemma pr_pequiv_trans[intro,trans]:
   "\<lbrakk> a \<sqsubseteq> b; b \<simeq> c \<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
   unfolding pequiv_def refines_def by(simp)
 
 text \<open>Refinement induces equivalence by antisymmetry:\<close>
 lemma pequiv_antisym:
   "\<lbrakk> a \<sqsubseteq> b; b \<sqsubseteq> a \<rbrakk> \<Longrightarrow> a \<simeq> b"
   by(auto intro:antisym)
 
 lemma pequiv_DC:
   "\<lbrakk> a \<simeq> c; b \<simeq> d \<rbrakk> \<Longrightarrow> (a \<Sqinter> b) \<simeq> (c \<Sqinter> d)"
   by(auto intro!:DC_mono pequiv_antisym simp:ac_simps)
 
 lemma pequiv_AC:
   "\<lbrakk> a \<simeq> c; b \<simeq> d \<rbrakk> \<Longrightarrow> (a \<Squnion> b) \<simeq> (c \<Squnion> d)"
   by(auto intro!:AC_mono pequiv_antisym simp:ac_simps)
 
 subsection \<open>Deterministic Programs are Maximal\<close>
 
 text \<open>Any sub-additive refinement of a deterministic program is in fact an equivalence.
 Deterministic programs are thus maximal (under the refinement order) among sub-additive programs.
 \<close>
 lemma refines_determ:
   fixes a::"'s prog"
   assumes da: "determ (wp a)"
       and wa: "well_def a"
       and wb: "well_def b"
       and dr: "a \<sqsubseteq> b"
   shows "a \<simeq> b"
   txt \<open>Proof by contradiction.\<close>
 proof(rule pequivI, rule contrapos_pp)
   from wb have "feasible (wp b)" by(auto)
   with wb have sab: "sub_add (wp b)"
     by(auto dest: sublinear_subadd[OF well_def_wp_sublinear])
   fix P::"'s \<Rightarrow> real" assume sP: "sound P"
   txt \<open>Assume that @{term a} and @{term b} are not equivalent:\<close>
   assume ne: "wp a P \<noteq> wp b P"
   txt \<open>Find a point at which they differ.  As @{term "a \<sqsubseteq> b"},
     @{term "wp b P s"} must by strictly greater than @{term "wp a P s"}
     here:\<close>
   hence "\<exists>s. wp a P s < wp b P s"
   proof(rule contrapos_np)
     assume "\<not>(\<exists>s. wp a P s < wp b P s)"
     hence "\<forall>s. wp b P s \<le> wp a P s" by(auto simp:not_less)
     hence "wp b P \<tturnstile> wp a P" by(auto)
     moreover from sP dr have "wp a P \<tturnstile> wp b P" by(auto)
     ultimately show "wp a P = wp b P" by(auto)
   qed
   then obtain s where less: "wp a P s < wp b P s" by(blast)
   txt \<open>Take a carefully constructed expectation:\<close>
   let ?Pc = "\<lambda>s. bound_of P - P s"
   have sPc: "sound ?Pc"
   proof(rule soundI)
     from sP have "\<And>s. 0 \<le> P s" by(auto)
     hence "\<And>s. ?Pc s \<le> bound_of P" by(auto)
     thus "bounded ?Pc" by(blast)
     from sP have "\<And>s. P s \<le> bound_of P" by(auto)
-    hence "\<And>s. 0 \<le> ?Pc s" by(auto simp:sign_simps)
+    hence "\<And>s. 0 \<le> ?Pc s"
+      by auto
     thus "nneg ?Pc" by(auto)
   qed
   txt \<open>We then show that @{term "wp b"} violates feasibility, and
     thus healthiness.\<close>
   from sP have "0 \<le> bound_of P" by(auto)
   with da have "bound_of P = wp a (\<lambda>s. bound_of P) s"
     by(simp add:maximalD determ_maximalD)
   also have "... = wp a (\<lambda>s. ?Pc s + P s) s"
     by(simp)
   also from da sP sPc have "... = wp a ?Pc s + wp a P s"
     by(subst additiveD[OF determ_additiveD], simp_all add:sP sPc)
   also from sPc dr have "... \<le> wp b ?Pc s + wp a P s"
     by(auto)
   also from less have "... < wp b ?Pc s + wp b P s"
     by(auto)
   also from sab sP sPc have "... \<le> wp b (\<lambda>s. ?Pc s + P s) s"
     by(blast)
   finally have "\<not>wp b (\<lambda>s. bound_of P) s \<le> bound_of P"
     by(simp)
   thus "\<not>bounded_by (bound_of P) (wp b (\<lambda>s. bound_of P))"
     by(auto)
 next  
   txt \<open>However,\<close>
   fix P::"'s \<Rightarrow> real" assume sP: "sound P"
   hence "nneg (\<lambda>s. bound_of P)" by(auto)
   moreover have "bounded_by (bound_of P) (\<lambda>s. bound_of P)" by(auto)
   ultimately
   show "bounded_by (bound_of P) (wp b (\<lambda>s. bound_of P))"
     using wb by(auto dest!:well_def_wp_healthy)
 qed
 
 subsection \<open>The Algebraic Structure of Refinement\<close>
 
 text \<open>Well-defined programs form a half-bounded semilattice under refinement, where @{term Abort}
 is bottom, and @{term "a \<Sqinter> b"} is @{term inf}. There is no unique top element, but all
 fully-deterministic programs are maximal.
 
 The type that we construct here is not especially useful, but serves as a convenient way to express
 this result.\<close>
 
 quotient_type 's program =
   "'s prog" / partial : "\<lambda>a b. a \<simeq> b \<and> well_def a \<and> well_def b"
 proof(rule part_equivpI)
   have "Skip \<simeq> Skip" and "well_def Skip" by(auto intro:wd_intros)
   thus "\<exists>x. x \<simeq> x \<and> well_def x \<and> well_def x" by(blast)
   show "symp (\<lambda>a b. a \<simeq> b \<and> well_def a \<and> well_def b)"
   proof(rule sympI, safe)
     fix a::"'a prog" and b
     assume "a \<simeq> b"
     hence "equiv_trans (wp a) (wp b)"
       by(simp add:pequiv_equiv_trans)
     thus "b \<simeq> a" by(simp add:ac_simps pequiv_equiv_trans)
   qed
   show "transp (\<lambda>a b. a \<simeq> b \<and> well_def a \<and> well_def b)"
     by(rule transpI, safe, rule pequiv_trans)
 qed
 
 instantiation program :: (type) semilattice_inf begin
 lift_definition
   less_eq_program :: "'a program \<Rightarrow> 'a program \<Rightarrow> bool" is refines
 proof(safe)
   fix a::"'a prog" and b c d
   assume "a \<simeq> b" hence "b \<simeq> a" by(simp add:ac_simps)
   also assume "a \<sqsubseteq> c"
   also assume "c \<simeq> d"
   finally show "b \<sqsubseteq> d" .
 next
   fix a::"'a prog" and b c d
   assume "a \<simeq> b"
   also assume "b \<sqsubseteq> d"
   also assume "c \<simeq> d" hence "d \<simeq> c" by(simp add:ac_simps)
   finally show "a \<sqsubseteq> c" .
 qed (* XXX - what's up here? *)
 
 lift_definition
   less_program :: "'a program \<Rightarrow> 'a program \<Rightarrow> bool"
   is "\<lambda>a b. a \<sqsubseteq> b \<and> \<not> b \<sqsubseteq> a"
 proof(safe)
   fix a::"'a prog" and b c d
   assume "a \<simeq> b" hence "b \<simeq> a" by(simp add:ac_simps)
   also assume "a \<sqsubseteq> c"
   also assume "c \<simeq> d"
   finally show "b \<sqsubseteq> d" .
 next
   fix a::"'a prog" and b c d
   assume "a \<simeq> b"
   also assume "b \<sqsubseteq> d"
   also assume "c \<simeq> d" hence "d \<simeq> c" by(simp add:ac_simps)
   finally show "a \<sqsubseteq> c" .
 next
   fix a b and c::"'a prog" and d
   assume "c \<simeq> d"
   also assume "d \<sqsubseteq> b"
   also assume "a \<simeq> b" hence "b \<simeq> a" by(simp add:ac_simps)
   finally have "c \<sqsubseteq> a" .
   moreover assume "\<not> c \<sqsubseteq> a"
   ultimately show False by(auto)
 next
   fix a b and c::"'a prog" and d
   assume "c \<simeq> d" hence "d \<simeq> c" by(simp add:ac_simps)
   also assume "c \<sqsubseteq> a"
   also assume "a \<simeq> b"
   finally have "d \<sqsubseteq> b" .
   moreover assume "\<not> d \<sqsubseteq> b"
   ultimately show False by(auto)
 qed
 
 lift_definition
   inf_program :: "'a program \<Rightarrow> 'a program \<Rightarrow> 'a program" is DC
 proof(safe)
   fix a b c d::"'s prog"
   assume "a \<simeq> b" and "c \<simeq> d"
   thus "(a \<Sqinter> c) \<simeq> (b \<Sqinter> d)" by(rule pequiv_DC)
 next
   fix a c::"'s prog"
   assume "well_def a" "well_def c"
   thus "well_def (a \<Sqinter> c)" by(rule wd_intros)
 next
   fix a c::"'s prog"
   assume "well_def a" "well_def c"
   thus "well_def (a \<Sqinter> c)" by(rule wd_intros)
 qed
 
 instance
 proof
   fix x y::"'a program"
   show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
     by(transfer, simp)
   show "x \<le> x"
     by(transfer, auto)
   show "inf x y \<le> x"
     by(transfer, rule left_refines_DC)
   show "inf x y \<le> y"
     by(transfer, rule right_refines_DC)
   assume "x \<le> y" and "y \<le> x" thus "x = y"
     by(transfer, iprover intro:pequiv_antisym)
 next
   fix x y z::"'a program"
   assume "x \<le> y" and "y \<le> z"
   thus "x \<le> z"
     by(transfer, iprover intro:pr_trans)
 next
   fix x y z::"'a program"
   assume "x \<le> y" and "x \<le> z"
   thus "x \<le> inf y z"
     by(transfer, iprover intro:DC_refines)
 qed
 end
 
 instantiation program :: (type) bot begin
 lift_definition
   bot_program :: "'a program" is Abort
   by(auto intro:wd_intros)
 
 instance ..
 end
 
 lemma eq_det: "\<And>a b::'s prog. \<lbrakk> a \<simeq> b; determ (wp a) \<rbrakk> \<Longrightarrow> determ (wp b)"
 proof(intro determI additiveI maximalI)
   fix a b::"'s prog" and P::"'s \<Rightarrow> real"
     and Q::"'s \<Rightarrow> real" and s::"'s"
   assume da: "determ (wp a)"
   assume sP: "sound P" and sQ: "sound Q"
     and eq: "a \<simeq> b"
   hence "wp b (\<lambda>s. P s + Q s) s =
          wp a (\<lambda>s. P s + Q s) s"
     by(simp add:sound_intros)
   also from da sP sQ
   have "... = wp a P s + wp a Q s"
     by(simp add:additiveD determ_additiveD)
   also from eq sP sQ
   have "... = wp b P s + wp b Q s"
     by(simp add:pequivD)
   finally show "wp b (\<lambda>s. P s + Q s) s = wp b P s + wp b Q s" .
 next
   fix a b::"'s prog" and c::real
   assume da: "determ (wp a)"
   assume "a \<simeq> b" hence "b \<simeq> a" by(simp add:ac_simps)
   moreover assume nn: "0 \<le> c"
   ultimately have "wp b (\<lambda>_. c) = wp a (\<lambda>_. c)"
     by(simp add:pequivD const_sound)
   also from da nn have "... = (\<lambda>_. c)"
     by(simp add:determ_maximalD maximalD)
   finally show "wp b (\<lambda>_. c) = (\<lambda>_. c)" .
 qed
 
 lift_definition
   pdeterm :: "'s program \<Rightarrow> bool"
   is "\<lambda>a. determ (wp a)"
 proof(safe)
   fix a b::"'s prog"
   assume "a \<simeq> b" and "determ (wp a)"
   thus "determ (wp b)" by(rule eq_det)
 next
   fix a b::"'s prog"
   assume "a \<simeq> b" hence "b \<simeq> a" by(simp add:ac_simps)
   moreover assume "determ (wp b)"
   ultimately show "determ (wp a)" by(rule eq_det)
 qed
 
 lemma determ_maximal:
   "\<lbrakk> pdeterm a; a \<le> x \<rbrakk> \<Longrightarrow> a = x"
   by(transfer, auto intro:refines_determ)
 
 subsection \<open>Data Refinement\<close>
 
 text \<open>A projective data refinement construction for pGCL. By projective, we mean that the abstract
 state is always a function (@{term \<phi>}) of the concrete state. Refinement may be predicated (@{term
 G}) on the state.\<close>
 
 definition
   drefines :: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'a prog \<Rightarrow> 'b prog \<Rightarrow> bool"
 where
   "drefines \<phi> G A B \<equiv> \<forall>P Q. (unitary P \<and> unitary Q \<and> (P \<tturnstile> wp A Q)) \<longrightarrow>
                             (\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp B (Q o \<phi>))"
 
 lemma drefinesD[dest]:
   "\<lbrakk> drefines \<phi> G A B; unitary P; unitary Q; P \<tturnstile> wp A Q \<rbrakk> \<Longrightarrow>
    \<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp B (Q o \<phi>)"
   unfolding drefines_def by(blast)
 
 text \<open>We can alternatively use G as an assumption:\<close>
 lemma drefinesD2:
   assumes dr:  "drefines \<phi> G A B"
       and uP:  "unitary P"
       and uQ:  "unitary Q"
       and wpA: "P \<tturnstile> wp A Q"
       and G:   "G s"
   shows "(P o \<phi>) s \<le> wp B (Q o \<phi>) s"
 proof -
   from uP have "0 \<le> (P o \<phi>) s" unfolding o_def by(blast)
   with G have "(P o \<phi>) s = (\<guillemotleft>G\<guillemotright> && (P o \<phi>)) s"
     by(simp add:exp_conj_def)
   also from assms have "... \<le> wp B (Q o \<phi>) s" by(blast)
   finally show "(P o \<phi>) s \<le> ..." .
 qed
 
 text \<open>This additional form is sometimes useful:\<close>
 lemma drefinesD3:
   assumes dr: "drefines \<phi> G a b"
       and G:  "G s"
       and uQ: "unitary Q"
       and wa: "well_def a"
   shows "wp a Q (\<phi> s) \<le> wp b (Q o \<phi>) s"
 proof -
   let "?L s'" = "wp a Q s'"
   from uQ wa have sL: "sound ?L" by(blast)
   from uQ wa have bL: "bounded_by 1 ?L" by(blast)
 
   have "?L \<tturnstile> ?L" by(simp)
   with sL and bL and assms
   show ?thesis
     by(blast intro:drefinesD2[OF dr, where P="?L", simplified])
 qed
 
 lemma drefinesI[intro]:
   "\<lbrakk> \<And>P Q. \<lbrakk> unitary P; unitary Q; P \<tturnstile> wp A Q \<rbrakk> \<Longrightarrow>
            \<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp B (Q o \<phi>) \<rbrakk> \<Longrightarrow>
    drefines \<phi> G A B"
   unfolding drefines_def by(blast)
 
 text \<open>Use G as an assumption, when showing refinement:\<close>
 lemma drefinesI2:
   fixes   A::"'a prog"
     and   B::"'b prog"
     and   \<phi>::"'b \<Rightarrow> 'a"
     and   G::"'b \<Rightarrow> bool"
   assumes wB: "well_def B"
       and withAs:
         "\<And>P Q s. \<lbrakk> unitary P; unitary Q;
                  G s; P \<tturnstile> wp A Q \<rbrakk> \<Longrightarrow> (P o \<phi>) s \<le> wp B (Q o \<phi>) s"
   shows "drefines \<phi> G A B"
 proof
   fix P and Q
   assume uP:  "unitary P"
      and uQ:  "unitary Q"
      and wpA: "P \<tturnstile> wp A Q"
 
   hence "\<And>s. G s \<Longrightarrow> (P o \<phi>) s \<le> wp B (Q o \<phi>) s"
     using withAs by(blast)
   moreover
   from uQ have "unitary (Q o \<phi>)"
     unfolding o_def by(blast)
   moreover
   from uP have "unitary (P o \<phi>)"
     unfolding o_def by(blast)
   ultimately
   show "\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp B (Q o \<phi>)"
     using wB by(blast intro:entails_pconj_assumption)
 qed
 
 lemma dr_strengthen_guard:
   fixes a::"'s prog" and b::"'t prog"
   assumes fg: "\<And>s. F s \<Longrightarrow> G s"
       and drab: "drefines \<phi> G a b"
   shows "drefines \<phi> F a b"
 proof(intro drefinesI)
   fix P Q::"'s expect"
   assume uP: "unitary P" and uQ: "unitary Q"
      and wp: "P \<tturnstile> wp a Q"
   from fg have "\<And>s. \<guillemotleft>F\<guillemotright> s \<le> \<guillemotleft>G\<guillemotright> s" by(simp add:embed_bool_def)
   hence "(\<guillemotleft>F\<guillemotright> && (P o \<phi>)) \<tturnstile> (\<guillemotleft>G\<guillemotright> && (P o \<phi>))" by(auto intro:pconj_mono le_funI simp:exp_conj_def)
   also from drab uP uQ wp have "... \<tturnstile> wp b (Q o \<phi>)" by(auto)
   finally show "\<guillemotleft>F\<guillemotright> && (P o \<phi>) \<tturnstile> wp b (Q o \<phi>)" .
 qed
 
 text \<open>Probabilistic correspondence, @{term pcorres}, is equality on distribution transformers,
 modulo a guard. It is the analogue, for data refinement, of program equivalence for program
 refinement.\<close>
 definition
   pcorres :: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'a prog \<Rightarrow> 'b prog \<Rightarrow> bool"
 where
   "pcorres \<phi> G A B \<longleftrightarrow>
    (\<forall>Q. unitary Q \<longrightarrow>  \<guillemotleft>G\<guillemotright> && (wp A Q o \<phi>) = \<guillemotleft>G\<guillemotright> && wp B (Q o \<phi>))"
 
 lemma pcorresI:
   "\<lbrakk> \<And>Q. unitary Q \<Longrightarrow> \<guillemotleft>G\<guillemotright> && (wp A Q o \<phi>) = \<guillemotleft>G\<guillemotright> && wp B (Q o \<phi>) \<rbrakk> \<Longrightarrow>
    pcorres \<phi> G A B"
   by(simp add:pcorres_def)
 
 text \<open>Often easier to use, as it allows one to assume the precondition.\<close>
 lemma pcorresI2[intro]:
   fixes A::"'a prog" and B::"'b prog"
   assumes withG: "\<And>Q s. \<lbrakk> unitary Q; G s \<rbrakk> \<Longrightarrow> wp A Q (\<phi> s)= wp B (Q o \<phi>) s"
       and wA: "well_def A"
       and wB: "well_def B"
   shows "pcorres \<phi> G A B"
 proof(rule pcorresI, rule ext)
   fix Q::"'a \<Rightarrow> real" and s::'b
   assume uQ: "unitary Q"
   hence uQ\<phi>: "unitary (Q o \<phi>)" by(auto)
   show "(\<guillemotleft>G\<guillemotright> && (wp A Q \<circ> \<phi>)) s = (\<guillemotleft>G\<guillemotright> && wp B (Q \<circ> \<phi>)) s"
   proof(cases "G s")
     case True note this
     moreover
     from well_def_wp_healthy[OF wA] uQ have "0 \<le> wp A Q (\<phi> s)" by(blast)
     moreover
     from well_def_wp_healthy[OF wB] uQ\<phi> have "0 \<le> wp B (Q o \<phi>) s" by(blast)
     ultimately show ?thesis
       using uQ by(simp add:exp_conj_def withG)
   next
     case False note this
     moreover
     from well_def_wp_healthy[OF wA] uQ have "wp A Q (\<phi> s) \<le> 1" by(blast)
     moreover
     from well_def_wp_healthy[OF wB] uQ\<phi> have "wp B (Q o \<phi>) s \<le> 1"
       by(blast dest!:healthy_bounded_byD intro:sound_nneg)
     ultimately show ?thesis by(simp add:exp_conj_def)
   qed
 qed
 
 lemma pcorresD:
   "\<lbrakk> pcorres \<phi> G A B; unitary Q \<rbrakk> \<Longrightarrow> \<guillemotleft>G\<guillemotright> && (wp A Q o \<phi>) = \<guillemotleft>G\<guillemotright> && wp B (Q o \<phi>)"
   unfolding pcorres_def by(simp)
 
 text \<open>Again, easier to use if the precondition is known to hold.\<close>
 lemma pcorresD2:
   assumes pc: "pcorres \<phi> G A B"
       and uQ: "unitary Q"
       and wA: "well_def A" and wB: "well_def B"
       and G: "G s"
   shows "wp A Q (\<phi> s) = wp B (Q o \<phi>) s"
 proof -
   from uQ well_def_wp_healthy[OF wA] have "0 \<le> wp A Q (\<phi> s)" by(auto)
   with G have "wp A Q (\<phi> s) = \<guillemotleft>G\<guillemotright> s .& wp A Q (\<phi> s)" by(simp)
   also {
     from pc uQ have "\<guillemotleft>G\<guillemotright> && (wp A Q o \<phi>) = \<guillemotleft>G\<guillemotright> && wp B (Q o \<phi>)"
       by(rule pcorresD)
     hence "\<guillemotleft>G\<guillemotright> s .& wp A Q (\<phi> s) = \<guillemotleft>G\<guillemotright> s .& wp B (Q o \<phi>) s"
       unfolding exp_conj_def o_def by(rule fun_cong)
   }
   also {
     from uQ have "sound Q" by(auto)
     hence "sound (Q o \<phi>)" by(auto intro:sound_intros)
     with well_def_wp_healthy[OF wB] have "0 \<le> wp B (Q o \<phi>) s" by(auto)
     with G have "\<guillemotleft>G\<guillemotright> s .& wp B (Q o \<phi>) s = wp B (Q o \<phi>) s" by(simp)
   }
   finally show ?thesis .
 qed
 
 subsection \<open>The Algebra of Data Refinement\<close>
 
 text \<open>Program refinement implies a trivial data refinement:\<close>
 lemma refines_drefines:
   fixes a::"'s prog"
   assumes rab: "a \<sqsubseteq> b" and wb: "well_def b"
   shows "drefines (\<lambda>s. s) G a b"
 proof(intro drefinesI2 wb, simp add:o_def)
   fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
   assume sQ: "unitary Q"
   assume "P \<tturnstile> wp a Q" hence "P s \<le> wp a Q s" by(auto)
   also from rab sQ have "... \<le> wp b Q s" by(auto)
   finally show "P s \<le> wp b Q s" .
 qed
 
 text \<open>Data refinement is transitive:\<close>
 lemma dr_trans[trans]:
   fixes A::"'a prog" and B::"'b prog" and C::"'c prog"
   assumes drAB: "drefines \<phi> G A B"
       and drBC: "drefines \<phi>' G' B C"
       and Gimp: "\<And>s. G' s \<Longrightarrow> G (\<phi>' s)"
   shows "drefines (\<phi> o \<phi>') G' A C"
 proof(rule drefinesI)
   fix P::"'a \<Rightarrow> real" and Q::"'a \<Rightarrow> real" and s::'a
   assume uP: "unitary P" and uQ: "unitary Q"
      and wpA: "P \<tturnstile> wp A Q"
 
   have "\<guillemotleft>G'\<guillemotright> && \<guillemotleft>G o \<phi>'\<guillemotright> = \<guillemotleft>G'\<guillemotright>"
   proof(rule ext, unfold exp_conj_def)
     fix x
     show "\<guillemotleft>G'\<guillemotright> x .& \<guillemotleft>G o \<phi>'\<guillemotright> x = \<guillemotleft>G'\<guillemotright> x" (is ?X)
     proof(cases "G' x")
       case False then show ?X by(simp)
     next
       case True
       moreover
       with Gimp have "(G o \<phi>') x" by(simp add:o_def)
       ultimately
       show ?X by(simp)
     qed
   qed
 
   with uP
   have "\<guillemotleft>G'\<guillemotright> && (P o (\<phi> o \<phi>')) = \<guillemotleft>G'\<guillemotright> && ((\<guillemotleft>G\<guillemotright> && (P o \<phi>)) o \<phi>')"
     by(simp add:exp_conj_assoc o_assoc)
 
   also {
     from uP uQ wpA and drAB
     have "\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp B (Q o \<phi>)"
       by(blast intro:drefinesD)
 
     with drBC and uP uQ
     have "\<guillemotleft>G'\<guillemotright> && ((\<guillemotleft>G\<guillemotright> && (P o \<phi>)) o \<phi>') \<tturnstile> wp C ((Q o \<phi>) o \<phi>')"
       by(blast intro:unitary_intros drefinesD)
   }
 
   finally
   show "\<guillemotleft>G'\<guillemotright> && (P o (\<phi> o \<phi>')) \<tturnstile> wp C (Q o (\<phi> o \<phi>'))"
     by(simp add:o_assoc)
 qed
 
 text \<open>Data refinement composes with program refinement:\<close>
 lemma pr_dr_trans[trans]:
   assumes prAB: "A \<sqsubseteq> B"
       and drBC: "drefines \<phi> G B C"
   shows "drefines \<phi> G A C"
 proof(rule drefinesI)
   fix P and Q
   assume uP:  "unitary P"
      and uQ:  "unitary Q"
      and wpA: "P \<tturnstile> wp A Q"
 
   note wpA
   also from uQ and prAB have "wp A Q \<tturnstile> wp B Q" by(blast)
   finally have "P \<tturnstile> wp B Q" .
   with uP uQ drBC
   show "\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp C (Q o \<phi>)" by(blast intro:drefinesD)
 qed
 
 lemma dr_pr_trans[trans]:
   assumes drAB: "drefines \<phi> G A B"
   assumes prBC: "B \<sqsubseteq> C"
   shows "drefines \<phi> G A C"
 proof(rule drefinesI)
   fix P and Q
   assume uP:  "unitary P"
      and uQ:  "unitary Q"
      and wpA: "P \<tturnstile> wp A Q"
 
   with drAB have "\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp B (Q o \<phi>)" by(blast intro:drefinesD)
   also from uQ prBC have "... \<tturnstile> wp C (Q o \<phi>)" by(blast)
   finally show "\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> ..." .
 qed
 
 text \<open>If the projection @{term \<phi>} commutes with the transformer, then data refinement is
 reflexive:\<close>
 lemma dr_refl:
   assumes wa: "well_def a"
       and comm: "\<And>Q. unitary Q \<Longrightarrow> wp a Q o \<phi> \<tturnstile> wp a (Q o \<phi>)"
   shows "drefines \<phi> G a a"
 proof(intro drefinesI2 wa)
   fix P and Q and s
   assume wp: "P \<tturnstile> wp a Q"
   assume uQ: "unitary Q"
 
   have "(P o \<phi>) s = P (\<phi> s)" by(simp)
   also from wp have "... \<le> wp a Q (\<phi> s)" by(blast)
   also {
     from comm uQ have "wp a Q o \<phi> \<tturnstile> wp a (Q o \<phi>)" by(blast)
     hence "(wp a Q o \<phi>) s \<le> wp a (Q o \<phi>) s" by(blast)
     hence "wp a Q (\<phi> s) \<le> ..." by(simp)
   }
   finally show  "(P o \<phi>) s \<le> wp a (Q o \<phi>) s" .
 qed
 
 text \<open>Correspondence implies data refinement\<close>
 lemma pcorres_drefine:
   assumes corres: "pcorres \<phi> G A C"
       and wC: "well_def C"
   shows "drefines \<phi> G A C"
 proof
   fix P and Q
   assume uP: "unitary P" and uQ: "unitary Q"
      and wpA: "P \<tturnstile> wp A Q"
   from wpA have "P o \<phi> \<tturnstile> wp A Q o \<phi>" by(simp add:o_def le_fun_def)
   hence "\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> \<guillemotleft>G\<guillemotright> && (wp A Q o \<phi>)"
     by(rule exp_conj_mono_right)
   also from corres uQ
   have "... = \<guillemotleft>G\<guillemotright> && (wp C (Q o \<phi>))" by(rule pcorresD)
   also
   have "... \<tturnstile> wp C (Q o \<phi>)"
   proof(rule le_funI)
     fix s
     from uQ have "unitary (Q o \<phi>)" by(rule unitary_intros)
     with well_def_wp_healthy[OF wC] have nn_wpC: "0 \<le> wp C (Q o \<phi>) s" by(blast)
     show "(\<guillemotleft>G\<guillemotright> && wp C (Q o \<phi>)) s \<le> wp C (Q o \<phi>) s"
     proof(cases "G s")
       case True
       with nn_wpC show ?thesis by(simp add:exp_conj_def)
     next
       case False note this
       moreover {
         from uQ have "unitary (Q o \<phi>)" by(simp)
         with well_def_wp_healthy[OF wC] have "wp C (Q o \<phi>) s \<le> 1" by(auto)
       }
       moreover note nn_wpC
       ultimately show ?thesis by(simp add:exp_conj_def)
     qed
   qed
   finally show "\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp C (Q o \<phi>)" .
 qed
 
 text \<open>Any \emph{data} refinement of a deterministic program is correspondence. This is the
 analogous result to that relating program refinement and equivalence.\<close>
 lemma drefines_determ:
   fixes a::"'a prog" and b::"'b prog"
   assumes da: "determ (wp a)"
       and wa: "well_def a"
       and wb: "well_def b"
       and dr: "drefines \<phi> G a b"
   shows "pcorres \<phi> G a b"
   txt \<open>The proof follows exactly the same form
     as that for program refinement: Assuming that correspondence
     \emph{doesn't} hold, we show that @{term "wp b"} is not feasible,
     and thus not healthy, contradicting the assumption.\<close>
 proof(rule pcorresI, rule contrapos_pp)
   from wb show "feasible (wp b)" by(auto)
 
   note ha = well_def_wp_healthy[OF wa]
   note hb = well_def_wp_healthy[OF wb]
 
   from wb have "sublinear (wp b)" by(auto)
   moreover from hb have "feasible (wp b)" by(auto)
   ultimately have sab: "sub_add (wp b)" by(rule sublinear_subadd)
 
   fix Q::"'a \<Rightarrow> real"
   assume uQ: "unitary Q"
   hence uQ\<phi>: "unitary (Q o \<phi>)" by(auto)
   assume ne: "\<guillemotleft>G\<guillemotright> && (wp a Q o \<phi>) \<noteq> \<guillemotleft>G\<guillemotright> && wp b (Q o \<phi>)"
   hence ne': "wp a Q o \<phi> \<noteq> wp b (Q o \<phi>)" by(auto)
 
   txt \<open>From refinement, @{term "\<guillemotleft>G\<guillemotright> && (wp a Q o \<phi>)"}
     lies below @{term "\<guillemotleft>G\<guillemotright> && wp b (Q o \<phi>)"}.\<close>
   from ha uQ
   have gle: "\<guillemotleft>G\<guillemotright> && (wp a Q o \<phi>) \<tturnstile> wp b (Q o \<phi>)" by(blast intro!:drefinesD[OF dr])
   have le: "\<guillemotleft>G\<guillemotright> && (wp a Q o \<phi>) \<tturnstile> \<guillemotleft>G\<guillemotright> && wp b (Q o \<phi>)"
     unfolding exp_conj_def
   proof(rule le_funI)
     fix s
     from gle have "\<guillemotleft>G\<guillemotright> s .& (wp a Q o \<phi>) s \<le> wp b (Q o \<phi>) s"
       unfolding exp_conj_def by(auto)
     hence "\<guillemotleft>G\<guillemotright> s .& (\<guillemotleft>G\<guillemotright> s .& (wp a Q o \<phi>) s) \<le> \<guillemotleft>G\<guillemotright> s .& wp b (Q o \<phi>) s"
       by(auto intro:pconj_mono)
     moreover from uQ ha have "wp a Q (\<phi> s) \<le> 1"
       by(auto dest:healthy_bounded_byD)
     moreover from uQ ha have "0 \<le> wp a Q (\<phi> s)"
       by(auto)
     ultimately
     show "\<guillemotleft> G \<guillemotright> s .& (wp a Q \<circ> \<phi>) s \<le> \<guillemotleft> G \<guillemotright> s .& wp b (Q \<circ> \<phi>) s"
       by(simp add:pconj_assoc)
   qed
 
   txt \<open>If the programs do not correspond, the terms must differ somewhere, and given the previous
   result, the second must be somewhere strictly larger than the first:\<close>
   have nle: "\<exists>s. (\<guillemotleft>G\<guillemotright> && (wp a Q o \<phi>)) s < (\<guillemotleft>G\<guillemotright> && wp b (Q o \<phi>)) s"
   proof(rule contrapos_np[OF ne], rule ext, rule antisym)
     fix s
     from le show "(\<guillemotleft>G\<guillemotright> && (wp a Q o \<phi>)) s \<le> (\<guillemotleft>G\<guillemotright> && wp b (Q o \<phi>)) s"
       by(blast)
   next
     fix s
     assume "\<not> (\<exists>s. (\<guillemotleft>G\<guillemotright> && (wp a Q \<circ> \<phi>)) s < (\<guillemotleft>G\<guillemotright> && wp b (Q \<circ> \<phi>)) s)"
     thus " (\<guillemotleft>G\<guillemotright> && (wp b (Q \<circ> \<phi>))) s \<le> (\<guillemotleft>G\<guillemotright> && (wp a Q \<circ> \<phi>)) s"
       by(simp add:not_less)
   qed
   from this obtain s where less_s:
     "(\<guillemotleft>G\<guillemotright> && (wp a Q \<circ> \<phi>)) s < (\<guillemotleft>G\<guillemotright> && wp b (Q \<circ> \<phi>)) s"
     by(blast)
   txt \<open>The transformers themselves must differ at this point:\<close>
   hence larger: "wp a Q (\<phi> s) < wp b (Q \<circ> \<phi>) s"
   proof(cases "G s")
     case True
     moreover from ha uQ have "0 \<le> wp a Q (\<phi> s)"
       by(blast)
     moreover from hb uQ\<phi> have "0 \<le> wp b (Q o \<phi>) s"
       by(blast)
     moreover note less_s
     ultimately show ?thesis by(simp add:exp_conj_def)
   next
     case False
     moreover from ha uQ have "wp a Q (\<phi> s) \<le> 1"
       by(blast)
     moreover {
       from uQ have "bounded_by 1 (Q o \<phi>)"
         by(blast)
       moreover from unitary_sound[OF uQ]
       have "sound (Q o \<phi>)" by(auto)
       ultimately have "wp b (Q o \<phi>) s \<le> 1"
         using hb by(auto)
     }
     moreover note less_s
     ultimately show ?thesis by(simp add:exp_conj_def)
   qed
   from less_s have "(\<guillemotleft>G\<guillemotright> && (wp a Q \<circ> \<phi>)) s \<noteq> (\<guillemotleft>G\<guillemotright> && wp b (Q \<circ> \<phi>)) s"
     by(force)
   txt \<open>@{term G} must also hold, as otherwise both would be zero.\<close>
   hence G_s: "G s"
   proof(rule contrapos_np)
     assume nG: "\<not> G s"
     moreover from ha uQ have "wp a Q (\<phi> s) \<le> 1"
       by(blast)
     moreover {
       from uQ have "bounded_by 1 (Q o \<phi>)"
         by(blast)
       moreover from unitary_sound[OF uQ]
       have "sound (Q o \<phi>)" by(auto)
       ultimately have "wp b (Q o \<phi>) s \<le> 1"
         using hb by(auto)
     }
     ultimately
     show "(\<guillemotleft>G\<guillemotright> && (wp a Q \<circ> \<phi>)) s = (\<guillemotleft>G\<guillemotright> && wp b (Q \<circ> \<phi>)) s"
       by(simp add:exp_conj_def)
   qed
 
   txt \<open>Take a carefully constructed expectation:\<close>
   let ?Qc = "\<lambda>s. bound_of Q - Q s"
   have bQc: "bounded_by 1 ?Qc"
   proof(rule bounded_byI)
     fix s
     from uQ have "bound_of Q \<le> 1" and "0 \<le> Q s" by(auto)
     thus "bound_of Q - Q s \<le> 1" by(auto)
   qed
   have sQc: "sound ?Qc"
   proof(rule soundI)
     from bQc show "bounded ?Qc" by(auto)
 
     show "nneg ?Qc"
     proof(rule nnegI)
       fix s
       from uQ have "Q s \<le> bound_of Q" by(auto)
       thus "0 \<le> bound_of Q - Q s" by(auto)
     qed
   qed
 
   txt \<open>By the maximality of @{term "wp a"}, @{term "wp b"} must violate feasibility, by mapping
   @{term s} to something strictly greater than @{term "bound_of Q"}.\<close>
   from uQ have "0 \<le> bound_of Q" by(auto)
   with da have "bound_of Q = wp a (\<lambda>s. bound_of Q) (\<phi> s)"
     by(simp add:maximalD determ_maximalD)
   also have "wp a (\<lambda>s. bound_of Q) (\<phi> s) = wp a (\<lambda>s. Q s + ?Qc s) (\<phi> s)"
     by(simp)
   also {
     from da have "additive (wp a)" by(blast)
     with uQ sQc
     have "wp a (\<lambda>s. Q s + ?Qc s) (\<phi> s) =
           wp a Q (\<phi> s) + wp a ?Qc (\<phi> s)" by(subst additiveD, blast+)
   }
   also {
     from ha and sQc and bQc
     have "\<guillemotleft>G\<guillemotright> && (wp a ?Qc o \<phi>) \<tturnstile> wp b (?Qc o \<phi>)"
       by(blast intro!:drefinesD[OF dr])
     hence "(\<guillemotleft>G\<guillemotright> && (wp a ?Qc o \<phi>)) s \<le> wp b (?Qc o \<phi>) s"
       by(blast)
     moreover from sQc and ha
     have "0 \<le> wp a (\<lambda>s. bound_of Q - Q s) (\<phi> s)"
       by(blast)
     ultimately
     have "wp a ?Qc (\<phi> s) \<le> wp b (?Qc o \<phi>) s"
       using G_s by(simp add:exp_conj_def)
     hence "wp a Q (\<phi> s) + wp a ?Qc (\<phi> s) \<le> wp a Q (\<phi> s) + wp b (?Qc o \<phi>) s"
       by(rule add_left_mono)
     also with larger
     have "wp a Q (\<phi> s) + wp b (?Qc o \<phi>) s <
           wp b (Q o \<phi>) s + wp b (?Qc o \<phi>) s"
       by(auto)
     finally
     have "wp a Q (\<phi> s) + wp a ?Qc (\<phi> s) <
           wp b (Q o \<phi>) s + wp b (?Qc o \<phi>) s" .
   }
   also from sab and unitary_sound[OF uQ] and sQc
   have "wp b (Q o \<phi>) s + wp b (?Qc o \<phi>) s \<le>
         wp b (\<lambda>s. (Q o \<phi>) s + (?Qc o \<phi>) s) s"
     by(blast)
   also have "... = wp b (\<lambda>s. bound_of Q) s"
     by(simp)
   finally
   show "\<not> feasible (wp b)"
   proof(rule contrapos_pn)
     assume fb: "feasible (wp b)"
     have "bounded_by (bound_of Q) (\<lambda>s. bound_of Q)" by(blast)
     hence "bounded_by (bound_of Q) (wp b (\<lambda>s. bound_of Q))"
       using uQ by(blast intro:feasible_boundedD[OF fb])
     hence "wp b (\<lambda>s. bound_of Q) s \<le> bound_of Q" by(blast)
     thus "\<not> bound_of Q < wp b (\<lambda>s. bound_of Q) s" by(simp)
   qed
 qed
 
 subsection \<open>Structural Rules for Correspondence\<close>
 
 lemma pcorres_Skip:
   "pcorres \<phi> G Skip Skip"
   by(simp add:pcorres_def wp_eval)
 
 text \<open>Correspondence composes over sequential composition.\<close>
 lemma pcorres_Seq:
   fixes A::"'b prog" and B::"'c prog"
     and C::"'b prog" and D::"'c prog"
     and \<phi>::"'c \<Rightarrow> 'b"
   assumes pcAB: "pcorres \<phi> G A B"
       and pcCD: "pcorres \<phi> H C D"
       and wA: "well_def A" and wB: "well_def B"
       and wC: "well_def C" and wD: "well_def D"
       and p3p2: "\<And>Q. unitary Q \<Longrightarrow> \<guillemotleft>I\<guillemotright> && wp B Q = wp B (\<guillemotleft>H\<guillemotright> && Q)"
       and p1p3: "\<And>s. G s \<Longrightarrow> I s"
   shows "pcorres \<phi> G (A;;C) (B;;D)"
 proof(rule pcorresI)
   fix Q::"'b \<Rightarrow> real"
   assume uQ: "unitary Q"
   with well_def_wp_healthy[OF wC] have uCQ: "unitary (wp C Q)" by(auto)
   from uQ well_def_wp_healthy[OF wD] have uDQ: "unitary (wp D (Q o \<phi>))"
     by(auto dest:unitary_comp)
 
   have p3p1: "\<And>R S. \<lbrakk> unitary R; unitary S; \<guillemotleft>I\<guillemotright> && R = \<guillemotleft>I\<guillemotright> && S \<rbrakk> \<Longrightarrow>
                     \<guillemotleft>G\<guillemotright> && R = \<guillemotleft>G\<guillemotright> && S"
   proof(rule ext)
     fix R::"'c \<Rightarrow> real" and S::"'c \<Rightarrow> real" and s::'c
     assume a3: "\<guillemotleft>I\<guillemotright> && R = \<guillemotleft>I\<guillemotright> && S"
        and uR: "unitary R" and uS: "unitary S"
     show "(\<guillemotleft>G\<guillemotright> && R) s = (\<guillemotleft>G\<guillemotright> && S) s"
     proof(simp add:exp_conj_def, cases "G s")
       case False note this
       moreover from uR have "R s \<le> 1" by(blast)
       moreover from uS have "S s \<le> 1" by(blast)
       ultimately show "\<guillemotleft>G\<guillemotright> s .& R s = \<guillemotleft>G\<guillemotright> s .& S s"
         by(simp)
     next
       case True note p1 = this
       with p1p3 have "I s" by(blast)
       with fun_cong[OF a3, where x=s] have "1 .& R s = 1 .& S s"
         by(simp add:exp_conj_def)
       with p1 show "\<guillemotleft>G\<guillemotright> s .& R s = \<guillemotleft>G\<guillemotright> s .& S s"
         by(simp)
     qed
   qed
 
   show "\<guillemotleft>G\<guillemotright> && (wp (A;;C) Q o \<phi>) = \<guillemotleft>G\<guillemotright> && wp (B;;D) (Q o \<phi>)"
   proof(simp add:wp_eval)
     from uCQ pcAB have "\<guillemotleft>G\<guillemotright> && (wp A (wp C Q) \<circ> \<phi>) =
                         \<guillemotleft>G\<guillemotright> && wp B ((wp C Q) \<circ> \<phi>)"
       by(auto dest:pcorresD)
     also have "\<guillemotleft>G\<guillemotright> && wp B ((wp C Q) \<circ> \<phi>) =
                \<guillemotleft>G\<guillemotright> && wp B (wp D (Q \<circ> \<phi>))"
     proof(rule p3p1)
       from uCQ well_def_wp_healthy[OF wB] show "unitary (wp B (wp C Q \<circ> \<phi>))"
         by(auto intro:unitary_comp)
       from uDQ well_def_wp_healthy[OF wB] show "unitary (wp B (wp D (Q \<circ> \<phi>)))"
         by(auto)
 
       from uQ have "\<guillemotleft> H \<guillemotright> && (wp C Q \<circ> \<phi>) = \<guillemotleft> H \<guillemotright> && wp D (Q \<circ> \<phi>)"
         by(blast intro:pcorresD[OF pcCD])
       thus "\<guillemotleft> I \<guillemotright> && wp B (wp C Q \<circ> \<phi>) = \<guillemotleft> I \<guillemotright> && wp B (wp D (Q \<circ> \<phi>))"
         by(simp add:p3p2 uCQ uDQ)
     qed
     finally show "\<guillemotleft>G\<guillemotright> && (wp A (wp C Q) \<circ> \<phi>) = \<guillemotleft>G\<guillemotright> && wp B (wp D (Q \<circ> \<phi>))" .
   qed
 qed
 
 subsection \<open>Structural Rules for Data Refinement\<close>
 
 lemma dr_Skip:
   fixes \<phi>::"'c \<Rightarrow> 'b"
   shows "drefines \<phi> G Skip Skip"
 proof(intro drefinesI2 wd_intros)
   fix P::"'b \<Rightarrow> real" and Q::"'b \<Rightarrow> real" and s::'c
   assume "P \<tturnstile> wp Skip Q"
   hence "(P o \<phi>) s \<le> wp Skip Q (\<phi> s)" by(simp, blast)
   thus "(P o \<phi>) s \<le> wp Skip (Q o \<phi>) s" by(simp add:wp_eval)
 qed
 
 lemma dr_Abort:
   fixes \<phi>::"'c \<Rightarrow> 'b"
   shows "drefines \<phi> G Abort Abort"
 proof(intro drefinesI2 wd_intros)
   fix P::"'b \<Rightarrow> real" and Q::"'b \<Rightarrow> real" and s::'c
   assume "P \<tturnstile> wp Abort Q"
   hence "(P o \<phi>) s \<le> wp Abort Q (\<phi> s)" by(auto)
   thus "(P o \<phi>) s \<le> wp Abort (Q o \<phi>) s" by(simp add:wp_eval)
 qed
 
 lemma dr_Apply:
   fixes \<phi>::"'c \<Rightarrow> 'b"
   assumes commutes: "f o \<phi> = \<phi> o g"
   shows "drefines \<phi> G (Apply f) (Apply g)"
 proof(intro drefinesI2 wd_intros)
   fix P::"'b \<Rightarrow> real" and Q::"'b \<Rightarrow> real" and s::'c
 
   assume wp: "P \<tturnstile> wp (Apply f) Q"
   hence "P \<tturnstile> (Q o f)" by(simp add:wp_eval)
   hence "P (\<phi> s) \<le> (Q o f) (\<phi> s)" by(blast)
   also have "... = Q ((f o \<phi>) s)" by(simp)
   also with commutes
   have "... = ((Q o \<phi>) o g) s" by(simp)
   also have "... = wp (Apply g) (Q o \<phi>) s"
     by(simp add:wp_eval)
   finally show "(P o \<phi>) s \<le> wp (Apply g) (Q o \<phi>) s" by(simp)
 qed
 
 lemma dr_Seq:
   assumes drAB: "drefines \<phi> P A B"
       and drBC: "drefines \<phi> Q C D"
       and wpB:  "\<guillemotleft>P\<guillemotright> \<tturnstile> wp B \<guillemotleft>Q\<guillemotright>"
       and wB:   "well_def B"
       and wC:   "well_def C"
       and wD:   "well_def D"
   shows "drefines \<phi> P (A;;C) (B;;D)"
 proof
   fix R and S
   assume uR: "unitary R" and uS: "unitary S"
      and wpAC: "R \<tturnstile> wp (A;;C) S"
 
   from uR
   have "\<guillemotleft>P\<guillemotright> && (R o \<phi>) = \<guillemotleft>P\<guillemotright> && (\<guillemotleft>P\<guillemotright> && (R o \<phi>))"
     by(simp add:exp_conj_assoc)
 
   also {
     from well_def_wp_healthy[OF wC] uR uS
      and wpAC[unfolded eval_wp_Seq o_def]
     have "\<guillemotleft>P\<guillemotright> && (R o \<phi>) \<tturnstile> wp B (wp C S o \<phi>)"
       by(auto intro:drefinesD[OF drAB])
     with wpB well_def_wp_healthy[OF wC] uS
          sublinear_sub_conj[OF well_def_wp_sublinear, OF wB]
     have "\<guillemotleft>P\<guillemotright> && (\<guillemotleft>P\<guillemotright> && (R o \<phi>)) \<tturnstile> wp B (\<guillemotleft>Q\<guillemotright> && (wp C S o \<phi>))"
       by(auto intro!:entails_combine dest!:unitary_sound)
   }
 
   also {
     from uS well_def_wp_healthy[OF wC]
     have "\<guillemotleft>Q\<guillemotright> && (wp C S o \<phi>) \<tturnstile> wp D (S o \<phi>)"
       by(auto intro!:drefinesD[OF drBC])
     with well_def_wp_healthy[OF wB] well_def_wp_healthy[OF wC]
          well_def_wp_healthy[OF wD] and unitary_sound[OF uS]
     have "wp B (\<guillemotleft>Q\<guillemotright> && (wp C S o \<phi>)) \<tturnstile> wp B (wp D (S o \<phi>))"
       by(blast intro!:mono_transD)
   }
 
   finally
   show "\<guillemotleft>P\<guillemotright> && (R o \<phi>) \<tturnstile> wp (B;;D) (S o \<phi>)"
     unfolding wp_eval o_def .
 qed
 
 lemma dr_repeat:
   fixes \<phi> :: "'a \<Rightarrow> 'b"
   assumes dr_ab: "drefines \<phi> G a b"
       and Gpr:  "\<guillemotleft>G\<guillemotright> \<tturnstile> wp b \<guillemotleft>G\<guillemotright>"
       and wa:    "well_def a"
       and wb:    "well_def b"
   shows "drefines \<phi> G (repeat n a) (repeat n b)" (is "?X n")
 proof(induct n)
   show "?X 0" by(simp add:dr_Skip)
 
   fix n
   assume IH: "?X n"
   thus "?X (Suc n)" by(auto intro!:dr_Seq Gpr assms wd_intros)
 qed
 
 end
diff --git a/thys/pGCL/Continuity.thy b/thys/pGCL/Continuity.thy
--- a/thys/pGCL/Continuity.thy
+++ b/thys/pGCL/Continuity.thy
@@ -1,1010 +1,1016 @@
 (*
  * Copyright (C) 2014 NICTA
  * All rights reserved.
  *)
 
 (* Author: David Cock - David.Cock@nicta.com.au *)
 
 section \<open>Continuity\<close>
 
 theory Continuity imports Healthiness begin
 
 text \<open>We rely on one additional healthiness property, continuity, which is shown here seperately,
 as its proof relies, in general, on healthiness.  It is only relevant when a program appears
 in an inductive context i.e.~inside a loop.\<close>
 
 text \<open>A continuous transformer preserves limits (or the suprema of ascending chains).\<close>
 definition bd_cts :: "'s trans \<Rightarrow> bool"
 where "bd_cts t = (\<forall>M. (\<forall>i. (M i \<tturnstile> M (Suc i)) \<and> sound (M i)) \<longrightarrow>
                        (\<exists>b. \<forall>i. bounded_by b (M i)) \<longrightarrow>
                        t (Sup_exp (range M)) = Sup_exp (range (t o M)))"
 
 lemma bd_ctsD:
   "\<lbrakk> bd_cts t; \<And>i. M i \<tturnstile> M (Suc i); \<And>i. sound (M i); \<And>i. bounded_by b (M i) \<rbrakk> \<Longrightarrow>
    t (Sup_exp (range M)) = Sup_exp (range (t o M))"
   unfolding bd_cts_def by(auto)
 
 lemma bd_ctsI:
   "(\<And>b M. (\<And>i. M i \<tturnstile> M (Suc i)) \<Longrightarrow> (\<And>i. sound (M i)) \<Longrightarrow> (\<And>i. bounded_by b (M i)) \<Longrightarrow>
          t (Sup_exp (range M)) = Sup_exp (range (t o M))) \<Longrightarrow> bd_cts t"
   unfolding bd_cts_def by(auto)
 
 text \<open>A generalised property for transformers of transformers.\<close>
 definition bd_cts_tr :: "('s trans \<Rightarrow> 's trans) \<Rightarrow> bool"
 where "bd_cts_tr T = (\<forall>M. (\<forall>i. le_trans (M i) (M (Suc i)) \<and> feasible (M i)) \<longrightarrow>
                           equiv_trans (T (Sup_trans (M ` UNIV))) (Sup_trans ((T o M) ` UNIV)))"
 
 lemma bd_cts_trD:
   "\<lbrakk> bd_cts_tr T; \<And>i. le_trans (M i) (M (Suc i)); \<And>i. feasible (M i) \<rbrakk> \<Longrightarrow>
    equiv_trans (T (Sup_trans (M ` UNIV))) (Sup_trans ((T o M) ` UNIV))"
   by(simp add:bd_cts_tr_def)
 
 lemma bd_cts_trI:
   "(\<And>M. (\<And>i. le_trans (M i) (M (Suc i))) \<Longrightarrow> (\<And>i. feasible (M i)) \<Longrightarrow>
          equiv_trans (T (Sup_trans (M ` UNIV))) (Sup_trans ((T o M) ` UNIV))) \<Longrightarrow> bd_cts_tr T"
   by(simp add:bd_cts_tr_def)
 
 subsection \<open>Continuity of Primitives\<close>
 
 lemma cts_wp_Abort:
   "bd_cts (wp (Abort::'s prog))"
 proof -
   have X: "range (\<lambda>(i::nat) (s::'s). 0) = {\<lambda>s. 0}" by(auto)
   show ?thesis by(intro bd_ctsI, simp add:wp_eval o_def Sup_exp_def X)
 qed
 
 lemma cts_wp_Skip:
   "bd_cts (wp Skip)"
   by(rule bd_ctsI, simp add:wp_def Skip_def o_def)
 
 lemma cts_wp_Apply:
   "bd_cts (wp (Apply f))"
 proof -
   have X: "\<And>M s. {P (f s) |P. P \<in> range M} = {P s |P. P \<in> range (\<lambda>i s. M i (f s))}" by(auto)
   show ?thesis by(intro bd_ctsI ext, simp add:wp_eval o_def Sup_exp_def X)
 qed
 
 lemma cts_wp_Bind:
   fixes a::"'a \<Rightarrow> 's prog"
   assumes ca: "\<And>s. bd_cts (wp (a (f s)))"
   shows "bd_cts (wp (Bind f a))"
 proof(rule bd_ctsI)
   fix M::"nat \<Rightarrow> 's expect" and c::real
   assume chain: "\<And>i. M i \<tturnstile> M (Suc i)" and sM: "\<And>i. sound (M i)"
      and bM: "\<And>i. bounded_by c (M i)"
   with bd_ctsD[OF ca]
   have "\<And>s. wp (a (f s)) (Sup_exp (range M)) =
             Sup_exp (range (wp (a (f s)) o M))"
     by(auto)
   moreover have "\<And>s. {fa s |fa. fa \<in> range (\<lambda>x. wp (a (f s)) (M x))} =
                       {fa s |fa. fa \<in> range (\<lambda>x s. wp (a (f s)) (M x) s)}"
     by(auto)
   ultimately show "wp (Bind f a) (Sup_exp (range M)) =
                    Sup_exp (range (wp (Bind f a) \<circ> M))"
     by(simp add:wp_eval o_def Sup_exp_def)
 qed
 
 text \<open>The first nontrivial proof.  We transform the suprema into limits, and appeal to the
 continuity of the underlying operation (here infimum).  This is typical of the remainder of the
 nonrecursive elements.\<close>
 lemma cts_wp_DC:
   fixes a b::"'s prog"
   assumes ca: "bd_cts (wp a)"
       and cb: "bd_cts (wp b)"
       and ha: "healthy (wp a)"
       and hb: "healthy (wp b)"
   shows "bd_cts (wp (a \<Sqinter> b))"
 proof(rule bd_ctsI, rule antisym)
   fix M::"nat \<Rightarrow> 's expect" and c::real
   assume chain: "\<And>i. M i \<tturnstile> M (Suc i)" and sM: "\<And>i. sound (M i)"
      and bM: "\<And>i. bounded_by c (M i)"
 
   from ha hb have hab: "healthy (wp (a \<Sqinter> b))" by(rule healthy_intros)
   from bM have leSup: "\<And>i. M i \<tturnstile> Sup_exp (range M)" by(auto intro:Sup_exp_upper)
   from sM bM have sSup: "sound (Sup_exp (range M))" by(auto intro:Sup_exp_sound)
 
   show "Sup_exp (range (wp (a \<Sqinter> b) \<circ> M)) \<tturnstile> wp (a \<Sqinter> b) (Sup_exp (range M))"
   proof(rule Sup_exp_least, clarsimp, rule le_funI)
     fix i s
     from mono_transD[OF healthy_monoD[OF hab]] leSup sM sSup
     have "wp (a \<Sqinter> b) (M i) \<tturnstile> wp (a \<Sqinter> b) (Sup_exp (range M))" by(auto)
     thus "wp (a \<Sqinter> b) (M i) s \<le> wp (a \<Sqinter> b) (Sup_exp (range M)) s" by(auto)
 
     from hab sSup have "sound (wp (a \<Sqinter> b) (Sup_exp (range M)))" by(auto)
     thus "nneg (wp (a \<Sqinter> b) (Sup_exp (range M)))" by(auto)
   qed
 
   from sM bM ha have "\<And>i. bounded_by c (wp a (M i))" by(auto)
   hence baM: "\<And>i s. wp a (M i) s \<le> c" by(auto)
   from sM bM hb have "\<And>i. bounded_by c (wp b (M i))" by(auto)
   hence bbM: "\<And>i s. wp b (M i) s \<le> c" by(auto)
 
   show "wp (a \<Sqinter> b) (Sup_exp (range M)) \<tturnstile> Sup_exp (range (wp (a \<Sqinter> b) \<circ> M))"
   proof(simp add:wp_eval o_def, rule le_funI)
     fix s::'s
     from bd_ctsD[OF ca, of M, OF chain sM bM] bd_ctsD[OF cb, of M, OF chain sM bM]
     have "min (wp a (Sup_exp (range M)) s) (wp b (Sup_exp (range M)) s) =
           min (Sup_exp (range (wp a o M)) s) (Sup_exp (range (wp b o M)) s)" by(simp)
     also {
       have "{f s |f. f \<in> range (\<lambda>x. wp a (M x))} = range (\<lambda>i. wp a (M i) s)"
            "{f s |f. f \<in> range (\<lambda>x. wp b (M x))} = range (\<lambda>i. wp b (M i) s)"
         by(auto)
       hence "min (Sup_exp (range (wp a o M)) s) (Sup_exp (range (wp b o M)) s) =
             min (Sup (range (\<lambda>i. wp a (M i) s))) (Sup (range (\<lambda>i. wp b (M i) s)))"
         by(simp add:Sup_exp_def o_def)
     }
     also {
       have "(\<lambda>i. wp a (M i) s) \<longlonglongrightarrow> Sup (range (\<lambda>i. wp a (M i) s))"
       proof(rule increasing_LIMSEQ)
         fix n
         from mono_transD[OF healthy_monoD, OF ha] sM chain
         show "wp a (M n) s \<le> wp a (M (Suc n)) s" by(auto intro:le_funD)
         from baM show "wp a (M n) s \<le> Sup (range (\<lambda>i. wp a (M i) s))"
           by(intro cSup_upper bdd_aboveI, auto)
 
         fix e::real assume pe: "0 < e"
         from baM have cSup: "Sup (range (\<lambda>i. wp a (M i) s)) \<in> closure (range (\<lambda>i. wp a (M i) s))"
           by(blast intro:closure_contains_Sup)
         with pe obtain y where yin: "y \<in> (range (\<lambda>i. wp a (M i) s))"
                           and dy: "dist y (Sup (range (\<lambda>i. wp a (M i) s))) < e"
           by(blast dest:iffD1[OF closure_approachable])
         from yin obtain i where "y = wp a (M i) s" by(auto)
         with dy have "dist (wp a (M i) s) (Sup (range (\<lambda>i. wp a (M i) s))) < e"
           by(simp)
         moreover from baM have "wp a (M i) s \<le> Sup (range (\<lambda>i. wp a (M i) s))"
           by(intro cSup_upper bdd_aboveI, auto)
         ultimately have "Sup (range (\<lambda>i. wp a (M i) s)) \<le> wp a (M i) s + e"
           by(simp add:dist_real_def)
         thus "\<exists>i. Sup (range (\<lambda>i. wp a (M i) s)) \<le> wp a (M i) s + e" by(auto)
       qed
       moreover
       have "(\<lambda>i. wp b (M i) s) \<longlonglongrightarrow> Sup (range (\<lambda>i. wp b (M i) s))"
       proof(rule increasing_LIMSEQ)
         fix n
         from mono_transD[OF healthy_monoD, OF hb] sM chain
         show "wp b (M n) s \<le> wp b (M (Suc n)) s" by(auto intro:le_funD)
         from bbM show "wp b (M n) s \<le> Sup (range (\<lambda>i. wp b (M i) s))"
           by(intro cSup_upper bdd_aboveI, auto)
 
         fix e::real assume pe: "0 < e"
         from bbM have cSup: "Sup (range (\<lambda>i. wp b (M i) s)) \<in> closure (range (\<lambda>i. wp b (M i) s))"
           by(blast intro:closure_contains_Sup)
         with pe obtain y where yin: "y \<in> (range (\<lambda>i. wp b (M i) s))"
                           and dy: "dist y (Sup (range (\<lambda>i. wp b (M i) s))) < e"
           by(blast dest:iffD1[OF closure_approachable])
         from yin obtain i where "y = wp b (M i) s" by(auto)
         with dy have "dist (wp b (M i) s) (Sup (range (\<lambda>i. wp b (M i) s))) < e"
           by(simp)
         moreover from bbM have "wp b (M i) s \<le> Sup (range (\<lambda>i. wp b (M i) s))"
           by(intro cSup_upper bdd_aboveI, auto)
         ultimately have "Sup (range (\<lambda>i. wp b (M i) s)) \<le> wp b (M i) s + e"
           by(simp add:dist_real_def)
         thus "\<exists>i. Sup (range (\<lambda>i. wp b (M i) s)) \<le> wp b (M i) s + e" by(auto)
       qed
       ultimately have "(\<lambda>i. min (wp a (M i) s) (wp b (M i) s)) \<longlonglongrightarrow>
                        min (Sup (range (\<lambda>i. wp a (M i) s))) (Sup (range (\<lambda>i. wp b (M i) s)))"
         by(rule tendsto_min)
       moreover have "bdd_above (range (\<lambda>i. min (wp a (M i) s) (wp b (M i) s)))"
       proof(intro bdd_aboveI, clarsimp)
         fix i
         have "min (wp a (M i) s) (wp b (M i) s) \<le> wp a (M i) s" by(auto)
         also {
           from ha sM bM have "bounded_by c (wp a (M i))" by(auto)
           hence "wp a (M i) s \<le>  c" by(auto)
         }
         finally show "min (wp a (M i) s) (wp b (M i) s) \<le> c" .
       qed
       ultimately
       have "min (Sup (range (\<lambda>i. wp a (M i) s))) (Sup (range (\<lambda>i. wp b (M i) s))) \<le>
             Sup (range (\<lambda>i. min (wp a (M i) s) (wp b (M i) s)))"
         by(blast intro:LIMSEQ_le_const2 cSup_upper min.mono[OF baM bbM])
     }
     also {
       have "range (\<lambda>i. min (wp a (M i) s) (wp b (M i) s)) =
             {f s |f. f \<in> range (\<lambda>i s. min (wp a (M i) s) (wp b (M i) s))}"
         by(auto)
       hence "Sup (range (\<lambda>i. min (wp a (M i) s) (wp b (M i) s))) =
            Sup_exp (range (\<lambda>i s. min (wp a (M i) s) (wp b (M i) s))) s"
         by (simp add: Sup_exp_def cong del: SUP_cong_simp)
     }
     finally show "min (wp a (Sup_exp (range M)) s) (wp b (Sup_exp (range M)) s) \<le>
                   Sup_exp (range (\<lambda>i s. min (wp a (M i) s) (wp b (M i) s))) s" .
   qed
 qed
 
 lemma cts_wp_Seq:
   fixes a b::"'s prog"
   assumes ca: "bd_cts (wp a)"
       and cb: "bd_cts (wp b)"
       and hb: "healthy (wp b)"
   shows "bd_cts (wp (a ;; b))"
 proof(rule bd_ctsI, simp add:o_def wp_eval)
   fix M::"nat \<Rightarrow> 's expect" and c::real
   assume chain: "\<And>i. M i \<tturnstile> M (Suc i)" and sM: "\<And>i. sound (M i)"
      and bM: "\<And>i. bounded_by c (M i)"
   hence "wp a (wp b (Sup_exp (range M))) = wp a (Sup_exp (range (wp b o M)))"
     by(subst bd_ctsD[OF cb], auto)
   also {
     from sM hb have "\<And>i. sound ((wp b o M) i)" by(auto)
     moreover from chain sM
     have "\<And>i. (wp b o M) i \<tturnstile> (wp b o M) (Suc i)"
       by(auto intro:mono_transD[OF healthy_monoD, OF hb])
     moreover from sM bM hb have "\<And>i. bounded_by c ((wp b o M) i)" by(auto)
     ultimately have "wp a (Sup_exp (range (wp b o M))) =
                      Sup_exp (range (wp a o (wp b o M)))"
       by(subst bd_ctsD[OF ca], auto)
   }
   also have "Sup_exp (range (wp a o (wp b o M))) =
              Sup_exp (range (\<lambda>i. wp a (wp b (M i))))"
     by(simp add:o_def)
   finally show "wp a (wp b (Sup_exp (range M))) =
                 Sup_exp (range (\<lambda>i. wp a (wp b (M i))))" .
 qed
 
 lemma cts_wp_PC:
   fixes a b::"'s prog"
   assumes ca: "bd_cts (wp a)"
       and cb: "bd_cts (wp b)"
       and ha: "healthy (wp a)"
       and hb: "healthy (wp b)"
       and up: "unitary p"
   shows "bd_cts (wp (PC a p b))"
 proof(rule bd_ctsI, rule ext, simp add:o_def wp_eval)
   fix M::"nat \<Rightarrow> 's expect" and c::real and s::'s
   assume chain: "\<And>i. M i \<tturnstile> M (Suc i)" and sM: "\<And>i. sound (M i)"
      and bM: "\<And>i. bounded_by c (M i)"
 
   from sM have "\<And>i. nneg (M i)" by(auto)
   with bM have nc: "0 \<le> c" by(auto)
 
   from chain sM bM have "wp a (Sup_exp (range M)) = Sup_exp (range (wp a o M))"
     by(rule bd_ctsD[OF ca])
   hence "wp a (Sup_exp (range M)) s = Sup_exp (range (wp a o M)) s"
     by(simp)
   also {
     have "{f s |f. f \<in> range (\<lambda>x. wp a (M x))} = range (\<lambda>i. wp a (M i) s)"
       by(auto)
     hence "Sup_exp (range (wp a o M)) s = Sup (range (\<lambda>i. wp a (M i) s))"
       by(simp add:Sup_exp_def o_def)
   }
   finally have "p s * wp a (Sup_exp (range M)) s =
                 p s * Sup (range (\<lambda>i. wp a (M i) s))" by(simp)
   also have "... = Sup {p s * x |x. x \<in> range (\<lambda>i. wp a (M i) s)}"
   proof(rule cSup_mult, blast, clarsimp)
     from up show "0 \<le> p s" by(auto)
     fix i
     from sM bM ha have "bounded_by c (wp a (M i))" by(auto)
     thus "wp a (M i) s \<le> c" by(auto)
   qed
   also {
     have "{p s * x |x. x \<in> range (\<lambda>i. wp a (M i) s)} = range (\<lambda>i. p s * wp a (M i) s)"
       by(auto)
     hence "Sup {p s * x |x. x \<in> range (\<lambda>i. wp a (M i) s)} =
            Sup (range (\<lambda>i. p s * wp a (M i) s))" by(simp)
   }
   finally have "p s * wp a (Sup_exp (range M)) s = Sup (range (\<lambda>i. p s * wp a (M i) s))" .
   moreover {
     from chain sM bM have "wp b (Sup_exp (range M)) = Sup_exp (range (wp b o M))"
       by(rule bd_ctsD[OF cb])
     hence "wp b (Sup_exp (range M)) s = Sup_exp (range (wp b o M)) s"
       by(simp)
     also {
       have "{f s |f. f \<in> range (\<lambda>x. wp b (M x))} = range (\<lambda>i. wp b (M i) s)"
         by(auto)
       hence "Sup_exp (range (wp b o M)) s = Sup (range (\<lambda>i. wp b (M i) s))"
         by(simp add:Sup_exp_def o_def)
     }
     finally have "(1 - p s) * wp b (Sup_exp (range M)) s =
                   (1 - p s) * Sup (range (\<lambda>i. wp b (M i) s))" by(simp)
     also have "... = Sup {(1 - p s) * x |x. x \<in> range (\<lambda>i. wp b (M i) s)}"
     proof(rule cSup_mult, blast, clarsimp)
-      from up show "0 \<le> 1 - p s" by(auto simp:sign_simps)
+      from up show "0 \<le> 1 - p s"
+        by auto
       fix i
       from sM bM hb have "bounded_by c (wp b (M i))" by(auto)
       thus "wp b (M i) s \<le> c" by(auto)
     qed
     also {
       have "{(1 - p s) * x |x. x \<in> range (\<lambda>i. wp b (M i) s)} =
             range (\<lambda>i. (1 - p s) * wp b (M i) s)"
         by(auto)
       hence "Sup {(1 - p s) * x |x. x \<in> range (\<lambda>i. wp b (M i) s)} =
              Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))" by(simp)
     }
     finally have "(1 - p s) * wp b (Sup_exp (range M)) s =
                   Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))" .
   }
   ultimately
   have "p s * wp a (Sup_exp (range M)) s + (1 - p s) * wp b (Sup_exp (range M)) s =
         Sup (range (\<lambda>i. p s * wp a (M i) s)) + Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))"
     by(simp)
   also {
     from bM sM ha have "\<And>i. bounded_by c (wp a (M i))" by(auto)
     hence "\<And>i. wp a (M i) s \<le> c" by(auto)
     moreover from up have "0 \<le> p s" by(auto)
     ultimately have "\<And>i. p s * wp a (M i) s \<le> p s * c" by(auto intro:mult_left_mono)
     also from up nc have "p s * c \<le> 1 * c" by(blast intro:mult_right_mono)
     also have "... = c" by(simp)
     finally have baM: "\<And>i. p s * wp a (M i) s \<le> c" .
 
     have lima: "(\<lambda>i. p s * wp a (M i) s) \<longlonglongrightarrow> Sup (range (\<lambda>i. p s * wp a (M i) s))"
     proof(rule increasing_LIMSEQ)
       fix n
       from sM chain healthy_monoD[OF ha] have "wp a (M n) \<tturnstile> wp a (M (Suc n))"
         by(auto)
       with up show "p s * wp a (M n) s \<le> p s * wp a (M (Suc n)) s"
         by(blast intro:mult_left_mono)
       from baM show "p s * wp a (M n) s \<le> Sup (range (\<lambda>i. p s * wp a (M i) s))"
         by(intro cSup_upper bdd_aboveI, auto)
     next
       fix e::real
       assume pe: "0 < e"
       from baM have "Sup (range (\<lambda>i. p s * wp a (M i) s)) \<in>
                      closure (range (\<lambda>i. p s * wp a (M i) s))"
         by(blast intro:closure_contains_Sup)
       thm closure_approachable
       with pe obtain y where yin: "y \<in> range (\<lambda>i. p s * wp a (M i) s)"
                          and dy: "dist y (Sup (range (\<lambda>i. p s * wp a (M i) s))) < e"
         by(blast dest:iffD1[OF closure_approachable])
       from yin obtain i where "y = p s * wp a (M i) s" by(auto)
       with dy have "dist (p s * wp a (M i) s) (Sup (range (\<lambda>i. p s * wp a (M i) s))) < e"
         by(simp)
       moreover from baM have "p s * wp a (M i) s \<le> Sup (range (\<lambda>i. p s * wp a (M i) s))"
         by(intro cSup_upper bdd_aboveI, auto)
       ultimately have "Sup (range (\<lambda>i. p s * wp a (M i) s)) \<le> p s * wp a (M i) s + e"
         by(simp add:dist_real_def)
       thus "\<exists>i. Sup (range (\<lambda>i. p s * wp a (M i) s)) \<le> p s * wp a (M i) s + e" by(auto)
     qed
 
     from bM sM hb have "\<And>i. bounded_by c (wp b (M i))" by(auto)
     hence "\<And>i. wp b (M i) s \<le> c" by(auto)
-    moreover from up have "0 \<le> (1 - p s)" by(auto simp:sign_simps)
+    moreover from up have "0 \<le> (1 - p s)"
+      by auto
     ultimately have "\<And>i. (1 - p s) * wp b (M i) s \<le> (1 - p s) * c" by(auto intro:mult_left_mono)
     also {
       from up have "1 - p s \<le> 1" by(auto)
       with nc have "(1 - p s) * c \<le> 1 * c" by(blast intro:mult_right_mono)
     }
     also have "1 * c = c" by(simp)
     finally have bbM: "\<And>i. (1 - p s) * wp b (M i) s \<le> c" .
 
     have limb: "(\<lambda>i. (1 - p s) * wp b (M i) s) \<longlonglongrightarrow> Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))"
     proof(rule increasing_LIMSEQ)
       fix n
       from sM chain healthy_monoD[OF hb] have "wp b (M n) \<tturnstile> wp b (M (Suc n))"
         by(auto)
-      moreover from up have "0 \<le> 1 - p s" by(auto simp:sign_simps)
+      moreover from up have "0 \<le> 1 - p s"
+        by auto
       ultimately show "(1 - p s) * wp b (M n) s \<le> (1 - p s) * wp b (M (Suc n)) s"
         by(blast intro:mult_left_mono)
       from bbM show "(1 - p s) * wp b (M n) s \<le> Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))"
         by(intro cSup_upper bdd_aboveI, auto)
     next
       fix e::real
       assume pe: "0 < e"
       from bbM have "Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s)) \<in>
                      closure (range (\<lambda>i. (1 - p s) * wp b (M i) s))"
         by(blast intro:closure_contains_Sup)
       with pe obtain y where yin: "y \<in> range (\<lambda>i. (1 - p s) * wp b (M i) s)"
                          and dy: "dist y (Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))) < e"
         by(blast dest:iffD1[OF closure_approachable])
       from yin obtain i where "y = (1 - p s) * wp b (M i) s" by(auto)
       with dy have "dist ((1 - p s) * wp b (M i) s)
                          (Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))) < e"
         by(simp)
       moreover from bbM
       have "(1 - p s) * wp b (M i) s \<le> Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))"
         by(intro cSup_upper bdd_aboveI, auto)
       ultimately have "Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s)) \<le> (1 - p s) * wp b (M i) s + e"
         by(simp add:dist_real_def)
       thus "\<exists>i. Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s)) \<le> (1 - p s) * wp b (M i) s + e" by(auto)
     qed
 
     from lima limb have "(\<lambda>i. p s * wp a (M i) s + (1 - p s) * wp b (M i) s) \<longlonglongrightarrow>
       Sup (range (\<lambda>i. p s * wp a (M i) s)) + Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))"
       by(rule tendsto_add)
     moreover from add_mono[OF baM bbM]
     have "\<And>i. p s * wp a (M i) s + (1 - p s) * wp b (M i) s \<le>
                        Sup (range (\<lambda>i. p s * wp a (M i) s + (1 - p s) * wp b (M i) s))"
       by(intro cSup_upper bdd_aboveI, auto)
     ultimately have "Sup (range (\<lambda>i. p s * wp a (M i) s)) +
                      Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s)) \<le>
                      Sup (range (\<lambda>i. p s * wp a (M i) s + (1 - p s) * wp b (M i) s))"
       by(blast intro: LIMSEQ_le_const2)
   }
   also {
     have "range (\<lambda>i. p s * wp a (M i) s + (1 - p s) * wp b (M i) s) =
           {f s |f. f \<in> range (\<lambda>x s. p s * wp a (M x) s + (1 - p s) * wp b (M x) s)}"
       by(auto)
     hence "Sup (range (\<lambda>i. p s * wp a (M i) s + (1 - p s) * wp b (M i) s)) =
            Sup_exp (range (\<lambda>x s. p s * wp a (M x) s + (1 - p s) * wp b (M x) s)) s"
       by (simp add: Sup_exp_def cong del: SUP_cong_simp)
   }
   finally
   have "p s * wp a (Sup_exp (range M)) s + (1 - p s) * wp b (Sup_exp (range M)) s \<le>
         Sup_exp (range (\<lambda>i s. p s * wp a (M i) s + (1 - p s) * wp b (M i) s)) s" .
   moreover
   have "Sup_exp (range (\<lambda>i s. p s * wp a (M i) s + (1 - p s) * wp b (M i) s)) s \<le>
         p s * wp a (Sup_exp (range M)) s + (1 - p s) * wp b (Sup_exp (range M)) s"
   proof(rule le_funD[OF Sup_exp_least], clarsimp, rule le_funI)
     fix i::nat and s::'s
     from bM have leSup: "M i \<tturnstile> Sup_exp (range M)"
       by(blast intro: Sup_exp_upper)
     moreover from sM bM have sSup: "sound (Sup_exp (range M))"
       by(auto intro:Sup_exp_sound)
     moreover note healthy_monoD[OF ha] sM
     ultimately have "wp a (M i) \<tturnstile> wp a (Sup_exp (range M))" by(auto)
     hence "wp a (M i) s \<le> wp a (Sup_exp (range M)) s" by(auto)
     moreover {
       from leSup sSup healthy_monoD[OF hb] sM
       have "wp b (M i) \<tturnstile> wp b (Sup_exp (range M))" by(auto)
       hence "wp b (M i) s \<le> wp b (Sup_exp (range M)) s" by(auto)
     }
-    moreover from up have "0 \<le> p s" "0 \<le> 1 - p s" by(auto simp:sign_simps)
+    moreover from up have "0 \<le> p s" "0 \<le> 1 - p s"
+      by auto
     ultimately
     show "p s * wp a (M i) s + (1 - p s) * wp b (M i) s \<le>
           p s * wp a (Sup_exp (range M)) s + (1 - p s) * wp b (Sup_exp (range M)) s"
       by(blast intro:add_mono mult_left_mono)
 
     from sSup ha hb have "sound (wp a (Sup_exp (range M)))"
                          "sound (wp b (Sup_exp (range M)))"
       by(auto)
     hence "\<And>s. 0 \<le> wp a (Sup_exp (range M)) s" "\<And>s. 0 \<le> wp b (Sup_exp (range M)) s"
       by(auto)
-    moreover from up have "\<And>s. 0 \<le> p s" "\<And>s. 0 \<le> 1 - p s" by(auto simp:sign_simps)
+    moreover from up have "\<And>s. 0 \<le> p s" "\<And>s. 0 \<le> 1 - p s"
+      by auto
     ultimately show "nneg (\<lambda>c. p c * wp a (Sup_exp (range M)) c +
                           (1 - p c) * wp b (Sup_exp (range M)) c)"
       by(blast intro:add_nonneg_nonneg mult_nonneg_nonneg)
   qed
   ultimately show "p s * wp a (Sup_exp (range M)) s + (1 - p s) * wp b (Sup_exp (range M)) s =
                   Sup_exp (range (\<lambda>x s. p s * wp a (M x) s + (1 - p s) * wp b (M x) s)) s"
     by(auto)
 qed
 
 text \<open>Both set-based choice operators are only continuous for finite sets (probabilistic choice
 \emph{can} be extended infinitely, but we have not done so).  The proofs for both are inductive,
 and rely on the above results on binary operators.\<close>
 
 lemma SetPC_Bind:
   "SetPC a p = Bind p (\<lambda>p. SetPC a (\<lambda>_. p))"
   by(intro ext, simp add:SetPC_def Bind_def Let_def)
 
 lemma SetPC_remove:
   assumes nz: "p x \<noteq> 0" and n1: "p x \<noteq> 1"
       and fsupp: "finite (supp p)"
   shows "SetPC a (\<lambda>_. p) = PC (a x) (\<lambda>_. p x) (SetPC a (\<lambda>_. dist_remove p x))"
 proof(intro ext, simp add:SetPC_def PC_def)
   fix ab P s
   from nz have "x \<in> supp p" by(simp add:supp_def)
   hence "supp p = insert x (supp p - {x})" by(auto)
   hence "(\<Sum>x\<in>supp p. p x * a x ab P s) =
          (\<Sum>x\<in>insert x (supp p - {x}). p x * a x ab P s)"
     by(simp)
   also from fsupp
   have "... = p x * a x ab P s + (\<Sum>x\<in>supp p - {x}. p x * a x ab P s)"
     by(blast intro:sum.insert)
   also from n1
   have "... = p x * a x ab P s + (1 - p x) * ((\<Sum>x\<in>supp p - {x}. p x * a x ab P s) / (1 - p x))"
     by(simp add:field_simps)
   also have "... = p x * a x ab P s +
                    (1 - p x) * ((\<Sum>y\<in>supp p - {x}. (p y / (1 - p x)) * a y ab P s))"
     by(simp add:sum_divide_distrib)
   also have "... = p x * a x ab P s +
                    (1 - p x) * ((\<Sum>y\<in>supp p - {x}. dist_remove p x y * a y ab P s))"
     by(simp add:dist_remove_def)
   also from nz n1
   have "... = p x * a x ab P s +
               (1 - p x) * ((\<Sum>y\<in>supp (dist_remove p x). dist_remove p x y * a y ab P s))"
     by(simp add:supp_dist_remove)
   finally show "(\<Sum>x\<in>supp p. p x * a x ab P s) =
                  p x * a x ab P s +
                  (1 - p x) * (\<Sum>y\<in>supp (dist_remove p x). dist_remove p x y * a y ab P s)" .
 qed
 
 lemma cts_bot:
   "bd_cts (\<lambda>(P::'s expect) (s::'s). 0::real)"
 proof -
   have X: "\<And>s::'s. {(P::'s expect) s |P. P \<in> range (\<lambda>P s. 0)} = {0}" by(auto)
   show ?thesis by(intro bd_ctsI, simp add:Sup_exp_def o_def X)
 qed
 
 lemma wp_SetPC_nil:
   "wp (SetPC a (\<lambda>s a. 0)) = (\<lambda>P s. 0)"
   by(intro ext, simp add:wp_eval)
 
 lemma SetPC_sgl:
   "supp p = {x} \<Longrightarrow> SetPC a (\<lambda>_. p) = (\<lambda>ab P s. p x * a x ab P s)"
   by(simp add:SetPC_def)
 
 lemma bd_cts_scale:
   fixes a::"'s trans"
   assumes ca: "bd_cts a"
       and ha: "healthy a"
       and nnc: "0 \<le> c"
   shows "bd_cts (\<lambda>P s. c * a P s)"
 proof(intro bd_ctsI ext, simp add:o_def)
   fix M::"nat \<Rightarrow> 's expect" and d::real and s::'s
   assume chain: "\<And>i. M i \<tturnstile> M (Suc i)" and sM: "\<And>i. sound (M i)"
      and bM: "\<And>i. bounded_by d (M i)"
 
   from sM have "\<And>i. nneg (M i)" by(auto)
   with bM have nnd: "0 \<le> d" by(auto)
 
   from sM bM have sSup: "sound (Sup_exp (range M))" by(auto intro:Sup_exp_sound)
   with healthy_scalingD[OF ha] nnc
   have "c * a (Sup_exp (range M)) s = a (\<lambda>s. c * Sup_exp (range M) s) s"
     by(auto intro:scalingD)
   also {
     have "\<And>s. {f s |f. f \<in> range M} = range (\<lambda>i. M i s)" by(auto)
     hence "a (\<lambda>s. c * Sup_exp (range M) s) s =
            a (\<lambda>s. c * Sup (range (\<lambda>i. M i s))) s"
       by(simp add:Sup_exp_def)
   }
   also {
     from bM have "\<And>x s. x \<in> range (\<lambda>i. M i s) \<Longrightarrow> x \<le> d" by(auto)
     with nnc have "a (\<lambda>s. c * Sup (range (\<lambda>i. M i s))) s =
                    a (\<lambda>s. Sup {c*x |x. x \<in> range (\<lambda>i. M i s)}) s"
       by(subst cSup_mult, blast+)
   }
   also {
     have X: "\<And>s. {c * x |x. x \<in> range (\<lambda>i. M i s)} = range (\<lambda>i. c * M i s)" by(auto)
     have "a (\<lambda>s. Sup {c * x |x. x \<in> range (\<lambda>i. M i s)}) s =
           a (\<lambda>s. Sup (range (\<lambda>i. c * M i s))) s" by(simp add:X)
   }
   also {
     have "\<And>s. range (\<lambda>i. c * M i s) = {f s |f. f \<in> range (\<lambda>i s. c * M i s)}"
       by(auto)
     hence "(\<lambda>s. Sup (range (\<lambda>i. c * M i s))) = Sup_exp (range (\<lambda>i s. c * M i s))"
       by (simp add: Sup_exp_def cong del: SUP_cong_simp)
     hence "a (\<lambda>s. Sup (range (\<lambda>i. c * M i s))) s =
            a (Sup_exp (range (\<lambda>i s. c * M i s))) s" by(simp)
   }
   also {
     from le_funD[OF chain] nnc
     have "\<And>i. (\<lambda>s. c * M i s) \<tturnstile> (\<lambda>s. c * M (Suc i) s)"
       by(auto intro:le_funI[OF mult_left_mono])
     moreover from sM nnc
     have "\<And>i. sound (\<lambda>s. c * M i s)"
       by(auto intro:sound_intros)
     moreover from bM nnc
     have "\<And>i. bounded_by (c * d) (\<lambda>s. c * M i s)"
       by(auto intro:mult_left_mono)
     ultimately
     have "a (Sup_exp (range (\<lambda>i s. c * M i s))) =
           Sup_exp (range (a o (\<lambda>i s. c * M i s)))"
       by(rule bd_ctsD[OF ca])
     hence "a (Sup_exp (range (\<lambda>i s. c * M i s))) s =
           Sup_exp (range (a o (\<lambda>i s. c * M i s))) s"
       by(auto)
   }
   also have "Sup_exp (range (a o (\<lambda>i s. c * M i s))) s =
              Sup_exp (range (\<lambda>x. a (\<lambda>s. c * M x s))) s"
     by(simp add:o_def)
   also {
     from nnc sM
     have "\<And>x. a (\<lambda>s. c * M x s) = (\<lambda>s. c * a (M x) s)"
       by(auto intro:scalingD[OF healthy_scalingD, OF ha, symmetric])
     hence "Sup_exp (range (\<lambda>x. a (\<lambda>s. c * M x s))) s =
            Sup_exp (range (\<lambda>x s. c * a (M x) s)) s"
       by(simp)
   }
   finally show "c * a (Sup_exp (range M)) s = Sup_exp (range (\<lambda>x s. c * a (M x) s)) s" .
 qed
 
 lemma cts_wp_SetPC_const:
   fixes a::"'a \<Rightarrow> 's prog"
   assumes ca: "\<And>x. x \<in> (supp p) \<Longrightarrow> bd_cts (wp (a x))"
       and ha: "\<And>x. x \<in> (supp p) \<Longrightarrow> healthy (wp (a x))"
       and up: "unitary p"
       and sump: "sum p (supp p) \<le> 1"
       and fsupp: "finite (supp p)"
   shows "bd_cts (wp (SetPC a (\<lambda>_. p)))"
 proof(cases "supp p = {}", simp add:supp_empty SetPC_def wp_def cts_bot)
   assume nesupp: "supp p \<noteq> {}"
   from fsupp have "unitary p \<longrightarrow> sum p (supp p) \<le> 1 \<longrightarrow> 
                    (\<forall>x\<in>supp p. bd_cts (wp (a x))) \<longrightarrow>
                    (\<forall>x\<in>supp p. healthy (wp (a x))) \<longrightarrow>
                    bd_cts (wp (SetPC a (\<lambda>_. p)))"
   proof(induct "supp p" arbitrary:p, simp add:supp_empty wp_SetPC_nil cts_bot, clarify)
     fix x::'a and F::"'a set" and p::"'a \<Rightarrow> real"
     assume fF: "finite F"
     assume "insert x F = supp p"
     hence pstep: "supp p = insert x F" by(simp)
     hence xin: "x \<in> supp p" by(auto)
     assume up: "unitary p" and ca: "\<forall>x\<in>supp p. bd_cts (wp (a x))"
        and ha: "\<forall>x\<in>supp p. healthy (wp (a x))"
        and sump: "sum p (supp p) \<le> 1"
        and xni: "x \<notin> F"
     assume IH: "\<And>p. F = supp p \<Longrightarrow>
                      unitary p \<longrightarrow> sum p (supp p) \<le> 1 \<longrightarrow>
                      (\<forall>x\<in>supp p. bd_cts (wp (a x))) \<longrightarrow>
                      (\<forall>x\<in>supp p. healthy (wp (a x))) \<longrightarrow>
                      bd_cts (wp (SetPC a (\<lambda>_. p)))"
 
     from fF pstep have fsupp: "finite (supp p)" by(auto)
 
     from xin have nzp: "p x \<noteq> 0" by(simp add:supp_def)
 
     have xy_le_sum:
       "\<And>y. y \<in> supp p \<Longrightarrow> y \<noteq> x \<Longrightarrow> p x + p y \<le> sum p (supp p)"
     proof -
       fix y assume yin: "y \<in> supp p" and yne: "y \<noteq> x"
       from up have "0 \<le> sum p (supp p - {x,y})"
         by(auto intro:sum_nonneg)
       hence "p x + p y \<le> p x + p y + sum p (supp p - {x,y})"
         by(auto)
     also {
       from yin yne fsupp
       have "p y + sum p (supp p - {x,y}) = sum p (supp p - {x})"
         by(subst sum.insert[symmetric], (blast intro!:sum.cong)+)
       moreover
       from xin fsupp
       have "p x + sum p (supp p - {x}) = sum p (supp p)"
         by(subst sum.insert[symmetric], (blast intro!:sum.cong)+)
       ultimately
       have "p x + p y + sum p (supp p - {x, y}) = sum p (supp p)" by(simp)
     }
     finally show "p x + p y \<le> sum p (supp p)" .
     qed
 
     have n1p: "\<And>y. y \<in> supp p \<Longrightarrow> y \<noteq> x \<Longrightarrow> p x \<noteq> 1"
     proof(rule ccontr, simp)
       assume px1: "p x = 1"
       fix y assume yin: "y \<in> supp p" and yne: "y \<noteq> x"
       from up have "0 \<le> p y" by(auto)
       with yin have "0 < p y" by(auto simp:supp_def)
       hence "0 + p x < p y + p x" by(rule add_strict_right_mono)
       with px1 have "1 < p x + p y" by(simp)
       also from yin yne have "p x + p y \<le> sum p (supp p)"
         by(rule xy_le_sum)
       finally show False using sump by(simp)
     qed
 
     show "bd_cts (wp (SetPC a (\<lambda>_. p)))"
     proof(cases "F = {}")
       case True with pstep have "supp p = {x}" by(simp)
       hence "wp (SetPC a (\<lambda>_. p)) = (\<lambda>P s. p x * wp (a x) P s)"
         by(simp add:SetPC_sgl wp_def)
       moreover {
         from up ca ha xin have "bd_cts (wp (a x))" "healthy (wp (a x))" "0 \<le> p x"
           by(auto)
         hence "bd_cts (\<lambda>P s. p x * wp (a x) P s)"
           by(rule bd_cts_scale)
       } 
       ultimately show ?thesis by(simp)
     next
       assume neF: "F \<noteq> {}"
       then obtain y where yinF: "y \<in> F" by(auto)
       with xni have yne: "y \<noteq> x" by(auto)
       from yinF pstep have yin: "y \<in> supp p" by(auto)
 
       from supp_dist_remove[of p x, OF nzp n1p, OF yin yne]
       have supp_sub: "supp (dist_remove p x) \<subseteq> supp p" by(auto)
 
       from xin ca have cax: "bd_cts (wp (a x))" by(auto)
       from xin ha have hax: "healthy (wp (a x))" by(auto)
 
       from supp_sub ha have hra: "\<forall>x\<in>supp (dist_remove p x). healthy (wp (a x))"
         by(auto)
       from supp_sub ca have cra: "\<forall>x\<in>supp (dist_remove p x). bd_cts (wp (a x))"
         by(auto)
 
       from supp_dist_remove[of p x, OF nzp n1p, OF yin yne] pstep xni
       have Fsupp: "F = supp (dist_remove p x)"
         by(simp)
 
       have udp: "unitary (dist_remove p x)"
       proof(intro unitaryI2 nnegI bounded_byI)
         fix y
         show "0 \<le> dist_remove p x y"
         proof(cases "y=x", simp_all add:dist_remove_def)
-          from up have "0 \<le> p y" "0 \<le> 1 - p x" by(auto simp:sign_simps)
+          from up have "0 \<le> p y" "0 \<le> 1 - p x"
+            by auto
           thus "0 \<le> p y / (1 - p x)"
             by(rule divide_nonneg_nonneg)
         qed
         show "dist_remove p x y \<le> 1"
         proof(cases "y=x", simp_all add:dist_remove_def,
               cases "y\<in>supp p", simp_all add:nsupp_zero)
           assume yne: "y \<noteq> x" and yin: "y \<in> supp p"
           hence "p x + p y \<le> sum p (supp p)"
             by(auto intro:xy_le_sum)
           also note sump
           finally have "p y \<le> 1 - p x" by(auto)
           moreover from up have "p x \<le> 1" by(auto)
           moreover from yin yne have "p x \<noteq> 1" by(rule n1p)
           ultimately show "p y / (1 - p x) \<le> 1" by(auto)
         qed
       qed
 
       from xin have pxn0: "p x \<noteq> 0" by(auto simp:supp_def)
       from yin yne have pxn1: "p x \<noteq> 1" by(rule n1p)
 
       from pxn0 pxn1 have "sum (dist_remove p x) (supp (dist_remove p x)) =
                            sum (dist_remove p x) (supp p - {x})"
         by(simp add:supp_dist_remove)
       also have "... = (\<Sum>y\<in>supp p - {x}. p y / (1 - p x))"
         by(simp add:dist_remove_def)
       also have "... = (\<Sum>y\<in>supp p - {x}. p y) / (1 - p x)"
         by(simp add:sum_divide_distrib)
       also {
         from xin have "insert x (supp p) = supp p" by(auto)
         with fsupp have "p x + (\<Sum>y\<in>supp p - {x}. p y) = sum p (supp p)"
           by(simp add:sum.insert[symmetric])
         also note sump
         finally have "sum p (supp p - {x}) \<le> 1 - p x" by(auto)
         moreover {
           from up have "p x \<le> 1" by(auto)
           with pxn1 have "p x < 1" by(auto)
           hence "0 < 1 - p x" by(auto)
         }
         ultimately have "sum p (supp p - {x}) / (1 - p x) \<le> 1"
           by(auto)
       }
       finally have sdp: "sum (dist_remove p x) (supp (dist_remove p x)) \<le> 1" .
 
       from Fsupp udp sdp hra cra IH
       have cts_dr: "bd_cts (wp (SetPC a (\<lambda>_. dist_remove p x)))"
         by(auto)
 
       from up have upx: "unitary (\<lambda>_. p x)" by(auto)
       
       from pxn0 pxn1 fsupp hra show ?thesis
         by(simp add:SetPC_remove,
            blast intro:cts_wp_PC cax cts_dr hax healthy_intros
                        unitary_sound[OF udp] sdp upx)
     qed
   qed
   with assms show ?thesis by(auto)
 qed
 
 lemma cts_wp_SetPC:
   fixes a::"'a \<Rightarrow> 's prog"
   assumes ca: "\<And>x s. x \<in> (supp (p s)) \<Longrightarrow> bd_cts (wp (a x))"
       and ha: "\<And>x s. x \<in> (supp (p s)) \<Longrightarrow> healthy (wp (a x))"
       and up: "\<And>s. unitary (p s)"
       and sump: "\<And>s. sum (p s) (supp (p s)) \<le> 1"
       and fsupp: "\<And>s. finite (supp (p s))"
   shows "bd_cts (wp (SetPC a p))"
 proof -
   from assms have "bd_cts (wp (Bind p (\<lambda>p. SetPC a (\<lambda>_. p))))"
     by(iprover intro!:cts_wp_Bind cts_wp_SetPC_const)
   thus ?thesis by(simp add:SetPC_Bind[symmetric])
 qed
 
 lemma wp_SetDC_Bind:
   "SetDC a S = Bind S (\<lambda>S. SetDC a (\<lambda>_. S))"
   by(intro ext, simp add:SetDC_def Bind_def)
 
 lemma SetDC_finite_insert:
   assumes fS: "finite S"
       and neS: "S \<noteq> {}"
   shows "SetDC a (\<lambda>_. insert x S) = a x \<Sqinter> SetDC a (\<lambda>_. S)"
 proof (intro ext, simp add: SetDC_def DC_def cong del: image_cong_simp cong add: INF_cong_simp)
   fix ab P s
   from fS have A: "finite (insert (a x ab P s) ((\<lambda>x. a x ab P s) ` S))" 
            and B: "finite (((\<lambda>x. a x ab P s) ` S))" by(auto)
   from neS have C: "insert (a x ab P s) ((\<lambda>x. a x ab P s) ` S) \<noteq> {}"
             and D: "(\<lambda>x. a x ab P s) ` S \<noteq> {}" by(auto)
   from A C have "Inf (insert (a x ab P s) ((\<lambda>x. a x ab P s) ` S)) =
                  Min (insert (a x ab P s) ((\<lambda>x. a x ab P s) ` S))"
     by(auto intro:cInf_eq_Min)
   also from B D have "... = min (a x ab P s) (Min ((\<lambda>x. a x ab P s) ` S))"
     by(auto intro:Min_insert)
   also from B D have "... = min (a x ab P s) (Inf ((\<lambda>x. a x ab P s) ` S))"
     by(simp add:cInf_eq_Min)
   finally show "(INF x\<in>insert x S. a x ab P s) =
     min (a x ab P s) (INF x\<in>S. a x ab P s)"
     by (simp cong del: INF_cong_simp)
 qed
 
 lemma SetDC_singleton:
   "SetDC a (\<lambda>_. {x}) = a x"
   by (simp add: SetDC_def cong del: INF_cong_simp)
 
 lemma cts_wp_SetDC_const:
   fixes a::"'a \<Rightarrow> 's prog"
   assumes ca: "\<And>x. x \<in> S \<Longrightarrow> bd_cts (wp (a x))"
       and ha: "\<And>x. x \<in> S \<Longrightarrow> healthy (wp (a x))"
       and fS: "finite S"
       and neS: "S \<noteq> {}"
   shows "bd_cts (wp (SetDC a (\<lambda>_. S)))"
 proof -
   have "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow>
         (\<forall>x\<in>S. bd_cts (wp (a x))) \<longrightarrow>
         (\<forall>x\<in>S. healthy (wp (a x))) \<longrightarrow>
         bd_cts (wp (SetDC a (\<lambda>_. S)))"
   proof(induct S rule:finite_induct, simp, clarsimp)
     fix x::'a and F::"'a set"
     assume fF: "finite F"
        and IH: "F \<noteq> {} \<Longrightarrow> bd_cts (wp (SetDC a (\<lambda>_. F)))"
        and cax: "bd_cts (wp (a x))"
        and hax: "healthy (wp (a x))"
        and haF: "\<forall>x\<in>F. healthy (wp (a x))"
     show "bd_cts (wp (SetDC a (\<lambda>_. insert x F)))"
     proof(cases "F = {}", simp add:SetDC_singleton cax)
       assume "F \<noteq> {}"
       with fF cax hax haF IH show "bd_cts (wp (SetDC a (\<lambda>_. insert x F)))"
        by(auto intro!:cts_wp_DC healthy_intros simp:SetDC_finite_insert)
     qed
   qed
   with assms show ?thesis by(auto)
 qed
 
 lemma cts_wp_SetDC:
   fixes a::"'a \<Rightarrow> 's prog"
   assumes ca: "\<And>x s. x \<in> S s \<Longrightarrow> bd_cts (wp (a x))"
       and ha: "\<And>x s. x \<in> S s \<Longrightarrow> healthy (wp (a x))"
       and fS: "\<And>s. finite (S s)"
       and neS: "\<And>s. S s \<noteq> {}"
   shows "bd_cts (wp (SetDC a S))"
 proof -
   from assms have "bd_cts (wp (Bind S (\<lambda>S. SetDC a (\<lambda>_. S))))"
     by(iprover intro!:cts_wp_Bind cts_wp_SetDC_const)
   thus ?thesis by(simp add:wp_SetDC_Bind[symmetric])
 qed
 
 lemma cts_wp_repeat:
   "bd_cts (wp a) \<Longrightarrow> healthy (wp a) \<Longrightarrow> bd_cts (wp (repeat n a))"
   by(induct n, auto intro:cts_wp_Skip cts_wp_Seq healthy_intros)
 
 lemma cts_wp_Embed:
   "bd_cts t \<Longrightarrow> bd_cts (wp (Embed t))"
   by(simp add:wp_eval)
 
 subsection \<open>Continuity of a Single Loop Step\<close>
 
 text \<open>A single loop iteration is continuous, in the more general sense defined above for
 transformer transformers.\<close>
 lemma cts_wp_loopstep:
   fixes body::"'s prog"
   assumes hb: "healthy (wp body)"
       and cb: "bd_cts (wp body)"
   shows "bd_cts_tr (\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))" (is "bd_cts_tr ?F")
 proof(rule bd_cts_trI, rule le_trans_antisym)
   fix M::"nat \<Rightarrow> 's trans" and b::real
   assume chain: "\<And>i. le_trans (M i) (M (Suc i))"
      and fM:    "\<And>i. feasible (M i)"
   show fw: "le_trans (Sup_trans (range (?F o M))) (?F (Sup_trans (range M)))"
   proof(rule le_transI[OF Sup_trans_least2], clarsimp)
     fix P Q::"'s expect" and t
     assume sP: "sound P"
     assume nQ: "nneg Q" and bP: "bounded_by (bound_of P) Q"
     hence sQ: "sound Q" by(auto)
 
     from fM have fSup: "feasible (Sup_trans (range M))"
       by(auto intro:feasible_Sup_trans)
 
     from sQ fM have "M t Q \<tturnstile> Sup_trans (range M) Q"
       by(auto intro:Sup_trans_upper2)
     moreover from sQ fM fSup
       have sMtP: "sound (M t Q)" "sound (Sup_trans (range M) Q)" by(auto)
     ultimately have "wp body (M t Q) \<tturnstile> wp body (Sup_trans (range M) Q)"
       using healthy_monoD[OF hb] by(auto)
     hence "\<And>s. wp body (M t Q) s \<le> wp body (Sup_trans (range M) Q) s"
       by(rule le_funD)
     thus "?F (M t) Q \<tturnstile> ?F (Sup_trans (range M)) Q"
       by(intro le_funI, simp add:wp_eval mult_left_mono)
 
     show "nneg (wp (body ;; Embed (Sup_trans (range M)) \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) Q)"
     proof(rule nnegI, simp add:wp_eval)
       fix s::'s
         from fSup sQ have "sound (Sup_trans (range M) Q)" by(auto)
         with hb have "sound (wp body (Sup_trans (range M) Q))" by(auto)
         hence "0 \<le> wp body (Sup_trans (range M) Q) s" by(auto)
         moreover from sQ have "0 \<le> Q s" by(auto)
         ultimately show "0 \<le> \<guillemotleft>G\<guillemotright> s * wp body (Sup_trans (range M) Q) s + (1 - \<guillemotleft>G\<guillemotright> s) * Q s"
           by(auto intro:add_nonneg_nonneg mult_nonneg_nonneg)
     qed
   next
     fix P::"'s expect" assume sP: "sound P"
     thus "nneg P" "bounded_by (bound_of P) P" by(auto)
     show "\<forall>u\<in>range ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> M).
             \<forall>R. nneg R \<and> bounded_by (bound_of P) R \<longrightarrow>
                 nneg (u R) \<and> bounded_by (bound_of P) (u R)"
     proof(clarsimp, intro conjI nnegI bounded_byI, simp_all add:wp_eval)
       fix u::nat and R::"'s expect" and s::'s
       assume nR: "nneg R" and bR: "bounded_by (bound_of P) R"
       hence sR: "sound R" by(auto)
       with fM have sMuR: "sound (M u R)" by(auto)
       with hb have "sound (wp body (M u R))" by(auto)
       hence "0 \<le> wp body (M u R) s" by(auto)
       moreover from nR have "0 \<le> R s" by(auto)
       ultimately show "0 \<le> \<guillemotleft>G\<guillemotright> s * wp body (M u R) s + (1 - \<guillemotleft>G\<guillemotright> s) * R s"
         by(auto intro:add_nonneg_nonneg mult_nonneg_nonneg)
 
       from sR bR fM have "bounded_by (bound_of P) (M u R)" by(auto)
       with sMuR hb have "bounded_by (bound_of P) (wp body (M u R))" by(auto)
       hence "wp body (M u R) s \<le> bound_of P" by(auto)
       moreover from bR have "R s \<le> bound_of P" by(auto)
       ultimately have "\<guillemotleft>G\<guillemotright> s * wp body (M u R) s + (1 - \<guillemotleft>G\<guillemotright> s) * R s \<le>
                        \<guillemotleft>G\<guillemotright> s * bound_of P + (1 - \<guillemotleft>G\<guillemotright> s) * bound_of P"
         by(auto intro:add_mono mult_left_mono)
       also have "... = bound_of P" by(simp add:algebra_simps)
       finally show "\<guillemotleft>G\<guillemotright> s * wp body (M u R) s + (1 - \<guillemotleft>G\<guillemotright> s) * R s \<le> bound_of P" .
     qed
   qed
 
   show "le_trans (?F (Sup_trans (range M))) (Sup_trans (range (?F o M)))"
    proof(rule le_transI, rule le_funI, simp add: wp_eval cong del: image_cong_simp)
     fix P::"'s expect" and s::'s
     assume sP: "sound P"
     have "{t P |t. t \<in> range M} = range (\<lambda>i. M i P)"
       by(blast)
     hence "wp body (Sup_trans (range M) P) s = wp body (Sup_exp (range (\<lambda>i. M i P))) s"
       by(simp add:Sup_trans_def)
     also {
       from sP fM have "\<And>i. sound (M i P)" by(auto)
       moreover from sP chain have "\<And>i. M i P \<tturnstile> M (Suc i) P" by(auto)
       moreover {
         from sP have "bounded_by (bound_of P) P" by(auto)
         with sP fM have "\<And>i. bounded_by (bound_of P) (M i P)" by(auto)
       }
       ultimately have "wp body (Sup_exp (range (\<lambda>i. M i P))) s =
                        Sup_exp (range (\<lambda>i. wp body (M i P))) s"
         by(subst bd_ctsD[OF cb], auto simp:o_def)
     }
     also have "Sup_exp (range (\<lambda>i. wp body (M i P))) s =
                Sup {f s |f. f \<in> range (\<lambda>i. wp body (M i P))}"
       by(simp add:Sup_exp_def)
     finally have "\<guillemotleft>G\<guillemotright> s * wp body (Sup_trans (range M) P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s =
                   \<guillemotleft>G\<guillemotright> s * Sup {f s |f. f \<in> range (\<lambda>i. wp body (M i P))} + (1 - \<guillemotleft>G\<guillemotright> s) * P s"
       by(simp)
     also {
       from sP fM have "\<And>i. sound (M i P)" by(auto)
       moreover from sP fM have "\<And>i. bounded_by (bound_of P) (M i P)" by(auto)
       ultimately have "\<And>i. bounded_by (bound_of P) (wp body (M i P))" using hb by(auto)
       hence bound: "\<And>i. wp body (M i P) s \<le> bound_of P" by(auto)
       moreover
       have "{\<guillemotleft> G \<guillemotright> s * x |x. x \<in> {f s |f. f \<in> range (\<lambda>i. wp body (M i P))}} =
             {\<guillemotleft> G \<guillemotright> s * f s |f. f \<in> range (\<lambda>i. wp body (M i P))}"
         by(blast)
       ultimately
       have "\<guillemotleft>G\<guillemotright> s * Sup {f s |f. f \<in> range (\<lambda>i. wp body (M i P))} =
             Sup {\<guillemotleft>G\<guillemotright> s * f s |f. f \<in> range (\<lambda>i. wp body (M i P))}"
         by(subst cSup_mult, auto)
       moreover {
         have "{x + (1-\<guillemotleft>G\<guillemotright> s) * P s |x.
                x \<in> {\<guillemotleft>G\<guillemotright> s * f s |f. f \<in> range (\<lambda>i. wp body (M i P))}} =
               {\<guillemotleft>G\<guillemotright> s * f s + (1-\<guillemotleft>G\<guillemotright> s) * P s |f. f \<in> range (\<lambda>i. wp body (M i P))}"
           by(blast)
         moreover from bound sP have "\<And>i. \<guillemotleft>G\<guillemotright> s * wp body (M i P) s \<le> bound_of P"
           by(cases "G s", auto)
         ultimately
         have "Sup {\<guillemotleft>G\<guillemotright> s * f s |f. f \<in> range (\<lambda>i. wp body (M i P))} + (1-\<guillemotleft>G\<guillemotright> s) * P s =
               Sup {\<guillemotleft>G\<guillemotright> s * f s + (1-\<guillemotleft>G\<guillemotright> s) * P s |f. f \<in> range (\<lambda>i. wp body (M i P))}"
           by(subst cSup_add, auto)
       }
       ultimately
       have "\<guillemotleft>G\<guillemotright> s * Sup {f s |f. f \<in> range (\<lambda>i. wp body (M i P))} + (1-\<guillemotleft>G\<guillemotright> s) * P s =
             Sup {\<guillemotleft>G\<guillemotright> s * f s + (1-\<guillemotleft>G\<guillemotright> s) * P s |f. f \<in> range (\<lambda>i. wp body (M i P))}"
         by(simp)
     }
     also {
       have "\<And>i. \<guillemotleft>G\<guillemotright> s * wp body (M i P) s + (1-\<guillemotleft>G\<guillemotright> s) * P s =
                  ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> M) i P s"
         by(simp add:wp_eval)
       also have "\<And>i. ... i \<le>
                  Sup {f s |f. f \<in> {t P |t. t \<in> range ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> M)}}"
       proof(intro cSup_upper bdd_aboveI, blast, clarsimp simp:wp_eval)
         fix i
         from sP have bP: "bounded_by (bound_of P) P" by(auto)
         with sP fM have "sound (M i P)" "bounded_by (bound_of P) (M i P)" by(auto)
         with hb have "bounded_by (bound_of P) (wp body (M i P))" by(auto)
         with bP have "wp body (M i P) s \<le> bound_of P" "P s \<le> bound_of P" by(auto)
         hence "\<guillemotleft>G\<guillemotright> s * wp body (M i P) s + (1-\<guillemotleft>G\<guillemotright> s) * P s \<le>
                \<guillemotleft>G\<guillemotright> s * (bound_of P) + (1-\<guillemotleft>G\<guillemotright> s) * (bound_of P)"
           by(auto intro:add_mono mult_left_mono)
         also have "... = bound_of P" by(simp add:algebra_simps)
         finally show "\<guillemotleft>G\<guillemotright> s * wp body (M i P) s + (1-\<guillemotleft>G\<guillemotright> s) * P s \<le> bound_of P" .
       qed
       finally
       have "Sup {\<guillemotleft>G\<guillemotright> s * f s + (1-\<guillemotleft>G\<guillemotright> s) * P s |f. f \<in> range (\<lambda>i. wp body (M i P))} \<le>
             Sup {f s |f. f \<in> {t P |t. t \<in> range ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> M)}}"
         by(blast intro:cSup_least)
     }
     also have "Sup {f s |f. f \<in> {t P |t. t \<in> range ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> M)}} =
                Sup_trans (range ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> M)) P s"
       by(simp add:Sup_trans_def Sup_exp_def)
     finally show "\<guillemotleft>G\<guillemotright> s * wp body (Sup_trans (range M) P) s + (1-\<guillemotleft>G\<guillemotright> s) * P s \<le>
                   Sup_trans (range ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> M)) P s" .
   qed
 qed
 
 end
diff --git a/thys/pGCL/Healthiness.thy b/thys/pGCL/Healthiness.thy
--- a/thys/pGCL/Healthiness.thy
+++ b/thys/pGCL/Healthiness.thy
@@ -1,1122 +1,1126 @@
 (*
  * Copyright (C) 2014 NICTA
  * All rights reserved.
  *)
 
 (* Author: David Cock - David.Cock@nicta.com.au *)
 
 section \<open>Healthiness\<close>
 
 theory Healthiness imports Embedding begin
 
 subsection \<open>The Healthiness of the Embedding\<close>
 
 text \<open>Healthiness is mostly derived by structural induction using
   the simplifier.  @{term Abort}, @{term Skip} and @{term Apply}
   form base cases.\<close>
 
 lemma healthy_wp_Abort:
   "healthy (wp Abort)"
 proof(rule healthy_parts)
   fix b and P::"'a \<Rightarrow> real"
   assume nP: "nneg P" and bP: "bounded_by b P"
   thus "bounded_by b (wp Abort P)"
     unfolding wp_eval by(blast)
   show "nneg (wp Abort P)"
     unfolding wp_eval by(blast)
 next
   fix P Q::"'a expect"
   show "wp Abort P \<tturnstile> wp Abort Q"
     unfolding wp_eval by(blast)
 next
   fix P and c and s::'a
   show "c * wp Abort P s = wp Abort (\<lambda>s. c * P s) s"
     unfolding wp_eval by(auto)
 qed
 
 lemma nearly_healthy_wlp_Abort:
   "nearly_healthy (wlp Abort)"
 proof(rule nearly_healthyI)
   fix P::"'s \<Rightarrow> real"
   show "unitary (wlp Abort P)"
     by(simp add:wp_eval)
 next
   fix P Q :: "'s expect"
   assume "P \<tturnstile> Q" and "unitary P" and "unitary Q"
   thus "wlp Abort P \<tturnstile> wlp Abort Q"
     unfolding wp_eval by(blast)
 qed
 
 lemma healthy_wp_Skip:
   "healthy (wp Skip)"
   by(force intro!:healthy_parts simp:wp_eval)
 
 lemma nearly_healthy_wlp_Skip:
   "nearly_healthy (wlp Skip)"
   by(auto simp:wp_eval)
 
 lemma healthy_wp_Seq:
   fixes t::"'s prog" and u
   assumes ht: "healthy (wp t)" and hu: "healthy (wp u)"
   shows "healthy (wp (t ;; u))"
 proof(rule healthy_parts, simp_all add:wp_eval)
   fix b and P::"'s \<Rightarrow> real"
   assume "bounded_by b P" and "nneg P"
   with hu have "bounded_by b (wp u P)" and "nneg (wp u P)" by(auto)
   with ht show "bounded_by b (wp t (wp u P))"
            and "nneg (wp t (wp u P))" by(auto)
 next
   fix P::"'s \<Rightarrow> real" and Q
   assume "sound P" and "sound Q" and "P \<tturnstile> Q"
   with hu have "sound (wp u P)" and "sound (wp u Q)"
     and "wp u P \<tturnstile> wp u Q" by(auto)
   with ht show "wp t (wp u P) \<tturnstile> wp t (wp u Q)" by(auto)
 next
   fix P::"'s \<Rightarrow> real" and c::real and s
   assume pos: "0 \<le> c" and sP: "sound P"
   with ht and hu have "c * wp t (wp u P) s = wp t (\<lambda>s. c * wp u P s) s"
     by(auto intro!:scalingD)
   also with hu and pos and sP have "... = wp t (wp u (\<lambda>s. c * P s)) s"
     by(simp add:scalingD[OF healthy_scalingD])
   finally show "c * wp t (wp u P) s = wp t (wp u (\<lambda>s. c * P s)) s" .
 qed
 
 lemma nearly_healthy_wlp_Seq:
   fixes t::"'s prog" and u
   assumes ht: "nearly_healthy (wlp t)" and hu: "nearly_healthy (wlp u)"
   shows "nearly_healthy (wlp (t ;; u))"
 proof(rule nearly_healthyI, simp_all add:wp_eval)
   fix b and P::"'s \<Rightarrow> real"
   assume "unitary P"
   with hu have "unitary (wlp u P)" by(auto)
   with ht show "unitary (wlp t (wlp u P))" by(auto)
 next
   fix P Q::"'s \<Rightarrow> real"
   assume "unitary P" and "unitary Q" and "P \<tturnstile> Q"
   with hu have "unitary (wlp u P)" and "unitary (wlp u Q)"
     and "wlp u P \<tturnstile> wlp u Q" by(auto)
   with ht show "wlp t (wlp u P) \<tturnstile> wlp t (wlp u Q)" by(auto)
 qed
 
 lemma healthy_wp_PC:
   fixes f::"'s prog" 
   assumes hf: "healthy (wp f)" and hg: "healthy (wp g)"
       and uP: "unitary P"
   shows "healthy (wp (f \<^bsub>P\<^esub>\<oplus> g))"
 proof(intro healthy_parts bounded_byI nnegI le_funI, simp_all add:wp_eval)
   fix b and Q::"'s \<Rightarrow> real" and s::'s
   assume nQ: "nneg Q" and bQ: "bounded_by b Q"
 
   txt \<open>Non-negative:\<close>
   from nQ and bQ and hf have "0 \<le> wp f Q s" by(auto)
   with uP have "0 \<le> P s * ..." by(auto intro:mult_nonneg_nonneg)
   moreover {
-    from uP have "0 \<le> 1 - P s" by(auto simp:sign_simps)
+    from uP have "0 \<le> 1 - P s"
+      by auto
     with nQ and bQ and hg have "0 \<le> ... * wp g Q s"
       by (metis healthy_nnegD2 mult_nonneg_nonneg nneg_def)
   }
   ultimately show "0 \<le> P s * wp f Q s + (1 - P s) * wp g Q s"
     by(auto intro:mult_nonneg_nonneg)
 
   txt \<open>Bounded:\<close>
   from nQ bQ hf have "wp f Q s \<le> b" by(auto)
   with uP nQ bQ hf have "P s * wp f Q s \<le> P s * b"
     by(blast intro!:mult_mono)
   moreover {
     from nQ bQ hg uP
-    have "wp g Q s \<le> b" and "0 \<le> 1 - P s" by(auto simp:sign_simps)
+    have "wp g Q s \<le> b" and "0 \<le> 1 - P s"
+      by auto
     with nQ bQ hg have "(1 - P s) * wp g Q s \<le> (1 - P s) * b"
       by(blast intro!:mult_mono)
   }
   ultimately have "P s * wp f Q s + (1 - P s) * wp g Q s \<le>
                    P s * b + (1 - P s) * b"
     by(blast intro:add_mono)
   also have "... = b" by(auto simp:algebra_simps)
   finally show "P s * wp f Q s + (1 - P s) * wp g Q s \<le> b" .
 next
   txt \<open>Monotonic:\<close>
   fix Q R::"'s \<Rightarrow> real" and s
   assume sQ: "sound Q" and sR: "sound R" and le: "Q \<tturnstile> R"
 
   with hf have "wp f Q s \<le> wp f R s" by(blast dest:mono_transD)
   with uP have "P s * wp f Q s \<le> P s * wp f R s"
     by(auto intro:mult_left_mono)
   moreover {
     from sQ sR le hg
     have "wp g Q s \<le> wp g R s" by(blast dest:mono_transD)
-    moreover from uP have "0 \<le> 1 - P s" by(auto simp:sign_simps)
+    moreover from uP have "0 \<le> 1 - P s"
+      by auto
     ultimately have "(1 - P s) * wp g Q s \<le> (1 - P s) * wp g R s"
       by(auto intro:mult_left_mono)
   }
   ultimately show "P s * wp f Q s + (1 - P s) * wp g Q s \<le>
                    P s * wp f R s + (1 - P s) * wp g R s" by(auto)
 next
   txt \<open>Scaling:\<close>
   fix Q::"'s \<Rightarrow> real" and c::real and s::'s
   assume sQ: "sound Q" and pos: "0 \<le> c"
   have "c * (P s * wp f Q s + (1 - P s) * wp g Q s) =
         P s * (c * wp f Q s) + (1 - P s) * (c * wp g Q s)"
     by(simp add:distrib_left)
   also have "... = P s * wp f (\<lambda>s.  c * Q s) s +
                    (1 - P s) * wp g (\<lambda>s. c * Q s) s"
     using hf hg sQ pos
     by(simp add:scalingD[OF healthy_scalingD])
   finally show "c * (P s * wp f Q s + (1 - P s) * wp g Q s) =
                 P s * wp f (\<lambda>s. c * Q s) s + (1 - P s) * wp g (\<lambda>s. c * Q s) s" .
 qed
 
 lemma nearly_healthy_wlp_PC:
   fixes f::"'s prog" 
   assumes hf: "nearly_healthy (wlp f)"
       and hg: "nearly_healthy (wlp g)"
       and uP: "unitary P"
   shows "nearly_healthy (wlp (f \<^bsub>P\<^esub>\<oplus> g))"
 proof(intro nearly_healthyI unitaryI2 nnegI bounded_byI le_funI,
       simp_all add:wp_eval)
   fix Q::"'s expect" and s::'s
   assume uQ: "unitary Q"
   from uQ hf hg have utQ: "unitary (wlp f Q)" "unitary (wlp g Q)" by(auto)
-  from uP have nnP: "0 \<le> P s" "0 \<le> 1 - P s" by(auto simp:sign_simps)
+  from uP have nnP: "0 \<le> P s" "0 \<le> 1 - P s"
+    by auto
   moreover from utQ have "0 \<le> wlp f Q s" "0 \<le> wlp g Q s" by(auto)
   ultimately show "0 \<le> P s * wlp f Q s + (1 - P s) * wlp g Q s"
     by(auto intro:add_nonneg_nonneg mult_nonneg_nonneg)
 
   from utQ have "wlp f Q s \<le> 1" "wlp g Q s \<le> 1" by(auto)
   with nnP have "P s * wlp f Q s + (1 - P s) * wlp g Q s \<le> P s * 1 + (1 - P s) * 1"
     by(blast intro:add_mono mult_left_mono)
   thus "P s * wlp f Q s + (1 - P s) * wlp g Q s \<le> 1" by(simp)
 
   fix R::"'s expect"
   assume uR: "unitary R" and le: "Q \<tturnstile> R"
   with uQ have "wlp f Q s \<le> wlp f R s"
     by(auto intro:le_funD[OF nearly_healthy_monoD, OF hf])
   with nnP have "P s * wlp f Q s \<le> P s * wlp f R s"
     by(auto intro:mult_left_mono)
   moreover {
     from uQ uR le have "wlp g Q s \<le> wlp g R s"
       by(auto intro:le_funD[OF nearly_healthy_monoD, OF hg])
     with nnP have "(1 - P s) * wlp g Q s \<le> (1 - P s) * wlp g R s"
       by(auto intro:mult_left_mono)
   }
   ultimately show "P s * wlp f Q s + (1 - P s) * wlp g Q s \<le>
                    P s * wlp f R s + (1 - P s) * wlp g R s"
     by(auto)
 qed
 
 lemma healthy_wp_DC:
   fixes f::"'s prog"
   assumes hf: "healthy (wp f)" and hg: "healthy (wp g)"
   shows "healthy (wp (f \<Sqinter> g))"
 proof(intro healthy_parts bounded_byI nnegI le_funI, simp_all only:wp_eval)
   fix b and P::"'s \<Rightarrow> real" and s::'s
   assume nP: "nneg P" and bP: "bounded_by b P"
 
   with hf have "bounded_by b (wp f P)" by(auto)
   hence "wp f P s \<le> b" by(blast)
   thus "min (wp f P s) (wp g P s) \<le> b" by(auto)
 
   from nP bP assms show "0 \<le> min (wp f P s) (wp g P s)" by(auto)
 next
   fix P::"'s \<Rightarrow> real" and Q and s::'s
   from assms have mf: "mono_trans (wp f)" and mg: "mono_trans (wp g)" by(auto)
   assume sP: "sound P" and sQ: "sound Q" and le: "P \<tturnstile> Q"
   hence "wp f P s \<le> wp f Q s" and "wp g P s \<le> wp g Q s"
     by(auto intro:le_funD[OF mono_transD[OF mf]] le_funD[OF mono_transD[OF mg]])
   thus "min (wp f P s) (wp g P s) \<le> min (wp f Q s) (wp g Q s)" by(auto)
 next
   fix P::"'s \<Rightarrow> real" and c::real and s::'s
   assume sP: "sound P" and pos: "0 \<le> c"
   from assms have sf: "scaling (wp f)" and sg: "scaling (wp g)" by(auto)
   from pos have "c * min (wp f P s) (wp g P s) =
                  min (c * wp f P s) (c * wp g P s)"
     by(simp add:min_distrib)
   also from sP and pos
   have "... = min (wp f (\<lambda>s. c * P s) s) (wp g (\<lambda>s. c * P s) s)"
     by(simp add:scalingD[OF sf] scalingD[OF sg])
   finally show "c * min (wp f P s) (wp g P s) =
                 min (wp f (\<lambda>s. c * P s) s) (wp g (\<lambda>s. c * P s) s)" .
 qed
 
 lemma nearly_healthy_wlp_DC:
   fixes f::"'s prog"
   assumes hf: "nearly_healthy (wlp f)"
       and hg: "nearly_healthy (wlp g)"
   shows "nearly_healthy (wlp (f \<Sqinter> g))"
 proof(intro nearly_healthyI bounded_byI nnegI le_funI unitaryI2,
       simp_all add:wp_eval, safe)
   fix P::"'s \<Rightarrow> real" and s::'s
   assume uP: "unitary P"
   with hf hg have utP: "unitary (wlp f P)" "unitary (wlp g P)" by(auto)
   thus "0 \<le> wlp f P s" "0 \<le> wlp g P s" by(auto)
 
   have "min (wlp f P s) (wlp g P s) \<le> wlp f P s" by(auto)
   also from utP have "... \<le> 1" by(auto)
   finally show "min (wlp f P s) (wlp g P s) \<le> 1" .
 
   fix Q::"'s \<Rightarrow> real"
   assume uQ: "unitary Q" and le: "P \<tturnstile> Q"
   have "min (wlp f P s) (wlp g P s) \<le> wlp f P s" by(auto)
   also from uP uQ le have "... \<le> wlp f Q s"
     by(auto intro:le_funD[OF nearly_healthy_monoD, OF hf])
   finally show "min (wlp f P s) (wlp g P s) \<le> wlp f Q s" .
 
   have "min (wlp f P s) (wlp g P s) \<le> wlp g P s" by(auto)
   also from uP uQ le have "... \<le> wlp g Q s"
     by(auto intro:le_funD[OF nearly_healthy_monoD, OF hg])
   finally show "min (wlp f P s) (wlp g P s) \<le> wlp g Q s" .
 qed
 
 lemma healthy_wp_AC:
   fixes f::"'s prog"
   assumes hf: "healthy (wp f)" and hg: "healthy (wp g)"
   shows "healthy (wp (f \<Squnion> g))"
 proof(intro healthy_parts bounded_byI nnegI le_funI, simp_all only:wp_eval)
   fix b and P::"'s \<Rightarrow> real" and s::'s
   assume nP: "nneg P" and bP: "bounded_by b P"
 
   with hf have "bounded_by b (wp f P)" by(auto)
   hence "wp f P s \<le> b" by(blast)
   moreover {
     from bP nP hg have "bounded_by b (wp g P)" by(auto)
     hence "wp g P s \<le> b" by(blast)
   }
   ultimately show "max (wp f P s) (wp g P s) \<le> b" by(auto)
 
   from nP bP assms have "0 \<le> wp f P s" by(auto)
   thus "0 \<le> max (wp f P s) (wp g P s)" by(auto)
 next
   fix P::"'s \<Rightarrow> real" and Q and s::'s
   from assms have mf: "mono_trans (wp f)" and mg: "mono_trans (wp g)" by(auto)
   assume sP: "sound P" and sQ: "sound Q" and le: "P \<tturnstile> Q"
   hence "wp f P s \<le> wp f Q s" and "wp g P s \<le> wp g Q s"
     by(auto intro:le_funD[OF mono_transD, OF mf] le_funD[OF mono_transD, OF mg])
   thus "max (wp f P s) (wp g P s) \<le> max (wp f Q s) (wp g Q s)" by(auto)
 next
   fix P::"'s \<Rightarrow> real" and c::real and s::'s
   assume sP: "sound P" and pos: "0 \<le> c"
   from assms have sf: "scaling (wp f)" and sg: "scaling (wp g)" by(auto)
   from pos have "c * max (wp f P s) (wp g P s) =
                  max (c * wp f P s) (c * wp g P s)"
     by(simp add:max_distrib)
   also from sP and pos
   have "... = max (wp f (\<lambda>s. c * P s) s) (wp g (\<lambda>s. c * P s) s)"
     by(simp add:scalingD[OF sf] scalingD[OF sg])
   finally show "c * max (wp f P s) (wp g P s) =
                 max (wp f (\<lambda>s. c * P s) s) (wp g (\<lambda>s. c * P s) s)" .
 qed
 
 lemma nearly_healthy_wlp_AC:
   fixes f::"'s prog"
   assumes hf: "nearly_healthy (wlp f)"
       and hg: "nearly_healthy (wlp g)"
   shows "nearly_healthy (wlp (f \<Squnion> g))"
 proof(intro nearly_healthyI bounded_byI nnegI unitaryI2 le_funI, simp_all only:wp_eval)
   fix b and P::"'s \<Rightarrow> real" and s::'s
   assume uP: "unitary P"
 
   with hf have "wlp f P s \<le> 1" by(auto)
   moreover from uP hg have "unitary (wlp g P)" by(auto)
   hence "wlp g P s \<le> 1" by(auto)
   ultimately show "max (wlp f P s) (wlp g P s) \<le> 1" by(auto)
 
   from uP hf have "unitary (wlp f P)" by(auto)
   hence "0 \<le> wlp f P s" by(auto)
   thus "0 \<le> max (wlp f P s) (wlp g P s)" by(auto)
 next
   fix P::"'s \<Rightarrow> real" and Q and s::'s
   assume uP: "unitary P" and uQ: "unitary Q" and le: "P \<tturnstile> Q"
   hence "wlp f P s \<le> wlp f Q s" and "wlp g P s \<le> wlp g Q s"
     by(auto intro:le_funD[OF nearly_healthy_monoD, OF hf]
                   le_funD[OF nearly_healthy_monoD, OF hg])
   thus "max (wlp f P s) (wlp g P s) \<le> max (wlp f Q s) (wlp g Q s)" by(auto)
 qed
 
 lemma healthy_wp_Embed:
   "healthy t \<Longrightarrow> healthy (wp (Embed t))"
   unfolding wp_def Embed_def by(simp)
 
 lemma nearly_healthy_wlp_Embed:
   "nearly_healthy t \<Longrightarrow> nearly_healthy (wlp (Embed t))"
   unfolding wlp_def Embed_def by(simp)
 
 lemma healthy_wp_repeat:
   assumes h_a: "healthy (wp a)"
   shows "healthy (wp (repeat n a))" (is "?X n")
 proof(induct n)
   show "?X 0" by(auto simp:wp_eval)
 next
   fix n assume IH: "?X n"
   thus "?X (Suc n)" by(simp add:healthy_wp_Seq h_a)
 qed
 
 lemma nearly_healthy_wlp_repeat:
   assumes h_a: "nearly_healthy (wlp a)"
   shows "nearly_healthy (wlp (repeat n a))" (is "?X n")
 proof(induct n)
   show "?X 0" by(simp add:wp_eval)
 next
   fix n assume IH: "?X n"
   thus "?X (Suc n)" by(simp add:nearly_healthy_wlp_Seq h_a)
 qed
 
 lemma healthy_wp_SetDC:
   fixes prog::"'b \<Rightarrow> 'a prog" and S::"'a \<Rightarrow> 'b set"
   assumes healthy:  "\<And>x s. x \<in> S s \<Longrightarrow> healthy (wp (prog x))"
       and nonempty: "\<And>s. \<exists>x. x \<in> S s"
   shows "healthy (wp (SetDC prog S))" (is "healthy ?T")
 proof(intro healthy_parts bounded_byI nnegI le_funI, simp_all only:wp_eval)
   fix b and P::"'a \<Rightarrow> real" and s::'a
   assume bP: "bounded_by b P" and nP: "nneg P"
   hence sP: "sound P" by(auto)
 
   from nonempty obtain x where xin: "x \<in> (\<lambda>a. wp (prog a) P s) ` S s" by(blast)
   moreover from sP and healthy
   have "\<forall>x\<in>(\<lambda>a. wp (prog a) P s) ` S s. 0 \<le> x" by(auto)
   ultimately have "Inf ((\<lambda>a. wp (prog a) P s) ` S s) \<le> x"
     by(intro cInf_lower bdd_belowI, auto)
   also from xin and healthy and sP and bP have "x \<le> b" by(blast)
   finally show "Inf ((\<lambda>a. wp (prog a) P s) ` S s) \<le> b" .
 
   from xin and sP and healthy
   show "0 \<le> Inf ((\<lambda>a. wp (prog a) P s) ` S s)" by(blast intro:cInf_greatest)
 next
   fix P::"'a \<Rightarrow> real" and Q and s::'a
   assume sP: "sound P" and sQ: "sound Q" and le: "P \<tturnstile> Q"
 
   from nonempty obtain x where xin: "x \<in> (\<lambda>a. wp (prog a) P s) ` S s" by(blast)
   moreover from sP and healthy
   have "\<forall>x\<in>(\<lambda>a. wp (prog a) P s) ` S s. 0 \<le> x" by(auto)
   moreover
   have "\<forall>x\<in>(\<lambda>a. wp (prog a) Q s) ` S s. \<exists>y\<in>(\<lambda>a. wp (prog a) P s) ` S s. y \<le> x"
   proof(rule ballI, clarify, rule bexI)
     fix x and a assume ain: "a \<in> S s"
     with healthy and sP and sQ and le show "wp (prog a) P s \<le> wp (prog a) Q s"
       by(auto dest:mono_transD[OF healthy_monoD])
     from ain show "wp (prog a) P s \<in> (\<lambda>a. wp (prog a) P s) ` S s" by(simp)
   qed
   ultimately
   show "Inf ((\<lambda>a. wp (prog a) P s) ` S s) \<le> Inf ((\<lambda>a. wp (prog a) Q s) ` S s)"
     by(intro cInf_mono, blast+)
 next
   fix P::"'a \<Rightarrow> real" and c::real and s::'a
   assume sP: "sound P" and pos: "0 \<le> c"
   from nonempty obtain x where xin: "x \<in> (\<lambda>a. wp (prog a) P s) ` S s" by(blast)
   have "c * Inf ((\<lambda>a. wp (prog a) P s) ` S s) =
         Inf ((*) c ` ((\<lambda>a. wp (prog a) P s) ` S s))" (is "?U = ?V")
   proof(rule antisym)
     show "?U \<le> ?V"
     proof(rule cInf_greatest)
       from nonempty show "(*) c ` (\<lambda>a. wp (prog a) P s) ` S s \<noteq> {}" by(auto)
       fix x assume "x \<in> (*) c ` (\<lambda>a. wp (prog a) P s) ` S s"
       then obtain y where yin: "y \<in> (\<lambda>a. wp (prog a) P s) ` S s" and rwx: "x = c * y" by(auto)
       have "Inf ((\<lambda>a. wp (prog a) P s) ` S s) \<le> y"
       proof(intro cInf_lower[OF yin] bdd_belowI)
         fix z assume zin: "z \<in> (\<lambda>a. wp (prog a) P s) ` S s"
         then obtain a where "a \<in> S s" and "z = wp (prog a) P s" by(auto)
         with sP show "0 \<le> z" by(auto dest:healthy)
       qed
       with pos rwx show "c * Inf ((\<lambda>a. wp (prog a) P s) ` S s) \<le> x" by(auto intro:mult_left_mono)
     qed
     show "?V \<le> ?U"
     proof(cases)
       assume cz: "c = 0"
       moreover {
         from nonempty obtain c where "c \<in> S s" by(auto)
         hence "\<exists>x. \<exists>xa\<in>S s. x = wp (prog xa) P s" by(auto)
       }
       ultimately show ?thesis by(simp add:image_def)
     next
       assume "c \<noteq> 0"
       from nonempty have "S s \<noteq> {}" by blast
       then have "inverse c * (INF x\<in>S s. c * wp (prog x) P s) \<le> (INF a\<in>S s. wp (prog a) P s)"
       proof (rule cINF_greatest)
         fix x
         assume "x \<in> S s"
         have "bdd_below ((\<lambda>x. c * wp (prog x) P s) ` S s)"
         proof (rule bdd_belowI [of _ 0])
           fix z
           assume "z \<in> (\<lambda>x. c * wp (prog x) P s) ` S s"
           then obtain b where "b \<in> S s" and rwz: "z = c * wp (prog b) P s" by auto
           with sP have "0 \<le> wp (prog b) P s" by (auto dest: healthy)
           with pos show "0 \<le> z" by (auto simp: rwz intro: mult_nonneg_nonneg)
         qed
         then have "(INF x\<in>S s. c * wp (prog x) P s) \<le> c * wp (prog x) P s"
         using \<open>x \<in> S s\<close> by (rule cINF_lower)
         with \<open>c \<noteq> 0\<close> show "inverse c * (INF x\<in>S s. c * wp (prog x) P s) \<le> wp (prog x) P s"
           by (simp add: mult_div_mono_left pos)
       qed
       with \<open>c \<noteq> 0\<close> have "inverse c * ?V \<le> inverse c * ?U"
         by (simp add: mult.assoc [symmetric] image_comp)
       with pos have "c * (inverse c * ?V) \<le> c * (inverse c * ?U)"
         by(auto intro:mult_left_mono)
       with \<open>c \<noteq> 0\<close> show ?thesis by (simp add:mult.assoc [symmetric])
     qed
   qed
   also have "... = Inf ((\<lambda>a. c * wp (prog a) P s) ` S s)"
     by (simp add: image_comp)
   also from sP and pos have "... = Inf ((\<lambda>a. wp (prog a) (\<lambda>s. c * P s) s) ` S s)"
     by(simp add:scalingD[OF healthy_scalingD, OF healthy] cong:image_cong)
   finally show "c * Inf ((\<lambda>a. wp (prog a) P s) ` S s) =
                 Inf ((\<lambda>a. wp (prog a) (\<lambda>s. c * P s) s) ` S s)" .
 qed
 
 lemma nearly_healthy_wlp_SetDC:
   fixes prog::"'b \<Rightarrow> 'a prog" and S::"'a \<Rightarrow> 'b set"
   assumes healthy:  "\<And>x s. x \<in> S s \<Longrightarrow> nearly_healthy (wlp (prog x))"
       and nonempty: "\<And>s. \<exists>x. x \<in> S s"
   shows "nearly_healthy (wlp (SetDC prog S))" (is "nearly_healthy ?T")
 proof(intro nearly_healthyI unitaryI2 bounded_byI nnegI le_funI, simp_all only:wp_eval)
   fix b and P::"'a \<Rightarrow> real" and s::'a
   assume uP: "unitary P"
 
   from nonempty obtain x where xin: "x \<in> (\<lambda>a. wlp (prog a) P s) ` S s" by(blast)
   moreover {
     from uP healthy
     have "\<forall>x\<in>(\<lambda>a. wlp (prog a) P) ` S s. unitary x" by(auto)
     hence "\<forall>x\<in>(\<lambda>a. wlp (prog a) P) ` S s. 0 \<le> x s" by(auto)
     hence "\<forall>y\<in>(\<lambda>a. wlp (prog a) P s) ` S s. 0 \<le> y" by(auto)
   }
   ultimately have "Inf ((\<lambda>a. wlp (prog a) P s) ` S s) \<le> x" by(intro cInf_lower bdd_belowI, auto)
   also from xin healthy uP have "x \<le> 1" by(blast)
   finally show "Inf ((\<lambda>a. wlp (prog a) P s) ` S s) \<le> 1" .
 
   from xin uP healthy
   show "0 \<le> Inf ((\<lambda>a. wlp (prog a) P s) ` S s)"
     by(blast dest!:unitary_sound[OF nearly_healthy_unitaryD[OF _ uP]]
              intro:cInf_greatest)
 next
   fix P::"'a \<Rightarrow> real" and Q and s::'a
   assume uP: "unitary P" and uQ: "unitary Q" and le: "P \<tturnstile> Q"
 
   from nonempty obtain x where xin: "x \<in> (\<lambda>a. wlp (prog a) P s) ` S s" by(blast)
   moreover {
     from uP healthy
     have "\<forall>x\<in>(\<lambda>a. wlp (prog a) P) ` S s. unitary x" by(auto)
     hence "\<forall>x\<in>(\<lambda>a. wlp (prog a) P) ` S s. 0 \<le> x s" by(auto)
     hence "\<forall>y\<in>(\<lambda>a. wlp (prog a) P s) ` S s. 0 \<le> y" by(auto)
   }
   moreover
   have "\<forall>x\<in>(\<lambda>a. wlp (prog a) Q s) ` S s. \<exists>y\<in>(\<lambda>a. wlp (prog a) P s) ` S s. y \<le> x"
   proof(rule ballI, clarify, rule bexI)
     fix x and a assume ain: "a \<in> S s"
     from uP uQ le show "wlp (prog a) P s \<le> wlp (prog a) Q s"
       by(auto intro:le_funD[OF nearly_healthy_monoD[OF healthy, OF ain]])
     from ain show "wlp (prog a) P s \<in> (\<lambda>a. wlp (prog a) P s) ` S s" by(simp)
   qed
   ultimately
   show "Inf ((\<lambda>a. wlp (prog a) P s) ` S s) \<le> Inf ((\<lambda>a. wlp (prog a) Q s) ` S s)"
     by(intro cInf_mono, blast+)
 qed
 
 lemma healthy_wp_SetPC:
   fixes p::"'s \<Rightarrow> 'a \<Rightarrow> real"
   and   f::"'a \<Rightarrow> 's prog"
   assumes healthy: "\<And>a s. a \<in> supp (p s) \<Longrightarrow> healthy (wp (f a))"
       and sound: "\<And>s. sound (p s)"
       and sub_dist: "\<And>s. (\<Sum>a\<in>supp (p s). p s a) \<le> 1"
   shows "healthy (wp (SetPC f p))" (is "healthy ?X")
 proof(intro healthy_parts bounded_byI nnegI le_funI, simp_all add:wp_eval)
   fix b and P::"'s \<Rightarrow> real" and s::'s
   assume bP: "bounded_by b P" and nP: "nneg P"
   hence sP: "sound P" by(auto)
 
   from sP and bP and healthy have "\<And>a s. a \<in> supp (p s) \<Longrightarrow> wp (f a) P s \<le> b"
     by(blast dest:healthy_bounded_byD)
   with sound have "(\<Sum>a\<in>supp (p s). p s a * wp (f a) P s) \<le> (\<Sum>a\<in>supp (p s). p s a * b)"
     by(blast intro:sum_mono mult_left_mono)
   also have "... = (\<Sum>a\<in>supp (p s). p s a) * b"
     by(simp add:sum_distrib_right)
   also {
     from bP and nP have "0 \<le> b" by(blast)
     with sub_dist have "(\<Sum>a\<in>supp (p s). p s a) * b \<le> 1 * b"
       by(rule mult_right_mono)
   }
   also have "1 * b = b" by(simp)
   finally show "(\<Sum>a\<in>supp (p s). p s a * wp (f a) P s) \<le> b" .
 
   show "0 \<le> (\<Sum>a\<in>supp (p s). p s a * wp (f a) P s)"
   proof(rule sum_nonneg [OF mult_nonneg_nonneg])
     fix x
     from sound show "0 \<le> p s x" by(blast)
     assume "x \<in> supp (p s)" with sP and healthy
     show "0 \<le> wp (f x) P s" by(blast)
   qed
 next
   fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s
   assume s_P: "sound P" and s_Q: "sound Q" and ent: "P \<tturnstile> Q"
   with healthy have "\<And>a. a \<in> supp (p s) \<Longrightarrow> wp (f a) P s \<le> wp (f a) Q s"
     by(blast)
   with sound show "(\<Sum>a\<in>supp (p s). p s a * wp (f a) P s) \<le>
                    (\<Sum>a\<in>supp (p s). p s a * wp (f a) Q s)"
     by(blast intro:sum_mono mult_left_mono)
 next
   fix P::"'s \<Rightarrow> real" and c::real and s::'s
   assume sound: "sound P" and pos: "0 \<le> c"
   have "c * (\<Sum>a\<in>supp (p s). p s a * wp (f a) P s) =
         (\<Sum>a\<in>supp (p s). p s a * (c * wp (f a) P s))"
        (is "?A = ?B")
     by(simp add:sum_distrib_left ac_simps)
   also from sound and pos and healthy
   have "... = (\<Sum>a\<in>supp (p s). p s a * wp (f a) (\<lambda>s. c * P s) s)"
     by(auto simp:scalingD[OF healthy_scalingD])
   finally show "?A = ..." .
 qed
 
 lemma nearly_healthy_wlp_SetPC:
   fixes p::"'s \<Rightarrow> 'a \<Rightarrow> real"
   and   f::"'a \<Rightarrow> 's prog"
   assumes healthy: "\<And>a s. a \<in> supp (p s) \<Longrightarrow> nearly_healthy (wlp (f a))"
       and sound: "\<And>s. sound (p s)"
       and sub_dist: "\<And>s. (\<Sum>a\<in>supp (p s). p s a) \<le> 1"
   shows "nearly_healthy (wlp (SetPC f p))" (is "nearly_healthy ?X")
 proof(intro nearly_healthyI unitaryI2 bounded_byI nnegI le_funI, simp_all only:wp_eval)
   fix b and P::"'s \<Rightarrow> real" and s::'s
   assume uP: "unitary P"
 
   from uP healthy have "\<And>a. a \<in> supp (p s) \<Longrightarrow> unitary (wlp (f a) P)" by(auto)
   hence "\<And>a. a \<in> supp (p s) \<Longrightarrow> wlp (f a) P s \<le> 1" by(auto)
   with sound have "(\<Sum>a\<in>supp (p s). p s a * wlp (f a) P s) \<le> (\<Sum>a\<in>supp (p s). p s a * 1)"
     by(blast intro:sum_mono mult_left_mono)
   also have "... = (\<Sum>a\<in>supp (p s). p s a)"
     by(simp add:sum_distrib_right)
   also note sub_dist
   finally show "(\<Sum>a\<in>supp (p s). p s a * wlp (f a) P s) \<le> 1" .
   show "0 \<le> (\<Sum>a\<in>supp (p s). p s a * wlp (f a) P s)"
   proof(rule sum_nonneg [OF mult_nonneg_nonneg])
     fix x
     from sound show "0 \<le> p s x" by(blast)
     assume "x \<in> supp (p s)" with uP healthy
     show "0 \<le> wlp (f x) P s" by(blast)
   qed
 next
   fix P::"'s expect" and Q::"'s expect" and s
   assume uP: "unitary P" and uQ: "unitary Q" and le: "P \<tturnstile> Q"
   hence "\<And>a. a \<in> supp (p s) \<Longrightarrow> wlp (f a) P s \<le> wlp (f a) Q s"
     by(blast intro:le_funD[OF nearly_healthy_monoD, OF healthy])
   with sound show "(\<Sum>a\<in>supp (p s). p s a * wlp (f a) P s) \<le>
                    (\<Sum>a\<in>supp (p s). p s a * wlp (f a) Q s)"
     by(blast intro:sum_mono mult_left_mono)
 qed
 
 lemma healthy_wp_Apply:
   "healthy (wp (Apply f))"
   unfolding Apply_def wp_def by(blast)
 
 lemma nearly_healthy_wlp_Apply:
   "nearly_healthy (wlp (Apply f))"
   by(intro nearly_healthyI unitaryI2 nnegI bounded_byI, auto simp:o_def wp_eval)
 
 lemma healthy_wp_Bind:
   fixes f::"'s \<Rightarrow> 'a"
   assumes hsub: "\<And>s. healthy (wp (p (f s)))"
   shows "healthy (wp (Bind f p))"
 proof(intro healthy_parts nnegI bounded_byI le_funI, simp_all only:wp_eval)
   fix b and P::"'s expect" and s::'s
   assume bP: "bounded_by b P" and nP: "nneg P"
   with hsub have "bounded_by b (wp (p (f s)) P)" by(auto)
   thus "wp (p (f s)) P s \<le> b" by(auto)
   from bP nP hsub have "nneg (wp (p (f s)) P)" by(auto)
   thus "0 \<le> wp (p (f s)) P s" by(auto)
 next
   fix P Q::"'s expect" and s::'s
   assume "sound P" "sound Q" "P \<tturnstile> Q"
   thus "wp (p (f s)) P s \<le> wp (p (f s)) Q s"
     by(rule le_funD[OF mono_transD, OF healthy_monoD, OF hsub])
 next
   fix P::"'s expect" and c::real and s::'s
   assume "sound P" and "0 \<le> c"
   thus "c * wp (p (f s)) P s = wp (p (f s)) (\<lambda>s. c * P s) s"
     by(simp add:scalingD[OF healthy_scalingD, OF hsub])
 qed
 
 lemma nearly_healthy_wlp_Bind:
   fixes f::"'s \<Rightarrow> 'a"
   assumes hsub: "\<And>s. nearly_healthy (wlp (p (f s)))"
   shows "nearly_healthy (wlp (Bind f p))"
 proof(intro nearly_healthyI unitaryI2 nnegI bounded_byI le_funI, simp_all only:wp_eval)
   fix P::"'s expect" and s::'s assume uP: "unitary P"
   with hsub have "unitary (wlp (p (f s)) P)" by(auto)
   thus "0 \<le> wlp (p (f s)) P s" "wlp (p (f s)) P s \<le> 1" by(auto)
 
   fix Q::"'s expect"
   assume "unitary Q" "P \<tturnstile> Q"
   with uP show "wlp (p (f s)) P s \<le> wlp (p (f s)) Q s"
     by(blast intro:le_funD[OF nearly_healthy_monoD, OF hsub])
 qed
 
 subsection \<open>Healthiness for Loops\<close>
 
 lemma wp_loop_step_mono:
   fixes t u::"'s trans"
   assumes hb: "healthy (wp body)"
       and le: "le_trans t u"
       and ht: "\<And>P. sound P \<Longrightarrow> sound (t P)"
       and hu: "\<And>P. sound P \<Longrightarrow> sound (u P)"
   shows "le_trans (wp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))
                   (wp (body ;; Embed u \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))"
 proof(intro le_transI le_funI, simp add:wp_eval)
   fix P::"'s expect" and s::'s
   assume sP: "sound P"
   with le have "t P \<tturnstile> u P" by(auto)
   moreover from sP ht hu have "sound (t P)" "sound (u P)" by(auto)
   ultimately have "wp body (t P) s \<le> wp body (u P) s"
     by(auto intro:le_funD[OF mono_transD, OF healthy_monoD, OF hb])
   thus "\<guillemotleft>G\<guillemotright> s * wp body (t P) s \<le> \<guillemotleft>G\<guillemotright> s * wp body (u P) s "
     by(auto intro:mult_left_mono)
 qed
 
 lemma wlp_loop_step_mono:
   fixes t u::"'s trans"
   assumes mb: "nearly_healthy (wlp body)"
       and le: "le_utrans t u"
       and ht: "\<And>P. unitary P \<Longrightarrow> unitary (t P)"
       and hu: "\<And>P. unitary P \<Longrightarrow> unitary (u P)"
   shows "le_utrans (wlp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))
                    (wlp (body ;; Embed u \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))"
 proof(intro le_utransI le_funI, simp add:wp_eval)
   fix P::"'s expect" and s::'s
   assume uP: "unitary P"
   with le have "t P \<tturnstile> u P" by(auto)
   moreover from uP ht hu have "unitary (t P)" "unitary (u P)" by(auto)
   ultimately have "wlp body (t P) s \<le> wlp body (u P) s"
     by(rule le_funD[OF nearly_healthy_monoD[OF mb]])
   thus "\<guillemotleft>G\<guillemotright> s * wlp body (t P) s \<le> \<guillemotleft>G\<guillemotright> s * wlp body (u P) s "
     by(auto intro:mult_left_mono)
 qed
 
 text \<open>For each sound expectation, we have a pre fixed point of the loop body.
 This lets us use the relevant fixed-point lemmas.\<close>
 lemma lfp_loop_fp:
   assumes hb: "healthy (wp body)"
       and sP: "sound P"
   shows "\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. bound_of P) s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<tturnstile> \<lambda>s. bound_of P"
 proof(rule le_funI)
   fix s
   from sP have "sound (\<lambda>s. bound_of P)" by(auto)
   moreover hence "bounded_by (bound_of P) (\<lambda>s. bound_of P)" by(auto)
   ultimately have "bounded_by (bound_of P) (wp body (\<lambda>s. bound_of P))"
     using hb by(auto)
   hence "wp body (\<lambda>s. bound_of P) s \<le> bound_of P" by(auto)
   moreover from sP have "P s \<le> bound_of P" by(auto)
   ultimately have "\<guillemotleft>G\<guillemotright> s * wp body (\<lambda>a. bound_of P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<le>
                    \<guillemotleft>G\<guillemotright> s * bound_of P + (1 - \<guillemotleft>G\<guillemotright> s) * bound_of P"
     by(blast intro:add_mono mult_left_mono)
   thus "\<guillemotleft>G\<guillemotright> s * wp body (\<lambda>a. bound_of P) s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le> bound_of P"
     by(simp add:algebra_simps negate_embed)
 qed
 
 lemma lfp_loop_greatest:
   fixes P::"'s expect"
   assumes lb: "\<And>R. \<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body R s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<tturnstile> R \<Longrightarrow> sound R \<Longrightarrow> Q \<tturnstile> R"
       and hb: "healthy (wp body)"
       and sP: "sound P"
       and sQ: "sound Q"
   shows "Q \<tturnstile> lfp_exp (\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s)"
   using sP by(auto intro!:lfp_exp_greatest[OF lb sQ] sP lfp_loop_fp hb)
 
 lemma lfp_loop_sound:
   fixes P::"'s expect"
   assumes hb: "healthy (wp body)"
       and sP: "sound P"
   shows "sound (lfp_exp (\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s))"
   using assms by(auto intro!:lfp_exp_sound lfp_loop_fp)
 
 lemma wlp_loop_step_unitary:
   fixes t u::"'s trans"
   assumes hb: "nearly_healthy (wlp body)"
       and ht: "\<And>P. unitary P \<Longrightarrow> unitary (t P)"
       and uP: "unitary P"
   shows "unitary (wlp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P)"
 proof(intro unitaryI2 nnegI bounded_byI, simp_all add:wp_eval)
   fix s::'s
   from ht uP have utP: "unitary (t P)" by(auto)
   with hb have "unitary (wlp body (t P))" by(auto)
   hence "0 \<le> wlp body (t P) s" by(auto)
   with uP show "0 \<le> \<guillemotleft> G \<guillemotright> s * wlp body (t P) s + (1 - \<guillemotleft> G \<guillemotright> s) * P s"
     by(auto intro!:add_nonneg_nonneg mult_nonneg_nonneg)
   from ht uP have "bounded_by 1 (t P)" by(auto)
   with utP hb have "bounded_by 1 (wlp body (t P))" by(auto)
   hence "wlp body (t P) s \<le> 1" by(auto)
   with uP have "\<guillemotleft>G\<guillemotright> s * wlp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<le> \<guillemotleft>G\<guillemotright> s * 1 + (1 - \<guillemotleft>G\<guillemotright> s) * 1"
     by(blast intro:add_mono mult_left_mono)
   also have "... = 1" by(simp)
   finally show "\<guillemotleft>G\<guillemotright> s * wlp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<le> 1" .
 qed
 
 lemma wp_loop_step_sound:
   fixes t u::"'s trans"
   assumes hb: "healthy (wp body)"
       and ht: "\<And>P. sound P \<Longrightarrow> sound (t P)"
       and sP: "sound P"
   shows "sound (wp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P)"
 proof(intro soundI2 nnegI bounded_byI, simp_all add:wp_eval)
   fix s::'s
   from ht sP have stP: "sound (t P)" by(auto)
   with hb have "0 \<le> wp body (t P) s" by(auto)
   with sP show "0 \<le> \<guillemotleft> G \<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft> G \<guillemotright> s) * P s"
     by(auto intro!:add_nonneg_nonneg mult_nonneg_nonneg)
 
   from ht sP have "sound (t P)" by(auto)
   moreover hence "bounded_by (bound_of (t P)) (t P)" by(auto)
   ultimately have "wp body (t P) s \<le> bound_of (t P)" using hb by(auto)
   hence "wp body (t P) s \<le> max (bound_of P) (bound_of (t P))" by(auto)
   moreover {
     from sP have "P s \<le> bound_of P" by(auto)
     hence "P s \<le> max (bound_of P) (bound_of (t P))" by(auto)
   }
   ultimately
   have "\<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<le>
         \<guillemotleft>G\<guillemotright> s * max (bound_of P) (bound_of (t P)) +
         (1 - \<guillemotleft>G\<guillemotright> s) * max (bound_of P) (bound_of (t P))"
     by(blast intro:add_mono mult_left_mono)
   also have "... = max (bound_of P) (bound_of (t P))" by(simp add:algebra_simps)
   finally show "\<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<le>
                 max (bound_of P) (bound_of (t P))" .
 qed
 
 text \<open>This gives the equivalence with the alternative definition for
   loops\citep[\S7, p.~198, footnote 23]{McIver_M_04}.\<close>
 
 lemma wlp_Loop1:
   fixes body :: "'s prog"
   assumes unitary: "unitary P"
       and healthy: "nearly_healthy (wlp body)"
   shows "wlp (do G \<longrightarrow> body od) P =
    gfp_exp (\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wlp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s)"
   (is "?X = gfp_exp (?Y P)")
 proof -
   let "?Z u" = "(body ;; Embed u \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)"
   show ?thesis
   proof(simp only: wp_eval, intro gfp_pulldown assms le_funI)
     fix u P
     show "wlp (?Z u) P = ?Y P (u P)" by(simp add:wp_eval negate_embed)
   next
     fix t::"'s trans" and P::"'s expect"
     assume ut: "\<And>Q. unitary Q \<Longrightarrow> unitary (t Q)" and uP: "unitary P"
     thus "unitary (wlp (?Z t) P)"
       by(rule wlp_loop_step_unitary[OF healthy])
   next
     fix P Q::"'s expect"
     assume uP: "unitary P" and uQ: "unitary Q"
     show "unitary (\<lambda>a. \<guillemotleft> G \<guillemotright> a * wlp body Q a + \<guillemotleft> \<N> G \<guillemotright> a * P a)"
     proof(intro unitaryI2 nnegI bounded_byI)
       fix s::'s
       from healthy uQ
       have "unitary (wlp body Q)" by(auto)
       hence "0 \<le> wlp body Q s" by(auto)
       with uP show "0 \<le> \<guillemotleft>G\<guillemotright> s * wlp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s"
         by(auto intro!:add_nonneg_nonneg mult_nonneg_nonneg)
 
       from healthy uQ have "bounded_by 1 (wlp body Q)" by(auto)
       with uP have "\<guillemotleft>G\<guillemotright> s * wlp body Q s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<le> \<guillemotleft>G\<guillemotright> s * 1 + (1 - \<guillemotleft>G\<guillemotright> s) * 1"
         by(blast intro:add_mono mult_left_mono)
       also have "... = 1" by(simp)
       finally show "\<guillemotleft>G\<guillemotright> s * wlp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le> 1"
         by(simp add:negate_embed)
     qed
   next
     fix P Q R::"'s expect" and s::'s
     assume uP: "unitary P" and uQ: "unitary Q" and uR: "unitary R"
        and le: "Q \<tturnstile> R"
     hence "wlp body Q s \<le> wlp body R s"
       by(blast intro:le_funD[OF nearly_healthy_monoD, OF healthy])
     thus "\<guillemotleft>G\<guillemotright> s * wlp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le>
           \<guillemotleft>G\<guillemotright> s * wlp body R s + \<guillemotleft>\<N> G\<guillemotright> s * P s"
       by(auto intro:mult_left_mono)
   next
     fix t u::"'s trans"
     assume "le_utrans t u"
            "\<And>P. unitary P \<Longrightarrow> unitary (t P)"
            "\<And>P. unitary P \<Longrightarrow> unitary (u P)"
     thus "le_utrans (wlp (?Z t)) (wlp (?Z u))"
       by(blast intro!:wlp_loop_step_mono[OF healthy])
   qed
 qed
 
 lemma wp_loop_sound:
   assumes sP: "sound P"
       and hb: "healthy (wp body)"
   shows "sound (wp do G \<longrightarrow> body od P)"
 proof(simp only: wp_eval, intro lfp_trans_sound sP)
   let ?v = "\<lambda>P s. bound_of P"
   show "le_trans (wp (body ;; Embed ?v \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) ?v"
     by(intro le_transI, simp add:wp_eval lfp_loop_fp[unfolded negate_embed] hb)
   show "\<And>P. sound P \<Longrightarrow> sound (?v P)" by(auto)
 qed
 
 text \<open>Likewise, we can rewrite strict loops.\<close>
 lemma wp_Loop1:
   fixes body :: "'s prog"
   assumes sP: "sound P"
       and healthy: "healthy (wp body)"
   shows "wp (do G \<longrightarrow> body od) P =
    lfp_exp (\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s)"
   (is "?X = lfp_exp (?Y P)")
 proof -
   let "?Z u" = "(body ;; Embed u \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)"
   show ?thesis
   proof(simp only: wp_eval, intro lfp_pulldown assms le_funI sP mono_transI)
     fix u P
     show "wp (?Z u) P = ?Y P (u P)" by(simp add:wp_eval negate_embed)
   next
     fix t::"'s trans" and P::"'s expect"
     assume ut: "\<And>Q. sound Q \<Longrightarrow> sound (t Q)" and uP: "sound P"
     with healthy show "sound (wp (?Z t) P)" by(rule wp_loop_step_sound)
   next
     fix P Q::"'s expect"
     assume sP: "sound P" and sQ: "sound Q"
     show "sound (\<lambda>a. \<guillemotleft> G \<guillemotright> a * wp body Q a + \<guillemotleft> \<N> G \<guillemotright> a * P a)"
     proof(intro soundI2 nnegI bounded_byI)
       fix s::'s
       from sQ have "nneg Q" "bounded_by (bound_of Q) Q" by(auto)
       with healthy have "bounded_by (bound_of Q) (wp body Q)" by(auto)
       hence "wp body Q s \<le> bound_of Q" by(auto)
       hence "wp body Q s \<le> max (bound_of P) (bound_of Q)" by(auto)
       moreover {
         from sP have "P s \<le> bound_of P" by(auto)
         hence "P s \<le> max (bound_of P) (bound_of Q)" by(auto)
       }
       ultimately have "\<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le>
                        \<guillemotleft>G\<guillemotright> s * max (bound_of P) (bound_of Q) +
                        \<guillemotleft>\<N> G\<guillemotright> s * max (bound_of P) (bound_of Q)"
         by(auto intro!:add_mono mult_left_mono)
       also have "... = max (bound_of P) (bound_of Q)" by(simp add:algebra_simps negate_embed)
       finally show "\<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le> max (bound_of P) (bound_of Q)" .
 
       from sP have "0 \<le> P s" by(auto)
       moreover from sQ healthy have "0 \<le> wp body Q s" by(auto)
       ultimately show "0 \<le> \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s"
         by(auto intro:add_nonneg_nonneg mult_nonneg_nonneg)
     qed
   next
     fix P Q R::"'s expect" and s::'s
     assume sQ: "sound Q" and sR: "sound R"
        and le: "Q \<tturnstile> R"
     hence "wp body Q s \<le> wp body R s"
       by(blast intro:le_funD[OF mono_transD, OF healthy_monoD, OF healthy])
     thus "\<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le>
           \<guillemotleft>G\<guillemotright> s * wp body R s + \<guillemotleft>\<N> G\<guillemotright> s * P s"
       by(auto intro:mult_left_mono)
   next
     fix t u::"'s trans"
     assume le: "le_trans t u"
        and st: "\<And>P. sound P \<Longrightarrow> sound (t P)"
        and su: "\<And>P. sound P \<Longrightarrow> sound (u P)"
     with healthy show "le_trans (wp (?Z t)) (wp (?Z u))"
       by(rule wp_loop_step_mono)
   next
     from healthy show "le_trans (wp (?Z (\<lambda>P s. bound_of P))) (\<lambda>P s. bound_of P)"
       by(intro le_transI, simp add:wp_eval lfp_loop_fp[unfolded negate_embed])
   next
     fix P::"'s expect" and s::'s
     assume "sound P"
     thus "sound (\<lambda>s. bound_of P)" by(auto)
   qed
 qed
 
 lemma nearly_healthy_wlp_loop:
   fixes body::"'s prog"
   assumes hb: "nearly_healthy (wlp body)"
   shows "nearly_healthy (wlp (do G \<longrightarrow> body od))"
 proof(intro nearly_healthyI unitaryI2 nnegI2 bounded_byI2, simp_all add:wlp_Loop1 hb)
   fix P::"'s expect"
   assume uP: "unitary P"
   let "?X R" = "\<lambda>Q s. \<guillemotleft> G \<guillemotright> s * wlp body Q s + \<guillemotleft> \<N> G \<guillemotright> s * R s"
 
   show "\<lambda>s. 0 \<tturnstile> gfp_exp (?X P)"
   proof(rule gfp_exp_upperbound)
     show "unitary (\<lambda>s. 0::real)" by(auto)
     with hb have "unitary (wlp body (\<lambda>s. 0))" by(auto)
     with uP show "\<lambda>s. 0 \<tturnstile> (?X P (\<lambda>s. 0))"
       by(blast intro!:le_funI add_nonneg_nonneg mult_nonneg_nonneg)
   qed
 
   show "gfp_exp (?X P) \<tturnstile> \<lambda>s. 1"
   proof(rule gfp_exp_least)
     show "unitary (\<lambda>s. 1::real)" by(auto)
     fix Q::"'s expect"
     assume "unitary Q"
     thus "Q \<tturnstile> \<lambda>s. 1" by(auto)
   qed
 
   fix Q::"'s expect"
   assume uQ: "unitary Q" and le: "P \<tturnstile> Q"
   show "gfp_exp (?X P) \<tturnstile> gfp_exp (?X Q)"
   proof(rule gfp_exp_least)
     fix R::"'s expect" assume uR: "unitary R"
     assume fp: "R \<tturnstile> ?X P R"
     also from le have "... \<tturnstile> ?X Q R"
       by(blast intro:add_mono mult_left_mono le_funI)
     finally show "R \<tturnstile> gfp_exp (?X Q)"
       using uR by(auto intro:gfp_exp_upperbound)
   next
     show "unitary (gfp_exp (?X Q))"
     proof(rule gfp_exp_unitary, intro unitaryI2 nnegI bounded_byI)
       fix R::"'s expect" and s::'s assume uR: "unitary R"
       with hb have ubP: "unitary (wlp body R)" by(auto)
       with uQ show "0 \<le> \<guillemotleft> G \<guillemotright> s * wlp body R s + \<guillemotleft> \<N> G \<guillemotright> s * Q s"
         by(blast intro:add_nonneg_nonneg mult_nonneg_nonneg)
 
       from ubP uQ have "wlp body R s \<le> 1" "Q s \<le> 1" by(auto)
       hence "\<guillemotleft> G \<guillemotright> s * wlp body R s + \<guillemotleft> \<N> G \<guillemotright> s * Q s \<le> \<guillemotleft>G\<guillemotright> s * 1 + \<guillemotleft>\<N> G\<guillemotright> s * 1"
         by(blast intro:add_mono mult_left_mono)
       thus "\<guillemotleft> G \<guillemotright> s * wlp body R s + \<guillemotleft> \<N> G \<guillemotright> s * Q s \<le> 1"
         by(simp add:negate_embed)
     qed
   qed
 qed
 
 text \<open>We show healthiness by appealing to the properties of expectation fixed points, applied
 to the alternative loop definition.\<close>
 lemma healthy_wp_loop:
   fixes body::"'s prog"
   assumes hb: "healthy (wp body)"
   shows "healthy (wp (do G \<longrightarrow> body od))"
 proof -
   let "?X P" = "(\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s)"
   show ?thesis
   proof(intro healthy_parts bounded_byI2 nnegI2, simp_all add:wp_Loop1 hb soundI2 sound_intros)
     fix P::"'s expect" and c::real and s::'s
     assume sP: "sound P" and nnc: "0 \<le> c"
     show "c * (lfp_exp (?X P)) s = lfp_exp (?X (\<lambda>s. c * P s)) s"
     proof(cases)
       assume "c = 0" thus ?thesis
       proof(simp, intro antisym)
         from hb have fp: "\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body (\<lambda>_. 0) s \<tturnstile> \<lambda>s. 0" by(simp)
         hence "lfp_exp (\<lambda>P s. \<guillemotleft>G\<guillemotright> s * wp body P s) \<tturnstile> \<lambda>s. 0"
           by(auto intro:lfp_exp_lowerbound)
         thus "lfp_exp (\<lambda>P s. \<guillemotleft>G\<guillemotright> s * wp body P s) s \<le> 0" by(auto)
         have "\<lambda>s. 0 \<tturnstile> lfp_exp (\<lambda>P s. \<guillemotleft>G\<guillemotright> s * wp body P s)"
           by(auto intro:lfp_exp_greatest fp)
         thus "0 \<le> lfp_exp (\<lambda>P s. \<guillemotleft>G\<guillemotright> s * wp body P s) s" by(auto)
       qed
     next
       have onesided: "\<And>P c. c \<noteq> 0 \<Longrightarrow> 0 \<le> c \<Longrightarrow> sound P \<Longrightarrow>
             \<lambda>a. c * lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * P b) a \<tturnstile>
                     lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * (c * P b))"
       proof -
         fix P::"'s expect" and c::real
         assume cnz: "c \<noteq> 0" and nnc: "0 \<le> c" and sP: "sound P"
         with nnc have cpos: "0 < c" by(auto)
         hence nnic: "0 \<le> inverse c" by(auto)
         show "\<lambda>a. c * lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * P b) a \<tturnstile>
               lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * (c * P b))"
         proof(rule lfp_exp_greatest)
           fix Q::"'s expect"
           assume sQ: "sound Q"
              and fp: "\<lambda>b. \<guillemotleft>G\<guillemotright> b * wp body Q b + \<guillemotleft>\<N> G\<guillemotright> b * (c * P b) \<tturnstile> Q"
           hence "\<And>s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * (c * P s) \<le> Q s" by(auto)
           with nnic
           have "\<And>s. inverse c * (\<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * (c * P s)) \<le>
                      inverse c * Q s"
             by(auto intro:mult_left_mono)
           hence "\<And>s. \<guillemotleft>G\<guillemotright> s * (inverse c * wp body Q s) + (inverse c * c) * \<guillemotleft>\<N> G\<guillemotright> s * P s \<le>
                      inverse c * Q s"
             by(simp add:algebra_simps)
           hence "\<And>s. \<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. inverse c * Q s) s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le>
                      inverse c * Q s"
             by(simp add:cnz scalingD[OF healthy_scalingD, OF hb sQ nnic])
           hence "\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. inverse c * Q s) s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<tturnstile>
                  \<lambda>s. inverse c * Q s" by(rule le_funI)
           moreover from nnic sQ have "sound (\<lambda>s. inverse c * Q s)"
             by(iprover intro:sound_intros)
           ultimately have "lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * P b) \<tturnstile>
                            \<lambda>s. inverse c * Q s"
             by(rule lfp_exp_lowerbound)
           hence "\<And>s. lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * P b) s \<le> inverse c * Q s"
             by(rule le_funD)
           with nnc
           have "\<And>s. c * lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * P b) s \<le>
                      c * (inverse c * Q s)"
             by(auto intro:mult_left_mono)
           also from cnz have "\<And>s. ... s = Q s" by(simp)
           finally show "\<lambda>a. c * lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * P b) a \<tturnstile> Q"
             by(rule le_funI)
         next
           from sP have "sound (\<lambda>s. bound_of P)" by(auto)
           with hb sP have "sound (lfp_exp (?X P))"
             by(blast intro:lfp_exp_sound lfp_loop_fp)
           with nnc show "sound (\<lambda>s. c * lfp_exp (?X P) s)"
             by(auto intro!:sound_intros)
 
           from hb sP nnc
           show "\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. bound_of (\<lambda>s. c * P s)) s +
                     \<guillemotleft>\<N> G\<guillemotright> s * (c * P s) \<tturnstile> \<lambda>s. bound_of (\<lambda>s. c * P s)"
             by(iprover intro:lfp_loop_fp sound_intros)
 
           from sP nnc show "sound (\<lambda>s. bound_of (\<lambda>s. c * P s))"
             by(auto intro!:sound_intros)
         qed
       qed
 
       assume nzc: "c \<noteq> 0"
       show ?thesis (is "?X P c s = ?Y P c s")
       proof(rule fun_cong[where x=s], rule antisym)
         from nzc nnc sP show "?X P c \<tturnstile> ?Y P c" by(rule onesided)
 
         from nzc have nzic: "inverse c \<noteq> 0" by(auto)
         moreover with nnc have nnic: "0 \<le> inverse c" by(auto)
         moreover from nnc sP have scP: "sound (\<lambda>s. c * P s)" by(auto intro!:sound_intros)
         ultimately have "?X (\<lambda>s. c * P s) (inverse c) \<tturnstile> ?Y (\<lambda>s. c * P s) (inverse c)"
           by(rule onesided)
         with nnc have "\<lambda>s. c * ?X (\<lambda>s. c * P s) (inverse c) s \<tturnstile>
                        \<lambda>s. c * ?Y (\<lambda>s. c * P s) (inverse c) s"
           by(blast intro:mult_left_mono)
         with nzc show "?Y P c \<tturnstile> ?X P c" by(simp add:mult.assoc[symmetric])
       qed
     qed
   next
     fix P::"'s expect" and b::real
     assume bP: "bounded_by b P" and nP: "nneg P"
     show "lfp_exp (\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s) \<tturnstile> \<lambda>s. b"
     proof(intro lfp_exp_lowerbound le_funI)
       fix s::'s
       from bP nP hb have "bounded_by b (wp body (\<lambda>s. b))" by(auto)
       hence "wp body (\<lambda>s. b) s \<le> b" by(auto)
       moreover from bP have "P s \<le> b" by(auto)
       ultimately have "\<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. b) s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le> \<guillemotleft>G\<guillemotright> s * b + \<guillemotleft>\<N> G\<guillemotright> s * b"
         by(auto intro!:add_mono mult_left_mono)
       also have "... = b" by(simp add:negate_embed field_simps)
       finally show "\<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. b) s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le> b" .
       from bP nP have "0 \<le> b" by(auto)
       thus "sound (\<lambda>s. b)" by(auto)
     qed
     from hb bP nP show "\<lambda>s. 0 \<tturnstile> lfp_exp (\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s)"
       by(auto dest!:sound_nneg intro!:lfp_loop_greatest)
   next
     fix P Q::"'s expect"
     assume sP: "sound P" and sQ: "sound Q" and le: "P \<tturnstile> Q"
     show "lfp_exp (?X P) \<tturnstile> lfp_exp (?X Q)"
     proof(rule lfp_exp_greatest)
       fix R::"'s expect"
       assume sR: "sound R"
          and fp: "\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body R s + \<guillemotleft>\<N> G\<guillemotright> s * Q s \<tturnstile> R"
       from le have "\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body R s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<tturnstile>
                     \<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body R s + \<guillemotleft>\<N> G\<guillemotright> s * Q s"
         by(auto intro:le_funI add_left_mono mult_left_mono)
       also note fp
       finally show "lfp_exp (\<lambda>R s. \<guillemotleft>G\<guillemotright> s * wp body R s + \<guillemotleft>\<N> G\<guillemotright> s * P s) \<tturnstile> R"
         using sR by(auto intro:lfp_exp_lowerbound)
     next
       from hb sP show "sound (lfp_exp (\<lambda>R s. \<guillemotleft>G\<guillemotright> s * wp body R s + \<guillemotleft>\<N> G\<guillemotright> s * P s))"
         by(rule lfp_loop_sound)
       from hb sQ show "\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. bound_of Q) s +  \<guillemotleft>\<N> G\<guillemotright> s * Q s \<tturnstile> \<lambda>s. bound_of Q"
         by(rule lfp_loop_fp)
       from sQ show "sound (\<lambda>s. bound_of Q)" by(auto)
     qed
   qed
 qed
 
 text \<open>Use 'simp add:healthy\_intros' or 'blast intro:healthy\_intros' as
         appropriate to discharge healthiness side-contitions for primitive
         programs automatically.\<close>
 lemmas healthy_intros =
   healthy_wp_Abort nearly_healthy_wlp_Abort healthy_wp_Skip   nearly_healthy_wlp_Skip
   healthy_wp_Seq   nearly_healthy_wlp_Seq   healthy_wp_PC     nearly_healthy_wlp_PC
   healthy_wp_DC    nearly_healthy_wlp_DC    healthy_wp_AC     nearly_healthy_wlp_AC
   healthy_wp_Embed nearly_healthy_wlp_Embed healthy_wp_Apply  nearly_healthy_wlp_Apply
   healthy_wp_SetDC nearly_healthy_wlp_SetDC healthy_wp_SetPC  nearly_healthy_wlp_SetPC
   healthy_wp_Bind  nearly_healthy_wlp_Bind  healthy_wp_repeat nearly_healthy_wlp_repeat
   healthy_wp_loop  nearly_healthy_wlp_loop
 
 end
diff --git a/thys/pGCL/Sublinearity.thy b/thys/pGCL/Sublinearity.thy
--- a/thys/pGCL/Sublinearity.thy
+++ b/thys/pGCL/Sublinearity.thy
@@ -1,461 +1,461 @@
 (*
  * Copyright (C) 2014 NICTA
  * All rights reserved.
  *)
 
 (* Author: David Cock - David.Cock@nicta.com.au *)
 
 section \<open>Sublinearity\<close>
 
 theory Sublinearity imports Embedding Healthiness LoopInduction begin
 
 subsection \<open>Nonrecursive Primitives\<close>
 
 text \<open>Sublinearity of non-recursive programs is generally straightforward, and follows from the
 alebraic properties of the underlying operations, together with healthiness.\<close>
 
 lemma sublinear_wp_Skip:
   "sublinear (wp Skip)"
   by(auto simp:wp_eval)
 
 lemma sublinear_wp_Abort:
   "sublinear (wp Abort)"
   by(auto simp:wp_eval)
 
 lemma sublinear_wp_Apply:
   "sublinear (wp (Apply f))"
   by(auto simp:wp_eval)
 
 lemma sublinear_wp_Seq:
   fixes x::"'s prog"
   assumes slx: "sublinear (wp x)" and sly: "sublinear (wp y)"
       and hx:  "healthy (wp x)"   and hy:  "healthy (wp y)"
   shows "sublinear (wp (x ;; y))"
 proof(rule sublinearI, simp add:wp_eval)
   fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
   and a::real and b::real and c::real
   assume sP: "sound P" and sQ: "sound Q"
      and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"
 
   with slx hy have "a * wp x (wp y P) s + b * wp x (wp y Q) s \<ominus> c \<le>
                     wp x (\<lambda>s. a * wp y P s + b * wp y Q s \<ominus> c) s"
     by(blast intro:sublinearD)
   also {      
     from sP sQ nna nnb nnc sly
     have "\<And>s. a * wp y P s + b * wp y Q s \<ominus> c \<le>
               wp y (\<lambda>s. a * P s + b * Q s \<ominus> c) s"
       by(blast intro:sublinearD)
     moreover from sP sQ hy
     have "sound (wp y P)" and "sound (wp y Q)" by(auto)
     moreover with nna nnb nnc
     have "sound (\<lambda>s. a * wp y P s + b * wp y Q s \<ominus> c)"
       by(auto intro!:sound_intros tminus_sound)
     moreover from sP sQ nna nnb nnc
     have "sound (\<lambda>s. a * P s + b * Q s \<ominus> c)"
       by(auto intro!:sound_intros tminus_sound)
     moreover with hy have "sound (wp y (\<lambda>s. a * P s + b * Q s \<ominus> c))"
       by(blast)
     ultimately
     have "wp x (\<lambda>s. a * wp y P s + b * wp y Q s \<ominus> c) s \<le>
           wp x (wp y (\<lambda>s. a * P s + b * Q s \<ominus> c)) s"
       by(blast intro!:le_funD[OF mono_transD[OF healthy_monoD[OF hx]]])
   }
   finally show "a * wp x (wp y P) s + b * wp x (wp y Q) s \<ominus> c \<le>
                 wp x (wp y (\<lambda>s. a * P s + b * Q s \<ominus> c)) s" .
 qed
 
 lemma sublinear_wp_PC:
   fixes x::"'s prog"
   assumes slx: "sublinear (wp x)" and sly: "sublinear (wp y)"
       and uP: "unitary P"
   shows "sublinear (wp (x \<^bsub>P\<^esub>\<oplus> y))"
 proof(rule sublinearI, simp add:wp_eval)
   fix R::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
   and a::real and b::real and c::real
   assume sR: "sound R" and sQ: "sound Q"
      and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"
 
   have "a * (P s * wp x Q s + (1 - P s) * wp y Q s) +
         b * (P s * wp x R s + (1 - P s) * wp y R s) \<ominus> c =
         (P s * a * wp x Q s + (1 - P s) * a * wp y Q s) +
         (P s * b * wp x R s + (1 - P s) * b * wp y R s) \<ominus> c"
     by(simp add:field_simps)
   also
   have "... = (P s * a * wp x Q s + P s * b * wp x R s) +
               ((1 - P s) * a * wp y Q s + (1 - P s) * b * wp y R s) \<ominus> c"
     by(simp add:ac_simps)
   also
   have "... = P s * (a * wp x Q s + b * wp x R s) +
               (1 - P s) * (a * wp y Q s + b * wp y R s) \<ominus>
               (P s * c + (1 - P s) * c)"
     by(simp add:field_simps)
   also
   have "... \<le> (P s * (a * wp x Q s + b * wp x R s) \<ominus> P s * c) +
               ((1 - P s) * (a * wp y Q s + b * wp y R s) \<ominus> (1 - P s) * c)"
     by(rule tminus_add_mono)
   also {
       from uP have "0 \<le> P s" and "0 \<le> 1 - P s"
-        by(auto simp:sign_simps)
+        by auto
       hence "(P s * (a * wp x Q s + b * wp x R s) \<ominus> P s * c) +
              ((1 - P s) * (a * wp y Q s + b * wp y R s) \<ominus> (1 - P s) * c) =
              P s * (a * wp x Q s + b * wp x R s \<ominus> c) +
              (1 - P s) * (a * wp y Q s + b * wp y R s  \<ominus> c)"
         by(simp add:tminus_left_distrib)
   }
   also {
     from sQ sR nna nnb nnc slx
     have "a * wp x Q s + b * wp x R s \<ominus> c \<le>
           wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
       by(blast)
     moreover
     from sQ sR nna nnb nnc sly
     have "a * wp y Q s + b * wp y R s \<ominus> c \<le>
           wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
       by(blast)
     moreover
     from uP have "0 \<le> P s" and "0 \<le> 1 - P s"
-      by(auto simp:sign_simps)
+      by auto
     ultimately
     have "P s * (a * wp x Q s + b * wp x R s \<ominus> c) +
           (1 - P s) * (a * wp y Q s + b * wp y R s  \<ominus> c) \<le>
           P s * wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s +
           (1 - P s) * wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
       by(blast intro:add_mono mult_left_mono)
   }
   finally
   show " a * (P s * wp x Q s + (1 - P s) * wp y Q s) +
          b * (P s * wp x R s + (1 - P s) * wp y R s) \<ominus> c \<le>
          P s * wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s +
          (1 - P s) * wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s" .
 qed
 
 lemma sublinear_wp_DC:
   fixes x::"'s prog"
   assumes slx: "sublinear (wp x)" and sly: "sublinear (wp y)"
   shows "sublinear (wp (x \<Sqinter> y))"
 proof(rule sublinearI, simp only:wp_eval)
   fix R::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
   and a::real and b::real and c::real
   assume sR: "sound R" and sQ: "sound Q"
      and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"
 
   from nna nnb
   have "a * min (wp x Q s) (wp y Q s) +
         b * min (wp x R s) (wp y R s) \<ominus> c =
         min (a * wp x Q s) (a * wp y Q s) +
         min (b * wp x R s) (b * wp y R s) \<ominus> c"
     by(simp add:min_distrib)
   also
   have "... \<le> min (a * wp x Q s + b * wp x R s)
                   (a * wp y Q s + b * wp y R s) \<ominus> c"
     by(auto intro!:tminus_left_mono)
   also
   have "... = min (a * wp x Q s + b * wp x R s \<ominus> c)
                   (a * wp y Q s + b * wp y R s \<ominus> c)"
     by(rule min_tminus_distrib)
   also {
     from slx sQ sR nna nnb nnc
     have "a * wp x Q s + b * wp x R s \<ominus> c \<le>
           wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
       by(blast)
     moreover
     from sly sQ sR nna nnb nnc
     have "a * wp y Q s + b * wp y R s \<ominus> c \<le>
           wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
       by(blast)
     ultimately
     have "min (a * wp x Q s + b * wp x R s \<ominus> c)
               (a * wp y Q s + b * wp y R s \<ominus> c) \<le>
           min (wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s)
               (wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s)"
       by(auto)
   }
   finally show "a * min (wp x Q s) (wp y Q s) +
                 b * min (wp x R s) (wp y R s) \<ominus> c \<le>
                min (wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s)
                    (wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s)" .
 qed
 
 text \<open>As for continuity, we insist on a finite support.\<close>
 lemma sublinear_wp_SetPC:
   fixes p::"'a \<Rightarrow> 's prog"
   assumes slp: "\<And>s a. a \<in> supp (P s) \<Longrightarrow> sublinear (wp (p a))"
       and sum: "\<And>s. (\<Sum>a\<in>supp (P s). P s a) \<le> 1"
       and nnP: "\<And>s a. 0 \<le> P s a"
       and fin: "\<And>s. finite (supp (P s))"
   shows "sublinear (wp (SetPC p P))"
 proof(rule sublinearI, simp add:wp_eval)
   fix R::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
   and a::real and b::real and c::real
   assume sR: "sound R" and sQ: "sound Q"
      and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"
   have "a * (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') Q s) +
         b * (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') R s) \<ominus> c =
         (\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s)) \<ominus> c"
     by(simp add:field_simps sum_distrib_left sum.distrib)
   also have "... \<le>
              (\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s)) \<ominus>
              (\<Sum>a'\<in>supp (P s). P s a' * c)"
   proof(rule tminus_right_antimono)
     have "(\<Sum>a'\<in>supp (P s). P s a' * c) \<le> (\<Sum>a'\<in>supp (P s). P s a') * c"
       by(simp add:sum_distrib_right)
     also from sum and nnc have "... \<le> 1 * c"
       by(rule mult_right_mono)
     finally show "(\<Sum>a'\<in>supp (P s). P s a' * c) \<le> c" by(simp)
   qed
   also from fin
   have "... \<le> (\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s) \<ominus> P s a' * c)"
     by(blast intro:tminus_sum_mono)
   also have "... = (\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s \<ominus> c))"
     by(simp add:nnP tminus_left_distrib)
   also {
     from slp sQ sR nna nnb nnc
     have "\<And>a'. a' \<in> supp (P s) \<Longrightarrow> a * wp (p a') Q s + b * wp (p a') R s \<ominus> c \<le>
                                     wp (p a') (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
       by(blast)
     with nnP
     have "(\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s \<ominus> c)) \<le>
           (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') (\<lambda>s. a * Q s + b * R s \<ominus> c) s)"
       by(blast intro:sum_mono mult_left_mono)
   }
   finally
   show "a * (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') Q s) +
         b * (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') R s) \<ominus> c \<le>
         (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') (\<lambda>s. a * Q s + b * R s \<ominus> c) s)" .
 qed
 
 lemma sublinear_wp_SetDC:
   fixes p::"'a \<Rightarrow> 's prog"
   assumes slp: "\<And>s a. a \<in> S s \<Longrightarrow> sublinear (wp (p a))"
       and hp:  "\<And>s a. a \<in> S s \<Longrightarrow> healthy (wp (p a))"
       and ne:  "\<And>s. S s \<noteq> {}"
   shows "sublinear (wp (SetDC p S))"
 proof(rule sublinearI, simp add:wp_eval, rule cInf_greatest)
   fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s and x y
   and a::real and b::real and c::real
   assume sP: "sound P" and sQ: "sound Q"
      and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"
 
   from ne show "(\<lambda>pr. wp (p pr) (\<lambda>s. a * P s + b * Q s \<ominus> c) s) ` S s \<noteq> {}" by(auto)
 
   assume yin: "y \<in> (\<lambda>pr. wp (p pr) (\<lambda>s. a * P s + b * Q s \<ominus> c) s) ` S s"
   then obtain x where xin: "x \<in> S s" and rwy: "y = wp (p x) (\<lambda>s. a * P s + b * Q s \<ominus> c) s"
     by(auto)
 
   from xin hp sP nna
   have "a * Inf ((\<lambda>a. wp (p a) P s) ` S s) \<le> a * wp (p x) P s"
     by(intro mult_left_mono[OF cInf_lower] bdd_belowI[where m=0], blast+)
   moreover from xin hp sQ nnb
   have "b * Inf ((\<lambda>a. wp (p a) Q s) ` S s) \<le> b * wp (p x) Q s"
     by(intro mult_left_mono[OF cInf_lower] bdd_belowI[where m=0], blast+)
   ultimately
   have "a * Inf ((\<lambda>a. wp (p a) P s) ` S s) +
         b * Inf ((\<lambda>a. wp (p a) Q s) ` S s) \<ominus> c \<le>
         a * wp (p x) P s + b * wp (p x) Q s \<ominus> c"
     by(blast intro:tminus_left_mono add_mono)
 
   also from xin slp sP sQ nna nnb nnc
   have "... \<le> wp (p x) (\<lambda>s. a * P s + b * Q s \<ominus> c) s"
     by(blast)
 
   finally show "a * Inf ((\<lambda>a. wp (p a) P s) ` S s) + b * Inf ((\<lambda>a. wp (p a) Q s) ` S s) \<ominus> c \<le> y"
     by(simp add:rwy)
 qed
 
 lemma sublinear_wp_Embed:
   "sublinear t \<Longrightarrow> sublinear (wp (Embed t))"
   by(simp add:wp_eval)
 
 lemma sublinear_wp_repeat:
   "\<lbrakk> sublinear (wp p); healthy (wp p) \<rbrakk> \<Longrightarrow> sublinear (wp (repeat n p))"
   by(induct n, simp_all add:sublinear_wp_Seq sublinear_wp_Skip healthy_wp_repeat)
 
 lemma sublinear_wp_Bind:
   "\<lbrakk> \<And>s. sublinear (wp (a (f s))) \<rbrakk> \<Longrightarrow> sublinear (wp (Bind f a))"
   by(rule sublinearI, simp add:wp_eval, auto)
 
 subsection \<open>Sublinearity for Loops\<close>
 
 text \<open>We break the proof of sublinearity loops into separate proofs of sub-distributivity and
 sub-additivity.  The first follows by transfinite induction.\<close>
 lemma sub_distrib_wp_loop:
   fixes body::"'s prog"
   assumes sdb: "sub_distrib (wp body)"
       and hb:  "healthy (wp body)"
       and nhb: "nearly_healthy (wlp body)"
   shows "sub_distrib (wp (do G \<longrightarrow> body od))"
 proof -
   have "\<forall>P s. sound P \<longrightarrow> wp (do G \<longrightarrow> body od) P s \<ominus> 1 \<le> 
                           wp (do G \<longrightarrow> body od) (\<lambda>s. P s \<ominus> 1) s"
   proof(rule loop_induct[OF hb nhb], safe)
     fix S::"('s trans \<times> 's trans) set" and P::"'s expect" and s::'s
     assume saS: "\<forall>x\<in>S. \<forall>P s. sound P \<longrightarrow> fst x P s \<ominus> 1 \<le> fst x (\<lambda>s. P s \<ominus> 1) s"
        and sP: "sound P"
        and fS: "\<forall>x\<in>S. feasible (fst x)"
 
     from sP have sPm: "sound (\<lambda>s. P s \<ominus> 1)" by(auto intro:tminus_sound)
 
     have nnSup: "\<And>s. 0 \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s"
     proof(cases "S={}", simp add:Sup_trans_def Sup_exp_def)
       fix s
       assume "S \<noteq> {}"
       then obtain x where xin: "x\<in>S" by(auto)
       with fS sPm have "0 \<le> fst x (\<lambda>s. P s \<ominus> 1) s" by(auto)
       also from xin fS sPm have "... \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s"
         by(auto intro!: le_funD[OF Sup_trans_upper2])
       finally show "?thesis s" .
     qed
 
     have "\<And>x s. fst x P s \<le> (fst x P s \<ominus> 1) + 1" by(simp add:tminus_def)
     also from saS sP
     have "\<And>x s. x\<in>S \<Longrightarrow> (fst x P s \<ominus> 1) + 1 \<le> fst x (\<lambda>s. P s \<ominus> 1) s + 1"
       by(auto intro:add_right_mono)
     also {
       from sP have "sound (\<lambda>s. P s \<ominus> 1)" by(auto intro:tminus_sound)
       with fS have "\<And>x s. x\<in>S \<Longrightarrow> fst x (\<lambda>s. P s \<ominus> 1) s + 1 \<le>
                                    Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1"
         by(blast intro!: add_right_mono le_funD[OF Sup_trans_upper2])
     }
     finally have le: "\<And>s. \<forall>x\<in>S. fst x P s \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1"
       by(auto)
     moreover from nnSup have nn: "\<And>s. 0 \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1"
       by(auto intro:add_nonneg_nonneg)
     ultimately
     have leSup: "Sup_trans (fst ` S) P s \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1"
       unfolding Sup_trans_def
       by(intro le_funD[OF Sup_exp_least], auto)
 
     show "Sup_trans (fst ` S) P s \<ominus> 1 \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s"
     proof(cases "Sup_trans (fst ` S) P s \<le> 1", simp_all add:nnSup)
       from leSup have "Sup_trans (fst ` S) P s - 1 \<le>
                        Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1 - 1"
         by(auto)
       thus "Sup_trans (fst ` S) P s - 1 \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s" by(simp)
     qed
   next
     fix t::"'s trans" and P::"'s expect" and s::'s
     assume IH: "\<forall>P s. sound P \<longrightarrow> t P s \<ominus> 1 \<le> t (\<lambda>a. P a \<ominus> 1) s"
        and ft: "feasible t"
        and sP: "sound P"
 
      from sP have "sound (\<lambda>s. P s \<ominus> 1)" by(auto intro:tminus_sound)
      with ft have s2: "sound (t (\<lambda>s. P s \<ominus> 1))" by(auto)
      from sP ft have "sound (t P)" by(auto)
      hence s3: "sound (\<lambda>s. t P s \<ominus> 1)" by(auto intro!:tminus_sound)
 
     show "wp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P s \<ominus> 1 \<le>
           wp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) (\<lambda>a. P a \<ominus> 1) s"
     proof(simp add:wp_eval)
       have "\<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<ominus> 1 =
             \<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<ominus> (\<guillemotleft>G\<guillemotright> s + (1 - \<guillemotleft>G\<guillemotright> s))"
         by(simp)
       also have "... \<le> (\<guillemotleft>G\<guillemotright> s * wp body (t P) s \<ominus> \<guillemotleft>G\<guillemotright> s) +
                         ((1 - \<guillemotleft>G\<guillemotright> s) * P s \<ominus> (1 - \<guillemotleft>G\<guillemotright> s))"
         by(rule tminus_add_mono)
       also have "... = \<guillemotleft>G\<guillemotright> s * (wp body (t P) s \<ominus> 1) + (1 - \<guillemotleft>G\<guillemotright> s) * (P s \<ominus> 1)"
         by(simp add:tminus_left_distrib)
       also {
         from ft sP have "wp body (t P) s \<ominus> 1 \<le> wp body (\<lambda>s. t P s \<ominus> 1) s"
           by(auto intro:sub_distribD[OF sdb])
         also {
           from IH sP have "\<lambda>s. t P s \<ominus> 1 \<tturnstile> t (\<lambda>s. P s \<ominus> 1)" by(auto)
           with sP ft s2 s3 have "wp body (\<lambda>s. t P s \<ominus> 1) s \<le> wp body (t (\<lambda>s. P s \<ominus> 1)) s"
             by(blast intro:le_funD[OF mono_transD, OF healthy_monoD, OF hb])
         }
         finally have "\<guillemotleft>G\<guillemotright> s * (wp body (t P) s \<ominus> 1) + (1 - \<guillemotleft>G\<guillemotright> s) * (P s \<ominus> 1) \<le>
                       \<guillemotleft>G\<guillemotright> s * wp body (t (\<lambda>s. P s \<ominus> 1)) s + (1 - \<guillemotleft>G\<guillemotright> s) * (P s \<ominus> 1)"
           by(auto intro:add_right_mono mult_left_mono)
       }
       finally show "\<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<ominus> 1 \<le>
                     \<guillemotleft>G\<guillemotright> s * wp body (t (\<lambda>s. P s \<ominus> 1)) s + (1 - \<guillemotleft>G\<guillemotright> s) * (P s \<ominus> 1)" .
     qed
   next
     fix t t'::"'s trans" and P::"'s expect" and s::'s
     assume IH: "\<forall>P s. sound P \<longrightarrow> t P s \<ominus> 1 \<le> t (\<lambda>a. P a \<ominus> 1) s"
        and eq: "equiv_trans t t'" and sP: "sound P"
 
     from sP have "t' P s \<ominus> 1 = t P s \<ominus> 1" by(simp add:equiv_transD[OF eq])
     also from sP IH have "... \<le> t (\<lambda>s. P s \<ominus> 1) s" by(auto)
     also {
       from sP have "sound (\<lambda>s. P s \<ominus> 1)" by(simp add:tminus_sound)
       hence "t (\<lambda>s. P s \<ominus> 1) s = t' (\<lambda>s. P s \<ominus> 1) s" by(simp add:equiv_transD[OF eq])
     }
     finally show "t' P s \<ominus> 1 \<le> t' (\<lambda>s. P s \<ominus> 1) s" .
   qed
   thus ?thesis by(auto intro!:sub_distribI)
 qed
 
 text \<open>For sub-additivity, we again use the limit-of-iterates characterisation.  Firstly, all
 iterates are sublinear:\<close>
 lemma sublinear_iterates:
   assumes hb: "healthy (wp body)"
       and sb: "sublinear (wp body)"
   shows "sublinear (iterates body G i)"
   by(induct i, auto intro!:sublinear_wp_PC sublinear_wp_Seq sublinear_wp_Skip sublinear_wp_Embed
                            assms healthy_intros iterates_healthy)
 
 text \<open>From this, sub-additivity follows for the limit (i.e. the loop), by appealing to the
 property at all steps.\<close>
 lemma sub_add_wp_loop:
   fixes body::"'s prog"
   assumes sb: "sublinear (wp body)"
       and cb:  "bd_cts (wp body)"
       and hwp:  "healthy (wp body)"
   shows "sub_add (wp (do G \<longrightarrow> body od))"
 proof
   fix P Q::"'s expect" and s::'s
   assume sP: "sound P" and sQ: "sound Q"
 
   from hwp cb sP have "(\<lambda>i. iterates body G i P s) \<longlonglongrightarrow> wp do G \<longrightarrow> body od P s"
     by(rule loop_iterates)
   moreover
   from hwp cb sQ have "(\<lambda>i. iterates body G i Q s) \<longlonglongrightarrow> wp do G \<longrightarrow> body od Q s"
     by(rule loop_iterates)
   ultimately
   have "(\<lambda>i. iterates body G i P s + iterates body G i Q s) \<longlonglongrightarrow>
         wp do G \<longrightarrow> body od P s + wp do G \<longrightarrow> body od Q s"
     by(rule tendsto_add)
   moreover {
     from sublinear_subadd[OF sublinear_iterates, OF hwp sb,
                           OF healthy_feasibleD[OF iterates_healthy, OF hwp]] sP sQ
     have "\<And>i. iterates body G i P s + iterates body G i Q s \<le> iterates body G i (\<lambda>s. P s + Q s) s"
       by(rule sub_addD)
   }
   moreover {
     from sP sQ have "sound (\<lambda>s. P s + Q s)" by(blast intro:sound_intros)
     with hwp cb have "(\<lambda>i. iterates body G i (\<lambda>s. P s + Q s) s) \<longlonglongrightarrow>
                            wp do G \<longrightarrow> body od (\<lambda>s. P s + Q s) s"
       by(blast intro:loop_iterates)
   }
   ultimately
   show "wp do G \<longrightarrow> body od P s + wp do G \<longrightarrow> body od Q s \<le> wp do G \<longrightarrow> body od (\<lambda>s. P s + Q s) s"
     by(blast intro:LIMSEQ_le)  
 qed
 
 lemma sublinear_wp_loop:
   fixes body::"'s prog"
   assumes hb:  "healthy (wp body)"
       and nhb: "nearly_healthy (wlp body)"
       and sb:  "sublinear (wp body)"
       and cb:  "bd_cts (wp body)"
   shows "sublinear (wp (do G \<longrightarrow> body od))"
    using sublinear_sub_distrib[OF sb] sublinear_subadd[OF sb]
          hb healthy_feasibleD[OF hb]
    by(iprover intro:sd_sa_sublinear[OF _ _ healthy_wp_loop[OF hb]]
                     sub_distrib_wp_loop sub_add_wp_loop assms)
 
 lemmas sublinear_intros =
   sublinear_wp_Abort
   sublinear_wp_Skip
   sublinear_wp_Apply
   sublinear_wp_Seq
   sublinear_wp_PC
   sublinear_wp_DC
   sublinear_wp_SetPC
   sublinear_wp_SetDC
   sublinear_wp_Embed
   sublinear_wp_repeat
   sublinear_wp_Bind
   sublinear_wp_loop
 
 end
diff --git a/thys/pGCL/WellDefined.thy b/thys/pGCL/WellDefined.thy
--- a/thys/pGCL/WellDefined.thy
+++ b/thys/pGCL/WellDefined.thy
@@ -1,813 +1,813 @@
 (*
  * Copyright (C) 2014 NICTA
  * All rights reserved.
  *)
 
 (* Author: David Cock - David.Cock@nicta.com.au *)
 
 section \<open>Well-Defined Programs.\<close>
 
 theory WellDefined imports
   Healthiness
   Sublinearity
   LoopInduction
 begin
 
 text \<open>The definition of a well-defined program collects the various notions of healthiness and
 well-behavedness that we have so far established: healthiness of the strict and liberal
 transformers, continuity and sublinearity of the strict transformers, and two new properties.
 These are that the strict transformer always lies below the liberal one (i.e. that it is at least
 as \emph{strict}, recalling the standard embedding of a predicate), and that expectation
 conjunction is distributed between then in a particular manner, which will be crucial in
 establishing the loop rules.\<close>
 
 subsection \<open>Strict Implies Liberal\<close>
 
 text \<open>This establishes the first connection between the strict and
   liberal interpretations (@{term wp} and @{term wlp}).\<close>
 
 definition
   wp_under_wlp :: "'s prog \<Rightarrow> bool"
 where
   "wp_under_wlp prog \<equiv> \<forall>P. unitary P \<longrightarrow> wp prog P \<tturnstile> wlp prog P"
 
 lemma wp_under_wlpI[intro]:
   "\<lbrakk> \<And>P. unitary P \<Longrightarrow> wp prog P \<tturnstile> wlp prog P \<rbrakk> \<Longrightarrow> wp_under_wlp prog"
   unfolding wp_under_wlp_def by(simp)
 
 lemma wp_under_wlpD[dest]:
   "\<lbrakk> wp_under_wlp prog; unitary P \<rbrakk> \<Longrightarrow> wp prog P \<tturnstile> wlp prog P"
   unfolding wp_under_wlp_def by(simp)
 
 lemma wp_under_le_trans:
   "wp_under_wlp a \<Longrightarrow> le_utrans (wp a) (wlp a)"
   by(blast)
 
 lemma wp_under_wlp_Abort:
   "wp_under_wlp Abort"
   by(rule wp_under_wlpI, unfold wp_eval, auto)
 
 lemma wp_under_wlp_Skip:
   "wp_under_wlp Skip"
   by(rule wp_under_wlpI, unfold wp_eval, blast)
 
 lemma wp_under_wlp_Apply:
   "wp_under_wlp (Apply f)"
   by(auto simp:wp_eval)
 
 lemma wp_under_wlp_Seq:
   assumes h_wlp_a: "nearly_healthy (wlp a)"
       and h_wp_b:  "healthy (wp b)"
       and h_wlp_b: "nearly_healthy (wlp b)"
       and wp_u_a:  "wp_under_wlp a"
       and wp_u_b:  "wp_under_wlp b"
   shows "wp_under_wlp (a ;; b)"
 proof(rule wp_under_wlpI, unfold wp_eval o_def)
   fix P::"'a \<Rightarrow> real" assume uP: "unitary P"
   with h_wp_b have "unitary (wp b P)" by(blast)
   with wp_u_a have "wp a (wp b P) \<tturnstile> wlp a (wp b P)" by(auto)
   also {
     from wp_u_b and uP have "wp b P \<tturnstile> wlp b P" by(blast)
     with h_wlp_a and h_wlp_b and h_wp_b and uP
     have "wlp a (wp b P) \<tturnstile> wlp a (wlp b P)"
       by(blast intro:nearly_healthy_monoD[OF h_wlp_a])
   }
   finally show "wp a (wp b P) \<tturnstile> wlp a (wlp b P)" .
 qed
 
 lemma wp_under_wlp_PC:
   assumes h_wp_a:  "healthy (wp a)"
       and h_wlp_a: "nearly_healthy (wlp a)"
       and h_wp_b:  "healthy (wp b)"
       and h_wlp_b: "nearly_healthy (wlp b)"
       and wp_u_a:  "wp_under_wlp a"
       and wp_u_b:  "wp_under_wlp b"
       and uP:      "unitary P"
   shows "wp_under_wlp (a \<^bsub>P\<^esub>\<oplus> b)"
 proof(rule wp_under_wlpI, unfold wp_eval, rule le_funI)
   fix Q::"'a \<Rightarrow> real" and s
   assume uQ: "unitary Q"
   from uP have "P s \<le> 1" by(blast)
   hence "0 \<le> 1 - P s" by(simp)
   moreover
   from uQ and wp_u_b have "wp b Q s \<le> wlp b Q s" by(blast)
   ultimately
   have "(1 - P s) * wp b Q s \<le> (1 - P s) * wlp b Q s"
     by(blast intro:mult_left_mono)
 
   moreover {
     from uQ and wp_u_a have "wp a Q s \<le> wlp a Q s" by(blast)
     with uP have "P s * wp a Q s \<le> P s * wlp a Q s"
       by(blast intro:mult_left_mono)
   }
 
   ultimately
   show "P s * wp  a Q s + (1 - P s) * wp  b Q s \<le>
         P s * wlp a Q s + (1 - P s) * wlp b Q s"
     by(blast intro: add_mono)
 qed
 
 lemma wp_under_wlp_DC:
   assumes wp_u_a:  "wp_under_wlp a"
       and wp_u_b:  "wp_under_wlp b"
   shows "wp_under_wlp (a \<Sqinter> b)"
 proof(rule wp_under_wlpI, unfold wp_eval, rule le_funI)
   fix Q::"'a \<Rightarrow> real" and s
   assume uQ: "unitary Q"
 
   from wp_u_a uQ have "wp a Q s \<le> wlp a Q s" by(blast)
   moreover
   from wp_u_b uQ have "wp b Q s \<le> wlp b Q s" by(blast)
   ultimately
   show "min (wp a Q s) (wp b Q s) \<le> min (wlp a Q s) (wlp b Q s)"
     by(auto)
 qed
 
 lemma wp_under_wlp_SetPC:
   assumes wp_u_f:  "\<And>s a. a \<in> supp (P s) \<Longrightarrow> wp_under_wlp (f a)"
       and nP:      "\<And>s a. a \<in> supp (P s) \<Longrightarrow> 0 \<le> P s a"
   shows "wp_under_wlp (SetPC f P)"
 proof(rule wp_under_wlpI, unfold wp_eval, rule le_funI)
   fix Q::"'a \<Rightarrow> real" and s
   assume uQ: "unitary Q"
 
   from wp_u_f uQ nP
   show "(\<Sum>a\<in>supp (P s). P s a * wp (f a) Q s) \<le> (\<Sum>a\<in>supp (P s). P s a * wlp (f a) Q s)"
     by(auto intro!:sum_mono mult_left_mono)
 qed
 
 lemma wp_under_wlp_SetDC:
   assumes wp_u_f:  "\<And>s a. a \<in> S s \<Longrightarrow> wp_under_wlp (f a)"
       and hf:      "\<And>s a. a \<in> S s \<Longrightarrow> healthy (wp (f a))"
       and nS:      "\<And>s. S s \<noteq> {}"
   shows "wp_under_wlp (SetDC f S)"
 proof(rule wp_under_wlpI, rule le_funI, unfold wp_eval)
   fix Q::"'a \<Rightarrow> real" and s
   assume uQ: "unitary Q"
 
   show "Inf ((\<lambda>a. wp (f a) Q s) ` S s) \<le> Inf ((\<lambda>a. wlp (f a) Q s) ` S s)"
   proof(rule cInf_mono)
     from nS show "(\<lambda>a. wlp (f a) Q s) ` S s \<noteq> {}" by(blast)
 
     fix x assume xin: "x \<in> (\<lambda>a. wlp (f a) Q s) ` S s"
     then obtain a where ain: "a \<in> S s" and xrw: "x = wlp (f a) Q s"
       by(blast)
     with wp_u_f uQ
     have "wp (f a) Q s \<le> wlp (f a) Q s" by(blast)
     moreover from ain have "wp (f a) Q s \<in> (\<lambda>a. wp (f a) Q s) ` S s"
       by(blast)
     ultimately show "\<exists>y\<in> (\<lambda>a. wp (f a) Q s) ` S s. y \<le> x"
       by(auto simp:xrw)
 
   next
     fix y assume yin: "y \<in> (\<lambda>a. wp (f a) Q s) ` S s"
     then obtain a where ain: "a \<in> S s" and yrw: "y = wp (f a) Q s"
       by(blast)
     with hf uQ have "unitary (wp (f a) Q)" by(auto)
     with yrw show "0 \<le> y" by(auto)
   qed
 qed
 
 lemma wp_under_wlp_Embed:
   "wp_under_wlp (Embed t)"
   by(rule wp_under_wlpI, unfold wp_eval, blast)
 
 lemma wp_under_wlp_loop:
   fixes body::"'s prog"
   assumes hwp: "healthy (wp body)"
       and hwlp: "nearly_healthy (wlp body)"
       and wp_under: "wp_under_wlp body"
   shows "wp_under_wlp (do G \<longrightarrow> body od)"
 proof(rule wp_under_wlpI)
   fix P::"'s expect"
   assume uP: "unitary P" hence sP: "sound P" by(auto)
 
   let "?X Q s" = "\<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s"
   let "?Y Q s" = "\<guillemotleft>G\<guillemotright> s * wlp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s"
 
   show "wp (do G \<longrightarrow> body od) P \<tturnstile> wlp (do G \<longrightarrow> body od) P"
   proof(simp add:hwp hwlp sP uP wp_Loop1 wlp_Loop1, rule gfp_exp_upperbound)
     thm lfp_loop_fp
     from hwp sP have "lfp_exp ?X = ?X (lfp_exp ?X)"
       by(rule lfp_wp_loop_unfold)
     hence "lfp_exp ?X \<tturnstile> ?X (lfp_exp ?X)" by(simp)
     also {
       from hwp uP have "wp body (lfp_exp ?X) \<tturnstile> wlp body (lfp_exp ?X)"
         by(auto intro:wp_under_wlpD[OF wp_under] lfp_loop_unitary)
       hence "?X (lfp_exp ?X) \<tturnstile> ?Y (lfp_exp ?X)"
         by(auto intro:add_mono mult_left_mono)
     }
     finally show "lfp_exp ?X \<tturnstile> ?Y (lfp_exp ?X)" .
     from hwp uP show "unitary (lfp_exp ?X)"
       by(auto intro:lfp_loop_unitary)
   qed
 qed
 
 lemma wp_under_wlp_repeat:
   "\<lbrakk> healthy (wp a); nearly_healthy (wlp a); wp_under_wlp a \<rbrakk> \<Longrightarrow>
    wp_under_wlp (repeat n a)"
   by(induct n, auto intro!:wp_under_wlp_Skip wp_under_wlp_Seq healthy_intros)
 
 lemma wp_under_wlp_Bind:
   "\<lbrakk> \<And>s. wp_under_wlp (a (f s)) \<rbrakk> \<Longrightarrow> wp_under_wlp (Bind f a)"
   unfolding wp_under_wlp_def by(auto simp:wp_eval)
 
 lemmas wp_under_wlp_intros =
   wp_under_wlp_Abort wp_under_wlp_Skip
   wp_under_wlp_Apply wp_under_wlp_Seq
   wp_under_wlp_PC    wp_under_wlp_DC
   wp_under_wlp_SetPC wp_under_wlp_SetDC
   wp_under_wlp_Embed wp_under_wlp_loop
   wp_under_wlp_repeat wp_under_wlp_Bind
 
 subsection \<open>Sub-Distributivity of Conjunction\<close>
 
 definition
   sub_distrib_pconj :: "'s prog \<Rightarrow> bool"
 where
   "sub_distrib_pconj prog \<equiv>
    \<forall>P Q. unitary P \<longrightarrow> unitary Q \<longrightarrow>
          wlp prog P && wp prog Q \<tturnstile> wp prog (P && Q)"
 
 lemma sub_distrib_pconjI[intro]:
   "\<lbrakk>\<And>P Q. \<lbrakk> unitary P; unitary Q \<rbrakk> \<Longrightarrow>  wlp prog P && wp prog Q \<tturnstile> wp prog (P && Q) \<rbrakk> \<Longrightarrow>
     sub_distrib_pconj prog"
   unfolding sub_distrib_pconj_def by(simp)
 
 lemma sub_distrib_pconjD[dest]:
   "\<And>P Q. \<lbrakk> sub_distrib_pconj prog; unitary P; unitary Q \<rbrakk> \<Longrightarrow>
    wlp prog P && wp prog Q \<tturnstile> wp prog (P && Q)"
   unfolding sub_distrib_pconj_def by(simp)
 
 lemma sdp_Abort:
   "sub_distrib_pconj Abort"
   by(rule sub_distrib_pconjI, unfold wp_eval, auto intro:exp_conj_rzero)
 
 lemma sdp_Skip:
   "sub_distrib_pconj Skip"
   by(rule sub_distrib_pconjI, simp add:wp_eval)
 
 lemma sdp_Seq:
   fixes a and b
   assumes sdp_a:   "sub_distrib_pconj a"
       and sdp_b:   "sub_distrib_pconj b"
       and h_wp_a:  "healthy (wp a)"
       and h_wp_b:  "healthy (wp b)"
       and h_wlp_b: "nearly_healthy (wlp b)"
   shows "sub_distrib_pconj (a ;; b)"
 proof(rule sub_distrib_pconjI, unfold wp_eval o_def)
   fix P::"'a \<Rightarrow> real" and Q::"'a \<Rightarrow> real"
   assume uP: "unitary P" and uQ: "unitary Q"
 
   with h_wp_b and h_wlp_b
   have "wlp a (wlp b P) && wp a (wp b Q) \<tturnstile> wp a (wlp b P && wp b Q)"
     by(blast intro!:sub_distrib_pconjD[OF sdp_a])
   also {
     from sdp_b and uP and uQ
     have "wlp b P && wp b Q \<tturnstile> wp b (P && Q)" by(blast)
     with h_wp_a h_wp_b h_wlp_b uP uQ
     have "wp a (wlp b P && wp b Q) \<tturnstile> wp a (wp b (P && Q))"
       by(blast intro!:mono_transD[OF healthy_monoD, OF h_wp_a] unitary_sound
                       unitary_intros sound_intros)
   }
   finally show "wlp a (wlp b P) && wp a (wp b Q) \<tturnstile> wp a (wp b (P && Q))" .
 qed
 
 lemma sdp_Apply:
   "sub_distrib_pconj (Apply f)"
   by(rule sub_distrib_pconjI, simp add:wp_eval)
 
 lemma sdp_DC:
   fixes a::"'s prog" and b
   assumes sdp_a:   "sub_distrib_pconj a"
       and sdp_b:   "sub_distrib_pconj b"
       and h_wp_a:  "healthy (wp a)"
       and h_wp_b:  "healthy (wp b)"
       and h_wlp_b: "nearly_healthy (wlp b)"
   shows "sub_distrib_pconj (a \<Sqinter> b)"
 proof(rule sub_distrib_pconjI, unfold wp_eval, rule le_funI)
   fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
   assume uP: "unitary P" and uQ: "unitary Q"
 
   have "((\<lambda>s. min (wlp a P s) (wlp b P s)) &&
          (\<lambda>s. min (wp a Q s) (wp b Q s))) s \<le>
         min (wlp a P s .& wp a Q s) (wlp b P s .& wp b Q s)"
     unfolding exp_conj_def by(rule min_pconj)
   also {
     have "(\<lambda>s. wlp a P s .& wp a Q s) = wlp a P && wp a Q"
       by(simp add:exp_conj_def)
     also from sdp_a uP uQ have "... \<tturnstile> wp a (P && Q)"
       by(blast dest:sub_distrib_pconjD)
     finally have "wlp a P s .& wp a Q s \<le> wp a (P && Q) s"
       by(rule le_funD)
     moreover {
       have "(\<lambda>s. wlp b P s .& wp b Q s) = wlp b P && wp b Q"
         by(simp add:exp_conj_def)
     also from sdp_b uP uQ have "... \<tturnstile> wp b (P && Q)"
       by(blast)
     finally have "wlp b P s .& wp b Q s \<le> wp b (P && Q) s"
       by(rule le_funD)
     }
     ultimately
     have "min (wlp a P s .& wp a Q s) (wlp b P s .& wp b Q s) \<le>
           min (wp a (P && Q) s) (wp b (P && Q) s)" by(auto)
   }
   finally
   show "((\<lambda>s. min (wlp a P s) (wlp b P s)) &&
          (\<lambda>s. min (wp a Q s) (wp b Q s))) s \<le>
         min (wp a (P && Q) s) (wp b (P && Q) s)" .
 qed
 
 lemma sdp_PC:
   fixes a::"'s prog" and b
   assumes sdp_a:   "sub_distrib_pconj a"
       and sdp_b:   "sub_distrib_pconj b"
       and h_wp_a:  "healthy (wp a)"
       and h_wp_b:  "healthy (wp b)"
       and h_wlp_b: "nearly_healthy (wlp b)"
       and uP:      "unitary P"
   shows "sub_distrib_pconj (a \<^bsub>P\<^esub>\<oplus> b)"
 proof(rule sub_distrib_pconjI, unfold wp_eval, rule le_funI)
   fix Q::"'s \<Rightarrow> real" and R::"'s \<Rightarrow> real" and s::'s
   assume uQ: "unitary Q" and uR: "unitary R"
 
   have nnA: "0 \<le> P s" and nnB: "P s \<le> 1"
-    using uP by(auto simp:sign_simps)
+    using uP by auto
   note nn = nnA nnB
 
   have "((\<lambda>s. P s * wlp a Q s + (1 - P s) * wlp b Q s) &&
          (\<lambda>s. P s *  wp a R s + (1 - P s) *  wp b R s)) s =
         ((P s * wlp a Q s + (1 - P s) * wlp b Q s) +
          (P s *  wp a R s + (1 - P s) *  wp b R s)) \<ominus> 1"
     by(simp add:exp_conj_def pconj_def)
   also have "... = P s *       (wlp a Q s + wp a R s) +
                    (1 - P s) * (wlp b Q s + wp b R s) \<ominus> 1"
     by(simp add:field_simps)
   also have "... = P s *       (wlp a Q s + wp a R s) +
                    (1 - P s) * (wlp b Q s + wp b R s) \<ominus>
                    (P s + (1 - P s))"
     by(simp)
   also have "... \<le> (P s *       (wlp a Q s + wp a R s) \<ominus> P s) +
                    ((1 - P s) * (wlp b Q s + wp b R s) \<ominus> (1 - P s))"
     by(rule tminus_add_mono)
   also have "... = (P s       * (wlp a Q s + wp a R s \<ominus> 1)) +
                    ((1 - P s) * (wlp b Q s + wp b R s \<ominus> 1))"
     by(simp add:nn tminus_left_distrib)
   also have "... = P s *       ((wlp a Q && wp a R) s) +
                    (1 - P s) * ((wlp b Q && wp b R) s)"
     by(simp add:exp_conj_def pconj_def)
   also {
     from sdp_a sdp_b uQ uR
     have "P s * (wlp a Q && wp a R) s \<le> P s * wp a (Q && R) s"
      and "(1 - P s) * (wlp b Q && wp b R) s \<le> (1 - P s) * wp b (Q && R) s"
        by (simp_all add: entailsD mult_left_mono nn sub_distrib_pconjD)
     hence "P s *       ((wlp a Q && wp a R) s) +
            (1 - P s) * ((wlp b Q && wp b R) s) \<le>
            P s * wp a (Q && R) s + (1 - P s) * wp b (Q && R) s"
       by(auto)
   }
   finally show "((\<lambda>s. P s * wlp a Q s + (1 - P s) * wlp b Q s) &&
                  (\<lambda>s. P s *  wp a R s + (1 - P s) *  wp b R s)) s \<le>
                 P s * wp a (Q && R) s + (1 - P s) * wp b (Q && R) s" .
 qed
 
 lemma sdp_Embed:
   "\<lbrakk> \<And>P Q. \<lbrakk> unitary P; unitary Q \<rbrakk> \<Longrightarrow> t P && t Q \<tturnstile> t (P && Q) \<rbrakk> \<Longrightarrow>
    sub_distrib_pconj (Embed t)"
   by(auto simp:wp_eval)
 
 lemma sdp_repeat:
   fixes a::"'s prog"
   assumes sdpa: "sub_distrib_pconj a"
       and hwp: "healthy (wp a)" and hwlp: "nearly_healthy (wlp a)"
   shows "sub_distrib_pconj (repeat n a)" (is "?X n")
 proof(induct n)
   show "?X 0" by(simp add:sdp_Skip)
   fix n assume IH: "?X n"
   show "?X (Suc n)"
   proof(rule sub_distrib_pconjI, simp add:wp_eval)
     fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real"
     assume uP: "unitary P" and uQ: "unitary Q"
     from assms have hwlpa: "nearly_healthy (wlp (repeat n a))"
                 and hwpa:  "healthy (wp (repeat n a))"
       by(auto intro:healthy_intros)
     from uP and hwlpa have "unitary (wlp (repeat n a) P)" by(blast)
     moreover from uQ and hwpa have "unitary (wp (repeat n a) Q)" by(blast)
     ultimately
     have "wlp a (wlp (repeat n a) P) && wp a (wp (repeat n a) Q) \<tturnstile>
           wp a (wlp (repeat n a) P && wp (repeat n a) Q)"
       using sdpa by(blast)
     also {
       from hwlp have "nearly_healthy (wlp (repeat n a))" by(rule healthy_intros)
       with uP have "sound (wlp (repeat n a) P)" by(auto)
       moreover from hwp uQ have "sound (wp (repeat n a) Q)"
         by(auto intro:healthy_intros)
       ultimately have "sound (wlp (repeat n a) P && wp (repeat n a) Q)"
         by(rule exp_conj_sound)
       moreover {
         from uP uQ have "sound (P && Q)" by(auto intro:exp_conj_sound)
         with hwp have "sound (wp (repeat n a) (P && Q))"
           by(auto intro:healthy_intros)
       }
       moreover from uP uQ IH
       have "wlp (repeat n a) P && wp (repeat n a) Q \<tturnstile> wp (repeat n a) (P && Q)"
         by(blast)
       ultimately
       have "wp a (wlp (repeat n a) P && wp (repeat n a) Q) \<tturnstile>
             wp a (wp (repeat n a) (P && Q))"
         by(rule mono_transD[OF healthy_monoD, OF hwp])
     }
     finally show "wlp a (wlp (repeat n a) P) && wp a (wp (repeat n a) Q) \<tturnstile>
                   wp a (wp (repeat n a) (P && Q))" .
   qed
 qed
 
 lemma sdp_SetPC:
   fixes p::"'a \<Rightarrow> 's prog"
   assumes sdp: "\<And>s a. a \<in> supp (P s) \<Longrightarrow> sub_distrib_pconj (p a)"
       and fin: "\<And>s. finite (supp (P s))"
       and nnp: "\<And>s a. 0 \<le> P s a"
       and sub: "\<And>s. sum (P s) (supp (P s)) \<le> 1"
   shows "sub_distrib_pconj (SetPC p P)"
 proof(rule sub_distrib_pconjI, simp add:wp_eval, rule le_funI)
   fix Q::"'s \<Rightarrow> real" and R::"'s \<Rightarrow> real" and s::'s
   assume uQ: "unitary Q" and uR: "unitary R"
   have "((\<lambda>s. \<Sum>a\<in>supp (P s). P s a * wlp (p a) Q s) &&
          (\<lambda>s. \<Sum>a\<in>supp (P s). P s a *  wp (p a) R s)) s =
         (\<Sum>a\<in>supp (P s). P s a * wlp (p a) Q s) + (\<Sum>a\<in>supp (P s). P s a * wp (p a) R s) \<ominus> 1"
     by(simp add:exp_conj_def pconj_def)
   also have "... = (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q s + wp (p a) R s)) \<ominus> 1"
     by(simp add: sum.distrib field_simps)
   also from sub
   have "... \<le> (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q s + wp (p a) R s)) \<ominus>
               (\<Sum>a\<in>supp (P s). P s a)"
     by(rule tminus_right_antimono)
   also from fin
   have "... \<le> (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q s + wp (p a) R s) \<ominus> P s a)"
     by(rule tminus_sum_mono)
   also from nnp
   have "... = (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q s + wp (p a) R s \<ominus> 1))"
     by(simp add:tminus_left_distrib)
   also have "... = (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q && wp (p a) R) s)"
     by(simp add:pconj_def exp_conj_def)
   also {
     from sdp uQ uR
     have "\<And>a. a \<in> supp (P s) \<Longrightarrow> wlp (p a) Q && wp (p a) R \<tturnstile> wp (p a) (Q && R)"
       by(blast intro:sub_distrib_pconjD)
     with nnp
     have "(\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q && wp (p a) R) s) \<le>
           (\<Sum>a\<in>supp (P s). P s a * (wp (p a) (Q && R)) s)"
       by(blast intro:sum_mono mult_left_mono)
   }
   finally show "((\<lambda>s. \<Sum>a\<in>supp (P s). P s a * wlp (p a) Q s) &&
                  (\<lambda>s. \<Sum>a\<in>supp (P s). P s a * wp (p a) R s)) s \<le>
                 (\<Sum>a\<in>supp (P s). P s a * wp (p a) (Q && R) s)" .
 qed
 
 lemma sdp_SetDC:
   fixes p::"'a \<Rightarrow> 's prog"
   assumes sdp: "\<And>s a. a \<in> S s \<Longrightarrow> sub_distrib_pconj (p a)"
       and hwp: "\<And>s a. a \<in> S s \<Longrightarrow> healthy (wp (p a))"
       and hwlp: "\<And>s a. a \<in> S s \<Longrightarrow> nearly_healthy (wlp (p a))"
       and ne:  "\<And>s. S s \<noteq> {}"
   shows "sub_distrib_pconj (SetDC p S)"
 proof(rule sub_distrib_pconjI, rule le_funI)
   fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
   assume uP: "unitary P" and uQ: "unitary Q"
 
   from uP hwlp
   have "\<And>x. x \<in> (\<lambda>a. wlp (p a) P) ` S s \<Longrightarrow> unitary x" by(auto)
   hence "\<And>y. y \<in> (\<lambda>a. wlp (p a) P s) ` S s \<Longrightarrow> 0 \<le> y" by(auto)
   hence "\<And>a. a \<in> S s \<Longrightarrow> wlp (SetDC p S) P s \<le> wlp (p a) P s"
     unfolding wp_eval by(intro cInf_lower bdd_belowI, auto)
   moreover {
     from uQ hwp have "\<And>a. a \<in> S s \<Longrightarrow>  0 \<le> wp (p a) Q s" by(blast)
     hence "\<And>a. a \<in> S s \<Longrightarrow> wp (SetDC p S) Q s \<le> wp (p a) Q s"
     unfolding wp_eval by(intro cInf_lower bdd_belowI, auto)
   }
   ultimately
   have "\<And>a. a \<in> S s \<Longrightarrow> wlp (SetDC p S) P s + wp (SetDC p S) Q s \<ominus> 1 \<le>
                       wlp (p a) P s + wp (p a) Q s \<ominus> 1"
     by(auto intro:tminus_left_mono add_mono)
   also have "\<And>a. wlp (p a) P s + wp (p a) Q s \<ominus> 1 = (wlp (p a) P && wp (p a) Q) s"
     by(simp add:exp_conj_def pconj_def)
   also from sdp uP uQ
   have "\<And>a. a \<in> S s \<Longrightarrow> ... a \<le> wp (p a) (P && Q) s"
     by(blast)
   also have "\<And>a. ... a = wp (p a) (\<lambda>s. P s + Q s \<ominus> 1) s"
     by(simp add:exp_conj_def pconj_def)
   finally
   show "(wlp (SetDC p S) P && wp (SetDC p S) Q) s \<le> wp (SetDC p S) (P && Q) s"
     unfolding exp_conj_def pconj_def wp_eval
     using ne by(blast intro!:cInf_greatest)
 qed
 
 lemma sdp_Bind:
   "\<lbrakk> \<And>s. sub_distrib_pconj (p (f s)) \<rbrakk> \<Longrightarrow> sub_distrib_pconj (Bind f p)"
   unfolding sub_distrib_pconj_def wp_eval exp_conj_def pconj_def
   by(blast)
 
 text \<open>For loops, we again appeal to our transfinite induction principle, this time taking
 advantage of the simultaneous treatment of both strict and liberal transformers.\<close>
 lemma sdp_loop:
   fixes body::"'s prog"
   assumes sdp_body: "sub_distrib_pconj body"
       and hwlp: "nearly_healthy (wlp body)"
       and hwp:  "healthy (wp body)"
   shows "sub_distrib_pconj (do G \<longrightarrow> body od)"
 proof(rule sub_distrib_pconjI, rule loop_induct[OF hwp hwlp])
   fix P Q::"'s expect" and S::"('s trans \<times> 's trans) set"
   assume uP: "unitary P" and uQ: "unitary Q"
      and ffst: "\<forall>x\<in>S. feasible (fst x)"
      and usnd: "\<forall>x\<in>S. \<forall>Q. unitary Q \<longrightarrow> unitary (snd x Q)"
      and IH: "\<forall>x\<in>S. snd x P && fst x Q \<tturnstile> fst x (P && Q)"
 
   show "Inf_utrans (snd ` S) P && Sup_trans (fst ` S) Q \<tturnstile>
                   Sup_trans (fst ` S) (P && Q)"
   proof(cases)
     assume "S = {}"
     thus ?thesis
       by(simp add:Inf_trans_def Sup_trans_def Inf_utrans_def
                   Inf_exp_def Sup_exp_def exp_conj_def)
   next
     assume ne: "S \<noteq> {}"
 
     let "?f s" = "1 + Sup_trans (fst ` S) (P && Q) s - Inf_utrans (snd ` S) P s"
 
     from ne obtain t where tin: "t \<in> fst ` S" by(auto)
     from ne obtain u where uin: "u \<in> snd ` S" by(auto)
 
     from tin ffst uP uQ have utPQ: "unitary (t (P && Q))"
       by(auto intro:exp_conj_unitary)
     hence "\<And>s. 0 \<le> t (P && Q) s" by(auto)
     also {
       from ffst tin have le: "le_utrans t (Sup_trans (fst ` S))"
         by(auto intro:Sup_trans_upper)
       with uP uQ have "\<And>s. t (P && Q) s \<le> Sup_trans (fst ` S) (P && Q) s"
         by(auto intro:exp_conj_unitary)
     }
     finally have nn_rhs: "\<And>s. 0 \<le> Sup_trans (fst ` S) (P && Q) s" .
 
     have "\<And>R. Inf_utrans (snd ` S) P && R \<tturnstile> Sup_trans (fst ` S) (P && Q) \<Longrightarrow> R \<le> ?f"
     proof(rule contrapos_pp, assumption)
       fix R
       assume "\<not> R \<le> ?f"
       then obtain s where "\<not> R s \<le> ?f s" by(auto)
       hence gt: "?f s < R s" by(simp)
 
       from nn_rhs have g1: "1 \<le> 1 + Sup_trans (fst ` S) (P && Q) s" by(auto)
       hence "Sup_trans (fst ` S) (P && Q) s = Inf_utrans (snd ` S) P s .& ?f s"
         by(simp add:pconj_def)
       also from g1 have "... = Inf_utrans (snd ` S) P s + ?f s - 1"
         by(simp)
       also from gt have "... < Inf_utrans (snd ` S) P s + R s - 1"
         by(simp)
       also {
         with g1 have "1 \<le> Inf_utrans (snd ` S) P s + R s"
           by(simp)
         hence "Inf_utrans (snd ` S) P s + R s - 1 = Inf_utrans (snd ` S) P s .& R s"
           by(simp add:pconj_def)
       }
       finally
       have "\<not> (Inf_utrans (snd ` S) P && R) s \<le> Sup_trans (fst ` S) (P && Q) s"
         by(simp add:exp_conj_def)
       thus "\<not> Inf_utrans (snd ` S) P && R \<tturnstile> Sup_trans (fst ` S) (P && Q)"
         by(auto)
     qed
 
     moreover have "\<forall>t\<in>fst ` S. Inf_utrans (snd ` S) P && t Q  \<tturnstile> Sup_trans (fst ` S) (P && Q)"
     proof
       fix t assume tin: "t \<in> fst ` S"
       then obtain x where xin: "x \<in> S" and fx: "t = fst x" by(auto)
 
       from xin have "snd x \<in> snd ` S" by(auto)
       with uP usnd have "Inf_utrans (snd ` S) P \<tturnstile> snd x P"
         by(auto intro:le_utransD[OF Inf_utrans_lower])
       hence "Inf_utrans (snd ` S) P && fst x Q \<tturnstile> snd x P && fst x Q"
         by(auto intro:entails_frame)
       also from xin IH have "... \<tturnstile> fst x (P && Q)"
         by(auto)
       also from xin ffst exp_conj_unitary[OF uP uQ]
       have "... \<tturnstile> Sup_trans (fst ` S) (P && Q)"
         by(auto intro:le_utransD[OF Sup_trans_upper])
       finally show "Inf_utrans (snd ` S) P && t Q \<tturnstile> Sup_trans (fst ` S) (P && Q)"
         by(simp add:fx)
     qed
     ultimately have bt: "\<forall>t\<in>fst ` S. t Q \<tturnstile> ?f" by(blast)
 
     have "Sup_trans (fst ` S) Q = Sup_exp {t Q |t. t \<in> fst ` S}"
       by(simp add:Sup_trans_def)
     also have "... \<tturnstile> ?f"
     proof(rule Sup_exp_least)
       from bt show " \<forall>R\<in>{t Q |t. t \<in> fst ` S}. R \<tturnstile> ?f" by(blast)
       from ne obtain t where tin: "t \<in> fst ` S" by(auto)
       with ffst uQ have "unitary (t Q)" by(auto)
       hence "\<lambda>s. 0 \<tturnstile> t Q" by(auto)
       also from tin bt have "... \<tturnstile> ?f" by(auto)
       finally show "nneg (\<lambda>s. 1 + Sup_trans (fst ` S) (P && Q) s -
                           Inf_utrans (snd ` S) P s)"
         by(auto)
     qed
     finally have "Inf_utrans (snd ` S) P && Sup_trans (fst ` S) Q \<tturnstile>
                   Inf_utrans (snd ` S) P && ?f"
       by(auto intro:entails_frame)
     also from nn_rhs have "... \<tturnstile> Sup_trans (fst ` S) (P && Q)"
       by(simp add:exp_conj_def pconj_def)
     finally show ?thesis .
   qed
 
 next
   fix P Q::"'s expect" and t u::"'s trans"
   assume uP: "unitary P" and uQ: "unitary Q"
      and ft: "feasible t"
      and uu: "\<And>Q. unitary Q \<Longrightarrow> unitary (u Q)"
      and IH: "u P && t Q \<tturnstile> t (P && Q)"
   show "wlp (body ;; Embed u \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P &&
         wp  (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) Q \<tturnstile>
         wp  (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) (P && Q)"
   proof(rule le_funI, simp add:wp_eval exp_conj_def pconj_def)
     fix s::'s
     have "\<guillemotleft> G \<guillemotright> s * wlp body (u P) s + (1 - \<guillemotleft> G \<guillemotright> s) * P s +
           (\<guillemotleft> G \<guillemotright> s * wp body (t Q) s + (1 - \<guillemotleft> G \<guillemotright> s) * Q s) \<ominus> 1 =
           (\<guillemotleft> G \<guillemotright> s * wlp body (u P) s + \<guillemotleft> G \<guillemotright> s * wp body (t Q) s) +
            ((1 - \<guillemotleft> G \<guillemotright> s) * P s + (1 - \<guillemotleft> G \<guillemotright> s) * Q s) \<ominus> (\<guillemotleft>G\<guillemotright> s + (1 - \<guillemotleft>G\<guillemotright> s))"
       by(simp add:ac_simps)
     also have "... \<le>
           (\<guillemotleft> G \<guillemotright> s * wlp body (u P) s + \<guillemotleft> G \<guillemotright> s * wp body (t Q) s \<ominus> \<guillemotleft>G\<guillemotright> s) +
            ((1 - \<guillemotleft> G \<guillemotright> s) * P s + (1 - \<guillemotleft> G \<guillemotright> s) * Q s \<ominus> (1 - \<guillemotleft>G\<guillemotright> s))"
       by(rule tminus_add_mono)
     also have "... =
           \<guillemotleft> G \<guillemotright> s * (wlp body (u P) s + wp body (t Q) s \<ominus> 1) +
            (1 - \<guillemotleft> G \<guillemotright> s) * (P s + Q s \<ominus> 1)"
        by(simp add:tminus_left_distrib distrib_left)
     also {
       from uP uQ ft uu
       have "wlp body (u P) && wp body (t Q) \<tturnstile> wp body (u P && t Q)"
         by(auto intro:sub_distrib_pconjD[OF sdp_body])
       also from IH unitary_sound[OF uP] unitary_sound[OF uQ] ft
                    unitary_sound[OF uu[OF uP]]
       have "\<dots> \<le> wp body (t (P && Q))"
         by(blast intro!:mono_transD[OF healthy_monoD, OF hwp] exp_conj_sound)
       finally have "wlp body (u P) s + wp body (t Q) s \<ominus> 1 \<le>
                     wp body (t (\<lambda>s. P s + Q s \<ominus> 1)) s"
         by(auto simp:exp_conj_def pconj_def)
       hence "\<guillemotleft> G \<guillemotright> s * (wlp body (u P) s + wp body (t Q) s \<ominus> 1) +
              (1 - \<guillemotleft> G \<guillemotright> s) * (P s + Q s \<ominus> 1) \<le>
              \<guillemotleft> G \<guillemotright> s * wp body (t (\<lambda>s. P s + Q s \<ominus> 1)) s +
              (1 - \<guillemotleft> G \<guillemotright> s) * (P s + Q s \<ominus> 1)"
         by(auto intro:add_right_mono mult_left_mono)
     }
     finally
     show "\<guillemotleft> G \<guillemotright> s * wlp body (u P) s + (1 - \<guillemotleft> G \<guillemotright> s) * P s +
           (\<guillemotleft> G \<guillemotright> s * wp body (t Q) s + (1 - \<guillemotleft> G \<guillemotright> s) * Q s) \<ominus> 1 \<le>
           \<guillemotleft> G \<guillemotright> s * wp body (t (\<lambda>s. P s + Q s \<ominus> 1)) s +
           (1 - \<guillemotleft> G \<guillemotright> s) * (P s + Q s \<ominus> 1)" .
   qed
 next
   fix P Q::"'s expect" and t t' u u'::"'s trans"
   assume "unitary P" "unitary Q"
          "equiv_trans t t'" "equiv_utrans u u'"
          "u P && t Q \<tturnstile> t (P && Q)"
   thus "u' P && t' Q \<tturnstile> t' (P && Q)"
     by(simp add:equiv_transD unitary_sound equiv_utransD exp_conj_unitary)
 qed
 
 lemmas sdp_intros =
   sdp_Abort  sdp_Skip  sdp_Apply
   sdp_Seq    sdp_DC    sdp_PC
   sdp_SetPC  sdp_SetDC sdp_Embed
   sdp_repeat sdp_Bind  sdp_loop
 
 subsection \<open>The Well-Defined Predicate.\<close>
 
 definition
   well_def :: "'s prog \<Rightarrow> bool"
 where
   "well_def prog \<equiv> healthy (wp prog) \<and> nearly_healthy (wlp prog)
                  \<and> wp_under_wlp prog \<and> sub_distrib_pconj prog
                  \<and> sublinear (wp prog) \<and> bd_cts (wp prog)"
 
 lemma well_defI[intro]:
   "\<lbrakk> healthy (wp prog); nearly_healthy (wlp prog);
      wp_under_wlp prog; sub_distrib_pconj prog; sublinear (wp prog);
      bd_cts (wp prog) \<rbrakk> \<Longrightarrow>
    well_def prog"
   unfolding well_def_def by(simp)
 
 lemma well_def_wp_healthy[dest]:
   "well_def prog \<Longrightarrow> healthy (wp prog)"
   unfolding well_def_def by(simp)
 
 lemma well_def_wlp_nearly_healthy[dest]:
   "well_def prog \<Longrightarrow> nearly_healthy (wlp prog)"
   unfolding well_def_def by(simp)
 
 lemma well_def_wp_under[dest]:
   "well_def prog \<Longrightarrow> wp_under_wlp prog"
   unfolding well_def_def by(simp)
 
 lemma well_def_sdp[dest]:
   "well_def prog \<Longrightarrow> sub_distrib_pconj prog"
   unfolding well_def_def by(simp)
 
 lemma well_def_wp_sublinear[dest]:
   "well_def prog \<Longrightarrow> sublinear (wp prog)"
   unfolding well_def_def by(simp)
 
 lemma well_def_wp_cts[dest]:
   "well_def prog \<Longrightarrow> bd_cts (wp prog)"
   unfolding well_def_def by(simp)
 
 lemmas wd_dests =
   well_def_wp_healthy well_def_wlp_nearly_healthy
   well_def_wp_under well_def_sdp
   well_def_wp_sublinear well_def_wp_cts
 
 lemma wd_Abort:
   "well_def Abort"
   by(blast intro:healthy_wp_Abort nearly_healthy_wlp_Abort
                  wp_under_wlp_Abort sdp_Abort sublinear_wp_Abort
                  cts_wp_Abort)
 
 lemma wd_Skip:
   "well_def Skip"
   by(blast intro:healthy_wp_Skip nearly_healthy_wlp_Skip
                  wp_under_wlp_Skip sdp_Skip sublinear_wp_Skip
                  cts_wp_Skip)
 
 lemma wd_Apply:
   "well_def (Apply f)"
   by(blast intro:healthy_wp_Apply nearly_healthy_wlp_Apply
                  wp_under_wlp_Apply sdp_Apply sublinear_wp_Apply
                  cts_wp_Apply)
 
 lemma wd_Seq:
   "\<lbrakk> well_def a; well_def b \<rbrakk> \<Longrightarrow> well_def (a ;; b)"
   by(blast intro:healthy_wp_Seq nearly_healthy_wlp_Seq
                  wp_under_wlp_Seq sdp_Seq sublinear_wp_Seq
                  cts_wp_Seq)
 
 lemma wd_PC:
   "\<lbrakk> well_def a; well_def b; unitary P \<rbrakk> \<Longrightarrow> well_def (a \<^bsub>P\<^esub>\<oplus> b)"
   by(blast intro:healthy_wp_PC nearly_healthy_wlp_PC
                  wp_under_wlp_PC sdp_PC sublinear_wp_PC
                  cts_wp_PC)
 
 lemma wd_DC:
   "\<lbrakk> well_def a; well_def b \<rbrakk> \<Longrightarrow> well_def (a \<Sqinter> b)"
   by(blast intro:healthy_wp_DC nearly_healthy_wlp_DC
                  wp_under_wlp_DC sdp_DC sublinear_wp_DC
                  cts_wp_DC)
 
 lemma wd_SetDC:
   "\<lbrakk> \<And>x s. x \<in> S s \<Longrightarrow> well_def (a x); \<And>s. S s \<noteq> {};
      \<And>s. finite (S s) \<rbrakk> \<Longrightarrow> well_def (SetDC a S)"
 by (simp add: cts_wp_SetDC ex_in_conv healthy_intros(17) healthy_intros(18) sdp_intros(8) sublinear_intros(8) well_def_def wp_under_wlp_intros(8))
 
 
 lemma wd_SetPC:
   "\<lbrakk> \<And>x s. x \<in> (supp (p s)) \<Longrightarrow> well_def (a x); \<And>s. unitary (p s); \<And>s. finite (supp (p s));
      \<And>s. sum (p s) (supp (p s)) \<le> 1 \<rbrakk> \<Longrightarrow> well_def (SetPC a p)"
   by(iprover intro!:well_defI healthy_wp_SetPC nearly_healthy_wlp_SetPC
                     wp_under_wlp_SetPC sdp_SetPC sublinear_wp_SetPC cts_wp_SetPC
              dest:wd_dests unitary_sound sound_nneg[OF unitary_sound] nnegD)
 
 lemma wd_Embed:
   fixes t::"'s trans"
   assumes ht: "healthy t" and st: "sublinear t" and ct: "bd_cts t"
   shows "well_def (Embed t)"
 proof(intro well_defI)
   from ht show "healthy (wp (Embed t))" "nearly_healthy (wlp (Embed t))"
     by(simp add:wp_def wlp_def Embed_def healthy_nearly_healthy)+
   from st show "sublinear (wp (Embed t))" by(simp add:wp_def Embed_def)
   show "wp_under_wlp (Embed t)" by(simp add:wp_under_wlp_def wp_eval)
   show "sub_distrib_pconj (Embed t)"
     by(rule sub_distrib_pconjI,
        auto intro:le_funI[OF sublinearD[OF st, where a=1 and b=1 and c=1, simplified]]
             simp:exp_conj_def pconj_def wp_def wlp_def Embed_def)
   from ct show "bd_cts (wp (Embed t))"
     by(simp add:wp_def Embed_def)
 qed
 
 lemma wd_repeat:
   "well_def a \<Longrightarrow> well_def (repeat n a)"
   by(blast intro:healthy_wp_repeat nearly_healthy_wlp_repeat
                  wp_under_wlp_repeat sdp_repeat sublinear_wp_repeat cts_wp_repeat)
 
 lemma wd_Bind:
   "\<lbrakk> \<And>s. well_def (a (f s)) \<rbrakk> \<Longrightarrow> well_def (Bind f a)"
   by(blast intro:healthy_wp_Bind nearly_healthy_wlp_Bind
                  wp_under_wlp_Bind sdp_Bind sublinear_wp_Bind cts_wp_Bind)
 
 lemma wd_loop:
   "well_def body \<Longrightarrow> well_def (do G \<longrightarrow> body od)"
   by(blast intro:healthy_wp_loop nearly_healthy_wlp_loop
                  wp_under_wlp_loop sdp_loop sublinear_wp_loop cts_wp_loop)
 
 lemmas wd_intros =
   wd_Abort wd_Skip   wd_Apply
   wd_Embed wd_Seq    wd_PC
   wd_DC    wd_SetPC  wd_SetDC
   wd_Bind  wd_repeat wd_loop
 
 end