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