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