# HG changeset patch
# User wenzelm
# Date 1483652286 -3600
# Node ID a0e1f64be67cb1f1b5e3bc0787d8975bfc9eeda7
# Parent  8e7db8df16a041d7496610dfc38be577b06f16aa# Parent  81a5473e6d047295caf670984c36c6facafb85b0
merged

diff -r 81a5473e6d04 -r a0e1f64be67c src/HOL/Analysis/Analysis.thy
--- a/src/HOL/Analysis/Analysis.thy	Thu Jan 05 22:37:52 2017 +0100
+++ b/src/HOL/Analysis/Analysis.thy	Thu Jan 05 22:38:06 2017 +0100
@@ -12,6 +12,7 @@
   Weierstrass_Theorems
   Polytope
   Further_Topology
+  Arcwise_Connected
   Poly_Roots
   Conformal_Mappings
   Generalised_Binomial_Theorem
diff -r 81a5473e6d04 -r a0e1f64be67c src/HOL/Analysis/Arcwise_Connected.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Analysis/Arcwise_Connected.thy	Thu Jan 05 22:38:06 2017 +0100
@@ -0,0 +1,2213 @@
+(*  Title:      HOL/Analysis/Arcwise_Connected.thy
+    Authors:    LC Paulson, based on material from HOL Light
+*)
+
+section \<open>Arcwise-connected sets\<close>
+
+theory Arcwise_Connected
+  imports Path_Connected Ordered_Euclidean_Space "~~/src/HOL/Number_Theory/Primes"
+
+begin
+
+subsection\<open>The Brouwer reduction theorem\<close>
+
+theorem Brouwer_reduction_theorem_gen:
+  fixes S :: "'a::euclidean_space set"
+  assumes "closed S" "\<phi> S"
+      and \<phi>: "\<And>F. \<lbrakk>\<And>n. closed(F n); \<And>n. \<phi>(F n); \<And>n. F(Suc n) \<subseteq> F n\<rbrakk> \<Longrightarrow> \<phi>(\<Inter>range F)"
+  obtains T where "T \<subseteq> S" "closed T" "\<phi> T" "\<And>U. \<lbrakk>U \<subseteq> S; closed U; \<phi> U\<rbrakk> \<Longrightarrow> \<not> (U \<subset> T)"
+proof -
+  obtain B :: "nat \<Rightarrow> 'a set"
+    where "inj B" "\<And>n. open(B n)" and open_cov: "\<And>S. open S \<Longrightarrow> \<exists>K. S = \<Union>(B ` K)"
+      by (metis Setcompr_eq_image that univ_second_countable_sequence)
+  define A where "A \<equiv> rec_nat S (\<lambda>n a. if \<exists>U. U \<subseteq> a \<and> closed U \<and> \<phi> U \<and> U \<inter> (B n) = {}
+                                        then @U. U \<subseteq> a \<and> closed U \<and> \<phi> U \<and> U \<inter> (B n) = {}
+                                        else a)"
+  have [simp]: "A 0 = S"
+    by (simp add: A_def)
+  have ASuc: "A(Suc n) = (if \<exists>U. U \<subseteq> A n \<and> closed U \<and> \<phi> U \<and> U \<inter> (B n) = {}
+                          then @U. U \<subseteq> A n \<and> closed U \<and> \<phi> U \<and> U \<inter> (B n) = {}
+                          else A n)" for n
+    by (auto simp: A_def)
+  have sub: "\<And>n. A(Suc n) \<subseteq> A n"
+    by (auto simp: ASuc dest!: someI_ex)
+  have subS: "A n \<subseteq> S" for n
+    by (induction n) (use sub in auto)
+  have clo: "closed (A n) \<and> \<phi> (A n)" for n
+    by (induction n) (auto simp: assms ASuc dest!: someI_ex)
+  show ?thesis
+  proof
+    show "\<Inter>range A \<subseteq> S"
+      using \<open>\<And>n. A n \<subseteq> S\<close> by blast
+    show "closed (INTER UNIV A)"
+      using clo by blast
+    show "\<phi> (INTER UNIV A)"
+      by (simp add: clo \<phi> sub)
+    show "\<not> U \<subset> INTER UNIV A" if "U \<subseteq> S" "closed U" "\<phi> U" for U
+    proof -
+      have "\<exists>y. x \<notin> A y" if "x \<notin> U" and Usub: "U \<subseteq> (\<Inter>x. A x)" for x
+      proof -
+        obtain e where "e > 0" and e: "ball x e \<subseteq> -U"
+          using \<open>closed U\<close> \<open>x \<notin> U\<close> openE [of "-U"] by blast
+        moreover obtain K where K: "ball x e = UNION K B"
+          using open_cov [of "ball x e"] by auto
+        ultimately have "UNION K B \<subseteq> -U"
+          by blast
+        have "K \<noteq> {}"
+          using \<open>0 < e\<close> \<open>ball x e = UNION K B\<close> by auto
+        then obtain n where "n \<in> K" "x \<in> B n"
+          by (metis K UN_E \<open>0 < e\<close> centre_in_ball)
+        then have "U \<inter> B n = {}"
+          using K e by auto
+        show ?thesis
+        proof (cases "\<exists>U\<subseteq>A n. closed U \<and> \<phi> U \<and> U \<inter> B n = {}")
+          case True
+          then show ?thesis
+            apply (rule_tac x="Suc n" in exI)
+            apply (simp add: ASuc)
+            apply (erule someI2_ex)
+            using \<open>x \<in> B n\<close> by blast
+        next
+          case False
+          then show ?thesis
+            by (meson Inf_lower Usub \<open>U \<inter> B n = {}\<close> \<open>\<phi> U\<close> \<open>closed U\<close> range_eqI subset_trans)
+        qed
+      qed
+      with that show ?thesis
+        by (meson Inter_iff psubsetE rangeI subsetI)
+    qed
+  qed
+qed
+
+corollary Brouwer_reduction_theorem:
+  fixes S :: "'a::euclidean_space set"
+  assumes "compact S" "\<phi> S" "S \<noteq> {}"
+      and \<phi>: "\<And>F. \<lbrakk>\<And>n. compact(F n); \<And>n. F n \<noteq> {}; \<And>n. \<phi>(F n); \<And>n. F(Suc n) \<subseteq> F n\<rbrakk> \<Longrightarrow> \<phi>(\<Inter>range F)"
+  obtains T where "T \<subseteq> S" "compact T" "T \<noteq> {}" "\<phi> T"
+                  "\<And>U. \<lbrakk>U \<subseteq> S; closed U; U \<noteq> {}; \<phi> U\<rbrakk> \<Longrightarrow> \<not> (U \<subset> T)"
+proof (rule Brouwer_reduction_theorem_gen [of S "\<lambda>T. T \<noteq> {} \<and> T \<subseteq> S \<and> \<phi> T"])
+  fix F
+  assume cloF: "\<And>n. closed (F n)"
+     and F: "\<And>n. F n \<noteq> {} \<and> F n \<subseteq> S \<and> \<phi> (F n)" and Fsub: "\<And>n. F (Suc n) \<subseteq> F n"
+  show "INTER UNIV F \<noteq> {} \<and> INTER UNIV F \<subseteq> S \<and> \<phi> (INTER UNIV F)"
+  proof (intro conjI)
+    show "INTER UNIV F \<noteq> {}"
+      apply (rule compact_nest)
+      apply (meson F cloF \<open>compact S\<close> seq_compact_closed_subset seq_compact_eq_compact)
+       apply (simp add: F)
+      by (meson Fsub lift_Suc_antimono_le)
+    show " INTER UNIV F \<subseteq> S"
+      using F by blast
+    show "\<phi> (INTER UNIV F)"
+      by (metis F Fsub \<phi> \<open>compact S\<close> cloF closed_Int_compact inf.orderE)
+  qed
+next
+  show "S \<noteq> {} \<and> S \<subseteq> S \<and> \<phi> S"
+    by (simp add: assms)
+qed (meson assms compact_imp_closed seq_compact_closed_subset seq_compact_eq_compact)+
+
+
+subsection\<open>Arcwise Connections\<close>
+
+subsection\<open>Density of points with dyadic rational coordinates.\<close>
+
+proposition closure_dyadic_rationals:
+    "closure (\<Union>k. \<Union>f \<in> Basis \<rightarrow> \<int>.
+                   { \<Sum>i :: 'a :: euclidean_space \<in> Basis. (f i / 2^k) *\<^sub>R i }) = UNIV"
+proof -
+  have "x \<in> closure (\<Union>k. \<Union>f \<in> Basis \<rightarrow> \<int>. {\<Sum>i \<in> Basis. (f i / 2^k) *\<^sub>R i})" for x::'a
+  proof (clarsimp simp: closure_approachable)
+    fix e::real
+    assume "e > 0"
+    then obtain k where k: "(1/2)^k < e/DIM('a)"
+      by (meson DIM_positive divide_less_eq_1_pos of_nat_0_less_iff one_less_numeral_iff real_arch_pow_inv semiring_norm(76) zero_less_divide_iff zero_less_numeral)
+    have "dist (\<Sum>i\<in>Basis. (real_of_int \<lfloor>2^k*(x \<bullet> i)\<rfloor> / 2^k) *\<^sub>R i) x =
+          dist (\<Sum>i\<in>Basis. (real_of_int \<lfloor>2^k*(x \<bullet> i)\<rfloor> / 2^k) *\<^sub>R i) (\<Sum>i\<in>Basis. (x \<bullet> i) *\<^sub>R i)"
+      by (simp add: euclidean_representation)
+    also have "... = norm ((\<Sum>i\<in>Basis. (real_of_int \<lfloor>2^k*(x \<bullet> i)\<rfloor> / 2^k) *\<^sub>R i - (x \<bullet> i) *\<^sub>R i))"
+      by (simp add: dist_norm sum_subtractf)
+    also have "... \<le> DIM('a)*((1/2)^k)"
+    proof (rule sum_norm_bound, simp add: algebra_simps)
+      fix i::'a
+      assume "i \<in> Basis"
+      then have "norm ((real_of_int \<lfloor>x \<bullet> i*2^k\<rfloor> / 2^k) *\<^sub>R i - (x \<bullet> i) *\<^sub>R i) =
+                 \<bar>real_of_int \<lfloor>x \<bullet> i*2^k\<rfloor> / 2^k - x \<bullet> i\<bar>"
+        by (simp add: scaleR_left_diff_distrib [symmetric])
+      also have "... \<le> (1/2) ^ k"
+        by (simp add: divide_simps) linarith
+      finally show "norm ((real_of_int \<lfloor>x \<bullet> i*2^k\<rfloor> / 2^k) *\<^sub>R i - (x \<bullet> i) *\<^sub>R i) \<le> (1/2) ^ k" .
+    qed
+    also have "... < DIM('a)*(e/DIM('a))"
+      using DIM_positive k linordered_comm_semiring_strict_class.comm_mult_strict_left_mono of_nat_0_less_iff by blast
+    also have "... = e"
+      by simp
+    finally have "dist (\<Sum>i\<in>Basis. (\<lfloor>2^k*(x \<bullet> i)\<rfloor> / 2^k) *\<^sub>R i) x < e" .
+    then
+    show "\<exists>k. \<exists>f \<in> Basis \<rightarrow> \<int>. dist (\<Sum>b\<in>Basis. (f b / 2^k) *\<^sub>R b) x < e"
+      apply (rule_tac x=k in exI)
+      apply (rule_tac x="\<lambda>i. of_int (floor (2^k*(x \<bullet> i)))" in bexI)
+       apply auto
+      done
+  qed
+  then show ?thesis by auto
+qed
+
+corollary closure_rational_coordinates:
+    "closure (\<Union>f \<in> Basis \<rightarrow> \<rat>. { \<Sum>i :: 'a :: euclidean_space \<in> Basis. f i *\<^sub>R i }) = UNIV"
+proof -
+  have *: "(\<Union>k. \<Union>f \<in> Basis \<rightarrow> \<int>. { \<Sum>i::'a \<in> Basis. (f i / 2^k) *\<^sub>R i })
+           \<subseteq> (\<Union>f \<in> Basis \<rightarrow> \<rat>. { \<Sum>i \<in> Basis. f i *\<^sub>R i })"
+  proof clarsimp
+    fix k and f :: "'a \<Rightarrow> real"
+    assume f: "f \<in> Basis \<rightarrow> \<int>"
+    show "\<exists>x \<in> Basis \<rightarrow> \<rat>. (\<Sum>i \<in> Basis. (f i / 2^k) *\<^sub>R i) = (\<Sum>i \<in> Basis. x i *\<^sub>R i)"
+      apply (rule_tac x="\<lambda>i. f i / 2^k" in bexI)
+      using Ints_subset_Rats f by auto
+  qed
+  show ?thesis
+    using closure_dyadic_rationals closure_mono [OF *] by blast
+qed
+
+lemma closure_dyadic_rationals_in_convex_set:
+   "\<lbrakk>convex S; interior S \<noteq> {}\<rbrakk>
+        \<Longrightarrow> closure(S \<inter>
+                    (\<Union>k. \<Union>f \<in> Basis \<rightarrow> \<int>.
+                   { \<Sum>i :: 'a :: euclidean_space \<in> Basis. (f i / 2^k) *\<^sub>R i })) =
+            closure S"
+  by (simp add: closure_dyadic_rationals closure_convex_Int_superset)
+
+lemma closure_rationals_in_convex_set:
+   "\<lbrakk>convex S; interior S \<noteq> {}\<rbrakk>
+    \<Longrightarrow> closure(S \<inter> (\<Union>f \<in> Basis \<rightarrow> \<rat>. { \<Sum>i :: 'a :: euclidean_space \<in> Basis. f i *\<^sub>R i })) =
+        closure S"
+  by (simp add: closure_rational_coordinates closure_convex_Int_superset)
+
+
+text\<open> Every path between distinct points contains an arc, and hence
+path connection is equivalent to arcwise connection for distinct points.
+The proof is based on Whyburn's "Topological Analysis".\<close>
+
+lemma closure_dyadic_rationals_in_convex_set_pos_1:
+  fixes S :: "real set"
+  assumes "convex S" and intnz: "interior S \<noteq> {}" and pos: "\<And>x. x \<in> S \<Longrightarrow> 0 \<le> x"
+    shows "closure(S \<inter> (\<Union>k m. {of_nat m / 2^k})) = closure S"
+proof -
+  have "\<exists>m. f 1/2^k = real m / 2^k" if "(f 1) / 2^k \<in> S" "f 1 \<in> \<int>" for k and f :: "real \<Rightarrow> real"
+    using that by (force simp: Ints_def zero_le_divide_iff power_le_zero_eq dest: pos zero_le_imp_eq_int)
+  then have "S \<inter> (\<Union>k m. {real m / 2^k}) = S \<inter>
+             (\<Union>k. \<Union>f\<in>Basis \<rightarrow> \<int>. {\<Sum>i\<in>Basis. (f i / 2^k) *\<^sub>R i})"
+    by force
+  then show ?thesis
+    using closure_dyadic_rationals_in_convex_set [OF \<open>convex S\<close> intnz] by simp
+qed
+
+
+definition dyadics :: "'a::field_char_0 set" where "dyadics \<equiv> \<Union>k m. {of_nat m / 2^k}"
+
+lemma real_in_dyadics [simp]: "real m \<in> dyadics"
+  apply (simp add: dyadics_def)
+  by (metis divide_numeral_1 numeral_One power_0)
+
+lemma nat_neq_4k1: "of_nat m \<noteq> (4 * of_nat k + 1) / (2 * 2^n :: 'a::field_char_0)"
+proof
+  assume "of_nat m = (4 * of_nat k + 1) / (2 * 2^n :: 'a)"
+  then have "of_nat (m * (2 * 2^n)) = (of_nat (Suc (4 * k)) :: 'a)"
+    by (simp add: divide_simps)
+  then have "m * (2 * 2^n) = Suc (4 * k)"
+    using of_nat_eq_iff by blast
+  then have "odd (m * (2 * 2^n))"
+    by simp
+  then show False
+    by simp
+qed
+
+lemma nat_neq_4k3: "of_nat m \<noteq> (4 * of_nat k + 3) / (2 * 2^n :: 'a::field_char_0)"
+proof
+  assume "of_nat m = (4 * of_nat k + 3) / (2 * 2^n :: 'a)"
+  then have "of_nat (m * (2 * 2^n)) = (of_nat (4 * k + 3) :: 'a)"
+    by (simp add: divide_simps)
+  then have "m * (2 * 2^n) = (4 * k) + 3"
+    using of_nat_eq_iff by blast
+  then have "odd (m * (2 * 2^n))"
+    by simp
+  then show False
+    by simp
+qed
+
+lemma iff_4k:
+  assumes "r = real k" "odd k"
+    shows "(4 * real m + r) / (2 * 2^n) = (4 * real m' + r) / (2 * 2 ^ n') \<longleftrightarrow> m=m' \<and> n=n'"
+proof -
+  { assume "(4 * real m + r) / (2 * 2^n) = (4 * real m' + r) / (2 * 2 ^ n')"
+    then have "real ((4 * m + k) * (2 * 2 ^ n')) = real ((4 * m' + k) * (2 * 2^n))"
+      using assms by (auto simp: field_simps)
+    then have "(4 * m + k) * (2 * 2 ^ n') = (4 * m' + k) * (2 * 2^n)"
+      using of_nat_eq_iff by blast
+    then have "(4 * m + k) * (2 ^ n') = (4 * m' + k) * (2^n)"
+      by linarith
+    then obtain "4*m + k = 4*m' + k" "n=n'"
+      apply (rule prime_power_cancel2 [OF two_is_prime_nat])
+      using assms by auto
+    then have "m=m'" "n=n'"
+      by auto
+  }
+  then show ?thesis by blast
+qed
+
+lemma neq_4k1_k43: "(4 * real m + 1) / (2 * 2^n) \<noteq> (4 * real m' + 3) / (2 * 2 ^ n')"
+proof
+  assume "(4 * real m + 1) / (2 * 2^n) = (4 * real m' + 3) / (2 * 2 ^ n')"
+  then have "real (Suc (4 * m) * (2 * 2 ^ n')) = real ((4 * m' + 3) * (2 * 2^n))"
+    by (auto simp: field_simps)
+  then have "Suc (4 * m) * (2 * 2 ^ n') = (4 * m' + 3) * (2 * 2^n)"
+    using of_nat_eq_iff by blast
+  then have "Suc (4 * m) * (2 ^ n') = (4 * m' + 3) * (2^n)"
+    by linarith
+  then have "Suc (4 * m) = (4 * m' + 3)"
+    by (rule prime_power_cancel2 [OF two_is_prime_nat]) auto
+  then have "1 + 2 * m' = 2 * m"
+    using \<open>Suc (4 * m) = 4 * m' + 3\<close> by linarith
+  then show False
+    using even_Suc by presburger
+qed
+
+lemma dyadic_413_cases:
+  obtains "(of_nat m::'a::field_char_0) / 2^k \<in> Nats"
+  | m' k' where "k' < k" "(of_nat m:: 'a) / 2^k = of_nat (4*m' + 1) / 2^Suc k'"
+  | m' k' where "k' < k" "(of_nat m:: 'a) / 2^k = of_nat (4*m' + 3) / 2^Suc k'"
+proof (cases "m>0")
+  case False
+  then have "m=0" by simp
+  with that show ?thesis by auto
+next
+  case True
+  obtain k' m' where m': "odd m'" and k': "m = m' * 2^k'"
+    using prime_power_canonical [OF two_is_prime_nat True] by blast
+  then obtain q r where q: "m' = 4*q + r" and r: "r < 4"
+    by (metis not_add_less2 split_div zero_neq_numeral)
+  show ?thesis
+  proof (cases "k \<le> k'")
+    case True
+    have "(of_nat m:: 'a) / 2^k = of_nat m' * (2 ^ k' / 2^k)"
+      using k' by (simp add: field_simps)
+    also have "... = (of_nat m'::'a) * 2 ^ (k'-k)"
+      using k' True by (simp add: power_diff)
+    also have "... \<in> \<nat>"
+      by (metis Nats_mult of_nat_in_Nats of_nat_numeral of_nat_power)
+    finally show ?thesis by (auto simp: that)
+  next
+    case False
+    then obtain kd where kd: "Suc kd = k - k'"
+      using Suc_diff_Suc not_less by blast
+    have "(of_nat m:: 'a) / 2^k = of_nat m' * (2 ^ k' / 2^k)"
+      using k' by (simp add: field_simps)
+    also have "... = (of_nat m'::'a) / 2 ^ (k-k')"
+      using k' False by (simp add: power_diff)
+    also have "... = ((of_nat r + 4 * of_nat q)::'a) / 2 ^ (k-k')"
+      using q by force
+    finally have meq: "(of_nat m:: 'a) / 2^k = (of_nat r + 4 * of_nat q) / 2 ^ (k - k')" .
+    have "r \<noteq> 0" "r \<noteq> 2"
+      using q m' by presburger+
+    with r consider "r = 1" | "r = 3"
+      by linarith
+    then show ?thesis
+    proof cases
+      assume "r = 1"
+      with meq kd that(2) [of kd q] show ?thesis
+        by simp
+    next
+      assume "r = 3"
+      with meq kd that(3) [of kd q]  show ?thesis
+        by simp
+    qed
+  qed
+qed
+
+
+lemma dyadics_iff:
+   "(dyadics :: 'a::field_char_0 set) =
+    Nats \<union> (\<Union>k m. {of_nat (4*m + 1) / 2^Suc k}) \<union> (\<Union>k m. {of_nat (4*m + 3) / 2^Suc k})"
+           (is "_ = ?rhs")
+proof
+  show "dyadics \<subseteq> ?rhs"
+    unfolding dyadics_def
+    apply clarify
+    apply (rule dyadic_413_cases, force+)
+    done
+next
+  show "?rhs \<subseteq> dyadics"
+    apply (clarsimp simp: dyadics_def Nats_def simp del: power_Suc)
+    apply (intro conjI subsetI)
+    apply (auto simp del: power_Suc)
+      apply (metis divide_numeral_1 numeral_One power_0)
+     apply (metis of_nat_Suc of_nat_mult of_nat_numeral)
+    by (metis of_nat_add of_nat_mult of_nat_numeral)
+qed
+
+
+function (domintros) dyad_rec :: "[nat \<Rightarrow> 'a, 'a\<Rightarrow>'a, 'a\<Rightarrow>'a, real] \<Rightarrow> 'a" where
+    "dyad_rec b l r (real m) = b m"
+  | "dyad_rec b l r ((4 * real m + 1) / 2 ^ (Suc n)) = l (dyad_rec b l r ((2*m + 1) / 2^n))"
+  | "dyad_rec b l r ((4 * real m + 3) / 2 ^ (Suc n)) = r (dyad_rec b l r ((2*m + 1) / 2^n))"
+  | "x \<notin> dyadics \<Longrightarrow> dyad_rec b l r x = undefined"
+  using iff_4k [of _ 1] iff_4k [of _ 3]
+         apply (simp_all add: nat_neq_4k1 nat_neq_4k3 neq_4k1_k43, atomize_elim)
+     apply (fastforce simp add: dyadics_iff Nats_def field_simps)+
+  done
+
+lemma dyadics_levels: "dyadics = (\<Union>K. \<Union>k<K. \<Union> m. {of_nat m / 2^k})"
+  unfolding dyadics_def by auto
+
+lemma dyad_rec_level_termination:
+  assumes "k < K"
+  shows "dyad_rec_dom(b, l, r, real m / 2^k)"
+  using assms
+proof (induction K arbitrary: k m)
+  case 0
+  then show ?case by auto
+next
+  case (Suc K)
+  then consider "k = K" | "k < K"
+    using less_antisym by blast
+  then show ?case
+  proof cases
+    assume "k = K"
+    show ?case
+    proof (rule dyadic_413_cases [of m k, where 'a=real])
+      show "real m / 2^k \<in> \<nat> \<Longrightarrow> dyad_rec_dom (b, l, r, real m / 2^k)"
+        by (force simp: Nats_def nat_neq_4k1 nat_neq_4k3 intro: dyad_rec.domintros)
+      show ?case if "k' < k" and eq: "real m / 2^k = real (4 * m' + 1) / 2^Suc k'" for m' k'
+      proof -
+        have "dyad_rec_dom (b, l, r, (4 * real m' + 1) / 2^Suc k')"
+        proof (rule dyad_rec.domintros)
+          fix m n
+          assume "(4 * real m' + 1) / (2 * 2 ^ k') = (4 * real m + 1) / (2 * 2^n)"
+          then have "m' = m" "k' = n" using iff_4k [of _ 1]
+            by auto
+          have "dyad_rec_dom (b, l, r, real (2 * m + 1) / 2 ^ k')"
+            using Suc.IH \<open>k = K\<close> \<open>k' < k\<close> by blast
+          then show "dyad_rec_dom (b, l, r, (2 * real m + 1) / 2^n)"
+            using \<open>k' = n\<close> by (auto simp: algebra_simps)
+        next
+          fix m n
+          assume "(4 * real m' + 1) / (2 * 2 ^ k') = (4 * real m + 3) / (2 * 2^n)"
+          then have "False"
+            by (metis neq_4k1_k43)
+          then show "dyad_rec_dom (b, l, r, (2 * real m + 1) / 2^n)" ..
+        qed
+        then show ?case by (simp add: eq add_ac)
+      qed
+      show ?case if "k' < k" and eq: "real m / 2^k = real (4 * m' + 3) / 2^Suc k'" for m' k'
+      proof -
+        have "dyad_rec_dom (b, l, r, (4 * real m' + 3) / 2^Suc k')"
+        proof (rule dyad_rec.domintros)
+          fix m n
+          assume "(4 * real m' + 3) / (2 * 2 ^ k') = (4 * real m + 1) / (2 * 2^n)"
+          then have "False"
+            by (metis neq_4k1_k43)
+          then show "dyad_rec_dom (b, l, r, (2 * real m + 1) / 2^n)" ..
+        next
+          fix m n
+          assume "(4 * real m' + 3) / (2 * 2 ^ k') = (4 * real m + 3) / (2 * 2^n)"
+          then have "m' = m" "k' = n" using iff_4k [of _ 3]
+            by auto
+          have "dyad_rec_dom (b, l, r, real (2 * m + 1) / 2 ^ k')"
+            using Suc.IH \<open>k = K\<close> \<open>k' < k\<close> by blast
+          then show "dyad_rec_dom (b, l, r, (2 * real m + 1) / 2^n)"
+            using \<open>k' = n\<close> by (auto simp: algebra_simps)
+        qed
+        then show ?case by (simp add: eq add_ac)
+      qed
+    qed
+  next
+    assume "k < K"
+    then show ?case
+      using Suc.IH by blast
+  qed
+qed
+
+
+lemma dyad_rec_termination: "x \<in> dyadics \<Longrightarrow> dyad_rec_dom(b,l,r,x)"
+  by (auto simp: dyadics_levels intro: dyad_rec_level_termination)
+
+lemma dyad_rec_of_nat [simp]: "dyad_rec b l r (real m) = b m"
+  by (simp add: dyad_rec.psimps dyad_rec_termination)
+
+lemma dyad_rec_41 [simp]: "dyad_rec b l r ((4 * real m + 1) / 2 ^ (Suc n)) = l (dyad_rec b l r ((2*m + 1) / 2^n))"
+  apply (rule dyad_rec.psimps)
+  by (metis dyad_rec_level_termination lessI add.commute of_nat_Suc of_nat_mult of_nat_numeral)
+
+
+lemma dyad_rec_43 [simp]: "dyad_rec b l r ((4 * real m + 3) / 2 ^ (Suc n)) = r (dyad_rec b l r ((2*m + 1) / 2^n))"
+  apply (rule dyad_rec.psimps)
+  by (metis dyad_rec_level_termination lessI of_nat_add of_nat_mult of_nat_numeral)
+
+lemma dyad_rec_41_times2:
+  assumes "n > 0"
+    shows "dyad_rec b l r (2 * ((4 * real m + 1) / 2^Suc n)) = l (dyad_rec b l r (2 * (2 * real m + 1) / 2^n))"
+proof -
+  obtain n' where n': "n = Suc n'"
+    using assms not0_implies_Suc by blast
+  have "dyad_rec b l r (2 * ((4 * real m + 1) / 2^Suc n)) = dyad_rec b l r ((2 * (4 * real m + 1)) / (2 * 2^n))"
+    by auto
+  also have "... = dyad_rec b l r ((4 * real m + 1) / 2^n)"
+    by (subst mult_divide_mult_cancel_left) auto
+  also have "... = l (dyad_rec b l r ((2 * real m + 1) / 2 ^ n'))"
+    by (simp add: add.commute [of 1] n' del: power_Suc)
+  also have "... = l (dyad_rec b l r ((2 * (2 * real m + 1)) / (2 * 2 ^ n')))"
+    by (subst mult_divide_mult_cancel_left) auto
+  also have "... = l (dyad_rec b l r (2 * (2 * real m + 1) / 2^n))"
+    by (simp add: add.commute n')
+  finally show ?thesis .
+qed
+
+lemma dyad_rec_43_times2:
+  assumes "n > 0"
+    shows "dyad_rec b l r (2 * ((4 * real m + 3) / 2^Suc n)) = r (dyad_rec b l r (2 * (2 * real m + 1) / 2^n))"
+proof -
+  obtain n' where n': "n = Suc n'"
+    using assms not0_implies_Suc by blast
+  have "dyad_rec b l r (2 * ((4 * real m + 3) / 2^Suc n)) = dyad_rec b l r ((2 * (4 * real m + 3)) / (2 * 2^n))"
+    by auto
+  also have "... = dyad_rec b l r ((4 * real m + 3) / 2^n)"
+    by (subst mult_divide_mult_cancel_left) auto
+  also have "... = r (dyad_rec b l r ((2 * real m + 1) / 2 ^ n'))"
+    by (simp add: n' del: power_Suc)
+  also have "... = r (dyad_rec b l r ((2 * (2 * real m + 1)) / (2 * 2 ^ n')))"
+    by (subst mult_divide_mult_cancel_left) auto
+  also have "... = r (dyad_rec b l r (2 * (2 * real m + 1) / 2^n))"
+    by (simp add: n')
+  finally show ?thesis .
+qed
+
+definition dyad_rec2
+    where "dyad_rec2 u v lc rc x =
+             dyad_rec (\<lambda>z. (u,v)) (\<lambda>(a,b). (a, lc a b (midpoint a b))) (\<lambda>(a,b). (rc a b (midpoint a b), b)) (2*x)"
+
+abbreviation leftrec where "leftrec u v lc rc x \<equiv> fst (dyad_rec2 u v lc rc x)"
+abbreviation rightrec where "rightrec u v lc rc x \<equiv> snd (dyad_rec2 u v lc rc x)"
+
+lemma leftrec_base: "leftrec u v lc rc (real m / 2) = u"
+  by (simp add: dyad_rec2_def)
+
+lemma leftrec_41: "n > 0 \<Longrightarrow> leftrec u v lc rc ((4 * real m + 1) / 2 ^ (Suc n)) = leftrec u v lc rc ((2 * real m + 1) / 2^n)"
+  apply (simp only: dyad_rec2_def dyad_rec_41_times2)
+  apply (simp add: case_prod_beta)
+  done
+
+lemma leftrec_43: "n > 0 \<Longrightarrow>
+             leftrec u v lc rc ((4 * real m + 3) / 2 ^ (Suc n)) =
+                 rc (leftrec u v lc rc ((2 * real m + 1) / 2^n)) (rightrec u v lc rc ((2 * real m + 1) / 2^n))
+                 (midpoint (leftrec u v lc rc ((2 * real m + 1) / 2^n)) (rightrec u v lc rc ((2 * real m + 1) / 2^n)))"
+  apply (simp only: dyad_rec2_def dyad_rec_43_times2)
+  apply (simp add: case_prod_beta)
+  done
+
+lemma rightrec_base: "rightrec u v lc rc (real m / 2) = v"
+  by (simp add: dyad_rec2_def)
+
+lemma rightrec_41: "n > 0 \<Longrightarrow>
+             rightrec u v lc rc ((4 * real m + 1) / 2 ^ (Suc n)) =
+                 lc (leftrec u v lc rc ((2 * real m + 1) / 2^n)) (rightrec u v lc rc ((2 * real m + 1) / 2^n))
+                 (midpoint (leftrec u v lc rc ((2 * real m + 1) / 2^n)) (rightrec u v lc rc ((2 * real m + 1) / 2^n)))"
+  apply (simp only: dyad_rec2_def dyad_rec_41_times2)
+  apply (simp add: case_prod_beta)
+  done
+
+lemma rightrec_43: "n > 0 \<Longrightarrow> rightrec u v lc rc ((4 * real m + 3) / 2 ^ (Suc n)) = rightrec u v lc rc ((2 * real m + 1) / 2^n)"
+  apply (simp only: dyad_rec2_def dyad_rec_43_times2)
+  apply (simp add: case_prod_beta)
+  done
+
+lemma dyadics_in_open_unit_interval:
+   "{0<..<1} \<inter> (\<Union>k m. {real m / 2^k}) = (\<Union>k. \<Union>m \<in> {0<..<2^k}. {real m / 2^k})"
+  by (auto simp: divide_simps)
+
+
+
+theorem homeomorphic_monotone_image_interval:
+  fixes f :: "real \<Rightarrow> 'a::{real_normed_vector,complete_space}"
+  assumes cont_f: "continuous_on {0..1} f"
+      and conn: "\<And>y. connected ({0..1} \<inter> f -` {y})"
+      and f_1not0: "f 1 \<noteq> f 0"
+    shows "(f ` {0..1}) homeomorphic {0..1::real}"
+proof -
+  have "\<exists>c d. a \<le> c \<and> c \<le> m \<and> m \<le> d \<and> d \<le> b \<and>
+              (\<forall>x \<in> {c..d}. f x = f m) \<and>
+              (\<forall>x \<in> {a..<c}. (f x \<noteq> f m)) \<and>
+              (\<forall>x \<in> {d<..b}. (f x \<noteq> f m)) \<and>
+              (\<forall>x \<in> {a..<c}. \<forall>y \<in> {d<..b}. f x \<noteq> f y)"
+    if m: "m \<in> {a..b}" and ab01: "{a..b} \<subseteq> {0..1}" for a b m
+  proof -
+    have comp: "compact (f -` {f m} \<inter> {0..1})"
+      by (simp add: compact_eq_bounded_closed bounded_Int closed_vimage_Int cont_f)
+    obtain c0 d0 where cd0: "{0..1} \<inter> f -` {f m} = {c0..d0}"
+      using connected_compact_interval_1 [of "{0..1} \<inter> f -` {f m}"] conn comp
+      by (metis Int_commute)
+    with that have "m \<in> cbox c0 d0"
+      by auto
+    obtain c d where cd: "{a..b} \<inter> f -` {f m} = {c..d}"
+      apply (rule_tac c="max a c0" and d="min b d0" in that)
+      using ab01 cd0 by auto
+    then have cdab: "{c..d} \<subseteq> {a..b}"
+      by blast
+    show ?thesis
+    proof (intro exI conjI ballI)
+      show "a \<le> c" "d \<le> b"
+        using cdab cd m by auto
+      show "c \<le> m" "m \<le> d"
+        using cd m by auto
+      show "\<And>x. x \<in> {c..d} \<Longrightarrow> f x = f m"
+        using cd by blast
+      show "f x \<noteq> f m" if "x \<in> {a..<c}" for x
+        using that m cd [THEN equalityD1, THEN subsetD] \<open>c \<le> m\<close> by force
+      show "f x \<noteq> f m" if "x \<in> {d<..b}" for x
+        using that m cd [THEN equalityD1, THEN subsetD, of x] \<open>m \<le> d\<close> by force
+      show "f x \<noteq> f y" if "x \<in> {a..<c}" "y \<in> {d<..b}" for x y
+      proof (cases "f x = f m \<or> f y = f m")
+        case True
+        then show ?thesis
+          using \<open>\<And>x. x \<in> {a..<c} \<Longrightarrow> f x \<noteq> f m\<close> that by auto
+      next
+        case False
+        have False if "f x = f y"
+        proof -
+          have "x \<le> m" "m \<le> y"
+            using \<open>c \<le> m\<close> \<open>x \<in> {a..<c}\<close>  \<open>m \<le> d\<close> \<open>y \<in> {d<..b}\<close> by auto
+          then have "x \<in> ({0..1} \<inter> f -` {f y})" "y \<in> ({0..1} \<inter> f -` {f y})"
+            using \<open>x \<in> {a..<c}\<close> \<open>y \<in> {d<..b}\<close> ab01 by (auto simp: that)
+          then have "m \<in> ({0..1} \<inter> f -` {f y})"
+            by (meson \<open>m \<le> y\<close> \<open>x \<le> m\<close> is_interval_connected_1 conn [of "f y"] is_interval_1)
+          with False show False by auto
+        qed
+        then show ?thesis by auto
+      qed
+    qed
+  qed
+  then obtain leftcut rightcut where LR:
+    "\<And>a b m. \<lbrakk>m \<in> {a..b}; {a..b} \<subseteq> {0..1}\<rbrakk> \<Longrightarrow>
+            (a \<le> leftcut a b m \<and> leftcut a b m \<le> m \<and> m \<le> rightcut a b m \<and> rightcut a b m \<le> b \<and>
+            (\<forall>x \<in> {leftcut a b m..rightcut a b m}. f x = f m) \<and>
+            (\<forall>x \<in> {a..<leftcut a b m}. f x \<noteq> f m) \<and>
+            (\<forall>x \<in> {rightcut a b m<..b}. f x \<noteq> f m) \<and>
+            (\<forall>x \<in> {a..<leftcut a b m}. \<forall>y \<in> {rightcut a b m<..b}. f x \<noteq> f y))"
+    apply atomize
+    apply (clarsimp simp only: imp_conjL [symmetric] choice_iff choice_iff')
+    apply (rule that, blast)
+    done
+  then have left_right: "\<And>a b m. \<lbrakk>m \<in> {a..b}; {a..b} \<subseteq> {0..1}\<rbrakk> \<Longrightarrow> a \<le> leftcut a b m \<and> rightcut a b m \<le> b"
+    and left_right_m: "\<And>a b m. \<lbrakk>m \<in> {a..b}; {a..b} \<subseteq> {0..1}\<rbrakk> \<Longrightarrow> leftcut a b m \<le> m \<and> m \<le> rightcut a b m"
+    by auto
+  have left_neq: "\<lbrakk>a \<le> x; x < leftcut a b m; a \<le> m; m \<le> b; {a..b} \<subseteq> {0..1}\<rbrakk> \<Longrightarrow> f x \<noteq> f m"
+    and right_neq: "\<lbrakk>rightcut a b m < x; x \<le> b; a \<le> m; m \<le> b; {a..b} \<subseteq> {0..1}\<rbrakk> \<Longrightarrow> f x \<noteq> f m"
+    and left_right_neq: "\<lbrakk>a \<le> x; x < leftcut a b m; rightcut a b m < y; y \<le> b; a \<le> m; m \<le> b; {a..b} \<subseteq> {0..1}\<rbrakk> \<Longrightarrow> f x \<noteq> f m"
+    and feqm: "\<lbrakk>leftcut a b m \<le> x; x \<le> rightcut a b m; a \<le> m; m \<le> b; {a..b} \<subseteq> {0..1}\<rbrakk>
+                         \<Longrightarrow> f x = f m" for a b m x y
+    by (meson atLeastAtMost_iff greaterThanAtMost_iff atLeastLessThan_iff LR)+
+  have f_eqI: "\<And>a b m x y. \<lbrakk>leftcut a b m \<le> x; x \<le> rightcut a b m; leftcut a b m \<le> y; y \<le> rightcut a b m;
+                             a \<le> m; m \<le> b; {a..b} \<subseteq> {0..1}\<rbrakk>  \<Longrightarrow> f x = f y"
+    by (metis feqm)
+  define u where "u \<equiv> rightcut 0 1 0"
+  have lc[simp]: "leftcut 0 1 0 = 0" and u01: "0 \<le> u" "u \<le> 1"
+    using LR [of 0 0 1] by (auto simp: u_def)
+  have f0u: "\<And>x. x \<in> {0..u} \<Longrightarrow> f x = f 0"
+    using LR [of 0 0 1] unfolding u_def [symmetric]
+    by (metis \<open>leftcut 0 1 0 = 0\<close> atLeastAtMost_iff order_refl zero_le_one)
+  have fu1: "\<And>x. x \<in> {u<..1} \<Longrightarrow> f x \<noteq> f 0"
+    using LR [of 0 0 1] unfolding u_def [symmetric] by fastforce
+  define v where "v \<equiv> leftcut u 1 1"
+  have rc[simp]: "rightcut u 1 1 = 1" and v01: "u \<le> v" "v \<le> 1"
+    using LR [of 1 u 1] u01  by (auto simp: v_def)
+  have fuv: "\<And>x. x \<in> {u..<v} \<Longrightarrow> f x \<noteq> f 1"
+    using LR [of 1 u 1] u01 v_def by fastforce
+  have f0v: "\<And>x. x \<in> {0..<v} \<Longrightarrow> f x \<noteq> f 1"
+    by (metis f_1not0 atLeastAtMost_iff atLeastLessThan_iff f0u fuv linear)
+  have fv1: "\<And>x. x \<in> {v..1} \<Longrightarrow> f x = f 1"
+    using LR [of 1 u 1] u01 v_def by (metis atLeastAtMost_iff atLeastatMost_subset_iff order_refl rc)
+  define a where "a \<equiv> leftrec u v leftcut rightcut"
+  define b where "b \<equiv> rightrec u v leftcut rightcut"
+  define c where "c \<equiv> \<lambda>x. midpoint (a x) (b x)"
+  have a_real [simp]: "a (real j) = u" for j
+    using a_def leftrec_base
+    by (metis nonzero_mult_div_cancel_right of_nat_mult of_nat_numeral zero_neq_numeral)
+  have b_real [simp]: "b (real j) = v" for j
+    using b_def rightrec_base
+    by (metis nonzero_mult_div_cancel_right of_nat_mult of_nat_numeral zero_neq_numeral)
+  have a41: "a ((4 * real m + 1) / 2^Suc n) = a ((2 * real m + 1) / 2^n)" if "n > 0" for m n
+    using that a_def leftrec_41 by blast
+  have b41: "b ((4 * real m + 1) / 2^Suc n) =
+               leftcut (a ((2 * real m + 1) / 2^n))
+                       (b ((2 * real m + 1) / 2^n))
+                       (c ((2 * real m + 1) / 2^n))" if "n > 0" for m n
+    using that a_def b_def c_def rightrec_41 by blast
+  have a43: "a ((4 * real m + 3) / 2^Suc n) =
+               rightcut (a ((2 * real m + 1) / 2^n))
+                        (b ((2 * real m + 1) / 2^n))
+                        (c ((2 * real m + 1) / 2^n))" if "n > 0" for m n
+    using that a_def b_def c_def leftrec_43 by blast
+  have b43: "b ((4 * real m + 3) / 2^Suc n) = b ((2 * real m + 1) / 2^n)" if "n > 0" for m n
+    using that b_def rightrec_43 by blast
+  have uabv: "u \<le> a (real m / 2 ^ n) \<and> a (real m / 2 ^ n) \<le> b (real m / 2 ^ n) \<and> b (real m / 2 ^ n) \<le> v" for m n
+  proof (induction n arbitrary: m)
+    case 0
+    then show ?case by (simp add: v01)
+  next
+    case (Suc n p)
+    show ?case
+    proof (cases "even p")
+      case True
+      then obtain m where "p = 2*m" by (metis evenE)
+      then show ?thesis
+        by (simp add: Suc.IH)
+    next
+      case False
+      then obtain m where m: "p = 2*m + 1" by (metis oddE)
+      show ?thesis
+      proof (cases n)
+        case 0
+        then show ?thesis
+          by (simp add: a_def b_def leftrec_base rightrec_base v01)
+      next
+        case (Suc n')
+        then have "n > 0" by simp
+        have a_le_c: "a (real m / 2^n) \<le> c (real m / 2^n)" for m
+          unfolding c_def by (metis Suc.IH ge_midpoint_1)
+        have c_le_b: "c (real m / 2^n) \<le> b (real m / 2^n)" for m
+          unfolding c_def by (metis Suc.IH le_midpoint_1)
+        have c_ge_u: "c (real m / 2^n) \<ge> u" for m
+          using Suc.IH a_le_c order_trans by blast
+        have c_le_v: "c (real m / 2^n) \<le> v" for m
+          using Suc.IH c_le_b order_trans by blast
+        have a_ge_0: "0 \<le> a (real m / 2^n)" for m
+          using Suc.IH order_trans u01(1) by blast
+        have b_le_1: "b (real m / 2^n) \<le> 1" for m
+          using Suc.IH order_trans v01(2) by blast
+        have left_le: "leftcut (a ((real m) / 2^n)) (b ((real m) / 2^n)) (c ((real m) / 2^n)) \<le> c ((real m) / 2^n)" for m
+          by (simp add: LR a_ge_0 a_le_c b_le_1 c_le_b)
+        have right_ge: "rightcut (a ((real m) / 2^n)) (b ((real m) / 2^n)) (c ((real m) / 2^n)) \<ge> c ((real m) / 2^n)" for m
+          by (simp add: LR a_ge_0 a_le_c b_le_1 c_le_b)
+        show ?thesis
+        proof (cases "even m")
+          case True
+          then obtain r where r: "m = 2*r" by (metis evenE)
+          show ?thesis
+            using a_le_c [of "m+1"] c_le_b [of "m+1"] a_ge_0 [of "m+1"] b_le_1 [of "m+1"]
+              Suc.IH [of "m+1"]
+            apply (simp add: r m add.commute [of 1] \<open>n > 0\<close> a41 b41 del: power_Suc)
+            apply (auto simp: left_right [THEN conjunct1])
+            using  order_trans [OF left_le c_le_v]
+            by (metis (no_types, hide_lams) add.commute mult_2 of_nat_Suc of_nat_add)
+        next
+          case False
+          then obtain r where r: "m = 2*r + 1" by (metis oddE)
+          show ?thesis
+            using a_le_c [of "m"] c_le_b [of "m"] a_ge_0 [of "m"] b_le_1 [of "m"]
+              Suc.IH [of "m+1"]
+            apply (simp add: r m add.commute [of 3] \<open>n > 0\<close> a43 b43 del: power_Suc)
+            apply (auto simp: add.commute left_right [THEN conjunct2])
+            using  order_trans [OF c_ge_u right_ge]
+             apply (metis (no_types, hide_lams) mult_2 numeral_One of_nat_add of_nat_numeral)
+            apply (metis Suc.IH mult_2 of_nat_1 of_nat_add)
+            done
+        qed
+      qed
+    qed
+  qed
+  have a_ge_0 [simp]: "0 \<le> a(m / 2^n)" and b_le_1 [simp]: "b(m / 2^n) \<le> 1" for m::nat and n
+    using uabv order_trans u01 v01 by blast+
+  then have b_ge_0 [simp]: "0 \<le> b(m / 2^n)" and a_le_1 [simp]: "a(m / 2^n) \<le> 1" for m::nat and n
+    using uabv order_trans by blast+
+  have alec [simp]: "a(m / 2^n) \<le> c(m / 2^n)" and cleb [simp]: "c(m / 2^n) \<le> b(m / 2^n)" for m::nat and n
+    by (auto simp: c_def ge_midpoint_1 le_midpoint_1 uabv)
+  have c_ge_0 [simp]: "0 \<le> c(m / 2^n)" and c_le_1 [simp]: "c(m / 2^n) \<le> 1" for m::nat and n
+    using a_ge_0 alec order_trans apply blast
+    by (meson b_le_1 cleb order_trans)
+  have "\<lbrakk>d = m-n; odd j; \<bar>real i / 2^m - real j / 2^n\<bar> < 1/2 ^ n\<rbrakk>
+        \<Longrightarrow> (a(j / 2^n)) \<le> (c(i / 2^m)) \<and> (c(i / 2^m)) \<le> (b(j / 2^n))" for d i j m n
+  proof (induction d arbitrary: j n rule: less_induct)
+    case (less d j n)
+    show ?case
+    proof (cases "m \<le> n")
+      case True
+      have "\<bar>2^n\<bar> * \<bar>real i / 2^m - real j / 2^n\<bar> = 0"
+      proof (rule Ints_nonzero_abs_less1)
+        have "(real i * 2^n - real j * 2^m) / 2^m = (real i * 2^n) / 2^m - (real j * 2^m) / 2^m"
+          using diff_divide_distrib by blast
+        also have "... = (real i * 2 ^ (n-m)) - (real j)"
+          using True by (auto simp: power_diff field_simps)
+        also have "... \<in> \<int>"
+          by simp
+        finally have "(real i * 2^n - real j * 2^m) / 2^m \<in> \<int>" .
+        with True Ints_abs show "\<bar>2^n\<bar> * \<bar>real i / 2^m - real j / 2^n\<bar> \<in> \<int>"
+          by (fastforce simp: divide_simps)
+        show "\<bar>\<bar>2^n\<bar> * \<bar>real i / 2^m - real j / 2^n\<bar>\<bar> < 1"
+          using less.prems by (auto simp: divide_simps)
+      qed
+      then have "real i / 2^m = real j / 2^n"
+        by auto
+      then show ?thesis
+        by auto
+    next
+      case False
+      then have "n < m" by auto
+      obtain k where k: "j = Suc (2*k)"
+        using \<open>odd j\<close> oddE by fastforce
+      show ?thesis
+      proof (cases "n > 0")
+        case False
+        then have "a (real j / 2^n) = u"
+          by simp
+        also have "... \<le> c (real i / 2^m)"
+          using alec uabv by (blast intro: order_trans)
+        finally have ac: "a (real j / 2^n) \<le> c (real i / 2^m)" .
+        have "c (real i / 2^m) \<le> v"
+          using cleb uabv by (blast intro: order_trans)
+        also have "... = b (real j / 2^n)"
+          using False by simp
+        finally show ?thesis
+          by (auto simp: ac)
+      next
+        case True show ?thesis
+        proof (cases "real i / 2^m" "real j / 2^n" rule: linorder_cases)
+          case less
+          moreover have "real (4 * k + 1) / 2 ^ Suc n + 1 / (2 ^ Suc n) = real j / 2 ^ n"
+            using k by (force simp: divide_simps)
+          moreover have "\<bar>real i / 2 ^ m - real j / 2 ^ n\<bar> < 2 / (2 ^ Suc n)"
+            using less.prems by simp
+          ultimately have closer: "\<bar>real i / 2 ^ m - real (4 * k + 1) / 2 ^ Suc n\<bar> < 1 / (2 ^ Suc n)"
+            using less.prems by linarith
+          have *: "a (real (4 * k + 1) / 2 ^ Suc n) \<le> c (real i / 2 ^ m) \<and>
+                   c (real i / 2 ^ m) \<le> b (real (4 * k + 1) / 2 ^ Suc n)"
+            apply (rule less.IH [OF _ refl])
+            using closer \<open>n < m\<close> \<open>d = m - n\<close> apply (auto simp: divide_simps  \<open>n < m\<close> diff_less_mono2)
+            done
+          show ?thesis
+            using LR [of "c((2*k + 1) / 2^n)" "a((2*k + 1) / 2^n)" "b((2*k + 1) / 2^n)"]
+            using alec [of "2*k+1"] cleb [of "2*k+1"] a_ge_0 [of "2*k+1"] b_le_1 [of "2*k+1"]
+            using k a41 b41 * \<open>0 < n\<close>
+            apply (simp add: add.commute)
+            done
+        next
+          case equal then show ?thesis by simp
+        next
+          case greater
+          moreover have "real (4 * k + 3) / 2 ^ Suc n - 1 / (2 ^ Suc n) = real j / 2 ^ n"
+            using k by (force simp: divide_simps)
+          moreover have "\<bar>real i / 2 ^ m - real j / 2 ^ n\<bar> < 2 * 1 / (2 ^ Suc n)"
+            using less.prems by simp
+          ultimately have closer: "\<bar>real i / 2 ^ m - real (4 * k + 3) / 2 ^ Suc n\<bar> < 1 / (2 ^ Suc n)"
+            using less.prems by linarith
+          have *: "a (real (4 * k + 3) / 2 ^ Suc n) \<le> c (real i / 2 ^ m) \<and>
+                   c (real i / 2 ^ m) \<le> b (real (4 * k + 3) / 2 ^ Suc n)"
+            apply (rule less.IH [OF _ refl])
+            using closer \<open>n < m\<close> \<open>d = m - n\<close> apply (auto simp: divide_simps  \<open>n < m\<close> diff_less_mono2)
+            done
+          show ?thesis
+            using LR [of "c((2*k + 1) / 2^n)" "a((2*k + 1) / 2^n)" "b((2*k + 1) / 2^n)"]
+            using alec [of "2*k+1"] cleb [of "2*k+1"] a_ge_0 [of "2*k+1"] b_le_1 [of "2*k+1"]
+            using k a43 b43 * \<open>0 < n\<close>
+            apply (simp add: add.commute)
+            done
+        qed
+      qed
+    qed
+  qed
+  then have aj_le_ci: "a (real j / 2 ^ n) \<le> c (real i / 2 ^ m)"
+    and ci_le_bj: "c (real i / 2 ^ m) \<le> b (real j / 2 ^ n)" if "odd j" "\<bar>real i / 2^m - real j / 2^n\<bar> < 1/2 ^ n" for i j m n
+    using that by blast+
+  have close_ab: "odd m \<Longrightarrow> \<bar>a (real m / 2 ^ n) - b (real m / 2 ^ n)\<bar> \<le> 2 / 2^n" for m n
+  proof (induction n arbitrary: m)
+    case 0
+    with u01 v01 show ?case by auto
+  next
+    case (Suc n m)
+    with oddE obtain k where k: "m = Suc (2*k)" by fastforce
+    show ?case
+    proof (cases "n > 0")
+      case False
+      with u01 v01 show ?thesis
+        by (simp add: a_def b_def leftrec_base rightrec_base)
+    next
+      case True
+      show ?thesis
+      proof (cases "even k")
+        case True
+        then obtain j where j: "k = 2*j" by (metis evenE)
+        have "\<bar>a ((2 * real j + 1) / 2 ^ n) - (b ((2 * real j + 1) / 2 ^ n))\<bar> \<le> 2/2 ^ n"
+        proof -
+          have "odd (Suc k)"
+            using True by auto
+          then show ?thesis
+            by (metis (no_types) Groups.add_ac(2) Suc.IH j of_nat_Suc of_nat_mult of_nat_numeral)
+        qed
+        moreover have "a ((2 * real j + 1) / 2 ^ n) \<le>
+                       leftcut (a ((2 * real j + 1) / 2 ^ n)) (b ((2 * real j + 1) / 2 ^ n)) (c ((2 * real j + 1) / 2 ^ n))"
+          using alec [of "2*j+1"] cleb [of "2*j+1"] a_ge_0 [of "2*j+1"]  b_le_1 [of "2*j+1"]
+          by (auto simp: add.commute left_right)
+        moreover have "leftcut (a ((2 * real j + 1) / 2 ^ n)) (b ((2 * real j + 1) / 2 ^ n)) (c ((2 * real j + 1) / 2 ^ n)) \<le>
+                         c ((2 * real j + 1) / 2 ^ n)"
+          using alec [of "2*j+1"] cleb [of "2*j+1"] a_ge_0 [of "2*j+1"]  b_le_1 [of "2*j+1"]
+          by (auto simp: add.commute left_right_m)
+        ultimately have "\<bar>a ((2 * real j + 1) / 2 ^ n) -
+                          leftcut (a ((2 * real j + 1) / 2 ^ n)) (b ((2 * real j + 1) / 2 ^ n)) (c ((2 * real j + 1) / 2 ^ n))\<bar>
+                   \<le> 2/2 ^ Suc n"
+          by (simp add: c_def midpoint_def)
+        with j k \<open>n > 0\<close> show ?thesis
+          by (simp add: add.commute [of 1] a41 b41 del: power_Suc)
+      next
+        case False
+        then obtain j where j: "k = 2*j + 1" by (metis oddE)
+        have "\<bar>a ((2 * real j + 1) / 2 ^ n) - (b ((2 * real j + 1) / 2 ^ n))\<bar> \<le> 2/2 ^ n"
+          using Suc.IH [OF False] j by (auto simp: algebra_simps)
+        moreover have "c ((2 * real j + 1) / 2 ^ n) \<le>
+                       rightcut (a ((2 * real j + 1) / 2 ^ n)) (b ((2 * real j + 1) / 2 ^ n)) (c ((2 * real j + 1) / 2 ^ n))"
+          using alec [of "2*j+1"] cleb [of "2*j+1"] a_ge_0 [of "2*j+1"]  b_le_1 [of "2*j+1"]
+          by (auto simp: add.commute left_right_m)
+        moreover have "rightcut (a ((2 * real j + 1) / 2 ^ n)) (b ((2 * real j + 1) / 2 ^ n)) (c ((2 * real j + 1) / 2 ^ n)) \<le>
+                         b ((2 * real j + 1) / 2 ^ n)"
+          using alec [of "2*j+1"] cleb [of "2*j+1"] a_ge_0 [of "2*j+1"]  b_le_1 [of "2*j+1"]
+          by (auto simp: add.commute left_right)
+        ultimately have "\<bar>rightcut (a ((2 * real j + 1) / 2 ^ n)) (b ((2 * real j + 1) / 2 ^ n)) (c ((2 * real j + 1) / 2 ^ n)) -
+                          b ((2 * real j + 1) / 2 ^ n)\<bar>  \<le>  2/2 ^ Suc n"
+          by (simp add: c_def midpoint_def)
+        with j k \<open>n > 0\<close> show ?thesis
+          by (simp add: add.commute [of 3] a43 b43 del: power_Suc)
+      qed
+    qed
+  qed
+  have m1_to_3: "4 * real k - 1 = real (4 * (k-1)) + 3" if "0 < k" for k
+    using that by auto
+  have fb_eq_fa: "\<lbrakk>0 < j; 2*j < 2 ^ n\<rbrakk> \<Longrightarrow> f(b((2 * real j - 1) / 2^n)) = f(a((2 * real j + 1) / 2^n))" for n j
+  proof (induction n arbitrary: j)
+    case 0
+    then show ?case by auto
+  next
+    case (Suc n j) show ?case
+    proof (cases "n > 0")
+      case False
+      with Suc.prems show ?thesis by auto
+    next
+      case True
+      show ?thesis proof (cases "even j")
+        case True
+        then obtain k where k: "j = 2*k" by (metis evenE)
+        with \<open>0 < j\<close> have "k > 0" "2 * k < 2 ^ n"
+          using Suc.prems(2) k by auto
+        with k \<open>0 < n\<close> Suc.IH [of k] show ?thesis
+          apply (simp add: m1_to_3 a41 b43 del: power_Suc)
+          apply (subst of_nat_diff, auto)
+          done
+      next
+        case False
+        then obtain k where k: "j = 2*k + 1" by (metis oddE)
+        have "f (leftcut (a ((2 * k + 1) / 2^n)) (b ((2 * k + 1) / 2^n)) (c ((2 * k + 1) / 2^n)))
+              = f (c ((2 * k + 1) / 2^n))"
+          "f (c ((2 * k + 1) / 2^n))
+              = f (rightcut (a ((2 * k + 1) / 2^n)) (b ((2 * k + 1) / 2^n)) (c ((2 * k + 1) / 2^n)))"
+          using alec [of "2*k+1" n] cleb [of "2*k+1" n] a_ge_0 [of "2*k+1" n]  b_le_1 [of "2*k+1" n] k
+          using left_right_m [of "c((2*k + 1) / 2^n)" "a((2*k + 1) / 2^n)" "b((2*k + 1) / 2^n)"]
+           apply (auto simp: add.commute  feqm [OF order_refl]  feqm [OF _ order_refl, symmetric])
+          done
+        then
+        show ?thesis
+          by (simp add: k add.commute [of 1] add.commute [of 3] a43 b41\<open>0 < n\<close> del: power_Suc)
+      qed
+    qed
+  qed
+  have f_eq_fc: "\<lbrakk>0 < j; j < 2 ^ n\<rbrakk>
+                 \<Longrightarrow> f(b((2*j - 1) / 2 ^ (Suc n))) = f(c(j / 2^n)) \<and>
+                     f(a((2*j + 1) / 2 ^ (Suc n))) = f(c(j / 2^n))" for n and j::nat
+  proof (induction n arbitrary: j)
+    case 0
+    then show ?case by auto
+  next
+    case (Suc n)
+    show ?case
+    proof (cases "even j")
+      case True
+      then obtain k where k: "j = 2*k" by (metis evenE)
+      then have less2n: "k < 2 ^ n"
+        using Suc.prems(2) by auto
+      have "0 < k" using \<open>0 < j\<close> k by linarith
+      then have m1_to_3: "real (4 * k - Suc 0) = real (4 * (k-1)) + 3"
+        by auto
+      then show ?thesis
+        using Suc.IH [of k] k \<open>0 < k\<close>
+        apply (simp add: less2n add.commute [of 1] m1_to_3 a41 b43 del: power_Suc)
+        apply (auto simp: of_nat_diff)
+        done
+    next
+      case False
+      then obtain k where k: "j = 2*k + 1" by (metis oddE)
+      with Suc.prems have "k < 2^n" by auto
+      show ?thesis
+        using alec [of "2*k+1" "Suc n"] cleb [of "2*k+1" "Suc n"] a_ge_0 [of "2*k+1" "Suc n"]  b_le_1 [of "2*k+1" "Suc n"] k
+        using left_right_m [of "c((2*k + 1) / 2 ^ Suc n)" "a((2*k + 1) / 2 ^ Suc n)" "b((2*k + 1) / 2 ^ Suc n)"]
+        apply (simp add: add.commute [of 1] add.commute [of 3] m1_to_3 b41 a43 del: power_Suc)
+        apply (force intro: feqm)
+        done
+    qed
+  qed
+  define D01 where "D01 \<equiv> {0<..<1} \<inter> (\<Union>k m. {real m / 2^k})"
+  have cloD01 [simp]: "closure D01 = {0..1}"
+    unfolding D01_def
+    by (subst closure_dyadic_rationals_in_convex_set_pos_1) auto
+  have "uniformly_continuous_on D01 (f \<circ> c)"
+  proof (clarsimp simp: uniformly_continuous_on_def)
+    fix e::real
+    assume "0 < e"
+    have ucontf: "uniformly_continuous_on {0..1} f"
+      by (simp add: compact_uniformly_continuous [OF cont_f])
+    then obtain d where "0 < d" and d: "\<And>x x'. \<lbrakk>x \<in> {0..1}; x' \<in> {0..1}; norm (x' - x) < d\<rbrakk> \<Longrightarrow> norm (f x' - f x) < e/2"
+      unfolding uniformly_continuous_on_def dist_norm
+      by (metis \<open>0 < e\<close> less_divide_eq_numeral1(1) mult_zero_left)
+    obtain n where n: "1/2^n < min d 1"
+      by (metis \<open>0 < d\<close> divide_less_eq_1 less_numeral_extra(1) min_def one_less_numeral_iff power_one_over real_arch_pow_inv semiring_norm(76) zero_less_numeral)
+    with gr0I have "n > 0"
+      by (force simp: divide_simps)
+    show "\<exists>d>0. \<forall>x\<in>D01. \<forall>x'\<in>D01. dist x' x < d \<longrightarrow> dist (f (c x')) (f (c x)) < e"
+    proof (intro exI ballI impI conjI)
+      show "(0::real) < 1/2^n" by auto
+    next
+      have dist_fc_close: "dist (f(c(real i / 2^m))) (f(c(real j / 2^n))) < e/2"
+        if i: "0 < i" "i < 2 ^ m" and j: "0 < j" "j < 2 ^ n" and clo: "abs(i / 2^m - j / 2^n) < 1/2 ^ n" for i j m
+      proof -
+        have abs3: "\<bar>x - a\<bar> < e \<Longrightarrow> x = a \<or> \<bar>x - (a - e/2)\<bar> < e/2 \<or> \<bar>x - (a + e/2)\<bar> < e/2" for x a e::real
+          by linarith
+        consider "i / 2 ^ m = j / 2 ^ n"
+          | "\<bar>i / 2 ^ m - (2 * j - 1) / 2 ^ Suc n\<bar> < 1/2 ^ Suc n"
+          | "\<bar>i / 2 ^ m - (2 * j + 1) / 2 ^ Suc n\<bar> < 1/2 ^ Suc n"
+          using abs3 [OF clo] j by (auto simp: field_simps of_nat_diff)
+        then show ?thesis
+        proof cases
+          case 1 with \<open>0 < e\<close> show ?thesis by auto
+        next
+          case 2
+          have *: "abs(a - b) \<le> 1/2 ^ n \<and> 1/2 ^ n < d \<and> a \<le> c \<and> c \<le> b \<Longrightarrow> b - c < d" for a b c
+            by auto
+          have "norm (c (real i / 2 ^ m) - b (real (2 * j - 1) / 2 ^ Suc n)) < d"
+            using 2 j n close_ab [of "2*j-1" "Suc n"]
+            using b_ge_0 [of "2*j-1" "Suc n"] b_le_1 [of "2*j-1" "Suc n"]
+            using aj_le_ci [of "2*j-1" i m "Suc n"]
+            using ci_le_bj [of "2*j-1" i m "Suc n"]
+            apply (simp add: divide_simps of_nat_diff del: power_Suc)
+            apply (auto simp: divide_simps intro!: *)
+            done
+          moreover have "f(c(j / 2^n)) = f(b ((2*j - 1) / 2 ^ (Suc n)))"
+            using f_eq_fc [OF j] by metis
+          ultimately show ?thesis
+            by (metis dist_norm atLeastAtMost_iff b_ge_0 b_le_1 c_ge_0 c_le_1 d)
+        next
+          case 3
+          have *: "abs(a - b) \<le> 1/2 ^ n \<and> 1/2 ^ n < d \<and> a \<le> c \<and> c \<le> b \<Longrightarrow> c - a < d" for a b c
+            by auto
+          have "norm (c (real i / 2 ^ m) - a (real (2 * j + 1) / 2 ^ Suc n)) < d"
+            using 3 j n close_ab [of "2*j+1" "Suc n"]
+            using b_ge_0 [of "2*j+1" "Suc n"] b_le_1 [of "2*j+1" "Suc n"]
+            using aj_le_ci [of "2*j+1" i m "Suc n"]
+            using ci_le_bj [of "2*j+1" i m "Suc n"]
+            apply (simp add: divide_simps of_nat_diff del: power_Suc)
+            apply (auto simp: divide_simps intro!: *)
+            done
+          moreover have "f(c(j / 2^n)) = f(a ((2*j + 1) / 2 ^ (Suc n)))"
+            using f_eq_fc [OF j] by metis
+          ultimately show ?thesis
+            by (metis dist_norm a_ge_0 atLeastAtMost_iff a_ge_0 a_le_1 c_ge_0 c_le_1 d)
+        qed
+      qed
+      show "dist (f (c x')) (f (c x)) < e"
+        if "x \<in> D01" "x' \<in> D01" "dist x' x < 1/2^n" for x x'
+        using that unfolding D01_def dyadics_in_open_unit_interval
+      proof clarsimp
+        fix i k::nat and m p
+        assume i: "0 < i" "i < 2 ^ m" and k: "0<k" "k < 2 ^ p"
+        assume clo: "dist (real k / 2 ^ p) (real i / 2 ^ m) < 1/2 ^ n"
+        obtain j::nat where "0 < j" "j < 2 ^ n"
+          and clo_ij: "abs(i / 2^m - j / 2^n) < 1/2 ^ n"
+          and clo_kj: "abs(k / 2^p - j / 2^n) < 1/2 ^ n"
+        proof -
+          have "max (2^n * i / 2^m) (2^n * k / 2^p) \<ge> 0"
+            by (auto simp: le_max_iff_disj)
+          then obtain j where "floor (max (2^n*i / 2^m) (2^n*k / 2^p)) = int j"
+            using zero_le_floor zero_le_imp_eq_int by blast
+          then have j_le: "real j \<le> max (2^n * i / 2^m) (2^n * k / 2^p)"
+            and less_j1: "max (2^n * i / 2^m) (2^n * k / 2^p) < real j + 1"
+            using floor_correct [of "max (2^n * i / 2^m) (2^n * k / 2^p)"] by linarith+
+          show thesis
+          proof (cases "j = 0")
+            case True
+            show thesis
+            proof
+              show "(1::nat) < 2 ^ n"
+                apply (subst one_less_power)
+                using \<open>n > 0\<close> by auto
+              show "\<bar>real i / 2 ^ m - real 1/2 ^ n\<bar> < 1/2 ^ n"
+                using i less_j1 by (simp add: dist_norm field_simps True)
+              show "\<bar>real k / 2 ^ p - real 1/2 ^ n\<bar> < 1/2 ^ n"
+                using k less_j1 by (simp add: dist_norm field_simps True)
+            qed simp
+          next
+            case False
+            have 1: "real j * 2 ^ m < real i * 2 ^ n"
+              if j: "real j * 2 ^ p \<le> real k * 2 ^ n" and k: "real k * 2 ^ m < real i * 2 ^ p"
+              for i k m p
+            proof -
+              have "real j * 2 ^ p * 2 ^ m \<le> real k * 2 ^ n * 2 ^ m"
+                using j by simp
+              moreover have "real k * 2 ^ m * 2 ^ n < real i * 2 ^ p * 2 ^ n"
+                using k by simp
+              ultimately have "real j * 2 ^ p * 2 ^ m < real i * 2 ^ p * 2 ^ n"
+                by (simp only: mult_ac)
+              then show ?thesis
+                by simp
+            qed
+            have 2: "real j * 2 ^ m < 2 ^ m + real i * 2 ^ n"
+              if j: "real j * 2 ^ p \<le> real k * 2 ^ n" and k: "real k * (2 ^ m * 2 ^ n) < 2 ^ m * 2 ^ p + real i * (2 ^ n * 2 ^ p)"
+              for i k m p
+            proof -
+              have "real j * 2 ^ p * 2 ^ m \<le> real k * (2 ^ m * 2 ^ n)"
+                using j by simp
+              also have "... < 2 ^ m * 2 ^ p + real i * (2 ^ n * 2 ^ p)"
+                by (rule k)
+              finally have "(real j * 2 ^ m) * 2 ^ p < (2 ^ m + real i * 2 ^ n) * 2 ^ p"
+                by (simp add: algebra_simps)
+              then show ?thesis
+                by simp
+            qed
+            have 3: "real j * 2 ^ p < 2 ^ p + real k * 2 ^ n"
+              if j: "real j * 2 ^ m \<le> real i * 2 ^ n" and i: "real i * 2 ^ p \<le> real k * 2 ^ m"
+            proof -
+              have "real j * 2 ^ m * 2 ^ p \<le> real i * 2 ^ n * 2 ^ p"
+                using j by simp
+              moreover have "real i * 2 ^ p * 2 ^ n \<le> real k * 2 ^ m * 2 ^ n"
+                using i by simp
+              ultimately have "real j * 2 ^ m * 2 ^ p \<le> real k * 2 ^ m * 2 ^ n"
+                by (simp only: mult_ac)
+              then have "real j * 2 ^ p \<le> real k * 2 ^ n"
+                by simp
+              also have "... < 2 ^ p + real k * 2 ^ n"
+                by auto
+              finally show ?thesis by simp
+            qed
+            show ?thesis
+            proof
+              have "real j < 2 ^ n"
+                using j_le i k
+                apply (auto simp: le_max_iff_disj simp del: real_of_nat_less_numeral_power_cancel_iff elim!: le_less_trans)
+                 apply (auto simp: field_simps)
+                done
+              then show "j < 2 ^ n"
+                by auto
+              show "\<bar>real i / 2 ^ m - real j / 2 ^ n\<bar> < 1/2 ^ n"
+                using clo less_j1 j_le
+                apply (auto simp: le_max_iff_disj divide_simps dist_norm)
+                 apply (auto simp: algebra_simps abs_if split: if_split_asm dest: 1 2)
+                done
+              show "\<bar>real k / 2 ^ p - real j / 2 ^ n\<bar> < 1/2 ^ n"
+                using  clo less_j1 j_le
+                apply (auto simp: le_max_iff_disj divide_simps dist_norm)
+                 apply (auto simp: algebra_simps not_less abs_if split: if_split_asm dest: 3 2)
+                done
+            qed (use False in simp)
+          qed
+        qed
+        show "dist (f (c (real k / 2 ^ p))) (f (c (real i / 2 ^ m))) < e"
+        proof (rule dist_triangle_half_l)
+          show "dist (f (c (real k / 2 ^ p))) (f(c(j / 2^n))) < e/2"
+            apply (rule dist_fc_close)
+            using \<open>0 < j\<close> \<open>j < 2 ^ n\<close> k clo_kj by auto
+          show "dist (f (c (real i / 2 ^ m))) (f (c (real j / 2 ^ n))) < e/2"
+            apply (rule dist_fc_close)
+            using \<open>0 < j\<close> \<open>j < 2 ^ n\<close> i clo_ij by auto
+        qed
+      qed
+    qed
+  qed
+  then obtain h where ucont_h: "uniformly_continuous_on {0..1} h"
+    and fc_eq: "\<And>x. x \<in> D01 \<Longrightarrow> (f \<circ> c) x = h x"
+  proof (rule uniformly_continuous_on_extension_on_closure [of D01 "f \<circ> c"])
+  qed (use closure_subset [of D01] in \<open>auto intro!: that\<close>)
+  then have cont_h: "continuous_on {0..1} h"
+    using uniformly_continuous_imp_continuous by blast
+  have h_eq: "h (real k / 2 ^ m) = f (c (real k / 2 ^ m))" if "0 < k" "k < 2^m" for k m
+    using fc_eq that by (force simp: D01_def)
+  have "h ` {0..1} = f ` {0..1}"
+  proof
+    have "h ` (closure D01) \<subseteq> f ` {0..1}"
+    proof (rule image_closure_subset)
+      show "continuous_on (closure D01) h"
+        using cont_h by simp
+      show "closed (f ` {0..1})"
+        using compact_continuous_image [OF cont_f] compact_imp_closed by blast
+      show "h ` D01 \<subseteq> f ` {0..1}"
+        by (force simp: dyadics_in_open_unit_interval D01_def h_eq)
+    qed
+    with cloD01 show "h ` {0..1} \<subseteq> f ` {0..1}" by simp
+    have a12 [simp]: "a (1/2) = u"
+      by (metis a_def leftrec_base numeral_One of_nat_numeral)
+    have b12 [simp]: "b (1/2) = v"
+      by (metis b_def rightrec_base numeral_One of_nat_numeral)
+    have "f ` {0..1} \<subseteq> closure(h ` D01)"
+    proof (clarsimp simp: closure_approachable dyadics_in_open_unit_interval D01_def)
+      fix x e::real
+      assume "0 \<le> x" "x \<le> 1" "0 < e"
+      have ucont_f: "uniformly_continuous_on {0..1} f"
+        using compact_uniformly_continuous cont_f by blast
+      then obtain \<delta> where "\<delta> > 0"
+        and \<delta>: "\<And>x x'. \<lbrakk>x \<in> {0..1}; x' \<in> {0..1}; dist x' x < \<delta>\<rbrakk> \<Longrightarrow> norm (f x' - f x) < e"
+        using \<open>0 < e\<close> by (auto simp: uniformly_continuous_on_def dist_norm)
+      have *: "\<exists>m::nat. \<exists>y. odd m \<and> 0 < m \<and> m < 2 ^ n \<and> y \<in> {a(m / 2^n) .. b(m / 2^n)} \<and> f y = f x"
+        if "n \<noteq> 0" for n
+        using that
+      proof (induction n)
+        case 0 then show ?case by auto
+      next
+        case (Suc n)
+        show ?case
+        proof (cases "n=0")
+          case True
+          consider "x \<in> {0..u}" | "x \<in> {u..v}" | "x \<in> {v..1}"
+            using \<open>0 \<le> x\<close> \<open>x \<le> 1\<close> by force
+          then have "\<exists>y\<ge>a (real 1/2). y \<le> b (real 1/2) \<and> f y = f x"
+          proof cases
+            case 1
+            then show ?thesis
+              apply (rule_tac x=u in exI)
+              using uabv [of 1 1] f0u [of u] f0u [of x] by auto
+          next
+            case 2
+            then show ?thesis
+              by (rule_tac x=x in exI) auto
+          next
+            case 3
+            then show ?thesis
+              apply (rule_tac x=v in exI)
+              using uabv [of 1 1] fv1 [of v] fv1 [of x] by auto
+          qed
+          with \<open>n=0\<close> show ?thesis
+            by (rule_tac x=1 in exI) auto
+        next
+          case False
+          with Suc obtain m y
+            where "odd m" "0 < m" and mless: "m < 2 ^ n"
+              and y: "y \<in> {a (real m / 2 ^ n)..b (real m / 2 ^ n)}" and feq: "f y = f x"
+            by metis
+          then obtain j where j: "m = 2*j + 1" by (metis oddE)
+          consider "y \<in> {a((2*j + 1) / 2^n) .. b((4*j + 1) / 2 ^ (Suc n))}"
+            | "y \<in> {b((4*j + 1) / 2 ^ (Suc n)) .. a((4*j + 3) / 2 ^ (Suc n))}"
+            | "y \<in> {a((4*j + 3) / 2 ^ (Suc n)) .. b((2*j + 1) / 2^n)}"
+            using y j by force
+          then show ?thesis
+          proof cases
+            case 1
+            then show ?thesis
+              apply (rule_tac x="4*j + 1" in exI)
+              apply (rule_tac x=y in exI)
+              using mless j \<open>n \<noteq> 0\<close>
+              apply (simp add: feq a41 b41 add.commute [of 1] del: power_Suc)
+              apply (simp add: algebra_simps)
+              done
+          next
+            case 2
+            show ?thesis
+              apply (rule_tac x="4*j + 1" in exI)
+              apply (rule_tac x="b((4*j + 1) / 2 ^ (Suc n))" in exI)
+              using mless \<open>n \<noteq> 0\<close> 2 j
+              using alec [of "2*j+1" n] cleb [of "2*j+1" n] a_ge_0 [of "2*j+1" n]  b_le_1 [of "2*j+1" n]
+              using left_right [of "c((2*j + 1) / 2^n)" "a((2*j + 1) / 2^n)" "b((2*j + 1) / 2^n)"]
+              apply (simp add: a41 b41 a43 b43 add.commute [of 1] add.commute [of 3] del: power_Suc)
+              apply (auto simp: feq [symmetric] intro: f_eqI)
+              done
+          next
+            case 3
+            then show ?thesis
+              apply (rule_tac x="4*j + 3" in exI)
+              apply (rule_tac x=y in exI)
+              using mless j \<open>n \<noteq> 0\<close>
+              apply (simp add: feq a43 b43 del: power_Suc)
+              apply (simp add: algebra_simps)
+              done
+          qed
+        qed
+      qed
+      obtain n where n: "1/2^n < min (\<delta> / 2) 1"
+        by (metis \<open>0 < \<delta>\<close> divide_less_eq_1 less_numeral_extra(1) min_less_iff_conj one_less_numeral_iff power_one_over real_arch_pow_inv semiring_norm(76) zero_less_divide_iff zero_less_numeral)
+      with gr0I have "n \<noteq> 0"
+        by fastforce
+      with * obtain m::nat and y
+        where "odd m" "0 < m" and mless: "m < 2 ^ n"
+          and y: "y \<in> {a(m / 2^n) .. b(m / 2^n)}" and feq: "f x = f y"
+        by metis
+      then have "0 \<le> y" "y \<le> 1"
+        by (metis atLeastAtMost_iff a_ge_0 b_le_1 order.trans)+
+      moreover have "y < \<delta> + c (real m / 2 ^ n)" "c (real m / 2 ^ n) < \<delta> + y"
+        using y apply simp_all
+        using alec [of m n] cleb [of m n] n real_sum_of_halves close_ab [OF \<open>odd m\<close>, of n]
+        by linarith+
+      moreover note \<open>0 < m\<close> mless \<open>0 \<le> x\<close> \<open>x \<le> 1\<close>
+      ultimately show "\<exists>k. \<exists>m\<in>{0<..<2 ^ k}. dist (h (real m / 2 ^ k)) (f x) < e"
+        apply (rule_tac x=n in exI)
+        apply (rule_tac x=m in bexI)
+         apply (auto simp: dist_norm h_eq feq \<delta>)
+        done
+    qed
+    also have "... \<subseteq> h ` {0..1}"
+      apply (rule closure_minimal)
+      using compact_continuous_image [OF cont_h] compact_imp_closed by (auto simp: D01_def)
+    finally show "f ` {0..1} \<subseteq> h ` {0..1}" .
+  qed
+  moreover have "inj_on h {0..1}"
+  proof -
+    have "u < v"
+      by (metis atLeastAtMost_iff f0u f_1not0 fv1 order.not_eq_order_implies_strict u01(1) u01(2) v01(1))
+    have f_not_fu: "\<And>x. \<lbrakk>u < x; x \<le> v\<rbrakk> \<Longrightarrow> f x \<noteq> f u"
+      by (metis atLeastAtMost_iff f0u fu1 greaterThanAtMost_iff order_refl order_trans u01(1) v01(2))
+    have f_not_fv: "\<And>x. \<lbrakk>u \<le> x; x < v\<rbrakk> \<Longrightarrow> f x \<noteq> f v"
+      by (metis atLeastAtMost_iff order_refl order_trans v01(2) atLeastLessThan_iff fuv fv1)
+    have a_less_b:
+         "a(j / 2^n) < b(j / 2^n) \<and>
+          (\<forall>x. a(j / 2^n) < x \<longrightarrow> x \<le> b(j / 2^n) \<longrightarrow> f x \<noteq> f(a(j / 2^n))) \<and>
+          (\<forall>x. a(j / 2^n) \<le> x \<longrightarrow> x < b(j / 2^n) \<longrightarrow> f x \<noteq> f(b(j / 2^n)))" for n and j::nat
+    proof (induction n arbitrary: j)
+      case 0 then show ?case
+        by (simp add: \<open>u < v\<close> f_not_fu f_not_fv)
+    next
+      case (Suc n j) show ?case
+      proof (cases "n > 0")
+        case False then show ?thesis
+          by (auto simp: a_def b_def leftrec_base rightrec_base \<open>u < v\<close> f_not_fu f_not_fv)
+      next
+        case True show ?thesis
+        proof (cases "even j")
+          case True
+          with \<open>0 < n\<close> Suc.IH show ?thesis
+            by (auto elim!: evenE)
+        next
+          case False
+          then obtain k where k: "j = 2*k + 1" by (metis oddE)
+          then show ?thesis
+          proof (cases "even k")
+            case True
+            then obtain m where m: "k = 2*m" by (metis evenE)
+            have fleft: "f (leftcut (a ((2*m + 1) / 2^n)) (b ((2*m + 1) / 2^n)) (c ((2*m + 1) / 2^n))) =
+                         f (c((2*m + 1) / 2^n))"
+              using alec [of "2*m+1" n] cleb [of "2*m+1" n] a_ge_0 [of "2*m+1" n]  b_le_1 [of "2*m+1" n]
+              using left_right_m [of "c((2*m + 1) / 2^n)" "a((2*m + 1) / 2^n)" "b((2*m + 1) / 2^n)"]
+              by (auto intro: f_eqI)
+            show ?thesis
+            proof (intro conjI impI notI allI)
+              have False if "b (real j / 2 ^ Suc n) \<le> a (real j / 2 ^ Suc n)"
+              proof -
+                have "f (c ((1 + real m * 2) / 2 ^ n)) = f (a ((1 + real m * 2) / 2 ^ n))"
+                  using k m \<open>0 < n\<close> fleft that a41 [of n m] b41 [of n m]
+                  using alec [of "2*m+1" n] cleb [of "2*m+1" n] a_ge_0 [of "2*m+1" n]  b_le_1 [of "2*m+1" n]
+                  using left_right [of "c((2*m + 1) / 2^n)" "a((2*m + 1) / 2^n)" "b((2*m + 1) / 2^n)"]
+                  by (auto simp: algebra_simps)
+                moreover have "a (real (1 + m * 2) / 2 ^ n) < c (real (1 + m * 2) / 2 ^ n)"
+                  using Suc.IH [of "1 + m * 2"] by (simp add: c_def midpoint_def)
+                moreover have "c (real (1 + m * 2) / 2 ^ n) \<le> b (real (1 + m * 2) / 2 ^ n)"
+                  using cleb by blast
+                ultimately show ?thesis
+                  using Suc.IH [of "1 + m * 2"] by force
+              qed
+              then show "a (real j / 2 ^ Suc n) < b (real j / 2 ^ Suc n)" by force
+            next
+              fix x
+              assume "a (real j / 2 ^ Suc n) < x" "x \<le> b (real j / 2 ^ Suc n)" "f x = f (a (real j / 2 ^ Suc n))"
+              then show False
+                using Suc.IH [of "1 + m * 2", THEN conjunct2, THEN conjunct1]
+                using k m \<open>0 < n\<close> a41 [of n m] b41 [of n m]
+                using alec [of "2*m+1" n] cleb [of "2*m+1" n] a_ge_0 [of "2*m+1" n] b_le_1 [of "2*m+1" n]
+                using left_right_m [of "c((2*m + 1) / 2^n)" "a((2*m + 1) / 2^n)" "b((2*m + 1) / 2^n)"]
+                by (auto simp: algebra_simps)
+            next
+              fix x
+              assume "a (real j / 2 ^ Suc n) \<le> x" "x < b (real j / 2 ^ Suc n)" "f x = f (b (real j / 2 ^ Suc n))"
+              then show False
+                using k m \<open>0 < n\<close> a41 [of n m] b41 [of n m] fleft left_neq
+                using alec [of "2*m+1" n] cleb [of "2*m+1" n] a_ge_0 [of "2*m+1" n] b_le_1 [of "2*m+1" n]
+                by (auto simp: algebra_simps)
+            qed
+          next
+            case False
+            with oddE obtain m where m: "k = Suc (2*m)" by fastforce
+            have fright: "f (rightcut (a ((2*m + 1) / 2^n)) (b ((2*m + 1) / 2^n)) (c ((2*m + 1) / 2^n))) = f (c((2*m + 1) / 2^n))"
+              using alec [of "2*m+1" n] cleb [of "2*m+1" n] a_ge_0 [of "2*m+1" n]  b_le_1 [of "2*m+1" n]
+              using left_right_m [of "c((2*m + 1) / 2^n)" "a((2*m + 1) / 2^n)" "b((2*m + 1) / 2^n)"]
+              by (auto intro: f_eqI [OF _ order_refl])
+            show ?thesis
+            proof (intro conjI impI notI allI)
+              have False if "b (real j / 2 ^ Suc n) \<le> a (real j / 2 ^ Suc n)"
+              proof -
+                have "f (c ((1 + real m * 2) / 2 ^ n)) = f (b ((1 + real m * 2) / 2 ^ n))"
+                  using k m \<open>0 < n\<close> fright that a43 [of n m] b43 [of n m]
+                  using alec [of "2*m+1" n] cleb [of "2*m+1" n] a_ge_0 [of "2*m+1" n]  b_le_1 [of "2*m+1" n]
+                  using left_right [of "c((2*m + 1) / 2^n)" "a((2*m + 1) / 2^n)" "b((2*m + 1) / 2^n)"]
+                  by (auto simp: algebra_simps)
+                moreover have "a (real (1 + m * 2) / 2 ^ n) \<le> c (real (1 + m * 2) / 2 ^ n)"
+                  using alec by blast
+                moreover have "c (real (1 + m * 2) / 2 ^ n) < b (real (1 + m * 2) / 2 ^ n)"
+                  using Suc.IH [of "1 + m * 2"] by (simp add: c_def midpoint_def)
+                ultimately show ?thesis
+                  using Suc.IH [of "1 + m * 2"] by force
+              qed
+              then show "a (real j / 2 ^ Suc n) < b (real j / 2 ^ Suc n)" by force
+            next
+              fix x
+              assume "a (real j / 2 ^ Suc n) < x" "x \<le> b (real j / 2 ^ Suc n)" "f x = f (a (real j / 2 ^ Suc n))"
+              then show False
+                using k m \<open>0 < n\<close> a43 [of n m] b43 [of n m] fright right_neq
+                using alec [of "2*m+1" n] cleb [of "2*m+1" n] a_ge_0 [of "2*m+1" n] b_le_1 [of "2*m+1" n]
+                by (auto simp: algebra_simps)
+            next
+              fix x
+              assume "a (real j / 2 ^ Suc n) \<le> x" "x < b (real j / 2 ^ Suc n)" "f x = f (b (real j / 2 ^ Suc n))"
+              then show False
+                using Suc.IH [of "1 + m * 2", THEN conjunct2, THEN conjunct2]
+                using k m \<open>0 < n\<close> a43 [of n m] b43 [of n m]
+                using alec [of "2*m+1" n] cleb [of "2*m+1" n] a_ge_0 [of "2*m+1" n] b_le_1 [of "2*m+1" n]
+                using left_right_m [of "c((2*m + 1) / 2^n)" "a((2*m + 1) / 2^n)" "b((2*m + 1) / 2^n)"]
+                by (auto simp: algebra_simps fright simp del: power_Suc)
+            qed
+          qed
+        qed
+      qed
+    qed
+    have c_gt_0 [simp]: "0 < c(m / 2^n)" and c_less_1 [simp]: "c(m / 2^n) < 1" for m::nat and n
+      using a_less_b [of m n] apply (simp_all add: c_def midpoint_def)
+      using a_ge_0 [of m n] b_le_1 [of m n] apply linarith+
+      done
+    have approx: "\<exists>j n. odd j \<and> n \<noteq> 0 \<and>
+                        real i / 2^m \<le> real j / 2^n \<and>
+                        real j / 2^n \<le> real k / 2^p \<and>
+                        \<bar>real i / 2 ^ m - real j / 2 ^ n\<bar> < 1/2^n \<and>
+                        \<bar>real k / 2 ^ p - real j / 2 ^ n\<bar> < 1/2^n"
+      if "0 < i" "i < 2 ^ m" "0 < k" "k < 2 ^ p" "i / 2^m < k / 2^p" "m + p = N" for N m p i k
+      using that
+    proof (induction N arbitrary: m p i k rule: less_induct)
+      case (less N)
+      then consider "i / 2^m \<le> 1/2" "1/2 \<le> k / 2^p" | "k / 2^p < 1/2" | "k / 2^p \<ge> 1/2" "1/2 < i / 2^m"
+        by linarith
+      then show ?case
+      proof cases
+        case 1
+        with less.prems show ?thesis
+          by (rule_tac x=1 in exI)+ (fastforce simp: divide_simps)
+      next
+        case 2 show ?thesis
+        proof (cases m)
+          case 0 with less.prems show ?thesis
+            by auto
+        next
+          case (Suc m') show ?thesis
+          proof (cases p)
+            case 0 with less.prems show ?thesis by auto
+          next
+            case (Suc p')
+            have False if "real i * 2 ^ p' < real k * 2 ^ m'" "k < 2 ^ p'" "2 ^ m' \<le> i"
+            proof -
+              have "real k * 2 ^ m' < 2 ^ p' * 2 ^ m'"
+                using that by simp
+              then have "real i * 2 ^ p' < 2 ^ p' * 2 ^ m'"
+                using that by linarith
+              with that show ?thesis by simp
+            qed
+            then show ?thesis
+              using less.IH [of "m'+p'" i m' k p'] less.prems \<open>m = Suc m'\<close> 2 Suc
+              apply atomize
+              apply (force simp: divide_simps)
+              done
+          qed
+        qed
+      next
+        case 3 show ?thesis
+        proof (cases m)
+          case 0 with less.prems show ?thesis
+            by auto
+        next
+          case (Suc m') show ?thesis
+          proof (cases p)
+            case 0 with less.prems show ?thesis by auto
+          next
+            case (Suc p')
+            then show ?thesis
+              using less.IH [of "m'+p'" "i - 2^m'" m' "k - 2 ^ p'" p'] less.prems \<open>m = Suc m'\<close> Suc 3
+              apply atomize
+              apply (auto simp: field_simps of_nat_diff)
+              apply (rule_tac x="2 ^ n + j" in exI, simp)
+              apply (rule_tac x="Suc n" in exI)
+              apply (auto simp: field_simps)
+              done
+          qed
+        qed
+      qed
+    qed
+    have clec: "c(real i / 2^m) \<le> c(real j / 2^n)"
+      if i: "0 < i" "i < 2 ^ m" and j: "0 < j" "j < 2 ^ n" and ij: "i / 2^m < j / 2^n" for m i n j
+    proof -
+      obtain j' n' where "odd j'" "n' \<noteq> 0"
+        and i_le_j: "real i / 2 ^ m \<le> real j' / 2 ^ n'"
+        and j_le_j: "real j' / 2 ^ n' \<le> real j / 2 ^ n"
+        and clo_ij: "\<bar>real i / 2 ^ m - real j' / 2 ^ n'\<bar> < 1/2 ^ n'"
+        and clo_jj: "\<bar>real j / 2 ^ n - real j' / 2 ^ n'\<bar> < 1/2 ^ n'"
+        using approx [of i m j n "m+n"] that i j ij by auto
+      with oddE obtain q where q: "j' = Suc (2*q)" by fastforce
+      have "c (real i / 2 ^ m) \<le> c((2*q + 1) / 2^n')"
+      proof (cases "i / 2^m = (2*q + 1) / 2^n'")
+        case True then show ?thesis by simp
+      next
+        case False
+        with i_le_j q have less: "i / 2^m < (2*q + 1) / 2^n'"
+          by auto
+        have *: "\<lbrakk>i < q; abs(i - q) < s*2; q = r + s\<rbrakk> \<Longrightarrow> abs(i - r) < s" for i q s r::real
+          by auto
+        have "c(i / 2^m) \<le> b(real(4 * q + 1) / 2 ^ (Suc n'))"
+          apply (rule ci_le_bj, force)
+          apply (rule * [OF less])
+          using i_le_j clo_ij q apply (auto simp: divide_simps)
+          done
+        then show ?thesis
+          using alec [of "2*q+1" n'] cleb [of "2*q+1" n'] a_ge_0 [of "2*q+1" n'] b_le_1 [of "2*q+1" n'] b41 [of n' q] \<open>n' \<noteq> 0\<close>
+          using left_right_m [of "c((2*q + 1) / 2^n')" "a((2*q + 1) / 2^n')" "b((2*q + 1) / 2^n')"]
+          by (auto simp: algebra_simps)
+      qed
+      also have "... \<le> c(real j / 2^n)"
+      proof (cases "j / 2^n = (2*q + 1) / 2^n'")
+        case True
+        then show ?thesis by simp
+      next
+        case False
+        with j_le_j q have less: "(2*q + 1) / 2^n' < j / 2^n"
+          by auto
+        have *: "\<lbrakk>q < i; abs(i - q) < s*2; r = q + s\<rbrakk> \<Longrightarrow> abs(i - r) < s" for i q s r::real
+          by auto
+        have "a(real(4*q + 3) / 2 ^ (Suc n')) \<le> c(j / 2^n)"
+          apply (rule aj_le_ci, force)
+          apply (rule * [OF less])
+          using j_le_j clo_jj q apply (auto simp: divide_simps)
+          done
+        then show ?thesis
+          using alec [of "2*q+1" n'] cleb [of "2*q+1" n'] a_ge_0 [of "2*q+1" n'] b_le_1 [of "2*q+1" n'] a43 [of n' q] \<open>n' \<noteq> 0\<close>
+          using left_right_m [of "c((2*q + 1) / 2^n')" "a((2*q + 1) / 2^n')" "b((2*q + 1) / 2^n')"]
+          by (auto simp: algebra_simps)
+      qed
+      finally show ?thesis .
+    qed
+    have "x = y" if "0 \<le> x" "x \<le> 1" "0 \<le> y" "y \<le> 1" "h x = h y" for x y
+      using that
+    proof (induction x y rule: linorder_class.linorder_less_wlog)
+      case (less x1 x2)
+      obtain m n where m: "0 < m" "m < 2 ^ n"
+        and x12: "x1 < m / 2^n" "m / 2^n < x2"
+        and neq: "h x1 \<noteq> h (real m / 2^n)"
+      proof -
+        have "(x1 + x2) / 2 \<in> closure D01"
+          using cloD01 less.hyps less.prems by auto
+        with less obtain y where "y \<in> D01" and dist_y: "dist y ((x1 + x2) / 2) < (x2 - x1) / 64"
+          unfolding closure_approachable
+          by (metis diff_gt_0_iff_gt less_divide_eq_numeral1(1) mult_zero_left)
+        obtain m n where m: "0 < m" "m < 2 ^ n"
+                     and clo: "\<bar>real m / 2 ^ n - (x1 + x2) / 2\<bar> < (x2 - x1) / 64"
+                     and n: "1/2^n < (x2 - x1) / 128"
+        proof -
+          have "min 1 ((x2 - x1) / 128) > 0" "1/2 < (1::real)"
+            using less by auto
+          then obtain N where N: "1/2^N < min 1 ((x2 - x1) / 128)"
+            by (metis power_one_over real_arch_pow_inv)
+          then have "N > 0"
+            using less_divide_eq_1 by force
+          obtain p q where p: "p < 2 ^ q" "p \<noteq> 0" and yeq: "y = real p / 2 ^ q"
+            using \<open>y \<in> D01\<close> by (auto simp: zero_less_divide_iff D01_def)
+          show ?thesis
+          proof
+            show "0 < 2^N * p"
+              using p by auto
+            show "2 ^ N * p < 2 ^ (N+q)"
+              by (simp add: p power_add)
+            have "\<bar>real (2 ^ N * p) / 2 ^ (N + q) - (x1 + x2) / 2\<bar> = \<bar>real p / 2 ^ q - (x1 + x2) / 2\<bar>"
+              by (simp add: power_add)
+            also have "... = \<bar>y - (x1 + x2) / 2\<bar>"
+              by (simp add: yeq)
+            also have "... < (x2 - x1) / 64"
+              using dist_y by (simp add: dist_norm)
+            finally show "\<bar>real (2 ^ N * p) / 2 ^ (N + q) - (x1 + x2) / 2\<bar> < (x2 - x1) / 64" .
+            have "(1::real) / 2 ^ (N + q) \<le> 1/2^N"
+              by (simp add: field_simps)
+            also have "... < (x2 - x1) / 128"
+              using N by force
+            finally show "1/2 ^ (N + q) < (x2 - x1) / 128" .
+          qed
+        qed
+        obtain m' n' m'' n'' where "0 < m'" "m' < 2 ^ n'" "x1 < m' / 2^n'" "m' / 2^n' < x2"
+          and "0 < m''" "m'' < 2 ^ n''" "x1 < m'' / 2^n''" "m'' / 2^n'' < x2"
+          and neq: "h (real m'' / 2^n'') \<noteq> h (real m' / 2^n')"
+        proof
+          show "0 < Suc (2*m)"
+            by simp
+          show m21: "Suc (2*m) < 2 ^ Suc n"
+            using m by auto
+          show "x1 < real (Suc (2 * m)) / 2 ^ Suc n"
+            using clo by (simp add: field_simps abs_if split: if_split_asm)
+          show "real (Suc (2 * m)) / 2 ^ Suc n < x2"
+            using n clo by (simp add: field_simps abs_if split: if_split_asm)
+          show "0 < 4*m + 3"
+            by simp
+          have "m+1 \<le> 2 ^ n"
+            using m by simp
+          then have "4 * (m+1) \<le> 4 * (2 ^ n)"
+            by simp
+          then show m43: "4*m + 3 < 2 ^ (n+2)"
+            by (simp add: algebra_simps)
+          show "x1 < real (4 * m + 3) / 2 ^ (n + 2)"
+            using clo by (simp add: field_simps abs_if split: if_split_asm)
+          show "real (4 * m + 3) / 2 ^ (n + 2) < x2"
+            using n clo by (simp add: field_simps abs_if split: if_split_asm)
+          have c_fold: "midpoint (a ((2 * real m + 1) / 2 ^ Suc n)) (b ((2 * real m + 1) / 2 ^ Suc n)) = c ((2 * real m + 1) / 2 ^ Suc n)"
+            by (simp add: c_def)
+          define R where "R \<equiv> rightcut (a ((2 * real m + 1) / 2 ^ Suc n)) (b ((2 * real m + 1) / 2 ^ Suc n))  (c ((2 * real m + 1) / 2 ^ Suc n))"
+          have "R < b ((2 * real m + 1) / 2 ^ Suc n)"
+            unfolding R_def  using a_less_b [of "4*m + 3" "n+2"] a43 [of "Suc n" m] b43 [of "Suc n" m]
+            by simp
+          then have Rless: "R < midpoint R (b ((2 * real m + 1) / 2 ^ Suc n))"
+            by (simp add: midpoint_def)
+          have midR_le: "midpoint R (b ((2 * real m + 1) / 2 ^ Suc n)) \<le> b ((2 * real m + 1) / (2 * 2 ^ n))"
+            using \<open>R < b ((2 * real m + 1) / 2 ^ Suc n)\<close>
+            by (simp add: midpoint_def)
+          have "(real (Suc (2 * m)) / 2 ^ Suc n) \<in> D01"  "real (4 * m + 3) / 2 ^ (n + 2) \<in> D01"
+            by (simp_all add: D01_def m21 m43 del: power_Suc of_nat_Suc of_nat_add add_2_eq_Suc') blast+
+          then show "h (real (4 * m + 3) / 2 ^ (n + 2)) \<noteq> h (real (Suc (2 * m)) / 2 ^ Suc n)"
+            using a_less_b [of "4*m + 3" "n+2", THEN conjunct1]
+            using a43 [of "Suc n" m] b43 [of "Suc n" m]
+            using alec [of "2*m+1" "Suc n"] cleb [of "2*m+1" "Suc n"] a_ge_0 [of "2*m+1" "Suc n"]  b_le_1 [of "2*m+1" "Suc n"]
+            apply (simp add: fc_eq [symmetric] c_def del: power_Suc)
+            apply (simp only: add.commute [of 1] c_fold R_def [symmetric])
+            apply (rule right_neq)
+            using Rless apply (simp add: R_def)
+               apply (rule midR_le, auto)
+            done
+        qed
+        then show ?thesis by (metis that)
+      qed
+      have m_div: "0 < m / 2^n" "m / 2^n < 1"
+        using m  by (auto simp: divide_simps)
+      have closure0m: "{0..m / 2^n} = closure ({0<..< m / 2^n} \<inter> (\<Union>k m. {real m / 2 ^ k}))"
+        by (subst closure_dyadic_rationals_in_convex_set_pos_1, simp_all add: not_le m)
+      have closurem1: "{m / 2^n .. 1} = closure ({m / 2^n <..< 1} \<inter> (\<Union>k m. {real m / 2 ^ k}))"
+        apply (subst closure_dyadic_rationals_in_convex_set_pos_1; simp add: not_le m)
+        using \<open>0 < real m / 2 ^ n\<close> by linarith
+      have cont_h': "continuous_on (closure ({u<..<v} \<inter> (\<Union>k m. {real m / 2 ^ k}))) h"
+        if "0 \<le> u" "v \<le> 1" for u v
+        apply (rule continuous_on_subset [OF cont_h])
+        apply (rule closure_minimal [OF subsetI])
+        using that apply auto
+        done
+      have closed_f': "closed (f ` {u..v})" if "0 \<le> u" "v \<le> 1" for u v
+        by (metis compact_continuous_image cont_f compact_interval atLeastatMost_subset_iff
+            compact_imp_closed continuous_on_subset that)
+      have less_2I: "\<And>k i. real i / 2 ^ k < 1 \<Longrightarrow> i < 2 ^ k"
+        by simp
+      have "h ` ({0<..<m / 2 ^ n} \<inter> (\<Union>q p. {real p / 2 ^ q})) \<subseteq> f ` {0..c (m / 2 ^ n)}"
+      proof clarsimp
+        fix p q
+        assume p: "0 < real p / 2 ^ q" "real p / 2 ^ q < real m / 2 ^ n"
+        then have [simp]: "0 < p" "p < 2 ^ q"
+           apply (simp add: divide_simps)
+          apply (blast intro: p less_2I m_div less_trans)
+          done
+        have "f (c (real p / 2 ^ q)) \<in> f ` {0..c (real m / 2 ^ n)}"
+          by (auto simp: clec p m)
+        then show "h (real p / 2 ^ q) \<in> f ` {0..c (real m / 2 ^ n)}"
+          by (simp add: h_eq)
+      qed
+      then have "h ` {0 .. m / 2^n} \<subseteq> f ` {0 .. c(m / 2^n)}"
+        apply (subst closure0m)
+        apply (rule image_closure_subset [OF cont_h' closed_f'])
+        using m_div apply auto
+        done
+      then have hx1: "h x1 \<in> f ` {0 .. c(m / 2^n)}"
+        using x12 less.prems(1) by auto
+      then obtain t1 where t1: "h x1 = f t1" "0 \<le> t1" "t1 \<le> c (m / 2 ^ n)"
+        by auto
+      have "h ` ({m / 2 ^ n<..<1} \<inter> (\<Union>q p. {real p / 2 ^ q})) \<subseteq> f ` {c (m / 2 ^ n)..1}"
+      proof clarsimp
+        fix p q
+        assume p: "real m / 2 ^ n < real p / 2 ^ q" and [simp]: "p < 2 ^ q"
+        then have [simp]: "0 < p"
+          using gr_zeroI m_div by fastforce
+        have "f (c (real p / 2 ^ q)) \<in> f ` {c (m / 2 ^ n)..1}"
+          by (auto simp: clec p m)
+        then show "h (real p / 2 ^ q) \<in> f ` {c (real m / 2 ^ n)..1}"
+          by (simp add: h_eq)
+      qed
+      then have "h ` {m / 2^n .. 1} \<subseteq> f ` {c(m / 2^n) .. 1}"
+        apply (subst closurem1)
+        apply (rule image_closure_subset [OF cont_h' closed_f'])
+        using m apply auto
+        done
+      then have hx2: "h x2 \<in> f ` {c(m / 2^n)..1}"
+        using x12 less.prems by auto
+      then obtain t2 where t2: "h x2 = f t2" "c (m / 2 ^ n) \<le> t2" "t2 \<le> 1"
+        by auto
+      with t1 less neq have False
+        using conn [of "h x2", unfolded is_interval_connected_1 [symmetric] is_interval_1, rule_format, of t1 t2 "c(m / 2^n)"]
+        by (simp add: h_eq m)
+      then show ?case by blast
+    qed auto
+    then show ?thesis
+      by (auto simp: inj_on_def)
+  qed
+  ultimately have "{0..1::real} homeomorphic f ` {0..1}"
+    using homeomorphic_compact [OF _ cont_h] by blast
+  then show ?thesis
+    using homeomorphic_sym by blast
+qed
+
+
+theorem path_contains_arc:
+  fixes p :: "real \<Rightarrow> 'a::{complete_space,real_normed_vector}"
+  assumes "path p" and a: "pathstart p = a" and b: "pathfinish p = b" and "a \<noteq> b"
+  obtains q where "arc q" "path_image q \<subseteq> path_image p" "pathstart q = a" "pathfinish q = b"
+proof -
+  have ucont_p: "uniformly_continuous_on {0..1} p"
+    using \<open>path p\<close> unfolding path_def
+    by (metis compact_Icc compact_uniformly_continuous)
+  define \<phi> where "\<phi> \<equiv> \<lambda>S. S \<subseteq> {0..1} \<and> 0 \<in> S \<and> 1 \<in> S \<and>
+                           (\<forall>x \<in> S. \<forall>y \<in> S. open_segment x y \<inter> S = {} \<longrightarrow> p x = p y)"
+  obtain T where "closed T" "\<phi> T" and T: "\<And>U. \<lbrakk>closed U; \<phi> U\<rbrakk> \<Longrightarrow> \<not> (U \<subset> T)"
+  proof (rule Brouwer_reduction_theorem_gen [of "{0..1}" \<phi>])
+    have *: "{x<..<y} \<inter> {0..1} = {x<..<y}" if "0 \<le> x" "y \<le> 1" "x \<le> y" for x y::real
+      using that by auto
+    show "\<phi> {0..1}"
+      by (auto simp: \<phi>_def open_segment_eq_real_ivl *)
+    show "\<phi> (INTER UNIV F)"
+      if "\<And>n. closed (F n)" and \<phi>: "\<And>n. \<phi> (F n)" and Fsub: "\<And>n. F (Suc n) \<subseteq> F n" for F
+    proof -
+      have F01: "\<And>n. F n \<subseteq> {0..1} \<and> 0 \<in> F n \<and> 1 \<in> F n"
+        and peq: "\<And>n x y. \<lbrakk>x \<in> F n; y \<in> F n; open_segment x y \<inter> F n = {}\<rbrakk> \<Longrightarrow> p x = p y"
+        by (metis \<phi> \<phi>_def)+
+      have pqF: False if "\<forall>u. x \<in> F u" "\<forall>x. y \<in> F x" "open_segment x y \<inter> (\<Inter>x. F x) = {}" and neg: "p x \<noteq> p y"
+        for x y
+        using that
+      proof (induction x y rule: linorder_class.linorder_less_wlog)
+        case (less x y)
+        have xy: "x \<in> {0..1}" "y \<in> {0..1}"
+          by (metis less.prems subsetCE F01)+
+        have "norm(p x - p y) / 2 > 0"
+          using less by auto
+        then obtain e where "e > 0"
+          and e: "\<And>u v. \<lbrakk>u \<in> {0..1}; v \<in> {0..1}; dist v u < e\<rbrakk> \<Longrightarrow> dist (p v) (p u) < norm(p x - p y) / 2"
+          by (metis uniformly_continuous_onE [OF ucont_p])
+        have minxy: "min e (y - x)  < (y - x) * (3 / 2)"
+          by (subst min_less_iff_disj) (simp add: less)
+        obtain w z where "w < z" and w: "w \<in> {x<..<y}" and z: "z \<in> {x<..<y}"
+          and wxe: "norm(w - x) < e" and zye: "norm(z - y) < e"
+          apply (rule_tac w = "x + (min e (y - x) / 3)" and z = "y - (min e (y - x) / 3)" in that)
+          using minxy \<open>0 < e\<close> less by simp_all
+        have Fclo: "\<And>T. T \<in> range F \<Longrightarrow> closed T"
+          by (metis \<open>\<And>n. closed (F n)\<close> image_iff)
+        have eq: "{w..z} \<inter> INTER UNIV F = {}"
+          using less w z apply (auto simp: open_segment_eq_real_ivl)
+          by (metis (no_types, hide_lams) INT_I IntI empty_iff greaterThanLessThan_iff not_le order.trans)
+        then obtain K where "finite K" and K: "{w..z} \<inter> (\<Inter> (F ` K)) = {}"
+          by (metis finite_subset_image compact_imp_fip [OF compact_interval Fclo])
+        then have "K \<noteq> {}"
+          using \<open>w < z\<close> \<open>{w..z} \<inter> INTER K F = {}\<close> by auto
+        define n where "n \<equiv> Max K"
+        have "n \<in> K" unfolding n_def by (metis \<open>K \<noteq> {}\<close> \<open>finite K\<close> Max_in)
+        have "F n \<subseteq> \<Inter> (F ` K)"
+          unfolding n_def by (metis Fsub Max_ge \<open>K \<noteq> {}\<close> \<open>finite K\<close> cINF_greatest lift_Suc_antimono_le)
+        with K have wzF_null: "{w..z} \<inter> F n = {}"
+          by (metis disjoint_iff_not_equal subset_eq)
+        obtain u where u: "u \<in> F n" "u \<in> {x..w}" "({u..w} - {u}) \<inter> F n = {}"
+        proof (cases "w \<in> F n")
+          case True
+          then show ?thesis
+            by (metis wzF_null \<open>w < z\<close> atLeastAtMost_iff disjoint_iff_not_equal less_eq_real_def)
+        next
+          case False
+          obtain u where "u \<in> F n" "u \<in> {x..w}" "{u<..<w} \<inter> F n = {}"
+          proof (rule segment_to_point_exists [of "F n \<inter> {x..w}" w])
+            show "closed (F n \<inter> {x..w})"
+              by (metis \<open>\<And>n. closed (F n)\<close> closed_Int closed_real_atLeastAtMost)
+            show "F n \<inter> {x..w} \<noteq> {}"
+              by (metis atLeastAtMost_iff disjoint_iff_not_equal greaterThanLessThan_iff less.prems(1) less_eq_real_def w)
+          qed (auto simp: open_segment_eq_real_ivl intro!: that)
+          with False show thesis
+            apply (auto simp: disjoint_iff_not_equal intro!: that)
+            by (metis greaterThanLessThan_iff less_eq_real_def)
+        qed
+        obtain v where v: "v \<in> F n" "v \<in> {z..y}" "({z..v} - {v}) \<inter> F n = {}"
+        proof (cases "z \<in> F n")
+          case True
+          have "z \<in> {w..z}"
+            using \<open>w < z\<close> by auto
+          then show ?thesis
+            by (metis wzF_null Int_iff True empty_iff)
+        next
+          case False
+          show ?thesis
+          proof (rule segment_to_point_exists [of "F n \<inter> {z..y}" z])
+            show "closed (F n \<inter> {z..y})"
+              by (metis \<open>\<And>n. closed (F n)\<close> closed_Int closed_atLeastAtMost)
+            show "F n \<inter> {z..y} \<noteq> {}"
+              by (metis atLeastAtMost_iff disjoint_iff_not_equal greaterThanLessThan_iff less.prems(2) less_eq_real_def z)
+            show "\<And>b. \<lbrakk>b \<in> F n \<inter> {z..y}; open_segment z b \<inter> (F n \<inter> {z..y}) = {}\<rbrakk> \<Longrightarrow> thesis"
+              apply (rule that)
+                apply (auto simp: open_segment_eq_real_ivl)
+              by (metis DiffI Int_iff atLeastAtMost_diff_ends atLeastAtMost_iff atLeastatMost_empty_iff empty_iff insert_iff False)
+          qed
+        qed
+        obtain u v where "u \<in> {0..1}" "v \<in> {0..1}" "norm(u - x) < e" "norm(v - y) < e" "p u = p v"
+        proof
+          show "u \<in> {0..1}" "v \<in> {0..1}"
+            by (metis F01 \<open>u \<in> F n\<close> \<open>v \<in> F n\<close> subsetD)+
+          show "norm(u - x) < e" "norm (v - y) < e"
+            using \<open>u \<in> {x..w}\<close> \<open>v \<in> {z..y}\<close> atLeastAtMost_iff real_norm_def wxe zye by auto
+          show "p u = p v"
+          proof (rule peq)
+            show "u \<in> F n" "v \<in> F n"
+              by (auto simp: u v)
+            have "False" if "\<xi> \<in> F n" "u < \<xi>" "\<xi> < v" for \<xi>
+            proof -
+              have "\<xi> \<notin> {z..v}"
+                by (metis DiffI disjoint_iff_not_equal less_irrefl singletonD that v(3))
+              moreover have "\<xi> \<notin> {w..z} \<inter> F n"
+                by (metis equals0D wzF_null)
+              ultimately have "\<xi> \<in> {u..w}"
+                using that by auto
+              then show ?thesis
+                by (metis DiffI disjoint_iff_not_equal less_eq_real_def not_le singletonD that u(3))
+            qed
+            moreover
+            have "\<lbrakk>\<xi> \<in> F n; v < \<xi>; \<xi> < u\<rbrakk> \<Longrightarrow> False" for \<xi>
+              using \<open>u \<in> {x..w}\<close> \<open>v \<in> {z..y}\<close> \<open>w < z\<close> by simp
+            ultimately
+            show "open_segment u v \<inter> F n = {}"
+              by (force simp: open_segment_eq_real_ivl)
+          qed
+        qed
+        then show ?case
+          using e [of x u] e [of y v] xy
+          apply (simp add: open_segment_eq_real_ivl dist_norm del: divide_const_simps)
+          by (metis dist_norm dist_triangle_half_r less_irrefl)
+      qed (auto simp: open_segment_commute)
+      show ?thesis
+        unfolding \<phi>_def by (metis (no_types, hide_lams) INT_I Inf_lower2 rangeI that F01 subsetCE pqF)
+    qed
+    show "closed {0..1::real}" by auto
+  qed (meson \<phi>_def)
+  then have "T \<subseteq> {0..1}" "0 \<in> T" "1 \<in> T"
+    and peq: "\<And>x y. \<lbrakk>x \<in> T; y \<in> T; open_segment x y \<inter> T = {}\<rbrakk> \<Longrightarrow> p x = p y"
+    unfolding \<phi>_def by metis+
+  then have "T \<noteq> {}" by auto
+  define h where "h \<equiv> \<lambda>x. p(@y. y \<in> T \<and> open_segment x y \<inter> T = {})"
+  have "p y = p z" if "y \<in> T" "z \<in> T" and xyT: "open_segment x y \<inter> T = {}" and xzT: "open_segment x z \<inter> T = {}"
+    for x y z
+  proof (cases "x \<in> T")
+    case True
+    with that show ?thesis by (metis \<open>\<phi> T\<close> \<phi>_def)
+  next
+    case False
+    have "insert x (open_segment x y \<union> open_segment x z) \<inter> T = {}"
+      by (metis False Int_Un_distrib2 Int_insert_left Un_empty_right xyT xzT)
+    moreover have "open_segment y z \<inter> T \<subseteq> insert x (open_segment x y \<union> open_segment x z) \<inter> T"
+      apply auto
+      by (metis greaterThanLessThan_iff less_eq_real_def less_le_trans linorder_neqE_linordered_idom open_segment_eq_real_ivl)
+    ultimately have "open_segment y z \<inter> T = {}"
+      by blast
+    with that peq show ?thesis by metis
+  qed
+  then have h_eq_p_gen: "h x = p y" if "y \<in> T" "open_segment x y \<inter> T = {}" for x y
+    using that unfolding h_def
+    by (metis (mono_tags, lifting) some_eq_ex)
+  then have h_eq_p: "\<And>x. x \<in> T \<Longrightarrow> h x = p x"
+    by simp
+  have disjoint: "\<And>x. \<exists>y. y \<in> T \<and> open_segment x y \<inter> T = {}"
+    by (meson \<open>T \<noteq> {}\<close> \<open>closed T\<close> segment_to_point_exists)
+  have heq: "h x = h x'" if "open_segment x x' \<inter> T = {}" for x x'
+  proof (cases "x \<in> T \<or> x' \<in> T")
+    case True
+    then show ?thesis
+      by (metis h_eq_p h_eq_p_gen open_segment_commute that)
+  next
+    case False
+    obtain y y' where "y \<in> T" "open_segment x y \<inter> T = {}" "h x = p y"
+      "y' \<in> T" "open_segment x' y' \<inter> T = {}" "h x' = p y'"
+      by (meson disjoint h_eq_p_gen)
+    moreover have "open_segment y y' \<subseteq> (insert x (insert x' (open_segment x y \<union> open_segment x' y' \<union> open_segment x x')))"
+      by (auto simp: open_segment_eq_real_ivl)
+    ultimately show ?thesis
+      using False that by (fastforce simp add: h_eq_p intro!: peq)
+  qed
+  have "h ` {0..1} homeomorphic {0..1::real}"
+  proof (rule homeomorphic_monotone_image_interval)
+    show "continuous_on {0..1} h"
+    proof (clarsimp simp add: continuous_on_iff)
+      fix u \<epsilon>::real
+      assume "0 < \<epsilon>" "0 \<le> u" "u \<le> 1"
+      then obtain \<delta> where "\<delta> > 0" and \<delta>: "\<And>v. v \<in> {0..1} \<Longrightarrow> dist v u < \<delta> \<longrightarrow> dist (p v) (p u) < \<epsilon> / 2"
+        using ucont_p [unfolded uniformly_continuous_on_def]
+        by (metis atLeastAtMost_iff half_gt_zero_iff)
+      then have "dist (h v) (h u) < \<epsilon>" if "v \<in> {0..1}" "dist v u < \<delta>" for v
+      proof (cases "open_segment u v \<inter> T = {}")
+        case True
+        then show ?thesis
+          using \<open>0 < \<epsilon>\<close> heq by auto
+      next
+        case False
+        have uvT: "closed (closed_segment u v \<inter> T)" "closed_segment u v \<inter> T \<noteq> {}"
+          using False open_closed_segment by (auto simp: \<open>closed T\<close> closed_Int)
+        obtain w where "w \<in> T" and w: "w \<in> closed_segment u v" "open_segment u w \<inter> T = {}"
+          apply (rule segment_to_point_exists [OF uvT, of u])
+          by (metis IntD1 Int_commute Int_left_commute ends_in_segment(1) inf.orderE subset_oc_segment)
+        then have puw: "dist (p u) (p w) < \<epsilon> / 2"
+          by (metis (no_types) \<open>T \<subseteq> {0..1}\<close> \<open>dist v u < \<delta>\<close> \<delta> dist_commute dist_in_closed_segment le_less_trans subsetCE)
+        obtain z where "z \<in> T" and z: "z \<in> closed_segment u v" "open_segment v z \<inter> T = {}"
+          apply (rule segment_to_point_exists [OF uvT, of v])
+          by (metis IntD2 Int_commute Int_left_commute ends_in_segment(2) inf.orderE subset_oc_segment)
+        then have "dist (p u) (p z) < \<epsilon> / 2"
+          by (metis \<open>T \<subseteq> {0..1}\<close> \<open>dist v u < \<delta>\<close> \<delta> dist_commute dist_in_closed_segment le_less_trans subsetCE)
+        then show ?thesis
+          using puw by (metis (no_types) \<open>w \<in> T\<close> \<open>z \<in> T\<close> dist_commute dist_triangle_half_l h_eq_p_gen w(2) z(2))
+      qed
+      with \<open>0 < \<delta>\<close> show "\<exists>\<delta>>0. \<forall>v\<in>{0..1}. dist v u < \<delta> \<longrightarrow> dist (h v) (h u) < \<epsilon>" by blast
+    qed
+    show "connected ({0..1} \<inter> h -` {z})" for z
+    proof (clarsimp simp add: connected_iff_connected_component)
+      fix u v
+      assume huv_eq: "h v = h u" and uv: "0 \<le> u" "u \<le> 1" "0 \<le> v" "v \<le> 1"
+      have "\<exists>T. connected T \<and> T \<subseteq> {0..1} \<and> T \<subseteq> h -` {h u} \<and> u \<in> T \<and> v \<in> T"
+      proof (intro exI conjI)
+        show "connected (closed_segment u v)"
+          by simp
+        show "closed_segment u v \<subseteq> {0..1}"
+          by (simp add: uv closed_segment_eq_real_ivl)
+        have pxy: "p x = p y"
+          if "T \<subseteq> {0..1}" "0 \<in> T" "1 \<in> T" "x \<in> T" "y \<in> T"
+          and disjT: "open_segment x y \<inter> (T - open_segment u v) = {}"
+          and xynot: "x \<notin> open_segment u v" "y \<notin> open_segment u v"
+          for x y
+        proof (cases "open_segment x y \<inter> open_segment u v = {}")
+          case True
+          then show ?thesis
+            by (metis Diff_Int_distrib Diff_empty peq disjT \<open>x \<in> T\<close> \<open>y \<in> T\<close>)
+        next
+          case False
+          then have "open_segment x u \<union> open_segment y v \<subseteq> open_segment x y - open_segment u v \<or>
+                     open_segment y u \<union> open_segment x v \<subseteq> open_segment x y - open_segment u v" (is "?xuyv \<or> ?yuxv")
+            using xynot by (fastforce simp add: open_segment_eq_real_ivl not_le not_less split: if_split_asm)
+          then show "p x = p y"
+          proof
+            assume "?xuyv"
+            then have "open_segment x u \<inter> T = {}" "open_segment y v \<inter> T = {}"
+              using disjT by auto
+            then have "h x = h y"
+              using heq huv_eq by auto
+            then show ?thesis
+              using h_eq_p \<open>x \<in> T\<close> \<open>y \<in> T\<close> by auto
+          next
+            assume "?yuxv"
+            then have "open_segment y u \<inter> T = {}" "open_segment x v \<inter> T = {}"
+              using disjT by auto
+            then have "h x = h y"
+              using heq [of y u]  heq [of x v] huv_eq by auto
+            then show ?thesis
+              using h_eq_p \<open>x \<in> T\<close> \<open>y \<in> T\<close> by auto
+          qed
+        qed
+        have "\<not> T - open_segment u v \<subset> T"
+        proof (rule T)
+          show "closed (T - open_segment u v)"
+            by (simp add: closed_Diff [OF \<open>closed T\<close>] open_segment_eq_real_ivl)
+          have "0 \<notin> open_segment u v" "1 \<notin> open_segment u v"
+            using open_segment_eq_real_ivl uv by auto
+          then show "\<phi> (T - open_segment u v)"
+            using \<open>T \<subseteq> {0..1}\<close> \<open>0 \<in> T\<close> \<open>1 \<in> T\<close>
+            by (auto simp: \<phi>_def) (meson peq pxy)
+        qed
+        then have "open_segment u v \<inter> T = {}"
+          by blast
+        then show "closed_segment u v \<subseteq> h -` {h u}"
+          by (force intro: heq simp: open_segment_eq_real_ivl closed_segment_eq_real_ivl split: if_split_asm)+
+      qed auto
+      then show "connected_component ({0..1} \<inter> h -` {h u}) u v"
+        by (simp add: connected_component_def)
+    qed
+    show "h 1 \<noteq> h 0"
+      by (metis \<open>\<phi> T\<close> \<phi>_def a \<open>a \<noteq> b\<close> b h_eq_p pathfinish_def pathstart_def)
+  qed
+  then obtain f and g :: "real \<Rightarrow> 'a"
+    where gfeq: "(\<forall>x\<in>h ` {0..1}. (g(f x) = x))" and fhim: "f ` h ` {0..1} = {0..1}" and contf: "continuous_on (h ` {0..1}) f"
+      and fgeq: "(\<forall>y\<in>{0..1}. (f(g y) = y))" and pag: "path_image g = h ` {0..1}" and contg: "continuous_on {0..1} g"
+    by (auto simp: homeomorphic_def homeomorphism_def path_image_def)
+  then have "arc g"
+    by (metis arc_def path_def inj_on_def)
+  obtain u v where "u \<in> {0..1}" "a = g u" "v \<in> {0..1}" "b = g v"
+    by (metis (mono_tags, hide_lams) \<open>\<phi> T\<close> \<phi>_def a b fhim gfeq h_eq_p imageI path_image_def pathfinish_def pathfinish_in_path_image pathstart_def pathstart_in_path_image)
+  then have "a \<in> path_image g" "b \<in> path_image g"
+    using path_image_def by blast+
+  have ph: "path_image h \<subseteq> path_image p"
+    by (metis image_mono image_subset_iff path_image_def disjoint h_eq_p_gen \<open>T \<subseteq> {0..1}\<close>)
+  show ?thesis
+  proof
+    show "pathstart (subpath u v g) = a" "pathfinish (subpath u v g) = b"
+      by (simp_all add: \<open>a = g u\<close> \<open>b = g v\<close>)
+    show "path_image (subpath u v g) \<subseteq> path_image p"
+      by (metis \<open>arc g\<close> \<open>u \<in> {0..1}\<close> \<open>v \<in> {0..1}\<close> arc_imp_path order_trans pag path_image_def path_image_subpath_subset ph)
+    show "arc (subpath u v g)"
+      using \<open>arc g\<close> \<open>a = g u\<close> \<open>b = g v\<close> \<open>u \<in> {0..1}\<close> \<open>v \<in> {0..1}\<close> arc_subpath_arc \<open>a \<noteq> b\<close> by blast
+  qed
+qed
+
+
+corollary path_connected_arcwise:
+  fixes S :: "'a::{complete_space,real_normed_vector} set"
+  shows "path_connected S \<longleftrightarrow>
+         (\<forall>x \<in> S. \<forall>y \<in> S. x \<noteq> y \<longrightarrow> (\<exists>g. arc g \<and> path_image g \<subseteq> S \<and> pathstart g = x \<and> pathfinish g = y))"
+        (is "?lhs = ?rhs")
+proof (intro iffI impI ballI)
+  fix x y
+  assume "path_connected S" "x \<in> S" "y \<in> S" "x \<noteq> y"
+  then obtain p where p: "path p" "path_image p \<subseteq> S" "pathstart p = x" "pathfinish p = y"
+    by (force simp: path_connected_def)
+  then show "\<exists>g. arc g \<and> path_image g \<subseteq> S \<and> pathstart g = x \<and> pathfinish g = y"
+    by (metis \<open>x \<noteq> y\<close> order_trans path_contains_arc)
+next
+  assume R [rule_format]: ?rhs
+  show ?lhs
+    unfolding path_connected_def
+  proof (intro ballI)
+    fix x y
+    assume "x \<in> S" "y \<in> S"
+    show "\<exists>g. path g \<and> path_image g \<subseteq> S \<and> pathstart g = x \<and> pathfinish g = y"
+    proof (cases "x = y")
+      case True with \<open>x \<in> S\<close> path_component_def path_component_refl show ?thesis
+        by blast
+    next
+      case False with R [OF \<open>x \<in> S\<close> \<open>y \<in> S\<close>] show ?thesis
+        by (auto intro: arc_imp_path)
+    qed
+  qed
+qed
+
+
+corollary arc_connected_trans:
+  fixes g :: "real \<Rightarrow> 'a::{complete_space,real_normed_vector}"
+  assumes "arc g" "arc h" "pathfinish g = pathstart h" "pathstart g \<noteq> pathfinish h"
+  obtains i where "arc i" "path_image i \<subseteq> path_image g \<union> path_image h"
+                  "pathstart i = pathstart g" "pathfinish i = pathfinish h"
+  by (metis (no_types, hide_lams) arc_imp_path assms path_contains_arc path_image_join path_join pathfinish_join pathstart_join)
+
+
+
+
+subsection\<open>Accessibility of frontier points\<close>
+
+lemma dense_accessible_frontier_points:
+  fixes S :: "'a::{complete_space,real_normed_vector} set"
+  assumes "open S" and opeSV: "openin (subtopology euclidean (frontier S)) V" and "V \<noteq> {}"
+  obtains g where "arc g" "g ` {0..<1} \<subseteq> S" "pathstart g \<in> S" "pathfinish g \<in> V"
+proof -
+  obtain z where "z \<in> V"
+    using \<open>V \<noteq> {}\<close> by auto
+  then obtain r where "r > 0" and r: "ball z r \<inter> frontier S \<subseteq> V"
+    by (metis openin_contains_ball opeSV)
+  then have "z \<in> frontier S"
+    using \<open>z \<in> V\<close> opeSV openin_contains_ball by blast
+  then have "z \<in> closure S" "z \<notin> S"
+    by (simp_all add: frontier_def assms interior_open)
+  with \<open>r > 0\<close> have "infinite (S \<inter> ball z r)"
+    by (auto simp: closure_def islimpt_eq_infinite_ball)
+  then obtain y where "y \<in> S" and y: "y \<in> ball z r"
+    using infinite_imp_nonempty by force
+  then have "y \<notin> frontier S"
+    by (meson \<open>open S\<close> disjoint_iff_not_equal frontier_disjoint_eq)
+  have "y \<noteq> z"
+    using \<open>y \<in> S\<close> \<open>z \<notin> S\<close> by blast
+  have "path_connected(ball z r)"
+    by (simp add: convex_imp_path_connected)
+  with y \<open>r > 0\<close>  obtain g where "arc g" and pig: "path_image g \<subseteq> ball z r"
+                                 and g: "pathstart g = y" "pathfinish g = z"
+    using \<open>y \<noteq> z\<close> by (force simp: path_connected_arcwise)
+  have "compact (g -` frontier S \<inter> {0..1})"
+    apply (simp add: compact_eq_bounded_closed bounded_Int bounded_closed_interval)
+     apply (rule closed_vimage_Int)
+    using \<open>arc g\<close> apply (auto simp: arc_def path_def)
+    done
+  moreover have "g -` frontier S \<inter> {0..1} \<noteq> {}"
+  proof -
+    have "\<exists>r. r \<in> g -` frontier S \<and> r \<in> {0..1}"
+      by (metis \<open>z \<in> frontier S\<close> g(2) imageE path_image_def pathfinish_in_path_image vimageI2)
+    then show ?thesis
+      by blast
+  qed
+  ultimately obtain t where gt: "g t \<in> frontier S" and "0 \<le> t" "t \<le> 1"
+                and t: "\<And>u. \<lbrakk>g u \<in> frontier S; 0 \<le> u; u \<le> 1\<rbrakk> \<Longrightarrow> t \<le> u"
+    by (force simp: dest!: compact_attains_inf)
+  moreover have "t \<noteq> 0"
+    by (metis \<open>y \<notin> frontier S\<close> g(1) gt pathstart_def)
+  ultimately have  t01: "0 < t" "t \<le> 1"
+    by auto
+  have "V \<subseteq> frontier S"
+    using opeSV openin_contains_ball by blast
+  show ?thesis
+  proof
+    show "arc (subpath 0 t g)"
+      by (simp add: \<open>0 \<le> t\<close> \<open>t \<le> 1\<close> \<open>arc g\<close> \<open>t \<noteq> 0\<close> arc_subpath_arc)
+    have "g 0 \<in> S"
+      by (metis \<open>y \<in> S\<close> g(1) pathstart_def)
+    then show "pathstart (subpath 0 t g) \<in> S"
+      by auto
+    have "g t \<in> V"
+      by (metis IntI atLeastAtMost_iff gt image_eqI path_image_def pig r subsetCE \<open>0 \<le> t\<close> \<open>t \<le> 1\<close>)
+    then show "pathfinish (subpath 0 t g) \<in> V"
+      by auto
+    then have "inj_on (subpath 0 t g) {0..1}"
+      using t01
+      apply (clarsimp simp: inj_on_def subpath_def)
+      apply (drule inj_onD [OF arc_imp_inj_on [OF \<open>arc g\<close>]])
+      using mult_le_one apply auto
+      done
+    then have "subpath 0 t g ` {0..<1} \<subseteq> subpath 0 t g ` {0..1} - {subpath 0 t g 1}"
+      by (force simp: dest: inj_onD)
+    moreover have False if "subpath 0 t g ` ({0..<1}) - S \<noteq> {}"
+    proof -
+      have contg: "continuous_on {0..1} g"
+        using \<open>arc g\<close> by (auto simp: arc_def path_def)
+      have "subpath 0 t g ` {0..<1} \<inter> frontier S \<noteq> {}"
+      proof (rule connected_Int_frontier [OF _ _ that])
+        show "connected (subpath 0 t g ` {0..<1})"
+          apply (rule connected_continuous_image)
+           apply (simp add: subpath_def)
+           apply (intro continuous_intros continuous_on_compose2 [OF contg])
+           apply (auto simp: \<open>0 \<le> t\<close> \<open>t \<le> 1\<close> mult_le_one)
+          done
+        show "subpath 0 t g ` {0..<1} \<inter> S \<noteq> {}"
+          using \<open>y \<in> S\<close> g(1) by (force simp: subpath_def image_def pathstart_def)
+      qed
+      then obtain x where "x \<in> subpath 0 t g ` {0..<1}" "x \<in> frontier S"
+        by blast
+      with t01 \<open>0 \<le> t\<close> mult_le_one t show False
+        by (fastforce simp: subpath_def)
+    qed
+    then have "subpath 0 t g ` {0..1} - {subpath 0 t g 1} \<subseteq> S"
+      using subsetD by fastforce
+    ultimately  show "subpath 0 t g ` {0..<1} \<subseteq> S"
+      by auto
+  qed
+qed
+
+
+lemma dense_accessible_frontier_points_connected:
+  fixes S :: "'a::{complete_space,real_normed_vector} set"
+  assumes "open S" "connected S" "x \<in> S" "V \<noteq> {}"
+      and ope: "openin (subtopology euclidean (frontier S)) V"
+  obtains g where "arc g" "g ` {0..<1} \<subseteq> S" "pathstart g = x" "pathfinish g \<in> V"
+proof -
+  have "V \<subseteq> frontier S"
+    using ope openin_imp_subset by blast
+  with \<open>open S\<close> \<open>x \<in> S\<close> have "x \<notin> V"
+    using interior_open by (auto simp: frontier_def)
+  obtain g where "arc g" and g: "g ` {0..<1} \<subseteq> S" "pathstart g \<in> S" "pathfinish g \<in> V"
+    by (metis dense_accessible_frontier_points [OF \<open>open S\<close> ope \<open>V \<noteq> {}\<close>])
+  then have "path_connected S"
+    by (simp add: assms connected_open_path_connected)
+  with \<open>pathstart g \<in> S\<close> \<open>x \<in> S\<close> have "path_component S x (pathstart g)"
+    by (simp add: path_connected_component)
+  then obtain f where "path f" and f: "path_image f \<subseteq> S" "pathstart f = x" "pathfinish f = pathstart g"
+    by (auto simp: path_component_def)
+  then have "path (f +++ g)"
+    by (simp add: \<open>arc g\<close> arc_imp_path)
+  then obtain h where "arc h"
+                  and h: "path_image h \<subseteq> path_image (f +++ g)" "pathstart h = x" "pathfinish h = pathfinish g"
+    apply (rule path_contains_arc [of "f +++ g" x "pathfinish g"])
+    using f \<open>x \<notin> V\<close> \<open>pathfinish g \<in> V\<close> by auto
+  have "h ` {0..1} - {h 1} \<subseteq> S"
+    using f g h apply (clarsimp simp: path_image_join)
+    apply (simp add: path_image_def pathfinish_def subset_iff image_def Bex_def)
+    by (metis le_less)
+  then have "h ` {0..<1} \<subseteq> S"
+    using \<open>arc h\<close> by (force simp: arc_def dest: inj_onD)
+  then show thesis
+    apply (rule that [OF \<open>arc h\<close>])
+    using h \<open>pathfinish g \<in> V\<close> by auto
+qed
+
+lemma dense_access_fp_aux:
+  fixes S :: "'a::{complete_space,real_normed_vector} set"
+  assumes S: "open S" "connected S"
+      and opeSU: "openin (subtopology euclidean (frontier S)) U"
+      and opeSV: "openin (subtopology euclidean (frontier S)) V"
+      and "V \<noteq> {}" "\<not> U \<subseteq> V"
+  obtains g where "arc g" "pathstart g \<in> U" "pathfinish g \<in> V" "g ` {0<..<1} \<subseteq> S"
+proof -
+  have "S \<noteq> {}"
+    using opeSV \<open>V \<noteq> {}\<close> by (metis frontier_empty openin_subtopology_empty)
+  then obtain x where "x \<in> S" by auto
+  obtain g where "arc g" and g: "g ` {0..<1} \<subseteq> S" "pathstart g = x" "pathfinish g \<in> V"
+    using dense_accessible_frontier_points_connected [OF S \<open>x \<in> S\<close> \<open>V \<noteq> {}\<close> opeSV] by blast
+  obtain h where "arc h" and h: "h ` {0..<1} \<subseteq> S" "pathstart h = x" "pathfinish h \<in> U - {pathfinish g}"
+  proof (rule dense_accessible_frontier_points_connected [OF S \<open>x \<in> S\<close>])
+    show "U - {pathfinish g} \<noteq> {}"
+      using \<open>pathfinish g \<in> V\<close> \<open>\<not> U \<subseteq> V\<close> by blast
+    show "openin (subtopology euclidean (frontier S)) (U - {pathfinish g})"
+      by (simp add: opeSU openin_delete)
+  qed auto
+  obtain \<gamma> where "arc \<gamma>"
+             and \<gamma>: "path_image \<gamma> \<subseteq> path_image (reversepath h +++ g)"
+                    "pathstart \<gamma> = pathfinish h" "pathfinish \<gamma> = pathfinish g"
+  proof (rule path_contains_arc [of "(reversepath h +++ g)" "pathfinish h" "pathfinish g"])
+    show "path (reversepath h +++ g)"
+      by (simp add: \<open>arc g\<close> \<open>arc h\<close> \<open>pathstart g = x\<close> \<open>pathstart h = x\<close> arc_imp_path)
+    show "pathstart (reversepath h +++ g) = pathfinish h"
+         "pathfinish (reversepath h +++ g) = pathfinish g"
+      by auto
+    show "pathfinish h \<noteq> pathfinish g"
+      using \<open>pathfinish h \<in> U - {pathfinish g}\<close> by auto
+  qed auto
+  show ?thesis
+  proof
+    show "arc \<gamma>" "pathstart \<gamma> \<in> U" "pathfinish \<gamma> \<in> V"
+      using \<gamma> \<open>arc \<gamma>\<close> \<open>pathfinish h \<in> U - {pathfinish g}\<close>  \<open>pathfinish g \<in> V\<close> by auto
+    have "\<gamma> ` {0..1} - {\<gamma> 0, \<gamma> 1} \<subseteq> S"
+      using \<gamma> g h
+      apply (simp add: path_image_join)
+      apply (simp add: path_image_def pathstart_def pathfinish_def subset_iff image_def Bex_def)
+      by (metis linorder_neqE_linordered_idom not_less)
+    then show "\<gamma> ` {0<..<1} \<subseteq> S"
+      using \<open>arc h\<close> \<open>arc \<gamma>\<close>
+      by (metis arc_imp_simple_path path_image_def pathfinish_def pathstart_def simple_path_endless)
+  qed
+qed
+
+lemma dense_accessible_frontier_point_pairs:
+  fixes S :: "'a::{complete_space,real_normed_vector} set"
+  assumes S: "open S" "connected S"
+      and opeSU: "openin (subtopology euclidean (frontier S)) U"
+      and opeSV: "openin (subtopology euclidean (frontier S)) V"
+      and "U \<noteq> {}" "V \<noteq> {}" "U \<noteq> V"
+    obtains g where "arc g" "pathstart g \<in> U" "pathfinish g \<in> V" "g ` {0<..<1} \<subseteq> S"
+proof -
+  consider "\<not> U \<subseteq> V" | "\<not> V \<subseteq> U"
+    using \<open>U \<noteq> V\<close> by blast
+  then show ?thesis
+  proof cases
+    case 1 then show ?thesis
+      using assms dense_access_fp_aux [OF S opeSU opeSV] that by blast
+  next
+    case 2
+    obtain g where "arc g" and g: "pathstart g \<in> V" "pathfinish g \<in> U" "g ` {0<..<1} \<subseteq> S"
+      using assms dense_access_fp_aux [OF S opeSV opeSU] "2" by blast
+    show ?thesis
+    proof
+      show "arc (reversepath g)"
+        by (simp add: \<open>arc g\<close> arc_reversepath)
+      show "pathstart (reversepath g) \<in> U" "pathfinish (reversepath g) \<in> V"
+        using g by auto
+      show "reversepath g ` {0<..<1} \<subseteq> S"
+        using g by (auto simp: reversepath_def)
+    qed
+  qed
+qed
+
+end
diff -r 81a5473e6d04 -r a0e1f64be67c src/HOL/Analysis/Brouwer_Fixpoint.thy
--- a/src/HOL/Analysis/Brouwer_Fixpoint.thy	Thu Jan 05 22:37:52 2017 +0100
+++ b/src/HOL/Analysis/Brouwer_Fixpoint.thy	Thu Jan 05 22:38:06 2017 +0100
@@ -2021,6 +2021,55 @@
     done
 qed
 
+lemma connected_sphere_eq:
+  fixes a :: "'a :: euclidean_space"
+  shows "connected(sphere a r) \<longleftrightarrow> 2 \<le> DIM('a) \<or> r \<le> 0"
+    (is "?lhs = ?rhs")
+proof (cases r "0::real" rule: linorder_cases)
+  case less
+  then show ?thesis by auto
+next
+  case equal
+  then show ?thesis by auto
+next
+  case greater
+  show ?thesis
+  proof
+    assume L: ?lhs
+    have "False" if 1: "DIM('a) = 1"
+    proof -
+      obtain x y where xy: "sphere a r = {x,y}" "x \<noteq> y"
+        using sphere_1D_doubleton [OF 1 greater]
+        by (metis dist_self greater insertI1 less_add_same_cancel1 mem_sphere mult_2 not_le zero_le_dist)
+      then have "finite (sphere a r)"
+        by auto
+      with L \<open>r > 0\<close> show "False"
+        apply (auto simp: connected_finite_iff_sing)
+        using xy by auto
+    qed
+    with greater show ?rhs
+      by (metis DIM_ge_Suc0 One_nat_def Suc_1 le_antisym not_less_eq_eq)
+  next
+    assume ?rhs
+    then show ?lhs
+      using connected_sphere greater by auto
+  qed
+qed
+
+lemma path_connected_sphere_eq:
+  fixes a :: "'a :: euclidean_space"
+  shows "path_connected(sphere a r) \<longleftrightarrow> 2 \<le> DIM('a) \<or> r \<le> 0"
+         (is "?lhs = ?rhs")
+proof
+  assume ?lhs
+  then show ?rhs
+    using connected_sphere_eq path_connected_imp_connected by blast
+next
+  assume R: ?rhs
+  then show ?lhs
+    by (auto simp: contractible_imp_path_connected contractible_sphere path_connected_sphere)
+qed
+
 proposition frontier_subset_retraction:
   fixes S :: "'a::euclidean_space set"
   assumes "bounded S" and fros: "frontier S \<subseteq> T"
@@ -2073,7 +2122,7 @@
   ultimately show False by simp
 qed
 
-subsection\<open>Retractions\<close>
+subsection\<open>More Properties of Retractions\<close>
 
 lemma retraction:
    "retraction s t r \<longleftrightarrow>
@@ -2272,6 +2321,60 @@
   using assms
   by (auto simp: retract_of_def retraction intro!: retraction_imp_quotient_map elim!: locally_path_connected_quotient_image)
 
+subsubsection\<open>A few simple lemmas about deformation retracts\<close>
+
+lemma deformation_retract_imp_homotopy_eqv:
+  fixes S :: "'a::euclidean_space set"
+  assumes "homotopic_with (\<lambda>x. True) S S id r" "retraction S T r"
+    shows "S homotopy_eqv T"
+  apply (simp add: homotopy_eqv_def)
+  apply (rule_tac x=r in exI)
+  using assms apply (simp add: retraction_def)
+  apply (rule_tac x=id in exI)
+  apply (auto simp: continuous_on_id)
+   apply (metis homotopic_with_symD)
+  by (metis continuous_on_id' homotopic_with_equal homotopic_with_symD id_apply image_id subset_refl)
+
+lemma deformation_retract:
+  fixes S :: "'a::euclidean_space set"
+    shows "(\<exists>r. homotopic_with (\<lambda>x. True) S S id r \<and> retraction S T r) \<longleftrightarrow>
+           T retract_of S \<and> (\<exists>f. homotopic_with (\<lambda>x. True) S S id f \<and> f ` S \<subseteq> T)"
+    (is "?lhs = ?rhs")
+proof
+  assume ?lhs
+  then show ?rhs
+    by (auto simp: retract_of_def retraction_def)
+next
+  assume ?rhs
+  then show ?lhs
+    apply (clarsimp simp add: retract_of_def retraction_def)
+    apply (rule_tac x=r in exI, simp)
+     apply (rule homotopic_with_trans, assumption)
+     apply (rule_tac f = "r \<circ> f" and g="r \<circ> id" in homotopic_with_eq)
+        apply (rule_tac Y=S in homotopic_compose_continuous_left)
+         apply (auto simp: homotopic_with_sym)
+    done
+qed
+
+lemma deformation_retract_of_contractible_sing:
+  fixes S :: "'a::euclidean_space set"
+  assumes "contractible S" "a \<in> S"
+  obtains r where "homotopic_with (\<lambda>x. True) S S id r" "retraction S {a} r"
+proof -
+  have "{a} retract_of S"
+    by (simp add: \<open>a \<in> S\<close>)
+  moreover have "homotopic_with (\<lambda>x. True) S S id (\<lambda>x. a)"
+    using assms
+    apply (clarsimp simp add: contractible_def)
+    apply (rule homotopic_with_trans, assumption)
+    by (metis assms(1) contractible_imp_path_connected homotopic_constant_maps homotopic_with_sym homotopic_with_trans insert_absorb insert_not_empty path_component_mem(1) path_connected_component)
+  moreover have "(\<lambda>x. a) ` S \<subseteq> {a}"
+    by (simp add: image_subsetI)
+  ultimately show ?thesis
+    using that deformation_retract  by metis
+qed
+
+
 subsection\<open>Punctured affine hulls, etc.\<close>
 
 lemma continuous_on_compact_surface_projection_aux:
@@ -2493,6 +2596,23 @@
 by (metis assms closure_closed compact_eq_bounded_closed rel_frontier_def
           rel_frontier_retract_of_punctured_affine_hull)
 
+lemma homotopy_eqv_rel_frontier_punctured_convex:
+  fixes S :: "'a::euclidean_space set"
+  assumes "convex S" "bounded S" "a \<in> rel_interior S" "convex T" "rel_frontier S \<subseteq> T" "T \<subseteq> affine hull S"
+  shows "(rel_frontier S) homotopy_eqv (T - {a})"
+  apply (rule rel_frontier_deformation_retract_of_punctured_convex [of S T])
+  using assms
+  apply auto
+  apply (subst homotopy_eqv_sym)
+  using deformation_retract_imp_homotopy_eqv by blast
+
+lemma homotopy_eqv_rel_frontier_punctured_affine_hull:
+  fixes S :: "'a::euclidean_space set"
+  assumes "convex S" "bounded S" "a \<in> rel_interior S"
+    shows "(rel_frontier S) homotopy_eqv (affine hull S - {a})"
+apply (rule homotopy_eqv_rel_frontier_punctured_convex)
+  using assms rel_frontier_affine_hull  by force+
+
 lemma path_connected_sphere_gen:
   assumes "convex S" "bounded S" "aff_dim S \<noteq> 1"
   shows "path_connected(rel_frontier S)"
@@ -3931,7 +4051,6 @@
   assumes "AR S" "AR T" shows "AR(S \<times> T)"
 using assms by (simp add: AR_ANR ANR_Times contractible_Times)
 
-
 lemma ENR_rel_frontier_convex:
   fixes S :: "'a::euclidean_space set"
   assumes "bounded S" "convex S"
@@ -3972,6 +4091,297 @@
   assumes "bounded S" "convex S"
     shows "ANR(rel_frontier S)"
 by (simp add: ENR_imp_ANR ENR_rel_frontier_convex assms)
+    
+lemma ENR_closedin_Un_local:
+  fixes S :: "'a::euclidean_space set"
+  shows "\<lbrakk>ENR S; ENR T; ENR(S \<inter> T);
+          closedin (subtopology euclidean (S \<union> T)) S; closedin (subtopology euclidean (S \<union> T)) T\<rbrakk>
+        \<Longrightarrow> ENR(S \<union> T)"
+by (simp add: ENR_ANR ANR_closed_Un_local locally_compact_closedin_Un)
+
+lemma ENR_closed_Un:
+  fixes S :: "'a::euclidean_space set"
+  shows "\<lbrakk>closed S; closed T; ENR S; ENR T; ENR(S \<inter> T)\<rbrakk> \<Longrightarrow> ENR(S \<union> T)"
+by (auto simp: closed_subset ENR_closedin_Un_local)
+
+lemma absolute_retract_Un:
+  fixes S :: "'a::euclidean_space set"
+  shows "\<lbrakk>S retract_of UNIV; T retract_of UNIV; (S \<inter> T) retract_of UNIV\<rbrakk>
+         \<Longrightarrow> (S \<union> T) retract_of UNIV"
+  by (meson AR_closed_Un_local_aux closed_subset retract_of_UNIV retract_of_imp_subset)
+
+lemma retract_from_Un_Int:
+  fixes S :: "'a::euclidean_space set"
+  assumes clS: "closedin (subtopology euclidean (S \<union> T)) S"
+      and clT: "closedin (subtopology euclidean (S \<union> T)) T"
+      and Un: "(S \<union> T) retract_of U" and Int: "(S \<inter> T) retract_of T"
+    shows "S retract_of U"
+proof -
+  obtain r where r: "continuous_on T r" "r ` T \<subseteq> S \<inter> T" "\<forall>x\<in>S \<inter> T. r x = x"
+    using Int by (auto simp: retraction_def retract_of_def)
+  have "S retract_of S \<union> T"
+    unfolding retraction_def retract_of_def
+  proof (intro exI conjI)
+    show "continuous_on (S \<union> T) (\<lambda>x. if x \<in> S then x else r x)"
+      apply (rule continuous_on_cases_local [OF clS clT])
+      using r by (auto simp: continuous_on_id)
+  qed (use r in auto)
+  also have "... retract_of U"
+    by (rule Un)
+  finally show ?thesis .
+qed
+
+lemma AR_from_Un_Int_local:
+  fixes S :: "'a::euclidean_space set"
+  assumes clS: "closedin (subtopology euclidean (S \<union> T)) S"
+      and clT: "closedin (subtopology euclidean (S \<union> T)) T"
+      and Un: "AR(S \<union> T)" and Int: "AR(S \<inter> T)"
+    shows "AR S"
+  apply (rule AR_retract_of_AR [OF Un])
+  by (meson AR_imp_retract clS clT closedin_closed_subset local.Int retract_from_Un_Int retract_of_refl sup_ge2)
+
+lemma AR_from_Un_Int_local':
+  fixes S :: "'a::euclidean_space set"
+  assumes "closedin (subtopology euclidean (S \<union> T)) S"
+      and "closedin (subtopology euclidean (S \<union> T)) T"
+      and "AR(S \<union> T)" "AR(S \<inter> T)"
+    shows "AR T"
+  using AR_from_Un_Int_local [of T S] assms by (simp add: Un_commute Int_commute)
+
+lemma AR_from_Un_Int:
+  fixes S :: "'a::euclidean_space set"
+  assumes clo: "closed S" "closed T" and Un: "AR(S \<union> T)" and Int: "AR(S \<inter> T)"
+  shows "AR S"
+  by (metis AR_from_Un_Int_local [OF _ _ Un Int] Un_commute clo closed_closedin closedin_closed_subset inf_sup_absorb subtopology_UNIV top_greatest)
+
+lemma ANR_from_Un_Int_local:
+  fixes S :: "'a::euclidean_space set"
+  assumes clS: "closedin (subtopology euclidean (S \<union> T)) S"
+      and clT: "closedin (subtopology euclidean (S \<union> T)) T"
+      and Un: "ANR(S \<union> T)" and Int: "ANR(S \<inter> T)"
+    shows "ANR S"
+proof -
+  obtain V where clo: "closedin (subtopology euclidean (S \<union> T)) (S \<inter> T)"
+             and ope: "openin (subtopology euclidean (S \<union> T)) V"
+             and ret: "S \<inter> T retract_of V"
+    using ANR_imp_neighbourhood_retract [OF Int] by (metis clS clT closedin_Int)
+  then obtain r where r: "continuous_on V r" and rim: "r ` V \<subseteq> S \<inter> T" and req: "\<forall>x\<in>S \<inter> T. r x = x"
+    by (auto simp: retraction_def retract_of_def)
+  have Vsub: "V \<subseteq> S \<union> T"
+    by (meson ope openin_contains_cball)
+  have Vsup: "S \<inter> T \<subseteq> V"
+    by (simp add: retract_of_imp_subset ret)
+  then have eq: "S \<union> V = ((S \<union> T) - T) \<union> V"
+    by auto
+  have eq': "S \<union> V = S \<union> (V \<inter> T)"
+    using Vsub by blast
+  have "continuous_on (S \<union> V \<inter> T) (\<lambda>x. if x \<in> S then x else r x)"
+  proof (rule continuous_on_cases_local)
+    show "closedin (subtopology euclidean (S \<union> V \<inter> T)) S"
+      using clS closedin_subset_trans inf.boundedE by blast
+    show "closedin (subtopology euclidean (S \<union> V \<inter> T)) (V \<inter> T)"
+      using clT Vsup by (auto simp: closedin_closed)
+    show "continuous_on (V \<inter> T) r"
+      by (meson Int_lower1 continuous_on_subset r)
+  qed (use req continuous_on_id in auto)
+  with rim have "S retract_of S \<union> V"
+    unfolding retraction_def retract_of_def
+    apply (rule_tac x="\<lambda>x. if x \<in> S then x else r x" in exI)
+    apply (auto simp: eq')
+    done
+  then show ?thesis
+    using ANR_neighborhood_retract [OF Un]
+    using \<open>S \<union> V = S \<union> T - T \<union> V\<close> clT ope by fastforce
+qed
+
+lemma ANR_from_Un_Int:
+  fixes S :: "'a::euclidean_space set"
+  assumes clo: "closed S" "closed T" and Un: "ANR(S \<union> T)" and Int: "ANR(S \<inter> T)"
+  shows "ANR S"
+  by (metis ANR_from_Un_Int_local [OF _ _ Un Int] Un_commute clo closed_closedin closedin_closed_subset inf_sup_absorb subtopology_UNIV top_greatest)
+
+proposition ANR_finite_Union_convex_closed:
+  fixes \<T> :: "'a::euclidean_space set set"
+  assumes \<T>: "finite \<T>" and clo: "\<And>C. C \<in> \<T> \<Longrightarrow> closed C" and con: "\<And>C. C \<in> \<T> \<Longrightarrow> convex C"
+  shows "ANR(\<Union>\<T>)"
+proof -
+  have "ANR(\<Union>\<T>)" if "card \<T> < n" for n
+  using assms that
+  proof (induction n arbitrary: \<T>)
+    case 0 then show ?case by simp
+  next
+    case (Suc n)
+    have "ANR(\<Union>\<U>)" if "finite \<U>" "\<U> \<subseteq> \<T>" for \<U>
+      using that
+    proof (induction \<U>)
+      case empty
+      then show ?case  by simp
+    next
+      case (insert C \<U>)
+      have "ANR (C \<union> \<Union>\<U>)"
+      proof (rule ANR_closed_Un)
+        show "ANR (C \<inter> \<Union>\<U>)"
+          unfolding Int_Union
+        proof (rule Suc)
+          show "finite (op \<inter> C ` \<U>)"
+            by (simp add: insert.hyps(1))
+          show "\<And>Ca. Ca \<in> op \<inter> C ` \<U> \<Longrightarrow> closed Ca"
+            by (metis (no_types, hide_lams) Suc.prems(2) closed_Int subsetD imageE insert.prems insertI1 insertI2)
+          show "\<And>Ca. Ca \<in> op \<inter> C ` \<U> \<Longrightarrow> convex Ca"
+            by (metis (mono_tags, lifting) Suc.prems(3) convex_Int imageE insert.prems insert_subset subsetCE)
+          show "card (op \<inter> C ` \<U>) < n"
+          proof -
+            have "card \<T> \<le> n"
+              by (meson Suc.prems(4) not_less not_less_eq)
+            then show ?thesis
+              by (metis Suc.prems(1) card_image_le card_seteq insert.hyps insert.prems insert_subset le_trans not_less)
+          qed
+        qed
+        show "closed (\<Union>\<U>)"
+          using Suc.prems(2) insert.hyps(1) insert.prems by blast
+      qed (use Suc.prems convex_imp_ANR insert.prems insert.IH in auto)
+      then show ?case
+        by simp
+    qed
+    then show ?case
+      using Suc.prems(1) by blast
+  qed
+  then show ?thesis
+    by blast
+qed
+
+
+lemma finite_imp_ANR:
+  fixes S :: "'a::euclidean_space set"
+  assumes "finite S"
+  shows "ANR S"
+proof -
+  have "ANR(\<Union>x \<in> S. {x})"
+    by (blast intro: ANR_finite_Union_convex_closed assms)
+  then show ?thesis
+    by simp
+qed
+
+lemma ANR_insert:
+  fixes S :: "'a::euclidean_space set"
+  assumes "ANR S" "closed S"
+  shows "ANR(insert a S)"
+  by (metis ANR_closed_Un ANR_empty ANR_singleton Diff_disjoint Diff_insert_absorb assms closed_singleton insert_absorb insert_is_Un)
+
+lemma ANR_path_component_ANR:
+  fixes S :: "'a::euclidean_space set"
+  shows "ANR S \<Longrightarrow> ANR(path_component_set S x)"
+  using ANR_imp_locally_path_connected ANR_openin openin_path_component_locally_path_connected by blast
+
+lemma ANR_connected_component_ANR:
+  fixes S :: "'a::euclidean_space set"
+  shows "ANR S \<Longrightarrow> ANR(connected_component_set S x)"
+  by (metis ANR_openin openin_connected_component_locally_connected ANR_imp_locally_connected)
+
+lemma ANR_component_ANR:
+  fixes S :: "'a::euclidean_space set"
+  assumes "ANR S" "c \<in> components S"
+  shows "ANR c"
+  by (metis ANR_connected_component_ANR assms componentsE)
+
+subsection\<open>Original ANR material, now for ENRs.\<close>
+
+lemma ENR_bounded:
+  fixes S :: "'a::euclidean_space set"
+  assumes "bounded S"
+  shows "ENR S \<longleftrightarrow> (\<exists>U. open U \<and> bounded U \<and> S retract_of U)"
+         (is "?lhs = ?rhs")
+proof
+  obtain r where "0 < r" and r: "S \<subseteq> ball 0 r"
+    using bounded_subset_ballD assms by blast
+  assume ?lhs
+  then show ?rhs
+    apply (clarsimp simp: ENR_def)
+    apply (rule_tac x="ball 0 r \<inter> U" in exI, auto)
+    using r retract_of_imp_subset retract_of_subset by fastforce
+next
+  assume ?rhs
+  then show ?lhs
+    using ENR_def by blast
+qed
+
+lemma absolute_retract_imp_AR_gen:
+  fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
+  assumes "S retract_of T" "convex T" "T \<noteq> {}" "S homeomorphic S'" "closedin (subtopology euclidean U) S'"
+  shows "S' retract_of U"
+proof -
+  have "AR T"
+    by (simp add: assms convex_imp_AR)
+  then have "AR S"
+    using AR_retract_of_AR assms by auto
+  then show ?thesis
+    using assms AR_imp_absolute_retract by metis
+qed
+
+lemma absolute_retract_imp_AR:
+  fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
+  assumes "S retract_of UNIV" "S homeomorphic S'" "closed S'"
+  shows "S' retract_of UNIV"
+  using AR_imp_absolute_retract_UNIV assms retract_of_UNIV by blast
+
+lemma homeomorphic_compact_arness:
+  fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
+  assumes "S homeomorphic S'"
+  shows "compact S \<and> S retract_of UNIV \<longleftrightarrow> compact S' \<and> S' retract_of UNIV"
+  using assms homeomorphic_compactness
+  apply auto
+   apply (meson assms compact_AR homeomorphic_AR_iff_AR homeomorphic_compactness)+
+  done
+
+lemma absolute_retract_from_Un_Int:
+  fixes S :: "'a::euclidean_space set"
+  assumes "(S \<union> T) retract_of UNIV" "(S \<inter> T) retract_of UNIV" "closed S" "closed T"
+  shows "S retract_of UNIV"
+  using AR_from_Un_Int assms retract_of_UNIV by auto
+
+lemma ENR_from_Un_Int_gen:
+  fixes S :: "'a::euclidean_space set"
+  assumes "closedin (subtopology euclidean (S \<union> T)) S" "closedin (subtopology euclidean (S \<union> T)) T" "ENR(S \<union> T)" "ENR(S \<inter> T)"
+  shows "ENR S"
+  apply (simp add: ENR_ANR)
+  using ANR_from_Un_Int_local ENR_ANR assms locally_compact_closedin by blast
+
+
+lemma ENR_from_Un_Int:
+  fixes S :: "'a::euclidean_space set"
+  assumes "closed S" "closed T" "ENR(S \<union> T)" "ENR(S \<inter> T)"
+  shows "ENR S"
+  by (meson ENR_from_Un_Int_gen assms closed_subset sup_ge1 sup_ge2)
+
+
+lemma ENR_finite_Union_convex_closed:
+  fixes \<T> :: "'a::euclidean_space set set"
+  assumes \<T>: "finite \<T>" and clo: "\<And>C. C \<in> \<T> \<Longrightarrow> closed C" and con: "\<And>C. C \<in> \<T> \<Longrightarrow> convex C"
+  shows "ENR(\<Union> \<T>)"
+  by (simp add: ENR_ANR ANR_finite_Union_convex_closed \<T> clo closed_Union closed_imp_locally_compact con)
+
+lemma finite_imp_ENR:
+  fixes S :: "'a::euclidean_space set"
+  shows "finite S \<Longrightarrow> ENR S"
+  by (simp add: ENR_ANR finite_imp_ANR finite_imp_closed closed_imp_locally_compact)
+
+lemma ENR_insert:
+  fixes S :: "'a::euclidean_space set"
+  assumes "closed S" "ENR S"
+  shows "ENR(insert a S)"
+proof -
+  have "ENR ({a} \<union> S)"
+    by (metis ANR_insert ENR_ANR Un_commute Un_insert_right assms closed_imp_locally_compact closed_insert sup_bot_right)
+  then show ?thesis
+    by auto
+qed
+
+lemma ENR_path_component_ENR:
+  fixes S :: "'a::euclidean_space set"
+  assumes "ENR S"
+  shows "ENR(path_component_set S x)"
+  by (metis ANR_imp_locally_path_connected ENR_empty ENR_imp_ANR ENR_openin assms
+            locally_path_connected_2 openin_subtopology_self path_component_eq_empty)
 
 (*UNUSED
 lemma ENR_Times:
@@ -3983,6 +4393,61 @@
   SIMP_TAC[ENR_ANR; ANR_PCROSS; LOCALLY_COMPACT_PCROSS]);;
 *)
 
+subsection\<open>Finally, spheres are ANRs and ENRs\<close>
+
+lemma absolute_retract_homeomorphic_convex_compact:
+  fixes S :: "'a::euclidean_space set" and U :: "'b::euclidean_space set"
+  assumes "S homeomorphic U" "S \<noteq> {}" "S \<subseteq> T" "convex U" "compact U"
+  shows "S retract_of T"
+  by (metis UNIV_I assms compact_AR convex_imp_AR homeomorphic_AR_iff_AR homeomorphic_compactness homeomorphic_empty(1) retract_of_subset subsetI)
+
+lemma frontier_retract_of_punctured_universe:
+  fixes S :: "'a::euclidean_space set"
+  assumes "convex S" "bounded S" "a \<in> interior S"
+  shows "(frontier S) retract_of (- {a})"
+  using rel_frontier_retract_of_punctured_affine_hull
+  by (metis Compl_eq_Diff_UNIV affine_hull_nonempty_interior assms empty_iff rel_frontier_frontier rel_interior_nonempty_interior)
+
+lemma sphere_retract_of_punctured_universe_gen:
+  fixes a :: "'a::euclidean_space"
+  assumes "b \<in> ball a r"
+  shows  "sphere a r retract_of (- {b})"
+proof -
+  have "frontier (cball a r) retract_of (- {b})"
+    apply (rule frontier_retract_of_punctured_universe)
+    using assms by auto
+  then show ?thesis
+    by simp
+qed
+
+lemma sphere_retract_of_punctured_universe:
+  fixes a :: "'a::euclidean_space"
+  assumes "0 < r"
+  shows "sphere a r retract_of (- {a})"
+  by (simp add: assms sphere_retract_of_punctured_universe_gen)
+
+proposition ENR_sphere:
+  fixes a :: "'a::euclidean_space"
+  shows "ENR(sphere a r)"
+proof (cases "0 < r")
+  case True
+  then have "sphere a r retract_of -{a}"
+    by (simp add: sphere_retract_of_punctured_universe)
+  with open_delete show ?thesis
+    by (auto simp: ENR_def)
+next
+  case False
+  then show ?thesis
+    using finite_imp_ENR
+    by (metis finite_insert infinite_imp_nonempty less_linear sphere_eq_empty sphere_trivial)
+qed
+
+corollary ANR_sphere:
+  fixes a :: "'a::euclidean_space"
+  shows "ANR(sphere a r)"
+  by (simp add: ENR_imp_ANR ENR_sphere)
+
+
 subsection\<open>Borsuk homotopy extension theorem\<close>
 
 text\<open>It's only this late so we can use the concept of retraction,
@@ -4259,6 +4724,78 @@
   then show ?thesis by blast
 qed
 
+lemma homotopic_Borsuk_maps_in_bounded_component:
+  fixes a :: "'a :: euclidean_space"
+  assumes "compact S" and "a \<notin> S"and "b \<notin> S"
+      and boc: "bounded (connected_component_set (- S) a)"
+      and hom: "homotopic_with (\<lambda>x. True) S (sphere 0 1)
+                               (\<lambda>x. (x - a) /\<^sub>R norm (x - a))
+                               (\<lambda>x. (x - b) /\<^sub>R norm (x - b))"
+   shows "connected_component (- S) a b"
+proof (rule ccontr)
+  assume notcc: "\<not> connected_component (- S) a b"
+  let ?T = "S \<union> connected_component_set (- S) a"
+  have "\<nexists>g. continuous_on (S \<union> connected_component_set (- S) a) g \<and>
+            g ` (S \<union> connected_component_set (- S) a) \<subseteq> sphere 0 1 \<and>
+            (\<forall>x\<in>S. g x = (x - a) /\<^sub>R norm (x - a))"
+    by (simp add: \<open>a \<notin> S\<close> componentsI non_extensible_Borsuk_map [OF \<open>compact S\<close> _ boc])
+  moreover obtain g where "continuous_on (S \<union> connected_component_set (- S) a) g"
+                          "g ` (S \<union> connected_component_set (- S) a) \<subseteq> sphere 0 1"
+                          "\<And>x. x \<in> S \<Longrightarrow> g x = (x - a) /\<^sub>R norm (x - a)"
+  proof (rule Borsuk_homotopy_extension_homotopic)
+    show "closedin (subtopology euclidean ?T) S"
+      by (simp add: \<open>compact S\<close> closed_subset compact_imp_closed)
+    show "continuous_on ?T (\<lambda>x. (x - b) /\<^sub>R norm (x - b))"
+      by (simp add: \<open>b \<notin> S\<close> notcc continuous_on_Borsuk_map)
+    show "(\<lambda>x. (x - b) /\<^sub>R norm (x - b)) ` ?T \<subseteq> sphere 0 1"
+      by (simp add: \<open>b \<notin> S\<close> notcc Borsuk_map_into_sphere)
+    show "homotopic_with (\<lambda>x. True) S (sphere 0 1)
+             (\<lambda>x. (x - b) /\<^sub>R norm (x - b)) (\<lambda>x. (x - a) /\<^sub>R norm (x - a))"
+      by (simp add: hom homotopic_with_symD)
+    qed (auto simp: ANR_sphere intro: that)
+  ultimately show False by blast
+qed
+
+
+lemma Borsuk_maps_homotopic_in_connected_component_eq:
+  fixes a :: "'a :: euclidean_space"
+  assumes S: "compact S" "a \<notin> S" "b \<notin> S" and 2: "2 \<le> DIM('a)"
+    shows "(homotopic_with (\<lambda>x. True) S (sphere 0 1)
+                   (\<lambda>x. (x - a) /\<^sub>R norm (x - a))
+                   (\<lambda>x. (x - b) /\<^sub>R norm (x - b)) \<longleftrightarrow>
+           connected_component (- S) a b)"
+         (is "?lhs = ?rhs")
+proof
+  assume L: ?lhs
+  show ?rhs
+  proof (cases "bounded(connected_component_set (- S) a)")
+    case True
+    show ?thesis
+      by (rule homotopic_Borsuk_maps_in_bounded_component [OF S True L])
+  next
+    case not_bo_a: False
+    show ?thesis
+    proof (cases "bounded(connected_component_set (- S) b)")
+      case True
+      show ?thesis
+        using homotopic_Borsuk_maps_in_bounded_component [OF S]
+        by (simp add: L True assms connected_component_sym homotopic_Borsuk_maps_in_bounded_component homotopic_with_sym)
+    next
+      case False
+      then show ?thesis
+        using cobounded_unique_unbounded_component [of "-S" a b] \<open>compact S\<close> not_bo_a
+        by (auto simp: compact_eq_bounded_closed assms connected_component_eq_eq)
+    qed
+  qed
+next
+  assume R: ?rhs
+  then have "path_component (- S) a b"
+    using assms(1) compact_eq_bounded_closed open_Compl open_path_connected_component_set by fastforce
+  then show ?lhs
+    by (simp add: Borsuk_maps_homotopic_in_path_component)
+qed
+
+
 subsection\<open>The complement of a set and path-connectedness\<close>
 
 text\<open>Complement in dimension N > 1 of set homeomorphic to any interval in
diff -r 81a5473e6d04 -r a0e1f64be67c src/HOL/Analysis/Cauchy_Integral_Theorem.thy
--- a/src/HOL/Analysis/Cauchy_Integral_Theorem.thy	Thu Jan 05 22:37:52 2017 +0100
+++ b/src/HOL/Analysis/Cauchy_Integral_Theorem.thy	Thu Jan 05 22:38:06 2017 +0100
@@ -577,9 +577,6 @@
 
 subsection \<open>Valid paths, and their start and finish\<close>
 
-lemma Diff_Un_eq: "A - (B \<union> C) = A - B - C"
-  by blast
-
 definition valid_path :: "(real \<Rightarrow> 'a :: real_normed_vector) \<Rightarrow> bool"
   where "valid_path f \<equiv> f piecewise_C1_differentiable_on {0..1::real}"
 
diff -r 81a5473e6d04 -r a0e1f64be67c src/HOL/Analysis/Complex_Transcendental.thy
--- a/src/HOL/Analysis/Complex_Transcendental.thy	Thu Jan 05 22:37:52 2017 +0100
+++ b/src/HOL/Analysis/Complex_Transcendental.thy	Thu Jan 05 22:38:06 2017 +0100
@@ -3559,4 +3559,70 @@
   shows "S homotopy_eqv T \<Longrightarrow> simply_connected S \<longleftrightarrow> simply_connected T"
   by (simp add: simply_connected_eq_homotopic_circlemaps homotopy_eqv_homotopic_triviality)
 
+
+subsection\<open>Homeomorphism of simple closed curves to circles\<close>
+
+proposition homeomorphic_simple_path_image_circle:
+  fixes a :: complex and \<gamma> :: "real \<Rightarrow> 'a::t2_space"
+  assumes "simple_path \<gamma>" and loop: "pathfinish \<gamma> = pathstart \<gamma>" and "0 < r"
+  shows "(path_image \<gamma>) homeomorphic sphere a r"
+proof -
+  have "homotopic_loops (path_image \<gamma>) \<gamma> \<gamma>"
+    by (simp add: assms homotopic_loops_refl simple_path_imp_path)
+  then have hom: "homotopic_with (\<lambda>h. True) (sphere 0 1) (path_image \<gamma>)
+               (\<gamma> \<circ> (\<lambda>z. Arg z / (2*pi))) (\<gamma> \<circ> (\<lambda>z. Arg z / (2*pi)))"
+    by (rule homotopic_loops_imp_homotopic_circlemaps)
+  have "\<exists>g. homeomorphism (sphere 0 1) (path_image \<gamma>) (\<gamma> \<circ> (\<lambda>z. Arg z / (2*pi))) g"
+  proof (rule homeomorphism_compact)
+    show "continuous_on (sphere 0 1) (\<gamma> \<circ> (\<lambda>z. Arg z / (2*pi)))"
+      using hom homotopic_with_imp_continuous by blast
+    show "inj_on (\<gamma> \<circ> (\<lambda>z. Arg z / (2*pi))) (sphere 0 1)"
+    proof
+      fix x y
+      assume xy: "x \<in> sphere 0 1" "y \<in> sphere 0 1"
+         and eq: "(\<gamma> \<circ> (\<lambda>z. Arg z / (2*pi))) x = (\<gamma> \<circ> (\<lambda>z. Arg z / (2*pi))) y"
+      then have "(Arg x / (2*pi)) = (Arg y / (2*pi))"
+      proof -
+        have "(Arg x / (2*pi)) \<in> {0..1}" "(Arg y / (2*pi)) \<in> {0..1}"
+          using Arg_ge_0 Arg_lt_2pi dual_order.strict_iff_order by fastforce+
+        with eq show ?thesis
+          using \<open>simple_path \<gamma>\<close> Arg_lt_2pi unfolding simple_path_def o_def
+          by (metis eq_divide_eq_1 not_less_iff_gr_or_eq)
+      qed
+      with xy show "x = y"
+        by (metis Arg Arg_0 dist_0_norm divide_cancel_right dual_order.strict_iff_order mem_sphere)
+    qed
+    have "\<And>z. cmod z = 1 \<Longrightarrow> \<exists>x\<in>{0..1}. \<gamma> (Arg z / (2*pi)) = \<gamma> x"
+       by (metis Arg_ge_0 Arg_lt_2pi atLeastAtMost_iff divide_less_eq_1 less_eq_real_def zero_less_mult_iff pi_gt_zero zero_le_divide_iff zero_less_numeral)
+     moreover have "\<exists>z\<in>sphere 0 1. \<gamma> x = \<gamma> (Arg z / (2*pi))" if "0 \<le> x" "x \<le> 1" for x
+     proof (cases "x=1")
+       case True
+       then show ?thesis
+         apply (rule_tac x=1 in bexI)
+         apply (metis loop Arg_of_real divide_eq_0_iff of_real_1 pathfinish_def pathstart_def \<open>0 \<le> x\<close>, auto)
+         done
+     next
+       case False
+       then have *: "(Arg (exp (\<i>*(2* of_real pi* of_real x))) / (2*pi)) = x"
+         using that by (auto simp: Arg_exp divide_simps)
+       show ?thesis
+         by (rule_tac x="exp(ii* of_real(2*pi*x))" in bexI) (auto simp: *)
+    qed
+    ultimately show "(\<gamma> \<circ> (\<lambda>z. Arg z / (2*pi))) ` sphere 0 1 = path_image \<gamma>"
+      by (auto simp: path_image_def image_iff)
+    qed auto
+    then have "path_image \<gamma> homeomorphic sphere (0::complex) 1"
+      using homeomorphic_def homeomorphic_sym by blast
+  also have "... homeomorphic sphere a r"
+    by (simp add: assms homeomorphic_spheres)
+  finally show ?thesis .
+qed
+
+lemma homeomorphic_simple_path_images:
+  fixes \<gamma>1 :: "real \<Rightarrow> 'a::t2_space" and \<gamma>2 :: "real \<Rightarrow> 'b::t2_space"
+  assumes "simple_path \<gamma>1" and loop: "pathfinish \<gamma>1 = pathstart \<gamma>1"
+  assumes "simple_path \<gamma>2" and loop: "pathfinish \<gamma>2 = pathstart \<gamma>2"
+  shows "(path_image \<gamma>1) homeomorphic (path_image \<gamma>2)"
+  by (meson assms homeomorphic_simple_path_image_circle homeomorphic_sym homeomorphic_trans loop pi_gt_zero)
+
 end
diff -r 81a5473e6d04 -r a0e1f64be67c src/HOL/Analysis/Convex_Euclidean_Space.thy
--- a/src/HOL/Analysis/Convex_Euclidean_Space.thy	Thu Jan 05 22:37:52 2017 +0100
+++ b/src/HOL/Analysis/Convex_Euclidean_Space.thy	Thu Jan 05 22:38:06 2017 +0100
@@ -1314,21 +1314,6 @@
 lemma fst_snd_linear: "linear (\<lambda>(x,y). x + y)"
   unfolding linear_iff by (simp add: algebra_simps)
 
-lemma scaleR_2:
-  fixes x :: "'a::real_vector"
-  shows "scaleR 2 x = x + x"
-  unfolding one_add_one [symmetric] scaleR_left_distrib by simp
-
-lemma scaleR_half_double [simp]:
-  fixes a :: "'a::real_normed_vector"
-  shows "(1 / 2) *\<^sub>R (a + a) = a"
-proof -
-  have "\<And>r. r *\<^sub>R (a + a) = (r * 2) *\<^sub>R a"
-    by (metis scaleR_2 scaleR_scaleR)
-  then show ?thesis
-    by simp
-qed
-
 lemma vector_choose_size:
   assumes "0 \<le> c"
   obtains x :: "'a::{real_normed_vector, perfect_space}" where "norm x = c"
diff -r 81a5473e6d04 -r a0e1f64be67c src/HOL/Analysis/Further_Topology.thy
--- a/src/HOL/Analysis/Further_Topology.thy	Thu Jan 05 22:37:52 2017 +0100
+++ b/src/HOL/Analysis/Further_Topology.thy	Thu Jan 05 22:38:06 2017 +0100
@@ -1134,11 +1134,6 @@
 
 (*Up to extend_map_affine_to_sphere_cofinite_gen*)
 
-lemma closedin_closed_subset:
- "\<lbrakk>closedin (subtopology euclidean U) V; T \<subseteq> U; S = V \<inter> T\<rbrakk>
-             \<Longrightarrow> closedin (subtopology euclidean T) S"
-  by (metis (no_types, lifting) Int_assoc Int_commute closedin_closed inf.orderE)
-
 lemma extend_map_affine_to_sphere1:
   fixes f :: "'a::euclidean_space \<Rightarrow> 'b::topological_space"
   assumes "finite K" "affine U" and contf: "continuous_on (U - K) f"
@@ -2976,6 +2971,133 @@
     by (simp add: aff_dim_cball)
 qed
 
+lemma simply_connected_sphere_eq:
+  fixes a :: "'a::euclidean_space"
+  shows "simply_connected(sphere a r) \<longleftrightarrow> 3 \<le> DIM('a) \<or> r \<le> 0"  (is "?lhs = ?rhs")
+proof (cases "r \<le> 0")
+  case True
+  have "simply_connected (sphere a r)"
+    apply (rule convex_imp_simply_connected)
+    using True less_eq_real_def by auto
+  with True show ?thesis by auto
+next
+  case False
+  show ?thesis
+  proof
+    assume L: ?lhs
+    have "False" if "DIM('a) = 1 \<or> DIM('a) = 2"
+      using that
+    proof
+      assume "DIM('a) = 1"
+      with L show False
+        using connected_sphere_eq simply_connected_imp_connected
+        by (metis False Suc_1 not_less_eq_eq order_refl)
+    next
+      assume "DIM('a) = 2"
+      then have "sphere a r homeomorphic sphere (0::complex) 1"
+        by (metis DIM_complex False homeomorphic_spheres_gen not_less zero_less_one)
+      then have "simply_connected(sphere (0::complex) 1)"
+        using L homeomorphic_simply_connected_eq by blast
+      then obtain a::complex where "homotopic_with (\<lambda>h. True) (sphere 0 1) (sphere 0 1) id (\<lambda>x. a)"
+        apply (simp add: simply_connected_eq_contractible_circlemap)
+        by (metis continuous_on_id' id_apply image_id subset_refl)
+      then show False
+        using contractible_sphere contractible_def not_one_le_zero by blast
+    qed
+    with False show ?rhs
+      apply simp
+      by (metis DIM_ge_Suc0 le_antisym not_less_eq_eq numeral_2_eq_2 numeral_3_eq_3)
+  next
+    assume ?rhs
+    with False show ?lhs by (simp add: simply_connected_sphere)
+  qed
+qed
+
+
+lemma simply_connected_punctured_universe_eq:
+  fixes a :: "'a::euclidean_space"
+  shows "simply_connected(- {a}) \<longleftrightarrow> 3 \<le> DIM('a)"
+proof -
+  have [simp]: "a \<in> rel_interior (cball a 1)"
+    by (simp add: rel_interior_nonempty_interior)
+  have [simp]: "affine hull cball a 1 - {a} = -{a}"
+    by (metis Compl_eq_Diff_UNIV aff_dim_cball aff_dim_lt_full not_less_iff_gr_or_eq zero_less_one)
+  have "simply_connected(- {a}) \<longleftrightarrow> simply_connected(sphere a 1)"
+    apply (rule sym)
+    apply (rule homotopy_eqv_simple_connectedness)
+    using homotopy_eqv_rel_frontier_punctured_affine_hull [of "cball a 1" a] apply auto
+    done
+  also have "...  \<longleftrightarrow> 3 \<le> DIM('a)"
+    by (simp add: simply_connected_sphere_eq)
+  finally show ?thesis .
+qed
+
+lemma not_simply_connected_circle:
+  fixes a :: complex
+  shows "0 < r \<Longrightarrow> \<not> simply_connected(sphere a r)"
+by (simp add: simply_connected_sphere_eq)
+
+  
+proposition simply_connected_punctured_convex:
+  fixes a :: "'a::euclidean_space"
+  assumes "convex S" and 3: "3 \<le> aff_dim S"
+    shows "simply_connected(S - {a})"
+proof (cases "a \<in> rel_interior S")
+  case True
+  then obtain e where "a \<in> S" "0 < e" and e: "cball a e \<inter> affine hull S \<subseteq> S"
+    by (auto simp: rel_interior_cball)
+  have con: "convex (cball a e \<inter> affine hull S)"
+    by (simp add: convex_Int)
+  have bo: "bounded (cball a e \<inter> affine hull S)"
+    by (simp add: bounded_Int)
+  have "affine hull S \<inter> interior (cball a e) \<noteq> {}"
+    using \<open>0 < e\<close> \<open>a \<in> S\<close> hull_subset by fastforce
+  then have "3 \<le> aff_dim (affine hull S \<inter> cball a e)"
+    by (simp add: 3 aff_dim_convex_Int_nonempty_interior [OF convex_affine_hull])
+  also have "... = aff_dim (cball a e \<inter> affine hull S)"
+    by (simp add: Int_commute)
+  finally have "3 \<le> aff_dim (cball a e \<inter> affine hull S)" .
+  moreover have "rel_frontier (cball a e \<inter> affine hull S) homotopy_eqv S - {a}"
+  proof (rule homotopy_eqv_rel_frontier_punctured_convex)
+    show "a \<in> rel_interior (cball a e \<inter> affine hull S)"
+      by (meson IntI Int_mono \<open>a \<in> S\<close> \<open>0 < e\<close> e \<open>cball a e \<inter> affine hull S \<subseteq> S\<close> ball_subset_cball centre_in_cball dual_order.strict_implies_order hull_inc hull_mono mem_rel_interior_ball)
+    have "closed (cball a e \<inter> affine hull S)"
+      by blast
+    then show "rel_frontier (cball a e \<inter> affine hull S) \<subseteq> S"
+      apply (simp add: rel_frontier_def)
+      using e by blast
+    show "S \<subseteq> affine hull (cball a e \<inter> affine hull S)"
+      by (metis (no_types, lifting) IntI \<open>a \<in> S\<close> \<open>0 < e\<close> affine_hull_convex_Int_nonempty_interior centre_in_ball convex_affine_hull empty_iff hull_subset inf_commute interior_cball subsetCE subsetI)
+    qed (auto simp: assms con bo)
+  ultimately show ?thesis
+    using homotopy_eqv_simple_connectedness simply_connected_sphere_gen [OF con bo]
+    by blast
+next
+  case False
+  show ?thesis
+    apply (rule contractible_imp_simply_connected)
+    apply (rule contractible_convex_tweak_boundary_points [OF \<open>convex S\<close>])
+     apply (simp add: False rel_interior_subset subset_Diff_insert)
+    by (meson Diff_subset closure_subset subset_trans)
+qed
+
+corollary simply_connected_punctured_universe:
+  fixes a :: "'a::euclidean_space"
+  assumes "3 \<le> DIM('a)"
+  shows "simply_connected(- {a})"
+proof -
+  have [simp]: "affine hull cball a 1 = UNIV"
+    apply auto
+    by (metis UNIV_I aff_dim_cball aff_dim_lt_full zero_less_one not_less_iff_gr_or_eq)
+  have "simply_connected (rel_frontier (cball a 1)) = simply_connected (affine hull cball a 1 - {a})"
+    apply (rule homotopy_eqv_simple_connectedness)
+    apply (rule homotopy_eqv_rel_frontier_punctured_affine_hull)
+      apply (force simp: rel_interior_cball intro: homotopy_eqv_simple_connectedness homotopy_eqv_rel_frontier_punctured_affine_hull)+
+    done
+  then show ?thesis
+    using simply_connected_sphere [of a 1, OF assms] by (auto simp: Compl_eq_Diff_UNIV)
+qed
+
 
 subsection\<open>The power, squaring and exponential functions as covering maps\<close>
 
diff -r 81a5473e6d04 -r a0e1f64be67c src/HOL/Analysis/Homeomorphism.thy
--- a/src/HOL/Analysis/Homeomorphism.thy	Thu Jan 05 22:37:52 2017 +0100
+++ b/src/HOL/Analysis/Homeomorphism.thy	Thu Jan 05 22:38:06 2017 +0100
@@ -8,6 +8,34 @@
 imports Path_Connected
 begin
 
+lemma homeomorphic_spheres':
+  fixes a ::"'a::euclidean_space" and b ::"'b::euclidean_space"
+  assumes "0 < \<delta>" and dimeq: "DIM('a) = DIM('b)"
+  shows "(sphere a \<delta>) homeomorphic (sphere b \<delta>)"
+proof -
+  obtain f :: "'a\<Rightarrow>'b" and g where "linear f" "linear g"
+     and fg: "\<And>x. norm(f x) = norm x" "\<And>y. norm(g y) = norm y" "\<And>x. g(f x) = x" "\<And>y. f(g y) = y"
+    by (blast intro: isomorphisms_UNIV_UNIV [OF dimeq])
+  then have "continuous_on UNIV f" "continuous_on UNIV g"
+    using linear_continuous_on linear_linear by blast+
+  then show ?thesis
+    unfolding homeomorphic_minimal
+    apply(rule_tac x="\<lambda>x. b + f(x - a)" in exI)
+    apply(rule_tac x="\<lambda>x. a + g(x - b)" in exI)
+    using assms
+    apply (force intro: continuous_intros
+                  continuous_on_compose2 [of _ f] continuous_on_compose2 [of _ g] simp: dist_commute dist_norm fg)
+    done
+qed
+
+lemma homeomorphic_spheres_gen:
+    fixes a :: "'a::euclidean_space" and b :: "'b::euclidean_space"
+  assumes "0 < r" "0 < s" "DIM('a::euclidean_space) = DIM('b::euclidean_space)"
+  shows "(sphere a r homeomorphic sphere b s)"
+  apply (rule homeomorphic_trans [OF homeomorphic_spheres homeomorphic_spheres'])
+  using assms  apply auto
+  done
+
 subsection \<open>Homeomorphism of all convex compact sets with nonempty interior\<close>
 
 proposition ray_to_rel_frontier:
@@ -1360,4 +1388,1036 @@
    shows "g1 x = g2 x"
 using covering_space_lift_unique_gen [of c p S] in_components_self assms ex_in_conv by blast
 
+lemma covering_space_locally:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+  assumes loc: "locally \<phi> C" and cov: "covering_space C p S"
+      and pim: "\<And>T. \<lbrakk>T \<subseteq> C; \<phi> T\<rbrakk> \<Longrightarrow> \<psi>(p ` T)"
+    shows "locally \<psi> S"
+proof -
+  have "locally \<psi> (p ` C)"
+    apply (rule locally_open_map_image [OF loc])
+    using cov covering_space_imp_continuous apply blast
+    using cov covering_space_imp_surjective covering_space_open_map apply blast
+    by (simp add: pim)
+  then show ?thesis
+    using covering_space_imp_surjective [OF cov] by metis
+qed
+
+
+proposition covering_space_locally_eq:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+  assumes cov: "covering_space C p S"
+      and pim: "\<And>T. \<lbrakk>T \<subseteq> C; \<phi> T\<rbrakk> \<Longrightarrow> \<psi>(p ` T)"
+      and qim: "\<And>q U. \<lbrakk>U \<subseteq> S; continuous_on U q; \<psi> U\<rbrakk> \<Longrightarrow> \<phi>(q ` U)"
+    shows "locally \<psi> S \<longleftrightarrow> locally \<phi> C"
+         (is "?lhs = ?rhs")
+proof
+  assume L: ?lhs
+  show ?rhs
+  proof (rule locallyI)
+    fix V x
+    assume V: "openin (subtopology euclidean C) V" and "x \<in> V"
+    have "p x \<in> p ` C"
+      by (metis IntE V \<open>x \<in> V\<close> imageI openin_open)
+    then obtain T \<V> where "p x \<in> T"
+                      and opeT: "openin (subtopology euclidean S) T"
+                      and veq: "\<Union>\<V> = {x \<in> C. p x \<in> T}"
+                      and ope: "\<forall>U\<in>\<V>. openin (subtopology euclidean C) U"
+                      and hom: "\<forall>U\<in>\<V>. \<exists>q. homeomorphism U T p q"
+      using cov unfolding covering_space_def by (blast intro: that)
+    have "x \<in> \<Union>\<V>"
+      using V veq \<open>p x \<in> T\<close> \<open>x \<in> V\<close> openin_imp_subset by fastforce
+    then obtain U where "x \<in> U" "U \<in> \<V>"
+      by blast
+    then obtain q where opeU: "openin (subtopology euclidean C) U" and q: "homeomorphism U T p q"
+      using ope hom by blast
+    with V have "openin (subtopology euclidean C) (U \<inter> V)"
+      by blast
+    then have UV: "openin (subtopology euclidean S) (p ` (U \<inter> V))"
+      using cov covering_space_open_map by blast
+    obtain W W' where opeW: "openin (subtopology euclidean S) W" and "\<psi> W'" "p x \<in> W" "W \<subseteq> W'" and W'sub: "W' \<subseteq> p ` (U \<inter> V)"
+      using locallyE [OF L UV] \<open>x \<in> U\<close> \<open>x \<in> V\<close> by blast
+    then have "W \<subseteq> T"
+      by (metis Int_lower1 q homeomorphism_image1 image_Int_subset order_trans)
+    show "\<exists>U Z. openin (subtopology euclidean C) U \<and>
+                 \<phi> Z \<and> x \<in> U \<and> U \<subseteq> Z \<and> Z \<subseteq> V"
+    proof (intro exI conjI)
+      have "openin (subtopology euclidean T) W"
+        by (meson opeW opeT openin_imp_subset openin_subset_trans \<open>W \<subseteq> T\<close>)
+      then have "openin (subtopology euclidean U) (q ` W)"
+        by (meson homeomorphism_imp_open_map homeomorphism_symD q)
+      then show "openin (subtopology euclidean C) (q ` W)"
+        using opeU openin_trans by blast
+      show "\<phi> (q ` W')"
+        by (metis (mono_tags, lifting) Int_subset_iff UV W'sub \<open>\<psi> W'\<close> continuous_on_subset dual_order.trans homeomorphism_def image_Int_subset openin_imp_subset q qim)
+      show "x \<in> q ` W"
+        by (metis \<open>p x \<in> W\<close> \<open>x \<in> U\<close> homeomorphism_def imageI q)
+      show "q ` W \<subseteq> q ` W'"
+        using \<open>W \<subseteq> W'\<close> by blast
+      have "W' \<subseteq> p ` V"
+        using W'sub by blast
+      then show "q ` W' \<subseteq> V"
+        using W'sub homeomorphism_apply1 [OF q] by auto
+      qed
+  qed
+next
+  assume ?rhs
+  then show ?lhs
+    using cov covering_space_locally pim by blast
+qed
+
+lemma covering_space_locally_compact_eq:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+  assumes "covering_space C p S"
+  shows "locally compact S \<longleftrightarrow> locally compact C"
+  apply (rule covering_space_locally_eq [OF assms])
+   apply (meson assms compact_continuous_image continuous_on_subset covering_space_imp_continuous)
+  using compact_continuous_image by blast
+
+lemma covering_space_locally_connected_eq:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+  assumes "covering_space C p S"
+    shows "locally connected S \<longleftrightarrow> locally connected C"
+  apply (rule covering_space_locally_eq [OF assms])
+   apply (meson connected_continuous_image assms continuous_on_subset covering_space_imp_continuous)
+  using connected_continuous_image by blast
+
+lemma covering_space_locally_path_connected_eq:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+  assumes "covering_space C p S"
+    shows "locally path_connected S \<longleftrightarrow> locally path_connected C"
+  apply (rule covering_space_locally_eq [OF assms])
+   apply (meson path_connected_continuous_image assms continuous_on_subset covering_space_imp_continuous)
+  using path_connected_continuous_image by blast
+
+
+lemma covering_space_locally_compact:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+  assumes "locally compact C" "covering_space C p S"
+  shows "locally compact S"
+  using assms covering_space_locally_compact_eq by blast
+
+
+lemma covering_space_locally_connected:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+  assumes "locally connected C" "covering_space C p S"
+  shows "locally connected S"
+  using assms covering_space_locally_connected_eq by blast
+
+lemma covering_space_locally_path_connected:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+  assumes "locally path_connected C" "covering_space C p S"
+  shows "locally path_connected S"
+  using assms covering_space_locally_path_connected_eq by blast
+
+proposition covering_space_lift_homotopy:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+    and h :: "real \<times> 'c::real_normed_vector \<Rightarrow> 'b"
+  assumes cov: "covering_space C p S"
+      and conth: "continuous_on ({0..1} \<times> U) h"
+      and him: "h ` ({0..1} \<times> U) \<subseteq> S"
+      and heq: "\<And>y. y \<in> U \<Longrightarrow> h (0,y) = p(f y)"
+      and contf: "continuous_on U f" and fim: "f ` U \<subseteq> C"
+    obtains k where "continuous_on ({0..1} \<times> U) k"
+                    "k ` ({0..1} \<times> U) \<subseteq> C"
+                    "\<And>y. y \<in> U \<Longrightarrow> k(0, y) = f y"
+                    "\<And>z. z \<in> {0..1} \<times> U \<Longrightarrow> h z = p(k z)"
+proof -
+  have "\<exists>V k. openin (subtopology euclidean U) V \<and> y \<in> V \<and>
+              continuous_on ({0..1} \<times> V) k \<and> k ` ({0..1} \<times> V) \<subseteq> C \<and>
+              (\<forall>z \<in> V. k(0, z) = f z) \<and> (\<forall>z \<in> {0..1} \<times> V. h z = p(k z))"
+        if "y \<in> U" for y
+  proof -
+    obtain UU where UU: "\<And>s. s \<in> S \<Longrightarrow> s \<in> (UU s) \<and> openin (subtopology euclidean S) (UU s) \<and>
+                                        (\<exists>\<V>. \<Union>\<V> = {x. x \<in> C \<and> p x \<in> (UU s)} \<and>
+                                            (\<forall>U \<in> \<V>. openin (subtopology euclidean C) U) \<and>
+                                            pairwise disjnt \<V> \<and>
+                                            (\<forall>U \<in> \<V>. \<exists>q. homeomorphism U (UU s) p q))"
+      using cov unfolding covering_space_def by (metis (mono_tags))
+    then have ope: "\<And>s. s \<in> S \<Longrightarrow> s \<in> (UU s) \<and> openin (subtopology euclidean S) (UU s)"
+      by blast
+    have "\<exists>k n i. open k \<and> open n \<and>
+                  t \<in> k \<and> y \<in> n \<and> i \<in> S \<and> h ` (({0..1} \<inter> k) \<times> (U \<inter> n)) \<subseteq> UU i" if "t \<in> {0..1}" for t
+    proof -
+      have hinS: "h (t, y) \<in> S"
+        using \<open>y \<in> U\<close> him that by blast
+      then have "(t,y) \<in> {z \<in> {0..1} \<times> U. h z \<in> UU (h (t, y))}"
+        using \<open>y \<in> U\<close> \<open>t \<in> {0..1}\<close>  by (auto simp: ope)
+      moreover have ope_01U: "openin (subtopology euclidean ({0..1} \<times> U)) {z. z \<in> ({0..1} \<times> U) \<and> h z \<in> UU(h(t, y))}"
+        using hinS ope continuous_on_open_gen [OF him] conth by blast
+      ultimately obtain V W where opeV: "open V" and "t \<in> {0..1} \<inter> V" "t \<in> {0..1} \<inter> V"
+                              and opeW: "open W" and "y \<in> U" "y \<in> W"
+                              and VW: "({0..1} \<inter> V) \<times> (U \<inter> W)  \<subseteq> {z. z \<in> ({0..1} \<times> U) \<and> h z \<in> UU(h(t, y))}"
+        by (rule Times_in_interior_subtopology) (auto simp: openin_open)
+      then show ?thesis
+        using hinS by blast
+    qed
+    then obtain K NN X where
+              K: "\<And>t. t \<in> {0..1} \<Longrightarrow> open (K t)"
+          and NN: "\<And>t. t \<in> {0..1} \<Longrightarrow> open (NN t)"
+          and inUS: "\<And>t. t \<in> {0..1} \<Longrightarrow> t \<in> K t \<and> y \<in> NN t \<and> X t \<in> S"
+          and him: "\<And>t. t \<in> {0..1} \<Longrightarrow> h ` (({0..1} \<inter> K t) \<times> (U \<inter> NN t)) \<subseteq> UU (X t)"
+    by (metis (mono_tags))
+    obtain \<T> where "\<T> \<subseteq> ((\<lambda>i. K i \<times> NN i)) ` {0..1}" "finite \<T>" "{0::real..1} \<times> {y} \<subseteq> \<Union>\<T>"
+    proof (rule compactE)
+      show "compact ({0::real..1} \<times> {y})"
+        by (simp add: compact_Times)
+      show "{0..1} \<times> {y} \<subseteq> (\<Union>i\<in>{0..1}. K i \<times> NN i)"
+        using K inUS by auto
+      show "\<And>B. B \<in> (\<lambda>i. K i \<times> NN i) ` {0..1} \<Longrightarrow> open B"
+        using K NN by (auto simp: open_Times)
+    qed blast
+    then obtain tk where "tk \<subseteq> {0..1}" "finite tk"
+                     and tk: "{0::real..1} \<times> {y} \<subseteq> (\<Union>i \<in> tk. K i \<times> NN i)"
+      by (metis (no_types, lifting) finite_subset_image)
+    then have "tk \<noteq> {}"
+      by auto
+    define n where "n = INTER tk NN"
+    have "y \<in> n" "open n"
+      using inUS NN \<open>tk \<subseteq> {0..1}\<close> \<open>finite tk\<close>
+      by (auto simp: n_def open_INT subset_iff)
+    obtain \<delta> where "0 < \<delta>" and \<delta>: "\<And>T. \<lbrakk>T \<subseteq> {0..1}; diameter T < \<delta>\<rbrakk> \<Longrightarrow> \<exists>B\<in>K ` tk. T \<subseteq> B"
+    proof (rule Lebesgue_number_lemma [of "{0..1}" "K ` tk"])
+      show "K ` tk \<noteq> {}"
+        using \<open>tk \<noteq> {}\<close> by auto
+      show "{0..1} \<subseteq> UNION tk K"
+        using tk by auto
+      show "\<And>B. B \<in> K ` tk \<Longrightarrow> open B"
+        using \<open>tk \<subseteq> {0..1}\<close> K by auto
+    qed auto
+    obtain N::nat where N: "N > 1 / \<delta>"
+      using reals_Archimedean2 by blast
+    then have "N > 0"
+      using \<open>0 < \<delta>\<close> order.asym by force
+    have *: "\<exists>V k. openin (subtopology euclidean U) V \<and> y \<in> V \<and>
+                   continuous_on ({0..of_nat n / N} \<times> V) k \<and>
+                   k ` ({0..of_nat n / N} \<times> V) \<subseteq> C \<and>
+                   (\<forall>z\<in>V. k (0, z) = f z) \<and>
+                   (\<forall>z\<in>{0..of_nat n / N} \<times> V. h z = p (k z))" if "n \<le> N" for n
+      using that
+    proof (induction n)
+      case 0
+      show ?case
+        apply (rule_tac x=U in exI)
+        apply (rule_tac x="f \<circ> snd" in exI)
+        apply (intro conjI \<open>y \<in> U\<close> continuous_intros continuous_on_subset [OF contf])
+        using fim  apply (auto simp: heq)
+        done
+    next
+      case (Suc n)
+      then obtain V k where opeUV: "openin (subtopology euclidean U) V"
+                        and "y \<in> V"
+                        and contk: "continuous_on ({0..real n / real N} \<times> V) k"
+                        and kim: "k ` ({0..real n / real N} \<times> V) \<subseteq> C"
+                        and keq: "\<And>z. z \<in> V \<Longrightarrow> k (0, z) = f z"
+                        and heq: "\<And>z. z \<in> {0..real n / real N} \<times> V \<Longrightarrow> h z = p (k z)"
+        using Suc_leD by auto
+      have "n \<le> N"
+        using Suc.prems by auto
+      obtain t where "t \<in> tk" and t: "{real n / real N .. (1 + real n) / real N} \<subseteq> K t"
+      proof (rule bexE [OF \<delta>])
+        show "{real n / real N .. (1 + real n) / real N} \<subseteq> {0..1}"
+          using Suc.prems by (auto simp: divide_simps algebra_simps)
+        show diameter_less: "diameter {real n / real N .. (1 + real n) / real N} < \<delta>"
+          using \<open>0 < \<delta>\<close> N by (auto simp: divide_simps algebra_simps)
+      qed blast
+      have t01: "t \<in> {0..1}"
+        using \<open>t \<in> tk\<close> \<open>tk \<subseteq> {0..1}\<close> by blast
+      obtain \<V> where "\<Union>\<V> = {x. x \<in> C \<and> p x \<in> (UU (X t))}"
+                 and opeC: "\<And>U. U \<in> \<V> \<Longrightarrow> openin (subtopology euclidean C) U"
+                 and "pairwise disjnt \<V>"
+                 and homuu: "\<And>U. U \<in> \<V> \<Longrightarrow> \<exists>q. homeomorphism U (UU (X t)) p q"
+        using inUS [OF t01] UU by meson
+      have n_div_N_in: "real n / real N \<in> {real n / real N .. (1 + real n) / real N}"
+        using N by (auto simp: divide_simps algebra_simps)
+      with t have nN_in_kkt: "real n / real N \<in> K t"
+        by blast
+      have "k (real n / real N, y) \<in> {x. x \<in> C \<and> p x \<in> (UU (X t))}"
+      proof (simp, rule conjI)
+        show "k (real n / real N, y) \<in> C"
+          using \<open>y \<in> V\<close> kim keq by force
+        have "p (k (real n / real N, y)) = h (real n / real N, y)"
+          by (simp add: \<open>y \<in> V\<close> heq)
+        also have "... \<in> h ` (({0..1} \<inter> K t) \<times> (U \<inter> NN t))"
+          apply (rule imageI)
+           using \<open>y \<in> V\<close> t01 \<open>n \<le> N\<close>
+          apply (simp add: nN_in_kkt \<open>y \<in> U\<close> inUS divide_simps)
+          done
+        also have "... \<subseteq> UU (X t)"
+          using him t01 by blast
+        finally show "p (k (real n / real N, y)) \<in> UU (X t)" .
+      qed
+      then have "k (real n / real N, y) \<in> \<Union>\<V>"
+        using \<open>\<Union>\<V> = {x \<in> C. p x \<in> UU (X t)}\<close> by blast
+      then obtain W where W: "k (real n / real N, y) \<in> W" and "W \<in> \<V>"
+        by blast
+      then obtain p' where opeC': "openin (subtopology euclidean C) W"
+                       and hom': "homeomorphism W (UU (X t)) p p'"
+        using homuu opeC by blast
+      then have "W \<subseteq> C"
+        using openin_imp_subset by blast
+      define W' where "W' = UU(X t)"
+      have opeVW: "openin (subtopology euclidean V) {z \<in> V. (k \<circ> Pair (real n / real N)) z \<in> W}"
+        apply (rule continuous_openin_preimage [OF _ _ opeC'])
+         apply (intro continuous_intros continuous_on_subset [OF contk])
+        using kim apply (auto simp: \<open>y \<in> V\<close> W)
+        done
+      obtain N' where opeUN': "openin (subtopology euclidean U) N'"
+                  and "y \<in> N'" and kimw: "k ` ({(real n / real N)} \<times> N') \<subseteq> W"
+        apply (rule_tac N' = "{z \<in> V. (k \<circ> Pair ((real n / real N))) z \<in> W}" in that)
+        apply (fastforce simp:  \<open>y \<in> V\<close> W intro!: openin_trans [OF opeVW opeUV])+
+        done
+      obtain Q Q' where opeUQ: "openin (subtopology euclidean U) Q"
+                    and cloUQ': "closedin (subtopology euclidean U) Q'"
+                    and "y \<in> Q" "Q \<subseteq> Q'"
+                    and Q': "Q' \<subseteq> (U \<inter> NN(t)) \<inter> N' \<inter> V"
+      proof -
+        obtain VO VX where "open VO" "open VX" and VO: "V = U \<inter> VO" and VX: "N' = U \<inter> VX"
+          using opeUV opeUN' by (auto simp: openin_open)
+        then have "open (NN(t) \<inter> VO \<inter> VX)"
+          using NN t01 by blast
+        then obtain e where "e > 0" and e: "cball y e \<subseteq> NN(t) \<inter> VO \<inter> VX"
+          by (metis Int_iff \<open>N' = U \<inter> VX\<close> \<open>V = U \<inter> VO\<close> \<open>y \<in> N'\<close> \<open>y \<in> V\<close> inUS open_contains_cball t01)
+        show ?thesis
+        proof
+          show "openin (subtopology euclidean U) (U \<inter> ball y e)"
+            by blast
+          show "closedin (subtopology euclidean U) (U \<inter> cball y e)"
+            using e by (auto simp: closedin_closed)
+        qed (use \<open>y \<in> U\<close> \<open>e > 0\<close> VO VX e in auto)
+      qed
+      then have "y \<in> Q'" "Q \<subseteq> (U \<inter> NN(t)) \<inter> N' \<inter> V"
+        by blast+
+      have neq: "{0..real n / real N} \<union> {real n / real N..(1 + real n) / real N} = {0..(1 + real n) / real N}"
+        apply (auto simp: divide_simps)
+        by (metis mult_zero_left of_nat_0_le_iff of_nat_0_less_iff order_trans real_mult_le_cancel_iff1)
+      then have neqQ': "{0..real n / real N} \<times> Q' \<union> {real n / real N..(1 + real n) / real N} \<times> Q' = {0..(1 + real n) / real N} \<times> Q'"
+        by blast
+      have cont: "continuous_on ({0..(1 + real n) / real N} \<times> Q')
+        (\<lambda>x. if x \<in> {0..real n / real N} \<times> Q' then k x else (p' \<circ> h) x)"
+        unfolding neqQ' [symmetric]
+      proof (rule continuous_on_cases_local, simp_all add: neqQ' del: comp_apply)
+        show "closedin (subtopology euclidean ({0..(1 + real n) / real N} \<times> Q'))
+                       ({0..real n / real N} \<times> Q')"
+          apply (simp add: closedin_closed)
+          apply (rule_tac x="{0 .. real n / real N} \<times> UNIV" in exI)
+          using n_div_N_in apply (auto simp: closed_Times)
+          done
+        show "closedin (subtopology euclidean ({0..(1 + real n) / real N} \<times> Q'))
+                       ({real n / real N..(1 + real n) / real N} \<times> Q')"
+          apply (simp add: closedin_closed)
+          apply (rule_tac x="{real n / real N .. (1 + real n) / real N} \<times> UNIV" in exI)
+          apply (auto simp: closed_Times)
+          by (meson divide_nonneg_nonneg of_nat_0_le_iff order_trans)
+        show "continuous_on ({0..real n / real N} \<times> Q') k"
+          apply (rule continuous_on_subset [OF contk])
+          using Q' by auto
+        have "continuous_on ({real n / real N..(1 + real n) / real N} \<times> Q') h"
+        proof (rule continuous_on_subset [OF conth])
+          show "{real n / real N..(1 + real n) / real N} \<times> Q' \<subseteq> {0..1} \<times> U"
+            using \<open>N > 0\<close>
+            apply auto
+              apply (meson divide_nonneg_nonneg of_nat_0_le_iff order_trans)
+            using Suc.prems order_trans apply fastforce
+            apply (metis IntE  cloUQ' closedin_closed)
+            done
+        qed
+        moreover have "continuous_on (h ` ({real n / real N..(1 + real n) / real N} \<times> Q')) p'"
+        proof (rule continuous_on_subset [OF homeomorphism_cont2 [OF hom']])
+          have "h ` ({real n / real N..(1 + real n) / real N} \<times> Q') \<subseteq> h ` (({0..1} \<inter> K t) \<times> (U \<inter> NN t))"
+            apply (rule image_mono)
+            using \<open>0 < \<delta>\<close> \<open>N > 0\<close> Suc.prems apply auto
+              apply (meson divide_nonneg_nonneg of_nat_0_le_iff order_trans)
+            using Suc.prems order_trans apply fastforce
+            using t Q' apply auto
+            done
+          with him show "h ` ({real n / real N..(1 + real n) / real N} \<times> Q') \<subseteq> UU (X t)"
+            using t01 by blast
+        qed
+        ultimately show "continuous_on ({real n / real N..(1 + real n) / real N} \<times> Q') (p' \<circ> h)"
+          by (rule continuous_on_compose)
+        have "k (real n / real N, b) = p' (h (real n / real N, b))" if "b \<in> Q'" for b
+        proof -
+          have "k (real n / real N, b) \<in> W"
+            using that Q' kimw  by force
+          then have "k (real n / real N, b) = p' (p (k (real n / real N, b)))"
+            by (simp add:  homeomorphism_apply1 [OF hom'])
+          then show ?thesis
+            using Q' that by (force simp: heq)
+        qed
+        then show "\<And>x. x \<in> {real n / real N..(1 + real n) / real N} \<times> Q' \<and>
+                  x \<in> {0..real n / real N} \<times> Q' \<Longrightarrow> k x = (p' \<circ> h) x"
+          by auto
+      qed
+      have h_in_UU: "h (x, y) \<in> UU (X t)" if "y \<in> Q" "\<not> x \<le> real n / real N" "0 \<le> x" "x \<le> (1 + real n) / real N" for x y
+      proof -
+        have "x \<le> 1"
+          using Suc.prems that order_trans by force
+        moreover have "x \<in> K t"
+          by (meson atLeastAtMost_iff le_less not_le subset_eq t that)
+        moreover have "y \<in> U"
+          using \<open>y \<in> Q\<close> opeUQ openin_imp_subset by blast
+        moreover have "y \<in> NN t"
+          using Q' \<open>Q \<subseteq> Q'\<close> \<open>y \<in> Q\<close> by auto
+        ultimately have "(x, y) \<in> (({0..1} \<inter> K t) \<times> (U \<inter> NN t))"
+          using that by auto
+        then have "h (x, y) \<in> h ` (({0..1} \<inter> K t) \<times> (U \<inter> NN t))"
+          by blast
+        also have "... \<subseteq> UU (X t)"
+          by (metis him t01)
+        finally show ?thesis .
+      qed
+      let ?k = "(\<lambda>x. if x \<in> {0..real n / real N} \<times> Q' then k x else (p' \<circ> h) x)"
+      show ?case
+      proof (intro exI conjI)
+        show "continuous_on ({0..real (Suc n) / real N} \<times> Q) ?k"
+          apply (rule continuous_on_subset [OF cont])
+          using \<open>Q \<subseteq> Q'\<close> by auto
+        have "\<And>a b. \<lbrakk>a \<le> real n / real N; b \<in> Q'; 0 \<le> a\<rbrakk> \<Longrightarrow> k (a, b) \<in> C"
+          using kim Q' by force
+        moreover have "\<And>a b. \<lbrakk>b \<in> Q; 0 \<le> a; a \<le> (1 + real n) / real N; \<not> a \<le> real n / real N\<rbrakk> \<Longrightarrow> p' (h (a, b)) \<in> C"
+          apply (rule \<open>W \<subseteq> C\<close> [THEN subsetD])
+          using homeomorphism_image2 [OF hom', symmetric]  h_in_UU  Q' \<open>Q \<subseteq> Q'\<close> \<open>W \<subseteq> C\<close>
+          apply auto
+          done
+        ultimately show "?k ` ({0..real (Suc n) / real N} \<times> Q) \<subseteq> C"
+          using Q' \<open>Q \<subseteq> Q'\<close> by force
+        show "\<forall>z\<in>Q. ?k (0, z) = f z"
+          using Q' keq  \<open>Q \<subseteq> Q'\<close> by auto
+        show "\<forall>z \<in> {0..real (Suc n) / real N} \<times> Q. h z = p(?k z)"
+          using \<open>Q \<subseteq> U \<inter> NN t \<inter> N' \<inter> V\<close> heq apply clarsimp
+          using h_in_UU Q' \<open>Q \<subseteq> Q'\<close> apply (auto simp: homeomorphism_apply2 [OF hom', symmetric])
+          done
+        qed (auto simp: \<open>y \<in> Q\<close> opeUQ)
+    qed
+    show ?thesis
+      using*[OF order_refl] N \<open>0 < \<delta>\<close> by (simp add: split: if_split_asm)
+  qed
+  then obtain V fs where opeV: "\<And>y. y \<in> U \<Longrightarrow> openin (subtopology euclidean U) (V y)"
+          and V: "\<And>y. y \<in> U \<Longrightarrow> y \<in> V y"
+          and contfs: "\<And>y. y \<in> U \<Longrightarrow> continuous_on ({0..1} \<times> V y) (fs y)"
+          and *: "\<And>y. y \<in> U \<Longrightarrow> (fs y) ` ({0..1} \<times> V y) \<subseteq> C \<and>
+                            (\<forall>z \<in> V y. fs y (0, z) = f z) \<and>
+                            (\<forall>z \<in> {0..1} \<times> V y. h z = p(fs y z))"
+    by (metis (mono_tags))
+  then have VU: "\<And>y. y \<in> U \<Longrightarrow> V y \<subseteq> U"
+    by (meson openin_imp_subset)
+  obtain k where contk: "continuous_on ({0..1} \<times> U) k"
+             and k: "\<And>x i. \<lbrakk>i \<in> U; x \<in> {0..1} \<times> U \<inter> {0..1} \<times> V i\<rbrakk> \<Longrightarrow> k x = fs i x"
+  proof (rule pasting_lemma_exists)
+    show "{0..1} \<times> U \<subseteq> (\<Union>i\<in>U. {0..1} \<times> V i)"
+      apply auto
+      using V by blast
+    show "\<And>i. i \<in> U \<Longrightarrow> openin (subtopology euclidean ({0..1} \<times> U)) ({0..1} \<times> V i)"
+      by (simp add: opeV openin_Times)
+    show "\<And>i. i \<in> U \<Longrightarrow> continuous_on ({0..1} \<times> V i) (fs i)"
+      using contfs by blast
+    show "fs i x = fs j x"  if "i \<in> U" "j \<in> U" and x: "x \<in> {0..1} \<times> U \<inter> {0..1} \<times> V i \<inter> {0..1} \<times> V j"
+         for i j x
+    proof -
+      obtain u y where "x = (u, y)" "y \<in> V i" "y \<in> V j" "0 \<le> u" "u \<le> 1"
+        using x by auto
+      show ?thesis
+      proof (rule covering_space_lift_unique [OF cov, of _ "(0,y)" _ "{0..1} \<times> {y}" h])
+        show "fs i (0, y) = fs j (0, y)"
+          using*V by (simp add: \<open>y \<in> V i\<close> \<open>y \<in> V j\<close> that)
+        show conth_y: "continuous_on ({0..1} \<times> {y}) h"
+          apply (rule continuous_on_subset [OF conth])
+          using VU \<open>y \<in> V j\<close> that by auto
+        show "h ` ({0..1} \<times> {y}) \<subseteq> S"
+          using \<open>y \<in> V i\<close> assms(3) VU that by fastforce
+        show "continuous_on ({0..1} \<times> {y}) (fs i)"
+          using continuous_on_subset [OF contfs] \<open>i \<in> U\<close>
+          by (simp add: \<open>y \<in> V i\<close> subset_iff)
+        show "fs i ` ({0..1} \<times> {y}) \<subseteq> C"
+          using "*" \<open>y \<in> V i\<close> \<open>i \<in> U\<close> by fastforce
+        show "\<And>x. x \<in> {0..1} \<times> {y} \<Longrightarrow> h x = p (fs i x)"
+          using "*" \<open>y \<in> V i\<close> \<open>i \<in> U\<close> by blast
+        show "continuous_on ({0..1} \<times> {y}) (fs j)"
+          using continuous_on_subset [OF contfs] \<open>j \<in> U\<close>
+          by (simp add: \<open>y \<in> V j\<close> subset_iff)
+        show "fs j ` ({0..1} \<times> {y}) \<subseteq> C"
+          using "*" \<open>y \<in> V j\<close> \<open>j \<in> U\<close> by fastforce
+        show "\<And>x. x \<in> {0..1} \<times> {y} \<Longrightarrow> h x = p (fs j x)"
+          using "*" \<open>y \<in> V j\<close> \<open>j \<in> U\<close> by blast
+        show "connected ({0..1::real} \<times> {y})"
+          using connected_Icc connected_Times connected_sing by blast
+        show "(0, y) \<in> {0..1::real} \<times> {y}"
+          by force
+        show "x \<in> {0..1} \<times> {y}"
+          using \<open>x = (u, y)\<close> x by blast
+      qed
+    qed
+  qed blast
+  show ?thesis
+  proof
+    show "k ` ({0..1} \<times> U) \<subseteq> C"
+      using V*k VU by fastforce
+    show "\<And>y. y \<in> U \<Longrightarrow> k (0, y) = f y"
+      by (simp add: V*k)
+    show "\<And>z. z \<in> {0..1} \<times> U \<Longrightarrow> h z = p (k z)"
+      using V*k by auto
+  qed (auto simp: contk)
+qed
+
+corollary covering_space_lift_homotopy_alt:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+    and h :: "'c::real_normed_vector \<times> real \<Rightarrow> 'b"
+  assumes cov: "covering_space C p S"
+      and conth: "continuous_on (U \<times> {0..1}) h"
+      and him: "h ` (U \<times> {0..1}) \<subseteq> S"
+      and heq: "\<And>y. y \<in> U \<Longrightarrow> h (y,0) = p(f y)"
+      and contf: "continuous_on U f" and fim: "f ` U \<subseteq> C"
+  obtains k where "continuous_on (U \<times> {0..1}) k"
+                  "k ` (U \<times> {0..1}) \<subseteq> C"
+                  "\<And>y. y \<in> U \<Longrightarrow> k(y, 0) = f y"
+                  "\<And>z. z \<in> U \<times> {0..1} \<Longrightarrow> h z = p(k z)"
+proof -
+  have "continuous_on ({0..1} \<times> U) (h \<circ> (\<lambda>z. (snd z, fst z)))"
+    by (intro continuous_intros continuous_on_subset [OF conth]) auto
+  then obtain k where contk: "continuous_on ({0..1} \<times> U) k"
+                  and kim:  "k ` ({0..1} \<times> U) \<subseteq> C"
+                  and k0: "\<And>y. y \<in> U \<Longrightarrow> k(0, y) = f y"
+                  and heqp: "\<And>z. z \<in> {0..1} \<times> U \<Longrightarrow> (h \<circ> (\<lambda>z. Pair (snd z) (fst z))) z = p(k z)"
+    apply (rule covering_space_lift_homotopy [OF cov _ _ _ contf fim])
+    using him  by (auto simp: contf heq)
+  show ?thesis
+    apply (rule_tac k="k \<circ> (\<lambda>z. Pair (snd z) (fst z))" in that)
+       apply (intro continuous_intros continuous_on_subset [OF contk])
+    using kim heqp apply (auto simp: k0)
+    done
+qed
+
+corollary covering_space_lift_homotopic_function:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector" and g:: "'c::real_normed_vector \<Rightarrow> 'a"
+  assumes cov: "covering_space C p S"
+      and contg: "continuous_on U g"
+      and gim: "g ` U \<subseteq> C"
+      and pgeq: "\<And>y. y \<in> U \<Longrightarrow> p(g y) = f y"
+      and hom: "homotopic_with (\<lambda>x. True) U S f f'"
+    obtains g' where "continuous_on U g'" "image g' U \<subseteq> C" "\<And>y. y \<in> U \<Longrightarrow> p(g' y) = f' y"
+proof -
+  obtain h where conth: "continuous_on ({0..1::real} \<times> U) h"
+             and him: "h ` ({0..1} \<times> U) \<subseteq> S"
+             and h0:  "\<And>x. h(0, x) = f x"
+             and h1: "\<And>x. h(1, x) = f' x"
+    using hom by (auto simp: homotopic_with_def)
+  have "\<And>y. y \<in> U \<Longrightarrow> h (0, y) = p (g y)"
+    by (simp add: h0 pgeq)
+  then obtain k where contk: "continuous_on ({0..1} \<times> U) k"
+                  and kim: "k ` ({0..1} \<times> U) \<subseteq> C"
+                  and k0: "\<And>y. y \<in> U \<Longrightarrow> k(0, y) = g y"
+                  and heq: "\<And>z. z \<in> {0..1} \<times> U \<Longrightarrow> h z = p(k z)"
+    using covering_space_lift_homotopy [OF cov conth him _ contg gim] by metis
+  show ?thesis
+  proof
+    show "continuous_on U (k \<circ> Pair 1)"
+      by (meson contk atLeastAtMost_iff continuous_on_o_Pair order_refl zero_le_one)
+    show "(k \<circ> Pair 1) ` U \<subseteq> C"
+      using kim by auto
+    show "\<And>y. y \<in> U \<Longrightarrow> p ((k \<circ> Pair 1) y) = f' y"
+      by (auto simp: h1 heq [symmetric])
+  qed
+qed
+
+corollary covering_space_lift_inessential_function:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector" and U :: "'c::real_normed_vector set"
+  assumes cov: "covering_space C p S"
+      and hom: "homotopic_with (\<lambda>x. True) U S f (\<lambda>x. a)"
+  obtains g where "continuous_on U g" "g ` U \<subseteq> C" "\<And>y. y \<in> U \<Longrightarrow> p(g y) = f y"
+proof (cases "U = {}")
+  case True
+  then show ?thesis
+    using that continuous_on_empty by blast
+next
+  case False
+  then obtain b where b: "b \<in> C" "p b = a"
+    using covering_space_imp_surjective [OF cov] homotopic_with_imp_subset2 [OF hom]
+    by auto
+  then have gim: "(\<lambda>y. b) ` U \<subseteq> C"
+    by blast
+  show ?thesis
+    apply (rule covering_space_lift_homotopic_function
+                  [OF cov continuous_on_const gim _ homotopic_with_symD [OF hom]])
+    using b that apply auto
+    done
+qed
+
+subsection\<open> Lifting of general functions to covering space\<close>
+
+proposition covering_space_lift_path_strong:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+    and f :: "'c::real_normed_vector \<Rightarrow> 'b"
+  assumes cov: "covering_space C p S" and "a \<in> C"
+      and "path g" and pag: "path_image g \<subseteq> S" and pas: "pathstart g = p a"
+    obtains h where "path h" "path_image h \<subseteq> C" "pathstart h = a"
+                and "\<And>t. t \<in> {0..1} \<Longrightarrow> p(h t) = g t"
+proof -
+  obtain k:: "real \<times> 'c \<Rightarrow> 'a"
+    where contk: "continuous_on ({0..1} \<times> {undefined}) k"
+      and kim: "k ` ({0..1} \<times> {undefined}) \<subseteq> C"
+      and k0:  "k (0, undefined) = a"
+      and pk: "\<And>z. z \<in> {0..1} \<times> {undefined} \<Longrightarrow> p(k z) = (g \<circ> fst) z"
+  proof (rule covering_space_lift_homotopy [OF cov, of "{undefined}" "g \<circ> fst"])
+    show "continuous_on ({0..1::real} \<times> {undefined::'c}) (g \<circ> fst)"
+      apply (intro continuous_intros)
+      using \<open>path g\<close> by (simp add: path_def)
+    show "(g \<circ> fst) ` ({0..1} \<times> {undefined}) \<subseteq> S"
+      using pag by (auto simp: path_image_def)
+    show "(g \<circ> fst) (0, y) = p a" if "y \<in> {undefined}" for y::'c
+      by (metis comp_def fst_conv pas pathstart_def)
+  qed (use assms in auto)
+  show ?thesis
+  proof
+    show "path (k \<circ> (\<lambda>t. Pair t undefined))"
+      unfolding path_def
+      by (intro continuous_on_compose continuous_intros continuous_on_subset [OF contk]) auto
+    show "path_image (k \<circ> (\<lambda>t. (t, undefined))) \<subseteq> C"
+      using kim by (auto simp: path_image_def)
+    show "pathstart (k \<circ> (\<lambda>t. (t, undefined))) = a"
+      by (auto simp: pathstart_def k0)
+    show "\<And>t. t \<in> {0..1} \<Longrightarrow> p ((k \<circ> (\<lambda>t. (t, undefined))) t) = g t"
+      by (auto simp: pk)
+  qed
+qed
+
+corollary covering_space_lift_path:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+  assumes cov: "covering_space C p S" and "path g" and pig: "path_image g \<subseteq> S"
+  obtains h where "path h" "path_image h \<subseteq> C" "\<And>t. t \<in> {0..1} \<Longrightarrow> p(h t) = g t"
+proof -
+  obtain a where "a \<in> C" "pathstart g = p a"
+    by (metis pig cov covering_space_imp_surjective imageE pathstart_in_path_image subsetCE)
+  show ?thesis
+    using covering_space_lift_path_strong [OF cov \<open>a \<in> C\<close> \<open>path g\<close> pig]
+    by (metis \<open>pathstart g = p a\<close> that)
+qed
+
+  
+proposition covering_space_lift_homotopic_paths:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+  assumes cov: "covering_space C p S"
+      and "path g1" and pig1: "path_image g1 \<subseteq> S"
+      and "path g2" and pig2: "path_image g2 \<subseteq> S"
+      and hom: "homotopic_paths S g1 g2"
+      and "path h1" and pih1: "path_image h1 \<subseteq> C" and ph1: "\<And>t. t \<in> {0..1} \<Longrightarrow> p(h1 t) = g1 t"
+      and "path h2" and pih2: "path_image h2 \<subseteq> C" and ph2: "\<And>t. t \<in> {0..1} \<Longrightarrow> p(h2 t) = g2 t"
+      and h1h2: "pathstart h1 = pathstart h2"
+    shows "homotopic_paths C h1 h2"
+proof -
+  obtain h :: "real \<times> real \<Rightarrow> 'b"
+     where conth: "continuous_on ({0..1} \<times> {0..1}) h"
+       and him: "h ` ({0..1} \<times> {0..1}) \<subseteq> S"
+       and h0: "\<And>x. h (0, x) = g1 x" and h1: "\<And>x. h (1, x) = g2 x"
+       and heq0: "\<And>t. t \<in> {0..1} \<Longrightarrow> h (t, 0) = g1 0"
+       and heq1: "\<And>t. t \<in> {0..1} \<Longrightarrow> h (t, 1) = g1 1"
+    using hom by (auto simp: homotopic_paths_def homotopic_with_def pathstart_def pathfinish_def)
+  obtain k where contk: "continuous_on ({0..1} \<times> {0..1}) k"
+             and kim: "k ` ({0..1} \<times> {0..1}) \<subseteq> C"
+             and kh2: "\<And>y. y \<in> {0..1} \<Longrightarrow> k (y, 0) = h2 0"
+             and hpk: "\<And>z. z \<in> {0..1} \<times> {0..1} \<Longrightarrow> h z = p (k z)"
+    apply (rule covering_space_lift_homotopy_alt [OF cov conth him, of "\<lambda>x. h2 0"])
+    using h1h2 ph1 ph2 apply (force simp: heq0 pathstart_def pathfinish_def)
+    using path_image_def pih2 continuous_on_const by fastforce+
+  have contg1: "continuous_on {0..1} g1" and contg2: "continuous_on {0..1} g2"
+    using \<open>path g1\<close> \<open>path g2\<close> path_def by blast+
+  have g1im: "g1 ` {0..1} \<subseteq> S" and g2im: "g2 ` {0..1} \<subseteq> S"
+    using path_image_def pig1 pig2 by auto
+  have conth1: "continuous_on {0..1} h1" and conth2: "continuous_on {0..1} h2"
+    using \<open>path h1\<close> \<open>path h2\<close> path_def by blast+
+  have h1im: "h1 ` {0..1} \<subseteq> C" and h2im: "h2 ` {0..1} \<subseteq> C"
+    using path_image_def pih1 pih2 by auto
+  show ?thesis
+    unfolding homotopic_paths pathstart_def pathfinish_def
+  proof (intro exI conjI ballI)
+    show keqh1: "k(0, x) = h1 x" if "x \<in> {0..1}" for x
+    proof (rule covering_space_lift_unique [OF cov _ contg1 g1im])
+      show "k (0,0) = h1 0"
+        by (metis atLeastAtMost_iff h1h2 kh2 order_refl pathstart_def zero_le_one)
+      show "continuous_on {0..1} (\<lambda>a. k (0, a))"
+        by (intro continuous_intros continuous_on_compose2 [OF contk]) auto
+      show "\<And>x. x \<in> {0..1} \<Longrightarrow> g1 x = p (k (0, x))"
+        by (metis atLeastAtMost_iff h0 hpk zero_le_one mem_Sigma_iff order_refl)
+    qed (use conth1 h1im kim that in \<open>auto simp: ph1\<close>)
+    show "k(1, x) = h2 x" if "x \<in> {0..1}" for x
+    proof (rule covering_space_lift_unique [OF cov _ contg2 g2im])
+      show "k (1,0) = h2 0"
+        by (metis atLeastAtMost_iff kh2 order_refl zero_le_one)
+      show "continuous_on {0..1} (\<lambda>a. k (1, a))"
+        by (intro continuous_intros continuous_on_compose2 [OF contk]) auto
+      show "\<And>x. x \<in> {0..1} \<Longrightarrow> g2 x = p (k (1, x))"
+        by (metis atLeastAtMost_iff h1 hpk mem_Sigma_iff order_refl zero_le_one)
+    qed (use conth2 h2im kim that in \<open>auto simp: ph2\<close>)
+    show "\<And>t. t \<in> {0..1} \<Longrightarrow> (k \<circ> Pair t) 0 = h1 0"
+      by (metis comp_apply h1h2 kh2 pathstart_def)
+    show "(k \<circ> Pair t) 1 = h1 1" if "t \<in> {0..1}" for t
+    proof (rule covering_space_lift_unique
+           [OF cov, of "\<lambda>a. (k \<circ> Pair a) 1" 0 "\<lambda>a. h1 1" "{0..1}"  "\<lambda>x. g1 1"])
+      show "(k \<circ> Pair 0) 1 = h1 1"
+        using keqh1 by auto
+      show "continuous_on {0..1} (\<lambda>a. (k \<circ> Pair a) 1)"
+        apply simp
+        by (intro continuous_intros continuous_on_compose2 [OF contk]) auto
+      show "\<And>x. x \<in> {0..1} \<Longrightarrow> g1 1 = p ((k \<circ> Pair x) 1)"
+        using heq1 hpk by auto
+    qed (use contk kim g1im h1im that in \<open>auto simp: ph1 continuous_on_const\<close>)
+  qed (use contk kim in auto)
+qed
+
+
+corollary covering_space_monodromy:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+  assumes cov: "covering_space C p S"
+      and "path g1" and pig1: "path_image g1 \<subseteq> S"
+      and "path g2" and pig2: "path_image g2 \<subseteq> S"
+      and hom: "homotopic_paths S g1 g2"
+      and "path h1" and pih1: "path_image h1 \<subseteq> C" and ph1: "\<And>t. t \<in> {0..1} \<Longrightarrow> p(h1 t) = g1 t"
+      and "path h2" and pih2: "path_image h2 \<subseteq> C" and ph2: "\<And>t. t \<in> {0..1} \<Longrightarrow> p(h2 t) = g2 t"
+      and h1h2: "pathstart h1 = pathstart h2"
+    shows "pathfinish h1 = pathfinish h2"
+  using covering_space_lift_homotopic_paths [OF assms] homotopic_paths_imp_pathfinish by blast
+
+
+corollary covering_space_lift_homotopic_path:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+  assumes cov: "covering_space C p S"
+      and hom: "homotopic_paths S f f'"
+      and "path g" and pig: "path_image g \<subseteq> C"
+      and a: "pathstart g = a" and b: "pathfinish g = b"
+      and pgeq: "\<And>t. t \<in> {0..1} \<Longrightarrow> p(g t) = f t"
+  obtains g' where "path g'" "path_image g' \<subseteq> C"
+                   "pathstart g' = a" "pathfinish g' = b" "\<And>t. t \<in> {0..1} \<Longrightarrow> p(g' t) = f' t"
+proof (rule covering_space_lift_path_strong [OF cov, of a f'])
+  show "a \<in> C"
+    using a pig by auto
+  show "path f'" "path_image f' \<subseteq> S"
+    using hom homotopic_paths_imp_path homotopic_paths_imp_subset by blast+
+  show "pathstart f' = p a"
+    by (metis a atLeastAtMost_iff hom homotopic_paths_imp_pathstart order_refl pathstart_def pgeq zero_le_one)
+qed (metis (mono_tags, lifting) assms cov covering_space_monodromy hom homotopic_paths_imp_path homotopic_paths_imp_subset pgeq pig)
+
+
+proposition covering_space_lift_general:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+    and f :: "'c::real_normed_vector \<Rightarrow> 'b"
+  assumes cov: "covering_space C p S" and "a \<in> C" "z \<in> U"
+      and U: "path_connected U" "locally path_connected U"
+      and contf: "continuous_on U f" and fim: "f ` U \<subseteq> S"
+      and feq: "f z = p a"
+      and hom: "\<And>r. \<lbrakk>path r; path_image r \<subseteq> U; pathstart r = z; pathfinish r = z\<rbrakk>
+                     \<Longrightarrow> \<exists>q. path q \<and> path_image q \<subseteq> C \<and>
+                             pathstart q = a \<and> pathfinish q = a \<and>
+                             homotopic_paths S (f \<circ> r) (p \<circ> q)"
+  obtains g where "continuous_on U g" "g ` U \<subseteq> C" "g z = a" "\<And>y. y \<in> U \<Longrightarrow> p(g y) = f y"
+proof -
+  have *: "\<exists>g h. path g \<and> path_image g \<subseteq> U \<and>
+                 pathstart g = z \<and> pathfinish g = y \<and>
+                 path h \<and> path_image h \<subseteq> C \<and> pathstart h = a \<and>
+                 (\<forall>t \<in> {0..1}. p(h t) = f(g t))"
+          if "y \<in> U" for y
+  proof -
+    obtain g where "path g" "path_image g \<subseteq> U" and pastg: "pathstart g = z"
+               and pafig: "pathfinish g = y"
+      using U \<open>z \<in> U\<close> \<open>y \<in> U\<close> by (force simp: path_connected_def)
+    obtain h where "path h" "path_image h \<subseteq> C" "pathstart h = a"
+               and "\<And>t. t \<in> {0..1} \<Longrightarrow> p(h t) = (f \<circ> g) t"
+    proof (rule covering_space_lift_path_strong [OF cov \<open>a \<in> C\<close>])
+      show "path (f \<circ> g)"
+        using \<open>path g\<close> \<open>path_image g \<subseteq> U\<close> contf continuous_on_subset path_continuous_image by blast
+      show "path_image (f \<circ> g) \<subseteq> S"
+        by (metis \<open>path_image g \<subseteq> U\<close> fim image_mono path_image_compose subset_trans)
+      show "pathstart (f \<circ> g) = p a"
+        by (simp add: feq pastg pathstart_compose)
+    qed auto
+    then show ?thesis
+      by (metis \<open>path g\<close> \<open>path_image g \<subseteq> U\<close> comp_apply pafig pastg)
+  qed
+  have "\<exists>l. \<forall>g h. path g \<and> path_image g \<subseteq> U \<and> pathstart g = z \<and> pathfinish g = y \<and>
+                  path h \<and> path_image h \<subseteq> C \<and> pathstart h = a \<and>
+                  (\<forall>t \<in> {0..1}. p(h t) = f(g t))  \<longrightarrow> pathfinish h = l" for y
+  proof -
+    have "pathfinish h = pathfinish h'"
+         if g: "path g" "path_image g \<subseteq> U" "pathstart g = z" "pathfinish g = y"
+            and h: "path h" "path_image h \<subseteq> C" "pathstart h = a"
+            and phg: "\<And>t. t \<in> {0..1} \<Longrightarrow> p(h t) = f(g t)"
+            and g': "path g'" "path_image g' \<subseteq> U" "pathstart g' = z" "pathfinish g' = y"
+            and h': "path h'" "path_image h' \<subseteq> C" "pathstart h' = a"
+            and phg': "\<And>t. t \<in> {0..1} \<Longrightarrow> p(h' t) = f(g' t)"
+         for g h g' h'
+    proof -
+      obtain q where "path q" and piq: "path_image q \<subseteq> C" and pastq: "pathstart q = a" and pafiq: "pathfinish q = a"
+                 and homS: "homotopic_paths S (f \<circ> g +++ reversepath g') (p \<circ> q)"
+        using g g' hom [of "g +++ reversepath g'"] by (auto simp:  subset_path_image_join)
+              have papq: "path (p \<circ> q)"
+                using homS homotopic_paths_imp_path by blast
+              have pipq: "path_image (p \<circ> q) \<subseteq> S"
+                using homS homotopic_paths_imp_subset by blast
+      obtain q' where "path q'" "path_image q' \<subseteq> C"
+                and "pathstart q' = pathstart q" "pathfinish q' = pathfinish q"
+                and pq'_eq: "\<And>t. t \<in> {0..1} \<Longrightarrow> p (q' t) = (f \<circ> g +++ reversepath g') t"
+        using covering_space_lift_homotopic_path [OF cov homotopic_paths_sym [OF homS] \<open>path q\<close> piq refl refl]
+        by auto
+      have "q' t = (h \<circ> op *\<^sub>R 2) t" if "0 \<le> t" "t \<le> 1/2" for t
+      proof (rule covering_space_lift_unique [OF cov, of q' 0 "h \<circ> op *\<^sub>R 2" "{0..1/2}" "f \<circ> g \<circ> op *\<^sub>R 2" t])
+        show "q' 0 = (h \<circ> op *\<^sub>R 2) 0"
+          by (metis \<open>pathstart q' = pathstart q\<close> comp_def g h pastq pathstart_def pth_4(2))
+        show "continuous_on {0..1/2} (f \<circ> g \<circ> op *\<^sub>R 2)"
+          apply (intro continuous_intros continuous_on_compose continuous_on_path [OF \<open>path g\<close>] continuous_on_subset [OF contf])
+          using g(2) path_image_def by fastforce+
+        show "(f \<circ> g \<circ> op *\<^sub>R 2) ` {0..1/2} \<subseteq> S"
+          using g(2) path_image_def fim by fastforce
+        show "(h \<circ> op *\<^sub>R 2) ` {0..1/2} \<subseteq> C"
+          using h path_image_def by fastforce
+        show "q' ` {0..1/2} \<subseteq> C"
+          using \<open>path_image q' \<subseteq> C\<close> path_image_def by fastforce
+        show "\<And>x. x \<in> {0..1/2} \<Longrightarrow> (f \<circ> g \<circ> op *\<^sub>R 2) x = p (q' x)"
+          by (auto simp: joinpaths_def pq'_eq)
+        show "\<And>x. x \<in> {0..1/2} \<Longrightarrow> (f \<circ> g \<circ> op *\<^sub>R 2) x = p ((h \<circ> op *\<^sub>R 2) x)"
+          by (simp add: phg)
+        show "continuous_on {0..1/2} q'"
+          by (simp add: continuous_on_path \<open>path q'\<close>)
+        show "continuous_on {0..1/2} (h \<circ> op *\<^sub>R 2)"
+          apply (intro continuous_intros continuous_on_compose continuous_on_path [OF \<open>path h\<close>], force)
+          done
+      qed (use that in auto)
+      moreover have "q' t = (reversepath h' \<circ> (\<lambda>t. 2 *\<^sub>R t - 1)) t" if "1/2 < t" "t \<le> 1" for t
+      proof (rule covering_space_lift_unique [OF cov, of q' 1 "reversepath h' \<circ> (\<lambda>t. 2 *\<^sub>R t - 1)" "{1/2<..1}" "f \<circ> reversepath g' \<circ> (\<lambda>t. 2 *\<^sub>R t - 1)" t])
+        show "q' 1 = (reversepath h' \<circ> (\<lambda>t. 2 *\<^sub>R t - 1)) 1"
+          using h' \<open>pathfinish q' = pathfinish q\<close> pafiq
+          by (simp add: pathstart_def pathfinish_def reversepath_def)
+        show "continuous_on {1/2<..1} (f \<circ> reversepath g' \<circ> (\<lambda>t. 2 *\<^sub>R t - 1))"
+          apply (intro continuous_intros continuous_on_compose continuous_on_path \<open>path g'\<close> continuous_on_subset [OF contf])
+          using g' apply simp_all
+          by (auto simp: path_image_def reversepath_def)
+        show "(f \<circ> reversepath g' \<circ> (\<lambda>t. 2 *\<^sub>R t - 1)) ` {1/2<..1} \<subseteq> S"
+          using g'(2) path_image_def fim by (auto simp: image_subset_iff path_image_def reversepath_def)
+        show "q' ` {1/2<..1} \<subseteq> C"
+          using \<open>path_image q' \<subseteq> C\<close> path_image_def by fastforce
+        show "(reversepath h' \<circ> (\<lambda>t. 2 *\<^sub>R t - 1)) ` {1/2<..1} \<subseteq> C"
+          using h' by (simp add: path_image_def reversepath_def subset_eq)
+        show "\<And>x. x \<in> {1/2<..1} \<Longrightarrow> (f \<circ> reversepath g' \<circ> (\<lambda>t. 2 *\<^sub>R t - 1)) x = p (q' x)"
+          by (auto simp: joinpaths_def pq'_eq)
+        show "\<And>x. x \<in> {1/2<..1} \<Longrightarrow>
+                  (f \<circ> reversepath g' \<circ> (\<lambda>t. 2 *\<^sub>R t - 1)) x = p ((reversepath h' \<circ> (\<lambda>t. 2 *\<^sub>R t - 1)) x)"
+          by (simp add: phg' reversepath_def)
+        show "continuous_on {1/2<..1} q'"
+          by (auto intro: continuous_on_path [OF \<open>path q'\<close>])
+        show "continuous_on {1/2<..1} (reversepath h' \<circ> (\<lambda>t. 2 *\<^sub>R t - 1))"
+          apply (intro continuous_intros continuous_on_compose continuous_on_path \<open>path h'\<close>)
+          using h' apply auto
+          done
+      qed (use that in auto)
+      ultimately have "q' t = (h +++ reversepath h') t" if "0 \<le> t" "t \<le> 1" for t
+        using that by (simp add: joinpaths_def)
+      then have "path(h +++ reversepath h')"
+        by (auto intro: path_eq [OF \<open>path q'\<close>])
+      then show ?thesis
+        by (auto simp: \<open>path h\<close> \<open>path h'\<close>)
+    qed
+    then show ?thesis by metis
+  qed
+  then obtain l :: "'c \<Rightarrow> 'a"
+          where l: "\<And>y g h. \<lbrakk>path g; path_image g \<subseteq> U; pathstart g = z; pathfinish g = y;
+                             path h; path_image h \<subseteq> C; pathstart h = a;
+                             \<And>t. t \<in> {0..1} \<Longrightarrow> p(h t) = f(g t)\<rbrakk> \<Longrightarrow> pathfinish h = l y"
+    by metis
+  show ?thesis
+  proof
+    show pleq: "p (l y) = f y" if "y \<in> U" for y
+      using*[OF \<open>y \<in> U\<close>]  by (metis l atLeastAtMost_iff order_refl pathfinish_def zero_le_one)
+    show "l z = a"
+      using l [of "linepath z z" z "linepath a a"] by (auto simp: assms)
+    show LC: "l ` U \<subseteq> C"
+      by (clarify dest!: *) (metis (full_types) l pathfinish_in_path_image subsetCE)
+    have "\<exists>T. openin (subtopology euclidean U) T \<and> y \<in> T \<and> T \<subseteq> {x \<in> U. l x \<in> X}"
+         if X: "openin (subtopology euclidean C) X" and "y \<in> U" "l y \<in> X" for X y
+    proof -
+      have "X \<subseteq> C"
+        using X openin_euclidean_subtopology_iff by blast
+      have "f y \<in> S"
+        using fim \<open>y \<in> U\<close> by blast
+      then obtain W \<V>
+              where WV: "f y \<in> W \<and> openin (subtopology euclidean S) W \<and>
+                         (\<Union>\<V> = {x. x \<in> C \<and> p x \<in> W} \<and>
+                          (\<forall>U \<in> \<V>. openin (subtopology euclidean C) U) \<and>
+                          pairwise disjnt \<V> \<and>
+                          (\<forall>U \<in> \<V>. \<exists>q. homeomorphism U W p q))"
+        using cov by (force simp: covering_space_def)
+      then have "l y \<in> \<Union>\<V>"
+        using \<open>X \<subseteq> C\<close> pleq that by auto
+      then obtain W' where "l y \<in> W'" and "W' \<in> \<V>"
+        by blast
+      with WV obtain p' where opeCW': "openin (subtopology euclidean C) W'"
+                          and homUW': "homeomorphism W' W p p'"
+        by blast
+      then have contp': "continuous_on W p'" and p'im: "p' ` W \<subseteq> W'"
+        using homUW' homeomorphism_image2 homeomorphism_cont2 by fastforce+
+      obtain V where "y \<in> V" "y \<in> U" and fimW: "f ` V \<subseteq> W" "V \<subseteq> U"
+                 and "path_connected V" and opeUV: "openin (subtopology euclidean U) V"
+      proof -
+        have "openin (subtopology euclidean U) {c \<in> U. f c \<in> W}"
+          using WV contf continuous_on_open_gen fim by auto
+        then show ?thesis
+          using U WV
+          apply (auto simp: locally_path_connected)
+          apply (drule_tac x="{x. x \<in> U \<and> f x \<in> W}" in spec)
+          apply (drule_tac x=y in spec)
+          apply (auto simp: \<open>y \<in> U\<close> intro: that)
+          done
+      qed
+      have "W' \<subseteq> C" "W \<subseteq> S"
+        using opeCW' WV openin_imp_subset by auto
+      have p'im: "p' ` W \<subseteq> W'"
+        using homUW' homeomorphism_image2 by fastforce
+      show ?thesis
+      proof (intro exI conjI)
+        have "openin (subtopology euclidean S) {x \<in> W. p' x \<in> W' \<inter> X}"
+        proof (rule openin_trans)
+          show "openin (subtopology euclidean W) {x \<in> W. p' x \<in> W' \<inter> X}"
+            apply (rule continuous_openin_preimage [OF contp' p'im])
+            using X \<open>W' \<subseteq> C\<close> apply (auto simp: openin_open)
+            done
+          show "openin (subtopology euclidean S) W"
+            using WV by blast
+        qed
+        then show "openin (subtopology euclidean U) (V \<inter> {x. x \<in> U \<and> f x \<in> {x. x \<in> W \<and> p' x \<in> W' \<inter> X}})"
+          by (intro openin_Int opeUV continuous_openin_preimage [OF contf fim])
+        have "p' (f y) \<in> X"
+          using \<open>l y \<in> W'\<close> homeomorphism_apply1 [OF homUW'] pleq \<open>y \<in> U\<close> \<open>l y \<in> X\<close> by fastforce
+        then show "y \<in> V \<inter> {x \<in> U. f x \<in> {x \<in> W. p' x \<in> W' \<inter> X}}"
+          using \<open>y \<in> U\<close> \<open>y \<in> V\<close> WV p'im by auto
+        show "V \<inter> {x \<in> U. f x \<in> {x \<in> W. p' x \<in> W' \<inter> X}} \<subseteq> {x \<in> U. l x \<in> X}"
+        proof clarsimp
+          fix y'
+          assume y': "y' \<in> V" "y' \<in> U" "f y' \<in> W" "p' (f y') \<in> W'" "p' (f y') \<in> X"
+          then obtain \<gamma> where "path \<gamma>" "path_image \<gamma> \<subseteq> V" "pathstart \<gamma> = y" "pathfinish \<gamma> = y'"
+            by (meson \<open>path_connected V\<close> \<open>y \<in> V\<close> path_connected_def)
+          obtain pp qq where "path pp" "path_image pp \<subseteq> U"
+                             "pathstart pp = z" "pathfinish pp = y"
+                             "path qq" "path_image qq \<subseteq> C" "pathstart qq = a"
+                         and pqqeq: "\<And>t. t \<in> {0..1} \<Longrightarrow> p(qq t) = f(pp t)"
+            using*[OF \<open>y \<in> U\<close>] by blast
+          have finW: "\<And>x. \<lbrakk>0 \<le> x; x \<le> 1\<rbrakk> \<Longrightarrow> f (\<gamma> x) \<in> W"
+            using \<open>path_image \<gamma> \<subseteq> V\<close> by (auto simp: image_subset_iff path_image_def fimW [THEN subsetD])
+          have "pathfinish (qq +++ (p' \<circ> f \<circ> \<gamma>)) = l y'"
+          proof (rule l [of "pp +++ \<gamma>" y' "qq +++ (p' \<circ> f \<circ> \<gamma>)" ])
+            show "path (pp +++ \<gamma>)"
+              by (simp add: \<open>path \<gamma>\<close> \<open>path pp\<close> \<open>pathfinish pp = y\<close> \<open>pathstart \<gamma> = y\<close>)
+            show "path_image (pp +++ \<gamma>) \<subseteq> U"
+              using \<open>V \<subseteq> U\<close> \<open>path_image \<gamma> \<subseteq> V\<close> \<open>path_image pp \<subseteq> U\<close> not_in_path_image_join by blast
+            show "pathstart (pp +++ \<gamma>) = z"
+              by (simp add: \<open>pathstart pp = z\<close>)
+            show "pathfinish (pp +++ \<gamma>) = y'"
+              by (simp add: \<open>pathfinish \<gamma> = y'\<close>)
+            have paqq: "pathfinish qq = pathstart (p' \<circ> f \<circ> \<gamma>)"
+              apply (simp add: \<open>pathstart \<gamma> = y\<close> pathstart_compose)
+              apply (metis (mono_tags, lifting) \<open>l y \<in> W'\<close> \<open>path pp\<close> \<open>path qq\<close> \<open>path_image pp \<subseteq> U\<close> \<open>path_image qq \<subseteq> C\<close>
+                           \<open>pathfinish pp = y\<close> \<open>pathstart pp = z\<close> \<open>pathstart qq = a\<close>
+                           homeomorphism_apply1 [OF homUW'] l pleq pqqeq \<open>y \<in> U\<close>)
+              done
+            have "continuous_on (path_image \<gamma>) (p' \<circ> f)"
+            proof (rule continuous_on_compose)
+              show "continuous_on (path_image \<gamma>) f"
+                using \<open>path_image \<gamma> \<subseteq> V\<close> \<open>V \<subseteq> U\<close> contf continuous_on_subset by blast
+              show "continuous_on (f ` path_image \<gamma>) p'"
+                apply (rule continuous_on_subset [OF contp'])
+                apply (auto simp: path_image_def pathfinish_def pathstart_def finW)
+                done
+            qed
+            then show "path (qq +++ (p' \<circ> f \<circ> \<gamma>))"
+              using \<open>path \<gamma>\<close> \<open>path qq\<close> paqq path_continuous_image path_join_imp by blast
+            show "path_image (qq +++ (p' \<circ> f \<circ> \<gamma>)) \<subseteq> C"
+              apply (rule subset_path_image_join)
+               apply (simp add: \<open>path_image qq \<subseteq> C\<close>)
+              by (metis \<open>W' \<subseteq> C\<close> \<open>path_image \<gamma> \<subseteq> V\<close> dual_order.trans fimW(1) image_comp image_mono p'im path_image_compose)
+            show "pathstart (qq +++ (p' \<circ> f \<circ> \<gamma>)) = a"
+              by (simp add: \<open>pathstart qq = a\<close>)
+            show "p ((qq +++ (p' \<circ> f \<circ> \<gamma>)) \<xi>) = f ((pp +++ \<gamma>) \<xi>)" if \<xi>: "\<xi> \<in> {0..1}" for \<xi>
+            proof (simp add: joinpaths_def, safe)
+              show "p (qq (2*\<xi>)) = f (pp (2*\<xi>))" if "\<xi>*2 \<le> 1"
+                using \<open>\<xi> \<in> {0..1}\<close> pqqeq that by auto
+              show "p (p' (f (\<gamma> (2*\<xi> - 1)))) = f (\<gamma> (2*\<xi> - 1))" if "\<not> \<xi>*2 \<le> 1"
+                apply (rule homeomorphism_apply2 [OF homUW' finW])
+                using that \<xi> by auto
+            qed
+          qed
+          with \<open>pathfinish \<gamma> = y'\<close>  \<open>p' (f y') \<in> X\<close> show "l y' \<in> X"
+            unfolding pathfinish_join by (simp add: pathfinish_def)
+        qed
+      qed
+    qed
+    then show "continuous_on U l"
+      using openin_subopen continuous_on_open_gen [OF LC]
+      by (metis (no_types, lifting) mem_Collect_eq)
+  qed
+qed
+
+
+corollary covering_space_lift_stronger:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+    and f :: "'c::real_normed_vector \<Rightarrow> 'b"
+  assumes cov: "covering_space C p S" "a \<in> C" "z \<in> U"
+      and U: "path_connected U" "locally path_connected U"
+      and contf: "continuous_on U f" and fim: "f ` U \<subseteq> S"
+      and feq: "f z = p a"
+      and hom: "\<And>r. \<lbrakk>path r; path_image r \<subseteq> U; pathstart r = z; pathfinish r = z\<rbrakk>
+                     \<Longrightarrow> \<exists>b. homotopic_paths S (f \<circ> r) (linepath b b)"
+  obtains g where "continuous_on U g" "g ` U \<subseteq> C" "g z = a" "\<And>y. y \<in> U \<Longrightarrow> p(g y) = f y"
+proof (rule covering_space_lift_general [OF cov U contf fim feq])
+  fix r
+  assume "path r" "path_image r \<subseteq> U" "pathstart r = z" "pathfinish r = z"
+  then obtain b where b: "homotopic_paths S (f \<circ> r) (linepath b b)"
+    using hom by blast
+  then have "f (pathstart r) = b"
+    by (metis homotopic_paths_imp_pathstart pathstart_compose pathstart_linepath)
+  then have "homotopic_paths S (f \<circ> r) (linepath (f z) (f z))"
+    by (simp add: b \<open>pathstart r = z\<close>)
+  then have "homotopic_paths S (f \<circ> r) (p \<circ> linepath a a)"
+    by (simp add: o_def feq linepath_def)
+  then show "\<exists>q. path q \<and>
+                  path_image q \<subseteq> C \<and>
+                  pathstart q = a \<and> pathfinish q = a \<and> homotopic_paths S (f \<circ> r) (p \<circ> q)"
+    by (force simp: \<open>a \<in> C\<close>)
+qed auto
+
+corollary covering_space_lift_strong:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+    and f :: "'c::real_normed_vector \<Rightarrow> 'b"
+  assumes cov: "covering_space C p S" "a \<in> C" "z \<in> U"
+      and scU: "simply_connected U" and lpcU: "locally path_connected U"
+      and contf: "continuous_on U f" and fim: "f ` U \<subseteq> S"
+      and feq: "f z = p a"
+  obtains g where "continuous_on U g" "g ` U \<subseteq> C" "g z = a" "\<And>y. y \<in> U \<Longrightarrow> p(g y) = f y"
+proof (rule covering_space_lift_stronger [OF cov _ lpcU contf fim feq])
+  show "path_connected U"
+    using scU simply_connected_eq_contractible_loop_some by blast
+  fix r
+  assume r: "path r" "path_image r \<subseteq> U" "pathstart r = z" "pathfinish r = z"
+  have "linepath (f z) (f z) = f \<circ> linepath z z"
+    by (simp add: o_def linepath_def)
+  then have "homotopic_paths S (f \<circ> r) (linepath (f z) (f z))"
+    by (metis r contf fim homotopic_paths_continuous_image scU simply_connected_eq_contractible_path)
+  then show "\<exists>b. homotopic_paths S (f \<circ> r) (linepath b b)"
+    by blast
+qed blast
+
+corollary covering_space_lift:
+  fixes p :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+    and f :: "'c::real_normed_vector \<Rightarrow> 'b"
+  assumes cov: "covering_space C p S"
+      and U: "simply_connected U"  "locally path_connected U"
+      and contf: "continuous_on U f" and fim: "f ` U \<subseteq> S"
+    obtains g where "continuous_on U g" "g ` U \<subseteq> C" "\<And>y. y \<in> U \<Longrightarrow> p(g y) = f y"
+proof (cases "U = {}")
+  case True
+  with that show ?thesis by auto
+next
+  case False
+  then obtain z where "z \<in> U" by blast
+  then obtain a where "a \<in> C" "f z = p a"
+    by (metis cov covering_space_imp_surjective fim image_iff image_subset_iff)
+  then show ?thesis
+    by (metis that covering_space_lift_strong [OF cov _ \<open>z \<in> U\<close> U contf fim])
+qed
+
 end
diff -r 81a5473e6d04 -r a0e1f64be67c src/HOL/Analysis/Path_Connected.thy
--- a/src/HOL/Analysis/Path_Connected.thy	Thu Jan 05 22:37:52 2017 +0100
+++ b/src/HOL/Analysis/Path_Connected.thy	Thu Jan 05 22:38:06 2017 +0100
@@ -134,12 +134,18 @@
 
 subsection\<open>Basic lemmas about paths\<close>
 
+lemma continuous_on_path: "path f \<Longrightarrow> t \<subseteq> {0..1} \<Longrightarrow> continuous_on t f"
+  using continuous_on_subset path_def by blast
+
 lemma arc_imp_simple_path: "arc g \<Longrightarrow> simple_path g"
   by (simp add: arc_def inj_on_def simple_path_def)
 
 lemma arc_imp_path: "arc g \<Longrightarrow> path g"
   using arc_def by blast
 
+lemma arc_imp_inj_on: "arc g \<Longrightarrow> inj_on g {0..1}"
+  by (auto simp: arc_def)
+
 lemma simple_path_imp_path: "simple_path g \<Longrightarrow> path g"
   using simple_path_def by blast
 
@@ -1047,7 +1053,7 @@
     done
 qed
 
-subsection \<open>Reparametrizing a closed curve to start at some chosen point\<close>
+subsection \<open>shiftpath: Reparametrizing a closed curve to start at some chosen point\<close>
 
 definition shiftpath :: "real \<Rightarrow> (real \<Rightarrow> 'a::topological_space) \<Rightarrow> real \<Rightarrow> 'a"
   where "shiftpath a f = (\<lambda>x. if (a + x) \<le> 1 then f (a + x) else f (a + x - 1))"
@@ -1146,6 +1152,22 @@
     by (auto simp add: image_iff)
 qed
 
+lemma simple_path_shiftpath:
+  assumes "simple_path g" "pathfinish g = pathstart g" and a: "0 \<le> a" "a \<le> 1"
+    shows "simple_path (shiftpath a g)"
+  unfolding simple_path_def
+proof (intro conjI impI ballI)
+  show "path (shiftpath a g)"
+    by (simp add: assms path_shiftpath simple_path_imp_path)
+  have *: "\<And>x y. \<lbrakk>g x = g y; x \<in> {0..1}; y \<in> {0..1}\<rbrakk> \<Longrightarrow> x = y \<or> x = 0 \<and> y = 1 \<or> x = 1 \<and> y = 0"
+    using assms by (simp add:  simple_path_def)
+  show "x = y \<or> x = 0 \<and> y = 1 \<or> x = 1 \<and> y = 0"
+    if "x \<in> {0..1}" "y \<in> {0..1}" "shiftpath a g x = shiftpath a g y" for x y
+    using that a unfolding shiftpath_def
+    apply (simp add: split: if_split_asm)
+      apply (drule *; auto)+
+    done
+qed
 
 subsection \<open>Special case of straight-line paths\<close>
 
@@ -1499,8 +1521,8 @@
   using path_connected_component_set by auto
 
 lemma path_connected_imp_connected:
-  assumes "path_connected s"
-  shows "connected s"
+  assumes "path_connected S"
+  shows "connected S"
   unfolding connected_def not_ex
   apply rule
   apply rule
@@ -1509,10 +1531,10 @@
   apply (elim conjE)
 proof -
   fix e1 e2
-  assume as: "open e1" "open e2" "s \<subseteq> e1 \<union> e2" "e1 \<inter> e2 \<inter> s = {}" "e1 \<inter> s \<noteq> {}" "e2 \<inter> s \<noteq> {}"
-  then obtain x1 x2 where obt:"x1 \<in> e1 \<inter> s" "x2 \<in> e2 \<inter> s"
+  assume as: "open e1" "open e2" "S \<subseteq> e1 \<union> e2" "e1 \<inter> e2 \<inter> S = {}" "e1 \<inter> S \<noteq> {}" "e2 \<inter> S \<noteq> {}"
+  then obtain x1 x2 where obt:"x1 \<in> e1 \<inter> S" "x2 \<in> e2 \<inter> S"
     by auto
-  then obtain g where g: "path g" "path_image g \<subseteq> s" "pathstart g = x1" "pathfinish g = x2"
+  then obtain g where g: "path g" "path_image g \<subseteq> S" "pathstart g = x1" "pathfinish g = x2"
     using assms[unfolded path_connected_def,rule_format,of x1 x2] by auto
   have *: "connected {0..1::real}"
     by (auto intro!: convex_connected convex_real_interval)
@@ -1535,23 +1557,23 @@
 qed
 
 lemma open_path_component:
-  fixes s :: "'a::real_normed_vector set"
-  assumes "open s"
-  shows "open (path_component_set s x)"
+  fixes S :: "'a::real_normed_vector set"
+  assumes "open S"
+  shows "open (path_component_set S x)"
   unfolding open_contains_ball
 proof
   fix y
-  assume as: "y \<in> path_component_set s x"
-  then have "y \<in> s"
+  assume as: "y \<in> path_component_set S x"
+  then have "y \<in> S"
     apply -
     apply (rule path_component_mem(2))
     unfolding mem_Collect_eq
     apply auto
     done
-  then obtain e where e: "e > 0" "ball y e \<subseteq> s"
+  then obtain e where e: "e > 0" "ball y e \<subseteq> S"
     using assms[unfolded open_contains_ball]
     by auto
-  show "\<exists>e > 0. ball y e \<subseteq> path_component_set s x"
+  show "\<exists>e > 0. ball y e \<subseteq> path_component_set S x"
     apply (rule_tac x=e in exI)
     apply (rule,rule \<open>e>0\<close>)
     apply rule
@@ -1559,7 +1581,7 @@
   proof -
     fix z
     assume "dist y z < e"
-    then show "path_component s x z"
+    then show "path_component S x z"
       apply (rule_tac path_component_trans[of _ _ y])
       defer
       apply (rule path_component_of_subset[OF e(2)])
@@ -1571,17 +1593,17 @@
 qed
 
 lemma open_non_path_component:
-  fixes s :: "'a::real_normed_vector set"
-  assumes "open s"
-  shows "open (s - path_component_set s x)"
+  fixes S :: "'a::real_normed_vector set"
+  assumes "open S"
+  shows "open (S - path_component_set S x)"
   unfolding open_contains_ball
 proof
   fix y
-  assume as: "y \<in> s - path_component_set s x"
-  then obtain e where e: "e > 0" "ball y e \<subseteq> s"
+  assume as: "y \<in> S - path_component_set S x"
+  then obtain e where e: "e > 0" "ball y e \<subseteq> S"
     using assms [unfolded open_contains_ball]
     by auto
-  show "\<exists>e>0. ball y e \<subseteq> s - path_component_set s x"
+  show "\<exists>e>0. ball y e \<subseteq> S - path_component_set S x"
     apply (rule_tac x=e in exI)
     apply rule
     apply (rule \<open>e>0\<close>)
@@ -1590,8 +1612,8 @@
     defer
   proof (rule ccontr)
     fix z
-    assume "z \<in> ball y e" "\<not> z \<notin> path_component_set s x"
-    then have "y \<in> path_component_set s x"
+    assume "z \<in> ball y e" "\<not> z \<notin> path_component_set S x"
+    then have "y \<in> path_component_set S x"
       unfolding not_not mem_Collect_eq using \<open>e>0\<close>
       apply -
       apply (rule path_component_trans, assumption)
@@ -1605,42 +1627,42 @@
 qed
 
 lemma connected_open_path_connected:
-  fixes s :: "'a::real_normed_vector set"
-  assumes "open s"
-    and "connected s"
-  shows "path_connected s"
+  fixes S :: "'a::real_normed_vector set"
+  assumes "open S"
+    and "connected S"
+  shows "path_connected S"
   unfolding path_connected_component_set
 proof (rule, rule, rule path_component_subset, rule)
   fix x y
-  assume "x \<in> s" and "y \<in> s"
-  show "y \<in> path_component_set s x"
+  assume "x \<in> S" and "y \<in> S"
+  show "y \<in> path_component_set S x"
   proof (rule ccontr)
     assume "\<not> ?thesis"
-    moreover have "path_component_set s x \<inter> s \<noteq> {}"
-      using \<open>x \<in> s\<close> path_component_eq_empty path_component_subset[of s x]
+    moreover have "path_component_set S x \<inter> S \<noteq> {}"
+      using \<open>x \<in> S\<close> path_component_eq_empty path_component_subset[of S x]
       by auto
     ultimately
     show False
-      using \<open>y \<in> s\<close> open_non_path_component[OF assms(1)] open_path_component[OF assms(1)]
+      using \<open>y \<in> S\<close> open_non_path_component[OF assms(1)] open_path_component[OF assms(1)]
       using assms(2)[unfolded connected_def not_ex, rule_format,
-        of "path_component_set s x" "s - path_component_set s x"]
+        of "path_component_set S x" "S - path_component_set S x"]
       by auto
   qed
 qed
 
 lemma path_connected_continuous_image:
-  assumes "continuous_on s f"
-    and "path_connected s"
-  shows "path_connected (f ` s)"
+  assumes "continuous_on S f"
+    and "path_connected S"
+  shows "path_connected (f ` S)"
   unfolding path_connected_def
 proof (rule, rule)
   fix x' y'
-  assume "x' \<in> f ` s" "y' \<in> f ` s"
-  then obtain x y where x: "x \<in> s" and y: "y \<in> s" and x': "x' = f x" and y': "y' = f y"
+  assume "x' \<in> f ` S" "y' \<in> f ` S"
+  then obtain x y where x: "x \<in> S" and y: "y \<in> S" and x': "x' = f x" and y': "y' = f y"
     by auto
-  from x y obtain g where "path g \<and> path_image g \<subseteq> s \<and> pathstart g = x \<and> pathfinish g = y"
+  from x y obtain g where "path g \<and> path_image g \<subseteq> S \<and> pathstart g = x \<and> pathfinish g = y"
     using assms(2)[unfolded path_connected_def] by fast
-  then show "\<exists>g. path g \<and> path_image g \<subseteq> f ` s \<and> pathstart g = x' \<and> pathfinish g = y'"
+  then show "\<exists>g. path g \<and> path_image g \<subseteq> f ` S \<and> pathstart g = x' \<and> pathfinish g = y'"
     unfolding x' y'
     apply (rule_tac x="f \<circ> g" in exI)
     unfolding path_defs
@@ -1649,12 +1671,27 @@
     done
 qed
 
-lemma path_connected_segment:
+lemma path_connected_translationI:
+  fixes a :: "'a :: topological_group_add"
+  assumes "path_connected S" shows "path_connected ((\<lambda>x. a + x) ` S)"
+  by (intro path_connected_continuous_image assms continuous_intros)
+
+lemma path_connected_translation:
+  fixes a :: "'a :: topological_group_add"
+  shows "path_connected ((\<lambda>x. a + x) ` S) = path_connected S"
+proof -
+  have "\<forall>x y. op + (x::'a) ` op + (0 - x) ` y = y"
+    by (simp add: image_image)
+  then show ?thesis
+    by (metis (no_types) path_connected_translationI)
+qed
+
+lemma path_connected_segment [simp]:
     fixes a :: "'a::real_normed_vector"
     shows "path_connected (closed_segment a b)"
   by (simp add: convex_imp_path_connected)
 
-lemma path_connected_open_segment:
+lemma path_connected_open_segment [simp]:
     fixes a :: "'a::real_normed_vector"
     shows "path_connected (open_segment a b)"
   by (simp add: convex_imp_path_connected)
@@ -1663,10 +1700,10 @@
   "s homeomorphic t \<Longrightarrow> path_connected s \<longleftrightarrow> path_connected t"
   unfolding homeomorphic_def homeomorphism_def by (metis path_connected_continuous_image)
 
-lemma path_connected_empty: "path_connected {}"
+lemma path_connected_empty [simp]: "path_connected {}"
   unfolding path_connected_def by auto
 
-lemma path_connected_singleton: "path_connected {a}"
+lemma path_connected_singleton [simp]: "path_connected {a}"
   unfolding path_connected_def pathstart_def pathfinish_def path_image_def
   apply clarify
   apply (rule_tac x="\<lambda>x. a" in exI)
@@ -1743,7 +1780,7 @@
   unfolding path_connected_component
   by (meson path_component_path_image_pathstart path_component_sym path_component_trans)
 
-lemma path_connected_path_component:
+lemma path_connected_path_component [simp]:
    "path_connected (path_component_set s x)"
 proof -
   { fix y z
@@ -1973,54 +2010,46 @@
   by (simp add: path_connected_punctured_universe path_connected_imp_connected)
 
 lemma path_connected_sphere:
-  assumes "2 \<le> DIM('a::euclidean_space)"
-  shows "path_connected {x::'a. norm (x - a) = r}"
-proof (rule linorder_cases [of r 0])
-  assume "r < 0"
-  then have "{x::'a. norm(x - a) = r} = {}"
-    by auto
+  fixes a :: "'a :: euclidean_space"
+  assumes "2 \<le> DIM('a)"
+  shows "path_connected(sphere a r)"
+proof (cases r "0::real" rule: linorder_cases)
+  case less
   then show ?thesis
-    using path_connected_empty by simp
+    by (simp add: path_connected_empty)
 next
-  assume "r = 0"
+  case equal
   then show ?thesis
-    using path_connected_singleton by simp
+    by (simp add: path_connected_singleton)
 next
-  assume r: "0 < r"
-  have *: "{x::'a. norm(x - a) = r} = (\<lambda>x. a + r *\<^sub>R x) ` {x. norm x = 1}"
-    apply (rule set_eqI)
-    apply rule
-    unfolding image_iff
-    apply (rule_tac x="(1/r) *\<^sub>R (x - a)" in bexI)
-    unfolding mem_Collect_eq norm_scaleR
-    using r
-    apply (auto simp add: scaleR_right_diff_distrib)
-    done
-  have **: "{x::'a. norm x = 1} = (\<lambda>x. (1/norm x) *\<^sub>R x) ` (- {0})"
-    apply (rule set_eqI)
-    apply rule
-    unfolding image_iff
-    apply (rule_tac x=x in bexI)
-    unfolding mem_Collect_eq
-    apply (auto split: if_split_asm)
-    done
-  have "continuous_on (- {0}) (\<lambda>x::'a. 1 / norm x)"
-    by (auto intro!: continuous_intros)
+  case greater
+  then have eq: "(sphere (0::'a) r) = (\<lambda>x. (r / norm x) *\<^sub>R x) ` (- {0::'a})"
+    by (force simp: image_iff split: if_split_asm)
+  have "continuous_on (- {0::'a}) (\<lambda>x. (r / norm x) *\<^sub>R x)"
+    by (intro continuous_intros) auto
+  then have "path_connected ((\<lambda>x. (r / norm x) *\<^sub>R x) ` (- {0::'a}))"
+    by (intro path_connected_continuous_image path_connected_punctured_universe assms)
+  with eq have "path_connected (sphere (0::'a) r)"
+    by auto
+  then have "path_connected(op +a ` (sphere (0::'a) r))"
+    by (simp add: path_connected_translation)
   then show ?thesis
-    unfolding * **
-    using path_connected_punctured_universe[OF assms]
-    by (auto intro!: path_connected_continuous_image continuous_intros)
-qed
-
-corollary connected_sphere: "2 \<le> DIM('a::euclidean_space) \<Longrightarrow> connected {x::'a. norm (x - a) = r}"
-  using path_connected_sphere path_connected_imp_connected
-  by auto
+    by (metis add.right_neutral sphere_translation)
+qed
+
+lemma connected_sphere:
+    fixes a :: "'a :: euclidean_space"
+    assumes "2 \<le> DIM('a)"
+      shows "connected(sphere a r)"
+  using path_connected_sphere [OF assms]
+  by (simp add: path_connected_imp_connected)
+
 
 corollary path_connected_complement_bounded_convex:
     fixes s :: "'a :: euclidean_space set"
     assumes "bounded s" "convex s" and 2: "2 \<le> DIM('a)"
     shows "path_connected (- s)"
-proof (cases "s={}")
+proof (cases "s = {}")
   case True then show ?thesis
     using convex_imp_path_connected by auto
 next
@@ -2104,11 +2133,11 @@
     then have pdy: "path_component (- s) y (a + D *\<^sub>R (y - a))"
       by (force simp: closed_segment_def intro!: path_connected_linepath)
     have pyx: "path_component (- s) (a + D *\<^sub>R (y - a)) (a + C *\<^sub>R (x - a))"
-      apply (rule path_component_of_subset [of "{x. norm(x - a) = B}"])
+      apply (rule path_component_of_subset [of "sphere a B"])
        using \<open>s \<subseteq> ball a B\<close>
        apply (force simp: ball_def dist_norm norm_minus_commute)
       apply (rule path_connected_sphere [OF 2, of a B, simplified path_connected_component, rule_format])
-      using \<open>x \<noteq> a\<close>  using \<open>y \<noteq> a\<close>  B apply (auto simp: C_def D_def)
+       using \<open>x \<noteq> a\<close>  using \<open>y \<noteq> a\<close>  B apply (auto simp: dist_norm C_def D_def)
       done
     have "path_component (- s) x y"
       by (metis path_component_trans path_component_sym pcx pdy pyx)
@@ -2193,6 +2222,52 @@
   thus ?case by (metis Diff_insert)
 qed
 
+lemma sphere_1D_doubleton_zero:
+  assumes 1: "DIM('a) = 1" and "r > 0"
+  obtains x y::"'a::euclidean_space"
+    where "sphere 0 r = {x,y} \<and> dist x y = 2*r"
+proof -
+  obtain b::'a where b: "Basis = {b}"
+    using 1 card_1_singletonE by blast
+  show ?thesis
+  proof (intro that conjI)
+    have "x = norm x *\<^sub>R b \<or> x = - norm x *\<^sub>R b" if "r = norm x" for x
+    proof -
+      have xb: "(x \<bullet> b) *\<^sub>R b = x"
+        using euclidean_representation [of x, unfolded b] by force
+      then have "norm ((x \<bullet> b) *\<^sub>R b) = norm x"
+        by simp
+      with b have "\<bar>x \<bullet> b\<bar> = norm x"
+        using norm_Basis by fastforce
+      with xb show ?thesis
+        apply (simp add: abs_if split: if_split_asm)
+        apply (metis add.inverse_inverse real_vector.scale_minus_left xb)
+        done
+    qed
+    with \<open>r > 0\<close> b show "sphere 0 r = {r *\<^sub>R b, - r *\<^sub>R b}"
+      by (force simp: sphere_def dist_norm)
+    have "dist (r *\<^sub>R b) (- r *\<^sub>R b) = norm (r *\<^sub>R b + r *\<^sub>R b)"
+      by (simp add: dist_norm)
+    also have "... = norm ((2*r) *\<^sub>R b)"
+      by (metis mult_2 scaleR_add_left)
+    also have "... = 2*r"
+      using \<open>r > 0\<close> b norm_Basis by fastforce
+    finally show "dist (r *\<^sub>R b) (- r *\<^sub>R b) = 2*r" .
+  qed
+qed
+
+lemma sphere_1D_doubleton:
+  fixes a :: "'a :: euclidean_space"
+  assumes "DIM('a) = 1" and "r > 0"
+  obtains x y where "sphere a r = {x,y} \<and> dist x y = 2*r"
+proof -
+  have "sphere a r = op +a ` sphere 0 r"
+    by (metis add.right_neutral sphere_translation)
+  then show ?thesis
+    using sphere_1D_doubleton_zero [OF assms]
+    by (metis (mono_tags, lifting) dist_add_cancel image_empty image_insert that)
+qed
+
 lemma psubset_sphere_Compl_connected:
   fixes S :: "'a::euclidean_space set"
   assumes S: "S \<subset> sphere a r" and "0 < r" and 2: "2 \<le> DIM('a)"
@@ -2219,6 +2294,7 @@
     by (simp add: CS connected_Un)
 qed
 
+
 subsection\<open>Relations between components and path components\<close>
 
 lemma open_connected_component:
@@ -2590,20 +2666,6 @@
 by (metis bounded_subset [of "connected_component_set (- s) _"] connected_component_maximal
        Compl_iff Un_iff assms subsetI)
 
-lemma frontier_interiors: "frontier s = - interior(s) - interior(-s)"
-  by (simp add: Int_commute frontier_def interior_closure)
-
-lemma frontier_interior_subset: "frontier(interior S) \<subseteq> frontier S"
-  by (simp add: Diff_mono frontier_interiors interior_mono interior_subset)
-
-lemma connected_Int_frontier:
-     "\<lbrakk>connected s; s \<inter> t \<noteq> {}; s - t \<noteq> {}\<rbrakk> \<Longrightarrow> (s \<inter> frontier t \<noteq> {})"
-  apply (simp add: frontier_interiors connected_openin, safe)
-  apply (drule_tac x="s \<inter> interior t" in spec, safe)
-   apply (drule_tac [2] x="s \<inter> interior (-t)" in spec)
-   apply (auto simp: disjoint_eq_subset_Compl dest: interior_subset [THEN subsetD])
-  done
-
 lemma frontier_not_empty:
   fixes S :: "'a :: real_normed_vector set"
   shows "\<lbrakk>S \<noteq> {}; S \<noteq> UNIV\<rbrakk> \<Longrightarrow> frontier S \<noteq> {}"
@@ -2735,7 +2797,7 @@
     shows "connected_component_set s x = UNIV \<longleftrightarrow> s = UNIV"
   using connected_component_in connected_component_UNIV by blast
 
-lemma components_univ [simp]: "components UNIV = {UNIV :: 'a::real_normed_vector set}"
+lemma components_UNIV [simp]: "components UNIV = {UNIV :: 'a::real_normed_vector set}"
   by (auto simp: components_eq_sing_iff)
 
 lemma interior_inside_frontier:
@@ -2837,6 +2899,26 @@
   shows "\<lbrakk>convex t; s \<subseteq> t\<rbrakk> \<Longrightarrow> - t \<subseteq> outside s"
   using outside_convex outside_mono by blast
 
+lemma outside_Un_outside_Un:
+  fixes S :: "'a::real_normed_vector set"
+  assumes "S \<inter> outside(T \<union> U) = {}"
+  shows "outside(T \<union> U) \<subseteq> outside(T \<union> S)"
+proof
+  fix x
+  assume x: "x \<in> outside (T \<union> U)"
+  have "Y \<subseteq> - S" if "connected Y" "Y \<subseteq> - T" "Y \<subseteq> - U" "x \<in> Y" "u \<in> Y" for u Y
+  proof -
+    have "Y \<subseteq> connected_component_set (- (T \<union> U)) x"
+      by (simp add: connected_component_maximal that)
+    also have "... \<subseteq> outside(T \<union> U)"
+      by (metis (mono_tags, lifting) Collect_mono mem_Collect_eq outside outside_same_component x)
+    finally have "Y \<subseteq> outside(T \<union> U)" .
+    with assms show ?thesis by auto
+  qed
+  with x show "x \<in> outside (T \<union> S)"
+    by (simp add: outside_connected_component_lt connected_component_def) meson
+qed
+
 lemma outside_frontier_misses_closure:
     fixes s :: "'a::real_normed_vector set"
     assumes "bounded s"
@@ -3560,6 +3642,56 @@
   by (metis homotopic_compose_continuous_right homotopic_with_imp_continuous homotopic_with_imp_subset2)
 
 
+text\<open>Homotopic triviality implicitly incorporates path-connectedness.\<close>
+lemma homotopic_triviality:
+  fixes S :: "'a::real_normed_vector set"
+  shows  "(\<forall>f g. continuous_on S f \<and> f ` S \<subseteq> T \<and>
+                 continuous_on S g \<and> g ` S \<subseteq> T
+                 \<longrightarrow> homotopic_with (\<lambda>x. True) S T f g) \<longleftrightarrow>
+          (S = {} \<or> path_connected T) \<and>
+          (\<forall>f. continuous_on S f \<and> f ` S \<subseteq> T \<longrightarrow> (\<exists>c. homotopic_with (\<lambda>x. True) S T f (\<lambda>x. c)))"
+          (is "?lhs = ?rhs")
+proof (cases "S = {} \<or> T = {}")
+  case True then show ?thesis by auto
+next
+  case False show ?thesis
+  proof
+    assume LHS [rule_format]: ?lhs
+    have pab: "path_component T a b" if "a \<in> T" "b \<in> T" for a b
+    proof -
+      have "homotopic_with (\<lambda>x. True) S T (\<lambda>x. a) (\<lambda>x. b)"
+        by (simp add: LHS continuous_on_const image_subset_iff that)
+      then show ?thesis
+        using False homotopic_constant_maps by blast
+    qed
+      moreover
+    have "\<exists>c. homotopic_with (\<lambda>x. True) S T f (\<lambda>x. c)" if "continuous_on S f" "f ` S \<subseteq> T" for f
+      by (metis (full_types) False LHS equals0I homotopic_constant_maps homotopic_with_imp_continuous homotopic_with_imp_subset2 pab that)
+    ultimately show ?rhs
+      by (simp add: path_connected_component)
+  next
+    assume RHS: ?rhs
+    with False have T: "path_connected T"
+      by blast
+    show ?lhs
+    proof clarify
+      fix f g
+      assume "continuous_on S f" "f ` S \<subseteq> T" "continuous_on S g" "g ` S \<subseteq> T"
+      obtain c d where c: "homotopic_with (\<lambda>x. True) S T f (\<lambda>x. c)" and d: "homotopic_with (\<lambda>x. True) S T g (\<lambda>x. d)"
+        using False \<open>continuous_on S f\<close> \<open>f ` S \<subseteq> T\<close>  RHS \<open>continuous_on S g\<close> \<open>g ` S \<subseteq> T\<close> by blast
+      then have "c \<in> T" "d \<in> T"
+        using False homotopic_with_imp_subset2 by fastforce+
+      with T have "path_component T c d"
+        using path_connected_component by blast
+      then have "homotopic_with (\<lambda>x. True) S T (\<lambda>x. c) (\<lambda>x. d)"
+        by (simp add: homotopic_constant_maps)
+      with c d show "homotopic_with (\<lambda>x. True) S T f g"
+        by (meson homotopic_with_symD homotopic_with_trans)
+    qed
+  qed
+qed
+
+
 subsection\<open>Homotopy of paths, maintaining the same endpoints.\<close>
 
 
@@ -4519,7 +4651,7 @@
   shows "starlike S \<Longrightarrow> contractible S"
 using starlike_imp_contractible_gen contractible_def by (fastforce simp: id_def)
 
-lemma contractible_UNIV: "contractible (UNIV :: 'a::real_normed_vector set)"
+lemma contractible_UNIV [simp]: "contractible (UNIV :: 'a::real_normed_vector set)"
   by (simp add: starlike_imp_contractible)
 
 lemma starlike_imp_simply_connected:
@@ -4547,8 +4679,8 @@
   shows "is_interval S \<longleftrightarrow> simply_connected S"
 using convex_imp_simply_connected is_interval_convex_1 is_interval_path_connected_1 simply_connected_imp_path_connected by auto
 
-lemma contractible_empty: "contractible {}"
-  by (simp add: continuous_on_empty contractible_def homotopic_with)
+lemma contractible_empty [simp]: "contractible {}"
+  by (simp add: contractible_def homotopic_with)
 
 lemma contractible_convex_tweak_boundary_points:
   fixes S :: "'a::euclidean_space set"
@@ -4557,7 +4689,7 @@
 proof (cases "S = {}")
   case True
   with assms show ?thesis
-    by (simp add: contractible_empty subsetCE)
+    by (simp add: subsetCE)
 next
   case False
   show ?thesis
@@ -4569,9 +4701,9 @@
 lemma convex_imp_contractible:
   fixes S :: "'a::real_normed_vector set"
   shows "convex S \<Longrightarrow> contractible S"
-using contractible_empty convex_imp_starlike starlike_imp_contractible by auto
-
-lemma contractible_sing:
+  using contractible_empty convex_imp_starlike starlike_imp_contractible by blast
+
+lemma contractible_sing [simp]:
   fixes a :: "'a::real_normed_vector"
   shows "contractible {a}"
 by (rule convex_imp_contractible [OF convex_singleton])
@@ -4705,6 +4837,28 @@
 apply (auto intro: P)
 done
 
+lemma locally_Times:
+  fixes S :: "('a::metric_space) set" and T :: "('b::metric_space) set"
+  assumes PS: "locally P S" and QT: "locally Q T" and R: "\<And>S T. P S \<and> Q T \<Longrightarrow> R(S \<times> T)"
+  shows "locally R (S \<times> T)"
+    unfolding locally_def
+proof (clarify)
+  fix W x y
+  assume W: "openin (subtopology euclidean (S \<times> T)) W" and xy: "(x, y) \<in> W"
+  then obtain U V where "openin (subtopology euclidean S) U" "x \<in> U"
+                        "openin (subtopology euclidean T) V" "y \<in> V" "U \<times> V \<subseteq> W"
+    using Times_in_interior_subtopology by metis
+  then obtain U1 U2 V1 V2
+         where opeS: "openin (subtopology euclidean S) U1 \<and> P U2 \<and> x \<in> U1 \<and> U1 \<subseteq> U2 \<and> U2 \<subseteq> U"
+           and opeT: "openin (subtopology euclidean T) V1 \<and> Q V2 \<and> y \<in> V1 \<and> V1 \<subseteq> V2 \<and> V2 \<subseteq> V"
+    by (meson PS QT locallyE)
+  with \<open>U \<times> V \<subseteq> W\<close> show "\<exists>u v. openin (subtopology euclidean (S \<times> T)) u \<and> R v \<and> (x,y) \<in> u \<and> u \<subseteq> v \<and> v \<subseteq> W"
+    apply (rule_tac x="U1 \<times> V1" in exI)
+    apply (rule_tac x="U2 \<times> V2" in exI)
+    apply (auto simp: openin_Times R)
+    done
+qed
+
 
 proposition homeomorphism_locally_imp:
   fixes S :: "'a::metric_space set" and t :: "'b::t2_space set"
@@ -5148,6 +5302,106 @@
     using compact_eq_bounded_closed locally_mono by blast
 qed
 
+lemma locally_compact_openin_Un:
+  fixes S :: "'a::euclidean_space set"
+  assumes LCS: "locally compact S" and LCT:"locally compact T"
+      and opS: "openin (subtopology euclidean (S \<union> T)) S"
+      and opT: "openin (subtopology euclidean (S \<union> T)) T"
+    shows "locally compact (S \<union> T)"
+proof -
+  have "\<exists>e>0. closed (cball x e \<inter> (S \<union> T))" if "x \<in> S" for x
+  proof -
+    obtain e1 where "e1 > 0" and e1: "closed (cball x e1 \<inter> S)"
+      using LCS \<open>x \<in> S\<close> unfolding locally_compact_Int_cball by blast
+    moreover obtain e2 where "e2 > 0" and e2: "cball x e2 \<inter> (S \<union> T) \<subseteq> S"
+      by (meson \<open>x \<in> S\<close> opS openin_contains_cball)
+    then have "cball x e2 \<inter> (S \<union> T) = cball x e2 \<inter> S"
+      by force
+    ultimately show ?thesis
+      apply (rule_tac x="min e1 e2" in exI)
+      apply (auto simp: cball_min_Int \<open>e2 > 0\<close> inf_assoc closed_Int)
+      by (metis closed_Int closed_cball inf_left_commute)
+  qed
+  moreover have "\<exists>e>0. closed (cball x e \<inter> (S \<union> T))" if "x \<in> T" for x
+  proof -
+    obtain e1 where "e1 > 0" and e1: "closed (cball x e1 \<inter> T)"
+      using LCT \<open>x \<in> T\<close> unfolding locally_compact_Int_cball by blast
+    moreover obtain e2 where "e2 > 0" and e2: "cball x e2 \<inter> (S \<union> T) \<subseteq> T"
+      by (meson \<open>x \<in> T\<close> opT openin_contains_cball)
+    then have "cball x e2 \<inter> (S \<union> T) = cball x e2 \<inter> T"
+      by force
+    ultimately show ?thesis
+      apply (rule_tac x="min e1 e2" in exI)
+      apply (auto simp: cball_min_Int \<open>e2 > 0\<close> inf_assoc closed_Int)
+      by (metis closed_Int closed_cball inf_left_commute)
+  qed
+  ultimately show ?thesis
+    by (force simp: locally_compact_Int_cball)
+qed
+
+lemma locally_compact_closedin_Un:
+  fixes S :: "'a::euclidean_space set"
+  assumes LCS: "locally compact S" and LCT:"locally compact T"
+      and clS: "closedin (subtopology euclidean (S \<union> T)) S"
+      and clT: "closedin (subtopology euclidean (S \<union> T)) T"
+    shows "locally compact (S \<union> T)"
+proof -
+  have "\<exists>e>0. closed (cball x e \<inter> (S \<union> T))" if "x \<in> S" "x \<in> T" for x
+  proof -
+    obtain e1 where "e1 > 0" and e1: "closed (cball x e1 \<inter> S)"
+      using LCS \<open>x \<in> S\<close> unfolding locally_compact_Int_cball by blast
+    moreover
+    obtain e2 where "e2 > 0" and e2: "closed (cball x e2 \<inter> T)"
+      using LCT \<open>x \<in> T\<close> unfolding locally_compact_Int_cball by blast
+    ultimately show ?thesis
+      apply (rule_tac x="min e1 e2" in exI)
+      apply (auto simp: cball_min_Int \<open>e2 > 0\<close> inf_assoc closed_Int Int_Un_distrib)
+      by (metis closed_Int closed_Un closed_cball inf_left_commute)
+  qed
+  moreover
+  have "\<exists>e>0. closed (cball x e \<inter> (S \<union> T))" if x: "x \<in> S" "x \<notin> T" for x
+  proof -
+    obtain e1 where "e1 > 0" and e1: "closed (cball x e1 \<inter> S)"
+      using LCS \<open>x \<in> S\<close> unfolding locally_compact_Int_cball by blast
+    moreover
+    obtain e2 where "e2>0" and "cball x e2 \<inter> (S \<union> T) \<subseteq> S - T"
+      using clT x by (fastforce simp: openin_contains_cball closedin_def)
+    then have "closed (cball x e2 \<inter> T)"
+    proof -
+      have "{} = T - (T - cball x e2)"
+        using Diff_subset Int_Diff \<open>cball x e2 \<inter> (S \<union> T) \<subseteq> S - T\<close> by auto
+      then show ?thesis
+        by (simp add: Diff_Diff_Int inf_commute)
+    qed
+    ultimately show ?thesis
+      apply (rule_tac x="min e1 e2" in exI)
+      apply (auto simp: cball_min_Int \<open>e2 > 0\<close> inf_assoc closed_Int Int_Un_distrib)
+      by (metis closed_Int closed_Un closed_cball inf_left_commute)
+  qed
+  moreover
+  have "\<exists>e>0. closed (cball x e \<inter> (S \<union> T))" if x: "x \<notin> S" "x \<in> T" for x
+  proof -
+    obtain e1 where "e1 > 0" and e1: "closed (cball x e1 \<inter> T)"
+      using LCT \<open>x \<in> T\<close> unfolding locally_compact_Int_cball by blast
+    moreover
+    obtain e2 where "e2>0" and "cball x e2 \<inter> (S \<union> T) \<subseteq> S \<union> T - S"
+      using clS x by (fastforce simp: openin_contains_cball closedin_def)
+    then have "closed (cball x e2 \<inter> S)"
+      by (metis Diff_disjoint Int_empty_right closed_empty inf.left_commute inf.orderE inf_sup_absorb)
+    ultimately show ?thesis
+      apply (rule_tac x="min e1 e2" in exI)
+      apply (auto simp: cball_min_Int \<open>e2 > 0\<close> inf_assoc closed_Int Int_Un_distrib)
+      by (metis closed_Int closed_Un closed_cball inf_left_commute)
+  qed
+  ultimately show ?thesis
+    by (auto simp: locally_compact_Int_cball)
+qed
+
+lemma locally_compact_Times:
+  fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
+  shows "\<lbrakk>locally compact S; locally compact T\<rbrakk> \<Longrightarrow> locally compact (S \<times> T)"
+  by (auto simp: compact_Times locally_Times)
+
 subsection\<open>Important special cases of local connectedness and path connectedness\<close>
 
 lemma locally_connected_1:
@@ -6519,6 +6773,64 @@
     by (meson pwd countable_image_inj_on disjoint_image f inj_on_image pairwise_disjnt_countable)
 qed
 
+lemma connected_uncountable:
+  fixes S :: "'a::metric_space set"
+  assumes "connected S" "a \<in> S" "b \<in> S" "a \<noteq> b" shows "uncountable S"
+proof -
+  have "continuous_on S (dist a)"
+    by (intro continuous_intros)
+  then have "connected (dist a ` S)"
+    by (metis connected_continuous_image \<open>connected S\<close>)
+  then have "closed_segment 0 (dist a b) \<subseteq> (dist a ` S)"
+    by (simp add: assms closed_segment_subset is_interval_connected_1 is_interval_convex)
+  then have "uncountable (dist a ` S)"
+    by (metis \<open>a \<noteq> b\<close> countable_subset dist_eq_0_iff uncountable_closed_segment)
+  then show ?thesis
+    by blast
+qed
+
+lemma path_connected_uncountable:
+  fixes S :: "'a::metric_space set"
+  assumes "path_connected S" "a \<in> S" "b \<in> S" "a \<noteq> b" shows "uncountable S"
+  using path_connected_imp_connected assms connected_uncountable by metis
+
+lemma connected_finite_iff_sing:
+  fixes S :: "'a::metric_space set"
+  assumes "connected S"
+  shows "finite S \<longleftrightarrow> S = {} \<or> (\<exists>a. S = {a})"  (is "_ = ?rhs")
+proof -
+  have "uncountable S" if "\<not> ?rhs"
+    using connected_uncountable assms that by blast
+  then show ?thesis
+    using uncountable_infinite by auto
+qed
+
+lemma connected_card_eq_iff_nontrivial:
+  fixes S :: "'a::metric_space set"
+  shows "connected S \<Longrightarrow> uncountable S \<longleftrightarrow> ~(\<exists>a. S \<subseteq> {a})"
+  apply (auto simp: countable_finite finite_subset)
+  by (metis connected_uncountable is_singletonI' is_singleton_the_elem subset_singleton_iff)
+
+lemma simple_path_image_uncountable:
+  fixes g :: "real \<Rightarrow> 'a::metric_space"
+  assumes "simple_path g"
+  shows "uncountable (path_image g)"
+proof -
+  have "g 0 \<in> path_image g" "g (1/2) \<in> path_image g"
+    by (simp_all add: path_defs)
+  moreover have "g 0 \<noteq> g (1/2)"
+    using assms by (fastforce simp add: simple_path_def)
+  ultimately show ?thesis
+    apply (simp add: assms connected_card_eq_iff_nontrivial connected_simple_path_image)
+    by blast
+qed
+
+lemma arc_image_uncountable:
+  fixes g :: "real \<Rightarrow> 'a::metric_space"
+  assumes "arc g"
+  shows "uncountable (path_image g)"
+  by (simp add: arc_imp_simple_path assms simple_path_image_uncountable)
+
 
 subsection\<open> Some simple positive connection theorems\<close>
 
diff -r 81a5473e6d04 -r a0e1f64be67c src/HOL/Analysis/Topology_Euclidean_Space.thy
--- a/src/HOL/Analysis/Topology_Euclidean_Space.thy	Thu Jan 05 22:37:52 2017 +0100
+++ b/src/HOL/Analysis/Topology_Euclidean_Space.thy	Thu Jan 05 22:38:06 2017 +0100
@@ -15,24 +15,6 @@
   Norm_Arith
 begin
 
-(* FIXME: move to HOL/Real_Vector_Spaces.thy *)
-
-lemma scaleR_2:
-  fixes x :: "'a::real_vector"
-  shows "scaleR 2 x = x + x"
-  unfolding one_add_one [symmetric] scaleR_left_distrib by simp
-
-lemma scaleR_half_double [simp]:
-  fixes a :: "'a::real_normed_vector"
-  shows "(1 / 2) *\<^sub>R (a + a) = a"
-proof -
-  have "\<And>r. r *\<^sub>R (a + a) = (r * 2) *\<^sub>R a"
-    by (metis scaleR_2 scaleR_scaleR)
-  then show ?thesis
-    by simp
-qed
-
-
 (* FIXME: move elsewhere *)
 
 lemma Times_eq_image_sum:
@@ -894,6 +876,11 @@
 lemma closed_subset: "S \<subseteq> T \<Longrightarrow> closed S \<Longrightarrow> closedin (subtopology euclidean T) S"
   by (auto simp add: closedin_closed)
 
+lemma closedin_closed_subset:
+ "\<lbrakk>closedin (subtopology euclidean U) V; T \<subseteq> U; S = V \<inter> T\<rbrakk>
+             \<Longrightarrow> closedin (subtopology euclidean T) S"
+  by (metis (no_types, lifting) Int_assoc Int_commute closedin_closed inf.orderE)
+
 lemma finite_imp_closedin:
   fixes S :: "'a::t1_space set"
   shows "\<lbrakk>finite S; S \<subseteq> T\<rbrakk> \<Longrightarrow> closedin (subtopology euclidean T) S"
@@ -1099,7 +1086,7 @@
 lemma cball_min_Int: "cball a (min r s) = cball a r \<inter> cball a s"
   by (simp add: set_eq_iff)
 
-lemma cball_diff_eq_sphere: "cball a r - ball a r =  {x. dist x a = r}"
+lemma cball_diff_eq_sphere: "cball a r - ball a r =  sphere a r"
   by (auto simp: cball_def ball_def dist_commute)
 
 lemma image_add_ball [simp]:
@@ -2744,6 +2731,28 @@
 lemma frontier_UNIV [simp]: "frontier UNIV = {}"
   using frontier_complement frontier_empty by fastforce
 
+lemma frontier_interiors: "frontier s = - interior(s) - interior(-s)"
+  by (simp add: Int_commute frontier_def interior_closure)
+
+lemma frontier_interior_subset: "frontier(interior S) \<subseteq> frontier S"
+  by (simp add: Diff_mono frontier_interiors interior_mono interior_subset)
+
+lemma connected_Int_frontier:
+     "\<lbrakk>connected s; s \<inter> t \<noteq> {}; s - t \<noteq> {}\<rbrakk> \<Longrightarrow> (s \<inter> frontier t \<noteq> {})"
+  apply (simp add: frontier_interiors connected_openin, safe)
+  apply (drule_tac x="s \<inter> interior t" in spec, safe)
+   apply (drule_tac [2] x="s \<inter> interior (-t)" in spec)
+   apply (auto simp: disjoint_eq_subset_Compl dest: interior_subset [THEN subsetD])
+  done
+
+lemma closure_Un_frontier: "closure S = S \<union> frontier S"
+proof -
+  have "S \<union> interior S = S"
+    using interior_subset by auto
+  then show ?thesis
+    using closure_subset by (auto simp: frontier_def)
+qed
+
 
 subsection \<open>Filters and the ``eventually true'' quantifier\<close>
 
diff -r 81a5473e6d04 -r a0e1f64be67c src/HOL/Library/Polynomial.thy
--- a/src/HOL/Library/Polynomial.thy	Thu Jan 05 22:37:52 2017 +0100
+++ b/src/HOL/Library/Polynomial.thy	Thu Jan 05 22:38:06 2017 +0100
@@ -12,6 +12,21 @@
   "~~/src/HOL/Library/Infinite_Set"
 begin
 
+subsection \<open>Misc\<close>
+
+lemma quotient_of_denom_pos': "snd (quotient_of x) > 0"
+  using quotient_of_denom_pos [OF surjective_pairing] .
+  
+lemma of_int_divide_in_Ints: 
+  "b dvd a \<Longrightarrow> of_int a div of_int b \<in> (\<int> :: 'a :: idom_divide set)"
+proof (cases "of_int b = (0 :: 'a)")
+  case False
+  assume "b dvd a"
+  then obtain c where "a = b * c" ..
+  with \<open>of_int b \<noteq> (0::'a)\<close> show ?thesis by simp
+qed auto
+
+  
 subsection \<open>Auxiliary: operations for lists (later) representing coefficients\<close>
 
 definition cCons :: "'a::zero \<Rightarrow> 'a list \<Rightarrow> 'a list"  (infixr "##" 65)
@@ -143,6 +158,33 @@
   "coeff p (degree p) = 0 \<longleftrightarrow> p = 0"
   by (cases "p = 0", simp, simp add: leading_coeff_neq_0)
 
+lemma eq_zero_or_degree_less:
+  assumes "degree p \<le> n" and "coeff p n = 0"
+  shows "p = 0 \<or> degree p < n"
+proof (cases n)
+  case 0
+  with \<open>degree p \<le> n\<close> and \<open>coeff p n = 0\<close>
+  have "coeff p (degree p) = 0" by simp
+  then have "p = 0" by simp
+  then show ?thesis ..
+next
+  case (Suc m)
+  have "\<forall>i>n. coeff p i = 0"
+    using \<open>degree p \<le> n\<close> by (simp add: coeff_eq_0)
+  then have "\<forall>i\<ge>n. coeff p i = 0"
+    using \<open>coeff p n = 0\<close> by (simp add: le_less)
+  then have "\<forall>i>m. coeff p i = 0"
+    using \<open>n = Suc m\<close> by (simp add: less_eq_Suc_le)
+  then have "degree p \<le> m"
+    by (rule degree_le)
+  then have "degree p < n"
+    using \<open>n = Suc m\<close> by (simp add: less_Suc_eq_le)
+  then show ?thesis ..
+qed
+
+lemma coeff_0_degree_minus_1: "coeff rrr dr = 0 \<Longrightarrow> degree rrr \<le> dr \<Longrightarrow> degree rrr \<le> dr - 1"
+  using eq_zero_or_degree_less by fastforce
+
 
 subsection \<open>List-style constructor for polynomials\<close>
 
@@ -481,6 +523,7 @@
   "p \<noteq> 0 \<Longrightarrow> fold_coeffs f (pCons a p) = f a \<circ> fold_coeffs f p"
   by (simp add: fold_coeffs_def)
 
+
 subsection \<open>Canonical morphism on polynomials -- evaluation\<close>
 
 definition poly :: "'a::comm_semiring_0 poly \<Rightarrow> 'a \<Rightarrow> 'a"
@@ -572,8 +615,22 @@
   
 lemma monom_eq_const_iff: "monom c n = [:d:] \<longleftrightarrow> c = d \<and> (c = 0 \<or> n = 0)"
   using monom_eq_iff'[of c n d 0] by (simp add: monom_0)
-  
-    
+
+
+subsection \<open>Leading coefficient\<close>
+
+abbreviation lead_coeff:: "'a::zero poly \<Rightarrow> 'a"
+  where "lead_coeff p \<equiv> coeff p (degree p)"
+
+lemma lead_coeff_pCons[simp]:
+  "p \<noteq> 0 \<Longrightarrow> lead_coeff (pCons a p) = lead_coeff p"
+  "p = 0 \<Longrightarrow> lead_coeff (pCons a p) = a"
+  by auto
+
+lemma lead_coeff_monom [simp]: "lead_coeff (monom c n) = c"
+  by (cases "c = 0") (simp_all add: degree_monom_eq)
+
+
 subsection \<open>Addition and subtraction\<close>
 
 instantiation poly :: (comm_monoid_add) comm_monoid_add
@@ -694,6 +751,16 @@
   "degree (- p) = degree p"
   unfolding degree_def by simp
 
+lemma lead_coeff_add_le:
+  assumes "degree p < degree q"
+  shows "lead_coeff (p + q) = lead_coeff q" 
+  using assms
+  by (metis coeff_add coeff_eq_0 monoid_add_class.add.left_neutral degree_add_eq_right)
+
+lemma lead_coeff_minus:
+  "lead_coeff (- p) = - lead_coeff p"
+  by (metis coeff_minus degree_minus)
+
 lemma degree_diff_le_max:
   fixes p q :: "'a :: ab_group_add poly"
   shows "degree (p - q) \<le> max (degree p) (degree q)"
@@ -894,7 +961,16 @@
   shows "coeffs (smult a p) = (if a = 0 then [] else map (Groups.times a) (coeffs p))"
   by (rule coeffs_eqI)
     (auto simp add: not_0_coeffs_not_Nil last_map last_coeffs_not_0 nth_default_map_eq nth_default_coeffs_eq)
-   
+
+lemma smult_eq_iff:
+  assumes "(b :: 'a :: field) \<noteq> 0"
+  shows   "smult a p = smult b q \<longleftrightarrow> smult (a / b) p = q"
+proof
+  assume "smult a p = smult b q"
+  also from assms have "smult (inverse b) \<dots> = q" by simp
+  finally show "smult (a / b) p = q" by (simp add: field_simps)
+qed (insert assms, auto)
+
 instantiation poly :: (comm_semiring_0) comm_semiring_0
 begin
 
@@ -1037,6 +1113,10 @@
   "degree (p ^ n) \<le> degree p * n"
   by (induct n) (auto intro: order_trans degree_mult_le)
 
+lemma coeff_0_power:
+  "coeff (p ^ n) 0 = coeff p 0 ^ n"
+  by (induction n) (simp_all add: coeff_mult)
+
 lemma poly_smult [simp]:
   "poly (smult a p) x = a * poly p x"
   by (induct p, simp, simp add: algebra_simps)
@@ -1064,6 +1144,40 @@
     by (rule le_trans[OF degree_mult_le], insert insert, auto)
 qed simp
 
+lemma coeff_0_prod_list:
+  "coeff (prod_list xs) 0 = prod_list (map (\<lambda>p. coeff p 0) xs)"
+  by (induction xs) (simp_all add: coeff_mult)
+
+lemma coeff_monom_mult: 
+  "coeff (monom c n * p) k = (if k < n then 0 else c * coeff p (k - n))"
+proof -
+  have "coeff (monom c n * p) k = (\<Sum>i\<le>k. (if n = i then c else 0) * coeff p (k - i))"
+    by (simp add: coeff_mult)
+  also have "\<dots> = (\<Sum>i\<le>k. (if n = i then c * coeff p (k - i) else 0))"
+    by (intro sum.cong) simp_all
+  also have "\<dots> = (if k < n then 0 else c * coeff p (k - n))" by (simp add: sum.delta')
+  finally show ?thesis .
+qed
+
+lemma monom_1_dvd_iff':
+  "monom 1 n dvd p \<longleftrightarrow> (\<forall>k<n. coeff p k = 0)"
+proof
+  assume "monom 1 n dvd p"
+  then obtain r where r: "p = monom 1 n * r" by (elim dvdE)
+  thus "\<forall>k<n. coeff p k = 0" by (simp add: coeff_mult)
+next
+  assume zero: "(\<forall>k<n. coeff p k = 0)"
+  define r where "r = Abs_poly (\<lambda>k. coeff p (k + n))"
+  have "\<forall>\<^sub>\<infinity>k. coeff p (k + n) = 0"
+    by (subst cofinite_eq_sequentially, subst eventually_sequentially_seg, 
+        subst cofinite_eq_sequentially [symmetric]) transfer
+  hence coeff_r [simp]: "coeff r k = coeff p (k + n)" for k unfolding r_def
+    by (subst poly.Abs_poly_inverse) simp_all
+  have "p = monom 1 n * r"
+    by (intro poly_eqI, subst coeff_monom_mult) (insert zero, simp_all)
+  thus "monom 1 n dvd p" by simp
+qed
+
 
 subsection \<open>Mapping polynomials\<close>
 
@@ -1169,7 +1283,7 @@
   by (intro poly_eqI) (simp_all add: coeff_map_poly)
 
 
-subsection \<open>Conversions from natural numbers\<close>
+subsection \<open>Conversions from @{typ nat} and @{typ int} numbers\<close>
 
 lemma of_nat_poly: "of_nat n = [:of_nat n :: 'a :: comm_semiring_1:]"
 proof (induction n)
@@ -1185,11 +1299,29 @@
 lemma degree_of_nat [simp]: "degree (of_nat n) = 0"
   by (simp add: of_nat_poly)
 
-lemma degree_numeral [simp]: "degree (numeral n) = 0"
-  by (subst of_nat_numeral [symmetric], subst of_nat_poly) simp
+lemma lead_coeff_of_nat [simp]:
+  "lead_coeff (of_nat n) = (of_nat n :: 'a :: {comm_semiring_1,semiring_char_0})"
+  by (simp add: of_nat_poly)
+
+lemma of_int_poly: "of_int k = [:of_int k :: 'a :: comm_ring_1:]"
+  by (simp only: of_int_of_nat of_nat_poly) simp
+
+lemma degree_of_int [simp]: "degree (of_int k) = 0"
+  by (simp add: of_int_poly)
+
+lemma lead_coeff_of_int [simp]:
+  "lead_coeff (of_int k) = (of_int k :: 'a :: {comm_ring_1,ring_char_0})"
+  by (simp add: of_int_poly)
 
 lemma numeral_poly: "numeral n = [:numeral n:]"
   by (subst of_nat_numeral [symmetric], subst of_nat_poly) simp
+    
+lemma degree_numeral [simp]: "degree (numeral n) = 0"
+  by (subst of_nat_numeral [symmetric], subst of_nat_poly) simp
+
+lemma lead_coeff_numeral [simp]: 
+  "lead_coeff (numeral n) = numeral n"
+  by (simp add: numeral_poly)
 
 
 subsection \<open>Lemmas about divisibility\<close>
@@ -1231,6 +1363,28 @@
   shows "smult a p dvd q \<longleftrightarrow> (if a = 0 then q = 0 else p dvd q)"
   by (auto elim: smult_dvd smult_dvd_cancel)
 
+lemma is_unit_smult_iff: "smult c p dvd 1 \<longleftrightarrow> c dvd 1 \<and> p dvd 1"
+proof -
+  have "smult c p = [:c:] * p" by simp
+  also have "\<dots> dvd 1 \<longleftrightarrow> c dvd 1 \<and> p dvd 1"
+  proof safe
+    assume A: "[:c:] * p dvd 1"
+    thus "p dvd 1" by (rule dvd_mult_right)
+    from A obtain q where B: "1 = [:c:] * p * q" by (erule dvdE)
+    have "c dvd c * (coeff p 0 * coeff q 0)" by simp
+    also have "\<dots> = coeff ([:c:] * p * q) 0" by (simp add: mult.assoc coeff_mult)
+    also note B [symmetric]
+    finally show "c dvd 1" by simp
+  next
+    assume "c dvd 1" "p dvd 1"
+    from \<open>c dvd 1\<close> obtain d where "1 = c * d" by (erule dvdE)
+    hence "1 = [:c:] * [:d:]" by (simp add: one_poly_def mult_ac)
+    hence "[:c:] dvd 1" by (rule dvdI)
+    from mult_dvd_mono[OF this \<open>p dvd 1\<close>] show "[:c:] * p dvd 1" by simp
+  qed
+  finally show ?thesis .
+qed
+
 
 subsection \<open>Polynomials form an integral domain\<close>
 
@@ -1296,6 +1450,27 @@
   "[:a::'a::{comm_semiring_1,semiring_no_zero_divisors}:] dvd [:b:] \<longleftrightarrow> a dvd b"
   by (subst const_poly_dvd_iff) (auto simp: coeff_pCons split: nat.splits)
 
+lemma lead_coeff_mult:
+  fixes p q :: "'a :: {comm_semiring_0, semiring_no_zero_divisors} poly"
+  shows "lead_coeff (p * q) = lead_coeff p * lead_coeff q"
+  by (cases "p=0 \<or> q=0", auto simp add:coeff_mult_degree_sum degree_mult_eq)
+
+lemma lead_coeff_smult:
+  "lead_coeff (smult c p :: 'a :: {comm_semiring_0,semiring_no_zero_divisors} poly) = c * lead_coeff p"
+proof -
+  have "smult c p = [:c:] * p" by simp
+  also have "lead_coeff \<dots> = c * lead_coeff p"
+    by (subst lead_coeff_mult) simp_all
+  finally show ?thesis .
+qed
+
+lemma lead_coeff_1 [simp]: "lead_coeff 1 = 1"
+  by simp
+
+lemma lead_coeff_power: 
+  "lead_coeff (p ^ n :: 'a :: {comm_semiring_1,semiring_no_zero_divisors} poly) = lead_coeff p ^ n"
+  by (induction n) (simp_all add: lead_coeff_mult)
+
 
 subsection \<open>Polynomials form an ordered integral domain\<close>
 
@@ -1401,77 +1576,10 @@
 text \<open>TODO: Simplification rules for comparisons\<close>
 
 
-subsection \<open>Leading coefficient\<close>
-
-definition lead_coeff:: "'a::zero poly \<Rightarrow> 'a" where
-  "lead_coeff p= coeff p (degree p)"
-
-lemma lead_coeff_pCons[simp]:
-    "p\<noteq>0 \<Longrightarrow>lead_coeff (pCons a p) = lead_coeff p"
-    "p=0 \<Longrightarrow> lead_coeff (pCons a p) = a"
-unfolding lead_coeff_def by auto
-
-lemma lead_coeff_0[simp]:"lead_coeff 0 =0" 
-  unfolding lead_coeff_def by auto
-
-lemma coeff_0_prod_list: "coeff (prod_list xs) 0 = prod_list (map (\<lambda>p. coeff p 0) xs)"
-  by (induction xs) (simp_all add: coeff_mult)
-
-lemma coeff_0_power: "coeff (p ^ n) 0 = coeff p 0 ^ n"
-  by (induction n) (simp_all add: coeff_mult)
-
-lemma lead_coeff_mult:
-   fixes p q::"'a :: {comm_semiring_0,semiring_no_zero_divisors} poly"
-   shows "lead_coeff (p * q) = lead_coeff p * lead_coeff q"
-by (unfold lead_coeff_def,cases "p=0 \<or> q=0",auto simp add:coeff_mult_degree_sum degree_mult_eq)
-
-lemma lead_coeff_add_le:
-  assumes "degree p < degree q"
-  shows "lead_coeff (p+q) = lead_coeff q" 
-using assms unfolding lead_coeff_def
-by (metis coeff_add coeff_eq_0 monoid_add_class.add.left_neutral degree_add_eq_right)
-
-lemma lead_coeff_minus:
-  "lead_coeff (-p) = - lead_coeff p"
-by (metis coeff_minus degree_minus lead_coeff_def)
-
-lemma lead_coeff_smult:
-  "lead_coeff (smult c p :: 'a :: {comm_semiring_0,semiring_no_zero_divisors} poly) = c * lead_coeff p"
-proof -
-  have "smult c p = [:c:] * p" by simp
-  also have "lead_coeff \<dots> = c * lead_coeff p"
-    by (subst lead_coeff_mult) simp_all
-  finally show ?thesis .
-qed
-
-lemma lead_coeff_eq_zero_iff [simp]: "lead_coeff p = 0 \<longleftrightarrow> p = 0"
-  by (simp add: lead_coeff_def)
-
-lemma lead_coeff_1 [simp]: "lead_coeff 1 = 1"
-  by (simp add: lead_coeff_def)
-
-lemma lead_coeff_of_nat [simp]:
-  "lead_coeff (of_nat n) = (of_nat n :: 'a :: {comm_semiring_1,semiring_char_0})"
-  by (induction n) (simp_all add: lead_coeff_def of_nat_poly)
-
-lemma lead_coeff_numeral [simp]: 
-  "lead_coeff (numeral n) = numeral n"
-  unfolding lead_coeff_def
-  by (subst of_nat_numeral [symmetric], subst of_nat_poly) simp
-
-lemma lead_coeff_power: 
-  "lead_coeff (p ^ n :: 'a :: {comm_semiring_1,semiring_no_zero_divisors} poly) = lead_coeff p ^ n"
-  by (induction n) (simp_all add: lead_coeff_mult)
-
-lemma lead_coeff_nonzero: "p \<noteq> 0 \<Longrightarrow> lead_coeff p \<noteq> 0"
-  by (simp add: lead_coeff_def)
-
-lemma lead_coeff_monom [simp]: "lead_coeff (monom c n) = c"
-  by (cases "c = 0") (simp_all add: lead_coeff_def degree_monom_eq)
-
-
 subsection \<open>Synthetic division and polynomial roots\<close>
 
+subsubsection \<open>Synthetic division\<close>  
+  
 text \<open>
   Synthetic division is simply division by the linear polynomial @{term "x - c"}.
 \<close>
@@ -1539,9 +1647,12 @@
   using synthetic_div_correct [of p c]
   by (simp add: algebra_simps)
 
+    
+subsubsection \<open>Polynomial roots\<close>
+  
 lemma poly_eq_0_iff_dvd:
   fixes c :: "'a::{comm_ring_1}"
-  shows "poly p c = 0 \<longleftrightarrow> [:-c, 1:] dvd p"
+  shows "poly p c = 0 \<longleftrightarrow> [:- c, 1:] dvd p"
 proof
   assume "poly p c = 0"
   with synthetic_div_correct' [of c p]
@@ -1555,7 +1666,7 @@
 
 lemma dvd_iff_poly_eq_0:
   fixes c :: "'a::{comm_ring_1}"
-  shows "[:c, 1:] dvd p \<longleftrightarrow> poly p (-c) = 0"
+  shows "[:c, 1:] dvd p \<longleftrightarrow> poly p (- c) = 0"
   by (simp add: poly_eq_0_iff_dvd)
 
 lemma poly_roots_finite:
@@ -1610,1318 +1721,8 @@
   shows "(\<forall>x. poly p x = 0) \<longleftrightarrow> p = 0"
   by (auto simp add: poly_eq_poly_eq_iff [symmetric])
 
-
-subsection \<open>Long division of polynomials\<close>
-
-inductive eucl_rel_poly :: "'a::field poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<times> 'a poly \<Rightarrow> bool"
-  where eucl_rel_poly_by0: "eucl_rel_poly x 0 (0, x)"
-  | eucl_rel_poly_dividesI: "y \<noteq> 0 \<Longrightarrow> x = q * y \<Longrightarrow> eucl_rel_poly x y (q, 0)"
-  | eucl_rel_poly_remainderI: "y \<noteq> 0 \<Longrightarrow> degree r < degree y
-      \<Longrightarrow> x = q * y + r \<Longrightarrow> eucl_rel_poly x y (q, r)"
-  
-lemma eucl_rel_poly_iff:
-  "eucl_rel_poly x y (q, r) \<longleftrightarrow>
-    x = q * y + r \<and>
-      (if y = 0 then q = 0 else r = 0 \<or> degree r < degree y)"
-  by (auto elim: eucl_rel_poly.cases
-    intro: eucl_rel_poly_by0 eucl_rel_poly_dividesI eucl_rel_poly_remainderI)
-  
-lemma eucl_rel_poly_0:
-  "eucl_rel_poly 0 y (0, 0)"
-  unfolding eucl_rel_poly_iff by simp
-
-lemma eucl_rel_poly_by_0:
-  "eucl_rel_poly x 0 (0, x)"
-  unfolding eucl_rel_poly_iff by simp
-
-lemma eq_zero_or_degree_less:
-  assumes "degree p \<le> n" and "coeff p n = 0"
-  shows "p = 0 \<or> degree p < n"
-proof (cases n)
-  case 0
-  with \<open>degree p \<le> n\<close> and \<open>coeff p n = 0\<close>
-  have "coeff p (degree p) = 0" by simp
-  then have "p = 0" by simp
-  then show ?thesis ..
-next
-  case (Suc m)
-  have "\<forall>i>n. coeff p i = 0"
-    using \<open>degree p \<le> n\<close> by (simp add: coeff_eq_0)
-  then have "\<forall>i\<ge>n. coeff p i = 0"
-    using \<open>coeff p n = 0\<close> by (simp add: le_less)
-  then have "\<forall>i>m. coeff p i = 0"
-    using \<open>n = Suc m\<close> by (simp add: less_eq_Suc_le)
-  then have "degree p \<le> m"
-    by (rule degree_le)
-  then have "degree p < n"
-    using \<open>n = Suc m\<close> by (simp add: less_Suc_eq_le)
-  then show ?thesis ..
-qed
-
-lemma eucl_rel_poly_pCons:
-  assumes rel: "eucl_rel_poly x y (q, r)"
-  assumes y: "y \<noteq> 0"
-  assumes b: "b = coeff (pCons a r) (degree y) / coeff y (degree y)"
-  shows "eucl_rel_poly (pCons a x) y (pCons b q, pCons a r - smult b y)"
-    (is "eucl_rel_poly ?x y (?q, ?r)")
-proof -
-  have x: "x = q * y + r" and r: "r = 0 \<or> degree r < degree y"
-    using assms unfolding eucl_rel_poly_iff by simp_all
-
-  have 1: "?x = ?q * y + ?r"
-    using b x by simp
-
-  have 2: "?r = 0 \<or> degree ?r < degree y"
-  proof (rule eq_zero_or_degree_less)
-    show "degree ?r \<le> degree y"
-    proof (rule degree_diff_le)
-      show "degree (pCons a r) \<le> degree y"
-        using r by auto
-      show "degree (smult b y) \<le> degree y"
-        by (rule degree_smult_le)
-    qed
-  next
-    show "coeff ?r (degree y) = 0"
-      using \<open>y \<noteq> 0\<close> unfolding b by simp
-  qed
-
-  from 1 2 show ?thesis
-    unfolding eucl_rel_poly_iff
-    using \<open>y \<noteq> 0\<close> by simp
-qed
-
-lemma eucl_rel_poly_exists: "\<exists>q r. eucl_rel_poly x y (q, r)"
-apply (cases "y = 0")
-apply (fast intro!: eucl_rel_poly_by_0)
-apply (induct x)
-apply (fast intro!: eucl_rel_poly_0)
-apply (fast intro!: eucl_rel_poly_pCons)
-done
-
-lemma eucl_rel_poly_unique:
-  assumes 1: "eucl_rel_poly x y (q1, r1)"
-  assumes 2: "eucl_rel_poly x y (q2, r2)"
-  shows "q1 = q2 \<and> r1 = r2"
-proof (cases "y = 0")
-  assume "y = 0" with assms show ?thesis
-    by (simp add: eucl_rel_poly_iff)
-next
-  assume [simp]: "y \<noteq> 0"
-  from 1 have q1: "x = q1 * y + r1" and r1: "r1 = 0 \<or> degree r1 < degree y"
-    unfolding eucl_rel_poly_iff by simp_all
-  from 2 have q2: "x = q2 * y + r2" and r2: "r2 = 0 \<or> degree r2 < degree y"
-    unfolding eucl_rel_poly_iff by simp_all
-  from q1 q2 have q3: "(q1 - q2) * y = r2 - r1"
-    by (simp add: algebra_simps)
-  from r1 r2 have r3: "(r2 - r1) = 0 \<or> degree (r2 - r1) < degree y"
-    by (auto intro: degree_diff_less)
-
-  show "q1 = q2 \<and> r1 = r2"
-  proof (rule ccontr)
-    assume "\<not> (q1 = q2 \<and> r1 = r2)"
-    with q3 have "q1 \<noteq> q2" and "r1 \<noteq> r2" by auto
-    with r3 have "degree (r2 - r1) < degree y" by simp
-    also have "degree y \<le> degree (q1 - q2) + degree y" by simp
-    also have "\<dots> = degree ((q1 - q2) * y)"
-      using \<open>q1 \<noteq> q2\<close> by (simp add: degree_mult_eq)
-    also have "\<dots> = degree (r2 - r1)"
-      using q3 by simp
-    finally have "degree (r2 - r1) < degree (r2 - r1)" .
-    then show "False" by simp
-  qed
-qed
-
-lemma eucl_rel_poly_0_iff: "eucl_rel_poly 0 y (q, r) \<longleftrightarrow> q = 0 \<and> r = 0"
-by (auto dest: eucl_rel_poly_unique intro: eucl_rel_poly_0)
-
-lemma eucl_rel_poly_by_0_iff: "eucl_rel_poly x 0 (q, r) \<longleftrightarrow> q = 0 \<and> r = x"
-by (auto dest: eucl_rel_poly_unique intro: eucl_rel_poly_by_0)
-
-lemmas eucl_rel_poly_unique_div = eucl_rel_poly_unique [THEN conjunct1]
-
-lemmas eucl_rel_poly_unique_mod = eucl_rel_poly_unique [THEN conjunct2]
-
-
-
-subsection \<open>Pseudo-Division and Division of Polynomials\<close>
-
-text\<open>This part is by René Thiemann and Akihisa Yamada.\<close>
-
-fun pseudo_divmod_main :: "'a :: comm_ring_1  \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly 
-  \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a poly \<times> 'a poly" where
-  "pseudo_divmod_main lc q r d dr (Suc n) = (let
-     rr = smult lc r;
-     qq = coeff r dr;
-     rrr = rr - monom qq n * d;
-     qqq = smult lc q + monom qq n
-     in pseudo_divmod_main lc qqq rrr d (dr - 1) n)"
-| "pseudo_divmod_main lc q r d dr 0 = (q,r)"
-
-definition pseudo_divmod :: "'a :: comm_ring_1 poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<times> 'a poly" where
-  "pseudo_divmod p q \<equiv> if q = 0 then (0,p) else
-     pseudo_divmod_main (coeff q (degree q)) 0 p q (degree p) (1 + length (coeffs p) - length (coeffs q))"
-
-lemma coeff_0_degree_minus_1: "coeff rrr dr = 0 \<Longrightarrow> degree rrr \<le> dr \<Longrightarrow> degree rrr \<le> dr - 1"
-  using eq_zero_or_degree_less by fastforce
-  
-lemma pseudo_divmod_main: assumes d: "d \<noteq> 0" "lc = coeff d (degree d)"
-  and *: "degree r \<le> dr" "pseudo_divmod_main lc q r d dr n = (q',r')" 
-    "n = 1 + dr - degree d \<or> dr = 0 \<and> n = 0 \<and> r = 0" 
-  shows "(r' = 0 \<or> degree r' < degree d) \<and> smult (lc^n) (d * q + r) = d * q' + r'"
-  using *
-proof (induct n arbitrary: q r dr)
-  case (Suc n q r dr)
-  let ?rr = "smult lc r"
-  let ?qq = "coeff r dr"
-  define b where [simp]: "b = monom ?qq n"
-  let ?rrr = "?rr - b * d"
-  let ?qqq = "smult lc q + b"
-  note res = Suc(3)
-  from res[unfolded pseudo_divmod_main.simps[of lc q] Let_def] 
-  have res: "pseudo_divmod_main lc ?qqq ?rrr d (dr - 1) n = (q',r')" 
-    by (simp del: pseudo_divmod_main.simps)
-  have dr: "dr = n + degree d" using Suc(4) by auto
-  have "coeff (b * d) dr = coeff b n * coeff d (degree d)"
-  proof (cases "?qq = 0")
-    case False
-    hence n: "n = degree b" by (simp add: degree_monom_eq)
-    show ?thesis unfolding n dr by (simp add: coeff_mult_degree_sum)
-  qed auto
-  also have "\<dots> = lc * coeff b n" unfolding d by simp
-  finally have "coeff (b * d) dr = lc * coeff b n" .
-  moreover have "coeff ?rr dr = lc * coeff r dr" by simp
-  ultimately have c0: "coeff ?rrr dr = 0" by auto
-  have dr: "dr = n + degree d" using Suc(4) by auto
-  have deg_rr: "degree ?rr \<le> dr" using Suc(2) 
-    using degree_smult_le dual_order.trans by blast 
-  have deg_bd: "degree (b * d) \<le> dr"
-    unfolding dr
-    by(rule order.trans[OF degree_mult_le], auto simp: degree_monom_le)
-  have "degree ?rrr \<le> dr"
-    using degree_diff_le[OF deg_rr deg_bd] by auto
-  with c0 have deg_rrr: "degree ?rrr \<le> (dr - 1)" by (rule coeff_0_degree_minus_1)
-  have "n = 1 + (dr - 1) - degree d \<or> dr - 1 = 0 \<and> n = 0 \<and> ?rrr = 0"
-  proof (cases dr)
-    case 0
-    with Suc(4) have 0: "dr = 0" "n = 0" "degree d = 0" by auto
-    with deg_rrr have "degree ?rrr = 0" by simp
-    hence "\<exists> a. ?rrr = [: a :]" by (metis degree_pCons_eq_if old.nat.distinct(2) pCons_cases)
-    from this obtain a where rrr: "?rrr = [:a:]" by auto
-    show ?thesis unfolding 0 using c0 unfolding rrr 0 by simp
-  qed (insert Suc(4), auto)
-  note IH = Suc(1)[OF deg_rrr res this]
-  show ?case
-  proof (intro conjI)
-    show "r' = 0 \<or> degree r' < degree d" using IH by blast
-    show "smult (lc ^ Suc n) (d * q + r) = d * q' + r'"
-      unfolding IH[THEN conjunct2,symmetric]
-      by (simp add: field_simps smult_add_right)
-  qed
-qed auto
-
-lemma pseudo_divmod:
-  assumes g: "g \<noteq> 0" and *: "pseudo_divmod f g = (q,r)" 
-  shows "smult (coeff g (degree g) ^ (Suc (degree f) - degree g)) f = g * q + r" (is ?A)
-    and "r = 0 \<or> degree r < degree g" (is ?B)
-proof -
-  from *[unfolded pseudo_divmod_def Let_def]
-  have "pseudo_divmod_main (coeff g (degree g)) 0 f g (degree f) (1 + length (coeffs f) - length (coeffs g)) = (q, r)" by (auto simp: g)
-  note main = pseudo_divmod_main[OF _ _ _ this, OF g refl le_refl]
-  have "1 + length (coeffs f) - length (coeffs g) = 1 + degree f - degree g \<or>
-    degree f = 0 \<and> 1 + length (coeffs f) - length (coeffs g) = 0 \<and> f = 0" using g 
-    by (cases "f = 0"; cases "coeffs g", auto simp: degree_eq_length_coeffs)
-  note main = main[OF this]
-  from main show "r = 0 \<or> degree r < degree g" by auto
-  show "smult (coeff g (degree g) ^ (Suc (degree f) - degree g)) f = g * q + r" 
-    by (subst main[THEN conjunct2, symmetric], simp add: degree_eq_length_coeffs,
-    insert g, cases "f = 0"; cases "coeffs g", auto)
-qed
-  
-definition "pseudo_mod_main lc r d dr n = snd (pseudo_divmod_main lc 0 r d dr n)"
-
-lemma snd_pseudo_divmod_main:
-  "snd (pseudo_divmod_main lc q r d dr n) = snd (pseudo_divmod_main lc q' r d dr n)"
-by (induct n arbitrary: q q' lc r d dr; simp add: Let_def)
-
-definition pseudo_mod 
-    :: "'a :: {comm_ring_1,semiring_1_no_zero_divisors} poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
-  "pseudo_mod f g = snd (pseudo_divmod f g)"
-  
-lemma pseudo_mod:
-  fixes f g
-  defines "r \<equiv> pseudo_mod f g"
-  assumes g: "g \<noteq> 0"
-  shows "\<exists> a q. a \<noteq> 0 \<and> smult a f = g * q + r" "r = 0 \<or> degree r < degree g"
-proof - 
-  let ?cg = "coeff g (degree g)"
-  let ?cge = "?cg ^ (Suc (degree f) - degree g)"
-  define a where "a = ?cge"
-  obtain q where pdm: "pseudo_divmod f g = (q,r)" using r_def[unfolded pseudo_mod_def]
-    by (cases "pseudo_divmod f g", auto)
-  from pseudo_divmod[OF g pdm] have id: "smult a f = g * q + r" and "r = 0 \<or> degree r < degree g" 
-    unfolding a_def by auto
-  show "r = 0 \<or> degree r < degree g" by fact
-  from g have "a \<noteq> 0" unfolding a_def by auto
-  thus "\<exists> a q. a \<noteq> 0 \<and> smult a f = g * q + r" using id by auto
-qed
-
-instantiation poly :: (idom_divide) idom_divide
-begin
-
-fun divide_poly_main :: "'a \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly 
-  \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a poly" where
-  "divide_poly_main lc q r d dr (Suc n) = (let cr = coeff r dr; a = cr div lc; mon = monom a n in 
-     if False \<or> a * lc = cr then (* False \<or> is only because of problem in function-package *)
-     divide_poly_main 
-       lc 
-       (q + mon) 
-       (r - mon * d) 
-       d (dr - 1) n else 0)"
-| "divide_poly_main lc q r d dr 0 = q"
-
-definition divide_poly :: "'a poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
-  "divide_poly f g = (if g = 0 then 0 else
-     divide_poly_main (coeff g (degree g)) 0 f g (degree f) (1 + length (coeffs f) - length (coeffs g)))" 
-
-lemma divide_poly_main:
-  assumes d: "d \<noteq> 0" "lc = coeff d (degree d)"
-    and *: "degree (d * r) \<le> dr" "divide_poly_main lc q (d * r) d dr n = q'" 
-    "n = 1 + dr - degree d \<or> dr = 0 \<and> n = 0 \<and> d * r = 0" 
-  shows "q' = q + r"
-  using *
-proof (induct n arbitrary: q r dr)
-  case (Suc n q r dr)
-  let ?rr = "d * r"
-  let ?a = "coeff ?rr dr"
-  let ?qq = "?a div lc"
-  define b where [simp]: "b = monom ?qq n"
-  let ?rrr =  "d * (r - b)"
-  let ?qqq = "q + b"
-  note res = Suc(3)
-  have dr: "dr = n + degree d" using Suc(4) by auto
-  have lc: "lc \<noteq> 0" using d by auto
-  have "coeff (b * d) dr = coeff b n * coeff d (degree d)"
-  proof (cases "?qq = 0")
-    case False
-    hence n: "n = degree b" by (simp add: degree_monom_eq)
-    show ?thesis unfolding n dr by (simp add: coeff_mult_degree_sum)
-  qed simp
-  also have "\<dots> = lc * coeff b n" unfolding d by simp
-  finally have c2: "coeff (b * d) dr = lc * coeff b n" .
-  have rrr: "?rrr = ?rr - b * d" by (simp add: field_simps)
-  have c1: "coeff (d * r) dr = lc * coeff r n"
-  proof (cases "degree r = n")
-    case True
-    thus ?thesis using Suc(2) unfolding dr using coeff_mult_degree_sum[of d r] d by (auto simp: ac_simps)
-  next
-    case False
-    have "degree r \<le> n" using dr Suc(2) by auto
-      (metis add.commute add_le_cancel_left d(1) degree_0 degree_mult_eq diff_is_0_eq diff_zero le_cases)
-    with False have r_n: "degree r < n" by auto
-    hence right: "lc * coeff r n = 0" by (simp add: coeff_eq_0)
-    have "coeff (d * r) dr = coeff (d * r) (degree d + n)" unfolding dr by (simp add: ac_simps)
-    also have "\<dots> = 0" using r_n
-      by (metis False Suc.prems(1) add.commute add_left_imp_eq coeff_degree_mult coeff_eq_0 
-        coeff_mult_degree_sum degree_mult_le dr le_eq_less_or_eq)
-    finally show ?thesis unfolding right .
-  qed
-  have c0: "coeff ?rrr dr = 0" 
-    and id: "lc * (coeff (d * r) dr div lc) = coeff (d * r) dr" unfolding rrr coeff_diff c2
-    unfolding b_def coeff_monom coeff_smult c1 using lc by auto
-  from res[unfolded divide_poly_main.simps[of lc q] Let_def] id
-  have res: "divide_poly_main lc ?qqq ?rrr d (dr - 1) n = q'" 
-    by (simp del: divide_poly_main.simps add: field_simps)
-  note IH = Suc(1)[OF _ res] 
-  have dr: "dr = n + degree d" using Suc(4) by auto
-  have deg_rr: "degree ?rr \<le> dr" using Suc(2) by auto
-  have deg_bd: "degree (b * d) \<le> dr"
-    unfolding dr b_def by (rule order.trans[OF degree_mult_le], auto simp: degree_monom_le)
-  have "degree ?rrr \<le> dr" unfolding rrr by (rule degree_diff_le[OF deg_rr deg_bd])
-  with c0 have deg_rrr: "degree ?rrr \<le> (dr - 1)" by (rule coeff_0_degree_minus_1)
-  have "n = 1 + (dr - 1) - degree d \<or> dr - 1 = 0 \<and> n = 0 \<and> ?rrr = 0"  
-  proof (cases dr)
-    case 0
-    with Suc(4) have 0: "dr = 0" "n = 0" "degree d = 0" by auto
-    with deg_rrr have "degree ?rrr = 0" by simp
-    from degree_eq_zeroE[OF this] obtain a where rrr: "?rrr = [:a:]" by metis
-    show ?thesis unfolding 0 using c0 unfolding rrr 0 by simp
-  qed (insert Suc(4), auto)
-  note IH = IH[OF deg_rrr this]
-  show ?case using IH by simp
-next
-  case (0 q r dr)
-  show ?case 
-  proof (cases "r = 0")
-    case True
-    thus ?thesis using 0 by auto
-  next
-    case False
-    have "degree (d * r) = degree d + degree r" using d False 
-      by (subst degree_mult_eq, auto)
-    thus ?thesis using 0 d by auto
-  qed
-qed 
-
-lemma fst_pseudo_divmod_main_as_divide_poly_main:
-  assumes d: "d \<noteq> 0"
-  defines lc: "lc \<equiv> coeff d (degree d)"
-  shows "fst (pseudo_divmod_main lc q r d dr n) = divide_poly_main lc (smult (lc^n) q) (smult (lc^n) r) d dr n"
-proof(induct n arbitrary: q r dr)
-  case 0 then show ?case by simp
-next
-  case (Suc n)
-    note lc0 = leading_coeff_neq_0[OF d, folded lc]
-    then have "pseudo_divmod_main lc q r d dr (Suc n) =
-    pseudo_divmod_main lc (smult lc q + monom (coeff r dr) n)
-      (smult lc r - monom (coeff r dr) n * d) d (dr - 1) n"
-    by (simp add: Let_def ac_simps)
-    also have "fst ... = divide_poly_main lc
-     (smult (lc^n) (smult lc q + monom (coeff r dr) n))
-     (smult (lc^n) (smult lc r - monom (coeff r dr) n * d))
-     d (dr - 1) n"
-      unfolding Suc[unfolded divide_poly_main.simps Let_def]..
-    also have "... = divide_poly_main lc (smult (lc ^ Suc n) q)
-        (smult (lc ^ Suc n) r) d dr (Suc n)"
-      unfolding smult_monom smult_distribs mult_smult_left[symmetric]
-      using lc0 by (simp add: Let_def ac_simps)
-    finally show ?case.
-qed
-
-
-lemma divide_poly_main_0: "divide_poly_main 0 0 r d dr n = 0"
-proof (induct n arbitrary: r d dr)
-  case (Suc n r d dr)
-  show ?case unfolding divide_poly_main.simps[of _ _ r] Let_def
-    by (simp add: Suc del: divide_poly_main.simps)
-qed simp
-
-lemma divide_poly:
-  assumes g: "g \<noteq> 0"
-  shows "(f * g) div g = (f :: 'a poly)" 
-proof - 
-  have "divide_poly_main (coeff g (degree g)) 0 (g * f) g (degree (g * f)) (1 + length (coeffs (g * f)) - length (coeffs  g)) 
-    = (f * g) div g" unfolding divide_poly_def Let_def by (simp add: ac_simps)
-  note main = divide_poly_main[OF g refl le_refl this]
-  {
-    fix f :: "'a poly"
-    assume "f \<noteq> 0"
-    hence "length (coeffs f) = Suc (degree f)" unfolding degree_eq_length_coeffs by auto
-  } note len = this
-  have "(f * g) div g = 0 + f"
-  proof (rule main, goal_cases)
-    case 1
-    show ?case
-    proof (cases "f = 0")
-      case True
-      with g show ?thesis by (auto simp: degree_eq_length_coeffs)
-    next
-      case False
-      with g have fg: "g * f \<noteq> 0" by auto
-      show ?thesis unfolding len[OF fg] len[OF g] by auto
-    qed
-  qed
-  thus ?thesis by simp
-qed
-
-lemma divide_poly_0: "f div 0 = (0 :: 'a poly)"
-  by (simp add: divide_poly_def Let_def divide_poly_main_0)
-
-instance
-  by standard (auto simp: divide_poly divide_poly_0)
-
-end
-
-instance poly :: (idom_divide) algebraic_semidom ..
-
-lemma div_const_poly_conv_map_poly: 
-  assumes "[:c:] dvd p"
-  shows   "p div [:c:] = map_poly (\<lambda>x. x div c) p"
-proof (cases "c = 0")
-  case False
-  from assms obtain q where p: "p = [:c:] * q" by (erule dvdE)
-  moreover {
-    have "smult c q = [:c:] * q" by simp
-    also have "\<dots> div [:c:] = q" by (rule nonzero_mult_div_cancel_left) (insert False, auto)
-    finally have "smult c q div [:c:] = q" .
-  }
-  ultimately show ?thesis by (intro poly_eqI) (auto simp: coeff_map_poly False)
-qed (auto intro!: poly_eqI simp: coeff_map_poly)
-
-lemma is_unit_monom_0:
-  fixes a :: "'a::field"
-  assumes "a \<noteq> 0"
-  shows "is_unit (monom a 0)"
-proof
-  from assms show "1 = monom a 0 * monom (inverse a) 0"
-    by (simp add: mult_monom)
-qed
-
-lemma is_unit_triv:
-  fixes a :: "'a::field"
-  assumes "a \<noteq> 0"
-  shows "is_unit [:a:]"
-  using assms by (simp add: is_unit_monom_0 monom_0 [symmetric])
-
-lemma is_unit_iff_degree:
-  assumes "p \<noteq> (0 :: _ :: field poly)"
-  shows "is_unit p \<longleftrightarrow> degree p = 0" (is "?P \<longleftrightarrow> ?Q")
-proof
-  assume ?Q
-  then obtain a where "p = [:a:]" by (rule degree_eq_zeroE)
-  with assms show ?P by (simp add: is_unit_triv)
-next
-  assume ?P
-  then obtain q where "q \<noteq> 0" "p * q = 1" ..
-  then have "degree (p * q) = degree 1"
-    by simp
-  with \<open>p \<noteq> 0\<close> \<open>q \<noteq> 0\<close> have "degree p + degree q = 0"
-    by (simp add: degree_mult_eq)
-  then show ?Q by simp
-qed
-
-lemma is_unit_pCons_iff:
-  "is_unit (pCons (a::_::field) p) \<longleftrightarrow> p = 0 \<and> a \<noteq> 0"
-  by (cases "p = 0") (auto simp add: is_unit_triv is_unit_iff_degree)
-
-lemma is_unit_monom_trival:
-  fixes p :: "'a::field poly"
-  assumes "is_unit p"
-  shows "monom (coeff p (degree p)) 0 = p"
-  using assms by (cases p) (simp_all add: monom_0 is_unit_pCons_iff)
-
-lemma is_unit_const_poly_iff: 
-  "[:c :: 'a :: {comm_semiring_1,semiring_no_zero_divisors}:] dvd 1 \<longleftrightarrow> c dvd 1"
-  by (auto simp: one_poly_def)
-
-lemma is_unit_polyE:
-  fixes p :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
-  assumes "p dvd 1" obtains c where "p = [:c:]" "c dvd 1"
-proof -
-  from assms obtain q where "1 = p * q"
-    by (rule dvdE)
-  then have "p \<noteq> 0" and "q \<noteq> 0"
-    by auto
-  from \<open>1 = p * q\<close> have "degree 1 = degree (p * q)"
-    by simp
-  also from \<open>p \<noteq> 0\<close> and \<open>q \<noteq> 0\<close> have "\<dots> = degree p + degree q"
-    by (simp add: degree_mult_eq)
-  finally have "degree p = 0" by simp
-  with degree_eq_zeroE obtain c where c: "p = [:c:]" .
-  moreover with \<open>p dvd 1\<close> have "c dvd 1"
-    by (simp add: is_unit_const_poly_iff)
-  ultimately show thesis
-    by (rule that)
-qed
-
-lemma is_unit_polyE':
-  assumes "is_unit (p::_::field poly)"
-  obtains a where "p = monom a 0" and "a \<noteq> 0"
-proof -
-  obtain a q where "p = pCons a q" by (cases p)
-  with assms have "p = [:a:]" and "a \<noteq> 0"
-    by (simp_all add: is_unit_pCons_iff)
-  with that show thesis by (simp add: monom_0)
-qed
-
-lemma is_unit_poly_iff:
-  fixes p :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
-  shows "p dvd 1 \<longleftrightarrow> (\<exists>c. p = [:c:] \<and> c dvd 1)"
-  by (auto elim: is_unit_polyE simp add: is_unit_const_poly_iff)
-
-instantiation poly :: ("{normalization_semidom, idom_divide}") normalization_semidom
-begin
-
-definition unit_factor_poly :: "'a poly \<Rightarrow> 'a poly"
-  where "unit_factor_poly p = monom (unit_factor (lead_coeff p)) 0"
-
-definition normalize_poly :: "'a poly \<Rightarrow> 'a poly"
-  where "normalize_poly p = map_poly (\<lambda>x. x div unit_factor (lead_coeff p)) p"
-
-instance proof
-  fix p :: "'a poly"
-  show "unit_factor p * normalize p = p"
-    by (cases "p = 0")
-       (simp_all add: unit_factor_poly_def normalize_poly_def monom_0 
-          smult_conv_map_poly map_poly_map_poly o_def)
-next
-  fix p :: "'a poly"
-  assume "is_unit p"
-  then obtain c where p: "p = [:c:]" "is_unit c"
-    by (auto simp: is_unit_poly_iff)
-  thus "normalize p = 1"
-    by (simp add: normalize_poly_def map_poly_pCons is_unit_normalize one_poly_def)
-next
-  fix p :: "'a poly" assume "p \<noteq> 0"
-  thus "is_unit (unit_factor p)"
-    by (simp add: unit_factor_poly_def monom_0 is_unit_poly_iff)
-qed (simp_all add: normalize_poly_def unit_factor_poly_def monom_0 lead_coeff_mult unit_factor_mult)
-
-end
-
-lemma normalize_poly_eq_div:
-  "normalize p = p div [:unit_factor (lead_coeff p):]"
-proof (cases "p = 0")
-  case False
-  thus ?thesis
-    by (subst div_const_poly_conv_map_poly)
-       (auto simp: normalize_poly_def const_poly_dvd_iff lead_coeff_def )
-qed (auto simp: normalize_poly_def)
-
-lemma unit_factor_pCons:
-  "unit_factor (pCons a p) = (if p = 0 then monom (unit_factor a) 0 else unit_factor p)"
-  by (simp add: unit_factor_poly_def)
-
-lemma normalize_monom [simp]:
-  "normalize (monom a n) = monom (normalize a) n"
-  by (simp add: map_poly_monom normalize_poly_def)
-
-lemma unit_factor_monom [simp]:
-  "unit_factor (monom a n) = monom (unit_factor a) 0"
-  by (simp add: unit_factor_poly_def )
-
-lemma normalize_const_poly: "normalize [:c:] = [:normalize c:]"
-  by (simp add: normalize_poly_def map_poly_pCons)
-
-lemma normalize_smult: "normalize (smult c p) = smult (normalize c) (normalize p)"
-proof -
-  have "smult c p = [:c:] * p" by simp
-  also have "normalize \<dots> = smult (normalize c) (normalize p)"
-    by (subst normalize_mult) (simp add: normalize_const_poly)
-  finally show ?thesis .
-qed
-
-
-subsubsection \<open>Division in Field Polynomials\<close>
-
-text\<open>
- This part connects the above result to the division of field polynomials.
- Mainly imported from Isabelle 2016.
-\<close>
-
-lemma pseudo_divmod_field:
-  assumes g: "(g::'a::field poly) \<noteq> 0" and *: "pseudo_divmod f g = (q,r)"
-  defines "c \<equiv> coeff g (degree g) ^ (Suc (degree f) - degree g)"
-  shows "f = g * smult (1/c) q + smult (1/c) r"
-proof -
-  from leading_coeff_neq_0[OF g] have c0: "c \<noteq> 0" unfolding c_def by auto
-  from pseudo_divmod(1)[OF g *, folded c_def]
-  have "smult c f = g * q + r" by auto
-  also have "smult (1/c) ... = g * smult (1/c) q + smult (1/c) r" by (simp add: smult_add_right)
-  finally show ?thesis using c0 by auto
-qed
-
-lemma divide_poly_main_field:
-  assumes d: "(d::'a::field poly) \<noteq> 0"
-  defines lc: "lc \<equiv> coeff d (degree d)"
-  shows "divide_poly_main lc q r d dr n = fst (pseudo_divmod_main lc (smult ((1/lc)^n) q) (smult ((1/lc)^n) r) d dr n)"
-  unfolding lc
-  by(subst fst_pseudo_divmod_main_as_divide_poly_main, auto simp: d power_one_over)
-
-lemma divide_poly_field:
-  fixes f g :: "'a :: field poly"
-  defines "f' \<equiv> smult ((1 / coeff g (degree g)) ^ (Suc (degree f) - degree g)) f"
-  shows "(f::'a::field poly) div g = fst (pseudo_divmod f' g)"
-proof (cases "g = 0")
-  case True show ?thesis 
-    unfolding divide_poly_def pseudo_divmod_def Let_def f'_def True by (simp add: divide_poly_main_0)
-next
-  case False
-    from leading_coeff_neq_0[OF False] have "degree f' = degree f" unfolding f'_def by auto
-    then show ?thesis
-      using length_coeffs_degree[of f'] length_coeffs_degree[of f]
-      unfolding divide_poly_def pseudo_divmod_def Let_def
-                divide_poly_main_field[OF False]
-                length_coeffs_degree[OF False] 
-                f'_def
-      by force
-qed
-
-instantiation poly :: (field) ring_div
-begin
-
-definition modulo_poly where
-  mod_poly_def: "f mod g \<equiv>
-    if g = 0 then f
-    else pseudo_mod (smult ((1/coeff g (degree g)) ^ (Suc (degree f) - degree g)) f) g"
-
-lemma eucl_rel_poly: "eucl_rel_poly (x::'a::field poly) y (x div y, x mod y)"
-  unfolding eucl_rel_poly_iff
-proof (intro conjI)
-  show "x = x div y * y + x mod y"
-  proof(cases "y = 0")
-    case True show ?thesis by(simp add: True divide_poly_def divide_poly_0 mod_poly_def)
-  next
-    case False
-    then have "pseudo_divmod (smult ((1 / coeff y (degree y)) ^ (Suc (degree x) - degree y)) x) y =
-          (x div y, x mod y)"
-      unfolding divide_poly_field mod_poly_def pseudo_mod_def by simp
-    from pseudo_divmod[OF False this]
-    show ?thesis using False
-      by (simp add: power_mult_distrib[symmetric] mult.commute)
-  qed
-  show "if y = 0 then x div y = 0 else x mod y = 0 \<or> degree (x mod y) < degree y"
-  proof (cases "y = 0")
-    case True then show ?thesis by auto
-  next
-    case False
-      with pseudo_mod[OF this] show ?thesis unfolding mod_poly_def by simp
-  qed
-qed
-
-lemma div_poly_eq:
-  "eucl_rel_poly (x::'a::field poly) y (q, r) \<Longrightarrow> x div y = q"
-  by(rule eucl_rel_poly_unique_div[OF eucl_rel_poly])
-
-lemma mod_poly_eq:
-  "eucl_rel_poly (x::'a::field poly) y (q, r) \<Longrightarrow> x mod y = r"
-  by (rule eucl_rel_poly_unique_mod[OF eucl_rel_poly])
-
-instance
-proof
-  fix x y :: "'a poly"
-  from eucl_rel_poly[of x y,unfolded eucl_rel_poly_iff]
-  show "x div y * y + x mod y = x" by auto
-next
-  fix x y z :: "'a poly"
-  assume "y \<noteq> 0"
-  hence "eucl_rel_poly (x + z * y) y (z + x div y, x mod y)"
-    using eucl_rel_poly [of x y]
-    by (simp add: eucl_rel_poly_iff distrib_right)
-  thus "(x + z * y) div y = z + x div y"
-    by (rule div_poly_eq)
-next
-  fix x y z :: "'a poly"
-  assume "x \<noteq> 0"
-  show "(x * y) div (x * z) = y div z"
-  proof (cases "y \<noteq> 0 \<and> z \<noteq> 0")
-    have "\<And>x::'a poly. eucl_rel_poly x 0 (0, x)"
-      by (rule eucl_rel_poly_by_0)
-    then have [simp]: "\<And>x::'a poly. x div 0 = 0"
-      by (rule div_poly_eq)
-    have "\<And>x::'a poly. eucl_rel_poly 0 x (0, 0)"
-      by (rule eucl_rel_poly_0)
-    then have [simp]: "\<And>x::'a poly. 0 div x = 0"
-      by (rule div_poly_eq)
-    case False then show ?thesis by auto
-  next
-    case True then have "y \<noteq> 0" and "z \<noteq> 0" by auto
-    with \<open>x \<noteq> 0\<close>
-    have "\<And>q r. eucl_rel_poly y z (q, r) \<Longrightarrow> eucl_rel_poly (x * y) (x * z) (q, x * r)"
-      by (auto simp add: eucl_rel_poly_iff algebra_simps)
-        (rule classical, simp add: degree_mult_eq)
-    moreover from eucl_rel_poly have "eucl_rel_poly y z (y div z, y mod z)" .
-    ultimately have "eucl_rel_poly (x * y) (x * z) (y div z, x * (y mod z))" .
-    then show ?thesis by (simp add: div_poly_eq)
-  qed
-qed
-
-end
-
-lemma degree_mod_less:
-  "y \<noteq> 0 \<Longrightarrow> x mod y = 0 \<or> degree (x mod y) < degree y"
-  using eucl_rel_poly [of x y]
-  unfolding eucl_rel_poly_iff by simp
-
-lemma div_poly_less: "degree (x::'a::field poly) < degree y \<Longrightarrow> x div y = 0"
-proof -
-  assume "degree x < degree y"
-  hence "eucl_rel_poly x y (0, x)"
-    by (simp add: eucl_rel_poly_iff)
-  thus "x div y = 0" by (rule div_poly_eq)
-qed
-
-lemma mod_poly_less: "degree x < degree y \<Longrightarrow> x mod y = x"
-proof -
-  assume "degree x < degree y"
-  hence "eucl_rel_poly x y (0, x)"
-    by (simp add: eucl_rel_poly_iff)
-  thus "x mod y = x" by (rule mod_poly_eq)
-qed
-
-lemma eucl_rel_poly_smult_left:
-  "eucl_rel_poly x y (q, r)
-    \<Longrightarrow> eucl_rel_poly (smult a x) y (smult a q, smult a r)"
-  unfolding eucl_rel_poly_iff by (simp add: smult_add_right)
-
-lemma div_smult_left: "(smult (a::'a::field) x) div y = smult a (x div y)"
-  by (rule div_poly_eq, rule eucl_rel_poly_smult_left, rule eucl_rel_poly)
-
-lemma mod_smult_left: "(smult a x) mod y = smult a (x mod y)"
-  by (rule mod_poly_eq, rule eucl_rel_poly_smult_left, rule eucl_rel_poly)
-
-lemma poly_div_minus_left [simp]:
-  fixes x y :: "'a::field poly"
-  shows "(- x) div y = - (x div y)"
-  using div_smult_left [of "- 1::'a"] by simp
-
-lemma poly_mod_minus_left [simp]:
-  fixes x y :: "'a::field poly"
-  shows "(- x) mod y = - (x mod y)"
-  using mod_smult_left [of "- 1::'a"] by simp
-
-lemma eucl_rel_poly_add_left:
-  assumes "eucl_rel_poly x y (q, r)"
-  assumes "eucl_rel_poly x' y (q', r')"
-  shows "eucl_rel_poly (x + x') y (q + q', r + r')"
-  using assms unfolding eucl_rel_poly_iff
-  by (auto simp add: algebra_simps degree_add_less)
-
-lemma poly_div_add_left:
-  fixes x y z :: "'a::field poly"
-  shows "(x + y) div z = x div z + y div z"
-  using eucl_rel_poly_add_left [OF eucl_rel_poly eucl_rel_poly]
-  by (rule div_poly_eq)
-
-lemma poly_mod_add_left:
-  fixes x y z :: "'a::field poly"
-  shows "(x + y) mod z = x mod z + y mod z"
-  using eucl_rel_poly_add_left [OF eucl_rel_poly eucl_rel_poly]
-  by (rule mod_poly_eq)
-
-lemma poly_div_diff_left:
-  fixes x y z :: "'a::field poly"
-  shows "(x - y) div z = x div z - y div z"
-  by (simp only: diff_conv_add_uminus poly_div_add_left poly_div_minus_left)
-
-lemma poly_mod_diff_left:
-  fixes x y z :: "'a::field poly"
-  shows "(x - y) mod z = x mod z - y mod z"
-  by (simp only: diff_conv_add_uminus poly_mod_add_left poly_mod_minus_left)
-
-lemma eucl_rel_poly_smult_right:
-  "a \<noteq> 0 \<Longrightarrow> eucl_rel_poly x y (q, r)
-    \<Longrightarrow> eucl_rel_poly x (smult a y) (smult (inverse a) q, r)"
-  unfolding eucl_rel_poly_iff by simp
-
-lemma div_smult_right:
-  "(a::'a::field) \<noteq> 0 \<Longrightarrow> x div (smult a y) = smult (inverse a) (x div y)"
-  by (rule div_poly_eq, erule eucl_rel_poly_smult_right, rule eucl_rel_poly)
-
-lemma mod_smult_right: "a \<noteq> 0 \<Longrightarrow> x mod (smult a y) = x mod y"
-  by (rule mod_poly_eq, erule eucl_rel_poly_smult_right, rule eucl_rel_poly)
-
-lemma poly_div_minus_right [simp]:
-  fixes x y :: "'a::field poly"
-  shows "x div (- y) = - (x div y)"
-  using div_smult_right [of "- 1::'a"] by (simp add: nonzero_inverse_minus_eq)
-
-lemma poly_mod_minus_right [simp]:
-  fixes x y :: "'a::field poly"
-  shows "x mod (- y) = x mod y"
-  using mod_smult_right [of "- 1::'a"] by simp
-
-lemma eucl_rel_poly_mult:
-  "eucl_rel_poly x y (q, r) \<Longrightarrow> eucl_rel_poly q z (q', r')
-    \<Longrightarrow> eucl_rel_poly x (y * z) (q', y * r' + r)"
-apply (cases "z = 0", simp add: eucl_rel_poly_iff)
-apply (cases "y = 0", simp add: eucl_rel_poly_by_0_iff eucl_rel_poly_0_iff)
-apply (cases "r = 0")
-apply (cases "r' = 0")
-apply (simp add: eucl_rel_poly_iff)
-apply (simp add: eucl_rel_poly_iff field_simps degree_mult_eq)
-apply (cases "r' = 0")
-apply (simp add: eucl_rel_poly_iff degree_mult_eq)
-apply (simp add: eucl_rel_poly_iff field_simps)
-apply (simp add: degree_mult_eq degree_add_less)
-done
-
-lemma poly_div_mult_right:
-  fixes x y z :: "'a::field poly"
-  shows "x div (y * z) = (x div y) div z"
-  by (rule div_poly_eq, rule eucl_rel_poly_mult, (rule eucl_rel_poly)+)
-
-lemma poly_mod_mult_right:
-  fixes x y z :: "'a::field poly"
-  shows "x mod (y * z) = y * (x div y mod z) + x mod y"
-  by (rule mod_poly_eq, rule eucl_rel_poly_mult, (rule eucl_rel_poly)+)
-
-lemma mod_pCons:
-  fixes a and x
-  assumes y: "y \<noteq> 0"
-  defines b: "b \<equiv> coeff (pCons a (x mod y)) (degree y) / coeff y (degree y)"
-  shows "(pCons a x) mod y = (pCons a (x mod y) - smult b y)"
-unfolding b
-apply (rule mod_poly_eq)
-apply (rule eucl_rel_poly_pCons [OF eucl_rel_poly y refl])
-done
-
-definition pdivmod :: "'a::field poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<times> 'a poly"
-where
-  "pdivmod p q = (p div q, p mod q)"
-
-lemma pdivmod_0:
-  "pdivmod 0 q = (0, 0)"
-  by (simp add: pdivmod_def)
-
-lemma pdivmod_pCons:
-  "pdivmod (pCons a p) q =
-    (if q = 0 then (0, pCons a p) else
-      (let (s, r) = pdivmod p q;
-           b = coeff (pCons a r) (degree q) / coeff q (degree q)
-        in (pCons b s, pCons a r - smult b q)))"
-  apply (simp add: pdivmod_def Let_def, safe)
-  apply (rule div_poly_eq)
-  apply (erule eucl_rel_poly_pCons [OF eucl_rel_poly _ refl])
-  apply (rule mod_poly_eq)
-  apply (erule eucl_rel_poly_pCons [OF eucl_rel_poly _ refl])
-  done
-
-lemma pdivmod_fold_coeffs:
-  "pdivmod p q = (if q = 0 then (0, p)
-    else fold_coeffs (\<lambda>a (s, r).
-      let b = coeff (pCons a r) (degree q) / coeff q (degree q)
-      in (pCons b s, pCons a r - smult b q)
-   ) p (0, 0))"
-  apply (cases "q = 0")
-  apply (simp add: pdivmod_def)
-  apply (rule sym)
-  apply (induct p)
-  apply (simp_all add: pdivmod_0 pdivmod_pCons)
-  apply (case_tac "a = 0 \<and> p = 0")
-  apply (auto simp add: pdivmod_def)
-  done
-
-subsection \<open>List-based versions for fast implementation\<close>
-(* Subsection by:
-      Sebastiaan Joosten
-      René Thiemann
-      Akihisa Yamada
-    *)
-fun minus_poly_rev_list :: "'a :: group_add list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
-  "minus_poly_rev_list (x # xs) (y # ys) = (x - y) # (minus_poly_rev_list xs ys)"
-| "minus_poly_rev_list xs [] = xs"
-| "minus_poly_rev_list [] (y # ys) = []"
-
-fun pseudo_divmod_main_list :: "'a::comm_ring_1 \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list 
-  \<Rightarrow> nat \<Rightarrow> 'a list \<times> 'a list" where
-  "pseudo_divmod_main_list lc q r d (Suc n) = (let
-     rr = map (op * lc) r;
-     a = hd r;
-     qqq = cCons a (map (op * lc) q);
-     rrr = tl (if a = 0 then rr else minus_poly_rev_list rr (map (op * a) d))
-     in pseudo_divmod_main_list lc qqq rrr d n)"
-| "pseudo_divmod_main_list lc q r d 0 = (q,r)"
-
-fun pseudo_mod_main_list :: "'a::comm_ring_1 \<Rightarrow> 'a list \<Rightarrow> 'a list 
-  \<Rightarrow> nat \<Rightarrow> 'a list" where
-  "pseudo_mod_main_list lc r d (Suc n) = (let
-     rr = map (op * lc) r;
-     a = hd r;
-     rrr = tl (if a = 0 then rr else minus_poly_rev_list rr (map (op * a) d))
-     in pseudo_mod_main_list lc rrr d n)"
-| "pseudo_mod_main_list lc r d 0 = r"
-
-
-fun divmod_poly_one_main_list :: "'a::comm_ring_1 list \<Rightarrow> 'a list \<Rightarrow> 'a list 
-  \<Rightarrow> nat \<Rightarrow> 'a list \<times> 'a list" where
-  "divmod_poly_one_main_list q r d (Suc n) = (let
-     a = hd r;
-     qqq = cCons a q;
-     rr = tl (if a = 0 then r else minus_poly_rev_list r (map (op * a) d))
-     in divmod_poly_one_main_list qqq rr d n)"
-| "divmod_poly_one_main_list q r d 0 = (q,r)"
-
-fun mod_poly_one_main_list :: "'a::comm_ring_1 list \<Rightarrow> 'a list 
-  \<Rightarrow> nat \<Rightarrow> 'a list" where
-  "mod_poly_one_main_list r d (Suc n) = (let
-     a = hd r;
-     rr = tl (if a = 0 then r else minus_poly_rev_list r (map (op * a) d))
-     in mod_poly_one_main_list rr d n)"
-| "mod_poly_one_main_list r d 0 = r"
-
-definition pseudo_divmod_list :: "'a::comm_ring_1 list \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list" where
-  "pseudo_divmod_list p q =
-  (if q = [] then ([],p) else
- (let rq = rev q;
-     (qu,re) = pseudo_divmod_main_list (hd rq) [] (rev p) rq (1 + length p - length q) in 
-   (qu,rev re)))"
-
-definition pseudo_mod_list :: "'a::comm_ring_1 list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
-  "pseudo_mod_list p q =
-  (if q = [] then p else
- (let rq = rev q;
-     re = pseudo_mod_main_list (hd rq) (rev p) rq (1 + length p - length q) in 
-   (rev re)))"
-
-lemma minus_zero_does_nothing:
-"(minus_poly_rev_list x (map (op * 0) y)) = (x :: 'a :: ring list)"
-  by(induct x y rule: minus_poly_rev_list.induct, auto)
-
-lemma length_minus_poly_rev_list[simp]:
- "length (minus_poly_rev_list xs ys) = length xs"
-  by(induct xs ys rule: minus_poly_rev_list.induct, auto)
-
-lemma if_0_minus_poly_rev_list:
-  "(if a = 0 then x else minus_poly_rev_list x (map (op * a) y))
-      = minus_poly_rev_list x (map (op * (a :: 'a :: ring)) y)"
-  by(cases "a=0",simp_all add:minus_zero_does_nothing)
-
-lemma Poly_append:
-  "Poly ((a::'a::comm_semiring_1 list) @ b) = Poly a + monom 1 (length a) * Poly b"
-  by (induct a,auto simp: monom_0 monom_Suc)
-
-lemma minus_poly_rev_list: "length p \<ge> length (q :: 'a :: comm_ring_1 list) \<Longrightarrow>
-  Poly (rev (minus_poly_rev_list (rev p) (rev q)))
-  = Poly p - monom 1 (length p - length q) * Poly q"
-proof (induct "rev p" "rev q" arbitrary: p q rule: minus_poly_rev_list.induct)
-  case (1 x xs y ys) 
-  have "length (rev q) \<le> length (rev p)" using 1 by simp
-  from this[folded 1(2,3)] have ys_xs:"length ys \<le> length xs" by simp
-  hence a:"Poly (rev (minus_poly_rev_list xs ys)) =
-           Poly (rev xs) - monom 1 (length xs - length ys) * Poly (rev ys)"
-    by(subst "1.hyps"(1)[of "rev xs" "rev ys", unfolded rev_rev_ident length_rev],auto)
-  have "Poly p - monom 1 (length p - length q) * Poly q
-      = Poly (rev (rev p)) - monom 1 (length (rev (rev p)) - length (rev (rev q))) * Poly (rev (rev q))"
-    by simp
-  also have "\<dots> = Poly (rev (x # xs)) - monom 1 (length (x # xs) - length (y # ys)) * Poly (rev (y # ys))"
-    unfolding 1(2,3) by simp
-  also have "\<dots> = Poly (rev xs) + monom x (length xs) -
-  (monom 1 (length xs - length ys) * Poly (rev ys) + monom y (length xs))" using ys_xs
-    by (simp add:Poly_append distrib_left mult_monom smult_monom)
-  also have "\<dots> = Poly (rev (minus_poly_rev_list xs ys)) + monom (x - y) (length xs)"
-    unfolding a diff_monom[symmetric] by(simp)
-  finally show ?case
-    unfolding 1(2,3)[symmetric] by (simp add: smult_monom Poly_append)
-qed auto
-
-lemma smult_monom_mult: "smult a (monom b n * f) = monom (a * b) n * f"
-  using smult_monom [of a _ n] by (metis mult_smult_left)
-
-lemma head_minus_poly_rev_list:
-  "length d \<le> length r \<Longrightarrow> d\<noteq>[] \<Longrightarrow>
-  hd (minus_poly_rev_list (map (op * (last d :: 'a :: comm_ring)) r) (map (op * (hd r)) (rev d))) = 0"
-proof(induct r)
-  case (Cons a rs)
-  thus ?case by(cases "rev d", simp_all add:ac_simps)
-qed simp
-
-lemma Poly_map: "Poly (map (op * a) p) = smult a (Poly p)"
-proof (induct p)
-  case(Cons x xs) thus ?case by (cases "Poly xs = 0",auto)
-qed simp
-
-lemma last_coeff_is_hd: "xs \<noteq> [] \<Longrightarrow> coeff (Poly xs) (length xs - 1) = hd (rev xs)"
-  by (simp_all add: hd_conv_nth rev_nth nth_default_nth nth_append)
-
-lemma pseudo_divmod_main_list_invar :
-  assumes leading_nonzero:"last d \<noteq> 0"
-  and lc:"last d = lc"
-  and dNonempty:"d \<noteq> []"
-  and "pseudo_divmod_main_list lc q (rev r) (rev d) n = (q',rev r')"
-  and "n = (1 + length r - length d)"
-  shows 
-  "pseudo_divmod_main lc (monom 1 n * Poly q) (Poly r) (Poly d) (length r - 1) n = 
-  (Poly q', Poly r')"
-using assms(4-)
-proof(induct "n" arbitrary: r q)
-case (Suc n r q)
-  have ifCond: "\<not> Suc (length r) \<le> length d" using Suc.prems by simp
-  have rNonempty:"r \<noteq> []"
-    using ifCond dNonempty using Suc_leI length_greater_0_conv list.size(3) by fastforce
-  let ?a = "(hd (rev r))"
-  let ?rr = "map (op * lc) (rev r)"
-  let ?rrr = "rev (tl (minus_poly_rev_list ?rr (map (op * ?a) (rev d))))"
-  let ?qq = "cCons ?a (map (op * lc) q)"
-  have n: "n = (1 + length r - length d - 1)"
-    using ifCond Suc(3) by simp
-  have rr_val:"(length ?rrr) = (length r - 1)" using ifCond by auto
-  hence rr_smaller: "(1 + length r - length d - 1) = (1 + length ?rrr - length d)"
-    using rNonempty ifCond unfolding One_nat_def by auto
-  from ifCond have id: "Suc (length r) - length d = Suc (length r - length d)" by auto
-  have "pseudo_divmod_main_list lc ?qq (rev ?rrr) (rev d) (1 + length r - length d - 1) = (q', rev r')"
-    using Suc.prems ifCond by (simp add:Let_def if_0_minus_poly_rev_list id)
-  hence v:"pseudo_divmod_main_list lc ?qq (rev ?rrr) (rev d) n = (q', rev r')"
-    using n by auto
-  have sucrr:"Suc (length r) - length d = Suc (length r - length d)"
-    using Suc_diff_le ifCond not_less_eq_eq by blast
-  have n_ok : "n = 1 + (length ?rrr) - length d" using Suc(3) rNonempty by simp
-  have cong: "\<And> x1 x2 x3 x4 y1 y2 y3 y4. x1 = y1 \<Longrightarrow> x2 = y2 \<Longrightarrow> x3 = y3 \<Longrightarrow> x4 = y4 \<Longrightarrow>
-    pseudo_divmod_main lc x1 x2 x3 x4 n = pseudo_divmod_main lc y1 y2 y3 y4 n" by simp
-  have hd_rev:"coeff (Poly r) (length r - Suc 0) = hd (rev r)"
-    using last_coeff_is_hd[OF rNonempty] by simp
-  show ?case unfolding Suc.hyps(1)[OF v n_ok, symmetric] pseudo_divmod_main.simps Let_def
-  proof (rule cong[OF _ _ refl], goal_cases)
-    case 1 
-    show ?case unfolding monom_Suc hd_rev[symmetric]
-      by (simp add: smult_monom Poly_map)
-  next
-    case 2 
-    show ?case 
-    proof (subst Poly_on_rev_starting_with_0, goal_cases)
-      show "hd (minus_poly_rev_list (map (op * lc) (rev r)) (map (op * (hd (rev r))) (rev d))) = 0"
-        by (fold lc, subst head_minus_poly_rev_list, insert ifCond dNonempty,auto)
-      from ifCond have "length d \<le> length r" by simp
-      then show "smult lc (Poly r) - monom (coeff (Poly r) (length r - 1)) n * Poly d =
-        Poly (rev (minus_poly_rev_list (map (op * lc) (rev r)) (map (op * (hd (rev r))) (rev d))))"
-        by (fold rev_map) (auto simp add: n smult_monom_mult Poly_map hd_rev [symmetric]
-          minus_poly_rev_list)
-    qed
-  qed simp
-qed simp
-
-lemma pseudo_divmod_impl[code]: "pseudo_divmod (f::'a::comm_ring_1 poly) g =
-  map_prod poly_of_list poly_of_list (pseudo_divmod_list (coeffs f) (coeffs g))"
-proof (cases "g=0")
-case False
-  hence coeffs_g_nonempty:"(coeffs g) \<noteq> []" by simp
-  hence lastcoeffs:"last (coeffs g) = coeff g (degree g)"
-    by (simp add: hd_rev last_coeffs_eq_coeff_degree not_0_coeffs_not_Nil)
-  obtain q r where qr: "pseudo_divmod_main_list
-            (last (coeffs g)) (rev [])
-            (rev (coeffs f)) (rev (coeffs g))
-            (1 + length (coeffs f) -
-             length (coeffs g)) = (q,rev (rev r))"  by force
-  then have qr': "pseudo_divmod_main_list
-            (hd (rev (coeffs g))) []
-            (rev (coeffs f)) (rev (coeffs g))
-            (1 + length (coeffs f) -
-             length (coeffs g)) = (q,r)" using hd_rev[OF coeffs_g_nonempty] by(auto)
-  from False have cg: "(coeffs g = []) = False" by auto
-  have last_non0:"last (coeffs g) \<noteq> 0" using False by (simp add:last_coeffs_not_0)
-  show ?thesis
-    unfolding pseudo_divmod_def pseudo_divmod_list_def Let_def qr' map_prod_def split cg if_False
-    pseudo_divmod_main_list_invar[OF last_non0 _ _ qr,unfolded lastcoeffs,simplified,symmetric,OF False]
-    poly_of_list_def
-    using False by (auto simp: degree_eq_length_coeffs)
-next
-  case True
-  show ?thesis unfolding True unfolding pseudo_divmod_def pseudo_divmod_list_def
-  by auto
-qed
-
-lemma pseudo_mod_main_list: "snd (pseudo_divmod_main_list l q 
-  xs ys n) = pseudo_mod_main_list l xs ys n"
-  by (induct n arbitrary: l q xs ys, auto simp: Let_def)
-
-lemma pseudo_mod_impl[code]: "pseudo_mod f g =
-  poly_of_list (pseudo_mod_list (coeffs f) (coeffs g))"
-proof -
-  have snd_case: "\<And> f g p. snd ((\<lambda> (x,y). (f x, g y)) p) = g (snd p)" 
-    by auto
-  show ?thesis
-  unfolding pseudo_mod_def pseudo_divmod_impl pseudo_divmod_list_def
-    pseudo_mod_list_def Let_def
-  by (simp add: snd_case pseudo_mod_main_list)
-qed
-
-
-(* *************** *)
-subsubsection \<open>Improved Code-Equations for Polynomial (Pseudo) Division\<close>
-
-lemma pdivmod_pdivmodrel: "eucl_rel_poly p q (r, s) \<longleftrightarrow> pdivmod p q = (r, s)"
-  by (metis pdivmod_def eucl_rel_poly eucl_rel_poly_unique)
-
-lemma pdivmod_via_pseudo_divmod: "pdivmod f g = (if g = 0 then (0,f) 
-     else let 
-       ilc = inverse (coeff g (degree g));       
-       h = smult ilc g;
-       (q,r) = pseudo_divmod f h
-     in (smult ilc q, r))" (is "?l = ?r")
-proof (cases "g = 0")
-  case False
-  define lc where "lc = inverse (coeff g (degree g))"
-  define h where "h = smult lc g"
-  from False have h1: "coeff h (degree h) = 1" and lc: "lc \<noteq> 0" unfolding h_def lc_def by auto
-  hence h0: "h \<noteq> 0" by auto
-  obtain q r where p: "pseudo_divmod f h = (q,r)" by force
-  from False have id: "?r = (smult lc q, r)" 
-    unfolding Let_def h_def[symmetric] lc_def[symmetric] p by auto
-  from pseudo_divmod[OF h0 p, unfolded h1] 
-  have f: "f = h * q + r" and r: "r = 0 \<or> degree r < degree h" by auto
-  have "eucl_rel_poly f h (q, r)" unfolding eucl_rel_poly_iff using f r h0 by auto
-  hence "pdivmod f h = (q,r)" by (simp add: pdivmod_pdivmodrel)
-  hence "pdivmod f g = (smult lc q, r)" 
-    unfolding pdivmod_def h_def div_smult_right[OF lc] mod_smult_right[OF lc]
-    using lc by auto
-  with id show ?thesis by auto
-qed (auto simp: pdivmod_def)
-
-lemma pdivmod_via_pseudo_divmod_list: "pdivmod f g = (let 
-  cg = coeffs g
-  in if cg = [] then (0,f)
-     else let 
-       cf = coeffs f;
-       ilc = inverse (last cg);       
-       ch = map (op * ilc) cg;
-       (q,r) = pseudo_divmod_main_list 1 [] (rev cf) (rev ch) (1 + length cf - length cg)
-     in (poly_of_list (map (op * ilc) q), poly_of_list (rev r)))"
-proof -
-  note d = pdivmod_via_pseudo_divmod
-      pseudo_divmod_impl pseudo_divmod_list_def
-  show ?thesis
-  proof (cases "g = 0")
-    case True thus ?thesis unfolding d by auto
-  next
-    case False
-    define ilc where "ilc = inverse (coeff g (degree g))"
-    from False have ilc: "ilc \<noteq> 0" unfolding ilc_def by auto
-    with False have id: "(g = 0) = False" "(coeffs g = []) = False" 
-      "last (coeffs g) = coeff g (degree g)" 
-      "(coeffs (smult ilc g) = []) = False"
-      by (auto simp: last_coeffs_eq_coeff_degree) 
-    have id2: "hd (rev (coeffs (smult ilc g))) = 1"      
-      by (subst hd_rev, insert id ilc, auto simp: coeffs_smult, subst last_map, auto simp: id ilc_def)
-    have id3: "length (coeffs (smult ilc g)) = length (coeffs g)" 
-      "rev (coeffs (smult ilc g)) = rev (map (op * ilc) (coeffs g))" unfolding coeffs_smult using ilc by auto
-    obtain q r where pair: "pseudo_divmod_main_list 1 [] (rev (coeffs f)) (rev (map (op * ilc) (coeffs g)))
-           (1 + length (coeffs f) - length (coeffs g)) = (q,r)" by force
-    show ?thesis unfolding d Let_def id if_False ilc_def[symmetric] map_prod_def[symmetric] id2 
-      unfolding id3 pair map_prod_def split by (auto simp: Poly_map)
-  qed
-qed
-
-lemma pseudo_divmod_main_list_1: "pseudo_divmod_main_list 1 = divmod_poly_one_main_list"
-proof (intro ext, goal_cases)
-  case (1 q r d n)
-  {
-    fix xs :: "'a list"
-    have "map (op * 1) xs = xs" by (induct xs, auto)
-  } note [simp] = this
-  show ?case by (induct n arbitrary: q r d, auto simp: Let_def)
-qed
-
-fun divide_poly_main_list :: "'a::idom_divide \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list 
-  \<Rightarrow> nat \<Rightarrow> 'a list" where
-  "divide_poly_main_list lc q r d (Suc n) = (let
-     cr = hd r
-     in if cr = 0 then divide_poly_main_list lc (cCons cr q) (tl r) d n else let 
-     a = cr div lc;
-     qq = cCons a q;
-     rr = minus_poly_rev_list r (map (op * a) d)
-     in if hd rr = 0 then divide_poly_main_list lc qq (tl rr) d n else [])"
-| "divide_poly_main_list lc q r d 0 = q"
-
-
-lemma divide_poly_main_list_simp[simp]: "divide_poly_main_list lc q r d (Suc n) = (let
-     cr = hd r;
-     a = cr div lc;
-     qq = cCons a q;
-     rr = minus_poly_rev_list r (map (op * a) d)
-     in if hd rr = 0 then divide_poly_main_list lc qq (tl rr) d n else [])"
-  by (simp add: Let_def minus_zero_does_nothing)
-
-declare divide_poly_main_list.simps(1)[simp del]
-
-definition divide_poly_list :: "'a::idom_divide poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
-  "divide_poly_list f g =
-    (let cg = coeffs g
-     in if cg = [] then g
-        else let cf = coeffs f; cgr = rev cg
-          in poly_of_list (divide_poly_main_list (hd cgr) [] (rev cf) cgr (1 + length cf - length cg)))"
-
-lemmas pdivmod_via_divmod_list[code] = pdivmod_via_pseudo_divmod_list[unfolded pseudo_divmod_main_list_1]
-
-lemma mod_poly_one_main_list: "snd (divmod_poly_one_main_list q r d n) = mod_poly_one_main_list r d n"
-  by  (induct n arbitrary: q r d, auto simp: Let_def)
-
-lemma mod_poly_code[code]: "f mod g =
-    (let cg = coeffs g
-     in if cg = [] then f
-        else let cf = coeffs f; ilc = inverse (last cg); ch = map (op * ilc) cg;
-                 r = mod_poly_one_main_list (rev cf) (rev ch) (1 + length cf - length cg)
-             in poly_of_list (rev r))" (is "?l = ?r")
-proof -
-  have "?l = snd (pdivmod f g)" unfolding pdivmod_def by simp
-  also have "\<dots> = ?r" unfolding pdivmod_via_divmod_list Let_def
-     mod_poly_one_main_list[symmetric, of _ _ _ Nil] by (auto split: prod.splits)
-  finally show ?thesis .
-qed
-
-definition div_field_poly_impl :: "'a :: field poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where 
-  "div_field_poly_impl f g = (
-    let cg = coeffs g
-      in if cg = [] then 0
-        else let cf = coeffs f; ilc = inverse (last cg); ch = map (op * ilc) cg;
-                 q = fst (divmod_poly_one_main_list [] (rev cf) (rev ch) (1 + length cf - length cg))
-             in poly_of_list ((map (op * ilc) q)))"
-
-text \<open>We do not declare the following lemma as code equation, since then polynomial division 
-  on non-fields will no longer be executable. However, a code-unfold is possible, since 
-  \<open>div_field_poly_impl\<close> is a bit more efficient than the generic polynomial division.\<close>
-lemma div_field_poly_impl[code_unfold]: "op div = div_field_poly_impl"
-proof (intro ext)
-  fix f g :: "'a poly"
-  have "f div g = fst (pdivmod f g)" unfolding pdivmod_def by simp
-  also have "\<dots> = div_field_poly_impl f g" unfolding 
-    div_field_poly_impl_def pdivmod_via_divmod_list Let_def by (auto split: prod.splits)
-  finally show "f div g =  div_field_poly_impl f g" .
-qed
-
-
-lemma divide_poly_main_list:
-  assumes lc0: "lc \<noteq> 0"
-  and lc:"last d = lc"
-  and d:"d \<noteq> []"
-  and "n = (1 + length r - length d)"
-  shows 
-  "Poly (divide_poly_main_list lc q (rev r) (rev d) n) =
-  divide_poly_main lc (monom 1 n * Poly q) (Poly r) (Poly d) (length r - 1) n"
-using assms(4-)
-proof(induct "n" arbitrary: r q)
-case (Suc n r q)
-  have ifCond: "\<not> Suc (length r) \<le> length d" using Suc.prems by simp
-  have r: "r \<noteq> []"
-    using ifCond d using Suc_leI length_greater_0_conv list.size(3) by fastforce
-  then obtain rr lcr where r: "r = rr @ [lcr]" by (cases r rule: rev_cases, auto)
-  from d lc obtain dd where d: "d = dd @ [lc]" 
-    by (cases d rule: rev_cases, auto)
-  from Suc(2) ifCond have n: "n = 1 + length rr - length d" by (auto simp: r)
-  from ifCond have len: "length dd \<le> length rr" by (simp add: r d)
-  show ?case
-  proof (cases "lcr div lc * lc = lcr")
-    case False
-    thus ?thesis unfolding Suc(2)[symmetric] using r d
-      by (auto simp add: Let_def nth_default_append)
-  next
-    case True
-    hence id:
-    "?thesis = (Poly (divide_poly_main_list lc (cCons (lcr div lc) q)
-         (rev (rev (minus_poly_rev_list (rev rr) (rev (map (op * (lcr div lc)) dd))))) (rev d) n) = 
-      divide_poly_main lc
-           (monom 1 (Suc n) * Poly q + monom (lcr div lc) n)
-           (Poly r - monom (lcr div lc) n * Poly d)
-           (Poly d) (length rr - 1) n)"
-           using r d 
-      by (cases r rule: rev_cases; cases "d" rule: rev_cases; 
-        auto simp add: Let_def rev_map nth_default_append)      
-    have cong: "\<And> x1 x2 x3 x4 y1 y2 y3 y4. x1 = y1 \<Longrightarrow> x2 = y2 \<Longrightarrow> x3 = y3 \<Longrightarrow> x4 = y4 \<Longrightarrow>
-      divide_poly_main lc x1 x2 x3 x4 n = divide_poly_main lc y1 y2 y3 y4 n" by simp
-    show ?thesis unfolding id 
-    proof (subst Suc(1), simp add: n,
-      subst minus_poly_rev_list, force simp: len, rule cong[OF _ _ refl], goal_cases)
-      case 2 
-      have "monom lcr (length rr) = monom (lcr div lc) (length rr - length dd) * monom lc (length dd)"
-        by (simp add: mult_monom len True)
-      thus ?case unfolding r d Poly_append n ring_distribs
-        by (auto simp: Poly_map smult_monom smult_monom_mult)
-    qed (auto simp: len monom_Suc smult_monom)
-  qed
-qed simp
-
-
-lemma divide_poly_list[code]: "f div g = divide_poly_list f g" 
-proof -
-  note d = divide_poly_def divide_poly_list_def
-  show ?thesis
-  proof (cases "g = 0")
-    case True
-    show ?thesis unfolding d True by auto
-  next
-    case False
-    then obtain cg lcg where cg: "coeffs g = cg @ [lcg]" by (cases "coeffs g" rule: rev_cases, auto)    
-    with False have id: "(g = 0) = False" "(cg @ [lcg] = []) = False" by auto
-    from cg False have lcg: "coeff g (degree g) = lcg" 
-      using last_coeffs_eq_coeff_degree last_snoc by force
-    with False have lcg0: "lcg \<noteq> 0" by auto
-    from cg have ltp: "Poly (cg @ [lcg]) = g"
-     using Poly_coeffs [of g] by auto
-    show ?thesis unfolding d cg Let_def id if_False poly_of_list_def
-      by (subst divide_poly_main_list, insert False cg lcg0, auto simp: lcg ltp,
-      simp add: degree_eq_length_coeffs)
-  qed
-qed
-
-subsection \<open>Order of polynomial roots\<close>
+    
+subsubsection \<open>Order of polynomial roots\<close>
 
 definition order :: "'a::idom \<Rightarrow> 'a poly \<Rightarrow> nat"
 where
@@ -2986,6 +1787,124 @@
 lemma order_0I: "poly p a \<noteq> 0 \<Longrightarrow> order a p = 0"
   by (subst (asm) order_root) auto
 
+lemma order_unique_lemma:
+  fixes p :: "'a::idom poly"
+  assumes "[:-a, 1:] ^ n dvd p" "\<not> [:-a, 1:] ^ Suc n dvd p"
+  shows "n = order a p"
+unfolding Polynomial.order_def
+apply (rule Least_equality [symmetric])
+apply (fact assms)
+apply (rule classical)
+apply (erule notE)
+unfolding not_less_eq_eq
+using assms(1) apply (rule power_le_dvd)
+apply assumption
+  done
+    
+lemma order_mult: "p * q \<noteq> 0 \<Longrightarrow> order a (p * q) = order a p + order a q"
+proof -
+  define i where "i = order a p"
+  define j where "j = order a q"
+  define t where "t = [:-a, 1:]"
+  have t_dvd_iff: "\<And>u. t dvd u \<longleftrightarrow> poly u a = 0"
+    unfolding t_def by (simp add: dvd_iff_poly_eq_0)
+  assume "p * q \<noteq> 0"
+  then show "order a (p * q) = i + j"
+    apply clarsimp
+    apply (drule order [where a=a and p=p, folded i_def t_def])
+    apply (drule order [where a=a and p=q, folded j_def t_def])
+    apply clarify
+    apply (erule dvdE)+
+    apply (rule order_unique_lemma [symmetric], fold t_def)
+    apply (simp_all add: power_add t_dvd_iff)
+    done
+qed
+
+lemma order_smult:
+  assumes "c \<noteq> 0" 
+  shows "order x (smult c p) = order x p"
+proof (cases "p = 0")
+  case False
+  have "smult c p = [:c:] * p" by simp
+  also from assms False have "order x \<dots> = order x [:c:] + order x p" 
+    by (subst order_mult) simp_all
+  also from assms have "order x [:c:] = 0" by (intro order_0I) auto
+  finally show ?thesis by simp
+qed simp
+
+(* Next two lemmas contributed by Wenda Li *)
+lemma order_1_eq_0 [simp]:"order x 1 = 0" 
+  by (metis order_root poly_1 zero_neq_one)
+
+lemma order_power_n_n: "order a ([:-a,1:]^n)=n" 
+proof (induct n) (*might be proved more concisely using nat_less_induct*)
+  case 0
+  thus ?case by (metis order_root poly_1 power_0 zero_neq_one)
+next 
+  case (Suc n)
+  have "order a ([:- a, 1:] ^ Suc n)=order a ([:- a, 1:] ^ n) + order a [:-a,1:]" 
+    by (metis (no_types, hide_lams) One_nat_def add_Suc_right monoid_add_class.add.right_neutral 
+      one_neq_zero order_mult pCons_eq_0_iff power_add power_eq_0_iff power_one_right)
+  moreover have "order a [:-a,1:]=1" unfolding order_def
+    proof (rule Least_equality,rule ccontr)
+      assume  "\<not> \<not> [:- a, 1:] ^ Suc 1 dvd [:- a, 1:]"
+      hence "[:- a, 1:] ^ Suc 1 dvd [:- a, 1:]" by simp
+      hence "degree ([:- a, 1:] ^ Suc 1) \<le> degree ([:- a, 1:] )" 
+        by (rule dvd_imp_degree_le,auto) 
+      thus False by auto
+    next
+      fix y assume asm:"\<not> [:- a, 1:] ^ Suc y dvd [:- a, 1:]"
+      show "1 \<le> y" 
+        proof (rule ccontr)
+          assume "\<not> 1 \<le> y"
+          hence "y=0" by auto
+          hence "[:- a, 1:] ^ Suc y dvd [:- a, 1:]" by auto
+          thus False using asm by auto
+        qed
+    qed
+  ultimately show ?case using Suc by auto
+qed
+
+lemma order_0_monom [simp]:
+  assumes "c \<noteq> 0"
+  shows   "order 0 (monom c n) = n"
+  using assms order_power_n_n[of 0 n] by (simp add: monom_altdef order_smult)
+
+lemma dvd_imp_order_le:
+  "q \<noteq> 0 \<Longrightarrow> p dvd q \<Longrightarrow> Polynomial.order a p \<le> Polynomial.order a q"
+  by (auto simp: order_mult elim: dvdE)
+
+text\<open>Now justify the standard squarefree decomposition, i.e. f / gcd(f,f').\<close>
+
+lemma order_divides: "[:-a, 1:] ^ n dvd p \<longleftrightarrow> p = 0 \<or> n \<le> order a p"
+apply (cases "p = 0", auto)
+apply (drule order_2 [where a=a and p=p])
+apply (metis not_less_eq_eq power_le_dvd)
+apply (erule power_le_dvd [OF order_1])
+done
+
+lemma order_decomp:
+  assumes "p \<noteq> 0"
+  shows "\<exists>q. p = [:- a, 1:] ^ order a p * q \<and> \<not> [:- a, 1:] dvd q"
+proof -
+  from assms have A: "[:- a, 1:] ^ order a p dvd p"
+    and B: "\<not> [:- a, 1:] ^ Suc (order a p) dvd p" by (auto dest: order)
+  from A obtain q where C: "p = [:- a, 1:] ^ order a p * q" ..
+  with B have "\<not> [:- a, 1:] ^ Suc (order a p) dvd [:- a, 1:] ^ order a p * q"
+    by simp
+  then have "\<not> [:- a, 1:] ^ order a p * [:- a, 1:] dvd [:- a, 1:] ^ order a p * q"
+    by simp
+  then have D: "\<not> [:- a, 1:] dvd q"
+    using idom_class.dvd_mult_cancel_left [of "[:- a, 1:] ^ order a p" "[:- a, 1:]" q]
+    by auto
+  from C D show ?thesis by blast
+qed
+
+lemma monom_1_dvd_iff:
+  assumes "p \<noteq> 0"
+  shows   "monom 1 n dvd p \<longleftrightarrow> n \<le> order 0 p"
+  using assms order_divides[of 0 n p] by (simp add: monom_altdef)
+
 
 subsection \<open>Additional induction rules on polynomials\<close>
 
@@ -3055,7 +1974,7 @@
   finally show ?thesis .
 qed
 
-
+  
 subsection \<open>Composition of polynomials\<close>
 
 (* Several lemmas contributed by René Thiemann and Akihisa Yamada *)
@@ -3218,7 +2137,7 @@
   shows "lead_coeff (pcompose p q) = lead_coeff p * lead_coeff q ^ (degree p)"
 proof (induct p)
   case 0
-  thus ?case unfolding lead_coeff_def by auto
+  thus ?case by auto
 next
   case (pCons a p)
   have "degree ( q * pcompose p q) = 0 \<Longrightarrow> ?case"
@@ -3230,9 +2149,13 @@
     qed
   moreover have "degree ( q * pcompose p q) > 0 \<Longrightarrow> ?case" 
     proof -
-      assume "degree ( q * pcompose p q) > 0"
-      hence "lead_coeff (pcompose (pCons a p) q) =lead_coeff ( q * pcompose p q)"
-        by (auto simp add:pcompose_pCons lead_coeff_add_le)
+      assume "degree (q * pcompose p q) > 0"
+      then have "degree [:a:] < degree (q * pcompose p q)"
+        by simp
+      then have "lead_coeff ([:a:] + q * p \<circ>\<^sub>p q) = lead_coeff (q * p \<circ>\<^sub>p q)"
+        by (rule lead_coeff_add_le)
+      then have "lead_coeff (pcompose (pCons a p) q) = lead_coeff (q * pcompose p q)"
+        by (simp add: pcompose_pCons)
       also have "... = lead_coeff q * (lead_coeff p * lead_coeff q ^ degree p)"
         using pCons.hyps(2) lead_coeff_mult[of q "pcompose p q"] by simp
       also have "... = lead_coeff p * lead_coeff q ^ (degree p + 1)"
@@ -3254,7 +2177,6 @@
 lemma nth_default_take: "nth_default x (take n xs) m = (if m < n then nth_default x xs m else x)"
   by (auto simp add: nth_default_def add_ac)
   
-  
 lemma coeff_poly_shift: "coeff (poly_shift n p) i = coeff p (i + n)"
 proof -
   from MOST_coeff_eq_0[of p] obtain m where "\<forall>k>m. coeff p k = 0" by (auto simp: MOST_nat)
@@ -3359,7 +2281,7 @@
   by (induction rule: pCons_induct) (simp_all add: field_simps reflect_poly_pCons' poly_monom)
 
 lemma coeff_0_reflect_poly [simp]: "coeff (reflect_poly p) 0 = lead_coeff p"
-  by (simp add: coeff_reflect_poly lead_coeff_def)
+  by (simp add: coeff_reflect_poly)
 
 lemma poly_reflect_poly_0 [simp]: "poly (reflect_poly p) 0 = lead_coeff p"
   by (simp add: poly_0_coeff_0)
@@ -3442,7 +2364,7 @@
   reflect_poly_power reflect_poly_prod reflect_poly_prod_list
 
 
-subsection \<open>Derivatives of univariate polynomials\<close>
+subsection \<open>Derivatives\<close>
 
 function pderiv :: "('a :: {comm_semiring_1,semiring_no_zero_divisors}) poly \<Rightarrow> 'a poly"
 where
@@ -3735,6 +2657,136 @@
   qed
 qed
 
+lemma lemma_order_pderiv1:
+  "pderiv ([:- a, 1:] ^ Suc n * q) = [:- a, 1:] ^ Suc n * pderiv q +
+    smult (of_nat (Suc n)) (q * [:- a, 1:] ^ n)"
+apply (simp only: pderiv_mult pderiv_power_Suc)
+apply (simp del: power_Suc of_nat_Suc add: pderiv_pCons)
+done
+
+lemma lemma_order_pderiv:
+  fixes p :: "'a :: field_char_0 poly"
+  assumes n: "0 < n" 
+      and pd: "pderiv p \<noteq> 0" 
+      and pe: "p = [:- a, 1:] ^ n * q" 
+      and nd: "~ [:- a, 1:] dvd q"
+    shows "n = Suc (order a (pderiv p))"
+using n 
+proof -
+  have "pderiv ([:- a, 1:] ^ n * q) \<noteq> 0"
+    using assms by auto
+  obtain n' where "n = Suc n'" "0 < Suc n'" "pderiv ([:- a, 1:] ^ Suc n' * q) \<noteq> 0"
+    using assms by (cases n) auto
+  have *: "!!k l. k dvd k * pderiv q + smult (of_nat (Suc n')) l \<Longrightarrow> k dvd l"
+    by (auto simp del: of_nat_Suc simp: dvd_add_right_iff dvd_smult_iff)
+  have "n' = order a (pderiv ([:- a, 1:] ^ Suc n' * q))" 
+  proof (rule order_unique_lemma)
+    show "[:- a, 1:] ^ n' dvd pderiv ([:- a, 1:] ^ Suc n' * q)"
+      apply (subst lemma_order_pderiv1)
+      apply (rule dvd_add)
+      apply (metis dvdI dvd_mult2 power_Suc2)
+      apply (metis dvd_smult dvd_triv_right)
+      done
+  next
+    show "\<not> [:- a, 1:] ^ Suc n' dvd pderiv ([:- a, 1:] ^ Suc n' * q)"
+     apply (subst lemma_order_pderiv1)
+     by (metis * nd dvd_mult_cancel_right power_not_zero pCons_eq_0_iff power_Suc zero_neq_one)
+  qed
+  then show ?thesis
+    by (metis \<open>n = Suc n'\<close> pe)
+qed
+
+lemma order_pderiv:
+  "\<lbrakk>pderiv p \<noteq> 0; order a (p :: 'a :: field_char_0 poly) \<noteq> 0\<rbrakk> \<Longrightarrow>
+     (order a p = Suc (order a (pderiv p)))"
+apply (case_tac "p = 0", simp)
+apply (drule_tac a = a and p = p in order_decomp)
+using neq0_conv
+apply (blast intro: lemma_order_pderiv)
+done
+
+lemma poly_squarefree_decomp_order:
+  assumes "pderiv (p :: 'a :: field_char_0 poly) \<noteq> 0"
+  and p: "p = q * d"
+  and p': "pderiv p = e * d"
+  and d: "d = r * p + s * pderiv p"
+  shows "order a q = (if order a p = 0 then 0 else 1)"
+proof (rule classical)
+  assume 1: "order a q \<noteq> (if order a p = 0 then 0 else 1)"
+  from \<open>pderiv p \<noteq> 0\<close> have "p \<noteq> 0" by auto
+  with p have "order a p = order a q + order a d"
+    by (simp add: order_mult)
+  with 1 have "order a p \<noteq> 0" by (auto split: if_splits)
+  have "order a (pderiv p) = order a e + order a d"
+    using \<open>pderiv p \<noteq> 0\<close> \<open>pderiv p = e * d\<close> by (simp add: order_mult)
+  have "order a p = Suc (order a (pderiv p))"
+    using \<open>pderiv p \<noteq> 0\<close> \<open>order a p \<noteq> 0\<close> by (rule order_pderiv)
+  have "d \<noteq> 0" using \<open>p \<noteq> 0\<close> \<open>p = q * d\<close> by simp
+  have "([:-a, 1:] ^ (order a (pderiv p))) dvd d"
+    apply (simp add: d)
+    apply (rule dvd_add)
+    apply (rule dvd_mult)
+    apply (simp add: order_divides \<open>p \<noteq> 0\<close>
+           \<open>order a p = Suc (order a (pderiv p))\<close>)
+    apply (rule dvd_mult)
+    apply (simp add: order_divides)
+    done
+  then have "order a (pderiv p) \<le> order a d"
+    using \<open>d \<noteq> 0\<close> by (simp add: order_divides)
+  show ?thesis
+    using \<open>order a p = order a q + order a d\<close>
+    using \<open>order a (pderiv p) = order a e + order a d\<close>
+    using \<open>order a p = Suc (order a (pderiv p))\<close>
+    using \<open>order a (pderiv p) \<le> order a d\<close>
+    by auto
+qed
+
+lemma poly_squarefree_decomp_order2: 
+     "\<lbrakk>pderiv p \<noteq> (0 :: 'a :: field_char_0 poly);
+       p = q * d;
+       pderiv p = e * d;
+       d = r * p + s * pderiv p
+      \<rbrakk> \<Longrightarrow> \<forall>a. order a q = (if order a p = 0 then 0 else 1)"
+by (blast intro: poly_squarefree_decomp_order)
+
+lemma order_pderiv2: 
+  "\<lbrakk>pderiv p \<noteq> 0; order a (p :: 'a :: field_char_0 poly) \<noteq> 0\<rbrakk>
+      \<Longrightarrow> (order a (pderiv p) = n) = (order a p = Suc n)"
+by (auto dest: order_pderiv)
+
+definition rsquarefree :: "'a::idom poly \<Rightarrow> bool"
+  where "rsquarefree p \<longleftrightarrow> p \<noteq> 0 \<and> (\<forall>a. order a p = 0 \<or> order a p = 1)"
+
+lemma pderiv_iszero: "pderiv p = 0 \<Longrightarrow> \<exists>h. p = [:h :: 'a :: {semidom,semiring_char_0}:]"
+  by (cases p) (auto simp: pderiv_eq_0_iff split: if_splits)
+
+lemma rsquarefree_roots:
+  fixes p :: "'a :: field_char_0 poly"
+  shows "rsquarefree p = (\<forall>a. \<not>(poly p a = 0 \<and> poly (pderiv p) a = 0))"
+apply (simp add: rsquarefree_def)
+apply (case_tac "p = 0", simp, simp)
+apply (case_tac "pderiv p = 0")
+apply simp
+apply (drule pderiv_iszero, clarsimp)
+apply (metis coeff_0 coeff_pCons_0 degree_pCons_0 le0 le_antisym order_degree)
+apply (force simp add: order_root order_pderiv2)
+  done
+
+lemma poly_squarefree_decomp:
+  assumes "pderiv (p :: 'a :: field_char_0 poly) \<noteq> 0"
+    and "p = q * d"
+    and "pderiv p = e * d"
+    and "d = r * p + s * pderiv p"
+  shows "rsquarefree q & (\<forall>a. (poly q a = 0) = (poly p a = 0))"
+proof -
+  from \<open>pderiv p \<noteq> 0\<close> have "p \<noteq> 0" by auto
+  with \<open>p = q * d\<close> have "q \<noteq> 0" by simp
+  have "\<forall>a. order a q = (if order a p = 0 then 0 else 1)"
+    using assms by (rule poly_squarefree_decomp_order2)
+  with \<open>p \<noteq> 0\<close> \<open>q \<noteq> 0\<close> show ?thesis
+    by (simp add: rsquarefree_def order_root)
+qed
+
 
 subsection \<open>Algebraic numbers\<close>
 
@@ -3746,7 +2798,6 @@
   The equivalence is obvious since any rational polynomial can be multiplied with the 
   LCM of its coefficients, yielding an integer polynomial with the same roots.
 \<close>
-subsection \<open>Algebraic numbers\<close>
 
 definition algebraic :: "'a :: field_char_0 \<Rightarrow> bool" where
   "algebraic x \<longleftrightarrow> (\<exists>p. (\<forall>i. coeff p i \<in> \<int>) \<and> p \<noteq> 0 \<and> poly p x = 0)"
@@ -3761,25 +2812,6 @@
   obtains p where "\<And>i. coeff p i \<in> \<int>" "p \<noteq> 0" "poly p x = 0"
   using assms unfolding algebraic_def by blast
 
-lemma quotient_of_denom_pos': "snd (quotient_of x) > 0"
-  using quotient_of_denom_pos[OF surjective_pairing] .
-  
-lemma of_int_div_in_Ints: 
-  "b dvd a \<Longrightarrow> of_int a div of_int b \<in> (\<int> :: 'a :: ring_div set)"
-proof (cases "of_int b = (0 :: 'a)")
-  assume "b dvd a" "of_int b \<noteq> (0::'a)"
-  then obtain c where "a = b * c" by (elim dvdE)
-  with \<open>of_int b \<noteq> (0::'a)\<close> show ?thesis by simp
-qed auto
-
-lemma of_int_divide_in_Ints: 
-  "b dvd a \<Longrightarrow> of_int a / of_int b \<in> (\<int> :: 'a :: field set)"
-proof (cases "of_int b = (0 :: 'a)")
-  assume "b dvd a" "of_int b \<noteq> (0::'a)"
-  then obtain c where "a = b * c" by (elim dvdE)
-  with \<open>of_int b \<noteq> (0::'a)\<close> show ?thesis by simp
-qed auto
-
 lemma algebraic_altdef:
   fixes p :: "'a :: field_char_0 poly"
   shows "algebraic x \<longleftrightarrow> (\<exists>p. (\<forall>i. coeff p i \<in> \<rat>) \<and> p \<noteq> 0 \<and> poly p x = 0)"
@@ -3834,285 +2866,1426 @@
 qed
 
 
-text\<open>Lemmas for Derivatives\<close>
-
-lemma order_unique_lemma:
-  fixes p :: "'a::idom poly"
-  assumes "[:-a, 1:] ^ n dvd p" "\<not> [:-a, 1:] ^ Suc n dvd p"
-  shows "n = order a p"
-unfolding Polynomial.order_def
-apply (rule Least_equality [symmetric])
-apply (fact assms)
-apply (rule classical)
-apply (erule notE)
-unfolding not_less_eq_eq
-using assms(1) apply (rule power_le_dvd)
-apply assumption
-done
-
-lemma lemma_order_pderiv1:
-  "pderiv ([:- a, 1:] ^ Suc n * q) = [:- a, 1:] ^ Suc n * pderiv q +
-    smult (of_nat (Suc n)) (q * [:- a, 1:] ^ n)"
-apply (simp only: pderiv_mult pderiv_power_Suc)
-apply (simp del: power_Suc of_nat_Suc add: pderiv_pCons)
-done
-
-lemma lemma_order_pderiv:
-  fixes p :: "'a :: field_char_0 poly"
-  assumes n: "0 < n" 
-      and pd: "pderiv p \<noteq> 0" 
-      and pe: "p = [:- a, 1:] ^ n * q" 
-      and nd: "~ [:- a, 1:] dvd q"
-    shows "n = Suc (order a (pderiv p))"
-using n 
+subsection \<open>Content and primitive part of a polynomial\<close>
+
+definition content :: "('a :: semiring_Gcd poly) \<Rightarrow> 'a" where
+  "content p = Gcd (set (coeffs p))"
+
+lemma content_0 [simp]: "content 0 = 0"
+  by (simp add: content_def)
+
+lemma content_1 [simp]: "content 1 = 1"
+  by (simp add: content_def)
+
+lemma content_const [simp]: "content [:c:] = normalize c"
+  by (simp add: content_def cCons_def)
+
+lemma const_poly_dvd_iff_dvd_content:
+  fixes c :: "'a :: semiring_Gcd"
+  shows "[:c:] dvd p \<longleftrightarrow> c dvd content p"
+proof (cases "p = 0")
+  case [simp]: False
+  have "[:c:] dvd p \<longleftrightarrow> (\<forall>n. c dvd coeff p n)" by (rule const_poly_dvd_iff)
+  also have "\<dots> \<longleftrightarrow> (\<forall>a\<in>set (coeffs p). c dvd a)"
+  proof safe
+    fix n :: nat assume "\<forall>a\<in>set (coeffs p). c dvd a"
+    thus "c dvd coeff p n"
+      by (cases "n \<le> degree p") (auto simp: coeff_eq_0 coeffs_def split: if_splits)
+  qed (auto simp: coeffs_def simp del: upt_Suc split: if_splits)
+  also have "\<dots> \<longleftrightarrow> c dvd content p"
+    by (simp add: content_def dvd_Gcd_iff mult.commute [of "unit_factor x" for x]
+          dvd_mult_unit_iff)
+  finally show ?thesis .
+qed simp_all
+
+lemma content_dvd [simp]: "[:content p:] dvd p"
+  by (subst const_poly_dvd_iff_dvd_content) simp_all
+  
+lemma content_dvd_coeff [simp]: "content p dvd coeff p n"
+  by (cases "n \<le> degree p") 
+     (auto simp: content_def coeffs_def not_le coeff_eq_0 simp del: upt_Suc intro: Gcd_dvd)
+
+lemma content_dvd_coeffs: "c \<in> set (coeffs p) \<Longrightarrow> content p dvd c"
+  by (simp add: content_def Gcd_dvd)
+
+lemma normalize_content [simp]: "normalize (content p) = content p"
+  by (simp add: content_def)
+
+lemma is_unit_content_iff [simp]: "is_unit (content p) \<longleftrightarrow> content p = 1"
+proof
+  assume "is_unit (content p)"
+  hence "normalize (content p) = 1" by (simp add: is_unit_normalize del: normalize_content)
+  thus "content p = 1" by simp
+qed auto
+
+lemma content_smult [simp]: "content (smult c p) = normalize c * content p"
+  by (simp add: content_def coeffs_smult Gcd_mult)
+
+lemma content_eq_zero_iff [simp]: "content p = 0 \<longleftrightarrow> p = 0"
+  by (auto simp: content_def simp: poly_eq_iff coeffs_def)
+
+definition primitive_part :: "'a :: {semiring_Gcd,idom_divide} poly \<Rightarrow> 'a poly" where
+  "primitive_part p = (if p = 0 then 0 else map_poly (\<lambda>x. x div content p) p)"
+  
+lemma primitive_part_0 [simp]: "primitive_part 0 = 0"
+  by (simp add: primitive_part_def)
+
+lemma content_times_primitive_part [simp]:
+  fixes p :: "'a :: {idom_divide, semiring_Gcd} poly"
+  shows "smult (content p) (primitive_part p) = p"
+proof (cases "p = 0")
+  case False
+  thus ?thesis
+  unfolding primitive_part_def
+  by (auto simp: smult_conv_map_poly map_poly_map_poly o_def content_dvd_coeffs 
+           intro: map_poly_idI)
+qed simp_all
+
+lemma primitive_part_eq_0_iff [simp]: "primitive_part p = 0 \<longleftrightarrow> p = 0"
+proof (cases "p = 0")
+  case False
+  hence "primitive_part p = map_poly (\<lambda>x. x div content p) p"
+    by (simp add:  primitive_part_def)
+  also from False have "\<dots> = 0 \<longleftrightarrow> p = 0"
+    by (intro map_poly_eq_0_iff) (auto simp: dvd_div_eq_0_iff content_dvd_coeffs)
+  finally show ?thesis using False by simp
+qed simp
+
+lemma content_primitive_part [simp]:
+  assumes "p \<noteq> 0"
+  shows   "content (primitive_part p) = 1"
 proof -
-  have "pderiv ([:- a, 1:] ^ n * q) \<noteq> 0"
-    using assms by auto
-  obtain n' where "n = Suc n'" "0 < Suc n'" "pderiv ([:- a, 1:] ^ Suc n' * q) \<noteq> 0"
-    using assms by (cases n) auto
-  have *: "!!k l. k dvd k * pderiv q + smult (of_nat (Suc n')) l \<Longrightarrow> k dvd l"
-    by (auto simp del: of_nat_Suc simp: dvd_add_right_iff dvd_smult_iff)
-  have "n' = order a (pderiv ([:- a, 1:] ^ Suc n' * q))" 
-  proof (rule order_unique_lemma)
-    show "[:- a, 1:] ^ n' dvd pderiv ([:- a, 1:] ^ Suc n' * q)"
-      apply (subst lemma_order_pderiv1)
-      apply (rule dvd_add)
-      apply (metis dvdI dvd_mult2 power_Suc2)
-      apply (metis dvd_smult dvd_triv_right)
-      done
+  have "p = smult (content p) (primitive_part p)" by simp
+  also have "content \<dots> = content p * content (primitive_part p)" 
+    by (simp del: content_times_primitive_part)
+  finally show ?thesis using assms by simp
+qed
+
+lemma content_decompose:
+  fixes p :: "'a :: semiring_Gcd poly"
+  obtains p' where "p = smult (content p) p'" "content p' = 1"
+proof (cases "p = 0")
+  case True
+  thus ?thesis by (intro that[of 1]) simp_all
+next
+  case False
+  from content_dvd[of p] obtain r where r: "p = [:content p:] * r" by (erule dvdE)
+  have "content p * 1 = content p * content r" by (subst r) simp
+  with False have "content r = 1" by (subst (asm) mult_left_cancel) simp_all
+  with r show ?thesis by (intro that[of r]) simp_all
+qed
+
+lemma content_dvd_contentI [intro]:
+  "p dvd q \<Longrightarrow> content p dvd content q"
+  using const_poly_dvd_iff_dvd_content content_dvd dvd_trans by blast
+  
+lemma primitive_part_const_poly [simp]: "primitive_part [:x:] = [:unit_factor x:]"
+  by (simp add: primitive_part_def map_poly_pCons)
+ 
+lemma primitive_part_prim: "content p = 1 \<Longrightarrow> primitive_part p = p"
+  by (auto simp: primitive_part_def)
+  
+lemma degree_primitive_part [simp]: "degree (primitive_part p) = degree p"
+proof (cases "p = 0")
+  case False
+  have "p = smult (content p) (primitive_part p)" by simp
+  also from False have "degree \<dots> = degree (primitive_part p)"
+    by (subst degree_smult_eq) simp_all
+  finally show ?thesis ..
+qed simp_all
+
+
+subsection \<open>Division of polynomials\<close>
+
+subsubsection \<open>Division in general\<close>
+  
+instantiation poly :: (idom_divide) idom_divide
+begin
+
+fun divide_poly_main :: "'a \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly 
+  \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a poly" where
+  "divide_poly_main lc q r d dr (Suc n) = (let cr = coeff r dr; a = cr div lc; mon = monom a n in 
+     if False \<or> a * lc = cr then (* False \<or> is only because of problem in function-package *)
+     divide_poly_main 
+       lc 
+       (q + mon) 
+       (r - mon * d) 
+       d (dr - 1) n else 0)"
+| "divide_poly_main lc q r d dr 0 = q"
+
+definition divide_poly :: "'a poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
+  "divide_poly f g = (if g = 0 then 0 else
+     divide_poly_main (coeff g (degree g)) 0 f g (degree f) (1 + length (coeffs f) - length (coeffs g)))" 
+
+lemma divide_poly_main:
+  assumes d: "d \<noteq> 0" "lc = coeff d (degree d)"
+    and *: "degree (d * r) \<le> dr" "divide_poly_main lc q (d * r) d dr n = q'" 
+    "n = 1 + dr - degree d \<or> dr = 0 \<and> n = 0 \<and> d * r = 0" 
+  shows "q' = q + r"
+  using *
+proof (induct n arbitrary: q r dr)
+  case (Suc n q r dr)
+  let ?rr = "d * r"
+  let ?a = "coeff ?rr dr"
+  let ?qq = "?a div lc"
+  define b where [simp]: "b = monom ?qq n"
+  let ?rrr =  "d * (r - b)"
+  let ?qqq = "q + b"
+  note res = Suc(3)
+  have dr: "dr = n + degree d" using Suc(4) by auto
+  have lc: "lc \<noteq> 0" using d by auto
+  have "coeff (b * d) dr = coeff b n * coeff d (degree d)"
+  proof (cases "?qq = 0")
+    case False
+    hence n: "n = degree b" by (simp add: degree_monom_eq)
+    show ?thesis unfolding n dr by (simp add: coeff_mult_degree_sum)
+  qed simp
+  also have "\<dots> = lc * coeff b n" unfolding d by simp
+  finally have c2: "coeff (b * d) dr = lc * coeff b n" .
+  have rrr: "?rrr = ?rr - b * d" by (simp add: field_simps)
+  have c1: "coeff (d * r) dr = lc * coeff r n"
+  proof (cases "degree r = n")
+    case True
+    thus ?thesis using Suc(2) unfolding dr using coeff_mult_degree_sum[of d r] d by (auto simp: ac_simps)
   next
-    show "\<not> [:- a, 1:] ^ Suc n' dvd pderiv ([:- a, 1:] ^ Suc n' * q)"
-     apply (subst lemma_order_pderiv1)
-     by (metis * nd dvd_mult_cancel_right power_not_zero pCons_eq_0_iff power_Suc zero_neq_one)
+    case False
+    have "degree r \<le> n" using dr Suc(2) by auto
+      (metis add.commute add_le_cancel_left d(1) degree_0 degree_mult_eq diff_is_0_eq diff_zero le_cases)
+    with False have r_n: "degree r < n" by auto
+    hence right: "lc * coeff r n = 0" by (simp add: coeff_eq_0)
+    have "coeff (d * r) dr = coeff (d * r) (degree d + n)" unfolding dr by (simp add: ac_simps)
+    also have "\<dots> = 0" using r_n
+      by (metis False Suc.prems(1) add.commute add_left_imp_eq coeff_degree_mult coeff_eq_0 
+        coeff_mult_degree_sum degree_mult_le dr le_eq_less_or_eq)
+    finally show ?thesis unfolding right .
+  qed
+  have c0: "coeff ?rrr dr = 0" 
+    and id: "lc * (coeff (d * r) dr div lc) = coeff (d * r) dr" unfolding rrr coeff_diff c2
+    unfolding b_def coeff_monom coeff_smult c1 using lc by auto
+  from res[unfolded divide_poly_main.simps[of lc q] Let_def] id
+  have res: "divide_poly_main lc ?qqq ?rrr d (dr - 1) n = q'" 
+    by (simp del: divide_poly_main.simps add: field_simps)
+  note IH = Suc(1)[OF _ res] 
+  have dr: "dr = n + degree d" using Suc(4) by auto
+  have deg_rr: "degree ?rr \<le> dr" using Suc(2) by auto
+  have deg_bd: "degree (b * d) \<le> dr"
+    unfolding dr b_def by (rule order.trans[OF degree_mult_le], auto simp: degree_monom_le)
+  have "degree ?rrr \<le> dr" unfolding rrr by (rule degree_diff_le[OF deg_rr deg_bd])
+  with c0 have deg_rrr: "degree ?rrr \<le> (dr - 1)"
+    by (rule coeff_0_degree_minus_1)
+  have "n = 1 + (dr - 1) - degree d \<or> dr - 1 = 0 \<and> n = 0 \<and> ?rrr = 0"  
+  proof (cases dr)
+    case 0
+    with Suc(4) have 0: "dr = 0" "n = 0" "degree d = 0" by auto
+    with deg_rrr have "degree ?rrr = 0" by simp
+    from degree_eq_zeroE[OF this] obtain a where rrr: "?rrr = [:a:]" by metis
+    show ?thesis unfolding 0 using c0 unfolding rrr 0 by simp
+  qed (insert Suc(4), auto)
+  note IH = IH[OF deg_rrr this]
+  show ?case using IH by simp
+next
+  case (0 q r dr)
+  show ?case 
+  proof (cases "r = 0")
+    case True
+    thus ?thesis using 0 by auto
+  next
+    case False
+    have "degree (d * r) = degree d + degree r" using d False 
+      by (subst degree_mult_eq, auto)
+    thus ?thesis using 0 d by auto
+  qed
+qed 
+
+lemma divide_poly_main_0: "divide_poly_main 0 0 r d dr n = 0"
+proof (induct n arbitrary: r d dr)
+  case (Suc n r d dr)
+  show ?case unfolding divide_poly_main.simps[of _ _ r] Let_def
+    by (simp add: Suc del: divide_poly_main.simps)
+qed simp
+
+lemma divide_poly:
+  assumes g: "g \<noteq> 0"
+  shows "(f * g) div g = (f :: 'a poly)" 
+proof - 
+  have "divide_poly_main (coeff g (degree g)) 0 (g * f) g (degree (g * f)) (1 + length (coeffs (g * f)) - length (coeffs  g)) 
+    = (f * g) div g" unfolding divide_poly_def Let_def by (simp add: ac_simps)
+  note main = divide_poly_main[OF g refl le_refl this]
+  {
+    fix f :: "'a poly"
+    assume "f \<noteq> 0"
+    hence "length (coeffs f) = Suc (degree f)" unfolding degree_eq_length_coeffs by auto
+  } note len = this
+  have "(f * g) div g = 0 + f"
+  proof (rule main, goal_cases)
+    case 1
+    show ?case
+    proof (cases "f = 0")
+      case True
+      with g show ?thesis by (auto simp: degree_eq_length_coeffs)
+    next
+      case False
+      with g have fg: "g * f \<noteq> 0" by auto
+      show ?thesis unfolding len[OF fg] len[OF g] by auto
+    qed
   qed
-  then show ?thesis
-    by (metis \<open>n = Suc n'\<close> pe)
+  thus ?thesis by simp
+qed
+
+lemma divide_poly_0: "f div 0 = (0 :: 'a poly)"
+  by (simp add: divide_poly_def Let_def divide_poly_main_0)
+
+instance
+  by standard (auto simp: divide_poly divide_poly_0)
+
+end
+
+instance poly :: (idom_divide) algebraic_semidom ..
+
+lemma div_const_poly_conv_map_poly: 
+  assumes "[:c:] dvd p"
+  shows   "p div [:c:] = map_poly (\<lambda>x. x div c) p"
+proof (cases "c = 0")
+  case False
+  from assms obtain q where p: "p = [:c:] * q" by (erule dvdE)
+  moreover {
+    have "smult c q = [:c:] * q" by simp
+    also have "\<dots> div [:c:] = q" by (rule nonzero_mult_div_cancel_left) (insert False, auto)
+    finally have "smult c q div [:c:] = q" .
+  }
+  ultimately show ?thesis by (intro poly_eqI) (auto simp: coeff_map_poly False)
+qed (auto intro!: poly_eqI simp: coeff_map_poly)
+
+lemma is_unit_monom_0:
+  fixes a :: "'a::field"
+  assumes "a \<noteq> 0"
+  shows "is_unit (monom a 0)"
+proof
+  from assms show "1 = monom a 0 * monom (inverse a) 0"
+    by (simp add: mult_monom)
 qed
 
-lemma order_decomp:
-  assumes "p \<noteq> 0"
-  shows "\<exists>q. p = [:- a, 1:] ^ order a p * q \<and> \<not> [:- a, 1:] dvd q"
+lemma is_unit_triv:
+  fixes a :: "'a::field"
+  assumes "a \<noteq> 0"
+  shows "is_unit [:a:]"
+  using assms by (simp add: is_unit_monom_0 monom_0 [symmetric])
+
+lemma is_unit_iff_degree:
+  assumes "p \<noteq> (0 :: _ :: field poly)"
+  shows "is_unit p \<longleftrightarrow> degree p = 0" (is "?P \<longleftrightarrow> ?Q")
+proof
+  assume ?Q
+  then obtain a where "p = [:a:]" by (rule degree_eq_zeroE)
+  with assms show ?P by (simp add: is_unit_triv)
+next
+  assume ?P
+  then obtain q where "q \<noteq> 0" "p * q = 1" ..
+  then have "degree (p * q) = degree 1"
+    by simp
+  with \<open>p \<noteq> 0\<close> \<open>q \<noteq> 0\<close> have "degree p + degree q = 0"
+    by (simp add: degree_mult_eq)
+  then show ?Q by simp
+qed
+
+lemma is_unit_pCons_iff:
+  "is_unit (pCons (a::_::field) p) \<longleftrightarrow> p = 0 \<and> a \<noteq> 0"
+  by (cases "p = 0") (auto simp add: is_unit_triv is_unit_iff_degree)
+
+lemma is_unit_monom_trival:
+  fixes p :: "'a::field poly"
+  assumes "is_unit p"
+  shows "monom (coeff p (degree p)) 0 = p"
+  using assms by (cases p) (simp_all add: monom_0 is_unit_pCons_iff)
+
+lemma is_unit_const_poly_iff: 
+  "[:c :: 'a :: {comm_semiring_1,semiring_no_zero_divisors}:] dvd 1 \<longleftrightarrow> c dvd 1"
+  by (auto simp: one_poly_def)
+
+lemma is_unit_polyE:
+  fixes p :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
+  assumes "p dvd 1" obtains c where "p = [:c:]" "c dvd 1"
 proof -
-  from assms have A: "[:- a, 1:] ^ order a p dvd p"
-    and B: "\<not> [:- a, 1:] ^ Suc (order a p) dvd p" by (auto dest: order)
-  from A obtain q where C: "p = [:- a, 1:] ^ order a p * q" ..
-  with B have "\<not> [:- a, 1:] ^ Suc (order a p) dvd [:- a, 1:] ^ order a p * q"
+  from assms obtain q where "1 = p * q"
+    by (rule dvdE)
+  then have "p \<noteq> 0" and "q \<noteq> 0"
+    by auto
+  from \<open>1 = p * q\<close> have "degree 1 = degree (p * q)"
     by simp
-  then have "\<not> [:- a, 1:] ^ order a p * [:- a, 1:] dvd [:- a, 1:] ^ order a p * q"
-    by simp
-  then have D: "\<not> [:- a, 1:] dvd q"
-    using idom_class.dvd_mult_cancel_left [of "[:- a, 1:] ^ order a p" "[:- a, 1:]" q]
-    by auto
-  from C D show ?thesis by blast
+  also from \<open>p \<noteq> 0\<close> and \<open>q \<noteq> 0\<close> have "\<dots> = degree p + degree q"
+    by (simp add: degree_mult_eq)
+  finally have "degree p = 0" by simp
+  with degree_eq_zeroE obtain c where c: "p = [:c:]" .
+  moreover with \<open>p dvd 1\<close> have "c dvd 1"
+    by (simp add: is_unit_const_poly_iff)
+  ultimately show thesis
+    by (rule that)
+qed
+
+lemma is_unit_polyE':
+  assumes "is_unit (p::_::field poly)"
+  obtains a where "p = monom a 0" and "a \<noteq> 0"
+proof -
+  obtain a q where "p = pCons a q" by (cases p)
+  with assms have "p = [:a:]" and "a \<noteq> 0"
+    by (simp_all add: is_unit_pCons_iff)
+  with that show thesis by (simp add: monom_0)
 qed
 
-lemma order_pderiv:
-  "\<lbrakk>pderiv p \<noteq> 0; order a (p :: 'a :: field_char_0 poly) \<noteq> 0\<rbrakk> \<Longrightarrow>
-     (order a p = Suc (order a (pderiv p)))"
-apply (case_tac "p = 0", simp)
-apply (drule_tac a = a and p = p in order_decomp)
-using neq0_conv
-apply (blast intro: lemma_order_pderiv)
-done
-
-lemma order_mult: "p * q \<noteq> 0 \<Longrightarrow> order a (p * q) = order a p + order a q"
+lemma is_unit_poly_iff:
+  fixes p :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
+  shows "p dvd 1 \<longleftrightarrow> (\<exists>c. p = [:c:] \<and> c dvd 1)"
+  by (auto elim: is_unit_polyE simp add: is_unit_const_poly_iff)
+
+  
+subsubsection \<open>Pseudo-Division\<close>
+
+text\<open>This part is by René Thiemann and Akihisa Yamada.\<close>
+
+fun pseudo_divmod_main :: "'a :: comm_ring_1  \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly 
+  \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a poly \<times> 'a poly" where
+  "pseudo_divmod_main lc q r d dr (Suc n) = (let
+     rr = smult lc r;
+     qq = coeff r dr;
+     rrr = rr - monom qq n * d;
+     qqq = smult lc q + monom qq n
+     in pseudo_divmod_main lc qqq rrr d (dr - 1) n)"
+| "pseudo_divmod_main lc q r d dr 0 = (q,r)"
+
+definition pseudo_divmod :: "'a :: comm_ring_1 poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<times> 'a poly" where
+  "pseudo_divmod p q \<equiv> if q = 0 then (0,p) else
+     pseudo_divmod_main (coeff q (degree q)) 0 p q (degree p) (1 + length (coeffs p) - length (coeffs q))"
+
+lemma pseudo_divmod_main: assumes d: "d \<noteq> 0" "lc = coeff d (degree d)"
+  and *: "degree r \<le> dr" "pseudo_divmod_main lc q r d dr n = (q',r')" 
+    "n = 1 + dr - degree d \<or> dr = 0 \<and> n = 0 \<and> r = 0" 
+  shows "(r' = 0 \<or> degree r' < degree d) \<and> smult (lc^n) (d * q + r) = d * q' + r'"
+  using *
+proof (induct n arbitrary: q r dr)
+  case (Suc n q r dr)
+  let ?rr = "smult lc r"
+  let ?qq = "coeff r dr"
+  define b where [simp]: "b = monom ?qq n"
+  let ?rrr = "?rr - b * d"
+  let ?qqq = "smult lc q + b"
+  note res = Suc(3)
+  from res[unfolded pseudo_divmod_main.simps[of lc q] Let_def] 
+  have res: "pseudo_divmod_main lc ?qqq ?rrr d (dr - 1) n = (q',r')" 
+    by (simp del: pseudo_divmod_main.simps)
+  have dr: "dr = n + degree d" using Suc(4) by auto
+  have "coeff (b * d) dr = coeff b n * coeff d (degree d)"
+  proof (cases "?qq = 0")
+    case False
+    hence n: "n = degree b" by (simp add: degree_monom_eq)
+    show ?thesis unfolding n dr by (simp add: coeff_mult_degree_sum)
+  qed auto
+  also have "\<dots> = lc * coeff b n" unfolding d by simp
+  finally have "coeff (b * d) dr = lc * coeff b n" .
+  moreover have "coeff ?rr dr = lc * coeff r dr" by simp
+  ultimately have c0: "coeff ?rrr dr = 0" by auto
+  have dr: "dr = n + degree d" using Suc(4) by auto
+  have deg_rr: "degree ?rr \<le> dr" using Suc(2) 
+    using degree_smult_le dual_order.trans by blast 
+  have deg_bd: "degree (b * d) \<le> dr"
+    unfolding dr
+    by(rule order.trans[OF degree_mult_le], auto simp: degree_monom_le)
+  have "degree ?rrr \<le> dr"
+    using degree_diff_le[OF deg_rr deg_bd] by auto
+  with c0 have deg_rrr: "degree ?rrr \<le> (dr - 1)" by (rule coeff_0_degree_minus_1)
+  have "n = 1 + (dr - 1) - degree d \<or> dr - 1 = 0 \<and> n = 0 \<and> ?rrr = 0"
+  proof (cases dr)
+    case 0
+    with Suc(4) have 0: "dr = 0" "n = 0" "degree d = 0" by auto
+    with deg_rrr have "degree ?rrr = 0" by simp
+    hence "\<exists> a. ?rrr = [: a :]" by (metis degree_pCons_eq_if old.nat.distinct(2) pCons_cases)
+    from this obtain a where rrr: "?rrr = [:a:]" by auto
+    show ?thesis unfolding 0 using c0 unfolding rrr 0 by simp
+  qed (insert Suc(4), auto)
+  note IH = Suc(1)[OF deg_rrr res this]
+  show ?case
+  proof (intro conjI)
+    show "r' = 0 \<or> degree r' < degree d" using IH by blast
+    show "smult (lc ^ Suc n) (d * q + r) = d * q' + r'"
+      unfolding IH[THEN conjunct2,symmetric]
+      by (simp add: field_simps smult_add_right)
+  qed
+qed auto
+
+lemma pseudo_divmod:
+  assumes g: "g \<noteq> 0" and *: "pseudo_divmod f g = (q,r)" 
+  shows "smult (coeff g (degree g) ^ (Suc (degree f) - degree g)) f = g * q + r" (is ?A)
+    and "r = 0 \<or> degree r < degree g" (is ?B)
 proof -
-  define i where "i = order a p"
-  define j where "j = order a q"
-  define t where "t = [:-a, 1:]"
-  have t_dvd_iff: "\<And>u. t dvd u \<longleftrightarrow> poly u a = 0"
-    unfolding t_def by (simp add: dvd_iff_poly_eq_0)
-  assume "p * q \<noteq> 0"
-  then show "order a (p * q) = i + j"
-    apply clarsimp
-    apply (drule order [where a=a and p=p, folded i_def t_def])
-    apply (drule order [where a=a and p=q, folded j_def t_def])
-    apply clarify
-    apply (erule dvdE)+
-    apply (rule order_unique_lemma [symmetric], fold t_def)
-    apply (simp_all add: power_add t_dvd_iff)
-    done
+  from *[unfolded pseudo_divmod_def Let_def]
+  have "pseudo_divmod_main (coeff g (degree g)) 0 f g (degree f) (1 + length (coeffs f) - length (coeffs g)) = (q, r)" by (auto simp: g)
+  note main = pseudo_divmod_main[OF _ _ _ this, OF g refl le_refl]
+  have "1 + length (coeffs f) - length (coeffs g) = 1 + degree f - degree g \<or>
+    degree f = 0 \<and> 1 + length (coeffs f) - length (coeffs g) = 0 \<and> f = 0" using g 
+    by (cases "f = 0"; cases "coeffs g", auto simp: degree_eq_length_coeffs)
+  note main = main[OF this]
+  from main show "r = 0 \<or> degree r < degree g" by auto
+  show "smult (coeff g (degree g) ^ (Suc (degree f) - degree g)) f = g * q + r" 
+    by (subst main[THEN conjunct2, symmetric], simp add: degree_eq_length_coeffs,
+    insert g, cases "f = 0"; cases "coeffs g", auto)
+qed
+  
+definition "pseudo_mod_main lc r d dr n = snd (pseudo_divmod_main lc 0 r d dr n)"
+
+lemma snd_pseudo_divmod_main:
+  "snd (pseudo_divmod_main lc q r d dr n) = snd (pseudo_divmod_main lc q' r d dr n)"
+by (induct n arbitrary: q q' lc r d dr; simp add: Let_def)
+
+definition pseudo_mod 
+    :: "'a :: {comm_ring_1,semiring_1_no_zero_divisors} poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
+  "pseudo_mod f g = snd (pseudo_divmod f g)"
+  
+lemma pseudo_mod:
+  fixes f g
+  defines "r \<equiv> pseudo_mod f g"
+  assumes g: "g \<noteq> 0"
+  shows "\<exists> a q. a \<noteq> 0 \<and> smult a f = g * q + r" "r = 0 \<or> degree r < degree g"
+proof - 
+  let ?cg = "coeff g (degree g)"
+  let ?cge = "?cg ^ (Suc (degree f) - degree g)"
+  define a where "a = ?cge"
+  obtain q where pdm: "pseudo_divmod f g = (q,r)" using r_def[unfolded pseudo_mod_def]
+    by (cases "pseudo_divmod f g", auto)
+  from pseudo_divmod[OF g pdm] have id: "smult a f = g * q + r" and "r = 0 \<or> degree r < degree g" 
+    unfolding a_def by auto
+  show "r = 0 \<or> degree r < degree g" by fact
+  from g have "a \<noteq> 0" unfolding a_def by auto
+  thus "\<exists> a q. a \<noteq> 0 \<and> smult a f = g * q + r" using id by auto
+qed
+  
+lemma fst_pseudo_divmod_main_as_divide_poly_main:
+  assumes d: "d \<noteq> 0"
+  defines lc: "lc \<equiv> coeff d (degree d)"
+  shows "fst (pseudo_divmod_main lc q r d dr n) = divide_poly_main lc (smult (lc^n) q) (smult (lc^n) r) d dr n"
+proof(induct n arbitrary: q r dr)
+  case 0 then show ?case by simp
+next
+  case (Suc n)
+    note lc0 = leading_coeff_neq_0[OF d, folded lc]
+    then have "pseudo_divmod_main lc q r d dr (Suc n) =
+    pseudo_divmod_main lc (smult lc q + monom (coeff r dr) n)
+      (smult lc r - monom (coeff r dr) n * d) d (dr - 1) n"
+    by (simp add: Let_def ac_simps)
+    also have "fst ... = divide_poly_main lc
+     (smult (lc^n) (smult lc q + monom (coeff r dr) n))
+     (smult (lc^n) (smult lc r - monom (coeff r dr) n * d))
+     d (dr - 1) n"
+      unfolding Suc[unfolded divide_poly_main.simps Let_def]..
+    also have "... = divide_poly_main lc (smult (lc ^ Suc n) q)
+        (smult (lc ^ Suc n) r) d dr (Suc n)"
+      unfolding smult_monom smult_distribs mult_smult_left[symmetric]
+      using lc0 by (simp add: Let_def ac_simps)
+    finally show ?case.
 qed
 
-lemma order_smult:
-  assumes "c \<noteq> 0" 
-  shows "order x (smult c p) = order x p"
+
+subsubsection \<open>Division in polynomials over fields\<close>
+
+lemma pseudo_divmod_field:
+  assumes g: "(g::'a::field poly) \<noteq> 0" and *: "pseudo_divmod f g = (q,r)"
+  defines "c \<equiv> coeff g (degree g) ^ (Suc (degree f) - degree g)"
+  shows "f = g * smult (1/c) q + smult (1/c) r"
+proof -
+  from leading_coeff_neq_0[OF g] have c0: "c \<noteq> 0" unfolding c_def by auto
+  from pseudo_divmod(1)[OF g *, folded c_def]
+  have "smult c f = g * q + r" by auto
+  also have "smult (1/c) ... = g * smult (1/c) q + smult (1/c) r" by (simp add: smult_add_right)
+  finally show ?thesis using c0 by auto
+qed
+
+lemma divide_poly_main_field:
+  assumes d: "(d::'a::field poly) \<noteq> 0"
+  defines lc: "lc \<equiv> coeff d (degree d)"
+  shows "divide_poly_main lc q r d dr n = fst (pseudo_divmod_main lc (smult ((1/lc)^n) q) (smult ((1/lc)^n) r) d dr n)"
+  unfolding lc
+  by(subst fst_pseudo_divmod_main_as_divide_poly_main, auto simp: d power_one_over)
+
+lemma divide_poly_field:
+  fixes f g :: "'a :: field poly"
+  defines "f' \<equiv> smult ((1 / coeff g (degree g)) ^ (Suc (degree f) - degree g)) f"
+  shows "(f::'a::field poly) div g = fst (pseudo_divmod f' g)"
+proof (cases "g = 0")
+  case True show ?thesis 
+    unfolding divide_poly_def pseudo_divmod_def Let_def f'_def True by (simp add: divide_poly_main_0)
+next
+  case False
+    from leading_coeff_neq_0[OF False] have "degree f' = degree f" unfolding f'_def by auto
+    then show ?thesis
+      using length_coeffs_degree[of f'] length_coeffs_degree[of f]
+      unfolding divide_poly_def pseudo_divmod_def Let_def
+                divide_poly_main_field[OF False]
+                length_coeffs_degree[OF False] 
+                f'_def
+      by force
+qed
+
+instantiation poly :: ("{normalization_semidom, idom_divide}") normalization_semidom
+begin
+
+definition unit_factor_poly :: "'a poly \<Rightarrow> 'a poly"
+  where "unit_factor_poly p = monom (unit_factor (lead_coeff p)) 0"
+
+definition normalize_poly :: "'a poly \<Rightarrow> 'a poly"
+  where "normalize_poly p = map_poly (\<lambda>x. x div unit_factor (lead_coeff p)) p"
+
+instance proof
+  fix p :: "'a poly"
+  show "unit_factor p * normalize p = p"
+    by (cases "p = 0")
+       (simp_all add: unit_factor_poly_def normalize_poly_def monom_0 
+          smult_conv_map_poly map_poly_map_poly o_def)
+next
+  fix p :: "'a poly"
+  assume "is_unit p"
+  then obtain c where p: "p = [:c:]" "is_unit c"
+    by (auto simp: is_unit_poly_iff)
+  thus "normalize p = 1"
+    by (simp add: normalize_poly_def map_poly_pCons is_unit_normalize one_poly_def)
+next
+  fix p :: "'a poly" assume "p \<noteq> 0"
+  thus "is_unit (unit_factor p)"
+    by (simp add: unit_factor_poly_def monom_0 is_unit_poly_iff)
+qed (simp_all add: normalize_poly_def unit_factor_poly_def monom_0 lead_coeff_mult unit_factor_mult)
+
+end
+
+lemma normalize_poly_eq_div:
+  "normalize p = p div [:unit_factor (lead_coeff p):]"
 proof (cases "p = 0")
   case False
+  thus ?thesis
+    by (subst div_const_poly_conv_map_poly)
+       (auto simp: normalize_poly_def const_poly_dvd_iff)
+qed (auto simp: normalize_poly_def)
+
+lemma unit_factor_pCons:
+  "unit_factor (pCons a p) = (if p = 0 then monom (unit_factor a) 0 else unit_factor p)"
+  by (simp add: unit_factor_poly_def)
+
+lemma normalize_monom [simp]:
+  "normalize (monom a n) = monom (normalize a) n"
+  by (cases "a = 0") (simp_all add: map_poly_monom normalize_poly_def degree_monom_eq)
+
+lemma unit_factor_monom [simp]:
+  "unit_factor (monom a n) = monom (unit_factor a) 0"
+  by (cases "a = 0") (simp_all add: unit_factor_poly_def degree_monom_eq)
+
+lemma normalize_const_poly: "normalize [:c:] = [:normalize c:]"
+  by (simp add: normalize_poly_def map_poly_pCons)
+
+lemma normalize_smult: "normalize (smult c p) = smult (normalize c) (normalize p)"
+proof -
   have "smult c p = [:c:] * p" by simp
-  also from assms False have "order x \<dots> = order x [:c:] + order x p" 
-    by (subst order_mult) simp_all
-  also from assms have "order x [:c:] = 0" by (intro order_0I) auto
-  finally show ?thesis by simp
-qed simp
-
-(* Next two lemmas contributed by Wenda Li *)
-lemma order_1_eq_0 [simp]:"order x 1 = 0" 
-  by (metis order_root poly_1 zero_neq_one)
-
-lemma order_power_n_n: "order a ([:-a,1:]^n)=n" 
-proof (induct n) (*might be proved more concisely using nat_less_induct*)
-  case 0
-  thus ?case by (metis order_root poly_1 power_0 zero_neq_one)
-next 
-  case (Suc n)
-  have "order a ([:- a, 1:] ^ Suc n)=order a ([:- a, 1:] ^ n) + order a [:-a,1:]" 
-    by (metis (no_types, hide_lams) One_nat_def add_Suc_right monoid_add_class.add.right_neutral 
-      one_neq_zero order_mult pCons_eq_0_iff power_add power_eq_0_iff power_one_right)
-  moreover have "order a [:-a,1:]=1" unfolding order_def
-    proof (rule Least_equality,rule ccontr)
-      assume  "\<not> \<not> [:- a, 1:] ^ Suc 1 dvd [:- a, 1:]"
-      hence "[:- a, 1:] ^ Suc 1 dvd [:- a, 1:]" by simp
-      hence "degree ([:- a, 1:] ^ Suc 1) \<le> degree ([:- a, 1:] )" 
-        by (rule dvd_imp_degree_le,auto) 
-      thus False by auto
-    next
-      fix y assume asm:"\<not> [:- a, 1:] ^ Suc y dvd [:- a, 1:]"
-      show "1 \<le> y" 
-        proof (rule ccontr)
-          assume "\<not> 1 \<le> y"
-          hence "y=0" by auto
-          hence "[:- a, 1:] ^ Suc y dvd [:- a, 1:]" by auto
-          thus False using asm by auto
-        qed
-    qed
-  ultimately show ?case using Suc by auto
+  also have "normalize \<dots> = smult (normalize c) (normalize p)"
+    by (subst normalize_mult) (simp add: normalize_const_poly)
+  finally show ?thesis .
 qed
 
-lemma order_0_monom [simp]:
-  assumes "c \<noteq> 0"
-  shows   "order 0 (monom c n) = n"
-  using assms order_power_n_n[of 0 n] by (simp add: monom_altdef order_smult)
-
-lemma dvd_imp_order_le:
-  "q \<noteq> 0 \<Longrightarrow> p dvd q \<Longrightarrow> Polynomial.order a p \<le> Polynomial.order a q"
-  by (auto simp: order_mult elim: dvdE)
-
-text\<open>Now justify the standard squarefree decomposition, i.e. f / gcd(f,f').\<close>
-
-lemma order_divides: "[:-a, 1:] ^ n dvd p \<longleftrightarrow> p = 0 \<or> n \<le> order a p"
-apply (cases "p = 0", auto)
-apply (drule order_2 [where a=a and p=p])
-apply (metis not_less_eq_eq power_le_dvd)
-apply (erule power_le_dvd [OF order_1])
-done
-
-lemma monom_1_dvd_iff:
-  assumes "p \<noteq> 0"
-  shows   "monom 1 n dvd p \<longleftrightarrow> n \<le> Polynomial.order 0 p"
-  using assms order_divides[of 0 n p] by (simp add: monom_altdef)
-
-lemma poly_squarefree_decomp_order:
-  assumes "pderiv (p :: 'a :: field_char_0 poly) \<noteq> 0"
-  and p: "p = q * d"
-  and p': "pderiv p = e * d"
-  and d: "d = r * p + s * pderiv p"
-  shows "order a q = (if order a p = 0 then 0 else 1)"
-proof (rule classical)
-  assume 1: "order a q \<noteq> (if order a p = 0 then 0 else 1)"
-  from \<open>pderiv p \<noteq> 0\<close> have "p \<noteq> 0" by auto
-  with p have "order a p = order a q + order a d"
-    by (simp add: order_mult)
-  with 1 have "order a p \<noteq> 0" by (auto split: if_splits)
-  have "order a (pderiv p) = order a e + order a d"
-    using \<open>pderiv p \<noteq> 0\<close> \<open>pderiv p = e * d\<close> by (simp add: order_mult)
-  have "order a p = Suc (order a (pderiv p))"
-    using \<open>pderiv p \<noteq> 0\<close> \<open>order a p \<noteq> 0\<close> by (rule order_pderiv)
-  have "d \<noteq> 0" using \<open>p \<noteq> 0\<close> \<open>p = q * d\<close> by simp
-  have "([:-a, 1:] ^ (order a (pderiv p))) dvd d"
-    apply (simp add: d)
-    apply (rule dvd_add)
-    apply (rule dvd_mult)
-    apply (simp add: order_divides \<open>p \<noteq> 0\<close>
-           \<open>order a p = Suc (order a (pderiv p))\<close>)
-    apply (rule dvd_mult)
-    apply (simp add: order_divides)
-    done
-  then have "order a (pderiv p) \<le> order a d"
-    using \<open>d \<noteq> 0\<close> by (simp add: order_divides)
-  show ?thesis
-    using \<open>order a p = order a q + order a d\<close>
-    using \<open>order a (pderiv p) = order a e + order a d\<close>
-    using \<open>order a p = Suc (order a (pderiv p))\<close>
-    using \<open>order a (pderiv p) \<le> order a d\<close>
-    by auto
-qed
-
-lemma poly_squarefree_decomp_order2: 
-     "\<lbrakk>pderiv p \<noteq> (0 :: 'a :: field_char_0 poly);
-       p = q * d;
-       pderiv p = e * d;
-       d = r * p + s * pderiv p
-      \<rbrakk> \<Longrightarrow> \<forall>a. order a q = (if order a p = 0 then 0 else 1)"
-by (blast intro: poly_squarefree_decomp_order)
-
-lemma order_pderiv2: 
-  "\<lbrakk>pderiv p \<noteq> 0; order a (p :: 'a :: field_char_0 poly) \<noteq> 0\<rbrakk>
-      \<Longrightarrow> (order a (pderiv p) = n) = (order a p = Suc n)"
-by (auto dest: order_pderiv)
-
-definition
-  rsquarefree :: "'a::idom poly => bool" where
-  "rsquarefree p = (p \<noteq> 0 & (\<forall>a. (order a p = 0) | (order a p = 1)))"
-
-lemma pderiv_iszero: "pderiv p = 0 \<Longrightarrow> \<exists>h. p = [:h :: 'a :: {semidom,semiring_char_0}:]"
-  by (cases p) (auto simp: pderiv_eq_0_iff split: if_splits)
-
-lemma rsquarefree_roots:
-  fixes p :: "'a :: field_char_0 poly"
-  shows "rsquarefree p = (\<forall>a. \<not>(poly p a = 0 \<and> poly (pderiv p) a = 0))"
-apply (simp add: rsquarefree_def)
-apply (case_tac "p = 0", simp, simp)
-apply (case_tac "pderiv p = 0")
-apply simp
-apply (drule pderiv_iszero, clarsimp)
-apply (metis coeff_0 coeff_pCons_0 degree_pCons_0 le0 le_antisym order_degree)
-apply (force simp add: order_root order_pderiv2)
-done
-
-lemma poly_squarefree_decomp:
-  assumes "pderiv (p :: 'a :: field_char_0 poly) \<noteq> 0"
-    and "p = q * d"
-    and "pderiv p = e * d"
-    and "d = r * p + s * pderiv p"
-  shows "rsquarefree q & (\<forall>a. (poly q a = 0) = (poly p a = 0))"
+lemma smult_content_normalize_primitive_part [simp]:
+  "smult (content p) (normalize (primitive_part p)) = normalize p"
 proof -
-  from \<open>pderiv p \<noteq> 0\<close> have "p \<noteq> 0" by auto
-  with \<open>p = q * d\<close> have "q \<noteq> 0" by simp
-  have "\<forall>a. order a q = (if order a p = 0 then 0 else 1)"
-    using assms by (rule poly_squarefree_decomp_order2)
-  with \<open>p \<noteq> 0\<close> \<open>q \<noteq> 0\<close> show ?thesis
-    by (simp add: rsquarefree_def order_root)
-qed
-
-lemma coeff_monom_mult: 
-  "coeff (monom c n * p) k = (if k < n then 0 else c * coeff p (k - n))"
-proof -
-  have "coeff (monom c n * p) k = (\<Sum>i\<le>k. (if n = i then c else 0) * coeff p (k - i))"
-    by (simp add: coeff_mult)
-  also have "\<dots> = (\<Sum>i\<le>k. (if n = i then c * coeff p (k - i) else 0))"
-    by (intro sum.cong) simp_all
-  also have "\<dots> = (if k < n then 0 else c * coeff p (k - n))" by (simp add: sum.delta')
+  have "smult (content p) (normalize (primitive_part p)) = 
+          normalize ([:content p:] * primitive_part p)" 
+    by (subst normalize_mult) (simp_all add: normalize_const_poly)
+  also have "[:content p:] * primitive_part p = p" by simp
   finally show ?thesis .
 qed
 
-lemma monom_1_dvd_iff':
-  "monom 1 n dvd p \<longleftrightarrow> (\<forall>k<n. coeff p k = 0)"
+inductive eucl_rel_poly :: "'a::field poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<times> 'a poly \<Rightarrow> bool"
+  where eucl_rel_poly_by0: "eucl_rel_poly x 0 (0, x)"
+  | eucl_rel_poly_dividesI: "y \<noteq> 0 \<Longrightarrow> x = q * y \<Longrightarrow> eucl_rel_poly x y (q, 0)"
+  | eucl_rel_poly_remainderI: "y \<noteq> 0 \<Longrightarrow> degree r < degree y
+      \<Longrightarrow> x = q * y + r \<Longrightarrow> eucl_rel_poly x y (q, r)"
+  
+lemma eucl_rel_poly_iff:
+  "eucl_rel_poly x y (q, r) \<longleftrightarrow>
+    x = q * y + r \<and>
+      (if y = 0 then q = 0 else r = 0 \<or> degree r < degree y)"
+  by (auto elim: eucl_rel_poly.cases
+    intro: eucl_rel_poly_by0 eucl_rel_poly_dividesI eucl_rel_poly_remainderI)
+  
+lemma eucl_rel_poly_0:
+  "eucl_rel_poly 0 y (0, 0)"
+  unfolding eucl_rel_poly_iff by simp
+
+lemma eucl_rel_poly_by_0:
+  "eucl_rel_poly x 0 (0, x)"
+  unfolding eucl_rel_poly_iff by simp
+
+lemma eucl_rel_poly_pCons:
+  assumes rel: "eucl_rel_poly x y (q, r)"
+  assumes y: "y \<noteq> 0"
+  assumes b: "b = coeff (pCons a r) (degree y) / coeff y (degree y)"
+  shows "eucl_rel_poly (pCons a x) y (pCons b q, pCons a r - smult b y)"
+    (is "eucl_rel_poly ?x y (?q, ?r)")
+proof -
+  have x: "x = q * y + r" and r: "r = 0 \<or> degree r < degree y"
+    using assms unfolding eucl_rel_poly_iff by simp_all
+
+  have 1: "?x = ?q * y + ?r"
+    using b x by simp
+
+  have 2: "?r = 0 \<or> degree ?r < degree y"
+  proof (rule eq_zero_or_degree_less)
+    show "degree ?r \<le> degree y"
+    proof (rule degree_diff_le)
+      show "degree (pCons a r) \<le> degree y"
+        using r by auto
+      show "degree (smult b y) \<le> degree y"
+        by (rule degree_smult_le)
+    qed
+  next
+    show "coeff ?r (degree y) = 0"
+      using \<open>y \<noteq> 0\<close> unfolding b by simp
+  qed
+
+  from 1 2 show ?thesis
+    unfolding eucl_rel_poly_iff
+    using \<open>y \<noteq> 0\<close> by simp
+qed
+
+lemma eucl_rel_poly_exists: "\<exists>q r. eucl_rel_poly x y (q, r)"
+apply (cases "y = 0")
+apply (fast intro!: eucl_rel_poly_by_0)
+apply (induct x)
+apply (fast intro!: eucl_rel_poly_0)
+apply (fast intro!: eucl_rel_poly_pCons)
+done
+
+lemma eucl_rel_poly_unique:
+  assumes 1: "eucl_rel_poly x y (q1, r1)"
+  assumes 2: "eucl_rel_poly x y (q2, r2)"
+  shows "q1 = q2 \<and> r1 = r2"
+proof (cases "y = 0")
+  assume "y = 0" with assms show ?thesis
+    by (simp add: eucl_rel_poly_iff)
+next
+  assume [simp]: "y \<noteq> 0"
+  from 1 have q1: "x = q1 * y + r1" and r1: "r1 = 0 \<or> degree r1 < degree y"
+    unfolding eucl_rel_poly_iff by simp_all
+  from 2 have q2: "x = q2 * y + r2" and r2: "r2 = 0 \<or> degree r2 < degree y"
+    unfolding eucl_rel_poly_iff by simp_all
+  from q1 q2 have q3: "(q1 - q2) * y = r2 - r1"
+    by (simp add: algebra_simps)
+  from r1 r2 have r3: "(r2 - r1) = 0 \<or> degree (r2 - r1) < degree y"
+    by (auto intro: degree_diff_less)
+
+  show "q1 = q2 \<and> r1 = r2"
+  proof (rule ccontr)
+    assume "\<not> (q1 = q2 \<and> r1 = r2)"
+    with q3 have "q1 \<noteq> q2" and "r1 \<noteq> r2" by auto
+    with r3 have "degree (r2 - r1) < degree y" by simp
+    also have "degree y \<le> degree (q1 - q2) + degree y" by simp
+    also have "\<dots> = degree ((q1 - q2) * y)"
+      using \<open>q1 \<noteq> q2\<close> by (simp add: degree_mult_eq)
+    also have "\<dots> = degree (r2 - r1)"
+      using q3 by simp
+    finally have "degree (r2 - r1) < degree (r2 - r1)" .
+    then show "False" by simp
+  qed
+qed
+
+lemma eucl_rel_poly_0_iff: "eucl_rel_poly 0 y (q, r) \<longleftrightarrow> q = 0 \<and> r = 0"
+by (auto dest: eucl_rel_poly_unique intro: eucl_rel_poly_0)
+
+lemma eucl_rel_poly_by_0_iff: "eucl_rel_poly x 0 (q, r) \<longleftrightarrow> q = 0 \<and> r = x"
+by (auto dest: eucl_rel_poly_unique intro: eucl_rel_poly_by_0)
+
+lemmas eucl_rel_poly_unique_div = eucl_rel_poly_unique [THEN conjunct1]
+
+lemmas eucl_rel_poly_unique_mod = eucl_rel_poly_unique [THEN conjunct2]
+
+instantiation poly :: (field) ring_div
+begin
+
+definition modulo_poly where
+  mod_poly_def: "f mod g \<equiv>
+    if g = 0 then f
+    else pseudo_mod (smult ((1/coeff g (degree g)) ^ (Suc (degree f) - degree g)) f) g"
+
+lemma eucl_rel_poly: "eucl_rel_poly (x::'a::field poly) y (x div y, x mod y)"
+  unfolding eucl_rel_poly_iff
+proof (intro conjI)
+  show "x = x div y * y + x mod y"
+  proof(cases "y = 0")
+    case True show ?thesis by(simp add: True divide_poly_def divide_poly_0 mod_poly_def)
+  next
+    case False
+    then have "pseudo_divmod (smult ((1 / coeff y (degree y)) ^ (Suc (degree x) - degree y)) x) y =
+          (x div y, x mod y)"
+      unfolding divide_poly_field mod_poly_def pseudo_mod_def by simp
+    from pseudo_divmod[OF False this]
+    show ?thesis using False
+      by (simp add: power_mult_distrib[symmetric] mult.commute)
+  qed
+  show "if y = 0 then x div y = 0 else x mod y = 0 \<or> degree (x mod y) < degree y"
+  proof (cases "y = 0")
+    case True then show ?thesis by auto
+  next
+    case False
+      with pseudo_mod[OF this] show ?thesis unfolding mod_poly_def by simp
+  qed
+qed
+
+lemma div_poly_eq:
+  "eucl_rel_poly (x::'a::field poly) y (q, r) \<Longrightarrow> x div y = q"
+  by(rule eucl_rel_poly_unique_div[OF eucl_rel_poly])
+
+lemma mod_poly_eq:
+  "eucl_rel_poly (x::'a::field poly) y (q, r) \<Longrightarrow> x mod y = r"
+  by (rule eucl_rel_poly_unique_mod[OF eucl_rel_poly])
+
+instance
 proof
-  assume "monom 1 n dvd p"
-  then obtain r where r: "p = monom 1 n * r" by (elim dvdE)
-  thus "\<forall>k<n. coeff p k = 0" by (simp add: coeff_mult)
+  fix x y :: "'a poly"
+  from eucl_rel_poly[of x y,unfolded eucl_rel_poly_iff]
+  show "x div y * y + x mod y = x" by auto
+next
+  fix x y z :: "'a poly"
+  assume "y \<noteq> 0"
+  hence "eucl_rel_poly (x + z * y) y (z + x div y, x mod y)"
+    using eucl_rel_poly [of x y]
+    by (simp add: eucl_rel_poly_iff distrib_right)
+  thus "(x + z * y) div y = z + x div y"
+    by (rule div_poly_eq)
 next
-  assume zero: "(\<forall>k<n. coeff p k = 0)"
-  define r where "r = Abs_poly (\<lambda>k. coeff p (k + n))"
-  have "\<forall>\<^sub>\<infinity>k. coeff p (k + n) = 0"
-    by (subst cofinite_eq_sequentially, subst eventually_sequentially_seg, 
-        subst cofinite_eq_sequentially [symmetric]) transfer
-  hence coeff_r [simp]: "coeff r k = coeff p (k + n)" for k unfolding r_def
-    by (subst poly.Abs_poly_inverse) simp_all
-  have "p = monom 1 n * r"
-    by (intro poly_eqI, subst coeff_monom_mult) (insert zero, simp_all)
-  thus "monom 1 n dvd p" by simp
+  fix x y z :: "'a poly"
+  assume "x \<noteq> 0"
+  show "(x * y) div (x * z) = y div z"
+  proof (cases "y \<noteq> 0 \<and> z \<noteq> 0")
+    have "\<And>x::'a poly. eucl_rel_poly x 0 (0, x)"
+      by (rule eucl_rel_poly_by_0)
+    then have [simp]: "\<And>x::'a poly. x div 0 = 0"
+      by (rule div_poly_eq)
+    have "\<And>x::'a poly. eucl_rel_poly 0 x (0, 0)"
+      by (rule eucl_rel_poly_0)
+    then have [simp]: "\<And>x::'a poly. 0 div x = 0"
+      by (rule div_poly_eq)
+    case False then show ?thesis by auto
+  next
+    case True then have "y \<noteq> 0" and "z \<noteq> 0" by auto
+    with \<open>x \<noteq> 0\<close>
+    have "\<And>q r. eucl_rel_poly y z (q, r) \<Longrightarrow> eucl_rel_poly (x * y) (x * z) (q, x * r)"
+      by (auto simp add: eucl_rel_poly_iff algebra_simps)
+        (rule classical, simp add: degree_mult_eq)
+    moreover from eucl_rel_poly have "eucl_rel_poly y z (y div z, y mod z)" .
+    ultimately have "eucl_rel_poly (x * y) (x * z) (y div z, x * (y mod z))" .
+    then show ?thesis by (simp add: div_poly_eq)
+  qed
+qed
+
+end
+
+lemma degree_mod_less:
+  "y \<noteq> 0 \<Longrightarrow> x mod y = 0 \<or> degree (x mod y) < degree y"
+  using eucl_rel_poly [of x y]
+  unfolding eucl_rel_poly_iff by simp
+
+lemma degree_mod_less': "b \<noteq> 0 \<Longrightarrow> a mod b \<noteq> 0 \<Longrightarrow> degree (a mod b) < degree b"
+  using degree_mod_less[of b a] by auto
+
+lemma div_poly_less: "degree (x::'a::field poly) < degree y \<Longrightarrow> x div y = 0"
+proof -
+  assume "degree x < degree y"
+  hence "eucl_rel_poly x y (0, x)"
+    by (simp add: eucl_rel_poly_iff)
+  thus "x div y = 0" by (rule div_poly_eq)
+qed
+
+lemma mod_poly_less: "degree x < degree y \<Longrightarrow> x mod y = x"
+proof -
+  assume "degree x < degree y"
+  hence "eucl_rel_poly x y (0, x)"
+    by (simp add: eucl_rel_poly_iff)
+  thus "x mod y = x" by (rule mod_poly_eq)
+qed
+
+lemma eucl_rel_poly_smult_left:
+  "eucl_rel_poly x y (q, r)
+    \<Longrightarrow> eucl_rel_poly (smult a x) y (smult a q, smult a r)"
+  unfolding eucl_rel_poly_iff by (simp add: smult_add_right)
+
+lemma div_smult_left: "(smult (a::'a::field) x) div y = smult a (x div y)"
+  by (rule div_poly_eq, rule eucl_rel_poly_smult_left, rule eucl_rel_poly)
+
+lemma mod_smult_left: "(smult a x) mod y = smult a (x mod y)"
+  by (rule mod_poly_eq, rule eucl_rel_poly_smult_left, rule eucl_rel_poly)
+
+lemma poly_div_minus_left [simp]:
+  fixes x y :: "'a::field poly"
+  shows "(- x) div y = - (x div y)"
+  using div_smult_left [of "- 1::'a"] by simp
+
+lemma poly_mod_minus_left [simp]:
+  fixes x y :: "'a::field poly"
+  shows "(- x) mod y = - (x mod y)"
+  using mod_smult_left [of "- 1::'a"] by simp
+
+lemma eucl_rel_poly_add_left:
+  assumes "eucl_rel_poly x y (q, r)"
+  assumes "eucl_rel_poly x' y (q', r')"
+  shows "eucl_rel_poly (x + x') y (q + q', r + r')"
+  using assms unfolding eucl_rel_poly_iff
+  by (auto simp add: algebra_simps degree_add_less)
+
+lemma poly_div_add_left:
+  fixes x y z :: "'a::field poly"
+  shows "(x + y) div z = x div z + y div z"
+  using eucl_rel_poly_add_left [OF eucl_rel_poly eucl_rel_poly]
+  by (rule div_poly_eq)
+
+lemma poly_mod_add_left:
+  fixes x y z :: "'a::field poly"
+  shows "(x + y) mod z = x mod z + y mod z"
+  using eucl_rel_poly_add_left [OF eucl_rel_poly eucl_rel_poly]
+  by (rule mod_poly_eq)
+
+lemma poly_div_diff_left:
+  fixes x y z :: "'a::field poly"
+  shows "(x - y) div z = x div z - y div z"
+  by (simp only: diff_conv_add_uminus poly_div_add_left poly_div_minus_left)
+
+lemma poly_mod_diff_left:
+  fixes x y z :: "'a::field poly"
+  shows "(x - y) mod z = x mod z - y mod z"
+  by (simp only: diff_conv_add_uminus poly_mod_add_left poly_mod_minus_left)
+
+lemma eucl_rel_poly_smult_right:
+  "a \<noteq> 0 \<Longrightarrow> eucl_rel_poly x y (q, r)
+    \<Longrightarrow> eucl_rel_poly x (smult a y) (smult (inverse a) q, r)"
+  unfolding eucl_rel_poly_iff by simp
+
+lemma div_smult_right:
+  "(a::'a::field) \<noteq> 0 \<Longrightarrow> x div (smult a y) = smult (inverse a) (x div y)"
+  by (rule div_poly_eq, erule eucl_rel_poly_smult_right, rule eucl_rel_poly)
+
+lemma mod_smult_right: "a \<noteq> 0 \<Longrightarrow> x mod (smult a y) = x mod y"
+  by (rule mod_poly_eq, erule eucl_rel_poly_smult_right, rule eucl_rel_poly)
+
+lemma poly_div_minus_right [simp]:
+  fixes x y :: "'a::field poly"
+  shows "x div (- y) = - (x div y)"
+  using div_smult_right [of "- 1::'a"] by (simp add: nonzero_inverse_minus_eq)
+
+lemma poly_mod_minus_right [simp]:
+  fixes x y :: "'a::field poly"
+  shows "x mod (- y) = x mod y"
+  using mod_smult_right [of "- 1::'a"] by simp
+
+lemma eucl_rel_poly_mult:
+  "eucl_rel_poly x y (q, r) \<Longrightarrow> eucl_rel_poly q z (q', r')
+    \<Longrightarrow> eucl_rel_poly x (y * z) (q', y * r' + r)"
+apply (cases "z = 0", simp add: eucl_rel_poly_iff)
+apply (cases "y = 0", simp add: eucl_rel_poly_by_0_iff eucl_rel_poly_0_iff)
+apply (cases "r = 0")
+apply (cases "r' = 0")
+apply (simp add: eucl_rel_poly_iff)
+apply (simp add: eucl_rel_poly_iff field_simps degree_mult_eq)
+apply (cases "r' = 0")
+apply (simp add: eucl_rel_poly_iff degree_mult_eq)
+apply (simp add: eucl_rel_poly_iff field_simps)
+apply (simp add: degree_mult_eq degree_add_less)
+done
+
+lemma poly_div_mult_right:
+  fixes x y z :: "'a::field poly"
+  shows "x div (y * z) = (x div y) div z"
+  by (rule div_poly_eq, rule eucl_rel_poly_mult, (rule eucl_rel_poly)+)
+
+lemma poly_mod_mult_right:
+  fixes x y z :: "'a::field poly"
+  shows "x mod (y * z) = y * (x div y mod z) + x mod y"
+  by (rule mod_poly_eq, rule eucl_rel_poly_mult, (rule eucl_rel_poly)+)
+
+lemma mod_pCons:
+  fixes a and x
+  assumes y: "y \<noteq> 0"
+  defines b: "b \<equiv> coeff (pCons a (x mod y)) (degree y) / coeff y (degree y)"
+  shows "(pCons a x) mod y = (pCons a (x mod y) - smult b y)"
+unfolding b
+apply (rule mod_poly_eq)
+apply (rule eucl_rel_poly_pCons [OF eucl_rel_poly y refl])
+done
+
+definition pdivmod :: "'a::field poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<times> 'a poly"
+where
+  "pdivmod p q = (p div q, p mod q)"
+
+lemma pdivmod_pdivmodrel: "eucl_rel_poly p q (r, s) \<longleftrightarrow> pdivmod p q = (r, s)"
+  by (metis pdivmod_def eucl_rel_poly eucl_rel_poly_unique)
+
+lemma pdivmod_0:
+  "pdivmod 0 q = (0, 0)"
+  by (simp add: pdivmod_def)
+
+lemma pdivmod_pCons:
+  "pdivmod (pCons a p) q =
+    (if q = 0 then (0, pCons a p) else
+      (let (s, r) = pdivmod p q;
+           b = coeff (pCons a r) (degree q) / coeff q (degree q)
+        in (pCons b s, pCons a r - smult b q)))"
+  apply (simp add: pdivmod_def Let_def, safe)
+  apply (rule div_poly_eq)
+  apply (erule eucl_rel_poly_pCons [OF eucl_rel_poly _ refl])
+  apply (rule mod_poly_eq)
+  apply (erule eucl_rel_poly_pCons [OF eucl_rel_poly _ refl])
+  done
+
+lemma pdivmod_fold_coeffs:
+  "pdivmod p q = (if q = 0 then (0, p)
+    else fold_coeffs (\<lambda>a (s, r).
+      let b = coeff (pCons a r) (degree q) / coeff q (degree q)
+      in (pCons b s, pCons a r - smult b q)
+   ) p (0, 0))"
+  apply (cases "q = 0")
+  apply (simp add: pdivmod_def)
+  apply (rule sym)
+  apply (induct p)
+  apply (simp_all add: pdivmod_0 pdivmod_pCons)
+  apply (case_tac "a = 0 \<and> p = 0")
+  apply (auto simp add: pdivmod_def)
+  done
+
+    
+subsubsection \<open>List-based versions for fast implementation\<close>
+(* Subsection by:
+      Sebastiaan Joosten
+      René Thiemann
+      Akihisa Yamada
+    *)
+fun minus_poly_rev_list :: "'a :: group_add list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
+  "minus_poly_rev_list (x # xs) (y # ys) = (x - y) # (minus_poly_rev_list xs ys)"
+| "minus_poly_rev_list xs [] = xs"
+| "minus_poly_rev_list [] (y # ys) = []"
+
+fun pseudo_divmod_main_list :: "'a::comm_ring_1 \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list 
+  \<Rightarrow> nat \<Rightarrow> 'a list \<times> 'a list" where
+  "pseudo_divmod_main_list lc q r d (Suc n) = (let
+     rr = map (op * lc) r;
+     a = hd r;
+     qqq = cCons a (map (op * lc) q);
+     rrr = tl (if a = 0 then rr else minus_poly_rev_list rr (map (op * a) d))
+     in pseudo_divmod_main_list lc qqq rrr d n)"
+| "pseudo_divmod_main_list lc q r d 0 = (q,r)"
+
+fun pseudo_mod_main_list :: "'a::comm_ring_1 \<Rightarrow> 'a list \<Rightarrow> 'a list 
+  \<Rightarrow> nat \<Rightarrow> 'a list" where
+  "pseudo_mod_main_list lc r d (Suc n) = (let
+     rr = map (op * lc) r;
+     a = hd r;
+     rrr = tl (if a = 0 then rr else minus_poly_rev_list rr (map (op * a) d))
+     in pseudo_mod_main_list lc rrr d n)"
+| "pseudo_mod_main_list lc r d 0 = r"
+
+
+fun divmod_poly_one_main_list :: "'a::comm_ring_1 list \<Rightarrow> 'a list \<Rightarrow> 'a list 
+  \<Rightarrow> nat \<Rightarrow> 'a list \<times> 'a list" where
+  "divmod_poly_one_main_list q r d (Suc n) = (let
+     a = hd r;
+     qqq = cCons a q;
+     rr = tl (if a = 0 then r else minus_poly_rev_list r (map (op * a) d))
+     in divmod_poly_one_main_list qqq rr d n)"
+| "divmod_poly_one_main_list q r d 0 = (q,r)"
+
+fun mod_poly_one_main_list :: "'a::comm_ring_1 list \<Rightarrow> 'a list 
+  \<Rightarrow> nat \<Rightarrow> 'a list" where
+  "mod_poly_one_main_list r d (Suc n) = (let
+     a = hd r;
+     rr = tl (if a = 0 then r else minus_poly_rev_list r (map (op * a) d))
+     in mod_poly_one_main_list rr d n)"
+| "mod_poly_one_main_list r d 0 = r"
+
+definition pseudo_divmod_list :: "'a::comm_ring_1 list \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list" where
+  "pseudo_divmod_list p q =
+  (if q = [] then ([],p) else
+ (let rq = rev q;
+     (qu,re) = pseudo_divmod_main_list (hd rq) [] (rev p) rq (1 + length p - length q) in 
+   (qu,rev re)))"
+
+definition pseudo_mod_list :: "'a::comm_ring_1 list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
+  "pseudo_mod_list p q =
+  (if q = [] then p else
+ (let rq = rev q;
+     re = pseudo_mod_main_list (hd rq) (rev p) rq (1 + length p - length q) in 
+   (rev re)))"
+
+lemma minus_zero_does_nothing:
+"(minus_poly_rev_list x (map (op * 0) y)) = (x :: 'a :: ring list)"
+  by(induct x y rule: minus_poly_rev_list.induct, auto)
+
+lemma length_minus_poly_rev_list[simp]:
+ "length (minus_poly_rev_list xs ys) = length xs"
+  by(induct xs ys rule: minus_poly_rev_list.induct, auto)
+
+lemma if_0_minus_poly_rev_list:
+  "(if a = 0 then x else minus_poly_rev_list x (map (op * a) y))
+      = minus_poly_rev_list x (map (op * (a :: 'a :: ring)) y)"
+  by(cases "a=0",simp_all add:minus_zero_does_nothing)
+
+lemma Poly_append:
+  "Poly ((a::'a::comm_semiring_1 list) @ b) = Poly a + monom 1 (length a) * Poly b"
+  by (induct a,auto simp: monom_0 monom_Suc)
+
+lemma minus_poly_rev_list: "length p \<ge> length (q :: 'a :: comm_ring_1 list) \<Longrightarrow>
+  Poly (rev (minus_poly_rev_list (rev p) (rev q)))
+  = Poly p - monom 1 (length p - length q) * Poly q"
+proof (induct "rev p" "rev q" arbitrary: p q rule: minus_poly_rev_list.induct)
+  case (1 x xs y ys) 
+  have "length (rev q) \<le> length (rev p)" using 1 by simp
+  from this[folded 1(2,3)] have ys_xs:"length ys \<le> length xs" by simp
+  hence a:"Poly (rev (minus_poly_rev_list xs ys)) =
+           Poly (rev xs) - monom 1 (length xs - length ys) * Poly (rev ys)"
+    by(subst "1.hyps"(1)[of "rev xs" "rev ys", unfolded rev_rev_ident length_rev],auto)
+  have "Poly p - monom 1 (length p - length q) * Poly q
+      = Poly (rev (rev p)) - monom 1 (length (rev (rev p)) - length (rev (rev q))) * Poly (rev (rev q))"
+    by simp
+  also have "\<dots> = Poly (rev (x # xs)) - monom 1 (length (x # xs) - length (y # ys)) * Poly (rev (y # ys))"
+    unfolding 1(2,3) by simp
+  also have "\<dots> = Poly (rev xs) + monom x (length xs) -
+  (monom 1 (length xs - length ys) * Poly (rev ys) + monom y (length xs))" using ys_xs
+    by (simp add:Poly_append distrib_left mult_monom smult_monom)
+  also have "\<dots> = Poly (rev (minus_poly_rev_list xs ys)) + monom (x - y) (length xs)"
+    unfolding a diff_monom[symmetric] by(simp)
+  finally show ?case
+    unfolding 1(2,3)[symmetric] by (simp add: smult_monom Poly_append)
+qed auto
+
+lemma smult_monom_mult: "smult a (monom b n * f) = monom (a * b) n * f"
+  using smult_monom [of a _ n] by (metis mult_smult_left)
+
+lemma head_minus_poly_rev_list:
+  "length d \<le> length r \<Longrightarrow> d\<noteq>[] \<Longrightarrow>
+  hd (minus_poly_rev_list (map (op * (last d :: 'a :: comm_ring)) r) (map (op * (hd r)) (rev d))) = 0"
+proof(induct r)
+  case (Cons a rs)
+  thus ?case by(cases "rev d", simp_all add:ac_simps)
+qed simp
+
+lemma Poly_map: "Poly (map (op * a) p) = smult a (Poly p)"
+proof (induct p)
+  case(Cons x xs) thus ?case by (cases "Poly xs = 0",auto)
+qed simp
+
+lemma last_coeff_is_hd: "xs \<noteq> [] \<Longrightarrow> coeff (Poly xs) (length xs - 1) = hd (rev xs)"
+  by (simp_all add: hd_conv_nth rev_nth nth_default_nth nth_append)
+
+lemma pseudo_divmod_main_list_invar :
+  assumes leading_nonzero:"last d \<noteq> 0"
+  and lc:"last d = lc"
+  and dNonempty:"d \<noteq> []"
+  and "pseudo_divmod_main_list lc q (rev r) (rev d) n = (q',rev r')"
+  and "n = (1 + length r - length d)"
+  shows 
+  "pseudo_divmod_main lc (monom 1 n * Poly q) (Poly r) (Poly d) (length r - 1) n = 
+  (Poly q', Poly r')"
+using assms(4-)
+proof(induct "n" arbitrary: r q)
+case (Suc n r q)
+  have ifCond: "\<not> Suc (length r) \<le> length d" using Suc.prems by simp
+  have rNonempty:"r \<noteq> []"
+    using ifCond dNonempty using Suc_leI length_greater_0_conv list.size(3) by fastforce
+  let ?a = "(hd (rev r))"
+  let ?rr = "map (op * lc) (rev r)"
+  let ?rrr = "rev (tl (minus_poly_rev_list ?rr (map (op * ?a) (rev d))))"
+  let ?qq = "cCons ?a (map (op * lc) q)"
+  have n: "n = (1 + length r - length d - 1)"
+    using ifCond Suc(3) by simp
+  have rr_val:"(length ?rrr) = (length r - 1)" using ifCond by auto
+  hence rr_smaller: "(1 + length r - length d - 1) = (1 + length ?rrr - length d)"
+    using rNonempty ifCond unfolding One_nat_def by auto
+  from ifCond have id: "Suc (length r) - length d = Suc (length r - length d)" by auto
+  have "pseudo_divmod_main_list lc ?qq (rev ?rrr) (rev d) (1 + length r - length d - 1) = (q', rev r')"
+    using Suc.prems ifCond by (simp add:Let_def if_0_minus_poly_rev_list id)
+  hence v:"pseudo_divmod_main_list lc ?qq (rev ?rrr) (rev d) n = (q', rev r')"
+    using n by auto
+  have sucrr:"Suc (length r) - length d = Suc (length r - length d)"
+    using Suc_diff_le ifCond not_less_eq_eq by blast
+  have n_ok : "n = 1 + (length ?rrr) - length d" using Suc(3) rNonempty by simp
+  have cong: "\<And> x1 x2 x3 x4 y1 y2 y3 y4. x1 = y1 \<Longrightarrow> x2 = y2 \<Longrightarrow> x3 = y3 \<Longrightarrow> x4 = y4 \<Longrightarrow>
+    pseudo_divmod_main lc x1 x2 x3 x4 n = pseudo_divmod_main lc y1 y2 y3 y4 n" by simp
+  have hd_rev:"coeff (Poly r) (length r - Suc 0) = hd (rev r)"
+    using last_coeff_is_hd[OF rNonempty] by simp
+  show ?case unfolding Suc.hyps(1)[OF v n_ok, symmetric] pseudo_divmod_main.simps Let_def
+  proof (rule cong[OF _ _ refl], goal_cases)
+    case 1 
+    show ?case unfolding monom_Suc hd_rev[symmetric]
+      by (simp add: smult_monom Poly_map)
+  next
+    case 2 
+    show ?case 
+    proof (subst Poly_on_rev_starting_with_0, goal_cases)
+      show "hd (minus_poly_rev_list (map (op * lc) (rev r)) (map (op * (hd (rev r))) (rev d))) = 0"
+        by (fold lc, subst head_minus_poly_rev_list, insert ifCond dNonempty,auto)
+      from ifCond have "length d \<le> length r" by simp
+      then show "smult lc (Poly r) - monom (coeff (Poly r) (length r - 1)) n * Poly d =
+        Poly (rev (minus_poly_rev_list (map (op * lc) (rev r)) (map (op * (hd (rev r))) (rev d))))"
+        by (fold rev_map) (auto simp add: n smult_monom_mult Poly_map hd_rev [symmetric]
+          minus_poly_rev_list)
+    qed
+  qed simp
+qed simp
+
+lemma pseudo_divmod_impl[code]: "pseudo_divmod (f::'a::comm_ring_1 poly) g =
+  map_prod poly_of_list poly_of_list (pseudo_divmod_list (coeffs f) (coeffs g))"
+proof (cases "g=0")
+case False
+  hence coeffs_g_nonempty:"(coeffs g) \<noteq> []" by simp
+  hence lastcoeffs:"last (coeffs g) = coeff g (degree g)"
+    by (simp add: hd_rev last_coeffs_eq_coeff_degree not_0_coeffs_not_Nil)
+  obtain q r where qr: "pseudo_divmod_main_list
+            (last (coeffs g)) (rev [])
+            (rev (coeffs f)) (rev (coeffs g))
+            (1 + length (coeffs f) -
+             length (coeffs g)) = (q,rev (rev r))"  by force
+  then have qr': "pseudo_divmod_main_list
+            (hd (rev (coeffs g))) []
+            (rev (coeffs f)) (rev (coeffs g))
+            (1 + length (coeffs f) -
+             length (coeffs g)) = (q,r)" using hd_rev[OF coeffs_g_nonempty] by(auto)
+  from False have cg: "(coeffs g = []) = False" by auto
+  have last_non0:"last (coeffs g) \<noteq> 0" using False by (simp add:last_coeffs_not_0)
+  show ?thesis
+    unfolding pseudo_divmod_def pseudo_divmod_list_def Let_def qr' map_prod_def split cg if_False
+    pseudo_divmod_main_list_invar[OF last_non0 _ _ qr,unfolded lastcoeffs,simplified,symmetric,OF False]
+    poly_of_list_def
+    using False by (auto simp: degree_eq_length_coeffs)
+next
+  case True
+  show ?thesis unfolding True unfolding pseudo_divmod_def pseudo_divmod_list_def
+  by auto
+qed
+
+lemma pseudo_mod_main_list: "snd (pseudo_divmod_main_list l q 
+  xs ys n) = pseudo_mod_main_list l xs ys n"
+  by (induct n arbitrary: l q xs ys, auto simp: Let_def)
+
+lemma pseudo_mod_impl[code]: "pseudo_mod f g =
+  poly_of_list (pseudo_mod_list (coeffs f) (coeffs g))"
+proof -
+  have snd_case: "\<And> f g p. snd ((\<lambda> (x,y). (f x, g y)) p) = g (snd p)" 
+    by auto
+  show ?thesis
+  unfolding pseudo_mod_def pseudo_divmod_impl pseudo_divmod_list_def
+    pseudo_mod_list_def Let_def
+  by (simp add: snd_case pseudo_mod_main_list)
+qed
+
+
+(* *************** *)
+subsubsection \<open>Improved Code-Equations for Polynomial (Pseudo) Division\<close>
+
+lemma pdivmod_via_pseudo_divmod: "pdivmod f g = (if g = 0 then (0,f) 
+     else let 
+       ilc = inverse (coeff g (degree g));       
+       h = smult ilc g;
+       (q,r) = pseudo_divmod f h
+     in (smult ilc q, r))" (is "?l = ?r")
+proof (cases "g = 0")
+  case False
+  define lc where "lc = inverse (coeff g (degree g))"
+  define h where "h = smult lc g"
+  from False have h1: "coeff h (degree h) = 1" and lc: "lc \<noteq> 0" unfolding h_def lc_def by auto
+  hence h0: "h \<noteq> 0" by auto
+  obtain q r where p: "pseudo_divmod f h = (q,r)" by force
+  from False have id: "?r = (smult lc q, r)" 
+    unfolding Let_def h_def[symmetric] lc_def[symmetric] p by auto
+  from pseudo_divmod[OF h0 p, unfolded h1] 
+  have f: "f = h * q + r" and r: "r = 0 \<or> degree r < degree h" by auto
+  have "eucl_rel_poly f h (q, r)" unfolding eucl_rel_poly_iff using f r h0 by auto
+  hence "pdivmod f h = (q,r)" by (simp add: pdivmod_pdivmodrel)
+  hence "pdivmod f g = (smult lc q, r)" 
+    unfolding pdivmod_def h_def div_smult_right[OF lc] mod_smult_right[OF lc]
+    using lc by auto
+  with id show ?thesis by auto
+qed (auto simp: pdivmod_def)
+
+lemma pdivmod_via_pseudo_divmod_list: "pdivmod f g = (let 
+  cg = coeffs g
+  in if cg = [] then (0,f)
+     else let 
+       cf = coeffs f;
+       ilc = inverse (last cg);       
+       ch = map (op * ilc) cg;
+       (q,r) = pseudo_divmod_main_list 1 [] (rev cf) (rev ch) (1 + length cf - length cg)
+     in (poly_of_list (map (op * ilc) q), poly_of_list (rev r)))"
+proof -
+  note d = pdivmod_via_pseudo_divmod
+      pseudo_divmod_impl pseudo_divmod_list_def
+  show ?thesis
+  proof (cases "g = 0")
+    case True thus ?thesis unfolding d by auto
+  next
+    case False
+    define ilc where "ilc = inverse (coeff g (degree g))"
+    from False have ilc: "ilc \<noteq> 0" unfolding ilc_def by auto
+    with False have id: "(g = 0) = False" "(coeffs g = []) = False" 
+      "last (coeffs g) = coeff g (degree g)" 
+      "(coeffs (smult ilc g) = []) = False"
+      by (auto simp: last_coeffs_eq_coeff_degree) 
+    have id2: "hd (rev (coeffs (smult ilc g))) = 1"      
+      by (subst hd_rev, insert id ilc, auto simp: coeffs_smult, subst last_map, auto simp: id ilc_def)
+    have id3: "length (coeffs (smult ilc g)) = length (coeffs g)" 
+      "rev (coeffs (smult ilc g)) = rev (map (op * ilc) (coeffs g))" unfolding coeffs_smult using ilc by auto
+    obtain q r where pair: "pseudo_divmod_main_list 1 [] (rev (coeffs f)) (rev (map (op * ilc) (coeffs g)))
+           (1 + length (coeffs f) - length (coeffs g)) = (q,r)" by force
+    show ?thesis unfolding d Let_def id if_False ilc_def[symmetric] map_prod_def[symmetric] id2 
+      unfolding id3 pair map_prod_def split by (auto simp: Poly_map)
+  qed
+qed
+
+lemma pseudo_divmod_main_list_1: "pseudo_divmod_main_list 1 = divmod_poly_one_main_list"
+proof (intro ext, goal_cases)
+  case (1 q r d n)
+  {
+    fix xs :: "'a list"
+    have "map (op * 1) xs = xs" by (induct xs, auto)
+  } note [simp] = this
+  show ?case by (induct n arbitrary: q r d, auto simp: Let_def)
+qed
+
+fun divide_poly_main_list :: "'a::idom_divide \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list 
+  \<Rightarrow> nat \<Rightarrow> 'a list" where
+  "divide_poly_main_list lc q r d (Suc n) = (let
+     cr = hd r
+     in if cr = 0 then divide_poly_main_list lc (cCons cr q) (tl r) d n else let 
+     a = cr div lc;
+     qq = cCons a q;
+     rr = minus_poly_rev_list r (map (op * a) d)
+     in if hd rr = 0 then divide_poly_main_list lc qq (tl rr) d n else [])"
+| "divide_poly_main_list lc q r d 0 = q"
+
+
+lemma divide_poly_main_list_simp[simp]: "divide_poly_main_list lc q r d (Suc n) = (let
+     cr = hd r;
+     a = cr div lc;
+     qq = cCons a q;
+     rr = minus_poly_rev_list r (map (op * a) d)
+     in if hd rr = 0 then divide_poly_main_list lc qq (tl rr) d n else [])"
+  by (simp add: Let_def minus_zero_does_nothing)
+
+declare divide_poly_main_list.simps(1)[simp del]
+
+definition divide_poly_list :: "'a::idom_divide poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
+  "divide_poly_list f g =
+    (let cg = coeffs g
+     in if cg = [] then g
+        else let cf = coeffs f; cgr = rev cg
+          in poly_of_list (divide_poly_main_list (hd cgr) [] (rev cf) cgr (1 + length cf - length cg)))"
+
+lemmas pdivmod_via_divmod_list[code] = pdivmod_via_pseudo_divmod_list[unfolded pseudo_divmod_main_list_1]
+
+lemma mod_poly_one_main_list: "snd (divmod_poly_one_main_list q r d n) = mod_poly_one_main_list r d n"
+  by  (induct n arbitrary: q r d, auto simp: Let_def)
+
+lemma mod_poly_code[code]: "f mod g =
+    (let cg = coeffs g
+     in if cg = [] then f
+        else let cf = coeffs f; ilc = inverse (last cg); ch = map (op * ilc) cg;
+                 r = mod_poly_one_main_list (rev cf) (rev ch) (1 + length cf - length cg)
+             in poly_of_list (rev r))" (is "?l = ?r")
+proof -
+  have "?l = snd (pdivmod f g)" unfolding pdivmod_def by simp
+  also have "\<dots> = ?r" unfolding pdivmod_via_divmod_list Let_def
+     mod_poly_one_main_list[symmetric, of _ _ _ Nil] by (auto split: prod.splits)
+  finally show ?thesis .
+qed
+
+definition div_field_poly_impl :: "'a :: field poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where 
+  "div_field_poly_impl f g = (
+    let cg = coeffs g
+      in if cg = [] then 0
+        else let cf = coeffs f; ilc = inverse (last cg); ch = map (op * ilc) cg;
+                 q = fst (divmod_poly_one_main_list [] (rev cf) (rev ch) (1 + length cf - length cg))
+             in poly_of_list ((map (op * ilc) q)))"
+
+text \<open>We do not declare the following lemma as code equation, since then polynomial division 
+  on non-fields will no longer be executable. However, a code-unfold is possible, since 
+  \<open>div_field_poly_impl\<close> is a bit more efficient than the generic polynomial division.\<close>
+lemma div_field_poly_impl[code_unfold]: "op div = div_field_poly_impl"
+proof (intro ext)
+  fix f g :: "'a poly"
+  have "f div g = fst (pdivmod f g)" unfolding pdivmod_def by simp
+  also have "\<dots> = div_field_poly_impl f g" unfolding 
+    div_field_poly_impl_def pdivmod_via_divmod_list Let_def by (auto split: prod.splits)
+  finally show "f div g =  div_field_poly_impl f g" .
+qed
+
+
+lemma divide_poly_main_list:
+  assumes lc0: "lc \<noteq> 0"
+  and lc:"last d = lc"
+  and d:"d \<noteq> []"
+  and "n = (1 + length r - length d)"
+  shows 
+  "Poly (divide_poly_main_list lc q (rev r) (rev d) n) =
+  divide_poly_main lc (monom 1 n * Poly q) (Poly r) (Poly d) (length r - 1) n"
+using assms(4-)
+proof(induct "n" arbitrary: r q)
+case (Suc n r q)
+  have ifCond: "\<not> Suc (length r) \<le> length d" using Suc.prems by simp
+  have r: "r \<noteq> []"
+    using ifCond d using Suc_leI length_greater_0_conv list.size(3) by fastforce
+  then obtain rr lcr where r: "r = rr @ [lcr]" by (cases r rule: rev_cases, auto)
+  from d lc obtain dd where d: "d = dd @ [lc]" 
+    by (cases d rule: rev_cases, auto)
+  from Suc(2) ifCond have n: "n = 1 + length rr - length d" by (auto simp: r)
+  from ifCond have len: "length dd \<le> length rr" by (simp add: r d)
+  show ?case
+  proof (cases "lcr div lc * lc = lcr")
+    case False
+    thus ?thesis unfolding Suc(2)[symmetric] using r d
+      by (auto simp add: Let_def nth_default_append)
+  next
+    case True
+    hence id:
+    "?thesis = (Poly (divide_poly_main_list lc (cCons (lcr div lc) q)
+         (rev (rev (minus_poly_rev_list (rev rr) (rev (map (op * (lcr div lc)) dd))))) (rev d) n) = 
+      divide_poly_main lc
+           (monom 1 (Suc n) * Poly q + monom (lcr div lc) n)
+           (Poly r - monom (lcr div lc) n * Poly d)
+           (Poly d) (length rr - 1) n)"
+           using r d 
+      by (cases r rule: rev_cases; cases "d" rule: rev_cases; 
+        auto simp add: Let_def rev_map nth_default_append)      
+    have cong: "\<And> x1 x2 x3 x4 y1 y2 y3 y4. x1 = y1 \<Longrightarrow> x2 = y2 \<Longrightarrow> x3 = y3 \<Longrightarrow> x4 = y4 \<Longrightarrow>
+      divide_poly_main lc x1 x2 x3 x4 n = divide_poly_main lc y1 y2 y3 y4 n" by simp
+    show ?thesis unfolding id 
+    proof (subst Suc(1), simp add: n,
+      subst minus_poly_rev_list, force simp: len, rule cong[OF _ _ refl], goal_cases)
+      case 2 
+      have "monom lcr (length rr) = monom (lcr div lc) (length rr - length dd) * monom lc (length dd)"
+        by (simp add: mult_monom len True)
+      thus ?case unfolding r d Poly_append n ring_distribs
+        by (auto simp: Poly_map smult_monom smult_monom_mult)
+    qed (auto simp: len monom_Suc smult_monom)
+  qed
+qed simp
+
+
+lemma divide_poly_list[code]: "f div g = divide_poly_list f g" 
+proof -
+  note d = divide_poly_def divide_poly_list_def
+  show ?thesis
+  proof (cases "g = 0")
+    case True
+    show ?thesis unfolding d True by auto
+  next
+    case False
+    then obtain cg lcg where cg: "coeffs g = cg @ [lcg]" by (cases "coeffs g" rule: rev_cases, auto)    
+    with False have id: "(g = 0) = False" "(cg @ [lcg] = []) = False" by auto
+    from cg False have lcg: "coeff g (degree g) = lcg" 
+      using last_coeffs_eq_coeff_degree last_snoc by force
+    with False have lcg0: "lcg \<noteq> 0" by auto
+    from cg have ltp: "Poly (cg @ [lcg]) = g"
+     using Poly_coeffs [of g] by auto
+    show ?thesis unfolding d cg Let_def id if_False poly_of_list_def
+      by (subst divide_poly_main_list, insert False cg lcg0, auto simp: lcg ltp,
+      simp add: degree_eq_length_coeffs)
+  qed
 qed
 
 no_notation cCons (infixr "##" 65)
diff -r 81a5473e6d04 -r a0e1f64be67c src/HOL/Library/Polynomial_Factorial.thy
--- a/src/HOL/Library/Polynomial_Factorial.thy	Thu Jan 05 22:37:52 2017 +0100
+++ b/src/HOL/Library/Polynomial_Factorial.thy	Thu Jan 05 22:38:06 2017 +0100
@@ -19,40 +19,6 @@
 lemma prod_mset_const_poly: "prod_mset (image_mset (\<lambda>x. [:f x:]) A) = [:prod_mset (image_mset f A):]"
   by (induction A) (simp_all add: one_poly_def mult_ac)
 
-lemma is_unit_smult_iff: "smult c p dvd 1 \<longleftrightarrow> c dvd 1 \<and> p dvd 1"
-proof -
-  have "smult c p = [:c:] * p" by simp
-  also have "\<dots> dvd 1 \<longleftrightarrow> c dvd 1 \<and> p dvd 1"
-  proof safe
-    assume A: "[:c:] * p dvd 1"
-    thus "p dvd 1" by (rule dvd_mult_right)
-    from A obtain q where B: "1 = [:c:] * p * q" by (erule dvdE)
-    have "c dvd c * (coeff p 0 * coeff q 0)" by simp
-    also have "\<dots> = coeff ([:c:] * p * q) 0" by (simp add: mult.assoc coeff_mult)
-    also note B [symmetric]
-    finally show "c dvd 1" by simp
-  next
-    assume "c dvd 1" "p dvd 1"
-    from \<open>c dvd 1\<close> obtain d where "1 = c * d" by (erule dvdE)
-    hence "1 = [:c:] * [:d:]" by (simp add: one_poly_def mult_ac)
-    hence "[:c:] dvd 1" by (rule dvdI)
-    from mult_dvd_mono[OF this \<open>p dvd 1\<close>] show "[:c:] * p dvd 1" by simp
-  qed
-  finally show ?thesis .
-qed
-
-lemma degree_mod_less': "b \<noteq> 0 \<Longrightarrow> a mod b \<noteq> 0 \<Longrightarrow> degree (a mod b) < degree b"
-  using degree_mod_less[of b a] by auto
-  
-lemma smult_eq_iff:
-  assumes "(b :: 'a :: field) \<noteq> 0"
-  shows   "smult a p = smult b q \<longleftrightarrow> smult (a / b) p = q"
-proof
-  assume "smult a p = smult b q"
-  also from assms have "smult (inverse b) \<dots> = q" by simp
-  finally show "smult (a / b) p = q" by (simp add: field_simps)
-qed (insert assms, auto)
-
 lemma irreducible_const_poly_iff:
   fixes c :: "'a :: {comm_semiring_1,semiring_no_zero_divisors}"
   shows "irreducible [:c:] \<longleftrightarrow> irreducible c"
@@ -160,145 +126,6 @@
   by (intro unit_factor_1_imp_normalized unit_factor_snd_quot_of_fract)
 
 
-subsection \<open>Content and primitive part of a polynomial\<close>
-
-definition content :: "('a :: semiring_Gcd poly) \<Rightarrow> 'a" where
-  "content p = Gcd (set (coeffs p))"
-
-lemma content_0 [simp]: "content 0 = 0"
-  by (simp add: content_def)
-
-lemma content_1 [simp]: "content 1 = 1"
-  by (simp add: content_def)
-
-lemma content_const [simp]: "content [:c:] = normalize c"
-  by (simp add: content_def cCons_def)
-
-lemma const_poly_dvd_iff_dvd_content:
-  fixes c :: "'a :: semiring_Gcd"
-  shows "[:c:] dvd p \<longleftrightarrow> c dvd content p"
-proof (cases "p = 0")
-  case [simp]: False
-  have "[:c:] dvd p \<longleftrightarrow> (\<forall>n. c dvd coeff p n)" by (rule const_poly_dvd_iff)
-  also have "\<dots> \<longleftrightarrow> (\<forall>a\<in>set (coeffs p). c dvd a)"
-  proof safe
-    fix n :: nat assume "\<forall>a\<in>set (coeffs p). c dvd a"
-    thus "c dvd coeff p n"
-      by (cases "n \<le> degree p") (auto simp: coeff_eq_0 coeffs_def split: if_splits)
-  qed (auto simp: coeffs_def simp del: upt_Suc split: if_splits)
-  also have "\<dots> \<longleftrightarrow> c dvd content p"
-    by (simp add: content_def dvd_Gcd_iff mult.commute [of "unit_factor x" for x]
-          dvd_mult_unit_iff lead_coeff_nonzero)
-  finally show ?thesis .
-qed simp_all
-
-lemma content_dvd [simp]: "[:content p:] dvd p"
-  by (subst const_poly_dvd_iff_dvd_content) simp_all
-  
-lemma content_dvd_coeff [simp]: "content p dvd coeff p n"
-  by (cases "n \<le> degree p") 
-     (auto simp: content_def coeffs_def not_le coeff_eq_0 simp del: upt_Suc intro: Gcd_dvd)
-
-lemma content_dvd_coeffs: "c \<in> set (coeffs p) \<Longrightarrow> content p dvd c"
-  by (simp add: content_def Gcd_dvd)
-
-lemma normalize_content [simp]: "normalize (content p) = content p"
-  by (simp add: content_def)
-
-lemma is_unit_content_iff [simp]: "is_unit (content p) \<longleftrightarrow> content p = 1"
-proof
-  assume "is_unit (content p)"
-  hence "normalize (content p) = 1" by (simp add: is_unit_normalize del: normalize_content)
-  thus "content p = 1" by simp
-qed auto
-
-lemma content_smult [simp]: "content (smult c p) = normalize c * content p"
-  by (simp add: content_def coeffs_smult Gcd_mult)
-
-lemma content_eq_zero_iff [simp]: "content p = 0 \<longleftrightarrow> p = 0"
-  by (auto simp: content_def simp: poly_eq_iff coeffs_def)
-
-definition primitive_part :: "'a :: {semiring_Gcd,idom_divide} poly \<Rightarrow> 'a poly" where
-  "primitive_part p = (if p = 0 then 0 else map_poly (\<lambda>x. x div content p) p)"
-  
-lemma primitive_part_0 [simp]: "primitive_part 0 = 0"
-  by (simp add: primitive_part_def)
-
-lemma content_times_primitive_part [simp]:
-  fixes p :: "'a :: {idom_divide, semiring_Gcd} poly"
-  shows "smult (content p) (primitive_part p) = p"
-proof (cases "p = 0")
-  case False
-  thus ?thesis
-  unfolding primitive_part_def
-  by (auto simp: smult_conv_map_poly map_poly_map_poly o_def content_dvd_coeffs 
-           intro: map_poly_idI)
-qed simp_all
-
-lemma primitive_part_eq_0_iff [simp]: "primitive_part p = 0 \<longleftrightarrow> p = 0"
-proof (cases "p = 0")
-  case False
-  hence "primitive_part p = map_poly (\<lambda>x. x div content p) p"
-    by (simp add:  primitive_part_def)
-  also from False have "\<dots> = 0 \<longleftrightarrow> p = 0"
-    by (intro map_poly_eq_0_iff) (auto simp: dvd_div_eq_0_iff content_dvd_coeffs)
-  finally show ?thesis using False by simp
-qed simp
-
-lemma content_primitive_part [simp]:
-  assumes "p \<noteq> 0"
-  shows   "content (primitive_part p) = 1"
-proof -
-  have "p = smult (content p) (primitive_part p)" by simp
-  also have "content \<dots> = content p * content (primitive_part p)" 
-    by (simp del: content_times_primitive_part)
-  finally show ?thesis using assms by simp
-qed
-
-lemma content_decompose:
-  fixes p :: "'a :: semiring_Gcd poly"
-  obtains p' where "p = smult (content p) p'" "content p' = 1"
-proof (cases "p = 0")
-  case True
-  thus ?thesis by (intro that[of 1]) simp_all
-next
-  case False
-  from content_dvd[of p] obtain r where r: "p = [:content p:] * r" by (erule dvdE)
-  have "content p * 1 = content p * content r" by (subst r) simp
-  with False have "content r = 1" by (subst (asm) mult_left_cancel) simp_all
-  with r show ?thesis by (intro that[of r]) simp_all
-qed
-
-lemma smult_content_normalize_primitive_part [simp]:
-  "smult (content p) (normalize (primitive_part p)) = normalize p"
-proof -
-  have "smult (content p) (normalize (primitive_part p)) = 
-          normalize ([:content p:] * primitive_part p)" 
-    by (subst normalize_mult) (simp_all add: normalize_const_poly)
-  also have "[:content p:] * primitive_part p = p" by simp
-  finally show ?thesis .
-qed
-
-lemma content_dvd_contentI [intro]:
-  "p dvd q \<Longrightarrow> content p dvd content q"
-  using const_poly_dvd_iff_dvd_content content_dvd dvd_trans by blast
-  
-lemma primitive_part_const_poly [simp]: "primitive_part [:x:] = [:unit_factor x:]"
-  by (simp add: primitive_part_def map_poly_pCons)
- 
-lemma primitive_part_prim: "content p = 1 \<Longrightarrow> primitive_part p = p"
-  by (auto simp: primitive_part_def)
-  
-lemma degree_primitive_part [simp]: "degree (primitive_part p) = degree p"
-proof (cases "p = 0")
-  case False
-  have "p = smult (content p) (primitive_part p)" by simp
-  also from False have "degree \<dots> = degree (primitive_part p)"
-    by (subst degree_smult_eq) simp_all
-  finally show ?thesis ..
-qed simp_all
-
-
 subsection \<open>Lifting polynomial coefficients to the field of fractions\<close>
 
 abbreviation (input) fract_poly 
@@ -690,7 +517,7 @@
   fix p :: "'a poly"
   show "unit_factor_field_poly p * normalize_field_poly p = p"
     by (cases "p = 0") 
-       (simp_all add: unit_factor_field_poly_def normalize_field_poly_def lead_coeff_nonzero)
+       (simp_all add: unit_factor_field_poly_def normalize_field_poly_def)
 next
   fix p :: "'a poly" assume "is_unit p"
   thus "normalize_field_poly p = 1"
@@ -698,7 +525,7 @@
 next
   fix p :: "'a poly" assume "p \<noteq> 0"
   thus "is_unit (unit_factor_field_poly p)"
-    by (simp add: unit_factor_field_poly_def lead_coeff_nonzero is_unit_pCons_iff)
+    by (simp add: unit_factor_field_poly_def is_unit_pCons_iff)
 next
   fix p q s :: "'a poly" assume "s \<noteq> 0"
   moreover assume "euclidean_size_field_poly p < euclidean_size_field_poly q"
@@ -943,7 +770,7 @@
   have "fract_poly p = unit_factor_field_poly (fract_poly p) * 
           normalize_field_poly (fract_poly p)" by simp
   also have "unit_factor_field_poly (fract_poly p) = [:to_fract (lead_coeff p):]" 
-    by (simp add: unit_factor_field_poly_def lead_coeff_def monom_0 degree_map_poly coeff_map_poly)
+    by (simp add: unit_factor_field_poly_def monom_0 degree_map_poly coeff_map_poly)
   also from assms have "normalize_field_poly (fract_poly p) = prod_mset ?P" 
     by (subst field_poly_prod_mset_prime_factorization) simp_all
   also have "\<dots> = prod_mset (image_mset id ?P)" by simp
diff -r 81a5473e6d04 -r a0e1f64be67c src/HOL/Real_Vector_Spaces.thy
--- a/src/HOL/Real_Vector_Spaces.thy	Thu Jan 05 22:37:52 2017 +0100
+++ b/src/HOL/Real_Vector_Spaces.thy	Thu Jan 05 22:38:06 2017 +0100
@@ -176,6 +176,21 @@
   for x :: "'a::real_vector"
   using scaleR_minus_left [of 1 x] by simp
 
+lemma scaleR_2:
+  fixes x :: "'a::real_vector"
+  shows "scaleR 2 x = x + x"
+  unfolding one_add_one [symmetric] scaleR_left_distrib by simp
+
+lemma scaleR_half_double [simp]:
+  fixes a :: "'a::real_vector"
+  shows "(1 / 2) *\<^sub>R (a + a) = a"
+proof -
+  have "\<And>r. r *\<^sub>R (a + a) = (r * 2) *\<^sub>R a"
+    by (metis scaleR_2 scaleR_scaleR)
+  then show ?thesis
+    by simp
+qed
+
 class real_algebra = real_vector + ring +
   assumes mult_scaleR_left [simp]: "scaleR a x * y = scaleR a (x * y)"
     and mult_scaleR_right [simp]: "x * scaleR a y = scaleR a (x * y)"