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