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