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