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