src/HOL/Analysis/Brouwer_Fixpoint.thy
author nipkow
Thu Jul 12 11:23:46 2018 +0200 (13 months ago)
changeset 68617 75129a73aca3
parent 68361 20375f232f3b
child 68621 27432da24236
permissions -rw-r--r--
more economic tagging
     1 (*  Author:     John Harrison
     2     Author:     Robert Himmelmann, TU Muenchen (Translation from HOL light) and LCP
     3 *)
     4 
     5 (* At the moment this is just Brouwer's fixpoint theorem. The proof is from  *)
     6 (* Kuhn: "some combinatorial lemmas in topology", IBM J. v4. (1960) p. 518   *)
     7 (* See "http://www.research.ibm.com/journal/rd/045/ibmrd0405K.pdf".          *)
     8 (*                                                                           *)
     9 (* The script below is quite messy, but at least we avoid formalizing any    *)
    10 (* topological machinery; we don't even use barycentric subdivision; this is *)
    11 (* the big advantage of Kuhn's proof over the usual Sperner's lemma one.     *)
    12 (*                                                                           *)
    13 (*              (c) Copyright, John Harrison 1998-2008                       *)
    14 
    15 section \<open>Brouwer's Fixed Point Theorem\<close>
    16 
    17 theory Brouwer_Fixpoint
    18 imports Path_Connected Homeomorphism
    19 begin
    20 
    21 subsection \<open>Unit cubes\<close>
    22 
    23 (* FIXME mv euclidean topological space *)
    24 definition unit_cube :: "'a::euclidean_space set"
    25   where "unit_cube = {x. \<forall>i\<in>Basis. 0 \<le> x \<bullet> i \<and> x \<bullet> i \<le> 1}"
    26 
    27 lemma mem_unit_cube: "x \<in> unit_cube \<longleftrightarrow> (\<forall>i\<in>Basis. 0 \<le> x \<bullet> i \<and> x \<bullet> i \<le> 1)"
    28   unfolding unit_cube_def by simp
    29 
    30 lemma bounded_unit_cube: "bounded unit_cube"
    31   unfolding bounded_def
    32 proof (intro exI ballI)
    33   fix y :: 'a assume y: "y \<in> unit_cube"
    34   have "dist 0 y = norm y" by (rule dist_0_norm)
    35   also have "\<dots> = norm (\<Sum>i\<in>Basis. (y \<bullet> i) *\<^sub>R i)" unfolding euclidean_representation ..
    36   also have "\<dots> \<le> (\<Sum>i\<in>Basis. norm ((y \<bullet> i) *\<^sub>R i))" by (rule norm_sum)
    37   also have "\<dots> \<le> (\<Sum>i::'a\<in>Basis. 1)"
    38     by (rule sum_mono, simp add: y [unfolded mem_unit_cube])
    39   finally show "dist 0 y \<le> (\<Sum>i::'a\<in>Basis. 1)" .
    40 qed
    41 
    42 lemma closed_unit_cube: "closed unit_cube"
    43   unfolding unit_cube_def Collect_ball_eq Collect_conj_eq
    44   by (rule closed_INT, auto intro!: closed_Collect_le continuous_on_inner continuous_on_const continuous_on_id)
    45 
    46 lemma compact_unit_cube: "compact unit_cube" (is "compact ?C")
    47   unfolding compact_eq_seq_compact_metric
    48   using bounded_unit_cube closed_unit_cube
    49   by (rule bounded_closed_imp_seq_compact)
    50 
    51 lemma convex_unit_cube: "convex unit_cube"
    52   by (rule is_interval_convex) (fastforce simp add: is_interval_def mem_unit_cube)
    53 
    54 
    55 (* FIXME mv topology euclidean space *)
    56 subsection \<open>Retractions\<close>
    57 
    58 definition "retraction S T r \<longleftrightarrow> T \<subseteq> S \<and> continuous_on S r \<and> r ` S \<subseteq> T \<and> (\<forall>x\<in>T. r x = x)"
    59 
    60 definition retract_of (infixl "retract'_of" 50)
    61   where "(T retract_of S) \<longleftrightarrow> (\<exists>r. retraction S T r)"
    62 
    63 lemma retraction_idempotent: "retraction S T r \<Longrightarrow> x \<in> S \<Longrightarrow>  r (r x) = r x"
    64   unfolding retraction_def by auto
    65 
    66 text \<open>Preservation of fixpoints under (more general notion of) retraction\<close>
    67 
    68 lemma invertible_fixpoint_property:
    69   fixes S :: "'a::euclidean_space set"
    70     and T :: "'b::euclidean_space set"
    71   assumes contt: "continuous_on T i"
    72     and "i ` T \<subseteq> S"
    73     and contr: "continuous_on S r"
    74     and "r ` S \<subseteq> T"
    75     and ri: "\<And>y. y \<in> T \<Longrightarrow> r (i y) = y"
    76     and FP: "\<And>f. \<lbrakk>continuous_on S f; f ` S \<subseteq> S\<rbrakk> \<Longrightarrow> \<exists>x\<in>S. f x = x"
    77     and contg: "continuous_on T g"
    78     and "g ` T \<subseteq> T"
    79   obtains y where "y \<in> T" and "g y = y"
    80 proof -
    81   have "\<exists>x\<in>S. (i \<circ> g \<circ> r) x = x"
    82   proof (rule FP)
    83     show "continuous_on S (i \<circ> g \<circ> r)"
    84       by (meson contt contr assms(4) contg assms(8) continuous_on_compose continuous_on_subset)
    85     show "(i \<circ> g \<circ> r) ` S \<subseteq> S"
    86       using assms(2,4,8) by force
    87   qed
    88   then obtain x where x: "x \<in> S" "(i \<circ> g \<circ> r) x = x" ..
    89   then have *: "g (r x) \<in> T"
    90     using assms(4,8) by auto
    91   have "r ((i \<circ> g \<circ> r) x) = r x"
    92     using x by auto
    93   then show ?thesis
    94     using "*" ri that by auto
    95 qed
    96 
    97 lemma homeomorphic_fixpoint_property:
    98   fixes S :: "'a::euclidean_space set"
    99     and T :: "'b::euclidean_space set"
   100   assumes "S homeomorphic T"
   101   shows "(\<forall>f. continuous_on S f \<and> f ` S \<subseteq> S \<longrightarrow> (\<exists>x\<in>S. f x = x)) \<longleftrightarrow>
   102          (\<forall>g. continuous_on T g \<and> g ` T \<subseteq> T \<longrightarrow> (\<exists>y\<in>T. g y = y))"
   103          (is "?lhs = ?rhs")
   104 proof -
   105   obtain r i where r:
   106       "\<forall>x\<in>S. i (r x) = x" "r ` S = T" "continuous_on S r"
   107       "\<forall>y\<in>T. r (i y) = y" "i ` T = S" "continuous_on T i"
   108     using assms unfolding homeomorphic_def homeomorphism_def  by blast
   109   show ?thesis
   110   proof
   111     assume ?lhs
   112     with r show ?rhs
   113       by (metis invertible_fixpoint_property[of T i S r] order_refl)
   114   next
   115     assume ?rhs
   116     with r show ?lhs
   117       by (metis invertible_fixpoint_property[of S r T i] order_refl)
   118   qed
   119 qed
   120 
   121 lemma retract_fixpoint_property:
   122   fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
   123     and S :: "'a set"
   124   assumes "T retract_of S"
   125     and FP: "\<And>f. \<lbrakk>continuous_on S f; f ` S \<subseteq> S\<rbrakk> \<Longrightarrow> \<exists>x\<in>S. f x = x"
   126     and contg: "continuous_on T g"
   127     and "g ` T \<subseteq> T"
   128   obtains y where "y \<in> T" and "g y = y"
   129 proof -
   130   obtain h where "retraction S T h"
   131     using assms(1) unfolding retract_of_def ..
   132   then show ?thesis
   133     unfolding retraction_def
   134     using invertible_fixpoint_property[OF continuous_on_id _ _ _ _ FP]
   135     by (metis assms(4) contg image_ident that)
   136 qed
   137 
   138 lemma retraction:
   139    "retraction S T r \<longleftrightarrow>
   140     T \<subseteq> S \<and> continuous_on S r \<and> r ` S = T \<and> (\<forall>x \<in> T. r x = x)"
   141 by (force simp: retraction_def)
   142 
   143 lemma retract_of_imp_extensible:
   144   assumes "S retract_of T" and "continuous_on S f" and "f ` S \<subseteq> U"
   145   obtains g where "continuous_on T g" "g ` T \<subseteq> U" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
   146 using assms
   147 apply (clarsimp simp add: retract_of_def retraction)
   148 apply (rule_tac g = "f \<circ> r" in that)
   149 apply (auto simp: continuous_on_compose2)
   150 done
   151 
   152 lemma idempotent_imp_retraction:
   153   assumes "continuous_on S f" and "f ` S \<subseteq> S" and "\<And>x. x \<in> S \<Longrightarrow> f(f x) = f x"
   154     shows "retraction S (f ` S) f"
   155 by (simp add: assms retraction)
   156 
   157 lemma retraction_subset:
   158   assumes "retraction S T r" and "T \<subseteq> s'" and "s' \<subseteq> S"
   159   shows "retraction s' T r"
   160   unfolding retraction_def
   161   by (metis assms continuous_on_subset image_mono retraction)
   162 
   163 lemma retract_of_subset:
   164   assumes "T retract_of S" and "T \<subseteq> s'" and "s' \<subseteq> S"
   165     shows "T retract_of s'"
   166 by (meson assms retract_of_def retraction_subset)
   167 
   168 lemma retraction_refl [simp]: "retraction S S (\<lambda>x. x)"
   169 by (simp add: continuous_on_id retraction)
   170 
   171 lemma retract_of_refl [iff]: "S retract_of S"
   172   unfolding retract_of_def retraction_def
   173   using continuous_on_id by blast
   174 
   175 lemma retract_of_imp_subset:
   176    "S retract_of T \<Longrightarrow> S \<subseteq> T"
   177 by (simp add: retract_of_def retraction_def)
   178 
   179 lemma retract_of_empty [simp]:
   180      "({} retract_of S) \<longleftrightarrow> S = {}"  "(S retract_of {}) \<longleftrightarrow> S = {}"
   181 by (auto simp: retract_of_def retraction_def)
   182 
   183 lemma retract_of_singleton [iff]: "({x} retract_of S) \<longleftrightarrow> x \<in> S"
   184   unfolding retract_of_def retraction_def by force
   185 
   186 lemma retraction_comp:
   187    "\<lbrakk>retraction S T f; retraction T U g\<rbrakk>
   188         \<Longrightarrow> retraction S U (g \<circ> f)"
   189 apply (auto simp: retraction_def intro: continuous_on_compose2)
   190 by blast
   191 
   192 lemma retract_of_trans [trans]:
   193   assumes "S retract_of T" and "T retract_of U"
   194     shows "S retract_of U"
   195 using assms by (auto simp: retract_of_def intro: retraction_comp)
   196 
   197 lemma closedin_retract:
   198   fixes S :: "'a :: real_normed_vector set"
   199   assumes "S retract_of T"
   200     shows "closedin (subtopology euclidean T) S"
   201 proof -
   202   obtain r where "S \<subseteq> T" "continuous_on T r" "r ` T \<subseteq> S" "\<And>x. x \<in> S \<Longrightarrow> r x = x"
   203     using assms by (auto simp: retract_of_def retraction_def)
   204   then have S: "S = {x \<in> T. (norm(r x - x)) = 0}" by auto
   205   show ?thesis
   206     apply (subst S)
   207     apply (rule continuous_closedin_preimage_constant)
   208     by (simp add: \<open>continuous_on T r\<close> continuous_on_diff continuous_on_id continuous_on_norm)
   209 qed
   210 
   211 lemma closedin_self [simp]:
   212     fixes S :: "'a :: real_normed_vector set"
   213     shows "closedin (subtopology euclidean S) S"
   214   by (simp add: closedin_retract)
   215 
   216 lemma retract_of_contractible:
   217   assumes "contractible T" "S retract_of T"
   218     shows "contractible S"
   219 using assms
   220 apply (clarsimp simp add: retract_of_def contractible_def retraction_def homotopic_with)
   221 apply (rule_tac x="r a" in exI)
   222 apply (rule_tac x="r \<circ> h" in exI)
   223 apply (intro conjI continuous_intros continuous_on_compose)
   224 apply (erule continuous_on_subset | force)+
   225 done
   226 
   227 lemma retract_of_compact:
   228      "\<lbrakk>compact T; S retract_of T\<rbrakk> \<Longrightarrow> compact S"
   229   by (metis compact_continuous_image retract_of_def retraction)
   230 
   231 lemma retract_of_closed:
   232     fixes S :: "'a :: real_normed_vector set"
   233     shows "\<lbrakk>closed T; S retract_of T\<rbrakk> \<Longrightarrow> closed S"
   234   by (metis closedin_retract closedin_closed_eq)
   235 
   236 lemma retract_of_connected:
   237     "\<lbrakk>connected T; S retract_of T\<rbrakk> \<Longrightarrow> connected S"
   238   by (metis Topological_Spaces.connected_continuous_image retract_of_def retraction)
   239 
   240 lemma retract_of_path_connected:
   241     "\<lbrakk>path_connected T; S retract_of T\<rbrakk> \<Longrightarrow> path_connected S"
   242   by (metis path_connected_continuous_image retract_of_def retraction)
   243 
   244 lemma retract_of_simply_connected:
   245     "\<lbrakk>simply_connected T; S retract_of T\<rbrakk> \<Longrightarrow> simply_connected S"
   246 apply (simp add: retract_of_def retraction_def, clarify)
   247 apply (rule simply_connected_retraction_gen)
   248 apply (force simp: continuous_on_id elim!: continuous_on_subset)+
   249 done
   250 
   251 lemma retract_of_homotopically_trivial:
   252   assumes ts: "T retract_of S"
   253       and hom: "\<And>f g. \<lbrakk>continuous_on U f; f ` U \<subseteq> S;
   254                        continuous_on U g; g ` U \<subseteq> S\<rbrakk>
   255                        \<Longrightarrow> homotopic_with (\<lambda>x. True) U S f g"
   256       and "continuous_on U f" "f ` U \<subseteq> T"
   257       and "continuous_on U g" "g ` U \<subseteq> T"
   258     shows "homotopic_with (\<lambda>x. True) U T f g"
   259 proof -
   260   obtain r where "r ` S \<subseteq> S" "continuous_on S r" "\<forall>x\<in>S. r (r x) = r x" "T = r ` S"
   261     using ts by (auto simp: retract_of_def retraction)
   262   then obtain k where "Retracts S r T k"
   263     unfolding Retracts_def
   264     by (metis continuous_on_subset dual_order.trans image_iff image_mono)
   265   then show ?thesis
   266     apply (rule Retracts.homotopically_trivial_retraction_gen)
   267     using assms
   268     apply (force simp: hom)+
   269     done
   270 qed
   271 
   272 lemma retract_of_homotopically_trivial_null:
   273   assumes ts: "T retract_of S"
   274       and hom: "\<And>f. \<lbrakk>continuous_on U f; f ` U \<subseteq> S\<rbrakk>
   275                      \<Longrightarrow> \<exists>c. homotopic_with (\<lambda>x. True) U S f (\<lambda>x. c)"
   276       and "continuous_on U f" "f ` U \<subseteq> T"
   277   obtains c where "homotopic_with (\<lambda>x. True) U T f (\<lambda>x. c)"
   278 proof -
   279   obtain r where "r ` S \<subseteq> S" "continuous_on S r" "\<forall>x\<in>S. r (r x) = r x" "T = r ` S"
   280     using ts by (auto simp: retract_of_def retraction)
   281   then obtain k where "Retracts S r T k"
   282     unfolding Retracts_def
   283     by (metis continuous_on_subset dual_order.trans image_iff image_mono)
   284   then show ?thesis
   285     apply (rule Retracts.homotopically_trivial_retraction_null_gen)
   286     apply (rule TrueI refl assms that | assumption)+
   287     done
   288 qed
   289 
   290 lemma retraction_imp_quotient_map:
   291    "retraction S T r
   292     \<Longrightarrow> U \<subseteq> T
   293             \<Longrightarrow> (openin (subtopology euclidean S) (S \<inter> r -` U) \<longleftrightarrow>
   294                  openin (subtopology euclidean T) U)"
   295 apply (clarsimp simp add: retraction)
   296 apply (rule continuous_right_inverse_imp_quotient_map [where g=r])
   297 apply (auto simp: elim: continuous_on_subset)
   298 done
   299 
   300 lemma retract_of_locally_compact:
   301     fixes S :: "'a :: {heine_borel,real_normed_vector} set"
   302     shows  "\<lbrakk> locally compact S; T retract_of S\<rbrakk> \<Longrightarrow> locally compact T"
   303   by (metis locally_compact_closedin closedin_retract)
   304 
   305 lemma retract_of_Times:
   306    "\<lbrakk>S retract_of s'; T retract_of t'\<rbrakk> \<Longrightarrow> (S \<times> T) retract_of (s' \<times> t')"
   307 apply (simp add: retract_of_def retraction_def Sigma_mono, clarify)
   308 apply (rename_tac f g)
   309 apply (rule_tac x="\<lambda>z. ((f \<circ> fst) z, (g \<circ> snd) z)" in exI)
   310 apply (rule conjI continuous_intros | erule continuous_on_subset | force)+
   311 done
   312 
   313 lemma homotopic_into_retract:
   314    "\<lbrakk>f ` S \<subseteq> T; g ` S \<subseteq> T; T retract_of U; homotopic_with (\<lambda>x. True) S U f g\<rbrakk>
   315         \<Longrightarrow> homotopic_with (\<lambda>x. True) S T f g"
   316 apply (subst (asm) homotopic_with_def)
   317 apply (simp add: homotopic_with retract_of_def retraction_def, clarify)
   318 apply (rule_tac x="r \<circ> h" in exI)
   319 apply (rule conjI continuous_intros | erule continuous_on_subset | force simp: image_subset_iff)+
   320 done
   321 
   322 lemma retract_of_locally_connected:
   323   assumes "locally connected T" "S retract_of T"
   324     shows "locally connected S"
   325   using assms
   326   by (auto simp: retract_of_def retraction intro!: retraction_imp_quotient_map elim!: locally_connected_quotient_image)
   327 
   328 lemma retract_of_locally_path_connected:
   329   assumes "locally path_connected T" "S retract_of T"
   330     shows "locally path_connected S"
   331   using assms
   332   by (auto simp: retract_of_def retraction intro!: retraction_imp_quotient_map elim!: locally_path_connected_quotient_image)
   333 
   334 text \<open>A few simple lemmas about deformation retracts\<close>
   335 
   336 lemma deformation_retract_imp_homotopy_eqv:
   337   fixes S :: "'a::euclidean_space set"
   338   assumes "homotopic_with (\<lambda>x. True) S S id r" and r: "retraction S T r"
   339   shows "S homotopy_eqv T"
   340 proof -
   341   have "homotopic_with (\<lambda>x. True) S S (id \<circ> r) id"
   342     by (simp add: assms(1) homotopic_with_symD)
   343   moreover have "homotopic_with (\<lambda>x. True) T T (r \<circ> id) id"
   344     using r unfolding retraction_def
   345     by (metis (no_types, lifting) comp_id continuous_on_id' homotopic_with_equal homotopic_with_symD id_def image_id order_refl)
   346   ultimately
   347   show ?thesis
   348     unfolding homotopy_eqv_def
   349     by (metis continuous_on_id' id_def image_id r retraction_def)
   350 qed
   351 
   352 lemma deformation_retract:
   353   fixes S :: "'a::euclidean_space set"
   354     shows "(\<exists>r. homotopic_with (\<lambda>x. True) S S id r \<and> retraction S T r) \<longleftrightarrow>
   355            T retract_of S \<and> (\<exists>f. homotopic_with (\<lambda>x. True) S S id f \<and> f ` S \<subseteq> T)"
   356     (is "?lhs = ?rhs")
   357 proof
   358   assume ?lhs
   359   then show ?rhs
   360     by (auto simp: retract_of_def retraction_def)
   361 next
   362   assume ?rhs
   363   then show ?lhs
   364     apply (clarsimp simp add: retract_of_def retraction_def)
   365     apply (rule_tac x=r in exI, simp)
   366      apply (rule homotopic_with_trans, assumption)
   367      apply (rule_tac f = "r \<circ> f" and g="r \<circ> id" in homotopic_with_eq)
   368         apply (rule_tac Y=S in homotopic_compose_continuous_left)
   369          apply (auto simp: homotopic_with_sym)
   370     done
   371 qed
   372 
   373 lemma deformation_retract_of_contractible_sing:
   374   fixes S :: "'a::euclidean_space set"
   375   assumes "contractible S" "a \<in> S"
   376   obtains r where "homotopic_with (\<lambda>x. True) S S id r" "retraction S {a} r"
   377 proof -
   378   have "{a} retract_of S"
   379     by (simp add: \<open>a \<in> S\<close>)
   380   moreover have "homotopic_with (\<lambda>x. True) S S id (\<lambda>x. a)"
   381       using assms
   382       by (auto simp: contractible_def continuous_on_const continuous_on_id homotopic_into_contractible image_subset_iff)
   383   moreover have "(\<lambda>x. a) ` S \<subseteq> {a}"
   384     by (simp add: image_subsetI)
   385   ultimately show ?thesis
   386     using that deformation_retract  by metis
   387 qed
   388 
   389 
   390 lemma continuous_on_compact_surface_projection_aux:
   391   fixes S :: "'a::t2_space set"
   392   assumes "compact S" "S \<subseteq> T" "image q T \<subseteq> S"
   393       and contp: "continuous_on T p"
   394       and "\<And>x. x \<in> S \<Longrightarrow> q x = x"
   395       and [simp]: "\<And>x. x \<in> T \<Longrightarrow> q(p x) = q x"
   396       and "\<And>x. x \<in> T \<Longrightarrow> p(q x) = p x"
   397     shows "continuous_on T q"
   398 proof -
   399   have *: "image p T = image p S"
   400     using assms by auto (metis imageI subset_iff)
   401   have contp': "continuous_on S p"
   402     by (rule continuous_on_subset [OF contp \<open>S \<subseteq> T\<close>])
   403   have "continuous_on (p ` T) q"
   404     by (simp add: "*" assms(1) assms(2) assms(5) continuous_on_inv contp' rev_subsetD)
   405   then have "continuous_on T (q \<circ> p)"
   406     by (rule continuous_on_compose [OF contp])
   407   then show ?thesis
   408     by (rule continuous_on_eq [of _ "q \<circ> p"]) (simp add: o_def)
   409 qed
   410 
   411 lemma continuous_on_compact_surface_projection:
   412   fixes S :: "'a::real_normed_vector set"
   413   assumes "compact S"
   414       and S: "S \<subseteq> V - {0}" and "cone V"
   415       and iff: "\<And>x k. x \<in> V - {0} \<Longrightarrow> 0 < k \<and> (k *\<^sub>R x) \<in> S \<longleftrightarrow> d x = k"
   416   shows "continuous_on (V - {0}) (\<lambda>x. d x *\<^sub>R x)"
   417 proof (rule continuous_on_compact_surface_projection_aux [OF \<open>compact S\<close> S])
   418   show "(\<lambda>x. d x *\<^sub>R x) ` (V - {0}) \<subseteq> S"
   419     using iff by auto
   420   show "continuous_on (V - {0}) (\<lambda>x. inverse(norm x) *\<^sub>R x)"
   421     by (intro continuous_intros) force
   422   show "\<And>x. x \<in> S \<Longrightarrow> d x *\<^sub>R x = x"
   423     by (metis S zero_less_one local.iff scaleR_one subset_eq)
   424   show "d (x /\<^sub>R norm x) *\<^sub>R (x /\<^sub>R norm x) = d x *\<^sub>R x" if "x \<in> V - {0}" for x
   425     using iff [of "inverse(norm x) *\<^sub>R x" "norm x * d x", symmetric] iff that \<open>cone V\<close>
   426     by (simp add: field_simps cone_def zero_less_mult_iff)
   427   show "d x *\<^sub>R x /\<^sub>R norm (d x *\<^sub>R x) = x /\<^sub>R norm x" if "x \<in> V - {0}" for x
   428   proof -
   429     have "0 < d x"
   430       using local.iff that by blast
   431     then show ?thesis
   432       by simp
   433   qed
   434 qed
   435 
   436 subsection \<open>Absolute retracts, absolute neighbourhood retracts (ANR) and Euclidean neighbourhood retracts (ENR)\<close>
   437 
   438 text \<open>Absolute retracts (AR), absolute neighbourhood retracts (ANR) and also Euclidean neighbourhood
   439 retracts (ENR). We define AR and ANR by specializing the standard definitions for a set to embedding
   440 in spaces of higher dimension.
   441 
   442 John Harrison writes: "This turns out to be sufficient (since any set in $\mathbb{R}^n$ can be
   443 embedded as a closed subset of a convex subset of $\mathbb{R}^{n+1}$) to derive the usual
   444 definitions, but we need to split them into two implications because of the lack of type
   445 quantifiers. Then ENR turns out to be equivalent to ANR plus local compactness."\<close>
   446 
   447 definition AR :: "'a::topological_space set => bool"
   448   where
   449    "AR S \<equiv> \<forall>U. \<forall>S'::('a * real) set. S homeomorphic S' \<and> closedin (subtopology euclidean U) S'
   450                 \<longrightarrow> S' retract_of U"
   451 
   452 definition ANR :: "'a::topological_space set => bool"
   453   where
   454    "ANR S \<equiv> \<forall>U. \<forall>S'::('a * real) set. S homeomorphic S' \<and> closedin (subtopology euclidean U) S'
   455                 \<longrightarrow> (\<exists>T. openin (subtopology euclidean U) T \<and>
   456                         S' retract_of T)"
   457 
   458 definition ENR :: "'a::topological_space set => bool"
   459   where "ENR S \<equiv> \<exists>U. open U \<and> S retract_of U"
   460 
   461 text \<open>First, show that we do indeed get the "usual" properties of ARs and ANRs.\<close>
   462 
   463 lemma AR_imp_absolute_extensor:
   464   fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
   465   assumes "AR S" and contf: "continuous_on T f" and "f ` T \<subseteq> S"
   466       and cloUT: "closedin (subtopology euclidean U) T"
   467   obtains g where "continuous_on U g" "g ` U \<subseteq> S" "\<And>x. x \<in> T \<Longrightarrow> g x = f x"
   468 proof -
   469   have "aff_dim S < int (DIM('b \<times> real))"
   470     using aff_dim_le_DIM [of S] by simp
   471   then obtain C and S' :: "('b * real) set"
   472           where C: "convex C" "C \<noteq> {}"
   473             and cloCS: "closedin (subtopology euclidean C) S'"
   474             and hom: "S homeomorphic S'"
   475     by (metis that homeomorphic_closedin_convex)
   476   then have "S' retract_of C"
   477     using \<open>AR S\<close> by (simp add: AR_def)
   478   then obtain r where "S' \<subseteq> C" and contr: "continuous_on C r"
   479                   and "r ` C \<subseteq> S'" and rid: "\<And>x. x\<in>S' \<Longrightarrow> r x = x"
   480     by (auto simp: retraction_def retract_of_def)
   481   obtain g h where "homeomorphism S S' g h"
   482     using hom by (force simp: homeomorphic_def)
   483   then have "continuous_on (f ` T) g"
   484     by (meson \<open>f ` T \<subseteq> S\<close> continuous_on_subset homeomorphism_def)
   485   then have contgf: "continuous_on T (g \<circ> f)"
   486     by (metis continuous_on_compose contf)
   487   have gfTC: "(g \<circ> f) ` T \<subseteq> C"
   488   proof -
   489     have "g ` S = S'"
   490       by (metis (no_types) \<open>homeomorphism S S' g h\<close> homeomorphism_def)
   491     with \<open>S' \<subseteq> C\<close> \<open>f ` T \<subseteq> S\<close> show ?thesis by force
   492   qed
   493   obtain f' where f': "continuous_on U f'"  "f' ` U \<subseteq> C"
   494                       "\<And>x. x \<in> T \<Longrightarrow> f' x = (g \<circ> f) x"
   495     by (metis Dugundji [OF C cloUT contgf gfTC])
   496   show ?thesis
   497   proof (rule_tac g = "h \<circ> r \<circ> f'" in that)
   498     show "continuous_on U (h \<circ> r \<circ> f')"
   499       apply (intro continuous_on_compose f')
   500        using continuous_on_subset contr f' apply blast
   501       by (meson \<open>homeomorphism S S' g h\<close> \<open>r ` C \<subseteq> S'\<close> continuous_on_subset \<open>f' ` U \<subseteq> C\<close> homeomorphism_def image_mono)
   502     show "(h \<circ> r \<circ> f') ` U \<subseteq> S"
   503       using \<open>homeomorphism S S' g h\<close> \<open>r ` C \<subseteq> S'\<close> \<open>f' ` U \<subseteq> C\<close>
   504       by (fastforce simp: homeomorphism_def)
   505     show "\<And>x. x \<in> T \<Longrightarrow> (h \<circ> r \<circ> f') x = f x"
   506       using \<open>homeomorphism S S' g h\<close> \<open>f ` T \<subseteq> S\<close> f'
   507       by (auto simp: rid homeomorphism_def)
   508   qed
   509 qed
   510 
   511 lemma AR_imp_absolute_retract:
   512   fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
   513   assumes "AR S" "S homeomorphic S'"
   514       and clo: "closedin (subtopology euclidean U) S'"
   515     shows "S' retract_of U"
   516 proof -
   517   obtain g h where hom: "homeomorphism S S' g h"
   518     using assms by (force simp: homeomorphic_def)
   519   have h: "continuous_on S' h" " h ` S' \<subseteq> S"
   520     using hom homeomorphism_def apply blast
   521     apply (metis hom equalityE homeomorphism_def)
   522     done
   523   obtain h' where h': "continuous_on U h'" "h' ` U \<subseteq> S"
   524               and h'h: "\<And>x. x \<in> S' \<Longrightarrow> h' x = h x"
   525     by (blast intro: AR_imp_absolute_extensor [OF \<open>AR S\<close> h clo])
   526   have [simp]: "S' \<subseteq> U" using clo closedin_limpt by blast
   527   show ?thesis
   528   proof (simp add: retraction_def retract_of_def, intro exI conjI)
   529     show "continuous_on U (g \<circ> h')"
   530       apply (intro continuous_on_compose h')
   531       apply (meson hom continuous_on_subset h' homeomorphism_cont1)
   532       done
   533     show "(g \<circ> h') ` U \<subseteq> S'"
   534       using h'  by clarsimp (metis hom subsetD homeomorphism_def imageI)
   535     show "\<forall>x\<in>S'. (g \<circ> h') x = x"
   536       by clarsimp (metis h'h hom homeomorphism_def)
   537   qed
   538 qed
   539 
   540 lemma AR_imp_absolute_retract_UNIV:
   541   fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
   542   assumes "AR S" and hom: "S homeomorphic S'"
   543       and clo: "closed S'"
   544     shows "S' retract_of UNIV"
   545 apply (rule AR_imp_absolute_retract [OF \<open>AR S\<close> hom])
   546 using clo closed_closedin by auto
   547 
   548 lemma absolute_extensor_imp_AR:
   549   fixes S :: "'a::euclidean_space set"
   550   assumes "\<And>f :: 'a * real \<Rightarrow> 'a.
   551            \<And>U T. \<lbrakk>continuous_on T f;  f ` T \<subseteq> S;
   552                   closedin (subtopology euclidean U) T\<rbrakk>
   553                  \<Longrightarrow> \<exists>g. continuous_on U g \<and> g ` U \<subseteq> S \<and> (\<forall>x \<in> T. g x = f x)"
   554   shows "AR S"
   555 proof (clarsimp simp: AR_def)
   556   fix U and T :: "('a * real) set"
   557   assume "S homeomorphic T" and clo: "closedin (subtopology euclidean U) T"
   558   then obtain g h where hom: "homeomorphism S T g h"
   559     by (force simp: homeomorphic_def)
   560   have h: "continuous_on T h" " h ` T \<subseteq> S"
   561     using hom homeomorphism_def apply blast
   562     apply (metis hom equalityE homeomorphism_def)
   563     done
   564   obtain h' where h': "continuous_on U h'" "h' ` U \<subseteq> S"
   565               and h'h: "\<forall>x\<in>T. h' x = h x"
   566     using assms [OF h clo] by blast
   567   have [simp]: "T \<subseteq> U"
   568     using clo closedin_imp_subset by auto
   569   show "T retract_of U"
   570   proof (simp add: retraction_def retract_of_def, intro exI conjI)
   571     show "continuous_on U (g \<circ> h')"
   572       apply (intro continuous_on_compose h')
   573       apply (meson hom continuous_on_subset h' homeomorphism_cont1)
   574       done
   575     show "(g \<circ> h') ` U \<subseteq> T"
   576       using h'  by clarsimp (metis hom subsetD homeomorphism_def imageI)
   577     show "\<forall>x\<in>T. (g \<circ> h') x = x"
   578       by clarsimp (metis h'h hom homeomorphism_def)
   579   qed
   580 qed
   581 
   582 lemma AR_eq_absolute_extensor:
   583   fixes S :: "'a::euclidean_space set"
   584   shows "AR S \<longleftrightarrow>
   585        (\<forall>f :: 'a * real \<Rightarrow> 'a.
   586         \<forall>U T. continuous_on T f \<longrightarrow> f ` T \<subseteq> S \<longrightarrow>
   587                closedin (subtopology euclidean U) T \<longrightarrow>
   588                 (\<exists>g. continuous_on U g \<and> g ` U \<subseteq> S \<and> (\<forall>x \<in> T. g x = f x)))"
   589 apply (rule iffI)
   590  apply (metis AR_imp_absolute_extensor)
   591 apply (simp add: absolute_extensor_imp_AR)
   592 done
   593 
   594 lemma AR_imp_retract:
   595   fixes S :: "'a::euclidean_space set"
   596   assumes "AR S \<and> closedin (subtopology euclidean U) S"
   597     shows "S retract_of U"
   598 using AR_imp_absolute_retract assms homeomorphic_refl by blast
   599 
   600 lemma AR_homeomorphic_AR:
   601   fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
   602   assumes "AR T" "S homeomorphic T"
   603     shows "AR S"
   604 unfolding AR_def
   605 by (metis assms AR_imp_absolute_retract homeomorphic_trans [of _ S] homeomorphic_sym)
   606 
   607 lemma homeomorphic_AR_iff_AR:
   608   fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
   609   shows "S homeomorphic T \<Longrightarrow> AR S \<longleftrightarrow> AR T"
   610 by (metis AR_homeomorphic_AR homeomorphic_sym)
   611 
   612 
   613 lemma ANR_imp_absolute_neighbourhood_extensor:
   614   fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
   615   assumes "ANR S" and contf: "continuous_on T f" and "f ` T \<subseteq> S"
   616       and cloUT: "closedin (subtopology euclidean U) T"
   617   obtains V g where "T \<subseteq> V" "openin (subtopology euclidean U) V"
   618                     "continuous_on V g"
   619                     "g ` V \<subseteq> S" "\<And>x. x \<in> T \<Longrightarrow> g x = f x"
   620 proof -
   621   have "aff_dim S < int (DIM('b \<times> real))"
   622     using aff_dim_le_DIM [of S] by simp
   623   then obtain C and S' :: "('b * real) set"
   624           where C: "convex C" "C \<noteq> {}"
   625             and cloCS: "closedin (subtopology euclidean C) S'"
   626             and hom: "S homeomorphic S'"
   627     by (metis that homeomorphic_closedin_convex)
   628   then obtain D where opD: "openin (subtopology euclidean C) D" and "S' retract_of D"
   629     using \<open>ANR S\<close> by (auto simp: ANR_def)
   630   then obtain r where "S' \<subseteq> D" and contr: "continuous_on D r"
   631                   and "r ` D \<subseteq> S'" and rid: "\<And>x. x \<in> S' \<Longrightarrow> r x = x"
   632     by (auto simp: retraction_def retract_of_def)
   633   obtain g h where homgh: "homeomorphism S S' g h"
   634     using hom by (force simp: homeomorphic_def)
   635   have "continuous_on (f ` T) g"
   636     by (meson \<open>f ` T \<subseteq> S\<close> continuous_on_subset homeomorphism_def homgh)
   637   then have contgf: "continuous_on T (g \<circ> f)"
   638     by (intro continuous_on_compose contf)
   639   have gfTC: "(g \<circ> f) ` T \<subseteq> C"
   640   proof -
   641     have "g ` S = S'"
   642       by (metis (no_types) homeomorphism_def homgh)
   643     then show ?thesis
   644       by (metis (no_types) assms(3) cloCS closedin_def image_comp image_mono order.trans topspace_euclidean_subtopology)
   645   qed
   646   obtain f' where contf': "continuous_on U f'"
   647               and "f' ` U \<subseteq> C"
   648               and eq: "\<And>x. x \<in> T \<Longrightarrow> f' x = (g \<circ> f) x"
   649     by (metis Dugundji [OF C cloUT contgf gfTC])
   650   show ?thesis
   651   proof (rule_tac V = "U \<inter> f' -` D" and g = "h \<circ> r \<circ> f'" in that)
   652     show "T \<subseteq> U \<inter> f' -` D"
   653       using cloUT closedin_imp_subset \<open>S' \<subseteq> D\<close> \<open>f ` T \<subseteq> S\<close> eq homeomorphism_image1 homgh
   654       by fastforce
   655     show ope: "openin (subtopology euclidean U) (U \<inter> f' -` D)"
   656       using  \<open>f' ` U \<subseteq> C\<close> by (auto simp: opD contf' continuous_openin_preimage)
   657     have conth: "continuous_on (r ` f' ` (U \<inter> f' -` D)) h"
   658       apply (rule continuous_on_subset [of S'])
   659       using homeomorphism_def homgh apply blast
   660       using \<open>r ` D \<subseteq> S'\<close> by blast
   661     show "continuous_on (U \<inter> f' -` D) (h \<circ> r \<circ> f')"
   662       apply (intro continuous_on_compose conth
   663                    continuous_on_subset [OF contr] continuous_on_subset [OF contf'], auto)
   664       done
   665     show "(h \<circ> r \<circ> f') ` (U \<inter> f' -` D) \<subseteq> S"
   666       using \<open>homeomorphism S S' g h\<close>  \<open>f' ` U \<subseteq> C\<close>  \<open>r ` D \<subseteq> S'\<close>
   667       by (auto simp: homeomorphism_def)
   668     show "\<And>x. x \<in> T \<Longrightarrow> (h \<circ> r \<circ> f') x = f x"
   669       using \<open>homeomorphism S S' g h\<close> \<open>f ` T \<subseteq> S\<close> eq
   670       by (auto simp: rid homeomorphism_def)
   671   qed
   672 qed
   673 
   674 
   675 corollary ANR_imp_absolute_neighbourhood_retract:
   676   fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
   677   assumes "ANR S" "S homeomorphic S'"
   678       and clo: "closedin (subtopology euclidean U) S'"
   679   obtains V where "openin (subtopology euclidean U) V" "S' retract_of V"
   680 proof -
   681   obtain g h where hom: "homeomorphism S S' g h"
   682     using assms by (force simp: homeomorphic_def)
   683   have h: "continuous_on S' h" " h ` S' \<subseteq> S"
   684     using hom homeomorphism_def apply blast
   685     apply (metis hom equalityE homeomorphism_def)
   686     done
   687     from ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR S\<close> h clo]
   688   obtain V h' where "S' \<subseteq> V" and opUV: "openin (subtopology euclidean U) V"
   689                 and h': "continuous_on V h'" "h' ` V \<subseteq> S"
   690                 and h'h:"\<And>x. x \<in> S' \<Longrightarrow> h' x = h x"
   691     by (blast intro: ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR S\<close> h clo])
   692   have "S' retract_of V"
   693   proof (simp add: retraction_def retract_of_def, intro exI conjI \<open>S' \<subseteq> V\<close>)
   694     show "continuous_on V (g \<circ> h')"
   695       apply (intro continuous_on_compose h')
   696       apply (meson hom continuous_on_subset h' homeomorphism_cont1)
   697       done
   698     show "(g \<circ> h') ` V \<subseteq> S'"
   699       using h'  by clarsimp (metis hom subsetD homeomorphism_def imageI)
   700     show "\<forall>x\<in>S'. (g \<circ> h') x = x"
   701       by clarsimp (metis h'h hom homeomorphism_def)
   702   qed
   703   then show ?thesis
   704     by (rule that [OF opUV])
   705 qed
   706 
   707 corollary ANR_imp_absolute_neighbourhood_retract_UNIV:
   708   fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
   709   assumes "ANR S" and hom: "S homeomorphic S'" and clo: "closed S'"
   710   obtains V where "open V" "S' retract_of V"
   711   using ANR_imp_absolute_neighbourhood_retract [OF \<open>ANR S\<close> hom]
   712 by (metis clo closed_closedin open_openin subtopology_UNIV)
   713 
   714 corollary neighbourhood_extension_into_ANR:
   715   fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
   716   assumes contf: "continuous_on S f" and fim: "f ` S \<subseteq> T" and "ANR T" "closed S"
   717   obtains V g where "S \<subseteq> V" "open V" "continuous_on V g"
   718                     "g ` V \<subseteq> T" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
   719   using ANR_imp_absolute_neighbourhood_extensor [OF  \<open>ANR T\<close> contf fim]
   720   by (metis \<open>closed S\<close> closed_closedin open_openin subtopology_UNIV)
   721 
   722 lemma absolute_neighbourhood_extensor_imp_ANR:
   723   fixes S :: "'a::euclidean_space set"
   724   assumes "\<And>f :: 'a * real \<Rightarrow> 'a.
   725            \<And>U T. \<lbrakk>continuous_on T f;  f ` T \<subseteq> S;
   726                   closedin (subtopology euclidean U) T\<rbrakk>
   727                  \<Longrightarrow> \<exists>V g. T \<subseteq> V \<and> openin (subtopology euclidean U) V \<and>
   728                        continuous_on V g \<and> g ` V \<subseteq> S \<and> (\<forall>x \<in> T. g x = f x)"
   729   shows "ANR S"
   730 proof (clarsimp simp: ANR_def)
   731   fix U and T :: "('a * real) set"
   732   assume "S homeomorphic T" and clo: "closedin (subtopology euclidean U) T"
   733   then obtain g h where hom: "homeomorphism S T g h"
   734     by (force simp: homeomorphic_def)
   735   have h: "continuous_on T h" " h ` T \<subseteq> S"
   736     using hom homeomorphism_def apply blast
   737     apply (metis hom equalityE homeomorphism_def)
   738     done
   739   obtain V h' where "T \<subseteq> V" and opV: "openin (subtopology euclidean U) V"
   740                 and h': "continuous_on V h'" "h' ` V \<subseteq> S"
   741               and h'h: "\<forall>x\<in>T. h' x = h x"
   742     using assms [OF h clo] by blast
   743   have [simp]: "T \<subseteq> U"
   744     using clo closedin_imp_subset by auto
   745   have "T retract_of V"
   746   proof (simp add: retraction_def retract_of_def, intro exI conjI \<open>T \<subseteq> V\<close>)
   747     show "continuous_on V (g \<circ> h')"
   748       apply (intro continuous_on_compose h')
   749       apply (meson hom continuous_on_subset h' homeomorphism_cont1)
   750       done
   751     show "(g \<circ> h') ` V \<subseteq> T"
   752       using h'  by clarsimp (metis hom subsetD homeomorphism_def imageI)
   753     show "\<forall>x\<in>T. (g \<circ> h') x = x"
   754       by clarsimp (metis h'h hom homeomorphism_def)
   755   qed
   756   then show "\<exists>V. openin (subtopology euclidean U) V \<and> T retract_of V"
   757     using opV by blast
   758 qed
   759 
   760 lemma ANR_eq_absolute_neighbourhood_extensor:
   761   fixes S :: "'a::euclidean_space set"
   762   shows "ANR S \<longleftrightarrow>
   763          (\<forall>f :: 'a * real \<Rightarrow> 'a.
   764           \<forall>U T. continuous_on T f \<longrightarrow> f ` T \<subseteq> S \<longrightarrow>
   765                 closedin (subtopology euclidean U) T \<longrightarrow>
   766                (\<exists>V g. T \<subseteq> V \<and> openin (subtopology euclidean U) V \<and>
   767                        continuous_on V g \<and> g ` V \<subseteq> S \<and> (\<forall>x \<in> T. g x = f x)))"
   768 apply (rule iffI)
   769  apply (metis ANR_imp_absolute_neighbourhood_extensor)
   770 apply (simp add: absolute_neighbourhood_extensor_imp_ANR)
   771 done
   772 
   773 lemma ANR_imp_neighbourhood_retract:
   774   fixes S :: "'a::euclidean_space set"
   775   assumes "ANR S" "closedin (subtopology euclidean U) S"
   776   obtains V where "openin (subtopology euclidean U) V" "S retract_of V"
   777 using ANR_imp_absolute_neighbourhood_retract assms homeomorphic_refl by blast
   778 
   779 lemma ANR_imp_absolute_closed_neighbourhood_retract:
   780   fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
   781   assumes "ANR S" "S homeomorphic S'" and US': "closedin (subtopology euclidean U) S'"
   782   obtains V W
   783     where "openin (subtopology euclidean U) V"
   784           "closedin (subtopology euclidean U) W"
   785           "S' \<subseteq> V" "V \<subseteq> W" "S' retract_of W"
   786 proof -
   787   obtain Z where "openin (subtopology euclidean U) Z" and S'Z: "S' retract_of Z"
   788     by (blast intro: assms ANR_imp_absolute_neighbourhood_retract)
   789   then have UUZ: "closedin (subtopology euclidean U) (U - Z)"
   790     by auto
   791   have "S' \<inter> (U - Z) = {}"
   792     using \<open>S' retract_of Z\<close> closedin_retract closedin_subtopology by fastforce
   793   then obtain V W
   794       where "openin (subtopology euclidean U) V"
   795         and "openin (subtopology euclidean U) W"
   796         and "S' \<subseteq> V" "U - Z \<subseteq> W" "V \<inter> W = {}"
   797       using separation_normal_local [OF US' UUZ]  by auto
   798   moreover have "S' retract_of U - W"
   799     apply (rule retract_of_subset [OF S'Z])
   800     using US' \<open>S' \<subseteq> V\<close> \<open>V \<inter> W = {}\<close> closedin_subset apply fastforce
   801     using Diff_subset_conv \<open>U - Z \<subseteq> W\<close> by blast
   802   ultimately show ?thesis
   803     apply (rule_tac V=V and W = "U-W" in that)
   804     using openin_imp_subset apply force+
   805     done
   806 qed
   807 
   808 lemma ANR_imp_closed_neighbourhood_retract:
   809   fixes S :: "'a::euclidean_space set"
   810   assumes "ANR S" "closedin (subtopology euclidean U) S"
   811   obtains V W where "openin (subtopology euclidean U) V"
   812                     "closedin (subtopology euclidean U) W"
   813                     "S \<subseteq> V" "V \<subseteq> W" "S retract_of W"
   814 by (meson ANR_imp_absolute_closed_neighbourhood_retract assms homeomorphic_refl)
   815 
   816 lemma ANR_homeomorphic_ANR:
   817   fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
   818   assumes "ANR T" "S homeomorphic T"
   819     shows "ANR S"
   820 unfolding ANR_def
   821 by (metis assms ANR_imp_absolute_neighbourhood_retract homeomorphic_trans [of _ S] homeomorphic_sym)
   822 
   823 lemma homeomorphic_ANR_iff_ANR:
   824   fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
   825   shows "S homeomorphic T \<Longrightarrow> ANR S \<longleftrightarrow> ANR T"
   826 by (metis ANR_homeomorphic_ANR homeomorphic_sym)
   827 
   828 subsubsection \<open>Analogous properties of ENRs\<close>
   829 
   830 lemma ENR_imp_absolute_neighbourhood_retract:
   831   fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
   832   assumes "ENR S" and hom: "S homeomorphic S'"
   833       and "S' \<subseteq> U"
   834   obtains V where "openin (subtopology euclidean U) V" "S' retract_of V"
   835 proof -
   836   obtain X where "open X" "S retract_of X"
   837     using \<open>ENR S\<close> by (auto simp: ENR_def)
   838   then obtain r where "retraction X S r"
   839     by (auto simp: retract_of_def)
   840   have "locally compact S'"
   841     using retract_of_locally_compact open_imp_locally_compact
   842           homeomorphic_local_compactness \<open>S retract_of X\<close> \<open>open X\<close> hom by blast
   843   then obtain W where UW: "openin (subtopology euclidean U) W"
   844                   and WS': "closedin (subtopology euclidean W) S'"
   845     apply (rule locally_compact_closedin_open)
   846     apply (rename_tac W)
   847     apply (rule_tac W = "U \<inter> W" in that, blast)
   848     by (simp add: \<open>S' \<subseteq> U\<close> closedin_limpt)
   849   obtain f g where hom: "homeomorphism S S' f g"
   850     using assms by (force simp: homeomorphic_def)
   851   have contg: "continuous_on S' g"
   852     using hom homeomorphism_def by blast
   853   moreover have "g ` S' \<subseteq> S" by (metis hom equalityE homeomorphism_def)
   854   ultimately obtain h where conth: "continuous_on W h" and hg: "\<And>x. x \<in> S' \<Longrightarrow> h x = g x"
   855     using Tietze_unbounded [of S' g W] WS' by blast
   856   have "W \<subseteq> U" using UW openin_open by auto
   857   have "S' \<subseteq> W" using WS' closedin_closed by auto
   858   have him: "\<And>x. x \<in> S' \<Longrightarrow> h x \<in> X"
   859     by (metis (no_types) \<open>S retract_of X\<close> hg hom homeomorphism_def image_insert insert_absorb insert_iff retract_of_imp_subset subset_eq)
   860   have "S' retract_of (W \<inter> h -` X)"
   861   proof (simp add: retraction_def retract_of_def, intro exI conjI)
   862     show "S' \<subseteq> W" "S' \<subseteq> h -` X"
   863       using him WS' closedin_imp_subset by blast+
   864     show "continuous_on (W \<inter> h -` X) (f \<circ> r \<circ> h)"
   865     proof (intro continuous_on_compose)
   866       show "continuous_on (W \<inter> h -` X) h"
   867         by (meson conth continuous_on_subset inf_le1)
   868       show "continuous_on (h ` (W \<inter> h -` X)) r"
   869       proof -
   870         have "h ` (W \<inter> h -` X) \<subseteq> X"
   871           by blast
   872         then show "continuous_on (h ` (W \<inter> h -` X)) r"
   873           by (meson \<open>retraction X S r\<close> continuous_on_subset retraction)
   874       qed
   875       show "continuous_on (r ` h ` (W \<inter> h -` X)) f"
   876         apply (rule continuous_on_subset [of S])
   877          using hom homeomorphism_def apply blast
   878         apply clarify
   879         apply (meson \<open>retraction X S r\<close> subsetD imageI retraction_def)
   880         done
   881     qed
   882     show "(f \<circ> r \<circ> h) ` (W \<inter> h -` X) \<subseteq> S'"
   883       using \<open>retraction X S r\<close> hom
   884       by (auto simp: retraction_def homeomorphism_def)
   885     show "\<forall>x\<in>S'. (f \<circ> r \<circ> h) x = x"
   886       using \<open>retraction X S r\<close> hom by (auto simp: retraction_def homeomorphism_def hg)
   887   qed
   888   then show ?thesis
   889     apply (rule_tac V = "W \<inter> h -` X" in that)
   890      apply (rule openin_trans [OF _ UW])
   891      using \<open>continuous_on W h\<close> \<open>open X\<close> continuous_openin_preimage_eq apply blast+
   892      done
   893 qed
   894 
   895 corollary ENR_imp_absolute_neighbourhood_retract_UNIV:
   896   fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
   897   assumes "ENR S" "S homeomorphic S'"
   898   obtains T' where "open T'" "S' retract_of T'"
   899 by (metis ENR_imp_absolute_neighbourhood_retract UNIV_I assms(1) assms(2) open_openin subsetI subtopology_UNIV)
   900 
   901 lemma ENR_homeomorphic_ENR:
   902   fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
   903   assumes "ENR T" "S homeomorphic T"
   904     shows "ENR S"
   905 unfolding ENR_def
   906 by (meson ENR_imp_absolute_neighbourhood_retract_UNIV assms homeomorphic_sym)
   907 
   908 lemma homeomorphic_ENR_iff_ENR:
   909   fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
   910   assumes "S homeomorphic T"
   911     shows "ENR S \<longleftrightarrow> ENR T"
   912 by (meson ENR_homeomorphic_ENR assms homeomorphic_sym)
   913 
   914 lemma ENR_translation:
   915   fixes S :: "'a::euclidean_space set"
   916   shows "ENR(image (\<lambda>x. a + x) S) \<longleftrightarrow> ENR S"
   917 by (meson homeomorphic_sym homeomorphic_translation homeomorphic_ENR_iff_ENR)
   918 
   919 lemma ENR_linear_image_eq:
   920   fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
   921   assumes "linear f" "inj f"
   922   shows "ENR (image f S) \<longleftrightarrow> ENR S"
   923 apply (rule homeomorphic_ENR_iff_ENR)
   924 using assms homeomorphic_sym linear_homeomorphic_image by auto
   925 
   926 text \<open>Some relations among the concepts. We also relate AR to being a retract of UNIV, which is
   927 often a more convenient proxy in the closed case.\<close>
   928 
   929 lemma AR_imp_ANR: "AR S \<Longrightarrow> ANR S"
   930   using ANR_def AR_def by fastforce
   931 
   932 lemma ENR_imp_ANR:
   933   fixes S :: "'a::euclidean_space set"
   934   shows "ENR S \<Longrightarrow> ANR S"
   935 apply (simp add: ANR_def)
   936 by (metis ENR_imp_absolute_neighbourhood_retract closedin_imp_subset)
   937 
   938 lemma ENR_ANR:
   939   fixes S :: "'a::euclidean_space set"
   940   shows "ENR S \<longleftrightarrow> ANR S \<and> locally compact S"
   941 proof
   942   assume "ENR S"
   943   then have "locally compact S"
   944     using ENR_def open_imp_locally_compact retract_of_locally_compact by auto
   945   then show "ANR S \<and> locally compact S"
   946     using ENR_imp_ANR \<open>ENR S\<close> by blast
   947 next
   948   assume "ANR S \<and> locally compact S"
   949   then have "ANR S" "locally compact S" by auto
   950   then obtain T :: "('a * real) set" where "closed T" "S homeomorphic T"
   951     using locally_compact_homeomorphic_closed
   952     by (metis DIM_prod DIM_real Suc_eq_plus1 lessI)
   953   then show "ENR S"
   954     using \<open>ANR S\<close>
   955     apply (simp add: ANR_def)
   956     apply (drule_tac x=UNIV in spec)
   957     apply (drule_tac x=T in spec, clarsimp)
   958     apply (meson ENR_def ENR_homeomorphic_ENR open_openin)
   959     done
   960 qed
   961 
   962 
   963 lemma AR_ANR:
   964   fixes S :: "'a::euclidean_space set"
   965   shows "AR S \<longleftrightarrow> ANR S \<and> contractible S \<and> S \<noteq> {}"
   966         (is "?lhs = ?rhs")
   967 proof
   968   assume ?lhs
   969   obtain C and S' :: "('a * real) set"
   970     where "convex C" "C \<noteq> {}" "closedin (subtopology euclidean C) S'" "S homeomorphic S'"
   971       apply (rule homeomorphic_closedin_convex [of S, where 'n = "'a * real"])
   972       using aff_dim_le_DIM [of S] by auto
   973   with \<open>AR S\<close> have "contractible S"
   974     apply (simp add: AR_def)
   975     apply (drule_tac x=C in spec)
   976     apply (drule_tac x="S'" in spec, simp)
   977     using convex_imp_contractible homeomorphic_contractible_eq retract_of_contractible by fastforce
   978   with \<open>AR S\<close> show ?rhs
   979     apply (auto simp: AR_imp_ANR)
   980     apply (force simp: AR_def)
   981     done
   982 next
   983   assume ?rhs
   984   then obtain a and h:: "real \<times> 'a \<Rightarrow> 'a"
   985       where conth: "continuous_on ({0..1} \<times> S) h"
   986         and hS: "h ` ({0..1} \<times> S) \<subseteq> S"
   987         and [simp]: "\<And>x. h(0, x) = x"
   988         and [simp]: "\<And>x. h(1, x) = a"
   989         and "ANR S" "S \<noteq> {}"
   990     by (auto simp: contractible_def homotopic_with_def)
   991   then have "a \<in> S"
   992     by (metis all_not_in_conv atLeastAtMost_iff image_subset_iff mem_Sigma_iff order_refl zero_le_one)
   993   have "\<exists>g. continuous_on W g \<and> g ` W \<subseteq> S \<and> (\<forall>x\<in>T. g x = f x)"
   994          if      f: "continuous_on T f" "f ` T \<subseteq> S"
   995             and WT: "closedin (subtopology euclidean W) T"
   996          for W T and f :: "'a \<times> real \<Rightarrow> 'a"
   997   proof -
   998     obtain U g
   999       where "T \<subseteq> U" and WU: "openin (subtopology euclidean W) U"
  1000         and contg: "continuous_on U g"
  1001         and "g ` U \<subseteq> S" and gf: "\<And>x. x \<in> T \<Longrightarrow> g x = f x"
  1002       using iffD1 [OF ANR_eq_absolute_neighbourhood_extensor \<open>ANR S\<close>, rule_format, OF f WT]
  1003       by auto
  1004     have WWU: "closedin (subtopology euclidean W) (W - U)"
  1005       using WU closedin_diff by fastforce
  1006     moreover have "(W - U) \<inter> T = {}"
  1007       using \<open>T \<subseteq> U\<close> by auto
  1008     ultimately obtain V V'
  1009       where WV': "openin (subtopology euclidean W) V'"
  1010         and WV: "openin (subtopology euclidean W) V"
  1011         and "W - U \<subseteq> V'" "T \<subseteq> V" "V' \<inter> V = {}"
  1012       using separation_normal_local [of W "W-U" T] WT by blast
  1013     then have WVT: "T \<inter> (W - V) = {}"
  1014       by auto
  1015     have WWV: "closedin (subtopology euclidean W) (W - V)"
  1016       using WV closedin_diff by fastforce
  1017     obtain j :: " 'a \<times> real \<Rightarrow> real"
  1018       where contj: "continuous_on W j"
  1019         and j:  "\<And>x. x \<in> W \<Longrightarrow> j x \<in> {0..1}"
  1020         and j0: "\<And>x. x \<in> W - V \<Longrightarrow> j x = 1"
  1021         and j1: "\<And>x. x \<in> T \<Longrightarrow> j x = 0"
  1022       by (rule Urysohn_local [OF WT WWV WVT, of 0 "1::real"]) (auto simp: in_segment)
  1023     have Weq: "W = (W - V) \<union> (W - V')"
  1024       using \<open>V' \<inter> V = {}\<close> by force
  1025     show ?thesis
  1026     proof (intro conjI exI)
  1027       have *: "continuous_on (W - V') (\<lambda>x. h (j x, g x))"
  1028         apply (rule continuous_on_compose2 [OF conth continuous_on_Pair])
  1029           apply (rule continuous_on_subset [OF contj Diff_subset])
  1030          apply (rule continuous_on_subset [OF contg])
  1031          apply (metis Diff_subset_conv Un_commute \<open>W - U \<subseteq> V'\<close>)
  1032         using j \<open>g ` U \<subseteq> S\<close> \<open>W - U \<subseteq> V'\<close> apply fastforce
  1033         done
  1034       show "continuous_on W (\<lambda>x. if x \<in> W - V then a else h (j x, g x))"
  1035         apply (subst Weq)
  1036         apply (rule continuous_on_cases_local)
  1037             apply (simp_all add: Weq [symmetric] WWV continuous_on_const *)
  1038           using WV' closedin_diff apply fastforce
  1039          apply (auto simp: j0 j1)
  1040         done
  1041     next
  1042       have "h (j (x, y), g (x, y)) \<in> S" if "(x, y) \<in> W" "(x, y) \<in> V" for x y
  1043       proof -
  1044         have "j(x, y) \<in> {0..1}"
  1045           using j that by blast
  1046         moreover have "g(x, y) \<in> S"
  1047           using \<open>V' \<inter> V = {}\<close> \<open>W - U \<subseteq> V'\<close> \<open>g ` U \<subseteq> S\<close> that by fastforce
  1048         ultimately show ?thesis
  1049           using hS by blast
  1050       qed
  1051       with \<open>a \<in> S\<close> \<open>g ` U \<subseteq> S\<close>
  1052       show "(\<lambda>x. if x \<in> W - V then a else h (j x, g x)) ` W \<subseteq> S"
  1053         by auto
  1054     next
  1055       show "\<forall>x\<in>T. (if x \<in> W - V then a else h (j x, g x)) = f x"
  1056         using \<open>T \<subseteq> V\<close> by (auto simp: j0 j1 gf)
  1057     qed
  1058   qed
  1059   then show ?lhs
  1060     by (simp add: AR_eq_absolute_extensor)
  1061 qed
  1062 
  1063 
  1064 lemma ANR_retract_of_ANR:
  1065   fixes S :: "'a::euclidean_space set"
  1066   assumes "ANR T" "S retract_of T"
  1067   shows "ANR S"
  1068 using assms
  1069 apply (simp add: ANR_eq_absolute_neighbourhood_extensor retract_of_def retraction_def)
  1070 apply (clarsimp elim!: all_forward)
  1071 apply (erule impCE, metis subset_trans)
  1072 apply (clarsimp elim!: ex_forward)
  1073 apply (rule_tac x="r \<circ> g" in exI)
  1074 by (metis comp_apply continuous_on_compose continuous_on_subset subsetD imageI image_comp image_mono subset_trans)
  1075 
  1076 lemma AR_retract_of_AR:
  1077   fixes S :: "'a::euclidean_space set"
  1078   shows "\<lbrakk>AR T; S retract_of T\<rbrakk> \<Longrightarrow> AR S"
  1079 using ANR_retract_of_ANR AR_ANR retract_of_contractible by fastforce
  1080 
  1081 lemma ENR_retract_of_ENR:
  1082    "\<lbrakk>ENR T; S retract_of T\<rbrakk> \<Longrightarrow> ENR S"
  1083 by (meson ENR_def retract_of_trans)
  1084 
  1085 lemma retract_of_UNIV:
  1086   fixes S :: "'a::euclidean_space set"
  1087   shows "S retract_of UNIV \<longleftrightarrow> AR S \<and> closed S"
  1088 by (metis AR_ANR AR_imp_retract ENR_def ENR_imp_ANR closed_UNIV closed_closedin contractible_UNIV empty_not_UNIV open_UNIV retract_of_closed retract_of_contractible retract_of_empty(1) subtopology_UNIV)
  1089 
  1090 lemma compact_AR:
  1091   fixes S :: "'a::euclidean_space set"
  1092   shows "compact S \<and> AR S \<longleftrightarrow> compact S \<and> S retract_of UNIV"
  1093 using compact_imp_closed retract_of_UNIV by blast
  1094 
  1095 text \<open>More properties of ARs, ANRs and ENRs\<close>
  1096 
  1097 lemma not_AR_empty [simp]: "~ AR({})"
  1098   by (auto simp: AR_def)
  1099 
  1100 lemma ENR_empty [simp]: "ENR {}"
  1101   by (simp add: ENR_def)
  1102 
  1103 lemma ANR_empty [simp]: "ANR ({} :: 'a::euclidean_space set)"
  1104   by (simp add: ENR_imp_ANR)
  1105 
  1106 lemma convex_imp_AR:
  1107   fixes S :: "'a::euclidean_space set"
  1108   shows "\<lbrakk>convex S; S \<noteq> {}\<rbrakk> \<Longrightarrow> AR S"
  1109 apply (rule absolute_extensor_imp_AR)
  1110 apply (rule Dugundji, assumption+)
  1111 by blast
  1112 
  1113 lemma convex_imp_ANR:
  1114   fixes S :: "'a::euclidean_space set"
  1115   shows "convex S \<Longrightarrow> ANR S"
  1116 using ANR_empty AR_imp_ANR convex_imp_AR by blast
  1117 
  1118 lemma ENR_convex_closed:
  1119   fixes S :: "'a::euclidean_space set"
  1120   shows "\<lbrakk>closed S; convex S\<rbrakk> \<Longrightarrow> ENR S"
  1121 using ENR_def ENR_empty convex_imp_AR retract_of_UNIV by blast
  1122 
  1123 lemma AR_UNIV [simp]: "AR (UNIV :: 'a::euclidean_space set)"
  1124   using retract_of_UNIV by auto
  1125 
  1126 lemma ANR_UNIV [simp]: "ANR (UNIV :: 'a::euclidean_space set)"
  1127   by (simp add: AR_imp_ANR)
  1128 
  1129 lemma ENR_UNIV [simp]:"ENR UNIV"
  1130   using ENR_def by blast
  1131 
  1132 lemma AR_singleton:
  1133     fixes a :: "'a::euclidean_space"
  1134     shows "AR {a}"
  1135   using retract_of_UNIV by blast
  1136 
  1137 lemma ANR_singleton:
  1138     fixes a :: "'a::euclidean_space"
  1139     shows "ANR {a}"
  1140   by (simp add: AR_imp_ANR AR_singleton)
  1141 
  1142 lemma ENR_singleton: "ENR {a}"
  1143   using ENR_def by blast
  1144 
  1145 text \<open>ARs closed under union\<close>
  1146 
  1147 lemma AR_closed_Un_local_aux:
  1148   fixes U :: "'a::euclidean_space set"
  1149   assumes "closedin (subtopology euclidean U) S"
  1150           "closedin (subtopology euclidean U) T"
  1151           "AR S" "AR T" "AR(S \<inter> T)"
  1152   shows "(S \<union> T) retract_of U"
  1153 proof -
  1154   have "S \<inter> T \<noteq> {}"
  1155     using assms AR_def by fastforce
  1156   have "S \<subseteq> U" "T \<subseteq> U"
  1157     using assms by (auto simp: closedin_imp_subset)
  1158   define S' where "S' \<equiv> {x \<in> U. setdist {x} S \<le> setdist {x} T}"
  1159   define T' where "T' \<equiv> {x \<in> U. setdist {x} T \<le> setdist {x} S}"
  1160   define W  where "W \<equiv> {x \<in> U. setdist {x} S = setdist {x} T}"
  1161   have US': "closedin (subtopology euclidean U) S'"
  1162     using continuous_closedin_preimage [of U "\<lambda>x. setdist {x} S - setdist {x} T" "{..0}"]
  1163     by (simp add: S'_def vimage_def Collect_conj_eq continuous_on_diff continuous_on_setdist)
  1164   have UT': "closedin (subtopology euclidean U) T'"
  1165     using continuous_closedin_preimage [of U "\<lambda>x. setdist {x} T - setdist {x} S" "{..0}"]
  1166     by (simp add: T'_def vimage_def Collect_conj_eq continuous_on_diff continuous_on_setdist)
  1167   have "S \<subseteq> S'"
  1168     using S'_def \<open>S \<subseteq> U\<close> setdist_sing_in_set by fastforce
  1169   have "T \<subseteq> T'"
  1170     using T'_def \<open>T \<subseteq> U\<close> setdist_sing_in_set by fastforce
  1171   have "S \<inter> T \<subseteq> W" "W \<subseteq> U"
  1172     using \<open>S \<subseteq> U\<close> by (auto simp: W_def setdist_sing_in_set)
  1173   have "(S \<inter> T) retract_of W"
  1174     apply (rule AR_imp_absolute_retract [OF \<open>AR(S \<inter> T)\<close>])
  1175      apply (simp add: homeomorphic_refl)
  1176     apply (rule closedin_subset_trans [of U])
  1177     apply (simp_all add: assms closedin_Int \<open>S \<inter> T \<subseteq> W\<close> \<open>W \<subseteq> U\<close>)
  1178     done
  1179   then obtain r0
  1180     where "S \<inter> T \<subseteq> W" and contr0: "continuous_on W r0"
  1181       and "r0 ` W \<subseteq> S \<inter> T"
  1182       and r0 [simp]: "\<And>x. x \<in> S \<inter> T \<Longrightarrow> r0 x = x"
  1183       by (auto simp: retract_of_def retraction_def)
  1184   have ST: "x \<in> W \<Longrightarrow> x \<in> S \<longleftrightarrow> x \<in> T" for x
  1185     using setdist_eq_0_closedin \<open>S \<inter> T \<noteq> {}\<close> assms
  1186     by (force simp: W_def setdist_sing_in_set)
  1187   have "S' \<inter> T' = W"
  1188     by (auto simp: S'_def T'_def W_def)
  1189   then have cloUW: "closedin (subtopology euclidean U) W"
  1190     using closedin_Int US' UT' by blast
  1191   define r where "r \<equiv> \<lambda>x. if x \<in> W then r0 x else x"
  1192   have "r ` (W \<union> S) \<subseteq> S" "r ` (W \<union> T) \<subseteq> T"
  1193     using \<open>r0 ` W \<subseteq> S \<inter> T\<close> r_def by auto
  1194   have contr: "continuous_on (W \<union> (S \<union> T)) r"
  1195   unfolding r_def
  1196   proof (rule continuous_on_cases_local [OF _ _ contr0 continuous_on_id])
  1197     show "closedin (subtopology euclidean (W \<union> (S \<union> T))) W"
  1198       using \<open>S \<subseteq> U\<close> \<open>T \<subseteq> U\<close> \<open>W \<subseteq> U\<close> \<open>closedin (subtopology euclidean U) W\<close> closedin_subset_trans by fastforce
  1199     show "closedin (subtopology euclidean (W \<union> (S \<union> T))) (S \<union> T)"
  1200       by (meson \<open>S \<subseteq> U\<close> \<open>T \<subseteq> U\<close> \<open>W \<subseteq> U\<close> assms closedin_Un closedin_subset_trans sup.bounded_iff sup.cobounded2)
  1201     show "\<And>x. x \<in> W \<and> x \<notin> W \<or> x \<in> S \<union> T \<and> x \<in> W \<Longrightarrow> r0 x = x"
  1202       by (auto simp: ST)
  1203   qed
  1204   have cloUWS: "closedin (subtopology euclidean U) (W \<union> S)"
  1205     by (simp add: cloUW assms closedin_Un)
  1206   obtain g where contg: "continuous_on U g"
  1207              and "g ` U \<subseteq> S" and geqr: "\<And>x. x \<in> W \<union> S \<Longrightarrow> g x = r x"
  1208     apply (rule AR_imp_absolute_extensor [OF \<open>AR S\<close> _ _ cloUWS])
  1209       apply (rule continuous_on_subset [OF contr])
  1210       using \<open>r ` (W \<union> S) \<subseteq> S\<close> apply auto
  1211     done
  1212   have cloUWT: "closedin (subtopology euclidean U) (W \<union> T)"
  1213     by (simp add: cloUW assms closedin_Un)
  1214   obtain h where conth: "continuous_on U h"
  1215              and "h ` U \<subseteq> T" and heqr: "\<And>x. x \<in> W \<union> T \<Longrightarrow> h x = r x"
  1216     apply (rule AR_imp_absolute_extensor [OF \<open>AR T\<close> _ _ cloUWT])
  1217       apply (rule continuous_on_subset [OF contr])
  1218       using \<open>r ` (W \<union> T) \<subseteq> T\<close> apply auto
  1219     done
  1220   have "U = S' \<union> T'"
  1221     by (force simp: S'_def T'_def)
  1222   then have cont: "continuous_on U (\<lambda>x. if x \<in> S' then g x else h x)"
  1223     apply (rule ssubst)
  1224     apply (rule continuous_on_cases_local)
  1225     using US' UT' \<open>S' \<inter> T' = W\<close> \<open>U = S' \<union> T'\<close>
  1226           contg conth continuous_on_subset geqr heqr apply auto
  1227     done
  1228   have UST: "(\<lambda>x. if x \<in> S' then g x else h x) ` U \<subseteq> S \<union> T"
  1229     using \<open>g ` U \<subseteq> S\<close> \<open>h ` U \<subseteq> T\<close> by auto
  1230   show ?thesis
  1231     apply (simp add: retract_of_def retraction_def \<open>S \<subseteq> U\<close> \<open>T \<subseteq> U\<close>)
  1232     apply (rule_tac x="\<lambda>x. if x \<in> S' then g x else h x" in exI)
  1233     apply (intro conjI cont UST)
  1234     by (metis IntI ST Un_iff \<open>S \<subseteq> S'\<close> \<open>S' \<inter> T' = W\<close> \<open>T \<subseteq> T'\<close> subsetD geqr heqr r0 r_def)
  1235 qed
  1236 
  1237 
  1238 lemma AR_closed_Un_local:
  1239   fixes S :: "'a::euclidean_space set"
  1240   assumes STS: "closedin (subtopology euclidean (S \<union> T)) S"
  1241       and STT: "closedin (subtopology euclidean (S \<union> T)) T"
  1242       and "AR S" "AR T" "AR(S \<inter> T)"
  1243     shows "AR(S \<union> T)"
  1244 proof -
  1245   have "C retract_of U"
  1246        if hom: "S \<union> T homeomorphic C" and UC: "closedin (subtopology euclidean U) C"
  1247        for U and C :: "('a * real) set"
  1248   proof -
  1249     obtain f g where hom: "homeomorphism (S \<union> T) C f g"
  1250       using hom by (force simp: homeomorphic_def)
  1251     have US: "closedin (subtopology euclidean U) (C \<inter> g -` S)"
  1252       apply (rule closedin_trans [OF _ UC])
  1253       apply (rule continuous_closedin_preimage_gen [OF _ _ STS])
  1254       using hom homeomorphism_def apply blast
  1255       apply (metis hom homeomorphism_def set_eq_subset)
  1256       done
  1257     have UT: "closedin (subtopology euclidean U) (C \<inter> g -` T)"
  1258       apply (rule closedin_trans [OF _ UC])
  1259       apply (rule continuous_closedin_preimage_gen [OF _ _ STT])
  1260       using hom homeomorphism_def apply blast
  1261       apply (metis hom homeomorphism_def set_eq_subset)
  1262       done
  1263     have ARS: "AR (C \<inter> g -` S)"
  1264       apply (rule AR_homeomorphic_AR [OF \<open>AR S\<close>])
  1265       apply (simp add: homeomorphic_def)
  1266       apply (rule_tac x=g in exI)
  1267       apply (rule_tac x=f in exI)
  1268       using hom apply (auto simp: homeomorphism_def elim!: continuous_on_subset)
  1269       apply (rule_tac x="f x" in image_eqI, auto)
  1270       done
  1271     have ART: "AR (C \<inter> g -` T)"
  1272       apply (rule AR_homeomorphic_AR [OF \<open>AR T\<close>])
  1273       apply (simp add: homeomorphic_def)
  1274       apply (rule_tac x=g in exI)
  1275       apply (rule_tac x=f in exI)
  1276       using hom apply (auto simp: homeomorphism_def elim!: continuous_on_subset)
  1277       apply (rule_tac x="f x" in image_eqI, auto)
  1278       done
  1279     have ARI: "AR ((C \<inter> g -` S) \<inter> (C \<inter> g -` T))"
  1280       apply (rule AR_homeomorphic_AR [OF \<open>AR (S \<inter> T)\<close>])
  1281       apply (simp add: homeomorphic_def)
  1282       apply (rule_tac x=g in exI)
  1283       apply (rule_tac x=f in exI)
  1284       using hom
  1285       apply (auto simp: homeomorphism_def elim!: continuous_on_subset)
  1286       apply (rule_tac x="f x" in image_eqI, auto)
  1287       done
  1288     have "C = (C \<inter> g -` S) \<union> (C \<inter> g -` T)"
  1289       using hom  by (auto simp: homeomorphism_def)
  1290     then show ?thesis
  1291       by (metis AR_closed_Un_local_aux [OF US UT ARS ART ARI])
  1292   qed
  1293   then show ?thesis
  1294     by (force simp: AR_def)
  1295 qed
  1296 
  1297 corollary AR_closed_Un:
  1298   fixes S :: "'a::euclidean_space set"
  1299   shows "\<lbrakk>closed S; closed T; AR S; AR T; AR (S \<inter> T)\<rbrakk> \<Longrightarrow> AR (S \<union> T)"
  1300 by (metis AR_closed_Un_local_aux closed_closedin retract_of_UNIV subtopology_UNIV)
  1301 
  1302 text \<open>ANRs closed under union\<close>
  1303 
  1304 lemma ANR_closed_Un_local_aux:
  1305   fixes U :: "'a::euclidean_space set"
  1306   assumes US: "closedin (subtopology euclidean U) S"
  1307       and UT: "closedin (subtopology euclidean U) T"
  1308       and "ANR S" "ANR T" "ANR(S \<inter> T)"
  1309   obtains V where "openin (subtopology euclidean U) V" "(S \<union> T) retract_of V"
  1310 proof (cases "S = {} \<or> T = {}")
  1311   case True with assms that show ?thesis
  1312     by (metis ANR_imp_neighbourhood_retract Un_commute inf_bot_right sup_inf_absorb)
  1313 next
  1314   case False
  1315   then have [simp]: "S \<noteq> {}" "T \<noteq> {}" by auto
  1316   have "S \<subseteq> U" "T \<subseteq> U"
  1317     using assms by (auto simp: closedin_imp_subset)
  1318   define S' where "S' \<equiv> {x \<in> U. setdist {x} S \<le> setdist {x} T}"
  1319   define T' where "T' \<equiv> {x \<in> U. setdist {x} T \<le> setdist {x} S}"
  1320   define W  where "W \<equiv> {x \<in> U. setdist {x} S = setdist {x} T}"
  1321   have cloUS': "closedin (subtopology euclidean U) S'"
  1322     using continuous_closedin_preimage [of U "\<lambda>x. setdist {x} S - setdist {x} T" "{..0}"]
  1323     by (simp add: S'_def vimage_def Collect_conj_eq continuous_on_diff continuous_on_setdist)
  1324   have cloUT': "closedin (subtopology euclidean U) T'"
  1325     using continuous_closedin_preimage [of U "\<lambda>x. setdist {x} T - setdist {x} S" "{..0}"]
  1326     by (simp add: T'_def vimage_def Collect_conj_eq continuous_on_diff continuous_on_setdist)
  1327   have "S \<subseteq> S'"
  1328     using S'_def \<open>S \<subseteq> U\<close> setdist_sing_in_set by fastforce
  1329   have "T \<subseteq> T'"
  1330     using T'_def \<open>T \<subseteq> U\<close> setdist_sing_in_set by fastforce
  1331   have "S' \<union> T' = U"
  1332     by (auto simp: S'_def T'_def)
  1333   have "W \<subseteq> S'"
  1334     by (simp add: Collect_mono S'_def W_def)
  1335   have "W \<subseteq> T'"
  1336     by (simp add: Collect_mono T'_def W_def)
  1337   have ST_W: "S \<inter> T \<subseteq> W" and "W \<subseteq> U"
  1338     using \<open>S \<subseteq> U\<close> by (force simp: W_def setdist_sing_in_set)+
  1339   have "S' \<inter> T' = W"
  1340     by (auto simp: S'_def T'_def W_def)
  1341   then have cloUW: "closedin (subtopology euclidean U) W"
  1342     using closedin_Int cloUS' cloUT' by blast
  1343   obtain W' W0 where "openin (subtopology euclidean W) W'"
  1344                  and cloWW0: "closedin (subtopology euclidean W) W0"
  1345                  and "S \<inter> T \<subseteq> W'" "W' \<subseteq> W0"
  1346                  and ret: "(S \<inter> T) retract_of W0"
  1347     apply (rule ANR_imp_closed_neighbourhood_retract [OF \<open>ANR(S \<inter> T)\<close>])
  1348     apply (rule closedin_subset_trans [of U, OF _ ST_W \<open>W \<subseteq> U\<close>])
  1349     apply (blast intro: assms)+
  1350     done
  1351   then obtain U0 where opeUU0: "openin (subtopology euclidean U) U0"
  1352                    and U0: "S \<inter> T \<subseteq> U0" "U0 \<inter> W \<subseteq> W0"
  1353     unfolding openin_open  using \<open>W \<subseteq> U\<close> by blast
  1354   have "W0 \<subseteq> U"
  1355     using \<open>W \<subseteq> U\<close> cloWW0 closedin_subset by fastforce
  1356   obtain r0
  1357     where "S \<inter> T \<subseteq> W0" and contr0: "continuous_on W0 r0" and "r0 ` W0 \<subseteq> S \<inter> T"
  1358       and r0 [simp]: "\<And>x. x \<in> S \<inter> T \<Longrightarrow> r0 x = x"
  1359     using ret  by (force simp: retract_of_def retraction_def)
  1360   have ST: "x \<in> W \<Longrightarrow> x \<in> S \<longleftrightarrow> x \<in> T" for x
  1361     using assms by (auto simp: W_def setdist_sing_in_set dest!: setdist_eq_0_closedin)
  1362   define r where "r \<equiv> \<lambda>x. if x \<in> W0 then r0 x else x"
  1363   have "r ` (W0 \<union> S) \<subseteq> S" "r ` (W0 \<union> T) \<subseteq> T"
  1364     using \<open>r0 ` W0 \<subseteq> S \<inter> T\<close> r_def by auto
  1365   have contr: "continuous_on (W0 \<union> (S \<union> T)) r"
  1366   unfolding r_def
  1367   proof (rule continuous_on_cases_local [OF _ _ contr0 continuous_on_id])
  1368     show "closedin (subtopology euclidean (W0 \<union> (S \<union> T))) W0"
  1369       apply (rule closedin_subset_trans [of U])
  1370       using cloWW0 cloUW closedin_trans \<open>W0 \<subseteq> U\<close> \<open>S \<subseteq> U\<close> \<open>T \<subseteq> U\<close> apply blast+
  1371       done
  1372     show "closedin (subtopology euclidean (W0 \<union> (S \<union> T))) (S \<union> T)"
  1373       by (meson \<open>S \<subseteq> U\<close> \<open>T \<subseteq> U\<close> \<open>W0 \<subseteq> U\<close> assms closedin_Un closedin_subset_trans sup.bounded_iff sup.cobounded2)
  1374     show "\<And>x. x \<in> W0 \<and> x \<notin> W0 \<or> x \<in> S \<union> T \<and> x \<in> W0 \<Longrightarrow> r0 x = x"
  1375       using ST cloWW0 closedin_subset by fastforce
  1376   qed
  1377   have cloS'WS: "closedin (subtopology euclidean S') (W0 \<union> S)"
  1378     by (meson closedin_subset_trans US cloUS' \<open>S \<subseteq> S'\<close> \<open>W \<subseteq> S'\<close> cloUW cloWW0 
  1379               closedin_Un closedin_imp_subset closedin_trans)
  1380   obtain W1 g where "W0 \<union> S \<subseteq> W1" and contg: "continuous_on W1 g"
  1381                 and opeSW1: "openin (subtopology euclidean S') W1"
  1382                 and "g ` W1 \<subseteq> S" and geqr: "\<And>x. x \<in> W0 \<union> S \<Longrightarrow> g x = r x"
  1383     apply (rule ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR S\<close> _ \<open>r ` (W0 \<union> S) \<subseteq> S\<close> cloS'WS])
  1384      apply (rule continuous_on_subset [OF contr], blast+)
  1385     done
  1386   have cloT'WT: "closedin (subtopology euclidean T') (W0 \<union> T)"
  1387     by (meson closedin_subset_trans UT cloUT' \<open>T \<subseteq> T'\<close> \<open>W \<subseteq> T'\<close> cloUW cloWW0 
  1388               closedin_Un closedin_imp_subset closedin_trans)
  1389   obtain W2 h where "W0 \<union> T \<subseteq> W2" and conth: "continuous_on W2 h"
  1390                 and opeSW2: "openin (subtopology euclidean T') W2"
  1391                 and "h ` W2 \<subseteq> T" and heqr: "\<And>x. x \<in> W0 \<union> T \<Longrightarrow> h x = r x"
  1392     apply (rule ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR T\<close> _ \<open>r ` (W0 \<union> T) \<subseteq> T\<close> cloT'WT])
  1393      apply (rule continuous_on_subset [OF contr], blast+)
  1394     done
  1395   have "S' \<inter> T' = W"
  1396     by (force simp: S'_def T'_def W_def)
  1397   obtain O1 O2 where "open O1" "W1 = S' \<inter> O1" "open O2" "W2 = T' \<inter> O2"
  1398     using opeSW1 opeSW2 by (force simp: openin_open)
  1399   show ?thesis
  1400   proof
  1401     have eq: "W1 - (W - U0) \<union> (W2 - (W - U0)) =
  1402          ((U - T') \<inter> O1 \<union> (U - S') \<inter> O2 \<union> U \<inter> O1 \<inter> O2) - (W - U0)"
  1403      using \<open>U0 \<inter> W \<subseteq> W0\<close> \<open>W0 \<union> S \<subseteq> W1\<close> \<open>W0 \<union> T \<subseteq> W2\<close>
  1404       by (auto simp: \<open>S' \<union> T' = U\<close> [symmetric] \<open>S' \<inter> T' = W\<close> [symmetric] \<open>W1 = S' \<inter> O1\<close> \<open>W2 = T' \<inter> O2\<close>)
  1405     show "openin (subtopology euclidean U) (W1 - (W - U0) \<union> (W2 - (W - U0)))"
  1406       apply (subst eq)
  1407       apply (intro openin_Un openin_Int_open openin_diff closedin_diff cloUW opeUU0 cloUS' cloUT' \<open>open O1\<close> \<open>open O2\<close>, simp_all)
  1408       done
  1409     have cloW1: "closedin (subtopology euclidean (W1 - (W - U0) \<union> (W2 - (W - U0)))) (W1 - (W - U0))"
  1410       using cloUS' apply (simp add: closedin_closed)
  1411       apply (erule ex_forward)
  1412       using U0 \<open>W0 \<union> S \<subseteq> W1\<close>
  1413       apply (auto simp: \<open>W1 = S' \<inter> O1\<close> \<open>W2 = T' \<inter> O2\<close> \<open>S' \<union> T' = U\<close> [symmetric]\<open>S' \<inter> T' = W\<close> [symmetric])
  1414       done
  1415     have cloW2: "closedin (subtopology euclidean (W1 - (W - U0) \<union> (W2 - (W - U0)))) (W2 - (W - U0))"
  1416       using cloUT' apply (simp add: closedin_closed)
  1417       apply (erule ex_forward)
  1418       using U0 \<open>W0 \<union> T \<subseteq> W2\<close>
  1419       apply (auto simp: \<open>W1 = S' \<inter> O1\<close> \<open>W2 = T' \<inter> O2\<close> \<open>S' \<union> T' = U\<close> [symmetric]\<open>S' \<inter> T' = W\<close> [symmetric])
  1420       done
  1421     have *: "\<forall>x\<in>S \<union> T. (if x \<in> S' then g x else h x) = x"
  1422       using ST \<open>S' \<inter> T' = W\<close> cloT'WT closedin_subset geqr heqr 
  1423       apply (auto simp: r_def, fastforce)
  1424       using \<open>S \<subseteq> S'\<close> \<open>T \<subseteq> T'\<close> \<open>W0 \<union> S \<subseteq> W1\<close> \<open>W1 = S' \<inter> O1\<close>  by auto
  1425     have "\<exists>r. continuous_on (W1 - (W - U0) \<union> (W2 - (W - U0))) r \<and>
  1426               r ` (W1 - (W - U0) \<union> (W2 - (W - U0))) \<subseteq> S \<union> T \<and> 
  1427               (\<forall>x\<in>S \<union> T. r x = x)"
  1428       apply (rule_tac x = "\<lambda>x. if  x \<in> S' then g x else h x" in exI)
  1429       apply (intro conjI *)
  1430       apply (rule continuous_on_cases_local 
  1431                   [OF cloW1 cloW2 continuous_on_subset [OF contg] continuous_on_subset [OF conth]])
  1432       using \<open>W1 = S' \<inter> O1\<close> \<open>W2 = T' \<inter> O2\<close> \<open>S' \<inter> T' = W\<close>
  1433             \<open>g ` W1 \<subseteq> S\<close> \<open>h ` W2 \<subseteq> T\<close> apply auto
  1434       using \<open>U0 \<inter> W \<subseteq> W0\<close> \<open>W0 \<union> S \<subseteq> W1\<close> apply (fastforce simp add: geqr heqr)+
  1435       done
  1436     then show "S \<union> T retract_of W1 - (W - U0) \<union> (W2 - (W - U0))"
  1437       using  \<open>W0 \<union> S \<subseteq> W1\<close> \<open>W0 \<union> T \<subseteq> W2\<close> ST opeUU0 U0
  1438       by (auto simp: retract_of_def retraction_def)
  1439   qed
  1440 qed
  1441 
  1442 
  1443 lemma ANR_closed_Un_local:
  1444   fixes S :: "'a::euclidean_space set"
  1445   assumes STS: "closedin (subtopology euclidean (S \<union> T)) S"
  1446       and STT: "closedin (subtopology euclidean (S \<union> T)) T"
  1447       and "ANR S" "ANR T" "ANR(S \<inter> T)" 
  1448     shows "ANR(S \<union> T)"
  1449 proof -
  1450   have "\<exists>T. openin (subtopology euclidean U) T \<and> C retract_of T"
  1451        if hom: "S \<union> T homeomorphic C" and UC: "closedin (subtopology euclidean U) C"
  1452        for U and C :: "('a * real) set"
  1453   proof -
  1454     obtain f g where hom: "homeomorphism (S \<union> T) C f g"
  1455       using hom by (force simp: homeomorphic_def)
  1456     have US: "closedin (subtopology euclidean U) (C \<inter> g -` S)"
  1457       apply (rule closedin_trans [OF _ UC])
  1458       apply (rule continuous_closedin_preimage_gen [OF _ _ STS])
  1459       using hom [unfolded homeomorphism_def] apply blast
  1460       apply (metis hom homeomorphism_def set_eq_subset)
  1461       done
  1462     have UT: "closedin (subtopology euclidean U) (C \<inter> g -` T)"
  1463       apply (rule closedin_trans [OF _ UC])
  1464       apply (rule continuous_closedin_preimage_gen [OF _ _ STT])
  1465       using hom [unfolded homeomorphism_def] apply blast
  1466       apply (metis hom homeomorphism_def set_eq_subset)
  1467       done
  1468     have ANRS: "ANR (C \<inter> g -` S)"
  1469       apply (rule ANR_homeomorphic_ANR [OF \<open>ANR S\<close>])
  1470       apply (simp add: homeomorphic_def)
  1471       apply (rule_tac x=g in exI)
  1472       apply (rule_tac x=f in exI)
  1473       using hom apply (auto simp: homeomorphism_def elim!: continuous_on_subset)
  1474       apply (rule_tac x="f x" in image_eqI, auto)
  1475       done
  1476     have ANRT: "ANR (C \<inter> g -` T)"
  1477       apply (rule ANR_homeomorphic_ANR [OF \<open>ANR T\<close>])
  1478       apply (simp add: homeomorphic_def)
  1479       apply (rule_tac x=g in exI)
  1480       apply (rule_tac x=f in exI)
  1481       using hom apply (auto simp: homeomorphism_def elim!: continuous_on_subset)
  1482       apply (rule_tac x="f x" in image_eqI, auto)
  1483       done
  1484     have ANRI: "ANR ((C \<inter> g -` S) \<inter> (C \<inter> g -` T))"
  1485       apply (rule ANR_homeomorphic_ANR [OF \<open>ANR (S \<inter> T)\<close>])
  1486       apply (simp add: homeomorphic_def)
  1487       apply (rule_tac x=g in exI)
  1488       apply (rule_tac x=f in exI)
  1489       using hom
  1490       apply (auto simp: homeomorphism_def elim!: continuous_on_subset)
  1491       apply (rule_tac x="f x" in image_eqI, auto)
  1492       done
  1493     have "C = (C \<inter> g -` S) \<union> (C \<inter> g -` T)"
  1494       using hom by (auto simp: homeomorphism_def)
  1495     then show ?thesis
  1496       by (metis ANR_closed_Un_local_aux [OF US UT ANRS ANRT ANRI])
  1497   qed
  1498   then show ?thesis
  1499     by (auto simp: ANR_def)
  1500 qed    
  1501 
  1502 corollary ANR_closed_Un:
  1503   fixes S :: "'a::euclidean_space set"
  1504   shows "\<lbrakk>closed S; closed T; ANR S; ANR T; ANR (S \<inter> T)\<rbrakk> \<Longrightarrow> ANR (S \<union> T)"
  1505 by (simp add: ANR_closed_Un_local closedin_def diff_eq open_Compl openin_open_Int)
  1506 
  1507 lemma ANR_openin:
  1508   fixes S :: "'a::euclidean_space set"
  1509   assumes "ANR T" and opeTS: "openin (subtopology euclidean T) S"
  1510   shows "ANR S"
  1511 proof (clarsimp simp only: ANR_eq_absolute_neighbourhood_extensor)
  1512   fix f :: "'a \<times> real \<Rightarrow> 'a" and U C
  1513   assume contf: "continuous_on C f" and fim: "f ` C \<subseteq> S"
  1514      and cloUC: "closedin (subtopology euclidean U) C"
  1515   have "f ` C \<subseteq> T"
  1516     using fim opeTS openin_imp_subset by blast
  1517   obtain W g where "C \<subseteq> W"
  1518                and UW: "openin (subtopology euclidean U) W"
  1519                and contg: "continuous_on W g"
  1520                and gim: "g ` W \<subseteq> T"
  1521                and geq: "\<And>x. x \<in> C \<Longrightarrow> g x = f x"
  1522     apply (rule ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR T\<close> contf \<open>f ` C \<subseteq> T\<close> cloUC])
  1523     using fim by auto
  1524   show "\<exists>V g. C \<subseteq> V \<and> openin (subtopology euclidean U) V \<and> continuous_on V g \<and> g ` V \<subseteq> S \<and> (\<forall>x\<in>C. g x = f x)"
  1525   proof (intro exI conjI)
  1526     show "C \<subseteq> W \<inter> g -` S"
  1527       using \<open>C \<subseteq> W\<close> fim geq by blast
  1528     show "openin (subtopology euclidean U) (W \<inter> g -` S)"
  1529       by (metis (mono_tags, lifting) UW contg continuous_openin_preimage gim opeTS openin_trans)
  1530     show "continuous_on (W \<inter> g -` S) g"
  1531       by (blast intro: continuous_on_subset [OF contg])
  1532     show "g ` (W \<inter> g -` S) \<subseteq> S"
  1533       using gim by blast
  1534     show "\<forall>x\<in>C. g x = f x"
  1535       using geq by blast
  1536   qed
  1537 qed
  1538 
  1539 lemma ENR_openin:
  1540     fixes S :: "'a::euclidean_space set"
  1541     assumes "ENR T" and opeTS: "openin (subtopology euclidean T) S"
  1542     shows "ENR S"
  1543   using assms apply (simp add: ENR_ANR)
  1544   using ANR_openin locally_open_subset by blast
  1545 
  1546 lemma ANR_neighborhood_retract:
  1547     fixes S :: "'a::euclidean_space set"
  1548     assumes "ANR U" "S retract_of T" "openin (subtopology euclidean U) T"
  1549     shows "ANR S"
  1550   using ANR_openin ANR_retract_of_ANR assms by blast
  1551 
  1552 lemma ENR_neighborhood_retract:
  1553     fixes S :: "'a::euclidean_space set"
  1554     assumes "ENR U" "S retract_of T" "openin (subtopology euclidean U) T"
  1555     shows "ENR S"
  1556   using ENR_openin ENR_retract_of_ENR assms by blast
  1557 
  1558 lemma ANR_rel_interior:
  1559   fixes S :: "'a::euclidean_space set"
  1560   shows "ANR S \<Longrightarrow> ANR(rel_interior S)"
  1561    by (blast intro: ANR_openin openin_set_rel_interior)
  1562 
  1563 lemma ANR_delete:
  1564   fixes S :: "'a::euclidean_space set"
  1565   shows "ANR S \<Longrightarrow> ANR(S - {a})"
  1566    by (blast intro: ANR_openin openin_delete openin_subtopology_self)
  1567 
  1568 lemma ENR_rel_interior:
  1569   fixes S :: "'a::euclidean_space set"
  1570   shows "ENR S \<Longrightarrow> ENR(rel_interior S)"
  1571    by (blast intro: ENR_openin openin_set_rel_interior)
  1572 
  1573 lemma ENR_delete:
  1574   fixes S :: "'a::euclidean_space set"
  1575   shows "ENR S \<Longrightarrow> ENR(S - {a})"
  1576    by (blast intro: ENR_openin openin_delete openin_subtopology_self)
  1577 
  1578 lemma open_imp_ENR: "open S \<Longrightarrow> ENR S"
  1579     using ENR_def by blast
  1580 
  1581 lemma open_imp_ANR:
  1582     fixes S :: "'a::euclidean_space set"
  1583     shows "open S \<Longrightarrow> ANR S"
  1584   by (simp add: ENR_imp_ANR open_imp_ENR)
  1585 
  1586 lemma ANR_ball [iff]:
  1587     fixes a :: "'a::euclidean_space"
  1588     shows "ANR(ball a r)"
  1589   by (simp add: convex_imp_ANR)
  1590 
  1591 lemma ENR_ball [iff]: "ENR(ball a r)"
  1592   by (simp add: open_imp_ENR)
  1593 
  1594 lemma AR_ball [simp]:
  1595     fixes a :: "'a::euclidean_space"
  1596     shows "AR(ball a r) \<longleftrightarrow> 0 < r"
  1597   by (auto simp: AR_ANR convex_imp_contractible)
  1598 
  1599 lemma ANR_cball [iff]:
  1600     fixes a :: "'a::euclidean_space"
  1601     shows "ANR(cball a r)"
  1602   by (simp add: convex_imp_ANR)
  1603 
  1604 lemma ENR_cball:
  1605     fixes a :: "'a::euclidean_space"
  1606     shows "ENR(cball a r)"
  1607   using ENR_convex_closed by blast
  1608 
  1609 lemma AR_cball [simp]:
  1610     fixes a :: "'a::euclidean_space"
  1611     shows "AR(cball a r) \<longleftrightarrow> 0 \<le> r"
  1612   by (auto simp: AR_ANR convex_imp_contractible)
  1613 
  1614 lemma ANR_box [iff]:
  1615     fixes a :: "'a::euclidean_space"
  1616     shows "ANR(cbox a b)" "ANR(box a b)"
  1617   by (auto simp: convex_imp_ANR open_imp_ANR)
  1618 
  1619 lemma ENR_box [iff]:
  1620     fixes a :: "'a::euclidean_space"
  1621     shows "ENR(cbox a b)" "ENR(box a b)"
  1622 apply (simp add: ENR_convex_closed closed_cbox)
  1623 by (simp add: open_box open_imp_ENR)
  1624 
  1625 lemma AR_box [simp]:
  1626     "AR(cbox a b) \<longleftrightarrow> cbox a b \<noteq> {}" "AR(box a b) \<longleftrightarrow> box a b \<noteq> {}"
  1627   by (auto simp: AR_ANR convex_imp_contractible)
  1628 
  1629 lemma ANR_interior:
  1630      fixes S :: "'a::euclidean_space set"
  1631      shows "ANR(interior S)"
  1632   by (simp add: open_imp_ANR)
  1633 
  1634 lemma ENR_interior:
  1635      fixes S :: "'a::euclidean_space set"
  1636      shows "ENR(interior S)"
  1637   by (simp add: open_imp_ENR)
  1638 
  1639 lemma AR_imp_contractible:
  1640     fixes S :: "'a::euclidean_space set"
  1641     shows "AR S \<Longrightarrow> contractible S"
  1642   by (simp add: AR_ANR)
  1643 
  1644 lemma ENR_imp_locally_compact:
  1645     fixes S :: "'a::euclidean_space set"
  1646     shows "ENR S \<Longrightarrow> locally compact S"
  1647   by (simp add: ENR_ANR)
  1648 
  1649 lemma ANR_imp_locally_path_connected:
  1650   fixes S :: "'a::euclidean_space set"
  1651   assumes "ANR S"
  1652     shows "locally path_connected S"
  1653 proof -
  1654   obtain U and T :: "('a \<times> real) set"
  1655      where "convex U" "U \<noteq> {}"
  1656        and UT: "closedin (subtopology euclidean U) T"
  1657        and "S homeomorphic T"
  1658     apply (rule homeomorphic_closedin_convex [of S])
  1659     using aff_dim_le_DIM [of S] apply auto
  1660     done
  1661   then have "locally path_connected T"
  1662     by (meson ANR_imp_absolute_neighbourhood_retract
  1663         assms convex_imp_locally_path_connected locally_open_subset retract_of_locally_path_connected)
  1664   then have S: "locally path_connected S"
  1665       if "openin (subtopology euclidean U) V" "T retract_of V" "U \<noteq> {}" for V
  1666     using \<open>S homeomorphic T\<close> homeomorphic_locally homeomorphic_path_connectedness by blast
  1667   show ?thesis
  1668     using assms
  1669     apply (clarsimp simp: ANR_def)
  1670     apply (drule_tac x=U in spec)
  1671     apply (drule_tac x=T in spec)
  1672     using \<open>S homeomorphic T\<close> \<open>U \<noteq> {}\<close> UT  apply (blast intro: S)
  1673     done
  1674 qed
  1675 
  1676 lemma ANR_imp_locally_connected:
  1677   fixes S :: "'a::euclidean_space set"
  1678   assumes "ANR S"
  1679     shows "locally connected S"
  1680 using locally_path_connected_imp_locally_connected ANR_imp_locally_path_connected assms by auto
  1681 
  1682 lemma AR_imp_locally_path_connected:
  1683   fixes S :: "'a::euclidean_space set"
  1684   assumes "AR S"
  1685     shows "locally path_connected S"
  1686 by (simp add: ANR_imp_locally_path_connected AR_imp_ANR assms)
  1687 
  1688 lemma AR_imp_locally_connected:
  1689   fixes S :: "'a::euclidean_space set"
  1690   assumes "AR S"
  1691     shows "locally connected S"
  1692 using ANR_imp_locally_connected AR_ANR assms by blast
  1693 
  1694 lemma ENR_imp_locally_path_connected:
  1695   fixes S :: "'a::euclidean_space set"
  1696   assumes "ENR S"
  1697     shows "locally path_connected S"
  1698 by (simp add: ANR_imp_locally_path_connected ENR_imp_ANR assms)
  1699 
  1700 lemma ENR_imp_locally_connected:
  1701   fixes S :: "'a::euclidean_space set"
  1702   assumes "ENR S"
  1703     shows "locally connected S"
  1704 using ANR_imp_locally_connected ENR_ANR assms by blast
  1705 
  1706 lemma ANR_Times:
  1707   fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
  1708   assumes "ANR S" "ANR T" shows "ANR(S \<times> T)"
  1709 proof (clarsimp simp only: ANR_eq_absolute_neighbourhood_extensor)
  1710   fix f :: " ('a \<times> 'b) \<times> real \<Rightarrow> 'a \<times> 'b" and U C
  1711   assume "continuous_on C f" and fim: "f ` C \<subseteq> S \<times> T"
  1712      and cloUC: "closedin (subtopology euclidean U) C"
  1713   have contf1: "continuous_on C (fst \<circ> f)"
  1714     by (simp add: \<open>continuous_on C f\<close> continuous_on_fst)
  1715   obtain W1 g where "C \<subseteq> W1"
  1716                and UW1: "openin (subtopology euclidean U) W1"
  1717                and contg: "continuous_on W1 g"
  1718                and gim: "g ` W1 \<subseteq> S"
  1719                and geq: "\<And>x. x \<in> C \<Longrightarrow> g x = (fst \<circ> f) x"
  1720     apply (rule ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR S\<close> contf1 _ cloUC])
  1721     using fim apply auto
  1722     done
  1723   have contf2: "continuous_on C (snd \<circ> f)"
  1724     by (simp add: \<open>continuous_on C f\<close> continuous_on_snd)
  1725   obtain W2 h where "C \<subseteq> W2"
  1726                and UW2: "openin (subtopology euclidean U) W2"
  1727                and conth: "continuous_on W2 h"
  1728                and him: "h ` W2 \<subseteq> T"
  1729                and heq: "\<And>x. x \<in> C \<Longrightarrow> h x = (snd \<circ> f) x"
  1730     apply (rule ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR T\<close> contf2 _ cloUC])
  1731     using fim apply auto
  1732     done
  1733   show "\<exists>V g. C \<subseteq> V \<and>
  1734                openin (subtopology euclidean U) V \<and>
  1735                continuous_on V g \<and> g ` V \<subseteq> S \<times> T \<and> (\<forall>x\<in>C. g x = f x)"
  1736   proof (intro exI conjI)
  1737     show "C \<subseteq> W1 \<inter> W2"
  1738       by (simp add: \<open>C \<subseteq> W1\<close> \<open>C \<subseteq> W2\<close>)
  1739     show "openin (subtopology euclidean U) (W1 \<inter> W2)"
  1740       by (simp add: UW1 UW2 openin_Int)
  1741     show  "continuous_on (W1 \<inter> W2) (\<lambda>x. (g x, h x))"
  1742       by (metis (no_types) contg conth continuous_on_Pair continuous_on_subset inf_commute inf_le1)
  1743     show  "(\<lambda>x. (g x, h x)) ` (W1 \<inter> W2) \<subseteq> S \<times> T"
  1744       using gim him by blast
  1745     show  "(\<forall>x\<in>C. (g x, h x) = f x)"
  1746       using geq heq by auto
  1747   qed
  1748 qed
  1749 
  1750 lemma AR_Times:
  1751   fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
  1752   assumes "AR S" "AR T" shows "AR(S \<times> T)"
  1753 using assms by (simp add: AR_ANR ANR_Times contractible_Times)
  1754 
  1755 subsection \<open>Kuhn Simplices\<close>
  1756 
  1757 lemma bij_betw_singleton_eq:
  1758   assumes f: "bij_betw f A B" and g: "bij_betw g A B" and a: "a \<in> A"
  1759   assumes eq: "(\<And>x. x \<in> A \<Longrightarrow> x \<noteq> a \<Longrightarrow> f x = g x)"
  1760   shows "f a = g a"
  1761 proof -
  1762   have "f ` (A - {a}) = g ` (A - {a})"
  1763     by (intro image_cong) (simp_all add: eq)
  1764   then have "B - {f a} = B - {g a}"
  1765     using f g a  by (auto simp: bij_betw_def inj_on_image_set_diff set_eq_iff Diff_subset)
  1766   moreover have "f a \<in> B" "g a \<in> B"
  1767     using f g a by (auto simp: bij_betw_def)
  1768   ultimately show ?thesis
  1769     by auto
  1770 qed
  1771 
  1772 lemma swap_image:
  1773   "Fun.swap i j f ` A = (if i \<in> A then (if j \<in> A then f ` A else f ` ((A - {i}) \<union> {j}))
  1774                                   else (if j \<in> A then f ` ((A - {j}) \<union> {i}) else f ` A))"
  1775   by (auto simp: swap_def image_def) metis
  1776 
  1777 lemmas swap_apply1 = swap_apply(1)
  1778 lemmas swap_apply2 = swap_apply(2)
  1779 lemmas Zero_notin_Suc = zero_notin_Suc_image
  1780 
  1781 lemma pointwise_minimal_pointwise_maximal:
  1782   fixes s :: "(nat \<Rightarrow> nat) set"
  1783   assumes "finite s"
  1784     and "s \<noteq> {}"
  1785     and "\<forall>x\<in>s. \<forall>y\<in>s. x \<le> y \<or> y \<le> x"
  1786   shows "\<exists>a\<in>s. \<forall>x\<in>s. a \<le> x"
  1787     and "\<exists>a\<in>s. \<forall>x\<in>s. x \<le> a"
  1788   using assms
  1789 proof (induct s rule: finite_ne_induct)
  1790   case (insert b s)
  1791   assume *: "\<forall>x\<in>insert b s. \<forall>y\<in>insert b s. x \<le> y \<or> y \<le> x"
  1792   then obtain u l where "l \<in> s" "\<forall>b\<in>s. l \<le> b" "u \<in> s" "\<forall>b\<in>s. b \<le> u"
  1793     using insert by auto
  1794   with * show "\<exists>a\<in>insert b s. \<forall>x\<in>insert b s. a \<le> x" "\<exists>a\<in>insert b s. \<forall>x\<in>insert b s. x \<le> a"
  1795     using *[rule_format, of b u] *[rule_format, of b l] by (metis insert_iff order.trans)+
  1796 qed auto
  1797 
  1798 (* FIXME mv *)
  1799 lemma brouwer_compactness_lemma:
  1800   fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
  1801   assumes "compact s"
  1802     and "continuous_on s f"
  1803     and "\<not> (\<exists>x\<in>s. f x = 0)"
  1804   obtains d where "0 < d" and "\<forall>x\<in>s. d \<le> norm (f x)"
  1805 proof (cases "s = {}")
  1806   case True
  1807   show thesis
  1808     by (rule that [of 1]) (auto simp: True)
  1809 next
  1810   case False
  1811   have "continuous_on s (norm \<circ> f)"
  1812     by (rule continuous_intros continuous_on_norm assms(2))+
  1813   with False obtain x where x: "x \<in> s" "\<forall>y\<in>s. (norm \<circ> f) x \<le> (norm \<circ> f) y"
  1814     using continuous_attains_inf[OF assms(1), of "norm \<circ> f"]
  1815     unfolding o_def
  1816     by auto
  1817   have "(norm \<circ> f) x > 0"
  1818     using assms(3) and x(1)
  1819     by auto
  1820   then show ?thesis
  1821     by (rule that) (insert x(2), auto simp: o_def)
  1822 qed
  1823 
  1824 lemma kuhn_labelling_lemma:
  1825   fixes P Q :: "'a::euclidean_space \<Rightarrow> bool"
  1826   assumes "\<forall>x. P x \<longrightarrow> P (f x)"
  1827     and "\<forall>x. P x \<longrightarrow> (\<forall>i\<in>Basis. Q i \<longrightarrow> 0 \<le> x\<bullet>i \<and> x\<bullet>i \<le> 1)"
  1828   shows "\<exists>l. (\<forall>x.\<forall>i\<in>Basis. l x i \<le> (1::nat)) \<and>
  1829              (\<forall>x.\<forall>i\<in>Basis. P x \<and> Q i \<and> (x\<bullet>i = 0) \<longrightarrow> (l x i = 0)) \<and>
  1830              (\<forall>x.\<forall>i\<in>Basis. P x \<and> Q i \<and> (x\<bullet>i = 1) \<longrightarrow> (l x i = 1)) \<and>
  1831              (\<forall>x.\<forall>i\<in>Basis. P x \<and> Q i \<and> (l x i = 0) \<longrightarrow> x\<bullet>i \<le> f x\<bullet>i) \<and>
  1832              (\<forall>x.\<forall>i\<in>Basis. P x \<and> Q i \<and> (l x i = 1) \<longrightarrow> f x\<bullet>i \<le> x\<bullet>i)"
  1833 proof -
  1834   { fix x i
  1835     let ?R = "\<lambda>y. (P x \<and> Q i \<and> x \<bullet> i = 0 \<longrightarrow> y = (0::nat)) \<and>
  1836         (P x \<and> Q i \<and> x \<bullet> i = 1 \<longrightarrow> y = 1) \<and>
  1837         (P x \<and> Q i \<and> y = 0 \<longrightarrow> x \<bullet> i \<le> f x \<bullet> i) \<and>
  1838         (P x \<and> Q i \<and> y = 1 \<longrightarrow> f x \<bullet> i \<le> x \<bullet> i)"
  1839     { assume "P x" "Q i" "i \<in> Basis" with assms have "0 \<le> f x \<bullet> i \<and> f x \<bullet> i \<le> 1" by auto }
  1840     then have "i \<in> Basis \<Longrightarrow> ?R 0 \<or> ?R 1" by auto }
  1841   then show ?thesis
  1842     unfolding all_conj_distrib[symmetric] Ball_def (* FIXME: shouldn't this work by metis? *)
  1843     by (subst choice_iff[symmetric])+ blast
  1844 qed
  1845 
  1846 
  1847 subsubsection \<open>The key "counting" observation, somewhat abstracted\<close>
  1848 
  1849 lemma kuhn_counting_lemma:
  1850   fixes bnd compo compo' face S F
  1851   defines "nF s == card {f\<in>F. face f s \<and> compo' f}"
  1852   assumes [simp, intro]: "finite F" \<comment> \<open>faces\<close> and [simp, intro]: "finite S" \<comment> \<open>simplices\<close>
  1853     and "\<And>f. f \<in> F \<Longrightarrow> bnd f \<Longrightarrow> card {s\<in>S. face f s} = 1"
  1854     and "\<And>f. f \<in> F \<Longrightarrow> \<not> bnd f \<Longrightarrow> card {s\<in>S. face f s} = 2"
  1855     and "\<And>s. s \<in> S \<Longrightarrow> compo s \<Longrightarrow> nF s = 1"
  1856     and "\<And>s. s \<in> S \<Longrightarrow> \<not> compo s \<Longrightarrow> nF s = 0 \<or> nF s = 2"
  1857     and "odd (card {f\<in>F. compo' f \<and> bnd f})"
  1858   shows "odd (card {s\<in>S. compo s})"
  1859 proof -
  1860   have "(\<Sum>s | s \<in> S \<and> \<not> compo s. nF s) + (\<Sum>s | s \<in> S \<and> compo s. nF s) = (\<Sum>s\<in>S. nF s)"
  1861     by (subst sum.union_disjoint[symmetric]) (auto intro!: sum.cong)
  1862   also have "\<dots> = (\<Sum>s\<in>S. card {f \<in> {f\<in>F. compo' f \<and> bnd f}. face f s}) +
  1863                   (\<Sum>s\<in>S. card {f \<in> {f\<in>F. compo' f \<and> \<not> bnd f}. face f s})"
  1864     unfolding sum.distrib[symmetric]
  1865     by (subst card_Un_disjoint[symmetric])
  1866        (auto simp: nF_def intro!: sum.cong arg_cong[where f=card])
  1867   also have "\<dots> = 1 * card {f\<in>F. compo' f \<and> bnd f} + 2 * card {f\<in>F. compo' f \<and> \<not> bnd f}"
  1868     using assms(4,5) by (fastforce intro!: arg_cong2[where f="(+)"] sum_multicount)
  1869   finally have "odd ((\<Sum>s | s \<in> S \<and> \<not> compo s. nF s) + card {s\<in>S. compo s})"
  1870     using assms(6,8) by simp
  1871   moreover have "(\<Sum>s | s \<in> S \<and> \<not> compo s. nF s) =
  1872     (\<Sum>s | s \<in> S \<and> \<not> compo s \<and> nF s = 0. nF s) + (\<Sum>s | s \<in> S \<and> \<not> compo s \<and> nF s = 2. nF s)"
  1873     using assms(7) by (subst sum.union_disjoint[symmetric]) (fastforce intro!: sum.cong)+
  1874   ultimately show ?thesis
  1875     by auto
  1876 qed
  1877 
  1878 subsubsection \<open>The odd/even result for faces of complete vertices, generalized\<close>
  1879 
  1880 lemma kuhn_complete_lemma:
  1881   assumes [simp]: "finite simplices"
  1882     and face: "\<And>f s. face f s \<longleftrightarrow> (\<exists>a\<in>s. f = s - {a})"
  1883     and card_s[simp]:  "\<And>s. s \<in> simplices \<Longrightarrow> card s = n + 2"
  1884     and rl_bd: "\<And>s. s \<in> simplices \<Longrightarrow> rl ` s \<subseteq> {..Suc n}"
  1885     and bnd: "\<And>f s. s \<in> simplices \<Longrightarrow> face f s \<Longrightarrow> bnd f \<Longrightarrow> card {s\<in>simplices. face f s} = 1"
  1886     and nbnd: "\<And>f s. s \<in> simplices \<Longrightarrow> face f s \<Longrightarrow> \<not> bnd f \<Longrightarrow> card {s\<in>simplices. face f s} = 2"
  1887     and odd_card: "odd (card {f. (\<exists>s\<in>simplices. face f s) \<and> rl ` f = {..n} \<and> bnd f})"
  1888   shows "odd (card {s\<in>simplices. (rl ` s = {..Suc n})})"
  1889 proof (rule kuhn_counting_lemma)
  1890   have finite_s[simp]: "\<And>s. s \<in> simplices \<Longrightarrow> finite s"
  1891     by (metis add_is_0 zero_neq_numeral card_infinite assms(3))
  1892 
  1893   let ?F = "{f. \<exists>s\<in>simplices. face f s}"
  1894   have F_eq: "?F = (\<Union>s\<in>simplices. \<Union>a\<in>s. {s - {a}})"
  1895     by (auto simp: face)
  1896   show "finite ?F"
  1897     using \<open>finite simplices\<close> unfolding F_eq by auto
  1898 
  1899   show "card {s \<in> simplices. face f s} = 1" if "f \<in> ?F" "bnd f" for f
  1900     using bnd that by auto
  1901 
  1902   show "card {s \<in> simplices. face f s} = 2" if "f \<in> ?F" "\<not> bnd f" for f
  1903     using nbnd that by auto
  1904 
  1905   show "odd (card {f \<in> {f. \<exists>s\<in>simplices. face f s}. rl ` f = {..n} \<and> bnd f})"
  1906     using odd_card by simp
  1907 
  1908   fix s assume s[simp]: "s \<in> simplices"
  1909   let ?S = "{f \<in> {f. \<exists>s\<in>simplices. face f s}. face f s \<and> rl ` f = {..n}}"
  1910   have "?S = (\<lambda>a. s - {a}) ` {a\<in>s. rl ` (s - {a}) = {..n}}"
  1911     using s by (fastforce simp: face)
  1912   then have card_S: "card ?S = card {a\<in>s. rl ` (s - {a}) = {..n}}"
  1913     by (auto intro!: card_image inj_onI)
  1914 
  1915   { assume rl: "rl ` s = {..Suc n}"
  1916     then have inj_rl: "inj_on rl s"
  1917       by (intro eq_card_imp_inj_on) auto
  1918     moreover obtain a where "rl a = Suc n" "a \<in> s"
  1919       by (metis atMost_iff image_iff le_Suc_eq rl)
  1920     ultimately have n: "{..n} = rl ` (s - {a})"
  1921       by (auto simp: inj_on_image_set_diff Diff_subset rl)
  1922     have "{a\<in>s. rl ` (s - {a}) = {..n}} = {a}"
  1923       using inj_rl \<open>a \<in> s\<close> by (auto simp: n inj_on_image_eq_iff[OF inj_rl] Diff_subset)
  1924     then show "card ?S = 1"
  1925       unfolding card_S by simp }
  1926 
  1927   { assume rl: "rl ` s \<noteq> {..Suc n}"
  1928     show "card ?S = 0 \<or> card ?S = 2"
  1929     proof cases
  1930       assume *: "{..n} \<subseteq> rl ` s"
  1931       with rl rl_bd[OF s] have rl_s: "rl ` s = {..n}"
  1932         by (auto simp: atMost_Suc subset_insert_iff split: if_split_asm)
  1933       then have "\<not> inj_on rl s"
  1934         by (intro pigeonhole) simp
  1935       then obtain a b where ab: "a \<in> s" "b \<in> s" "rl a = rl b" "a \<noteq> b"
  1936         by (auto simp: inj_on_def)
  1937       then have eq: "rl ` (s - {a}) = rl ` s"
  1938         by auto
  1939       with ab have inj: "inj_on rl (s - {a})"
  1940         by (intro eq_card_imp_inj_on) (auto simp: rl_s card_Diff_singleton_if)
  1941 
  1942       { fix x assume "x \<in> s" "x \<notin> {a, b}"
  1943         then have "rl ` s - {rl x} = rl ` ((s - {a}) - {x})"
  1944           by (auto simp: eq Diff_subset inj_on_image_set_diff[OF inj])
  1945         also have "\<dots> = rl ` (s - {x})"
  1946           using ab \<open>x \<notin> {a, b}\<close> by auto
  1947         also assume "\<dots> = rl ` s"
  1948         finally have False
  1949           using \<open>x\<in>s\<close> by auto }
  1950       moreover
  1951       { fix x assume "x \<in> {a, b}" with ab have "x \<in> s \<and> rl ` (s - {x}) = rl ` s"
  1952           by (simp add: set_eq_iff image_iff Bex_def) metis }
  1953       ultimately have "{a\<in>s. rl ` (s - {a}) = {..n}} = {a, b}"
  1954         unfolding rl_s[symmetric] by fastforce
  1955       with \<open>a \<noteq> b\<close> show "card ?S = 0 \<or> card ?S = 2"
  1956         unfolding card_S by simp
  1957     next
  1958       assume "\<not> {..n} \<subseteq> rl ` s"
  1959       then have "\<And>x. rl ` (s - {x}) \<noteq> {..n}"
  1960         by auto
  1961       then show "card ?S = 0 \<or> card ?S = 2"
  1962         unfolding card_S by simp
  1963     qed }
  1964 qed fact
  1965 
  1966 locale kuhn_simplex =
  1967   fixes p n and base upd and s :: "(nat \<Rightarrow> nat) set"
  1968   assumes base: "base \<in> {..< n} \<rightarrow> {..< p}"
  1969   assumes base_out: "\<And>i. n \<le> i \<Longrightarrow> base i = p"
  1970   assumes upd: "bij_betw upd {..< n} {..< n}"
  1971   assumes s_pre: "s = (\<lambda>i j. if j \<in> upd`{..< i} then Suc (base j) else base j) ` {.. n}"
  1972 begin
  1973 
  1974 definition "enum i j = (if j \<in> upd`{..< i} then Suc (base j) else base j)"
  1975 
  1976 lemma s_eq: "s = enum ` {.. n}"
  1977   unfolding s_pre enum_def[abs_def] ..
  1978 
  1979 lemma upd_space: "i < n \<Longrightarrow> upd i < n"
  1980   using upd by (auto dest!: bij_betwE)
  1981 
  1982 lemma s_space: "s \<subseteq> {..< n} \<rightarrow> {.. p}"
  1983 proof -
  1984   { fix i assume "i \<le> n" then have "enum i \<in> {..< n} \<rightarrow> {.. p}"
  1985     proof (induct i)
  1986       case 0 then show ?case
  1987         using base by (auto simp: Pi_iff less_imp_le enum_def)
  1988     next
  1989       case (Suc i) with base show ?case
  1990         by (auto simp: Pi_iff Suc_le_eq less_imp_le enum_def intro: upd_space)
  1991     qed }
  1992   then show ?thesis
  1993     by (auto simp: s_eq)
  1994 qed
  1995 
  1996 lemma inj_upd: "inj_on upd {..< n}"
  1997   using upd by (simp add: bij_betw_def)
  1998 
  1999 lemma inj_enum: "inj_on enum {.. n}"
  2000 proof -
  2001   { fix x y :: nat assume "x \<noteq> y" "x \<le> n" "y \<le> n"
  2002     with upd have "upd ` {..< x} \<noteq> upd ` {..< y}"
  2003       by (subst inj_on_image_eq_iff[where C="{..< n}"]) (auto simp: bij_betw_def)
  2004     then have "enum x \<noteq> enum y"
  2005       by (auto simp: enum_def fun_eq_iff) }
  2006   then show ?thesis
  2007     by (auto simp: inj_on_def)
  2008 qed
  2009 
  2010 lemma enum_0: "enum 0 = base"
  2011   by (simp add: enum_def[abs_def])
  2012 
  2013 lemma base_in_s: "base \<in> s"
  2014   unfolding s_eq by (subst enum_0[symmetric]) auto
  2015 
  2016 lemma enum_in: "i \<le> n \<Longrightarrow> enum i \<in> s"
  2017   unfolding s_eq by auto
  2018 
  2019 lemma one_step:
  2020   assumes a: "a \<in> s" "j < n"
  2021   assumes *: "\<And>a'. a' \<in> s \<Longrightarrow> a' \<noteq> a \<Longrightarrow> a' j = p'"
  2022   shows "a j \<noteq> p'"
  2023 proof
  2024   assume "a j = p'"
  2025   with * a have "\<And>a'. a' \<in> s \<Longrightarrow> a' j = p'"
  2026     by auto
  2027   then have "\<And>i. i \<le> n \<Longrightarrow> enum i j = p'"
  2028     unfolding s_eq by auto
  2029   from this[of 0] this[of n] have "j \<notin> upd ` {..< n}"
  2030     by (auto simp: enum_def fun_eq_iff split: if_split_asm)
  2031   with upd \<open>j < n\<close> show False
  2032     by (auto simp: bij_betw_def)
  2033 qed
  2034 
  2035 lemma upd_inj: "i < n \<Longrightarrow> j < n \<Longrightarrow> upd i = upd j \<longleftrightarrow> i = j"
  2036   using upd by (auto simp: bij_betw_def inj_on_eq_iff)
  2037 
  2038 lemma upd_surj: "upd ` {..< n} = {..< n}"
  2039   using upd by (auto simp: bij_betw_def)
  2040 
  2041 lemma in_upd_image: "A \<subseteq> {..< n} \<Longrightarrow> i < n \<Longrightarrow> upd i \<in> upd ` A \<longleftrightarrow> i \<in> A"
  2042   using inj_on_image_mem_iff[of upd "{..< n}"] upd
  2043   by (auto simp: bij_betw_def)
  2044 
  2045 lemma enum_inj: "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> enum i = enum j \<longleftrightarrow> i = j"
  2046   using inj_enum by (auto simp: inj_on_eq_iff)
  2047 
  2048 lemma in_enum_image: "A \<subseteq> {.. n} \<Longrightarrow> i \<le> n \<Longrightarrow> enum i \<in> enum ` A \<longleftrightarrow> i \<in> A"
  2049   using inj_on_image_mem_iff[OF inj_enum] by auto
  2050 
  2051 lemma enum_mono: "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> enum i \<le> enum j \<longleftrightarrow> i \<le> j"
  2052   by (auto simp: enum_def le_fun_def in_upd_image Ball_def[symmetric])
  2053 
  2054 lemma enum_strict_mono: "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> enum i < enum j \<longleftrightarrow> i < j"
  2055   using enum_mono[of i j] enum_inj[of i j] by (auto simp: le_less)
  2056 
  2057 lemma chain: "a \<in> s \<Longrightarrow> b \<in> s \<Longrightarrow> a \<le> b \<or> b \<le> a"
  2058   by (auto simp: s_eq enum_mono)
  2059 
  2060 lemma less: "a \<in> s \<Longrightarrow> b \<in> s \<Longrightarrow> a i < b i \<Longrightarrow> a < b"
  2061   using chain[of a b] by (auto simp: less_fun_def le_fun_def not_le[symmetric])
  2062 
  2063 lemma enum_0_bot: "a \<in> s \<Longrightarrow> a = enum 0 \<longleftrightarrow> (\<forall>a'\<in>s. a \<le> a')"
  2064   unfolding s_eq by (auto simp: enum_mono Ball_def)
  2065 
  2066 lemma enum_n_top: "a \<in> s \<Longrightarrow> a = enum n \<longleftrightarrow> (\<forall>a'\<in>s. a' \<le> a)"
  2067   unfolding s_eq by (auto simp: enum_mono Ball_def)
  2068 
  2069 lemma enum_Suc: "i < n \<Longrightarrow> enum (Suc i) = (enum i)(upd i := Suc (enum i (upd i)))"
  2070   by (auto simp: fun_eq_iff enum_def upd_inj)
  2071 
  2072 lemma enum_eq_p: "i \<le> n \<Longrightarrow> n \<le> j \<Longrightarrow> enum i j = p"
  2073   by (induct i) (auto simp: enum_Suc enum_0 base_out upd_space not_less[symmetric])
  2074 
  2075 lemma out_eq_p: "a \<in> s \<Longrightarrow> n \<le> j \<Longrightarrow> a j = p"
  2076   unfolding s_eq by (auto simp: enum_eq_p)
  2077 
  2078 lemma s_le_p: "a \<in> s \<Longrightarrow> a j \<le> p"
  2079   using out_eq_p[of a j] s_space by (cases "j < n") auto
  2080 
  2081 lemma le_Suc_base: "a \<in> s \<Longrightarrow> a j \<le> Suc (base j)"
  2082   unfolding s_eq by (auto simp: enum_def)
  2083 
  2084 lemma base_le: "a \<in> s \<Longrightarrow> base j \<le> a j"
  2085   unfolding s_eq by (auto simp: enum_def)
  2086 
  2087 lemma enum_le_p: "i \<le> n \<Longrightarrow> j < n \<Longrightarrow> enum i j \<le> p"
  2088   using enum_in[of i] s_space by auto
  2089 
  2090 lemma enum_less: "a \<in> s \<Longrightarrow> i < n \<Longrightarrow> enum i < a \<longleftrightarrow> enum (Suc i) \<le> a"
  2091   unfolding s_eq by (auto simp: enum_strict_mono enum_mono)
  2092 
  2093 lemma ksimplex_0:
  2094   "n = 0 \<Longrightarrow> s = {(\<lambda>x. p)}"
  2095   using s_eq enum_def base_out by auto
  2096 
  2097 lemma replace_0:
  2098   assumes "j < n" "a \<in> s" and p: "\<forall>x\<in>s - {a}. x j = 0" and "x \<in> s"
  2099   shows "x \<le> a"
  2100 proof cases
  2101   assume "x \<noteq> a"
  2102   have "a j \<noteq> 0"
  2103     using assms by (intro one_step[where a=a]) auto
  2104   with less[OF \<open>x\<in>s\<close> \<open>a\<in>s\<close>, of j] p[rule_format, of x] \<open>x \<in> s\<close> \<open>x \<noteq> a\<close>
  2105   show ?thesis
  2106     by auto
  2107 qed simp
  2108 
  2109 lemma replace_1:
  2110   assumes "j < n" "a \<in> s" and p: "\<forall>x\<in>s - {a}. x j = p" and "x \<in> s"
  2111   shows "a \<le> x"
  2112 proof cases
  2113   assume "x \<noteq> a"
  2114   have "a j \<noteq> p"
  2115     using assms by (intro one_step[where a=a]) auto
  2116   with enum_le_p[of _ j] \<open>j < n\<close> \<open>a\<in>s\<close>
  2117   have "a j < p"
  2118     by (auto simp: less_le s_eq)
  2119   with less[OF \<open>a\<in>s\<close> \<open>x\<in>s\<close>, of j] p[rule_format, of x] \<open>x \<in> s\<close> \<open>x \<noteq> a\<close>
  2120   show ?thesis
  2121     by auto
  2122 qed simp
  2123 
  2124 end
  2125 
  2126 locale kuhn_simplex_pair = s: kuhn_simplex p n b_s u_s s + t: kuhn_simplex p n b_t u_t t
  2127   for p n b_s u_s s b_t u_t t
  2128 begin
  2129 
  2130 lemma enum_eq:
  2131   assumes l: "i \<le> l" "l \<le> j" and "j + d \<le> n"
  2132   assumes eq: "s.enum ` {i .. j} = t.enum ` {i + d .. j + d}"
  2133   shows "s.enum l = t.enum (l + d)"
  2134 using l proof (induct l rule: dec_induct)
  2135   case base
  2136   then have s: "s.enum i \<in> t.enum ` {i + d .. j + d}" and t: "t.enum (i + d) \<in> s.enum ` {i .. j}"
  2137     using eq by auto
  2138   from t \<open>i \<le> j\<close> \<open>j + d \<le> n\<close> have "s.enum i \<le> t.enum (i + d)"
  2139     by (auto simp: s.enum_mono)
  2140   moreover from s \<open>i \<le> j\<close> \<open>j + d \<le> n\<close> have "t.enum (i + d) \<le> s.enum i"
  2141     by (auto simp: t.enum_mono)
  2142   ultimately show ?case
  2143     by auto
  2144 next
  2145   case (step l)
  2146   moreover from step.prems \<open>j + d \<le> n\<close> have
  2147       "s.enum l < s.enum (Suc l)"
  2148       "t.enum (l + d) < t.enum (Suc l + d)"
  2149     by (simp_all add: s.enum_strict_mono t.enum_strict_mono)
  2150   moreover have
  2151       "s.enum (Suc l) \<in> t.enum ` {i + d .. j + d}"
  2152       "t.enum (Suc l + d) \<in> s.enum ` {i .. j}"
  2153     using step \<open>j + d \<le> n\<close> eq by (auto simp: s.enum_inj t.enum_inj)
  2154   ultimately have "s.enum (Suc l) = t.enum (Suc (l + d))"
  2155     using \<open>j + d \<le> n\<close>
  2156     by (intro antisym s.enum_less[THEN iffD1] t.enum_less[THEN iffD1])
  2157        (auto intro!: s.enum_in t.enum_in)
  2158   then show ?case by simp
  2159 qed
  2160 
  2161 lemma ksimplex_eq_bot:
  2162   assumes a: "a \<in> s" "\<And>a'. a' \<in> s \<Longrightarrow> a \<le> a'"
  2163   assumes b: "b \<in> t" "\<And>b'. b' \<in> t \<Longrightarrow> b \<le> b'"
  2164   assumes eq: "s - {a} = t - {b}"
  2165   shows "s = t"
  2166 proof cases
  2167   assume "n = 0" with s.ksimplex_0 t.ksimplex_0 show ?thesis by simp
  2168 next
  2169   assume "n \<noteq> 0"
  2170   have "s.enum 0 = (s.enum (Suc 0)) (u_s 0 := s.enum (Suc 0) (u_s 0) - 1)"
  2171        "t.enum 0 = (t.enum (Suc 0)) (u_t 0 := t.enum (Suc 0) (u_t 0) - 1)"
  2172     using \<open>n \<noteq> 0\<close> by (simp_all add: s.enum_Suc t.enum_Suc)
  2173   moreover have e0: "a = s.enum 0" "b = t.enum 0"
  2174     using a b by (simp_all add: s.enum_0_bot t.enum_0_bot)
  2175   moreover
  2176   { fix j assume "0 < j" "j \<le> n"
  2177     moreover have "s - {a} = s.enum ` {Suc 0 .. n}" "t - {b} = t.enum ` {Suc 0 .. n}"
  2178       unfolding s.s_eq t.s_eq e0 by (auto simp: s.enum_inj t.enum_inj)
  2179     ultimately have "s.enum j = t.enum j"
  2180       using enum_eq[of "1" j n 0] eq by auto }
  2181   note enum_eq = this
  2182   then have "s.enum (Suc 0) = t.enum (Suc 0)"
  2183     using \<open>n \<noteq> 0\<close> by auto
  2184   moreover
  2185   { fix j assume "Suc j < n"
  2186     with enum_eq[of "Suc j"] enum_eq[of "Suc (Suc j)"]
  2187     have "u_s (Suc j) = u_t (Suc j)"
  2188       using s.enum_Suc[of "Suc j"] t.enum_Suc[of "Suc j"]
  2189       by (auto simp: fun_eq_iff split: if_split_asm) }
  2190   then have "\<And>j. 0 < j \<Longrightarrow> j < n \<Longrightarrow> u_s j = u_t j"
  2191     by (auto simp: gr0_conv_Suc)
  2192   with \<open>n \<noteq> 0\<close> have "u_t 0 = u_s 0"
  2193     by (intro bij_betw_singleton_eq[OF t.upd s.upd, of 0]) auto
  2194   ultimately have "a = b"
  2195     by simp
  2196   with assms show "s = t"
  2197     by auto
  2198 qed
  2199 
  2200 lemma ksimplex_eq_top:
  2201   assumes a: "a \<in> s" "\<And>a'. a' \<in> s \<Longrightarrow> a' \<le> a"
  2202   assumes b: "b \<in> t" "\<And>b'. b' \<in> t \<Longrightarrow> b' \<le> b"
  2203   assumes eq: "s - {a} = t - {b}"
  2204   shows "s = t"
  2205 proof (cases n)
  2206   assume "n = 0" with s.ksimplex_0 t.ksimplex_0 show ?thesis by simp
  2207 next
  2208   case (Suc n')
  2209   have "s.enum n = (s.enum n') (u_s n' := Suc (s.enum n' (u_s n')))"
  2210        "t.enum n = (t.enum n') (u_t n' := Suc (t.enum n' (u_t n')))"
  2211     using Suc by (simp_all add: s.enum_Suc t.enum_Suc)
  2212   moreover have en: "a = s.enum n" "b = t.enum n"
  2213     using a b by (simp_all add: s.enum_n_top t.enum_n_top)
  2214   moreover
  2215   { fix j assume "j < n"
  2216     moreover have "s - {a} = s.enum ` {0 .. n'}" "t - {b} = t.enum ` {0 .. n'}"
  2217       unfolding s.s_eq t.s_eq en by (auto simp: s.enum_inj t.enum_inj Suc)
  2218     ultimately have "s.enum j = t.enum j"
  2219       using enum_eq[of "0" j n' 0] eq Suc by auto }
  2220   note enum_eq = this
  2221   then have "s.enum n' = t.enum n'"
  2222     using Suc by auto
  2223   moreover
  2224   { fix j assume "j < n'"
  2225     with enum_eq[of j] enum_eq[of "Suc j"]
  2226     have "u_s j = u_t j"
  2227       using s.enum_Suc[of j] t.enum_Suc[of j]
  2228       by (auto simp: Suc fun_eq_iff split: if_split_asm) }
  2229   then have "\<And>j. j < n' \<Longrightarrow> u_s j = u_t j"
  2230     by (auto simp: gr0_conv_Suc)
  2231   then have "u_t n' = u_s n'"
  2232     by (intro bij_betw_singleton_eq[OF t.upd s.upd, of n']) (auto simp: Suc)
  2233   ultimately have "a = b"
  2234     by simp
  2235   with assms show "s = t"
  2236     by auto
  2237 qed
  2238 
  2239 end
  2240 
  2241 inductive ksimplex for p n :: nat where
  2242   ksimplex: "kuhn_simplex p n base upd s \<Longrightarrow> ksimplex p n s"
  2243 
  2244 lemma finite_ksimplexes: "finite {s. ksimplex p n s}"
  2245 proof (rule finite_subset)
  2246   { fix a s assume "ksimplex p n s" "a \<in> s"
  2247     then obtain b u where "kuhn_simplex p n b u s" by (auto elim: ksimplex.cases)
  2248     then interpret kuhn_simplex p n b u s .
  2249     from s_space \<open>a \<in> s\<close> out_eq_p[OF \<open>a \<in> s\<close>]
  2250     have "a \<in> (\<lambda>f x. if n \<le> x then p else f x) ` ({..< n} \<rightarrow>\<^sub>E {.. p})"
  2251       by (auto simp: image_iff subset_eq Pi_iff split: if_split_asm
  2252                intro!: bexI[of _ "restrict a {..< n}"]) }
  2253   then show "{s. ksimplex p n s} \<subseteq> Pow ((\<lambda>f x. if n \<le> x then p else f x) ` ({..< n} \<rightarrow>\<^sub>E {.. p}))"
  2254     by auto
  2255 qed (simp add: finite_PiE)
  2256 
  2257 lemma ksimplex_card:
  2258   assumes "ksimplex p n s" shows "card s = Suc n"
  2259 using assms proof cases
  2260   case (ksimplex u b)
  2261   then interpret kuhn_simplex p n u b s .
  2262   show ?thesis
  2263     by (simp add: card_image s_eq inj_enum)
  2264 qed
  2265 
  2266 lemma simplex_top_face:
  2267   assumes "0 < p" "\<forall>x\<in>s'. x n = p"
  2268   shows "ksimplex p n s' \<longleftrightarrow> (\<exists>s a. ksimplex p (Suc n) s \<and> a \<in> s \<and> s' = s - {a})"
  2269   using assms
  2270 proof safe
  2271   fix s a assume "ksimplex p (Suc n) s" and a: "a \<in> s" and na: "\<forall>x\<in>s - {a}. x n = p"
  2272   then show "ksimplex p n (s - {a})"
  2273   proof cases
  2274     case (ksimplex base upd)
  2275     then interpret kuhn_simplex p "Suc n" base upd "s" .
  2276 
  2277     have "a n < p"
  2278       using one_step[of a n p] na \<open>a\<in>s\<close> s_space by (auto simp: less_le)
  2279     then have "a = enum 0"
  2280       using \<open>a \<in> s\<close> na by (subst enum_0_bot) (auto simp: le_less intro!: less[of a _ n])
  2281     then have s_eq: "s - {a} = enum ` Suc ` {.. n}"
  2282       using s_eq by (simp add: atMost_Suc_eq_insert_0 insert_ident Zero_notin_Suc in_enum_image subset_eq)
  2283     then have "enum 1 \<in> s - {a}"
  2284       by auto
  2285     then have "upd 0 = n"
  2286       using \<open>a n < p\<close> \<open>a = enum 0\<close> na[rule_format, of "enum 1"]
  2287       by (auto simp: fun_eq_iff enum_Suc split: if_split_asm)
  2288     then have "bij_betw upd (Suc ` {..< n}) {..< n}"
  2289       using upd
  2290       by (subst notIn_Un_bij_betw3[where b=0])
  2291          (auto simp: lessThan_Suc[symmetric] lessThan_Suc_eq_insert_0)
  2292     then have "bij_betw (upd\<circ>Suc) {..<n} {..<n}"
  2293       by (rule bij_betw_trans[rotated]) (auto simp: bij_betw_def)
  2294 
  2295     have "a n = p - 1"
  2296       using enum_Suc[of 0] na[rule_format, OF \<open>enum 1 \<in> s - {a}\<close>] \<open>a = enum 0\<close> by (auto simp: \<open>upd 0 = n\<close>)
  2297 
  2298     show ?thesis
  2299     proof (rule ksimplex.intros, standard)
  2300       show "bij_betw (upd\<circ>Suc) {..< n} {..< n}" by fact
  2301       show "base(n := p) \<in> {..<n} \<rightarrow> {..<p}" "\<And>i. n\<le>i \<Longrightarrow> (base(n := p)) i = p"
  2302         using base base_out by (auto simp: Pi_iff)
  2303 
  2304       have "\<And>i. Suc ` {..< i} = {..< Suc i} - {0}"
  2305         by (auto simp: image_iff Ball_def) arith
  2306       then have upd_Suc: "\<And>i. i \<le> n \<Longrightarrow> (upd\<circ>Suc) ` {..< i} = upd ` {..< Suc i} - {n}"
  2307         using \<open>upd 0 = n\<close> upd_inj
  2308         by (auto simp: image_comp[symmetric] inj_on_image_set_diff[OF inj_upd])
  2309       have n_in_upd: "\<And>i. n \<in> upd ` {..< Suc i}"
  2310         using \<open>upd 0 = n\<close> by auto
  2311 
  2312       define f' where "f' i j =
  2313         (if j \<in> (upd\<circ>Suc)`{..< i} then Suc ((base(n := p)) j) else (base(n := p)) j)" for i j
  2314       { fix x i assume i[arith]: "i \<le> n" then have "enum (Suc i) x = f' i x"
  2315           unfolding f'_def enum_def using \<open>a n < p\<close> \<open>a = enum 0\<close> \<open>upd 0 = n\<close> \<open>a n = p - 1\<close>
  2316           by (simp add: upd_Suc enum_0 n_in_upd) }
  2317       then show "s - {a} = f' ` {.. n}"
  2318         unfolding s_eq image_comp by (intro image_cong) auto
  2319     qed
  2320   qed
  2321 next
  2322   assume "ksimplex p n s'" and *: "\<forall>x\<in>s'. x n = p"
  2323   then show "\<exists>s a. ksimplex p (Suc n) s \<and> a \<in> s \<and> s' = s - {a}"
  2324   proof cases
  2325     case (ksimplex base upd)
  2326     then interpret kuhn_simplex p n base upd s' .
  2327     define b where "b = base (n := p - 1)"
  2328     define u where "u i = (case i of 0 \<Rightarrow> n | Suc i \<Rightarrow> upd i)" for i
  2329 
  2330     have "ksimplex p (Suc n) (s' \<union> {b})"
  2331     proof (rule ksimplex.intros, standard)
  2332       show "b \<in> {..<Suc n} \<rightarrow> {..<p}"
  2333         using base \<open>0 < p\<close> unfolding lessThan_Suc b_def by (auto simp: PiE_iff)
  2334       show "\<And>i. Suc n \<le> i \<Longrightarrow> b i = p"
  2335         using base_out by (auto simp: b_def)
  2336 
  2337       have "bij_betw u (Suc ` {..< n} \<union> {0}) ({..<n} \<union> {u 0})"
  2338         using upd
  2339         by (intro notIn_Un_bij_betw) (auto simp: u_def bij_betw_def image_comp comp_def inj_on_def)
  2340       then show "bij_betw u {..<Suc n} {..<Suc n}"
  2341         by (simp add: u_def lessThan_Suc[symmetric] lessThan_Suc_eq_insert_0)
  2342 
  2343       define f' where "f' i j = (if j \<in> u`{..< i} then Suc (b j) else b j)" for i j
  2344 
  2345       have u_eq: "\<And>i. i \<le> n \<Longrightarrow> u ` {..< Suc i} = upd ` {..< i} \<union> { n }"
  2346         by (auto simp: u_def image_iff upd_inj Ball_def split: nat.split) arith
  2347 
  2348       { fix x have "x \<le> n \<Longrightarrow> n \<notin> upd ` {..<x}"
  2349           using upd_space by (simp add: image_iff neq_iff) }
  2350       note n_not_upd = this
  2351 
  2352       have *: "f' ` {.. Suc n} = f' ` (Suc ` {.. n} \<union> {0})"
  2353         unfolding atMost_Suc_eq_insert_0 by simp
  2354       also have "\<dots> = (f' \<circ> Suc) ` {.. n} \<union> {b}"
  2355         by (auto simp: f'_def)
  2356       also have "(f' \<circ> Suc) ` {.. n} = s'"
  2357         using \<open>0 < p\<close> base_out[of n]
  2358         unfolding s_eq enum_def[abs_def] f'_def[abs_def] upd_space
  2359         by (intro image_cong) (simp_all add: u_eq b_def fun_eq_iff n_not_upd)
  2360       finally show "s' \<union> {b} = f' ` {.. Suc n}" ..
  2361     qed
  2362     moreover have "b \<notin> s'"
  2363       using * \<open>0 < p\<close> by (auto simp: b_def)
  2364     ultimately show ?thesis by auto
  2365   qed
  2366 qed
  2367 
  2368 lemma ksimplex_replace_0:
  2369   assumes s: "ksimplex p n s" and a: "a \<in> s"
  2370   assumes j: "j < n" and p: "\<forall>x\<in>s - {a}. x j = 0"
  2371   shows "card {s'. ksimplex p n s' \<and> (\<exists>b\<in>s'. s' - {b} = s - {a})} = 1"
  2372   using s
  2373 proof cases
  2374   case (ksimplex b_s u_s)
  2375 
  2376   { fix t b assume "ksimplex p n t"
  2377     then obtain b_t u_t where "kuhn_simplex p n b_t u_t t"
  2378       by (auto elim: ksimplex.cases)
  2379     interpret kuhn_simplex_pair p n b_s u_s s b_t u_t t
  2380       by intro_locales fact+
  2381 
  2382     assume b: "b \<in> t" "t - {b} = s - {a}"
  2383     with a j p s.replace_0[of _ a] t.replace_0[of _ b] have "s = t"
  2384       by (intro ksimplex_eq_top[of a b]) auto }
  2385   then have "{s'. ksimplex p n s' \<and> (\<exists>b\<in>s'. s' - {b} = s - {a})} = {s}"
  2386     using s \<open>a \<in> s\<close> by auto
  2387   then show ?thesis
  2388     by simp
  2389 qed
  2390 
  2391 lemma ksimplex_replace_1:
  2392   assumes s: "ksimplex p n s" and a: "a \<in> s"
  2393   assumes j: "j < n" and p: "\<forall>x\<in>s - {a}. x j = p"
  2394   shows "card {s'. ksimplex p n s' \<and> (\<exists>b\<in>s'. s' - {b} = s - {a})} = 1"
  2395   using s
  2396 proof cases
  2397   case (ksimplex b_s u_s)
  2398 
  2399   { fix t b assume "ksimplex p n t"
  2400     then obtain b_t u_t where "kuhn_simplex p n b_t u_t t"
  2401       by (auto elim: ksimplex.cases)
  2402     interpret kuhn_simplex_pair p n b_s u_s s b_t u_t t
  2403       by intro_locales fact+
  2404 
  2405     assume b: "b \<in> t" "t - {b} = s - {a}"
  2406     with a j p s.replace_1[of _ a] t.replace_1[of _ b] have "s = t"
  2407       by (intro ksimplex_eq_bot[of a b]) auto }
  2408   then have "{s'. ksimplex p n s' \<and> (\<exists>b\<in>s'. s' - {b} = s - {a})} = {s}"
  2409     using s \<open>a \<in> s\<close> by auto
  2410   then show ?thesis
  2411     by simp
  2412 qed
  2413 
  2414 lemma card_2_exists: "card s = 2 \<longleftrightarrow> (\<exists>x\<in>s. \<exists>y\<in>s. x \<noteq> y \<and> (\<forall>z\<in>s. z = x \<or> z = y))"
  2415   by (auto simp: card_Suc_eq eval_nat_numeral)
  2416 
  2417 lemma ksimplex_replace_2:
  2418   assumes s: "ksimplex p n s" and "a \<in> s" and "n \<noteq> 0"
  2419     and lb: "\<forall>j<n. \<exists>x\<in>s - {a}. x j \<noteq> 0"
  2420     and ub: "\<forall>j<n. \<exists>x\<in>s - {a}. x j \<noteq> p"
  2421   shows "card {s'. ksimplex p n s' \<and> (\<exists>b\<in>s'. s' - {b} = s - {a})} = 2"
  2422   using s
  2423 proof cases
  2424   case (ksimplex base upd)
  2425   then interpret kuhn_simplex p n base upd s .
  2426 
  2427   from \<open>a \<in> s\<close> obtain i where "i \<le> n" "a = enum i"
  2428     unfolding s_eq by auto
  2429 
  2430   from \<open>i \<le> n\<close> have "i = 0 \<or> i = n \<or> (0 < i \<and> i < n)"
  2431     by linarith
  2432   then have "\<exists>!s'. s' \<noteq> s \<and> ksimplex p n s' \<and> (\<exists>b\<in>s'. s - {a} = s'- {b})"
  2433   proof (elim disjE conjE)
  2434     assume "i = 0"
  2435     define rot where [abs_def]: "rot i = (if i + 1 = n then 0 else i + 1)" for i
  2436     let ?upd = "upd \<circ> rot"
  2437 
  2438     have rot: "bij_betw rot {..< n} {..< n}"
  2439       by (auto simp: bij_betw_def inj_on_def image_iff Ball_def rot_def)
  2440          arith+
  2441     from rot upd have "bij_betw ?upd {..<n} {..<n}"
  2442       by (rule bij_betw_trans)
  2443 
  2444     define f' where [abs_def]: "f' i j =
  2445       (if j \<in> ?upd`{..< i} then Suc (enum (Suc 0) j) else enum (Suc 0) j)" for i j
  2446 
  2447     interpret b: kuhn_simplex p n "enum (Suc 0)" "upd \<circ> rot" "f' ` {.. n}"
  2448     proof
  2449       from \<open>a = enum i\<close> ub \<open>n \<noteq> 0\<close> \<open>i = 0\<close>
  2450       obtain i' where "i' \<le> n" "enum i' \<noteq> enum 0" "enum i' (upd 0) \<noteq> p"
  2451         unfolding s_eq by (auto intro: upd_space simp: enum_inj)
  2452       then have "enum 1 \<le> enum i'" "enum i' (upd 0) < p"
  2453         using enum_le_p[of i' "upd 0"] by (auto simp: enum_inj enum_mono upd_space)
  2454       then have "enum 1 (upd 0) < p"
  2455         by (auto simp: le_fun_def intro: le_less_trans)
  2456       then show "enum (Suc 0) \<in> {..<n} \<rightarrow> {..<p}"
  2457         using base \<open>n \<noteq> 0\<close> by (auto simp: enum_0 enum_Suc PiE_iff extensional_def upd_space)
  2458 
  2459       { fix i assume "n \<le> i" then show "enum (Suc 0) i = p"
  2460         using \<open>n \<noteq> 0\<close> by (auto simp: enum_eq_p) }
  2461       show "bij_betw ?upd {..<n} {..<n}" by fact
  2462     qed (simp add: f'_def)
  2463     have ks_f': "ksimplex p n (f' ` {.. n})"
  2464       by rule unfold_locales
  2465 
  2466     have b_enum: "b.enum = f'" unfolding f'_def b.enum_def[abs_def] ..
  2467     with b.inj_enum have inj_f': "inj_on f' {.. n}" by simp
  2468 
  2469     have [simp]: "\<And>j. j < n \<Longrightarrow> rot ` {..< j} = {0 <..< Suc j}"
  2470       by (auto simp: rot_def image_iff Ball_def)
  2471          arith
  2472 
  2473     { fix j assume j: "j < n"
  2474       from j \<open>n \<noteq> 0\<close> have "f' j = enum (Suc j)"
  2475         by (auto simp: f'_def enum_def upd_inj in_upd_image image_comp[symmetric] fun_eq_iff) }
  2476     note f'_eq_enum = this
  2477     then have "enum ` Suc ` {..< n} = f' ` {..< n}"
  2478       by (force simp: enum_inj)
  2479     also have "Suc ` {..< n} = {.. n} - {0}"
  2480       by (auto simp: image_iff Ball_def) arith
  2481     also have "{..< n} = {.. n} - {n}"
  2482       by auto
  2483     finally have eq: "s - {a} = f' ` {.. n} - {f' n}"
  2484       unfolding s_eq \<open>a = enum i\<close> \<open>i = 0\<close>
  2485       by (simp add: Diff_subset inj_on_image_set_diff[OF inj_enum] inj_on_image_set_diff[OF inj_f'])
  2486 
  2487     have "enum 0 < f' 0"
  2488       using \<open>n \<noteq> 0\<close> by (simp add: enum_strict_mono f'_eq_enum)
  2489     also have "\<dots> < f' n"
  2490       using \<open>n \<noteq> 0\<close> b.enum_strict_mono[of 0 n] unfolding b_enum by simp
  2491     finally have "a \<noteq> f' n"
  2492       using \<open>a = enum i\<close> \<open>i = 0\<close> by auto
  2493 
  2494     { fix t c assume "ksimplex p n t" "c \<in> t" and eq_sma: "s - {a} = t - {c}"
  2495       obtain b u where "kuhn_simplex p n b u t"
  2496         using \<open>ksimplex p n t\<close> by (auto elim: ksimplex.cases)
  2497       then interpret t: kuhn_simplex p n b u t .
  2498 
  2499       { fix x assume "x \<in> s" "x \<noteq> a"
  2500          then have "x (upd 0) = enum (Suc 0) (upd 0)"
  2501            by (auto simp: \<open>a = enum i\<close> \<open>i = 0\<close> s_eq enum_def enum_inj) }
  2502       then have eq_upd0: "\<forall>x\<in>t-{c}. x (upd 0) = enum (Suc 0) (upd 0)"
  2503         unfolding eq_sma[symmetric] by auto
  2504       then have "c (upd 0) \<noteq> enum (Suc 0) (upd 0)"
  2505         using \<open>n \<noteq> 0\<close> by (intro t.one_step[OF \<open>c\<in>t\<close> ]) (auto simp: upd_space)
  2506       then have "c (upd 0) < enum (Suc 0) (upd 0) \<or> c (upd 0) > enum (Suc 0) (upd 0)"
  2507         by auto
  2508       then have "t = s \<or> t = f' ` {..n}"
  2509       proof (elim disjE conjE)
  2510         assume *: "c (upd 0) < enum (Suc 0) (upd 0)"
  2511         interpret st: kuhn_simplex_pair p n base upd s b u t ..
  2512         { fix x assume "x \<in> t" with * \<open>c\<in>t\<close> eq_upd0[rule_format, of x] have "c \<le> x"
  2513             by (auto simp: le_less intro!: t.less[of _ _ "upd 0"]) }
  2514         note top = this
  2515         have "s = t"
  2516           using \<open>a = enum i\<close> \<open>i = 0\<close> \<open>c \<in> t\<close>
  2517           by (intro st.ksimplex_eq_bot[OF _ _ _ _ eq_sma])
  2518              (auto simp: s_eq enum_mono t.s_eq t.enum_mono top)
  2519         then show ?thesis by simp
  2520       next
  2521         assume *: "c (upd 0) > enum (Suc 0) (upd 0)"
  2522         interpret st: kuhn_simplex_pair p n "enum (Suc 0)" "upd \<circ> rot" "f' ` {.. n}" b u t ..
  2523         have eq: "f' ` {..n} - {f' n} = t - {c}"
  2524           using eq_sma eq by simp
  2525         { fix x assume "x \<in> t" with * \<open>c\<in>t\<close> eq_upd0[rule_format, of x] have "x \<le> c"
  2526             by (auto simp: le_less intro!: t.less[of _ _ "upd 0"]) }
  2527         note top = this
  2528         have "f' ` {..n} = t"
  2529           using \<open>a = enum i\<close> \<open>i = 0\<close> \<open>c \<in> t\<close>
  2530           by (intro st.ksimplex_eq_top[OF _ _ _ _ eq])
  2531              (auto simp: b.s_eq b.enum_mono t.s_eq t.enum_mono b_enum[symmetric] top)
  2532         then show ?thesis by simp
  2533       qed }
  2534     with ks_f' eq \<open>a \<noteq> f' n\<close> \<open>n \<noteq> 0\<close> show ?thesis
  2535       apply (intro ex1I[of _ "f' ` {.. n}"])
  2536       apply auto []
  2537       apply metis
  2538       done
  2539   next
  2540     assume "i = n"
  2541     from \<open>n \<noteq> 0\<close> obtain n' where n': "n = Suc n'"
  2542       by (cases n) auto
  2543 
  2544     define rot where "rot i = (case i of 0 \<Rightarrow> n' | Suc i \<Rightarrow> i)" for i
  2545     let ?upd = "upd \<circ> rot"
  2546 
  2547     have rot: "bij_betw rot {..< n} {..< n}"
  2548       by (auto simp: bij_betw_def inj_on_def image_iff Bex_def rot_def n' split: nat.splits)
  2549          arith
  2550     from rot upd have "bij_betw ?upd {..<n} {..<n}"
  2551       by (rule bij_betw_trans)
  2552 
  2553     define b where "b = base (upd n' := base (upd n') - 1)"
  2554     define f' where [abs_def]: "f' i j = (if j \<in> ?upd`{..< i} then Suc (b j) else b j)" for i j
  2555 
  2556     interpret b: kuhn_simplex p n b "upd \<circ> rot" "f' ` {.. n}"
  2557     proof
  2558       { fix i assume "n \<le> i" then show "b i = p"
  2559           using base_out[of i] upd_space[of n'] by (auto simp: b_def n') }
  2560       show "b \<in> {..<n} \<rightarrow> {..<p}"
  2561         using base \<open>n \<noteq> 0\<close> upd_space[of n']
  2562         by (auto simp: b_def PiE_def Pi_iff Ball_def upd_space extensional_def n')
  2563 
  2564       show "bij_betw ?upd {..<n} {..<n}" by fact
  2565     qed (simp add: f'_def)
  2566     have f': "b.enum = f'" unfolding f'_def b.enum_def[abs_def] ..
  2567     have ks_f': "ksimplex p n (b.enum ` {.. n})"
  2568       unfolding f' by rule unfold_locales
  2569 
  2570     have "0 < n"
  2571       using \<open>n \<noteq> 0\<close> by auto
  2572 
  2573     { from \<open>a = enum i\<close> \<open>n \<noteq> 0\<close> \<open>i = n\<close> lb upd_space[of n']
  2574       obtain i' where "i' \<le> n" "enum i' \<noteq> enum n" "0 < enum i' (upd n')"
  2575         unfolding s_eq by (auto simp: enum_inj n')
  2576       moreover have "enum i' (upd n') = base (upd n')"
  2577         unfolding enum_def using \<open>i' \<le> n\<close> \<open>enum i' \<noteq> enum n\<close> by (auto simp: n' upd_inj enum_inj)
  2578       ultimately have "0 < base (upd n')"
  2579         by auto }
  2580     then have benum1: "b.enum (Suc 0) = base"
  2581       unfolding b.enum_Suc[OF \<open>0<n\<close>] b.enum_0 by (auto simp: b_def rot_def)
  2582 
  2583     have [simp]: "\<And>j. Suc j < n \<Longrightarrow> rot ` {..< Suc j} = {n'} \<union> {..< j}"
  2584       by (auto simp: rot_def image_iff Ball_def split: nat.splits)
  2585     have rot_simps: "\<And>j. rot (Suc j) = j" "rot 0 = n'"
  2586       by (simp_all add: rot_def)
  2587 
  2588     { fix j assume j: "Suc j \<le> n" then have "b.enum (Suc j) = enum j"
  2589         by (induct j) (auto simp: benum1 enum_0 b.enum_Suc enum_Suc rot_simps) }
  2590     note b_enum_eq_enum = this
  2591     then have "enum ` {..< n} = b.enum ` Suc ` {..< n}"
  2592       by (auto simp: image_comp intro!: image_cong)
  2593     also have "Suc ` {..< n} = {.. n} - {0}"
  2594       by (auto simp: image_iff Ball_def) arith
  2595     also have "{..< n} = {.. n} - {n}"
  2596       by auto
  2597     finally have eq: "s - {a} = b.enum ` {.. n} - {b.enum 0}"
  2598       unfolding s_eq \<open>a = enum i\<close> \<open>i = n\<close>
  2599       using inj_on_image_set_diff[OF inj_enum Diff_subset, of "{n}"]
  2600             inj_on_image_set_diff[OF b.inj_enum Diff_subset, of "{0}"]
  2601       by (simp add: comp_def)
  2602 
  2603     have "b.enum 0 \<le> b.enum n"
  2604       by (simp add: b.enum_mono)
  2605     also have "b.enum n < enum n"
  2606       using \<open>n \<noteq> 0\<close> by (simp add: enum_strict_mono b_enum_eq_enum n')
  2607     finally have "a \<noteq> b.enum 0"
  2608       using \<open>a = enum i\<close> \<open>i = n\<close> by auto
  2609 
  2610     { fix t c assume "ksimplex p n t" "c \<in> t" and eq_sma: "s - {a} = t - {c}"
  2611       obtain b' u where "kuhn_simplex p n b' u t"
  2612         using \<open>ksimplex p n t\<close> by (auto elim: ksimplex.cases)
  2613       then interpret t: kuhn_simplex p n b' u t .
  2614 
  2615       { fix x assume "x \<in> s" "x \<noteq> a"
  2616          then have "x (upd n') = enum n' (upd n')"
  2617            by (auto simp: \<open>a = enum i\<close> n' \<open>i = n\<close> s_eq enum_def enum_inj in_upd_image) }
  2618       then have eq_upd0: "\<forall>x\<in>t-{c}. x (upd n') = enum n' (upd n')"
  2619         unfolding eq_sma[symmetric] by auto
  2620       then have "c (upd n') \<noteq> enum n' (upd n')"
  2621         using \<open>n \<noteq> 0\<close> by (intro t.one_step[OF \<open>c\<in>t\<close> ]) (auto simp: n' upd_space[unfolded n'])
  2622       then have "c (upd n') < enum n' (upd n') \<or> c (upd n') > enum n' (upd n')"
  2623         by auto
  2624       then have "t = s \<or> t = b.enum ` {..n}"
  2625       proof (elim disjE conjE)
  2626         assume *: "c (upd n') > enum n' (upd n')"
  2627         interpret st: kuhn_simplex_pair p n base upd s b' u t ..
  2628         { fix x assume "x \<in> t" with * \<open>c\<in>t\<close> eq_upd0[rule_format, of x] have "x \<le> c"
  2629             by (auto simp: le_less intro!: t.less[of _ _ "upd n'"]) }
  2630         note top = this
  2631         have "s = t"
  2632           using \<open>a = enum i\<close> \<open>i = n\<close> \<open>c \<in> t\<close>
  2633           by (intro st.ksimplex_eq_top[OF _ _ _ _ eq_sma])
  2634              (auto simp: s_eq enum_mono t.s_eq t.enum_mono top)
  2635         then show ?thesis by simp
  2636       next
  2637         assume *: "c (upd n') < enum n' (upd n')"
  2638         interpret st: kuhn_simplex_pair p n b "upd \<circ> rot" "f' ` {.. n}" b' u t ..
  2639         have eq: "f' ` {..n} - {b.enum 0} = t - {c}"
  2640           using eq_sma eq f' by simp
  2641         { fix x assume "x \<in> t" with * \<open>c\<in>t\<close> eq_upd0[rule_format, of x] have "c \<le> x"
  2642             by (auto simp: le_less intro!: t.less[of _ _ "upd n'"]) }
  2643         note bot = this
  2644         have "f' ` {..n} = t"
  2645           using \<open>a = enum i\<close> \<open>i = n\<close> \<open>c \<in> t\<close>
  2646           by (intro st.ksimplex_eq_bot[OF _ _ _ _ eq])
  2647              (auto simp: b.s_eq b.enum_mono t.s_eq t.enum_mono bot)
  2648         with f' show ?thesis by simp
  2649       qed }
  2650     with ks_f' eq \<open>a \<noteq> b.enum 0\<close> \<open>n \<noteq> 0\<close> show ?thesis
  2651       apply (intro ex1I[of _ "b.enum ` {.. n}"])
  2652       apply auto []
  2653       apply metis
  2654       done
  2655   next
  2656     assume i: "0 < i" "i < n"
  2657     define i' where "i' = i - 1"
  2658     with i have "Suc i' < n"
  2659       by simp
  2660     with i have Suc_i': "Suc i' = i"
  2661       by (simp add: i'_def)
  2662 
  2663     let ?upd = "Fun.swap i' i upd"
  2664     from i upd have "bij_betw ?upd {..< n} {..< n}"
  2665       by (subst bij_betw_swap_iff) (auto simp: i'_def)
  2666 
  2667     define f' where [abs_def]: "f' i j = (if j \<in> ?upd`{..< i} then Suc (base j) else base j)"
  2668       for i j
  2669     interpret b: kuhn_simplex p n base ?upd "f' ` {.. n}"
  2670     proof
  2671       show "base \<in> {..<n} \<rightarrow> {..<p}" by (rule base)
  2672       { fix i assume "n \<le> i" then show "base i = p" by (rule base_out) }
  2673       show "bij_betw ?upd {..<n} {..<n}" by fact
  2674     qed (simp add: f'_def)
  2675     have f': "b.enum = f'" unfolding f'_def b.enum_def[abs_def] ..
  2676     have ks_f': "ksimplex p n (b.enum ` {.. n})"
  2677       unfolding f' by rule unfold_locales
  2678 
  2679     have "{i} \<subseteq> {..n}"
  2680       using i by auto
  2681     { fix j assume "j \<le> n"
  2682       moreover have "j < i \<or> i = j \<or> i < j" by arith
  2683       moreover note i
  2684       ultimately have "enum j = b.enum j \<longleftrightarrow> j \<noteq> i"
  2685         unfolding enum_def[abs_def] b.enum_def[abs_def]
  2686         by (auto simp: fun_eq_iff swap_image i'_def
  2687                            in_upd_image inj_on_image_set_diff[OF inj_upd]) }
  2688     note enum_eq_benum = this
  2689     then have "enum ` ({.. n} - {i}) = b.enum ` ({.. n} - {i})"
  2690       by (intro image_cong) auto
  2691     then have eq: "s - {a} = b.enum ` {.. n} - {b.enum i}"
  2692       unfolding s_eq \<open>a = enum i\<close>
  2693       using inj_on_image_set_diff[OF inj_enum Diff_subset \<open>{i} \<subseteq> {..n}\<close>]
  2694             inj_on_image_set_diff[OF b.inj_enum Diff_subset \<open>{i} \<subseteq> {..n}\<close>]
  2695       by (simp add: comp_def)
  2696 
  2697     have "a \<noteq> b.enum i"
  2698       using \<open>a = enum i\<close> enum_eq_benum i by auto
  2699 
  2700     { fix t c assume "ksimplex p n t" "c \<in> t" and eq_sma: "s - {a} = t - {c}"
  2701       obtain b' u where "kuhn_simplex p n b' u t"
  2702         using \<open>ksimplex p n t\<close> by (auto elim: ksimplex.cases)
  2703       then interpret t: kuhn_simplex p n b' u t .
  2704       have "enum i' \<in> s - {a}" "enum (i + 1) \<in> s - {a}"
  2705         using \<open>a = enum i\<close> i enum_in by (auto simp: enum_inj i'_def)
  2706       then obtain l k where
  2707         l: "t.enum l = enum i'" "l \<le> n" "t.enum l \<noteq> c" and
  2708         k: "t.enum k = enum (i + 1)" "k \<le> n" "t.enum k \<noteq> c"
  2709         unfolding eq_sma by (auto simp: t.s_eq)
  2710       with i have "t.enum l < t.enum k"
  2711         by (simp add: enum_strict_mono i'_def)
  2712       with \<open>l \<le> n\<close> \<open>k \<le> n\<close> have "l < k"
  2713         by (simp add: t.enum_strict_mono)
  2714       { assume "Suc l = k"
  2715         have "enum (Suc (Suc i')) = t.enum (Suc l)"
  2716           using i by (simp add: k \<open>Suc l = k\<close> i'_def)
  2717         then have False
  2718           using \<open>l < k\<close> \<open>k \<le> n\<close> \<open>Suc i' < n\<close>
  2719           by (auto simp: t.enum_Suc enum_Suc l upd_inj fun_eq_iff split: if_split_asm)
  2720              (metis Suc_lessD n_not_Suc_n upd_inj) }
  2721       with \<open>l < k\<close> have "Suc l < k"
  2722         by arith
  2723       have c_eq: "c = t.enum (Suc l)"
  2724       proof (rule ccontr)
  2725         assume "c \<noteq> t.enum (Suc l)"
  2726         then have "t.enum (Suc l) \<in> s - {a}"
  2727           using \<open>l < k\<close> \<open>k \<le> n\<close> by (simp add: t.s_eq eq_sma)
  2728         then obtain j where "t.enum (Suc l) = enum j" "j \<le> n" "enum j \<noteq> enum i"
  2729           unfolding s_eq \<open>a = enum i\<close> by auto
  2730         with i have "t.enum (Suc l) \<le> t.enum l \<or> t.enum k \<le> t.enum (Suc l)"
  2731           by (auto simp: i'_def enum_mono enum_inj l k)
  2732         with \<open>Suc l < k\<close> \<open>k \<le> n\<close> show False
  2733           by (simp add: t.enum_mono)
  2734       qed
  2735 
  2736       { have "t.enum (Suc (Suc l)) \<in> s - {a}"
  2737           unfolding eq_sma c_eq t.s_eq using \<open>Suc l < k\<close> \<open>k \<le> n\<close> by (auto simp: t.enum_inj)
  2738         then obtain j where eq: "t.enum (Suc (Suc l)) = enum j" and "j \<le> n" "j \<noteq> i"
  2739           by (auto simp: s_eq \<open>a = enum i\<close>)
  2740         moreover have "enum i' < t.enum (Suc (Suc l))"
  2741           unfolding l(1)[symmetric] using \<open>Suc l < k\<close> \<open>k \<le> n\<close> by (auto simp: t.enum_strict_mono)
  2742         ultimately have "i' < j"
  2743           using i by (simp add: enum_strict_mono i'_def)
  2744         with \<open>j \<noteq> i\<close> \<open>j \<le> n\<close> have "t.enum k \<le> t.enum (Suc (Suc l))"
  2745           unfolding i'_def by (simp add: enum_mono k eq)
  2746         then have "k \<le> Suc (Suc l)"
  2747           using \<open>k \<le> n\<close> \<open>Suc l < k\<close> by (simp add: t.enum_mono) }
  2748       with \<open>Suc l < k\<close> have "Suc (Suc l) = k" by simp
  2749       then have "enum (Suc (Suc i')) = t.enum (Suc (Suc l))"
  2750         using i by (simp add: k i'_def)
  2751       also have "\<dots> = (enum i') (u l := Suc (enum i' (u l)), u (Suc l) := Suc (enum i' (u (Suc l))))"
  2752         using \<open>Suc l < k\<close> \<open>k \<le> n\<close> by (simp add: t.enum_Suc l t.upd_inj)
  2753       finally have "(u l = upd i' \<and> u (Suc l) = upd (Suc i')) \<or>
  2754         (u l = upd (Suc i') \<and> u (Suc l) = upd i')"
  2755         using \<open>Suc i' < n\<close> by (auto simp: enum_Suc fun_eq_iff split: if_split_asm)
  2756 
  2757       then have "t = s \<or> t = b.enum ` {..n}"
  2758       proof (elim disjE conjE)
  2759         assume u: "u l = upd i'"
  2760         have "c = t.enum (Suc l)" unfolding c_eq ..
  2761         also have "t.enum (Suc l) = enum (Suc i')"
  2762           using u \<open>l < k\<close> \<open>k \<le> n\<close> \<open>Suc i' < n\<close> by (simp add: enum_Suc t.enum_Suc l)
  2763         also have "\<dots> = a"
  2764           using \<open>a = enum i\<close> i by (simp add: i'_def)
  2765         finally show ?thesis
  2766           using eq_sma \<open>a \<in> s\<close> \<open>c \<in> t\<close> by auto
  2767       next
  2768         assume u: "u l = upd (Suc i')"
  2769         define B where "B = b.enum ` {..n}"
  2770         have "b.enum i' = enum i'"
  2771           using enum_eq_benum[of i'] i by (auto simp: i'_def gr0_conv_Suc)
  2772         have "c = t.enum (Suc l)" unfolding c_eq ..
  2773         also have "t.enum (Suc l) = b.enum (Suc i')"
  2774           using u \<open>l < k\<close> \<open>k \<le> n\<close> \<open>Suc i' < n\<close>
  2775           by (simp_all add: enum_Suc t.enum_Suc l b.enum_Suc \<open>b.enum i' = enum i'\<close> swap_apply1)
  2776              (simp add: Suc_i')
  2777         also have "\<dots> = b.enum i"
  2778           using i by (simp add: i'_def)
  2779         finally have "c = b.enum i" .
  2780         then have "t - {c} = B - {c}" "c \<in> B"
  2781           unfolding eq_sma[symmetric] eq B_def using i by auto
  2782         with \<open>c \<in> t\<close> have "t = B"
  2783           by auto
  2784         then show ?thesis
  2785           by (simp add: B_def)
  2786       qed }
  2787     with ks_f' eq \<open>a \<noteq> b.enum i\<close> \<open>n \<noteq> 0\<close> \<open>i \<le> n\<close> show ?thesis
  2788       apply (intro ex1I[of _ "b.enum ` {.. n}"])
  2789       apply auto []
  2790       apply metis
  2791       done
  2792   qed
  2793   then show ?thesis
  2794     using s \<open>a \<in> s\<close> by (simp add: card_2_exists Ex1_def) metis
  2795 qed
  2796 
  2797 text \<open>Hence another step towards concreteness.\<close>
  2798 
  2799 lemma kuhn_simplex_lemma:
  2800   assumes "\<forall>s. ksimplex p (Suc n) s \<longrightarrow> rl ` s \<subseteq> {.. Suc n}"
  2801     and "odd (card {f. \<exists>s a. ksimplex p (Suc n) s \<and> a \<in> s \<and> (f = s - {a}) \<and>
  2802       rl ` f = {..n} \<and> ((\<exists>j\<le>n. \<forall>x\<in>f. x j = 0) \<or> (\<exists>j\<le>n. \<forall>x\<in>f. x j = p))})"
  2803   shows "odd (card {s. ksimplex p (Suc n) s \<and> rl ` s = {..Suc n}})"
  2804 proof (rule kuhn_complete_lemma[OF finite_ksimplexes refl, unfolded mem_Collect_eq,
  2805     where bnd="\<lambda>f. (\<exists>j\<in>{..n}. \<forall>x\<in>f. x j = 0) \<or> (\<exists>j\<in>{..n}. \<forall>x\<in>f. x j = p)"],
  2806     safe del: notI)
  2807 
  2808   have *: "\<And>x y. x = y \<Longrightarrow> odd (card x) \<Longrightarrow> odd (card y)"
  2809     by auto
  2810   show "odd (card {f. (\<exists>s\<in>{s. ksimplex p (Suc n) s}. \<exists>a\<in>s. f = s - {a}) \<and>
  2811     rl ` f = {..n} \<and> ((\<exists>j\<in>{..n}. \<forall>x\<in>f. x j = 0) \<or> (\<exists>j\<in>{..n}. \<forall>x\<in>f. x j = p))})"
  2812     apply (rule *[OF _ assms(2)])
  2813     apply (auto simp: atLeast0AtMost)
  2814     done
  2815 
  2816 next
  2817 
  2818   fix s assume s: "ksimplex p (Suc n) s"
  2819   then show "card s = n + 2"
  2820     by (simp add: ksimplex_card)
  2821 
  2822   fix a assume a: "a \<in> s" then show "rl a \<le> Suc n"
  2823     using assms(1) s by (auto simp: subset_eq)
  2824 
  2825   let ?S = "{t. ksimplex p (Suc n) t \<and> (\<exists>b\<in>t. s - {a} = t - {b})}"
  2826   { fix j assume j: "j \<le> n" "\<forall>x\<in>s - {a}. x j = 0"
  2827     with s a show "card ?S = 1"
  2828       using ksimplex_replace_0[of p "n + 1" s a j]
  2829       by (subst eq_commute) simp }
  2830 
  2831   { fix j assume j: "j \<le> n" "\<forall>x\<in>s - {a}. x j = p"
  2832     with s a show "card ?S = 1"
  2833       using ksimplex_replace_1[of p "n + 1" s a j]
  2834       by (subst eq_commute) simp }
  2835 
  2836   { assume "card ?S \<noteq> 2" "\<not> (\<exists>j\<in>{..n}. \<forall>x\<in>s - {a}. x j = p)"
  2837     with s a show "\<exists>j\<in>{..n}. \<forall>x\<in>s - {a}. x j = 0"
  2838       using ksimplex_replace_2[of p "n + 1" s a]
  2839       by (subst (asm) eq_commute) auto }
  2840 qed
  2841 
  2842 subsubsection \<open>Reduced labelling\<close>
  2843 
  2844 definition reduced :: "nat \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> nat" where "reduced n x = (LEAST k. k = n \<or> x k \<noteq> 0)"
  2845 
  2846 lemma reduced_labelling:
  2847   shows "reduced n x \<le> n"
  2848     and "\<forall>i<reduced n x. x i = 0"
  2849     and "reduced n x = n \<or> x (reduced n x) \<noteq> 0"
  2850 proof -
  2851   show "reduced n x \<le> n"
  2852     unfolding reduced_def by (rule LeastI2_wellorder[where a=n]) auto
  2853   show "\<forall>i<reduced n x. x i = 0"
  2854     unfolding reduced_def by (rule LeastI2_wellorder[where a=n]) fastforce+
  2855   show "reduced n x = n \<or> x (reduced n x) \<noteq> 0"
  2856     unfolding reduced_def by (rule LeastI2_wellorder[where a=n]) fastforce+
  2857 qed
  2858 
  2859 lemma reduced_labelling_unique:
  2860   "r \<le> n \<Longrightarrow> \<forall>i<r. x i = 0 \<Longrightarrow> r = n \<or> x r \<noteq> 0 \<Longrightarrow> reduced n x = r"
  2861  unfolding reduced_def by (rule LeastI2_wellorder[where a=n]) (metis le_less not_le)+
  2862 
  2863 lemma reduced_labelling_zero: "j < n \<Longrightarrow> x j = 0 \<Longrightarrow> reduced n x \<noteq> j"
  2864   using reduced_labelling[of n x] by auto
  2865 
  2866 lemma reduce_labelling_zero[simp]: "reduced 0 x = 0"
  2867   by (rule reduced_labelling_unique) auto
  2868 
  2869 lemma reduced_labelling_nonzero: "j < n \<Longrightarrow> x j \<noteq> 0 \<Longrightarrow> reduced n x \<le> j"
  2870   using reduced_labelling[of n x] by (elim allE[where x=j]) auto
  2871 
  2872 lemma reduced_labelling_Suc: "reduced (Suc n) x \<noteq> Suc n \<Longrightarrow> reduced (Suc n) x = reduced n x"
  2873   using reduced_labelling[of "Suc n" x]
  2874   by (intro reduced_labelling_unique[symmetric]) auto
  2875 
  2876 lemma complete_face_top:
  2877   assumes "\<forall>x\<in>f. \<forall>j\<le>n. x j = 0 \<longrightarrow> lab x j = 0"
  2878     and "\<forall>x\<in>f. \<forall>j\<le>n. x j = p \<longrightarrow> lab x j = 1"
  2879     and eq: "(reduced (Suc n) \<circ> lab) ` f = {..n}"
  2880   shows "((\<exists>j\<le>n. \<forall>x\<in>f. x j = 0) \<or> (\<exists>j\<le>n. \<forall>x\<in>f. x j = p)) \<longleftrightarrow> (\<forall>x\<in>f. x n = p)"
  2881 proof (safe del: disjCI)
  2882   fix x j assume j: "j \<le> n" "\<forall>x\<in>f. x j = 0"
  2883   { fix x assume "x \<in> f" with assms j have "reduced (Suc n) (lab x) \<noteq> j"
  2884       by (intro reduced_labelling_zero) auto }
  2885   moreover have "j \<in> (reduced (Suc n) \<circ> lab) ` f"
  2886     using j eq by auto
  2887   ultimately show "x n = p"
  2888     by force
  2889 next
  2890   fix x j assume j: "j \<le> n" "\<forall>x\<in>f. x j = p" and x: "x \<in> f"
  2891   have "j = n"
  2892   proof (rule ccontr)
  2893     assume "\<not> ?thesis"
  2894     { fix x assume "x \<in> f"
  2895       with assms j have "reduced (Suc n) (lab x) \<le> j"
  2896         by (intro reduced_labelling_nonzero) auto
  2897       then have "reduced (Suc n) (lab x) \<noteq> n"
  2898         using \<open>j \<noteq> n\<close> \<open>j \<le> n\<close> by simp }
  2899     moreover
  2900     have "n \<in> (reduced (Suc n) \<circ> lab) ` f"
  2901       using eq by auto
  2902     ultimately show False
  2903       by force
  2904   qed
  2905   moreover have "j \<in> (reduced (Suc n) \<circ> lab) ` f"
  2906     using j eq by auto
  2907   ultimately show "x n = p"
  2908     using j x by auto
  2909 qed auto
  2910 
  2911 text \<open>Hence we get just about the nice induction.\<close>
  2912 
  2913 lemma kuhn_induction:
  2914   assumes "0 < p"
  2915     and lab_0: "\<forall>x. \<forall>j\<le>n. (\<forall>j. x j \<le> p) \<and> x j = 0 \<longrightarrow> lab x j = 0"
  2916     and lab_1: "\<forall>x. \<forall>j\<le>n. (\<forall>j. x j \<le> p) \<and> x j = p \<longrightarrow> lab x j = 1"
  2917     and odd: "odd (card {s. ksimplex p n s \<and> (reduced n\<circ>lab) ` s = {..n}})"
  2918   shows "odd (card {s. ksimplex p (Suc n) s \<and> (reduced (Suc n)\<circ>lab) ` s = {..Suc n}})"
  2919 proof -
  2920   let ?rl = "reduced (Suc n) \<circ> lab" and ?ext = "\<lambda>f v. \<exists>j\<le>n. \<forall>x\<in>f. x j = v"
  2921   let ?ext = "\<lambda>s. (\<exists>j\<le>n. \<forall>x\<in>s. x j = 0) \<or> (\<exists>j\<le>n. \<forall>x\<in>s. x j = p)"
  2922   have "\<forall>s. ksimplex p (Suc n) s \<longrightarrow> ?rl ` s \<subseteq> {..Suc n}"
  2923     by (simp add: reduced_labelling subset_eq)
  2924   moreover
  2925   have "{s. ksimplex p n s \<and> (reduced n \<circ> lab) ` s = {..n}} =
  2926         {f. \<exists>s a. ksimplex p (Suc n) s \<and> a \<in> s \<and> f = s - {a} \<and> ?rl ` f = {..n} \<and> ?ext f}"
  2927   proof (intro set_eqI, safe del: disjCI equalityI disjE)
  2928     fix s assume s: "ksimplex p n s" and rl: "(reduced n \<circ> lab) ` s = {..n}"
  2929     from s obtain u b where "kuhn_simplex p n u b s" by (auto elim: ksimplex.cases)
  2930     then interpret kuhn_simplex p n u b s .
  2931     have all_eq_p: "\<forall>x\<in>s. x n = p"
  2932       by (auto simp: out_eq_p)
  2933     moreover
  2934     { fix x assume "x \<in> s"
  2935       with lab_1[rule_format, of n x] all_eq_p s_le_p[of x]
  2936       have "?rl x \<le> n"
  2937         by (auto intro!: reduced_labelling_nonzero)
  2938       then have "?rl x = reduced n (lab x)"
  2939         by (auto intro!: reduced_labelling_Suc) }
  2940     then have "?rl ` s = {..n}"
  2941       using rl by (simp cong: image_cong)
  2942     moreover
  2943     obtain t a where "ksimplex p (Suc n) t" "a \<in> t" "s = t - {a}"
  2944       using s unfolding simplex_top_face[OF \<open>0 < p\<close> all_eq_p] by auto
  2945     ultimately
  2946     show "\<exists>t a. ksimplex p (Suc n) t \<and> a \<in> t \<and> s = t - {a} \<and> ?rl ` s = {..n} \<and> ?ext s"
  2947       by auto
  2948   next
  2949     fix x s a assume s: "ksimplex p (Suc n) s" and rl: "?rl ` (s - {a}) = {.. n}"
  2950       and a: "a \<in> s" and "?ext (s - {a})"
  2951     from s obtain u b where "kuhn_simplex p (Suc n) u b s" by (auto elim: ksimplex.cases)
  2952     then interpret kuhn_simplex p "Suc n" u b s .
  2953     have all_eq_p: "\<forall>x\<in>s. x (Suc n) = p"
  2954       by (auto simp: out_eq_p)
  2955 
  2956     { fix x assume "x \<in> s - {a}"
  2957       then have "?rl x \<in> ?rl ` (s - {a})"
  2958         by auto
  2959       then have "?rl x \<le> n"
  2960         unfolding rl by auto
  2961       then have "?rl x = reduced n (lab x)"
  2962         by (auto intro!: reduced_labelling_Suc) }
  2963     then show rl': "(reduced n\<circ>lab) ` (s - {a}) = {..n}"
  2964       unfolding rl[symmetric] by (intro image_cong) auto
  2965 
  2966     from \<open>?ext (s - {a})\<close>
  2967     have all_eq_p: "\<forall>x\<in>s - {a}. x n = p"
  2968     proof (elim disjE exE conjE)
  2969       fix j assume "j \<le> n" "\<forall>x\<in>s - {a}. x j = 0"
  2970       with lab_0[rule_format, of j] all_eq_p s_le_p
  2971       have "\<And>x. x \<in> s - {a} \<Longrightarrow> reduced (Suc n) (lab x) \<noteq> j"
  2972         by (intro reduced_labelling_zero) auto
  2973       moreover have "j \<in> ?rl ` (s - {a})"
  2974         using \<open>j \<le> n\<close> unfolding rl by auto
  2975       ultimately show ?thesis
  2976         by force
  2977     next
  2978       fix j assume "j \<le> n" and eq_p: "\<forall>x\<in>s - {a}. x j = p"
  2979       show ?thesis
  2980       proof cases
  2981         assume "j = n" with eq_p show ?thesis by simp
  2982       next
  2983         assume "j \<noteq> n"
  2984         { fix x assume x: "x \<in> s - {a}"
  2985           have "reduced n (lab x) \<le> j"
  2986           proof (rule reduced_labelling_nonzero)
  2987             show "lab x j \<noteq> 0"
  2988               using lab_1[rule_format, of j x] x s_le_p[of x] eq_p \<open>j \<le> n\<close> by auto
  2989             show "j < n"
  2990               using \<open>j \<le> n\<close> \<open>j \<noteq> n\<close> by simp
  2991           qed
  2992           then have "reduced n (lab x) \<noteq> n"
  2993             using \<open>j \<le> n\<close> \<open>j \<noteq> n\<close> by simp }
  2994         moreover have "n \<in> (reduced n\<circ>lab) ` (s - {a})"
  2995           unfolding rl' by auto
  2996         ultimately show ?thesis
  2997           by force
  2998       qed
  2999     qed
  3000     show "ksimplex p n (s - {a})"
  3001       unfolding simplex_top_face[OF \<open>0 < p\<close> all_eq_p] using s a by auto
  3002   qed
  3003   ultimately show ?thesis
  3004     using assms by (intro kuhn_simplex_lemma) auto
  3005 qed
  3006 
  3007 text \<open>And so we get the final combinatorial result.\<close>
  3008 
  3009 lemma ksimplex_0: "ksimplex p 0 s \<longleftrightarrow> s = {(\<lambda>x. p)}"
  3010 proof
  3011   assume "ksimplex p 0 s" then show "s = {(\<lambda>x. p)}"
  3012     by (blast dest: kuhn_simplex.ksimplex_0 elim: ksimplex.cases)
  3013 next
  3014   assume s: "s = {(\<lambda>x. p)}"
  3015   show "ksimplex p 0 s"
  3016   proof (intro ksimplex, unfold_locales)
  3017     show "(\<lambda>_. p) \<in> {..<0::nat} \<rightarrow> {..<p}" by auto
  3018     show "bij_betw id {..<0} {..<0}"
  3019       by simp
  3020   qed (auto simp: s)
  3021 qed
  3022 
  3023 lemma kuhn_combinatorial:
  3024   assumes "0 < p"
  3025     and "\<forall>x j. (\<forall>j. x j \<le> p) \<and> j < n \<and> x j = 0 \<longrightarrow> lab x j = 0"
  3026     and "\<forall>x j. (\<forall>j. x j \<le> p) \<and> j < n  \<and> x j = p \<longrightarrow> lab x j = 1"
  3027   shows "odd (card {s. ksimplex p n s \<and> (reduced n\<circ>lab) ` s = {..n}})"
  3028     (is "odd (card (?M n))")
  3029   using assms
  3030 proof (induct n)
  3031   case 0 then show ?case
  3032     by (simp add: ksimplex_0 cong: conj_cong)
  3033 next
  3034   case (Suc n)
  3035   then have "odd (card (?M n))"
  3036     by force
  3037   with Suc show ?case
  3038     using kuhn_induction[of p n] by (auto simp: comp_def)
  3039 qed
  3040 
  3041 lemma kuhn_lemma:
  3042   fixes n p :: nat
  3043   assumes "0 < p"
  3044     and "\<forall>x. (\<forall>i<n. x i \<le> p) \<longrightarrow> (\<forall>i<n. label x i = (0::nat) \<or> label x i = 1)"
  3045     and "\<forall>x. (\<forall>i<n. x i \<le> p) \<longrightarrow> (\<forall>i<n. x i = 0 \<longrightarrow> label x i = 0)"
  3046     and "\<forall>x. (\<forall>i<n. x i \<le> p) \<longrightarrow> (\<forall>i<n. x i = p \<longrightarrow> label x i = 1)"
  3047   obtains q where "\<forall>i<n. q i < p"
  3048     and "\<forall>i<n. \<exists>r s. (\<forall>j<n. q j \<le> r j \<and> r j \<le> q j + 1) \<and> (\<forall>j<n. q j \<le> s j \<and> s j \<le> q j + 1) \<and> label r i \<noteq> label s i"
  3049 proof -
  3050   let ?rl = "reduced n \<circ> label"
  3051   let ?A = "{s. ksimplex p n s \<and> ?rl ` s = {..n}}"
  3052   have "odd (card ?A)"
  3053     using assms by (intro kuhn_combinatorial[of p n label]) auto
  3054   then have "?A \<noteq> {}"
  3055     by fastforce
  3056   then obtain s b u where "kuhn_simplex p n b u s" and rl: "?rl ` s = {..n}"
  3057     by (auto elim: ksimplex.cases)
  3058   interpret kuhn_simplex p n b u s by fact
  3059 
  3060   show ?thesis
  3061   proof (intro that[of b] allI impI)
  3062     fix i
  3063     assume "i < n"
  3064     then show "b i < p"
  3065       using base by auto
  3066   next
  3067     fix i
  3068     assume "i < n"
  3069     then have "i \<in> {.. n}" "Suc i \<in> {.. n}"
  3070       by auto
  3071     then obtain u v where u: "u \<in> s" "Suc i = ?rl u" and v: "v \<in> s" "i = ?rl v"
  3072       unfolding rl[symmetric] by blast
  3073 
  3074     have "label u i \<noteq> label v i"
  3075       using reduced_labelling [of n "label u"] reduced_labelling [of n "label v"]
  3076         u(2)[symmetric] v(2)[symmetric] \<open>i < n\<close>
  3077       by auto
  3078     moreover
  3079     have "b j \<le> u j" "u j \<le> b j + 1" "b j \<le> v j" "v j \<le> b j + 1" if "j < n" for j
  3080       using that base_le[OF \<open>u\<in>s\<close>] le_Suc_base[OF \<open>u\<in>s\<close>] base_le[OF \<open>v\<in>s\<close>] le_Suc_base[OF \<open>v\<in>s\<close>]
  3081       by auto
  3082     ultimately show "\<exists>r s. (\<forall>j<n. b j \<le> r j \<and> r j \<le> b j + 1) \<and>
  3083         (\<forall>j<n. b j \<le> s j \<and> s j \<le> b j + 1) \<and> label r i \<noteq> label s i"
  3084       by blast
  3085   qed
  3086 qed
  3087 
  3088 subsubsection \<open>Main result for the unit cube\<close>
  3089 
  3090 lemma kuhn_labelling_lemma':
  3091   assumes "(\<forall>x::nat\<Rightarrow>real. P x \<longrightarrow> P (f x))"
  3092     and "\<forall>x. P x \<longrightarrow> (\<forall>i::nat. Q i \<longrightarrow> 0 \<le> x i \<and> x i \<le> 1)"
  3093   shows "\<exists>l. (\<forall>x i. l x i \<le> (1::nat)) \<and>
  3094              (\<forall>x i. P x \<and> Q i \<and> x i = 0 \<longrightarrow> l x i = 0) \<and>
  3095              (\<forall>x i. P x \<and> Q i \<and> x i = 1 \<longrightarrow> l x i = 1) \<and>
  3096              (\<forall>x i. P x \<and> Q i \<and> l x i = 0 \<longrightarrow> x i \<le> f x i) \<and>
  3097              (\<forall>x i. P x \<and> Q i \<and> l x i = 1 \<longrightarrow> f x i \<le> x i)"
  3098 proof -
  3099   have and_forall_thm: "\<And>P Q. (\<forall>x. P x) \<and> (\<forall>x. Q x) \<longleftrightarrow> (\<forall>x. P x \<and> Q x)"
  3100     by auto
  3101   have *: "\<forall>x y::real. 0 \<le> x \<and> x \<le> 1 \<and> 0 \<le> y \<and> y \<le> 1 \<longrightarrow> x \<noteq> 1 \<and> x \<le> y \<or> x \<noteq> 0 \<and> y \<le> x"
  3102     by auto
  3103   show ?thesis
  3104     unfolding and_forall_thm
  3105     apply (subst choice_iff[symmetric])+
  3106     apply rule
  3107     apply rule
  3108   proof -
  3109     fix x x'
  3110     let ?R = "\<lambda>y::nat.
  3111       (P x \<and> Q x' \<and> x x' = 0 \<longrightarrow> y = 0) \<and>
  3112       (P x \<and> Q x' \<and> x x' = 1 \<longrightarrow> y = 1) \<and>
  3113       (P x \<and> Q x' \<and> y = 0 \<longrightarrow> x x' \<le> (f x) x') \<and>
  3114       (P x \<and> Q x' \<and> y = 1 \<longrightarrow> (f x) x' \<le> x x')"
  3115     have "0 \<le> f x x' \<and> f x x' \<le> 1" if "P x" "Q x'"
  3116       using assms(2)[rule_format,of "f x" x'] that
  3117       apply (drule_tac assms(1)[rule_format])
  3118       apply auto
  3119       done
  3120     then have "?R 0 \<or> ?R 1"
  3121       by auto
  3122     then show "\<exists>y\<le>1. ?R y"
  3123       by auto
  3124   qed
  3125 qed
  3126 
  3127 subsection \<open>Brouwer's fixed point theorem\<close>
  3128 
  3129 text \<open>We start proving Brouwer's fixed point theorem for unit cubes.\<close>
  3130 
  3131 lemma brouwer_cube:
  3132   fixes f :: "'a::euclidean_space \<Rightarrow> 'a"
  3133   assumes "continuous_on unit_cube f"
  3134     and "f ` unit_cube \<subseteq> unit_cube"
  3135   shows "\<exists>x\<in>unit_cube. f x = x"
  3136 proof (rule ccontr)
  3137   define n where "n = DIM('a)"
  3138   have n: "1 \<le> n" "0 < n" "n \<noteq> 0"
  3139     unfolding n_def by (auto simp: Suc_le_eq DIM_positive)
  3140   assume "\<not> ?thesis"
  3141   then have *: "\<not> (\<exists>x\<in>unit_cube. f x - x = 0)"
  3142     by auto
  3143   obtain d where
  3144       d: "d > 0" "\<And>x. x \<in> unit_cube \<Longrightarrow> d \<le> norm (f x - x)"
  3145     apply (rule brouwer_compactness_lemma[OF compact_unit_cube _ *])
  3146     apply (rule continuous_intros assms)+
  3147     apply blast
  3148     done
  3149   have *: "\<forall>x. x \<in> unit_cube \<longrightarrow> f x \<in> unit_cube"
  3150     "\<forall>x. x \<in> (unit_cube::'a set) \<longrightarrow> (\<forall>i\<in>Basis. True \<longrightarrow> 0 \<le> x \<bullet> i \<and> x \<bullet> i \<le> 1)"
  3151     using assms(2)[unfolded image_subset_iff Ball_def]
  3152     unfolding mem_unit_cube
  3153     by auto
  3154   obtain label :: "'a \<Rightarrow> 'a \<Rightarrow> nat" where label [rule_format]:
  3155     "\<forall>x. \<forall>i\<in>Basis. label x i \<le> 1"
  3156     "\<forall>x. \<forall>i\<in>Basis. x \<in> unit_cube \<and> x \<bullet> i = 0 \<longrightarrow> label x i = 0"
  3157     "\<forall>x. \<forall>i\<in>Basis. x \<in> unit_cube \<and> x \<bullet> i = 1 \<longrightarrow> label x i = 1"
  3158     "\<forall>x. \<forall>i\<in>Basis. x \<in> unit_cube \<and> label x i = 0 \<longrightarrow> x \<bullet> i \<le> f x \<bullet> i"
  3159     "\<forall>x. \<forall>i\<in>Basis. x \<in> unit_cube \<and> label x i = 1 \<longrightarrow> f x \<bullet> i \<le> x \<bullet> i"
  3160     using kuhn_labelling_lemma[OF *] by auto
  3161   note label = this [rule_format]
  3162   have lem1: "\<forall>x\<in>unit_cube. \<forall>y\<in>unit_cube. \<forall>i\<in>Basis. label x i \<noteq> label y i \<longrightarrow>
  3163     \<bar>f x \<bullet> i - x \<bullet> i\<bar> \<le> norm (f y - f x) + norm (y - x)"
  3164   proof safe
  3165     fix x y :: 'a
  3166     assume x: "x \<in> unit_cube" and y: "y \<in> unit_cube"
  3167     fix i
  3168     assume i: "label x i \<noteq> label y i" "i \<in> Basis"
  3169     have *: "\<And>x y fx fy :: real. x \<le> fx \<and> fy \<le> y \<or> fx \<le> x \<and> y \<le> fy \<Longrightarrow>
  3170       \<bar>fx - x\<bar> \<le> \<bar>fy - fx\<bar> + \<bar>y - x\<bar>" by auto
  3171     have "\<bar>(f x - x) \<bullet> i\<bar> \<le> \<bar>(f y - f x)\<bullet>i\<bar> + \<bar>(y - x)\<bullet>i\<bar>"
  3172     proof (cases "label x i = 0")
  3173       case True
  3174       then have fxy: "\<not> f y \<bullet> i \<le> y \<bullet> i \<Longrightarrow> f x \<bullet> i \<le> x \<bullet> i"
  3175         by (metis True i label(1) label(5) le_antisym less_one not_le_imp_less y)
  3176       show ?thesis
  3177       unfolding inner_simps         
  3178       by (rule *) (auto simp: True i label x y fxy)
  3179     next
  3180       case False
  3181       then show ?thesis
  3182         using label [OF \<open>i \<in> Basis\<close>] i(1) x y
  3183         apply (auto simp: inner_diff_left le_Suc_eq)
  3184         by (metis "*")
  3185     qed
  3186     also have "\<dots> \<le> norm (f y - f x) + norm (y - x)"
  3187       by (simp add: add_mono i(2) norm_bound_Basis_le)
  3188     finally show "\<bar>f x \<bullet> i - x \<bullet> i\<bar> \<le> norm (f y - f x) + norm (y - x)"
  3189       unfolding inner_simps .
  3190   qed
  3191   have "\<exists>e>0. \<forall>x\<in>unit_cube. \<forall>y\<in>unit_cube. \<forall>z\<in>unit_cube. \<forall>i\<in>Basis.
  3192     norm (x - z) < e \<longrightarrow> norm (y - z) < e \<longrightarrow> label x i \<noteq> label y i \<longrightarrow>
  3193       \<bar>(f(z) - z)\<bullet>i\<bar> < d / (real n)"
  3194   proof -
  3195     have d': "d / real n / 8 > 0"
  3196       using d(1) by (simp add: n_def DIM_positive)
  3197     have *: "uniformly_continuous_on unit_cube f"
  3198       by (rule compact_uniformly_continuous[OF assms(1) compact_unit_cube])
  3199     obtain e where e:
  3200         "e > 0"
  3201         "\<And>x x'. x \<in> unit_cube \<Longrightarrow>
  3202           x' \<in> unit_cube \<Longrightarrow>
  3203           norm (x' - x) < e \<Longrightarrow>
  3204           norm (f x' - f x) < d / real n / 8"
  3205       using *[unfolded uniformly_continuous_on_def,rule_format,OF d']
  3206       unfolding dist_norm
  3207       by blast
  3208     show ?thesis
  3209     proof (intro exI conjI ballI impI)
  3210       show "0 < min (e / 2) (d / real n / 8)"
  3211         using d' e by auto
  3212       fix x y z i
  3213       assume as:
  3214         "x \<in> unit_cube" "y \<in> unit_cube" "z \<in> unit_cube"
  3215         "norm (x - z) < min (e / 2) (d / real n / 8)"
  3216         "norm (y - z) < min (e / 2) (d / real n / 8)"
  3217         "label x i \<noteq> label y i"
  3218       assume i: "i \<in> Basis"
  3219       have *: "\<And>z fz x fx n1 n2 n3 n4 d4 d :: real. \<bar>fx - x\<bar> \<le> n1 + n2 \<Longrightarrow>
  3220         \<bar>fx - fz\<bar> \<le> n3 \<Longrightarrow> \<bar>x - z\<bar> \<le> n4 \<Longrightarrow>
  3221         n1 < d4 \<Longrightarrow> n2 < 2 * d4 \<Longrightarrow> n3 < d4 \<Longrightarrow> n4 < d4 \<Longrightarrow>
  3222         (8 * d4 = d) \<Longrightarrow> \<bar>fz - z\<bar> < d"
  3223         by auto
  3224       show "\<bar>(f z - z) \<bullet> i\<bar> < d / real n"
  3225         unfolding inner_simps
  3226       proof (rule *)
  3227         show "\<bar>f x \<bullet> i - x \<bullet> i\<bar> \<le> norm (f y -f x) + norm (y - x)"
  3228           using as(1) as(2) as(6) i lem1 by blast
  3229         show "norm (f x - f z) < d / real n / 8"
  3230           using d' e as by auto
  3231         show "\<bar>f x \<bullet> i - f z \<bullet> i\<bar> \<le> norm (f x - f z)" "\<bar>x \<bullet> i - z \<bullet> i\<bar> \<le> norm (x - z)"
  3232           unfolding inner_diff_left[symmetric]
  3233           by (rule Basis_le_norm[OF i])+
  3234         have tria: "norm (y - x) \<le> norm (y - z) + norm (x - z)"
  3235           using dist_triangle[of y x z, unfolded dist_norm]
  3236           unfolding norm_minus_commute
  3237           by auto
  3238         also have "\<dots> < e / 2 + e / 2"
  3239           using as(4) as(5) by auto
  3240         finally show "norm (f y - f x) < d / real n / 8"
  3241           using as(1) as(2) e(2) by auto
  3242         have "norm (y - z) + norm (x - z) < d / real n / 8 + d / real n / 8"
  3243           using as(4) as(5) by auto
  3244         with tria show "norm (y - x) < 2 * (d / real n / 8)"
  3245           by auto
  3246       qed (use as in auto)
  3247     qed
  3248   qed
  3249   then
  3250   obtain e where e:
  3251     "e > 0"
  3252     "\<And>x y z i. x \<in> unit_cube \<Longrightarrow>
  3253       y \<in> unit_cube \<Longrightarrow>
  3254       z \<in> unit_cube \<Longrightarrow>
  3255       i \<in> Basis \<Longrightarrow>
  3256       norm (x - z) < e \<and> norm (y - z) < e \<and> label x i \<noteq> label y i \<Longrightarrow>
  3257       \<bar>(f z - z) \<bullet> i\<bar> < d / real n"
  3258     by blast
  3259   obtain p :: nat where p: "1 + real n / e \<le> real p"
  3260     using real_arch_simple ..
  3261   have "1 + real n / e > 0"
  3262     using e(1) n by (simp add: add_pos_pos)
  3263   then have "p > 0"
  3264     using p by auto
  3265 
  3266   obtain b :: "nat \<Rightarrow> 'a" where b: "bij_betw b {..< n} Basis"
  3267     by atomize_elim (auto simp: n_def intro!: finite_same_card_bij)
  3268   define b' where "b' = inv_into {..< n} b"
  3269   then have b': "bij_betw b' Basis {..< n}"
  3270     using bij_betw_inv_into[OF b] by auto
  3271   then have b'_Basis: "\<And>i. i \<in> Basis \<Longrightarrow> b' i \<in> {..< n}"
  3272     unfolding bij_betw_def by (auto simp: set_eq_iff)
  3273   have bb'[simp]:"\<And>i. i \<in> Basis \<Longrightarrow> b (b' i) = i"
  3274     unfolding b'_def
  3275     using b
  3276     by (auto simp: f_inv_into_f bij_betw_def)
  3277   have b'b[simp]:"\<And>i. i < n \<Longrightarrow> b' (b i) = i"
  3278     unfolding b'_def
  3279     using b
  3280     by (auto simp: inv_into_f_eq bij_betw_def)
  3281   have *: "\<And>x :: nat. x = 0 \<or> x = 1 \<longleftrightarrow> x \<le> 1"
  3282     by auto
  3283   have b'': "\<And>j. j < n \<Longrightarrow> b j \<in> Basis"
  3284     using b unfolding bij_betw_def by auto
  3285   have q1: "0 < p" "\<forall>x. (\<forall>i<n. x i \<le> p) \<longrightarrow>
  3286     (\<forall>i<n. (label (\<Sum>i\<in>Basis. (real (x (b' i)) / real p) *\<^sub>R i) \<circ> b) i = 0 \<or>
  3287            (label (\<Sum>i\<in>Basis. (real (x (b' i)) / real p) *\<^sub>R i) \<circ> b) i = 1)"
  3288     unfolding *
  3289     using \<open>p > 0\<close> \<open>n > 0\<close>
  3290     using label(1)[OF b'']
  3291     by auto
  3292   { fix x :: "nat \<Rightarrow> nat" and i assume "\<forall>i<n. x i \<le> p" "i < n" "x i = p \<or> x i = 0"
  3293     then have "(\<Sum>i\<in>Basis. (real (x (b' i)) / real p) *\<^sub>R i) \<in> (unit_cube::'a set)"
  3294       using b'_Basis
  3295       by (auto simp: mem_unit_cube inner_simps bij_betw_def zero_le_divide_iff divide_le_eq_1) }
  3296   note cube = this
  3297   have q2: "\<forall>x. (\<forall>i<n. x i \<le> p) \<longrightarrow> (\<forall>i<n. x i = 0 \<longrightarrow>
  3298       (label (\<Sum>i\<in>Basis. (real (x (b' i)) / real p) *\<^sub>R i) \<circ> b) i = 0)"
  3299     unfolding o_def using cube \<open>p > 0\<close> by (intro allI impI label(2)) (auto simp: b'')
  3300   have q3: "\<forall>x. (\<forall>i<n. x i \<le> p) \<longrightarrow> (\<forall>i<n. x i = p \<longrightarrow>
  3301       (label (\<Sum>i\<in>Basis. (real (x (b' i)) / real p) *\<^sub>R i) \<circ> b) i = 1)"
  3302     using cube \<open>p > 0\<close> unfolding o_def by (intro allI impI label(3)) (auto simp: b'')
  3303   obtain q where q:
  3304       "\<forall>i<n. q i < p"
  3305       "\<forall>i<n.
  3306          \<exists>r s. (\<forall>j<n. q j \<le> r j \<and> r j \<le> q j + 1) \<and>
  3307                (\<forall>j<n. q j \<le> s j \<and> s j \<le> q j + 1) \<and>
  3308                (label (\<Sum>i\<in>Basis. (real (r (b' i)) / real p) *\<^sub>R i) \<circ> b) i \<noteq>
  3309                (label (\<Sum>i\<in>Basis. (real (s (b' i)) / real p) *\<^sub>R i) \<circ> b) i"
  3310     by (rule kuhn_lemma[OF q1 q2 q3])
  3311   define z :: 'a where "z = (\<Sum>i\<in>Basis. (real (q (b' i)) / real p) *\<^sub>R i)"
  3312   have "\<exists>i\<in>Basis. d / real n \<le> \<bar>(f z - z)\<bullet>i\<bar>"
  3313   proof (rule ccontr)
  3314     have "\<forall>i\<in>Basis. q (b' i) \<in> {0..p}"
  3315       using q(1) b'
  3316       by (auto intro: less_imp_le simp: bij_betw_def)
  3317     then have "z \<in> unit_cube"
  3318       unfolding z_def mem_unit_cube
  3319       using b'_Basis
  3320       by (auto simp: bij_betw_def zero_le_divide_iff divide_le_eq_1)
  3321     then have d_fz_z: "d \<le> norm (f z - z)"
  3322       by (rule d)
  3323     assume "\<not> ?thesis"
  3324     then have as: "\<forall>i\<in>Basis. \<bar>f z \<bullet> i - z \<bullet> i\<bar> < d / real n"
  3325       using \<open>n > 0\<close>
  3326       by (auto simp: not_le inner_diff)
  3327     have "norm (f z - z) \<le> (\<Sum>i\<in>Basis. \<bar>f z \<bullet> i - z \<bullet> i\<bar>)"
  3328       unfolding inner_diff_left[symmetric]
  3329       by (rule norm_le_l1)
  3330     also have "\<dots> < (\<Sum>(i::'a) \<in> Basis. d / real n)"
  3331       by (meson as finite_Basis nonempty_Basis sum_strict_mono)
  3332     also have "\<dots> = d"
  3333       using DIM_positive[where 'a='a] by (auto simp: n_def)
  3334     finally show False
  3335       using d_fz_z by auto
  3336   qed
  3337   then obtain i where i: "i \<in> Basis" "d / real n \<le> \<bar>(f z - z) \<bullet> i\<bar>" ..
  3338   have *: "b' i < n"
  3339     using i and b'[unfolded bij_betw_def]
  3340     by auto
  3341   obtain r s where rs:
  3342     "\<And>j. j < n \<Longrightarrow> q j \<le> r j \<and> r j \<le> q j + 1"
  3343     "\<And>j. j < n \<Longrightarrow> q j \<le> s j \<and> s j \<le> q j + 1"
  3344     "(label (\<Sum>i\<in>Basis. (real (r (b' i)) / real p) *\<^sub>R i) \<circ> b) (b' i) \<noteq>
  3345       (label (\<Sum>i\<in>Basis. (real (s (b' i)) / real p) *\<^sub>R i) \<circ> b) (b' i)"
  3346     using q(2)[rule_format,OF *] by blast
  3347   have b'_im: "\<And>i. i \<in> Basis \<Longrightarrow>  b' i < n"
  3348     using b' unfolding bij_betw_def by auto
  3349   define r' ::'a where "r' = (\<Sum>i\<in>Basis. (real (r (b' i)) / real p) *\<^sub>R i)"
  3350   have "\<And>i. i \<in> Basis \<Longrightarrow> r (b' i) \<le> p"
  3351     apply (rule order_trans)
  3352     apply (rule rs(1)[OF b'_im,THEN conjunct2])
  3353     using q(1)[rule_format,OF b'_im]
  3354     apply (auto simp: Suc_le_eq)
  3355     done
  3356   then have "r' \<in> unit_cube"
  3357     unfolding r'_def mem_unit_cube
  3358     using b'_Basis
  3359     by (auto simp: bij_betw_def zero_le_divide_iff divide_le_eq_1)
  3360   define s' :: 'a where "s' = (\<Sum>i\<in>Basis. (real (s (b' i)) / real p) *\<^sub>R i)"
  3361   have "\<And>i. i \<in> Basis \<Longrightarrow> s (b' i) \<le> p"
  3362     using b'_im q(1) rs(2) by fastforce
  3363   then have "s' \<in> unit_cube"
  3364     unfolding s'_def mem_unit_cube
  3365     using b'_Basis by (auto simp: bij_betw_def zero_le_divide_iff divide_le_eq_1)
  3366   have "z \<in> unit_cube"
  3367     unfolding z_def mem_unit_cube
  3368     using b'_Basis q(1)[rule_format,OF b'_im] \<open>p > 0\<close>
  3369     by (auto simp: bij_betw_def zero_le_divide_iff divide_le_eq_1 less_imp_le)
  3370   {
  3371     have "(\<Sum>i\<in>Basis. \<bar>real (r (b' i)) - real (q (b' i))\<bar>) \<le> (\<Sum>(i::'a)\<in>Basis. 1)"
  3372       by (rule sum_mono) (use rs(1)[OF b'_im] in force)
  3373     also have "\<dots> < e * real p"
  3374       using p \<open>e > 0\<close> \<open>p > 0\<close>
  3375       by (auto simp: field_simps n_def)
  3376     finally have "(\<Sum>i\<in>Basis. \<bar>real (r (b' i)) - real (q (b' i))\<bar>) < e * real p" .
  3377   }
  3378   moreover
  3379   {
  3380     have "(\<Sum>i\<in>Basis. \<bar>real (s (b' i)) - real (q (b' i))\<bar>) \<le> (\<Sum>(i::'a)\<in>Basis. 1)"
  3381       by (rule sum_mono) (use rs(2)[OF b'_im] in force)
  3382     also have "\<dots> < e * real p"
  3383       using p \<open>e > 0\<close> \<open>p > 0\<close>
  3384       by (auto simp: field_simps n_def)
  3385     finally have "(\<Sum>i\<in>Basis. \<bar>real (s (b' i)) - real (q (b' i))\<bar>) < e * real p" .
  3386   }
  3387   ultimately
  3388   have "norm (r' - z) < e" and "norm (s' - z) < e"
  3389     unfolding r'_def s'_def z_def
  3390     using \<open>p > 0\<close>
  3391     apply (rule_tac[!] le_less_trans[OF norm_le_l1])
  3392     apply (auto simp: field_simps sum_divide_distrib[symmetric] inner_diff_left)
  3393     done
  3394   then have "\<bar>(f z - z) \<bullet> i\<bar> < d / real n"
  3395     using rs(3) i
  3396     unfolding r'_def[symmetric] s'_def[symmetric] o_def bb'
  3397     by (intro e(2)[OF \<open>r'\<in>unit_cube\<close> \<open>s'\<in>unit_cube\<close> \<open>z\<in>unit_cube\<close>]) auto
  3398   then show False
  3399     using i by auto
  3400 qed
  3401 
  3402 text \<open>Next step is to prove it for nonempty interiors.\<close>
  3403 
  3404 lemma brouwer_weak:
  3405   fixes f :: "'a::euclidean_space \<Rightarrow> 'a"
  3406   assumes "compact S"
  3407     and "convex S"
  3408     and "interior S \<noteq> {}"
  3409     and "continuous_on S f"
  3410     and "f ` S \<subseteq> S"
  3411   obtains x where "x \<in> S" and "f x = x"
  3412 proof -
  3413   let ?U = "unit_cube :: 'a set"
  3414   have "\<Sum>Basis /\<^sub>R 2 \<in> interior ?U"
  3415   proof (rule interiorI)
  3416     let ?I = "(\<Inter>i\<in>Basis. {x::'a. 0 < x \<bullet> i} \<inter> {x. x \<bullet> i < 1})"
  3417     show "open ?I"
  3418       by (intro open_INT finite_Basis ballI open_Int, auto intro: open_Collect_less simp: continuous_on_inner continuous_on_const continuous_on_id)
  3419     show "\<Sum>Basis /\<^sub>R 2 \<in> ?I"
  3420       by simp
  3421     show "?I \<subseteq> unit_cube"
  3422       unfolding unit_cube_def by force
  3423   qed
  3424   then have *: "interior ?U \<noteq> {}" by fast
  3425   have *: "?U homeomorphic S"
  3426     using homeomorphic_convex_compact[OF convex_unit_cube compact_unit_cube * assms(2,1,3)] .
  3427   have "\<forall>f. continuous_on ?U f \<and> f ` ?U \<subseteq> ?U \<longrightarrow>
  3428     (\<exists>x\<in>?U. f x = x)"
  3429     using brouwer_cube by auto
  3430   then show ?thesis
  3431     unfolding homeomorphic_fixpoint_property[OF *]
  3432     using assms
  3433     by (auto intro: that)
  3434 qed
  3435 
  3436 text \<open>Then the particular case for closed balls.\<close>
  3437 
  3438 lemma brouwer_ball:
  3439   fixes f :: "'a::euclidean_space \<Rightarrow> 'a"
  3440   assumes "e > 0"
  3441     and "continuous_on (cball a e) f"
  3442     and "f ` cball a e \<subseteq> cball a e"
  3443   obtains x where "x \<in> cball a e" and "f x = x"
  3444   using brouwer_weak[OF compact_cball convex_cball, of a e f]
  3445   unfolding interior_cball ball_eq_empty
  3446   using assms by auto
  3447 
  3448 text \<open>And finally we prove Brouwer's fixed point theorem in its general version.\<close>
  3449 
  3450 theorem brouwer:
  3451   fixes f :: "'a::euclidean_space \<Rightarrow> 'a"
  3452   assumes S: "compact S" "convex S" "S \<noteq> {}"
  3453     and contf: "continuous_on S f"
  3454     and fim: "f ` S \<subseteq> S"
  3455   obtains x where "x \<in> S" and "f x = x"
  3456 proof -
  3457   have "\<exists>e>0. S \<subseteq> cball 0 e"
  3458     using compact_imp_bounded[OF \<open>compact S\<close>]  unfolding bounded_pos
  3459     by auto
  3460   then obtain e where e: "e > 0" "S \<subseteq> cball 0 e"
  3461     by blast
  3462   have "\<exists>x\<in> cball 0 e. (f \<circ> closest_point S) x = x"
  3463   proof (rule_tac brouwer_ball[OF e(1)])
  3464     show "continuous_on (cball 0 e) (f \<circ> closest_point S)"
  3465       apply (rule continuous_on_compose)
  3466       using S compact_eq_bounded_closed continuous_on_closest_point apply blast
  3467       by (meson S contf closest_point_in_set compact_imp_closed continuous_on_subset image_subsetI)
  3468     show "(f \<circ> closest_point S) ` cball 0 e \<subseteq> cball 0 e"
  3469       by clarsimp (metis S fim closest_point_exists(1) compact_eq_bounded_closed e(2) image_subset_iff mem_cball_0 subsetCE)
  3470   qed (use assms in auto)
  3471   then obtain x where x: "x \<in> cball 0 e" "(f \<circ> closest_point S) x = x" ..
  3472   have "x \<in> S"
  3473     by (metis closest_point_in_set comp_apply compact_imp_closed fim image_eqI S(1) S(3) subset_iff x(2))
  3474   then have *: "closest_point S x = x"
  3475     by (rule closest_point_self)
  3476   show thesis
  3477   proof
  3478     show "closest_point S x \<in> S"
  3479       by (simp add: "*" \<open>x \<in> S\<close>)
  3480     show "f (closest_point S x) = closest_point S x"
  3481       using "*" x(2) by auto
  3482   qed
  3483 qed
  3484 
  3485 subsection \<open>Applications\<close>
  3486 
  3487 text \<open>So we get the no-retraction theorem.\<close>
  3488 
  3489 corollary no_retraction_cball:
  3490   fixes a :: "'a::euclidean_space"
  3491   assumes "e > 0"
  3492   shows "\<not> (frontier (cball a e) retract_of (cball a e))"
  3493 proof
  3494   assume *: "frontier (cball a e) retract_of (cball a e)"
  3495   have **: "\<And>xa. a - (2 *\<^sub>R a - xa) = - (a - xa)"
  3496     using scaleR_left_distrib[of 1 1 a] by auto
  3497   obtain x where x: "x \<in> {x. norm (a - x) = e}" "2 *\<^sub>R a - x = x"
  3498   proof (rule retract_fixpoint_property[OF *, of "\<lambda>x. scaleR 2 a - x"])
  3499     show "continuous_on (frontier (cball a e)) ((-) (2 *\<^sub>R a))"
  3500       by (intro continuous_intros)
  3501     show "(-) (2 *\<^sub>R a) ` frontier (cball a e) \<subseteq> frontier (cball a e)"
  3502       by clarsimp (metis "**" dist_norm norm_minus_cancel)
  3503   qed (auto simp: dist_norm intro: brouwer_ball[OF assms])
  3504   then have "scaleR 2 a = scaleR 1 x + scaleR 1 x"
  3505     by (auto simp: algebra_simps)
  3506   then have "a = x"
  3507     unfolding scaleR_left_distrib[symmetric]
  3508     by auto
  3509   then show False
  3510     using x assms by auto
  3511 qed
  3512 
  3513 corollary contractible_sphere:
  3514   fixes a :: "'a::euclidean_space"
  3515   shows "contractible(sphere a r) \<longleftrightarrow> r \<le> 0"
  3516 proof (cases "0 < r")
  3517   case True
  3518   then show ?thesis
  3519     unfolding contractible_def nullhomotopic_from_sphere_extension
  3520     using no_retraction_cball [OF True, of a]
  3521     by (auto simp: retract_of_def retraction_def)
  3522 next
  3523   case False
  3524   then show ?thesis
  3525     unfolding contractible_def nullhomotopic_from_sphere_extension
  3526     using continuous_on_const less_eq_real_def by auto
  3527 qed
  3528 
  3529 corollary connected_sphere_eq:
  3530   fixes a :: "'a :: euclidean_space"
  3531   shows "connected(sphere a r) \<longleftrightarrow> 2 \<le> DIM('a) \<or> r \<le> 0"
  3532     (is "?lhs = ?rhs")
  3533 proof (cases r "0::real" rule: linorder_cases)
  3534   case less
  3535   then show ?thesis by auto
  3536 next
  3537   case equal
  3538   then show ?thesis by auto
  3539 next
  3540   case greater
  3541   show ?thesis
  3542   proof
  3543     assume L: ?lhs
  3544     have "False" if 1: "DIM('a) = 1"
  3545     proof -
  3546       obtain x y where xy: "sphere a r = {x,y}" "x \<noteq> y"
  3547         using sphere_1D_doubleton [OF 1 greater]
  3548         by (metis dist_self greater insertI1 less_add_same_cancel1 mem_sphere mult_2 not_le zero_le_dist)
  3549       then have "finite (sphere a r)"
  3550         by auto
  3551       with L \<open>r > 0\<close> xy show "False"
  3552         using connected_finite_iff_sing by auto
  3553     qed
  3554     with greater show ?rhs
  3555       by (metis DIM_ge_Suc0 One_nat_def Suc_1 le_antisym not_less_eq_eq)
  3556   next
  3557     assume ?rhs
  3558     then show ?lhs
  3559       using connected_sphere greater by auto
  3560   qed
  3561 qed
  3562 
  3563 corollary path_connected_sphere_eq:
  3564   fixes a :: "'a :: euclidean_space"
  3565   shows "path_connected(sphere a r) \<longleftrightarrow> 2 \<le> DIM('a) \<or> r \<le> 0"
  3566          (is "?lhs = ?rhs")
  3567 proof
  3568   assume ?lhs
  3569   then show ?rhs
  3570     using connected_sphere_eq path_connected_imp_connected by blast
  3571 next
  3572   assume R: ?rhs
  3573   then show ?lhs
  3574     by (auto simp: contractible_imp_path_connected contractible_sphere path_connected_sphere)
  3575 qed
  3576 
  3577 proposition frontier_subset_retraction:
  3578   fixes S :: "'a::euclidean_space set"
  3579   assumes "bounded S" and fros: "frontier S \<subseteq> T"
  3580       and contf: "continuous_on (closure S) f"
  3581       and fim: "f ` S \<subseteq> T"
  3582       and fid: "\<And>x. x \<in> T \<Longrightarrow> f x = x"
  3583     shows "S \<subseteq> T"
  3584 proof (rule ccontr)
  3585   assume "\<not> S \<subseteq> T"
  3586   then obtain a where "a \<in> S" "a \<notin> T" by blast
  3587   define g where "g \<equiv> \<lambda>z. if z \<in> closure S then f z else z"
  3588   have "continuous_on (closure S \<union> closure(-S)) g"
  3589     unfolding g_def
  3590     apply (rule continuous_on_cases)
  3591     using fros fid frontier_closures
  3592         apply (auto simp: contf continuous_on_id)
  3593     done
  3594   moreover have "closure S \<union> closure(- S) = UNIV"
  3595     using closure_Un by fastforce
  3596   ultimately have contg: "continuous_on UNIV g" by metis
  3597   obtain B where "0 < B" and B: "closure S \<subseteq> ball a B"
  3598     using \<open>bounded S\<close> bounded_subset_ballD by blast
  3599   have notga: "g x \<noteq> a" for x
  3600     unfolding g_def using fros fim \<open>a \<notin> T\<close>
  3601     apply (auto simp: frontier_def)
  3602     using fid interior_subset apply fastforce
  3603     by (simp add: \<open>a \<in> S\<close> closure_def)
  3604   define h where "h \<equiv> (\<lambda>y. a + (B / norm(y - a)) *\<^sub>R (y - a)) \<circ> g"
  3605   have "\<not> (frontier (cball a B) retract_of (cball a B))"
  3606     by (metis no_retraction_cball \<open>0 < B\<close>)
  3607   then have "\<And>k. \<not> retraction (cball a B) (frontier (cball a B)) k"
  3608     by (simp add: retract_of_def)
  3609   moreover have "retraction (cball a B) (frontier (cball a B)) h"
  3610     unfolding retraction_def
  3611   proof (intro conjI ballI)
  3612     show "frontier (cball a B) \<subseteq> cball a B"
  3613       by force
  3614     show "continuous_on (cball a B) h"
  3615       unfolding h_def
  3616       by (intro continuous_intros) (use contg continuous_on_subset notga in auto)
  3617     show "h ` cball a B \<subseteq> frontier (cball a B)"
  3618       using \<open>0 < B\<close> by (auto simp: h_def notga dist_norm)
  3619     show "\<And>x. x \<in> frontier (cball a B) \<Longrightarrow> h x = x"
  3620       apply (auto simp: h_def algebra_simps)
  3621       apply (simp add: vector_add_divide_simps  notga)
  3622       by (metis (no_types, hide_lams) B add.commute dist_commute  dist_norm g_def mem_ball not_less_iff_gr_or_eq  subset_eq)
  3623   qed
  3624   ultimately show False by simp
  3625 qed
  3626 
  3627 subsubsection \<open>Punctured affine hulls, etc\<close>
  3628 
  3629 lemma rel_frontier_deformation_retract_of_punctured_convex:
  3630   fixes S :: "'a::euclidean_space set"
  3631   assumes "convex S" "convex T" "bounded S"
  3632       and arelS: "a \<in> rel_interior S"
  3633       and relS: "rel_frontier S \<subseteq> T"
  3634       and affS: "T \<subseteq> affine hull S"
  3635   obtains r where "homotopic_with (\<lambda>x. True) (T - {a}) (T - {a}) id r"
  3636                   "retraction (T - {a}) (rel_frontier S) r"
  3637 proof -
  3638   have "\<exists>d. 0 < d \<and> (a + d *\<^sub>R l) \<in> rel_frontier S \<and>
  3639             (\<forall>e. 0 \<le> e \<and> e < d \<longrightarrow> (a + e *\<^sub>R l) \<in> rel_interior S)"
  3640        if "(a + l) \<in> affine hull S" "l \<noteq> 0" for l
  3641     apply (rule ray_to_rel_frontier [OF \<open>bounded S\<close> arelS])
  3642     apply (rule that)+
  3643     by metis
  3644   then obtain dd
  3645     where dd1: "\<And>l. \<lbrakk>(a + l) \<in> affine hull S; l \<noteq> 0\<rbrakk> \<Longrightarrow> 0 < dd l \<and> (a + dd l *\<^sub>R l) \<in> rel_frontier S"
  3646       and dd2: "\<And>l e. \<lbrakk>(a + l) \<in> affine hull S; e < dd l; 0 \<le> e; l \<noteq> 0\<rbrakk>
  3647                       \<Longrightarrow> (a + e *\<^sub>R l) \<in> rel_interior S"
  3648     by metis+
  3649   have aaffS: "a \<in> affine hull S"
  3650     by (meson arelS subsetD hull_inc rel_interior_subset)
  3651   have "((\<lambda>z. z - a) ` (affine hull S - {a})) = ((\<lambda>z. z - a) ` (affine hull S)) - {0}"
  3652     by auto
  3653   moreover have "continuous_on (((\<lambda>z. z - a) ` (affine hull S)) - {0}) (\<lambda>x. dd x *\<^sub>R x)"
  3654   proof (rule continuous_on_compact_surface_projection)
  3655     show "compact (rel_frontier ((\<lambda>z. z - a) ` S))"
  3656       by (simp add: \<open>bounded S\<close> bounded_translation_minus compact_rel_frontier_bounded)
  3657     have releq: "rel_frontier ((\<lambda>z. z - a) ` S) = (\<lambda>z. z - a) ` rel_frontier S"
  3658       using rel_frontier_translation [of "-a"] add.commute by simp
  3659     also have "\<dots> \<subseteq> (\<lambda>z. z - a) ` (affine hull S) - {0}"
  3660       using rel_frontier_affine_hull arelS rel_frontier_def by fastforce
  3661     finally show "rel_frontier ((\<lambda>z. z - a) ` S) \<subseteq> (\<lambda>z. z - a) ` (affine hull S) - {0}" .
  3662     show "cone ((\<lambda>z. z - a) ` (affine hull S))"
  3663       by (rule subspace_imp_cone)
  3664          (use aaffS in \<open>simp add: subspace_affine image_comp o_def affine_translation_aux [of a]\<close>)
  3665     show "(0 < k \<and> k *\<^sub>R x \<in> rel_frontier ((\<lambda>z. z - a) ` S)) \<longleftrightarrow> (dd x = k)"
  3666          if x: "x \<in> (\<lambda>z. z - a) ` (affine hull S) - {0}" for k x
  3667     proof
  3668       show "dd x = k \<Longrightarrow> 0 < k \<and> k *\<^sub>R x \<in> rel_frontier ((\<lambda>z. z - a) ` S)"
  3669       using dd1 [of x] that image_iff by (fastforce simp add: releq)
  3670     next
  3671       assume k: "0 < k \<and> k *\<^sub>R x \<in> rel_frontier ((\<lambda>z. z - a) ` S)"
  3672       have False if "dd x < k"
  3673       proof -
  3674         have "k \<noteq> 0" "a + k *\<^sub>R x \<in> closure S"
  3675           using k closure_translation [of "-a"]
  3676           by (auto simp: rel_frontier_def)
  3677         then have segsub: "open_segment a (a + k *\<^sub>R x) \<subseteq> rel_interior S"
  3678           by (metis rel_interior_closure_convex_segment [OF \<open>convex S\<close> arelS])
  3679         have "x \<noteq> 0" and xaffS: "a + x \<in> affine hull S"
  3680           using x by auto
  3681         then have "0 < dd x" and inS: "a + dd x *\<^sub>R x \<in> rel_frontier S"
  3682           using dd1 by auto
  3683         moreover have "a + dd x *\<^sub>R x \<in> open_segment a (a + k *\<^sub>R x)"
  3684           using k \<open>x \<noteq> 0\<close> \<open>0 < dd x\<close>
  3685           apply (simp add: in_segment)
  3686           apply (rule_tac x = "dd x / k" in exI)
  3687           apply (simp add: field_simps that)
  3688           apply (simp add: vector_add_divide_simps algebra_simps)
  3689           apply (metis (no_types) \<open>k \<noteq> 0\<close> divide_inverse_commute inverse_eq_divide mult.left_commute right_inverse)
  3690           done
  3691         ultimately show ?thesis
  3692           using segsub by (auto simp: rel_frontier_def)
  3693       qed
  3694       moreover have False if "k < dd x"
  3695         using x k that rel_frontier_def
  3696         by (fastforce simp: algebra_simps releq dest!: dd2)
  3697       ultimately show "dd x = k"
  3698         by fastforce
  3699     qed
  3700   qed
  3701   ultimately have *: "continuous_on ((\<lambda>z. z - a) ` (affine hull S - {a})) (\<lambda>x. dd x *\<^sub>R x)"
  3702     by auto
  3703   have "continuous_on (affine hull S - {a}) ((\<lambda>x. a + dd x *\<^sub>R x) \<circ> (\<lambda>z. z - a))"
  3704     by (intro * continuous_intros continuous_on_compose)
  3705   with affS have contdd: "continuous_on (T - {a}) ((\<lambda>x. a + dd x *\<^sub>R x) \<circ> (\<lambda>z. z - a))"
  3706     by (blast intro: continuous_on_subset)
  3707   show ?thesis
  3708   proof
  3709     show "homotopic_with (\<lambda>x. True) (T - {a}) (T - {a}) id (\<lambda>x. a + dd (x - a) *\<^sub>R (x - a))"
  3710     proof (rule homotopic_with_linear)
  3711       show "continuous_on (T - {a}) id"
  3712         by (intro continuous_intros continuous_on_compose)
  3713       show "continuous_on (T - {a}) (\<lambda>x. a + dd (x - a) *\<^sub>R (x - a))"
  3714         using contdd by (simp add: o_def)
  3715       show "closed_segment (id x) (a + dd (x - a) *\<^sub>R (x - a)) \<subseteq> T - {a}"
  3716            if "x \<in> T - {a}" for x
  3717       proof (clarsimp simp: in_segment, intro conjI)
  3718         fix u::real assume u: "0 \<le> u" "u \<le> 1"
  3719         have "a + dd (x - a) *\<^sub>R (x - a) \<in> T"
  3720           by (metis DiffD1 DiffD2 add.commute add.right_neutral affS dd1 diff_add_cancel relS singletonI subsetCE that)
  3721         then show "(1 - u) *\<^sub>R x + u *\<^sub>R (a + dd (x - a) *\<^sub>R (x - a)) \<in> T"
  3722           using convexD [OF \<open>convex T\<close>] that u by simp
  3723         have iff: "(1 - u) *\<^sub>R x + u *\<^sub>R (a + d *\<^sub>R (x - a)) = a \<longleftrightarrow>
  3724                   (1 - u + u * d) *\<^sub>R (x - a) = 0" for d
  3725           by (auto simp: algebra_simps)
  3726         have "x \<in> T" "x \<noteq> a" using that by auto
  3727         then have axa: "a + (x - a) \<in> affine hull S"
  3728            by (metis (no_types) add.commute affS diff_add_cancel set_rev_mp)
  3729         then have "\<not> dd (x - a) \<le> 0 \<and> a + dd (x - a) *\<^sub>R (x - a) \<in> rel_frontier S"
  3730           using \<open>x \<noteq> a\<close> dd1 by fastforce
  3731         with \<open>x \<noteq> a\<close> show "(1 - u) *\<^sub>R x + u *\<^sub>R (a + dd (x - a) *\<^sub>R (x - a)) \<noteq> a"
  3732           apply (auto simp: iff)
  3733           using less_eq_real_def mult_le_0_iff not_less u by fastforce
  3734       qed
  3735     qed
  3736     show "retraction (T - {a}) (rel_frontier S) (\<lambda>x. a + dd (x - a) *\<^sub>R (x - a))"
  3737     proof (simp add: retraction_def, intro conjI ballI)
  3738       show "rel_frontier S \<subseteq> T - {a}"
  3739         using arelS relS rel_frontier_def by fastforce
  3740       show "continuous_on (T - {a}) (\<lambda>x. a + dd (x - a) *\<^sub>R (x - a))"
  3741         using contdd by (simp add: o_def)
  3742       show "(\<lambda>x. a + dd (x - a) *\<^sub>R (x - a)) ` (T - {a}) \<subseteq> rel_frontier S"
  3743         apply (auto simp: rel_frontier_def)
  3744         apply (metis Diff_subset add.commute affS dd1 diff_add_cancel eq_iff_diff_eq_0 rel_frontier_def subset_iff)
  3745         by (metis DiffE add.commute affS dd1 diff_add_cancel eq_iff_diff_eq_0 rel_frontier_def rev_subsetD)
  3746       show "a + dd (x - a) *\<^sub>R (x - a) = x" if x: "x \<in> rel_frontier S" for x
  3747       proof -
  3748         have "x \<noteq> a"
  3749           using that arelS by (auto simp: rel_frontier_def)
  3750         have False if "dd (x - a) < 1"
  3751         proof -
  3752           have "x \<in> closure S"
  3753             using x by (auto simp: rel_frontier_def)
  3754           then have segsub: "open_segment a x \<subseteq> rel_interior S"
  3755             by (metis rel_interior_closure_convex_segment [OF \<open>convex S\<close> arelS])
  3756           have  xaffS: "x \<in> affine hull S"
  3757             using affS relS x by auto
  3758           then have "0 < dd (x - a)" and inS: "a + dd (x - a) *\<^sub>R (x - a) \<in> rel_frontier S"
  3759             using dd1 by (auto simp: \<open>x \<noteq> a\<close>)
  3760           moreover have "a + dd (x - a) *\<^sub>R (x - a) \<in> open_segment a x"
  3761             using  \<open>x \<noteq> a\<close> \<open>0 < dd (x - a)\<close>
  3762             apply (simp add: in_segment)
  3763             apply (rule_tac x = "dd (x - a)" in exI)
  3764             apply (simp add: algebra_simps that)
  3765             done
  3766           ultimately show ?thesis
  3767             using segsub by (auto simp: rel_frontier_def)
  3768         qed
  3769         moreover have False if "1 < dd (x - a)"
  3770           using x that dd2 [of "x - a" 1] \<open>x \<noteq> a\<close> closure_affine_hull
  3771           by (auto simp: rel_frontier_def)
  3772         ultimately have "dd (x - a) = 1" \<comment> \<open>similar to another proof above\<close>
  3773           by fastforce
  3774         with that show ?thesis
  3775           by (simp add: rel_frontier_def)
  3776       qed
  3777     qed
  3778   qed
  3779 qed
  3780 
  3781 corollary rel_frontier_retract_of_punctured_affine_hull:
  3782   fixes S :: "'a::euclidean_space set"
  3783   assumes "bounded S" "convex S" "a \<in> rel_interior S"
  3784     shows "rel_frontier S retract_of (affine hull S - {a})"
  3785 apply (rule rel_frontier_deformation_retract_of_punctured_convex [of S "affine hull S" a])
  3786 apply (auto simp: affine_imp_convex rel_frontier_affine_hull retract_of_def assms)
  3787 done
  3788 
  3789 corollary rel_boundary_retract_of_punctured_affine_hull:
  3790   fixes S :: "'a::euclidean_space set"
  3791   assumes "compact S" "convex S" "a \<in> rel_interior S"
  3792     shows "(S - rel_interior S) retract_of (affine hull S - {a})"
  3793 by (metis assms closure_closed compact_eq_bounded_closed rel_frontier_def
  3794           rel_frontier_retract_of_punctured_affine_hull)
  3795 
  3796 lemma homotopy_eqv_rel_frontier_punctured_convex:
  3797   fixes S :: "'a::euclidean_space set"
  3798   assumes "convex S" "bounded S" "a \<in> rel_interior S" "convex T" "rel_frontier S \<subseteq> T" "T \<subseteq> affine hull S"
  3799   shows "(rel_frontier S) homotopy_eqv (T - {a})"
  3800   apply (rule rel_frontier_deformation_retract_of_punctured_convex [of S T])
  3801   using assms
  3802   apply auto
  3803   apply (subst homotopy_eqv_sym)
  3804   using deformation_retract_imp_homotopy_eqv by blast
  3805 
  3806 lemma homotopy_eqv_rel_frontier_punctured_affine_hull:
  3807   fixes S :: "'a::euclidean_space set"
  3808   assumes "convex S" "bounded S" "a \<in> rel_interior S"
  3809     shows "(rel_frontier S) homotopy_eqv (affine hull S - {a})"
  3810 apply (rule homotopy_eqv_rel_frontier_punctured_convex)
  3811   using assms rel_frontier_affine_hull  by force+
  3812 
  3813 lemma path_connected_sphere_gen:
  3814   assumes "convex S" "bounded S" "aff_dim S \<noteq> 1"
  3815   shows "path_connected(rel_frontier S)"
  3816 proof (cases "rel_interior S = {}")
  3817   case True
  3818   then show ?thesis
  3819     by (simp add: \<open>convex S\<close> convex_imp_path_connected rel_frontier_def)
  3820 next
  3821   case False
  3822   then show ?thesis
  3823     by (metis aff_dim_affine_hull affine_affine_hull affine_imp_convex all_not_in_conv assms path_connected_punctured_convex rel_frontier_retract_of_punctured_affine_hull retract_of_path_connected)
  3824 qed
  3825 
  3826 lemma connected_sphere_gen:
  3827   assumes "convex S" "bounded S" "aff_dim S \<noteq> 1"
  3828   shows "connected(rel_frontier S)"
  3829   by (simp add: assms path_connected_imp_connected path_connected_sphere_gen)
  3830 
  3831 subsubsection\<open>Borsuk-style characterization of separation\<close>
  3832 
  3833 lemma continuous_on_Borsuk_map:
  3834    "a \<notin> s \<Longrightarrow>  continuous_on s (\<lambda>x. inverse(norm (x - a)) *\<^sub>R (x - a))"
  3835 by (rule continuous_intros | force)+
  3836 
  3837 lemma Borsuk_map_into_sphere:
  3838    "(\<lambda>x. inverse(norm (x - a)) *\<^sub>R (x - a)) ` s \<subseteq> sphere 0 1 \<longleftrightarrow> (a \<notin> s)"
  3839   by auto (metis eq_iff_diff_eq_0 left_inverse norm_eq_zero)
  3840 
  3841 lemma Borsuk_maps_homotopic_in_path_component:
  3842   assumes "path_component (- s) a b"
  3843     shows "homotopic_with (\<lambda>x. True) s (sphere 0 1)
  3844                    (\<lambda>x. inverse(norm(x - a)) *\<^sub>R (x - a))
  3845                    (\<lambda>x. inverse(norm(x - b)) *\<^sub>R (x - b))"
  3846 proof -
  3847   obtain g where "path g" "path_image g \<subseteq> -s" "pathstart g = a" "pathfinish g = b"
  3848     using assms by (auto simp: path_component_def)
  3849   then show ?thesis
  3850     apply (simp add: path_def path_image_def pathstart_def pathfinish_def homotopic_with_def)
  3851     apply (rule_tac x = "\<lambda>z. inverse(norm(snd z - (g \<circ> fst)z)) *\<^sub>R (snd z - (g \<circ> fst)z)" in exI)
  3852     apply (intro conjI continuous_intros)
  3853     apply (rule continuous_intros | erule continuous_on_subset | fastforce simp: divide_simps sphere_def)+
  3854     done
  3855 qed
  3856 
  3857 lemma non_extensible_Borsuk_map:
  3858   fixes a :: "'a :: euclidean_space"
  3859   assumes "compact s" and cin: "c \<in> components(- s)" and boc: "bounded c" and "a \<in> c"
  3860     shows "~ (\<exists>g. continuous_on (s \<union> c) g \<and>
  3861                   g ` (s \<union> c) \<subseteq> sphere 0 1 \<and>
  3862                   (\<forall>x \<in> s. g x = inverse(norm(x - a)) *\<^sub>R (x - a)))"
  3863 proof -
  3864   have "closed s" using assms by (simp add: compact_imp_closed)
  3865   have "c \<subseteq> -s"
  3866     using assms by (simp add: in_components_subset)
  3867   with \<open>a \<in> c\<close> have "a \<notin> s" by blast
  3868   then have ceq: "c = connected_component_set (- s) a"
  3869     by (metis \<open>a \<in> c\<close> cin components_iff connected_component_eq)
  3870   then have "bounded (s \<union> connected_component_set (- s) a)"
  3871     using \<open>compact s\<close> boc compact_imp_bounded by auto
  3872   with bounded_subset_ballD obtain r where "0 < r" and r: "(s \<union> connected_component_set (- s) a) \<subseteq> ball a r"
  3873     by blast
  3874   { fix g
  3875     assume "continuous_on (s \<union> c) g"
  3876             "g ` (s \<union> c) \<subseteq> sphere 0 1"
  3877        and [simp]: "\<And>x. x \<in> s \<Longrightarrow> g x = (x - a) /\<^sub>R norm (x - a)"
  3878     then have [simp]: "\<And>x. x \<in> s \<union> c \<Longrightarrow> norm (g x) = 1"
  3879       by force
  3880     have cb_eq: "cball a r = (s \<union> connected_component_set (- s) a) \<union>
  3881                       (cball a r - connected_component_set (- s) a)"
  3882       using ball_subset_cball [of a r] r by auto
  3883     have cont1: "continuous_on (s \<union> connected_component_set (- s) a)
  3884                      (\<lambda>x. a + r *\<^sub>R g x)"
  3885       apply (rule continuous_intros)+
  3886       using \<open>continuous_on (s \<union> c) g\<close> ceq by blast
  3887     have cont2: "continuous_on (cball a r - connected_component_set (- s) a)
  3888             (\<lambda>x. a + r *\<^sub>R ((x - a) /\<^sub>R norm (x - a)))"
  3889       by (rule continuous_intros | force simp: \<open>a \<notin> s\<close>)+
  3890     have 1: "continuous_on (cball a r)
  3891              (\<lambda>x. if connected_component (- s) a x
  3892                   then a + r *\<^sub>R g x
  3893                   else a + r *\<^sub>R ((x - a) /\<^sub>R norm (x - a)))"
  3894       apply (subst cb_eq)
  3895       apply (rule continuous_on_cases [OF _ _ cont1 cont2])
  3896         using ceq cin
  3897       apply (auto intro: closed_Un_complement_component
  3898                   simp: \<open>closed s\<close> open_Compl open_connected_component)
  3899       done
  3900     have 2: "(\<lambda>x. a + r *\<^sub>R g x) ` (cball a r \<inter> connected_component_set (- s) a)
  3901              \<subseteq> sphere a r "
  3902       using \<open>0 < r\<close> by (force simp: dist_norm ceq)
  3903     have "retraction (cball a r) (sphere a r)
  3904             (\<lambda>x. if x \<in> connected_component_set (- s) a
  3905                  then a + r *\<^sub>R g x
  3906                  else a + r *\<^sub>R ((x - a) /\<^sub>R norm (x - a)))"
  3907       using  \<open>0 < r\<close>
  3908       apply (simp add: retraction_def dist_norm 1 2, safe)
  3909       apply (force simp: dist_norm abs_if mult_less_0_iff divide_simps \<open>a \<notin> s\<close>)
  3910       using r
  3911       by (auto simp: dist_norm norm_minus_commute)
  3912     then have False
  3913       using no_retraction_cball
  3914              [OF \<open>0 < r\<close>, of a, unfolded retract_of_def, simplified, rule_format,
  3915               of "\<lambda>x. if x \<in> connected_component_set (- s) a
  3916                       then a + r *\<^sub>R g x
  3917                       else a + r *\<^sub>R inverse(norm(x - a)) *\<^sub>R (x - a)"]
  3918       by blast
  3919   }
  3920   then show ?thesis
  3921     by blast
  3922 qed
  3923 
  3924 subsubsection  \<open>We continue with ANRs and ENRs\<close>
  3925 
  3926 lemma ENR_rel_frontier_convex:
  3927   fixes S :: "'a::euclidean_space set"
  3928   assumes "bounded S" "convex S"
  3929     shows "ENR(rel_frontier S)"
  3930 proof (cases "S = {}")
  3931   case True then show ?thesis
  3932     by simp
  3933 next
  3934   case False
  3935   with assms have "rel_interior S \<noteq> {}"
  3936     by (simp add: rel_interior_eq_empty)
  3937   then obtain a where a: "a \<in> rel_interior S"
  3938     by auto
  3939   have ahS: "affine hull S - {a} \<subseteq> {x. closest_point (affine hull S) x \<noteq> a}"
  3940     by (auto simp: closest_point_self)
  3941   have "rel_frontier S retract_of affine hull S - {a}"
  3942     by (simp add: assms a rel_frontier_retract_of_punctured_affine_hull)
  3943   also have "\<dots> retract_of {x. closest_point (affine hull S) x \<noteq> a}"
  3944     apply (simp add: retract_of_def retraction_def ahS)
  3945     apply (rule_tac x="closest_point (affine hull S)" in exI)
  3946     apply (auto simp: False closest_point_self affine_imp_convex closest_point_in_set continuous_on_closest_point)
  3947     done
  3948   finally have "rel_frontier S retract_of {x. closest_point (affine hull S) x \<noteq> a}" .
  3949   moreover have "openin (subtopology euclidean UNIV) (UNIV \<inter> closest_point (affine hull S) -` (- {a}))"
  3950     apply (rule continuous_openin_preimage_gen)
  3951     apply (auto simp: False affine_imp_convex continuous_on_closest_point)
  3952     done
  3953   ultimately show ?thesis
  3954     unfolding ENR_def
  3955     apply (rule_tac x = "closest_point (affine hull S) -` (- {a})" in exI)
  3956     apply (simp add: vimage_def)
  3957     done
  3958 qed
  3959 
  3960 lemma ANR_rel_frontier_convex:
  3961                  fixes S :: "'a::euclidean_space set"
  3962   assumes "bounded S" "convex S"
  3963     shows "ANR(rel_frontier S)"
  3964 by (simp add: ENR_imp_ANR ENR_rel_frontier_convex assms)
  3965     
  3966 lemma ENR_closedin_Un_local:
  3967   fixes S :: "'a::euclidean_space set"
  3968   shows "\<lbrakk>ENR S; ENR T; ENR(S \<inter> T);
  3969           closedin (subtopology euclidean (S \<union> T)) S; closedin (subtopology euclidean (S \<union> T)) T\<rbrakk>
  3970         \<Longrightarrow> ENR(S \<union> T)"
  3971 by (simp add: ENR_ANR ANR_closed_Un_local locally_compact_closedin_Un)
  3972 
  3973 lemma ENR_closed_Un:
  3974   fixes S :: "'a::euclidean_space set"
  3975   shows "\<lbrakk>closed S; closed T; ENR S; ENR T; ENR(S \<inter> T)\<rbrakk> \<Longrightarrow> ENR(S \<union> T)"
  3976 by (auto simp: closed_subset ENR_closedin_Un_local)
  3977 
  3978 lemma absolute_retract_Un:
  3979   fixes S :: "'a::euclidean_space set"
  3980   shows "\<lbrakk>S retract_of UNIV; T retract_of UNIV; (S \<inter> T) retract_of UNIV\<rbrakk>
  3981          \<Longrightarrow> (S \<union> T) retract_of UNIV"
  3982   by (meson AR_closed_Un_local_aux closed_subset retract_of_UNIV retract_of_imp_subset)
  3983 
  3984 lemma retract_from_Un_Int:
  3985   fixes S :: "'a::euclidean_space set"
  3986   assumes clS: "closedin (subtopology euclidean (S \<union> T)) S"
  3987       and clT: "closedin (subtopology euclidean (S \<union> T)) T"
  3988       and Un: "(S \<union> T) retract_of U" and Int: "(S \<inter> T) retract_of T"
  3989     shows "S retract_of U"
  3990 proof -
  3991   obtain r where r: "continuous_on T r" "r ` T \<subseteq> S \<inter> T" "\<forall>x\<in>S \<inter> T. r x = x"
  3992     using Int by (auto simp: retraction_def retract_of_def)
  3993   have "S retract_of S \<union> T"
  3994     unfolding retraction_def retract_of_def
  3995   proof (intro exI conjI)
  3996     show "continuous_on (S \<union> T) (\<lambda>x. if x \<in> S then x else r x)"
  3997       apply (rule continuous_on_cases_local [OF clS clT])
  3998       using r by (auto simp: continuous_on_id)
  3999   qed (use r in auto)
  4000   also have "\<dots> retract_of U"
  4001     by (rule Un)
  4002   finally show ?thesis .
  4003 qed
  4004 
  4005 lemma AR_from_Un_Int_local:
  4006   fixes S :: "'a::euclidean_space set"
  4007   assumes clS: "closedin (subtopology euclidean (S \<union> T)) S"
  4008       and clT: "closedin (subtopology euclidean (S \<union> T)) T"
  4009       and Un: "AR(S \<union> T)" and Int: "AR(S \<inter> T)"
  4010     shows "AR S"
  4011   apply (rule AR_retract_of_AR [OF Un])
  4012   by (meson AR_imp_retract clS clT closedin_closed_subset local.Int retract_from_Un_Int retract_of_refl sup_ge2)
  4013 
  4014 lemma AR_from_Un_Int_local':
  4015   fixes S :: "'a::euclidean_space set"
  4016   assumes "closedin (subtopology euclidean (S \<union> T)) S"
  4017       and "closedin (subtopology euclidean (S \<union> T)) T"
  4018       and "AR(S \<union> T)" "AR(S \<inter> T)"
  4019     shows "AR T"
  4020   using AR_from_Un_Int_local [of T S] assms by (simp add: Un_commute Int_commute)
  4021 
  4022 lemma AR_from_Un_Int:
  4023   fixes S :: "'a::euclidean_space set"
  4024   assumes clo: "closed S" "closed T" and Un: "AR(S \<union> T)" and Int: "AR(S \<inter> T)"
  4025   shows "AR S"
  4026   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)
  4027 
  4028 lemma ANR_from_Un_Int_local:
  4029   fixes S :: "'a::euclidean_space set"
  4030   assumes clS: "closedin (subtopology euclidean (S \<union> T)) S"
  4031       and clT: "closedin (subtopology euclidean (S \<union> T)) T"
  4032       and Un: "ANR(S \<union> T)" and Int: "ANR(S \<inter> T)"
  4033     shows "ANR S"
  4034 proof -
  4035   obtain V where clo: "closedin (subtopology euclidean (S \<union> T)) (S \<inter> T)"
  4036              and ope: "openin (subtopology euclidean (S \<union> T)) V"
  4037              and ret: "S \<inter> T retract_of V"
  4038     using ANR_imp_neighbourhood_retract [OF Int] by (metis clS clT closedin_Int)
  4039   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"
  4040     by (auto simp: retraction_def retract_of_def)
  4041   have Vsub: "V \<subseteq> S \<union> T"
  4042     by (meson ope openin_contains_cball)
  4043   have Vsup: "S \<inter> T \<subseteq> V"
  4044     by (simp add: retract_of_imp_subset ret)
  4045   then have eq: "S \<union> V = ((S \<union> T) - T) \<union> V"
  4046     by auto
  4047   have eq': "S \<union> V = S \<union> (V \<inter> T)"
  4048     using Vsub by blast
  4049   have "continuous_on (S \<union> V \<inter> T) (\<lambda>x. if x \<in> S then x else r x)"
  4050   proof (rule continuous_on_cases_local)
  4051     show "closedin (subtopology euclidean (S \<union> V \<inter> T)) S"
  4052       using clS closedin_subset_trans inf.boundedE by blast
  4053     show "closedin (subtopology euclidean (S \<union> V \<inter> T)) (V \<inter> T)"
  4054       using clT Vsup by (auto simp: closedin_closed)
  4055     show "continuous_on (V \<inter> T) r"
  4056       by (meson Int_lower1 continuous_on_subset r)
  4057   qed (use req continuous_on_id in auto)
  4058   with rim have "S retract_of S \<union> V"
  4059     unfolding retraction_def retract_of_def
  4060     apply (rule_tac x="\<lambda>x. if x \<in> S then x else r x" in exI)
  4061     apply (auto simp: eq')
  4062     done
  4063   then show ?thesis
  4064     using ANR_neighborhood_retract [OF Un]
  4065     using \<open>S \<union> V = S \<union> T - T \<union> V\<close> clT ope by fastforce
  4066 qed
  4067 
  4068 lemma ANR_from_Un_Int:
  4069   fixes S :: "'a::euclidean_space set"
  4070   assumes clo: "closed S" "closed T" and Un: "ANR(S \<union> T)" and Int: "ANR(S \<inter> T)"
  4071   shows "ANR S"
  4072   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)
  4073 
  4074 lemma ANR_finite_Union_convex_closed:
  4075   fixes \<T> :: "'a::euclidean_space set set"
  4076   assumes \<T>: "finite \<T>" and clo: "\<And>C. C \<in> \<T> \<Longrightarrow> closed C" and con: "\<And>C. C \<in> \<T> \<Longrightarrow> convex C"
  4077   shows "ANR(\<Union>\<T>)"
  4078 proof -
  4079   have "ANR(\<Union>\<T>)" if "card \<T> < n" for n
  4080   using assms that
  4081   proof (induction n arbitrary: \<T>)
  4082     case 0 then show ?case by simp
  4083   next
  4084     case (Suc n)
  4085     have "ANR(\<Union>\<U>)" if "finite \<U>" "\<U> \<subseteq> \<T>" for \<U>
  4086       using that
  4087     proof (induction \<U>)
  4088       case empty
  4089       then show ?case  by simp
  4090     next
  4091       case (insert C \<U>)
  4092       have "ANR (C \<union> \<Union>\<U>)"
  4093       proof (rule ANR_closed_Un)
  4094         show "ANR (C \<inter> \<Union>\<U>)"
  4095           unfolding Int_Union
  4096         proof (rule Suc)
  4097           show "finite ((\<inter>) C ` \<U>)"
  4098             by (simp add: insert.hyps(1))
  4099           show "\<And>Ca. Ca \<in> (\<inter>) C ` \<U> \<Longrightarrow> closed Ca"
  4100             by (metis (no_types, hide_lams) Suc.prems(2) closed_Int subsetD imageE insert.prems insertI1 insertI2)
  4101           show "\<And>Ca. Ca \<in> (\<inter>) C ` \<U> \<Longrightarrow> convex Ca"
  4102             by (metis (mono_tags, lifting) Suc.prems(3) convex_Int imageE insert.prems insert_subset subsetCE)
  4103           show "card ((\<inter>) C ` \<U>) < n"
  4104           proof -
  4105             have "card \<T> \<le> n"
  4106               by (meson Suc.prems(4) not_less not_less_eq)
  4107             then show ?thesis
  4108               by (metis Suc.prems(1) card_image_le card_seteq insert.hyps insert.prems insert_subset le_trans not_less)
  4109           qed
  4110         qed
  4111         show "closed (\<Union>\<U>)"
  4112           using Suc.prems(2) insert.hyps(1) insert.prems by blast
  4113       qed (use Suc.prems convex_imp_ANR insert.prems insert.IH in auto)
  4114       then show ?case
  4115         by simp
  4116     qed
  4117     then show ?case
  4118       using Suc.prems(1) by blast
  4119   qed
  4120   then show ?thesis
  4121     by blast
  4122 qed
  4123 
  4124 
  4125 lemma finite_imp_ANR:
  4126   fixes S :: "'a::euclidean_space set"
  4127   assumes "finite S"
  4128   shows "ANR S"
  4129 proof -
  4130   have "ANR(\<Union>x \<in> S. {x})"
  4131     by (blast intro: ANR_finite_Union_convex_closed assms)
  4132   then show ?thesis
  4133     by simp
  4134 qed
  4135 
  4136 lemma ANR_insert:
  4137   fixes S :: "'a::euclidean_space set"
  4138   assumes "ANR S" "closed S"
  4139   shows "ANR(insert a S)"
  4140   by (metis ANR_closed_Un ANR_empty ANR_singleton Diff_disjoint Diff_insert_absorb assms closed_singleton insert_absorb insert_is_Un)
  4141 
  4142 lemma ANR_path_component_ANR:
  4143   fixes S :: "'a::euclidean_space set"
  4144   shows "ANR S \<Longrightarrow> ANR(path_component_set S x)"
  4145   using ANR_imp_locally_path_connected ANR_openin openin_path_component_locally_path_connected by blast
  4146 
  4147 lemma ANR_connected_component_ANR:
  4148   fixes S :: "'a::euclidean_space set"
  4149   shows "ANR S \<Longrightarrow> ANR(connected_component_set S x)"
  4150   by (metis ANR_openin openin_connected_component_locally_connected ANR_imp_locally_connected)
  4151 
  4152 lemma ANR_component_ANR:
  4153   fixes S :: "'a::euclidean_space set"
  4154   assumes "ANR S" "c \<in> components S"
  4155   shows "ANR c"
  4156   by (metis ANR_connected_component_ANR assms componentsE)
  4157 
  4158 subsubsection\<open>Original ANR material, now for ENRs\<close>
  4159 
  4160 lemma ENR_bounded:
  4161   fixes S :: "'a::euclidean_space set"
  4162   assumes "bounded S"
  4163   shows "ENR S \<longleftrightarrow> (\<exists>U. open U \<and> bounded U \<and> S retract_of U)"
  4164          (is "?lhs = ?rhs")
  4165 proof
  4166   obtain r where "0 < r" and r: "S \<subseteq> ball 0 r"
  4167     using bounded_subset_ballD assms by blast
  4168   assume ?lhs
  4169   then show ?rhs
  4170     apply (clarsimp simp: ENR_def)
  4171     apply (rule_tac x="ball 0 r \<inter> U" in exI, auto)
  4172     using r retract_of_imp_subset retract_of_subset by fastforce
  4173 next
  4174   assume ?rhs
  4175   then show ?lhs
  4176     using ENR_def by blast
  4177 qed
  4178 
  4179 lemma absolute_retract_imp_AR_gen:
  4180   fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
  4181   assumes "S retract_of T" "convex T" "T \<noteq> {}" "S homeomorphic S'" "closedin (subtopology euclidean U) S'"
  4182   shows "S' retract_of U"
  4183 proof -
  4184   have "AR T"
  4185     by (simp add: assms convex_imp_AR)
  4186   then have "AR S"
  4187     using AR_retract_of_AR assms by auto
  4188   then show ?thesis
  4189     using assms AR_imp_absolute_retract by metis
  4190 qed
  4191 
  4192 lemma absolute_retract_imp_AR:
  4193   fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
  4194   assumes "S retract_of UNIV" "S homeomorphic S'" "closed S'"
  4195   shows "S' retract_of UNIV"
  4196   using AR_imp_absolute_retract_UNIV assms retract_of_UNIV by blast
  4197 
  4198 lemma homeomorphic_compact_arness:
  4199   fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
  4200   assumes "S homeomorphic S'"
  4201   shows "compact S \<and> S retract_of UNIV \<longleftrightarrow> compact S' \<and> S' retract_of UNIV"
  4202   using assms homeomorphic_compactness
  4203   apply auto
  4204    apply (meson assms compact_AR homeomorphic_AR_iff_AR homeomorphic_compactness)+
  4205   done
  4206 
  4207 lemma absolute_retract_from_Un_Int:
  4208   fixes S :: "'a::euclidean_space set"
  4209   assumes "(S \<union> T) retract_of UNIV" "(S \<inter> T) retract_of UNIV" "closed S" "closed T"
  4210   shows "S retract_of UNIV"
  4211   using AR_from_Un_Int assms retract_of_UNIV by auto
  4212 
  4213 lemma ENR_from_Un_Int_gen:
  4214   fixes S :: "'a::euclidean_space set"
  4215   assumes "closedin (subtopology euclidean (S \<union> T)) S" "closedin (subtopology euclidean (S \<union> T)) T" "ENR(S \<union> T)" "ENR(S \<inter> T)"
  4216   shows "ENR S"
  4217   apply (simp add: ENR_ANR)
  4218   using ANR_from_Un_Int_local ENR_ANR assms locally_compact_closedin by blast
  4219 
  4220 
  4221 lemma ENR_from_Un_Int:
  4222   fixes S :: "'a::euclidean_space set"
  4223   assumes "closed S" "closed T" "ENR(S \<union> T)" "ENR(S \<inter> T)"
  4224   shows "ENR S"
  4225   by (meson ENR_from_Un_Int_gen assms closed_subset sup_ge1 sup_ge2)
  4226 
  4227 
  4228 lemma ENR_finite_Union_convex_closed:
  4229   fixes \<T> :: "'a::euclidean_space set set"
  4230   assumes \<T>: "finite \<T>" and clo: "\<And>C. C \<in> \<T> \<Longrightarrow> closed C" and con: "\<And>C. C \<in> \<T> \<Longrightarrow> convex C"
  4231   shows "ENR(\<Union> \<T>)"
  4232   by (simp add: ENR_ANR ANR_finite_Union_convex_closed \<T> clo closed_Union closed_imp_locally_compact con)
  4233 
  4234 lemma finite_imp_ENR:
  4235   fixes S :: "'a::euclidean_space set"
  4236   shows "finite S \<Longrightarrow> ENR S"
  4237   by (simp add: ENR_ANR finite_imp_ANR finite_imp_closed closed_imp_locally_compact)
  4238 
  4239 lemma ENR_insert:
  4240   fixes S :: "'a::euclidean_space set"
  4241   assumes "closed S" "ENR S"
  4242   shows "ENR(insert a S)"
  4243 proof -
  4244   have "ENR ({a} \<union> S)"
  4245     by (metis ANR_insert ENR_ANR Un_commute Un_insert_right assms closed_imp_locally_compact closed_insert sup_bot_right)
  4246   then show ?thesis
  4247     by auto
  4248 qed
  4249 
  4250 lemma ENR_path_component_ENR:
  4251   fixes S :: "'a::euclidean_space set"
  4252   assumes "ENR S"
  4253   shows "ENR(path_component_set S x)"
  4254   by (metis ANR_imp_locally_path_connected ENR_empty ENR_imp_ANR ENR_openin assms
  4255             locally_path_connected_2 openin_subtopology_self path_component_eq_empty)
  4256 
  4257 (*UNUSED
  4258 lemma ENR_Times:
  4259   fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
  4260   assumes "ENR S" "ENR T" shows "ENR(S \<times> T)"
  4261 using assms apply (simp add: ENR_ANR ANR_Times)
  4262 thm locally_compact_Times
  4263 oops
  4264   SIMP_TAC[ENR_ANR; ANR_PCROSS; LOCALLY_COMPACT_PCROSS]);;
  4265 *)
  4266 
  4267 subsubsection\<open>Finally, spheres are ANRs and ENRs\<close>
  4268 
  4269 lemma absolute_retract_homeomorphic_convex_compact:
  4270   fixes S :: "'a::euclidean_space set" and U :: "'b::euclidean_space set"
  4271   assumes "S homeomorphic U" "S \<noteq> {}" "S \<subseteq> T" "convex U" "compact U"
  4272   shows "S retract_of T"
  4273   by (metis UNIV_I assms compact_AR convex_imp_AR homeomorphic_AR_iff_AR homeomorphic_compactness homeomorphic_empty(1) retract_of_subset subsetI)
  4274 
  4275 lemma frontier_retract_of_punctured_universe:
  4276   fixes S :: "'a::euclidean_space set"
  4277   assumes "convex S" "bounded S" "a \<in> interior S"
  4278   shows "(frontier S) retract_of (- {a})"
  4279   using rel_frontier_retract_of_punctured_affine_hull
  4280   by (metis Compl_eq_Diff_UNIV affine_hull_nonempty_interior assms empty_iff rel_frontier_frontier rel_interior_nonempty_interior)
  4281 
  4282 lemma sphere_retract_of_punctured_universe_gen:
  4283   fixes a :: "'a::euclidean_space"
  4284   assumes "b \<in> ball a r"
  4285   shows  "sphere a r retract_of (- {b})"
  4286 proof -
  4287   have "frontier (cball a r) retract_of (- {b})"
  4288     apply (rule frontier_retract_of_punctured_universe)
  4289     using assms by auto
  4290   then show ?thesis
  4291     by simp
  4292 qed
  4293 
  4294 lemma sphere_retract_of_punctured_universe:
  4295   fixes a :: "'a::euclidean_space"
  4296   assumes "0 < r"
  4297   shows "sphere a r retract_of (- {a})"
  4298   by (simp add: assms sphere_retract_of_punctured_universe_gen)
  4299 
  4300 lemma ENR_sphere:
  4301   fixes a :: "'a::euclidean_space"
  4302   shows "ENR(sphere a r)"
  4303 proof (cases "0 < r")
  4304   case True
  4305   then have "sphere a r retract_of -{a}"
  4306     by (simp add: sphere_retract_of_punctured_universe)
  4307   with open_delete show ?thesis
  4308     by (auto simp: ENR_def)
  4309 next
  4310   case False
  4311   then show ?thesis
  4312     using finite_imp_ENR
  4313     by (metis finite_insert infinite_imp_nonempty less_linear sphere_eq_empty sphere_trivial)
  4314 qed
  4315 
  4316 corollary%unimportant ANR_sphere:
  4317   fixes a :: "'a::euclidean_space"
  4318   shows "ANR(sphere a r)"
  4319   by (simp add: ENR_imp_ANR ENR_sphere)
  4320 
  4321 subsubsection\<open>Spheres are connected, etc\<close>
  4322 
  4323 lemma locally_path_connected_sphere_gen:
  4324   fixes S :: "'a::euclidean_space set"
  4325   assumes "bounded S" and "convex S" 
  4326   shows "locally path_connected (rel_frontier S)"
  4327 proof (cases "rel_interior S = {}")
  4328   case True
  4329   with assms show ?thesis
  4330     by (simp add: rel_interior_eq_empty)
  4331 next
  4332   case False
  4333   then obtain a where a: "a \<in> rel_interior S"
  4334     by blast
  4335   show ?thesis
  4336   proof (rule retract_of_locally_path_connected)
  4337     show "locally path_connected (affine hull S - {a})"
  4338       by (meson convex_affine_hull convex_imp_locally_path_connected locally_open_subset openin_delete openin_subtopology_self)
  4339     show "rel_frontier S retract_of affine hull S - {a}"
  4340       using a assms rel_frontier_retract_of_punctured_affine_hull by blast
  4341   qed
  4342 qed
  4343 
  4344 lemma locally_connected_sphere_gen:
  4345   fixes S :: "'a::euclidean_space set"
  4346   assumes "bounded S" and "convex S" 
  4347   shows "locally connected (rel_frontier S)"
  4348   by (simp add: ANR_imp_locally_connected ANR_rel_frontier_convex assms)
  4349 
  4350 lemma locally_path_connected_sphere:
  4351   fixes a :: "'a::euclidean_space"
  4352   shows "locally path_connected (sphere a r)"
  4353   using ENR_imp_locally_path_connected ENR_sphere by blast
  4354 
  4355 lemma locally_connected_sphere:
  4356   fixes a :: "'a::euclidean_space"
  4357   shows "locally connected(sphere a r)"
  4358   using ANR_imp_locally_connected ANR_sphere by blast
  4359 
  4360 subsubsection\<open>Borsuk homotopy extension theorem\<close>
  4361 
  4362 text\<open>It's only this late so we can use the concept of retraction,
  4363   saying that the domain sets or range set are ENRs.\<close>
  4364 
  4365 theorem Borsuk_homotopy_extension_homotopic:
  4366   fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
  4367   assumes cloTS: "closedin (subtopology euclidean T) S"
  4368       and anr: "(ANR S \<and> ANR T) \<or> ANR U"
  4369       and contf: "continuous_on T f"
  4370       and "f ` T \<subseteq> U"
  4371       and "homotopic_with (\<lambda>x. True) S U f g"
  4372    obtains g' where "homotopic_with (\<lambda>x. True) T U f g'"
  4373                     "continuous_on T g'" "image g' T \<subseteq> U"
  4374                     "\<And>x. x \<in> S \<Longrightarrow> g' x = g x"
  4375 proof -
  4376   have "S \<subseteq> T" using assms closedin_imp_subset by blast
  4377   obtain h where conth: "continuous_on ({0..1} \<times> S) h"
  4378              and him: "h ` ({0..1} \<times> S) \<subseteq> U"
  4379              and [simp]: "\<And>x. h(0, x) = f x" "\<And>x. h(1::real, x) = g x"
  4380        using assms by (auto simp: homotopic_with_def)
  4381   define h' where "h' \<equiv>  \<lambda>z. if snd z \<in> S then h z else (f \<circ> snd) z"
  4382   define B where "B \<equiv> {0::real} \<times> T \<union> {0..1} \<times> S"
  4383   have clo0T: "closedin (subtopology euclidean ({0..1} \<times> T)) ({0::real} \<times> T)"
  4384     by (simp add: closedin_subtopology_refl closedin_Times)
  4385   moreover have cloT1S: "closedin (subtopology euclidean ({0..1} \<times> T)) ({0..1} \<times> S)"
  4386     by (simp add: closedin_subtopology_refl closedin_Times assms)
  4387   ultimately have clo0TB:"closedin (subtopology euclidean ({0..1} \<times> T)) B"
  4388     by (auto simp: B_def)
  4389   have cloBS: "closedin (subtopology euclidean B) ({0..1} \<times> S)"
  4390     by (metis (no_types) Un_subset_iff B_def closedin_subset_trans [OF cloT1S] clo0TB closedin_imp_subset closedin_self)
  4391   moreover have cloBT: "closedin (subtopology euclidean B) ({0} \<times> T)"
  4392     using \<open>S \<subseteq> T\<close> closedin_subset_trans [OF clo0T]
  4393     by (metis B_def Un_upper1 clo0TB closedin_closed inf_le1)
  4394   moreover have "continuous_on ({0} \<times> T) (f \<circ> snd)"
  4395     apply (rule continuous_intros)+
  4396     apply (simp add: contf)
  4397     done
  4398   ultimately have conth': "continuous_on B h'"
  4399     apply (simp add: h'_def B_def Un_commute [of "{0} \<times> T"])
  4400     apply (auto intro!: continuous_on_cases_local conth)
  4401     done
  4402   have "image h' B \<subseteq> U"
  4403     using \<open>f ` T \<subseteq> U\<close> him by (auto simp: h'_def B_def)
  4404   obtain V k where "B \<subseteq> V" and opeTV: "openin (subtopology euclidean ({0..1} \<times> T)) V"
  4405                and contk: "continuous_on V k" and kim: "k ` V \<subseteq> U"
  4406                and keq: "\<And>x. x \<in> B \<Longrightarrow> k x = h' x"
  4407   using anr
  4408   proof
  4409     assume ST: "ANR S \<and> ANR T"
  4410     have eq: "({0} \<times> T \<inter> {0..1} \<times> S) = {0::real} \<times> S"
  4411       using \<open>S \<subseteq> T\<close> by auto
  4412     have "ANR B"
  4413       apply (simp add: B_def)
  4414       apply (rule ANR_closed_Un_local)
  4415           apply (metis cloBT B_def)
  4416          apply (metis Un_commute cloBS B_def)
  4417         apply (simp_all add: ANR_Times convex_imp_ANR ANR_singleton ST eq)
  4418       done
  4419     note Vk = that
  4420     have *: thesis if "openin (subtopology euclidean ({0..1::real} \<times> T)) V"
  4421                       "retraction V B r" for V r
  4422       using that
  4423       apply (clarsimp simp add: retraction_def)
  4424       apply (rule Vk [of V "h' \<circ> r"], assumption+)
  4425         apply (metis continuous_on_compose conth' continuous_on_subset) 
  4426       using \<open>h' ` B \<subseteq> U\<close> apply force+
  4427       done
  4428     show thesis
  4429         apply (rule ANR_imp_neighbourhood_retract [OF \<open>ANR B\<close> clo0TB])
  4430         apply (auto simp: ANR_Times ANR_singleton ST retract_of_def *)
  4431         done
  4432   next
  4433     assume "ANR U"
  4434     with ANR_imp_absolute_neighbourhood_extensor \<open>h' ` B \<subseteq> U\<close> clo0TB conth' that
  4435     show ?thesis by blast
  4436   qed
  4437   define S' where "S' \<equiv> {x. \<exists>u::real. u \<in> {0..1} \<and> (u, x::'a) \<in> {0..1} \<times> T - V}"
  4438   have "closedin (subtopology euclidean T) S'"
  4439     unfolding S'_def
  4440     apply (rule closedin_compact_projection, blast)
  4441     using closedin_self opeTV by blast
  4442   have S'_def: "S' = {x. \<exists>u::real.  (u, x::'a) \<in> {0..1} \<times> T - V}"
  4443     by (auto simp: S'_def)
  4444   have cloTS': "closedin (subtopology euclidean T) S'"
  4445     using S'_def \<open>closedin (subtopology euclidean T) S'\<close> by blast
  4446   have "S \<inter> S' = {}"
  4447     using S'_def B_def \<open>B \<subseteq> V\<close> by force
  4448   obtain a :: "'a \<Rightarrow> real" where conta: "continuous_on T a"
  4449       and "\<And>x. x \<in> T \<Longrightarrow> a x \<in> closed_segment 1 0"
  4450       and a1: "\<And>x. x \<in> S \<Longrightarrow> a x = 1"
  4451       and a0: "\<And>x. x \<in> S' \<Longrightarrow> a x = 0"
  4452     apply (rule Urysohn_local [OF cloTS cloTS' \<open>S \<inter> S' = {}\<close>, of 1 0], blast)
  4453     done
  4454   then have ain: "\<And>x. x \<in> T \<Longrightarrow> a x \<in> {0..1}"
  4455     using closed_segment_eq_real_ivl by auto
  4456   have inV: "(u * a t, t) \<in> V" if "t \<in> T" "0 \<le> u" "u \<le> 1" for t u
  4457   proof (rule ccontr)
  4458     assume "(u * a t, t) \<notin> V"
  4459     with ain [OF \<open>t \<in> T\<close>] have "a t = 0"
  4460       apply simp
  4461       apply (rule a0)
  4462       by (metis (no_types, lifting) Diff_iff S'_def SigmaI atLeastAtMost_iff mem_Collect_eq mult_le_one mult_nonneg_nonneg that)
  4463     show False
  4464       using B_def \<open>(u * a t, t) \<notin> V\<close> \<open>B \<subseteq> V\<close> \<open>a t = 0\<close> that by auto
  4465   qed
  4466   show ?thesis
  4467   proof
  4468     show hom: "homotopic_with (\<lambda>x. True) T U f (\<lambda>x. k (a x, x))"
  4469     proof (simp add: homotopic_with, intro exI conjI)
  4470       show "continuous_on ({0..1} \<times> T) (k \<circ> (\<lambda>z. (fst z *\<^sub>R (a \<circ> snd) z, snd z)))"
  4471         apply (intro continuous_on_compose continuous_intros)
  4472         apply (rule continuous_on_subset [OF conta], force)
  4473         apply (rule continuous_on_subset [OF contk])
  4474         apply (force intro: inV)
  4475         done
  4476       show "(k \<circ> (\<lambda>z. (fst z *\<^sub>R (a \<circ> snd) z, snd z))) ` ({0..1} \<times> T) \<subseteq> U"
  4477         using inV kim by auto
  4478       show "\<forall>x\<in>T. (k \<circ> (\<lambda>z. (fst z *\<^sub>R (a \<circ> snd) z, snd z))) (0, x) = f x"
  4479         by (simp add: B_def h'_def keq)
  4480       show "\<forall>x\<in>T. (k \<circ> (\<lambda>z. (fst z *\<^sub>R (a \<circ> snd) z, snd z))) (1, x) = k (a x, x)"
  4481         by auto
  4482     qed
  4483   show "continuous_on T (\<lambda>x. k (a x, x))"
  4484     using hom homotopic_with_imp_continuous by blast
  4485   show "(\<lambda>x. k (a x, x)) ` T \<subseteq> U"
  4486   proof clarify
  4487     fix t
  4488     assume "t \<in> T"
  4489     show "k (a t, t) \<in> U"
  4490       by (metis \<open>t \<in> T\<close> image_subset_iff inV kim not_one_le_zero linear mult_cancel_right1)
  4491   qed
  4492   show "\<And>x. x \<in> S \<Longrightarrow> k (a x, x) = g x"
  4493     by (simp add: B_def a1 h'_def keq)
  4494   qed
  4495 qed
  4496 
  4497 
  4498 corollary%unimportant nullhomotopic_into_ANR_extension:
  4499   fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
  4500   assumes "closed S"
  4501       and contf: "continuous_on S f"
  4502       and "ANR T"
  4503       and fim: "f ` S \<subseteq> T"
  4504       and "S \<noteq> {}"
  4505    shows "(\<exists>c. homotopic_with (\<lambda>x. True) S T f (\<lambda>x. c)) \<longleftrightarrow>
  4506           (\<exists>g. continuous_on UNIV g \<and> range g \<subseteq> T \<and> (\<forall>x \<in> S. g x = f x))"
  4507        (is "?lhs = ?rhs")
  4508 proof
  4509   assume ?lhs
  4510   then obtain c where c: "homotopic_with (\<lambda>x. True) S T (\<lambda>x. c) f"
  4511     by (blast intro: homotopic_with_symD)
  4512   have "closedin (subtopology euclidean UNIV) S"
  4513     using \<open>closed S\<close> closed_closedin by fastforce
  4514   then obtain g where "continuous_on UNIV g" "range g \<subseteq> T"
  4515                       "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
  4516     apply (rule Borsuk_homotopy_extension_homotopic [OF _ _ continuous_on_const _ c, where T=UNIV])
  4517     using \<open>ANR T\<close> \<open>S \<noteq> {}\<close> c homotopic_with_imp_subset1 apply fastforce+
  4518     done
  4519   then show ?rhs by blast
  4520 next
  4521   assume ?rhs
  4522   then obtain g where "continuous_on UNIV g" "range g \<subseteq> T" "\<And>x. x\<in>S \<Longrightarrow> g x = f x"
  4523     by blast
  4524   then obtain c where "homotopic_with (\<lambda>h. True) UNIV T g (\<lambda>x. c)"
  4525     using nullhomotopic_from_contractible [of UNIV g T] contractible_UNIV by blast
  4526   then show ?lhs
  4527     apply (rule_tac x=c in exI)
  4528     apply (rule homotopic_with_eq [of _ _ _ g "\<lambda>x. c"])
  4529     apply (rule homotopic_with_subset_left)
  4530     apply (auto simp: \<open>\<And>x. x \<in> S \<Longrightarrow> g x = f x\<close>)
  4531     done
  4532 qed
  4533 
  4534 corollary%unimportant nullhomotopic_into_rel_frontier_extension:
  4535   fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
  4536   assumes "closed S"
  4537       and contf: "continuous_on S f"
  4538       and "convex T" "bounded T"
  4539       and fim: "f ` S \<subseteq> rel_frontier T"
  4540       and "S \<noteq> {}"
  4541    shows "(\<exists>c. homotopic_with (\<lambda>x. True) S (rel_frontier T) f (\<lambda>x. c)) \<longleftrightarrow>
  4542           (\<exists>g. continuous_on UNIV g \<and> range g \<subseteq> rel_frontier T \<and> (\<forall>x \<in> S. g x = f x))"
  4543 by (simp add: nullhomotopic_into_ANR_extension assms ANR_rel_frontier_convex)
  4544 
  4545 corollary%unimportant nullhomotopic_into_sphere_extension:
  4546   fixes f :: "'a::euclidean_space \<Rightarrow> 'b :: euclidean_space"
  4547   assumes "closed S" and contf: "continuous_on S f"
  4548       and "S \<noteq> {}" and fim: "f ` S \<subseteq> sphere a r"
  4549     shows "((\<exists>c. homotopic_with (\<lambda>x. True) S (sphere a r) f (\<lambda>x. c)) \<longleftrightarrow>
  4550            (\<exists>g. continuous_on UNIV g \<and> range g \<subseteq> sphere a r \<and> (\<forall>x \<in> S. g x = f x)))"
  4551            (is "?lhs = ?rhs")
  4552 proof (cases "r = 0")
  4553   case True with fim show ?thesis
  4554     apply auto
  4555     using fim continuous_on_const apply fastforce
  4556     by (metis contf contractible_sing nullhomotopic_into_contractible)
  4557 next
  4558   case False
  4559   then have eq: "sphere a r = rel_frontier (cball a r)" by simp
  4560   show ?thesis
  4561     using fim unfolding eq
  4562     apply (rule nullhomotopic_into_rel_frontier_extension [OF \<open>closed S\<close> contf convex_cball bounded_cball])
  4563     apply (rule \<open>S \<noteq> {}\<close>)
  4564     done
  4565 qed
  4566 
  4567 proposition%unimportant Borsuk_map_essential_bounded_component:
  4568   fixes a :: "'a :: euclidean_space"
  4569   assumes "compact S" and "a \<notin> S"
  4570    shows "bounded (connected_component_set (- S) a) \<longleftrightarrow>
  4571           ~(\<exists>c. homotopic_with (\<lambda>x. True) S (sphere 0 1)
  4572                                (\<lambda>x. inverse(norm(x - a)) *\<^sub>R (x - a)) (\<lambda>x. c))"
  4573    (is "?lhs = ?rhs")
  4574 proof (cases "S = {}")
  4575   case True then show ?thesis
  4576     by simp
  4577 next
  4578   case False
  4579   have "closed S" "bounded S"
  4580     using \<open>compact S\<close> compact_eq_bounded_closed by auto
  4581   have s01: "(\<lambda>x. (x - a) /\<^sub>R norm (x - a)) ` S \<subseteq> sphere 0 1"
  4582     using \<open>a \<notin> S\<close>  by clarsimp (metis dist_eq_0_iff dist_norm mult.commute right_inverse)
  4583   have aincc: "a \<in> connected_component_set (- S) a"
  4584     by (simp add: \<open>a \<notin> S\<close>)
  4585   obtain r where "r>0" and r: "S \<subseteq> ball 0 r"
  4586     using bounded_subset_ballD \<open>bounded S\<close> by blast
  4587   have "~ ?rhs \<longleftrightarrow> ~ ?lhs"
  4588   proof
  4589     assume notr: "~ ?rhs"
  4590     have nog: "\<nexists>g. continuous_on (S \<union> connected_component_set (- S) a) g \<and>
  4591                    g ` (S \<union> connected_component_set (- S) a) \<subseteq> sphere 0 1 \<and>
  4592                    (\<forall>x\<in>S. g x = (x - a) /\<^sub>R norm (x - a))"
  4593          if "bounded (connected_component_set (- S) a)"
  4594       apply (rule non_extensible_Borsuk_map [OF \<open>compact S\<close> componentsI _ aincc])
  4595       using  \<open>a \<notin> S\<close> that by auto
  4596     obtain g where "range g \<subseteq> sphere 0 1" "continuous_on UNIV g"
  4597                         "\<And>x. x \<in> S \<Longrightarrow> g x = (x - a) /\<^sub>R norm (x - a)"
  4598       using notr
  4599       by (auto simp: nullhomotopic_into_sphere_extension
  4600                  [OF \<open>closed S\<close> continuous_on_Borsuk_map [OF \<open>a \<notin> S\<close>] False s01])
  4601     with \<open>a \<notin> S\<close> show  "~ ?lhs"
  4602       apply (clarsimp simp: Borsuk_map_into_sphere [of a S, symmetric] dest!: nog)
  4603       apply (drule_tac x=g in spec)
  4604       using continuous_on_subset by fastforce 
  4605   next
  4606     assume "~ ?lhs"
  4607     then obtain b where b: "b \<in> connected_component_set (- S) a" and "r \<le> norm b"
  4608       using bounded_iff linear by blast
  4609     then have bnot: "b \<notin> ball 0 r"
  4610       by simp
  4611     have "homotopic_with (\<lambda>x. True) S (sphere 0 1) (\<lambda>x. (x - a) /\<^sub>R norm (x - a))
  4612                                                    (\<lambda>x. (x - b) /\<^sub>R norm (x - b))"
  4613       apply (rule Borsuk_maps_homotopic_in_path_component)
  4614       using \<open>closed S\<close> b open_Compl open_path_connected_component apply fastforce
  4615       done
  4616     moreover
  4617     obtain c where "homotopic_with (\<lambda>x. True) (ball 0 r) (sphere 0 1)
  4618                                    (\<lambda>x. inverse (norm (x - b)) *\<^sub>R (x - b)) (\<lambda>x. c)"
  4619     proof (rule nullhomotopic_from_contractible)
  4620       show "contractible (ball (0::'a) r)"
  4621         by (metis convex_imp_contractible convex_ball)
  4622       show "continuous_on (ball 0 r) (\<lambda>x. inverse(norm (x - b)) *\<^sub>R (x - b))"
  4623         by (rule continuous_on_Borsuk_map [OF bnot])
  4624       show "(\<lambda>x. (x - b) /\<^sub>R norm (x - b)) ` ball 0 r \<subseteq> sphere 0 1"
  4625         using bnot Borsuk_map_into_sphere by blast
  4626     qed blast
  4627     ultimately have "homotopic_with (\<lambda>x. True) S (sphere 0 1)
  4628                          (\<lambda>x. (x - a) /\<^sub>R norm (x - a)) (\<lambda>x. c)"
  4629       by (meson homotopic_with_subset_left homotopic_with_trans r)
  4630     then show "~ ?rhs"
  4631       by blast
  4632   qed
  4633   then show ?thesis by blast
  4634 qed
  4635 
  4636 lemma homotopic_Borsuk_maps_in_bounded_component:
  4637   fixes a :: "'a :: euclidean_space"
  4638   assumes "compact S" and "a \<notin> S"and "b \<notin> S"
  4639       and boc: "bounded (connected_component_set (- S) a)"
  4640       and hom: "homotopic_with (\<lambda>x. True) S (sphere 0 1)
  4641                                (\<lambda>x. (x - a) /\<^sub>R norm (x - a))
  4642                                (\<lambda>x. (x - b) /\<^sub>R norm (x - b))"
  4643    shows "connected_component (- S) a b"
  4644 proof (rule ccontr)
  4645   assume notcc: "\<not> connected_component (- S) a b"
  4646   let ?T = "S \<union> connected_component_set (- S) a"
  4647   have "\<nexists>g. continuous_on (S \<union> connected_component_set (- S) a) g \<and>
  4648             g ` (S \<union> connected_component_set (- S) a) \<subseteq> sphere 0 1 \<and>
  4649             (\<forall>x\<in>S. g x = (x - a) /\<^sub>R norm (x - a))"
  4650     by (simp add: \<open>a \<notin> S\<close> componentsI non_extensible_Borsuk_map [OF \<open>compact S\<close> _ boc])
  4651   moreover obtain g where "continuous_on (S \<union> connected_component_set (- S) a) g"
  4652                           "g ` (S \<union> connected_component_set (- S) a) \<subseteq> sphere 0 1"
  4653                           "\<And>x. x \<in> S \<Longrightarrow> g x = (x - a) /\<^sub>R norm (x - a)"
  4654   proof (rule Borsuk_homotopy_extension_homotopic)
  4655     show "closedin (subtopology euclidean ?T) S"
  4656       by (simp add: \<open>compact S\<close> closed_subset compact_imp_closed)
  4657     show "continuous_on ?T (\<lambda>x. (x - b) /\<^sub>R norm (x - b))"
  4658       by (simp add: \<open>b \<notin> S\<close> notcc continuous_on_Borsuk_map)
  4659     show "(\<lambda>x. (x - b) /\<^sub>R norm (x - b)) ` ?T \<subseteq> sphere 0 1"
  4660       by (simp add: \<open>b \<notin> S\<close> notcc Borsuk_map_into_sphere)
  4661     show "homotopic_with (\<lambda>x. True) S (sphere 0 1)
  4662              (\<lambda>x. (x - b) /\<^sub>R norm (x - b)) (\<lambda>x. (x - a) /\<^sub>R norm (x - a))"
  4663       by (simp add: hom homotopic_with_symD)
  4664     qed (auto simp: ANR_sphere intro: that)
  4665   ultimately show False by blast
  4666 qed
  4667 
  4668 
  4669 lemma Borsuk_maps_homotopic_in_connected_component_eq:
  4670   fixes a :: "'a :: euclidean_space"
  4671   assumes S: "compact S" "a \<notin> S" "b \<notin> S" and 2: "2 \<le> DIM('a)"
  4672     shows "(homotopic_with (\<lambda>x. True) S (sphere 0 1)
  4673                    (\<lambda>x. (x - a) /\<^sub>R norm (x - a))
  4674                    (\<lambda>x. (x - b) /\<^sub>R norm (x - b)) \<longleftrightarrow>
  4675            connected_component (- S) a b)"
  4676          (is "?lhs = ?rhs")
  4677 proof
  4678   assume L: ?lhs
  4679   show ?rhs
  4680   proof (cases "bounded(connected_component_set (- S) a)")
  4681     case True
  4682     show ?thesis
  4683       by (rule homotopic_Borsuk_maps_in_bounded_component [OF S True L])
  4684   next
  4685     case not_bo_a: False
  4686     show ?thesis
  4687     proof (cases "bounded(connected_component_set (- S) b)")
  4688       case True
  4689       show ?thesis
  4690         using homotopic_Borsuk_maps_in_bounded_component [OF S]
  4691         by (simp add: L True assms connected_component_sym homotopic_Borsuk_maps_in_bounded_component homotopic_with_sym)
  4692     next
  4693       case False
  4694       then show ?thesis
  4695         using cobounded_unique_unbounded_component [of "-S" a b] \<open>compact S\<close> not_bo_a
  4696         by (auto simp: compact_eq_bounded_closed assms connected_component_eq_eq)
  4697     qed
  4698   qed
  4699 next
  4700   assume R: ?rhs
  4701   then have "path_component (- S) a b"
  4702     using assms(1) compact_eq_bounded_closed open_Compl open_path_connected_component_set by fastforce
  4703   then show ?lhs
  4704     by (simp add: Borsuk_maps_homotopic_in_path_component)
  4705 qed
  4706 
  4707 subsubsection\<open>More extension theorems\<close>
  4708 
  4709 lemma extension_from_clopen:
  4710   assumes ope: "openin (subtopology euclidean S) T"
  4711       and clo: "closedin (subtopology euclidean S) T"
  4712       and contf: "continuous_on T f" and fim: "f ` T \<subseteq> U" and null: "U = {} \<Longrightarrow> S = {}"
  4713  obtains g where "continuous_on S g" "g ` S \<subseteq> U" "\<And>x. x \<in> T \<Longrightarrow> g x = f x"
  4714 proof (cases "U = {}")
  4715   case True
  4716   then show ?thesis
  4717     by (simp add: null that)
  4718 next
  4719   case False
  4720   then obtain a where "a \<in> U"
  4721     by auto
  4722   let ?g = "\<lambda>x. if x \<in> T then f x else a"
  4723   have Seq: "S = T \<union> (S - T)"
  4724     using clo closedin_imp_subset by fastforce
  4725   show ?thesis
  4726   proof
  4727     have "continuous_on (T \<union> (S - T)) ?g"
  4728       apply (rule continuous_on_cases_local)
  4729       using Seq clo ope by (auto simp: contf continuous_on_const intro: continuous_on_cases_local)
  4730     with Seq show "continuous_on S ?g"
  4731       by metis
  4732     show "?g ` S \<subseteq> U"
  4733       using \<open>a \<in> U\<close> fim by auto
  4734     show "\<And>x. x \<in> T \<Longrightarrow> ?g x = f x"
  4735       by auto
  4736   qed
  4737 qed
  4738 
  4739 
  4740 lemma extension_from_component:
  4741   fixes f :: "'a :: euclidean_space \<Rightarrow> 'b :: euclidean_space"
  4742   assumes S: "locally connected S \<or> compact S" and "ANR U"
  4743      and C: "C \<in> components S" and contf: "continuous_on C f" and fim: "f ` C \<subseteq> U"
  4744  obtains g where "continuous_on S g" "g ` S \<subseteq> U" "\<And>x. x \<in> C \<Longrightarrow> g x = f x"
  4745 proof -
  4746   obtain T g where ope: "openin (subtopology euclidean S) T"
  4747                and clo: "closedin (subtopology euclidean S) T"
  4748                and "C \<subseteq> T" and contg: "continuous_on T g" and gim: "g ` T \<subseteq> U"
  4749                and gf: "\<And>x. x \<in> C \<Longrightarrow> g x = f x"
  4750     using S
  4751   proof
  4752     assume "locally connected S"
  4753     show ?thesis
  4754       by (metis C \<open>locally connected S\<close> openin_components_locally_connected closedin_component contf fim order_refl that)
  4755   next
  4756     assume "compact S"
  4757     then obtain W g where "C \<subseteq> W" and opeW: "openin (subtopology euclidean S) W"
  4758                  and contg: "continuous_on W g"
  4759                  and gim: "g ` W \<subseteq> U" and gf: "\<And>x. x \<in> C \<Longrightarrow> g x = f x"
  4760       using ANR_imp_absolute_neighbourhood_extensor [of U C f S] C \<open>ANR U\<close> closedin_component contf fim by blast
  4761     then obtain V where "open V" and V: "W = S \<inter> V"
  4762       by (auto simp: openin_open)
  4763     moreover have "locally compact S"
  4764       by (simp add: \<open>compact S\<close> closed_imp_locally_compact compact_imp_closed)
  4765     ultimately obtain K where opeK: "openin (subtopology euclidean S) K" and "compact K" "C \<subseteq> K" "K \<subseteq> V"
  4766       by (metis C Int_subset_iff \<open>C \<subseteq> W\<close> \<open>compact S\<close> compact_components Sura_Bura_clopen_subset)
  4767     show ?thesis
  4768     proof
  4769       show "closedin (subtopology euclidean S) K"
  4770         by (meson \<open>compact K\<close> \<open>compact S\<close> closedin_compact_eq opeK openin_imp_subset)
  4771       show "continuous_on K g"
  4772         by (metis Int_subset_iff V \<open>K \<subseteq> V\<close> contg continuous_on_subset opeK openin_subtopology subset_eq)
  4773       show "g ` K \<subseteq> U"
  4774         using V \<open>K \<subseteq> V\<close> gim opeK openin_imp_subset by fastforce
  4775     qed (use opeK gf \<open>C \<subseteq> K\<close> in auto)
  4776   qed
  4777   obtain h where "continuous_on S h" "h ` S \<subseteq> U" "\<And>x. x \<in> T \<Longrightarrow> h x = g x"
  4778     using extension_from_clopen
  4779     by (metis C bot.extremum_uniqueI clo contg gim fim image_is_empty in_components_nonempty ope)
  4780   then show ?thesis
  4781     by (metis \<open>C \<subseteq> T\<close> gf subset_eq that)
  4782 qed
  4783 
  4784 
  4785 lemma tube_lemma:
  4786   fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
  4787   assumes "compact S" and S: "S \<noteq> {}" "(\<lambda>x. (x,a)) ` S \<subseteq> U" 
  4788       and ope: "openin (subtopology euclidean (S \<times> T)) U"
  4789   obtains V where "openin (subtopology euclidean T) V" "a \<in> V" "S \<times> V \<subseteq> U"
  4790 proof -
  4791   let ?W = "{y. \<exists>x. x \<in> S \<and> (x, y) \<in> (S \<times> T - U)}"
  4792   have "U \<subseteq> S \<times> T" "closedin (subtopology euclidean (S \<times> T)) (S \<times> T - U)"
  4793     using ope by (auto simp: openin_closedin_eq)
  4794   then have "closedin (subtopology euclidean T) ?W"
  4795     using \<open>compact S\<close> closedin_compact_projection by blast
  4796   moreover have "a \<in> T - ?W"
  4797     using \<open>U \<subseteq> S \<times> T\<close> S by auto
  4798   moreover have "S \<times> (T - ?W) \<subseteq> U"
  4799     by auto
  4800   ultimately show ?thesis
  4801     by (metis (no_types, lifting) Sigma_cong closedin_def that topspace_euclidean_subtopology)
  4802 qed
  4803 
  4804 lemma tube_lemma_gen:
  4805   fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
  4806   assumes "compact S" "S \<noteq> {}" "T \<subseteq> T'" "S \<times> T \<subseteq> U"
  4807       and ope: "openin (subtopology euclidean (S \<times> T')) U"
  4808   obtains V where "openin (subtopology euclidean T') V" "T \<subseteq> V" "S \<times> V \<subseteq> U"
  4809 proof -
  4810   have "\<And>x. x \<in> T \<Longrightarrow> \<exists>V. openin (subtopology euclidean T') V \<and> x \<in> V \<and> S \<times> V \<subseteq> U"
  4811     using assms by (auto intro:  tube_lemma [OF \<open>compact S\<close>])
  4812   then obtain F where F: "\<And>x. x \<in> T \<Longrightarrow> openin (subtopology euclidean T') (F x) \<and> x \<in> F x \<and> S \<times> F x \<subseteq> U"
  4813     by metis
  4814   show ?thesis
  4815   proof
  4816     show "openin (subtopology euclidean T') (UNION T F)"
  4817       using F by blast
  4818     show "T \<subseteq> UNION T F"
  4819       using F by blast
  4820     show "S \<times> UNION T F \<subseteq> U"
  4821       using F by auto
  4822   qed
  4823 qed
  4824 
  4825 proposition%unimportant homotopic_neighbourhood_extension:
  4826   fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
  4827   assumes contf: "continuous_on S f" and fim: "f ` S \<subseteq> U"
  4828       and contg: "continuous_on S g" and gim: "g ` S \<subseteq> U"
  4829       and clo: "closedin (subtopology euclidean S) T"
  4830       and "ANR U" and hom: "homotopic_with (\<lambda>x. True) T U f g"
  4831     obtains V where "T \<subseteq> V" "openin (subtopology euclidean S) V"
  4832                     "homotopic_with (\<lambda>x. True) V U f g"
  4833 proof -
  4834   have "T \<subseteq> S"
  4835     using clo closedin_imp_subset by blast
  4836   obtain h where conth: "continuous_on ({0..1::real} \<times> T) h"
  4837              and him: "h ` ({0..1} \<times> T) \<subseteq> U"
  4838              and h0: "\<And>x. h(0, x) = f x" and h1: "\<And>x. h(1, x) = g x"
  4839     using hom by (auto simp: homotopic_with_def)
  4840   define h' where "h' \<equiv> \<lambda>z. if fst z \<in> {0} then f(snd z)
  4841                              else if fst z \<in> {1} then g(snd z)
  4842                              else h z"
  4843   let ?S0 = "{0::real} \<times> S" and ?S1 = "{1::real} \<times> S"
  4844   have "continuous_on(?S0 \<union> (?S1 \<union> {0..1} \<times> T)) h'"
  4845     unfolding h'_def
  4846   proof (intro continuous_on_cases_local)
  4847     show "closedin (subtopology euclidean (?S0 \<union> (?S1 \<union> {0..1} \<times> T))) ?S0"
  4848          "closedin (subtopology euclidean (?S1 \<union> {0..1} \<times> T)) ?S1"
  4849       using \<open>T \<subseteq> S\<close> by (force intro: closedin_Times closedin_subset_trans [of "{0..1} \<times> S"])+
  4850     show "closedin (subtopology euclidean (?S0 \<union> (?S1 \<union> {0..1} \<times> T))) (?S1 \<union> {0..1} \<times> T)"
  4851          "closedin (subtopology euclidean (?S1 \<union> {0..1} \<times> T)) ({0..1} \<times> T)"
  4852       using \<open>T \<subseteq> S\<close> by (force intro: clo closedin_Times closedin_subset_trans [of "{0..1} \<times> S"])+
  4853     show "continuous_on (?S0) (\<lambda>x. f (snd x))"
  4854       by (intro continuous_intros continuous_on_compose2 [OF contf]) auto
  4855     show "continuous_on (?S1) (\<lambda>x. g (snd x))"
  4856       by (intro continuous_intros continuous_on_compose2 [OF contg]) auto
  4857   qed (use h0 h1 conth in auto)
  4858   then have "continuous_on ({0,1} \<times> S \<union> ({0..1} \<times> T)) h'"
  4859     by (metis Sigma_Un_distrib1 Un_assoc insert_is_Un) 
  4860   moreover have "h' ` ({0,1} \<times> S \<union> {0..1} \<times> T) \<subseteq> U"
  4861     using fim gim him \<open>T \<subseteq> S\<close> unfolding h'_def by force
  4862   moreover have "closedin (subtopology euclidean ({0..1::real} \<times> S)) ({0,1} \<times> S \<union> {0..1::real} \<times> T)"
  4863     by (intro closedin_Times closedin_Un clo) (simp_all add: closed_subset)
  4864   ultimately
  4865   obtain W k where W: "({0,1} \<times> S) \<union> ({0..1} \<times> T) \<subseteq> W"
  4866                and opeW: "openin (subtopology euclidean ({0..1} \<times> S)) W"
  4867                and contk: "continuous_on W k"
  4868                and kim: "k ` W \<subseteq> U"
  4869                and kh': "\<And>x. x \<in> ({0,1} \<times> S) \<union> ({0..1} \<times> T) \<Longrightarrow> k x = h' x"
  4870     by (metis ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR U\<close>, of "({0,1} \<times> S) \<union> ({0..1} \<times> T)" h' "{0..1} \<times> S"])
  4871   obtain T' where opeT': "openin (subtopology euclidean S) T'" 
  4872               and "T \<subseteq> T'" and TW: "{0..1} \<times> T' \<subseteq> W"
  4873     using tube_lemma_gen [of "{0..1::real}" T S W] W \<open>T \<subseteq> S\<close> opeW by auto
  4874   moreover have "homotopic_with (\<lambda>x. True) T' U f g"
  4875   proof (simp add: homotopic_with, intro exI conjI)
  4876     show "continuous_on ({0..1} \<times> T') k"
  4877       using TW continuous_on_subset contk by auto
  4878     show "k ` ({0..1} \<times> T') \<subseteq> U"
  4879       using TW kim by fastforce
  4880     have "T' \<subseteq> S"
  4881       by (meson opeT' subsetD openin_imp_subset)
  4882     then show "\<forall>x\<in>T'. k (0, x) = f x" "\<forall>x\<in>T'. k (1, x) = g x"
  4883       by (auto simp: kh' h'_def)
  4884   qed
  4885   ultimately show ?thesis
  4886     by (blast intro: that)
  4887 qed
  4888 
  4889 text\<open> Homotopy on a union of closed-open sets.\<close>
  4890 proposition%unimportant homotopic_on_clopen_Union:
  4891   fixes \<F> :: "'a::euclidean_space set set"
  4892   assumes "\<And>S. S \<in> \<F> \<Longrightarrow> closedin (subtopology euclidean (\<Union>\<F>)) S"
  4893       and "\<And>S. S \<in> \<F> \<Longrightarrow> openin (subtopology euclidean (\<Union>\<F>)) S"
  4894       and "\<And>S. S \<in> \<F> \<Longrightarrow> homotopic_with (\<lambda>x. True) S T f g"
  4895   shows "homotopic_with (\<lambda>x. True) (\<Union>\<F>) T f g"
  4896 proof -
  4897   obtain \<V> where "\<V> \<subseteq> \<F>" "countable \<V>" and eqU: "\<Union>\<V> = \<Union>\<F>"
  4898     using Lindelof_openin assms by blast
  4899   show ?thesis
  4900   proof (cases "\<V> = {}")
  4901     case True
  4902     then show ?thesis
  4903       by (metis Union_empty eqU homotopic_on_empty)
  4904   next
  4905     case False
  4906     then obtain V :: "nat \<Rightarrow> 'a set" where V: "range V = \<V>"
  4907       using range_from_nat_into \<open>countable \<V>\<close> by metis
  4908     with \<open>\<V> \<subseteq> \<F>\<close> have clo: "\<And>n. closedin (subtopology euclidean (\<Union>\<F>)) (V n)"
  4909                   and ope: "\<And>n. openin (subtopology euclidean (\<Union>\<F>)) (V n)"
  4910                   and hom: "\<And>n. homotopic_with (\<lambda>x. True) (V n) T f g"
  4911       using assms by auto 
  4912     then obtain h where conth: "\<And>n. continuous_on ({0..1::real} \<times> V n) (h n)"
  4913                   and him: "\<And>n. h n ` ({0..1} \<times> V n) \<subseteq> T" 
  4914                   and h0: "\<And>n. \<And>x. x \<in> V n \<Longrightarrow> h n (0, x) = f x" 
  4915                   and h1: "\<And>n. \<And>x. x \<in> V n \<Longrightarrow> h n (1, x) = g x"
  4916       by (simp add: homotopic_with) metis
  4917     have wop: "b \<in> V x \<Longrightarrow> \<exists>k. b \<in> V k \<and> (\<forall>j<k. b \<notin> V j)" for b x
  4918         using nat_less_induct [where P = "\<lambda>i. b \<notin> V i"] by meson
  4919     obtain \<zeta> where cont: "continuous_on ({0..1} \<times> UNION UNIV V) \<zeta>"
  4920               and eq: "\<And>x i. \<lbrakk>x \<in> {0..1} \<times> UNION UNIV V \<inter>
  4921                                    {0..1} \<times> (V i - (\<Union>m<i. V m))\<rbrakk> \<Longrightarrow> \<zeta> x = h i x"
  4922     proof (rule pasting_lemma_exists)
  4923       show "{0..1} \<times> UNION UNIV V \<subseteq> (\<Union>i. {0..1::real} \<times> (V i - (\<Union>m<i. V m)))"
  4924         by (force simp: Ball_def dest: wop)
  4925       show "openin (subtopology euclidean ({0..1} \<times> UNION UNIV V)) 
  4926                    ({0..1::real} \<times> (V i - (\<Union>m<i. V m)))" for i
  4927       proof (intro openin_Times openin_subtopology_self openin_diff)
  4928         show "openin (subtopology euclidean (UNION UNIV V)) (V i)"
  4929           using ope V eqU by auto
  4930         show "closedin (subtopology euclidean (UNION UNIV V)) (\<Union>m<i. V m)"
  4931           using V clo eqU by (force intro: closedin_Union)
  4932       qed
  4933       show "continuous_on ({0..1} \<times> (V i - (\<Union>m<i. V m))) (h i)" for i
  4934         by (rule continuous_on_subset [OF conth]) auto
  4935       show "\<And>i j x. x \<in> {0..1} \<times> UNION UNIV V \<inter>
  4936                     {0..1} \<times> (V i - (\<Union>m<i. V m)) \<inter> {0..1} \<times> (V j - (\<Union>m<j. V m))
  4937                     \<Longrightarrow> h i x = h j x"
  4938         by clarsimp (metis lessThan_iff linorder_neqE_nat)
  4939     qed auto
  4940     show ?thesis
  4941     proof (simp add: homotopic_with eqU [symmetric], intro exI conjI ballI)
  4942       show "continuous_on ({0..1} \<times> \<Union>\<V>) \<zeta>"
  4943         using V eqU by (blast intro!:  continuous_on_subset [OF cont])
  4944       show "\<zeta>` ({0..1} \<times> \<Union>\<V>) \<subseteq> T"
  4945       proof clarsimp
  4946         fix t :: real and y :: "'a" and X :: "'a set"
  4947         assume "y \<in> X" "X \<in> \<V>" and t: "0 \<le> t" "t \<le> 1"
  4948         then obtain k where "y \<in> V k" and j: "\<forall>j<k. y \<notin> V j"
  4949           by (metis image_iff V wop)
  4950         with him t show "\<zeta>(t, y) \<in> T"
  4951           by (subst eq) force+
  4952       qed
  4953       fix X y
  4954       assume "X \<in> \<V>" "y \<in> X"
  4955       then obtain k where "y \<in> V k" and j: "\<forall>j<k. y \<notin> V j"
  4956         by (metis image_iff V wop)
  4957       then show "\<zeta>(0, y) = f y" and "\<zeta>(1, y) = g y"
  4958         by (subst eq [where i=k]; force simp: h0 h1)+ 
  4959     qed
  4960   qed
  4961 qed
  4962 
  4963 lemma homotopic_on_components_eq:
  4964   fixes S :: "'a :: euclidean_space set" and T :: "'b :: euclidean_space set"
  4965   assumes S: "locally connected S \<or> compact S" and "ANR T"
  4966   shows "homotopic_with (\<lambda>x. True) S T f g \<longleftrightarrow>
  4967          (continuous_on S f \<and> f ` S \<subseteq> T \<and> continuous_on S g \<and> g ` S \<subseteq> T) \<and>
  4968          (\<forall>C \<in> components S. homotopic_with (\<lambda>x. True) C T f g)"
  4969     (is "?lhs \<longleftrightarrow> ?C \<and> ?rhs")
  4970 proof -
  4971   have "continuous_on S f" "f ` S \<subseteq> T" "continuous_on S g" "g ` S \<subseteq> T" if ?lhs
  4972     using homotopic_with_imp_continuous homotopic_with_imp_subset1 homotopic_with_imp_subset2 that by blast+
  4973   moreover have "?lhs \<longleftrightarrow> ?rhs"
  4974     if contf: "continuous_on S f" and fim: "f ` S \<subseteq> T" and contg: "continuous_on S g" and gim: "g ` S \<subseteq> T"
  4975   proof
  4976     assume ?lhs
  4977     with that show ?rhs
  4978       by (simp add: homotopic_with_subset_left in_components_subset)
  4979   next
  4980     assume R: ?rhs
  4981     have "\<exists>U. C \<subseteq> U \<and> closedin (subtopology euclidean S) U \<and>
  4982               openin (subtopology euclidean S) U \<and>
  4983               homotopic_with (\<lambda>x. True) U T f g" if C: "C \<in> components S" for C
  4984     proof -
  4985       have "C \<subseteq> S"
  4986         by (simp add: in_components_subset that)
  4987       show ?thesis
  4988         using S
  4989       proof
  4990         assume "locally connected S"
  4991         show ?thesis
  4992         proof (intro exI conjI)
  4993           show "closedin (subtopology euclidean S) C"
  4994             by (simp add: closedin_component that)
  4995           show "openin (subtopology euclidean S) C"
  4996             by (simp add: \<open>locally connected S\<close> openin_components_locally_connected that)
  4997           show "homotopic_with (\<lambda>x. True) C T f g"
  4998             by (simp add: R that)
  4999         qed auto
  5000       next
  5001         assume "compact S"
  5002         have hom: "homotopic_with (\<lambda>x. True) C T f g"
  5003           using R that by blast
  5004         obtain U where "C \<subseteq> U" and opeU: "openin (subtopology euclidean S) U"
  5005                   and hom: "homotopic_with (\<lambda>x. True) U T f g"
  5006           using homotopic_neighbourhood_extension [OF contf fim contg gim _ \<open>ANR T\<close> hom]
  5007             \<open>C \<in> components S\<close> closedin_component by blast
  5008         then obtain V where "open V" and V: "U = S \<inter> V"
  5009           by (auto simp: openin_open)
  5010         moreover have "locally compact S"
  5011           by (simp add: \<open>compact S\<close> closed_imp_locally_compact compact_imp_closed)
  5012         ultimately obtain K where opeK: "openin (subtopology euclidean S) K" and "compact K" "C \<subseteq> K" "K \<subseteq> V"
  5013           by (metis C Int_subset_iff Sura_Bura_clopen_subset \<open>C \<subseteq> U\<close> \<open>compact S\<close> compact_components)
  5014         show ?thesis
  5015         proof (intro exI conjI)
  5016           show "closedin (subtopology euclidean S) K"
  5017             by (meson \<open>compact K\<close> \<open>compact S\<close> closedin_compact_eq opeK openin_imp_subset)
  5018           show "homotopic_with (\<lambda>x. True) K T f g"
  5019             using V \<open>K \<subseteq> V\<close> hom homotopic_with_subset_left opeK openin_imp_subset by fastforce
  5020         qed (use opeK \<open>C \<subseteq> K\<close> in auto)
  5021       qed
  5022     qed
  5023     then obtain \<phi> where \<phi>: "\<And>C. C \<in> components S \<Longrightarrow> C \<subseteq> \<phi> C"
  5024                   and clo\<phi>: "\<And>C. C \<in> components S \<Longrightarrow> closedin (subtopology euclidean S) (\<phi> C)"
  5025                   and ope\<phi>: "\<And>C. C \<in> components S \<Longrightarrow> openin (subtopology euclidean S) (\<phi> C)"
  5026                   and hom\<phi>: "\<And>C. C \<in> components S \<Longrightarrow> homotopic_with (\<lambda>x. True) (\<phi> C) T f g"
  5027       by metis
  5028     have Seq: "S = UNION (components S) \<phi>"
  5029     proof
  5030       show "S \<subseteq> UNION (components S) \<phi>"
  5031         by (metis Sup_mono Union_components \<phi> imageI)
  5032       show "UNION (components S) \<phi> \<subseteq> S"
  5033         using ope\<phi> openin_imp_subset by fastforce
  5034     qed
  5035     show ?lhs
  5036       apply (subst Seq)
  5037       apply (rule homotopic_on_clopen_Union)
  5038       using Seq clo\<phi> ope\<phi> hom\<phi> by auto
  5039   qed
  5040   ultimately show ?thesis by blast
  5041 qed
  5042 
  5043 
  5044 lemma cohomotopically_trivial_on_components:
  5045   fixes S :: "'a :: euclidean_space set" and T :: "'b :: euclidean_space set"
  5046   assumes S: "locally connected S \<or> compact S" and "ANR T"
  5047   shows
  5048    "(\<forall>f g. continuous_on S f \<longrightarrow> f ` S \<subseteq> T \<longrightarrow> continuous_on S g \<longrightarrow> g ` S \<subseteq> T \<longrightarrow>
  5049            homotopic_with (\<lambda>x. True) S T f g)
  5050     \<longleftrightarrow>
  5051     (\<forall>C\<in>components S.
  5052         \<forall>f g. continuous_on C f \<longrightarrow> f ` C \<subseteq> T \<longrightarrow> continuous_on C g \<longrightarrow> g ` C \<subseteq> T \<longrightarrow>
  5053               homotopic_with (\<lambda>x. True) C T f g)"
  5054      (is "?lhs = ?rhs")
  5055 proof
  5056   assume L[rule_format]: ?lhs
  5057   show ?rhs
  5058   proof clarify
  5059     fix C f g
  5060     assume contf: "continuous_on C f" and fim: "f ` C \<subseteq> T"
  5061        and contg: "continuous_on C g" and gim: "g ` C \<subseteq> T" and C: "C \<in> components S"
  5062     obtain f' where contf': "continuous_on S f'" and f'im: "f' ` S \<subseteq> T" and f'f: "\<And>x. x \<in> C \<Longrightarrow> f' x = f x"
  5063       using extension_from_component [OF S \<open>ANR T\<close> C contf fim] by metis
  5064     obtain g' where contg': "continuous_on S g'" and g'im: "g' ` S \<subseteq> T" and g'g: "\<And>x. x \<in> C \<Longrightarrow> g' x = g x"
  5065       using extension_from_component [OF S \<open>ANR T\<close> C contg gim] by metis
  5066     have "homotopic_with (\<lambda>x. True) C T f' g'"
  5067       using L [OF contf' f'im contg' g'im] homotopic_with_subset_left C in_components_subset by fastforce
  5068     then show "homotopic_with (\<lambda>x. True) C T f g"
  5069       using f'f g'g homotopic_with_eq by force
  5070   qed
  5071 next
  5072   assume R [rule_format]: ?rhs
  5073   show ?lhs
  5074   proof clarify
  5075     fix f g
  5076     assume contf: "continuous_on S f" and fim: "f ` S \<subseteq> T"
  5077       and contg: "continuous_on S g" and gim: "g ` S \<subseteq> T"
  5078     moreover have "homotopic_with (\<lambda>x. True) C T f g" if "C \<in> components S" for C
  5079       using R [OF that]
  5080       by (meson contf contg continuous_on_subset fim gim image_mono in_components_subset order.trans that)
  5081     ultimately show "homotopic_with (\<lambda>x. True) S T f g"
  5082       by (subst homotopic_on_components_eq [OF S \<open>ANR T\<close>]) auto
  5083   qed
  5084 qed
  5085 
  5086 subsubsection\<open>The complement of a set and path-connectedness\<close>
  5087 
  5088 text\<open>Complement in dimension N > 1 of set homeomorphic to any interval in
  5089  any dimension is (path-)connected. This naively generalizes the argument
  5090  in Ryuji Maehara's paper "The Jordan curve theorem via the Brouwer fixed point theorem",
  5091 American Mathematical Monthly 1984.\<close>
  5092 
  5093 lemma unbounded_components_complement_absolute_retract:
  5094   fixes S :: "'a::euclidean_space set"
  5095   assumes C: "C \<in> components(- S)" and S: "compact S" "AR S"
  5096     shows "\<not> bounded C"
  5097 proof -
  5098   obtain y where y: "C = connected_component_set (- S) y" and "y \<notin> S"
  5099     using C by (auto simp: components_def)
  5100   have "open(- S)"
  5101     using S by (simp add: closed_open compact_eq_bounded_closed)
  5102   have "S retract_of UNIV"
  5103     using S compact_AR by blast
  5104   then obtain r where contr: "continuous_on UNIV r" and ontor: "range r \<subseteq> S"
  5105                   and r: "\<And>x. x \<in> S \<Longrightarrow> r x = x"
  5106     by (auto simp: retract_of_def retraction_def)
  5107   show ?thesis
  5108   proof
  5109     assume "bounded C"
  5110     have "connected_component_set (- S) y \<subseteq> S"
  5111     proof (rule frontier_subset_retraction)
  5112       show "bounded (connected_component_set (- S) y)"
  5113         using \<open>bounded C\<close> y by blast
  5114       show "frontier (connected_component_set (- S) y) \<subseteq> S"
  5115         using C \<open>compact S\<close> compact_eq_bounded_closed frontier_of_components_closed_complement y by blast
  5116       show "continuous_on (closure (connected_component_set (- S) y)) r"
  5117         by (blast intro: continuous_on_subset [OF contr])
  5118     qed (use ontor r in auto)
  5119     with \<open>y \<notin> S\<close> show False by force
  5120   qed
  5121 qed
  5122 
  5123 lemma connected_complement_absolute_retract:
  5124   fixes S :: "'a::euclidean_space set"
  5125   assumes S: "compact S" "AR S" and 2: "2 \<le> DIM('a)"
  5126     shows "connected(- S)"
  5127 proof -
  5128   have "S retract_of UNIV"
  5129     using S compact_AR by blast
  5130   show ?thesis
  5131     apply (clarsimp simp: connected_iff_connected_component_eq)
  5132     apply (rule cobounded_unique_unbounded_component [OF _ 2])
  5133       apply (simp add: \<open>compact S\<close> compact_imp_bounded)
  5134      apply (meson ComplI S componentsI unbounded_components_complement_absolute_retract)+
  5135     done
  5136 qed
  5137 
  5138 lemma path_connected_complement_absolute_retract:
  5139   fixes S :: "'a::euclidean_space set"
  5140   assumes "compact S" "AR S" "2 \<le> DIM('a)"
  5141     shows "path_connected(- S)"
  5142   using connected_complement_absolute_retract [OF assms]
  5143   using \<open>compact S\<close> compact_eq_bounded_closed connected_open_path_connected by blast
  5144 
  5145 theorem connected_complement_homeomorphic_convex_compact:
  5146   fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
  5147   assumes hom: "S homeomorphic T" and T: "convex T" "compact T" and 2: "2 \<le> DIM('a)"
  5148     shows "connected(- S)"
  5149 proof (cases "S = {}")
  5150   case True
  5151   then show ?thesis
  5152     by (simp add: connected_UNIV)
  5153 next
  5154   case False
  5155   show ?thesis
  5156   proof (rule connected_complement_absolute_retract)
  5157     show "compact S"
  5158       using \<open>compact T\<close> hom homeomorphic_compactness by auto
  5159     show "AR S"
  5160       by (meson AR_ANR False \<open>convex T\<close> convex_imp_ANR convex_imp_contractible hom homeomorphic_ANR_iff_ANR homeomorphic_contractible_eq)
  5161   qed (rule 2)
  5162 qed
  5163 
  5164 corollary path_connected_complement_homeomorphic_convex_compact:
  5165   fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
  5166   assumes hom: "S homeomorphic T" "convex T" "compact T" "2 \<le> DIM('a)"
  5167     shows "path_connected(- S)"
  5168   using connected_complement_homeomorphic_convex_compact [OF assms]
  5169   using \<open>compact T\<close> compact_eq_bounded_closed connected_open_path_connected hom homeomorphic_compactness by blast
  5170 
  5171 lemma path_connected_complement_homeomorphic_interval:
  5172   fixes S :: "'a::euclidean_space set"
  5173   assumes "S homeomorphic cbox a b" "2 \<le> DIM('a)"
  5174   shows "path_connected(-S)"
  5175   using assms compact_cbox convex_box(1) path_connected_complement_homeomorphic_convex_compact by blast
  5176 
  5177 lemma connected_complement_homeomorphic_interval:
  5178   fixes S :: "'a::euclidean_space set"
  5179   assumes "S homeomorphic cbox a b" "2 \<le> DIM('a)"
  5180   shows "connected(-S)"
  5181   using assms path_connected_complement_homeomorphic_interval path_connected_imp_connected by blast
  5182 
  5183 end