diff --git a/thys/Algebraic_Numbers/Complex_Algebraic_Numbers.thy b/thys/Algebraic_Numbers/Complex_Algebraic_Numbers.thy
--- a/thys/Algebraic_Numbers/Complex_Algebraic_Numbers.thy
+++ b/thys/Algebraic_Numbers/Complex_Algebraic_Numbers.thy
@@ -1,1130 +1,1130 @@
 (*  
     Author:      Sebastiaan Joosten 
                  René Thiemann
                  Akihisa Yamada
     License:     BSD
 *)
 section \<open>Complex Algebraic Numbers\<close>
 
 text \<open>Since currently there is no immediate analog of Sturm's theorem for the complex numbers,
   we implement complex algebraic numbers via their real and imaginary part.
   
   The major algorithm in this theory is a factorization algorithm which factors a rational
   polynomial over the complex numbers. 
 
   This algorithm is then combined with explicit root algorithms to try to factor arbitrary  
   complex polymials.\<close>
 
 theory Complex_Algebraic_Numbers
 imports 
   Real_Roots
   Complex_Roots_Real_Poly
   Compare_Complex
   Jordan_Normal_Form.Char_Poly  
   Berlekamp_Zassenhaus.Code_Abort_Gcd
   Interval_Arithmetic
 begin
 
 subsection \<open>Complex Roots\<close>
   
 abbreviation complex_of_int_poly :: "int poly \<Rightarrow> complex poly" where
   "complex_of_int_poly \<equiv> map_poly of_int"
 
 abbreviation complex_of_rat_poly :: "rat poly \<Rightarrow> complex poly" where
   "complex_of_rat_poly \<equiv> map_poly of_rat"
 
 lemma poly_complex_to_real: "(poly (complex_of_int_poly p) (complex_of_real x) = 0)
   = (poly (real_of_int_poly p) x = 0)"
 proof -
   have id: "of_int = complex_of_real o real_of_int" by auto
   interpret cr: semiring_hom complex_of_real by (unfold_locales, auto)
   show ?thesis unfolding id
     by (subst map_poly_map_poly[symmetric], force+)
 qed
 
 lemma represents_cnj: assumes "p represents x" shows "p represents (cnj x)"
 proof -
   from assms have p: "p \<noteq> 0" and "ipoly p x = 0" by auto
   hence rt: "poly (complex_of_int_poly p) x = 0" by auto
   have "poly (complex_of_int_poly p) (cnj x) = 0"
     by (rule complex_conjugate_root[OF _ rt], subst coeffs_map_poly, auto)
   with p show ?thesis by auto
 qed
 
 definition poly_2i :: "int poly" where
   "poly_2i \<equiv> [: 4, 0, 1:]"
   
 lemma represents_2i: "poly_2i represents (2 * \<i>)"
   unfolding represents_def poly_2i_def by simp
 
 definition root_poly_Re :: "int poly \<Rightarrow> int poly" where
   "root_poly_Re p = cf_pos_poly (poly_mult_rat (inverse 2) (poly_add p p))"
   
 lemma root_poly_Re_code[code]: 
   "root_poly_Re p = (let fs = coeffs (poly_add p p); k = length fs 
      in cf_pos_poly (poly_of_list (map (\<lambda>(fi, i). fi * 2 ^ i) (zip fs [0..<k]))))"
 proof -
   have [simp]: "quotient_of (1 / 2) = (1,2)" by eval
   show ?thesis unfolding root_poly_Re_def poly_mult_rat_def poly_mult_rat_main_def Let_def by simp
 qed
   
 definition root_poly_Im :: "int poly \<Rightarrow> int poly list" where
   "root_poly_Im p = (let fs = factors_of_int_poly 
     (poly_add p (poly_uminus p))
     in remdups ((if (\<exists> f \<in> set fs. coeff f 0 = 0) then [[:0,1:]] else [])) @ 
       [ cf_pos_poly (poly_div f poly_2i) . f \<leftarrow> fs, coeff f 0 \<noteq> 0])"
                           
 lemma represents_root_poly:
   assumes "ipoly p x = 0" and p: "p \<noteq> 0"
   shows "(root_poly_Re p) represents (Re x)"
     and "\<exists> q \<in> set (root_poly_Im p). q represents (Im x)"
 proof -
   let ?Rep = "root_poly_Re p"
   let ?Imp = "root_poly_Im p"
   from assms have ap: "p represents x" by auto
   from represents_cnj[OF this] have apc: "p represents (cnj x)" .
   from represents_mult_rat[OF _ represents_add[OF ap apc], of "inverse 2"]
   have "?Rep represents (1 / 2 * (x + cnj x))" unfolding root_poly_Re_def Let_def
     by (auto simp: hom_distribs)
   also have "1 / 2 * (x + cnj x) = of_real (Re x)"
     by (simp add: complex_add_cnj)
   finally have Rep: "?Rep \<noteq> 0" and rt: "ipoly ?Rep (complex_of_real (Re x)) = 0" unfolding represents_def by auto
   from rt[unfolded poly_complex_to_real]
   have "ipoly ?Rep (Re x) = 0" .
   with Rep show "?Rep represents (Re x)" by auto 
   let ?q = "poly_add p (poly_uminus p)"
   from represents_add[OF ap, of "poly_uminus p" "- cnj x"] represents_uminus[OF apc] 
   have apq: "?q represents (x - cnj x)" by auto
   from factors_int_poly_represents[OF this] obtain pi where pi: "pi \<in> set (factors_of_int_poly ?q)"
     and appi: "pi represents (x - cnj x)" and irr_pi: "irreducible pi" by auto
   have id: "inverse (2 * \<i>) * (x - cnj x) = of_real (Im x)"
     apply (cases x) by (simp add: complex_split imaginary_unit.ctr legacy_Complex_simps)
   from represents_2i have 12: "poly_2i represents (2 * \<i>)" by simp
   have "\<exists> qi \<in> set ?Imp. qi represents (inverse (2 * \<i>) * (x - cnj x))" 
   proof (cases "x - cnj x = 0")
     case False 
     have "poly poly_2i 0 \<noteq> 0" unfolding poly_2i_def by auto
     from represents_div[OF appi 12 this]
       represents_irr_non_0[OF irr_pi appi False, unfolded poly_0_coeff_0] pi
     show ?thesis unfolding root_poly_Im_def Let_def by (auto intro: bexI[of _ "cf_pos_poly (poly_div pi poly_2i)"])
   next
     case True
     hence id2: "Im x = 0" by (simp add: complex_eq_iff)
     from appi[unfolded True represents_def] have "coeff pi 0 = 0" by (cases pi, auto)
     with pi have mem: "[:0,1:] \<in> set ?Imp" unfolding root_poly_Im_def Let_def by auto
     have "[:0,1:] represents (complex_of_real (Im x))" unfolding id2 represents_def by simp
     with mem show ?thesis unfolding id by auto
   qed
   then obtain qi where qi: "qi \<in> set ?Imp" "qi \<noteq> 0" and rt: "ipoly qi (complex_of_real (Im x)) = 0"
     unfolding id represents_def by auto
   from qi rt[unfolded poly_complex_to_real]
   show "\<exists> qi \<in> set ?Imp. qi represents (Im x)" by auto 
 qed
   
 text \<open>Determine complex roots of a polynomial, 
    intended for polynomials of degree 3 or higher,
    for lower degree polynomials use @{const roots1} or @{const croots2}\<close>
 
 hide_const (open) eq
 
 primrec remdups_gen :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "remdups_gen eq [] = []"
 | "remdups_gen eq (x # xs) = (if (\<exists> y \<in> set xs. eq x y) then 
      remdups_gen eq xs else x # remdups_gen eq xs)"
 
   
 lemma real_of_3_remdups_equal_3[simp]: "real_of_3 ` set (remdups_gen equal_3 xs) = real_of_3 ` set xs" 
   by (induct xs, auto simp: equal_3)
   
 lemma distinct_remdups_equal_3: "distinct (map real_of_3 (remdups_gen equal_3 xs))"
   by (induct xs, auto, auto simp: equal_3)
   
 lemma real_of_3_code [code]: "real_of_3 x = real_of (Real_Alg_Quotient x)" 
   by (transfer, auto)
     
 definition "real_parts_3 p = roots_of_3 (root_poly_Re p)" 
   
 definition "pos_imaginary_parts_3 p = 
   remdups_gen equal_3 (filter (\<lambda> x. sgn_3 x = 1) (concat (map roots_of_3 (root_poly_Im p))))" 
 
 lemma real_parts_3: assumes p: "p \<noteq> 0" and "ipoly p x = 0" 
   shows "Re x \<in> real_of_3 ` set (real_parts_3 p)" 
   unfolding real_parts_3_def using represents_root_poly(1)[OF assms(2,1)]
     roots_of_3(1) unfolding represents_def by auto
     
 lemma distinct_real_parts_3: "distinct (map real_of_3 (real_parts_3 p))" 
   unfolding real_parts_3_def using roots_of_3(2) .
 
 lemma pos_imaginary_parts_3: assumes p: "p \<noteq> 0" and "ipoly p x = 0" and "Im x > 0" 
   shows "Im x \<in> real_of_3 ` set (pos_imaginary_parts_3 p)" 
 proof -
   from represents_root_poly(2)[OF assms(2,1)] obtain q where 
     q: "q \<in> set (root_poly_Im p)" "q represents Im x" by auto
   from roots_of_3(1)[of q] have "Im x \<in> real_of_3 ` set (roots_of_3 q)" using q
     unfolding represents_def by auto
   then obtain i3 where i3: "i3 \<in> set (roots_of_3 q)" and id: "Im x = real_of_3 i3" by auto
   from \<open>Im x > 0\<close> have "sgn (Im x) = 1" by simp
   hence sgn: "sgn_3 i3 = 1" unfolding id by (metis of_rat_eq_1_iff sgn_3)
   show ?thesis unfolding pos_imaginary_parts_3_def real_of_3_remdups_equal_3 id
     using sgn i3 q(1) by auto
 qed
   
 lemma distinct_pos_imaginary_parts_3: "distinct (map real_of_3 (pos_imaginary_parts_3 p))" 
   unfolding pos_imaginary_parts_3_def by (rule distinct_remdups_equal_3)
 
 lemma remdups_gen_subset: "set (remdups_gen eq xs) \<subseteq> set xs" 
   by (induct xs, auto)
     
 lemma positive_pos_imaginary_parts_3: assumes "x \<in> set (pos_imaginary_parts_3 p)"
   shows "0 < real_of_3 x" 
 proof -
   from subsetD[OF remdups_gen_subset assms[unfolded pos_imaginary_parts_3_def]]
   have "sgn_3 x = 1" by auto
   thus ?thesis using sgn_3[of x] by (simp add: sgn_1_pos)
 qed
     
 definition "pair_to_complex ri \<equiv> case ri of (r,i) \<Rightarrow> Complex (real_of_3 r) (real_of_3 i)" 
   
 fun get_itvl_2 :: "real_alg_2 \<Rightarrow> real interval" where
   "get_itvl_2 (Irrational n (p,l,r)) = Interval (of_rat l) (of_rat r)" 
 | "get_itvl_2 (Rational r) = (let rr = of_rat r in Interval rr rr)" 
 
 lemma get_bounds_2: assumes "invariant_2 x"
   shows "real_of_2 x \<in>\<^sub>i get_itvl_2 x" 
 proof (cases x)
   case (Irrational n plr)
   with assms obtain p l r where plr: "plr = (p,l,r)" by (cases plr, auto)
   from assms Irrational plr have inv1: "invariant_1 (p,l,r)" 
     and id: "real_of_2 x = real_of_1 (p,l,r)" by auto
   show ?thesis unfolding id using invariant_1D(1)[OF inv1] by (auto simp: plr Irrational)
 qed (insert assms, auto simp: Let_def)
 
 lift_definition get_itvl_3 :: "real_alg_3 \<Rightarrow> real interval" is get_itvl_2 .
 
 lemma get_itvl_3: "real_of_3 x \<in>\<^sub>i get_itvl_3 x" 
   by (transfer, insert get_bounds_2, auto)
 
 fun tighten_bounds_2 :: "real_alg_2 \<Rightarrow> real_alg_2" where
   "tighten_bounds_2 (Irrational n (p,l,r)) = (case tighten_poly_bounds p l r (sgn (ipoly p r))
     of (l',r',_) \<Rightarrow> Irrational n (p,l',r'))" 
 | "tighten_bounds_2 (Rational r) = Rational r" 
 
 lemma tighten_bounds_2: assumes inv: "invariant_2 x" 
   shows "real_of_2 (tighten_bounds_2 x) = real_of_2 x" "invariant_2 (tighten_bounds_2 x)" 
   "get_itvl_2 x = Interval l r \<Longrightarrow>
    get_itvl_2 (tighten_bounds_2 x) = Interval l' r' \<Longrightarrow> r' - l' = (r-l) / 2" 
 proof (atomize(full), cases x)
   case (Irrational n plr)
   show "real_of_2 (tighten_bounds_2 x) = real_of_2 x \<and>
        invariant_2 (tighten_bounds_2 x) \<and>
        (get_itvl_2 x = Interval l r \<longrightarrow>
         get_itvl_2 (tighten_bounds_2 x) = Interval l' r' \<longrightarrow> r' - l' = (r - l) / 2)"
   proof -
     obtain p l r where plr: "plr = (p,l,r)" by (cases plr, auto)
     let ?tb = "tighten_poly_bounds p l r (sgn (ipoly p r))" 
     obtain l' r' sr' where tb: "?tb = (l',r',sr')" by (cases ?tb, auto)
     have id: "tighten_bounds_2 x = Irrational n (p,l',r')" unfolding Irrational plr
       using tb by auto
     from inv[unfolded Irrational plr] have inv: "invariant_1_2 (p, l, r)"
       "n = card {y. y \<le> real_of_1 (p, l, r) \<and> ipoly p y = 0}" by auto
     have rof: "real_of_2 x = real_of_1 (p, l, r)" 
       "real_of_2 (tighten_bounds_2 x) = real_of_1 (p, l', r')" using Irrational plr id by auto
     from inv have inv1: "invariant_1 (p, l, r)" and "poly_cond2 p" by auto
     hence rc: "\<exists>!x. root_cond (p, l, r) x" "poly_cond2 p" by auto
     note tb' = tighten_poly_bounds[OF tb rc refl]    
     have eq: "real_of_1 (p, l, r) = real_of_1 (p, l', r')" using tb' inv1
       using invariant_1_sub_interval(2) by presburger
     from inv1 tb' have "invariant_1 (p, l', r')" by (metis invariant_1_sub_interval(1))
     hence inv2: "invariant_2 (tighten_bounds_2 x)" unfolding id using inv eq by auto
     thus ?thesis unfolding rof eq unfolding id unfolding Irrational plr 
       using tb'(1-4) arg_cong[OF tb'(5), of real_of_rat] by (auto simp: hom_distribs)
   qed
 qed (auto simp: Let_def)
 
 lift_definition tighten_bounds_3 :: "real_alg_3 \<Rightarrow> real_alg_3" is tighten_bounds_2
   using tighten_bounds_2 by auto
     
 lemma tighten_bounds_3:  
   "real_of_3 (tighten_bounds_3 x) = real_of_3 x"  
   "get_itvl_3 x = Interval l r \<Longrightarrow>
    get_itvl_3 (tighten_bounds_3 x) = Interval l' r' \<Longrightarrow> r' - l' = (r-l) / 2" 
   by (transfer, insert tighten_bounds_2, auto)+
     
 partial_function (tailrec) filter_list_length 
   :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   [code]: "filter_list_length f p n xs = (let ys = filter p xs 
      in if length ys = n then ys else
      filter_list_length f p n (map f ys))"
 
 lemma filter_list_length: assumes "length (filter P xs) = n"
   and "\<And> i x. x \<in> set xs \<Longrightarrow> P x \<Longrightarrow> p ((f ^^ i) x)" 
   and "\<And> x. x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> \<exists> i. \<not> p ((f ^^ i) x)" 
   and g: "\<And> x. g (f x) = g x"
   and P: "\<And> x. P (f x) = P x" 
 shows "map g (filter_list_length f p n xs) = map g (filter P xs)" 
 proof -
   from assms(3) have "\<forall> x. \<exists> i. x \<in> set xs \<longrightarrow> \<not> P x \<longrightarrow> \<not> p ((f ^^ i) x)" 
     by auto
   from choice[OF this] obtain i where i: "\<And> x. x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> \<not> p ((f ^^ (i x)) x)"  
     by auto
   define m where "m = max_list (map i xs)" 
   have m: "\<And> x. x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> \<exists> i \<le> m. \<not> p ((f ^^ i) x)"
     using max_list[of _ "map i xs", folded m_def] i by auto
   show ?thesis using assms(1-2) m
   proof (induct m arbitrary: xs rule: less_induct)
     case (less m xs)
     define ys where "ys = filter p xs"       
     have xs_ys: "filter P xs = filter P ys" unfolding ys_def filter_filter
       by (rule filter_cong[OF refl], insert less(3)[of _ 0], auto)    
     have "filter (P \<circ> f) ys = filter P ys" using P unfolding o_def by auto
     hence id3: "filter P (map f ys) = map f (filter P ys)" unfolding filter_map by simp      
     hence id2: "map g (filter P (map f ys)) = map g (filter P ys)" by (simp add: g)
     show ?case 
     proof (cases "length ys = n")
       case True
       hence id: "filter_list_length f p n xs = ys" unfolding ys_def 
         filter_list_length.simps[of _ _ _ xs] Let_def by auto 
       show ?thesis using True unfolding id xs_ys using less(2)
         by (metis filter_id_conv length_filter_less less_le xs_ys) 
     next
       case False
       {
         assume "m = 0" 
         from less(4)[unfolded this] have Pp: "x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> \<not> p x" for x by auto
         with xs_ys False[folded less(2)] have False
           by (metis (mono_tags, lifting) filter_True mem_Collect_eq set_filter ys_def)
       } note m0 = this
       then obtain M where mM: "m = Suc M" by (cases m, auto)
       hence m: "M < m" by simp
       from False have id: "filter_list_length f p n xs = filter_list_length f p n (map f ys)" 
         unfolding ys_def filter_list_length.simps[of _ _ _ xs] Let_def by auto
       show ?thesis unfolding id xs_ys id2[symmetric]
       proof (rule less(1)[OF m])
         fix y
         assume "y \<in> set (map f ys)" 
         then obtain x where x: "x \<in> set xs" "p x" and y: "y = f x" unfolding ys_def by auto
         {
           assume "\<not> P y"
           hence "\<not> P x" unfolding y P .
           from less(4)[OF x(1) this] obtain i where i: "i \<le> m" and p: "\<not> p ((f ^^ i) x)" by auto
           with x obtain j where ij: "i = Suc j" by (cases i, auto)
           with i have j: "j \<le> M" unfolding mM by auto
           have "\<not> p ((f ^^ j) y)" using p unfolding ij y funpow_Suc_right by simp
           thus "\<exists>i\<le> M. \<not> p ((f ^^ i) y)" using j by auto
         }
         {
           fix i
           assume "P y" 
           hence "P x" unfolding y P .
           from less(3)[OF x(1) this, of "Suc i"]
           show "p ((f ^^ i) y)" unfolding y funpow_Suc_right by simp
         }
       next
         show "length (filter P (map f ys)) = n" unfolding id3 length_map using xs_ys less(2) by auto
       qed
     qed
   qed
 qed
 
 
 definition complex_roots_of_int_poly3 :: "int poly \<Rightarrow> complex list" where
   "complex_roots_of_int_poly3 p \<equiv> let n = degree p; 
     rrts = real_roots_of_int_poly p;
     nr = length rrts; 
     crts = map (\<lambda> r. Complex r 0) rrts
     in 
     if n = nr then crts 
     else let nr_crts = n - nr in if nr_crts = 2 then 
     let pp = real_of_int_poly p div (prod_list (map (\<lambda> x. [:-x,1:]) rrts));
         cpp = map_poly (\<lambda> r. Complex r 0) pp
       in crts @ croots2 cpp else
     let
         nr_pos_crts = nr_crts div 2;
         rxs = real_parts_3 p;
         ixs = pos_imaginary_parts_3 p;
         rts = [(rx, ix). rx <- rxs, ix <- ixs];
         crts' = map pair_to_complex 
            (filter_list_length (map_prod tighten_bounds_3 tighten_bounds_3) 
               (\<lambda> (r, i). 0 \<in>\<^sub>c ipoly_complex_interval p (Complex_Interval (get_itvl_3 r) (get_itvl_3 i))) nr_pos_crts rts)
     in crts @ (concat (map (\<lambda> x. [x, cnj x]) crts'))"
 
 definition complex_roots_of_int_poly_all :: "int poly \<Rightarrow> complex list" where
   "complex_roots_of_int_poly_all p = (let n = degree p in 
     if n \<ge> 3 then complex_roots_of_int_poly3 p
     else if n = 1 then [roots1 (map_poly of_int p)] else if n = 2 then croots2 (map_poly of_int p)
     else [])"
 
 lemma in_real_itvl_get_bounds_tighten: "real_of_3 x \<in>\<^sub>i get_itvl_3 ((tighten_bounds_3 ^^ n) x)" 
 proof (induct n arbitrary: x)
   case 0
   thus ?case using get_itvl_3[of x] by simp
 next
   case (Suc n x)
   have id: "(tighten_bounds_3 ^^ (Suc n)) x = (tighten_bounds_3 ^^ n) (tighten_bounds_3 x)"
     by (metis comp_apply funpow_Suc_right)
   show ?case unfolding id tighten_bounds_3(1)[of x, symmetric] by (rule Suc)
 qed
 
 
 lemma sandwitch_real:
  fixes l r :: "nat \<Rightarrow> real"
  assumes la: "l \<longlonglongrightarrow> a" and ra: "r \<longlonglongrightarrow> a"
  and lm: "\<And>i. l i \<le> m i" and mr: "\<And>i. m i \<le> r i"
 shows "m \<longlonglongrightarrow> a"
 proof (rule LIMSEQ_I)
   fix e :: real
   assume "0 < e"
   hence e: "0 < e / 2" by simp  
   from LIMSEQ_D[OF la e] obtain n1 where n1: "\<And> n. n \<ge> n1 \<Longrightarrow> norm (l n - a) < e/2" by auto
   from LIMSEQ_D[OF ra e] obtain n2 where n2: "\<And> n. n \<ge> n2 \<Longrightarrow> norm (r n - a) < e/2" by auto
   show "\<exists>no. \<forall>n\<ge>no. norm (m n - a) < e"
   proof (rule exI[of _ "max n1 n2"], intro allI impI)  
     fix n
     assume "max n1 n2 \<le> n"     
     with n1 n2 have *: "norm (l n - a) < e/2" "norm (r n - a) < e/2" by auto
     from lm[of n] mr[of n] have "norm (m n - a) \<le> norm (l n - a) + norm (r n - a)" by simp
     with * show "norm (m n - a) < e" by auto
   qed
 qed
 
 lemma real_of_tighten_bounds_many[simp]: "real_of_3 ((tighten_bounds_3 ^^ i) x) = real_of_3 x"
   apply (induct i) using tighten_bounds_3 by auto
 
 definition lower_3 where "lower_3 x i \<equiv> interval.lower (get_itvl_3 ((tighten_bounds_3 ^^ i) x))"
 definition upper_3 where "upper_3 x i \<equiv> interval.upper (get_itvl_3 ((tighten_bounds_3 ^^ i) x))"
 
 lemma interval_size_3: "upper_3 x i - lower_3 x i = (upper_3 x 0 - lower_3 x 0)/2^i"
 proof (induct i)
   case (Suc i)
   have "upper_3 x (Suc i) - lower_3 x (Suc i) = (upper_3 x i - lower_3 x i) / 2"
      unfolding upper_3_def lower_3_def using tighten_bounds_3 get_itvl_3 by auto
   with Suc show ?case by auto
 qed auto
 
 lemma interval_size_3_tendsto_0: "(\<lambda>i. (upper_3 x i - lower_3 x i)) \<longlonglongrightarrow> 0"
   by (subst interval_size_3, auto intro: LIMSEQ_divide_realpow_zero)
 
 lemma dist_tendsto_0_imp_tendsto: "(\<lambda>i. \<bar>f i - a\<bar> :: real) \<longlonglongrightarrow> 0 \<Longrightarrow> f \<longlonglongrightarrow> a"
   using LIM_zero_cancel tendsto_rabs_zero_iff by blast
 
 lemma upper_3_tendsto: "upper_3 x \<longlonglongrightarrow> real_of_3 x"
 proof(rule dist_tendsto_0_imp_tendsto, rule sandwitch_real)
   fix i
   obtain l r where lr: "get_itvl_3 ((tighten_bounds_3 ^^ i) x) = Interval l r"
     by (metis interval.collapse)
   with get_itvl_3[of "(tighten_bounds_3 ^^ i) x"]
   show "\<bar>(upper_3 x) i - real_of_3 x\<bar> \<le> (upper_3 x i - lower_3 x i)"
     unfolding upper_3_def lower_3_def by auto
 qed (insert interval_size_3_tendsto_0, auto)
 
 lemma lower_3_tendsto: "lower_3 x \<longlonglongrightarrow> real_of_3 x"
 proof(rule dist_tendsto_0_imp_tendsto, rule sandwitch_real)
   fix i
   obtain l r where lr: "get_itvl_3 ((tighten_bounds_3 ^^ i) x) = Interval l r"
     by (metis interval.collapse)
   with get_itvl_3[of "(tighten_bounds_3 ^^ i) x"]
   show "\<bar>lower_3 x i - real_of_3 x\<bar> \<le> (upper_3 x i - lower_3 x i)"
     unfolding upper_3_def lower_3_def by auto
 qed (insert interval_size_3_tendsto_0, auto)
 
 lemma tends_to_tight_bounds_3: "(\<lambda>x. get_itvl_3 ((tighten_bounds_3 ^^ x) y)) \<longlonglongrightarrow>\<^sub>i real_of_3 y" 
   using lower_3_tendsto[of y] upper_3_tendsto[of y] unfolding lower_3_def upper_3_def
     interval_tendsto_def o_def by auto
     
 lemma complex_roots_of_int_poly3: assumes p: "p \<noteq> 0" and sf: "square_free p" 
   shows "set (complex_roots_of_int_poly3 p) = {x. ipoly p x = 0}" (is "?l = ?r")
     "distinct (complex_roots_of_int_poly3 p)" 
 proof -
   interpret map_poly_inj_idom_hom of_real..
   define q where "q = real_of_int_poly p"
   let ?q = "map_poly complex_of_real q"
   from p have q0: "q \<noteq> 0" unfolding q_def by auto
   hence q: "?q \<noteq> 0" by auto
   define rr where "rr = real_roots_of_int_poly p"
   define rrts where "rrts = map (\<lambda>r. Complex r 0) rr"
   note d = complex_roots_of_int_poly3_def[of p, unfolded Let_def, folded rr_def, folded rrts_def]
   have rr: "set rr = {x. ipoly p x = 0}" unfolding rr_def
     using real_roots_of_int_poly(1)[OF p] .
   have rrts: "set rrts = {x. poly ?q x = 0 \<and> x \<in> \<real>}" unfolding rrts_def set_map rr q_def
     complex_of_real_def[symmetric] by (auto elim: Reals_cases)
   have dist: "distinct rr" unfolding rr_def using real_roots_of_int_poly(2) .
   from dist have dist1: "distinct rrts" unfolding rrts_def distinct_map inj_on_def by auto
   have lrr: "length rr = card {x. poly (real_of_int_poly p) x = 0}"
     unfolding rr_def using real_roots_of_int_poly[of p] p distinct_card by fastforce
   have cr: "length rr = card {x. poly ?q x = 0 \<and> x \<in> \<real>}" unfolding lrr q_def[symmetric]
   proof -
     have "card {x. poly q x = 0} \<le> card {x. poly (map_poly complex_of_real q) x = 0 \<and> x \<in> \<real>}" (is "?l \<le> ?r")
       by (rule card_inj_on_le[of of_real], insert poly_roots_finite[OF q], auto simp: inj_on_def)
     moreover have "?l \<ge> ?r"
       by (rule card_inj_on_le[of Re, OF _ _ poly_roots_finite[OF q0]], auto simp: inj_on_def elim!: Reals_cases)
     ultimately show "?l = ?r" by simp
   qed 
   have conv: "\<And> x. ipoly p x = 0 \<longleftrightarrow> poly ?q x = 0"
     unfolding q_def by (subst map_poly_map_poly, auto simp: o_def)
   have r: "?r = {x. poly ?q x = 0}" unfolding conv ..
   have "?l = {x. ipoly p x = 0} \<and> distinct (complex_roots_of_int_poly3 p)" 
   proof (cases "degree p = length rr")
     case False note oFalse = this
     show ?thesis
     proof (cases "degree p - length rr = 2")
       case False
       let ?nr = "(degree p - length rr) div 2" 
       define cpxI where "cpxI = pos_imaginary_parts_3 p" 
       define cpxR where "cpxR = real_parts_3 p" 
       let ?rts = "[(rx,ix). rx <- cpxR, ix <- cpxI]" 
       define cpx where "cpx = map pair_to_complex (filter (\<lambda> c. ipoly p (pair_to_complex c) = 0) 
          ?rts)"
       let ?LL = "cpx @ map cnj cpx" 
       let ?LL' = "concat (map (\<lambda> x. [x,cnj x]) cpx)" 
       let ?ll = "rrts @ ?LL" 
       let ?ll' = "rrts @ ?LL'" 
       have cpx: "set cpx \<subseteq> ?r" unfolding cpx_def by auto
       have ccpx: "cnj ` set cpx \<subseteq> ?r" using cpx unfolding r 
         by (auto intro!: complex_conjugate_root[of ?q] simp: Reals_def) 
       have "set ?ll \<subseteq> ?r" using rrts cpx ccpx unfolding r by auto
       moreover
       {
         fix x :: complex
         assume rt: "ipoly p x = 0"
         {
           fix x 
           assume rt: "ipoly p x = 0"
             and gt: "Im x > 0"
           define rx where "rx = Re x"
           let ?x = "Complex rx (Im x)"
           have x: "x = ?x" by (cases x, auto simp: rx_def)
           from rt x have rt': "ipoly p ?x = 0" by auto
           from real_parts_3[OF p rt, folded rx_def] pos_imaginary_parts_3[OF p rt gt] rt'
           have "?x \<in> set cpx" unfolding cpx_def cpxI_def cpxR_def 
             by (force simp: pair_to_complex_def[abs_def])
           hence "x \<in> set cpx" using x by simp
         } note gt = this
         have cases: "Im x = 0 \<or> Im x > 0 \<or> Im x < 0" by auto
         from rt have rt': "ipoly p (cnj x) = 0" unfolding conv 
           by (intro complex_conjugate_root[of ?q x], auto simp: Reals_def)
         {
           assume "Im x > 0"
           from gt[OF rt this] have "x \<in> set ?ll" by auto
         }
         moreover
         {
           assume "Im x < 0"
           hence "Im (cnj x) > 0" by simp
           from gt[OF rt' this] have "cnj (cnj x) \<in> set ?ll" unfolding set_append set_map by blast
           hence "x \<in> set ?ll" by simp
         }
         moreover
         {
           assume "Im x = 0"
           hence "x \<in> \<real>" using complex_is_Real_iff by blast
           with rt rrts have "x \<in> set ?ll" unfolding conv by auto
         }
         ultimately have "x \<in> set ?ll" using cases by blast
       }
       ultimately have lr: "set ?ll = {x. ipoly p x = 0}" by blast 
       let ?rr = "map real_of_3 cpxR" 
       let ?pi = "map real_of_3 cpxI" 
       have dist2: "distinct ?rr" unfolding cpxR_def by (rule distinct_real_parts_3)
       have dist3: "distinct ?pi" unfolding cpxI_def by (rule distinct_pos_imaginary_parts_3)
       have idd: "concat (map (map pair_to_complex) (map (\<lambda>rx. map (Pair rx) cpxI) cpxR))
         = concat (map (\<lambda>r. map (\<lambda> i. Complex (real_of_3 r) (real_of_3 i)) cpxI) cpxR)" 
         unfolding pair_to_complex_def by (auto simp: o_def)
       have dist4: "distinct cpx" unfolding cpx_def 
       proof (rule distinct_map_filter, unfold map_concat idd, unfold distinct_conv_nth, intro allI impI, goal_cases) 
         case (1 i j)
         from nth_concat_diff[OF 1, unfolded length_map] dist2[unfolded distinct_conv_nth]
          dist3[unfolded distinct_conv_nth] show ?case by auto
       qed
       have dist5: "distinct (map cnj cpx)" using dist4 unfolding distinct_map by (auto simp: inj_on_def)
       {
         fix x :: complex
         have rrts: "x \<in> set rrts \<Longrightarrow> Im x = 0" unfolding rrts_def by auto
         have cpx: "\<And> x. x \<in> set cpx \<Longrightarrow> Im x > 0" unfolding cpx_def cpxI_def
           by (auto simp: pair_to_complex_def[abs_def] positive_pos_imaginary_parts_3)
         have cpx': "x \<in> cnj ` set cpx \<Longrightarrow> sgn (Im x) = -1" using cpx by auto
         have "x \<notin> set rrts \<inter> set cpx \<union> set rrts \<inter> cnj ` set cpx \<union> set cpx \<inter> cnj ` set cpx" 
           using rrts cpx[of x] cpx' by auto
       } note dist6 = this
       have dist: "distinct ?ll" 
         unfolding distinct_append using dist6 by (auto simp: dist1 dist4 dist5)
       let ?p = "complex_of_int_poly p" 
       have pp: "?p \<noteq> 0" using p by auto
       from p square_free_of_int_poly[OF sf] square_free_rsquarefree
       have rsf:"rsquarefree ?p" by auto
       from dist lr have "length ?ll = card {x. poly ?p x = 0}"
         by (metis distinct_card)
       also have "\<dots> = degree p" 
         using rsf unfolding rsquarefree_card_degree[OF pp] by simp
       finally have deg_len: "degree p = length ?ll" by simp
       let ?P = "\<lambda> c.  ipoly p (pair_to_complex c) = 0" 
       let ?itvl = "\<lambda> r i. ipoly_complex_interval p (Complex_Interval (get_itvl_3 r) (get_itvl_3 i))" 
       let ?itv = "\<lambda> (r,i). ?itvl r i" 
       let ?p = "(\<lambda> (r,i). 0 \<in>\<^sub>c (?itvl r i))" 
       let ?tb = tighten_bounds_3  
       let ?f = "map_prod ?tb ?tb" 
       have filter: "map pair_to_complex (filter_list_length ?f ?p ?nr ?rts) = map pair_to_complex (filter ?P ?rts)" 
       proof (rule filter_list_length)
         have "length (filter ?P ?rts) = length cpx" 
           unfolding cpx_def by simp
         also have "\<dots> = ?nr" unfolding deg_len by (simp add: rrts_def)
         finally show "length (filter ?P ?rts) = ?nr" by auto
       next
         fix n x
         assume x: "?P x" 
         obtain r i where xri: "x = (r,i)" by force
         have id: "(?f ^^ n) x = ((?tb ^^ n) r, (?tb ^^ n) i)" unfolding xri
           by (induct n, auto)
         have px: "pair_to_complex x = Complex (real_of_3 r) (real_of_3 i)" 
           unfolding xri pair_to_complex_def by auto
         show "?p ((?f ^^ n) x)"
           unfolding id split 
           by (rule ipoly_complex_interval[of "pair_to_complex x" _ p, unfolded x], unfold px,
             auto simp: in_complex_interval_def in_real_itvl_get_bounds_tighten)
       next
         fix x
         assume x: "x \<in> set ?rts" "\<not> ?P x"
         let ?x = "pair_to_complex x" 
         obtain r i where xri: "x = (r,i)" by force
         have id: "(?f ^^ n) x = ((?tb ^^ n) r, (?tb ^^ n) i)" for n unfolding xri
           by (induct n, auto)
         have px: "?x = Complex (real_of_3 r) (real_of_3 i)" 
           unfolding xri pair_to_complex_def by auto
         have cvg: "(\<lambda> n. ?itv ((?f ^^ n) x)) \<longlonglongrightarrow>\<^sub>c ipoly p ?x" 
           unfolding id split px
         proof (rule ipoly_complex_interval_tendsto)
           show "(\<lambda>ia. Complex_Interval (get_itvl_3 ((?tb ^^ ia) r)) (get_itvl_3 ((?tb ^^ ia) i))) \<longlonglongrightarrow>\<^sub>c
             Complex (real_of_3 r) (real_of_3 i)" 
             unfolding complex_interval_tendsto_def by (simp add: tends_to_tight_bounds_3 o_def)
         qed
         from complex_interval_tendsto_neq[OF this x(2)]
         show "\<exists> i. \<not> ?p ((?f ^^ i) x)" unfolding id by auto
       next
         show "pair_to_complex (?f x) = pair_to_complex x" for x
           by (cases x, auto simp: pair_to_complex_def tighten_bounds_3(1))
       next
         show "?P (?f x) = ?P x" for x 
           by (cases x, auto simp: pair_to_complex_def tighten_bounds_3(1)) 
       qed
       have l: "complex_roots_of_int_poly3 p = ?ll'" 
         unfolding d filter cpx_def[symmetric] cpxI_def[symmetric] cpxR_def[symmetric] using False oFalse
         by auto   
       have "distinct ?ll' = (distinct rrts \<and> distinct ?LL' \<and> set rrts \<inter> set ?LL' = {})" 
         unfolding distinct_append ..
       also have "set ?LL' = set ?LL" by auto
       also have "distinct ?LL' = distinct ?LL" by (induct cpx, auto)
       finally have "distinct ?ll' = distinct ?ll" unfolding distinct_append by auto
       with dist have "distinct ?ll'" by auto
       with lr l show ?thesis by auto
     next
       case True
       let ?cr = "map_poly of_real :: real poly \<Rightarrow> complex poly"
       define pp where "pp = complex_of_int_poly p"
       have id: "pp = map_poly of_real q" unfolding q_def pp_def
         by (subst map_poly_map_poly, auto simp: o_def)
       let ?rts = "map (\<lambda> x. [:-x,1:]) rr"
       define rts where "rts = prod_list ?rts"
       let ?c2 = "?cr (q div rts)"
       have pq: "\<And> x. ipoly p x = 0 \<longleftrightarrow> poly q x = 0" unfolding q_def by simp
       from True have 2: "degree q - card {x. poly q x = 0} = 2" unfolding pq[symmetric] lrr
         unfolding q_def by simp
       from True have id: "degree p = length rr \<longleftrightarrow> False" 
         "degree p - length rr = 2 \<longleftrightarrow> True" by auto
       have l: "?l = of_real ` {x. poly q x = 0} \<union> set (croots2 ?c2)"
         unfolding d rts_def id if_False if_True set_append rrts Reals_def
         by (fold complex_of_real_def q_def, auto)
       from dist
       have len_rr: "length rr = card {x. poly q x = 0}" unfolding rr[unfolded pq, symmetric] 
         by (simp add: distinct_card)
       have rr': "\<And> r. r \<in> set rr \<Longrightarrow> poly q r = 0" using rr unfolding q_def by simp
       with dist have "q = q div prod_list ?rts * prod_list ?rts"
       proof (induct rr arbitrary: q)
         case (Cons r rr q)
         note dist = Cons(2)
         let ?p = "q div [:-r,1:]"
         from Cons.prems(2) have "poly q r = 0" by simp
         hence "[:-r,1:] dvd q" using poly_eq_0_iff_dvd by blast
         from dvd_mult_div_cancel[OF this]
         have "q = ?p * [:-r,1:]" by simp
         moreover have "?p = ?p div (\<Prod>x\<leftarrow>rr. [:- x, 1:]) * (\<Prod>x\<leftarrow>rr. [:- x, 1:])"
         proof (rule Cons.hyps)
           show "distinct rr" using dist by auto
           fix s
           assume "s \<in> set rr"
           with dist Cons(3) have "s \<noteq> r" "poly q s = 0" by auto
           hence "poly (?p * [:- 1 * r, 1:]) s = 0" using calculation by force
           thus "poly ?p s = 0" by (simp add: \<open>s \<noteq> r\<close>)
         qed
         ultimately have q: "q = ?p div (\<Prod>x\<leftarrow>rr. [:- x, 1:]) * (\<Prod>x\<leftarrow>rr. [:- x, 1:]) * [:-r,1:]"
           by auto
         also have "\<dots> = (?p div (\<Prod>x\<leftarrow>rr. [:- x, 1:])) * (\<Prod>x\<leftarrow>r # rr. [:- x, 1:])"
           unfolding mult.assoc by simp
         also have "?p div (\<Prod>x\<leftarrow>rr. [:- x, 1:]) = q div (\<Prod>x\<leftarrow>r # rr. [:- x, 1:])"
           unfolding poly_div_mult_right[symmetric] by simp
         finally show ?case .
       qed simp
       hence q_div: "q = q div rts * rts" unfolding rts_def .
       from q_div q0 have "q div rts \<noteq> 0" "rts \<noteq> 0" by auto
       from degree_mult_eq[OF this] have "degree q = degree (q div rts) + degree rts"
         using q_div by simp
       also have "degree rts = length rr" unfolding rts_def by (rule degree_linear_factors)
       also have "\<dots> = card {x. poly q x = 0}" unfolding len_rr by simp
       finally have deg2: "degree ?c2 = 2" using 2 by simp
       note croots2 = croots2[OF deg2, symmetric]
       have "?q = ?cr (q div rts * rts)" using q_div by simp
       also have "\<dots> = ?cr rts * ?c2" unfolding hom_distribs by simp
       finally have q_prod: "?q = ?cr rts * ?c2" .
       from croots2 l
       have l: "?l = of_real ` {x. poly q x = 0} \<union> {x. poly ?c2 x = 0}" by simp
       from r[unfolded q_prod]
       have r: "?r = {x. poly (?cr rts) x = 0} \<union> {x. poly ?c2 x = 0}" by auto
       also have "?cr rts = (\<Prod>x\<leftarrow>rr. ?cr [:- x, 1:])" by (simp add: rts_def o_def of_real_poly_hom.hom_prod_list)
       also have "{x. poly \<dots> x = 0} = of_real ` set rr" 
         unfolding poly_prod_list_zero_iff by auto
       also have "set rr = {x. poly q x = 0}" unfolding rr q_def by simp
       finally have lr: "?l = ?r" unfolding l by simp
       show ?thesis 
       proof (intro conjI[OF lr])
         from sf have sf: "square_free q" unfolding q_def by (rule square_free_of_int_poly)
         {
           interpret field_hom_0' complex_of_real ..
           from sf have "square_free ?q" unfolding square_free_map_poly .
         } note sf = this
         have l: "complex_roots_of_int_poly3 p = rrts @ croots2 ?c2" 
           unfolding d rts_def id if_False if_True set_append rrts q_def complex_of_real_def by auto
         have dist2: "distinct (croots2 ?c2)" unfolding croots2_def Let_def by auto        
         {
           fix x
           assume x: "x \<in> set (croots2 ?c2)" "x \<in> set rrts" 
           from x(1)[unfolded croots2] have x1: "poly ?c2 x = 0" by auto
           from x(2) have x2: "poly (?cr rts) x = 0" 
             unfolding rrts_def rts_def complex_of_real_def[symmetric]
             by (auto simp: poly_prod_list_zero_iff o_def) 
           from square_free_multD(1)[OF sf[unfolded q_prod], of "[: -x, 1:]"]
             x1 x2 have False unfolding poly_eq_0_iff_dvd by auto 
         } note dist3 = this
         show "distinct (complex_roots_of_int_poly3 p)" unfolding l distinct_append
           by (intro conjI dist1 dist2, insert dist3, auto)
       qed
     qed
   next
     case True
     have "card {x. poly ?q x = 0} \<le> degree ?q" by (rule poly_roots_degree[OF q])
     also have "\<dots> = degree p" unfolding q_def by simp
     also have "\<dots> = card {x. poly ?q x = 0 \<and> x \<in> \<real>}" using True cr by simp
     finally have le: "card {x. poly ?q x = 0} \<le> card {x. poly ?q x = 0 \<and> x \<in> \<real>}" by auto
     have "{x. poly ?q x = 0 \<and> x \<in> \<real>} = {x. poly ?q x = 0}"
       by (rule card_seteq[OF _ _ le], insert poly_roots_finite[OF q], auto)
     with True rrts dist1 show ?thesis unfolding r d by auto
   qed
   thus "distinct (complex_roots_of_int_poly3 p)" "?l = ?r" by auto
 qed
 
 lemma complex_roots_of_int_poly_all: assumes sf: "degree p \<ge> 3 \<Longrightarrow> square_free p" 
   shows "p \<noteq> 0 \<Longrightarrow> set (complex_roots_of_int_poly_all p) = {x. ipoly p x = 0}" (is "_ \<Longrightarrow> set ?l = ?r")
     and "distinct (complex_roots_of_int_poly_all p)" 
 proof -
   note d = complex_roots_of_int_poly_all_def Let_def
   have "(p \<noteq> 0 \<longrightarrow> set ?l = ?r) \<and> (distinct (complex_roots_of_int_poly_all p))" 
   proof (cases "degree p \<ge> 3")
     case True
     hence p: "p \<noteq> 0" by auto
     from True complex_roots_of_int_poly3[OF p] sf show ?thesis unfolding d by auto
   next
     case False
     let ?p = "map_poly (of_int :: int \<Rightarrow> complex) p"
     have deg: "degree ?p = degree p" 
       by (simp add: degree_map_poly)
     show ?thesis
     proof (cases "degree p = 1")
       case True
       hence l: "?l = [roots1 ?p]" unfolding d by auto
       from True have "degree ?p = 1" unfolding deg by auto
       from roots1[OF this] show ?thesis unfolding l roots1_def by auto
     next
       case False
       show ?thesis 
       proof (cases "degree p = 2")
         case True
         hence l: "?l = croots2 ?p" unfolding d by auto
         from True have "degree ?p = 2" unfolding deg by auto
         from croots2[OF this] show ?thesis unfolding l by (simp add: croots2_def Let_def)
       next
         case False
         with \<open>degree p \<noteq> 1\<close> \<open>degree p \<noteq> 2\<close> \<open>\<not> (degree p \<ge> 3)\<close> have True: "degree p = 0" by auto
         hence l: "?l = []" unfolding d by auto
         from True have "degree ?p = 0" unfolding deg by auto
         from roots0[OF _ this] show ?thesis unfolding l by simp
       qed
     qed
   qed
   thus "p \<noteq> 0 \<Longrightarrow> set ?l = ?r" "distinct (complex_roots_of_int_poly_all p)" by auto
 qed
 
 text \<open>It now comes the preferred function to compute complex roots of a integer polynomial.\<close>
 definition complex_roots_of_int_poly :: "int poly \<Rightarrow> complex list" where
   "complex_roots_of_int_poly p = (
     let ps = (if degree p \<ge> 3 then factors_of_int_poly p else [p])
     in concat (map complex_roots_of_int_poly_all ps))"
 
 definition complex_roots_of_rat_poly :: "rat poly \<Rightarrow> complex list" where
   "complex_roots_of_rat_poly p = complex_roots_of_int_poly (snd (rat_to_int_poly p))"
  
   
 lemma complex_roots_of_int_poly:
   shows "p \<noteq> 0 \<Longrightarrow> set (complex_roots_of_int_poly p) = {x. ipoly p x = 0}" (is "_ \<Longrightarrow> ?l = ?r")
   and "distinct (complex_roots_of_int_poly p)" 
 proof -
   have "(p \<noteq> 0 \<longrightarrow> ?l = ?r) \<and> (distinct (complex_roots_of_int_poly p))" 
   proof (cases "degree p \<ge> 3")
     case False
     hence "complex_roots_of_int_poly p = complex_roots_of_int_poly_all p"
       unfolding complex_roots_of_int_poly_def Let_def by auto
     with complex_roots_of_int_poly_all[of p] False show ?thesis by auto
   next
     case True
     {
       fix q
       assume "q \<in> set (factors_of_int_poly p)"
       from factors_of_int_poly(1)[OF refl this] irreducible_imp_square_free[of q] 
       have 0: "q \<noteq> 0" and sf: "square_free q" by auto
       from complex_roots_of_int_poly_all(1)[OF sf 0] complex_roots_of_int_poly_all(2)[OF sf]
       have "set (complex_roots_of_int_poly_all q) = {x. ipoly q x = 0}" 
         "distinct (complex_roots_of_int_poly_all q)" by auto
     } note all = this
     from True have 
       "?l = (\<Union> ((\<lambda> p. set (complex_roots_of_int_poly_all p)) ` set (factors_of_int_poly p)))"
       unfolding complex_roots_of_int_poly_def Let_def by auto    
     also have "\<dots> = (\<Union> ((\<lambda> p. {x. ipoly p x = 0}) ` set (factors_of_int_poly p)))"
       using all by blast
     finally have l: "?l = (\<Union> ((\<lambda> p. {x. ipoly p x = 0}) ` set (factors_of_int_poly p)))" .    
     have lr: "p \<noteq> 0 \<longrightarrow> ?l = ?r" using l factors_of_int_poly(2)[OF refl, of p] by auto
     show ?thesis 
     proof (rule conjI[OF lr])
       from True have id: "complex_roots_of_int_poly p = 
           concat (map complex_roots_of_int_poly_all (factors_of_int_poly p))" 
         unfolding complex_roots_of_int_poly_def Let_def by auto
       show "distinct (complex_roots_of_int_poly p)" unfolding id distinct_conv_nth
       proof (intro allI impI, goal_cases)
         case (1 i j)
         let ?fp = "factors_of_int_poly p" 
         let ?rr = "complex_roots_of_int_poly_all" 
         let ?cc = "concat (map ?rr (factors_of_int_poly p))" 
         from nth_concat_diff[OF 1, unfolded length_map]
         obtain j1 k1 j2 k2 where 
           *: "(j1,k1) \<noteq> (j2,k2)"
           "j1 < length ?fp" "j2 < length ?fp" and
           "k1 < length (map ?rr ?fp ! j1)"
           "k2 < length (map ?rr ?fp ! j2)"
           "?cc ! i = map ?rr ?fp ! j1 ! k1" 
           "?cc ! j = map ?rr ?fp ! j2 ! k2" by blast
         hence **: "k1 < length (?rr (?fp ! j1))" 
           "k2 < length (?rr (?fp ! j2))" 
           "?cc ! i = ?rr (?fp ! j1) ! k1"
           "?cc ! j = ?rr (?fp ! j2) ! k2"
           by auto
         from * have mem: "?fp ! j1 \<in> set ?fp" "?fp ! j2 \<in> set ?fp" by auto
         show "?cc ! i \<noteq> ?cc ! j"
         proof (cases "j1 = j2")
           case True
           with * have "k1 \<noteq> k2" by auto
           with all(2)[OF mem(2)] **(1-2) show ?thesis unfolding **(3-4) unfolding True
             distinct_conv_nth by auto
         next
           case False
           from \<open>degree p \<ge> 3\<close> have p: "p \<noteq> 0" by auto
           note fip = factors_of_int_poly(2-3)[OF refl this]       
           show ?thesis unfolding **(3-4)
           proof
             define x where "x = ?rr (?fp ! j2) ! k2" 
             assume id: "?rr (?fp ! j1) ! k1 = ?rr (?fp ! j2) ! k2" 
             from ** have x1: "x \<in> set (?rr (?fp ! j1))" unfolding x_def id[symmetric] by auto
             from ** have x2: "x \<in> set (?rr (?fp ! j2))" unfolding x_def by auto            
             from all(1)[OF mem(1)] x1 have x1: "ipoly (?fp ! j1) x = 0" by auto
             from all(1)[OF mem(2)] x2 have x2: "ipoly (?fp ! j2) x = 0" by auto
             from False factors_of_int_poly(4)[OF refl, of p] have neq: "?fp ! j1 \<noteq> ?fp ! j2" 
               using * unfolding distinct_conv_nth by auto
             have "poly (complex_of_int_poly p) x = 0" by (meson fip(1) mem(2) x2)
             from fip(2)[OF this] mem x1 x2 neq
             show False by blast
           qed
         qed
       qed
     qed
   qed
   thus "p \<noteq> 0 \<Longrightarrow> ?l = ?r" "distinct (complex_roots_of_int_poly p)" by auto
 qed
 
 lemma complex_roots_of_rat_poly: 
   "p \<noteq> 0 \<Longrightarrow> set (complex_roots_of_rat_poly p) = {x. rpoly p x = 0}" (is "_ \<Longrightarrow> ?l = ?r")
   "distinct (complex_roots_of_rat_poly p)" 
 proof -
   obtain c q where cq: "rat_to_int_poly p = (c,q)" by force
   from rat_to_int_poly[OF this]
   have pq: "p = smult (inverse (of_int c)) (of_int_poly q)" 
     and c: "c \<noteq> 0" by auto
   show "distinct (complex_roots_of_rat_poly p)" unfolding complex_roots_of_rat_poly_def
     using complex_roots_of_int_poly(2) .
   assume p: "p \<noteq> 0" 
   with pq c have q: "q \<noteq> 0" by auto
   have id: "{x. rpoly p x = (0 :: complex)} = {x. ipoly q x = 0}"
-    unfolding pq by (simp add: c of_rat_of_int_poly map_poly_map_poly o_def hom_distribs)
+    unfolding pq by (simp add: c of_rat_of_int_poly hom_distribs)
   show "?l = ?r" unfolding complex_roots_of_rat_poly_def cq snd_conv id
     complex_roots_of_int_poly(1)[OF q] ..
 qed
 
 definition roots_of_complex_main :: "complex poly \<Rightarrow> complex list" where 
   "roots_of_complex_main p \<equiv> let n = degree p in 
     if n = 0 then [] else if n = 1 then [roots1 p] else if n = 2 then croots2 p
     else (complex_roots_of_rat_poly (map_poly to_rat p))"
   
 definition roots_of_complex_poly :: "complex poly \<Rightarrow> complex list option" where
   "roots_of_complex_poly p \<equiv> let (c,pis) = yun_factorization gcd p in
     if (c \<noteq> 0 \<and> (\<forall> (p,i) \<in> set pis. degree p \<le> 2 \<or> (\<forall> x \<in> set (coeffs p). x \<in> \<rat>))) then 
     Some (concat (map (roots_of_complex_main o fst) pis)) else None"
 
 lemma roots_of_complex_main: assumes p: "p \<noteq> 0" and deg: "degree p \<le> 2 \<or> set (coeffs p) \<subseteq> \<rat>"
   shows "set (roots_of_complex_main p) = {x. poly p x = 0}" (is "set ?l = ?r")
     and "distinct (roots_of_complex_main p)" 
 proof -
   note d = roots_of_complex_main_def Let_def
   have "set ?l = ?r \<and> distinct (roots_of_complex_main p)" 
   proof (cases "degree p = 0")
     case True
     hence "?l = []" unfolding d by auto
     with roots0[OF p True] show ?thesis by auto
   next
     case False note 0 = this
     show ?thesis
     proof (cases "degree p = 1")
       case True
       hence "?l = [roots1 p]" unfolding d by auto
       with roots1[OF True] show ?thesis by auto
     next
       case False note 1 = this
       show ?thesis
       proof (cases "degree p = 2")
         case True
         hence "?l = croots2 p" unfolding d by auto
         with croots2[OF True] show ?thesis by (auto simp: croots2_def Let_def)
       next
         case False note 2 = this
         let ?q = "map_poly to_rat p"
         from 0 1 2 have l: "?l = complex_roots_of_rat_poly ?q" unfolding d by auto
         from deg 0 1 2 have rat: "set (coeffs p) \<subseteq> \<rat>" by auto
         have "p = map_poly (of_rat o to_rat) p"
           by (rule sym, rule map_poly_idI, insert rat, auto)
         also have "\<dots> = complex_of_rat_poly ?q"
           by (subst map_poly_map_poly, auto simp: to_rat)
         finally have id: "{x. poly p x = 0} = {x. poly (complex_of_rat_poly ?q) x = 0}" and q: "?q \<noteq> 0" 
           using p by auto
         from complex_roots_of_rat_poly[of ?q, folded id l] q
         show ?thesis by auto
       qed
     qed
   qed
   thus "set ?l = ?r" "distinct ?l" by auto
 qed
  
 lemma roots_of_complex_poly: assumes rt: "roots_of_complex_poly p = Some xs"
   shows "set xs = {x. poly p x = 0}"
 proof -
   obtain c pis where yun: "yun_factorization gcd p = (c,pis)" by force
   from rt[unfolded roots_of_complex_poly_def yun split Let_def]
   have c: "c \<noteq> 0" and pis: "\<And> p i. (p, i)\<in> set pis \<Longrightarrow> degree p \<le> 2 \<or> (\<forall>x\<in>set (coeffs p). x \<in> \<rat>)"
     and xs: "xs = concat (map (roots_of_complex_main \<circ> fst) pis)"
     by (auto split: if_splits)
   note yun = square_free_factorizationD(1,2,4)[OF yun_factorization(1)[OF yun]]
   from yun(1) have p: "p = smult c (\<Prod>(a, i)\<in>set pis. a ^ Suc i)" .
   have "{x. poly p x = 0} = {x. poly (\<Prod>(a, i)\<in>set pis. a ^ Suc i) x = 0}"
     unfolding p using c by auto
   also have "\<dots> = \<Union> ((\<lambda> p. {x. poly p x = 0}) ` fst ` set pis)" (is "_ = ?r")
     by (subst poly_prod_0, force+)
   finally have r: "{x. poly p x = 0} = ?r" .
   {
     fix p i
     assume p: "(p,i) \<in> set pis"
     have "set (roots_of_complex_main p) = {x. poly p x = 0}"
       by (rule roots_of_complex_main, insert yun(2)[OF p] pis[OF p], auto)
   } note main = this
   have "set xs = \<Union> ((\<lambda> (p, i). set (roots_of_complex_main p)) ` set pis)" unfolding xs o_def
     by auto
   also have "\<dots> = ?r" using main by auto
   finally show ?thesis unfolding r by simp
 qed
 
 subsection \<open>Factorization of Complex Polynomials\<close>
 
 definition factorize_complex_main :: "complex poly \<Rightarrow> (complex \<times> (complex \<times> nat) list) option" where
   "factorize_complex_main p \<equiv> let (c,pis) = yun_factorization gcd p in
     if ((\<forall> (p,i) \<in> set pis. degree p \<le> 2 \<or> (\<forall> x \<in> set (coeffs p). x \<in> \<rat>))) then 
     Some (c, concat (map (\<lambda> (p,i). map (\<lambda> r. (r,i)) (roots_of_complex_main p)) pis)) else None"
 
 definition factorize_complex_poly :: "complex poly \<Rightarrow> (complex \<times> (complex poly \<times> nat) list) option" where
   "factorize_complex_poly p \<equiv> map_option 
     (\<lambda> (c,ris). (c, map (\<lambda> (r,i). ([:-r,1:],Suc i)) ris)) (factorize_complex_main p)"
 
 
 lemma factorize_complex_main: assumes rt: "factorize_complex_main p = Some (c,xis)"
   shows "p = smult c (\<Prod>(x, i)\<leftarrow>xis. [:- x, 1:] ^ Suc i)"
 proof -
   obtain d pis where yun: "yun_factorization gcd p = (d,pis)" by force
   from rt[unfolded factorize_complex_main_def yun split Let_def]
   have pis: "\<And> p i. (p, i)\<in>set pis \<Longrightarrow> degree p \<le> 2 \<or> (\<forall>x\<in>set (coeffs p). x \<in> \<rat>)"
     and xis: "xis = concat (map (\<lambda>(p, i). map (\<lambda>r. (r, i)) (roots_of_complex_main p)) pis)"
     and d: "d = c"
     by (auto split: if_splits)
   note yun = yun_factorization[OF yun[unfolded d]]
   note yun = square_free_factorizationD[OF yun(1)] yun(2)[unfolded snd_conv]
   let ?exp = "\<lambda> pis. \<Prod>(x, i)\<leftarrow>concat
     (map (\<lambda>(p, i). map (\<lambda>r. (r, i)) (roots_of_complex_main p)) pis). [:- x, 1:] ^ Suc i"
   from yun(1) have p: "p = smult c (\<Prod>(a, i)\<in>set pis. a ^ Suc i)" .
   also have "(\<Prod>(a, i)\<in>set pis. a ^ Suc i) = (\<Prod>(a, i)\<leftarrow>pis. a ^ Suc i)"
     by (rule prod.distinct_set_conv_list[OF yun(5)])
   also have "\<dots> = ?exp pis" using pis yun(2,6)
   proof (induct pis)
     case (Cons pi pis)
     obtain p i where pi: "pi = (p,i)" by force
     let ?rts = "roots_of_complex_main p"
     note Cons = Cons[unfolded pi]
     have IH: "(\<Prod>(a, i)\<leftarrow>pis. a ^ Suc i) = (?exp pis)"
       by (rule Cons(1)[OF Cons(2-4)], auto)
     from Cons(2-4)[of p i] have deg: "degree p \<le> 2 \<or> (\<forall>x\<in>set (coeffs p). x \<in> \<rat>)"
       and p: "square_free p" "degree p \<noteq> 0" "p \<noteq> 0" "monic p" by auto
     have "(\<Prod>(a, i)\<leftarrow>(pi # pis). a ^ Suc i) = p ^ Suc i * (\<Prod>(a, i)\<leftarrow>pis. a ^ Suc i)"
       unfolding pi by simp
     also have "(\<Prod>(a, i)\<leftarrow>pis. a ^ Suc i) = ?exp pis" by (rule IH)
     finally have id: "(\<Prod>(a, i)\<leftarrow>(pi # pis). a ^ Suc i) = p ^ Suc i * ?exp pis" by simp
     have "?exp (pi # pis) = ?exp [(p,i)] * ?exp pis" unfolding pi by simp
     also have "?exp [(p,i)] = (\<Prod>(x, i)\<leftarrow> (map (\<lambda>r. (r, i)) ?rts). [:- x, 1:] ^ Suc i)" 
       by simp
     also have "\<dots> = (\<Prod> x \<leftarrow> ?rts. [:- x, 1:])^Suc i"
       unfolding prod_list_power by (rule arg_cong[of _ _ prod_list], auto)
     also have "(\<Prod> x \<leftarrow> ?rts. [:- x, 1:]) = p" 
     proof -
       from fundamental_theorem_algebra_factorized[of p, unfolded \<open>monic p\<close>]
       obtain as where as: "p = (\<Prod>a\<leftarrow>as. [:- a, 1:])" by auto
       also have "\<dots> = (\<Prod>a\<in>set as. [:- a, 1:])"
       proof (rule sym, rule prod.distinct_set_conv_list, rule ccontr)
         assume "\<not> distinct as" 
         from not_distinct_decomp[OF this] obtain as1 as2 as3 a where
           a: "as = as1 @ [a] @ as2 @ [a] @ as3" by blast
         define q where "q = (\<Prod>a\<leftarrow>as1 @ as2 @ as3. [:- a, 1:])"
         have "p = (\<Prod>a\<leftarrow>as. [:- a, 1:])" by fact
         also have "\<dots> = (\<Prod>a\<leftarrow>([a] @ [a]). [:- a, 1:]) * q"
           unfolding q_def a map_append prod_list.append by (simp only: ac_simps)
         also have "\<dots> = [:-a,1:] * [:-a,1:] * q" by simp
         finally have "p = ([:-a,1:] * [:-a,1:]) * q" by simp
         hence "[:-a,1:] * [:-a,1:] dvd p" unfolding dvd_def ..
         with \<open>square_free p\<close>[unfolded square_free_def, THEN conjunct2, rule_format, of "[:-a,1:]"] 
         show False by auto
       qed
       also have "set as = {x. poly p x = 0}" unfolding as poly_prod_list 
         by (simp add: o_def, induct as, auto)
       also have "\<dots> = set ?rts"
         by (rule roots_of_complex_main(1)[symmetric], insert p deg, auto)
       also have "(\<Prod>a\<in>set ?rts. [:- a, 1:]) = (\<Prod>a\<leftarrow>?rts. [:- a, 1:])"
         by (rule prod.distinct_set_conv_list[OF roots_of_complex_main(2)], insert deg p, auto)
       finally show ?thesis by simp
     qed
     finally have id2: "?exp (pi # pis) = p ^ Suc i * ?exp pis" by simp
     show ?case unfolding id id2 ..
   qed simp
   also have "?exp pis = (\<Prod>(x, i)\<leftarrow>xis. [:- x, 1:] ^ Suc i)" unfolding xis ..
   finally show ?thesis unfolding p xis by simp
 qed
 
 lemma distinct_factorize_complex_main:
   assumes "factorize_complex_main p = Some fctrs"
   shows   "distinct (map fst (snd fctrs))"
 proof -
   from assms have solvable: "\<forall>x\<in>set (snd (yun_factorization gcd p)). degree (fst x) \<le> 2 \<or> 
                                  (\<forall>x\<in>set (coeffs (fst x)). x \<in> \<rat>)"
     by (auto simp add: factorize_complex_main_def case_prod_unfold 
                        Let_def map_concat o_def split: if_splits)
   have sqf: "square_free_factorization p 
                (fst (yun_factorization gcd p), snd (yun_factorization gcd p))"
     by (rule yun_factorization) simp
     
   have "map fst (snd fctrs) = 
         concat (map (\<lambda>x. (roots_of_complex_main (fst x))) (snd (yun_factorization gcd p)))" 
     using assms by (auto simp add: factorize_complex_main_def case_prod_unfold 
                            Let_def map_concat o_def split: if_splits)
   also have "distinct \<dots>"
   proof (rule distinct_concat, goal_cases)
     case 1
     show ?case
     proof (subst distinct_map, safe)
       from square_free_factorizationD(5)[OF sqf]
       show "distinct (snd (yun_factorization gcd p))" .
       show "inj_on (\<lambda>x. (roots_of_complex_main (fst x))) (set (snd (yun_factorization gcd p)))"
       proof (rule inj_onI, clarify, goal_cases)
         case (1 a1 b1 a2 b2)
         {
           assume neq: "(a1, b1) \<noteq> (a2, b2)"
           from 1(1,2)[THEN square_free_factorizationD(2)[OF sqf]] 
             have "degree a1 \<noteq> 0" "degree a2 \<noteq> 0" by blast+
           hence [simp]: "a1 \<noteq> 0" "a2 \<noteq> 0" by auto
           from square_free_factorizationD(3)[OF sqf 1(1,2) neq]
             have "coprime a1 a2" by simp
           from solvable 1(1) have "{z. poly a1 z = 0} = set (roots_of_complex_main a1)"
             by (intro roots_of_complex_main(1) [symmetric]) auto
           also have "set (roots_of_complex_main a1) = set (roots_of_complex_main a2)"
             using 1(3) by (subst (1 2) set_remdups [symmetric]) (simp only: fst_conv)
           also from solvable 1(2) have "\<dots> = {z. poly a2 z = 0}"
             by (intro roots_of_complex_main) auto
           finally have "{z. poly a1 z = 0} = {z. poly a2 z = 0}" .
           with coprime_imp_no_common_roots \<open>coprime a1 a2\<close>
             have "{z. poly a1 z = 0} = {}" by auto
           with fundamental_theorem_of_algebra constant_degree
             have "degree a1 = 0" by auto
           with \<open>degree a1 \<noteq> 0\<close> have False by contradiction
         }
         thus ?case by blast
       qed
     qed  
   next
     case (2 ys)
     then obtain f b where fb: "(f, b) \<in> set (snd (yun_factorization gcd p))" 
       and ys: "ys = roots_of_complex_main f" by auto
     from square_free_factorizationD(2)[OF sqf fb] have 0: "f \<noteq> 0" by auto
     from solvable[rule_format, OF fb] have f: "degree f \<le> 2 \<or> (set (coeffs f) \<subseteq> \<rat>)" by auto
     show ?case unfolding ys 
       by (rule roots_of_complex_main[OF 0 f])
   next
     case (3 ys zs)
     then obtain a1 b1 a2 b2 where ab:
       "(a1, b1) \<in> set (snd (yun_factorization gcd p))"
       "(a2, b2) \<in> set (snd (yun_factorization gcd p))"
       "ys = roots_of_complex_main a1" "zs = roots_of_complex_main a2"
       by auto
     with 3 have neq: "(a1,b1) \<noteq> (a2,b2)" by auto
     from ab(1,2)[THEN square_free_factorizationD(2)[OF sqf]] 
       have [simp]: "a1 \<noteq> 0" "a2 \<noteq> 0" by auto
     
     from square_free_factorizationD(3)[OF sqf ab(1,2) neq] have "coprime a1 a2" by simp
     have "set ys = {z. poly a1 z = 0}" "set zs = {z. poly a2 z = 0}"
       by (insert solvable ab(1,2), subst ab,
           rule roots_of_complex_main; (auto) [])+
     with coprime_imp_no_common_roots \<open>coprime a1 a2\<close> show ?case by auto
   qed 
   
   finally show ?thesis .
 qed
 
 lemma factorize_complex_poly: assumes fp: "factorize_complex_poly p = Some (c,qis)"
   shows 
   "p = smult c (\<Prod>(q, i)\<leftarrow>qis. q ^ i)" 
   "(q,i) \<in> set qis \<Longrightarrow> irreducible q \<and> i \<noteq> 0 \<and> monic q \<and> degree q = 1"
 proof -
   from fp[unfolded factorize_complex_poly_def]
   obtain pis where fp: "factorize_complex_main p = Some (c,pis)"
     and qis: "qis = map (\<lambda>(r, i). ([:- r, 1:], Suc i)) pis"
     by auto
   from factorize_complex_main[OF fp] have p: "p = smult c (\<Prod>(x, i)\<leftarrow>pis. [:- x, 1:] ^ Suc i)" .
   show "p = smult c (\<Prod>(q, i)\<leftarrow>qis. q ^ i)" unfolding p qis
     by (rule arg_cong[of _ _ "\<lambda> p. smult c (prod_list p)"], auto)
   show "(q,i) \<in> set qis \<Longrightarrow> irreducible q \<and> i \<noteq> 0 \<and> monic q \<and> degree q = 1"
     using linear_irreducible_field[of q] unfolding qis by auto
 qed
   
 end
diff --git a/thys/Algebraic_Numbers/Real_Algebraic_Numbers.thy b/thys/Algebraic_Numbers/Real_Algebraic_Numbers.thy
--- a/thys/Algebraic_Numbers/Real_Algebraic_Numbers.thy
+++ b/thys/Algebraic_Numbers/Real_Algebraic_Numbers.thy
@@ -1,3538 +1,3540 @@
 (*  
     Author:      Sebastiaan Joosten
                  René Thiemann 
                  Akihisa Yamada
     License:     BSD
 *)
 section \<open>Real Algebraic Numbers\<close>
 
 text \<open>Whereas we previously only proved the closure properties of algebraic numbers, this
   theory adds the numeric computations that are required to separate the roots, and to
   pick unique representatives of algebraic numbers. 
 
   The development is split into three major parts. First, an ambiguous representation of 
   algebraic numbers is used, afterwards another layer is used with special treatment of rational numbers
   which still does not admit unique representatives, and finally, a quotient type is created modulo 
   the equivalence.
   
   The theory also contains a code-setup to implement real numbers via real algebraic numbers.\<close>
 
 
 text \<open>The results are taken from the textbook \cite[pages 329ff]{AlgNumbers}.\<close>
 
 
 theory Real_Algebraic_Numbers
 imports 
   "Abstract-Rewriting.SN_Order_Carrier"
   Deriving.Compare_Rat
   Deriving.Compare_Real
   Jordan_Normal_Form.Gauss_Jordan_IArray_Impl
   Algebraic_Numbers
   Sturm_Rat
 begin
 
 (*TODO: move *)
 lemma ex1_imp_Collect_singleton: "(\<exists>!x. P x) \<and> P x \<longleftrightarrow> Collect P = {x}"
 proof(intro iffI conjI, unfold conj_imp_eq_imp_imp)
   assume "Ex1 P" "P x" then show "Collect P = {x}" by blast
 next
   assume Px: "Collect P = {x}"
   then have "P y \<longleftrightarrow> x = y" for y by auto
   then show "Ex1 P" by auto
   from Px show "P x" by auto
 qed
 
 lemma ex1_Collect_singleton[consumes 2]:
   assumes "\<exists>!x. P x" and "P x" and "Collect P = {x} \<Longrightarrow> thesis" shows thesis
   by (rule assms(3), subst ex1_imp_Collect_singleton[symmetric], insert assms(1,2), auto)
 
 lemma ex1_iff_Collect_singleton: "P x \<Longrightarrow> (\<exists>!x. P x) \<longleftrightarrow> Collect P = {x}"
   by (subst ex1_imp_Collect_singleton[symmetric], auto)
 
 context
   fixes f
   assumes bij: "bij f"
 begin
 lemma bij_imp_ex1_iff: "(\<exists>!x. P (f x)) \<longleftrightarrow> (\<exists>!y. P y)" (is "?l = ?r")
 proof (intro iffI)
   assume l: ?l
   then obtain x where "P (f x)" by auto
   with l have *: "{x} = Collect (P o f)" by auto
   also have "f ` \<dots> = {y. P (f (Hilbert_Choice.inv f y))}" using bij_image_Collect_eq[OF bij] by auto
   also have "\<dots> = {y. P y}"
   proof-
     have "f (Hilbert_Choice.inv f y) = y" for y by (meson bij bij_inv_eq_iff)
     then show ?thesis by simp
   qed
   finally have "Collect P = {f x}" by auto
   then show ?r by (fold ex1_imp_Collect_singleton, auto)
 next
   assume r: ?r
   then obtain y where "P y" by auto
   with r have "{y} = Collect P" by auto
   also have "Hilbert_Choice.inv f ` \<dots> = Collect (P \<circ> f)"
     using bij_image_Collect_eq[OF bij_imp_bij_inv[OF bij]] bij by (auto simp: inv_inv_eq)
   finally have "Collect (P o f) = {Hilbert_Choice.inv f y}" by (simp add: o_def)
   then show ?l by (fold ex1_imp_Collect_singleton, auto)
 qed
 
 lemma bij_ex1_imp_the_shift:
   assumes ex1: "\<exists>!y. P y" shows "(THE x. P (f x)) = Hilbert_Choice.inv f (THE y. P y)" (is "?l = ?r")
 proof-
   from ex1 have "P (THE y. P y)" by (rule the1I2)
   moreover from ex1[folded bij_imp_ex1_iff] have "P (f (THE x. P (f x)))" by (rule the1I2)
   ultimately have "(THE y. P y) = f (THE x. P (f x))" using ex1 by auto
   also have "Hilbert_Choice.inv f \<dots> = (THE x. P (f x))" using bij by (simp add: bij_is_inj)
   finally show "?l = ?r" by auto
 qed
 
 lemma bij_imp_Collect_image: "{x. P (f x)} = Hilbert_Choice.inv f ` {y. P y}" (is "?l = ?g ` _")
 proof-
   have "?l = ?g ` f ` ?l" by (simp add: image_comp inv_o_cancel[OF bij_is_inj[OF bij]])
   also have "f ` ?l = {f x | x. P (f x)}" by auto
   also have "\<dots> = {y. P y}" by (metis bij bij_iff)
   finally show ?thesis.
 qed
 
 lemma bij_imp_card_image: "card (f ` X) = card X"
   by (metis bij bij_iff card.infinite finite_imageD inj_onI inj_on_iff_eq_card)
 
 end
 
 lemma bij_imp_card: assumes bij: "bij f" shows "card {x. P (f x)} = card {x. P x}"
 unfolding bij_imp_Collect_image[OF bij] bij_imp_card_image[OF bij_imp_bij_inv[OF bij]]..
 
 lemma bij_add: "bij (\<lambda>x. x + y :: 'a :: group_add)" (is ?g1)
   and bij_minus: "bij (\<lambda>x. x - y :: 'a)" (is ?g2)
   and inv_add[simp]: "Hilbert_Choice.inv (\<lambda>x. x + y) = (\<lambda>x. x - y)" (is ?g3)
   and inv_minus[simp]: "Hilbert_Choice.inv (\<lambda>x. x - y) = (\<lambda>x. x + y)" (is ?g4)
 proof-
   have 1: "(\<lambda>x. x - y) \<circ> (\<lambda>x. x + y) = id" and 2: "(\<lambda>x. x + y) \<circ> (\<lambda>x. x - y) = id" by auto
   from o_bij[OF 1 2] show ?g1.
   from o_bij[OF 2 1] show ?g2.
   from inv_unique_comp[OF 2 1] show ?g3.
   from inv_unique_comp[OF 1 2] show ?g4.
 qed
 
 lemmas ex1_shift[simp] = bij_imp_ex1_iff[OF bij_add] bij_imp_ex1_iff[OF bij_minus]
 
 lemma ex1_the_shift:
   assumes ex1: "\<exists>!y :: 'a :: group_add. P y"
   shows "(THE x. P (x + d)) = (THE y. P y) - d"
     and "(THE x. P (x - d)) = (THE y. P y) + d"
   unfolding bij_ex1_imp_the_shift[OF bij_add ex1] bij_ex1_imp_the_shift[OF bij_minus ex1] by auto
 
 lemma card_shift_image[simp]:
   shows "card ((\<lambda>x :: 'a :: group_add. x + d) ` X) = card X"
     and "card ((\<lambda>x. x - d) ` X) = card X"
   by (auto simp: bij_imp_card_image[OF bij_add] bij_imp_card_image[OF bij_minus])
 
 lemma irreducible_root_free:
   fixes p :: "'a :: {idom,comm_ring_1} poly"
   assumes irr: "irreducible p" shows "root_free p"
 proof (cases "degree p" "1::nat" rule: linorder_cases)
   case greater
   {
     fix x
     assume "poly p x = 0"
     hence "[:-x,1:] dvd p" using poly_eq_0_iff_dvd by blast
     then obtain r where p: "p = r * [:-x,1:]" by (elim dvdE, auto)
     have deg: "degree [:-x,1:] = 1" by simp
     have dvd: "\<not> [:-x,1:] dvd 1" by (auto simp: poly_dvd_1)
     from greater have "degree r \<noteq> 0" using degree_mult_le[of r "[:-x,1:]", unfolded deg, folded p] by auto
     then have "\<not> r dvd 1" by (auto simp: poly_dvd_1)
     with p irr irreducibleD[OF irr p] dvd have False by auto
   }
   thus ?thesis unfolding root_free_def by auto
 next
   case less then have deg: "degree p = 0" by auto
   from deg obtain p0 where p: "p = [:p0:]" using degree0_coeffs by auto
   with irr have "p \<noteq> 0" by auto
   with p have "poly p x \<noteq> 0" for x by auto
   thus ?thesis by (auto simp: root_free_def)
 qed (auto simp: root_free_def)
 
 
 (* **************************************************************** *)
 subsection \<open>Real Algebraic Numbers -- Innermost Layer\<close>
 
 text \<open>We represent a real algebraic number \<open>\<alpha>\<close> by a tuple (p,l,r):
     \<open>\<alpha>\<close> is the unique root in the interval [l,r]
     and l and r have the same sign. We always assume that p is normalized, i.e.,
     p is the unique irreducible and positive content-free polynomial 
     which represents the algebraic number.
 
   This representation clearly admits duplicate representations for the same number, e.g.
   (...,x-3, 3,3) is equivalent to (...,x-3,2,10).\<close>
 
 subsubsection \<open>Basic Definitions\<close>
 
 type_synonym real_alg_1 = "int poly \<times> rat \<times> rat"
 
 fun poly_real_alg_1 :: "real_alg_1 \<Rightarrow> int poly" where "poly_real_alg_1 (p,_,_) = p"
 fun rai_ub :: "real_alg_1 \<Rightarrow> rat" where "rai_ub (_,_,r) = r"
 fun rai_lb :: "real_alg_1 \<Rightarrow> rat" where "rai_lb (_,l,_) = l"
 
 abbreviation "roots_below p x \<equiv> {y :: real. y \<le> x \<and> ipoly p y = 0}"
 
 abbreviation(input) unique_root :: "real_alg_1 \<Rightarrow> bool" where
   "unique_root plr \<equiv> (\<exists>! x. root_cond plr x)"
 
 abbreviation the_unique_root :: "real_alg_1 \<Rightarrow> real" where
   "the_unique_root plr \<equiv> (THE x. root_cond plr x)"
 
 abbreviation real_of_1 where "real_of_1 \<equiv> the_unique_root"
 
 lemma root_condI[intro]:
   assumes "of_rat (rai_lb plr) \<le> x" and "x \<le> of_rat (rai_ub plr)" and "ipoly (poly_real_alg_1 plr) x = 0"
   shows "root_cond plr x"
   using assms by (auto simp: root_cond_def)
 
 lemma root_condE[elim]:
   assumes "root_cond plr x"
       and "of_rat (rai_lb plr) \<le> x \<Longrightarrow> x \<le> of_rat (rai_ub plr) \<Longrightarrow> ipoly (poly_real_alg_1 plr) x = 0 \<Longrightarrow> thesis"
   shows thesis
   using assms by (auto simp: root_cond_def)
 
 lemma
   assumes ur: "unique_root plr"
   defines "x \<equiv> the_unique_root plr" and "p \<equiv> poly_real_alg_1 plr" and "l \<equiv> rai_lb plr" and "r \<equiv> rai_ub plr"
   shows unique_rootD: "of_rat l \<le> x" "x \<le> of_rat r" "ipoly p x = 0" "root_cond plr x"
         "x = y \<longleftrightarrow> root_cond plr y" "y = x \<longleftrightarrow> root_cond plr y"
     and the_unique_root_eqI: "root_cond plr y \<Longrightarrow> y = x" "root_cond plr y \<Longrightarrow> x = y"
 proof -
   from ur show x: "root_cond plr x" unfolding x_def by (rule theI')
   have "plr = (p,l,r)" by (cases plr, auto simp: p_def l_def r_def)
   from x[unfolded this] show "of_rat l \<le> x" "x \<le> of_rat r" "ipoly p x = 0" by auto
   from x ur
   show "root_cond plr y \<Longrightarrow> y = x" and "root_cond plr y \<Longrightarrow> x = y"
    and "x = y \<longleftrightarrow> root_cond plr y" and "y = x \<longleftrightarrow> root_cond plr y" by auto
 qed
 
 lemma unique_rootE:
   assumes ur: "unique_root plr"
   defines "x \<equiv> the_unique_root plr" and "p \<equiv> poly_real_alg_1 plr" and "l \<equiv> rai_lb plr" and "r \<equiv> rai_ub plr"
   assumes main: "of_rat l \<le> x \<Longrightarrow> x \<le> of_rat r \<Longrightarrow> ipoly p x = 0 \<Longrightarrow> root_cond plr x \<Longrightarrow>
         (\<And>y. x = y \<longleftrightarrow> root_cond plr y) \<Longrightarrow> (\<And>y. y = x \<longleftrightarrow> root_cond plr y) \<Longrightarrow> thesis"
   shows thesis by (rule main, unfold x_def p_def l_def r_def; rule unique_rootD[OF ur])
 
 lemma unique_rootI:
   assumes "\<And> y. root_cond plr y \<Longrightarrow> x = y" "root_cond plr x"
   shows "unique_root plr" using assms by blast
 
 definition poly_cond :: "int poly \<Rightarrow> bool" where
   "poly_cond p = (lead_coeff p > 0 \<and> irreducible p)"
 
 lemma poly_condI[intro]:
   assumes "lead_coeff p > 0" and "irreducible p" shows "poly_cond p" using assms by (auto simp: poly_cond_def)
 
 lemma poly_condD:
   assumes "poly_cond p"
   shows "irreducible p" and "lead_coeff p > 0" and "root_free p" and "square_free p" and "p \<noteq> 0"
   using assms unfolding poly_cond_def using irreducible_root_free irreducible_imp_square_free cf_pos_def by auto
 
 lemma poly_condE[elim]:
   assumes "poly_cond p"
       and "irreducible p \<Longrightarrow> lead_coeff p > 0 \<Longrightarrow> root_free p \<Longrightarrow> square_free p \<Longrightarrow> p \<noteq> 0 \<Longrightarrow> thesis"
   shows thesis
   using assms by (auto dest:poly_condD)
 
 definition invariant_1 :: "real_alg_1 \<Rightarrow> bool" where
   "invariant_1 tup \<equiv> case tup of (p,l,r) \<Rightarrow>
     unique_root (p,l,r) \<and> sgn l = sgn r \<and> poly_cond p"
 
 
 lemma invariant_1I:
   assumes "unique_root plr" and "sgn (rai_lb plr) = sgn (rai_ub plr)" and "poly_cond (poly_real_alg_1 plr)"
   shows "invariant_1 plr"
   using assms by (auto simp: invariant_1_def)
 
 lemma
   assumes "invariant_1 plr"
   defines "x \<equiv> the_unique_root plr" and "p \<equiv> poly_real_alg_1 plr" and "l \<equiv> rai_lb plr" and "r \<equiv> rai_ub plr"
   shows invariant_1D: "root_cond plr x"
     "sgn l = sgn r" "sgn x = of_rat (sgn r)" "unique_root plr" "poly_cond p" "degree p > 0" "primitive p"
     and invariant_1_root_cond: "\<And> y. root_cond plr y \<longleftrightarrow> y = x"
 proof -
   let ?l = "of_rat l :: real"
   let ?r = "of_rat r :: real"
   have plr: "plr = (p,l,r)" by (cases plr, auto simp: p_def l_def r_def)
   from assms
   show ur: "unique_root plr" and sgn: "sgn l = sgn r" and pc: "poly_cond p" by (auto simp: invariant_1_def)
   from ur show rc: "root_cond plr x" by (auto simp add: x_def plr intro: theI')
   from this[unfolded plr] have x: "ipoly p x = 0" and bnd: "?l \<le> x" "x \<le> ?r" by auto
   show "sgn x = of_rat (sgn r)"
   proof (cases "0::real" "x" rule:linorder_cases)
     case less
     with bnd(2) have "0 < ?r" by arith
     thus ?thesis using less by simp
   next
     case equal
     with bnd have "?l \<le> 0" "?r \<ge> 0" by auto
     hence "l \<le> 0" "r \<ge> 0" by auto
     with \<open>sgn l = sgn r\<close> have "l = 0" "r = 0" unfolding sgn_rat_def by (auto split: if_splits)
     with rc[unfolded plr]
     show ?thesis by auto
   next
     case greater
     with bnd(1) have "?l < 0" by arith
     thus ?thesis unfolding \<open>sgn l = sgn r\<close>[symmetric] using greater by simp
   qed
   from the_unique_root_eqI[OF ur] rc
   show "\<And> y. root_cond plr y \<longleftrightarrow> y = x" by metis
   {
     assume "degree p = 0"
     with poly_zero[OF x, simplified] sgn bnd have "p = 0" by auto
     with pc have "False" by auto
   }
   then show "degree p > 0" by auto
   with pc show "primitive p" by (intro irreducible_imp_primitive, auto)
 qed
 
 lemma invariant_1E[elim]:
   assumes "invariant_1 plr"
   defines "x \<equiv> the_unique_root plr" and "p \<equiv> poly_real_alg_1 plr" and "l \<equiv> rai_lb plr" and "r \<equiv> rai_ub plr"
   assumes main: "root_cond plr x \<Longrightarrow>
       sgn l = sgn r \<Longrightarrow> sgn x = of_rat (sgn r) \<Longrightarrow> unique_root plr \<Longrightarrow> poly_cond p \<Longrightarrow> degree p > 0 \<Longrightarrow>
       primitive p \<Longrightarrow> thesis"
   shows thesis apply (rule main)
   using assms(1) unfolding x_def p_def l_def r_def by (auto dest: invariant_1D)
 
 lemma invariant_1_realI:
   fixes plr :: real_alg_1
   defines "p \<equiv> poly_real_alg_1 plr" and "l \<equiv> rai_lb plr" and "r \<equiv> rai_ub plr"
   assumes x: "root_cond plr x" and "sgn l = sgn r"
       and ur: "unique_root plr"
       and "poly_cond p"
   shows "invariant_1 plr \<and> real_of_1 plr = x"
   using the_unique_root_eqI[OF ur x] assms by (cases plr, auto intro: invariant_1I)
     
 lemma real_of_1_0:
   assumes "invariant_1 (p,l,r)"
   shows [simp]: "the_unique_root (p,l,r) = 0 \<longleftrightarrow> r = 0"
     and [dest]: "l = 0 \<Longrightarrow> r = 0"
     and [intro]: "r = 0 \<Longrightarrow> l = 0"
   using assms by (auto simp: sgn_0_0)
 
 
 lemma invariant_1_pos: assumes rc: "invariant_1 (p,l,r)"
   shows [simp]:"the_unique_root (p,l,r) > 0 \<longleftrightarrow> r > 0" (is "?x > 0 \<longleftrightarrow> _")
     and [simp]:"the_unique_root (p,l,r) < 0 \<longleftrightarrow> r < 0"
     and [simp]:"the_unique_root (p,l,r) \<le> 0 \<longleftrightarrow> r \<le> 0"
     and [simp]:"the_unique_root (p,l,r) \<ge> 0 \<longleftrightarrow> r \<ge> 0"
     and [intro]: "r > 0 \<Longrightarrow> l > 0"
     and [dest]: "l > 0 \<Longrightarrow> r > 0"
     and [intro]: "r < 0 \<Longrightarrow> l < 0"
     and [dest]: "l < 0 \<Longrightarrow> r < 0"
 proof(atomize(full),goal_cases)
   case 1
   let ?r = "real_of_rat"
   from assms[unfolded invariant_1_def]
   have ur: "unique_root (p,l,r)" and sgn: "sgn l = sgn r" by auto
   from unique_rootD(1-2)[OF ur] have le: "?r l \<le> ?x" "?x \<le> ?r r" by auto
   from rc show ?case
   proof (cases r "0::rat" rule:linorder_cases)
     case greater
     with sgn have "sgn l = 1" by simp
     hence l0: "l > 0" by (auto simp: sgn_1_pos)
     hence "?r l > 0" by auto
     hence "?x > 0" using le(1) by arith
     with greater l0 show ?thesis by auto
   next
     case equal
     with real_of_1_0[OF rc] show ?thesis by auto
   next
     case less
     hence "?r r < 0" by auto
     with le(2) have "?x < 0" by arith
     with less sgn show ?thesis by (auto simp: sgn_1_neg)
   qed
 qed
 
 definition invariant_1_2 where
   "invariant_1_2 rai \<equiv> invariant_1 rai \<and> degree (poly_real_alg_1 rai) > 1"
 
 definition poly_cond2 where "poly_cond2 p \<equiv> poly_cond p \<and> degree p > 1"
 
 lemma poly_cond2I[intro!]: "poly_cond p \<Longrightarrow> degree p > 1 \<Longrightarrow> poly_cond2 p" by (simp add: poly_cond2_def)
 
 lemma poly_cond2D:
   assumes "poly_cond2 p"
   shows "poly_cond p" and "degree p > 1" using assms by (auto simp: poly_cond2_def)
 
 lemma poly_cond2E[elim!]:
   assumes "poly_cond2 p" and "poly_cond p \<Longrightarrow> degree p > 1 \<Longrightarrow> thesis" shows thesis
   using assms by (auto simp: poly_cond2_def)
 
 lemma invariant_1_2_poly_cond2: "invariant_1_2 rai \<Longrightarrow> poly_cond2 (poly_real_alg_1 rai)"
   unfolding invariant_1_def invariant_1_2_def poly_cond2_def by auto
 
 lemma invariant_1_2I[intro!]:
   assumes "invariant_1 rai" and "degree (poly_real_alg_1 rai) > 1" shows "invariant_1_2 rai"
   using assms by (auto simp: invariant_1_2_def)
 
 lemma invariant_1_2E[elim!]:
   assumes "invariant_1_2 rai"
       and "invariant_1 rai \<Longrightarrow> degree (poly_real_alg_1 rai) > 1 \<Longrightarrow> thesis"
   shows thesis using assms[unfolded invariant_1_2_def] by auto
 
 
 lemma invariant_1_2_realI:
   fixes plr :: real_alg_1
   defines "p \<equiv> poly_real_alg_1 plr" and "l \<equiv> rai_lb plr" and "r \<equiv> rai_ub plr"
   assumes x: "root_cond plr x" and sgn: "sgn l = sgn r" and ur: "unique_root plr" and p: "poly_cond2 p"
   shows "invariant_1_2 plr \<and> real_of_1 plr = x"
   using invariant_1_realI[OF x] p sgn ur unfolding p_def l_def r_def by auto
   
 subsection \<open>Real Algebraic Numbers = Rational + Irrational Real Algebraic Numbers\<close>
 
 text \<open>In the next representation of real algebraic numbers, we distinguish between
   rational and irrational numbers. The advantage is that whenever we only work on
   rational numbers, there is not much overhead involved in comparison to the 
   existing implementation of real numbers which just supports the rational numbers.
   For irrational numbers we additionally store the number of the root, counting from
   left to right. For instance $-\sqrt{2}$ and $\sqrt{2}$ would be root number 1 and 2
   of $x^2 - 2$.\<close>
 
 subsubsection \<open>Definitions and Algorithms on Raw Type\<close>
 datatype real_alg_2 = Rational rat | Irrational nat real_alg_1
 
   
 fun invariant_2 :: "real_alg_2 \<Rightarrow> bool" where 
   "invariant_2 (Irrational n rai) = (invariant_1_2 rai
     \<and> n = card(roots_below (poly_real_alg_1 rai) (real_of_1 rai)))"
 | "invariant_2 (Rational r) = True"
   
 fun real_of_2 :: "real_alg_2 \<Rightarrow> real" where
   "real_of_2 (Rational r) = of_rat r"
 | "real_of_2 (Irrational n rai) = real_of_1 rai"
 
 definition of_rat_2 :: "rat \<Rightarrow> real_alg_2" where
   [code_unfold]: "of_rat_2 = Rational"
 
 lemma of_rat_2: "real_of_2 (of_rat_2 x) = of_rat x" "invariant_2 (of_rat_2 x)"
   by (auto simp: of_rat_2_def)
 
 (* Invariant type *)
 typedef real_alg_3 = "Collect invariant_2" 
   morphisms rep_real_alg_3 Real_Alg_Invariant 
   by (rule exI[of _ "Rational 0"], auto)
 
 setup_lifting type_definition_real_alg_3
 
 lift_definition real_of_3 :: "real_alg_3 \<Rightarrow> real" is real_of_2 .
 
 (* *************** *)
 subsubsection \<open>Definitions and Algorithms on Quotient Type\<close>
 
 quotient_type real_alg = real_alg_3 / "\<lambda> x y. real_of_3 x = real_of_3 y"
   morphisms rep_real_alg Real_Alg_Quotient
   by (auto simp: equivp_def) metis
 
 (* real_of *)
 lift_definition real_of :: "real_alg \<Rightarrow> real" is real_of_3 .
 
 lemma real_of_inj: "(real_of x = real_of y) = (x = y)"
   by (transfer, simp)
 
 (* ********************** *)
 subsubsection \<open>Sign\<close>
 
 definition sgn_1 :: "real_alg_1 \<Rightarrow> rat" where
   "sgn_1 x = sgn (rai_ub x)" 
 
 lemma sgn_1: "invariant_1 x \<Longrightarrow> real_of_rat (sgn_1 x) = sgn (real_of_1 x)"
   unfolding sgn_1_def by auto
 
 lemma sgn_1_inj: "invariant_1 x \<Longrightarrow> invariant_1 y \<Longrightarrow> real_of_1 x = real_of_1 y \<Longrightarrow> sgn_1 x = sgn_1 y"
   by (auto simp: sgn_1_def elim!: invariant_1E)
 
 (* ********************** *)
 subsubsection \<open>Normalization: Bounds Close Together\<close>
 
 lemma unique_root_lr: assumes ur: "unique_root plr" shows "rai_lb plr \<le> rai_ub plr" (is "?l \<le> ?r")
 proof -
   let ?p = "poly_real_alg_1 plr"
   from ur[unfolded root_cond_def]
   have ex1: "\<exists>! x :: real. of_rat ?l \<le> x \<and> x \<le> of_rat ?r \<and> ipoly ?p x = 0" by (cases plr, simp)
   then obtain x :: real where bnd: "of_rat ?l \<le> x" "x \<le> of_rat ?r" and rt: "ipoly ?p x = 0" by auto
   from bnd have "real_of_rat ?l \<le> of_rat ?r" by linarith
   thus "?l \<le> ?r" by (simp add: of_rat_less_eq)
 qed
 
 locale map_poly_zero_hom_0 = base: zero_hom_0
 begin
   sublocale zero_hom_0 "map_poly hom" by (unfold_locales,auto)
 end
 interpretation of_int_poly_hom:
   map_poly_zero_hom_0 "of_int :: int \<Rightarrow> 'a :: {ring_1, ring_char_0}" ..
 
 lemma ipoly_roots_finite: "p \<noteq> 0 \<Longrightarrow> finite {x :: 'a :: {idom, ring_char_0}. ipoly p x = 0}"
   by (rule poly_roots_finite, simp)
 
 
 lemma roots_below_the_unique_root:
   assumes ur: "unique_root (p,l,r)"
   shows "roots_below p (the_unique_root (p,l,r)) = roots_below p (of_rat r)" (is "roots_below p ?x = _")
 proof-
   from ur have rc: "root_cond (p,l,r) ?x" by (auto dest!: unique_rootD)
   with ur have x: "{x. root_cond (p,l,r) x} = {?x}" by (auto intro: the_unique_root_eqI)
   from rc have "?x \<in> {y. ?x \<le> y \<and> y \<le> of_rat r \<and> ipoly p y = 0}" by auto
   with rc have l1x: "... = {?x}" by (intro equalityI, fold x(1), force, simp add: x)
 
   have rb:"roots_below p (of_rat r) = roots_below p ?x \<union> {y. ?x < y \<and> y \<le> of_rat r \<and> ipoly p y = 0}"
     using rc by auto
   have emp: "\<And>x. the_unique_root (p, l, r) < x \<Longrightarrow>
                   x \<notin> {ra. ?x \<le> ra \<and> ra \<le> real_of_rat r \<and> ipoly p ra = 0}"
     using l1x by auto
   with rb show ?thesis by auto
 qed
 
 lemma unique_root_sub_interval:
   assumes ur: "unique_root (p,l,r)"
       and rc: "root_cond (p,l',r') (the_unique_root (p,l,r))"
       and between: "l \<le> l'" "r' \<le> r"
   shows "unique_root (p,l',r')"
     and "the_unique_root (p,l',r') = the_unique_root (p,l,r)"
 proof -
   from between have ord: "real_of_rat l \<le> of_rat l'" "real_of_rat r' \<le> of_rat r" by (auto simp: of_rat_less_eq)
   from rc have lr': "real_of_rat l' \<le> of_rat r'" by auto
   with ord have lr: "real_of_rat l \<le> real_of_rat r" by auto
   show "\<exists>!x. root_cond (p, l', r') x"
   proof (rule, rule rc)
     fix y
     assume "root_cond (p,l',r') y"
     with ord have "root_cond (p,l,r) y" by (auto intro!:root_condI)
     from the_unique_root_eqI[OF ur this] show "y = the_unique_root (p,l,r)" by simp
   qed
   from the_unique_root_eqI[OF this rc] 
   show "the_unique_root (p,l',r') = the_unique_root (p,l,r)" by simp
 qed
 
 lemma invariant_1_sub_interval:
   assumes rc: "invariant_1 (p,l,r)"
       and sub: "root_cond (p,l',r') (the_unique_root (p,l,r))"
       and between: "l \<le> l'" "r' \<le> r"
   shows "invariant_1 (p,l',r')" and "real_of_1 (p,l',r') = real_of_1 (p,l,r)"
 proof -
   let ?r = real_of_rat
   note rcD = invariant_1D[OF rc]
   from rc
   have ur: "unique_root (p, l', r')"
     and id: "the_unique_root (p, l', r') = the_unique_root (p, l, r)"
     by (atomize(full), intro conjI unique_root_sub_interval[OF _ sub between], auto)
   show "real_of_1 (p,l',r') = real_of_1 (p,l,r)"
     using id by simp
   from rcD(1)[unfolded split] have "?r l \<le> ?r r" by auto
   hence lr: "l \<le> r" by (auto simp: of_rat_less_eq)
   from unique_rootD[OF ur] have "?r l' \<le> ?r r'" by auto
   hence lr': "l' \<le> r'" by (auto simp: of_rat_less_eq)
   have "sgn l' = sgn r'"
   proof (cases "r" "0::rat" rule: linorder_cases)
     case less
     with lr lr' between have "l < 0" "l' < 0" "r' < 0" "r < 0" by auto
     thus ?thesis unfolding sgn_rat_def by auto
   next
     case equal with rcD(2) have "l = 0" using sgn_0_0 by auto
     with equal between lr' have "l' = 0" "r' = 0" by auto then show ?thesis by auto
   next
     case greater
     with rcD(4) have "sgn r = 1" unfolding sgn_rat_def by (cases "r = 0", auto)
     with rcD(2) have "sgn l = 1" by simp
     hence l: "l > 0" unfolding sgn_rat_def by (cases "l = 0"; cases "l < 0"; auto)
     with lr lr' between have "l > 0" "l' > 0" "r' > 0" "r > 0" by auto
     thus ?thesis unfolding sgn_rat_def by auto
   qed
   with between ur rc show "invariant_1 (p,l',r')" by (auto simp add: invariant_1_def id)
 qed
 
 lemma root_sign_change: assumes
     p0: "poly (p::real poly) x = 0" and
     pd_ne0: "poly (pderiv p) x \<noteq> 0"
   obtains d where
     "0 < d"
     "sgn (poly p (x - d)) \<noteq> sgn (poly p (x + d))"
     "sgn (poly p (x - d)) \<noteq> 0"
     "0 \<noteq> sgn (poly p (x + d))"
     "\<forall> d' > 0. d' \<le> d \<longrightarrow> sgn (poly p (x + d')) = sgn (poly p (x + d)) \<and> sgn (poly p (x - d')) = sgn (poly p (x - d))"
 proof -
   assume a:"(\<And>d. 0 < d \<Longrightarrow>
           sgn (poly p (x - d)) \<noteq> sgn (poly p (x + d)) \<Longrightarrow>
           sgn (poly p (x - d)) \<noteq> 0 \<Longrightarrow>
           0 \<noteq> sgn (poly p (x + d)) \<Longrightarrow>
           \<forall>d'>0. d' \<le> d \<longrightarrow>
                  sgn (poly p (x + d')) = sgn (poly p (x + d)) \<and> sgn (poly p (x - d')) = sgn (poly p (x - d)) \<Longrightarrow>
           thesis)"
   from pd_ne0 consider "poly (pderiv p) x > 0" | "poly (pderiv p) x < 0" by linarith
   thus ?thesis proof(cases)
     case 1
     obtain d1 where d1:"\<And>h. 0<h \<Longrightarrow> h < d1 \<Longrightarrow> poly p (x - h) < 0" "d1 > 0"
       using DERIV_pos_inc_left[OF poly_DERIV 1] p0 by auto
     obtain d2 where d2:"\<And>h. 0<h \<Longrightarrow> h < d2 \<Longrightarrow> poly p (x + h) > 0" "d2 > 0"
       using DERIV_pos_inc_right[OF poly_DERIV 1] p0 by auto
     have g0:"0 < (min d1 d2) / 2" using d1 d2 by auto
     hence m1:"min d1 d2 / 2 < d1" and m2:"min d1 d2 / 2 < d2" by auto
     { fix d
       assume a1:"0 < d" and a2:"d < min d1 d2"
       have "sgn (poly p (x - d)) = -1" "sgn (poly p (x + d)) = 1"
         using d1(1)[OF a1] d2(1)[OF a1] a2 by auto
     } note d=this
     show ?thesis by(rule a[OF g0];insert d g0 m1 m2, simp)
   next
     case 2
     obtain d1 where d1:"\<And>h. 0<h \<Longrightarrow> h < d1 \<Longrightarrow> poly p (x - h) > 0" "d1 > 0"
       using DERIV_neg_dec_left[OF poly_DERIV 2] p0 by auto
     obtain d2 where d2:"\<And>h. 0<h \<Longrightarrow> h < d2 \<Longrightarrow> poly p (x + h) < 0" "d2 > 0"
       using DERIV_neg_dec_right[OF poly_DERIV 2] p0 by auto
     have g0:"0 < (min d1 d2) / 2" using d1 d2 by auto
     hence m1:"min d1 d2 / 2 < d1" and m2:"min d1 d2 / 2 < d2" by auto
     { fix d
       assume a1:"0 < d" and a2:"d < min d1 d2"
       have "sgn (poly p (x - d)) = 1" "sgn (poly p (x + d)) = -1"
         using d1(1)[OF a1] d2(1)[OF a1] a2 by auto
     } note d=this
     show ?thesis by(rule a[OF g0];insert d g0 m1 m2, simp)
   qed
 qed
 
 lemma rational_root_free_degree_iff: assumes rf: "root_free (map_poly rat_of_int p)" and rt: "ipoly p x = 0"
   shows "(x \<in> \<rat>) = (degree p = 1)"
 proof 
   assume "x \<in> \<rat>"
   then obtain y where x: "x = of_rat y" (is "_ = ?x") unfolding Rats_def by blast
   from rt[unfolded x] have "poly (map_poly rat_of_int p) y = 0" by simp
   with rf show "degree p = 1" unfolding root_free_def by auto
 next
   assume "degree p = 1"
   from degree1_coeffs[OF this]
   obtain a b where p: "p = [:a,b:]" and b: "b \<noteq> 0" by auto
   from rt[unfolded p hom_distribs] have "of_int a + x * of_int b = 0" by auto
   from arg_cong[OF this, of "\<lambda> x. (x - of_int a) / of_int b"]
   have "x = - of_rat (of_int a) / of_rat (of_int b)" using b by auto
   also have "\<dots> = of_rat (- of_int a / of_int b)" unfolding of_rat_minus of_rat_divide ..
   finally show "x \<in> \<rat>" by auto
 qed
 
 lemma rational_poly_cond_iff: assumes "poly_cond p" and "ipoly p x = 0" and "degree p > 1"
   shows "(x \<in> \<rat>) = (degree p = 1)"
 proof (rule rational_root_free_degree_iff[OF _ assms(2)])
   from poly_condD[OF assms(1)] irreducible_connect_rev[of p] assms(3)
   have p: "irreducible\<^sub>d p" by auto
   from irreducible\<^sub>d_int_rat[OF this]
   have "irreducible (map_poly rat_of_int p)" by simp
   thus "root_free (map_poly rat_of_int p)" by (rule irreducible_root_free) 
 qed
 
 lemma poly_cond_degree_gt_1: assumes "poly_cond p" "degree p > 1" "ipoly p x = 0"
   shows "x \<notin> \<rat>" 
   using rational_poly_cond_iff[OF assms(1,3)] assms(2) by simp
 
 lemma poly_cond2_no_rat_root: assumes "poly_cond2 p" 
   shows "ipoly p (real_of_rat x) \<noteq> 0"
   using poly_cond_degree_gt_1[of p "real_of_rat x"] assms by auto
 
 context 
   fixes p :: "int poly"
   and x :: "rat"
 begin
   
 lemma gt_rat_sign_change:
   assumes ur: "unique_root plr"
   defines "p \<equiv> poly_real_alg_1 plr" and "l \<equiv> rai_lb plr" and "r \<equiv> rai_ub plr"
   assumes p: "poly_cond2 p" and in_interval: "l \<le> y" "y \<le> r"
 shows "(sgn (ipoly p y) = sgn (ipoly p r)) = (of_rat y > the_unique_root plr)" (is "?gt = _")
 proof (rule ccontr)
   have plr[simp]: "plr = (p,l,r)" by (cases plr, auto simp: p_def l_def r_def)
   assume "?gt \<noteq> (real_of_rat y > the_unique_root plr)"
   note a = this[unfolded plr]
   from p have "irreducible p" by auto
   note nz = poly_cond2_no_rat_root[OF p]
   hence "p \<noteq> 0" unfolding irreducible_def by auto
   hence p0_real: "real_of_int_poly p \<noteq> (0::real poly)" by auto
   let ?p = "real_of_int_poly p"
   note urD = unique_rootD[OF ur, simplified]
   let ?ur = "the_unique_root (p, l, r)"
   let ?r = real_of_rat
   from poly_cond2_no_rat_root p
   have ru:"ipoly p y \<noteq> 0" by auto
   from in_interval have in':"?r l \<le> ?r y" "?r y \<le> ?r r" unfolding of_rat_less_eq by auto
   from p square_free_of_int_poly[of p] square_free_rsquarefree
   have rsf:"rsquarefree ?p" by auto
   have ur3:"poly ?p ?ur = 0" using urD(3) by simp
   from ur have "?ur \<le> of_rat r" by (auto elim!: unique_rootE)
   moreover
     from nz have "ipoly p (real_of_rat r) \<noteq> 0" by auto
     with ur3 have "real_of_rat r \<noteq> real_of_1 (p,l,r)" by force
   ultimately have "?ur < ?r r" by auto
   hence ur2: "0 < ?r r - ?ur" by linarith
   from rsquarefree_roots rsf ur3
   have pd_nonz:"poly (pderiv ?p) ?ur \<noteq> 0" by auto
   obtain d where d':"\<And>d'. d'>0 \<Longrightarrow> d' \<le> d \<Longrightarrow>
              sgn (poly ?p (?ur + d')) = sgn (poly ?p (?ur + d)) \<and>
              sgn (poly ?p (?ur - d')) = sgn (poly ?p (?ur - d))"
       "sgn (poly ?p (?ur - d)) \<noteq> sgn (poly ?p (?ur + d))"
       "sgn (poly ?p (?ur + d)) \<noteq> 0"
       and d_ge_0:"d > 0"
     by (metis root_sign_change[OF ur3 pd_nonz])
   have sr:"sgn (poly ?p (?ur + d)) = sgn (poly ?p (?r r))"
   proof (cases "?r r - ?ur \<le> d")
     case True show ?thesis using d'(1)[OF ur2 True] by auto
   next
     case False hence less:"?ur + d < ?r r" by auto
     show ?thesis
     proof(rule no_roots_inbetween_imp_same_sign[OF less,rule_format],goal_cases)
       case (1 x)
       from ur 1 d_ge_0 have ran: "real_of_rat l \<le> x" "x \<le> real_of_rat r" by (auto elim!: unique_rootE)
       from 1 d_ge_0 have "the_unique_root (p, l, r) \<noteq> x" by auto
       with ur have "\<not> root_cond (p,l,r) x" by auto
       with ran show ?case by auto
     qed
   qed
   consider "?r l < ?ur - d" "?r l < ?ur" | "0 < ?ur - ?r l" "?ur - ?r l \<le> d" | "?ur = ?r l"
     using urD by argo
   hence sl:"sgn (poly ?p (?ur - d)) = sgn (poly ?p (?r l)) \<or> 0 = sgn (poly ?p (?r l))"
   proof (cases)
     case 1
     have "sgn (poly ?p (?r l)) = sgn (poly ?p (?ur - d))"
     proof(rule no_roots_inbetween_imp_same_sign[OF 1(1),rule_format],goal_cases)
       case (1 x)
       from ur 1 d_ge_0 have ran: "real_of_rat l \<le> x" "x \<le> real_of_rat r" by (auto elim!: unique_rootE)
       from 1 d_ge_0 have "the_unique_root (p, l, r) \<noteq> x" by auto
       with ur have "\<not> root_cond (p,l,r) x" by auto
       with ran show ?case by auto
     qed
     thus ?thesis by auto
   next case 2 show ?thesis using d'(1)[OF 2] by simp
   qed (insert ur3,simp)
   have diff_sign: "sgn (ipoly p l) \<noteq> sgn (ipoly p r)"
     using d'(2-) sr sl real_of_rat_sgn by auto
   have ur':"\<And>x. real_of_rat l \<le> x \<and> x \<le> real_of_rat y \<Longrightarrow> ipoly p x = 0 \<Longrightarrow> \<not> (?r y \<le> the_unique_root (p,l,r))"
   proof(standard+,goal_cases)
     case (1 x)
     {
       assume id: "the_unique_root (p,l,r) = ?r y" 
       from nz[of y] id ur have False by (auto elim!: unique_rootE)
     } note neq = this
     have "root_cond (p, l, r) x" unfolding root_cond_def
       using 1 a ur by (auto elim!: unique_rootE)
     with conjunct2[OF 1(1)] 1(2-) the_unique_root_eqI[OF ur]
     show ?case by (auto intro!: neq)
   qed
   hence ur'':"\<forall>x. real_of_rat y \<le> x \<and> x \<le> real_of_rat r \<longrightarrow> poly (real_of_int_poly p) x \<noteq> 0 \<Longrightarrow> \<not> (?r y \<le> the_unique_root (p,l,r))"
     using urD(2,3) by auto
   have "(sgn (ipoly p y) = sgn (ipoly p r)) = (?r y > the_unique_root (p,l,r))"
   proof(cases "sgn (ipoly p r) = sgn (ipoly p y)")
     case True
     have sgn:"sgn (poly ?p (real_of_rat l)) \<noteq> sgn (poly ?p (real_of_rat y))" using True diff_sign
       by (simp add: real_of_rat_sgn)
     have ly:"of_rat l < (of_rat y::real)" using in_interval True diff_sign less_eq_rat_def of_rat_less by auto
     with no_roots_inbetween_imp_same_sign[OF ly,of ?p] sgn ur' True
     show ?thesis by force
   next
     case False
     hence ne:"sgn (ipoly p (real_of_rat y)) \<noteq> sgn (ipoly p (real_of_rat r))" by (simp add: real_of_rat_sgn)
     have ry:"of_rat y < (of_rat r::real)" using in_interval False diff_sign less_eq_rat_def of_rat_less by auto
     obtain x where x:"real_of_rat y \<le> x" "x \<le> real_of_rat r" "ipoly p x = 0"
       using no_roots_inbetween_imp_same_sign[OF ry,of ?p] ne by auto
     hence lx:"real_of_rat l \<le> x" using in_interval
       using False a urD by auto
     have "?ur = x" using x lx ur by (intro the_unique_root_eqI, auto)
     then show ?thesis using False x by auto
   qed
   thus False using diff_sign(1) a ru by(cases "ipoly p r = 0";auto simp:sgn_0_0)
 qed
   
 definition tighten_poly_bounds :: "rat \<Rightarrow> rat \<Rightarrow> rat \<Rightarrow> rat \<times> rat \<times> rat" where
   "tighten_poly_bounds l r sr = (let m = (l + r) / 2; sm = sgn (ipoly p m) in 
     if sm = sr
      then (l,m,sm) else (m,r,sr))"
 
 lemma tighten_poly_bounds: assumes res: "tighten_poly_bounds l r sr = (l',r',sr')"
   and ur: "unique_root (p,l,r)"
   and p:  "poly_cond2 p"   
   and sr: "sr = sgn (ipoly p r)" 
   shows "root_cond (p,l',r') (the_unique_root (p,l,r))" "l \<le> l'" "l' \<le> r'" "r' \<le> r" 
     "(r' - l') = (r - l) / 2" "sr' = sgn (ipoly p r')" 
 proof -
   let ?x = "the_unique_root (p,l,r)"
   let ?x' = "the_unique_root (p,l',r')"
   let ?m = "(l + r) / 2"
   note d = tighten_poly_bounds_def Let_def
   from unique_root_lr[OF ur] have lr: "l \<le> r" by auto
   thus "l \<le> l'" "l' \<le> r'" "r' \<le> r" "(r' - l') = (r - l) / 2" "sr' = sgn (ipoly p r')"
     using res sr unfolding d by (auto split: if_splits)
   hence "l \<le> ?m" "?m \<le> r" by auto
   note le = gt_rat_sign_change[OF ur,simplified,OF p this]
   note urD = unique_rootD[OF ur]
   show "root_cond (p,l',r') ?x"
   proof (cases "sgn (ipoly p ?m) = sgn (ipoly p r)")
     case *: False
     with res sr have id: "l' = ?m" "r' = r" unfolding d by auto
     from *[unfolded le] urD show ?thesis unfolding id by auto
   next
     case *: True 
     with res sr have id: "l' = l" "r' = ?m" unfolding d by auto
     from *[unfolded le] urD show ?thesis unfolding id by auto
   qed
 qed
 
 partial_function (tailrec) tighten_poly_bounds_epsilon :: "rat \<Rightarrow> rat \<Rightarrow> rat \<Rightarrow> rat \<times> rat \<times> rat" where
   [code]: "tighten_poly_bounds_epsilon l r sr = (if r - l \<le> x then (l,r,sr) else
     (case tighten_poly_bounds l r sr of (l',r',sr') \<Rightarrow> tighten_poly_bounds_epsilon l' r' sr'))"
     
 partial_function (tailrec) tighten_poly_bounds_for_x :: "rat \<Rightarrow> rat \<Rightarrow> rat \<Rightarrow>
   rat \<times> rat \<times> rat" where 
   [code]: "tighten_poly_bounds_for_x l r sr = (if x < l \<or> r < x then (l, r, sr) else
      (case tighten_poly_bounds l r sr of (l',r',sr') \<Rightarrow> tighten_poly_bounds_for_x l' r' sr'))"
 
 lemma tighten_poly_bounds_epsilon:
   assumes ur: "unique_root (p,l,r)"
   defines u: "u \<equiv> the_unique_root (p,l,r)"
   assumes p: "poly_cond2 p"
       and res: "tighten_poly_bounds_epsilon l r sr = (l',r',sr')"
       and sr: "sr = sgn (ipoly p r)" 
       and x: "x > 0"
   shows "l \<le> l'" "r' \<le> r" "root_cond (p,l',r') u" "r' - l' \<le> x" "sr' = sgn (ipoly p r')" 
 proof -
   let ?u = "the_unique_root (p,l,r)"
   define delta where "delta = x / 2"
   have delta: "delta > 0" unfolding delta_def using x by auto
   let ?dist = "\<lambda> (l,r,sr). r - l"
   let ?rel = "inv_image {(x, y). 0 \<le> y \<and> delta_gt delta x y} ?dist"
   note SN = SN_inv_image[OF delta_gt_SN[OF delta], of ?dist]
   note simps = res[unfolded tighten_poly_bounds_for_x.simps[of l r]]
   let ?P = "\<lambda> (l,r,sr). unique_root (p,l,r) \<longrightarrow> u = the_unique_root (p,l,r) 
     \<longrightarrow> tighten_poly_bounds_epsilon l r sr = (l',r',sr') 
     \<longrightarrow> sr = sgn (ipoly p r)
     \<longrightarrow> l \<le> l' \<and> r' \<le> r \<and> r' - l' \<le> x \<and> root_cond (p,l',r') u \<and> sr' = sgn (ipoly p r')"
   have "?P (l,r,sr)"
   proof (induct rule: SN_induct[OF SN])
     case (1 lr)
     obtain l r sr where lr: "lr = (l,r,sr)" by (cases lr, auto)
     show ?case unfolding lr split
     proof (intro impI)
       assume ur: "unique_root (p, l, r)"
         and u: "u = the_unique_root (p, l, r)"
         and res: "tighten_poly_bounds_epsilon l r sr = (l', r', sr')"
         and sr: "sr = sgn (ipoly p r)" 
       note tur = unique_rootD[OF ur]
       note simps = tighten_poly_bounds_epsilon.simps[of l r sr]
       show "l \<le> l' \<and> r' \<le> r \<and> r' - l' \<le> x \<and> root_cond (p, l', r') u \<and> sr' = sgn (ipoly p r')"
       proof (cases "r - l \<le> x")
         case True
         with res[unfolded simps] ur tur(4) u sr
         show ?thesis by auto
       next
         case False 
         hence x: "r - l > x" by auto
         let ?tight = "tighten_poly_bounds l r sr"
         obtain L R SR where tight: "?tight = (L,R,SR)" by (cases ?tight, auto)
         note tighten = tighten_poly_bounds[OF tight[unfolded sr] ur p]
         from unique_root_sub_interval[OF ur tighten(1-2,4)] p
         have ur': "unique_root (p,L,R)" "u = the_unique_root (p,L,R)" unfolding u by auto
         from res[unfolded simps tight] False sr have "tighten_poly_bounds_epsilon L R SR = (l',r',sr')" by auto
         note IH = 1[of "(L,R,SR)", unfolded tight split lr, rule_format, OF _ ur' this]
         have "L \<le> l' \<and> r' \<le> R \<and> r' - l' \<le> x \<and> root_cond (p, l', r') u \<and> sr' = sgn (ipoly p r')"
           by (rule IH, insert tighten False, auto simp: delta_gt_def delta_def)
         thus ?thesis using tighten by auto
       qed
     qed
   qed
   from this[unfolded split u, rule_format, OF ur refl res sr] 
   show "l \<le> l'" "r' \<le> r" "root_cond (p,l',r') u" "r' - l' \<le> x" "sr' = sgn (ipoly p r')" using u by auto
 qed
 
 lemma tighten_poly_bounds_for_x:
   assumes ur: "unique_root (p,l,r)"
   defines u: "u \<equiv> the_unique_root (p,l,r)"
   assumes p: "poly_cond2 p" 
       and res: "tighten_poly_bounds_for_x l r sr = (l',r',sr')"
       and sr: "sr = sgn (ipoly p r)" 
   shows "l \<le> l'" "l' \<le> r'" "r' \<le> r" "root_cond (p,l',r') u" "\<not> (l' \<le> x \<and> x \<le> r')" "sr' = sgn (ipoly p r')" "unique_root (p,l',r')"
 proof -
   let ?u = "the_unique_root (p,l,r)"
   let ?x = "real_of_rat x"
   define delta where "delta = abs ((u - ?x) / 2)"
   let ?p = "real_of_int_poly p"
   note ru = unique_rootD[OF ur]
   {
     assume "u = ?x"
     note u = this[unfolded u]
     from poly_cond2_no_rat_root[OF p] ur have False by (elim unique_rootE, auto simp: u)
   }
   hence delta: "delta > 0" unfolding delta_def by auto
   let ?dist = "\<lambda> (l,r,sr). real_of_rat (r - l)"
   let ?rel = "inv_image {(x, y). 0 \<le> y \<and> delta_gt delta x y} ?dist"
   note SN = SN_inv_image[OF delta_gt_SN[OF delta], of ?dist]
   note simps = res[unfolded tighten_poly_bounds_for_x.simps[of l r]]
   let ?P = "\<lambda> (l,r,sr). unique_root (p,l,r) \<longrightarrow> u = the_unique_root (p,l,r) 
     \<longrightarrow> tighten_poly_bounds_for_x l r sr = (l',r',sr') 
     \<longrightarrow> sr = sgn (ipoly p r)
     \<longrightarrow> l \<le> l' \<and> r' \<le> r \<and> \<not> (l' \<le> x \<and> x \<le> r') \<and> root_cond (p,l',r') u \<and> sr' = sgn (ipoly p r')"
   have "?P (l,r,sr)"
   proof (induct rule: SN_induct[OF SN])
     case (1 lr)
     obtain l r sr where lr: "lr = (l,r,sr)" by (cases lr, auto)
     let ?l = "real_of_rat l"
     let ?r = "real_of_rat r"
     show ?case unfolding lr split
     proof (intro impI)
       assume ur: "unique_root (p, l, r)"
         and u: "u = the_unique_root (p, l, r)"
         and res: "tighten_poly_bounds_for_x l r sr = (l', r', sr')"
         and sr: "sr = sgn (ipoly p r)" 
       note tur = unique_rootD[OF ur]
       note simps = tighten_poly_bounds_for_x.simps[of l r]
       show "l \<le> l' \<and> r' \<le> r \<and> \<not> (l' \<le> x \<and> x \<le> r') \<and> root_cond (p, l', r') u \<and> sr' = sgn (ipoly p r')"
       proof (cases "x < l \<or> r < x")
         case True
         with res[unfolded simps] ur tur(4) u sr
         show ?thesis by auto
       next
         case False 
         hence x: "?l \<le> ?x" "?x \<le> ?r" by (auto simp: of_rat_less_eq)
         let ?tight = "tighten_poly_bounds l r sr"
         obtain L R SR where tight: "?tight = (L,R,SR)" by (cases ?tight, auto)
         note tighten = tighten_poly_bounds[OF tight ur p sr]
         from unique_root_sub_interval[OF ur tighten(1-2,4)] p
         have ur': "unique_root (p,L,R)" "u = the_unique_root (p,L,R)" unfolding u by auto
         from res[unfolded simps tight] False have "tighten_poly_bounds_for_x L R SR = (l',r',sr')" by auto
         note IH = 1[of ?tight, unfolded tight split lr, rule_format, OF _ ur' this]
         let ?DIFF = "real_of_rat (R - L)" let ?diff = "real_of_rat (r - l)"
         have diff0: "0 \<le> ?DIFF" using tighten(3)
           by (metis cancel_comm_monoid_add_class.diff_cancel diff_right_mono of_rat_less_eq of_rat_hom.hom_zero)
         have *: "r - l - (r - l) / 2 = (r - l) / 2" by (auto simp: field_simps)
         have "delta_gt delta ?diff ?DIFF = (abs (u - of_rat x) \<le> real_of_rat (r - l) * 1)"
           unfolding delta_gt_def tighten(5) delta_def of_rat_diff[symmetric] * by (simp add: hom_distribs)
         also have "real_of_rat (r - l) * 1 = ?r - ?l" 
           unfolding of_rat_divide of_rat_mult of_rat_diff by auto
         also have "abs (u - of_rat x) \<le> ?r - ?l" using x ur by (elim unique_rootE, auto simp: u)
         finally have delta: "delta_gt delta ?diff ?DIFF" .
         have "L \<le> l' \<and> r' \<le> R \<and> \<not> (l' \<le> x \<and> x \<le> r') \<and> root_cond (p, l', r') u \<and> sr' = sgn (ipoly p r')"
           by (rule IH, insert delta diff0 tighten(6), auto)
         with \<open>l \<le> L\<close> \<open>R \<le> r\<close> show ?thesis by auto
       qed
     qed
   qed
   from this[unfolded split u, rule_format, OF ur refl res sr] 
   show *: "l \<le> l'" "r' \<le> r" "root_cond (p,l',r') u" "\<not> (l' \<le> x \<and> x \<le> r')" "sr' = sgn (ipoly p r')" unfolding u 
     by auto
   from *(3)[unfolded split] have "real_of_rat l' \<le> of_rat r'" by auto
   thus "l' \<le> r'" unfolding of_rat_less_eq .
   show "unique_root (p,l',r')" using ur *(1-3) p poly_condD(5) u unique_root_sub_interval(1) by blast
 qed
 end
 
 definition real_alg_precision :: rat where
   "real_alg_precision \<equiv> Rat.Fract 1 2"
 
 lemma real_alg_precision: "real_alg_precision > 0" 
   by eval
 
 definition normalize_bounds_1_main :: "rat \<Rightarrow> real_alg_1 \<Rightarrow> real_alg_1" where
   "normalize_bounds_1_main eps rai = (case rai of (p,l,r) \<Rightarrow>
     let (l',r',sr') = tighten_poly_bounds_epsilon p eps l r (sgn (ipoly p r));
         fr = rat_of_int (floor r');
         (l'',r'',_) = tighten_poly_bounds_for_x p fr l' r' sr'
     in (p,l'',r''))"
 
 definition normalize_bounds_1 :: "real_alg_1 \<Rightarrow> real_alg_1" where 
   "normalize_bounds_1 = (normalize_bounds_1_main real_alg_precision)"
 
 context
   fixes p q and l r :: rat
   assumes cong: "\<And> x. real_of_rat l \<le> x \<Longrightarrow> x \<le> of_rat r \<Longrightarrow> (ipoly p x = (0 :: real)) = (ipoly q x = 0)"
 begin
 lemma root_cond_cong: "root_cond (p,l,r) = root_cond (q,l,r)"
   by (intro ext, insert cong, auto simp: root_cond_def)
 
 lemma the_unique_root_cong: 
   "the_unique_root (p,l,r) = the_unique_root (q,l,r)"
   unfolding root_cond_cong ..
 
 lemma unique_root_cong: 
   "unique_root (p,l,r) = unique_root (q,l,r)"
   unfolding root_cond_cong ..
 end
 
 lemma normalize_bounds_1_main: assumes eps: "eps > 0" and rc: "invariant_1_2 x"
   defines y: "y \<equiv> normalize_bounds_1_main eps x"
   shows "invariant_1_2 y \<and> (real_of_1 y = real_of_1 x)"
 proof -
   obtain p l r where x: "x = (p,l,r)" by (cases x) auto
   note rc = rc[unfolded x]
   obtain l' r' sr' where tb: "tighten_poly_bounds_epsilon p eps l r (sgn (ipoly p r)) = (l',r',sr')" 
     by (cases rule: prod_cases3, auto)
   let ?fr = "rat_of_int (floor r')"
   obtain l'' r'' sr'' where tbx: "tighten_poly_bounds_for_x p ?fr l' r' sr' = (l'',r'',sr'')"
     by (cases rule: prod_cases3, auto)
   from y[unfolded normalize_bounds_1_main_def x] tb tbx
   have y: "y = (p, l'', r'')" 
     by (auto simp: Let_def)
   from rc have "unique_root (p, l, r)" and p2: "poly_cond2 p" by auto
   from tighten_poly_bounds_epsilon[OF this tb refl eps]
   have bnd: "l \<le> l'" "r' \<le> r" and rc': "root_cond (p, l', r') (the_unique_root (p, l, r))" 
     and eps: "r' - l' \<le> eps" (* currently not relevant for lemma *)
     and sr': "sr' = sgn (ipoly p r')" by auto
   from invariant_1_sub_interval[OF _ rc' bnd] rc
   have inv': "invariant_1 (p, l', r')" and eq: "real_of_1 (p, l', r') = real_of_1 (p, l, r)" by auto
   have bnd: "l' \<le> l''" "r'' \<le> r'" and rc': "root_cond (p, l'', r'') (the_unique_root (p, l', r'))"
     by (rule tighten_poly_bounds_for_x[OF _ p2 tbx sr'], fact invariant_1D[OF inv'])+
   from invariant_1_sub_interval[OF inv' rc' bnd] p2 eq
   show ?thesis unfolding y x by auto
 qed
 
 lemma normalize_bounds_1: assumes x: "invariant_1_2 x"
   shows "invariant_1_2 (normalize_bounds_1 x) \<and> (real_of_1 (normalize_bounds_1 x) = real_of_1 x)" 
 proof(cases x)
   case xx:(fields p l r)
   let ?res = "(p,l,r)"
   have norm: "normalize_bounds_1 x = (normalize_bounds_1_main real_alg_precision ?res)" 
     unfolding normalize_bounds_1_def by (simp add: xx)
   from x have x: "invariant_1_2 ?res" "real_of_1 ?res = real_of_1 x" unfolding xx by auto
   from normalize_bounds_1_main[OF real_alg_precision x(1)] x(2-)
   show ?thesis unfolding normalize_bounds_1_def xx by auto
 qed
   
 lemma normalize_bound_1_poly: "poly_real_alg_1 (normalize_bounds_1 rai) = poly_real_alg_1 rai" 
   unfolding normalize_bounds_1_def normalize_bounds_1_main_def Let_def
   by (auto split: prod.splits)
 
 definition real_alg_2_main :: "root_info \<Rightarrow> real_alg_1 \<Rightarrow> real_alg_2" where 
   "real_alg_2_main ri rai \<equiv> let p = poly_real_alg_1 rai
      in (if degree p = 1 then Rational (Rat.Fract (- coeff p 0) (coeff p 1))
        else (case normalize_bounds_1 rai of (p',l,r) \<Rightarrow>
        Irrational (root_info.number_root ri r) (p',l,r)))"
 
 definition real_alg_2 :: "real_alg_1 \<Rightarrow> real_alg_2" where 
   "real_alg_2 rai \<equiv> let p = poly_real_alg_1 rai
      in (if degree p = 1 then Rational (Rat.Fract (- coeff p 0) (coeff p 1))
        else (case normalize_bounds_1 rai of (p',l,r) \<Rightarrow>
        Irrational (root_info.number_root (root_info p) r) (p',l,r)))"
 
 lemma degree_1_ipoly: assumes "degree p = Suc 0"
   shows "ipoly p x = 0 \<longleftrightarrow> (x = real_of_rat (Rat.Fract (- coeff p 0) (coeff p 1)))"
 proof -
   from roots1[of "map_poly real_of_int p"] assms
   have "ipoly p x = 0 \<longleftrightarrow> x \<in> {roots1 (real_of_int_poly p)}" by auto
   also have "\<dots> = (x = real_of_rat (Rat.Fract (- coeff p 0) (coeff p 1)))" 
     unfolding Fract_of_int_quotient roots1_def hom_distribs
     by auto
   finally show ?thesis .
 qed
 
 lemma invariant_1_degree_0:
   assumes inv: "invariant_1 rai"
   shows "degree (poly_real_alg_1 rai) \<noteq> 0" (is "degree ?p \<noteq> 0")
 proof (rule notI)
   assume deg: "degree ?p = 0"
   from inv have "ipoly ?p (real_of_1 rai) = 0" by auto
   with deg have "?p = 0" by (meson less_Suc0 representsI represents_degree)
   with inv show False by auto
 qed
 
 lemma real_alg_2_main:
   assumes inv: "invariant_1 rai"
   defines [simp]: "p \<equiv> poly_real_alg_1 rai"
   assumes ric: "irreducible (poly_real_alg_1 rai) \<Longrightarrow> root_info_cond ri (poly_real_alg_1 rai)" 
   shows "invariant_2 (real_alg_2_main ri rai)" "real_of_2 (real_alg_2_main ri rai) = real_of_1 rai"
 proof (atomize(full))
   define l r where [simp]: "l \<equiv> rai_lb rai" and [simp]: "r \<equiv> rai_ub rai"
   show "invariant_2 (real_alg_2_main ri rai) \<and> real_of_2 (real_alg_2_main ri rai) = real_of_1 rai" 
     unfolding id using invariant_1D
   proof (cases "degree p" "Suc 0" rule: linorder_cases)
     case deg: equal
     hence id: "real_alg_2_main ri rai = Rational (Rat.Fract (- coeff p 0) (coeff p 1))" 
       unfolding real_alg_2_main_def Let_def by auto
     note rc = invariant_1D[OF inv]
     from degree_1_ipoly[OF deg, of "the_unique_root rai"] rc(1)
     show ?thesis unfolding id by auto
   next
     case deg: greater
     with inv have inv: "invariant_1_2 rai" unfolding p_def by auto
     define rai' where "rai' = normalize_bounds_1 rai"
     have rai': "real_of_1 rai = real_of_1 rai'" and inv': "invariant_1_2 rai'" 
       unfolding rai'_def using normalize_bounds_1[OF inv] by auto
     obtain p' l' r' where "rai' = (p',l',r')" by (cases rai')
     with arg_cong[OF rai'_def, of poly_real_alg_1, unfolded normalize_bound_1_poly] split
     have split: "rai' = (p,l',r')" by auto
     from inv'[unfolded split]
     have "poly_cond p" by auto
     from poly_condD[OF this] have irr: "irreducible p" by simp
     from ric irr have ric: "root_info_cond ri p" by auto
     have id: "real_alg_2_main ri rai = (Irrational (root_info.number_root ri r') rai')" 
       unfolding real_alg_2_main_def Let_def using deg split rai'_def
       by (auto simp: rai'_def rai')
     show ?thesis unfolding id using rai' root_info_condD(2)[OF ric] 
          inv'[unfolded split]
       apply (elim invariant_1_2E invariant_1E) using inv'
       by(auto simp: split roots_below_the_unique_root)
   next
     case deg: less then have "degree p = 0" by auto
     from this invariant_1_degree_0[OF inv] have "p = 0" by simp
     with inv show ?thesis by auto
   qed
 qed
 
 lemma real_alg_2: assumes "invariant_1 rai" 
   shows "invariant_2 (real_alg_2 rai)" "real_of_2 (real_alg_2 rai) = real_of_1 rai"
 proof -
   have deg: "0 < degree (poly_real_alg_1 rai)" using assms by auto
   have "real_alg_2 rai = real_alg_2_main (root_info (poly_real_alg_1 rai)) rai" 
     unfolding real_alg_2_def real_alg_2_main_def Let_def by auto
   from real_alg_2_main[OF assms root_info, folded this, simplified] deg
   show "invariant_2 (real_alg_2 rai)" "real_of_2 (real_alg_2 rai) = real_of_1 rai" by auto
 qed
 
 lemma invariant_2_realI:
   fixes plr :: real_alg_1
   defines "p \<equiv> poly_real_alg_1 plr" and "l \<equiv> rai_lb plr" and "r \<equiv> rai_ub plr"
   assumes x: "root_cond plr x" and sgn: "sgn l = sgn r"
       and ur: "unique_root plr"
       and p: "poly_cond p"
   shows "invariant_2 (real_alg_2 plr) \<and> real_of_2 (real_alg_2 plr) = x"
   using invariant_1_realI[OF x,folded p_def l_def r_def] sgn ur p
     real_alg_2[of plr] by auto
 
 (* ********************* *)
 subsubsection \<open>Comparisons\<close>
 
 fun compare_rat_1 :: "rat \<Rightarrow> real_alg_1 \<Rightarrow> order" where
   "compare_rat_1 x (p,l,r) = (if x < l then Lt else if x > r then Gt else
       if sgn (ipoly p x) = sgn(ipoly p r) then Gt else Lt)" 
   
 lemma compare_rat_1: assumes rai: "invariant_1_2 y" 
   shows "compare_rat_1 x y = compare (of_rat x) (real_of_1 y)" 
 proof-
   define p l r where "p \<equiv> poly_real_alg_1 y" "l \<equiv> rai_lb y" "r \<equiv> rai_ub y"
   then have y [simp]: "y = (p,l,r)" by (cases y, auto)
   from rai have ur: "unique_root y" by auto
   show ?thesis 
   proof (cases "x < l \<or> x > r")
     case True
     {
       assume xl: "x < l" 
       hence "real_of_rat x < of_rat l" unfolding of_rat_less by auto
       with rai have "of_rat x < the_unique_root y" by (auto elim!: invariant_1E)
       with xl rai have ?thesis by (cases y, auto simp: compare_real_def comparator_of_def)
     }
     moreover
     {
       assume xr: "\<not> x < l" "x > r" 
       hence "real_of_rat x > of_rat r" unfolding of_rat_less by auto
       with rai have "of_rat x > the_unique_root y" by (auto elim!: invariant_1E)
       with xr rai have ?thesis by (cases y, auto simp: compare_real_def comparator_of_def)
     }
     ultimately show ?thesis using True by auto
   next
     case False
     have 0: "ipoly p (real_of_rat x) \<noteq> 0" by (rule poly_cond2_no_rat_root, insert rai, auto)
     with rai have diff: "real_of_1 y \<noteq> of_rat x" by (auto elim!: invariant_1E)
     have "\<And> P. (1 < degree (poly_real_alg_1 y) \<Longrightarrow> \<exists>!x. root_cond y x \<Longrightarrow> poly_cond p \<Longrightarrow> P) \<Longrightarrow> P"
        using poly_real_alg_1.simps y rai invariant_1_2E invariant_1E by metis
     from this[OF gt_rat_sign_change] False
     have left: "compare_rat_1 x y = (if real_of_rat x \<le> the_unique_root y then Lt else Gt)"
       by (auto simp:poly_cond2_def)
     also have "\<dots> = compare (real_of_rat x) (real_of_1 y)" using diff
       by (auto simp: compare_real_def comparator_of_def)
     finally show ?thesis .
   qed
 qed
   
 lemma cf_pos_0[simp]: "\<not> cf_pos 0" 
   unfolding cf_pos_def by auto
 
 
 (* ********************* *)
 subsubsection\<open>Negation\<close>
 
 fun uminus_1 :: "real_alg_1 \<Rightarrow> real_alg_1" where
   "uminus_1 (p,l,r) = (abs_int_poly (poly_uminus p), -r, -l)"
 
 lemma uminus_1: assumes x: "invariant_1 x"
   defines y: "y \<equiv> uminus_1 x"
   shows "invariant_1 y \<and> (real_of_1 y = - real_of_1 x)"
 proof (cases x)
   case plr: (fields p l r)
   from x plr have inv: "invariant_1 (p,l,r)" by auto
   note * = invariant_1D[OF this]
   from plr have x: "x = (p,l,r)" by simp
   let ?p = "poly_uminus p"
   let ?mp = "abs_int_poly ?p"
   have y: "y = (?mp, -r , -l)" 
     unfolding y plr by (simp add: Let_def)
   {
     fix y
     assume "root_cond (?mp, - r, - l) y"
     hence mpy: "ipoly ?mp y = 0" and bnd: "- of_rat r \<le> y" "y \<le> - of_rat l"
       unfolding root_cond_def by (auto simp: of_rat_minus)
     from mpy have id: "ipoly p (- y) = 0" by auto
     from bnd have bnd: "of_rat l \<le> - y" "-y \<le> of_rat r" by auto
     from id bnd have "root_cond (p, l, r) (-y)" unfolding root_cond_def by auto
     with inv x have "real_of_1 x = -y" by (auto intro!: the_unique_root_eqI)
     then have "-real_of_1 x = y" by auto
   } note inj = this
   have rc: "root_cond (?mp, - r, - l) (- real_of_1 x)"
     using * unfolding root_cond_def y x by (auto simp: of_rat_minus sgn_minus_rat)
   from inj rc have ur': "unique_root (?mp, -r, -l)" by (auto intro: unique_rootI)
   with rc have the: "- real_of_1 x = the_unique_root (?mp, -r, -l)" by (auto intro: the_unique_root_eqI)
   have xp: "p represents (real_of_1 x)" using * unfolding root_cond_def split represents_def x by auto
   from * have mon: "lead_coeff ?mp > 0" by (unfold pos_poly_abs_poly, auto)
   from poly_uminus_irreducible * have mi: "irreducible ?mp" by auto
   from mi mon have pc': "poly_cond ?mp" by (auto simp: cf_pos_def)
   from poly_condD[OF pc'] have irr: "irreducible ?mp" by auto
   show ?thesis unfolding y apply (intro invariant_1_realI ur' rc) using pc' inv by auto
 qed
 
 lemma uminus_1_2:
   assumes x: "invariant_1_2 x"
   defines y: "y \<equiv> uminus_1 x"
   shows "invariant_1_2 y \<and> (real_of_1 y = - real_of_1 x)"
 proof -
   from x have "invariant_1 x" by auto
   from uminus_1[OF this] have *: "real_of_1 y = - real_of_1 x" 
     "invariant_1 y" unfolding y by auto
   obtain p l r where id: "x = (p,l,r)" by (cases x)
   from x[unfolded id] have "degree p > 1" by auto
   moreover have "poly_real_alg_1 y = abs_int_poly (poly_uminus p)"
     unfolding y id uminus_1.simps split Let_def by auto
   ultimately have "degree (poly_real_alg_1 y) > 1" by simp
   with * show ?thesis by auto
 qed
   
 fun uminus_2 :: "real_alg_2 \<Rightarrow> real_alg_2" where
   "uminus_2 (Rational r) = Rational (-r)"
 | "uminus_2 (Irrational n x) = real_alg_2 (uminus_1 x)"
 
 lemma uminus_2: assumes "invariant_2 x" 
   shows "real_of_2 (uminus_2 x) = uminus (real_of_2 x)"
   "invariant_2 (uminus_2 x)"
   using assms real_alg_2 uminus_1 by (atomize(full), cases x, auto simp: hom_distribs)
 
 declare uminus_1.simps[simp del]
 
 
 lift_definition uminus_3 :: "real_alg_3 \<Rightarrow> real_alg_3" is uminus_2 
   by (auto simp: uminus_2)
 
 lemma uminus_3: "real_of_3 (uminus_3 x) = - real_of_3 x"
   by (transfer, auto simp: uminus_2)
     
 instantiation real_alg :: uminus
 begin
 lift_definition uminus_real_alg :: "real_alg \<Rightarrow> real_alg" is uminus_3
   by (simp add: uminus_3)
 instance ..
 end
 
 lemma uminus_real_alg: "- (real_of x) = real_of (- x)"
   by (transfer, rule uminus_3[symmetric])
 
 (* ********************* *)
 subsubsection\<open>Inverse\<close>
 
 fun inverse_1 :: "real_alg_1 \<Rightarrow> real_alg_2" where
   "inverse_1 (p,l,r) = real_alg_2 (abs_int_poly (reflect_poly p), inverse r, inverse l)"
 
 lemma invariant_1_2_of_rat: assumes rc: "invariant_1_2 rai" 
   shows "real_of_1 rai \<noteq> of_rat x" 
 proof -
   obtain p l r where rai: "rai = (p, l, r)" by (cases rai, auto)
   from rc[unfolded rai]
   have "poly_cond2 p" "ipoly p (the_unique_root (p, l, r)) = 0" by (auto elim!: invariant_1E)
   from poly_cond2_no_rat_root[OF this(1), of x] this(2) show ?thesis unfolding rai by auto
 qed
   
 lemma inverse_1:
   assumes rcx: "invariant_1_2 x"
   defines y: "y \<equiv> inverse_1 x"
   shows "invariant_2 y \<and> (real_of_2 y = inverse (real_of_1 x))"
 proof (cases x)
   case x: (fields p l r)
   from x rcx have rcx: "invariant_1_2 (p,l,r)" by auto
   from invariant_1_2_poly_cond2[OF rcx] have pc2: "poly_cond2 p" by simp
   have x0: "real_of_1 (p,l,r) \<noteq> 0" using invariant_1_2_of_rat[OF rcx, of 0] x by auto
   let ?x = "real_of_1 (p,l,r)"
   let ?mp = "abs_int_poly (reflect_poly p)"
   from x0 rcx have lr0: "l \<noteq> 0" and "r \<noteq> 0" by auto
   from x0 rcx have y: "y = real_alg_2 (?mp, inverse r, inverse l)"
     unfolding y x Let_def inverse_1.simps by auto
   from rcx have mon: "lead_coeff ?mp > 0" by (unfold lead_coeff_abs_int_poly, auto)
   {
     fix y
     assume "root_cond (?mp, inverse r, inverse l) y"
     hence mpy: "ipoly ?mp y = 0" and bnd: "inverse (of_rat r) \<le> y" "y \<le> inverse (of_rat l)"
       unfolding root_cond_def by (auto simp: of_rat_inverse)
     from sgn_real_mono[OF bnd(1)] sgn_real_mono[OF bnd(2)] 
     have "sgn (of_rat r) \<le> sgn y" "sgn y \<le> sgn (of_rat l)"
       by (simp_all add: algebra_simps)
     with rcx have sgn: "sgn (inverse (of_rat r)) = sgn y" "sgn y = sgn (inverse (of_rat l))" 
       unfolding sgn_inverse inverse_sgn
       by (auto simp add: real_of_rat_sgn intro: order_antisym)
     from sgn[simplified, unfolded real_of_rat_sgn] lr0 have "y \<noteq> 0" by (auto simp:sgn_0_0)
     with mpy have id: "ipoly p (inverse y) = 0" by (auto simp: ipoly_reflect_poly)
     from inverse_le_sgn[OF sgn(1) bnd(1)] inverse_le_sgn[OF sgn(2) bnd(2)]
     have bnd: "of_rat l \<le> inverse y" "inverse y \<le> of_rat r" by auto
     from id bnd have "root_cond (p,l,r) (inverse y)" unfolding root_cond_def by auto
     from rcx this x0 have "?x = inverse y" by auto
     then have "inverse ?x = y" by auto
   } note inj = this
   have rc: "root_cond (?mp, inverse r, inverse l) (inverse ?x)"
     using rcx x0 apply (elim invariant_1_2E invariant_1E)
     by (simp add: root_cond_def of_rat_inverse real_of_rat_sgn inverse_le_iff_sgn ipoly_reflect_poly)
   from inj rc have ur: "unique_root (?mp, inverse r, inverse l)" by (auto intro: unique_rootI)
   with rc have the: "the_unique_root (?mp, inverse r, inverse l) = inverse ?x" by (auto intro: the_unique_root_eqI)
   have xp: "p represents ?x" unfolding split represents_def using rcx by (auto elim!: invariant_1E)
   from reflect_poly_irreducible[OF _ xp x0] poly_condD rcx
   have mi: "irreducible ?mp" by auto
   from mi mon have un: "poly_cond ?mp" by (auto simp: poly_cond_def)
   show ?thesis using rcx rc ur unfolding y
     by (intro invariant_2_realI, auto simp: x y un)
 qed
   
 fun inverse_2 :: "real_alg_2 \<Rightarrow> real_alg_2" where
   "inverse_2 (Rational r) = Rational (inverse r)"
 | "inverse_2 (Irrational n x) = inverse_1 x"
 
 lemma inverse_2: assumes "invariant_2 x"
   shows "real_of_2 (inverse_2 x) = inverse (real_of_2 x)"
   "invariant_2 (inverse_2 x)"
     using assms
     by (atomize(full), cases x, auto simp: real_alg_2 inverse_1 hom_distribs)
 
 lift_definition inverse_3 :: "real_alg_3 \<Rightarrow> real_alg_3" is inverse_2 
   by (auto simp: inverse_2)
 
 lemma inverse_3: "real_of_3 (inverse_3 x) = inverse (real_of_3 x)"
   by (transfer, auto simp: inverse_2)
   
 
 (* ********************* *)
 subsubsection\<open>Floor\<close>
 
 fun floor_1 :: "real_alg_1 \<Rightarrow> int" where
   "floor_1 (p,l,r) = (let
     (l',r',sr') = tighten_poly_bounds_epsilon p (1/2) l r (sgn (ipoly p r));
     fr = floor r';
     fl = floor l';
     fr' = rat_of_int fr
     in (if fr = fl then fr else
     let (l'',r'',sr'') = tighten_poly_bounds_for_x p fr' l' r' sr'
     in if fr' < l'' then fr else fl))"
 
 lemma floor_1: assumes "invariant_1_2 x"
   shows "floor (real_of_1 x) = floor_1 x"
 proof (cases x)
   case (fields p l r)
   obtain l' r' sr' where tbe: "tighten_poly_bounds_epsilon p (1 / 2) l r (sgn (ipoly p r)) = (l',r',sr')" 
     by (cases rule: prod_cases3, auto)    
   let ?fr = "floor r'"
   let ?fl = "floor l'"
   let ?fr' = "rat_of_int ?fr"
   obtain l'' r'' sr'' where tbx: "tighten_poly_bounds_for_x p ?fr' l' r' sr' = (l'',r'',sr'')" 
     by (cases rule: prod_cases3, auto)    
   note rc = assms[unfolded fields]
   hence rc1: "invariant_1 (p,l,r)" by auto
   have id: "floor_1 x = ((if ?fr = ?fl then ?fr 
     else if ?fr' < l'' then ?fr else ?fl))"
     unfolding fields floor_1.simps tbe Let_def split tbx by simp
   let ?x = "real_of_1 x" 
   have x: "?x = the_unique_root (p,l,r)" unfolding fields by simp
   have bnd: "l \<le> l'" "r' \<le> r" "r' - l' \<le> 1 / 2"
     and rc': "root_cond (p, l', r') (the_unique_root (p, l, r))" 
     and sr': "sr' = sgn (ipoly p r')"
     by (atomize(full), intro conjI tighten_poly_bounds_epsilon[OF _ _ tbe refl],insert rc,auto elim!: invariant_1E)
   let ?r = real_of_rat
   from rc'[folded x, unfolded split]
   have ineq: "?r l' \<le> ?x" "?x \<le> ?r r'" "?r l' \<le> ?r r'" by auto
   hence lr': "l' \<le> r'" unfolding of_rat_less_eq by simp
   have flr: "?fl \<le> ?fr"
     by (rule floor_mono[OF lr'])
   from invariant_1_sub_interval[OF rc1 rc' bnd(1,2)] 
   have rc': "invariant_1 (p, l', r')"
     and id': "the_unique_root (p, l', r') = the_unique_root (p, l, r)" by auto
   with rc have rc2': "invariant_1_2 (p, l', r')" by auto
   have x: "?x = the_unique_root (p,l',r')"
     unfolding fields using id' by simp
   {
     assume "?fr \<noteq> ?fl"
     with flr have flr: "?fl \<le> ?fr - 1" by simp
     have "?fr' \<le> r'"  "l' \<le> ?fr'" using flr bnd by linarith+
   } note fl_diff = this
   show ?thesis
   proof (cases "?fr = ?fl")
     case True
     hence id1: "floor_1 x = ?fr" unfolding id by auto
-    from True have id: "floor (?r l') = floor (?r r')" unfolding real_of_rat_floor by simp
+    from True have id: "floor (?r l') = floor (?r r')"
+      by simp
     have "floor ?x \<le> floor (?r r')"
       by (rule floor_mono[OF ineq(2)])
     moreover have "floor (?r l') \<le> floor ?x"
       by (rule floor_mono[OF ineq(1)])
-    ultimately have "floor ?x = floor (?r r')" unfolding id by simp
-    thus ?thesis unfolding id1 real_of_rat_floor .
+    ultimately have "floor ?x = floor (?r r')"
+      unfolding id by (simp add: id)
+    then show ?thesis by (simp add: id1)
   next
     case False
     with id have id: "floor_1 x = (if ?fr' < l'' then ?fr else ?fl)" by simp
     from rc2' have "unique_root (p,l',r')" "poly_cond2 p" by auto
     from tighten_poly_bounds_for_x[OF this tbx sr']
     have ineq': "l' \<le> l''" "r'' \<le> r'" and lr'': "l'' \<le> r''" and rc'': "root_cond (p,l'',r'') ?x"
       and fr': "\<not> (l'' \<le> ?fr' \<and> ?fr' \<le> r'')" unfolding x by auto
     from rc''[unfolded split]
     have ineq'': "?r l'' \<le> ?x" "?x \<le> ?r r''" by auto
     from False have "?fr \<noteq> ?fl" by auto
     note fr = fl_diff[OF this]
     show ?thesis
     proof (cases "?fr' < l''")
       case True
       with id have id: "floor_1 x = ?fr" by simp 
       have "floor ?x \<le> ?fr" using floor_mono[OF ineq(2)] by simp
       moreover
       from True have "?r ?fr' < ?r l''" unfolding of_rat_less .
       with ineq''(1) have "?r ?fr' \<le> ?x" by simp
       from floor_mono[OF this]
       have "?fr \<le> floor ?x" by simp 
       ultimately show ?thesis unfolding id by auto
     next
       case False
       with id have id: "floor_1 x = ?fl" by simp
       from False have "l'' \<le> ?fr'" by auto
       from floor_mono[OF ineq(1)] have "?fl \<le> floor ?x" by simp
       moreover have "floor ?x \<le> ?fl"
       proof -
         from False fr' have fr': "r'' < ?fr'" by auto
         hence "floor r'' < ?fr" by linarith
         with floor_mono[OF ineq''(2)] 
         have "floor ?x \<le> ?fr - 1" by auto
         also have "?fr - 1 = floor (r' - 1)" by simp
         also have "\<dots> \<le> ?fl"
           by (rule floor_mono, insert bnd, auto)
         finally show ?thesis .
       qed
       ultimately show ?thesis unfolding id by auto
     qed
   qed
 qed
 
 (* ********************* *)
 subsubsection\<open>Generic Factorization and Bisection Framework\<close>
 
 lemma card_1_Collect_ex1: assumes "card (Collect P) = 1"
   shows "\<exists>! x. P x"
 proof -
   from assms[unfolded card_eq_1_iff] obtain x where "Collect P = {x}" by auto
   thus ?thesis
     by (intro ex1I[of _ x], auto)
 qed
 
 fun sub_interval :: "rat \<times> rat \<Rightarrow> rat \<times> rat \<Rightarrow> bool" where
   "sub_interval (l,r) (l',r') = (l' \<le> l \<and> r \<le> r')"
 
 fun in_interval :: "rat \<times> rat \<Rightarrow> real \<Rightarrow> bool" where 
   "in_interval (l,r) x = (of_rat l \<le> x \<and> x \<le> of_rat r)" 
 
 definition converges_to :: "(nat \<Rightarrow> rat \<times> rat) \<Rightarrow> real \<Rightarrow> bool" where
   "converges_to f x \<equiv> (\<forall> n. in_interval (f n) x \<and> sub_interval (f (Suc n)) (f n))
    \<and> (\<forall> (eps :: real) > 0. \<exists> n l r. f n = (l,r) \<and> of_rat r - of_rat l \<le> eps)"
 
 context
   fixes bnd_update :: "'a \<Rightarrow> 'a" 
   and bnd_get :: "'a \<Rightarrow> rat \<times> rat"
 begin
 
 definition at_step :: "(nat \<Rightarrow> rat \<times> rat) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> bool" where
   "at_step f n a \<equiv> \<forall> i. bnd_get ((bnd_update ^^ i) a) = f (n + i)"
 
 partial_function (tailrec) select_correct_factor_main
   :: "'a \<Rightarrow> (int poly \<times> root_info)list \<Rightarrow> (int poly \<times> root_info)list
     \<Rightarrow> rat \<Rightarrow> rat \<Rightarrow> nat \<Rightarrow> (int poly \<times> root_info) \<times> rat \<times> rat" where
   [code]: "select_correct_factor_main bnd todo old l r n = (case todo of Nil
     \<Rightarrow> if n = 1 then (hd old, l, r) else let bnd' = bnd_update bnd in (case bnd_get bnd' of (l,r) \<Rightarrow> 
       select_correct_factor_main bnd' old [] l r 0)
    | Cons (p,ri) todo \<Rightarrow> let m = root_info.l_r ri l r in 
       if m = 0 then select_correct_factor_main bnd todo old l r n
       else select_correct_factor_main bnd todo ((p,ri) # old) l r (n + m))"
 
 definition select_correct_factor :: "'a \<Rightarrow> (int poly \<times> root_info)list \<Rightarrow>
     (int poly \<times> root_info) \<times> rat \<times> rat" where
   "select_correct_factor init polys = (case bnd_get init of (l,r) \<Rightarrow>
     select_correct_factor_main init polys [] l r 0)"
 
 lemma select_correct_factor_main: assumes conv: "converges_to f x"
   and at: "at_step f i a"
   and res: "select_correct_factor_main a todo old l r n = ((q,ri_fin),(l_fin,r_fin))"
   and bnd: "bnd_get a = (l,r)"
   and ri: "\<And> q ri. (q,ri) \<in> set todo \<union> set old \<Longrightarrow> root_info_cond ri q"
   and q0: "\<And> q ri. (q,ri) \<in> set todo \<union> set old \<Longrightarrow> q \<noteq> 0"
   and ex: "\<exists>q. q \<in> fst ` set todo \<union> fst ` set old \<and> ipoly q x = 0"
   and dist: "distinct (map fst (todo @ old))"
   and old: "\<And> q ri. (q,ri) \<in> set old \<Longrightarrow> root_info.l_r ri l r \<noteq> 0"
   and un: "\<And> x :: real. (\<exists>q. q \<in> fst ` set todo \<union> fst ` set old \<and> ipoly q x = 0) \<Longrightarrow> 
     \<exists>!q. q \<in> fst ` set todo \<union> fst ` set old \<and> ipoly q x = 0"
   and n: "n = sum_list (map (\<lambda> (q,ri). root_info.l_r ri l r) old)"
   shows "unique_root (q,l_fin,r_fin) \<and> (q,ri_fin) \<in> set todo \<union> set old \<and> x = the_unique_root (q,l_fin,r_fin)"
 proof -
   define orig where "orig = set todo \<union> set old"
   have orig: "set todo \<union> set old \<subseteq> orig" unfolding orig_def by auto
   let ?rts = "{x :: real. \<exists> q ri. (q,ri) \<in> orig \<and> ipoly q x = 0}"
   define rts where "rts = ?rts"
   let ?h = "\<lambda> (x,y). abs (x - y)" 
   let ?r = real_of_rat
   have rts: "?rts = (\<Union> ((\<lambda> (q,ri). {x. ipoly q x = 0}) ` set (todo @ old)))" unfolding orig_def by auto
   have "finite rts" unfolding rts rts_def
     using finite_ipoly_roots[OF q0] finite_set[of "todo @ old"] by auto  
   hence fin: "finite (rts \<times> rts - Id)" by auto   
   define diffs where "diffs = insert 1 {abs (x - y) | x y. x \<in> rts \<and> y \<in> rts \<and> x \<noteq> y}"
   have "finite {abs (x - y) | x y. x \<in> rts \<and> y \<in> rts \<and> x \<noteq> y}"
     by (rule subst[of _ _ finite, OF _ finite_imageI[OF fin, of ?h]], auto)
   hence diffs: "finite diffs" "diffs \<noteq> {}" unfolding diffs_def by auto
   define eps where "eps = Min diffs / 2"
   have "\<And> x. x \<in> diffs \<Longrightarrow> x > 0" unfolding diffs_def by auto
   with Min_gr_iff[OF diffs] have eps: "eps > 0" unfolding eps_def by auto
   note conv = conv[unfolded converges_to_def] 
   from conv eps obtain N L R where 
     N: "f N = (L,R)" "?r R - ?r L \<le> eps" by auto
   obtain pair where pair: "pair = (todo,i)" by auto
   define rel where "rel = measures [ \<lambda> (t,i). N - i, \<lambda> (t :: (int poly \<times> root_info) list,i). length t]"
   have wf: "wf rel" unfolding rel_def by simp
   show ?thesis
     using at res bnd ri q0 ex dist old un n pair orig
   proof (induct pair arbitrary: todo i old a l r n rule: wf_induct[OF wf])
     case (1 pair todo i old a l r n)
     note IH = 1(1)[rule_format]
     note at = 1(2)
     note res = 1(3)[unfolded select_correct_factor_main.simps[of _ todo]]
     note bnd = 1(4)
     note ri = 1(5)
     note q0 = 1(6)
     note ex = 1(7)
     note dist = 1(8)
     note old = 1(9)
     note un = 1(10)
     note n = 1(11)
     note pair = 1(12)
     note orig = 1(13)
     from at[unfolded at_step_def, rule_format, of 0] bnd have fi: "f i = (l,r)" by auto
     with conv have inx: "in_interval (f i) x" by blast
     hence lxr: "?r l \<le> x" "x \<le> ?r r" unfolding fi by auto
     from order.trans[OF this] have lr: "l \<le> r" unfolding of_rat_less_eq .
     show ?case 
     proof (cases todo)
       case (Cons rri tod)
       obtain s ri where rri: "rri = (s,ri)" by force
       with Cons have todo: "todo = (s,ri) # tod" by simp
       note res = res[unfolded todo list.simps split Let_def]
       from root_info_condD(1)[OF ri[of s ri, unfolded todo] lr]
       have ri': "root_info.l_r ri l r = card {x. root_cond (s, l, r) x}" by auto
       from q0 have s0: "s \<noteq> 0" unfolding todo by auto
       from finite_ipoly_roots[OF s0] have fins: "finite {x. root_cond (s, l, r) x}" 
         unfolding root_cond_def by auto
       have rel: "((tod,i), pair) \<in> rel" unfolding rel_def pair todo by simp
       show ?thesis
       proof (cases "root_info.l_r ri l r = 0")
         case True
         with res have res: "select_correct_factor_main a tod old l r n = ((q, ri_fin), l_fin, r_fin)" by auto
         from ri'[symmetric, unfolded True] fins have empty: "{x. root_cond (s, l, r) x} = {}" by simp
         from ex lxr empty have ex': "(\<exists>q. q \<in> fst ` set tod \<union> fst ` set old \<and> ipoly q x = 0)"
           unfolding todo root_cond_def split by auto
         have "unique_root (q, l_fin, r_fin) \<and> (q, ri_fin) \<in> set tod \<union> set old \<and> 
           x = the_unique_root (q, l_fin, r_fin)"
         proof (rule IH[OF rel at res bnd ri _ ex' _ _ _ n refl], goal_cases)
           case (5 y) thus ?case using un[of y] unfolding todo by auto
         next
           case 2 thus ?case using q0 unfolding todo by auto
         qed (insert dist old orig, auto simp: todo)
         thus ?thesis unfolding todo by auto
       next
         case False
         with res have res: "select_correct_factor_main a tod ((s, ri) # old) l r 
           (n + root_info.l_r ri l r) = ((q, ri_fin), l_fin, r_fin)" by auto
         from ex have ex': "\<exists>q. q \<in> fst ` set tod \<union> fst ` set ((s, ri) # old) \<and> ipoly q x = 0"
           unfolding todo by auto
         from dist have dist: "distinct (map fst (tod @ (s, ri) # old))" unfolding todo by auto
         have id: "set todo \<union> set old = set tod \<union> set ((s, ri) # old)" unfolding todo by simp
         show ?thesis unfolding id
         proof (rule IH[OF rel at res bnd ri _ ex' dist], goal_cases)
           case 4 thus ?case using un unfolding todo by auto
         qed (insert old False orig, auto simp: q0 todo n)
       qed
     next
       case Nil
       note res = res[unfolded Nil list.simps Let_def]
       from ex[unfolded Nil] lxr obtain s where "s \<in> fst ` set old \<and> root_cond (s,l,r) x"
         unfolding root_cond_def by auto
       then obtain q1 ri1 old' where old': "old = (q1,ri1) # old'" using id by (cases old, auto)
       let ?ri = "root_info.l_r ri1 l r"
       from old[unfolded old'] have 0: "?ri \<noteq> 0" by auto
       from n[unfolded old'] 0 have n0: "n \<noteq> 0" by auto
       from ri[unfolded old'] have ri': "root_info_cond ri1 q1" by auto
       show ?thesis
       proof (cases "n = 1")
         case False
         with n0 have n1: "n > 1" by auto
         obtain l' r' where bnd': "bnd_get (bnd_update a) = (l',r')" by force        
         with res False have res: "select_correct_factor_main (bnd_update a) old [] l' r' 0 =
           ((q, ri_fin), l_fin, r_fin)" by auto
         have at': "at_step f (Suc i) (bnd_update a)" unfolding at_step_def
         proof (intro allI, goal_cases)
           case (1 n)
           have id: "(bnd_update ^^ Suc n) a = (bnd_update ^^ n) (bnd_update a)"
             by (induct n, auto)
           from at[unfolded at_step_def, rule_format, of "Suc n"]
           show ?case unfolding id by simp
         qed
         from 0[unfolded root_info_condD(1)[OF ri' lr]] obtain y1 where y1: "root_cond (q1,l,r) y1" 
           by (cases "Collect (root_cond (q1, l, r)) = {}", auto)
         from n1[unfolded n old'] 
         have "?ri > 1 \<or> sum_list (map (\<lambda> (q,ri). root_info.l_r ri l r) old') \<noteq> 0"
           by (cases "sum_list (map (\<lambda> (q,ri). root_info.l_r ri l r) old')", auto)
         hence "\<exists> q2 ri2 y2. (q2,ri2) \<in> set old \<and> root_cond (q2,l,r) y2 \<and> y1 \<noteq> y2"
         proof
           assume "?ri > 1"
           with root_info_condD(1)[OF ri' lr] have "card {x. root_cond (q1, l, r) x} > 1" by simp
           from card_gt_1D[OF this] y1 obtain y2 where "root_cond (q1,l,r) y2" and "y1 \<noteq> y2" by auto
           thus ?thesis unfolding old' by auto
         next
           assume "sum_list (map (\<lambda> (q,ri). root_info.l_r ri l r) old') \<noteq> 0"
           then obtain q2 ri2 where mem: "(q2,ri2) \<in> set old'" and ri2: "root_info.l_r ri2 l r \<noteq> 0" by auto
           with q0 ri have "root_info_cond ri2 q2" unfolding old' by auto
           from ri2[unfolded root_info_condD(1)[OF this lr]] obtain y2 where y2: "root_cond (q2,l,r) y2"
             by (cases "Collect (root_cond (q2, l, r)) = {}", auto)
           from dist[unfolded old'] split_list[OF mem] have diff: "q1 \<noteq> q2" by auto
           from y1 have q1: "q1 \<in> fst ` set todo \<union> fst ` set old \<and> ipoly q1 y1 = 0"
             unfolding old' root_cond_def by auto
           from y2 have q2: "q2 \<in> fst ` set todo \<union> fst ` set old \<and> ipoly q2 y2 = 0"
             unfolding old' root_cond_def using mem by force
           have "y1 \<noteq> y2"
           proof
             assume id: "y1 = y2"
             from q1 have "\<exists> q1. q1 \<in> fst ` set todo \<union> fst ` set old \<and> ipoly q1 y1 = 0" by blast
             from un[OF this] q1 q2[folded id] have "q1 = q2" by auto
             with diff show False by simp
           qed
           with mem y2 show ?thesis unfolding old' by auto
         qed
         then obtain q2 ri2 y2 where 
           mem2: "(q2,ri2) \<in> set old" and y2: "root_cond (q2,l,r) y2" and diff: "y1 \<noteq> y2" by auto
         from mem2 orig have "(q1,ri1) \<in> orig" "(q2,ri2) \<in> orig"  unfolding old' by auto
         with y1 y2 diff have "abs (y1 - y2) \<in> diffs" unfolding diffs_def rts_def root_cond_def by auto
         from Min_le[OF diffs(1) this] have "abs (y1 - y2) \<ge> 2 * eps" unfolding eps_def by auto
         with eps have eps: "abs (y1 - y2) > eps" by auto
         from y1 y2 have l: "of_rat l \<le> min y1 y2" unfolding root_cond_def by auto
         from y1 y2 have r: "of_rat r \<ge> max y1 y2" unfolding root_cond_def by auto
         from l r eps have eps: "of_rat r - of_rat l > eps" by auto
         have "i < N" 
         proof (rule ccontr)
           assume "\<not> i < N"
           hence "\<exists> k. i = N + k" by presburger
           then obtain k where i: "i = N + k" by auto
           {
             fix k l r
             assume "f (N + k) = (l,r)"
             hence "of_rat r - of_rat l \<le> eps"
             proof (induct k arbitrary: l r)
               case 0
               with N show ?case by auto
             next
               case (Suc k l r)
               obtain l' r' where f: "f (N + k) = (l',r')" by force
               from Suc(1)[OF this] have IH: "?r r' - ?r l' \<le> eps" by auto
               from f Suc(2) conv[THEN conjunct1, rule_format, of "N + k"] 
               have "?r l \<ge> ?r l'" "?r r \<le> ?r r'"
                 by (auto simp: of_rat_less_eq)
               thus ?case using IH by auto
             qed
           } note * = this
           from at[unfolded at_step_def i, rule_format, of 0] bnd  have "f (N + k) = (l,r)" by auto
           from *[OF this] eps
           show False by auto
         qed
         hence rel: "((old, Suc i), pair) \<in> rel" unfolding pair rel_def by auto
         from dist have dist: "distinct (map fst (old @ []))" unfolding Nil by auto
         have id: "set todo \<union> set old = set old \<union> set []" unfolding Nil by auto
         show ?thesis unfolding id
         proof (rule IH[OF rel at' res bnd' ri _ _ dist _ _ _ refl], goal_cases)
           case 2 thus ?case using q0 by auto
         qed (insert ex un orig Nil, auto)
       next
         case True
         with res old' have id: "q = q1" "ri_fin = ri1" "l_fin = l" "r_fin = r" by auto
         from n[unfolded True old'] 0 have 1: "?ri = 1" 
           by (cases ?ri; cases "?ri - 1", auto)
         from root_info_condD(1)[OF ri' lr] 1 have "card {x. root_cond (q1,l,r) x} = 1" by auto
         from card_1_Collect_ex1[OF this]
         have unique: "unique_root (q1,l,r)" .
         from ex[unfolded Nil old'] consider (A) "ipoly q1 x = 0" 
           | (B) q where "q \<in> fst ` set old'" "ipoly q x = 0" by auto
         hence "x = the_unique_root (q1,l,r)"
         proof (cases)
           case A
           with lxr have "root_cond (q1,l,r) x" unfolding root_cond_def by auto
           from the_unique_root_eqI[OF unique this] show ?thesis by simp
         next
           case (B q)
           with lxr have "root_cond (q,l,r) x" unfolding root_cond_def by auto
           hence empty: "{x. root_cond (q,l,r) x} \<noteq> {}" by auto
           from B(1) obtain ri' where mem: "(q,ri') \<in> set old'" by force
           from q0[unfolded old'] mem have q0: "q \<noteq> 0" by auto
           from finite_ipoly_roots[OF this] have "finite {x. root_cond (q,l,r) x}" 
             unfolding root_cond_def by auto
           with empty have card: "card {x. root_cond (q,l,r) x} \<noteq> 0" by simp
           from ri[unfolded old'] mem have "root_info_cond ri' q" by auto
           from root_info_condD(1)[OF this lr] card have "root_info.l_r ri' l r \<noteq> 0" by auto
           with n[unfolded True old'] 1 split_list[OF mem] have False by auto
           thus ?thesis by simp
         qed
         thus ?thesis unfolding id using unique ri' unfolding old' by auto
       qed
     qed
   qed
 qed
 
 lemma select_correct_factor: assumes 
       conv: "converges_to (\<lambda> i. bnd_get ((bnd_update ^^ i) init)) x"
   and res: "select_correct_factor init polys = ((q,ri),(l,r))"
   and ri: "\<And> q ri. (q,ri) \<in> set polys \<Longrightarrow> root_info_cond ri q"
   and q0: "\<And> q ri. (q,ri) \<in> set polys \<Longrightarrow> q \<noteq> 0"
   and ex: "\<exists>q. q \<in> fst ` set polys \<and> ipoly q x = 0"
   and dist: "distinct (map fst polys)"
   and un: "\<And> x :: real. (\<exists>q. q \<in> fst ` set polys \<and> ipoly q x = 0) \<Longrightarrow> 
     \<exists>!q. q \<in> fst ` set polys \<and> ipoly q x = 0"
   shows "unique_root (q,l,r) \<and> (q,ri) \<in> set polys \<and> x = the_unique_root (q,l,r)"
 proof -
   obtain l' r' where init: "bnd_get init = (l',r')" by force
   from res[unfolded select_correct_factor_def init split]
   have res: "select_correct_factor_main init polys [] l' r' 0 = ((q, ri), l, r)" by auto
   have at: "at_step (\<lambda> i. bnd_get ((bnd_update ^^ i) init)) 0 init" unfolding at_step_def by auto
   have "unique_root (q,l,r) \<and> (q,ri) \<in> set polys \<union> set [] \<and> x = the_unique_root (q,l,r)"
     by (rule select_correct_factor_main[OF conv at res init ri], insert dist un ex q0, auto)
   thus ?thesis by auto
 qed
 
 definition real_alg_2' :: "root_info \<Rightarrow> int poly \<Rightarrow> rat \<Rightarrow> rat \<Rightarrow> real_alg_2" where
   [code del]: "real_alg_2' ri p l r = (
     if degree p = 1 then Rational (Rat.Fract (- coeff p 0) (coeff p 1)) else
     real_alg_2_main ri (case tighten_poly_bounds_for_x p 0 l r (sgn (ipoly p r)) of
               (l',r',sr') \<Rightarrow> (p, l', r')))"
 
 lemma real_alg_2'_code[code]: "real_alg_2' ri p l r =
  (if degree p = 1 then Rational (Rat.Fract (- coeff p 0) (coeff p 1))
      else case normalize_bounds_1
         (case tighten_poly_bounds_for_x p 0 l r (sgn (ipoly p r)) of (l', r', sr') \<Rightarrow> (p, l', r')) 
      of (p', l, r) \<Rightarrow> Irrational (root_info.number_root ri r) (p', l, r))"  
   unfolding real_alg_2'_def real_alg_2_main_def
   by (cases "tighten_poly_bounds_for_x p 0 l r (sgn (ipoly p r))", simp add: Let_def)
     
 definition real_alg_2'' :: "root_info \<Rightarrow> int poly \<Rightarrow> rat \<Rightarrow> rat \<Rightarrow> real_alg_2" where
   "real_alg_2'' ri p l r = (case normalize_bounds_1
         (case tighten_poly_bounds_for_x p 0 l r (sgn (ipoly p r)) of (l', r', sr') \<Rightarrow> (p, l', r')) 
      of (p', l, r) \<Rightarrow> Irrational (root_info.number_root ri r) (p', l, r))" 
 
 lemma real_alg_2'': "degree p \<noteq> 1 \<Longrightarrow> real_alg_2'' ri p l r = real_alg_2' ri p l r" 
   unfolding real_alg_2'_code real_alg_2''_def by auto
   
 lemma poly_cond_degree_0_imp_no_root:
   fixes x :: "'b :: {comm_ring_1,ring_char_0}"
   assumes pc: "poly_cond p" and deg: "degree p = 0" shows "ipoly p x \<noteq> 0"
 proof
   from pc have "p \<noteq> 0" by auto
   moreover assume "ipoly p x = 0"
     note poly_zero[OF this]
   ultimately show False using deg by auto
 qed
 
 lemma real_alg_2':
   assumes ur: "unique_root (q,l,r)" and pc: "poly_cond q" and ri: "root_info_cond ri q"
   shows "invariant_2 (real_alg_2' ri q l r) \<and> real_of_2 (real_alg_2' ri q l r) = the_unique_root (q,l,r)" (is "_ \<and> _ = ?x")
 proof (cases "degree q" "Suc 0" rule: linorder_cases)
   case deg: less
   then have "degree q = 0" by auto
   from poly_cond_degree_0_imp_no_root[OF pc this] ur have False by force
   then show ?thesis by auto
 next
   case deg: equal
   hence id: "real_alg_2' ri q l r = Rational (Rat.Fract (- coeff q 0) (coeff q 1))" 
     unfolding real_alg_2'_def by auto
   show ?thesis unfolding id using degree_1_ipoly[OF deg]
     using unique_rootD(4)[OF ur] by auto
 next
   case deg: greater
   with pc have pc2: "poly_cond2 q" by auto
   let ?rai = "real_alg_2' ri q l r"
   let ?r = real_of_rat
   obtain l' r' sr' where tight: "tighten_poly_bounds_for_x q 0 l r (sgn (ipoly q r)) = (l',r',sr')" 
     by (cases rule: prod_cases3, auto)
   let ?rai' = "(q, l', r')" 
   have rai': "?rai = real_alg_2_main ri ?rai'"
     unfolding real_alg_2'_def using deg tight by auto
   hence rai: "real_of_1 ?rai' = the_unique_root (q,l',r')" by auto
   note tight = tighten_poly_bounds_for_x[OF ur pc2 tight refl]
   let ?x = "the_unique_root (q, l, r)"
   from tight have tight: "root_cond (q,l',r') ?x" "l \<le> l'" "l' \<le> r'" "r' \<le> r" "l' > 0 \<or> r' < 0" by auto
   from unique_root_sub_interval[OF ur tight(1) tight(2,4)] poly_condD[OF pc]
   have ur': "unique_root (q, l', r')" and x: "?x = the_unique_root (q,l',r')" by auto
   from tight(2-) have sgn: "sgn l' = sgn r'" by auto
   show ?thesis unfolding rai' using real_alg_2_main[of ?rai' ri] invariant_1_realI[of ?rai' ?x]
     by (auto simp: tight(1) sgn pc ri ur')
 qed
 
 definition select_correct_factor_int_poly :: "'a \<Rightarrow> int poly \<Rightarrow> real_alg_2" where
   "select_correct_factor_int_poly init p \<equiv> 
      let qs = factors_of_int_poly p;
          polys = map (\<lambda> q. (q, root_info q)) qs;
          ((q,ri),(l,r)) = select_correct_factor init polys
       in real_alg_2' ri q l r"
 
 lemma select_correct_factor_int_poly: assumes 
       conv: "converges_to (\<lambda> i. bnd_get ((bnd_update ^^ i) init)) x"
   and rai: "select_correct_factor_int_poly init p = rai"
   and x: "ipoly p x = 0"
   and p: "p \<noteq> 0"
   shows "invariant_2 rai \<and> real_of_2 rai = x"
 proof -
   obtain qs where fact: "factors_of_int_poly p = qs" by auto
   define polys where "polys = map (\<lambda> q. (q, root_info q)) qs"
   obtain q ri l r where res: "select_correct_factor init polys = ((q,ri),(l,r))"
     by (cases "select_correct_factor init polys", auto)
   have fst: "map fst polys = qs" "fst ` set polys = set qs" unfolding polys_def map_map o_def 
     by force+
   note fact' = factors_of_int_poly[OF fact]
   note rai = rai[unfolded select_correct_factor_int_poly_def Let_def fact, 
     folded polys_def, unfolded res split]
   from fact' fst have dist: "distinct (map fst polys)" by auto
   from fact'(2)[OF p, of x] x fst 
   have ex: "\<exists>q. q \<in> fst ` set polys \<and> ipoly q x = 0" by auto
   {
     fix q ri
     assume "(q,ri) \<in> set polys"
     hence ri: "ri = root_info q" and q: "q \<in> set qs" unfolding polys_def by auto
     from fact'(1)[OF q] have *: "lead_coeff q > 0" "irreducible q" "degree q > 0" by auto
     from * have q0: "q \<noteq> 0" by auto
     from root_info[OF *(2-3)] ri have ri: "root_info_cond ri q" by auto
     note ri q0 *
   } note polys = this
   have "unique_root (q, l, r) \<and> (q, ri) \<in> set polys \<and> x = the_unique_root (q, l, r)"
     by (rule select_correct_factor[OF conv res polys(1) _ ex dist, unfolded fst, OF _ _ fact'(3)[OF p]],
     insert fact'(2)[OF p] polys(2), auto)
   hence ur: "unique_root (q,l,r)" and mem: "(q,ri) \<in> set polys" and x: "x = the_unique_root (q,l,r)" by auto
   note polys = polys[OF mem]
   from polys(3-4) have ty: "poly_cond q" by (simp add: poly_cond_def)
   show ?thesis unfolding x rai[symmetric] by (intro real_alg_2' ur ty polys(1))
 qed
 end
 
 (* ********************* *)
 subsubsection\<open>Addition\<close>
 
 lemma ipoly_0_0[simp]: "ipoly f (0::'a::{comm_ring_1,ring_char_0}) = 0 \<longleftrightarrow> poly f 0 = 0"
   unfolding poly_0_coeff_0 by simp
 
 lemma add_rat_roots_below[simp]: "roots_below (poly_add_rat r p) x = (\<lambda>y. y + of_rat r) ` roots_below p (x - of_rat r)"
 proof (unfold add_rat_roots image_def, intro Collect_eqI, goal_cases)
   case (1 y) then show ?case by (auto intro: exI[of _ "y - real_of_rat r"])
 qed
 
 lemma add_rat_root_cond:
   shows "root_cond (cf_pos_poly (poly_add_rat m p),l,r) x = root_cond (p, l - m, r - m) (x - of_rat m)"
   by (unfold root_cond_def, auto simp add: add_rat_roots hom_distribs)
 
 lemma add_rat_unique_root: "unique_root (cf_pos_poly (poly_add_rat m p), l, r) = unique_root (p, l-m, r-m)"
   by (auto simp: add_rat_root_cond)
 
 fun add_rat_1 :: "rat \<Rightarrow> real_alg_1 \<Rightarrow> real_alg_1" where
   "add_rat_1 r1 (p2,l2,r2) = (
     let p = cf_pos_poly (poly_add_rat r1 p2);
       (l,r,sr) = tighten_poly_bounds_for_x p 0 (l2+r1) (r2+r1) (sgn (ipoly p (r2+r1)))
     in
     (p,l,r))"
 
 lemma poly_real_alg_1_add_rat[simp]:
   "poly_real_alg_1 (add_rat_1 r y) = cf_pos_poly (poly_add_rat r (poly_real_alg_1 y))"
   by (cases y, auto simp: Let_def split: prod.split)
 
 lemma sgn_cf_pos:
   assumes "lead_coeff p > 0" shows "sgn (ipoly (cf_pos_poly p) (x::'a::linordered_field)) = sgn (ipoly p x)"
 proof (cases "p = 0")
   case True with assms show ?thesis by auto
 next
   case False
   from cf_pos_poly_main False obtain d where p': "Polynomial.smult d (cf_pos_poly p) = p" by auto
   have "d > 0"
   proof (rule zero_less_mult_pos2)
     from False assms have "0 < lead_coeff p" by (auto simp: cf_pos_def)
     also from p' have "\<dots> = d * lead_coeff (cf_pos_poly p)" by (metis lead_coeff_smult)
     finally show "0 < \<dots>".
     show "lead_coeff (cf_pos_poly p) > 0" using False by (unfold lead_coeff_cf_pos_poly)
   qed
   moreover from p' have "ipoly p x = of_int d * ipoly (cf_pos_poly p) x"
     by (fold poly_smult of_int_hom.map_poly_hom_smult, auto)
   ultimately show ?thesis by (auto simp: sgn_mult[where 'a='a])
 qed
 
 lemma add_rat_1: fixes r1 :: rat assumes inv_y: "invariant_1_2 y"
   defines "z \<equiv> add_rat_1 r1 y"
   shows "invariant_1_2 z \<and> (real_of_1 z = of_rat r1 + real_of_1 y)"
 proof (cases y)
   case y_def: (fields p2 l2 r2)
   define p where "p \<equiv> cf_pos_poly (poly_add_rat r1 p2)"
   obtain l r sr where lr: "tighten_poly_bounds_for_x p 0 (l2+r1) (r2+r1) (sgn (ipoly p (r2+r1))) = (l,r,sr)"
     by (metis surj_pair)
   from lr have z: "z = (p,l,r)" by (auto simp: y_def z_def p_def Let_def)
   from inv_y have ur: "unique_root (p, l2 + r1, r2 + r1)"
     by (auto simp: p_def add_rat_root_cond y_def add_rat_unique_root)
   from inv_y[unfolded y_def invariant_1_2_def,simplified] have pc2: "poly_cond2 p"
     unfolding p_def
     apply (intro poly_cond2I poly_add_rat_irreducible poly_condI, unfold lead_coeff_cf_pos_poly)
     apply (auto elim!: invariant_1E)
    done
   note main = tighten_poly_bounds_for_x[OF ur pc2 lr refl, simplified]
   then have "sgn l = sgn r" unfolding sgn_if apply simp apply linarith done
   from invariant_1_2_realI[OF main(4) _ main(7), simplified, OF this pc2] main(1-3) ur
   show ?thesis by (auto simp: z p_def y_def add_rat_root_cond ex1_the_shift)
 qed
 
 fun tighten_poly_bounds_binary :: "int poly \<Rightarrow> int poly \<Rightarrow> (rat \<times> rat \<times> rat) \<times> rat \<times> rat \<times> rat \<Rightarrow> (rat \<times> rat \<times> rat) \<times> rat \<times> rat \<times> rat"  where
   "tighten_poly_bounds_binary cr1 cr2 ((l1,r1,sr1),(l2,r2,sr2)) = 
      (tighten_poly_bounds cr1 l1 r1 sr1, tighten_poly_bounds cr2 l2 r2 sr2)"
 
 lemma tighten_poly_bounds_binary:
   assumes ur: "unique_root (p1,l1,r1)" "unique_root (p2,l2,r2)" and pt: "poly_cond2 p1" "poly_cond2 p2" 
   defines "x \<equiv> the_unique_root (p1,l1,r1)" and "y \<equiv> the_unique_root (p2,l2,r2)"
   assumes bnd: "\<And> l1 r1 l2 r2 l r sr1 sr2. I l1 \<Longrightarrow> I l2 \<Longrightarrow> root_cond (p1,l1,r1) x \<Longrightarrow> root_cond (p2,l2,r2) y \<Longrightarrow>
       bnd ((l1,r1,sr1),(l2,r2,sr2)) = (l,r) \<Longrightarrow> of_rat l \<le> f x y \<and> f x y \<le> of_rat r"
   and approx: "\<And> l1 r1 l2 r2 l1' r1' l2' r2' l l' r r' sr1 sr2 sr1' sr2'. 
     I l1 \<Longrightarrow> I l2 \<Longrightarrow>
     l1 \<le> r1 \<Longrightarrow> l2 \<le> r2 \<Longrightarrow> 
     (l,r) = bnd ((l1,r1,sr1), (l2,r2,sr2)) \<Longrightarrow>
     (l',r') = bnd ((l1',r1',sr1'), (l2',r2',sr2')) \<Longrightarrow>
     (l1',r1') \<in> {(l1,(l1+r1)/2),((l1+r1)/2,r1)} \<Longrightarrow>
     (l2',r2') \<in> {(l2,(l2+r2)/2),((l2+r2)/2,r2)} \<Longrightarrow>
     (r' - l') \<le> 3/4 * (r - l) \<and> l \<le> l' \<and> r' \<le> r"
   and I_mono: "\<And> l l'. I l \<Longrightarrow> l \<le> l' \<Longrightarrow> I l'"
   and I: "I l1" "I l2" 
   and sr: "sr1 = sgn (ipoly p1 r1)" "sr2 = sgn (ipoly p2 r2)"
   shows "converges_to (\<lambda> i. bnd ((tighten_poly_bounds_binary p1 p2 ^^ i) ((l1,r1,sr1),(l2,r2,sr2))))
      (f x y)"
 proof -
   let ?upd = "tighten_poly_bounds_binary p1 p2"
   define upd where "upd = ?upd"
   define init where "init = ((l1, r1, sr1), l2, r2, sr2)"
   let ?g = "(\<lambda>i. bnd ((upd ^^ i) init))"
   obtain l r where bnd_init: "bnd init = (l,r)" by force
   note ur1 = unique_rootD[OF ur(1)]
   note ur2 = unique_rootD[OF ur(2)]
   from ur1(4) ur2(4) x_def y_def
   have rc1: "root_cond (p1,l1,r1) x" and rc2: "root_cond (p2,l2,r2) y" by auto
   define g where "g = ?g"
   {
     fix i L1 R1 L2 R2 L R j SR1 SR2
     assume "((upd ^^ i)) init = ((L1,R1,SR1),(L2,R2,SR2))" "g i = (L,R)"
     hence "I L1 \<and> I L2 \<and> root_cond (p1,L1,R1) x \<and> root_cond (p2,L2,R2) y \<and>
       unique_root (p1, L1, R1) \<and> unique_root (p2, L2, R2) \<and> in_interval (L,R) (f x y) \<and> 
       (i = Suc j \<longrightarrow> sub_interval (g i) (g j) \<and> (R - L \<le> 3/4 * (snd (g j) - fst (g j))))
       \<and> SR1 = sgn (ipoly p1 R1) \<and> SR2 = sgn (ipoly p2 R2)"
     proof (induct i arbitrary: L1 R1 L2 R2 L R j SR1 SR2)
       case 0
       thus ?case using I rc1 rc2 ur bnd[of l1 l2 r1 r2 sr1 sr2 L R] g_def sr unfolding init_def by auto
     next
       case (Suc i)
       obtain l1 r1 l2 r2 sr1 sr2 where updi: "(upd ^^ i) init = ((l1, r1, sr1), l2, r2, sr2)" by (cases "(upd ^^ i) init", auto)
       obtain l r where bndi: "bnd ((l1, r1, sr1), l2, r2, sr2) = (l,r)" by force
       hence gi: "g i = (l,r)" using updi unfolding g_def by auto
       have "(upd ^^ Suc i) init = upd ((l1, r1, sr1), l2, r2, sr2)" using updi by simp
       from Suc(2)[unfolded this] have upd: "upd ((l1, r1, sr1), l2, r2, sr2) = ((L1, R1, SR1), L2, R2, SR2)" .
       from upd updi Suc(3) have bndsi: "bnd ((L1, R1, SR1), L2, R2, SR2) = (L,R)" by (auto simp: g_def)
       from Suc(1)[OF updi gi] have I: "I l1" "I l2" 
         and rc: "root_cond (p1,l1,r1) x" "root_cond (p2,l2,r2) y"
         and ur: "unique_root (p1, l1, r1)" "unique_root (p2, l2, r2)"
         and sr: "sr1 = sgn (ipoly p1 r1)" "sr2 = sgn (ipoly p2 r2)" 
         by auto
       from upd[unfolded upd_def] 
       have tight: "tighten_poly_bounds p1 l1 r1 sr1 = (L1, R1, SR1)" "tighten_poly_bounds p2 l2 r2 sr2 = (L2, R2, SR2)"
         by auto
       note tight1 = tighten_poly_bounds[OF tight(1) ur(1) pt(1) sr(1)]
       note tight2 = tighten_poly_bounds[OF tight(2) ur(2) pt(2) sr(2)]
       from tight1 have lr1: "l1 \<le> r1" by auto
       from tight2 have lr2: "l2 \<le> r2" by auto
       note ur1 = unique_rootD[OF ur(1)]
       note ur2 = unique_rootD[OF ur(2)]
       from tight1 I_mono[OF I(1)] have I1: "I L1" by auto
       from tight2 I_mono[OF I(2)] have I2: "I L2" by auto
       note ur1 = unique_root_sub_interval[OF ur(1) tight1(1,2,4)]
       note ur2 = unique_root_sub_interval[OF ur(2) tight2(1,2,4)]
       from rc(1) ur ur1 have x: "x = the_unique_root (p1,L1,R1)" by (auto intro!:the_unique_root_eqI)
       from rc(2) ur ur2 have y: "y = the_unique_root (p2,L2,R2)" by (auto intro!:the_unique_root_eqI)
       from unique_rootD[OF ur1(1)] x have x: "root_cond (p1,L1,R1) x" by auto
       from unique_rootD[OF ur2(1)] y have y: "root_cond (p2,L2,R2) y" by auto
       from tight(1) have half1: "(L1, R1) \<in> {(l1, (l1 + r1) / 2), ((l1 + r1) / 2, r1)}"
         unfolding tighten_poly_bounds_def Let_def by (auto split: if_splits)
       from tight(2) have half2: "(L2, R2) \<in> {(l2, (l2 + r2) / 2), ((l2 + r2) / 2, r2)}"
         unfolding tighten_poly_bounds_def Let_def by (auto split: if_splits)
       from approx[OF I lr1 lr2 bndi[symmetric] bndsi[symmetric] half1 half2]
       have "R - L \<le> 3 / 4 * (r - l) \<and> l \<le> L \<and> R \<le> r" .
       hence "sub_interval (g (Suc i)) (g i)" "R - L \<le> 3/4 * (snd (g i) - fst (g i))" 
         unfolding gi Suc(3) by auto
       with bnd[OF I1 I2 x y bndsi]
       show ?case using I1 I2 x y ur1 ur2 tight1(6) tight2(6) by auto
     qed
   } note invariants = this
   define L where "L = (\<lambda> i. fst (g i))"
   define R where "R = (\<lambda> i. snd (g i))"
   {
     fix i
     obtain l1 r1 l2 r2 sr1 sr2 where updi: "(upd ^^ i) init = ((l1, r1, sr1), l2, r2, sr2)" by (cases "(upd ^^ i) init", auto)
     obtain l r where bnd': "bnd ((l1, r1, sr1), l2, r2, sr2) = (l,r)" by force
     have gi: "g i = (l,r)" unfolding g_def updi bnd' by auto
     hence id: "l = L i" "r = R i" unfolding L_def R_def by auto
     from invariants[OF updi gi[unfolded id]] 
     have "in_interval (L i, R i) (f x y)" 
       "\<And> j. i = Suc j \<Longrightarrow> sub_interval (g i) (g j) \<and> R i - L i \<le> 3 / 4 * (R j - L j)"
       unfolding L_def R_def by auto
   } note * = this
   {
     fix i
     from *(1)[of i] *(2)[of "Suc i", OF refl]
     have "in_interval (g i) (f x y)" "sub_interval (g (Suc i)) (g i)" 
       "R (Suc i) - L (Suc i) \<le> 3 / 4 * (R i - L i)" unfolding L_def R_def by auto
   } note * = this
   show ?thesis unfolding upd_def[symmetric] init_def[symmetric] g_def[symmetric]
     unfolding converges_to_def 
   proof (intro conjI allI impI, rule *(1), rule *(2))
     fix eps :: real
     assume eps: "0 < eps"
     let ?r = real_of_rat 
     define r where "r = (\<lambda> n. ?r (R n))" 
     define l where "l = (\<lambda> n. ?r (L n))"
     define diff where "diff = (\<lambda> n. r n - l n)" 
     {
       fix n
       from *(3)[of n] have "?r (R (Suc n) - L (Suc n)) \<le> ?r (3 / 4 * (R n - L n))"
         unfolding of_rat_less_eq by simp
       also have "?r (R (Suc n) - L (Suc n)) = (r (Suc n) - l (Suc n))"
         unfolding of_rat_diff r_def l_def by simp
       also have "?r (3 / 4 * (R n - L n)) = 3 / 4 * (r n - l n)" 
         unfolding r_def l_def by (simp add: hom_distribs)
       finally have "diff (Suc n) \<le> 3 / 4 * diff n" unfolding diff_def .
     } note * = this
     {
       fix i
       have "diff i \<le> (3/4)^i * diff 0" 
       proof (induct i)
         case (Suc i)
         from Suc *[of i] show ?case by auto
       qed auto
     }
     then obtain c where *: "\<And> i. diff i \<le> (3/4)^i * c" by auto
     have "\<exists> n. diff n \<le> eps"
     proof (cases "c \<le> 0")
       case True
       with *[of 0] eps show ?thesis by (intro exI[of _ 0], auto)
     next
       case False  
       hence c: "c > 0" by auto
       with eps have "inverse c * eps > 0" by auto
       from exp_tends_to_zero[of "3/4 :: real", OF _ _ this] obtain n where 
         "(3/4) ^ n \<le> inverse c * eps" by auto
       from mult_right_mono[OF this, of c] c
       have "(3/4) ^ n * c \<le> eps" by (auto simp: field_simps)
       with *[of n] show ?thesis by (intro exI[of _ n], auto)
     qed
     then obtain n where "?r (R n) - ?r (L n) \<le> eps" unfolding l_def r_def diff_def by blast
     thus "\<exists>n l r. g n = (l, r) \<and> ?r r - ?r l \<le> eps" unfolding L_def R_def by (intro exI[of _ n], force)
   qed
 qed
 
 fun add_1 :: "real_alg_1 \<Rightarrow> real_alg_1 \<Rightarrow> real_alg_2" where
   "add_1 (p1,l1,r1) (p2,l2,r2) = (
      select_correct_factor_int_poly
        (tighten_poly_bounds_binary p1 p2)
        (\<lambda> ((l1,r1,sr1),(l2,r2,sr2)). (l1 + l2, r1 + r2))
        ((l1,r1,sgn (ipoly p1 r1)),(l2,r2, sgn (ipoly p2 r2))) 
        (poly_add p1 p2))"
 
 lemma add_1:
   assumes x: "invariant_1_2 x" and y: "invariant_1_2 y"
   defines z: "z \<equiv> add_1 x y"
   shows "invariant_2 z \<and> (real_of_2 z = real_of_1 x + real_of_1 y)"
 proof (cases x)
   case xt: (fields p1 l1 r1)
   show ?thesis
   proof (cases y)
     case yt: (fields p2 l2 r2)
     let ?x = "real_of_1 (p1, l1, r1)"
     let ?y = "real_of_1 (p2, l2, r2)"
     let ?p = "poly_add p1 p2"
     note x = x[unfolded xt]
     note y = y[unfolded yt]
     from x have ax: "p1 represents ?x" unfolding represents_def by (auto elim!: invariant_1E)
     from y have ay: "p2 represents ?y" unfolding represents_def by (auto elim!: invariant_1E)
     let ?bnd = "(\<lambda>((l1, r1, sr1 :: rat), l2 :: rat, r2 :: rat, sr2 :: rat). (l1 + l2, r1 + r2))"
     define bnd where "bnd = ?bnd"
     have "invariant_2 z \<and> real_of_2 z = ?x + ?y"
     proof (intro select_correct_factor_int_poly)
       from represents_add[OF ax ay]
       show "?p \<noteq> 0" "ipoly ?p (?x + ?y) = 0" by auto
       from z[unfolded xt yt]
       show sel: "select_correct_factor_int_poly
           (tighten_poly_bounds_binary p1 p2)
           bnd 
           ((l1,r1,sgn (ipoly p1 r1)),(l2,r2, sgn (ipoly p2 r2))) 
           (poly_add p1 p2) = z" by (auto simp: bnd_def)
       have ur1: "unique_root (p1,l1,r1)" "poly_cond2 p1" using x by auto
       have ur2: "unique_root (p2,l2,r2)" "poly_cond2 p2" using y by auto
       show "converges_to
         (\<lambda>i. bnd ((tighten_poly_bounds_binary p1 p2 ^^ i)
         ((l1,r1,sgn (ipoly p1 r1)),(l2,r2, sgn (ipoly p2 r2))))) (?x + ?y)"
         by (intro tighten_poly_bounds_binary ur1 ur2; force simp: bnd_def hom_distribs)
     qed
     thus ?thesis unfolding xt yt .
   qed
 qed
 
 declare add_rat_1.simps[simp del]
 declare add_1.simps[simp del]
 
 (* ********************* *)
 subsubsection\<open>Multiplication\<close>
   
 context
 begin
 private fun mult_rat_1_pos :: "rat \<Rightarrow> real_alg_1 \<Rightarrow> real_alg_2" where
   "mult_rat_1_pos r1 (p2,l2,r2) = real_alg_2 (cf_pos_poly (poly_mult_rat r1 p2), l2*r1, r2*r1)"
 
 private fun mult_1_pos :: "real_alg_1 \<Rightarrow> real_alg_1 \<Rightarrow> real_alg_2" where
   "mult_1_pos (p1,l1,r1) (p2,l2,r2) =
       select_correct_factor_int_poly 
         (tighten_poly_bounds_binary p1 p2)
         (\<lambda> ((l1,r1,sr1),(l2,r2,sr2)). (l1 * l2, r1 * r2))
         ((l1,r1,sgn (ipoly p1 r1)),(l2,r2, sgn (ipoly p2 r2))) 
         (poly_mult p1 p2)"
 
 fun mult_rat_1 :: "rat \<Rightarrow> real_alg_1 \<Rightarrow> real_alg_2" where
   "mult_rat_1 x y = 
     (if x < 0 then uminus_2 (mult_rat_1_pos (-x) y)
       else if x = 0 then Rational 0 else (mult_rat_1_pos x y))"
 
 fun mult_1 :: "real_alg_1 \<Rightarrow> real_alg_1 \<Rightarrow> real_alg_2" where
   "mult_1 x y = (case (x,y) of ((p1,l1,r1),(p2,l2,r2)) \<Rightarrow>
    if r1 > 0 then
      if r2 > 0 then mult_1_pos x y
      else uminus_2 (mult_1_pos x (uminus_1 y))
    else if r2 > 0 then uminus_2 (mult_1_pos (uminus_1 x) y)
      else mult_1_pos (uminus_1 x) (uminus_1 y))"
 
 lemma mult_rat_1_pos: fixes r1 :: rat assumes r1: "r1 > 0" and y: "invariant_1 y"
   defines z: "z \<equiv> mult_rat_1_pos r1 y"
   shows "invariant_2 z \<and> (real_of_2 z = of_rat r1 * real_of_1 y)" 
 proof -
   obtain p2 l2 r2 where yt: "y = (p2,l2,r2)" by (cases y, auto)
   let ?x = "real_of_rat r1"
   let ?y = "real_of_1 (p2, l2, r2)"
   let ?p = "poly_mult_rat r1 p2"
   let ?mp = "cf_pos_poly ?p"
   note y = y[unfolded yt]
   note yD = invariant_1D[OF y]
   from yD r1 have p: "?p \<noteq> 0" and r10: "r1 \<noteq> 0" by auto
   hence mp: "?mp \<noteq> 0" by simp
   from yD(1)
   have rt: "ipoly p2 ?y = 0" and bnd: "of_rat l2 \<le> ?y" "?y \<le> of_rat r2" by auto
   from rt r1 have rt: "ipoly ?mp (?x * ?y) = 0" by (auto simp add: field_simps ipoly_mult_rat[OF r10])
   from yD(5) have irr: "irreducible p2"
     unfolding represents_def using y unfolding root_cond_def split by auto
   from poly_mult_rat_irreducible[OF this _ r10] yD
   have irr: "irreducible ?mp" by simp
   from p have mon: "cf_pos ?mp" by auto
   obtain l r where lr: "l = l2 * r1" "r = r2 * r1" by force
   from bnd r1 have bnd: "of_rat l \<le> ?x * ?y" "?x * ?y \<le> of_rat r" unfolding lr of_rat_mult by auto
   with rt have rc: "root_cond (?mp,l,r) (?x * ?y)" unfolding root_cond_def by auto
   have ur: "unique_root (?mp,l,r)"
   proof (rule ex1I, rule rc)
     fix z
     assume "root_cond (?mp,l,r) z"
     from this[unfolded root_cond_def split] have bndz: "of_rat l \<le> z" "z \<le> of_rat r" 
       and rt: "ipoly ?mp z = 0" by auto
     have "fst (quotient_of r1) \<noteq> 0" using quotient_of_div[of r1] r10 by (cases "quotient_of r1", auto)
     with rt have rt: "ipoly p2 (z * inverse ?x) = 0" by (auto simp: ipoly_mult_rat[OF r10])
     from bndz r1 have "of_rat l2 \<le> z * inverse ?x" "z * inverse ?x \<le> of_rat r2" unfolding lr of_rat_mult
       by (auto simp: field_simps)
     with rt have "root_cond (p2,l2,r2) (z * inverse ?x)" unfolding root_cond_def by auto
     also note invariant_1_root_cond[OF y]
     finally have "?y = z * inverse ?x" by auto
     thus "z = ?x * ?y" using r1 by auto
   qed
   from r1 have sgnr: "sgn r = sgn r2" unfolding lr 
     by (cases "r2 = 0"; cases "r2 < 0"; auto simp: mult_neg_pos mult_less_0_iff)
   from r1 have sgnl: "sgn l = sgn l2" unfolding lr 
     by (cases "l2 = 0"; cases "l2 < 0"; auto simp: mult_neg_pos mult_less_0_iff)
   from the_unique_root_eqI[OF ur rc] have xy: "?x * ?y = the_unique_root (?mp,l,r)" by auto
   from z[unfolded yt, simplified, unfolded Let_def lr[symmetric] split]
   have z: "z = real_alg_2 (?mp, l, r)" by simp
   have yp2: "p2 represents ?y" using yD unfolding root_cond_def split represents_def by auto
   with irr mon have pc: "poly_cond ?mp" by (auto simp: poly_cond_def cf_pos_def)
   have rc: "invariant_1 (?mp, l, r)" unfolding z using yD(2) pc ur 
     by (auto simp add: invariant_1_def ur mp sgnr sgnl)
   show ?thesis unfolding z using real_alg_2[OF rc]
     unfolding yt xy unfolding z by simp
 qed
 
 lemma mult_1_pos: assumes x: "invariant_1_2 x" and y: "invariant_1_2 y"
   defines z: "z \<equiv> mult_1_pos x y"
   assumes pos: "real_of_1 x > 0" "real_of_1 y > 0"
   shows "invariant_2 z \<and> (real_of_2 z = real_of_1 x * real_of_1 y)" 
 proof -
   obtain p1 l1 r1 where xt: "x = (p1,l1,r1)" by (cases x, auto)
   obtain p2 l2 r2 where yt: "y = (p2,l2,r2)" by (cases y, auto)
   let ?x = "real_of_1 (p1, l1, r1)"
   let ?y = "real_of_1 (p2, l2, r2)"
   let ?r = "real_of_rat"
   let ?p = "poly_mult p1 p2"
   note x = x[unfolded xt]
   note y = y[unfolded yt]
   from x y have basic: "unique_root (p1, l1, r1)" "poly_cond2 p1" "unique_root (p2, l2, r2)" "poly_cond2 p2" by auto
   from basic have irr1: "irreducible p1" and irr2: "irreducible p2" by auto
   from x have ax: "p1 represents ?x" unfolding represents_def by (auto elim!:invariant_1E)
   from y have ay: "p2 represents ?y" unfolding represents_def by (auto elim!:invariant_1E)
   from ax ay pos[unfolded xt yt] have axy: "?p represents (?x * ?y)"
     by (intro represents_mult represents_irr_non_0[OF irr2], auto)
   from representsD[OF this] have p: "?p \<noteq> 0" and rt: "ipoly ?p (?x * ?y) = 0" .
   from x pos(1)[unfolded xt] have "?r r1 > 0" unfolding split by auto
   hence "sgn r1 = 1" unfolding sgn_rat_def by (auto split: if_splits)
   with x have "sgn l1 = 1" by auto
   hence l1_pos: "l1 > 0" unfolding sgn_rat_def by (cases "l1 = 0"; cases "l1 < 0"; auto)
   from y pos(2)[unfolded yt] have "?r r2 > 0" unfolding split by auto
   hence "sgn r2 = 1" unfolding sgn_rat_def by (auto split: if_splits)
   with y have "sgn l2 = 1" by auto
   hence l2_pos: "l2 > 0" unfolding sgn_rat_def by (cases "l2 = 0"; cases "l2 < 0"; auto)
   let ?bnd = "(\<lambda>((l1, r1, sr1 :: rat), l2 :: rat, r2 :: rat, sr2 :: rat). (l1 * l2, r1 * r2))"
   define bnd where "bnd = ?bnd"
   obtain z' where sel: "select_correct_factor_int_poly
         (tighten_poly_bounds_binary p1 p2)
         bnd 
         ((l1,r1,sgn (ipoly p1 r1)),(l2,r2, sgn (ipoly p2 r2))) 
         ?p = z'" by auto
   have main: "invariant_2 z' \<and> real_of_2 z' = ?x * ?y"
   proof (rule select_correct_factor_int_poly[OF _ sel rt p])
     {
       fix l1 r1 l2 r2 l1' r1' l2' r2' l l' r r' :: rat
       let ?m1 = "(l1+r1)/2" let ?m2 = "(l2+r2)/2"
       define d1 where "d1 = r1 - l1" 
       define d2 where "d2 = r2 - l2"
       let ?M1 = "l1 + d1/2" let ?M2 = "l2 + d2/2"
       assume le: "l1 > 0" "l2 > 0" "l1 \<le> r1" "l2 \<le> r2" and id: "(l, r) = (l1 * l2, r1 * r2)"
         "(l', r') = (l1' * l2', r1' * r2')" 
         and mem: "(l1', r1') \<in> {(l1, ?m1), (?m1, r1)}"
           "(l2', r2') \<in> {(l2, ?m2), (?m2, r2)}"
       hence id: "l = l1 * l2" "r = (l1 + d1) * (l2 + d2)" "l' = l1' * l2'" "r' = r1' * r2'" 
         "r1 = l1 + d1" "r2 = l2 + d2" and id': "?m1 = ?M1" "?m2 = ?M2"
         unfolding d1_def d2_def by (auto simp: field_simps)
       define l1d1 where "l1d1 = l1 + d1"
       from le have ge0: "d1 \<ge> 0" "d2 \<ge> 0" "l1 \<ge> 0" "l2 \<ge> 0" unfolding d1_def d2_def by auto
       have "4 * (r' - l') \<le> 3 * (r - l)" 
       proof (cases "l1' = l1 \<and> r1' = ?M1 \<and> l2' = l2 \<and> r2' = ?M2")
         case True
         hence id2: "l1' = l1" "r1' = ?M1" "l2' = l2" "r2' = ?M2" by auto
         show ?thesis unfolding id id2 unfolding ring_distribs using ge0 by simp 
       next
         case False note 1 = this
         show ?thesis
         proof (cases "l1' = l1 \<and> r1' = ?M1 \<and> l2' = ?M2 \<and> r2' = r2")
           case True
           hence id2: "l1' = l1" "r1' = ?M1" "l2' = ?M2" "r2' = r2" by auto
           show ?thesis unfolding id id2 unfolding ring_distribs using ge0 by simp
         next
           case False note 2 = this
           show ?thesis
           proof (cases "l1' = ?M1 \<and> r1' = r1 \<and> l2' = l2 \<and> r2' = ?M2")
             case True
             hence id2: "l1' = ?M1" "r1' = r1" "l2' = l2" "r2' = ?M2" by auto
           show ?thesis unfolding id id2 unfolding ring_distribs using ge0 by simp
           next
             case False note 3 = this
             from 1 2 3 mem have id2: "l1' = ?M1" "r1' = r1" "l2' = ?M2" "r2' = r2"
               unfolding id' by auto
           show ?thesis unfolding id id2 unfolding ring_distribs using ge0 by simp
           qed
         qed
       qed
       hence "r' - l' \<le> 3 / 4 * (r - l)" by simp
     } note decr = this
     show "converges_to
         (\<lambda>i. bnd ((tighten_poly_bounds_binary p1 p2 ^^ i)
         ((l1,r1,sgn (ipoly p1 r1)),(l2,r2, sgn (ipoly p2 r2))))) (?x * ?y)"
     proof (intro tighten_poly_bounds_binary[where f = "(*)" and I = "\<lambda> l. l > 0"]
       basic l1_pos l2_pos, goal_cases)
       case (1 L1 R1 L2 R2 L R)
       hence "L = L1 * L2" "R = R1 * R2" unfolding bnd_def by auto
       hence id: "?r L = ?r L1 * ?r L2" "?r R = ?r R1 * ?r R2" by (auto simp: hom_distribs)
       from 1(3-4) have le: "?r L1 \<le> ?x" "?x \<le> ?r R1" "?r L2 \<le> ?y" "?y \<le> ?r R2" 
         unfolding root_cond_def by auto
       from 1(1-2) have lt: "0 < ?r L1" "0 < ?r L2" by auto
       from mult_mono[OF le(1,3), folded id] lt le have L: "?r L \<le> ?x * ?y" by linarith
       have R: "?x * ?y \<le> ?r R"
         by (rule mult_mono[OF le(2,4), folded id], insert lt le, linarith+)
       show ?case using L R by blast
     next
       case (2 l1 r1 l2 r2 l1' r1' l2' r2' l l' r r')
       from 2(5-6) have lr: "l = l1 * l2" "r = r1 * r2" "l' = l1' * l2'" "r' = r1' * r2'"
         unfolding bnd_def by auto      
       from 2(1-4) have le: "0 < l1" "0 < l2" "l1 \<le> r1" "l2 \<le> r2" by auto
       from 2(7-8) le have le': "l1 \<le> l1'" "r1' \<le> r1" "l2 \<le> l2'" "r2' \<le> r2" "0 < r2'" "0 < r2" by auto
       from mult_mono[OF le'(1,3), folded lr] le le' have l: "l \<le> l'" by auto
       have r: "r' \<le> r" by (rule mult_mono[OF le'(2,4), folded lr], insert le le', linarith+)
       have "r' - l' \<le> 3 / 4 * (r - l)"
         by (rule decr[OF _ _ _ _ _ _ 2(7-8)], insert le le' lr, auto)
       thus ?case using l r by blast
     qed auto
   qed
   have z': "z' = z" unfolding z[unfolded xt yt, simplified, unfolded bnd_def[symmetric] sel]
     by auto
   from main[unfolded this] show ?thesis unfolding xt yt by simp
 qed
   
 lemma mult_1: assumes x: "invariant_1_2 x" and y: "invariant_1_2 y"
   defines z[simp]: "z \<equiv> mult_1 x y"
   shows "invariant_2 z \<and> (real_of_2 z = real_of_1 x * real_of_1 y)" 
 proof -
   obtain p1 l1 r1 where xt[simp]: "x = (p1,l1,r1)" by (cases x)
   obtain p2 l2 r2 where yt[simp]: "y = (p2,l2,r2)" by (cases y)
   let ?xt = "(p1, l1, r1)"
   let ?yt = "(p2, l2, r2)"
   let ?x = "real_of_1 ?xt"
   let ?y = "real_of_1 ?yt"
   let ?mxt = "uminus_1 ?xt"
   let ?myt = "uminus_1 ?yt"
   let ?mx = "real_of_1 ?mxt"
   let ?my = "real_of_1 ?myt"
   let ?r = "real_of_rat"
   from invariant_1_2_of_rat[OF x, of 0] have x0: "?x < 0 \<or> ?x > 0" by auto
   from invariant_1_2_of_rat[OF y, of 0] have y0: "?y < 0 \<or> ?y > 0" by auto
   from uminus_1_2[OF x] have mx: "invariant_1_2 ?mxt" and [simp]: "?mx = - ?x" by auto
   from uminus_1_2[OF y] have my: "invariant_1_2 ?myt" and [simp]: "?my = - ?y" by auto
   have id: "r1 > 0 \<longleftrightarrow> ?x > 0" "r1 < 0 \<longleftrightarrow> ?x < 0" "r2 > 0 \<longleftrightarrow> ?y > 0" "r2 < 0 \<longleftrightarrow> ?y < 0"
     using x y by auto
   show ?thesis
   proof (cases "?x > 0")
     case x0: True
     show ?thesis 
     proof (cases "?y > 0")
       case y0: True
       with x y x0 mult_1_pos[OF x y] show ?thesis by auto
     next
       case False
       with y0 have y0: "?y < 0" by auto
       with x0 have z: "z = uminus_2 (mult_1_pos ?xt ?myt)"
         unfolding z xt yt mult_1.simps split id by simp
       from x0 y0 mult_1_pos[OF x my] uminus_2[of "mult_1_pos ?xt ?myt"]
       show ?thesis unfolding z by simp
     qed
   next
     case False
     with x0 have x0: "?x0 < 0" by simp
     show ?thesis
     proof (cases "?y > 0")
       case y0: True
       with x0 x y id have z: "z = uminus_2 (mult_1_pos ?mxt ?yt)" by simp
       from x0 y0 mult_1_pos[OF mx y] uminus_2[of "mult_1_pos ?mxt ?yt"]
       show ?thesis unfolding z by auto
     next
       case False
       with y0 have y0: "?y < 0" by simp
       with x0 x y have z: "z = mult_1_pos ?mxt ?myt" by auto
       with x0 y0 x y mult_1_pos[OF mx my]
       show ?thesis unfolding z by auto
     qed
   qed
 qed
   
 
 lemma mult_rat_1: fixes x assumes y: "invariant_1 y"  
   defines z: "z \<equiv> mult_rat_1 x y"
   shows "invariant_2 z \<and> (real_of_2 z = of_rat x * real_of_1 y)" 
 proof (cases y)
   case yt: (fields p2 l2 r2)
   let ?yt = "(p2, l2, r2)"
   let ?x = "real_of_rat x"
   let ?y = "real_of_1 ?yt"
   let ?myt = "mult_rat_1_pos (- x) ?yt"
   note y = y[unfolded yt]
   note z = z[unfolded yt]
   show ?thesis
   proof(cases x "0::rat" rule:linorder_cases)
     case x: greater
     with z have z: "z = mult_rat_1_pos x ?yt" by simp
     from mult_rat_1_pos[OF x y] 
     show ?thesis unfolding yt z by auto
   next
     case less
     then have x: "- x > 0" by auto
     hence z: "z = uminus_2 ?myt" unfolding z by simp
     from mult_rat_1_pos[OF x y] have rc: "invariant_2 ?myt"
       and rr: "real_of_2 ?myt = - ?x * ?y" by (auto simp: hom_distribs)
     from uminus_2[OF rc] rr show ?thesis unfolding z[symmetric] unfolding yt[symmetric]
       by simp
   qed (auto simp: z)
 qed
 end
   
 declare mult_1.simps[simp del]
 declare mult_rat_1.simps[simp del]
 
 (* ********************* *)
 subsubsection\<open>Root\<close>
 
 definition ipoly_root_delta :: "int poly \<Rightarrow> real" where
   "ipoly_root_delta p = Min (insert 1 { abs (x - y) | x y. ipoly p x = 0 \<and> ipoly p y = 0 \<and> x \<noteq> y}) / 4"
 
 lemma ipoly_root_delta: assumes "p \<noteq> 0"
   shows "ipoly_root_delta p > 0"
     "2 \<le> card (Collect (root_cond (p, l, r))) \<Longrightarrow> ipoly_root_delta p \<le> real_of_rat (r - l) / 4"
 proof -
   let ?z = "0 :: real"
   let ?R = "{x. ipoly p x = ?z}"
   let ?set = "{ abs (x - y) | x y. ipoly p x = ?z  \<and> ipoly p y = 0 \<and> x \<noteq> y}"
   define S where "S = insert 1 ?set"
   from finite_ipoly_roots[OF assms] have finR: "finite ?R" and fin: "finite (?R \<times> ?R)" by auto
   have "finite ?set"
     by (rule finite_subset[OF _ finite_imageI[OF fin, of "\<lambda> (x,y). abs (x - y)"]], force)
   hence fin: "finite S" and ne: "S \<noteq> {}" and pos: "\<And> x. x \<in> S \<Longrightarrow> x > 0" unfolding S_def by auto
   have delta: "ipoly_root_delta p = Min S / 4" unfolding ipoly_root_delta_def S_def ..
   have pos: "Min S > 0" using fin ne pos by auto
   show "ipoly_root_delta p > 0" unfolding delta using pos by auto
   let ?S = "Collect (root_cond (p, l, r))"
   assume "2 \<le> card ?S"
   hence 2: "Suc (Suc 0) \<le> card ?S" by simp
   from 2[unfolded card_le_Suc_iff[of _ ?S]] obtain x T where 
     ST: "?S = insert x T" and xT: "x \<notin> T" and 1: "Suc 0 \<le> card T" by auto
   from 1[unfolded card_le_Suc_iff[of _ T]] obtain y where yT: "y \<in> T" by auto
   from ST xT yT have x: "x \<in> ?S" and y: "y \<in> ?S" and xy: "x \<noteq> y" by auto
   hence "abs (x - y) \<in> S" unfolding S_def root_cond_def[abs_def] by auto
   with fin have "Min S \<le> abs (x - y)" by auto
   with pos have le: "Min S / 2 \<le> abs (x - y) / 2" by auto
   from x y have "abs (x - y) \<le> of_rat r - of_rat l" unfolding root_cond_def[abs_def] by auto
   also have "\<dots> = of_rat (r - l)" by (auto simp: of_rat_diff)
   finally have "abs (x - y) / 2 \<le> of_rat (r - l) / 2" by auto
   with le show "ipoly_root_delta p \<le> real_of_rat (r - l) / 4" unfolding delta by auto
 qed
 
 lemma sgn_less_eq_1_rat: fixes a b :: rat
   shows "sgn a = 1 \<Longrightarrow> a \<le> b \<Longrightarrow> sgn b = 1" 
   by (metis (no_types, hide_lams) not_less one_neq_neg_one one_neq_zero order_trans sgn_rat_def)
 
 lemma sgn_less_eq_1_real: fixes a b :: real
   shows "sgn a = 1 \<Longrightarrow> a \<le> b \<Longrightarrow> sgn b = 1" 
   by (metis (no_types, hide_lams) not_less one_neq_neg_one one_neq_zero order_trans sgn_real_def)
 
 definition compare_1_rat :: "real_alg_1 \<Rightarrow> rat \<Rightarrow> order" where
   "compare_1_rat rai = (let p = poly_real_alg_1 rai in
     if degree p = 1 then let x = Rat.Fract (- coeff p 0) (coeff p 1)
      in (\<lambda> y. compare y x)
     else (\<lambda> y. compare_rat_1 y rai))" 
 
 lemma compare_real_of_rat: "compare (real_of_rat x) (of_rat y) = compare x y" 
   unfolding compare_rat_def compare_real_def comparator_of_def of_rat_less by auto
 
 lemma compare_1_rat: assumes rc: "invariant_1 y"
   shows "compare_1_rat y x = compare (of_rat x) (real_of_1 y)"
 proof (cases "degree (poly_real_alg_1 y)" "Suc 0" rule: linorder_cases)
   case less with invariant_1_degree_0[OF rc] show ?thesis by auto
 next
   case deg: greater
   with rc have rc: "invariant_1_2 y" by auto
   from deg compare_rat_1[OF rc, of x]
   show ?thesis unfolding compare_1_rat_def by auto
 next
   case deg: equal
   obtain p l r where y: "y = (p,l,r)" by (cases y)
   note rc = invariant_1D[OF rc[unfolded y]]
   from deg have p: "degree p = Suc 0" 
     and id: "compare_1_rat y x = compare x (Rat.Fract (- coeff p 0) (coeff p 1))" 
     unfolding compare_1_rat_def by (auto simp: Let_def y)
   from rc(1)[unfolded split] have "ipoly p (real_of_1 y) = 0" 
     unfolding y by auto
   with degree_1_ipoly[OF p, of "real_of_1 y"] 
   have id': "real_of_1 y = real_of_rat (Rat.Fract (- coeff p 0) (coeff p 1))" by simp
   show ?thesis unfolding id id' compare_real_of_rat ..
 qed
   
 context
   fixes n :: nat
 begin
 private definition initial_lower_bound :: "rat \<Rightarrow> rat" where 
   "initial_lower_bound l = (if l \<le> 1 then l else of_int (root_rat_floor n l))"
 
 private definition initial_upper_bound :: "rat \<Rightarrow> rat" where
   "initial_upper_bound r = (of_int (root_rat_ceiling n r))"
   
 context
   fixes cmpx :: "rat \<Rightarrow> order" 
 begin  
 fun tighten_bound_root :: 
   "rat \<times> rat \<Rightarrow> rat \<times> rat" where
   "tighten_bound_root (l',r') = (let 
       m' = (l' + r') / 2;
       m = m' ^ n      
       in case cmpx m of 
          Eq \<Rightarrow> (m',m')
        | Lt \<Rightarrow> (m',r')
        | Gt \<Rightarrow> (l',m'))" 
   
 lemma tighten_bound_root: assumes sgn: "sgn il = 1" "real_of_1 x \<ge> 0" and
   il: "real_of_rat il \<le> root n (real_of_1 x)" and 
   ir: "root n (real_of_1 x) \<le> real_of_rat ir" and
   rai: "invariant_1 x" and
   cmpx: "cmpx = compare_1_rat x" and
   n: "n \<noteq> 0" 
 shows "converges_to (\<lambda> i. (tighten_bound_root ^^ i) (il, ir))
      (root n (real_of_1 x))" (is "converges_to ?f ?x")
   unfolding converges_to_def
 proof (intro conjI impI allI)
   {
     fix x :: real
     have "x \<ge> 0 \<Longrightarrow> (root n x) ^ n = x" using n by simp
   } note root_exp_cancel = this
   {
     fix x :: real
     have "x \<ge> 0 \<Longrightarrow> root n (x ^ n) = x" using n
       using real_root_pos_unique by blast
   } note root_exp_cancel' = this
   from il ir have "real_of_rat il \<le> of_rat ir" by auto
   hence ir_il: "il \<le> ir" by (auto simp: of_rat_less_eq)
   from n have n': "n > 0" by auto
   {
     fix i
     have "in_interval (?f i) ?x \<and> sub_interval (?f i) (il,ir) \<and> (i \<noteq> 0 \<longrightarrow> sub_interval (?f i) (?f (i - 1))) 
       \<and> snd (?f i) - fst (?f i) \<le> (ir - il) / 2^i"
     proof (induct i)
       case 0
       show ?case using il ir by auto
     next
       case (Suc i)
       obtain l' r' where id: "(tighten_bound_root ^^ i) (il, ir) = (l',r')" 
         by (cases "(tighten_bound_root ^^ i) (il, ir)", auto)
       let ?m' = "(l' + r') / 2" 
       let ?m = "?m' ^ n" 
       define m where "m = ?m" 
       note IH = Suc[unfolded id split snd_conv fst_conv] 
       from IH have "sub_interval (l', r') (il, ir)" by auto
       hence ill': "il \<le> l'" "r' \<le> ir" by auto
       with sgn have l'0: "l' > 0" using sgn_1_pos sgn_less_eq_1_rat by blast
       from IH have lr'x: "in_interval (l', r') ?x" by auto
       hence lr'': "real_of_rat l' \<le> of_rat r'" by auto
       hence lr': "l' \<le> r'" unfolding of_rat_less_eq .
       with l'0 have r'0: "r' > 0" by auto
       note compare = compare_1_rat[OF rai, of ?m, folded cmpx]
       from IH have *: "r' - l' \<le> (ir - il) / 2 ^ i" by auto
       have "r' - (l' + r') / 2 = (r' - l') / 2" by (simp add: field_simps)
       also have "\<dots> \<le> (ir - il) / 2 ^ i / 2" using * 
         by (rule divide_right_mono, auto)  
       finally have size: "r' - (l' + r') / 2 \<le> (ir - il) / (2 * 2 ^ i)" by simp
       also have "r' - (l' + r') / 2 = (l' + r') / 2 - l'" by auto
       finally have size': "(l' + r') / 2 - l' \<le> (ir - il) / (2 * 2 ^ i)" by simp
       have "root n (real_of_rat ?m) = root n ((real_of_rat ?m') ^ n)" by (simp add: hom_distribs)
       also have "\<dots> = real_of_rat ?m'" 
         by (rule root_exp_cancel', insert l'0 lr', auto)
       finally have root: "root n (of_rat ?m) = of_rat ?m'" .
       show ?case 
       proof (cases "cmpx ?m")
         case Eq
         from compare[unfolded Eq] have "real_of_1 x = of_rat ?m" 
           unfolding compare_real_def comparator_of_def by (auto split: if_splits)
         from arg_cong[OF this, of "root n"] have "?x = root n (of_rat ?m)" .
         also have "\<dots> = root n  (real_of_rat ?m') ^ n"
           using n real_root_power by (auto simp: hom_distribs)
         also have "\<dots> = of_rat ?m'" 
           by (rule root_exp_cancel, insert IH sgn(2) l'0 r'0, auto)
         finally have x: "?x = of_rat ?m'"  .
         show ?thesis using x id Eq lr' ill' ir_il by (auto simp: Let_def)
       next
         case Lt 
         from compare[unfolded Lt] have lt: "of_rat ?m \<le> real_of_1 x" 
           unfolding compare_real_def comparator_of_def by (auto split: if_splits)
         have id'': "?f (Suc i) = (?m',r')" "?f (Suc i - 1) = (l',r')"  
           using Lt id by (auto simp add: Let_def)
         from real_root_le_mono[OF n' lt] 
         have "of_rat ?m' \<le> ?x" unfolding root by simp
         with lr'x lr'' have ineq': "real_of_rat l' + real_of_rat r' \<le> ?x * 2" by (auto simp: hom_distribs)
         show ?thesis unfolding id'' 
           by (auto simp: Let_def hom_distribs, insert size ineq' lr' ill' lr'x ir_il, auto)
       next
         case Gt
         from compare[unfolded Gt] have lt: "of_rat ?m \<ge> real_of_1 x" 
           unfolding compare_real_def comparator_of_def by (auto split: if_splits)
         have id'': "?f (Suc i) = (l',?m')" "?f (Suc i - 1) = (l',r')"  
           using Gt id by (auto simp add: Let_def)
         from real_root_le_mono[OF n' lt] 
         have "?x \<le> of_rat ?m'" unfolding root by simp
         with lr'x lr'' have ineq': "?x * 2 \<le> real_of_rat l' + real_of_rat r'" by (auto simp: hom_distribs)
         show ?thesis unfolding id'' 
           by (auto simp: Let_def hom_distribs, insert size' ineq' lr' ill' lr'x ir_il, auto)
       qed
     qed
   } note main = this
   fix i
   from main[of i] show "in_interval (?f i) ?x" by auto
   from main[of "Suc i"] show "sub_interval (?f (Suc i)) (?f i)" by auto
   fix eps :: real
   assume eps: "0 < eps" 
   define c where "c = eps / (max (real_of_rat (ir - il)) 1)" 
   have c0: "c > 0" using eps unfolding c_def by auto    
   from exp_tends_to_zero[OF _ _ this, of "1/2"] obtain i where c: "(1/2)^i \<le> c" by auto
   obtain l' r' where fi: "?f i = (l',r')" by force
   from main[of i, unfolded fi] have le: "r' - l' \<le> (ir - il) / 2 ^ i" by auto
   have iril: "real_of_rat (ir - il) \<ge> 0" using ir_il by (auto simp: of_rat_less_eq)
   show "\<exists>n la ra. ?f n = (la, ra) \<and> real_of_rat ra - real_of_rat la \<le> eps" 
   proof (intro conjI exI, rule fi)
     have "real_of_rat r' - of_rat l' = real_of_rat (r' - l')" by (auto simp: hom_distribs)
     also have "\<dots> \<le> real_of_rat ((ir - il) / 2 ^ i)" using le unfolding of_rat_less_eq .
     also have "\<dots> = (real_of_rat (ir - il)) * ((1/2) ^ i)" by (simp add: field_simps hom_distribs)
     also have "\<dots> \<le> (real_of_rat (ir - il)) * c" 
       by (rule mult_left_mono[OF c iril])
     also have "\<dots> \<le> eps"
     proof (cases "real_of_rat (ir - il) \<le> 1")
       case True
       hence "c = eps" unfolding c_def by (auto simp: hom_distribs)
       thus ?thesis using eps True by auto
     next
       case False
       hence "max (real_of_rat (ir - il)) 1 = real_of_rat (ir - il)" "real_of_rat (ir - il) \<noteq> 0" 
         by (auto simp: hom_distribs)
       hence "(real_of_rat (ir - il)) * c = eps" unfolding c_def by auto
       thus ?thesis by simp
     qed
     finally show "real_of_rat r' - of_rat l' \<le> eps" .
   qed
 qed
 end
 
 private fun root_pos_1 :: "real_alg_1 \<Rightarrow> real_alg_2" where
   "root_pos_1 (p,l,r) = (
       (select_correct_factor_int_poly 
         (tighten_bound_root (compare_1_rat (p,l,r)))
         (\<lambda> x. x)
         (initial_lower_bound l, initial_upper_bound r)
         (poly_nth_root n p)))"
 
 fun root_1 :: "real_alg_1 \<Rightarrow> real_alg_2" where
 "root_1 (p,l,r) = (
   if n = 0 \<or> r = 0 then Rational 0
   else if r > 0 then root_pos_1 (p,l,r)
   else uminus_2 (root_pos_1 (uminus_1 (p,l,r))))"
 
 context
   assumes n: "n \<noteq> 0"
 begin
 
 lemma initial_upper_bound: assumes x: "x > 0" and xr: "x \<le> of_rat r"
   shows "sgn (initial_upper_bound r) = 1" "root n x \<le> of_rat (initial_upper_bound r)"
 proof -
   have n: "n > 0" using n by auto
   note d = initial_upper_bound_def
   let ?r = "initial_upper_bound r"
   from x xr have r0: "r > 0" by (meson not_less of_rat_le_0_iff order_trans)
   hence "of_rat r > (0 :: real)" by auto
   hence "root n (of_rat r) > 0" using n by simp
   hence "1 \<le> ceiling (root n (of_rat r))" by auto
   hence "(1 :: rat) \<le> of_int (ceiling (root n (of_rat r)))" by linarith
   also have "\<dots> = ?r" unfolding d by simp
   finally show "sgn ?r = 1" unfolding sgn_rat_def by auto
   have "root n x \<le> root n (of_rat r)"
     unfolding real_root_le_iff[OF n] by (rule xr)
   also have "\<dots> \<le> of_rat ?r" unfolding d by simp
   finally show "root n x \<le> of_rat ?r" .
 qed
 
 lemma initial_lower_bound: assumes l: "l > 0" and lx: "of_rat l \<le> x"
   shows "sgn (initial_lower_bound l) = 1" "of_rat (initial_lower_bound l) \<le> root n x"
 proof -
   have n: "n > 0" using n by auto
   note d = initial_lower_bound_def
   let ?l = "initial_lower_bound l"
   from l lx have x0: "x > 0" by (meson not_less of_rat_le_0_iff order_trans)
   have "sgn ?l = 1 \<and> of_rat ?l \<le> root n x"
   proof (cases "l \<le> 1")
     case True
     hence ll: "?l = l" and l0: "of_rat l \<ge> (0 :: real)" and l1: "of_rat l \<le> (1 :: real)" 
       using l unfolding True d by auto
     have sgn: "sgn ?l = 1" using l unfolding ll by auto
     have "of_rat ?l = of_rat l" unfolding ll by simp
     also have "of_rat l \<le> root n (of_rat l)" using real_root_increasing[OF _ _ l0 l1, of 1 n] n
       by (cases "n = 1", auto)
     also have "\<dots> \<le> root n x" using lx unfolding real_root_le_iff[OF n] .
     finally show ?thesis using sgn by auto
   next
     case False
     hence l: "(1 :: real) \<le> of_rat l" and ll: "?l = of_int (floor (root n (of_rat l)))" 
       unfolding d by auto
     hence "root n 1 \<le> root n (of_rat l)"
       unfolding real_root_le_iff[OF n] by auto
     hence "1 \<le> root n (of_rat l)" using n by auto
     from floor_mono[OF this] have "1 \<le> ?l"
       using one_le_floor unfolding ll by fastforce
     hence sgn: "sgn ?l = 1" by simp
     have "of_rat ?l \<le> root n (of_rat l)" unfolding ll by simp
     also have "\<dots> \<le> root n x" using lx unfolding real_root_le_iff[OF n] .
     finally have "of_rat ?l \<le> root n x" .
     with sgn show ?thesis by auto
   qed
   thus "sgn ?l = 1" "of_rat ?l \<le> root n x" by auto
 qed
 
 lemma root_pos_1:
   assumes x: "invariant_1 x" and pos: "rai_ub x > 0"
   defines y: "y \<equiv> root_pos_1 x"
   shows "invariant_2 y \<and> real_of_2 y = root n (real_of_1 x)"
 proof (cases x)
   case (fields p l r)
   let ?l = "initial_lower_bound l"
   let ?r = "initial_upper_bound r"
   from x fields have rai: "invariant_1 (p,l,r)" by auto
   note * = invariant_1D[OF this]
   let ?x = "the_unique_root (p,l,r)"
   from pos[unfolded fields] *
   have sgnl: "sgn l = 1" by auto
   from sgnl have l0: "l > 0" by (unfold sgn_1_pos)
   hence ll0: "real_of_rat l > 0" by auto
   from * have lx: "of_rat l \<le> ?x" by auto
   with ll0 have x0: "?x > 0" by linarith
   note il = initial_lower_bound[OF l0 lx]
   from * have "?x \<le> of_rat r" by auto
   note iu = initial_upper_bound[OF x0 this]
   let ?p = "poly_nth_root n p"
   from x0 have id: "root n ?x ^ n = ?x" using n real_root_pow_pos by blast
   have rc: "root_cond (?p, ?l, ?r) (root n ?x)"
     using il iu * by (intro root_condI, auto simp: ipoly_nth_root id)
   hence root: "ipoly ?p (root n (real_of_1 x)) = 0" 
     unfolding root_cond_def fields by auto
   from * have "p \<noteq> 0" by auto
   hence p': "?p \<noteq> 0" using poly_nth_root_0[of n p] n by auto
   have tbr: "0 \<le> real_of_1 x"
             "real_of_rat (initial_lower_bound l) \<le> root n (real_of_1 x)"
             "root n (real_of_1 x) \<le> real_of_rat (initial_upper_bound r)"
      using x0 il(2) iu(2) fields by auto
   from select_correct_factor_int_poly[OF tighten_bound_root[OF il(1)[folded fields] tbr x refl n] refl root p']
   show ?thesis by (simp add: y fields)
 qed
 
 end
 
 lemma root_1: assumes x: "invariant_1 x"
   defines y: "y \<equiv> root_1 x"
   shows "invariant_2 y \<and> (real_of_2 y = root n (real_of_1 x))"
 proof (cases "n = 0 \<or> rai_ub x = 0")
   case True
   with x have "n = 0 \<or> real_of_1 x = 0" by (cases x, auto)
   then have "root n (real_of_1 x) = 0" by auto
   then show ?thesis unfolding y root_1.simps
     using x by (cases x, auto)
 next
   case False with x have n: "n \<noteq> 0" and x0: "real_of_1 x \<noteq> 0" by (simp, cases x, auto)
   note rt = root_pos_1
   show ?thesis
   proof (cases "rai_ub x" "0::rat" rule:linorder_cases)
     case greater
     with rt[OF n x this] n show ?thesis by (unfold y, cases x, simp)
   next
     case less
     let ?um = "uminus_1"
     let ?rt = "root_pos_1"
     from n less y x0 have y: "y = uminus_2 (?rt (?um x))" by (cases x, auto)
     from uminus_1[OF x] have umx: "invariant_1 (?um x)" and umx2: "real_of_1 (?um x) = - real_of_1 x" by auto
     with x less have "0 < rai_ub (uminus_1 x)"
       by (cases x, auto simp: uminus_1.simps Let_def)
     from rt[OF n umx this] umx2 have rumx: "invariant_2 (?rt (?um x))" 
       and rumx2: "real_of_2 (?rt (?um x)) = root n (- real_of_1 x)"
       by auto
     from uminus_2[OF rumx] rumx2 y real_root_minus show ?thesis by auto
   next
     case equal with x0 x show ?thesis by (cases x, auto)
   qed
 qed
 end
   
 declare root_1.simps[simp del]
 
 (* ********************** *)
 subsubsection \<open>Embedding of Rational Numbers\<close>
 
 definition of_rat_1 :: "rat \<Rightarrow> real_alg_1" where
   "of_rat_1 x \<equiv> (poly_rat x,x,x)"
 
 lemma of_rat_1:
   shows "invariant_1 (of_rat_1 x)" and "real_of_1 (of_rat_1 x) = of_rat x"
   unfolding of_rat_1_def
 by (atomize(full), intro invariant_1_realI unique_rootI poly_condI, auto )
 
 fun info_2 :: "real_alg_2 \<Rightarrow> rat + int poly \<times> nat" where
   "info_2 (Rational x) = Inl x"
 | "info_2 (Irrational n (p,l,r)) = Inr (p,n)" 
     
 lemma info_2_card: assumes rc: "invariant_2 x"
   shows "info_2 x = Inr (p,n) \<Longrightarrow> poly_cond p \<and> ipoly p (real_of_2 x) = 0 \<and> degree p \<ge> 2 
     \<and> card (roots_below p (real_of_2 x)) = n"
     "info_2 x = Inl y \<Longrightarrow> real_of_2 x = of_rat y" 
 proof (atomize(full), goal_cases)
   case 1
   show ?case
   proof (cases x)
     case (Irrational m rai)
     then obtain q l r where x: "x = Irrational m (q,l,r)" by (cases rai, auto)
     show ?thesis
     proof (cases "q = p \<and> m = n")
       case False
       thus ?thesis using x by auto
     next
       case True
       with x have x: "x = Irrational n (p,l,r)" by auto
       from rc[unfolded x, simplified] have inv: "invariant_1_2 (p,l,r)" and 
         n: "card (roots_below p (real_of_2 x)) = n" and 1: "degree p \<noteq> 1" 
         by (auto simp: x)
       from inv have "degree p \<noteq> 0" unfolding irreducible_def by auto
       with 1 have "degree p \<ge> 2" by linarith
       thus ?thesis unfolding n using inv x by (auto elim!: invariant_1E)
     qed
   qed auto
 qed
   
 lemma real_of_2_Irrational: "invariant_2 (Irrational n rai) \<Longrightarrow> real_of_2 (Irrational n rai) \<noteq> of_rat x" 
 proof
   assume "invariant_2 (Irrational n rai)" and rat: "real_of_2 (Irrational n rai) = real_of_rat x" 
   hence "real_of_1 rai \<in> \<rat>" "invariant_1_2 rai" by auto
   from invariant_1_2_of_rat[OF this(2)] rat show False by auto
 qed
             
 lemma info_2: assumes 
     ix: "invariant_2 x" and iy: "invariant_2 y"
   shows "info_2 x = info_2 y \<longleftrightarrow> real_of_2 x = real_of_2 y"
 proof (cases x)
   case x: (Irrational n1 rai1)
   note ix = ix[unfolded x]
   show ?thesis
   proof (cases y)
     case (Rational y)
     with real_of_2_Irrational[OF ix, of y] show ?thesis unfolding x by (cases rai1, auto)
   next
     case y: (Irrational n2 rai2)
     obtain p1 l1 r1 where rai1: "rai1 = (p1,l1,r1)" by (cases rai1)
     obtain p2 l2 r2 where rai2: "rai2 = (p2,l2,r2)" by (cases rai2)
     let ?rx = "the_unique_root (p1,l1,r1)"
     let ?ry = "the_unique_root (p2,l2,r2)"
     have id: "(info_2 x = info_2 y) = (p1 = p2 \<and> n1 = n2)" 
       "(real_of_2 x = real_of_2 y) = (?rx = ?ry)" 
       unfolding x y rai1 rai2 by auto
     from ix[unfolded x rai1]
     have ix: "invariant_1 (p1, l1, r1)" and deg1: "degree p1 > 1" and n1: "n1 = card (roots_below p1 ?rx)" by auto
     note Ix = invariant_1D[OF ix]
     from deg1 have p1_0: "p1 \<noteq> 0" by auto
     from iy[unfolded y rai2] 
     have iy: "invariant_1 (p2, l2, r2)" and "degree p2 > 1" and n2: "n2 = card (roots_below p2 ?ry)"  by auto
     note Iy = invariant_1D[OF iy]
     show ?thesis unfolding id
     proof
       assume eq: "?rx = ?ry" 
       from Ix
       have algx: "p1 represents ?rx \<and> irreducible p1 \<and> lead_coeff p1 > 0" unfolding represents_def by auto
       from iy
       have algy: "p2 represents ?rx \<and> irreducible p2 \<and> lead_coeff p2 > 0" unfolding represents_def eq by (auto elim!: invariant_1E)
       from algx have "algebraic ?rx" unfolding algebraic_altdef_ipoly by auto
       note unique = algebraic_imp_represents_unique[OF this]
       with algx algy have id: "p2 = p1" by auto
       from eq id n1 n2 show "p1 = p2 \<and> n1 = n2" by auto
     next
       assume "p1 = p2 \<and> n1 = n2" 
       hence id: "p1 = p2" "n1 = n2" by auto
       hence card: "card (roots_below p1 ?rx) = card (roots_below p1 ?ry)" unfolding n1 n2 by auto
       show "?rx = ?ry"
       proof (cases ?rx ?ry rule: linorder_cases)
         case less
         have "roots_below p1 ?rx = roots_below p1 ?ry"
         proof (intro card_subset_eq finite_subset[OF _ ipoly_roots_finite] card)
           from less show "roots_below p1 ?rx \<subseteq> roots_below p1 ?ry" by auto
         qed (insert p1_0, auto)
         then show ?thesis using id less unique_rootD(3)[OF Iy(4)] by (auto simp: less_eq_real_def)
       next
         case equal
         then show ?thesis by (simp add: id)
       next
         case greater
         have "roots_below p1 ?ry = roots_below p1 ?rx"
         proof (intro card_subset_eq card[symmetric] finite_subset[OF _ ipoly_roots_finite[OF p1_0]])
           from greater show "roots_below p1 ?ry \<subseteq> roots_below p1 ?rx" by auto
         qed auto
         hence "roots_below p2 ?ry = roots_below p2 ?rx" unfolding id by auto
         thus ?thesis using id greater unique_rootD(3)[OF Ix(4)] by (auto simp: less_eq_real_def)
       qed
     qed
   qed
 next
   case x: (Rational x)
   show ?thesis
   proof (cases y)
     case (Rational y)
     thus ?thesis using x by auto
   next
     case y: (Irrational n rai)
     with real_of_2_Irrational[OF iy[unfolded y], of x] show ?thesis unfolding x by (cases rai, auto)
   qed
 qed
   
 lemma info_2_unique: "invariant_2 x \<Longrightarrow> invariant_2 y \<Longrightarrow> 
   real_of_2 x = real_of_2 y \<Longrightarrow> info_2 x = info_2 y"
   using info_2 by blast
   
 lemma info_2_inj: "invariant_2 x \<Longrightarrow> invariant_2 y \<Longrightarrow> info_2 x = info_2 y \<Longrightarrow>
   real_of_2 x = real_of_2 y"
   using info_2 by blast    
 
 context
   fixes cr1 cr2 :: "rat \<Rightarrow> rat \<Rightarrow> nat"
 begin
 partial_function (tailrec) compare_1 :: "int poly \<Rightarrow> int poly \<Rightarrow> rat \<Rightarrow> rat \<Rightarrow> rat \<Rightarrow> rat \<Rightarrow> rat \<Rightarrow> rat \<Rightarrow> order" where
   [code]: "compare_1 p1 p2 l1 r1 sr1 l2 r2 sr2 = (if r1 < l2 then Lt else if r2 < l1 then Gt 
     else let 
       (l1',r1',sr1') = tighten_poly_bounds p1 l1 r1 sr1;
       (l2',r2',sr2') = tighten_poly_bounds p2 l2 r2 sr2
     in compare_1 p1 p2 l1' r1' sr1' l2' r2' sr2')
     "
   
 lemma compare_1:
   assumes ur1: "unique_root (p1,l1,r1)"
   and ur2: "unique_root (p2,l2,r2)"
   and pc: "poly_cond2 p1" "poly_cond2 p2"
   and diff: "the_unique_root (p1,l1,r1) \<noteq> the_unique_root (p2,l2,r2)"
   and sr: "sr1 = sgn (ipoly p1 r1)" "sr2 = sgn (ipoly p2 r2)" 
  shows "compare_1 p1 p2 l1 r1 sr1 l2 r2 sr2 = compare (the_unique_root (p1,l1,r1)) (the_unique_root (p2,l2,r2))"
 proof -
   let ?r = real_of_rat
   {
     fix d x y
     assume d: "d = (r1 - l1) + (r2 - l2)" and xy: "x = the_unique_root (p1,l1,r1)" "y = the_unique_root (p2,l2,r2)"
     define delta where "delta = abs (x - y) / 4"
     have delta: "delta > 0" and diff: "x \<noteq> y" unfolding delta_def using diff xy by auto
     let ?rel' = "{(x, y). 0 \<le> y \<and> delta_gt delta x y}"
     let ?rel = "inv_image ?rel' ?r"
     have SN: "SN ?rel" by (rule SN_inv_image[OF delta_gt_SN[OF delta]])
     from d ur1 ur2 
     have ?thesis unfolding xy[symmetric] using xy sr
     proof (induct d arbitrary: l1 r1 l2 r2 sr1 sr2 rule: SN_induct[OF SN])
       case (1 d l1 r1 l2 r2)
       note IH = 1(1)
       note d = 1(2)
       note ur = 1(3-4)
       note xy = 1(5-6)
       note sr = 1(7-8)
       note simps = compare_1.simps[of p1 p2 l1 r1 sr1 l2 r2 sr2]
       note urx = unique_rootD[OF ur(1), folded xy]
       note ury = unique_rootD[OF ur(2), folded xy]
       show ?case (is "?l = _")
       proof (cases "r1 < l2")
         case True
         hence l: "?l = Lt" and lt: "?r r1 < ?r l2" unfolding simps of_rat_less by auto
         show ?thesis unfolding l using lt True urx(2) ury(1) 
           by (auto simp: compare_real_def comparator_of_def)
       next
         case False note le = this
         show ?thesis
         proof (cases "r2 < l1")
           case True
           with le have l: "?l = Gt" and lt: "?r r2 < ?r l1" unfolding simps of_rat_less by auto
           show ?thesis unfolding l using lt True ury(2) urx(1) 
             by (auto simp: compare_real_def comparator_of_def)
         next
           case False
           obtain l1' r1' sr1' where tb1: "tighten_poly_bounds p1 l1 r1 sr1 = (l1',r1',sr1')" 
             by (cases rule: prod_cases3, auto)
           obtain l2' r2' sr2' where tb2: "tighten_poly_bounds p2 l2 r2 sr2 = (l2',r2',sr2')" 
             by (cases rule: prod_cases3, auto)            
           from False le tb1 tb2 have l: "?l = compare_1 p1 p2 l1' r1' sr1' l2' r2' sr2'" unfolding simps 
             by auto
           from tighten_poly_bounds[OF tb1 ur(1) pc(1) sr(1)]
           have rc1: "root_cond (p1, l1', r1') (the_unique_root (p1, l1, r1))" 
             and bnd1: "l1 \<le> l1'" "l1' \<le> r1'" "r1' \<le> r1" and d1: "r1' - l1' = (r1 - l1) / 2" 
             and sr1: "sr1' = sgn (ipoly p1 r1')" by auto
           from pc have "p1 \<noteq> 0" "p2 \<noteq> 0" by auto
           from unique_root_sub_interval[OF ur(1) rc1 bnd1(1,3)] xy ur this
           have ur1: "unique_root (p1, l1', r1')" and x: "x = the_unique_root (p1, l1', r1')" by (auto intro!: the_unique_root_eqI)
           from tighten_poly_bounds[OF tb2 ur(2) pc(2) sr(2)]
           have rc2: "root_cond (p2, l2', r2') (the_unique_root (p2, l2, r2))" 
             and bnd2: "l2 \<le> l2'" "l2' \<le> r2'" "r2' \<le> r2" and d2: "r2' - l2' = (r2 - l2) / 2" 
             and sr2: "sr2' = sgn (ipoly p2 r2')" by auto
           from unique_root_sub_interval[OF ur(2) rc2 bnd2(1,3)] xy ur pc
           have ur2: "unique_root (p2, l2', r2')" and y: "y = the_unique_root (p2, l2', r2')" by auto
           define d' where "d' = d/2"
           have d': "d' = r1' - l1' + (r2' - l2')" unfolding d'_def d d1 d2 by (simp add: field_simps)
           have d'0: "d' \<ge> 0" using bnd1 bnd2 unfolding d' by auto
           have dd: "d - d' = d/2" unfolding d'_def by simp
           have "abs (x - y) \<le> 2 * ?r d"
           proof (rule ccontr)
             assume "\<not> ?thesis"
             hence lt: "2 * ?r d < abs (x - y)" by auto
             have "r1 - l1 \<le> d" "r2 - l2 \<le> d" unfolding d using bnd1 bnd2 by auto
             from this[folded of_rat_less_eq[where 'a = real]] lt 
             have "?r (r1 - l1) < abs (x - y) / 2" "?r (r2 - l2) < abs (x - y) / 2" 
               and dd: "?r r1 - ?r l1 \<le> ?r d" "?r r2 - ?r l2 \<le> ?r d" by (auto simp: of_rat_diff)
             from le have "r1 \<ge> l2" by auto hence r1l2: "?r r1 \<ge> ?r l2" unfolding of_rat_less_eq by auto
             from False have "r2 \<ge> l1" by auto hence r2l1: "?r r2 \<ge> ?r l1" unfolding of_rat_less_eq by auto            
             show False
             proof (cases "x \<le> y")
               case True
               from urx(1-2) dd(1) have "?r r1 \<le> x + ?r d" by auto 
               with r1l2 have "?r l2 \<le> x + ?r d" by auto
               with True lt ury(2) dd(2) show False by auto
             next
               case False
               from ury(1-2) dd(2) have "?r r2 \<le> y + ?r d" by auto 
               with r2l1 have "?r l1 \<le> y + ?r d" by auto
               with False lt urx(2) dd(1) show False by auto
             qed              
           qed
           hence dd': "delta_gt delta (?r d) (?r d')"
              unfolding delta_gt_def delta_def using dd by (auto simp: hom_distribs)
           show ?thesis unfolding l
             by (rule IH[OF _ d' ur1 ur2 x y sr1 sr2], insert d'0 dd', auto)
         qed
       qed
     qed
   }
   thus ?thesis by auto
 qed
 end
   
 (* **************************************************************** *)  
 
 fun real_alg_1 :: "real_alg_2 \<Rightarrow> real_alg_1" where
   "real_alg_1 (Rational r) = of_rat_1 r"
 | "real_alg_1 (Irrational n rai) = rai"
   
 lemma real_alg_1: "real_of_1 (real_alg_1 x) = real_of_2 x"
   by (cases x, auto simp: of_rat_1)
     
 definition root_2 :: "nat \<Rightarrow> real_alg_2 \<Rightarrow> real_alg_2" where
   "root_2 n x = root_1 n (real_alg_1 x)"
 
 lemma root_2: assumes "invariant_2 x"
   shows "real_of_2 (root_2 n x) = root n (real_of_2 x)"
   "invariant_2 (root_2 n x)"
 proof (atomize(full), cases x, goal_cases)
   case (1 y)
   from of_rat_1[of y] root_1[of "of_rat_1 y" n] assms 1 real_alg_2
   show ?case by (simp add: root_2_def)
 next
   case (2 i rai)
   from root_1[of rai n] assms 2 real_alg_2 
   show ?case by (auto simp: root_2_def)
 qed
   
 fun add_2 :: "real_alg_2 \<Rightarrow> real_alg_2 \<Rightarrow> real_alg_2" where
   "add_2 (Rational r) (Rational q) = Rational (r + q)"
 | "add_2 (Rational r) (Irrational n x) = Irrational n (add_rat_1 r x)"
 | "add_2 (Irrational n x) (Rational q) = Irrational n (add_rat_1 q x)"
 | "add_2 (Irrational n x) (Irrational m y) = add_1 x y"
 
 lemma add_2: assumes x: "invariant_2 x" and y: "invariant_2 y" 
   shows "invariant_2 (add_2 x y)" (is ?g1)
     and "real_of_2 (add_2 x y) = real_of_2 x + real_of_2 y" (is ?g2)
   using assms add_rat_1 add_1
   by (atomize (full), (cases x; cases y), auto simp: hom_distribs)
 
 fun mult_2 :: "real_alg_2 \<Rightarrow> real_alg_2 \<Rightarrow> real_alg_2" where
   "mult_2 (Rational r) (Rational q) = Rational (r * q)"
 | "mult_2 (Rational r) (Irrational n y) = mult_rat_1 r y"
 | "mult_2 (Irrational n x) (Rational q) = mult_rat_1 q x"
 | "mult_2 (Irrational n x) (Irrational m y) = mult_1 x y"
 
 lemma mult_2: assumes "invariant_2 x" "invariant_2 y"
   shows "real_of_2 (mult_2 x y) = real_of_2 x * real_of_2 y"
   "invariant_2 (mult_2 x y)"
   using assms
   by (atomize(full), (cases x; cases y; auto simp: mult_rat_1 mult_1 hom_distribs))
 
 fun to_rat_2 :: "real_alg_2 \<Rightarrow> rat option" where
   "to_rat_2 (Rational r) = Some r"
 | "to_rat_2 (Irrational n rai) = None"
 
 lemma to_rat_2: assumes rc: "invariant_2 x" 
   shows "to_rat_2 x = (if real_of_2 x \<in> \<rat> then Some (THE q. real_of_2 x = of_rat q) else None)"
 proof (cases x)
   case (Irrational n rai)
   from real_of_2_Irrational[OF rc[unfolded this]] show ?thesis
     unfolding Irrational Rats_def by auto
 qed simp 
   
 fun equal_2 :: "real_alg_2 \<Rightarrow> real_alg_2 \<Rightarrow> bool" where
   "equal_2 (Rational r) (Rational q) = (r = q)" 
 | "equal_2 (Irrational n (p,_)) (Irrational m (q,_)) = (p = q \<and> n = m)"
 | "equal_2 (Rational r) (Irrational _ yy) = False"
 | "equal_2 (Irrational _ xx) (Rational q) = False"
 
 lemma equal_2[simp]: assumes rc: "invariant_2 x" "invariant_2 y" 
   shows "equal_2 x y = (real_of_2 x = real_of_2 y)"
   using info_2[OF rc]
   by (cases x; cases y, auto)
 
 fun compare_2 :: "real_alg_2 \<Rightarrow> real_alg_2 \<Rightarrow> order" where 
   "compare_2 (Rational r) (Rational q) = (compare r q)"
 | "compare_2 (Irrational n (p,l,r)) (Irrational m (q,l',r')) = (if p = q \<and> n = m then Eq
     else compare_1 p q l r (sgn (ipoly p r)) l' r' (sgn (ipoly q r')))" 
 | "compare_2 (Rational r) (Irrational _ xx) = (compare_rat_1 r xx)"
 | "compare_2 (Irrational _ xx) (Rational r) = (invert_order (compare_rat_1 r xx))"  
 
 lemma compare_2: assumes rc: "invariant_2 x" "invariant_2 y"
   shows "compare_2 x y = compare (real_of_2 x) (real_of_2 y)"
 proof (cases x)
   case (Rational r) note xx = this
   show ?thesis
   proof (cases y)
     case (Rational q) note yy = this
     show ?thesis unfolding xx yy by (simp add: compare_rat_def compare_real_def comparator_of_def of_rat_less)
   next
     case (Irrational n yy) note yy = this
     from compare_rat_1 rc
     show ?thesis unfolding xx yy by (simp add: of_rat_1)
   qed
 next
   case (Irrational n xx) note xx = this
   show ?thesis
   proof (cases y)
     case (Rational q) note yy = this
     from compare_rat_1 rc
     show ?thesis unfolding xx yy by simp
   next
     case (Irrational m yy) note yy = this
     obtain p l r where xxx: "xx = (p,l,r)" by (cases xx)
     obtain q l' r' where yyy: "yy = (q,l',r')" by (cases yy)
     note rc = rc[unfolded xx xxx yy yyy]
     from rc have I: "invariant_1_2 (p,l,r)" "invariant_1_2 (q,l',r')" by auto
     then have "unique_root (p,l,r)" "unique_root (q,l',r')" "poly_cond2 p" "poly_cond2 q" by auto
     from compare_1[OF this _ refl refl]
     show ?thesis using equal_2[OF rc] unfolding xx xxx yy yyy by simp
   qed
 qed
 
 fun sgn_2 :: "real_alg_2 \<Rightarrow> rat" where
   "sgn_2 (Rational r) = sgn r"
 | "sgn_2 (Irrational n rai) = sgn_1 rai"
 
 lemma sgn_2: "invariant_2 x \<Longrightarrow> real_of_rat (sgn_2 x) = sgn (real_of_2 x)" 
   using sgn_1 by (cases x, auto simp: real_of_rat_sgn)
 
 fun floor_2 :: "real_alg_2 \<Rightarrow> int" where
   "floor_2 (Rational r) = floor r"
 | "floor_2 (Irrational n rai) = floor_1 rai"
 
 lemma floor_2: "invariant_2 x \<Longrightarrow> floor_2 x = floor (real_of_2 x)"
   by (cases x, auto simp: floor_1)
   
 (* *************** *)
 subsubsection \<open>Definitions and Algorithms on Type with Invariant\<close>
 
 lift_definition of_rat_3 :: "rat \<Rightarrow> real_alg_3" is of_rat_2
   by (auto simp: of_rat_2)
 
 
     
 lemma of_rat_3: "real_of_3 (of_rat_3 x) = of_rat x"
   by (transfer, auto simp: of_rat_2)
 
 lift_definition root_3 :: "nat \<Rightarrow> real_alg_3 \<Rightarrow> real_alg_3" is root_2 
   by (auto simp: root_2)
 
 lemma root_3: "real_of_3 (root_3 n x) = root n (real_of_3 x)"
   by (transfer, auto simp: root_2)
 
 lift_definition equal_3 :: "real_alg_3 \<Rightarrow> real_alg_3 \<Rightarrow> bool" is equal_2 .
 
 lemma equal_3: "equal_3 x y = (real_of_3 x = real_of_3 y)"
   by (transfer, auto)  
 
 lift_definition compare_3 :: "real_alg_3 \<Rightarrow> real_alg_3 \<Rightarrow> order" is compare_2 .
 
 lemma compare_3: "compare_3 x y = (compare (real_of_3 x) (real_of_3 y))"
   by (transfer, auto simp: compare_2)  
     
 lift_definition add_3 :: "real_alg_3 \<Rightarrow> real_alg_3 \<Rightarrow> real_alg_3" is add_2 
   by (auto simp: add_2)
 
 lemma add_3: "real_of_3 (add_3 x y) = real_of_3 x + real_of_3 y"
   by (transfer, auto simp: add_2)
 
 lift_definition mult_3 :: "real_alg_3 \<Rightarrow> real_alg_3 \<Rightarrow> real_alg_3" is mult_2 
   by (auto simp: mult_2)
 
 lemma mult_3: "real_of_3 (mult_3 x y) = real_of_3 x * real_of_3 y"
   by (transfer, auto simp: mult_2)
 
 lift_definition sgn_3 :: "real_alg_3 \<Rightarrow> rat" is sgn_2 . 
 
 lemma sgn_3: "real_of_rat (sgn_3 x) = sgn (real_of_3 x)" 
   by (transfer, auto simp: sgn_2)
 
 lift_definition to_rat_3 :: "real_alg_3 \<Rightarrow> rat option" is to_rat_2 .
 
 lemma to_rat_3: "to_rat_3 x = 
   (if real_of_3 x \<in> \<rat> then Some (THE q. real_of_3 x = of_rat q) else None)"
   by (transfer, simp add: to_rat_2)
 
 lift_definition floor_3 :: "real_alg_3 \<Rightarrow> int" is floor_2 .
 
 lemma floor_3: "floor_3 x = floor (real_of_3 x)"
   by (transfer, auto simp: floor_2)
 
 (* *************** *)
 (* info *)
 
 lift_definition info_3 :: "real_alg_3 \<Rightarrow> rat + int poly \<times> nat" is info_2 .  
 
 lemma info_3_fun: "real_of_3 x = real_of_3 y \<Longrightarrow> info_3 x = info_3 y"
   by (transfer, intro info_2_unique, auto)
 
 lift_definition info_real_alg :: "real_alg \<Rightarrow> rat + int poly \<times> nat" is info_3
   by (metis info_3_fun)
     
 lemma info_real_alg: 
   "info_real_alg x = Inr (p,n) \<Longrightarrow> p represents (real_of x) \<and> card {y. y \<le> real_of x \<and> ipoly p y = 0} = n \<and> irreducible p" 
   "info_real_alg x = Inl q \<Longrightarrow> real_of x = of_rat q" 
 proof (atomize(full), transfer, transfer, goal_cases)
   case (1 x p n q)
   from 1 have x: "invariant_2 x" by auto
   note info = info_2_card[OF this]
   show ?case 
   proof (cases x)
     case irr: (Irrational m rai)
     from info(1)[of p n]
     show ?thesis unfolding irr by (cases rai, auto simp: poly_cond_def)
   qed (insert 1 info, auto)
 qed
     
 (* add *)
 instantiation real_alg :: plus
 begin
 lift_definition plus_real_alg :: "real_alg \<Rightarrow> real_alg \<Rightarrow> real_alg" is add_3
   by (simp add: add_3)
 instance ..
 end
 
 lemma plus_real_alg: "(real_of x) + (real_of y) = real_of (x + y)"
   by (transfer, rule add_3[symmetric])
 
 (* minus *)
 instantiation real_alg :: minus
 begin
 definition minus_real_alg :: "real_alg \<Rightarrow> real_alg \<Rightarrow> real_alg" where
   "minus_real_alg x y = x + (-y)"
 instance ..
 end
 
 lemma minus_real_alg: "(real_of x) - (real_of y) = real_of (x - y)"
   unfolding minus_real_alg_def minus_real_def uminus_real_alg plus_real_alg  ..  
 
 (* of_rat *)
 lift_definition of_rat_real_alg :: "rat \<Rightarrow> real_alg" is of_rat_3 .
 
 lemma of_rat_real_alg: "real_of_rat x = real_of (of_rat_real_alg x)"
   by (transfer, rule of_rat_3[symmetric])
 
 (* zero *)
 instantiation real_alg :: zero
 begin
 definition zero_real_alg :: "real_alg" where "zero_real_alg \<equiv> of_rat_real_alg 0"
 instance ..
 end
 
 lemma zero_real_alg: "0 = real_of 0"
   unfolding zero_real_alg_def by (simp add: of_rat_real_alg[symmetric])
 
 (* one *)
 instantiation real_alg :: one
 begin
 definition one_real_alg :: "real_alg" where "one_real_alg \<equiv> of_rat_real_alg 1"
 instance ..
 end
 
 lemma one_real_alg: "1 = real_of 1"
   unfolding one_real_alg_def by (simp add: of_rat_real_alg[symmetric])
 
 (* times *)
 instantiation real_alg :: times
 begin
 lift_definition times_real_alg :: "real_alg \<Rightarrow> real_alg \<Rightarrow> real_alg" is mult_3
   by (simp add: mult_3)
 instance ..
 end
 
 lemma times_real_alg: "(real_of x) * (real_of y) = real_of (x * y)"
   by (transfer, rule mult_3[symmetric])
 
 (* inverse *)
 instantiation real_alg :: inverse
 begin
 lift_definition inverse_real_alg :: "real_alg \<Rightarrow> real_alg" is inverse_3
   by (simp add: inverse_3)
 definition divide_real_alg :: "real_alg \<Rightarrow> real_alg \<Rightarrow> real_alg" where
   "divide_real_alg x y = x * inverse y" (* TODO: better to use poly_div *)
 instance ..
 end
 
 lemma inverse_real_alg: "inverse (real_of x) = real_of (inverse x)"
   by (transfer, rule inverse_3[symmetric])
 
 lemma divide_real_alg: "(real_of x) / (real_of y) = real_of (x / y)"
   unfolding divide_real_alg_def times_real_alg[symmetric] divide_real_def inverse_real_alg ..
 
 (* group *)
 instance real_alg :: ab_group_add
   apply intro_classes
   apply (transfer, unfold add_3, force)
   apply (unfold zero_real_alg_def, transfer, unfold add_3 of_rat_3, force)
   apply (transfer, unfold add_3 of_rat_3, force)
   apply (transfer, unfold add_3 uminus_3 of_rat_3, force)
   apply (unfold minus_real_alg_def, force)
 done
 
 (* field *)
 instance real_alg :: field
   apply intro_classes
   apply (transfer, unfold mult_3, force)
   apply (transfer, unfold mult_3, force)
   apply (unfold one_real_alg_def, transfer, unfold mult_3 of_rat_3, force)
   apply (transfer, unfold mult_3 add_3, force simp: field_simps)
   apply (unfold zero_real_alg_def, transfer, unfold of_rat_3, force)
   apply (transfer, unfold mult_3 inverse_3 of_rat_3, force simp: field_simps)
   apply (unfold divide_real_alg_def, force)
   apply (transfer, unfold inverse_3 of_rat_3, force)
 done
 
 (* numeral *)
 instance real_alg :: numeral ..  
 
 (* root *)
 lift_definition root_real_alg :: "nat \<Rightarrow> real_alg \<Rightarrow> real_alg" is root_3
   by (simp add: root_3)
 
 lemma root_real_alg: "root n (real_of x) = real_of (root_real_alg n x)"
   by (transfer, rule root_3[symmetric])
 
 (* sgn *)
 lift_definition sgn_real_alg_rat :: "real_alg \<Rightarrow> rat" is sgn_3
   by (insert sgn_3, metis to_rat_of_rat)
 
 lemma sgn_real_alg_rat: "real_of_rat (sgn_real_alg_rat x) = sgn (real_of x)" 
   by (transfer, auto simp: sgn_3)
 
 instantiation real_alg :: sgn
 begin
 definition sgn_real_alg :: "real_alg \<Rightarrow> real_alg" where
   "sgn_real_alg x = of_rat_real_alg (sgn_real_alg_rat x)"
 instance ..
 end
 
 lemma sgn_real_alg: "sgn (real_of x) = real_of (sgn x)"
   unfolding sgn_real_alg_def of_rat_real_alg[symmetric]
   by (transfer, simp add: sgn_3)
 
 (* equal *)
 instantiation real_alg :: equal
 begin
 lift_definition equal_real_alg :: "real_alg \<Rightarrow> real_alg \<Rightarrow> bool" is equal_3 
   by (simp add: equal_3)
 instance 
 proof
   fix x y :: real_alg
   show "equal_class.equal x y = (x = y)"
     by (transfer, simp add: equal_3)
 qed
 end
 
 lemma equal_real_alg: "HOL.equal (real_of x) (real_of y) = (x = y)"
   unfolding equal_real_def by (transfer, auto)
 
 (* comparisons *)
 instantiation real_alg :: ord 
 begin
 
 definition less_real_alg :: "real_alg \<Rightarrow> real_alg \<Rightarrow> bool" where
   [code del]: "less_real_alg x y = (real_of x < real_of y)"
 
 definition less_eq_real_alg :: "real_alg \<Rightarrow> real_alg \<Rightarrow> bool" where
   [code del]: "less_eq_real_alg x y = (real_of x \<le> real_of y)"
 
 instance ..
 end    
 
 lemma less_real_alg: "less (real_of x) (real_of y) = (x < y)" unfolding less_real_alg_def ..
 lemma less_eq_real_alg: "less_eq (real_of x) (real_of y) = (x \<le> y)" unfolding less_eq_real_alg_def ..
 
 instantiation real_alg :: compare_order
 begin
 
 lift_definition compare_real_alg :: "real_alg \<Rightarrow> real_alg \<Rightarrow> order" is compare_3
   by (simp add: compare_3)
 
 lemma compare_real_alg: "compare (real_of x) (real_of y) = (compare x y)"
   by (transfer, simp add: compare_3)
 
 instance
 proof (intro_classes, unfold compare_real_alg[symmetric, abs_def])
   show "le_of_comp (\<lambda>x y. compare (real_of x) (real_of y)) = (\<le>)" 
     by (intro ext, auto simp: compare_real_def comparator_of_def le_of_comp_def less_eq_real_alg_def)
   show "lt_of_comp (\<lambda>x y. compare (real_of x) (real_of y)) = (<)"
     by (intro ext, auto simp: compare_real_def comparator_of_def lt_of_comp_def less_real_alg_def)
   show "comparator (\<lambda>x y. compare (real_of x) (real_of y))" 
     unfolding comparator_def 
   proof (intro conjI impI allI)
     fix x y z :: "real_alg"
     let ?r = real_of
     note rc = comparator_compare[where 'a = real, unfolded comparator_def]
     from rc show "invert_order (compare (?r x) (?r y)) = compare (?r y) (?r x)" by blast
     from rc show "compare (?r x) (?r y) = Lt \<Longrightarrow> compare (?r y) (?r z) = Lt \<Longrightarrow> compare (?r x) (?r z) = Lt" by blast
     assume "compare (?r x) (?r y) = Eq"
     with rc have "?r x = ?r y" by blast
     thus "x = y" unfolding real_of_inj .
   qed
 qed
 end
   
 lemma less_eq_real_alg_code[code]: 
   "(less_eq :: real_alg \<Rightarrow> real_alg \<Rightarrow> bool) = le_of_comp compare"
   "(less :: real_alg \<Rightarrow> real_alg \<Rightarrow> bool) = lt_of_comp compare"
   by (rule ord_defs(1)[symmetric], rule ord_defs(2)[symmetric])
 
 instantiation real_alg :: abs
 begin
 
 definition abs_real_alg :: "real_alg \<Rightarrow> real_alg" where
   "abs_real_alg x = (if real_of x < 0 then uminus x else x)"
 instance ..
 end
 
 lemma abs_real_alg: "abs (real_of x) = real_of (abs x)"
   unfolding abs_real_alg_def abs_real_def if_distrib
   by (auto simp: uminus_real_alg)
 
 lemma sgn_real_alg_sound: "sgn x = (if x = 0 then 0 else if 0 < real_of x then 1 else - 1)"
   (is "_ = ?r")
 proof -
   have "real_of (sgn x) = sgn (real_of x)" by (simp add: sgn_real_alg)
   also have "\<dots> = real_of ?r" unfolding sgn_real_def if_distrib 
   by (auto simp: less_real_alg_def 
     zero_real_alg_def one_real_alg_def of_rat_real_alg[symmetric] equal_real_alg[symmetric]
     equal_real_def uminus_real_alg[symmetric])
   finally show "sgn x = ?r" unfolding equal_real_alg[symmetric] equal_real_def by simp
 qed
 
 lemma real_of_of_int: "real_of_rat (rat_of_int z) = real_of (of_int z)"
 proof (cases "z \<ge> 0")
   case True
   define n where "n = nat z"
   from True have z: "z = int n" unfolding n_def by simp
   show ?thesis unfolding z
     by (induct n, auto simp: zero_real_alg plus_real_alg[symmetric] one_real_alg hom_distribs)
 next
   case False
   define n where "n = nat (-z)"
   from False have z: "z = - int n" unfolding n_def by simp
   show ?thesis unfolding z
     by (induct n, auto simp: zero_real_alg plus_real_alg[symmetric] one_real_alg uminus_real_alg[symmetric]
       minus_real_alg[symmetric] hom_distribs)
 qed
 
 instance real_alg :: linordered_field
   apply standard
      apply (unfold less_eq_real_alg_def plus_real_alg[symmetric], force)
     apply (unfold abs_real_alg_def less_real_alg_def zero_real_alg[symmetric], rule refl)
    apply (unfold less_real_alg_def times_real_alg[symmetric], force)
   apply (rule sgn_real_alg_sound)
   done
 
 instantiation real_alg :: floor_ceiling
 begin
 lift_definition floor_real_alg :: "real_alg \<Rightarrow> int" is floor_3
   by (auto simp: floor_3)
 
 lemma floor_real_alg: "floor (real_of x) = floor x"
   by (transfer, auto simp: floor_3)
 
 instance 
 proof
   fix x :: real_alg
   show "of_int \<lfloor>x\<rfloor> \<le> x \<and> x < of_int (\<lfloor>x\<rfloor> + 1)" unfolding floor_real_alg[symmetric]
     using floor_correct[of "real_of x"] unfolding less_eq_real_alg_def less_real_alg_def
     real_of_of_int[symmetric] by (auto simp: hom_distribs)
   hence "x \<le> of_int (\<lfloor>x\<rfloor> + 1)" by auto
   thus "\<exists>z. x \<le> of_int z" by blast
 qed
 end
 
 definition real_alg_of_real :: "real \<Rightarrow> real_alg" where
   "real_alg_of_real x = (if (\<exists> y. x = real_of y) then (THE y. x = real_of y) else 0)" 
 
 lemma real_alg_of_real_code[code]: "real_alg_of_real (real_of x) = x"
   using real_of_inj unfolding real_alg_of_real_def by auto
 
 lift_definition to_rat_real_alg_main :: "real_alg \<Rightarrow> rat option" is to_rat_3
   by (simp add: to_rat_3)
 
 lemma to_rat_real_alg_main: "to_rat_real_alg_main x = (if real_of x \<in> \<rat> then 
   Some (THE q. real_of x = of_rat q) else None)"
   by (transfer, simp add: to_rat_3)
 
 definition to_rat_real_alg :: "real_alg \<Rightarrow> rat" where
   "to_rat_real_alg x = (case to_rat_real_alg_main x of Some q \<Rightarrow> q | None \<Rightarrow> 0)"
 
 definition is_rat_real_alg :: "real_alg \<Rightarrow> bool" where
   "is_rat_real_alg x = (case to_rat_real_alg_main x of Some q \<Rightarrow> True | None \<Rightarrow> False)"
 
 lemma is_rat_real_alg: "is_rat (real_of x) = (is_rat_real_alg x)"
   unfolding is_rat_real_alg_def is_rat to_rat_real_alg_main by auto
 
 lemma to_rat_real_alg: "to_rat (real_of x) = (to_rat_real_alg x)"
   unfolding to_rat to_rat_real_alg_def to_rat_real_alg_main by auto
 
 
 subsection \<open>Real Algebraic Numbers as Implementation for Real Numbers\<close>
 
 lemmas real_alg_code_eqns =  
   one_real_alg
   zero_real_alg
   uminus_real_alg
   root_real_alg
   minus_real_alg
   plus_real_alg
   times_real_alg
   inverse_real_alg
   divide_real_alg
   equal_real_alg
   less_real_alg
   less_eq_real_alg
   compare_real_alg
   sgn_real_alg
   abs_real_alg
   floor_real_alg
   is_rat_real_alg
   to_rat_real_alg
 
 code_datatype real_of
 
 declare [[code drop:
   "plus :: real \<Rightarrow> real \<Rightarrow> real"
   "uminus :: real \<Rightarrow> real"
   "minus :: real \<Rightarrow> real \<Rightarrow> real"
   "times :: real \<Rightarrow> real \<Rightarrow> real"
   "inverse :: real \<Rightarrow> real"
   "divide :: real \<Rightarrow> real \<Rightarrow> real"
   "floor :: real \<Rightarrow> int"
   "HOL.equal :: real \<Rightarrow> real \<Rightarrow> bool"
   "compare :: real \<Rightarrow> real \<Rightarrow> order"
   "less_eq :: real \<Rightarrow> real \<Rightarrow> bool"
   "less :: real \<Rightarrow> real \<Rightarrow> bool"
   "0 :: real"
   "1 :: real"
   "sgn :: real \<Rightarrow> real"
   "abs :: real \<Rightarrow> real"
   root]]
 
 declare real_alg_code_eqns [code equation]
 
 lemma [code]:
   "Ratreal = real_of \<circ> of_rat_real_alg"
   by (transfer, transfer) (simp add: fun_eq_iff of_rat_2)
 
 end
diff --git a/thys/Gromov_Hyperbolicity/Morse_Gromov_Theorem.thy b/thys/Gromov_Hyperbolicity/Morse_Gromov_Theorem.thy
--- a/thys/Gromov_Hyperbolicity/Morse_Gromov_Theorem.thy
+++ b/thys/Gromov_Hyperbolicity/Morse_Gromov_Theorem.thy
@@ -1,3435 +1,3436 @@
 (*  Author:  Sébastien Gouëzel   sebastien.gouezel@univ-rennes1.fr
     License: BSD
 *)
 
 
 theory Morse_Gromov_Theorem
   imports "HOL-Decision_Procs.Approximation" Gromov_Hyperbolicity Hausdorff_Distance
 begin
 
 hide_const (open) Approximation.Min
 hide_const (open) Approximation.Max
 
 section \<open>Quasiconvexity\<close>
 
 text \<open>In a Gromov-hyperbolic setting, convexity is not a well-defined notion as everything should
 be coarse. The good replacement is quasi-convexity: A set $X$ is $C$-quasi-convex if any pair of
 points in $X$ can be joined by a geodesic that remains within distance $C$ of $X$. One could also
 require this for all geodesics, up to changing $C$, as two geodesics between the same endpoints
 remain within uniformly bounded distance. We use the first definition to ensure that a geodesic is
 $0$-quasi-convex.\<close>
 
 definition quasiconvex::"real \<Rightarrow> ('a::metric_space) set \<Rightarrow> bool"
   where "quasiconvex C X = (C \<ge> 0 \<and> (\<forall>x\<in>X. \<forall>y\<in>X. \<exists>G. geodesic_segment_between G x y \<and> (\<forall>z\<in>G. infdist z X \<le> C)))"
 
 lemma quasiconvexD:
   assumes "quasiconvex C X" "x \<in> X" "y \<in> X"
   shows "\<exists>G. geodesic_segment_between G x y \<and> (\<forall>z\<in>G. infdist z X \<le> C)"
 using assms unfolding quasiconvex_def by auto
 
 lemma quasiconvexC:
   assumes "quasiconvex C X"
   shows "C \<ge> 0"
 using assms unfolding quasiconvex_def by auto
 
 lemma quasiconvexI:
   assumes "C \<ge> 0"
           "\<And>x y. x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> (\<exists>G. geodesic_segment_between G x y \<and> (\<forall>z\<in>G. infdist z X \<le> C))"
   shows "quasiconvex C X"
 using assms unfolding quasiconvex_def by auto
 
 lemma quasiconvex_of_geodesic:
   assumes "geodesic_segment G"
   shows "quasiconvex 0 G"
 proof (rule quasiconvexI, simp)
   fix x y assume *: "x \<in> G" "y \<in> G"
   obtain H where H: "H \<subseteq> G" "geodesic_segment_between H x y"
     using geodesic_subsegment_exists[OF assms(1) *] by auto
   have "infdist z G \<le> 0" if "z \<in> H" for z
     using H(1) that by auto
   then show "\<exists>H. geodesic_segment_between H x y \<and> (\<forall>z\<in>H. infdist z G \<le> 0)"
     using H(2) by auto
 qed
 
 lemma quasiconvex_empty:
   assumes "C \<ge> 0"
   shows "quasiconvex C {}"
 unfolding quasiconvex_def using assms by auto
 
 lemma quasiconvex_mono:
   assumes "C \<le> D"
           "quasiconvex C G"
   shows "quasiconvex D G"
 using assms unfolding quasiconvex_def by (auto, fastforce)
 
 text \<open>The $r$-neighborhood of a quasi-convex set is still quasi-convex in a hyperbolic space,
 for a constant that does not depend on $r$.\<close>
 
 lemma (in Gromov_hyperbolic_space_geodesic) quasiconvex_thickening:
   assumes "quasiconvex C (X::'a set)" "r \<ge> 0"
   shows "quasiconvex (C + 8 *deltaG(TYPE('a))) (\<Union>x\<in>X. cball x r)"
 proof (rule quasiconvexI)
   show "C + 8 *deltaG(TYPE('a)) \<ge> 0" using quasiconvexC[OF assms(1)] by simp
 next
   fix y z assume *: "y \<in> (\<Union>x\<in>X. cball x r)" "z \<in> (\<Union>x\<in>X. cball x r)"
   have A: "infdist w (\<Union>x\<in>X. cball x r) \<le> C + 8 * deltaG TYPE('a)" if "w \<in> {y--z}" for w
   proof -
     obtain py where py: "py \<in> X" "y \<in> cball py r"
       using * by auto
     obtain pz where pz: "pz \<in> X" "z \<in> cball pz r"
       using * by auto
     obtain G where G: "geodesic_segment_between G py pz" "(\<forall>p\<in>G. infdist p X \<le> C)"
       using quasiconvexD[OF assms(1) \<open>py \<in> X\<close> \<open>pz \<in> X\<close>] by auto
     have A: "infdist w ({y--py} \<union> G \<union> {pz--z}) \<le> 8 * deltaG(TYPE('a))"
       by (rule thin_quadrilaterals[OF _ G(1) _ _ \<open>w \<in> {y--z}\<close>, where ?x = y and ?t = z], auto)
     have "\<exists>u \<in> {y--py} \<union> G \<union> {pz--z}. infdist w ({y--py} \<union> G \<union> {pz--z}) = dist w u"
       apply (rule infdist_proper_attained, auto intro!: proper_Un simp add: geodesic_segment_topology(7))
       by (meson G(1) geodesic_segmentI geodesic_segment_topology(7))
     then obtain u where u: "u \<in> {y--py} \<union> G \<union> {pz--z}" "infdist w ({y--py} \<union> G \<union> {pz--z}) = dist w u"
       by auto
     then consider "u \<in> {y--py}" | "u \<in> G" | "u \<in> {pz--z}" by auto
     then have "infdist u (\<Union>x\<in>X. cball x r) \<le> C"
     proof (cases)
       case 1
       then have "dist py u \<le> dist py y"
         using geodesic_segment_dist_le local.some_geodesic_is_geodesic_segment(1) some_geodesic_commute some_geodesic_endpoints(1) by blast
       also have "... \<le> r"
         using py(2) by auto
       finally have "u \<in> cball py r"
         by auto
       then have "u \<in> (\<Union>x\<in>X. cball x r)"
         using py(1) by auto
       then have "infdist u (\<Union>x\<in>X. cball x r) = 0"
         by auto
       then show ?thesis
         using quasiconvexC[OF assms(1)] by auto
     next
       case 3
       then have "dist pz u \<le> dist pz z"
         using geodesic_segment_dist_le local.some_geodesic_is_geodesic_segment(1) some_geodesic_commute some_geodesic_endpoints(1) by blast
       also have "... \<le> r"
         using pz(2) by auto
       finally have "u \<in> cball pz r"
         by auto
       then have "u \<in> (\<Union>x\<in>X. cball x r)"
         using pz(1) by auto
       then have "infdist u (\<Union>x\<in>X. cball x r) = 0"
         by auto
       then show ?thesis
         using quasiconvexC[OF assms(1)] by auto
     next
       case 2
       have "infdist u (\<Union>x\<in>X. cball x r) \<le> infdist u X"
         apply (rule infdist_mono) using assms(2) py(1) by auto
       then show ?thesis using 2 G(2) by auto
     qed
     moreover have "infdist w (\<Union>x\<in>X. cball x r) \<le> infdist u (\<Union>x\<in>X. cball x r) + dist w u"
       by (intro mono_intros)
     ultimately show ?thesis
       using A u(2) by auto
   qed
   show "\<exists>G. geodesic_segment_between G y z \<and> (\<forall>w\<in>G. infdist w (\<Union>x\<in>X. cball x r) \<le> C + 8 * deltaG TYPE('a))"
     apply (rule exI[of _ "{y--z}"]) using A by auto
 qed
 
 text \<open>If $x$ has a projection $p$ on a quasi-convex set $G$, then all segments from a point in $G$
 to $x$ go close to $p$, i.e., the triangular inequality $d(x,y) \leq d(x,p) + d(p,y)$ is essentially
 an equality, up to an additive constant.\<close>
 
 lemma (in Gromov_hyperbolic_space_geodesic) dist_along_quasiconvex:
   assumes "quasiconvex C G" "p \<in> proj_set x G" "y \<in> G"
   shows "dist x p + dist p y \<le> dist x y + 4 * deltaG(TYPE('a)) + 2 * C"
 proof -
   have *: "p \<in> G"
     using assms proj_setD by auto
   obtain H where H: "geodesic_segment_between H p y" "\<And>q. q \<in> H \<Longrightarrow> infdist q G \<le> C"
     using quasiconvexD[OF assms(1) * assms(3)] by auto
   have "\<exists>m\<in>H. infdist x H = dist x m"
     apply (rule infdist_proper_attained[of H x]) using geodesic_segment_topology[OF geodesic_segmentI[OF H(1)]] by auto
   then obtain m where m: "m \<in> H" "infdist x H = dist x m" by auto
   then have I: "dist x m \<le> Gromov_product_at x p y + 2 * deltaG(TYPE('a))"
     using infdist_triangle_side[OF H(1), of x] by auto
   have "dist x p - dist x m - C \<le> e" if "e > 0" for e
   proof -
     have "\<exists>r\<in>G. dist m r < infdist m G + e"
       apply (rule infdist_almost_attained) using \<open>e > 0\<close> assms(3) by auto
     then obtain r where r: "r \<in> G" "dist m r < infdist m G + e"
       by auto
     then have *: "dist m r \<le> C + e" using H(2)[OF \<open>m \<in> H\<close>] by auto
     have "dist x p \<le> dist x r"
       using \<open>r \<in> G\<close> assms(2) proj_set_dist_le by blast
     also have "... \<le> dist x m + dist m r"
       by (intro mono_intros)
     finally show ?thesis using * by (auto simp add: metric_space_class.dist_commute)
   qed
   then have "dist x p - dist x m - C \<le> 0"
     using dense_ge by blast
   then show ?thesis
     using I unfolding Gromov_product_at_def by (auto simp add: algebra_simps divide_simps)
 qed
 
 text \<open>The next lemma is~\cite[Proposition 10.2.1]{coornaert_delzant_papadopoulos} with better
 constants. It states that the distance between the projections
 on a quasi-convex set is controlled by the distance of the original points, with a gain given by the
 distances of the points to the set.\<close>
 
 lemma (in Gromov_hyperbolic_space_geodesic) proj_along_quasiconvex_contraction:
   assumes "quasiconvex C G" "px \<in> proj_set x G" "py \<in> proj_set y G"
   shows "dist px py \<le> max (5 * deltaG(TYPE('a)) + 2 * C) (dist x y - dist px x - dist py y + 10 * deltaG(TYPE('a)) + 4 * C)"
 proof -
   have "px \<in> G" "py \<in> G"
     using assms proj_setD by auto
   have "(dist x px + dist px py - 4 * deltaG(TYPE('a)) - 2 * C) + (dist y py + dist py px - 4 *deltaG(TYPE('a)) - 2 * C)
         \<le> dist x py + dist y px"
     apply (intro mono_intros)
     using dist_along_quasiconvex[OF assms(1) assms(2) \<open>py \<in> G\<close>] dist_along_quasiconvex[OF assms(1) assms(3) \<open>px \<in> G\<close>] by auto
   also have "... \<le> max (dist x y + dist py px) (dist x px + dist py y) + 2 * deltaG(TYPE('a))"
     by (rule hyperb_quad_ineq)
   finally have *: "dist x px + dist y py + 2 * dist px py
           \<le> max (dist x y + dist py px) (dist x px + dist py y) + 10 * deltaG(TYPE('a)) + 4 * C"
     by (auto simp add: metric_space_class.dist_commute)
   show ?thesis
   proof (cases "dist x y + dist py px \<ge> dist x px + dist py y")
     case True
     then have "dist x px + dist y py + 2 * dist px py \<le> dist x y + dist py px + 10 * deltaG(TYPE('a)) + 4 * C"
       using * by auto
     then show ?thesis by (auto simp add: metric_space_class.dist_commute)
   next
     case False
     then have "dist x px + dist y py + 2 * dist px py \<le> dist x px + dist py y + 10 * deltaG(TYPE('a)) + 4 * C"
       using * by auto
     then show ?thesis by (simp add: metric_space_class.dist_commute)
   qed
 qed
 
 text \<open>The projection on a quasi-convex set is $1$-Lipschitz up to an additive error.\<close>
 
 lemma (in Gromov_hyperbolic_space_geodesic) proj_along_quasiconvex_contraction':
   assumes "quasiconvex C G" "px \<in> proj_set x G" "py \<in> proj_set y G"
   shows "dist px py \<le> dist x y + 4 * deltaG(TYPE('a)) + 2 * C"
 proof (cases "dist y py \<le> dist x px")
   case True
   have "dist x px + dist px py \<le> dist x py + 4 * deltaG(TYPE('a)) + 2 * C"
     by (rule dist_along_quasiconvex[OF assms(1) assms(2) proj_setD(1)[OF assms(3)]])
   also have "... \<le> (dist x y + dist y py) + 4 * deltaG(TYPE('a)) + 2 * C"
     by (intro mono_intros)
   finally show ?thesis using True by auto
 next
   case False
   have "dist y py + dist py px \<le> dist y px + 4 * deltaG(TYPE('a)) + 2 * C"
     by (rule dist_along_quasiconvex[OF assms(1) assms(3) proj_setD(1)[OF assms(2)]])
   also have "... \<le> (dist y x + dist x px) + 4 * deltaG(TYPE('a)) + 2 * C"
     by (intro mono_intros)
   finally show ?thesis using False by (auto simp add: metric_space_class.dist_commute)
 qed
 
 text \<open>We can in particular specialize the previous statements to geodesics, which are
 $0$-quasi-convex.\<close>
 
 lemma (in Gromov_hyperbolic_space_geodesic) dist_along_geodesic:
   assumes "geodesic_segment G" "p \<in> proj_set x G" "y \<in> G"
   shows "dist x p + dist p y \<le> dist x y + 4 * deltaG(TYPE('a))"
 using dist_along_quasiconvex[OF quasiconvex_of_geodesic[OF assms(1)] assms(2) assms(3)] by auto
 
 lemma (in Gromov_hyperbolic_space_geodesic) proj_along_geodesic_contraction:
   assumes "geodesic_segment G" "px \<in> proj_set x G" "py \<in> proj_set y G"
   shows "dist px py \<le> max (5 * deltaG(TYPE('a))) (dist x y - dist px x - dist py y + 10 * deltaG(TYPE('a)))"
 using proj_along_quasiconvex_contraction[OF quasiconvex_of_geodesic[OF assms(1)] assms(2) assms(3)] by auto
 
 lemma (in Gromov_hyperbolic_space_geodesic) proj_along_geodesic_contraction':
   assumes "geodesic_segment G" "px \<in> proj_set x G" "py \<in> proj_set y G"
   shows "dist px py \<le> dist x y + 4 * deltaG(TYPE('a))"
 using proj_along_quasiconvex_contraction'[OF quasiconvex_of_geodesic[OF assms(1)] assms(2) assms(3)] by auto
 
 text \<open>If one projects a continuous curve on a quasi-convex set, the image does not have to be
 connected (the projection is discontinuous), but since the projections of nearby points are within
 uniformly bounded distance one can find in the projection a point with almost prescribed distance
 to the starting point, say. For further applications, we also pick the first such point, i.e.,
 all the previous points are also close to the starting point.\<close>
 
 lemma (in Gromov_hyperbolic_space_geodesic) quasi_convex_projection_small_gaps:
   assumes "continuous_on {a..(b::real)} f"
           "a \<le> b"
           "quasiconvex C G"
           "\<And>t. t \<in> {a..b} \<Longrightarrow> p t \<in> proj_set (f t) G"
           "delta > deltaG(TYPE('a))"
           "d \<in> {4 * delta + 2 * C..dist (p a) (p b)}"
   shows "\<exists>t \<in> {a..b}. (dist (p a) (p t) \<in> {d - 4 * delta - 2 * C .. d})
                     \<and> (\<forall>s \<in> {a..t}. dist (p a) (p s) \<le> d)"
 proof -
   have "delta > 0"
     using assms(5) local.delta_nonneg by linarith
   moreover have "C \<ge> 0"
     using quasiconvexC[OF assms(3)] by simp
   ultimately have "d \<ge> 0" using assms by auto
 
   text \<open>The idea is to define the desired point as the last point $u$ for which there is a projection
   at distance at most $d$ of the starting point. Then the projection can not be much closer to
   the starting point, or one could point another such point further away by almost continuity, giving
   a contradiction. The technical implementation requires some care, as the "last point" may not
   satisfy the property, for lack of continuity. If it does, then fine. Otherwise, one should go just
   a little bit to its left to find the desired point.\<close>
   define I where "I = {t \<in> {a..b}. \<forall>s \<in> {a..t}. dist (p a) (p s) \<le> d}"
   have "a \<in> I"
     using \<open>a \<le> b\<close> \<open>d \<ge> 0\<close> unfolding I_def by auto
   have "bdd_above I"
     unfolding I_def by auto
   define u where "u = Sup I"
   have "a \<le> u"
     unfolding u_def apply (rule cSup_upper) using \<open>a \<in> I\<close> \<open>bdd_above I\<close> by auto
   have "u \<le> b"
     unfolding u_def apply (rule cSup_least) using \<open>a \<in> I\<close> apply auto unfolding I_def by auto
   have A: "dist (p a) (p s) \<le> d" if "s < u" "a \<le> s" for s
   proof -
     have "\<exists>t\<in>I. s < t"
       unfolding u_def apply (subst less_cSup_iff[symmetric])
       using \<open>a \<in> I\<close> \<open>bdd_above I\<close> using \<open>s < u\<close> unfolding u_def by auto
     then obtain t where t: "t \<in> I" "s < t" by auto
     then have "s \<in> {a..t}" using \<open>a \<le> s\<close> by auto
     then show ?thesis
       using t(1) unfolding I_def by auto
   qed
   have "continuous (at u within {a..b}) f"
     using assms(1) by (simp add: \<open>a \<le> u\<close> \<open>u \<le> b\<close> continuous_on_eq_continuous_within)
   then have "\<exists>i > 0. \<forall>s\<in>{a..b}. dist u s < i \<longrightarrow> dist (f u) (f s) < (delta - deltaG(TYPE('a)))"
     unfolding continuous_within_eps_delta using \<open>deltaG(TYPE('a)) < delta\<close> by (auto simp add: metric_space_class.dist_commute)
   then obtain e0 where e0: "e0 > 0" "\<And>s. s \<in> {a..b} \<Longrightarrow> dist u s < e0 \<Longrightarrow> dist (f u) (f s) < (delta - deltaG(TYPE('a)))"
     by auto
 
   show ?thesis
   proof (cases "dist (p a) (p u) > d")
     text \<open>First, consider the case where $u$ does not satisfy the defining property. Then the
     desired point $t$ is taken slightly to its left.\<close>
     case True
     then have "u \<noteq> a"
       using \<open>d \<ge> 0\<close> by auto
     then have "a < u" using \<open>a \<le> u\<close> by auto
 
     define e::real where "e = min (e0/2) ((u-a)/2)"
     then have "e > 0" using \<open>a < u\<close> \<open>e0 > 0\<close> by auto
     define t where "t = u - e"
     then have "t < u" using \<open>e > 0\<close> by auto
     have "u - b \<le> e" "e \<le> u - a"
       using \<open>e > 0\<close> \<open>u \<le> b\<close> unfolding e_def by (auto simp add: min_def)
     then have "t \<in> {a..b}" "t \<in> {a..t}"
       unfolding t_def by auto
     have "dist u t < e0"
       unfolding t_def e_def dist_real_def using \<open>e0 > 0\<close> \<open>a \<le> u\<close> by auto
     have *: "\<forall>s \<in> {a..t}. dist (p a) (p s) \<le> d"
       using A \<open>t < u\<close> by auto
     have "dist (p t) (p u) \<le> dist (f t) (f u) + 4 * deltaG(TYPE('a)) + 2 * C"
       apply (rule proj_along_quasiconvex_contraction'[OF \<open>quasiconvex C G\<close>])
       using assms (4) \<open>t \<in> {a..b}\<close> \<open>a \<le> u\<close> \<open>u \<le> b\<close> by auto
     also have "... \<le> (delta - deltaG(TYPE('a))) + 4 * deltaG(TYPE('a)) + 2 * C"
       apply (intro mono_intros)
       using e0(2)[OF \<open>t \<in> {a..b}\<close> \<open>dist u t < e0\<close>] by (auto simp add: metric_space_class.dist_commute)
     finally have I: "dist (p t) (p u) \<le> 4 * delta + 2 * C"
       using \<open>delta > deltaG(TYPE('a))\<close> by simp
 
     have "d \<le> dist (p a) (p u)"
       using True by auto
     also have "... \<le> dist (p a) (p t) + dist (p t) (p u)"
       by (intro mono_intros)
     also have "... \<le> dist (p a) (p t) + 4 * delta + 2 * C"
       using I by simp
     finally have **: "d - 4 * delta - 2 * C \<le> dist (p a) (p t)"
       by simp
     show ?thesis
       apply (rule bexI[OF _ \<open>t \<in> {a..b}\<close>]) using * ** \<open>t \<in> {a..b}\<close> by auto
   next
     text \<open>Next, consider the case where $u$ satisfies the defining property. Then we will take $t = u$.
     The only nontrivial point to check is that the distance of $f(u)$ to the starting point is not
     too small. For this, we need to separate the case where $u = b$ (in which case one argues directly)
     and the case where $u < b$, where one can use a point slightly to the right of $u$ which has a
     projection at distance $ > d$ of the starting point, and use almost continuity.\<close>
     case False
     have B: "dist (p a) (p s) \<le> d" if "s \<in> {a..u}" for s
     proof (cases "s = u")
       case True
       show ?thesis
         unfolding True using False by auto
     next
       case False
       then show ?thesis
         using that A by auto
     qed
     have C: "dist (p a) (p u) \<ge> d - 4 *delta - 2 * C"
     proof (cases "u = b")
       case True
       have "d \<le> dist (p a) (p b)"
         using assms by auto
       also have "... \<le> dist (p a) (p u) + dist (p u) (p b)"
         by (intro mono_intros)
       also have "... \<le> dist (p a) (p u) + (dist (f u) (f b) + 4 * deltaG TYPE('a) + 2 * C)"
         apply (intro mono_intros proj_along_quasiconvex_contraction'[OF \<open>quasiconvex C G\<close>])
         using assms \<open>a \<le> u\<close> \<open>u \<le> b\<close> by auto
       finally show ?thesis
         unfolding True using \<open>deltaG(TYPE('a)) < delta\<close> by auto
     next
       case False
       then have "u < b"
         using \<open>u \<le> b\<close> by auto
       define e::real where "e = min (e0/2) ((b-u)/2)"
       then have "e > 0" using \<open>u < b\<close> \<open>e0 > 0\<close> by auto
       define v where "v = u + e"
       then have "u < v"
         using \<open>e > 0\<close> by auto
       have "e \<le> b - u" "a - u \<le> e"
         using \<open>e > 0\<close> \<open>a \<le> u\<close> unfolding e_def by (auto simp add: min_def)
       then have "v \<in> {a..b}"
         unfolding v_def by auto
       moreover have "v \<notin> I"
         using \<open>u < v\<close> \<open>bdd_above I\<close> cSup_upper not_le unfolding u_def by auto
       ultimately have "\<exists>w \<in> {a..v}. dist (p a) (p w) > d"
         unfolding I_def by force
       then obtain w where w: "w \<in> {a..v}" "dist (p a) (p w) > d"
         by auto
       then have "w \<notin> {a..u}"
         using B by force
       then have "u < w"
         using w(1) by auto
       have "w \<in> {a..b}"
         using w(1) \<open>v \<in> {a..b}\<close> by auto
       have "dist u w = w - u"
         unfolding dist_real_def using \<open>u < w\<close> by auto
       also have "... \<le> v - u"
         using w(1) by auto
       also have "... < e0"
         unfolding v_def e_def min_def using \<open>e0 > 0\<close> by auto
       finally have "dist u w < e0" by simp
       have "dist (p u) (p w) \<le> dist (f u) (f w) + 4 * deltaG(TYPE('a)) + 2 * C"
         apply (rule proj_along_quasiconvex_contraction'[OF \<open>quasiconvex C G\<close>])
         using assms \<open>a \<le> u\<close> \<open>u \<le> b\<close> \<open>w \<in> {a..b}\<close> by auto
       also have "... \<le> (delta - deltaG(TYPE('a))) + 4 * deltaG(TYPE('a)) + 2 * C"
         apply (intro mono_intros)
         using e0(2)[OF \<open>w \<in> {a..b}\<close> \<open>dist u w < e0\<close>] by (auto simp add: metric_space_class.dist_commute)
       finally have I: "dist (p u) (p w) \<le> 4 * delta + 2 * C"
         using \<open>delta > deltaG(TYPE('a))\<close> by simp
       have "d \<le> dist (p a) (p u) + dist (p u) (p w)"
         using w(2) metric_space_class.dist_triangle[of "p a" "p w" "p u"] by auto
       also have "... \<le> dist (p a) (p u) + 4 * delta + 2 * C"
         using I by auto
       finally show ?thesis by simp
     qed
     show ?thesis
       apply (rule bexI[of _ u])
       using B \<open>a \<le> u\<close> \<open>u \<le> b\<close> C by auto
   qed
 qed
 
 text \<open>Same lemma, except that one exchanges the roles of the beginning and the end point.\<close>
 
 lemma (in Gromov_hyperbolic_space_geodesic) quasi_convex_projection_small_gaps':
   assumes "continuous_on {a..(b::real)} f"
           "a \<le> b"
           "quasiconvex C G"
           "\<And>x. x \<in> {a..b} \<Longrightarrow> p x \<in> proj_set (f x) G"
           "delta > deltaG(TYPE('a))"
           "d \<in> {4 * delta + 2 * C..dist (p a) (p b)}"
   shows "\<exists>t \<in> {a..b}. dist (p b) (p t) \<in> {d - 4 * delta - 2 * C .. d}
                     \<and> (\<forall>s \<in> {t..b}. dist (p b) (p s) \<le> d)"
 proof -
   have *: "continuous_on {-b..-a} (\<lambda>t. f(-t))"
     using continuous_on_compose[of "{-b..-a}" "\<lambda>t. -t" f] using assms(1) continuous_on_minus[OF continuous_on_id] by auto
   define q where "q = (\<lambda>t. p(-t))"
   have "\<exists>t \<in> {-b..-a}. (dist (q (-b)) (q t) \<in> {d - 4 * delta - 2 * C .. d})
                     \<and> (\<forall>s \<in> {-b..t}. dist (q (-b)) (q s) \<le> d)"
     apply (rule quasi_convex_projection_small_gaps[where ?f = "\<lambda>t. f(-t)" and ?G = G])
     unfolding q_def using assms * by (auto simp add: metric_space_class.dist_commute)
   then obtain t where t: "t \<in> {-b..-a}" "dist (q (-b)) (q t) \<in> {d - 4 * delta - 2 * C .. d}"
                       "\<And>s. s \<in> {-b..t} \<Longrightarrow> dist (q (-b)) (q s) \<le> d"
     by blast
   have *: "dist (p b) (p s) \<le> d" if "s \<in> {-t..b}" for s
     using t(3)[of "-s"] that q_def by auto
   show ?thesis
     apply (rule bexI[of _ "-t"]) using t * q_def by auto
 qed
 
 section \<open>The Morse-Gromov Theorem\<close>
 
 text \<open>The goal of this section is to prove a central basic result in the theory of hyperbolic spaces,
 usually called the Morse Lemma. It is really
 a theorem, and we add the name Gromov the avoid the confusion with the other Morse lemma
 on the existence of good coordinates for $C^2$ functions with non-vanishing hessian.
 
 It states that a quasi-geodesic remains within bounded distance of a geodesic with the same
 endpoints, the error depending only on $\delta$ and on the parameters $(\lambda, C)$ of the
 quasi-geodesic, but not on its length.
 
 There are several proofs of this result. We will follow the one of Shchur~\cite{shchur}, which
 gets an optimal dependency in terms of the parameters of the quasi-isometry, contrary to all
 previous proofs. The price to pay is that the proof is more involved (relying in particular on
 the fact that the closest point projection on quasi-convex sets is exponentially contracting).
 
 We will also give afterwards for completeness the proof in~\cite{bridson_haefliger}, as it brings
 up interesting tools, although the dependency it gives is worse.\<close>
 
 text \<open>The next lemma (for $C = 0$, Lemma 2 in~\cite{shchur}) asserts that, if two points are not too far apart (at distance at most
 $10 \delta$), and far enough from a given geodesic segment, then when one moves towards this
 geodesic segment by a fixed amount (here $5 \delta$), then the two points become closer (the new
 distance is at most $5 \delta$, gaining a factor of $2$). Later, we will iterate this lemma to
 show that the projection on a geodesic segment is exponentially contracting. For the application,
 we give a more general version involving an additional constant $C$.
 
 This lemma holds for $\delta$ the hyperbolicity constant. We will want to apply it with $\delta > 0$,
 so to avoid problems in the case $\delta = 0$ we formulate it not using the hyperbolicity constant of
 the given type, but any constant which is at least the hyperbolicity constant (this is to work
 around the fact that one can not say or use easily in Isabelle that a type with hyperbolicity
 $\delta$ is also hyperbolic for any larger constant $\delta'$.\<close>
 
 lemma (in Gromov_hyperbolic_space_geodesic) geodesic_projection_exp_contracting_aux:
   assumes "geodesic_segment G"
           "px \<in> proj_set x G"
           "py \<in> proj_set y G"
           "delta \<ge> deltaG(TYPE('a))"
           "dist x y \<le> 10 * delta + C"
           "M \<ge> 15/2 * delta"
           "dist px x \<ge> M + 5 * delta + C/2"
           "dist py y \<ge> M + 5 * delta + C/2"
           "C \<ge> 0"
   shows "dist (geodesic_segment_param {px--x} px M)
               (geodesic_segment_param {py--y} py M) \<le> 5 * delta"
 proof -
   have "dist px x \<le> dist py x"
     using proj_setD(2)[OF assms(2)] infdist_le[OF proj_setD(1)[OF assms(3)], of x] by (simp add: metric_space_class.dist_commute)
   have "dist py y \<le> dist px y"
     using proj_setD(2)[OF assms(3)] infdist_le[OF proj_setD(1)[OF assms(2)], of y] by (simp add: metric_space_class.dist_commute)
 
   have "delta \<ge> 0"
     using assms local.delta_nonneg by linarith
   then have M: "M \<ge> 0" "M \<le> dist px x" "M \<le> dist px y" "M \<le> dist py x" "M \<le> dist py y"
     using assms \<open>dist px x \<le> dist py x\<close> \<open>dist py y \<le> dist px y \<close>by auto
   have "px \<in> G" "py \<in> G"
     using assms proj_setD by auto
 
   define x' where "x' = geodesic_segment_param {px--x} px M"
   define y' where "y' = geodesic_segment_param {py--y} py M"
 
   text \<open>First step: the distance between $px$ and $py$ is at most $5\delta$.\<close>
   have "dist px py \<le> max (5 * deltaG(TYPE('a))) (dist x y - dist px x - dist py y + 10 * deltaG(TYPE('a)))"
     by (rule proj_along_geodesic_contraction[OF assms(1) assms(2) assms(3)])
   also have "... \<le> max (5 * deltaG(TYPE('a))) (5 * deltaG(TYPE('a)))"
     apply (intro mono_intros) using assms \<open>delta \<ge> 0\<close> by auto
   finally have "dist px py \<le> 5 * delta"
     using \<open>delta \<ge> deltaG(TYPE('a))\<close> by auto
 
   text \<open>Second step: show that all the interesting Gromov products at bounded below by $M$.\<close>
   have *: "x' \<in> {px--x}" unfolding x'_def
     by (simp add: geodesic_segment_param_in_segment)
   have "px \<in> proj_set x' G"
     by (rule proj_set_geodesic_same_basepoint[OF \<open>px \<in> proj_set x G\<close> _ *], auto)
   have "dist px x' = M"
     unfolding x'_def using M by auto
   have "dist px x' \<le> dist py x'"
     using proj_setD(2)[OF \<open>px \<in> proj_set x' G\<close>] infdist_le[OF proj_setD(1)[OF assms(3)], of x'] by (simp add: metric_space_class.dist_commute)
   have **: "dist px x = dist px x' + dist x' x"
     using geodesic_segment_dist[OF _ *, of px x] by auto
   have Ixx: "Gromov_product_at px x' x = M"
     unfolding Gromov_product_at_def ** x'_def using M by auto
   have "2 * M = dist px x' + dist px x - dist x' x"
     unfolding ** x'_def using M by auto
   also have "... \<le> dist py x' + dist py x - dist x' x"
     apply (intro mono_intros, auto) by fact+
   also have "... = 2 * Gromov_product_at py x x'"
     unfolding Gromov_product_at_def by (auto simp add: metric_space_class.dist_commute)
   finally have Iyx: "Gromov_product_at py x x' \<ge> M" by auto
 
   have *: "y' \<in> {py--y}" unfolding y'_def
     by (simp add: geodesic_segment_param_in_segment)
   have "py \<in> proj_set y' G"
     by (rule proj_set_geodesic_same_basepoint[OF \<open>py \<in> proj_set y G\<close> _ *], auto)
   have "dist py y' = M"
     unfolding y'_def using M by auto
   have "dist py y' \<le> dist px y'"
     using proj_setD(2)[OF \<open>py \<in> proj_set y' G\<close>] infdist_le[OF proj_setD(1)[OF assms(2)], of y'] by (simp add: metric_space_class.dist_commute)
   have **: "dist py y = dist py y' + dist y' y"
     using geodesic_segment_dist[OF _ *, of py y] by auto
   have Iyy: "Gromov_product_at py y' y = M"
     unfolding Gromov_product_at_def ** y'_def using M by auto
   have "2 * M = dist py y' + dist py y - dist y' y"
     unfolding ** y'_def using M by auto
   also have "... \<le> dist px y' + dist px y - dist y' y"
     apply (intro mono_intros, auto) by fact+
   also have "... = 2 * Gromov_product_at px y y'"
     unfolding Gromov_product_at_def by (auto simp add: metric_space_class.dist_commute)
   finally have Ixy: "Gromov_product_at px y y' \<ge> M" by auto
 
   have "2 * M \<le> dist px x + dist py y - dist x y"
     using assms by auto
   also have "... \<le> dist px x + dist px y - dist x y"
     by (intro mono_intros, fact)
   also have "... = 2 * Gromov_product_at px x y"
     unfolding Gromov_product_at_def by auto
   finally have Ix: "Gromov_product_at px x y \<ge> M"
     by auto
   have "2 * M \<le> dist px x + dist py y - dist x y"
     using assms by auto
   also have "... \<le> dist py x + dist py y - dist x y"
     by (intro mono_intros, fact)
   also have "... = 2 * Gromov_product_at py x y"
     unfolding Gromov_product_at_def by auto
   finally have Iy: "Gromov_product_at py x y \<ge> M"
     by auto
 
   text \<open>Third step: prove the estimate\<close>
   have "M - 2 * delta \<le> Min {Gromov_product_at px x' x, Gromov_product_at px x y, Gromov_product_at px y y'} - 2 * deltaG(TYPE('a))"
     using Ixx Ixy Ix \<open>delta \<ge> deltaG(TYPE('a))\<close> by auto
   also have "... \<le> Gromov_product_at px x' y'"
     by (intro mono_intros)
   finally have A: "M - 4 * delta + dist x' y' \<le> dist px y'"
     unfolding Gromov_product_at_def \<open>dist px x' = M\<close> by auto
 
   have "M - 2 * delta \<le> Min {Gromov_product_at py x' x, Gromov_product_at py x y, Gromov_product_at py y y'} - 2 * deltaG(TYPE('a))"
     using Iyx Iyy Iy \<open>delta \<ge> deltaG(TYPE('a))\<close> by (auto simp add: Gromov_product_commute)
   also have "... \<le> Gromov_product_at py x' y'"
     by (intro mono_intros)
   finally have B: "M - 4 * delta + dist x' y' \<le> dist py x'"
     unfolding Gromov_product_at_def \<open>dist py y' = M\<close> by auto
 
   have "dist px py \<le> 2 * M - 10 * delta"
     using assms \<open>dist px py \<le> 5 * delta\<close> by auto
   have "2 * M - 8 * delta + 2 * dist x' y' \<le> dist px y' + dist py x'"
     using A B by auto
   also have "... \<le> max (dist px py + dist y' x') (dist px x' + dist y' py) + 2 * deltaG TYPE('a)"
     by (rule hyperb_quad_ineq)
   also have "... \<le> max (dist px py + dist y' x') (dist px x' + dist y' py) + 2 * delta"
     using \<open>deltaG(TYPE('a)) \<le> delta\<close> by auto
   finally have "2 * M - 10 * delta + 2 * dist x' y' \<le> max (dist px py + dist y' x') (dist px x' + dist y' py)"
     by auto
   then have "2 * M - 10 * delta + 2 * dist x' y' \<le> dist px x' + dist py y'"
     apply (auto simp add: metric_space_class.dist_commute)
     using \<open>0 \<le> delta\<close> \<open>dist px py \<le> 2 * M - 10 * delta\<close> \<open>dist px x' = M\<close> \<open>dist py y' = M\<close> by auto
   then have "dist x' y' \<le> 5 * delta"
     unfolding \<open>dist px x' = M\<close> \<open>dist py y' = M\<close> by auto
   then show ?thesis
     unfolding x'_def y'_def by auto
 qed
 
 text \<open>The next lemma (Lemma 10 in~\cite{shchur} for $C = 0$) asserts that the projection on a geodesic segment is
 an exponential contraction.
 More precisely, if a path of length $L$ is at distance at least $D$ of a geodesic segment $G$,
 then the projection of the path on $G$ has diameter at most $C L \exp(-c D/\delta)$, where $C$ and
 $c$ are universal constants. This is not completely true at one can not go below a fixed size, as
 always, so the correct bound is $K \max(\delta, L \exp(-c D/\delta))$. For the application, we
 give a slightly more general statement involving an additional constant $C$.
 
 This statement follows from the previous lemma: if one moves towards $G$ by $10 \delta$, then
 the distance between points is divided by $2$. Then one iterates this statement as many times
 as possible, gaining a factor $2$ each time and therefore an exponential factor in the end.\<close>
 
 lemma (in Gromov_hyperbolic_space_geodesic) geodesic_projection_exp_contracting:
   assumes "geodesic_segment G"
           "\<And>x y. x \<in> {a..b} \<Longrightarrow> y \<in> {a..b} \<Longrightarrow> dist (f x) (f y) \<le> lambda * dist x y + C"
           "a \<le> b"
           "pa \<in> proj_set (f a) G"
           "pb \<in> proj_set (f b) G"
           "\<And>t. t \<in> {a..b} \<Longrightarrow> infdist (f t) G \<ge> D"
           "D \<ge> 15/2 * delta + C/2"
           "delta > deltaG(TYPE('a))"
           "C \<ge> 0"
           "lambda \<ge> 0"
   shows "dist pa pb \<le> max (5 * deltaG(TYPE('a))) ((4 * exp(1/2 * ln 2)) * lambda * (b-a) * exp(-(D-C/2) * ln 2 / (5 * delta)))"
 proof -
   have "delta > 0" using assms
     using local.delta_nonneg by linarith
   have "exp(15/2/5 * ln 2) = exp(ln 2) * exp(1/2 * ln (2::real))"
     unfolding mult_exp_exp by simp
   also have "... = 2 * exp(1/2 * ln 2)"
     by auto
   finally have "exp(15/2/5 * ln 2) = 2 * exp(1/2 * ln (2::real))"
     by simp
 
   text \<open>The idea of the proof is to start with a sequence of points separated by $10 \delta + C$ along
   the original path, and push them by a fixed distance towards $G$ to bring them at distance at most
   $5 \delta$, thanks to the previous lemma. Then, discard half the points, and start again. This
   is possible while one is far enough from $G$. In the first step of the proof, we formalize this
   in the case where the process can be iterated long enough that, at the end, the projections on $G$
   are very close together. This is a simple induction, based on the previous lemma.\<close>
 
   have Main: "\<And>c g p. (\<forall>i \<in> {0..2^k}. p i \<in> proj_set (g i) G)
             \<Longrightarrow> (\<forall>i \<in> {0..2^k}. dist (p i) (g i) \<ge> 5 * delta * k + 15/2 * delta + c/2)
             \<Longrightarrow> (\<forall>i \<in> {0..<2^k}. dist (g i) (g (Suc i)) \<le> 10 * delta + c)
             \<Longrightarrow> c \<ge> 0
             \<Longrightarrow> dist (p 0) (p (2^k)) \<le> 5 * deltaG(TYPE('a))" for k
   proof (induction k)
     case 0
     then have H: "p 0 \<in> proj_set (g 0) G"
                  "p 1 \<in> proj_set (g 1) G"
                  "dist (g 0) (g 1) \<le> 10 * delta + c"
                  "dist (p 0) (g 0) \<ge> 15/2 * delta + c/2"
                  "dist (p 1) (g 1) \<ge> 15/2 * delta + c/2"
       by auto
     have "dist (p 0) (p 1) \<le> max (5 * deltaG(TYPE('a))) (dist (g 0) (g 1) - dist (p 0) (g 0) - dist (p 1) (g 1) + 10 * deltaG(TYPE('a)))"
       by (rule proj_along_geodesic_contraction[OF \<open>geodesic_segment G\<close> \<open>p 0 \<in> proj_set (g 0) G\<close> \<open>p 1 \<in> proj_set (g 1) G\<close>])
     also have "... \<le> max (5 * deltaG(TYPE('a))) (5 * deltaG(TYPE('a)))"
       apply (intro mono_intros) using H \<open>delta > deltaG(TYPE('a))\<close> by auto
     finally show "dist (p 0) (p (2^0)) \<le> 5 * deltaG(TYPE('a))"
       by auto
   next
     case (Suc k)
     have *: "5 * delta * real (k + 1) + 5 * delta = 5 * delta * real (Suc k + 1)"
       by (simp add: algebra_simps)
     define h where "h = (\<lambda>i. geodesic_segment_param {p i--g i} (p i) (5 * delta * k + 15/2 * delta))"
     have h_dist: "dist (h i) (h (Suc i)) \<le> 5 * delta" if "i \<in> {0..<2^(Suc k)}" for i
       unfolding h_def apply (rule geodesic_projection_exp_contracting_aux[OF \<open>geodesic_segment G\<close> _ _ less_imp_le[OF \<open>delta > deltaG(TYPE('a))\<close>]])
       unfolding * using Suc.prems that \<open>delta > 0\<close> by (auto simp add: algebra_simps divide_simps)
     define g' where "g' = (\<lambda>i. h (2 * i))"
     define p' where "p' = (\<lambda>i. p (2 * i))"
     have "dist (p' 0) (p' (2^k)) \<le> 5 * deltaG(TYPE('a))"
     proof (rule Suc.IH[where ?g = g' and ?c = 0])
       show "\<forall>i\<in>{0..2 ^ k}. p' i \<in> proj_set (g' i) G"
       proof
         fix i::nat assume "i \<in> {0..2^k}"
         then have *: "2 * i \<in> {0..2^(Suc k)}" by auto
         show "p' i \<in> proj_set (g' i) G"
           unfolding p'_def g'_def h_def apply (rule proj_set_geodesic_same_basepoint[of _ "g (2 * i)" _ "{p(2 * i)--g(2 * i)}"])
           using Suc * by (auto simp add: geodesic_segment_param_in_segment)
       qed
       show "\<forall>i\<in>{0..2 ^ k}. 5 * delta * k + 15/2 * delta + 0/2 \<le> dist (p' i) (g' i)"
       proof
         fix i::nat assume "i \<in> {0..2^k}"
         then have *: "2 * i \<in> {0..2^(Suc k)}" by auto
         have "5 * delta * k + 15/2 * delta \<le> 5 * delta * Suc k + 15/2 * delta + c/2"
           using \<open>delta > 0\<close> \<open>c \<ge> 0\<close> by (auto simp add: algebra_simps divide_simps)
         also have "... \<le> dist (p (2 * i)) (g (2 * i))"
           using Suc * by auto
         finally have *: "5 * delta * k + 15/2 * delta \<le> dist (p (2 * i)) (g (2 * i))" by simp
         have "dist (p' i) (g' i) = 5 * delta * k + 15/2 * delta"
           unfolding p'_def g'_def h_def apply (rule geodesic_segment_param_in_geodesic_spaces(6))
           using * \<open>delta > 0\<close> by auto
         then show "5 * delta * k + 15/2 * delta + 0/2 \<le> dist (p' i) (g' i)" by simp
       qed
       show "\<forall>i\<in>{0..<2 ^ k}. dist (g' i) (g' (Suc i)) \<le> 10 * delta + 0"
       proof
         fix i::nat assume *: "i \<in> {0..<2 ^ k}"
         have "dist (g' i) (g' (Suc i)) = dist (h (2 * i)) (h (Suc (Suc (2 * i))))"
           unfolding g'_def by auto
         also have "... \<le> dist (h (2 * i)) (h (Suc (2 * i))) + dist (h (Suc (2 * i))) (h (Suc (Suc (2 * i))))"
           by (intro mono_intros)
         also have "... \<le> 5 * delta + 5 * delta"
           apply (intro mono_intros h_dist) using * by auto
         finally show "dist (g' i) (g' (Suc i)) \<le> 10 * delta + 0" by simp
       qed
     qed (simp)
     then show "dist (p 0) (p (2 ^ Suc k)) \<le> 5 * deltaG(TYPE('a))"
       unfolding p'_def by auto
   qed
 
   text \<open>Now, we will apply the previous basic statement to points along our original path. We
   introduce $k$, the number of steps for which the pushing process can be done -- it only depends on
   the original distance $D$ to $G$. \<close>
 
   define k where "k = nat(floor((D - C/2 - 15/2 * delta)/(5 * delta)))"
   have "int k = floor((D - C/2 - 15/2 * delta)/(5 * delta))"
     unfolding k_def apply (rule nat_0_le) using \<open>D \<ge> 15/2 * delta + C/2\<close> \<open>delta > 0\<close> by auto
   then have "k \<le> (D - C/2 - 15/2 * delta)/(5 * delta)" "(D - C/2 - 15/2 * delta)/(5 * delta) \<le> k + 1"
     by linarith+
   then have k: "D \<ge> 5 * delta * k + 15/2 * delta + C/2" "D \<le> 5 * delta * (k+1) + 15/2 * delta + C/2"
     using \<open>delta > 0\<close> by (auto simp add: algebra_simps divide_simps)
   have "exp((D-C/2)/(5 * delta) * ln 2) * exp(-15/2/5 * ln 2) = exp(((D-C/2-15/2 * delta)/(5 * delta)) * ln 2)"
     unfolding mult_exp_exp using \<open>delta > 0\<close> by (simp add: algebra_simps divide_simps)
   also have "... \<le> exp((k+1) * ln 2)"
     apply (intro mono_intros) using k(2) \<open>delta > 0\<close> by (auto simp add: divide_simps algebra_simps)
   also have "... = 2^(k+1)"
     by (subst powr_realpow[symmetric], auto simp add: powr_def)
   also have "... = 2 * 2^k"
     by auto
   finally have k': "1/2^k \<le> 2 * exp(15/2/5 * ln 2) * exp(- ((D-C/2) * ln 2 / (5 * delta)))"
     by (auto simp add: algebra_simps divide_simps exp_minus)
 
   text \<open>We separate the proof into two cases. If the path is not too long, then it can be covered by
   $2^k$ points at distance at most $10 \delta + C$. By the basic statement, it follows that the diameter
   of the projection is at most $5 \delta$. Otherwise, we subdivide the path into $2^N$ points at
   distance at most $10 \delta + C$, with $N \geq k$, and apply the basic statement to blocks of $2^k$
   consecutive points. It follows that the projections of $g_0, g_{2^k}, g_{2\cdot 2^k},\dotsc$ are
   at distances at most $5 \delta$. Hence, the first and last projections are at distance at most
   $2^{N-k} \cdot 5 \delta$, which is the desired bound.\<close>
 
   show ?thesis
   proof (cases "lambda * (b-a) \<le> 10 * delta * 2^k")
     text \<open>First, treat the case where the path is rather short.\<close>
     case True
     define g::"nat \<Rightarrow> 'a" where "g = (\<lambda>i. f(a + (b-a) * i/2^k))"
     have "g 0 = f a" "g(2^k) = f b"
       unfolding g_def by auto
     have *: "a + (b-a) * i/2^k \<in> {a..b}" if "i \<in> {0..2^k}" for i::nat
     proof -
       have "a + (b - a) * (real i / 2 ^ k) \<le> a + (b-a) * (2^k/2^k)"
         apply (intro mono_intros) using that \<open>a \<le> b\<close> by auto
       then show ?thesis using \<open>a \<le> b\<close> by auto
     qed
     have A: "dist (g i) (g (Suc i)) \<le> 10 * delta + C" if "i \<in> {0..<2^k}" for i
     proof -
       have "dist (g i) (g (Suc i)) \<le> lambda * dist (a + (b-a) * i/2^k) (a + (b-a) * (Suc i)/2^k) + C"
         unfolding g_def apply (intro assms(2) *) using that by auto
       also have "... = lambda * (b-a)/2^k + C"
         unfolding dist_real_def using \<open>a \<le> b\<close> by (auto simp add: algebra_simps divide_simps)
       also have "... \<le> 10 * delta + C"
         using True by (simp add: divide_simps algebra_simps)
       finally show ?thesis by simp
     qed
     define p where "p = (\<lambda>i. if i = 0 then pa else if i = 2^k then pb else SOME p. p \<in> proj_set (g i) G)"
     have B: "p i \<in> proj_set (g i) G" if "i \<in> {0..2^k}" for i
     proof (cases "i = 0 \<or> i = 2^k")
       case True
       then show ?thesis
         using \<open>pa \<in> proj_set (f a) G\<close> \<open>pb \<in> proj_set (f b) G\<close> unfolding p_def g_def by auto
     next
       case False
       then have "p i = (SOME p. p \<in> proj_set (g i) G)"
         unfolding p_def by auto
       moreover have "proj_set (g i) G \<noteq> {}"
         apply (rule proj_set_nonempty_of_proper) using geodesic_segment_topology[OF \<open>geodesic_segment G\<close>] by auto
       ultimately show ?thesis
         using some_in_eq by auto
     qed
     have C: "dist (p i) (g i) \<ge> 5 * delta * k + 15/2 * delta + C/2" if "i \<in> {0..2^k}" for i
     proof -
       have "5 * delta * k + 15/2 * delta + C/2 \<le> D"
         using k(1) by simp
       also have "... \<le> infdist (g i) G"
         unfolding g_def apply (rule \<open>\<And>t. t \<in> {a..b} \<Longrightarrow> infdist (f t) G \<ge> D\<close>) using * that by auto
       also have "... = dist (p i) (g i)"
         using that proj_setD(2)[OF B[OF that]] by (simp add: metric_space_class.dist_commute)
       finally show ?thesis by simp
     qed
     have "dist (p 0) (p (2^k)) \<le> 5 * deltaG(TYPE('a))"
       apply (rule Main[where ?g = g and ?c = C]) using A B C \<open>C \<ge> 0\<close> by auto
     then show ?thesis
       unfolding p_def by auto
   next
     text \<open>Now, the case where the path is long. We introduce $N$ such that it is roughly of length
     $2^N \cdot 10 \delta$.\<close>
     case False
     have *: "10 * delta * 2^k \<le> lambda * (b-a)" using False by simp
     have "lambda * (b-a) > 0"
       using \<open>delta > 0\<close> False \<open>0 \<le> lambda\<close> assms(3) less_eq_real_def mult_le_0_iff by auto
     then have "a < b" "lambda > 0"
       using \<open>a \<le> b\<close> \<open>lambda \<ge> 0\<close> less_eq_real_def by auto
     define n where "n = nat(floor(log 2 (lambda * (b-a)/(10 * delta))))"
     have "log 2 (lambda * (b-a)/(10 * delta)) \<ge> log 2 (2^k)"
       apply (subst log_le_cancel_iff)
       using * \<open>delta > 0\<close> \<open>a < b\<close> \<open>lambda > 0\<close> by (auto simp add: divide_simps algebra_simps)
     moreover have "log 2 (2^k) = k"
-      by (simp add: log2_of_power_eq)
+      by simp
     ultimately have A: "log 2 (lambda * (b-a)/(10 * delta)) \<ge> k" by auto
     have **: "int n = floor(log 2 (lambda * (b-a)/(10 * delta)))"
       unfolding n_def apply (rule nat_0_le) using A by auto
     then have "log 2 (2^n) \<le> log 2 (lambda * (b-a)/(10 * delta))"
       apply (subst log_nat_power, auto) by linarith
     then have I: "2^n \<le> lambda * (b-a)/(10 * delta)"
-      using \<open>0 < lambda * (b - a)\<close> \<open>0 < delta\<close> by auto
+      using \<open>0 < lambda * (b - a)\<close> \<open>0 < delta\<close>
+      by (simp add: le_log_iff powr_realpow)
     have "log 2 (lambda * (b-a)/(10 * delta)) \<le> log 2 (2^(n+1))"
       apply (subst log_nat_power, auto) using ** by linarith
     then have J: "lambda * (b-a)/(10 * delta) \<le> 2^(n+1)"
       using \<open>0 < lambda * (b - a)\<close> \<open>0 < delta\<close> by auto
     have K: "k \<le> n" using A ** by linarith
     define N where "N = n+1"
     have N: "k+1 \<le> N" "lambda * (b-a) / 2^N \<le> 10 *delta" "2 ^ N \<le> lambda * (b - a) / (5 * delta)"
       using I J K \<open>delta > 0\<close> unfolding N_def by (auto simp add: divide_simps algebra_simps)
     then have "2 ^ k \<noteq> (0::real)" "k \<le> N"
       by auto
     then have "(2^(N-k)::real) = 2^N/2^k"
       by (metis (no_types) add_diff_cancel_left' le_Suc_ex nonzero_mult_div_cancel_left power_add)
 
     text \<open>Define $2^N$ points along the path, separated by at most $10\delta$, and their projections.\<close>
     define g::"nat \<Rightarrow> 'a" where "g = (\<lambda>i. f(a + (b-a) * i/2^N))"
     have "g 0 = f a" "g(2^N) = f b"
       unfolding g_def by auto
     have *: "a + (b-a) * i/2^N \<in> {a..b}" if "i \<in> {0..2^N}" for i::nat
     proof -
       have "a + (b - a) * (real i / 2 ^ N) \<le> a + (b-a) * (2^N/2^N)"
         apply (intro mono_intros) using that \<open>a \<le> b\<close> by auto
       then show ?thesis using \<open>a \<le> b\<close> by auto
     qed
     have A: "dist (g i) (g (Suc i)) \<le> 10 * delta + C" if "i \<in> {0..<2^N}" for i
     proof -
       have "dist (g i) (g (Suc i)) \<le> lambda * dist (a + (b-a) * i/2^N) (a + (b-a) * (Suc i)/2^N) + C"
         unfolding g_def apply (intro assms(2) *)
         using that by auto
       also have "... = lambda * (b-a)/2^N + C"
         unfolding dist_real_def using \<open>a \<le> b\<close> by (auto simp add: algebra_simps divide_simps)
       also have "... \<le> 10 * delta + C"
         using N by simp
       finally show ?thesis by simp
     qed
     define p where "p = (\<lambda>i. if i = 0 then pa else if i = 2^N then pb else SOME p. p \<in> proj_set (g i) G)"
     have B: "p i \<in> proj_set (g i) G" if "i \<in> {0..2^N}" for i
     proof (cases "i = 0 \<or> i = 2^N")
       case True
       then show ?thesis
         using \<open>pa \<in> proj_set (f a) G\<close> \<open>pb \<in> proj_set (f b) G\<close> unfolding p_def g_def by auto
     next
       case False
       then have "p i = (SOME p. p \<in> proj_set (g i) G)"
         unfolding p_def by auto
       moreover have "proj_set (g i) G \<noteq> {}"
         apply (rule proj_set_nonempty_of_proper) using geodesic_segment_topology[OF \<open>geodesic_segment G\<close>] by auto
       ultimately show ?thesis
         using some_in_eq by auto
     qed
     have C: "dist (p i) (g i) \<ge> 5 * delta * k + 15/2 * delta + C/2" if "i \<in> {0..2^N}" for i
     proof -
       have "5 * delta * k + 15/2 * delta + C/2 \<le> D"
         using k(1) by simp
       also have "... \<le> infdist (g i) G"
         unfolding g_def apply (rule \<open>\<And>t. t \<in> {a..b} \<Longrightarrow> infdist (f t) G \<ge> D\<close>) using * that by auto
       also have "... = dist (p i) (g i)"
         using that proj_setD(2)[OF B[OF that]] by (simp add: metric_space_class.dist_commute)
       finally show ?thesis by simp
     qed
     text \<open>Use the basic statement to show that, along packets of size $2^k$, the projections
     are within $5\delta$ of each other.\<close>
     have I: "dist (p (2^k * j)) (p (2^k * (Suc j))) \<le> 5 * delta" if "j \<in> {0..<2^(N-k)}" for j
     proof -
       have I: "i + 2^k * j \<in> {0..2^N}" if "i \<in> {0..2^k}" for i
       proof -
         have "i + 2 ^ k * j \<le> 2^k + 2^k * (2^(N-k)-1)"
           apply (intro mono_intros) using that \<open>j \<in> {0..<2^(N-k)}\<close> by auto
         also have "... = 2^N"
           using \<open>k +1 \<le> N\<close> by (auto simp add: algebra_simps semiring_normalization_rules(26))
         finally show ?thesis by auto
       qed
       have I': "i + 2^k * j \<in> {0..<2^N}" if "i \<in> {0..<2^k}" for i
       proof -
         have "i + 2 ^ k * j < 2^k + 2^k * (2^(N-k)-1)"
           apply (intro mono_intros) using that \<open>j \<in> {0..<2^(N-k)}\<close> by auto
         also have "... = 2^N"
           using \<open>k +1 \<le> N\<close> by (auto simp add: algebra_simps semiring_normalization_rules(26))
         finally show ?thesis by auto
       qed
       define g' where "g' = (\<lambda>i. g (i + 2^k * j))"
       define p' where "p' = (\<lambda>i. p (i + 2^k * j))"
       have "dist (p' 0) (p' (2^k)) \<le> 5 * deltaG(TYPE('a))"
         apply (rule Main[where ?g = g' and ?c = C]) unfolding p'_def g'_def using A B C I I' \<open>C \<ge> 0\<close> by auto
       also have "... \<le> 5 * delta"
         using \<open>deltaG(TYPE('a)) < delta\<close> by auto
       finally show ?thesis
         unfolding p'_def by auto
     qed
     text \<open>Control the total distance by adding the contributions of blocks of size $2^k$.\<close>
     have *: "dist (p 0) (p(2^k * j)) \<le> (\<Sum>i<j. dist (p (2^k * i)) (p (2^k * (Suc i))))" for j
     proof (induction j)
       case (Suc j)
       have "dist (p 0) (p(2^k * (Suc j))) \<le> dist (p 0) (p(2^k * j)) + dist (p(2^k * j)) (p(2^k * (Suc j)))"
         by (intro mono_intros)
       also have "... \<le> (\<Sum>i<j. dist (p (2^k * i)) (p (2^k * (Suc i)))) + dist (p(2^k * j)) (p(2^k * (Suc j)))"
         using Suc.IH by auto
       also have "... = (\<Sum>i<Suc j. dist (p (2^k * i)) (p (2^k * (Suc i))))"
         by auto
       finally show ?case by simp
     qed (auto)
     have "dist pa pb = dist (p 0) (p (2^N))"
       unfolding p_def by auto
     also have "... = dist (p 0) (p (2^k * 2^(N-k)))"
       using \<open>k +1 \<le> N\<close> by (auto simp add: semiring_normalization_rules(26))
     also have "... \<le> (\<Sum>i<2^(N-k). dist (p (2^k * i)) (p (2^k * (Suc i))))"
       using * by auto
     also have "... \<le> (\<Sum>(i::nat)<2^(N-k). 5 * delta)"
       apply (rule sum_mono) using I by auto
     also have "... = 5 * delta * 2^(N-k)"
       by auto
     also have "... = 5 * delta * 2^N * (1/ 2^k)"
       unfolding \<open>(2^(N-k)::real) = 2^N/2^k\<close> by simp
     also have "... \<le> 5 * delta * (2 * lambda * (b-a)/(10 * delta)) * (2 * exp(15/2/5 * ln 2) * exp(- ((D-C/2) * ln 2 / (5 * delta))))"
       apply (intro mono_intros) using \<open>delta > 0\<close> \<open>lambda > 0\<close> \<open>a < b\<close> k' N by auto
     also have "... = (2 * exp(15/2/5 * ln 2)) * lambda * (b-a) * exp(-(D-C/2) * ln 2 / (5 * delta))"
       using \<open>delta > 0\<close> by (auto simp add: algebra_simps divide_simps)
     finally show ?thesis
       unfolding \<open>exp(15/2/5 * ln 2) = 2 * exp(1/2 * ln (2::real))\<close> by auto
   qed
 qed
 
 text \<open>We deduce from the previous result that a projection on a quasiconvex set is also
 exponentially contracting. To do this, one uses the contraction of a projection on a geodesic, and
 one adds up the additional errors due to the quasi-convexity. In particular, the projections on the
 original quasiconvex set or the geodesic do not have to coincide, but they are within distance at
 most $C + 8 \delta$.\<close>
 
 lemma (in Gromov_hyperbolic_space_geodesic) quasiconvex_projection_exp_contracting:
   assumes "quasiconvex K G"
           "\<And>x y. x \<in> {a..b} \<Longrightarrow> y \<in> {a..b} \<Longrightarrow> dist (f x) (f y) \<le> lambda * dist x y + C"
           "a \<le> b"
           "pa \<in> proj_set (f a) G"
           "pb \<in> proj_set (f b) G"
           "\<And>t. t \<in> {a..b} \<Longrightarrow> infdist (f t) G \<ge> D"
           "D \<ge> 15/2 * delta + K + C/2"
           "delta > deltaG(TYPE('a))"
           "C \<ge> 0"
           "lambda \<ge> 0"
   shows "dist pa pb \<le> 2 * K + 8 * delta + max (5 * deltaG(TYPE('a))) ((4 * exp(1/2 * ln 2)) * lambda * (b-a) * exp(-(D - K - C/2) * ln 2 / (5 * delta)))"
 proof -
   obtain H where H: "geodesic_segment_between H pa pb" "\<And>q. q \<in> H \<Longrightarrow> infdist q G \<le> K"
     using quasiconvexD[OF assms(1) proj_setD(1)[OF \<open>pa \<in> proj_set (f a) G\<close>] proj_setD(1)[OF \<open>pb \<in> proj_set (f b) G\<close>]] by auto
   obtain qa where qa: "qa \<in> proj_set (f a) H"
     using proj_set_nonempty_of_proper[of H "f a"] geodesic_segment_topology[OF geodesic_segmentI[OF H(1)]] by auto
   obtain qb where qb: "qb \<in> proj_set (f b) H"
     using proj_set_nonempty_of_proper[of H "f b"] geodesic_segment_topology[OF geodesic_segmentI[OF H(1)]] by auto
 
   have I: "infdist (f t) H \<ge> D - K" if "t \<in> {a..b}" for t
   proof -
     have *: "D - K \<le> dist (f t) h" if "h \<in> H" for h
     proof -
       have "D - K - dist (f t) h \<le> e" if "e > 0" for e
       proof -
         have *: "infdist h G < K + e" using H(2)[OF \<open>h \<in> H\<close>] \<open>e > 0\<close> by auto
         obtain g where g: "g \<in> G" "dist h g < K + e"
           using infdist_almost_attained[OF *] proj_setD(1)[OF \<open>pa \<in> proj_set (f a) G\<close>] by auto
         have "D \<le> dist (f t) g"
           using \<open>\<And>t. t \<in> {a..b} \<Longrightarrow> infdist (f t) G \<ge> D\<close>[OF \<open>t \<in> {a..b}\<close>] infdist_le[OF \<open>g \<in> G\<close>, of "f t"] by auto
         also have "... \<le> dist (f t) h + dist h g"
           by (intro mono_intros)
         also have "... \<le> dist (f t) h + K + e"
           using g(2) by auto
         finally show ?thesis by auto
       qed
       then have *: "D - K - dist (f t) h \<le> 0"
         using dense_ge by blast
       then show ?thesis by simp
     qed
     have "D - K \<le> Inf (dist (f t) ` H)"
       apply (rule cInf_greatest) using * H(1) by auto
     then show "D - K \<le> infdist (f t) H"
       apply (subst infdist_notempty) using H(1) by auto
   qed
   have Q: "dist qa qb \<le> max (5 * deltaG(TYPE('a))) ((4 * exp(1/2 * ln 2)) * lambda * (b-a) * exp(-((D - K)-C/2 ) * ln 2 / (5 * delta)))"
     apply (rule geodesic_projection_exp_contracting[OF geodesic_segmentI[OF \<open>geodesic_segment_between H pa pb\<close>] assms(2) assms(3)])
     using qa qb I assms by auto
 
   have A: "dist pa qa \<le> 4 * delta + K"
   proof -
     have "dist (f a) pa - dist (f a) qa - K \<le> e" if "e > 0" for e::real
     proof -
       have *: "infdist qa G < K + e" using H(2)[OF proj_setD(1)[OF qa]] \<open>e > 0\<close> by auto
       obtain g where g: "g \<in> G" "dist qa g < K + e"
         using infdist_almost_attained[OF *] proj_setD(1)[OF \<open>pa \<in> proj_set (f a) G\<close>] by auto
       have "dist (f a) pa \<le> dist (f a) g"
         unfolding proj_setD(2)[OF \<open>pa \<in> proj_set (f a) G\<close>] using infdist_le[OF \<open>g \<in> G\<close>, of "f a"] by simp
       also have "... \<le> dist (f a) qa + dist qa g"
         by (intro mono_intros)
       also have "... \<le> dist (f a) qa + K + e"
         using g(2) by auto
       finally show ?thesis by simp
     qed
     then have I: "dist (f a) pa - dist (f a) qa - K \<le> 0"
       using dense_ge by blast
     have "dist (f a) qa + dist qa pa \<le> dist (f a) pa + 4 * deltaG(TYPE('a))"
       apply (rule dist_along_geodesic[OF geodesic_segmentI[OF H(1)]]) using qa H(1) by auto
     also have "... \<le> dist (f a) qa + K + 4 * delta"
       using I assms by auto
     finally show ?thesis
       by (simp add: metric_space_class.dist_commute)
   qed
   have B: "dist qb pb \<le> 4 * delta + K"
   proof -
     have "dist (f b) pb - dist (f b) qb - K \<le> e" if "e > 0" for e::real
     proof -
       have *: "infdist qb G < K + e" using H(2)[OF proj_setD(1)[OF qb]] \<open>e > 0\<close> by auto
       obtain g where g: "g \<in> G" "dist qb g < K + e"
         using infdist_almost_attained[OF *] proj_setD(1)[OF \<open>pa \<in> proj_set (f a) G\<close>] by auto
       have "dist (f b) pb \<le> dist (f b) g"
         unfolding proj_setD(2)[OF \<open>pb \<in> proj_set (f b) G\<close>] using infdist_le[OF \<open>g \<in> G\<close>, of "f b"] by simp
       also have "... \<le> dist (f b) qb + dist qb g"
         by (intro mono_intros)
       also have "... \<le> dist (f b) qb + K + e"
         using g(2) by auto
       finally show ?thesis by simp
     qed
     then have I: "dist (f b) pb - dist (f b) qb - K \<le> 0"
       using dense_ge by blast
     have "dist (f b) qb + dist qb pb \<le> dist (f b) pb + 4 * deltaG(TYPE('a))"
       apply (rule dist_along_geodesic[OF geodesic_segmentI[OF H(1)]]) using qb H(1) by auto
     also have "... \<le> dist (f b) qb + K + 4 * delta"
       using I assms by auto
     finally show ?thesis
       by simp
   qed
   have "dist pa pb \<le> dist pa qa + dist qa qb + dist qb pb"
     by (intro mono_intros)
   then show ?thesis
     using Q A B by auto
 qed
 
 text \<open>The next statement is the main step in the proof of the Morse-Gromov theorem given by Shchur
 in~\cite{shchur}, asserting that a quasi-geodesic and a geodesic with the same endpoints are close.
 We show that a point on the quasi-geodesic is close to the geodesic -- the other inequality will
 follow easily later on. We also assume that the quasi-geodesic is parameterized by a Lipschitz map
 -- the general case will follow as any quasi-geodesic can be approximated by a Lipschitz map with
 good controls.
 
 Here is a sketch of the proof. Fix two large constants $L \leq D$ (that we will choose carefully
 to optimize the values of the constants at the end of the proof). Consider a quasi-geodesic $f$
 between two points $f(u^-)$ and $f(u^+)$, and a geodesic segment $G$ between the same points.
 Fix $f(z)$. We want to find a bound on $d(f(z), G)$.
 1 - If this distance is smaller than $L$, we are done (and the bound is $L$).
 2 - Assume it is larger.
 Let $\pi_z$ be a projection of $f(z)$ on $G$ (at distance $d(f(z),G)$ of $f(z)$), and $H$ a geodesic
 between $z$ and $\pi_z$. The idea will be to project the image of $f$ on $H$, and record how much
 progress is made towards $f(z)$. In this proof, we will construct several points before and after
 $z$. When necessary, we put an exponent $-$ on the points before $z$, and $+$ on the points after
 $z$. To ease the reading, the points are ordered following the alphabetical order, i.e., $u^- \leq v
 \leq w \leq x \leq y^- \leq z$.
 
 One can find two points $f(y^-)$ and $f(y^+)$ on the left and the right of $f(z)$ that project
 on $H$ roughly at distance $L$ of $\pi_z$ (up to some $O(\delta)$ -- recall that the closest point
 projection is not uniquely defined, and not continuous, so we make some choice here).
 Let $d^-$ be the minimal distance of $f([u^-, y^-])$ to $H$, and let $d^+$ be the minimal distance
 of $f([y^+, u^+)]$ to $H$.
 
 2.1 If the two distances $d^-$ and $d^+$ are less than $D$, then the distance between two points
 realizing the minimum (say $f(c^-)$ and $f(c^+)$) is at most $2D+L$, hence $c^+ - c^-$ is controlled
 (by $\lambda \cdot (2D+L) + C$) thanks to the quasi-isometry property. Therefore, $f(z)$ is not far
 away from $f(c^-)$ and $f(c^+)$ (again by the quasi-isometry property). Since the distance from
 these points to $\pi_z$ is controlled (by $D+L$), we get a good control on $d(f(z),\pi_z)$, as
 desired.
 
 2.2 The interesting case is when $d^-$ and $d^+$ are both $ > D$. Assume also for instance $d^- \geq
 d^+$, as the other case is analogous. We will construct two points $f(v)$ and $f(x)$ with $u^- \leq
 v \leq x \leq y^-$ with the following property:
 \begin{equation}
 \label{eq:xvK}
   K_1 e^{K_2 d(f(v), H)} \leq x-v,
 \end{equation}
 where $K_1$ and $K_2$ are some explicit constants (depending on $\lambda$, $\delta$, $L$ and $D$).
 Let us show how this will conclude the proof. The distance from $f(v)$ to $f(c^+)$ is at most
 $d(f(v),H) + L + d^+ \leq 3 d(f(v), H)$. Therefore, $c^+ - v$ is also controlled by $K' d(f(v), H)$
 by the quasi-isometry property. This gives
 \begin{align*}
   K &\leq K (x - v) e^{-K (c^+ - v)} \leq (e^{K (x-v)} - 1) \cdot e^{-K(c^+ - v)}
     \\& = e^{-K (c^+ - x)} - e^{-K (c^+ - v)}
     \leq e^{-K(c^+ - x)} - e^{-K (u^+ - u^-)}.
 \end{align*}
 This shows that, when one goes from the original quasi-geodesic $f([u^-, u^+])$ to the restricted
 quasi-geodesic $f([x, c^+])$, the quantity $e^{-K \cdot}$ decreases by a fixed amount. In particular,
 this process can only happen a uniformly bounded number of times, say $n$.
 
 Let $G'$ be a geodesic between $f(x)$ and $f(c^+)$. One checks geometrically that $d(f(z), G) \leq
 d(f(z), G') + (L + O(\delta))$, as both projections of $f(x)$ and $f(c^+)$ on $H$ are within
 distance $L$ of $\pi_z$. Iterating the process $n$ times, one gets finally $d(f(z), G) \leq O(1) + n
 (L + O(\delta))$. This is the desired bound for $d(f(z), G)$.
 
 To complete the proof, it remains to construct the points $f(v)$ and $f(x)$ satisfying~\eqref{eq:xvK}.
 This will be done through an inductive process.
 
 Assume first that there is a point $f(v)$ whose projection on $H$ is close to the projection of
 $f(u^-)$, and with $d(f(v), H) \leq 2 d^-$. Then the projections of $f(v)$ and $f(y^-)$ are far away
 (at distance at least $L + O(\delta)$). Since the portion of $f$ between $v$ and $y^-$ is everywhere
 at distance at least $d^-$ of $H$, the projection on $H$ contracts by a factor $e^{-d^-}$. It
 follows that this portion of $f$ has length at least $e^{d^-} \cdot (L+O(\delta))$. Therefore, by
 the quasi-isometry property, one gets $x - v \geq K e^{d^-}$. On the other hand, $d(v, H)$ is
 bounded above by $2 d^-$ by assumption. This gives the desired inequality~\eqref{eq:xvK} with $x =
 y^-$.
 
 Otherwise, all points $f(v)$ whose projection on $H$ is close to the projection of $f(u^-)$ are such
 that $d(f(v), H) \geq 2 d^-$. Consider $f(w_1)$ a point whose projection on $H$ is at distance
 roughly $10 \delta$ of the projection of $f(u^-)$. Let $V_1$ be the set of points at distance at
 most $d^-$ of $H$, i.e., the $d_1$-neighborhood of $H$. Then the distance between the projections of
 $f(u^-)$ and $f(w_1)$ on $V_1$ is very large (are there is an additional big contraction to go from
 $V_1$ to $H$). And moreover all the intermediate points $f(v)$ are at distance at least $2 d^-$ of
 $H$, and therefore at distance at least $d^-$ of $H$. Then one can play the same game as in the
 first case, where $y^-$ replaced by $w_1$ and $H$ replaced by $V_1$. If there is a point $f(v)$
 whose projection on $V_1$ is close to the projection of $f(u^-)$, then the pair of points $v$ and $x
 = w_1$ works. Otherwise, one lifts everything to $V_2$, the neighborhood of size $2d^-$ of $V_1$,
 and one argues again in the same way.
 
 The induction goes on like this until one finds a suitable pair of points. The process has indeed to
 stop at one time, as it can only go on while $f(u^-)$ is outside of $V_k$, the $(2^k-1) d^-$
 neighborhood of $H$). This concludes the sketch of the proof, modulo the adjustment of constants.
 
 Comments on the formalization below:
 \begin{itemize}
 \item The proof is written as an induction on $u^+ - u^-$. This makes it possible to either prove
 the bound directly (in the cases 1 and 2.1 above), or to use the bound on $d(z, G')$ in case 2.2
 using the induction assumption, and conclude the proof. Of course, $u^+ - u^-$ is not integer-valued,
 but in the reduction to $G'$ it decays by a fixed amount, so one can easily write this down as
 a genuine induction.
 \item The main difficulty in the proof is to construct the pair $(v, x)$ in case 2.2. This is again
 written as an induction over $k$: either the required bound is true, or one can find a point $f(w)$
 whose projection on $V_k$ is far enough from the projection of $f(u^-)$. Then, either one can use
 this point to prove the bound, or one can construct a point with the same property with respect to
 $V_{k+1}$, concluding the induction.
 \item Instead of writing $u^-$ and $u^+$ (which are not good variable names in Isabelle), we write
 $um$ and $uM$. Similarly for other variables.
 \item The proof only works when $\delta > 0$ (as one needs to divide by $\delta$
 in the exponential gain). Hence, we formulate it for some $\delta$ which is
 strictly larger than the hyperbolicity constant. In a subsequent application of
 the lemma, we will deduce the same statement for the hyperbolicity constant
 by a limiting argument.
 \item To optimize the value of the constant in the end, there is an additional important trick with
 respect to the above sketch: in case 2.2, there is an exponential gain. One can spare a fraction
 $(1-\alpha)$ of this gain to improve the constants, and spend the remaining fraction $\alpha$ to
 make the argument work. This makes it possible to reduce the value of the constant roughly from
 $40000$ to $100$, so we do it in the proof below. The values of $L$, $D$ and $\alpha$ can be chosen
 freely, and have been chosen to get the best possible constant in the end.
 \item For another optimization, we do not induce in terms of the distance from $f(z)$ to the geodesic
 $G$, but rather in terms of the Gromov product $(f(u^-), f(u^+))_{f(z)}$ (which is the same up to
 $O(\delta)$. And we do not take for $H$ a geodesic from $f(z)$ to its projection on $G$, but rather
 a geodesic from $f(z)$ to the point $m$ on $[f(u^-), f(u^+)]$ opposite to $f(z)$ in the tripod, i.e.,
 at distance $(f(z), f(u^+))_{f(u^-)}$ of $f(u^-)$, and at distance $(f(z), f(u^-))_{f(u^+)}$ of
 $f(u^+)$. Let $\pi_z$ denote the point on $[f(z), m]$ at distance $(f(u^-), f(u^+)_{f(z)}$ of $f(z)$.
 (It is within distance $2 \delta$ of $m$).
 In both approaches, what we want to control by induction is the distance from $f(z)$ to $\pi_z$.
 However, in the first approach, the points $f(u^-)$ and $f(u^+)$ project on $H$ between $\pi_z$ and
 $f(z)$, and since the location of their projection is only controlled up to $4\delta$ one loses
 essentially a $4\delta$-length of $L$ for the forthcoming argument. In the second approach, the
 projections on $H$ are on the other side of $\pi_z$ compared to $f(z)$, so one does not lose
 anything, and in the end it gives genuinely better bounds (making it possible to gain roughly
 $10 \delta$ in the final estimate).
 \end{itemize}
 \<close>
 
 lemma (in Gromov_hyperbolic_space_geodesic) Morse_Gromov_theorem_aux1:
   fixes f::"real \<Rightarrow> 'a"
   assumes "continuous_on {a..b} f"
           "lambda C-quasi_isometry_on {a..b} f"
           "a \<le> b"
           "geodesic_segment_between G (f a) (f b)"
           "z \<in> {a..b}"
           "delta > deltaG(TYPE('a))"
   shows "infdist (f z) G \<le> lambda^2 * (11/2 * C + 91 * delta)"
 proof -
   have "C \<ge> 0" "lambda \<ge> 1" using quasi_isometry_onD assms by auto
   have "delta > 0" using assms delta_nonneg order_trans by linarith
 
   text \<open>We give their values to the parameters $L$, $D$ and $\alpha$ that we will use in the proof.
   We also define two constants $K$ and $K_{mult}$ that appear in the precise formulation of the
   bounds. Their values have no precise meaning, they are just the outcome of the computation\<close>
   define alpha::real where "alpha = 12/100"
   have alphaaux:"alpha > 0" "alpha \<le> 1" unfolding alpha_def by auto
   define L::real where "L = 18 * delta"
   define D::real where "D = 55 * delta"
   define K where "K = alpha * ln 2 / (5 * (4 + (L + 2 * delta)/D) * delta * lambda)"
   have "K > 0" "L > 0" "D > 0" unfolding K_def L_def D_def using \<open>delta > 0\<close> \<open>lambda \<ge> 1\<close> alpha_def by auto
   have Laux: "L \<ge> 18 * delta" "D \<ge> 50 * delta" "L \<le> D" "D \<le> 4 * L" unfolding L_def D_def using \<open>delta > 0\<close> by auto
   have Daux: "8 * delta \<le> (1 - alpha) * D" unfolding alpha_def D_def using \<open>delta > 0\<close> by auto
   define Kmult where "Kmult = ((L + 4 * delta)/(L - 13 * delta)) * ((4 * exp(1/2 * ln 2)) * lambda * exp (- (1 - alpha) * D * ln 2 / (5 * delta)) / K)"
   have "Kmult > 0" unfolding Kmult_def using Laux \<open>delta > 0\<close> \<open>K > 0\<close> \<open>lambda \<ge> 1\<close> by (auto simp add: divide_simps)
 
   text \<open>We prove that, for any pair of points to the left and to the right of $f(z)$, the distance
   from $f(z)$ to a geodesic between these points is controlled. We prove this by reducing to a
   closer pair of points, i.e., this is an inductive argument over real numbers. However, we
   formalize it as an artificial induction over natural numbers, as this is how induction works
   best, and since in our reduction step the new pair of points is always significantly closer
   than the initial one, at least by an amount $\delta/\lambda$.
 
   The main inductive bound that we will prove is the following. In this bound, the first term is
   what comes from the trivial cases 1 and 2.1 in the description of the proof before the statement
   of the theorem, while the most interesting term is the second term, corresponding to the induction
   per se.\<close>
   have Main: "\<And>um uM. um \<in> {a..z} \<Longrightarrow> uM \<in> {z..b}
           \<Longrightarrow> uM - um \<le> n * (1/4) * delta / lambda
           \<Longrightarrow> Gromov_product_at (f z) (f um) (f uM) \<le> lambda^2 * (D + (3/2) * L + delta + 11/2 * C) - 2 * delta + Kmult * (1 - exp(- K * (uM - um)))"
     for n::nat
   proof (induction n)
     text \<open>Trivial base case of the induction\<close>
     case 0
     then have *: "z = um" "z = uM" by auto
     then have "Gromov_product_at (f z) (f um) (f uM) = 0" by auto
     also have "... \<le> 1 * (D + (3/2) * L + delta + 11/2 * C) - 2 * delta + 0 * (1 - exp(- K * (uM - um)))"
       using Laux \<open>C \<ge> 0\<close> \<open>delta > 0\<close> by auto
     also have "... \<le> lambda^2 * (D + (3/2) * L + delta + 11/2 * C) - 2 * delta + Kmult * (1 - exp(- K * (uM - um)))"
       apply (intro mono_intros)
       using \<open>C \<ge> 0\<close> \<open>delta > 0\<close> Laux \<open>D > 0\<close> \<open>K > 0\<close> "0.prems" \<open>lambda \<ge> 1\<close> \<open>Kmult > 0\<close> by auto
     finally show ?case by auto
   next
     case (Suc n)
     show ?case
     proof (cases "Gromov_product_at (f z) (f um) (f uM) \<le> L")
       text \<open>If $f(z)$ is already close to the geodesic, there is nothing to do, and we do not need
       the induction assumption. This is case 1 in the description above.\<close>
       case True
       have "L \<le> 1 * (D + (3/2) * L + delta + 11/2 * C) - 2 * delta + 0 * (1 - exp(- K * (uM - um)))"
         using Laux \<open>C \<ge> 0\<close> \<open>delta > 0\<close> by auto
       also have "... \<le> lambda^2 * (D + (3/2) * L + delta + 11/2 * C) - 2 * delta + Kmult * (1 - exp(- K * (uM - um)))"
         apply (intro mono_intros)
         using \<open>C \<ge> 0\<close> \<open>delta > 0\<close> Laux \<open>D > 0\<close> "Suc.prems" \<open>K > 0\<close> \<open>lambda \<ge> 1\<close> \<open>Kmult > 0\<close> by auto
       finally show ?thesis using True by auto
     next
       text \<open>We come to the interesting case where $f(z)$ is far away from a geodesic between
       $f(um)$ and $f(uM)$. Let $m$ be close to a projection of $f(z)$ on such a geodesic (we use
       the opposite point of $f(z)$ on the corresponding tripod). On a geodesic between $f(z)$ and $m$,
       consider the point $pi_z$ at distance $(f(um), f(uM))_{f(z)}$ of $f(z)$. It is very close to
       $m$ (within distance $2 \delta$). We will push the points $f(um)$ and $f(uM)$
       towards $f(z)$ by considering points whose projection on a geodesic $H$ between $m$ and
       $z$ is roughly at distance $L$ of $pi_z$.\<close>
       case False
       define m where "m = geodesic_segment_param {f um--f uM} (f um) (Gromov_product_at (f um) (f z) (f uM))"
       have "dist (f z) m \<le> Gromov_product_at (f z) (f um) (f uM) + 2 * deltaG(TYPE('a))"
         unfolding m_def by (rule dist_triangle_side_middle, auto)
       then have *: "dist (f z) m \<le> Gromov_product_at (f z) (f um) (f uM) + 2 * delta"
         using \<open>deltaG(TYPE('a)) < delta\<close> by auto
       have "Gromov_product_at (f z) (f um) (f uM) \<le> infdist (f z) {f um--f uM}"
         by (intro mono_intros, auto)
       also have "... \<le> dist (f z) m"
         apply (rule infdist_le) unfolding m_def by auto
       finally have **: "Gromov_product_at (f z) (f um) (f uM) \<le> dist (f z) m"
         by auto
 
       define H where "H = {f z--m}"
       define pi_z where "pi_z = geodesic_segment_param H (f z) (Gromov_product_at (f z) (f um) (f uM))"
       have "pi_z \<in> H" "m \<in> H" "f z \<in> H"
         unfolding pi_z_def H_def by (auto simp add: geodesic_segment_param_in_segment)
       have H: "geodesic_segment_between H (f z) m"
         unfolding H_def by auto
       have Dpi_z: "dist (f z) pi_z = Gromov_product_at (f z) (f um) (f uM)"
         unfolding pi_z_def H_def by (rule geodesic_segment_param(6)[where ?y = m], auto simp add: **)
       moreover have "dist (f z) m = dist (f z) pi_z + dist pi_z m"
         apply (rule geodesic_segment_dist[of H, symmetric]) using \<open>pi_z \<in> H\<close> unfolding H_def by auto
       ultimately have "dist pi_z m \<le> 2 * delta"
         using * by auto
 
       text \<open>Introduce the notation $p$ for some projection on the geodesic $H$.\<close>
       define p where "p = (\<lambda>r. SOME x. x \<in> proj_set (f r) H)"
       have p: "p x \<in> proj_set (f x) H" for x
         unfolding p_def using proj_set_nonempty_of_proper[of H "f x"] geodesic_segment_topology[OF geodesic_segmentI[OF H]]
         by (simp add: some_in_eq)
       then have pH: "p x \<in> H" for x
         using proj_setD(1) by auto
       have pz: "p z = f z"
         using p[of z] H by auto
 
       text \<open>The projection of $f(um)$ on $H$ is close to $pi_z$ (but it does not have to be exactly
       $pi_z$). It is between $pi_z$ and $m$.\<close>
       have "dist (f um) (f z) \<le> dist (f um) (p um) + dist (p um) (f z)"
         by (intro mono_intros)
       also have "... \<le> dist (f um) m + dist (p um) (f z)"
         unfolding proj_setD(2)[OF p[of um]] H_def by (auto intro!: infdist_le)
       also have "... = Gromov_product_at (f um) (f z) (f uM) + dist (p um) (f z)"
         unfolding m_def by simp
       finally have A: "Gromov_product_at (f z) (f um) (f uM) \<le> dist (p um) (f z)"
         unfolding Gromov_product_at_def by (simp add: metric_space_class.dist_commute divide_simps)
       have "dist (p um) pi_z = abs(dist (p um) (f z) - dist pi_z (f z))"
         apply (rule dist_along_geodesic_wrt_endpoint[of H _ m]) using pH \<open>pi_z \<in> H\<close> H_def by auto
       also have "... = dist (p um) (f z) - dist pi_z (f z)"
         using A Dpi_z by (simp add: metric_space_class.dist_commute)
       finally have Dum: "dist (p um) (f z) = dist (p um) pi_z + dist pi_z (f z)" by auto
 
       text \<open>Choose a point $f(ym)$ whose projection on $H$ is roughly at distance $L$ of $pi_z$.\<close>
       have "\<exists>ym \<in> {um..z}. (dist (p um) (p ym) \<in> {(L + dist pi_z (p um)) - 4 * delta - 2 * 0 .. L + dist pi_z (p um)})
                     \<and> (\<forall>r \<in> {um..ym}. dist (p um) (p r) \<le> L + dist pi_z (p um))"
       proof (rule quasi_convex_projection_small_gaps[where ?f = f and ?G = H])
         show "continuous_on {um..z} f"
           apply (rule continuous_on_subset[OF \<open>continuous_on {a..b} f\<close>])
           using \<open>um \<in> {a..z}\<close> \<open>z \<in> {a..b}\<close> by auto
         show "um \<le> z" using \<open>um \<in> {a..z}\<close> by auto
         show "quasiconvex 0 H" using quasiconvex_of_geodesic geodesic_segmentI H by auto
         show "deltaG TYPE('a) < delta" by fact
         have "L + dist pi_z (p um) \<le> dist (f z) pi_z + dist pi_z (p um)"
           using False Dpi_z by (simp add: metric_space_class.dist_commute)
         then have "L + dist pi_z (p um) \<le> dist (p um) (f z)"
           using Dum by (simp add: metric_space_class.dist_commute)
         then show "L + dist pi_z (p um) \<in> {4 * delta + 2 * 0..dist (p um) (p z)}"
           using \<open>delta > 0\<close> False L_def pz by auto
         show "p ym \<in> proj_set (f ym) H" for ym using p by simp
       qed
       then obtain ym where ym : "ym \<in> {um..z}"
                                 "dist (p um) (p ym) \<in> {(L + dist pi_z (p um)) - 4 * delta - 2 * 0 .. L + dist pi_z (p um)}"
                                 "\<And>r. r \<in> {um..ym} \<Longrightarrow> dist (p um) (p r) \<le> L + dist pi_z (p um)"
         by blast
       have *: "continuous_on {um..ym} (\<lambda>r. infdist (f r) H)"
         using continuous_on_infdist[OF continuous_on_subset[OF \<open>continuous_on {a..b} f\<close>, of "{um..ym}"], of H]
         \<open>ym \<in> {um..z}\<close> \<open>um \<in> {a..z}\<close> \<open>z \<in> {a..b}\<close> by auto
       text \<open>Choose a point $cm$ between $f(um)$ and $f(ym)$ realizing the minimal distance to $H$.
       Call this distance $dm$.\<close>
       have "\<exists>closestm \<in> {um..ym}. \<forall>v \<in> {um..ym}. infdist (f closestm) H \<le> infdist (f v) H"
         apply (rule continuous_attains_inf) using ym(1) * by auto
       then obtain closestm where closestm: "closestm \<in> {um..ym}" "\<And>v. v \<in> {um..ym} \<Longrightarrow> infdist (f closestm) H \<le> infdist (f v) H"
         by auto
       define dm where "dm = infdist (f closestm) H"
       have [simp]: "dm \<ge> 0" unfolding dm_def using infdist_nonneg by auto
 
       text \<open>Same things but in the interval $[z, uM]$.\<close>
       have I: "dist m (f uM) = dist (f um) (f uM) - dist (f um) m"
               "dist (f um) m = Gromov_product_at (f um) (f z) (f uM)"
         using geodesic_segment_dist[of "{f um--f uM}" "f um" "f uM" m] m_def by auto
       have "dist (f uM) (f z) \<le> dist (f uM) (p uM) + dist (p uM) (f z)"
         by (intro mono_intros)
       also have "... \<le> dist (f uM) m + dist (p uM) (f z)"
         unfolding proj_setD(2)[OF p[of uM]] H_def by (auto intro!: infdist_le)
       also have "... = Gromov_product_at (f uM) (f z) (f um) + dist (p uM) (f z)"
         using I unfolding Gromov_product_at_def by (simp add: divide_simps algebra_simps metric_space_class.dist_commute)
       finally have A: "Gromov_product_at (f z) (f um) (f uM) \<le> dist (p uM) (f z)"
         unfolding Gromov_product_at_def by (simp add: metric_space_class.dist_commute divide_simps)
       have "dist (p uM) pi_z = abs(dist (p uM) (f z) - dist pi_z (f z))"
         apply (rule dist_along_geodesic_wrt_endpoint[of H _ m]) using pH \<open>pi_z \<in> H\<close> H_def by auto
       also have "... = dist (p uM) (f z) - dist pi_z (f z)"
         using A Dpi_z by (simp add: metric_space_class.dist_commute)
       finally have DuM: "dist (p uM) (f z) = dist (p uM) pi_z + dist pi_z (f z)" by auto
 
       text \<open>Choose a point $f(yM)$ whose projection on $H$ is roughly at distance $L$ of $pi_z$.\<close>
       have "\<exists>yM \<in> {z..uM}. dist (p uM) (p yM) \<in> {(L + dist pi_z (p uM)) - 4* delta - 2 * 0 .. L + dist pi_z (p uM)}
                     \<and> (\<forall>r \<in> {yM..uM}. dist (p uM) (p r) \<le> L + dist pi_z (p uM))"
       proof (rule quasi_convex_projection_small_gaps'[where ?f = f and ?G = H])
         show "continuous_on {z..uM} f"
           apply (rule continuous_on_subset[OF \<open>continuous_on {a..b} f\<close>])
           using \<open>uM \<in> {z..b}\<close> \<open>z \<in> {a..b}\<close> by auto
         show "z \<le> uM" using \<open>uM \<in> {z..b}\<close> by auto
         show "quasiconvex 0 H" using quasiconvex_of_geodesic geodesic_segmentI H by auto
         show "deltaG TYPE('a) < delta" by fact
         have "L + dist pi_z (p uM) \<le> dist (f z) pi_z + dist pi_z (p uM)"
           using False Dpi_z by (simp add: metric_space_class.dist_commute)
         then have "L + dist pi_z (p uM) \<le> dist (p uM) (f z)"
           using DuM by (simp add: metric_space_class.dist_commute)
         then show "L + dist pi_z (p uM) \<in> {4 * delta + 2 * 0..dist (p z) (p uM)}"
           using \<open>delta > 0\<close> False L_def pz by (auto simp add: metric_space_class.dist_commute)
         show "p yM \<in> proj_set (f yM) H" for yM using p by simp
       qed
       then obtain yM where yM: "yM \<in> {z..uM}"
                               "dist (p uM) (p yM) \<in> {(L + dist pi_z (p uM)) - 4* delta - 2 * 0 .. L + dist pi_z (p uM)}"
                               "\<And>r. r \<in> {yM..uM} \<Longrightarrow> dist (p uM) (p r) \<le> L + dist pi_z (p uM)"
         by blast
       have *: "continuous_on {yM..uM} (\<lambda>r. infdist (f r) H)"
         using continuous_on_infdist[OF continuous_on_subset[OF \<open>continuous_on {a..b} f\<close>, of "{yM..uM}"], of H]
         \<open>yM \<in> {z..uM}\<close> \<open>uM \<in> {z..b}\<close> \<open>z \<in> {a..b}\<close> by auto
       have "\<exists>closestM \<in> {yM..uM}. \<forall>v \<in> {yM..uM}. infdist (f closestM) H \<le> infdist (f v) H"
         apply (rule continuous_attains_inf) using yM(1) * by auto
       then obtain closestM where closestM: "closestM \<in> {yM..uM}" "\<And>v. v \<in> {yM..uM} \<Longrightarrow> infdist (f closestM) H \<le> infdist (f v) H"
         by auto
       define dM where "dM = infdist (f closestM) H"
       have [simp]: "dM \<ge> 0" unfolding dM_def using infdist_nonneg by auto
 
       text \<open>Points between $f(um)$ and $f(ym)$, or between $f(yM)$ and $f(uM)$, project within
       distance at most $L$ of $pi_z$ by construction.\<close>
       have P0: "dist m (p x) \<le> dist m pi_z + L" if "x \<in> {um..ym} \<union> {yM..uM}" for x
       proof (cases "x \<in> {um..ym}")
         case True
         have "dist m (f z) = dist m (p um) + dist (p um) pi_z + dist pi_z (f z)"
           using geodesic_segment_dist[OF H pH[of um]] Dum by (simp add: metric_space_class.dist_commute)
         moreover have "dist m (f z) = dist m pi_z + dist pi_z (f z)"
           using geodesic_segment_dist[OF H \<open>pi_z \<in> H\<close>] by (simp add: metric_space_class.dist_commute)
         ultimately have *: "dist m pi_z = dist m (p um) + dist (p um) pi_z" by auto
         have "dist (p um) (p x) \<le> L + dist pi_z (p um)"
           using ym(3)[OF \<open>x \<in> {um..ym}\<close>] by blast
         then show ?thesis
           using metric_space_class.dist_triangle[of m "p x" "p um"] * by (auto simp add: metric_space_class.dist_commute)
       next
         case False
         then have "x \<in> {yM..uM}" using that by auto
         have "dist m (f z) = dist m (p uM) + dist (p uM) pi_z + dist pi_z (f z)"
           using geodesic_segment_dist[OF H pH[of uM]] DuM by (simp add: metric_space_class.dist_commute)
         moreover have "dist m (f z) = dist m pi_z + dist pi_z (f z)"
           using geodesic_segment_dist[OF H \<open>pi_z \<in> H\<close>] by (simp add: metric_space_class.dist_commute)
         ultimately have *: "dist m pi_z = dist m (p uM) + dist (p uM) pi_z" by auto
         have "dist (p uM) (p x) \<le> L + dist pi_z (p uM)"
           using yM(3)[OF \<open>x \<in> {yM..uM}\<close>] by blast
         then show ?thesis
           using metric_space_class.dist_triangle[of m "p x" "p uM"] * by (auto simp add: metric_space_class.dist_commute)
       qed
       have P: "dist pi_z (p x) \<le> L" if "x \<in> {um..ym} \<union> {yM..uM}" for x
       proof (cases "dist m (p x) \<le> dist pi_z m")
         case True
         have "dist pi_z (p x) \<le> dist pi_z m + dist m (p x)"
           by (intro mono_intros)
         also have "... \<le> 2 * delta + 2 * delta"
           using \<open>dist pi_z m \<le> 2 * delta\<close> True by auto
         finally show ?thesis
           using Laux \<open>delta > 0\<close> by auto
       next
         case False
         have "dist pi_z (p x) = abs(dist pi_z m - dist (p x) m)"
           apply (rule dist_along_geodesic_wrt_endpoint[OF geodesic_segment_commute[OF H]])
           using pH \<open>pi_z \<in> H\<close> by auto
         also have "... = dist (p x) m - dist pi_z m"
           using False by (simp add: metric_space_class.dist_commute)
         finally show ?thesis
           using P0[OF that] by (simp add: metric_space_class.dist_commute)
       qed
       text \<open>Auxiliary fact for later use:
       The distance between two points in $[um, ym]$ and $[yM, uM]$ can be controlled using
       the distances of their images under $f$ to $H$, thanks to the quasi-isometry property.\<close>
       have D: "dist rm rM \<le> lambda * (infdist (f rm) H + (L + C + 2 * delta) + infdist (f rM) H)"
         if "rm \<in> {um..ym}" "rM \<in> {yM..uM}" for rm rM
       proof -
         have *: "dist m (p rm) \<le> L + dist m pi_z" "dist m (p rM) \<le> L + dist m pi_z"
           using P0 that by force+
         have "dist (p rm) (p rM) = abs(dist (p rm) m - dist (p rM) m)"
           apply (rule dist_along_geodesic_wrt_endpoint[OF geodesic_segment_commute[OF H]])
           using pH by auto
         also have "... \<le> L + dist m pi_z"
           unfolding abs_le_iff using * apply (auto simp add: metric_space_class.dist_commute)
           by (metis diff_add_cancel le_add_same_cancel1 metric_space_class.zero_le_dist order_trans)+
         finally have *: "dist (p rm) (p rM) \<le> L + 2 * delta"
           using \<open>dist pi_z m \<le> 2 * delta\<close> by (simp add: metric_space_class.dist_commute)
 
         have "(1/lambda) * dist rm rM - C \<le> dist (f rm) (f rM)"
           apply (rule quasi_isometry_onD(2)[OF \<open>lambda C-quasi_isometry_on {a..b} f\<close>])
           using \<open>rm \<in> {um..ym}\<close> \<open>ym \<in> {um..z}\<close> \<open>um \<in> {a..z}\<close> \<open>z \<in> {a..b}\<close> \<open>rM \<in> {yM..uM}\<close> \<open>yM \<in> {z..uM}\<close> \<open>uM \<in> {z..b}\<close> by auto
         also have "... \<le> dist (f rm) (p rm) + dist (p rm) (p rM) + dist (p rM) (f rM)"
           by (intro mono_intros)
         also have "... \<le> infdist (f rm) H + L + 2 * delta + infdist (f rM) H"
           using * proj_setD(2)[OF p] by (simp add: metric_space_class.dist_commute)
         finally show ?thesis
           using \<open>lambda \<ge> 1\<close> by (simp add: algebra_simps divide_simps)
       qed
       text \<open>Auxiliary fact for later use in the inductive argument:
       the distance from $f(z)$ to $pi_z$ is controlled by the distance from $f(z)$ to any
       intermediate geodesic between points in $f[um, ym]$ and $f[yM, uM]$, up to a constant
       essentially given by $L$. This is a variation around Lemma 5 in~\cite{shchur}.\<close>
       have Rec: "Gromov_product_at (f z) (f um) (f uM) \<le> Gromov_product_at (f z) (f rm) (f rM) + (L + 4 * delta)" if "rm \<in> {um..ym}" "rM \<in> {yM..uM}" for rm rM
       proof -
         have *: "dist (f rm) (p rm) + dist (p rm) (f z) \<le> dist (f rm) (f z) + 4 * deltaG(TYPE('a))"
           apply (rule dist_along_geodesic[of H]) using p H_def by auto
         have "dist (f z) pi_z \<le> dist (f z) (p rm) + dist (p rm) pi_z"
           by (intro mono_intros)
         also have "... \<le> (Gromov_product_at (f z) (f rm) (p rm) + 2 * deltaG(TYPE('a))) + L"
           apply (intro mono_intros) using * P \<open>rm \<in> {um..ym}\<close> unfolding Gromov_product_at_def
           by (auto simp add: metric_space_class.dist_commute algebra_simps divide_simps)
         finally have A: "dist (f z) pi_z - L - 2 * deltaG(TYPE('a)) \<le> Gromov_product_at (f z) (f rm) (p rm)"
           by simp
         have *: "dist (f rM) (p rM) + dist (p rM) (f z) \<le> dist (f rM) (f z) + 4 * deltaG(TYPE('a))"
           apply (rule dist_along_geodesic[of H]) using p H_def by auto
         have "dist (f z) pi_z \<le> dist (f z) (p rM) + dist (p rM) pi_z"
           by (intro mono_intros)
         also have "... \<le> (Gromov_product_at (f z) (p rM) (f rM) + 2 * deltaG(TYPE('a))) + L"
           apply (intro mono_intros) using * P \<open>rM \<in> {yM..uM}\<close> unfolding Gromov_product_at_def
           by (auto simp add: metric_space_class.dist_commute algebra_simps divide_simps)
         finally have B: "dist (f z) pi_z - L - 2 * deltaG(TYPE('a)) \<le> Gromov_product_at (f z) (p rM) (f rM)"
           by simp
         have C: "dist (f z) pi_z - L - 2 * deltaG(TYPE('a)) \<le> Gromov_product_at (f z) (p rm) (p rM)"
         proof (cases "dist (f z) (p rm) \<le> dist (f z) (p rM)")
           case True
           have "dist (p rm) (p rM) = abs(dist (f z) (p rm) - dist (f z) (p rM))"
             using proj_setD(1)[OF p] dist_along_geodesic_wrt_endpoint[OF H, of "p rm" "p rM"]
             by (simp add: metric_space_class.dist_commute)
           also have "... = dist (f z) (p rM) - dist (f z) (p rm)"
             using True by auto
           finally have *: "dist (f z) (p rm) = Gromov_product_at (f z) (p rm) (p rM)"
             unfolding Gromov_product_at_def by auto
           have "dist (f z) pi_z \<le> dist (f z) (p rm) + dist (p rm) pi_z"
             by (intro mono_intros)
           also have "... \<le> Gromov_product_at (f z) (p rm) (p rM) + L + 2 * deltaG(TYPE('a))"
             using * P[of rm] \<open>rm \<in> {um..ym}\<close> apply (simp add: metric_space_class.dist_commute)
             using local.delta_nonneg by linarith
           finally show ?thesis by simp
         next
           case False
           have "dist (p rm) (p rM) = abs(dist (f z) (p rm) - dist (f z) (p rM))"
             using proj_setD(1)[OF p] dist_along_geodesic_wrt_endpoint[OF H, of "p rm" "p rM"]
             by (simp add: metric_space_class.dist_commute)
           also have "... = dist (f z) (p rm) - dist (f z) (p rM)"
             using False by auto
           finally have *: "dist (f z) (p rM) = Gromov_product_at (f z) (p rm) (p rM)"
             unfolding Gromov_product_at_def by auto
           have "dist (f z) pi_z \<le> dist (f z) (p rM) + dist (p rM) pi_z"
             by (intro mono_intros)
           also have "... \<le> Gromov_product_at (f z) (p rm) (p rM) + L + 2 * deltaG(TYPE('a))"
             using * P[of rM] \<open>rM \<in> {yM..uM}\<close> apply (simp add: metric_space_class.dist_commute)
             using local.delta_nonneg by linarith
           finally show ?thesis by simp
         qed
 
         have "Gromov_product_at (f z) (f um) (f uM) - L - 2 * deltaG(TYPE('a)) \<le> Min {Gromov_product_at (f z) (f rm) (p rm), Gromov_product_at (f z) (p rm) (p rM), Gromov_product_at (f z) (p rM) (f rM)}"
           using A B C unfolding Dpi_z by auto
         also have "... \<le> Gromov_product_at (f z) (f rm) (f rM) + 2 * deltaG(TYPE('a))"
           by (intro mono_intros)
         finally show ?thesis
           using \<open>deltaG(TYPE('a)) < delta\<close> by auto
       qed
 
       text \<open>We have proved the basic facts we will need in the main argument. This argument starts
       here. It is divided in several cases.\<close>
       consider "dm \<le> D + 4 * C \<and> dM \<le> D + 4 * C" | "dm \<ge> D + 4 * C \<and> dM \<le> dm" | "dM \<ge> D + 4 * C \<and> dm \<le> dM"
         by linarith
       then show ?thesis
       proof (cases)
         text \<open>Case 2.1 of the description before the statement: there are points in $f[um, ym]$ and
         in $f[yM, uM]$ which are close to $H$. Then one can conclude directly, without relying
         on the inductive argument, thanks to the quasi-isometry property.\<close>
         case 1
         have I: "Gromov_product_at (f z) (f closestm) (f closestM) \<le> lambda^2 * (D + L / 2 + delta + 11/2 * C) - 6 * delta"
         proof (cases "dist (f closestm) (f closestM) \<le> 12 * delta")
           case True
           have "1/lambda * dist closestm closestM - C \<le> dist (f closestm) (f closestM)"
             using quasi_isometry_onD(2)[OF assms(2)] \<open>closestm \<in> {um..ym}\<close> \<open>um \<in> {a..z}\<close> \<open>z \<in> {a..b}\<close> \<open>ym \<in> {um..z}\<close>
             \<open>closestM \<in> {yM..uM}\<close> \<open>uM \<in> {z..b}\<close> \<open>z \<in> {a..b}\<close> \<open>yM \<in> {z..uM}\<close> by auto
           then have "dist closestm closestM \<le> lambda * dist (f closestm) (f closestM) + lambda * C"
             using \<open>lambda \<ge> 1\<close> by (auto simp add: divide_simps algebra_simps)
           also have "... \<le> lambda * (12 * delta) + lambda * C"
             apply (intro mono_intros True) using \<open>lambda \<ge> 1\<close> by auto
           finally have M: "dist closestm closestM \<le> lambda * (12 * delta + C)"
             by (auto simp add: algebra_simps)
 
           have "2 * Gromov_product_at (f z) (f closestm) (f closestM) \<le> dist (f closestm) (f z) + dist (f z) (f (closestM))"
             unfolding Gromov_product_at_def by (auto simp add: metric_space_class.dist_commute)
           also have "... \<le> (lambda * dist closestm z + C) + (lambda * dist z closestM + C)"
             apply (intro mono_intros quasi_isometry_onD(1)[OF assms(2)])
             using \<open>closestm \<in> {um..ym}\<close> \<open>um \<in> {a..z}\<close> \<open>z \<in> {a..b}\<close> \<open>ym \<in> {um..z}\<close>
             \<open>closestM \<in> {yM..uM}\<close> \<open>uM \<in> {z..b}\<close> \<open>z \<in> {a..b}\<close> \<open>yM \<in> {z..uM}\<close> by auto
           also have "... = lambda * dist closestm closestM + 1 * 2 * C"
             unfolding dist_real_def using \<open>closestm \<in> {um..ym}\<close> \<open>um \<in> {a..z}\<close> \<open>z \<in> {a..b}\<close> \<open>ym \<in> {um..z}\<close>
             \<open>closestM \<in> {yM..uM}\<close> \<open>uM \<in> {z..b}\<close> \<open>z \<in> {a..b}\<close> \<open>yM \<in> {z..uM}\<close> by (auto simp add: algebra_simps)
           also have "... \<le> lambda * (lambda * (12 * delta + C)) + lambda^2 * 2 * C"
             apply (intro mono_intros M) using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> by auto
           also have "... = lambda^2 * (24 * delta + 3 * C) - lambda^2 * 12 * delta"
             by (simp add: algebra_simps power2_eq_square)
           also have "... \<le> lambda^2 * ((2 * D + L + 2 * delta) + 11 * C) - 1 * 12 * delta"
             apply (intro mono_intros) using Laux \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> \<open>delta > 0\<close> by auto
           finally show ?thesis
             by (auto simp add: divide_simps algebra_simps)
         next
           case False
           have "dist closestm closestM \<le> lambda * (dm + dM + L + 2 * delta + C)"
             using D[OF \<open>closestm \<in> {um..ym}\<close> \<open>closestM \<in> {yM..uM}\<close>] dm_def dM_def by (auto simp add: algebra_simps)
           also have "... \<le> lambda * ((D + 4 * C) + (D + 4 * C) + L + 2 * delta + C)"
             apply (intro mono_intros) using 1 \<open>lambda \<ge> 1\<close> by auto
           also have "... \<le> lambda * (2 * D + L + 2 * delta + 9 * C)"
             using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> by auto
           finally have M: "dist closestm closestM \<le> lambda * (2 * D + L + 2 * delta + 9 * C)"
             by (auto simp add: algebra_simps divide_simps metric_space_class.dist_commute)
 
           have "dist (f closestm) (f z) + dist (f z) (f (closestM)) \<le> (lambda * dist closestm z + C) + (lambda * dist z closestM + C)"
             apply (intro mono_intros quasi_isometry_onD(1)[OF assms(2)])
             using \<open>closestm \<in> {um..ym}\<close> \<open>um \<in> {a..z}\<close> \<open>z \<in> {a..b}\<close> \<open>ym \<in> {um..z}\<close>
             \<open>closestM \<in> {yM..uM}\<close> \<open>uM \<in> {z..b}\<close> \<open>z \<in> {a..b}\<close> \<open>yM \<in> {z..uM}\<close> by auto
           also have "... = lambda * dist closestm closestM + 1 * 2 * C"
             unfolding dist_real_def using \<open>closestm \<in> {um..ym}\<close> \<open>um \<in> {a..z}\<close> \<open>z \<in> {a..b}\<close> \<open>ym \<in> {um..z}\<close>
             \<open>closestM \<in> {yM..uM}\<close> \<open>uM \<in> {z..b}\<close> \<open>z \<in> {a..b}\<close> \<open>yM \<in> {z..uM}\<close> by (auto simp add: algebra_simps)
           also have "... \<le> lambda * (lambda * (2 * D + L + 2 * delta + 9 * C)) + lambda^2 * 2 * C"
             apply (intro mono_intros M) using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> by auto
           finally have "dist (f closestm) (f z) + dist (f z) (f closestM) \<le> lambda^2 * (2 * D + L + 2 * delta + 11 * C)"
             by (simp add: algebra_simps power2_eq_square)
           then show ?thesis
             unfolding Gromov_product_at_def using False by (simp add: metric_space_class.dist_commute algebra_simps divide_simps)
         qed
         have "Gromov_product_at (f z) (f um) (f uM) \<le> Gromov_product_at (f z) (f closestm) (f closestM) + 1 * L + 4 * delta + 0 * (1 - exp (- K * (uM - um)))"
           using Rec[OF \<open>closestm \<in> {um..ym}\<close> \<open>closestM \<in> {yM..uM}\<close>] by simp
         also have "... \<le> (lambda^2 * (D + L / 2 + delta + 11/2 * C) - 6 * delta) + lambda^2 * L + 4 * delta + Kmult * (1 - exp (- K * (uM - um)))"
           apply (intro mono_intros I)
           using Laux \<open>lambda \<ge> 1\<close> \<open>delta > 0\<close> \<open>Kmult > 0\<close> \<open>um \<in> {a..z}\<close> \<open>uM \<in> {z..b}\<close> \<open>K > 0\<close> by auto
         finally show ?thesis
           by (simp add: algebra_simps)
         text \<open>End of the easy case 2.1\<close>
       next
         text \<open>Case 2.2: $dm$ is large, i.e., all points in $f[um, ym]$ are far away from $H$. Moreover,
         assume that $dm \geq dM$. Then we will find a pair of points $v$ and $x$ with $um \leq v
         \leq x \leq ym$ satisfying the estimate~\eqref{eq:xvK}. We argue by induction: while we
         have not found such a pair, we can find a point $x_k$ whose projection on $V_k$, the
         neighborhood of size $(2^k-1) dm$ of $H$, is far enough from the projection of $um$, and
         such that all points in between are far enough from $V_k$ so that the corresponding
         projection will have good contraction properties.\<close>
         case 2
         then have I: "D + 4 * C \<le> dm" "dM \<le> dm" by auto
         define V where "V = (\<lambda>k::nat. (\<Union>g\<in>H. cball g ((2^k - 1) * dm)))"
         define QC where "QC = (\<lambda>k::nat. if k = 0 then 0 else 8 * delta)"
         have "QC k \<ge> 0" for k unfolding QC_def using \<open>delta > 0\<close> by auto
         have Q: "quasiconvex (0 + 8 * deltaG(TYPE('a))) (V k)" for k
           unfolding V_def apply (rule quasiconvex_thickening) using geodesic_segmentI[OF H]
           by (auto simp add: quasiconvex_of_geodesic)
         have "quasiconvex (QC k) (V k)" for k
           apply (cases "k = 0")
           apply (simp add: V_def QC_def quasiconvex_of_geodesic geodesic_segmentI[OF H])
           apply (rule quasiconvex_mono[OF _ Q[of k]]) using \<open>deltaG(TYPE('a)) < delta\<close> QC_def by auto
         text \<open>Define $q(k, x)$ to be the projection of $f(x)$ on $V_k$.\<close>
         define q::"nat \<Rightarrow> real \<Rightarrow> 'a" where "q = (\<lambda>k x. geodesic_segment_param {p x--f x} (p x) ((2^k - 1) * dm))"
 
         text \<open>The inductive argument\<close>
         have Ind_k: "(Gromov_product_at (f z) (f um) (f uM) \<le> lambda^2 * (D + 3/2 * L + delta + 11/2 * C) - 2 * delta + Kmult * (1 - exp(- K * (uM - um))))
               \<or> (\<exists>x \<in> {um..ym}. (\<forall>w \<in> {um..x}. dist (f w) (p w) \<ge> (2^(k+1)-1) * dm) \<and> dist (q k um) (q k x) \<ge> L - 4 * delta + 7 * QC k)" for k
         proof (induction k)
           text \<open>Base case: there is a point far enough from $q 0 um$ on $H$. This is just the point $ym$,
           by construction.\<close>
           case 0
           have *: "\<exists>x\<in> {um..ym}. (\<forall>w \<in> {um..x}. dist (f w) (p w) \<ge> (2^(0+1)-1) * dm) \<and> dist (q 0 um) (q 0 x) \<ge> L - 4 * delta + 7 * QC 0"
           proof (rule bexI[of _ ym], auto simp add: V_def q_def QC_def)
             show "um \<le> ym" using \<open>ym \<in> {um..z}\<close> by auto
             show "L - 4 * delta \<le> dist (p um) (p ym)"
               using ym(2) apply auto using metric_space_class.zero_le_dist[of pi_z "p um"] by linarith
             show "\<And>y. um \<le> y \<Longrightarrow> y \<le> ym \<Longrightarrow> dm \<le> dist (f y) (p y)"
               using dm_def closestm proj_setD(2)[OF p] by auto
           qed
           then show ?case
             by blast
         next
           text \<open>The induction. The inductive assumption claims that, either the desired inequality
           holds, or one can construct a point with good properties. If the desired inequality holds,
           there is nothing left to prove. Otherwise, we can start from this point at step $k$,
           say $x$, and either prove the desired inequality or construct a point with the good
           properties at step $k+1$.\<close>
           case Suck: (Suc k)
           show ?case
           proof (cases "Gromov_product_at (f z) (f um) (f uM) \<le> lambda\<^sup>2 * (D + 3/2 * L + delta + 11/2 * C) - 2 * delta + Kmult * (1 - exp (- K * (uM - um)))")
             case True
             then show ?thesis by simp
           next
             case False
             then obtain x where x: "x \<in> {um..ym}" "dist (q k um) (q k x) \<ge> L - 4 * delta + 7 * QC k"
                                    "\<And>w. w \<in> {um..x} \<Longrightarrow> dist (f w) (p w) \<ge> (2^(k+1)-1) * dm"
               using Suck.IH by auto
 
             text \<open>Some auxiliary technical inequalities to be used later on.\<close>
             have aux: "(2 ^ k - 1) * dm \<le> (2*2^k-1) * dm" "0 \<le> 2 * 2 ^ k - (1::real)" "dm \<le> dm * 2 ^ k"
               apply (auto simp add: algebra_simps)
               apply (metis power.simps(2) two_realpow_ge_one)
               using \<open>0 \<le> dm\<close> less_eq_real_def by fastforce
             have "L + C = (L/D) * (D + (D/L) * C)"
               using \<open>L > 0\<close> \<open>D > 0\<close> by (simp add: algebra_simps divide_simps)
             also have "... \<le> (L/D) * (D + 4 * C)"
               apply (intro mono_intros)
               using \<open>L > 0\<close> \<open>D > 0\<close> \<open>C \<ge> 0\<close> \<open>D \<le> 4 * L\<close> by (auto simp add: algebra_simps divide_simps)
             also have "... \<le> (L/D) * dm"
               apply (intro mono_intros) using I \<open>L > 0\<close> \<open>D > 0\<close> by auto
             finally have "L + C \<le> (L/D) * dm"
               by simp
             moreover have "2 * delta \<le> (2 * delta)/D * dm"
               using I \<open>C \<ge> 0\<close> \<open>delta > 0\<close> \<open>D > 0\<close> by (auto simp add: algebra_simps divide_simps)
             ultimately have aux2: "L + C + 2 * delta \<le> ((L + 2 * delta)/D) * dm"
               by (auto simp add: algebra_simps divide_simps)
             have aux3: "(1-alpha) * D + alpha * 2^k * dm \<le> dm * 2^k - C/2 - QC k"
             proof (cases "k = 0")
               case True
               show ?thesis
                  using I \<open>C \<ge> 0\<close> unfolding True QC_def alpha_def by auto
             next
               case False
               have "C/2 + QC k + (1-alpha) * D \<le> 2 * (1-alpha) * dm"
                 using I \<open>C \<ge> 0\<close> unfolding QC_def alpha_def using False Laux by auto
               also have "... \<le> 2^k * (1-alpha) * dm"
                 apply (intro mono_intros) using False alphaaux I \<open>D > 0\<close> \<open>C \<ge> 0\<close> by auto
               finally show ?thesis
                 by (simp add: algebra_simps)
             qed
 
             text \<open>Construct a point $w$ such that its projection on $V_k$ is close to that of $um$
             and therefore far away from that of $x$. This is just the intermediate value theorem
             (with some care as the closest point projection is not continuous).\<close>
             have "\<exists>w \<in> {um..x}. (dist (q k um) (q k w) \<in> {(9 * delta + 4 * QC k) - 4 * delta - 2 * QC k .. 9 * delta + 4 * QC k})
                     \<and> (\<forall>v \<in> {um..w}. dist (q k um) (q k v) \<le> 9 * delta + 4 * QC k)"
             proof (rule quasi_convex_projection_small_gaps[where ?f = f and ?G = "V k"])
               show "continuous_on {um..x} f"
                 apply (rule continuous_on_subset[OF \<open>continuous_on {a..b} f\<close>])
                 using \<open>um \<in> {a..z}\<close> \<open>z \<in> {a..b}\<close> \<open>ym \<in> {um..z}\<close> \<open>x \<in> {um..ym}\<close> by auto
               show "um \<le> x" using \<open>x \<in> {um..ym}\<close> by auto
               show "quasiconvex (QC k) (V k)" by fact
               show "deltaG TYPE('a) < delta" by fact
               show "9 * delta + 4 * QC k \<in> {4 * delta + 2 * QC k..dist (q k um) (q k x)}"
                 using x(2) \<open>delta > 0\<close> \<open>QC k \<ge> 0\<close> Laux by auto
               show "q k w \<in> proj_set (f w) (V k)" if "w \<in> {um..x}" for w
                 unfolding V_def q_def apply (rule proj_set_thickening)
                 using aux p x(3)[OF that] by (auto simp add: metric_space_class.dist_commute)
             qed
             then obtain w where w: "w \<in> {um..x}"
                                    "dist (q k um) (q k w) \<in> {(9 * delta + 4 * QC k) - 4 * delta - 2 * QC k .. 9 * delta + 4 * QC k}"
                                    "\<And>v. v \<in> {um..w} \<Longrightarrow> dist (q k um) (q k v) \<le> 9 * delta + 4 * QC k"
               by auto
             text \<open>There are now two cases to be considered: either one can find a point $v$ between
             $um$ and $w$ which is close enough to $H$. Then this point will satisfy~\eqref{eq:xvK},
             and we will be able to prove the desired inequality. Or there is no such point,
             and then $w$ will have the good properties at step $k+1$\<close>
             show ?thesis
             proof (cases "\<exists>v \<in> {um..w}. dist (f v) (p v) \<le> (2^(k+2)-1) * dm")
               case True
               text \<open>First subcase: there is a good point $v$ between $um$ and $w$. This is the
               heart of the argument: we will show that the desired inequality holds.\<close>
               then obtain v where v: "v \<in> {um..w}" "dist (f v) (p v) \<le> (2^(k+2)-1) * dm"
                 by auto
               text \<open>Auxiliary basic fact to be used later on.\<close>
               have aux4: "dm * 2 ^ k \<le> infdist (f r) (V k)" if "r \<in> {v..x}" for r
               proof -
                 have *: "q k r \<in> proj_set (f r) (V k)"
                   unfolding q_def V_def apply (rule proj_set_thickening)
                   using aux p[of r] x(3)[of r] that \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> by (auto simp add: metric_space_class.dist_commute)
                 have "infdist (f r) (V k) = dist (geodesic_segment_param {p r--f r} (p r) (dist (p r) (f r))) (geodesic_segment_param {p r--f r} (p r) ((2 ^ k - 1) * dm))"
                   using proj_setD(2)[OF *] unfolding q_def by auto
                 also have "... = abs(dist (p r) (f r) - (2 ^ k - 1) * dm)"
                   apply (rule geodesic_segment_param(7)[where ?y = "f r"])
                   using x(3)[of r] \<open>r \<in> {v..x}\<close> \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> aux by (auto simp add: metric_space_class.dist_commute)
                 also have "... = dist (f r) (p r) - (2 ^ k - 1) * dm"
                   using x(3)[of r] \<open>r \<in> {v..x}\<close> \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> aux by (auto simp add: metric_space_class.dist_commute)
                 finally have "dist (f r) (p r) = infdist (f r) (V k) + (2 ^ k - 1) * dm" by simp
                 moreover have "(2^(k+1) - 1) * dm \<le> dist (f r) (p r)"
                   apply (rule x(3)) using \<open>r \<in> {v..x}\<close> \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> by auto
                 ultimately have "(2^(k+1) - 1) * dm \<le> infdist (f r) (V k) + (2 ^ k - 1) * dm"
                   by simp
                 then show ?thesis by (auto simp add: algebra_simps)
               qed
 
               text \<open>Substep 1: We can control the distance from $f(v)$ to $f(closestM)$ in terms of the distance
               of the distance of $f(v)$ to $H$, i.e., by $2^k dm$. The same control follows
               for $closestM - v$ thanks to the quasi-isometry property. Then, we massage this
               inequality to put it in the form we will need, as an upper bound on $(x-v) \exp(-2^k dm)$.\<close>
               have "infdist (f v) H \<le> (2^(k+2)-1) * dm"
                 using v proj_setD(2)[OF p[of v]] by auto
               have "dist v closestM \<le> lambda * (infdist (f v) H + (L + C + 2 * delta) + infdist (f closestM) H)"
                 apply (rule D)
                 using \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> \<open>x \<in> {um..ym}\<close> \<open>ym \<in> {um..z}\<close> \<open>um \<in> {a..z}\<close> \<open>z \<in> {a..b}\<close> \<open>closestM \<in> {yM..uM}\<close> \<open>yM \<in> {z..uM}\<close> \<open>uM \<in> {z..b}\<close> by auto
               also have "... \<le> lambda * ((2^(k+2)-1) * dm + 1 * (L + C + 2 * delta) + dM)"
                 apply (intro mono_intros \<open>infdist (f v) H \<le> (2^(k+2)-1) * dm\<close>)
                 using dM_def \<open>lambda \<ge> 1\<close> \<open>L > 0\<close> \<open>C \<ge> 0\<close> \<open>delta > 0\<close> by (auto simp add: metric_space_class.dist_commute)
               also have "... \<le> lambda * ((2^(k+2)-1) * dm + 2^k * (((L + 2 * delta)/D) * dm) + dm)"
                 apply (intro mono_intros) using I \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> \<open>delta > 0\<close> \<open>L > 0\<close> aux2 by auto
               also have "... = lambda * 2^k * (4 + (L + 2 * delta)/D) * dm"
                 by (simp add: algebra_simps)
               finally have *: "dist v closestM / (lambda * (4 + (L + 2 * delta)/D)) \<le> 2^k * dm"
                 using \<open>lambda \<ge> 1\<close> \<open>L > 0\<close> \<open>D > 0\<close> \<open>delta > 0\<close> by (simp add: divide_simps, simp add: algebra_simps)
               text \<open>We reformulate this control inside of an exponential, as this is the form we
               will use later on.\<close>
               have "exp(- (alpha * (2^k * dm) * ln 2 / (5 * delta))) \<le> exp(-(alpha * (dist v closestM / (lambda * (4 + (L + 2 * delta)/D))) * ln 2 / (5 * delta)))"
                 apply (intro mono_intros *) using alphaaux \<open>delta > 0\<close> by auto
               also have "... = exp(-K * dist v closestM)"
                 unfolding K_def by (simp add: divide_simps)
               also have "... = exp(-K * (closestM - v))"
                 unfolding dist_real_def using \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> \<open>x \<in> {um..ym}\<close> \<open>ym \<in> {um..z}\<close> \<open>yM \<in> {z..uM}\<close> \<open>closestM \<in> {yM..uM}\<close> \<open>K > 0\<close> by auto
               finally have "exp(- (alpha * (2^k * dm) * ln 2 / (5 * delta))) \<le> exp(-K * (closestM - v))"
                 by simp
               text \<open>Plug in $x-v$ to get the final form of this inequality.\<close>
               then have "K * (x - v) * exp(- (alpha * (2^k * dm) * ln 2 / (5 * delta))) \<le> K * (x - v) * exp(-K * (closestM - v))"
                 apply (rule mult_left_mono)
                 using \<open>delta > 0\<close> \<open>lambda \<ge> 1\<close> \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> \<open>K > 0\<close> by auto
               also have "... = ((1 + K * (x - v)) - 1) * exp(- K * (closestM - v))"
                 by (auto simp add: algebra_simps)
               also have "... \<le> (exp (K * (x - v)) - 1) * exp(-K * (closestM - v))"
                 by (intro mono_intros, auto)
               also have "... = exp(-K * (closestM - x)) - exp(-K * (closestM - v))"
                 by (simp add: algebra_simps mult_exp_exp)
               also have "... \<le> exp(-K * (closestM - x)) - exp(-K * (uM - um))"
                 using \<open>K > 0\<close> \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> \<open>x \<in> {um..ym}\<close> \<open>ym \<in> {um..z}\<close> \<open>yM \<in> {z..uM}\<close> \<open>closestM \<in> {yM..uM}\<close> by auto
               finally have B: "(x - v) * exp(- alpha * 2^k * dm * ln 2 / (5 * delta)) \<le>
                                   (exp(-K * (closestM - x)) - exp(-K * (uM-um)))/K"
                 using \<open>K > 0\<close> by (auto simp add: divide_simps algebra_simps)
               text \<open>End of substep 1\<close>
 
               text \<open>Substep 2: The projections of $f(v)$ and $f(x)$ on the cylinder $V_k$ are well separated,
               by construction. This implies that $v$ and $x$ themselves are well separated, thanks
               to the exponential contraction property of the projection on the quasi-convex set $V_k$.
               This leads to a uniform lower bound for $(x-v) \exp(-2^k dm)$, which has been upper bounded
               in Substep 1.\<close>
               have "L - 4 * delta + 7 * QC k \<le> dist (q k um) (q k x)"
                 using x by simp
               also have "... \<le> dist (q k um) (q k v) + dist (q k v) (q k x)"
                 by (intro mono_intros)
               also have "... \<le> (9 * delta + 4 * QC k) + dist (q k v) (q k x)"
                 using w(3)[of v] \<open>v \<in> {um..w}\<close> by auto
               finally have "L - 13 * delta + 3 * QC k \<le> dist (q k v) (q k x)"
                 by simp
               also have "... \<le> 3 * QC k + max (5 * deltaG(TYPE('a))) ((4 * exp(1/2 * ln 2)) * lambda * (x - v) * exp(-(dm * 2^k - C/2 - QC k) * ln 2 / (5 * delta)))"
               proof (cases "k = 0")
                 text \<open>We use different statements for the projection in the case $k = 0$ (projection on
                 a geodesic) and $k > 0$ (projection on a quasi-convex set) as the bounds are better in
                 the first case, which is the most important one for the final value of the constant.\<close>
                 case True
                 have "dist (q k v) (q k x) \<le> max (5 * deltaG(TYPE('a))) ((4 * exp(1/2 * ln 2)) * lambda * (x - v) * exp(-(dm * 2^k - C/2) * ln 2 / (5 * delta)))"
                 proof (rule geodesic_projection_exp_contracting[where ?G = "V k" and ?f = f])
                   show "geodesic_segment (V k)" unfolding True V_def using geodesic_segmentI[OF H] by auto
                   show "v \<le> x" using \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> by auto
                   show "q k v \<in> proj_set (f v) (V k)"
                     unfolding q_def V_def apply (rule proj_set_thickening)
                     using aux p[of v] x(3)[of v] \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> by (auto simp add: metric_space_class.dist_commute)
                   show "q k x \<in> proj_set (f x) (V k)"
                     unfolding q_def V_def apply (rule proj_set_thickening)
                     using aux p[of x] x(3)[of x] \<open>w \<in> {um..x}\<close> by (auto simp add: metric_space_class.dist_commute)
                   show "15/2 * delta + C/2 \<le> dm * 2^k"
                     apply (rule order_trans[of _ dm])
                     using I \<open>delta > 0\<close> \<open>C \<ge> 0\<close> Laux unfolding QC_def by auto
                   show "deltaG TYPE('a) < delta" by fact
                   show "\<And>t. t \<in> {v..x} \<Longrightarrow> dm * 2 ^ k \<le> infdist (f t) (V k)"
                     using aux4 by auto
                   show "0 \<le> C" "0 \<le> lambda" using \<open>C \<ge> 0\<close> \<open>lambda \<ge> 1\<close> by auto
                   show "dist (f x1) (f x2) \<le> lambda * dist x1 x2 + C" if "x1 \<in> {v..x}" "x2 \<in> {v..x}" for x1 x2
                     using quasi_isometry_onD(1)[OF assms(2)] that \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> \<open>x \<in> {um..ym}\<close> \<open>ym \<in> {um..z}\<close> \<open>um \<in> {a..z}\<close> \<open>z \<in> {a..b}\<close> by auto
                 qed
                 then show ?thesis unfolding QC_def True by auto
               next
                 case False
                 have "dist (q k v) (q k x) \<le> 2 * QC k + 8 * delta + max (5 * deltaG(TYPE('a))) ((4 * exp(1/2 * ln 2)) * lambda * (x - v) * exp(-(dm * 2^k - QC k -C/2) * ln 2 / (5 * delta)))"
                 proof (rule quasiconvex_projection_exp_contracting[where ?G = "V k" and ?f = f])
                   show "quasiconvex (QC k) (V k)" by fact
                   show "v \<le> x" using \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> by auto
                   show "q k v \<in> proj_set (f v) (V k)"
                     unfolding q_def V_def apply (rule proj_set_thickening)
                     using aux p[of v] x(3)[of v] \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> by (auto simp add: metric_space_class.dist_commute)
                   show "q k x \<in> proj_set (f x) (V k)"
                     unfolding q_def V_def apply (rule proj_set_thickening)
                     using aux p[of x] x(3)[of x] \<open>w \<in> {um..x}\<close> by (auto simp add: metric_space_class.dist_commute)
                   show "15/2 * delta + QC k + C/2 \<le> dm * 2^k"
                     apply (rule order_trans[of _ dm])
                     using I \<open>delta > 0\<close> \<open>C \<ge> 0\<close> Laux unfolding QC_def by auto
                   show "deltaG TYPE('a) < delta" by fact
                   show "\<And>t. t \<in> {v..x} \<Longrightarrow> dm * 2 ^ k \<le> infdist (f t) (V k)"
                     using aux4 by auto
                   show "0 \<le> C" "0 \<le> lambda" using \<open>C \<ge> 0\<close> \<open>lambda \<ge> 1\<close> by auto
                   show "dist (f x1) (f x2) \<le> lambda * dist x1 x2 + C" if "x1 \<in> {v..x}" "x2 \<in> {v..x}" for x1 x2
                     using quasi_isometry_onD(1)[OF assms(2)] that \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> \<open>x \<in> {um..ym}\<close> \<open>ym \<in> {um..z}\<close> \<open>um \<in> {a..z}\<close> \<open>z \<in> {a..b}\<close> by auto
                 qed
                 then show ?thesis unfolding QC_def using False by (auto simp add: algebra_simps)
               qed
               finally have "L - 13 * delta \<le> max (5 * deltaG(TYPE('a))) ((4 * exp(1/2 * ln 2)) * lambda * (x - v) * exp(-(dm * 2^k - C/2 - QC k) * ln 2 / (5 * delta)))"
                 by auto
               then have "L - 13 * delta \<le> (4 * exp(1/2 * ln 2)) * lambda * (x - v) * exp(-(dm * 2^k - C/2 - QC k) * ln 2 / (5 * delta))"
                 using \<open>delta > deltaG(TYPE('a))\<close> Laux by auto
               text \<open>We separate the exponential gain coming from the contraction into two parts, one
               to be spent to improve the constant, and one for the inductive argument.\<close>
               also have "... \<le> (4 * exp(1/2 * ln 2)) * lambda * (x - v) * exp(-((1-alpha) * D + alpha * 2^k * dm) * ln 2 / (5 * delta))"
                 apply (intro mono_intros) using aux3 \<open>delta > 0\<close> \<open>lambda \<ge> 1\<close> \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> by auto
               also have "... = (4 * exp(1/2 * ln 2)) * lambda * (x - v) * (exp(-(1-alpha) * D * ln 2 / (5 * delta)) * exp(-alpha * 2^k * dm * ln 2 / (5 * delta)))"
                 unfolding mult_exp_exp by (auto simp add: algebra_simps divide_simps)
               finally have A: "L - 13 * delta \<le> (4 * exp(1/2 * ln 2)) * lambda * exp(-(1-alpha) * D * ln 2 / (5 * delta)) * ((x - v) * exp(-alpha * 2^k * dm * ln 2 / (5 * delta)))"
                 by (simp add: algebra_simps)
               text \<open>This is the end of the second substep.\<close>
 
               text \<open>Use the second substep to show that $x-v$ is bounded below, and therefore
               that $closestM - x$ (the endpoints of the new geodesic we want to consider in the
               inductive argument) are quantitatively closer than $uM - um$, which means that we
               will be able to use the inductive assumption over this new geodesic.\<close>
               also have "... \<le> (4 * exp(1/2 * ln 2)) * lambda * exp 0 * ((x - v) * exp 0)"
                 apply (intro mono_intros) using \<open>delta > 0\<close> \<open>lambda \<ge> 1\<close> \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> alphaaux \<open>D > 0\<close> \<open>C \<ge> 0\<close> I
                 by (auto simp add: divide_simps mult_nonpos_nonneg)
               also have "... = (4 * exp(1/2 * ln 2)) * lambda * (x-v)"
                 by simp
               also have "... \<le> 20 * lambda * (x - v)"
                 apply (intro mono_intros, approximation 10)
                 using \<open>delta > 0\<close> \<open>lambda \<ge> 1\<close> \<open>v \<in> {um..w}\<close> \<open>w \<in> {um..x}\<close> by auto
               finally have "x - v \<ge> (1/4) * delta / lambda"
                 using \<open>lambda \<ge> 1\<close> L_def \<open>delta > 0\<close> by (simp add: divide_simps algebra_simps)
               then have "closestM - x + (1/4) * delta / lambda \<le> closestM - v"
                 by simp
               also have "... \<le> uM - um"
                 using \<open>closestM \<in> {yM..uM}\<close> \<open>v \<in> {um..w}\<close> by auto
               also have "... \<le> Suc n * (1/4) * delta / lambda" by fact
               finally have "closestM - x \<le> n * (1/4) * delta / lambda"
                 unfolding Suc_eq_plus1 by (auto simp add: algebra_simps add_divide_distrib)
 
               text \<open>Conclusion of the proof: combine the lower bound of the second substep with
               the upper bound of the first substep to get a definite gain when one goes from
               the old geodesic to the new one. Then, apply the inductive assumption to the new one
               to conclude the desired inequality for the old one.\<close>
               have "L + 4 * delta = ((L + 4 * delta)/(L - 13 * delta)) * (L - 13 * delta)"
                 using Laux \<open>delta > 0\<close> by (simp add: algebra_simps divide_simps)
               also have "... \<le> ((L + 4 * delta)/(L - 13 * delta)) * ((4 * exp(1/2 * ln 2)) * lambda * exp (- (1 - alpha) * D * ln 2 / (5 * delta)) * ((x - v) * exp (- alpha * 2 ^ k * dm * ln 2 / (5 * delta))))"
                 apply (rule mult_left_mono) using A Laux \<open>delta > 0\<close> by (auto simp add: divide_simps)
               also have "... \<le> ((L + 4 * delta)/(L - 13 * delta)) * ((4 * exp(1/2 * ln 2)) * lambda * exp (- (1 - alpha) * D * ln 2 / (5 * delta)) * ((exp(-K * (closestM - x)) - exp(-K * (uM - um)))/K))"
                 apply (intro mono_intros B) using Laux \<open>delta > 0\<close> \<open>lambda \<ge> 1\<close> by (auto simp add: divide_simps)
               finally have C: "L + 4 * delta \<le> Kmult * (exp(-K * (closestM - x)) - exp(-K * (uM - um)))"
                 unfolding Kmult_def by auto
 
               have "Gromov_product_at (f z) (f um) (f uM) \<le> Gromov_product_at (f z) (f x) (f closestM) + (L + 4 * delta)"
                 apply (rule Rec) using \<open>closestM \<in> {yM..uM}\<close> \<open>x \<in> {um..ym}\<close> \<open>ym \<in> {um..z}\<close> by auto
               also have "... \<le> (lambda^2 * (D + 3/2 * L + delta + 11/2 * C) - 2 * delta + Kmult * (1 - exp(- K * (closestM - x)))) + (Kmult * (exp(-K * (closestM - x)) - exp(-K * (uM-um))))"
                 apply (intro mono_intros C Suc.IH)
                 using \<open>x \<in> {um..ym}\<close> \<open>ym \<in> {um..z}\<close> \<open>um \<in> {a..z}\<close> \<open>closestM \<in> {yM..uM}\<close> \<open>yM \<in> {z..uM}\<close> \<open>uM \<in> {z..b}\<close> \<open>closestM - x \<le> n * (1/4) * delta / lambda\<close> by auto
               also have "... = (lambda^2 * (D + 3/2 * L + delta + 11/2 * C) - 2 * delta + Kmult * (1 - exp(- K * (uM - um))))"
                 unfolding K_def by (simp add: algebra_simps)
               finally show ?thesis by auto
               text \<open>End of the first subcase, when there is a good point $v$ between $um$ and $w$.\<close>
             next
               case False
               text \<open>Second subcase: between $um$ and $w$, all points are far away from $V_k$. We
               will show that this implies that $w$ is admissible for the step $k+1$.\<close>
               have "\<exists>w\<in>{um..ym}. (\<forall>v\<in>{um..w}. (2 ^ (Suc k + 1) - 1) * dm \<le> dist (f v) (p v)) \<and> L - 4 * delta + 7 * QC (Suc k) \<le> dist (q (Suc k) um) (q (Suc k) w)"
               proof (rule bexI[of _ w], auto)
                 show "um \<le> w" "w \<le> ym" using \<open>w \<in> {um..x}\<close> \<open>x \<in> {um..ym}\<close> by auto
                 show "(4 * 2 ^ k - 1) * dm \<le> dist (f x) (p x)" if "um \<le> x" "x \<le> w" for x
                   using False \<open>dm \<ge> 0\<close> that by force
 
                 have "dist (q k um) (q (k+1) um) = 2^k * dm"
                   unfolding q_def apply (subst geodesic_segment_param(7)[where ?y = "f um"])
                   using x(3)[of um] \<open>x \<in> {um..ym}\<close> aux by (auto simp add: metric_space_class.dist_commute, simp add: algebra_simps)
                 have "dist (q k w) (q (k+1) w) = 2^k * dm"
                   unfolding q_def apply (subst geodesic_segment_param(7)[where ?y = "f w"])
                   using x(3)[of w] \<open>w \<in> {um..x}\<close> \<open>x \<in> {um..ym}\<close> aux by (auto simp add: metric_space_class.dist_commute, simp add: algebra_simps)
                 have i: "q k um \<in> proj_set (q (k+1) um) (V k)"
                   unfolding q_def V_def apply (rule proj_set_thickening'[of _ "f um"])
                   using p x(3)[of um] \<open>x \<in> {um..ym}\<close> aux by (auto simp add: algebra_simps metric_space_class.dist_commute)
                 have j: "q k w \<in> proj_set (q (k+1) w) (V k)"
                   unfolding q_def V_def apply (rule proj_set_thickening'[of _ "f w"])
                   using p x(3)[of w] \<open>x \<in> {um..ym}\<close> \<open>w \<in> {um..x}\<close> aux by (auto simp add: algebra_simps metric_space_class.dist_commute)
 
                 have "5 * delta + 2 * QC k \<le> dist (q k um) (q k w)" using w(2) by simp
                 also have "... \<le> max (5 * deltaG(TYPE('a)) + 2 * QC k)
                                       (dist (q (k + 1) um) (q (k + 1) w) - dist (q k um) (q (k + 1) um) - dist (q k w) (q (k + 1) w) + 10 * deltaG(TYPE('a)) + 4 * QC k)"
                   by (rule proj_along_quasiconvex_contraction[OF \<open>quasiconvex (QC k) (V k)\<close> i j])
                 finally have "5 * delta + 2 * QC k \<le> dist (q (k + 1) um) (q (k + 1) w) - dist (q k um) (q (k + 1) um) - dist (q k w) (q (k + 1) w) + 10 * deltaG(TYPE('a)) + 4 * QC k"
                   using \<open>deltaG(TYPE('a)) < delta\<close> by auto
                 then have "0 \<le> dist (q (k + 1) um) (q (k + 1) w) + 5 * delta + 2 * QC k - dist (q k um) (q (k + 1) um) - dist (q k w) (q (k + 1) w)"
                   using \<open>deltaG(TYPE('a)) < delta\<close> by auto
                 also have "... = dist (q (k + 1) um) (q (k + 1) w) + 5 * delta + 2 * QC k - 2^(k+1) * dm"
                   by (simp only: \<open>dist (q k w) (q (k+1) w) = 2^k * dm\<close> \<open>dist (q k um) (q (k+1) um) = 2^k * dm\<close>, auto)
                 finally have *: "2^(k+1) * dm - 5 * delta - 2 * QC k \<le> dist (q (k+1) um) (q (k+1) w)"
                   using \<open>deltaG(TYPE('a)) < delta\<close> by auto
                 have "L - 4 * delta + 7 * QC (k+1) \<le> 2 * dm - 5 * delta - 2 * QC k"
                   unfolding QC_def L_def using \<open>delta > 0\<close> Laux I \<open>C \<ge> 0\<close> by auto
                 also have "... \<le> 2^(k+1) * dm - 5 * delta - 2 * QC k"
                   using aux by (auto simp add: algebra_simps)
                 finally show "L - 4 * delta + 7 * QC (Suc k) \<le> dist (q (Suc k) um) (q (Suc k) w)"
                   using * by auto
               qed
               then show ?thesis
                 by simp
             qed
           qed
         qed
         text \<open>This is the end of the main induction over $k$. To conclude, choose $k$ large enough
         so that the second alternative in this induction is impossible. It follows that the first
         alternative holds, i.e., the desired inequality is true.\<close>
         have "dm > 0" using I \<open>delta > 0\<close> \<open>C \<ge> 0\<close> Laux by auto
         have "\<exists>k. 2^k > dist (f um) (p um)/dm + 1"
           by (simp add: real_arch_pow)
         then obtain k where "2^k > dist (f um) (p um)/dm + 1"
           by blast
         then have "dist (f um) (p um) < (2^k - 1) * dm"
           using \<open>dm > 0\<close> by (auto simp add: divide_simps algebra_simps)
         also have "... \<le> (2^(Suc k) - 1) * dm"
           by (intro mono_intros, auto)
         finally have "\<not>((2 ^ (k + 1) - 1) * dm \<le> dist (f um) (p um))"
           by simp
         then show "Gromov_product_at (f z) (f um) (f uM) \<le> lambda\<^sup>2 * (D + 3/2 * L + delta + 11/2 * C) - 2 * delta + Kmult * (1 - exp (- K * (uM - um)))"
           using Ind_k[of k] by auto
         text \<open>end of the case where $D + 4 * C \leq dm$ and $dM \leq dm$.\<close>
       next
         case 3
         text \<open>This is the exact copy of the previous case, except that the roles of the points before
         and after $z$ are exchanged. In a perfect world, one would use a lemma subsuming both cases,
         but in practice copy-paste seems to work better here as there are two many details to be
         changed regarding the direction of inequalities.\<close>
         then have I: "D + 4 * C \<le> dM" "dm \<le> dM" by auto
         define V where "V = (\<lambda>k::nat. (\<Union>g\<in>H. cball g ((2^k - 1) * dM)))"
         define QC where "QC = (\<lambda>k::nat. if k = 0 then 0 else 8 * delta)"
         have "QC k \<ge> 0" for k unfolding QC_def using \<open>delta > 0\<close> by auto
         have Q: "quasiconvex (0 + 8 * deltaG(TYPE('a))) (V k)" for k
           unfolding V_def apply (rule quasiconvex_thickening) using geodesic_segmentI[OF H]
           by (auto simp add: quasiconvex_of_geodesic)
         have "quasiconvex (QC k) (V k)" for k
           apply (cases "k = 0")
           apply (simp add: V_def QC_def quasiconvex_of_geodesic geodesic_segmentI[OF H])
           apply (rule quasiconvex_mono[OF _ Q[of k]]) using \<open>deltaG(TYPE('a)) < delta\<close> QC_def by auto
         define q::"nat \<Rightarrow> real \<Rightarrow> 'a" where "q = (\<lambda>k x. geodesic_segment_param {p x--f x} (p x) ((2^k - 1) * dM))"
 
         have Ind_k: "(Gromov_product_at (f z) (f um) (f uM) \<le> lambda^2 * (D + 3/2 * L + delta + 11/2 * C) - 2 * delta + Kmult * (1 - exp(- K * (uM - um))))
               \<or> (\<exists>x \<in> {yM..uM}. (\<forall>y \<in> {x..uM}. dist (f y) (p y) \<ge> (2^(k+1)-1) * dM) \<and> dist (q k uM) (q k x) \<ge> L - 4 * delta + 7 * QC k)" for k
         proof (induction k)
           case 0
           have *: "\<exists>x\<in> {yM..uM}. (\<forall>y \<in> {x..uM}. dist (f y) (p y) \<ge> (2^(0+1)-1) * dM) \<and> dist (q 0 uM) (q 0 x) \<ge> L - 4 * delta + 7 * QC 0"
           proof (rule bexI[of _ yM], auto simp add: V_def q_def QC_def)
             show "yM \<le> uM" using \<open>yM \<in> {z..uM}\<close> by auto
             show "L -4 * delta \<le> dist (p uM) (p yM)"
               using yM(2) apply auto using metric_space_class.zero_le_dist[of pi_z "p uM"] by linarith
             show "\<And>y. y \<le> uM \<Longrightarrow> yM \<le> y \<Longrightarrow> dM \<le> dist (f y) (p y)"
               using dM_def closestM proj_setD(2)[OF p] by auto
           qed
           then show ?case
             by blast
         next
           case Suck: (Suc k)
           show ?case
           proof (cases "Gromov_product_at (f z) (f um) (f uM) \<le> lambda\<^sup>2 * (D + 3/2 * L + delta + 11/2 * C) - 2 * delta + Kmult * (1 - exp (- K * (uM - um)))")
             case True
             then show ?thesis by simp
           next
             case False
             then obtain x where x: "x \<in> {yM..uM}" "dist (q k uM) (q k x) \<ge> L - 4 * delta + 7 * QC k"
                                    "\<And>w. w \<in> {x..uM} \<Longrightarrow> dist (f w) (p w) \<ge> (2^(k+1)-1) * dM"
               using Suck.IH by auto
             have aux: "(2 ^ k - 1) * dM \<le> (2*2^k-1) * dM" "0 \<le> 2 * 2 ^ k - (1::real)" "dM \<le> dM * 2 ^ k"
               apply (auto simp add: algebra_simps)
               apply (metis power.simps(2) two_realpow_ge_one)
               using \<open>0 \<le> dM\<close> less_eq_real_def by fastforce
             have "L + C = (L/D) * (D + (D/L) * C)"
               using \<open>L > 0\<close> \<open>D > 0\<close> by (simp add: algebra_simps divide_simps)
             also have "... \<le> (L/D) * (D + 4 * C)"
               apply (intro mono_intros)
               using \<open>L > 0\<close> \<open>D > 0\<close> \<open>C \<ge> 0\<close> \<open>D \<le> 4 * L\<close> by (auto simp add: algebra_simps divide_simps)
             also have "... \<le> (L/D) * dM"
               apply (intro mono_intros) using I \<open>L > 0\<close> \<open>D > 0\<close> by auto
             finally have "L + C \<le> (L/D) * dM"
               by simp
              moreover have "2 * delta \<le> (2 * delta)/D * dM"
               using I \<open>C \<ge> 0\<close> \<open>delta > 0\<close> \<open>D > 0\<close> by (auto simp add: algebra_simps divide_simps)
             ultimately have aux2: "L + C + 2 * delta \<le> ((L + 2 * delta)/D) * dM"
               by (auto simp add: algebra_simps divide_simps)
             have aux3: "(1-alpha) * D + alpha * 2^k * dM \<le> dM * 2^k - C/2 - QC k"
             proof (cases "k = 0")
               case True
               show ?thesis
                  using I \<open>C \<ge> 0\<close> unfolding True QC_def alpha_def by auto
             next
               case False
               have "C/2 + QC k + (1-alpha) * D \<le> 2 * (1-alpha) * dM"
                 using I \<open>C \<ge> 0\<close> unfolding QC_def alpha_def using False Laux by auto
               also have "... \<le> 2^k * (1-alpha) * dM"
                 apply (intro mono_intros) using False alphaaux I \<open>D > 0\<close> \<open>C \<ge> 0\<close> by auto
               finally show ?thesis
                 by (simp add: algebra_simps)
             qed
 
             have "\<exists>w \<in> {x..uM}. (dist (q k uM) (q k w) \<in> {(9 * delta + 4 * QC k) - 4 * delta - 2 * QC k .. 9 * delta + 4 * QC k})
                     \<and> (\<forall>v \<in> {w..uM}. dist (q k uM) (q k v) \<le> 9 * delta + 4 * QC k)"
             proof (rule quasi_convex_projection_small_gaps'[where ?f = f and ?G = "V k"])
               show "continuous_on {x..uM} f"
                 apply (rule continuous_on_subset[OF \<open>continuous_on {a..b} f\<close>])
                 using \<open>uM \<in> {z..b}\<close> \<open>z \<in> {a..b}\<close> \<open>yM \<in> {z..uM}\<close> \<open>x \<in> {yM..uM}\<close> by auto
               show "x \<le> uM" using \<open>x \<in> {yM..uM}\<close> by auto
               show "quasiconvex (QC k) (V k)" by fact
               show "deltaG TYPE('a) < delta" by fact
               show "9 * delta + 4 * QC k \<in> {4 * delta + 2 * QC k..dist (q k x) (q k uM)}"
                 using x(2) \<open>delta > 0\<close> \<open>QC k \<ge> 0\<close> Laux by (auto simp add: metric_space_class.dist_commute)
               show "q k w \<in> proj_set (f w) (V k)" if "w \<in> {x..uM}" for w
                 unfolding V_def q_def apply (rule proj_set_thickening)
                 using aux p x(3)[OF that] by (auto simp add: metric_space_class.dist_commute)
             qed
             then obtain w where w: "w \<in> {x..uM}"
                                    "dist (q k uM) (q k w) \<in> {(9 * delta + 4 * QC k) - 4 * delta - 2 * QC k .. 9 * delta + 4 * QC k}"
                                    "\<And>v. v \<in> {w..uM} \<Longrightarrow> dist (q k uM) (q k v) \<le> 9 * delta + 4 * QC k"
               by auto
             show ?thesis
             proof (cases "\<exists>v \<in> {w..uM}. dist (f v) (p v) \<le> (2^(k+2)-1) * dM")
               case True
               then obtain v where v: "v \<in> {w..uM}" "dist (f v) (p v) \<le> (2^(k+2)-1) * dM"
                 by auto
               have aux4: "dM * 2 ^ k \<le> infdist (f r) (V k)" if "r \<in> {x..v}" for r
               proof -
                 have *: "q k r \<in> proj_set (f r) (V k)"
                   unfolding q_def V_def apply (rule proj_set_thickening)
                   using aux p[of r] x(3)[of r] that \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> by (auto simp add: metric_space_class.dist_commute)
                 have "infdist (f r) (V k) = dist (geodesic_segment_param {p r--f r} (p r) (dist (p r) (f r))) (geodesic_segment_param {p r--f r} (p r) ((2 ^ k - 1) * dM))"
                   using proj_setD(2)[OF *] unfolding q_def by auto
                 also have "... = abs(dist (p r) (f r) - (2 ^ k - 1) * dM)"
                   apply (rule geodesic_segment_param(7)[where ?y = "f r"])
                   using x(3)[of r] \<open>r \<in> {x..v}\<close> \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> aux by (auto simp add: metric_space_class.dist_commute)
                 also have "... = dist (f r) (p r) - (2 ^ k - 1) * dM"
                   using x(3)[of r] \<open>r \<in> {x..v}\<close> \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> aux by (auto simp add: metric_space_class.dist_commute)
                 finally have "dist (f r) (p r) = infdist (f r) (V k) + (2 ^ k - 1) * dM" by simp
                 moreover have "(2^(k+1) - 1) * dM \<le> dist (f r) (p r)"
                   apply (rule x(3)) using \<open>r \<in> {x..v}\<close> \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> by auto
                 ultimately have "(2^(k+1) - 1) * dM \<le> infdist (f r) (V k) + (2 ^ k - 1) * dM"
                   by simp
                 then show ?thesis by (auto simp add: algebra_simps)
               qed
 
               have "infdist (f v) H \<le> (2^(k+2)-1) * dM"
                 using v proj_setD(2)[OF p[of v]] by auto
               have "dist closestm v \<le> lambda * (infdist (f closestm) H + (L + C + 2 * delta) + infdist (f v) H)"
                 apply (rule D)
                 using \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> \<open>x \<in> {yM..uM}\<close> \<open>yM \<in> {z..uM}\<close> \<open>uM \<in> {z..b}\<close> \<open>z \<in> {a..b}\<close> \<open>closestm \<in> {um..ym}\<close> \<open>ym \<in> {um..z}\<close> \<open>um \<in> {a..z}\<close> by auto
               also have "... \<le> lambda * (dm + 1 * (L + C + 2 * delta) + (2^(k+2)-1) * dM)"
                 apply (intro mono_intros \<open>infdist (f v) H \<le> (2^(k+2)-1) * dM\<close>)
                 using dm_def \<open>lambda \<ge> 1\<close> \<open>L > 0\<close> \<open>C \<ge> 0\<close> \<open>delta > 0\<close> by (auto simp add: metric_space_class.dist_commute)
               also have "... \<le> lambda * (dM + 2^k * (((L + 2 * delta)/D) * dM) + (2^(k+2)-1) * dM)"
                 apply (intro mono_intros) using I \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> \<open>delta > 0\<close> \<open>L > 0\<close> aux2 by auto
               also have "... = lambda * 2^k * (4 + (L + 2 * delta)/D) * dM"
                 by (simp add: algebra_simps)
               finally have *: "dist closestm v / (lambda * (4 + (L + 2 * delta)/D)) \<le> 2^k * dM"
                 using \<open>lambda \<ge> 1\<close> \<open>L > 0\<close> \<open>D > 0\<close> \<open>delta > 0\<close> by (simp add: divide_simps, simp add: algebra_simps)
 
               have "exp(- (alpha * (2^k * dM) * ln 2 / (5 * delta))) \<le> exp(-(alpha * (dist closestm v / (lambda * (4 + (L + 2 * delta)/D))) * ln 2 / (5 * delta)))"
                 apply (intro mono_intros *) using alphaaux \<open>delta > 0\<close> by auto
               also have "... = exp(-K * dist closestm v)"
                 unfolding K_def by (simp add: divide_simps)
               also have "... = exp(-K * (v - closestm))"
                 unfolding dist_real_def using \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> \<open>x \<in> {yM..uM}\<close> \<open>yM \<in> {z..uM}\<close> \<open>ym \<in> {um..z}\<close> \<open>closestm \<in> {um..ym}\<close> \<open>K > 0\<close> by auto
               finally have "exp(- (alpha * (2^k * dM) * ln 2 / (5 * delta))) \<le> exp(-K * (v - closestm))"
                 by simp
               then have "K * (v - x) * exp(- (alpha * (2^k * dM) * ln 2 / (5 * delta))) \<le> K * (v - x) * exp(-K * (v - closestm))"
                 apply (rule mult_left_mono)
                 using \<open>delta > 0\<close> \<open>lambda \<ge> 1\<close> \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> \<open>K > 0\<close> by auto
               also have "... = ((1 + K * (v - x)) - 1) * exp(- K * (v - closestm))"
                 by (auto simp add: algebra_simps)
               also have "... \<le> (exp (K * (v - x)) - 1) * exp(-K * (v - closestm))"
                 by (intro mono_intros, auto)
               also have "... = exp(-K * (x - closestm)) - exp(-K * (v - closestm))"
                 by (simp add: algebra_simps mult_exp_exp)
               also have "... \<le> exp(-K * (x - closestm)) - exp(-K * (uM - um))"
                 using \<open>K > 0\<close> \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> \<open>x \<in> {yM..uM}\<close> \<open>yM \<in> {z..uM}\<close> \<open>ym \<in> {um..z}\<close> \<open>closestm \<in> {um..ym}\<close> by auto
               finally have B: "(v - x) * exp(- alpha * 2^k * dM * ln 2 / (5 * delta)) \<le>
                                   (exp(-K * (x - closestm)) - exp(-K * (uM - um)))/K"
                 using \<open>K > 0\<close> by (auto simp add: divide_simps algebra_simps)
 
               text \<open>The projections of $f(v)$ and $f(x)$ on the cylinder $V_k$ are well separated,
               by construction. This implies that $v$ and $x$ themselves are well separated.\<close>
               have "L - 4 * delta + 7 * QC k \<le> dist (q k uM) (q k x)"
                 using x by simp
               also have "... \<le> dist (q k uM) (q k v) + dist (q k v) (q k x)"
                 by (intro mono_intros)
               also have "... \<le> (9 * delta + 4 * QC k) + dist (q k v) (q k x)"
                 using w(3)[of v] \<open>v \<in> {w..uM}\<close> by auto
               finally have "L - 13 * delta + 3 * QC k \<le> dist (q k x) (q k v)"
                 by (simp add: metric_space_class.dist_commute)
               also have "... \<le> 3 * QC k + max (5 * deltaG(TYPE('a))) ((4 * exp(1/2 * ln 2)) * lambda * (v - x) * exp(-(dM * 2^k - C/2 - QC k) * ln 2 / (5 * delta)))"
               proof (cases "k = 0")
                 case True
                 have "dist (q k x) (q k v) \<le> max (5 * deltaG(TYPE('a))) ((4 * exp(1/2 * ln 2)) * lambda * (v - x) * exp(-(dM * 2^k - C/2) * ln 2 / (5 * delta)))"
                 proof (rule geodesic_projection_exp_contracting[where ?G = "V k" and ?f = f])
                   show "geodesic_segment (V k)" unfolding V_def True using geodesic_segmentI[OF H] by auto
                   show "x \<le> v" using \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> by auto
                   show "q k v \<in> proj_set (f v) (V k)"
                     unfolding q_def V_def apply (rule proj_set_thickening)
                     using aux p[of v] x(3)[of v] \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> by (auto simp add: metric_space_class.dist_commute)
                   show "q k x \<in> proj_set (f x) (V k)"
                     unfolding q_def V_def apply (rule proj_set_thickening)
                     using aux p[of x] x(3)[of x] \<open>w \<in> {x..uM}\<close> by (auto simp add: metric_space_class.dist_commute)
                   show "15/2 * delta + C/2 \<le> dM * 2^k"
                     using I \<open>delta > 0\<close> \<open>C \<ge> 0\<close> Laux unfolding QC_def True by auto
                   show "deltaG TYPE('a) < delta" by fact
                   show "\<And>t. t \<in> {x..v} \<Longrightarrow> dM * 2 ^ k \<le> infdist (f t) (V k)"
                     using aux4 by auto
                   show "0 \<le> C" "0 \<le> lambda" using \<open>C \<ge> 0\<close> \<open>lambda \<ge> 1\<close> by auto
                   show "dist (f x1) (f x2) \<le> lambda * dist x1 x2 + C" if "x1 \<in> {x..v}" "x2 \<in> {x..v}" for x1 x2
                     using quasi_isometry_onD(1)[OF assms(2)] that \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> \<open>x \<in> {yM..uM}\<close> \<open>yM \<in> {z..uM}\<close> \<open>uM \<in> {z..b}\<close> \<open>z \<in> {a..b}\<close> by auto
                 qed
                 then show ?thesis unfolding QC_def True by auto
               next
                 case False
                 have "dist (q k x) (q k v) \<le> 2 * QC k + 8 * delta + max (5 * deltaG(TYPE('a))) ((4 * exp(1/2 * ln 2)) * lambda * (v - x) * exp(-(dM * 2^k - QC k - C/2) * ln 2 / (5 * delta)))"
                 proof (rule quasiconvex_projection_exp_contracting[where ?G = "V k" and ?f = f])
                   show "quasiconvex (QC k) (V k)" by fact
                   show "x \<le> v" using \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> by auto
                   show "q k v \<in> proj_set (f v) (V k)"
                     unfolding q_def V_def apply (rule proj_set_thickening)
                     using aux p[of v] x(3)[of v] \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> by (auto simp add: metric_space_class.dist_commute)
                   show "q k x \<in> proj_set (f x) (V k)"
                     unfolding q_def V_def apply (rule proj_set_thickening)
                     using aux p[of x] x(3)[of x] \<open>w \<in> {x..uM}\<close> by (auto simp add: metric_space_class.dist_commute)
                   show "15/2 * delta + QC k + C/2 \<le> dM * 2^k"
                     apply (rule order_trans[of _ dM])
                     using I \<open>delta > 0\<close> \<open>C \<ge> 0\<close> Laux unfolding QC_def by auto
                   show "deltaG TYPE('a) < delta" by fact
                   show "\<And>t. t \<in> {x..v} \<Longrightarrow> dM * 2 ^ k \<le> infdist (f t) (V k)"
                     using aux4 by auto
                   show "0 \<le> C" "0 \<le> lambda" using \<open>C \<ge> 0\<close> \<open>lambda \<ge> 1\<close> by auto
                   show "dist (f x1) (f x2) \<le> lambda * dist x1 x2 + C" if "x1 \<in> {x..v}" "x2 \<in> {x..v}" for x1 x2
                     using quasi_isometry_onD(1)[OF assms(2)] that \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> \<open>x \<in> {yM..uM}\<close> \<open>yM \<in> {z..uM}\<close> \<open>uM \<in> {z..b}\<close> \<open>z \<in> {a..b}\<close> by auto
                 qed
                 then show ?thesis unfolding QC_def using False by (auto simp add: algebra_simps)
               qed
               finally have "L - 13 * delta \<le> max (5 * deltaG(TYPE('a))) ((4 * exp(1/2 * ln 2)) * lambda * (v - x) * exp(-(dM * 2^k - C/2 - QC k) * ln 2 / (5 * delta)))"
                 by auto
               then have "L - 13 * delta \<le> (4 * exp(1/2 * ln 2)) * lambda * (v - x) * exp(-(dM * 2^k - C/2 - QC k) * ln 2 / (5 * delta))"
                 using \<open>delta > deltaG(TYPE('a))\<close> Laux by auto
               also have "... \<le> (4 * exp(1/2 * ln 2)) * lambda * (v - x) * exp(-((1-alpha) * D + alpha * 2^k * dM) * ln 2 / (5 * delta))"
                 apply (intro mono_intros) using aux3 \<open>delta > 0\<close> \<open>lambda \<ge> 1\<close> \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> by auto
               also have "... = (4 * exp(1/2 * ln 2)) * lambda * (v - x) * (exp(-(1-alpha) * D * ln 2 / (5 * delta)) * exp(-alpha * 2^k * dM * ln 2 / (5 * delta)))"
                 unfolding mult_exp_exp by (auto simp add: algebra_simps divide_simps)
               finally have A: "L - 13 * delta \<le> (4 * exp(1/2 * ln 2)) * lambda * exp(-(1-alpha) * D * ln 2 / (5 * delta)) * ((v - x) * exp(-alpha * 2^k * dM * ln 2 / (5 * delta)))"
                 by (simp add: algebra_simps)
 
               also have "... \<le> (4 * exp(1/2 * ln 2)) * lambda * exp 0 * ((v - x) * exp 0)"
                 apply (intro mono_intros) using \<open>delta > 0\<close> \<open>lambda \<ge> 1\<close> \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> alphaaux \<open>D > 0\<close> \<open>C \<ge> 0\<close> I
                 by (auto simp add: divide_simps mult_nonpos_nonneg)
               also have "... = (4 * exp(1/2 * ln 2)) * lambda * (v - x)"
                 by simp
               also have "... \<le> 20 * lambda * (v - x)"
                 apply (intro mono_intros, approximation 10)
                 using \<open>delta > 0\<close> \<open>lambda \<ge> 1\<close> \<open>v \<in> {w..uM}\<close> \<open>w \<in> {x..uM}\<close> by auto
               finally have "v - x \<ge> (1/4) * delta / lambda"
                 using \<open>lambda \<ge> 1\<close> L_def \<open>delta > 0\<close> by (simp add: divide_simps algebra_simps)
               then have "x - closestm + (1/4) * delta / lambda \<le> v - closestm"
                 by simp
               also have "... \<le> uM - um"
                 using \<open>closestm \<in> {um..ym}\<close> \<open>v \<in> {w..uM}\<close> by auto
               also have "... \<le> Suc n * (1/4) * delta / lambda" by fact
               finally have "x - closestm \<le> n * (1/4) * delta / lambda"
                 unfolding Suc_eq_plus1 by (auto simp add: algebra_simps add_divide_distrib)
 
               have "L + 4 * delta = ((L + 4 * delta)/(L - 13 * delta)) * (L - 13 * delta)"
                 using Laux \<open>delta > 0\<close> by (simp add: algebra_simps divide_simps)
               also have "... \<le> ((L + 4 * delta)/(L - 13 * delta)) * ((4 * exp(1/2 * ln 2)) * lambda * exp (- (1 - alpha) * D * ln 2 / (5 * delta)) * ((v - x) * exp (- alpha * 2 ^ k * dM * ln 2 / (5 * delta))))"
                 apply (rule mult_left_mono) using A Laux \<open>delta > 0\<close> by (auto simp add: divide_simps)
               also have "... \<le> ((L + 4 * delta)/(L - 13 * delta)) * ((4 * exp(1/2 * ln 2)) * lambda * exp (- (1 - alpha) * D * ln 2 / (5 * delta)) * ((exp(-K * (x - closestm)) - exp(-K * (uM - um)))/K))"
                 apply (intro mono_intros B) using Laux \<open>delta > 0\<close> \<open>lambda \<ge> 1\<close> by (auto simp add: divide_simps)
               finally have C: "L + 4 * delta \<le> Kmult * (exp(-K * (x - closestm)) - exp(-K * (uM - um)))"
                 unfolding Kmult_def by argo
 
               have "Gromov_product_at (f z) (f um) (f uM) \<le> Gromov_product_at (f z) (f closestm) (f x) + (L + 4 * delta)"
                 apply (rule Rec) using \<open>closestm \<in> {um..ym}\<close> \<open>x \<in> {yM..uM}\<close> \<open>yM \<in> {z..uM}\<close> by auto
               also have "... \<le> (lambda^2 * (D + 3/2 * L + delta + 11/2 * C) - 2 * delta + Kmult * (1 - exp(- K * (x - closestm)))) + (Kmult * (exp(-K * (x - closestm)) - exp(-K * (uM-um))))"
                 apply (intro mono_intros C Suc.IH)
                 using \<open>x \<in> {yM..uM}\<close> \<open>yM \<in> {z..uM}\<close> \<open>um \<in> {a..z}\<close> \<open>closestm \<in> {um..ym}\<close> \<open>ym \<in> {um..z}\<close> \<open>uM \<in> {z..b}\<close> \<open>x - closestm \<le> n * (1/4) * delta / lambda\<close> by auto
               also have "... = (lambda^2 * (D + 3/2 * L + delta + 11/2 * C) - 2 * delta + Kmult * (1 - exp(- K * (uM - um))))"
                 unfolding K_def by (simp add: algebra_simps)
               finally show ?thesis by auto
             next
               case False
               have "\<exists>w\<in>{yM..uM}. (\<forall>r\<in>{w..uM}. (2 ^ (Suc k + 1) - 1) * dM \<le> dist (f r) (p r)) \<and> L - 4 * delta + 7 * QC (Suc k) \<le> dist (q (Suc k) uM) (q (Suc k) w)"
               proof (rule bexI[of _ w], auto)
                 show "w \<le> uM" "yM \<le> w" using \<open>w \<in> {x..uM}\<close> \<open>x \<in> {yM..uM}\<close> by auto
                 show "(4 * 2 ^ k - 1) * dM \<le> dist (f x) (p x)" if "x \<le> uM" "w \<le> x" for x
                   using False \<open>dM \<ge> 0\<close> that by force
 
                 have "dist (q k uM) (q (k+1) uM) = 2^k * dM"
                   unfolding q_def apply (subst geodesic_segment_param(7)[where ?y = "f uM"])
                   using x(3)[of uM] \<open>x \<in> {yM..uM}\<close> aux by (auto simp add: metric_space_class.dist_commute, simp add: algebra_simps)
                 have "dist (q k w) (q (k+1) w) = 2^k * dM"
                   unfolding q_def apply (subst geodesic_segment_param(7)[where ?y = "f w"])
                   using x(3)[of w] \<open>w \<in> {x..uM}\<close> \<open>x \<in> {yM..uM}\<close> aux by (auto simp add: metric_space_class.dist_commute, simp add: algebra_simps)
                 have i: "q k uM \<in> proj_set (q (k+1) uM) (V k)"
                   unfolding q_def V_def apply (rule proj_set_thickening'[of _ "f uM"])
                   using p x(3)[of uM] \<open>x \<in> {yM..uM}\<close> aux by (auto simp add: algebra_simps metric_space_class.dist_commute)
                 have j: "q k w \<in> proj_set (q (k+1) w) (V k)"
                   unfolding q_def V_def apply (rule proj_set_thickening'[of _ "f w"])
                   using p x(3)[of w] \<open>x \<in> {yM..uM}\<close> \<open>w \<in> {x..uM}\<close> aux by (auto simp add: algebra_simps metric_space_class.dist_commute)
 
                 have "5 * delta + 2 * QC k \<le> dist (q k uM) (q k w)" using w(2) by simp
                 also have "... \<le> max (5 * deltaG(TYPE('a)) + 2 * QC k)
                                       (dist (q (k + 1) uM) (q (k + 1) w) - dist (q k uM) (q (k + 1) uM) - dist (q k w) (q (k + 1) w) + 10 * deltaG(TYPE('a)) + 4 * QC k)"
                   by (rule proj_along_quasiconvex_contraction[OF \<open>quasiconvex (QC k) (V k)\<close> i j])
                 finally have "5 * delta + 2 * QC k \<le> dist (q (k + 1) uM) (q (k + 1) w) - dist (q k uM) (q (k + 1) uM) - dist (q k w) (q (k + 1) w) + 10 * deltaG(TYPE('a)) + 4 * QC k"
                   using \<open>deltaG(TYPE('a)) < delta\<close> by auto
                 then have "0 \<le> dist (q (k + 1) uM) (q (k + 1) w) + 5 * delta + 2 * QC k - dist (q k uM) (q (k + 1) uM) - dist (q k w) (q (k + 1) w)"
                   using \<open>deltaG(TYPE('a)) < delta\<close> by auto
                 also have "... = dist (q (k + 1) uM) (q (k + 1) w) + 5 * delta + 2 * QC k - 2^(k+1) * dM"
                   by (simp only: \<open>dist (q k w) (q (k+1) w) = 2^k * dM\<close> \<open>dist (q k uM) (q (k+1) uM) = 2^k * dM\<close>, auto)
                 finally have *: "2^(k+1) * dM - 5 * delta - 2 * QC k \<le> dist (q (k+1) uM) (q (k+1) w)"
                   using \<open>deltaG(TYPE('a)) < delta\<close> by auto
                 have "L - 4 * delta + 7 * QC (k+1) \<le> 2 * dM - 5 * delta - 2 * QC k"
                   unfolding QC_def L_def using \<open>delta > 0\<close> Laux I \<open>C \<ge> 0\<close> by auto
                 also have "... \<le> 2^(k+1) * dM - 5 * delta - 2 * QC k"
                   using aux by (auto simp add: algebra_simps)
                 finally show "L - 4 * delta + 7 * QC (Suc k) \<le> dist (q (Suc k) uM) (q (Suc k) w)"
                   using * by auto
               qed
               then show ?thesis
                 by simp
             qed
           qed
         qed
         have "dM > 0" using I \<open>delta > 0\<close> \<open>C \<ge> 0\<close> Laux by auto
         have "\<exists>k. 2^k > dist (f uM) (p uM)/dM + 1"
           by (simp add: real_arch_pow)
         then obtain k where "2^k > dist (f uM) (p uM)/dM + 1"
           by blast
         then have "dist (f uM) (p uM) < (2^k - 1) * dM"
           using \<open>dM > 0\<close> by (auto simp add: divide_simps algebra_simps)
         also have "... \<le> (2^(Suc k) - 1) * dM"
           by (intro mono_intros, auto)
         finally have "\<not>((2 ^ (k + 1) - 1) * dM \<le> dist (f uM) (p uM))"
           by simp
         then show "Gromov_product_at (f z) (f um) (f uM) \<le> lambda\<^sup>2 * (D + 3/2 * L + delta + 11/2 * C) - 2 * delta + Kmult * (1 - exp (- K * (uM - um)))"
           using Ind_k[of k] by auto
       qed
     qed
   qed
   text \<open>The main induction is over. To conclude, one should apply its result to the original
   geodesic segment joining the points $f(a)$ and $f(b)$.\<close>
   obtain n::nat where "(b - a)/((1/4) * delta / lambda) \<le> n"
     using real_arch_simple by blast
   then have "b - a \<le> n * (1/4) * delta / lambda"
     using \<open>delta > 0\<close> \<open>lambda \<ge> 1\<close> by (auto simp add: divide_simps)
   have "infdist (f z) G \<le> Gromov_product_at (f z) (f a) (f b) + 2 * deltaG(TYPE('a))"
     apply (intro mono_intros) using assms by auto
   also have "... \<le> (lambda^2 * (D + 3/2 * L + delta + 11/2 * C) - 2 * delta + Kmult * (1 - exp(-K * (b - a)))) + 2 * delta"
     apply (intro mono_intros Main[OF _ _ \<open>b - a \<le> n * (1/4) * delta / lambda\<close>]) using assms by auto
   also have "... = lambda^2 * (D + 3/2 * L + delta + 11/2 * C) + Kmult * (1 - exp(-K * (b - a)))"
     by simp
   also have "... \<le> lambda^2 * (D + 3/2 * L + delta + 11/2 * C) + Kmult * (1 - 0)"
     apply (intro mono_intros) using \<open>Kmult > 0\<close> by auto
   also have "... = lambda^2 * (11/2 * C + (3200*exp(-459/50*ln 2)/ln 2 + 83) * delta)"
     unfolding Kmult_def K_def L_def alpha_def D_def using \<open>delta > 0\<close> \<open>lambda \<ge> 1\<close> by (simp add: algebra_simps divide_simps power2_eq_square mult_exp_exp)
   also have "... \<le> lambda^2 * (11/2 * C + 91 * delta)"
     apply (intro mono_intros, simp add: divide_simps, approximation 14)
     using \<open>delta > 0\<close> by auto
   finally show ?thesis by (simp add: algebra_simps)
 qed
 
 text \<open>Still assuming that our quasi-isometry is Lipschitz, we will improve slightly on the previous
 result, first going down to the hyperbolicity constant of the space, and also showing that,
 conversely, the geodesic is contained in a neighborhood of the quasi-geodesic. The argument for this
 last point goes as follows. Consider a point $x$ on the geodesic. Define two sets to
 be the $D$-thickenings of $[a,x]$ and $[x,b]$ respectively, where $D$ is such that any point on the
 quasi-geodesic is within distance $D$ of the geodesic (as given by the previous theorem). The union
 of these two sets covers the quasi-geodesic, and they are both closed and nonempty. By connectedness,
 there is a point $z$ in their intersection, $D$-close both to a point $x^-$ before $x$ and to a point
 $x^+$ after $x$. Then $x$ belongs to a geodesic between $x^-$ and $x^+$, which is contained in a
 $4\delta$-neighborhood of geodesics from $x^+$ to $z$ and from $x^-$ to $z$ by hyperbolicity. It
 follows that $x$ is at distance at most $D + 4\delta$ of $z$, concluding the proof.\<close>
 
 lemma (in Gromov_hyperbolic_space_geodesic) Morse_Gromov_theorem_aux2:
   fixes f::"real \<Rightarrow> 'a"
   assumes "continuous_on {a..b} f"
           "lambda C-quasi_isometry_on {a..b} f"
           "geodesic_segment_between G (f a) (f b)"
   shows "hausdorff_distance (f`{a..b}) G \<le> lambda^2 * (11/2 * C + 92 * deltaG(TYPE('a)))"
 proof (cases "a \<le> b")
   case True
   have "lambda \<ge> 1" "C \<ge> 0" using quasi_isometry_onD[OF assms(2)] by auto
   have *: "infdist (f z) G \<le> lambda^2 * (11/2 * C + 91 * delta)" if "z \<in> {a..b}" "delta > deltaG(TYPE('a))" for z delta
     by (rule Morse_Gromov_theorem_aux1[OF assms(1) assms(2) True assms(3) that])
   define D where "D = lambda^2 * (11/2 * C + 91 * deltaG(TYPE('a)))"
   have "D \<ge> 0" unfolding D_def using \<open>C \<ge> 0\<close> by auto
   have I: "infdist (f z) G \<le> D" if "z \<in> {a..b}" for z
   proof -
     have "(infdist (f z) G/ lambda^2 - 11/2 * C)/91 \<le> delta" if "delta > deltaG(TYPE('a))" for delta
       using *[OF \<open>z \<in> {a..b}\<close> that] \<open>lambda \<ge> 1\<close> by (auto simp add: divide_simps algebra_simps)
     then have "(infdist (f z) G/ lambda^2 - 11/2 * C)/91 \<le> deltaG(TYPE('a))"
       using dense_ge by blast
     then show ?thesis unfolding D_def using \<open>lambda \<ge> 1\<close> by (auto simp add: divide_simps algebra_simps)
   qed
   show ?thesis
   proof (rule hausdorff_distanceI)
     show "0 \<le> lambda\<^sup>2 * (11/2 * C + 92 * deltaG TYPE('a))" using \<open>C \<ge> 0\<close> by auto
     fix x assume "x \<in> f`{a..b}"
     then obtain z where z: "x = f z" "z \<in> {a..b}" by blast
     show "infdist x G \<le> lambda\<^sup>2 * (11/2 * C + 92 * deltaG TYPE('a))"
       unfolding z(1) by (rule order_trans[OF I[OF \<open>z \<in> {a..b}\<close>]], auto simp add: algebra_simps D_def)
   next
     fix x assume "x \<in> G"
     have "infdist x (f`{a..b}) \<le> D + 1 * deltaG TYPE('a)"
     proof -
       define p where "p = geodesic_segment_param G (f a)"
       then have p: "p 0 = f a" "p (dist (f a) (f b)) = f b"
         unfolding p_def using assms(3) by auto
       obtain t where t: "x = p t" "t \<in> {0..dist (f a) (f b)}"
         unfolding p_def using \<open>x \<in> G\<close> \<open>geodesic_segment_between G (f a) (f b)\<close> by (metis geodesic_segment_param(5) imageE)
       define Km where "Km = (\<Union>z \<in> p`{0..t}. cball z D)"
       define KM where "KM = (\<Union>z \<in> p`{t..dist (f a) (f b)}. cball z D)"
       have "f`{a..b} \<subseteq> Km \<union> KM"
       proof
         fix x assume x: "x \<in> f`{a..b}"
         have "\<exists>z \<in> G. infdist x G = dist x z"
           apply (rule infdist_proper_attained)
           using geodesic_segment_topology[OF geodesic_segmentI[OF assms(3)]] by auto
         then obtain z where z: "z \<in> G" "infdist x G = dist x z"
           by auto
         obtain tz where tz: "z = p tz" "tz \<in> {0..dist (f a) (f b)}"
           unfolding p_def using \<open>z \<in> G\<close> \<open>geodesic_segment_between G (f a) (f b)\<close> by (metis geodesic_segment_param(5) imageE)
         have "infdist x G \<le> D"
           using I \<open>x \<in> f`{a..b}\<close> by auto
         then have "dist z x \<le> D"
           using z(2) by (simp add: metric_space_class.dist_commute)
         then show "x \<in> Km \<union> KM"
           unfolding Km_def KM_def using tz by force
       qed
       then have *: "f`{a..b} = (Km \<inter> f`{a..b}) \<union> (KM \<inter> f`{a..b})" by auto
       have "(Km \<inter> f`{a..b}) \<inter> (KM \<inter> f`{a..b}) \<noteq> {}"
       proof (rule connected_as_closed_union[OF _ *])
         have "closed (f ` {a..b})"
           apply (intro compact_imp_closed compact_continuous_image) using assms(1) by auto
         have "closed Km"
           unfolding Km_def apply (intro compact_has_closed_thickening compact_continuous_image)
           apply (rule continuous_on_subset[of "{0..dist (f a) (f b)}" p])
           unfolding p_def using assms(3) \<open>t \<in> {0..dist (f a) (f b)}\<close> by (auto simp add: isometry_on_continuous)
         then show "closed (Km \<inter> f`{a..b})"
           by (rule topological_space_class.closed_Int) fact
 
         have "closed KM"
           unfolding KM_def apply (intro compact_has_closed_thickening compact_continuous_image)
           apply (rule continuous_on_subset[of "{0..dist (f a) (f b)}" p])
           unfolding p_def using assms(3) \<open>t \<in> {0..dist (f a) (f b)}\<close> by (auto simp add: isometry_on_continuous)
         then show "closed (KM \<inter> f`{a..b})"
           by (rule topological_space_class.closed_Int) fact
 
         show "connected (f`{a..b})"
           apply (rule connected_continuous_image) using assms(1) by auto
         have "f a \<in> Km \<inter> f`{a..b}" using True apply auto
           unfolding Km_def apply auto apply (rule bexI[of _ 0])
           unfolding p using \<open>D \<ge> 0\<close> t(2) by auto
         then show "Km \<inter> f`{a..b} \<noteq> {}" by auto
         have "f b \<in> KM \<inter> f`{a..b}" apply auto
           unfolding KM_def apply auto apply (rule bexI[of _ "dist (f a) (f b)"])
           unfolding p using \<open>D \<ge> 0\<close> t(2) True by auto
         then show "KM \<inter> f`{a..b} \<noteq> {}" by auto
       qed
       then obtain y where y: "y \<in> f`{a..b}" "y \<in> Km" "y \<in> KM" by auto
       obtain tm where tm: "tm \<in> {0..t}" "dist (p tm) y \<le> D"
         using y(2) unfolding Km_def by auto
       obtain tM where tM: "tM \<in> {t..dist (f a) (f b)}" "dist (p tM) y \<le> D"
         using y(3) unfolding KM_def by auto
       define H where "H = p`{tm..tM}"
       have *: "geodesic_segment_between H (p tm) (p tM)"
         unfolding H_def p_def apply (rule geodesic_segmentI2)
         using assms(3) \<open>tm \<in> {0..t}\<close> \<open>tM \<in> {t..dist (f a) (f b)}\<close> isometry_on_subset
         using assms(3) geodesic_segment_param(4) by (auto) fastforce
       have "x \<in> H"
         unfolding t(1) H_def using \<open>tm \<in> {0..t}\<close> \<open>tM \<in> {t..dist (f a) (f b)}\<close> by auto
       have "infdist x (f ` {a..b}) \<le> dist x y"
         by (rule infdist_le[OF y(1)])
       also have "... \<le> max (dist (p tm) y) (dist (p tM) y) + deltaG(TYPE('a))"
         by (rule dist_le_max_dist_triangle[OF * \<open>x \<in> H\<close>])
       finally show ?thesis
         using tm(2) tM(2) by auto
     qed
     also have "... \<le> D + lambda^2 * deltaG TYPE('a)"
       apply (intro mono_intros) using \<open>lambda \<ge> 1\<close> by auto
     finally show "infdist x (f ` {a..b}) \<le> lambda\<^sup>2 * (11/2 * C + 92 * deltaG TYPE('a))"
       unfolding D_def by (simp add: algebra_simps)
   qed
 next
   case False
   then have "f`{a..b} = {}"
     by auto
   then have "hausdorff_distance (f ` {a..b}) G = 0"
     unfolding hausdorff_distance_def by auto
   then show ?thesis
     using quasi_isometry_onD(4)[OF assms(2)] by auto
 qed
 
 text \<open>The full statement of the Morse-Gromov Theorem, asserting that a quasi-geodesic is
 within controlled distance of a geodesic with the same endpoints. It is given in the formulation
 of Shchur~\cite{shchur}, with optimal control in terms of the parameters of the quasi-isometry.
 This statement follows readily from the previous one and from the fact that quasi-geodesics can be
 approximated by Lipschitz ones.\<close>
 
 theorem (in Gromov_hyperbolic_space_geodesic) Morse_Gromov_theorem:
   fixes f::"real \<Rightarrow> 'a"
   assumes "lambda C-quasi_isometry_on {a..b} f"
           "geodesic_segment_between G (f a) (f b)"
   shows "hausdorff_distance (f`{a..b}) G \<le> 92 * lambda^2 * (C + deltaG(TYPE('a)))"
 proof -
   have C: "C \<ge> 0" "lambda \<ge> 1" using quasi_isometry_onD[OF assms(1)] by auto
   consider "dist (f a) (f b) \<ge> 2 * C \<and> a \<le> b" | "dist (f a) (f b) \<le> 2 * C \<and> a \<le> b" | "b < a"
     by linarith
   then show ?thesis
   proof (cases)
     case 1
     have "\<exists>d. continuous_on {a..b} d \<and> d a = f a \<and> d b = f b
                 \<and> (\<forall>x\<in>{a..b}. dist (f 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 (f`{a..b}) (d`{a..b}) \<le> 2 * C"
       apply (rule quasi_geodesic_made_lipschitz[OF assms(1)]) using 1 by auto
     then obtain d where d: "d a = f a" "d b = f b"
                         "\<And>x. x \<in> {a..b} \<Longrightarrow> dist (f x) (d x) \<le> 4 * C"
                         "lambda (4 * C)-quasi_isometry_on {a..b} d"
                         "(2 * lambda)-lipschitz_on {a..b} d"
                         "hausdorff_distance (f`{a..b}) (d`{a..b}) \<le> 2 * C"
       by auto
     have a: "hausdorff_distance (d`{a..b}) G \<le> lambda^2 * ((11/2) * (4 * C) + 92 * deltaG(TYPE('a)))"
       apply (rule Morse_Gromov_theorem_aux2) using d assms lipschitz_on_continuous_on by auto
 
     have "hausdorff_distance (f`{a..b}) G \<le>
           hausdorff_distance (f`{a..b}) (d`{a..b}) + hausdorff_distance (d`{a..b}) G"
       apply (rule hausdorff_distance_triangle)
       using 1 apply simp
       by (rule quasi_isometry_on_bounded[OF d(4)], auto)
     also have "... \<le> lambda^2 * ((11/2) * (4 * C) + 92 * deltaG(TYPE('a))) + 1 * 2 * C"
       using a d by auto
     also have "... \<le> lambda^2 * ((11/2) * (4 * C) + 92 * deltaG(TYPE('a))) + lambda^2 * 2 * C"
       apply (intro mono_intros) using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> by auto
     also have "... = lambda^2 * (24 * C + 92 * deltaG(TYPE('a)))"
       by (simp add: algebra_simps divide_simps)
     also have "... \<le> lambda^2 * (92 * C + 92 * deltaG(TYPE('a)))"
       apply (intro mono_intros) using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> by auto
     finally show ?thesis by (auto simp add: algebra_simps)
   next
     case 2
     have "(1/lambda) * dist a b - C \<le> dist (f a) (f b)"
       apply (rule quasi_isometry_onD[OF assms(1)]) using 2 by auto
     also have "... \<le> 2 * C" using 2 by auto
     finally have "dist a b \<le> 3 * lambda * C"
       using C by (auto simp add: algebra_simps divide_simps)
     then have *: "b - a \<le> 3 * lambda * C" using 2 unfolding dist_real_def by auto
     show ?thesis
     proof (rule hausdorff_distanceI2)
       show "0 \<le> 92 * lambda\<^sup>2 * (C + deltaG TYPE('a))" using C by auto
       fix x assume "x \<in> f`{a..b}"
       then obtain t where t: "x = f t" "t \<in> {a..b}" by auto
       have "dist x (f a) \<le> lambda * dist t a + C"
         unfolding t(1) using quasi_isometry_onD(1)[OF assms(1) t(2)] 2 by auto
       also have "... \<le> lambda * (b - a) + 1 * 1 * C + 0 * 0 * deltaG(TYPE('a))" using t(2) 2 C unfolding dist_real_def by auto
       also have "... \<le> lambda * (3 * lambda * C) + lambda^2 * (92-3) * C + lambda^2 * 92 * deltaG(TYPE('a))"
         apply (intro mono_intros *) using C by auto
       finally have *: "dist x (f a) \<le> 92 * lambda\<^sup>2 * (C + deltaG TYPE('a))"
         by (simp add: algebra_simps power2_eq_square)
       show "\<exists>y\<in>G. dist x y \<le> 92 * lambda\<^sup>2 * (C + deltaG TYPE('a))"
         apply (rule bexI[of _ "f a"]) using * 2 assms(2) by auto
     next
       fix x assume "x \<in> G"
       then have "dist x (f a) \<le> dist (f a) (f b)"
         by (meson assms geodesic_segment_dist_le geodesic_segment_endpoints(1) local.some_geodesic_is_geodesic_segment(1))
       also have "... \<le> 1 * 2 * C + lambda^2 * 0 * deltaG(TYPE('a))"
         using 2 by auto
       also have "... \<le> lambda^2 * 92 * C + lambda^2 * 92 * deltaG(TYPE('a))"
         apply (intro mono_intros) using C by auto
       finally have *: "dist x (f a) \<le> 92 * lambda\<^sup>2 * (C + deltaG TYPE('a))"
         by (simp add: algebra_simps)
       show "\<exists>y\<in>f`{a..b}. dist x y \<le> 92 * lambda\<^sup>2 * (C + deltaG TYPE('a))"
         apply (rule bexI[of _ "f a"]) using * 2 by auto
     qed
   next
     case 3
     then have "hausdorff_distance (f ` {a..b}) G = 0"
       unfolding hausdorff_distance_def by auto
     then show ?thesis
       using C by auto
   qed
 qed
 
 text \<open>This theorem implies the same statement for two quasi-geodesics sharing their endpoints.\<close>
 
 theorem (in Gromov_hyperbolic_space_geodesic) Morse_Gromov_theorem2:
   fixes c d::"real \<Rightarrow> 'a"
   assumes "lambda C-quasi_isometry_on {A..B} c"
           "lambda C-quasi_isometry_on {A..B} d"
           "c A = d A" "c B = d B"
   shows "hausdorff_distance (c`{A..B}) (d`{A..B}) \<le> 184 * lambda^2 * (C + deltaG(TYPE('a)))"
 proof (cases "A \<le> B")
   case False
   then have "hausdorff_distance (c`{A..B}) (d`{A..B}) = 0" by auto
   then show ?thesis using quasi_isometry_onD[OF assms(1)] delta_nonneg by auto
 next
   case True
   have "hausdorff_distance (c`{A..B}) {c A--c B} \<le> 92 * lambda^2 * (C + deltaG(TYPE('a)))"
     by (rule Morse_Gromov_theorem[OF assms(1)], auto)
   moreover have "hausdorff_distance {c A--c B} (d`{A..B}) \<le> 92 * lambda^2 * (C + deltaG(TYPE('a)))"
     unfolding \<open>c A = d A\<close> \<open>c B = d B\<close> apply (subst hausdorff_distance_sym)
     by (rule Morse_Gromov_theorem[OF assms(2)], auto)
   moreover have "hausdorff_distance (c`{A..B}) (d`{A..B}) \<le> hausdorff_distance (c`{A..B}) {c A--c B} + hausdorff_distance {c A--c B} (d`{A..B})"
     apply (rule hausdorff_distance_triangle)
     using True compact_imp_bounded[OF some_geodesic_compact] by auto
   ultimately show ?thesis by auto
 qed
 
 text \<open>We deduce from the Morse lemma that hyperbolicity is invariant under quasi-isometry.\<close>
 
 text \<open>First, we note that the image of a geodesic segment under a quasi-isometry is close to
 a geodesic segment in Hausdorff distance, as it is a quasi-geodesic.\<close>
 
 lemma geodesic_quasi_isometric_image:
   fixes f::"'a::metric_space \<Rightarrow> 'b::Gromov_hyperbolic_space_geodesic"
   assumes "lambda C-quasi_isometry_on UNIV f"
           "geodesic_segment_between G x y"
   shows "hausdorff_distance (f`G) {f x--f y} \<le> 92 * lambda^2 * (C + deltaG(TYPE('b)))"
 proof -
   define c where "c = f o (geodesic_segment_param G x)"
   have *: "(1 * lambda) (0 * lambda + C)-quasi_isometry_on {0..dist x y} c"
     unfolding c_def by (rule quasi_isometry_on_compose[where Y = UNIV], auto intro!: isometry_quasi_isometry_on simp add: assms)
   have "hausdorff_distance (c`{0..dist x y}) {c 0--c (dist x y)} \<le> 92 * lambda^2 * (C + deltaG(TYPE('b)))"
     apply (rule Morse_Gromov_theorem) using * by auto
   moreover have "c`{0..dist x y} = f`G"
     unfolding c_def image_comp[symmetric] using assms(2) by auto
   moreover have "c 0 = f x" "c (dist x y) = f y"
     unfolding c_def using assms(2) by auto
   ultimately show ?thesis by auto
 qed
 
 text \<open>We deduce that hyperbolicity is invariant under quasi-isometry. The proof goes as follows:
 we want to see that a geodesic triangle is delta-thin, i.e., a point on a side $Gxy$ is close to the
 union of the two other sides $Gxz$ and $Gyz$. Pull everything back by the quasi-isometry: we obtain
 three quasi-geodesic, each of which is close to the corresponding geodesic segment by the Morse lemma.
 As the geodesic triangle is thin, it follows that the quasi-geodesic triangle is also thin, i.e.,
 a point on $f^{-1}Gxy$ is close to $f^{-1}Gxz \cup f^{-1}Gyz$ (for some explicit, albeit large,
 constant). Then push everything forward by $f$: as it is a quasi-isometry, it will again distort
 distances by a bounded amount.\<close>
 
 lemma Gromov_hyperbolic_invariant_under_quasi_isometry_explicit:
   fixes f::"'a::geodesic_space \<Rightarrow> 'b::Gromov_hyperbolic_space_geodesic"
   assumes "lambda C-quasi_isometry f"
   shows "Gromov_hyperbolic_subset (752 * lambda^3 * (C + deltaG(TYPE('b)))) (UNIV::('a set))"
 proof -
   have C: "lambda \<ge> 1" "C \<ge> 0"
     using quasi_isometry_onD[OF assms] by auto
 
   text \<open>The Morse lemma gives a control bounded by $K$ below. Following the proof, we deduce
   a bound on the thinness of triangles by an ugly constant $L$. We bound it by a more tractable
   (albeit still ugly) constant $M$.\<close>
   define K where "K = 92 * lambda^2 * (C + deltaG(TYPE('b)))"
   have HD: "hausdorff_distance (f`G) {f a--f b} \<le> K" if "geodesic_segment_between G a b" for G a b
     unfolding K_def by (rule geodesic_quasi_isometric_image[OF assms that])
   define L where "L = lambda * (4 * 1 * deltaG(TYPE('b)) + 1 * 1 * C + 2 * K)"
   define M where "M = 188 * lambda^3 * (C + deltaG(TYPE('b)))"
 
   have "L \<le> lambda * (4 * lambda^2 * deltaG(TYPE('b)) + 4 * lambda^2 * C + 2 * K)"
     unfolding L_def apply (intro mono_intros) using C by auto
   also have "... = M"
     unfolding M_def K_def by (auto simp add: algebra_simps power2_eq_square power3_eq_cube)
   finally have "L \<le> M" by simp
 
   text \<open>After these preliminaries, we start the real argument per se, showing that triangles
   are thin in the type b.\<close>
   have Thin: "infdist w (Gxz \<union> Gyz) \<le> M" if
     H: "geodesic_segment_between Gxy x y" "geodesic_segment_between Gxz x z" "geodesic_segment_between Gyz y z" "w \<in> Gxy"
     for w x y z::'a and Gxy Gyz Gxz
   proof -
     obtain w2 where w2: "w2 \<in> {f x--f y}" "infdist (f w) {f x--f y} = dist (f w) w2"
       using infdist_proper_attained[OF proper_of_compact, of "{f x--f y}" "f w"] by auto
     have "dist (f w) w2 = infdist (f w) {f x-- f y}"
       using w2 by simp
     also have "... \<le> hausdorff_distance (f`Gxy) {f x-- f y}"
       using geodesic_segment_topology(4)[OF geodesic_segmentI] H
       by (auto intro!: quasi_isometry_on_bounded[OF quasi_isometry_on_subset[OF assms]] infdist_le_hausdorff_distance)
     also have "... \<le> K" using HD[OF H(1)] by simp
     finally have *: "dist (f w) w2 \<le> K" by simp
 
     have "infdist w2 (f`Gxz \<union> f`Gyz) \<le> infdist w2 ({f x--f z} \<union> {f y--f z})
                 + hausdorff_distance ({f x--f z} \<union> {f y--f z}) (f`Gxz \<union> f`Gyz)"
       apply (rule hausdorff_distance_infdist_triangle)
       using geodesic_segment_topology(4)[OF geodesic_segmentI] H
       by (auto intro!: quasi_isometry_on_bounded[OF quasi_isometry_on_subset[OF assms]])
     also have "... \<le> 4 * deltaG(TYPE('b)) + hausdorff_distance ({f x--f z} \<union> {f y--f z}) (f`Gxz \<union> f`Gyz)"
       apply (simp, rule thin_triangles[of "{f x--f z}" "f z" "f x" "{f y--f z}" "f y" "{f x--f y}" w2])
       using w2 apply auto
       using geodesic_segment_commute some_geodesic_is_geodesic_segment(1) by blast+
     also have "... \<le> 4 * deltaG(TYPE('b)) + max (hausdorff_distance {f x--f z} (f`Gxz)) (hausdorff_distance {f y--f z} (f`Gyz))"
       apply (intro mono_intros) using H by auto
     also have "... \<le> 4 * deltaG(TYPE('b)) + K"
       using HD[OF H(2)] HD[OF H(3)] by (auto simp add: hausdorff_distance_sym)
     finally have **: "infdist w2 (f`Gxz \<union> f`Gyz) \<le> 4 * deltaG(TYPE('b)) + K" by simp
 
     have "infdist (f w) (f`Gxz \<union> f`Gyz) \<le> infdist w2 (f`Gxz \<union> f`Gyz) + dist (f w) w2"
       by (rule infdist_triangle)
     then have A: "infdist (f w) (f`(Gxz \<union> Gyz)) \<le> 4 * deltaG(TYPE('b)) + 2 * K"
       using * ** by (auto simp add: image_Un)
 
     have "infdist w (Gxz \<union> Gyz) \<le> L + epsilon" if "epsilon > 0" for epsilon
     proof -
       have *: "epsilon/lambda > 0" using that C by auto
       have "\<exists>z \<in> f`(Gxz \<union> Gyz). dist (f w) z < 4 * deltaG(TYPE('b)) + 2 * K + epsilon/lambda"
         apply (rule infdist_almost_attained)
         using A * H(2) by auto
       then obtain z where z: "z \<in> Gxz \<union> Gyz" "dist (f w) (f z) < 4 * deltaG(TYPE('b)) + 2 * K + epsilon/lambda"
         by auto
 
       have "infdist w (Gxz \<union> Gyz) \<le> dist w z"
         by (auto intro!: infdist_le z(1))
       also have "... \<le> lambda * dist (f w) (f z) + C * lambda"
         using quasi_isometry_onD[OF assms] by (auto simp add: algebra_simps divide_simps)
       also have "... \<le> lambda * (4 * deltaG(TYPE('b)) + 2 * K + epsilon/lambda) + C * lambda"
         apply (intro mono_intros) using z(2) C by auto
       also have "... = L + epsilon"
         unfolding K_def L_def using C by (auto simp add: algebra_simps)
       finally show ?thesis by simp
     qed
     then have "infdist w (Gxz \<union> Gyz) \<le> L"
       using field_le_epsilon by blast
     then show ?thesis
       using \<open>L \<le> M\<close> by auto
   qed
   then have "Gromov_hyperbolic_subset (4 * M) (UNIV::'a set)"
     using thin_triangles_implies_hyperbolic[OF Thin] by auto
   then show ?thesis unfolding M_def by (auto simp add: algebra_simps)
 qed
 
 text \<open>Most often, the precise value of the constant in the previous theorem is irrelevant,
 it is used in the following form.\<close>
 
 theorem Gromov_hyperbolic_invariant_under_quasi_isometry:
   assumes "quasi_isometric (UNIV::('a::geodesic_space) set) (UNIV::('b::Gromov_hyperbolic_space_geodesic) set)"
   shows "\<exists>delta. Gromov_hyperbolic_subset delta (UNIV::'a set)"
 proof -
   obtain C lambda f where f: "lambda C-quasi_isometry_between (UNIV::'a set) (UNIV::'b set) f"
     using assms unfolding quasi_isometric_def by auto
   show ?thesis
     using Gromov_hyperbolic_invariant_under_quasi_isometry_explicit[OF quasi_isometry_betweenD(1)[OF f]] by blast
 qed
 
 
 text \<open>A central feature of hyperbolic spaces is that a path from $x$ to $y$ can not deviate
 too much from a geodesic from $x$ to $y$ unless it is extremely long (exponentially long in
 terms of the distance from $x$ to $y$). This is useful both to ensure that short paths (for instance
 quasi-geodesics) stay close to geodesics, see the Morse lemme below, and to ensure that paths
 that avoid a given large ball of radius $R$ have to be exponentially long in terms of $R$ (this
 is extremely useful for random walks). This proposition is the first non-trivial result
 on hyperbolic spaces in~\cite{bridson_haefliger} (Proposition III.H.1.6). We follow their proof.
 
 The proof is geometric, and uses the existence of geodesics and the fact that geodesic
 triangles are thin. In fact, the result still holds if the space is not geodesic, as
 it can be deduced by embedding the hyperbolic space in a geodesic hyperbolic space and using
 the result there.\<close>
 
 proposition (in Gromov_hyperbolic_space_geodesic) lipschitz_path_close_to_geodesic:
   fixes c::"real \<Rightarrow> 'a"
   assumes "M-lipschitz_on {A..B} c"
           "geodesic_segment_between G (c A) (c B)"
           "x \<in> G"
   shows "infdist x (c`{A..B}) \<le> (4/ln 2) * deltaG(TYPE('a)) * max 0 (ln (B-A)) + M"
 proof -
   have "M \<ge> 0" by (rule lipschitz_on_nonneg[OF assms(1)])
   have Main: "a \<in> {A..B} \<Longrightarrow> b \<in> {A..B} \<Longrightarrow> a \<le> b \<Longrightarrow> b-a \<le> 2^(n+1) \<Longrightarrow> geodesic_segment_between H (c a) (c b)
         \<Longrightarrow> y \<in> H \<Longrightarrow> infdist y (c`{A..B}) \<le> 4 * deltaG(TYPE('a)) * n + M" for a b H y n
   proof (induction n arbitrary: a b H y)
     case 0
     have "infdist y (c ` {A..B}) \<le> dist y (c b)"
       apply (rule infdist_le) using \<open>b \<in> {A..B}\<close> by auto
     moreover have "infdist y (c ` {A..B}) \<le> dist y (c a)"
       apply (rule infdist_le) using \<open>a \<in> {A..B}\<close> by auto
     ultimately have "2 * infdist y (c ` {A..B}) \<le> dist (c a) y + dist y (c b)"
       by (auto simp add: metric_space_class.dist_commute)
     also have "... = dist (c a) (c b)"
       by (rule geodesic_segment_dist[OF \<open>geodesic_segment_between H (c a) (c b)\<close> \<open>y \<in> H\<close>])
     also have "... \<le> M * abs(b - a)"
       using lipschitz_onD(1)[OF assms(1) \<open>a \<in> {A..B}\<close> \<open>b \<in> {A..B}\<close>] unfolding dist_real_def
       by (simp add: abs_minus_commute)
     also have "... \<le> M * 2"
       using \<open>a \<le> b\<close> \<open>b - a \<le> 2^(0 + 1)\<close> \<open>M \<ge> 0\<close> mult_left_mono by auto
     finally show ?case by simp
   next
     case (Suc n)
     define m where "m = (a + b)/2"
     have "m \<in> {A..B}" using \<open>a \<in> {A..B}\<close> \<open>b \<in> {A..B}\<close> unfolding m_def by auto
     define Ha where "Ha = {c m--c a}"
     define Hb where "Hb = {c m--c b}"
     have I: "geodesic_segment_between Ha (c m) (c a)" "geodesic_segment_between Hb (c m) (c b)"
       unfolding Ha_def Hb_def by auto
     then have "Ha \<noteq> {}" "Hb \<noteq> {}" "compact Ha" "compact Hb"
       by (auto intro: geodesic_segment_topology)
 
     have *: "infdist y (Ha \<union> Hb) \<le> 4 * deltaG(TYPE('a))"
       by (rule thin_triangles[OF I \<open>geodesic_segment_between H (c a) (c b)\<close> \<open>y \<in> H\<close>])
     then have "infdist y Ha \<le> 4 * deltaG(TYPE('a)) \<or> infdist y Hb \<le> 4 * deltaG(TYPE('a))"
       unfolding infdist_union_min[OF \<open>Ha \<noteq> {}\<close> \<open>Hb \<noteq> {}\<close>] by auto
     then show ?case
     proof
       assume H: "infdist y Ha \<le> 4 * deltaG TYPE('a)"
       obtain z where z: "z \<in> Ha" "infdist y Ha = dist y z"
         using infdist_proper_attained[OF proper_of_compact[OF \<open>compact Ha\<close>] \<open>Ha \<noteq> {}\<close>] by auto
       have Iz: "infdist z (c`{A..B}) \<le> 4 * deltaG(TYPE('a)) * n + M"
       proof (rule Suc.IH[OF \<open>a \<in> {A..B}\<close> \<open>m \<in> {A..B}\<close>, of Ha])
         show "a \<le> m" unfolding m_def using \<open>a \<le> b\<close> by auto
         show "m - a \<le> 2^(n+1)" using \<open>b - a \<le> 2^(Suc n + 1)\<close> \<open>a \<le> b\<close> unfolding m_def by auto
         show "geodesic_segment_between Ha (c a) (c m)" by (simp add: I(1) geodesic_segment_commute)
         show "z \<in> Ha" using z by auto
       qed
       have "infdist y (c`{A..B}) \<le> dist y z + infdist z (c`{A..B})"
         by (metis add.commute infdist_triangle)
       also have "... \<le> 4 * deltaG TYPE('a) + (4 * deltaG(TYPE('a)) * n + M)"
         using H z Iz by (auto intro: add_mono)
       finally show "infdist y (c ` {A..B}) \<le> 4 * deltaG TYPE('a) * real (Suc n) + M"
         by (auto simp add: algebra_simps)
     next
       assume H: "infdist y Hb \<le> 4 * deltaG TYPE('a)"
       obtain z where z: "z \<in> Hb" "infdist y Hb = dist y z"
         using infdist_proper_attained[OF proper_of_compact[OF \<open>compact Hb\<close>] \<open>Hb \<noteq> {}\<close>] by auto
       have Iz: "infdist z (c`{A..B}) \<le> 4 * deltaG(TYPE('a)) * n + M"
       proof (rule Suc.IH[OF \<open>m \<in> {A..B}\<close> \<open>b \<in> {A..B}\<close>, of Hb])
         show "m \<le> b" unfolding m_def using \<open>a \<le> b\<close> by auto
         show "b - m \<le> 2^(n+1)" using \<open>b - a \<le> 2^(Suc n + 1)\<close> \<open>a \<le> b\<close>
           unfolding m_def by (auto simp add: divide_simps)
         show "geodesic_segment_between Hb (c m) (c b)" by (simp add: I(2))
         show "z \<in> Hb" using z by auto
       qed
       have "infdist y (c`{A..B}) \<le> dist y z + infdist z (c`{A..B})"
         by (metis add.commute infdist_triangle)
       also have "... \<le> 4 * deltaG TYPE('a) + (4 * deltaG(TYPE('a)) * n + M)"
         using H z Iz by (auto intro: add_mono)
       finally show "infdist y (c ` {A..B}) \<le> 4 * deltaG TYPE('a) * real (Suc n) + M"
         by (auto simp add: algebra_simps)
     qed
   qed
   consider "B-A <0" | "B-A \<ge> 0 \<and> B-A \<le> 2" | "B-A > 2" by linarith
   then show ?thesis
   proof (cases)
     case 1
     then have "c`{A..B} = {}" by auto
     then show ?thesis unfolding infdist_def using \<open>M \<ge> 0\<close> by auto
   next
     case 2
     have "infdist x (c`{A..B}) \<le> 4 * deltaG(TYPE('a)) * real 0 + M"
       apply (rule Main[OF _ _ _ _ \<open>geodesic_segment_between G (c A) (c B)\<close> \<open>x \<in> G\<close>])
       using 2 by auto
     also have "... \<le> (4/ln 2) * deltaG(TYPE('a)) * max 0 (ln (B-A)) + M"
       using delta_nonneg by auto
     finally show ?thesis by auto
   next
     case 3
     define n::nat where "n = nat(floor (log 2 (B-A)))"
     have "log 2 (B-A) > 0" using 3 by auto
     then have n: "n \<le> log 2 (B-A)" "log 2 (B-A) < n+1"
       unfolding n_def by (auto simp add: floor_less_cancel)
     then have *: "B-A \<le> 2^(n+1)"
       by (meson le_log_of_power linear not_less one_less_numeral_iff semiring_norm(76))
     have "n \<le> ln (B-A) * (1/ln 2)" using n unfolding log_def by auto
     then have "n \<le> (1/ln 2) * max 0 (ln (B-A))"
       using 3 by (auto simp add: algebra_simps divide_simps)
     have "infdist x (c`{A..B}) \<le> 4 * deltaG(TYPE('a)) * n + M"
       apply (rule Main[OF _ _ _ _ \<open>geodesic_segment_between G (c A) (c B)\<close> \<open>x \<in> G\<close>])
       using * 3 by auto
     also have "... \<le> 4 * deltaG(TYPE('a)) * ((1/ln 2) * max 0 (ln (B-A))) + M"
       apply (intro mono_intros) using \<open>n \<le> (1/ln 2) * max 0 (ln (B-A))\<close> delta_nonneg by auto
     finally show ?thesis by auto
   qed
 qed
 
 text \<open>By rescaling coordinates at the origin, one obtains a variation around the previous
 statement.\<close>
 
 proposition (in Gromov_hyperbolic_space_geodesic) lipschitz_path_close_to_geodesic':
   fixes c::"real \<Rightarrow> 'a"
   assumes "M-lipschitz_on {A..B} c"
           "geodesic_segment_between G (c A) (c B)"
           "x \<in> G"
           "a > 0"
   shows "infdist x (c`{A..B}) \<le> (4/ln 2) * deltaG(TYPE('a)) * max 0 (ln (a * (B-A))) + M/a"
 proof -
   define d where "d = c o (\<lambda>t. (1/a) * t)"
   have *: "(M * ((1/a)* 1))-lipschitz_on {a * A..a * B} d"
     unfolding d_def apply (rule lipschitz_on_compose, intro lipschitz_intros) using assms by auto
   have "d`{a * A..a * B} = c`{A..B}"
     unfolding d_def image_comp[symmetric]
     apply (rule arg_cong[where ?f = "image c"]) using \<open>a > 0\<close> by auto
   then have "infdist x (c`{A..B}) = infdist x (d`{a * A..a * B})" by auto
   also have "... \<le> (4/ln 2) * deltaG(TYPE('a)) * max 0 (ln ((a * B)- (a * A))) + M/a"
     apply (rule lipschitz_path_close_to_geodesic[OF _ _ \<open>x \<in> G\<close>])
     using * assms unfolding d_def by auto
   finally show ?thesis by (auto simp add: algebra_simps)
 qed
 
 text \<open>We can now give another proof of the Morse-Gromov Theorem, as described
 in~\cite{bridson_haefliger}. It is more direct than the one we have given above, but it gives
 a worse dependence in terms of the quasi-isometry constants. In particular, when $C = \delta = 0$,
 it does not recover the fact that a quasi-geodesic has to coincide with a geodesic.\<close>
 
 theorem (in Gromov_hyperbolic_space_geodesic) Morse_Gromov_theorem_BH_proof:
   fixes c::"real \<Rightarrow> 'a"
   assumes "lambda C-quasi_isometry_on {A..B} c"
   shows "hausdorff_distance (c`{A..B}) {c A--c B} \<le> 72 * lambda^2 * (C + lambda + deltaG(TYPE('a))^2)"
 proof -
   have C: "C \<ge> 0" "lambda \<ge> 1" using quasi_isometry_onD[OF assms] by auto
   consider "B-A < 0" | "B-A \<ge> 0 \<and> dist (c A) (c B) \<le> 2 * C" | "B-A \<ge> 0 \<and> dist (c A) (c B) > 2 * C" by linarith
   then show ?thesis
   proof (cases)
     case 1
     then have "c`{A..B} = {}" by auto
     then show ?thesis unfolding hausdorff_distance_def using delta_nonneg C by auto
   next
     case 2
     have "(1/lambda) * dist A B - C \<le> dist (c A) (c B)"
       apply (rule quasi_isometry_onD[OF assms]) using 2 by auto
     also have "... \<le> 2 * C" using 2 by auto
     finally have "dist A B \<le> 3 * lambda * C"
       using C by (auto simp add: algebra_simps divide_simps)
     then have *: "B - A \<le> 3 * lambda * C" using 2 unfolding dist_real_def by auto
     show ?thesis
     proof (rule hausdorff_distanceI2)
       show "0 \<le> 72 * lambda^2 * (C + lambda + deltaG(TYPE('a))^2)" using C by auto
       fix x assume "x \<in> c`{A..B}"
       then obtain t where t: "x = c t" "t \<in> {A..B}" by auto
       have "dist x (c A) \<le> lambda * dist t A + C"
         unfolding t(1) using quasi_isometry_onD(1)[OF assms t(2), of A] 2 by auto
       also have "... \<le> lambda * (B-A) + C" using t(2) 2 C unfolding dist_real_def by auto
       also have "... \<le> 3 * lambda * lambda * C + 1 * 1 * C" using * C by auto
       also have "... \<le> 3 * lambda * lambda * C + lambda * lambda * C"
         apply (intro mono_intros) using C by auto
       also have "... = 4 * lambda * lambda * (C + 0 + 0^2)"
         by auto
       also have "... \<le> 72 * lambda * lambda * (C + lambda + deltaG(TYPE('a))^2)"
         apply (intro mono_intros) using C delta_nonneg by auto
       finally have *: "dist x (c A) \<le> 72 * lambda^2 * (C + lambda + deltaG(TYPE('a))^2)"
         unfolding power2_eq_square by simp
       show "\<exists>y\<in>{c A--c B}. dist x y \<le> 72 * lambda^2 * (C + lambda + deltaG(TYPE('a))^2)"
         apply (rule bexI[of _ "c A"]) using * by auto
     next
       fix x assume "x \<in> {c A-- c B}"
       then have "dist x (c A) \<le> dist (c A) (c B)"
         by (meson geodesic_segment_dist_le geodesic_segment_endpoints(1) local.some_geodesic_is_geodesic_segment(1))
       also have "... \<le> 2 * C"
         using 2 by auto
       also have "... \<le> 2 * 1 * 1 * (C + lambda + 0)" using 2 C unfolding dist_real_def by auto
       also have "... \<le> 72 * lambda * lambda * (C + lambda + deltaG(TYPE('a)) * deltaG(TYPE('a)))"
         apply (intro mono_intros) using C delta_nonneg by auto
       finally have *: "dist x (c A) \<le> 72 * lambda * lambda * (C + lambda + deltaG(TYPE('a)) * deltaG(TYPE('a)))"
         by simp
       show "\<exists>y\<in>c`{A..B}. dist x y \<le> 72 * lambda^2 * (C + lambda + deltaG(TYPE('a))^2)"
         apply (rule bexI[of _ "c A"]) unfolding power2_eq_square using * 2 by auto
     qed
   next
     case 3
     then obtain d where d: "continuous_on {A..B} d" "d A = c A" "d B = c B"
               "\<And>x. x \<in> {A..B} \<Longrightarrow> dist (c x) (d x) \<le> 4 *C"
               "lambda (4 * C)-quasi_isometry_on {A..B} d"
               "(2 * lambda)-lipschitz_on {A..B} d"
               "hausdorff_distance (c`{A..B}) (d`{A..B}) \<le> 2 * C"
       using quasi_geodesic_made_lipschitz[OF assms] C(1) by fastforce
 
     have "A \<in> {A..B}" "B \<in> {A..B}" using 3 by auto
 
     text \<open>We show that the distance of any point in the geodesic from $c(A)$ to $c(B)$ is a bounded
     distance away from the quasi-geodesic $d$, by considering a point $x$ where the distance $D$ is
     maximal and arguing around this point.
 
     Consider the point $x_m$ on the geodesic $[c(A), c(B)]$ at distance $2D$ from $x$, and the closest
     point $y_m$ on the image of $d$. Then the distance between $x_m$ and $y_m$ is at most $D$. Hence
     a point on $[x_m,y_m]$ is at distance at least $2D - D = D$ of $x$. In the same way, define $x_M$
     and $y_M$ on the other side of $x$. Then the excursion from $x_m$ to $y_m$, then to $y_M$ along
     $d$, then to $x_M$, has length at most $D + (\lambda \cdot 6D + C) + D$ and is always at distance
     at least $D$ from $x$. It follows from the previous lemma that $D \leq \log(length)$, which
     implies a bound on $D$.
 
     This argument has to be amended if $x$ is at distance $ < 2D$ from $c(A)$ or $c(B)$. In this case,
     simply use $x_m = y_m = c(A)$ or $x_M = y_M = c(B)$, then everything goes through.\<close>
 
     have "\<exists>x \<in> {c A--c B}. \<forall>y \<in> {c A--c B}. infdist y (d`{A..B}) \<le> infdist x (d`{A..B})"
       by (rule continuous_attains_sup, auto intro: continuous_intros)
     then obtain x where x: "x \<in> {c A--c B}" "\<And>y. y \<in> {c A--c B} \<Longrightarrow> infdist y (d`{A..B}) \<le> infdist x (d`{A..B})"
       by auto
     define D where "D = infdist x (d`{A..B})"
     have "D \<ge> 0" unfolding D_def by (rule infdist_nonneg)
     have D_bound: "D \<le> 24 * lambda + 12 * C + 24 * deltaG(TYPE('a))^2"
     proof (cases "D \<le> 1")
       case True
       have "1 * 1 + 1 * 0 + 0 * 0 \<le> 24 * lambda + 12 * C + 24 * deltaG(TYPE('a))^2"
         apply (intro mono_intros) using C delta_nonneg by auto
       then show ?thesis using True by auto
     next
       case False
       then have "D \<ge> 1" by auto
       have ln2mult: "2 * ln t = ln (t * t)" if "t > 0" for t::real by (simp add: that ln_mult)
       have "infdist (c A) (d`{A..B}) = 0" using \<open>d A = c A\<close> by (metis \<open>A \<in> {A..B}\<close> image_eqI infdist_zero)
       then have "x \<noteq> c A" using \<open>D \<ge> 1\<close> D_def by auto
 
       define tx where "tx = dist (c A) x"
       then have "tx \<in> {0..dist (c A) (c B)}"
         using \<open>x \<in> {c A--c B}\<close>
         by (meson atLeastAtMost_iff geodesic_segment_dist_le some_geodesic_is_geodesic_segment(1) metric_space_class.zero_le_dist some_geodesic_endpoints(1))
       have "tx > 0" using \<open>x \<noteq> c A\<close> tx_def by auto
       have x_param: "x = geodesic_segment_param {c A--c B} (c A) tx"
         using \<open>x \<in> {c A--c B}\<close> geodesic_segment_param[OF some_geodesic_is_geodesic_segment(1)] tx_def by auto
 
       define tm where "tm = max (tx - 2 * D) 0"
       have "tm \<in> {0..dist (c A) (c B)}" unfolding tm_def using \<open>tx \<in> {0..dist (c A) (c B)}\<close> \<open>D \<ge> 0\<close> by auto
       define xm where "xm = geodesic_segment_param {c A--c B} (c A) tm"
       have "xm \<in> {c A--c B}" using \<open>tm \<in> {0..dist (c A) (c B)}\<close>
         by (metis geodesic_segment_param(3) local.some_geodesic_is_geodesic_segment(1) xm_def)
       have "dist xm x = abs((max (tx - 2 * D) 0) - tx)"
         unfolding xm_def tm_def x_param apply (rule geodesic_segment_param[of _ _ "c B"], auto)
         using \<open>tx \<in> {0..dist (c A) (c B)}\<close> \<open>D \<ge> 0\<close> by auto
       also have "... \<le> 2 * D" by (simp add: \<open>0 \<le> D\<close> tx_def)
       finally have "dist xm x \<le> 2 * D" by auto
       have "\<exists>ym\<in>d`{A..B}. infdist xm (d`{A..B}) = dist xm ym"
         apply (rule infdist_proper_attained) using 3 d(1) proper_of_compact compact_continuous_image by auto
       then obtain ym where ym: "ym \<in> d`{A..B}" "dist xm ym = infdist xm (d`{A..B})"
         by metis
       then obtain um where um: "um \<in> {A..B}" "ym = d um" by auto
       have "dist xm ym \<le> D"
         unfolding D_def using x ym by (simp add: \<open>xm \<in> {c A--c B}\<close>)
       have D1: "dist x z \<ge> D" if "z \<in> {xm--ym}" for z
       proof (cases "tx - 2 * D < 0")
         case True
         then have "tm = 0" unfolding tm_def by auto
         then have "xm = c A" unfolding xm_def
           by (meson geodesic_segment_param(1) local.some_geodesic_is_geodesic_segment(1))
         then have "infdist xm (d`{A..B}) = 0"
           using \<open>d A = c A\<close> \<open>A \<in> {A..B}\<close> by (metis image_eqI infdist_zero)
         then have "ym = xm" using ym(2) by auto
         then have "z = xm" using \<open>z \<in> {xm--ym}\<close> geodesic_segment_between_x_x(3)
           by (metis empty_iff insert_iff some_geodesic_is_geodesic_segment(1))
         then have "z \<in> d`{A..B}" using \<open>ym = xm\<close> ym(1) by blast
         then show "dist x z \<ge> D" unfolding D_def by (simp add: infdist_le)
       next
         case False
         then have *: "tm = tx - 2 * D" unfolding tm_def by auto
         have "dist xm x = abs((tx - 2 * D) - tx)"
           unfolding xm_def x_param * apply (rule geodesic_segment_param[of _ _ "c B"], auto)
           using False \<open>tx \<in> {0..dist (c A) (c B)}\<close> \<open>D \<ge> 0\<close> by auto
         then have "2 * D = dist xm x" using \<open>D \<ge> 0\<close> by auto
         also have "... \<le> dist xm z + dist x z" using metric_space_class.dist_triangle2 by auto
         also have "... \<le> dist xm ym + dist x z"
           using \<open>z \<in> {xm--ym}\<close> by (auto, meson geodesic_segment_dist_le some_geodesic_is_geodesic_segment(1) some_geodesic_endpoints(1))
         also have "... \<le> D + dist x z"
           using \<open>dist xm ym \<le> D\<close> by simp
         finally show "dist x z \<ge> D" by auto
       qed
 
       define tM where "tM = min (tx + 2 * D) (dist (c A) (c B))"
       have "tM \<in> {0..dist (c A) (c B)}" unfolding tM_def using \<open>tx \<in> {0..dist (c A) (c B)}\<close> \<open>D \<ge> 0\<close> by auto
       have "tm \<le> tM"
         unfolding tM_def using \<open>D \<ge> 0\<close> \<open>tm \<in> {0..dist (c A) (c B)}\<close> \<open>tx \<equiv> dist (c A) x\<close> tm_def by auto
       define xM where "xM = geodesic_segment_param {c A--c B} (c A) tM"
       have "xM \<in> {c A--c B}" using \<open>tM \<in> {0..dist (c A) (c B)}\<close>
         by (metis geodesic_segment_param(3) local.some_geodesic_is_geodesic_segment(1) xM_def)
       have "dist xM x = abs((min (tx + 2 * D) (dist (c A) (c B))) - tx)"
         unfolding xM_def tM_def x_param apply (rule geodesic_segment_param[of _ _ "c B"], auto)
         using \<open>tx \<in> {0..dist (c A) (c B)}\<close> \<open>D \<ge> 0\<close> by auto
       also have "... \<le> 2 * D" using \<open>0 \<le> D\<close> \<open>tx \<in> {0..dist (c A) (c B)}\<close> by auto
       finally have "dist xM x \<le> 2 * D" by auto
       have "\<exists>yM\<in>d`{A..B}. infdist xM (d`{A..B}) = dist xM yM"
         apply (rule infdist_proper_attained) using 3 d(1) proper_of_compact compact_continuous_image by auto
       then obtain yM where yM: "yM \<in> d`{A..B}" "dist xM yM = infdist xM (d`{A..B})"
         by metis
       then obtain uM where uM: "uM \<in> {A..B}" "yM = d uM" by auto
       have "dist xM yM \<le> D"
         unfolding D_def using x yM by (simp add: \<open>xM \<in> {c A--c B}\<close>)
       have D3: "dist x z \<ge> D" if "z \<in> {xM--yM}" for z
       proof (cases "tx + 2 * D > dist (c A) (c B)")
         case True
         then have "tM = dist (c A) (c B)" unfolding tM_def by auto
         then have "xM = c B" unfolding xM_def
           by (meson geodesic_segment_param(2) local.some_geodesic_is_geodesic_segment(1))
         then have "infdist xM (d`{A..B}) = 0"
           using \<open>d B = c B\<close> \<open>B \<in> {A..B}\<close> by (metis image_eqI infdist_zero)
         then have "yM = xM" using yM(2) by auto
         then have "z = xM" using \<open>z \<in> {xM--yM}\<close> geodesic_segment_between_x_x(3)
           by (metis empty_iff insert_iff some_geodesic_is_geodesic_segment(1))
         then have "z \<in> d`{A..B}" using \<open>yM = xM\<close> yM(1) by blast
         then show "dist x z \<ge> D" unfolding D_def by (simp add: infdist_le)
       next
         case False
         then have *: "tM = tx + 2 * D" unfolding tM_def by auto
         have "dist xM x = abs((tx + 2 * D) - tx)"
           unfolding xM_def x_param * apply (rule geodesic_segment_param[of _ _ "c B"], auto)
           using False \<open>tx \<in> {0..dist (c A) (c B)}\<close> \<open>D \<ge> 0\<close> by auto
         then have "2 * D = dist xM x" using \<open>D \<ge> 0\<close> by auto
         also have "... \<le> dist xM z + dist x z" using metric_space_class.dist_triangle2 by auto
         also have "... \<le> dist xM yM + dist x z"
           using \<open>z \<in> {xM--yM}\<close> by (auto, meson geodesic_segment_dist_le local.some_geodesic_is_geodesic_segment(1) some_geodesic_endpoints(1))
         also have "... \<le> D + dist x z"
           using \<open>dist xM yM \<le> D\<close> by simp
         finally show "dist x z \<ge> D" by auto
       qed
 
       define excursion:: "real\<Rightarrow>'a" where "excursion = (\<lambda>t.
         if t \<in> {0..dist xm ym} then (geodesic_segment_param {xm--ym} xm t)
         else if t \<in> {dist xm ym..dist xm ym + abs(uM - um)} then d (um + sgn(uM-um) * (t - dist xm ym))
         else geodesic_segment_param {yM--xM} yM (t - dist xm ym - abs (uM -um)))"
       define L where "L = dist xm ym + abs(uM - um) + dist yM xM"
       have E1: "excursion t = geodesic_segment_param {xm--ym} xm t" if "t \<in> {0..dist xm ym}" for t
         unfolding excursion_def using that by auto
       have E2: "excursion t = d (um + sgn(uM-um) * (t - dist xm ym))" if "t \<in> {dist xm ym..dist xm ym + abs(uM - um)}" for t
         unfolding excursion_def using that by (auto simp add: \<open>ym = d um\<close>)
       have E3: "excursion t = geodesic_segment_param {yM--xM} yM (t - dist xm ym - abs (uM -um))"
         if "t \<in> {dist xm ym + \<bar>uM - um\<bar>..dist xm ym + \<bar>uM - um\<bar> + dist yM xM}" for t
         unfolding excursion_def using that \<open>yM = d uM\<close> \<open>ym = d um\<close> by (auto simp add: sgn_mult_abs)
       have E0: "excursion 0 = xm"
         unfolding excursion_def by auto
       have EL: "excursion L = xM"
         unfolding excursion_def L_def apply (auto simp add: uM(2) um(2) sgn_mult_abs)
         by (metis (mono_tags, hide_lams) add.left_neutral add_increasing2 add_le_same_cancel1 dist_real_def
               Gromov_product_e_x_x Gromov_product_nonneg metric_space_class.dist_le_zero_iff)
       have [simp]: "L \<ge> 0" unfolding L_def by auto
       have "L > 0"
       proof (rule ccontr)
         assume "\<not>(L > 0)"
         then have "L = 0" using \<open>L \<ge> 0\<close> by simp
         then have "xm = xM" using E0 EL by auto
         then have "tM = tm" unfolding xm_def xM_def
           using \<open>tM \<in> {0..dist (c A) (c B)}\<close> \<open>tm \<in> {0..dist (c A) (c B)}\<close> local.geodesic_segment_param_in_geodesic_spaces(6) by fastforce
         also have "... < tx" unfolding tm_def using \<open>tx > 0\<close> \<open>D \<ge> 1\<close> by auto
         also have "... \<le> tM" unfolding tM_def using \<open>D \<ge> 0\<close> \<open>tx \<in> {0..dist (c A) (c B)}\<close> by auto
         finally show False by simp
       qed
 
       have "(1/lambda) * dist um uM - (4 * C) \<le> dist (d um) (d uM)"
         by (rule quasi_isometry_onD(2)[OF \<open>lambda (4 * C)-quasi_isometry_on {A..B} d\<close> \<open>um \<in> {A..B}\<close> \<open>uM \<in> {A..B}\<close>])
       also have "... \<le> dist ym xm + dist xm x + dist x xM + dist xM yM"
         unfolding um(2)[symmetric] uM(2)[symmetric] by (rule dist_triangle5)
       also have "... \<le> D + (2*D) + (2*D) + D"
         using \<open>dist xm ym \<le> D\<close> \<open>dist xm x \<le> 2*D\<close> \<open>dist xM x \<le> 2*D\<close> \<open>dist xM yM \<le> D\<close>
         by (auto simp add: metric_space_class.dist_commute intro: add_mono)
       finally have "(1/lambda) * dist um uM \<le> 6*D + 4*C" by auto
       then have "dist um uM \<le> 6*D*lambda + 4*C*lambda"
         using C by (auto simp add: divide_simps algebra_simps)
       then have "L \<le> D + (6*D*lambda + 4*C*lambda) + D"
         unfolding L_def dist_real_def using \<open>dist xm ym \<le> D\<close> \<open>dist xM yM \<le> D\<close>
         by (auto simp add: metric_space_class.dist_commute intro: add_mono)
       also have "... \<le> 8 * D * lambda + 4*C*lambda"
         using C \<open>D \<ge> 0\<close> by (auto intro: mono_intros)
       finally have L_bound: "L \<le> lambda * (8 * D + 4 * C)"
         by (auto simp add: algebra_simps)
 
       have "1 * (1 * 1 + 0) \<le> lambda * (8 * D + 4 * C)"
         using C \<open>D \<ge> 1\<close> by (intro mono_intros, auto)
 
       consider "um < uM" | "um = uM" | "um > uM" by linarith
       then have "((\<lambda>t. um + sgn (uM - um) * (t - dist xm ym)) ` {dist xm ym..dist xm ym + \<bar>uM - um\<bar>}) \<subseteq> {min um uM..max um uM}"
         by (cases, auto)
       also have "... \<subseteq> {A..B}" using \<open>um \<in> {A..B}\<close> \<open>uM \<in> {A..B}\<close> by auto
       finally have middle: "((\<lambda>t. um + sgn (uM - um) * (t - dist xm ym)) ` {dist xm ym..dist xm ym + \<bar>uM - um\<bar>}) \<subseteq> {A..B}"
         by simp
 
       have "(2 * lambda)-lipschitz_on {0..L} excursion"
       proof (unfold L_def, rule lipschitz_on_closed_Union[of "{{0..dist xm ym}, {dist xm ym..dist xm ym + abs(uM - um)}, {dist xm ym + abs(uM - um)..dist xm ym + abs(uM - um) + dist yM xM}}" _ "\<lambda> i. i"], auto)
         show "lambda \<ge> 0" using C by auto
 
         have *: "1-lipschitz_on {0..dist xm ym} (geodesic_segment_param {xm--ym} xm)"
           by (rule isometry_on_lipschitz, simp)
         have **: "1-lipschitz_on {0..dist xm ym} excursion"
           using lipschitz_on_transform[OF * E1] by simp
         show "(2 * lambda)-lipschitz_on {0..dist xm ym} excursion"
           apply (rule lipschitz_on_mono[OF **]) using C by auto
 
         have *: "(1*(1+0))-lipschitz_on {dist xm ym + \<bar>uM - um\<bar>..dist xm ym + \<bar>uM - um\<bar> + dist yM xM}
                 ((geodesic_segment_param {yM--xM} yM) o (\<lambda>t. t - (dist xm ym + abs (uM -um))))"
           by (intro lipschitz_intros, rule isometry_on_lipschitz, auto)
         have **: "(1*(1+0))-lipschitz_on {dist xm ym + \<bar>uM - um\<bar>..dist xm ym + \<bar>uM - um\<bar> + dist yM xM} excursion"
           apply (rule lipschitz_on_transform[OF *]) using E3 unfolding comp_def by (auto simp add: algebra_simps)
         show "(2 * lambda)-lipschitz_on {dist xm ym + \<bar>uM - um\<bar>..dist xm ym + \<bar>uM - um\<bar> + dist yM xM} excursion"
           apply (rule lipschitz_on_mono[OF **]) using C by auto
 
         have **: "((2 * lambda) * (0 + abs(sgn (uM - um)) * (1 + 0)))-lipschitz_on {dist xm ym..dist xm ym + abs(uM - um)} (d o (\<lambda>t. um + sgn(uM-um) * (t - dist xm ym)))"
           apply (intro lipschitz_intros, rule lipschitz_on_subset[OF _ middle])
           using \<open>(2 * lambda)-lipschitz_on {A..B} d\<close> by simp
         have ***: "(2 * lambda)-lipschitz_on {dist xm ym..dist xm ym + abs(uM - um)} (d o (\<lambda>t. um + sgn(uM-um) * (t - dist xm ym)))"
           apply (rule lipschitz_on_mono[OF **]) using C by auto
         show "(2 * lambda)-lipschitz_on {dist xm ym..dist xm ym + abs(uM - um)} excursion"
           apply (rule lipschitz_on_transform[OF ***]) using E2 by auto
       qed
 
       have *: "dist x z \<ge> D" if z: "z \<in> excursion`{0..L}" for z
       proof -
         obtain tz where tz: "z = excursion tz" "tz \<in> {0..dist xm ym + abs(uM - um) + dist yM xM}"
           using z L_def by auto
         consider "tz \<in> {0..dist xm ym}" | "tz \<in> {dist xm ym<..dist xm ym + abs(uM - um)}" | "tz \<in> {dist xm ym + abs(uM - um)<..dist xm ym + abs(uM - um) + dist yM xM}"
           using tz by force
         then show ?thesis
         proof (cases)
           case 1
           then have "z \<in> {xm--ym}" unfolding tz(1) excursion_def by auto
           then show ?thesis using D1 by auto
         next
           case 3
           then have "z \<in> {yM--xM}" unfolding tz(1) excursion_def using tz(2) by auto
           then show ?thesis using D3 by (simp add: some_geodesic_commute)
         next
           case 2
           then have "z \<in> d`{A..B}" unfolding tz(1) excursion_def using middle by force
           then show ?thesis unfolding D_def by (simp add: infdist_le)
         qed
       qed
 
       text \<open>Now comes the main point: the excursion is always at distance at least $D$ of $x$,
       but this distance is also bounded by the log of its length, i.e., essentially $\log D$. To
       have an efficient estimate, we use a rescaled version, to get rid of one term on the right
       hand side.\<close>
       have "1 * 1 * 1 * (1 + 0/1) \<le> 512 * lambda * lambda * (1+C/D)"
         apply (intro mono_intros) using \<open>lambda \<ge> 1\<close> \<open>D \<ge> 1\<close> \<open>C \<ge> 0\<close> by auto
       then have "ln (512 * lambda * lambda * (1+C/D)) \<ge> 0"
         apply (subst ln_ge_zero_iff) by auto
       define a where "a = 64 * lambda/D"
       have "a > 0" unfolding a_def using \<open>D \<ge> 1\<close> \<open>lambda \<ge> 1\<close> by auto
 
       have "D \<le> infdist x (excursion`{0..L})"
         unfolding infdist_def apply auto apply (rule cInf_greatest) using * by auto
       also have "... \<le> (4/ln 2) * deltaG(TYPE('a)) * max 0 (ln (a * (L-0))) + (2 * lambda) / a"
       proof (rule lipschitz_path_close_to_geodesic'[of _ _ _ _ "geodesic_subsegment {c A--c B} (c A) tm tM"])
         show "(2 * lambda)-lipschitz_on {0..L} excursion" by fact
         have *: "geodesic_subsegment {c A--c B} (c A) tm tM = geodesic_segment_param {c A--c B} (c A) ` {tm..tM} "
           apply (rule geodesic_subsegment(1)[of _ _ "c B"])
           using \<open>tm \<in> {0..dist (c A) (c B)}\<close> \<open>tM \<in> {0..dist (c A) (c B)}\<close> \<open>tm \<le> tM\<close> by auto
         show "x \<in> geodesic_subsegment {c A--c B} (c A) tm tM"
           unfolding * unfolding x_param tm_def tM_def using \<open>tx \<in> {0..dist (c A) (c B)}\<close> \<open>0 \<le> D\<close> by simp
         show "geodesic_segment_between (geodesic_subsegment {c A--c B} (c A) tm tM) (excursion 0) (excursion L)"
           unfolding E0 EL xm_def xM_def apply (rule geodesic_subsegment[of _ _ "c B"])
           using \<open>tm \<in> {0..dist (c A) (c B)}\<close> \<open>tM \<in> {0..dist (c A) (c B)}\<close> \<open>tm \<le> tM\<close> by auto
       qed (fact)
       also have "... = (4/ln 2) * deltaG(TYPE('a)) * max 0 (ln (a *L)) + D/32"
         unfolding a_def using \<open>D \<ge> 1\<close> \<open>lambda \<ge> 1\<close> by (simp add: algebra_simps)
       finally have "(31 * ln 2 / 128) * D \<le> deltaG(TYPE('a)) * max 0 (ln (a * L))"
         by (auto simp add: algebra_simps divide_simps)
       also have "... \<le> deltaG(TYPE('a)) * max 0 (ln ((64 * lambda/D) * (lambda * (8 * D + 4 * C))))"
         unfolding a_def apply (intro mono_intros)
         using L_bound \<open>L > 0\<close> \<open>lambda \<ge> 1\<close> \<open>D \<ge> 1\<close> by auto
       also have "... \<le> deltaG(TYPE('a)) * max 0 (ln ((64 * lambda/D) * (lambda * (8 * D + 8 * C))))"
         apply (intro mono_intros)
         using L_bound \<open>L > 0\<close> \<open>lambda \<ge> 1\<close> \<open>D \<ge> 1\<close> \<open>C \<ge> 0\<close> by auto
       also have "... = deltaG(TYPE('a)) * max 0 (ln (512 * lambda * lambda * (1+C/D)))"
         using \<open>D \<ge> 1\<close> by (auto simp add: algebra_simps)
       also have "... = deltaG(TYPE('a)) * ln (512 * lambda * lambda * (1+C/D))"
         using \<open>ln (512 * lambda * lambda * (1+C/D)) \<ge> 0\<close> by auto
       also have "... \<le> deltaG(TYPE('a)) * ln (512 * lambda * lambda * (1+C/1))"
         apply (intro mono_intros) using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> \<open>D \<ge> 1\<close>
         by (auto simp add: divide_simps mult_ge1_mono(1))
       text \<open>We have obtained a bound on $D$, of the form $D \leq M \delta \ln(M \lambda^2(1+C))$.
       This is a nice bound, but we tweak it a little bit to obtain something more manageable,
       without the logarithm.\<close>
       also have "... = deltaG(TYPE('a)) * (ln 512 + 2 * ln lambda + ln (1+C))"
         apply (subst ln2mult) using \<open>C \<ge> 0\<close> \<open>lambda \<ge> 1\<close> apply simp
         apply (subst ln_mult[symmetric]) apply simp using \<open>C \<ge> 0\<close> \<open>lambda \<ge> 1\<close> apply simp
         apply (subst ln_mult[symmetric]) using \<open>C \<ge> 0\<close> \<open>lambda \<ge> 1\<close> by auto
       also have "... = (deltaG(TYPE('a)) * 1) * ln 512 + 2 * (deltaG(TYPE('a)) * ln lambda) + (deltaG(TYPE('a)) * ln (1+C))"
         by (auto simp add: algebra_simps)
       text \<open>For each term, of the form $\delta \ln c$, we bound it by $(\delta^2 + (\ln c)^2)/2$, and
       then bound $(\ln c)^2$ by $2c-2$. In fact, to get coefficients of the same order of
       magnitude on $\delta^2$ and $\lambda$, we tweak a little bit the inequality for the last two
       terms, using rather $uv \leq (u^2/2 + 2v^2)/2$. We also bound $\ln(32)$ by a good
       approximation $16/3$.\<close>
       also have "... \<le> (deltaG(TYPE('a))^2/2 + 1^2/2) * (25/4)
             + 2 * ((1/2) * deltaG(TYPE('a))^2/2 + 2 * (ln lambda)^2 / 2) + ((1/2) * deltaG(TYPE('a))^2/2 + 2 * (ln (1+C))^2 / 2)"
         by (intro mono_intros, auto, approximation 10)
       also have "... = (31/8) * deltaG(TYPE('a))^2 + 25/8 + 2 * (ln lambda)^2 + (ln (1+C))^2"
         by (auto simp add: algebra_simps)
       also have "... \<le> 4 * deltaG(TYPE('a))^2 + 4 + 2 * (2 * lambda - 2) + (2 * (1+C) - 2)"
         apply (intro mono_intros) using \<open>C \<ge> 0\<close> \<open>lambda \<ge> 1\<close> by auto
       also have "... \<le> 4 * deltaG(TYPE('a))^2 + 4 * lambda + 2 * C"
         by auto
       finally have "D \<le> (128 / (31 * ln 2)) * (4 * deltaG(TYPE('a))^2 + 4 * lambda + 2 * C)"
         by (auto simp add: divide_simps algebra_simps)
       also have "... \<le> 6 * (4 * deltaG(TYPE('a))^2 + 4 * lambda + 2 * C)"
         apply (intro mono_intros, approximation 10) using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> by auto
       also have "... \<le> 24 * deltaG(TYPE('a))^2 + 24 * lambda + 12 * C"
         using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> by auto
       finally show ?thesis by simp
     qed
     define D0 where "D0 = 24 * lambda + 12 * C + 24 * deltaG(TYPE('a))^2"
     have first_step: "infdist y (d`{A..B}) \<le> D0" if "y \<in> {c A--c B}" for y
       using x(2)[OF that] D_bound unfolding D0_def D_def by auto
     have "1 * 1 + 4 * 0 + 24 * 0 \<le> D0"
       unfolding D0_def apply (intro mono_intros) using C delta_nonneg by auto
     then have "D0 > 0" by simp
     text \<open>This is the end of the first step, i.e., showing that $[c(A), c(B)]$ is included in
     the neighborhood of size $D0$ of the quasi-geodesic.\<close>
 
     text \<open>Now, we start the second step: we show that the quasi-geodesic is included in the
     neighborhood of size $D1$ of the geodesic, where $D1 \geq D0$ is the constant defined below.
     The argument goes as follows. Assume that a point $y$ on the quasi-geodesic is at distance $ > D0$
     of the geodesic. Consider the last point $y_m$ before $y$ which is at distance $D0$ of the
     geodesic, and the first point $y_M$ after $y$ likewise. On $(y_m, y_M)$, one is always at distance
     $ > D0$ of the geodesic. However, by the first step, the geodesic is covered by the balls of radius
     $D0$ centered at points on the quasi-geodesic -- and only the points before $y_m$ or after $y_M$
     can be used. Let $K_m$ be the points on the geodesics that are at distance $\leq D0$ of a point
     on the quasi-geodesic before $y_m$, and likewise define $K_M$. These are two closed subsets of
     the geodesic. By connectedness, they have to intersect. This implies that some points before $y_m$
     and after $y_M$ are at distance at most $2D0$. Since we are dealing with a quasi-geodesic, this
     gives a bound on the distance between $y_m$ and $y_M$, and therefore a bound between $y$ and the
     geodesic, as desired.\<close>
 
     define D1 where "D1 = lambda * lambda * (72 * lambda + 44 * C + 72 * deltaG(TYPE('a))^2)"
     have "1 * 1 * (24 * lambda + 12 * C + 24 * deltaG(TYPE('a))^2)
             \<le> lambda * lambda * (72 * lambda + 44 * C + 72 * deltaG(TYPE('a))^2)"
       apply (intro mono_intros) using C by auto
     then have "D0 \<le> D1" unfolding D0_def D1_def by auto
     have second_step: "infdist y {c A--c B} \<le> D1" if "y \<in> d`{A..B}" for y
     proof (cases "infdist y {c A--c B} \<le> D0")
       case True
       then show ?thesis using \<open>D0 \<le> D1\<close> by auto
     next
       case False
       obtain ty where "ty \<in> {A..B}" "y = d ty" using \<open>y \<in> d`{A..B}\<close> by auto
 
       define tm where "tm = Sup ((\<lambda>t. infdist (d t) {c A--c B})-`{..D0} \<inter> {A..ty})"
       have tm: "tm \<in> (\<lambda>t. infdist (d t) {c A--c B})-`{..D0} \<inter> {A..ty}"
       unfolding tm_def proof (rule closed_contains_Sup)
         show "closed ((\<lambda>t. infdist (d t) {c A--c B})-`{..D0} \<inter> {A..ty})"
           apply (rule closed_vimage_Int, auto, intro continuous_intros)
           apply (rule continuous_on_subset[OF d(1)]) using \<open>ty \<in> {A..B}\<close> by auto
         have "A \<in> (\<lambda>t. infdist (d t) {c A--c B})-`{..D0} \<inter> {A..ty}"
           using \<open>D0 > 0\<close> \<open>ty \<in> {A..B}\<close> by (auto simp add: \<open>d A = c A\<close>)
         then show "(\<lambda>t. infdist (d t) {c A--c B})-`{..D0} \<inter> {A..ty} \<noteq> {}" by auto
         show "bdd_above ((\<lambda>t. infdist (d t) {c A--c B}) -` {..D0} \<inter> {A..ty})" by auto
       qed
       have *: "infdist (d t) {c A--c B} > D0" if "t \<in> {tm<..ty}" for t
       proof (rule ccontr)
         assume "\<not>(infdist (d t) {c A--c B} > D0)"
         then have *: "t \<in> (\<lambda>t. infdist (d t) {c A--c B})-`{..D0} \<inter> {A..ty}"
           using that tm by auto
         have "t \<le> tm" unfolding tm_def apply (rule cSup_upper) using * by auto
         then show False using that by auto
       qed
 
       define tM where "tM = Inf ((\<lambda>t. infdist (d t) {c A--c B})-`{..D0} \<inter> {ty..B})"
       have tM: "tM \<in> (\<lambda>t. infdist (d t) {c A--c B})-`{..D0} \<inter> {ty..B}"
       unfolding tM_def proof (rule closed_contains_Inf)
         show "closed ((\<lambda>t. infdist (d t) {c A--c B})-`{..D0} \<inter> {ty..B})"
           apply (rule closed_vimage_Int, auto, intro continuous_intros)
           apply (rule continuous_on_subset[OF d(1)]) using \<open>ty \<in> {A..B}\<close> by auto
         have "B \<in> (\<lambda>t. infdist (d t) {c A--c B})-`{..D0} \<inter> {ty..B}"
           using \<open>D0 > 0\<close> \<open>ty \<in> {A..B}\<close> by (auto simp add: \<open>d B = c B\<close>)
         then show "(\<lambda>t. infdist (d t) {c A--c B})-`{..D0} \<inter> {ty..B} \<noteq> {}" by auto
         show "bdd_below ((\<lambda>t. infdist (d t) {c A--c B}) -` {..D0} \<inter> {ty..B})" by auto
       qed
       have "infdist (d t) {c A--c B} > D0" if "t \<in> {ty..<tM}" for t
       proof (rule ccontr)
         assume "\<not>(infdist (d t) {c A--c B} > D0)"
         then have *: "t \<in> (\<lambda>t. infdist (d t) {c A--c B})-`{..D0} \<inter> {ty..B}"
           using that tM by auto
         have "t \<ge> tM" unfolding tM_def apply (rule cInf_lower) using * by auto
         then show False using that by auto
       qed
       then have lower_tm_tM: "infdist (d t) {c A--c B} > D0" if "t \<in> {tm<..<tM}" for t
         using * that by (cases "t \<ge> ty", auto)
 
       define Km where "Km = (\<Union>z \<in> d`{A..tm}. cball z D0)"
       define KM where "KM = (\<Union>z \<in> d`{tM..B}. cball z D0)"
       have "{c A--c B} \<subseteq> Km \<union> KM"
       proof
         fix x assume "x \<in> {c A--c B}"
         have "\<exists>z \<in> d`{A..B}. infdist x (d`{A..B}) = dist x z"
           apply (rule infdist_proper_attained[OF proper_of_compact], rule compact_continuous_image[OF \<open>continuous_on {A..B} d\<close>])
           using that by auto
         then obtain tx where "tx \<in> {A..B}" "infdist x (d`{A..B}) = dist x (d tx)" by blast
         then have "dist x (d tx) \<le> D0"
           using first_step[OF \<open>x \<in> {c A--c B}\<close>] by auto
         then have "x \<in> cball (d tx) D0" by (auto simp add: metric_space_class.dist_commute)
         consider "tx \<in> {A..tm}" | "tx \<in> {tm<..<tM}" | "tx \<in> {tM..B}"
           using \<open>tx \<in> {A..B}\<close> by fastforce
         then show "x \<in> Km \<union> KM"
         proof (cases)
           case 1
           then have "x \<in> Km" unfolding Km_def using \<open>x \<in> cball (d tx) D0\<close> by auto
           then show ?thesis by simp
         next
           case 3
           then have "x \<in> KM" unfolding KM_def using \<open>x \<in> cball (d tx) D0\<close> by auto
           then show ?thesis by simp
         next
           case 2
           have "infdist (d tx) {c A--c B} \<le> dist (d tx) x" using \<open>x \<in> {c A--c B}\<close> by (rule infdist_le)
           also have "... \<le> D0" using \<open>x \<in> cball (d tx) D0\<close> by auto
           finally have False using lower_tm_tM[OF 2] by simp
           then show ?thesis by simp
         qed
       qed
       then have *: "{c A--c B} = (Km \<inter> {c A--c B}) \<union> (KM \<inter> {c A--c B})" by auto
       have "(Km \<inter> {c A--c B}) \<inter> (KM \<inter> {c A--c B}) \<noteq> {}"
       proof (rule connected_as_closed_union[OF _ *])
         have "closed Km"
           unfolding Km_def apply (rule compact_has_closed_thickening)
           apply (rule compact_continuous_image)
           apply (rule continuous_on_subset[OF \<open>continuous_on {A..B} d\<close>])
           using tm \<open>ty \<in> {A..B}\<close> by auto
         then show "closed (Km \<inter> {c A--c B})" by (rule topological_space_class.closed_Int, auto)
 
         have "closed KM"
           unfolding KM_def apply (rule compact_has_closed_thickening)
           apply (rule compact_continuous_image)
           apply (rule continuous_on_subset[OF \<open>continuous_on {A..B} d\<close>])
           using tM \<open>ty \<in> {A..B}\<close> by auto
         then show "closed (KM \<inter> {c A--c B})" by (rule topological_space_class.closed_Int, auto)
 
         show "connected {c A--c B}" by simp
         have "c A \<in> Km \<inter> {c A--c B}" apply auto
           unfolding Km_def using tm \<open>d A = c A\<close> \<open>D0 > 0\<close> by (auto) (rule bexI[of _ A], auto)
         then show "Km \<inter> {c A--c B} \<noteq> {}" by auto
         have "c B \<in> KM \<inter> {c A--c B}" apply auto
           unfolding KM_def using tM \<open>d B = c B\<close> \<open>D0 > 0\<close> by (auto) (rule bexI[of _ B], auto)
         then show "KM \<inter> {c A--c B} \<noteq> {}" by auto
       qed
       then obtain w where "w \<in> {c A--c B}" "w \<in> Km" "w \<in> KM" by auto
       then obtain twm twM where tw: "twm \<in> {A..tm}" "w \<in> cball (d twm) D0" "twM \<in> {tM..B}" "w \<in> cball (d twM) D0"
         unfolding Km_def KM_def by auto
       have "(1/lambda) * dist twm twM - (4*C) \<le> dist (d twm) (d twM)"
         apply (rule quasi_isometry_onD(2)[OF d(5)]) using tw tm tM by auto
       also have "... \<le> dist (d twm) w + dist w (d twM)"
         by (rule metric_space_class.dist_triangle)
       also have "... \<le> 2 * D0" using tw by (auto simp add: metric_space_class.dist_commute)
       finally have "dist twm twM \<le> lambda * (4*C + 2*D0)"
         using C by (auto simp add: divide_simps algebra_simps)
       then have *: "dist twm ty \<le> lambda * (4*C + 2*D0)"
         using tw tm tM dist_real_def by auto
 
       have "dist (d ty) w \<le> dist (d ty) (d twm) + dist (d twm) w"
         by (rule metric_space_class.dist_triangle)
       also have "... \<le> (lambda * dist ty twm + (4*C)) + D0"
         apply (intro add_mono, rule quasi_isometry_onD(1)[OF d(5)]) using tw tm tM by auto
       also have "... \<le> (lambda * (lambda * (4*C + 2*D0))) + (4*C) + D0"
         apply (intro mono_intros) using C * by (auto simp add: metric_space_class.dist_commute)
       also have "... = lambda * lambda * (4*C + 2*D0) + 1 * 1 * (4 * C) + 1 * 1 * D0"
         by simp
       also have "... \<le> lambda * lambda * (4*C + 2*D0) + lambda * lambda * (4 * C) + lambda * lambda * D0"
         apply (intro mono_intros) using C * \<open>D0 > 0\<close> by auto
       also have "... = lambda * lambda * (8 * C + 3 * D0)"
         by (auto simp add: algebra_simps)
       also have "... = lambda * lambda * (44 * C + 72 * lambda + 72 * deltaG(TYPE('a))^2)"
         unfolding D0_def by auto
       finally have "dist y w \<le> D1" unfolding D1_def \<open>y = d ty\<close> by (auto simp add: algebra_simps)
       then show "infdist y {c A--c B} \<le> D1" using infdist_le[OF \<open>w \<in> {c A--c B}\<close>, of y] by auto
     qed
     text \<open>This concludes the second step.\<close>
 
     text \<open>Putting the two steps together, we deduce that the Hausdorff distance between the
     geodesic and the quasi-geodesic is bounded by $D1$. A bound between the geodesic and
     the original (untamed) quasi-geodesic follows.\<close>
 
     have a: "hausdorff_distance (d`{A..B}) {c A--c B} \<le> D1"
     proof (rule hausdorff_distanceI)
       show "D1 \<ge> 0" unfolding D1_def using C delta_nonneg by auto
       fix x assume "x \<in> d ` {A..B}"
       then show "infdist x {c A--c B} \<le> D1" using second_step by auto
     next
       fix x assume "x \<in> {c A--c B}"
       then show "infdist x (d`{A..B}) \<le> D1" using first_step \<open>D0 \<le> D1\<close> by force
     qed
 
     have "hausdorff_distance (c`{A..B}) {c A--c B} \<le>
         hausdorff_distance (c`{A..B}) (d`{A..B}) + hausdorff_distance (d`{A..B}) {c A--c B}"
       apply (rule hausdorff_distance_triangle)
       using \<open>A \<in> {A..B}\<close> apply blast
       by (rule quasi_isometry_on_bounded[OF d(5)], auto)
     also have "... \<le> D1 + 2*C" using a d by auto
     also have "... = lambda * lambda * (72 * lambda + 44 * C + 72 * deltaG(TYPE('a))^2) + 1 * 1 * (2 * C)"
       unfolding D1_def by auto
     also have "... \<le> lambda * lambda * (72 * lambda + 44 * C + 72 * deltaG(TYPE('a))^2)
                       + lambda * lambda * (28 * C)"
       apply (intro mono_intros) using C delta_nonneg by auto
     also have "... = 72 * lambda^2 * (lambda + C + deltaG(TYPE('a))^2)"
       by (auto simp add: algebra_simps power2_eq_square)
     finally show ?thesis by (auto simp add: algebra_simps)
   qed
 qed
 
 end (*of theory Morse_Gromov_Theorem*)
diff --git a/thys/KD_Tree/KDTree.thy b/thys/KD_Tree/KDTree.thy
--- a/thys/KD_Tree/KDTree.thy
+++ b/thys/KD_Tree/KDTree.thy
@@ -1,441 +1,441 @@
 (*
   File:     KDTree.thy
   Author:   Martin Rau, TU München
 *)
 
 section "Definition of the \<open>k\<close>-d Tree"
 
 theory KDTree
 imports
   Complex_Main
 begin
 
 
 text \<open>
   A \<open>k\<close>-d tree is a space-partitioning data structure for organizing points in a \<open>k\<close>-dimensional space.
   In principle the \<open>k\<close>-d tree is a binary tree. The leafs hold the \<open>k\<close>-dimensional points and the nodes
   contain left and right subtrees as well as a discriminator \<open>s\<close> at a particular axis \<open>a\<close>.
   Every node divides the space into two parts by splitting along a hyperplane.
   Consider a node \<open>n\<close> with associated discriminator \<open>s\<close> at axis \<open>a\<close>.
   All points in the left subtree must have a value at axis \<open>a\<close> that is less than or
   equal to \<open>s\<close> and all points in the right subtree must have a value at axis \<open>a\<close> that is
   greater than or equal to \<open>s\<close>.
 
   Deviations from the papers:
 
   The chosen tree representation is taken from @{cite "DBLP:journals/toms/FriedmanBF77"} with one minor
   adjustment. Originally the leafs hold buckets of points of size \<open>b\<close>. This representation fixes the
   bucket size to \<open>b = 1\<close>, a single point per Leaf. This is only a minor adjustment since the paper
   proves that \<open>b = 1\<close> is the optimal bucket size for minimizing the runtime of the nearest neighbor
   algorithm @{cite "DBLP:journals/toms/FriedmanBF77"}, only simplifies building the optimized
   \<open>k\<close>-d trees @{cite "DBLP:journals/toms/FriedmanBF77"} and has little influence on the
   search algorithm @{cite "DBLP:journals/cacm/Bentley75"}.
 \<close>
 
 type_synonym point = "real list"
 type_synonym axis = nat
 type_synonym dimension = nat
 type_synonym discriminator = real
 
 datatype kdt =
   Leaf point
 | Node axis discriminator kdt kdt
 
 
 subsection "Definition of the \<open>k\<close>-d Tree Invariant and Related Functions"
 
 definition dim :: "point \<Rightarrow> nat"  where
   "dim p = length p"
 
 declare dim_def[simp]
 
 fun set_kdt :: "kdt \<Rightarrow> point set" where
   "set_kdt (Leaf p) = {p}"
 | "set_kdt (Node _ _ l r) = set_kdt l \<union> set_kdt r"
 
 fun invar :: "dimension \<Rightarrow> kdt \<Rightarrow> bool" where
   "invar k (Leaf p) \<longleftrightarrow> dim p = k"
 | "invar k (Node a s l r) \<longleftrightarrow> (\<forall>p \<in> set_kdt l. p!a \<le> s) \<and> (\<forall>p \<in> set_kdt r. s \<le> p!a) \<and>
     invar k l \<and> invar k r \<and> a < k \<and> set_kdt l \<inter> set_kdt r = {}"
 
 fun size_kdt :: "kdt \<Rightarrow> nat" where
   "size_kdt (Leaf _) = 1"
 | "size_kdt (Node _ _ l r) = size_kdt l + size_kdt r"
 
 fun height :: "kdt \<Rightarrow> nat" where
   "height (Leaf _) = 0"
 | "height (Node _ _ l r) = max (height l) (height r) + 1"
 
 fun min_height :: "kdt \<Rightarrow> nat" where
   "min_height (Leaf _) = 0"
 | "min_height (Node _ _ l r) = min (min_height l) (min_height r) + 1"
 
 definition balanced :: "kdt \<Rightarrow> bool" where
   "balanced kdt \<longleftrightarrow> height kdt - min_height kdt \<le> 1"
 
 fun complete :: "kdt \<Rightarrow> bool" where
   "complete (Leaf _) = True"
 | "complete (Node _ _ l r) \<longleftrightarrow> complete l \<and> complete r \<and> height l = height r"
 
 
 lemma invar_l:
   "invar k (Node a s l r) \<Longrightarrow> invar k l"
   by simp
 
 lemma invar_r:
   "invar k (Node a s l r) \<Longrightarrow> invar k r"
   by simp
 
 lemma invar_axis_lt_d:
   "invar k (Node a s l r) \<Longrightarrow> a < k"
   by simp
 
 lemma invar_dim:
   "invar k kdt \<Longrightarrow> \<forall>p \<in> set_kdt kdt. dim p = k"
   by (induction kdt) auto
 
 lemma invar_l_le_a:
   "invar k (Node a s l r) \<Longrightarrow> \<forall>p \<in> set_kdt l. p!a \<le> s"
   by simp
 
 lemma invar_r_ge_a:
   "invar k (Node a s l r) \<Longrightarrow> \<forall>p \<in> set_kdt r. s \<le> p!a"
   by simp
 
 lemma invar_distinct:
   "invar k kdt \<Longrightarrow> kdt = Node a s l r \<Longrightarrow> set_kdt l \<inter> set_kdt r = {}"
   by fastforce
 
 lemma invar_set:
   "set_kdt (Node a s l r) = set_kdt l \<union> set_kdt r"
   by simp
 
 
 subsection "Lemmas adapted from \<open>HOL-Library.Tree\<close> to \<open>k\<close>-d Tree"
 
 lemma size_ge0[simp]: 
   "0 < size_kdt kdt"
   by (induction kdt) auto
 
 lemma eq_size_1[simp]:
   "size_kdt kdt = 1 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
   apply (induction kdt)
   apply (auto)
   using size_ge0 nat_less_le apply blast+
   done
 
 lemma eq_1_size[simp]:
   "1 = size_kdt kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
   using eq_size_1 by metis
 
 lemma neq_Leaf_iff: 
   "(\<nexists>p. kdt = Leaf p) = (\<exists>a s l r. kdt = Node a s l r)"
   by (cases kdt) auto
 
 lemma eq_height_0[simp]: 
   "height kdt = 0 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
   by (cases kdt) auto
 
 lemma eq_0_height[simp]: 
   "0 = height kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
   by (cases kdt) auto
 
 lemma eq_min_height_0[simp]: 
   "min_height kdt = 0 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
   by (cases kdt) auto
 
 lemma eq_0_min_height[simp]: 
   "0 = min_height kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
   by (cases kdt) auto
 
 lemma size_height: 
   "size_kdt kdt \<le> 2 ^ height kdt"
 proof(induction kdt)
   case (Node a s l r)
   show ?case
   proof (cases "height l \<le> height r")
     case True
     have "size_kdt (Node a s l r) = size_kdt l + size_kdt r" by simp
     also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
     also have "\<dots> \<le> 2 ^ height r + 2 ^ height r" using True by simp
     also have "\<dots> = 2 ^ height (Node a s l r)"
       using True by (auto simp: max_def mult_2)
     finally show ?thesis .
   next
     case False
     have "size_kdt (Node a s l r) = size_kdt l + size_kdt r" by simp
     also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
     also have "\<dots> \<le> 2 ^ height l + 2 ^ height l" using False by simp
     finally show ?thesis using False by (auto simp: max_def mult_2)
   qed
 qed simp
 
 lemma min_height_le_height: 
   "min_height kdt \<le> height kdt"
   by (induction kdt) auto
 
 lemma min_height_size: 
   "2 ^ min_height kdt \<le> size_kdt kdt"
 proof(induction kdt)
   case (Node a s l r)
   have "(2::nat) ^ min_height (Node a s l r) \<le> 2 ^ min_height l + 2 ^ min_height r"
     by (simp add: min_def)
   also have "\<dots> \<le> size_kdt (Node a s l r)" using Node.IH by simp
   finally show ?case .
 qed simp
 
 lemma complete_iff_height: 
   "complete kdt \<longleftrightarrow> (min_height kdt = height kdt)"
   apply (induction kdt)
   apply simp
   apply (simp add: min_def max_def)
   by (metis le_antisym le_trans min_height_le_height)
 
 lemma size_if_complete: 
   "complete kdt \<Longrightarrow> size_kdt kdt = 2 ^ height kdt"
   by (induction kdt) auto
 
 lemma complete_if_size_height: 
   "size_kdt kdt = 2 ^ height kdt \<Longrightarrow> complete kdt"
 proof (induction "height kdt" arbitrary: kdt)
   case 0 thus ?case by auto
 next
   case (Suc h)
   hence "\<nexists>p. kdt = Leaf p"
     by auto
   then obtain a s l r where [simp]: "kdt = Node a s l r"
     using neq_Leaf_iff by auto
   have 1: "height l \<le> h" and 2: "height r \<le> h" using Suc(2) by(auto)
   have 3: "\<not> height l < h"
   proof
     assume 0: "height l < h"
     have "size_kdt kdt = size_kdt l + size_kdt r" by simp
     also have "\<dots> \<le> 2 ^ height l + 2 ^ height r"
       using size_height[of l] size_height[of r] by arith
     also have " \<dots> < 2 ^ h + 2 ^ height r" using 0 by (simp)
     also have " \<dots> \<le> 2 ^ h + 2 ^ h" using 2 by (simp)
     also have "\<dots> = 2 ^ (Suc h)" by (simp)
     also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
     finally have "size_kdt kdt < size_kdt kdt" .
     thus False by (simp)
   qed
   have 4: "\<not> height r < h"
   proof
     assume 0: "height r < h"
     have "size_kdt kdt = size_kdt l + size_kdt r" by simp
     also have "\<dots> \<le> 2 ^ height l + 2 ^ height r"
       using size_height[of l] size_height[of r] by arith
     also have " \<dots> < 2 ^ height l + 2 ^ h" using 0 by (simp)
     also have " \<dots> \<le> 2 ^ h + 2 ^ h" using 1 by (simp)
     also have "\<dots> = 2 ^ (Suc h)" by (simp)
     also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
     finally have "size_kdt kdt < size_kdt kdt" .
     thus False by (simp)
   qed
   from 1 2 3 4 have *: "height l = h" "height r = h" by linarith+
   hence "size_kdt l = 2 ^ height l" "size_kdt r = 2 ^ height r"
     using Suc(3) size_height[of l] size_height[of r] by (auto)
   with * Suc(1) show ?case by simp
 qed
 
 lemma complete_if_size_min_height: 
   "size_kdt kdt = 2 ^ min_height kdt \<Longrightarrow> complete kdt"
 proof (induct "min_height kdt" arbitrary: kdt)
   case 0 thus ?case by auto
 next
   case (Suc h)
   hence "\<nexists>p. kdt = Leaf p"
     by auto
   then obtain a s l r where [simp]: "kdt = Node a s l r"
     using neq_Leaf_iff by auto
   have 1: "h \<le> min_height l" and 2: "h \<le> min_height r" using Suc(2) by (auto)
   have 3: "\<not> h < min_height l"
   proof
     assume 0: "h < min_height l"
     have "size_kdt kdt = size_kdt l + size_kdt r" by simp
     also note min_height_size[of l]
     also(xtrans) note min_height_size[of r]
     also(xtrans) have "(2::nat) ^ min_height l > 2 ^ h"
         using 0 by (simp add: diff_less_mono)
     also(xtrans) have "(2::nat) ^ min_height r \<ge> 2 ^ h" using 2 by simp
     also(xtrans) have "(2::nat) ^ h + 2 ^ h = 2 ^ (Suc h)" by (simp)
     also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
     finally show False by (simp add: diff_le_mono)
   qed
   have 4: "\<not> h < min_height r"
   proof
     assume 0: "h < min_height r"
     have "size_kdt kdt = size_kdt l + size_kdt r" by simp
     also note min_height_size[of l]
     also(xtrans) note min_height_size[of r]
     also(xtrans) have "(2::nat) ^ min_height r > 2 ^ h"
         using 0 by (simp add: diff_less_mono)
     also(xtrans) have "(2::nat) ^ min_height l \<ge> 2 ^ h" using 1 by simp
     also(xtrans) have "(2::nat) ^ h + 2 ^ h = 2 ^ (Suc h)" by (simp)
     also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
     finally show False by (simp add: diff_le_mono)
   qed
   from 1 2 3 4 have *: "min_height l = h" "min_height r = h" by linarith+
   hence "size_kdt l = 2 ^ min_height l" "size_kdt r = 2 ^ min_height r"
     using Suc(3) min_height_size[of l] min_height_size[of r] by (auto)
   with * Suc(1) show ?case
     by (simp add: complete_iff_height)
 qed
 
 lemma complete_iff_size: 
   "complete kdt \<longleftrightarrow> size_kdt kdt = 2 ^ height kdt"
   using complete_if_size_height size_if_complete by blast
 
 lemma size_height_if_incomplete:
   "\<not> complete kdt \<Longrightarrow> size_kdt kdt < 2 ^ height kdt"
   by (meson antisym_conv complete_iff_size not_le size_height)
 
 lemma min_height_size_if_incomplete:
   "\<not> complete kdt \<Longrightarrow> 2 ^ min_height kdt < size_kdt kdt"
   by (metis complete_if_size_min_height le_less min_height_size)
 
 lemma balanced_subtreeL: 
   "balanced (Node a s l r) \<Longrightarrow> balanced l"
   by (simp add: balanced_def)
 
 lemma balanced_subtreeR: 
   "balanced (Node a s l r) \<Longrightarrow> balanced r"
   by (simp add: balanced_def)
 
 lemma balanced_optimal:
   assumes "balanced kdt" "size_kdt kdt \<le> size_kdt kdt'"
   shows "height kdt \<le> height kdt'"
 proof (cases "complete kdt")
   case True
   have "(2::nat) ^ height kdt \<le> 2 ^ height kdt'"
   proof -
     have "2 ^ height kdt = size_kdt kdt"
       using True by (simp add: complete_iff_height size_if_complete)
     also have "\<dots> \<le> size_kdt kdt'" using assms(2) by simp
     also have "\<dots> \<le> 2 ^ height kdt'" by (rule size_height)
     finally show ?thesis .
   qed
   thus ?thesis by (simp)
 next
   case False
   have "(2::nat) ^ min_height kdt < 2 ^ height kdt'"
   proof -
     have "(2::nat) ^ min_height kdt < size_kdt kdt"
       by(rule min_height_size_if_incomplete[OF False])
     also have "\<dots> \<le> size_kdt kdt'" using assms(2) by simp
     also have "\<dots> \<le> 2 ^ height kdt'"  by(rule size_height)
     finally have "(2::nat) ^ min_height kdt < (2::nat) ^ height kdt'" .
     thus ?thesis .
   qed
   hence *: "min_height kdt < height kdt'" by simp
   have "min_height kdt + 1 = height kdt"
     using min_height_le_height[of kdt] assms(1) False
     by (simp add: complete_iff_height balanced_def)
   with * show ?thesis by arith
 qed
 
 
 subsection "Lemmas adapted from \<open>HOL-Library.Tree_Real\<close> to \<open>k\<close>-d Tree"
 
 lemma size_height_log: 
   "log 2 (size_kdt kdt) \<le> height kdt"
   by (simp add: log2_of_power_le size_height)
 
 lemma min_height_size_log: 
   "min_height kdt \<le> log 2 (size_kdt kdt)"
   by (simp add: le_log2_of_power min_height_size)
 
 lemma size_log_if_complete: 
   "complete kdt \<Longrightarrow> height kdt = log 2 (size_kdt kdt)"
-  by (simp add: log2_of_power_eq size_if_complete)
+  by (simp add: size_if_complete)
 
 lemma min_height_size_log_if_incomplete:
   "\<not> complete kdt \<Longrightarrow> min_height kdt < log 2 (size_kdt kdt)"
   by (simp add: less_log2_of_power min_height_size_if_incomplete)
 
 lemma min_height_balanced: 
   assumes "balanced kdt"
   shows "min_height kdt = nat(floor(log 2 (size_kdt kdt)))"
 proof cases
   assume *: "complete kdt"
   hence "size_kdt kdt = 2 ^ min_height kdt"
     by (simp add: complete_iff_height size_if_complete)
   from log2_of_power_eq[OF this] show ?thesis by linarith
 next
   assume *: "\<not> complete kdt"
   hence "height kdt = min_height kdt + 1"
     using assms min_height_le_height[of kdt]
     by(auto simp add: balanced_def complete_iff_height)
   hence "size_kdt kdt < 2 ^ (min_height kdt + 1)"
     by (metis * size_height_if_incomplete)
   hence "log 2 (size_kdt kdt) < min_height kdt + 1"
     using log2_of_power_less size_ge0 by blast
   thus ?thesis using min_height_size_log[of kdt] by linarith
 qed
 
 lemma height_balanced: 
   assumes "balanced kdt"
   shows "height kdt = nat(ceiling(log 2 (size_kdt kdt)))"
 proof cases
   assume *: "complete kdt"
   hence "size_kdt kdt = 2 ^ height kdt"
     by (simp add: size_if_complete)
   from log2_of_power_eq[OF this] show ?thesis
     by linarith
 next
   assume *: "\<not> complete kdt"
   hence **: "height kdt = min_height kdt + 1"
     using assms min_height_le_height[of kdt]
     by(auto simp add: balanced_def complete_iff_height)
   hence "size_kdt kdt \<le> 2 ^ (min_height kdt + 1)" by (metis size_height)
   from  log2_of_power_le[OF this size_ge0] min_height_size_log_if_incomplete[OF *] **
   show ?thesis by linarith
 qed
 
 lemma balanced_Node_if_wbal1:
   assumes "balanced l" "balanced r" "size_kdt l = size_kdt r + 1"
   shows "balanced (Node a s l r)"
 proof -
   from assms(3) have [simp]: "size_kdt l = size_kdt r + 1" by simp
   have "nat \<lceil>log 2 (1 + size_kdt r)\<rceil> \<ge> nat \<lceil>log 2 (size_kdt r)\<rceil>"
     by(rule nat_mono[OF ceiling_mono]) simp
   hence 1: "height(Node a s l r) = nat \<lceil>log 2 (1 + size_kdt r)\<rceil> + 1"
     using height_balanced[OF assms(1)] height_balanced[OF assms(2)]
     by (simp del: nat_ceiling_le_eq add: max_def)
   have "nat \<lfloor>log 2 (1 + size_kdt r)\<rfloor> \<ge> nat \<lfloor>log 2 (size_kdt r)\<rfloor>"
     by(rule nat_mono[OF floor_mono]) simp
   hence 2: "min_height(Node a s l r) = nat \<lfloor>log 2 (size_kdt r)\<rfloor> + 1"
     using min_height_balanced[OF assms(1)] min_height_balanced[OF assms(2)]
     by (simp)
   have "size_kdt r \<ge> 1" by (simp add: Suc_leI)
   then obtain i where i: "2 ^ i \<le> size_kdt r" "size_kdt r < 2 ^ (i + 1)"
     using ex_power_ivl1[of 2 "size_kdt r"] by auto
   hence i1: "2 ^ i < size_kdt r + 1" "size_kdt r + 1 \<le> 2 ^ (i + 1)" by auto
   from 1 2 floor_log_nat_eq_if[OF i] ceiling_log_nat_eq_if[OF i1]
   show ?thesis by(simp add:balanced_def)
 qed
 
 lemma balanced_sym: 
   "balanced (Node a s l r) \<Longrightarrow> balanced (Node a' s' r l)"
   by (auto simp: balanced_def)
 
 lemma balanced_Node_if_wbal2:
   assumes "balanced l" "balanced r" "abs(int(size_kdt l) - int(size_kdt r)) \<le> 1"
   shows "balanced (Node a s l r)"
 proof -
   have "size_kdt l = size_kdt r \<or> (size_kdt l = size_kdt r + 1 \<or> size_kdt r = size_kdt l + 1)" (is "?A \<or> ?B")
     using assms(3) by linarith
   thus ?thesis
   proof
     assume "?A"
     thus ?thesis using assms(1,2)
       apply(simp add: balanced_def min_def max_def)
       by (metis assms(1,2) balanced_optimal le_antisym le_less)
   next
     assume "?B"
     thus ?thesis
       by (meson assms(1,2) balanced_sym balanced_Node_if_wbal1)
   qed
 qed
 
 end
\ No newline at end of file
diff --git a/thys/Sqrt_Babylonian/Sqrt_Babylonian_Auxiliary.thy b/thys/Sqrt_Babylonian/Sqrt_Babylonian_Auxiliary.thy
--- a/thys/Sqrt_Babylonian/Sqrt_Babylonian_Auxiliary.thy
+++ b/thys/Sqrt_Babylonian/Sqrt_Babylonian_Auxiliary.thy
@@ -1,153 +1,136 @@
 (*  Title:       Computing Square Roots using the Babylonian Method
     Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
     Maintainer:  René Thiemann
     License:     LGPL
 *)
 
 (*
 Copyright 2009-2014 René Thiemann
 
 This file is part of IsaFoR/CeTA.
 
 IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
 terms of the GNU Lesser General Public License as published by the Free Software
 Foundation, either version 3 of the License, or (at your option) any later
 version.
 
 IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
 PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.
 
 You should have received a copy of the GNU Lesser General Public License along
 with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
 *)
 section \<open>Auxiliary lemmas which might be moved into the Isabelle distribution.\<close>
 
 theory Sqrt_Babylonian_Auxiliary
 imports 
   Complex_Main
 begin
 
 lemma mod_div_equality_int: "(n :: int) div x * x = n - n mod x"
   using div_mult_mod_eq[of n x] by arith
 
-lemma log_pow_cancel[simp]: "a > 0 \<Longrightarrow> a \<noteq> 1 \<Longrightarrow> log a (a ^ b) = b" 
-  by (metis monoid_mult_class.mult.right_neutral log_eq_one log_nat_power)
-
-lemma real_of_rat_floor[simp]: "floor (real_of_rat x) = floor x"
-  by (metis Ratreal_def real_floor_code)
-
-lemma abs_of_rat[simp]: "\<bar>real_of_rat x\<bar> = real_of_rat \<bar>x\<bar>" 
-proof (cases "x \<ge> 0")
-  case False
-  define y where "y = - x"
-  from False have y: "y \<ge> 0" "x = - y" by (auto simp: y_def)
-  thus ?thesis by (auto simp: of_rat_minus)
-qed auto
-
-lemma real_of_rat_ceiling[simp]: "ceiling (real_of_rat x) = ceiling x"
-  unfolding ceiling_def by (metis of_rat_minus real_of_rat_floor)
-
 lemma div_is_floor_divide_rat: "n div y = \<lfloor>rat_of_int n / rat_of_int y\<rfloor>"
   unfolding Fract_of_int_quotient[symmetric] floor_Fract by simp
 
 lemma div_is_floor_divide_real: "n div y = \<lfloor>real_of_int n / of_int y\<rfloor>"
   unfolding div_is_floor_divide_rat[of n y]
   by (metis Ratreal_def of_rat_divide of_rat_of_int_eq real_floor_code)
 
 lemma floor_div_pos_int: 
   fixes r :: "'a :: floor_ceiling"
   assumes n: "n > 0" 
   shows "\<lfloor>r / of_int n\<rfloor> = \<lfloor>r\<rfloor> div n" (is "?l = ?r")
 proof -
   let ?of_int = "of_int :: int \<Rightarrow> 'a"
   define rhs where "rhs = \<lfloor>r\<rfloor> div n"
   let ?n = "?of_int n"
   define m where "m = \<lfloor>r\<rfloor> mod n"
   let ?m = "?of_int m"
   from div_mult_mod_eq[of "floor r" n] have dm: "rhs * n + m = \<lfloor>r\<rfloor>" unfolding rhs_def m_def by simp
   have mn: "m < n" and m0: "m \<ge> 0" using n m_def by auto
   define e where "e = r - ?of_int \<lfloor>r\<rfloor>"
   have e0: "e \<ge> 0" unfolding e_def 
     by (metis diff_self eq_iff floor_diff_of_int zero_le_floor)
   have e1: "e < 1" unfolding e_def 
     by (metis diff_self dual_order.refl floor_diff_of_int floor_le_zero)
   have "r = ?of_int \<lfloor>r\<rfloor> + e" unfolding e_def by simp
   also have "\<lfloor>r\<rfloor> = rhs * n + m" using dm by simp
   finally have "r = ?of_int (rhs * n + m) + e" .
   hence "r / ?n = ?of_int (rhs * n) / ?n + (e + ?m) / ?n" using n by (simp add: field_simps)
   also have "?of_int (rhs * n) / ?n = ?of_int rhs" using n by auto
   finally have *: "r / ?of_int n = (e + ?of_int m) / ?of_int n + ?of_int rhs" by simp
   have "?l = rhs + floor ((e + ?m) / ?n)" unfolding * by simp
   also have "floor ((e + ?m) / ?n) = 0"
   proof (rule floor_unique)
     show "?of_int 0 \<le> (e + ?m) / ?n" using e0 m0 n 
       by (metis add_increasing2 divide_nonneg_pos of_int_0 of_int_0_le_iff of_int_0_less_iff)
     show "(e + ?m) / ?n < ?of_int 0 + 1"
     proof (rule ccontr)
       from n have n': "?n > 0" "?n \<ge> 0" by simp_all
       assume "\<not> ?thesis"
       hence "(e + ?m) / ?n \<ge> 1" by auto
       from mult_right_mono[OF this n'(2)]
       have "?n \<le> e + ?m" using n'(1) by simp
       also have "?m \<le> ?n - 1" using mn 
         by (metis of_int_1 of_int_diff of_int_le_iff zle_diff1_eq)
       finally have "?n \<le> e + ?n - 1" by auto
       with e1 show False by arith
     qed
   qed
   finally show ?thesis unfolding rhs_def by simp
 qed
 
 
 lemma floor_div_neg_int: 
   fixes r :: "'a :: floor_ceiling"
   assumes n: "n < 0" 
   shows "\<lfloor>r / of_int n\<rfloor> = \<lceil>r\<rceil> div n"
 proof -
   from n have n': "- n > 0" by auto
   have "\<lfloor>r / of_int n\<rfloor> = \<lfloor> - r / of_int (- n)\<rfloor>" using n
     by (metis floor_of_int floor_zero less_int_code(1) minus_divide_left minus_minus nonzero_minus_divide_right of_int_minus)
   also have "\<dots> = \<lfloor> - r \<rfloor> div (- n)" by (rule floor_div_pos_int[OF n'])
   also have "\<dots> = \<lceil> r \<rceil> div n" using n 
   by (metis ceiling_def div_minus_right)
   finally show ?thesis .
 qed
 
 lemma divide_less_floor1: "n / y < of_int (floor (n / y)) + 1" 
   by (metis floor_less_iff less_add_one of_int_1 of_int_add)
 
 context linordered_idom
 begin
 
 lemma sgn_int_pow_if [simp]:
   "sgn x ^ p = (if even p then 1 else sgn x)" if "x \<noteq> 0"
   using that by (induct p) simp_all
 
 lemma compare_pow_le_iff: "p > 0 \<Longrightarrow> (x :: 'a) \<ge> 0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> (x ^ p \<le> y ^ p) = (x \<le> y)"
   by (metis eq_iff linear power_eq_imp_eq_base power_mono)
 
 lemma compare_pow_less_iff: "p > 0 \<Longrightarrow> (x :: 'a) \<ge> 0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> (x ^ p < y ^ p) = (x < y)"
   by (metis power_less_imp_less_base power_strict_mono)
     
 end
 
 lemma quotient_of_int[simp]: "quotient_of (of_int i) = (i,1)" 
   by (metis Rat.of_int_def quotient_of_int)
 
 lemma quotient_of_nat[simp]: "quotient_of (of_nat i) = (int i,1)" 
   by (metis Rat.of_int_def Rat.quotient_of_int of_int_of_nat_eq)
 
 lemma square_lesseq_square: "\<And> x y. 0 \<le> (x :: 'a :: linordered_field) \<Longrightarrow> 0 \<le> y \<Longrightarrow> (x * x \<le> y * y) = (x \<le> y)"
   by (metis mult_mono mult_strict_mono' not_less)
 
 lemma square_less_square: "\<And> x y. 0 \<le> (x :: 'a :: linordered_field) \<Longrightarrow> 0 \<le> y \<Longrightarrow> (x * x < y * y) = (x < y)"
   by (metis mult_mono mult_strict_mono' not_less)
 
 lemma sqrt_sqrt[simp]: "x \<ge> 0 \<Longrightarrow> sqrt x * sqrt x = x"
   by (metis real_sqrt_pow2 power2_eq_square)
 
 lemma abs_lesseq_square: "abs (x :: real) \<le> abs y \<longleftrightarrow> x * x \<le> y * y"
   using square_lesseq_square[of "abs x" "abs y"] by auto
 
 end