src/HOL/Analysis/Brouwer_Fixpoint.thy
author nipkow
Thu Jul 12 11:23:46 2018 +0200 (13 months ago)
changeset 68617 75129a73aca3
parent 68361 20375f232f3b
child 68621 27432da24236
permissions -rw-r--r--
more economic tagging
wenzelm@53674
     1
(*  Author:     John Harrison
lp15@63305
     2
    Author:     Robert Himmelmann, TU Muenchen (Translation from HOL light) and LCP
wenzelm@53674
     3
*)
hoelzl@33741
     4
hoelzl@33741
     5
(* At the moment this is just Brouwer's fixpoint theorem. The proof is from  *)
hoelzl@33741
     6
(* Kuhn: "some combinatorial lemmas in topology", IBM J. v4. (1960) p. 518   *)
hoelzl@33741
     7
(* See "http://www.research.ibm.com/journal/rd/045/ibmrd0405K.pdf".          *)
hoelzl@33741
     8
(*                                                                           *)
hoelzl@33741
     9
(* The script below is quite messy, but at least we avoid formalizing any    *)
hoelzl@33741
    10
(* topological machinery; we don't even use barycentric subdivision; this is *)
hoelzl@33741
    11
(* the big advantage of Kuhn's proof over the usual Sperner's lemma one.     *)
hoelzl@33741
    12
(*                                                                           *)
hoelzl@33741
    13
(*              (c) Copyright, John Harrison 1998-2008                       *)
hoelzl@33741
    14
nipkow@68617
    15
section \<open>Brouwer's Fixed Point Theorem\<close>
hoelzl@33741
    16
hoelzl@33741
    17
theory Brouwer_Fixpoint
lp15@63129
    18
imports Path_Connected Homeomorphism
hoelzl@33741
    19
begin
hoelzl@33741
    20
nipkow@68617
    21
subsection \<open>Unit cubes\<close>
nipkow@68617
    22
nipkow@68617
    23
(* FIXME mv euclidean topological space *)
nipkow@68617
    24
definition unit_cube :: "'a::euclidean_space set"
nipkow@68617
    25
  where "unit_cube = {x. \<forall>i\<in>Basis. 0 \<le> x \<bullet> i \<and> x \<bullet> i \<le> 1}"
nipkow@68617
    26
nipkow@68617
    27
lemma mem_unit_cube: "x \<in> unit_cube \<longleftrightarrow> (\<forall>i\<in>Basis. 0 \<le> x \<bullet> i \<and> x \<bullet> i \<le> 1)"
nipkow@68617
    28
  unfolding unit_cube_def by simp
nipkow@68617
    29
nipkow@68617
    30
lemma bounded_unit_cube: "bounded unit_cube"
nipkow@68617
    31
  unfolding bounded_def
nipkow@68617
    32
proof (intro exI ballI)
nipkow@68617
    33
  fix y :: 'a assume y: "y \<in> unit_cube"
nipkow@68617
    34
  have "dist 0 y = norm y" by (rule dist_0_norm)
nipkow@68617
    35
  also have "\<dots> = norm (\<Sum>i\<in>Basis. (y \<bullet> i) *\<^sub>R i)" unfolding euclidean_representation ..
nipkow@68617
    36
  also have "\<dots> \<le> (\<Sum>i\<in>Basis. norm ((y \<bullet> i) *\<^sub>R i))" by (rule norm_sum)
nipkow@68617
    37
  also have "\<dots> \<le> (\<Sum>i::'a\<in>Basis. 1)"
nipkow@68617
    38
    by (rule sum_mono, simp add: y [unfolded mem_unit_cube])
nipkow@68617
    39
  finally show "dist 0 y \<le> (\<Sum>i::'a\<in>Basis. 1)" .
nipkow@68617
    40
qed
nipkow@68617
    41
nipkow@68617
    42
lemma closed_unit_cube: "closed unit_cube"
nipkow@68617
    43
  unfolding unit_cube_def Collect_ball_eq Collect_conj_eq
nipkow@68617
    44
  by (rule closed_INT, auto intro!: closed_Collect_le continuous_on_inner continuous_on_const continuous_on_id)
nipkow@68617
    45
nipkow@68617
    46
lemma compact_unit_cube: "compact unit_cube" (is "compact ?C")
nipkow@68617
    47
  unfolding compact_eq_seq_compact_metric
nipkow@68617
    48
  using bounded_unit_cube closed_unit_cube
nipkow@68617
    49
  by (rule bounded_closed_imp_seq_compact)
nipkow@68617
    50
nipkow@68617
    51
lemma convex_unit_cube: "convex unit_cube"
nipkow@68617
    52
  by (rule is_interval_convex) (fastforce simp add: is_interval_def mem_unit_cube)
nipkow@68617
    53
nipkow@68617
    54
nipkow@68617
    55
(* FIXME mv topology euclidean space *)
nipkow@68617
    56
subsection \<open>Retractions\<close>
nipkow@68617
    57
nipkow@68617
    58
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)"
nipkow@68617
    59
nipkow@68617
    60
definition retract_of (infixl "retract'_of" 50)
nipkow@68617
    61
  where "(T retract_of S) \<longleftrightarrow> (\<exists>r. retraction S T r)"
nipkow@68617
    62
nipkow@68617
    63
lemma retraction_idempotent: "retraction S T r \<Longrightarrow> x \<in> S \<Longrightarrow>  r (r x) = r x"
nipkow@68617
    64
  unfolding retraction_def by auto
nipkow@68617
    65
nipkow@68617
    66
text \<open>Preservation of fixpoints under (more general notion of) retraction\<close>
nipkow@68617
    67
nipkow@68617
    68
lemma invertible_fixpoint_property:
nipkow@68617
    69
  fixes S :: "'a::euclidean_space set"
nipkow@68617
    70
    and T :: "'b::euclidean_space set"
nipkow@68617
    71
  assumes contt: "continuous_on T i"
nipkow@68617
    72
    and "i ` T \<subseteq> S"
nipkow@68617
    73
    and contr: "continuous_on S r"
nipkow@68617
    74
    and "r ` S \<subseteq> T"
nipkow@68617
    75
    and ri: "\<And>y. y \<in> T \<Longrightarrow> r (i y) = y"
nipkow@68617
    76
    and FP: "\<And>f. \<lbrakk>continuous_on S f; f ` S \<subseteq> S\<rbrakk> \<Longrightarrow> \<exists>x\<in>S. f x = x"
nipkow@68617
    77
    and contg: "continuous_on T g"
nipkow@68617
    78
    and "g ` T \<subseteq> T"
nipkow@68617
    79
  obtains y where "y \<in> T" and "g y = y"
nipkow@68617
    80
proof -
nipkow@68617
    81
  have "\<exists>x\<in>S. (i \<circ> g \<circ> r) x = x"
nipkow@68617
    82
  proof (rule FP)
nipkow@68617
    83
    show "continuous_on S (i \<circ> g \<circ> r)"
nipkow@68617
    84
      by (meson contt contr assms(4) contg assms(8) continuous_on_compose continuous_on_subset)
nipkow@68617
    85
    show "(i \<circ> g \<circ> r) ` S \<subseteq> S"
nipkow@68617
    86
      using assms(2,4,8) by force
nipkow@68617
    87
  qed
nipkow@68617
    88
  then obtain x where x: "x \<in> S" "(i \<circ> g \<circ> r) x = x" ..
nipkow@68617
    89
  then have *: "g (r x) \<in> T"
nipkow@68617
    90
    using assms(4,8) by auto
nipkow@68617
    91
  have "r ((i \<circ> g \<circ> r) x) = r x"
nipkow@68617
    92
    using x by auto
nipkow@68617
    93
  then show ?thesis
nipkow@68617
    94
    using "*" ri that by auto
nipkow@68617
    95
qed
nipkow@68617
    96
nipkow@68617
    97
lemma homeomorphic_fixpoint_property:
nipkow@68617
    98
  fixes S :: "'a::euclidean_space set"
nipkow@68617
    99
    and T :: "'b::euclidean_space set"
nipkow@68617
   100
  assumes "S homeomorphic T"
nipkow@68617
   101
  shows "(\<forall>f. continuous_on S f \<and> f ` S \<subseteq> S \<longrightarrow> (\<exists>x\<in>S. f x = x)) \<longleftrightarrow>
nipkow@68617
   102
         (\<forall>g. continuous_on T g \<and> g ` T \<subseteq> T \<longrightarrow> (\<exists>y\<in>T. g y = y))"
nipkow@68617
   103
         (is "?lhs = ?rhs")
nipkow@68617
   104
proof -
nipkow@68617
   105
  obtain r i where r:
nipkow@68617
   106
      "\<forall>x\<in>S. i (r x) = x" "r ` S = T" "continuous_on S r"
nipkow@68617
   107
      "\<forall>y\<in>T. r (i y) = y" "i ` T = S" "continuous_on T i"
nipkow@68617
   108
    using assms unfolding homeomorphic_def homeomorphism_def  by blast
nipkow@68617
   109
  show ?thesis
nipkow@68617
   110
  proof
nipkow@68617
   111
    assume ?lhs
nipkow@68617
   112
    with r show ?rhs
nipkow@68617
   113
      by (metis invertible_fixpoint_property[of T i S r] order_refl)
nipkow@68617
   114
  next
nipkow@68617
   115
    assume ?rhs
nipkow@68617
   116
    with r show ?lhs
nipkow@68617
   117
      by (metis invertible_fixpoint_property[of S r T i] order_refl)
nipkow@68617
   118
  qed
nipkow@68617
   119
qed
nipkow@68617
   120
nipkow@68617
   121
lemma retract_fixpoint_property:
nipkow@68617
   122
  fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
nipkow@68617
   123
    and S :: "'a set"
nipkow@68617
   124
  assumes "T retract_of S"
nipkow@68617
   125
    and FP: "\<And>f. \<lbrakk>continuous_on S f; f ` S \<subseteq> S\<rbrakk> \<Longrightarrow> \<exists>x\<in>S. f x = x"
nipkow@68617
   126
    and contg: "continuous_on T g"
nipkow@68617
   127
    and "g ` T \<subseteq> T"
nipkow@68617
   128
  obtains y where "y \<in> T" and "g y = y"
nipkow@68617
   129
proof -
nipkow@68617
   130
  obtain h where "retraction S T h"
nipkow@68617
   131
    using assms(1) unfolding retract_of_def ..
nipkow@68617
   132
  then show ?thesis
nipkow@68617
   133
    unfolding retraction_def
nipkow@68617
   134
    using invertible_fixpoint_property[OF continuous_on_id _ _ _ _ FP]
nipkow@68617
   135
    by (metis assms(4) contg image_ident that)
nipkow@68617
   136
qed
nipkow@68617
   137
nipkow@68617
   138
lemma retraction:
nipkow@68617
   139
   "retraction S T r \<longleftrightarrow>
nipkow@68617
   140
    T \<subseteq> S \<and> continuous_on S r \<and> r ` S = T \<and> (\<forall>x \<in> T. r x = x)"
nipkow@68617
   141
by (force simp: retraction_def)
nipkow@68617
   142
nipkow@68617
   143
lemma retract_of_imp_extensible:
nipkow@68617
   144
  assumes "S retract_of T" and "continuous_on S f" and "f ` S \<subseteq> U"
nipkow@68617
   145
  obtains g where "continuous_on T g" "g ` T \<subseteq> U" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
nipkow@68617
   146
using assms
nipkow@68617
   147
apply (clarsimp simp add: retract_of_def retraction)
nipkow@68617
   148
apply (rule_tac g = "f \<circ> r" in that)
nipkow@68617
   149
apply (auto simp: continuous_on_compose2)
nipkow@68617
   150
done
nipkow@68617
   151
nipkow@68617
   152
lemma idempotent_imp_retraction:
nipkow@68617
   153
  assumes "continuous_on S f" and "f ` S \<subseteq> S" and "\<And>x. x \<in> S \<Longrightarrow> f(f x) = f x"
nipkow@68617
   154
    shows "retraction S (f ` S) f"
nipkow@68617
   155
by (simp add: assms retraction)
nipkow@68617
   156
nipkow@68617
   157
lemma retraction_subset:
nipkow@68617
   158
  assumes "retraction S T r" and "T \<subseteq> s'" and "s' \<subseteq> S"
nipkow@68617
   159
  shows "retraction s' T r"
nipkow@68617
   160
  unfolding retraction_def
nipkow@68617
   161
  by (metis assms continuous_on_subset image_mono retraction)
nipkow@68617
   162
nipkow@68617
   163
lemma retract_of_subset:
nipkow@68617
   164
  assumes "T retract_of S" and "T \<subseteq> s'" and "s' \<subseteq> S"
nipkow@68617
   165
    shows "T retract_of s'"
nipkow@68617
   166
by (meson assms retract_of_def retraction_subset)
nipkow@68617
   167
nipkow@68617
   168
lemma retraction_refl [simp]: "retraction S S (\<lambda>x. x)"
nipkow@68617
   169
by (simp add: continuous_on_id retraction)
nipkow@68617
   170
nipkow@68617
   171
lemma retract_of_refl [iff]: "S retract_of S"
nipkow@68617
   172
  unfolding retract_of_def retraction_def
nipkow@68617
   173
  using continuous_on_id by blast
nipkow@68617
   174
nipkow@68617
   175
lemma retract_of_imp_subset:
nipkow@68617
   176
   "S retract_of T \<Longrightarrow> S \<subseteq> T"
nipkow@68617
   177
by (simp add: retract_of_def retraction_def)
nipkow@68617
   178
nipkow@68617
   179
lemma retract_of_empty [simp]:
nipkow@68617
   180
     "({} retract_of S) \<longleftrightarrow> S = {}"  "(S retract_of {}) \<longleftrightarrow> S = {}"
nipkow@68617
   181
by (auto simp: retract_of_def retraction_def)
nipkow@68617
   182
nipkow@68617
   183
lemma retract_of_singleton [iff]: "({x} retract_of S) \<longleftrightarrow> x \<in> S"
nipkow@68617
   184
  unfolding retract_of_def retraction_def by force
nipkow@68617
   185
nipkow@68617
   186
lemma retraction_comp:
nipkow@68617
   187
   "\<lbrakk>retraction S T f; retraction T U g\<rbrakk>
nipkow@68617
   188
        \<Longrightarrow> retraction S U (g \<circ> f)"
nipkow@68617
   189
apply (auto simp: retraction_def intro: continuous_on_compose2)
nipkow@68617
   190
by blast
nipkow@68617
   191
nipkow@68617
   192
lemma retract_of_trans [trans]:
nipkow@68617
   193
  assumes "S retract_of T" and "T retract_of U"
nipkow@68617
   194
    shows "S retract_of U"
nipkow@68617
   195
using assms by (auto simp: retract_of_def intro: retraction_comp)
nipkow@68617
   196
nipkow@68617
   197
lemma closedin_retract:
nipkow@68617
   198
  fixes S :: "'a :: real_normed_vector set"
nipkow@68617
   199
  assumes "S retract_of T"
nipkow@68617
   200
    shows "closedin (subtopology euclidean T) S"
nipkow@68617
   201
proof -
nipkow@68617
   202
  obtain r where "S \<subseteq> T" "continuous_on T r" "r ` T \<subseteq> S" "\<And>x. x \<in> S \<Longrightarrow> r x = x"
nipkow@68617
   203
    using assms by (auto simp: retract_of_def retraction_def)
nipkow@68617
   204
  then have S: "S = {x \<in> T. (norm(r x - x)) = 0}" by auto
nipkow@68617
   205
  show ?thesis
nipkow@68617
   206
    apply (subst S)
nipkow@68617
   207
    apply (rule continuous_closedin_preimage_constant)
nipkow@68617
   208
    by (simp add: \<open>continuous_on T r\<close> continuous_on_diff continuous_on_id continuous_on_norm)
nipkow@68617
   209
qed
nipkow@68617
   210
nipkow@68617
   211
lemma closedin_self [simp]:
nipkow@68617
   212
    fixes S :: "'a :: real_normed_vector set"
nipkow@68617
   213
    shows "closedin (subtopology euclidean S) S"
nipkow@68617
   214
  by (simp add: closedin_retract)
nipkow@68617
   215
nipkow@68617
   216
lemma retract_of_contractible:
nipkow@68617
   217
  assumes "contractible T" "S retract_of T"
nipkow@68617
   218
    shows "contractible S"
nipkow@68617
   219
using assms
nipkow@68617
   220
apply (clarsimp simp add: retract_of_def contractible_def retraction_def homotopic_with)
nipkow@68617
   221
apply (rule_tac x="r a" in exI)
nipkow@68617
   222
apply (rule_tac x="r \<circ> h" in exI)
nipkow@68617
   223
apply (intro conjI continuous_intros continuous_on_compose)
nipkow@68617
   224
apply (erule continuous_on_subset | force)+
nipkow@68617
   225
done
nipkow@68617
   226
nipkow@68617
   227
lemma retract_of_compact:
nipkow@68617
   228
     "\<lbrakk>compact T; S retract_of T\<rbrakk> \<Longrightarrow> compact S"
nipkow@68617
   229
  by (metis compact_continuous_image retract_of_def retraction)
nipkow@68617
   230
nipkow@68617
   231
lemma retract_of_closed:
nipkow@68617
   232
    fixes S :: "'a :: real_normed_vector set"
nipkow@68617
   233
    shows "\<lbrakk>closed T; S retract_of T\<rbrakk> \<Longrightarrow> closed S"
nipkow@68617
   234
  by (metis closedin_retract closedin_closed_eq)
nipkow@68617
   235
nipkow@68617
   236
lemma retract_of_connected:
nipkow@68617
   237
    "\<lbrakk>connected T; S retract_of T\<rbrakk> \<Longrightarrow> connected S"
nipkow@68617
   238
  by (metis Topological_Spaces.connected_continuous_image retract_of_def retraction)
nipkow@68617
   239
nipkow@68617
   240
lemma retract_of_path_connected:
nipkow@68617
   241
    "\<lbrakk>path_connected T; S retract_of T\<rbrakk> \<Longrightarrow> path_connected S"
nipkow@68617
   242
  by (metis path_connected_continuous_image retract_of_def retraction)
nipkow@68617
   243
nipkow@68617
   244
lemma retract_of_simply_connected:
nipkow@68617
   245
    "\<lbrakk>simply_connected T; S retract_of T\<rbrakk> \<Longrightarrow> simply_connected S"
nipkow@68617
   246
apply (simp add: retract_of_def retraction_def, clarify)
nipkow@68617
   247
apply (rule simply_connected_retraction_gen)
nipkow@68617
   248
apply (force simp: continuous_on_id elim!: continuous_on_subset)+
nipkow@68617
   249
done
nipkow@68617
   250
nipkow@68617
   251
lemma retract_of_homotopically_trivial:
nipkow@68617
   252
  assumes ts: "T retract_of S"
nipkow@68617
   253
      and hom: "\<And>f g. \<lbrakk>continuous_on U f; f ` U \<subseteq> S;
nipkow@68617
   254
                       continuous_on U g; g ` U \<subseteq> S\<rbrakk>
nipkow@68617
   255
                       \<Longrightarrow> homotopic_with (\<lambda>x. True) U S f g"
nipkow@68617
   256
      and "continuous_on U f" "f ` U \<subseteq> T"
nipkow@68617
   257
      and "continuous_on U g" "g ` U \<subseteq> T"
nipkow@68617
   258
    shows "homotopic_with (\<lambda>x. True) U T f g"
nipkow@68617
   259
proof -
nipkow@68617
   260
  obtain r where "r ` S \<subseteq> S" "continuous_on S r" "\<forall>x\<in>S. r (r x) = r x" "T = r ` S"
nipkow@68617
   261
    using ts by (auto simp: retract_of_def retraction)
nipkow@68617
   262
  then obtain k where "Retracts S r T k"
nipkow@68617
   263
    unfolding Retracts_def
nipkow@68617
   264
    by (metis continuous_on_subset dual_order.trans image_iff image_mono)
nipkow@68617
   265
  then show ?thesis
nipkow@68617
   266
    apply (rule Retracts.homotopically_trivial_retraction_gen)
nipkow@68617
   267
    using assms
nipkow@68617
   268
    apply (force simp: hom)+
nipkow@68617
   269
    done
nipkow@68617
   270
qed
nipkow@68617
   271
nipkow@68617
   272
lemma retract_of_homotopically_trivial_null:
nipkow@68617
   273
  assumes ts: "T retract_of S"
nipkow@68617
   274
      and hom: "\<And>f. \<lbrakk>continuous_on U f; f ` U \<subseteq> S\<rbrakk>
nipkow@68617
   275
                     \<Longrightarrow> \<exists>c. homotopic_with (\<lambda>x. True) U S f (\<lambda>x. c)"
nipkow@68617
   276
      and "continuous_on U f" "f ` U \<subseteq> T"
nipkow@68617
   277
  obtains c where "homotopic_with (\<lambda>x. True) U T f (\<lambda>x. c)"
nipkow@68617
   278
proof -
nipkow@68617
   279
  obtain r where "r ` S \<subseteq> S" "continuous_on S r" "\<forall>x\<in>S. r (r x) = r x" "T = r ` S"
nipkow@68617
   280
    using ts by (auto simp: retract_of_def retraction)
nipkow@68617
   281
  then obtain k where "Retracts S r T k"
nipkow@68617
   282
    unfolding Retracts_def
nipkow@68617
   283
    by (metis continuous_on_subset dual_order.trans image_iff image_mono)
nipkow@68617
   284
  then show ?thesis
nipkow@68617
   285
    apply (rule Retracts.homotopically_trivial_retraction_null_gen)
nipkow@68617
   286
    apply (rule TrueI refl assms that | assumption)+
nipkow@68617
   287
    done
nipkow@68617
   288
qed
nipkow@68617
   289
nipkow@68617
   290
lemma retraction_imp_quotient_map:
nipkow@68617
   291
   "retraction S T r
nipkow@68617
   292
    \<Longrightarrow> U \<subseteq> T
nipkow@68617
   293
            \<Longrightarrow> (openin (subtopology euclidean S) (S \<inter> r -` U) \<longleftrightarrow>
nipkow@68617
   294
                 openin (subtopology euclidean T) U)"
nipkow@68617
   295
apply (clarsimp simp add: retraction)
nipkow@68617
   296
apply (rule continuous_right_inverse_imp_quotient_map [where g=r])
nipkow@68617
   297
apply (auto simp: elim: continuous_on_subset)
nipkow@68617
   298
done
nipkow@68617
   299
nipkow@68617
   300
lemma retract_of_locally_compact:
nipkow@68617
   301
    fixes S :: "'a :: {heine_borel,real_normed_vector} set"
nipkow@68617
   302
    shows  "\<lbrakk> locally compact S; T retract_of S\<rbrakk> \<Longrightarrow> locally compact T"
nipkow@68617
   303
  by (metis locally_compact_closedin closedin_retract)
nipkow@68617
   304
nipkow@68617
   305
lemma retract_of_Times:
nipkow@68617
   306
   "\<lbrakk>S retract_of s'; T retract_of t'\<rbrakk> \<Longrightarrow> (S \<times> T) retract_of (s' \<times> t')"
nipkow@68617
   307
apply (simp add: retract_of_def retraction_def Sigma_mono, clarify)
nipkow@68617
   308
apply (rename_tac f g)
nipkow@68617
   309
apply (rule_tac x="\<lambda>z. ((f \<circ> fst) z, (g \<circ> snd) z)" in exI)
nipkow@68617
   310
apply (rule conjI continuous_intros | erule continuous_on_subset | force)+
nipkow@68617
   311
done
nipkow@68617
   312
nipkow@68617
   313
lemma homotopic_into_retract:
nipkow@68617
   314
   "\<lbrakk>f ` S \<subseteq> T; g ` S \<subseteq> T; T retract_of U; homotopic_with (\<lambda>x. True) S U f g\<rbrakk>
nipkow@68617
   315
        \<Longrightarrow> homotopic_with (\<lambda>x. True) S T f g"
nipkow@68617
   316
apply (subst (asm) homotopic_with_def)
nipkow@68617
   317
apply (simp add: homotopic_with retract_of_def retraction_def, clarify)
nipkow@68617
   318
apply (rule_tac x="r \<circ> h" in exI)
nipkow@68617
   319
apply (rule conjI continuous_intros | erule continuous_on_subset | force simp: image_subset_iff)+
nipkow@68617
   320
done
nipkow@68617
   321
nipkow@68617
   322
lemma retract_of_locally_connected:
nipkow@68617
   323
  assumes "locally connected T" "S retract_of T"
nipkow@68617
   324
    shows "locally connected S"
nipkow@68617
   325
  using assms
nipkow@68617
   326
  by (auto simp: retract_of_def retraction intro!: retraction_imp_quotient_map elim!: locally_connected_quotient_image)
nipkow@68617
   327
nipkow@68617
   328
lemma retract_of_locally_path_connected:
nipkow@68617
   329
  assumes "locally path_connected T" "S retract_of T"
nipkow@68617
   330
    shows "locally path_connected S"
nipkow@68617
   331
  using assms
nipkow@68617
   332
  by (auto simp: retract_of_def retraction intro!: retraction_imp_quotient_map elim!: locally_path_connected_quotient_image)
nipkow@68617
   333
nipkow@68617
   334
text \<open>A few simple lemmas about deformation retracts\<close>
nipkow@68617
   335
nipkow@68617
   336
lemma deformation_retract_imp_homotopy_eqv:
nipkow@68617
   337
  fixes S :: "'a::euclidean_space set"
nipkow@68617
   338
  assumes "homotopic_with (\<lambda>x. True) S S id r" and r: "retraction S T r"
nipkow@68617
   339
  shows "S homotopy_eqv T"
nipkow@68617
   340
proof -
nipkow@68617
   341
  have "homotopic_with (\<lambda>x. True) S S (id \<circ> r) id"
nipkow@68617
   342
    by (simp add: assms(1) homotopic_with_symD)
nipkow@68617
   343
  moreover have "homotopic_with (\<lambda>x. True) T T (r \<circ> id) id"
nipkow@68617
   344
    using r unfolding retraction_def
nipkow@68617
   345
    by (metis (no_types, lifting) comp_id continuous_on_id' homotopic_with_equal homotopic_with_symD id_def image_id order_refl)
nipkow@68617
   346
  ultimately
nipkow@68617
   347
  show ?thesis
nipkow@68617
   348
    unfolding homotopy_eqv_def
nipkow@68617
   349
    by (metis continuous_on_id' id_def image_id r retraction_def)
nipkow@68617
   350
qed
nipkow@68617
   351
nipkow@68617
   352
lemma deformation_retract:
nipkow@68617
   353
  fixes S :: "'a::euclidean_space set"
nipkow@68617
   354
    shows "(\<exists>r. homotopic_with (\<lambda>x. True) S S id r \<and> retraction S T r) \<longleftrightarrow>
nipkow@68617
   355
           T retract_of S \<and> (\<exists>f. homotopic_with (\<lambda>x. True) S S id f \<and> f ` S \<subseteq> T)"
nipkow@68617
   356
    (is "?lhs = ?rhs")
nipkow@68617
   357
proof
nipkow@68617
   358
  assume ?lhs
nipkow@68617
   359
  then show ?rhs
nipkow@68617
   360
    by (auto simp: retract_of_def retraction_def)
nipkow@68617
   361
next
nipkow@68617
   362
  assume ?rhs
nipkow@68617
   363
  then show ?lhs
nipkow@68617
   364
    apply (clarsimp simp add: retract_of_def retraction_def)
nipkow@68617
   365
    apply (rule_tac x=r in exI, simp)
nipkow@68617
   366
     apply (rule homotopic_with_trans, assumption)
nipkow@68617
   367
     apply (rule_tac f = "r \<circ> f" and g="r \<circ> id" in homotopic_with_eq)
nipkow@68617
   368
        apply (rule_tac Y=S in homotopic_compose_continuous_left)
nipkow@68617
   369
         apply (auto simp: homotopic_with_sym)
nipkow@68617
   370
    done
nipkow@68617
   371
qed
nipkow@68617
   372
nipkow@68617
   373
lemma deformation_retract_of_contractible_sing:
nipkow@68617
   374
  fixes S :: "'a::euclidean_space set"
nipkow@68617
   375
  assumes "contractible S" "a \<in> S"
nipkow@68617
   376
  obtains r where "homotopic_with (\<lambda>x. True) S S id r" "retraction S {a} r"
nipkow@68617
   377
proof -
nipkow@68617
   378
  have "{a} retract_of S"
nipkow@68617
   379
    by (simp add: \<open>a \<in> S\<close>)
nipkow@68617
   380
  moreover have "homotopic_with (\<lambda>x. True) S S id (\<lambda>x. a)"
nipkow@68617
   381
      using assms
nipkow@68617
   382
      by (auto simp: contractible_def continuous_on_const continuous_on_id homotopic_into_contractible image_subset_iff)
nipkow@68617
   383
  moreover have "(\<lambda>x. a) ` S \<subseteq> {a}"
nipkow@68617
   384
    by (simp add: image_subsetI)
nipkow@68617
   385
  ultimately show ?thesis
nipkow@68617
   386
    using that deformation_retract  by metis
nipkow@68617
   387
qed
nipkow@68617
   388
nipkow@68617
   389
nipkow@68617
   390
lemma continuous_on_compact_surface_projection_aux:
nipkow@68617
   391
  fixes S :: "'a::t2_space set"
nipkow@68617
   392
  assumes "compact S" "S \<subseteq> T" "image q T \<subseteq> S"
nipkow@68617
   393
      and contp: "continuous_on T p"
nipkow@68617
   394
      and "\<And>x. x \<in> S \<Longrightarrow> q x = x"
nipkow@68617
   395
      and [simp]: "\<And>x. x \<in> T \<Longrightarrow> q(p x) = q x"
nipkow@68617
   396
      and "\<And>x. x \<in> T \<Longrightarrow> p(q x) = p x"
nipkow@68617
   397
    shows "continuous_on T q"
nipkow@68617
   398
proof -
nipkow@68617
   399
  have *: "image p T = image p S"
nipkow@68617
   400
    using assms by auto (metis imageI subset_iff)
nipkow@68617
   401
  have contp': "continuous_on S p"
nipkow@68617
   402
    by (rule continuous_on_subset [OF contp \<open>S \<subseteq> T\<close>])
nipkow@68617
   403
  have "continuous_on (p ` T) q"
nipkow@68617
   404
    by (simp add: "*" assms(1) assms(2) assms(5) continuous_on_inv contp' rev_subsetD)
nipkow@68617
   405
  then have "continuous_on T (q \<circ> p)"
nipkow@68617
   406
    by (rule continuous_on_compose [OF contp])
nipkow@68617
   407
  then show ?thesis
nipkow@68617
   408
    by (rule continuous_on_eq [of _ "q \<circ> p"]) (simp add: o_def)
nipkow@68617
   409
qed
nipkow@68617
   410
nipkow@68617
   411
lemma continuous_on_compact_surface_projection:
nipkow@68617
   412
  fixes S :: "'a::real_normed_vector set"
nipkow@68617
   413
  assumes "compact S"
nipkow@68617
   414
      and S: "S \<subseteq> V - {0}" and "cone V"
nipkow@68617
   415
      and iff: "\<And>x k. x \<in> V - {0} \<Longrightarrow> 0 < k \<and> (k *\<^sub>R x) \<in> S \<longleftrightarrow> d x = k"
nipkow@68617
   416
  shows "continuous_on (V - {0}) (\<lambda>x. d x *\<^sub>R x)"
nipkow@68617
   417
proof (rule continuous_on_compact_surface_projection_aux [OF \<open>compact S\<close> S])
nipkow@68617
   418
  show "(\<lambda>x. d x *\<^sub>R x) ` (V - {0}) \<subseteq> S"
nipkow@68617
   419
    using iff by auto
nipkow@68617
   420
  show "continuous_on (V - {0}) (\<lambda>x. inverse(norm x) *\<^sub>R x)"
nipkow@68617
   421
    by (intro continuous_intros) force
nipkow@68617
   422
  show "\<And>x. x \<in> S \<Longrightarrow> d x *\<^sub>R x = x"
nipkow@68617
   423
    by (metis S zero_less_one local.iff scaleR_one subset_eq)
nipkow@68617
   424
  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
nipkow@68617
   425
    using iff [of "inverse(norm x) *\<^sub>R x" "norm x * d x", symmetric] iff that \<open>cone V\<close>
nipkow@68617
   426
    by (simp add: field_simps cone_def zero_less_mult_iff)
nipkow@68617
   427
  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
nipkow@68617
   428
  proof -
nipkow@68617
   429
    have "0 < d x"
nipkow@68617
   430
      using local.iff that by blast
nipkow@68617
   431
    then show ?thesis
nipkow@68617
   432
      by simp
nipkow@68617
   433
  qed
nipkow@68617
   434
qed
nipkow@68617
   435
nipkow@68617
   436
subsection \<open>Absolute retracts, absolute neighbourhood retracts (ANR) and Euclidean neighbourhood retracts (ENR)\<close>
nipkow@68617
   437
nipkow@68617
   438
text \<open>Absolute retracts (AR), absolute neighbourhood retracts (ANR) and also Euclidean neighbourhood
nipkow@68617
   439
retracts (ENR). We define AR and ANR by specializing the standard definitions for a set to embedding
nipkow@68617
   440
in spaces of higher dimension.
nipkow@68617
   441
nipkow@68617
   442
John Harrison writes: "This turns out to be sufficient (since any set in $\mathbb{R}^n$ can be
nipkow@68617
   443
embedded as a closed subset of a convex subset of $\mathbb{R}^{n+1}$) to derive the usual
nipkow@68617
   444
definitions, but we need to split them into two implications because of the lack of type
nipkow@68617
   445
quantifiers. Then ENR turns out to be equivalent to ANR plus local compactness."\<close>
nipkow@68617
   446
nipkow@68617
   447
definition AR :: "'a::topological_space set => bool"
nipkow@68617
   448
  where
nipkow@68617
   449
   "AR S \<equiv> \<forall>U. \<forall>S'::('a * real) set. S homeomorphic S' \<and> closedin (subtopology euclidean U) S'
nipkow@68617
   450
                \<longrightarrow> S' retract_of U"
nipkow@68617
   451
nipkow@68617
   452
definition ANR :: "'a::topological_space set => bool"
nipkow@68617
   453
  where
nipkow@68617
   454
   "ANR S \<equiv> \<forall>U. \<forall>S'::('a * real) set. S homeomorphic S' \<and> closedin (subtopology euclidean U) S'
nipkow@68617
   455
                \<longrightarrow> (\<exists>T. openin (subtopology euclidean U) T \<and>
nipkow@68617
   456
                        S' retract_of T)"
nipkow@68617
   457
nipkow@68617
   458
definition ENR :: "'a::topological_space set => bool"
nipkow@68617
   459
  where "ENR S \<equiv> \<exists>U. open U \<and> S retract_of U"
nipkow@68617
   460
nipkow@68617
   461
text \<open>First, show that we do indeed get the "usual" properties of ARs and ANRs.\<close>
nipkow@68617
   462
nipkow@68617
   463
lemma AR_imp_absolute_extensor:
nipkow@68617
   464
  fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
nipkow@68617
   465
  assumes "AR S" and contf: "continuous_on T f" and "f ` T \<subseteq> S"
nipkow@68617
   466
      and cloUT: "closedin (subtopology euclidean U) T"
nipkow@68617
   467
  obtains g where "continuous_on U g" "g ` U \<subseteq> S" "\<And>x. x \<in> T \<Longrightarrow> g x = f x"
nipkow@68617
   468
proof -
nipkow@68617
   469
  have "aff_dim S < int (DIM('b \<times> real))"
nipkow@68617
   470
    using aff_dim_le_DIM [of S] by simp
nipkow@68617
   471
  then obtain C and S' :: "('b * real) set"
nipkow@68617
   472
          where C: "convex C" "C \<noteq> {}"
nipkow@68617
   473
            and cloCS: "closedin (subtopology euclidean C) S'"
nipkow@68617
   474
            and hom: "S homeomorphic S'"
nipkow@68617
   475
    by (metis that homeomorphic_closedin_convex)
nipkow@68617
   476
  then have "S' retract_of C"
nipkow@68617
   477
    using \<open>AR S\<close> by (simp add: AR_def)
nipkow@68617
   478
  then obtain r where "S' \<subseteq> C" and contr: "continuous_on C r"
nipkow@68617
   479
                  and "r ` C \<subseteq> S'" and rid: "\<And>x. x\<in>S' \<Longrightarrow> r x = x"
nipkow@68617
   480
    by (auto simp: retraction_def retract_of_def)
nipkow@68617
   481
  obtain g h where "homeomorphism S S' g h"
nipkow@68617
   482
    using hom by (force simp: homeomorphic_def)
nipkow@68617
   483
  then have "continuous_on (f ` T) g"
nipkow@68617
   484
    by (meson \<open>f ` T \<subseteq> S\<close> continuous_on_subset homeomorphism_def)
nipkow@68617
   485
  then have contgf: "continuous_on T (g \<circ> f)"
nipkow@68617
   486
    by (metis continuous_on_compose contf)
nipkow@68617
   487
  have gfTC: "(g \<circ> f) ` T \<subseteq> C"
nipkow@68617
   488
  proof -
nipkow@68617
   489
    have "g ` S = S'"
nipkow@68617
   490
      by (metis (no_types) \<open>homeomorphism S S' g h\<close> homeomorphism_def)
nipkow@68617
   491
    with \<open>S' \<subseteq> C\<close> \<open>f ` T \<subseteq> S\<close> show ?thesis by force
nipkow@68617
   492
  qed
nipkow@68617
   493
  obtain f' where f': "continuous_on U f'"  "f' ` U \<subseteq> C"
nipkow@68617
   494
                      "\<And>x. x \<in> T \<Longrightarrow> f' x = (g \<circ> f) x"
nipkow@68617
   495
    by (metis Dugundji [OF C cloUT contgf gfTC])
nipkow@68617
   496
  show ?thesis
nipkow@68617
   497
  proof (rule_tac g = "h \<circ> r \<circ> f'" in that)
nipkow@68617
   498
    show "continuous_on U (h \<circ> r \<circ> f')"
nipkow@68617
   499
      apply (intro continuous_on_compose f')
nipkow@68617
   500
       using continuous_on_subset contr f' apply blast
nipkow@68617
   501
      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)
nipkow@68617
   502
    show "(h \<circ> r \<circ> f') ` U \<subseteq> S"
nipkow@68617
   503
      using \<open>homeomorphism S S' g h\<close> \<open>r ` C \<subseteq> S'\<close> \<open>f' ` U \<subseteq> C\<close>
nipkow@68617
   504
      by (fastforce simp: homeomorphism_def)
nipkow@68617
   505
    show "\<And>x. x \<in> T \<Longrightarrow> (h \<circ> r \<circ> f') x = f x"
nipkow@68617
   506
      using \<open>homeomorphism S S' g h\<close> \<open>f ` T \<subseteq> S\<close> f'
nipkow@68617
   507
      by (auto simp: rid homeomorphism_def)
nipkow@68617
   508
  qed
nipkow@68617
   509
qed
nipkow@68617
   510
nipkow@68617
   511
lemma AR_imp_absolute_retract:
nipkow@68617
   512
  fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
nipkow@68617
   513
  assumes "AR S" "S homeomorphic S'"
nipkow@68617
   514
      and clo: "closedin (subtopology euclidean U) S'"
nipkow@68617
   515
    shows "S' retract_of U"
nipkow@68617
   516
proof -
nipkow@68617
   517
  obtain g h where hom: "homeomorphism S S' g h"
nipkow@68617
   518
    using assms by (force simp: homeomorphic_def)
nipkow@68617
   519
  have h: "continuous_on S' h" " h ` S' \<subseteq> S"
nipkow@68617
   520
    using hom homeomorphism_def apply blast
nipkow@68617
   521
    apply (metis hom equalityE homeomorphism_def)
nipkow@68617
   522
    done
nipkow@68617
   523
  obtain h' where h': "continuous_on U h'" "h' ` U \<subseteq> S"
nipkow@68617
   524
              and h'h: "\<And>x. x \<in> S' \<Longrightarrow> h' x = h x"
nipkow@68617
   525
    by (blast intro: AR_imp_absolute_extensor [OF \<open>AR S\<close> h clo])
nipkow@68617
   526
  have [simp]: "S' \<subseteq> U" using clo closedin_limpt by blast
nipkow@68617
   527
  show ?thesis
nipkow@68617
   528
  proof (simp add: retraction_def retract_of_def, intro exI conjI)
nipkow@68617
   529
    show "continuous_on U (g \<circ> h')"
nipkow@68617
   530
      apply (intro continuous_on_compose h')
nipkow@68617
   531
      apply (meson hom continuous_on_subset h' homeomorphism_cont1)
nipkow@68617
   532
      done
nipkow@68617
   533
    show "(g \<circ> h') ` U \<subseteq> S'"
nipkow@68617
   534
      using h'  by clarsimp (metis hom subsetD homeomorphism_def imageI)
nipkow@68617
   535
    show "\<forall>x\<in>S'. (g \<circ> h') x = x"
nipkow@68617
   536
      by clarsimp (metis h'h hom homeomorphism_def)
nipkow@68617
   537
  qed
nipkow@68617
   538
qed
nipkow@68617
   539
nipkow@68617
   540
lemma AR_imp_absolute_retract_UNIV:
nipkow@68617
   541
  fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
nipkow@68617
   542
  assumes "AR S" and hom: "S homeomorphic S'"
nipkow@68617
   543
      and clo: "closed S'"
nipkow@68617
   544
    shows "S' retract_of UNIV"
nipkow@68617
   545
apply (rule AR_imp_absolute_retract [OF \<open>AR S\<close> hom])
nipkow@68617
   546
using clo closed_closedin by auto
nipkow@68617
   547
nipkow@68617
   548
lemma absolute_extensor_imp_AR:
nipkow@68617
   549
  fixes S :: "'a::euclidean_space set"
nipkow@68617
   550
  assumes "\<And>f :: 'a * real \<Rightarrow> 'a.
nipkow@68617
   551
           \<And>U T. \<lbrakk>continuous_on T f;  f ` T \<subseteq> S;
nipkow@68617
   552
                  closedin (subtopology euclidean U) T\<rbrakk>
nipkow@68617
   553
                 \<Longrightarrow> \<exists>g. continuous_on U g \<and> g ` U \<subseteq> S \<and> (\<forall>x \<in> T. g x = f x)"
nipkow@68617
   554
  shows "AR S"
nipkow@68617
   555
proof (clarsimp simp: AR_def)
nipkow@68617
   556
  fix U and T :: "('a * real) set"
nipkow@68617
   557
  assume "S homeomorphic T" and clo: "closedin (subtopology euclidean U) T"
nipkow@68617
   558
  then obtain g h where hom: "homeomorphism S T g h"
nipkow@68617
   559
    by (force simp: homeomorphic_def)
nipkow@68617
   560
  have h: "continuous_on T h" " h ` T \<subseteq> S"
nipkow@68617
   561
    using hom homeomorphism_def apply blast
nipkow@68617
   562
    apply (metis hom equalityE homeomorphism_def)
nipkow@68617
   563
    done
nipkow@68617
   564
  obtain h' where h': "continuous_on U h'" "h' ` U \<subseteq> S"
nipkow@68617
   565
              and h'h: "\<forall>x\<in>T. h' x = h x"
nipkow@68617
   566
    using assms [OF h clo] by blast
nipkow@68617
   567
  have [simp]: "T \<subseteq> U"
nipkow@68617
   568
    using clo closedin_imp_subset by auto
nipkow@68617
   569
  show "T retract_of U"
nipkow@68617
   570
  proof (simp add: retraction_def retract_of_def, intro exI conjI)
nipkow@68617
   571
    show "continuous_on U (g \<circ> h')"
nipkow@68617
   572
      apply (intro continuous_on_compose h')
nipkow@68617
   573
      apply (meson hom continuous_on_subset h' homeomorphism_cont1)
nipkow@68617
   574
      done
nipkow@68617
   575
    show "(g \<circ> h') ` U \<subseteq> T"
nipkow@68617
   576
      using h'  by clarsimp (metis hom subsetD homeomorphism_def imageI)
nipkow@68617
   577
    show "\<forall>x\<in>T. (g \<circ> h') x = x"
nipkow@68617
   578
      by clarsimp (metis h'h hom homeomorphism_def)
nipkow@68617
   579
  qed
nipkow@68617
   580
qed
nipkow@68617
   581
nipkow@68617
   582
lemma AR_eq_absolute_extensor:
nipkow@68617
   583
  fixes S :: "'a::euclidean_space set"
nipkow@68617
   584
  shows "AR S \<longleftrightarrow>
nipkow@68617
   585
       (\<forall>f :: 'a * real \<Rightarrow> 'a.
nipkow@68617
   586
        \<forall>U T. continuous_on T f \<longrightarrow> f ` T \<subseteq> S \<longrightarrow>
nipkow@68617
   587
               closedin (subtopology euclidean U) T \<longrightarrow>
nipkow@68617
   588
                (\<exists>g. continuous_on U g \<and> g ` U \<subseteq> S \<and> (\<forall>x \<in> T. g x = f x)))"
nipkow@68617
   589
apply (rule iffI)
nipkow@68617
   590
 apply (metis AR_imp_absolute_extensor)
nipkow@68617
   591
apply (simp add: absolute_extensor_imp_AR)
nipkow@68617
   592
done
nipkow@68617
   593
nipkow@68617
   594
lemma AR_imp_retract:
nipkow@68617
   595
  fixes S :: "'a::euclidean_space set"
nipkow@68617
   596
  assumes "AR S \<and> closedin (subtopology euclidean U) S"
nipkow@68617
   597
    shows "S retract_of U"
nipkow@68617
   598
using AR_imp_absolute_retract assms homeomorphic_refl by blast
nipkow@68617
   599
nipkow@68617
   600
lemma AR_homeomorphic_AR:
nipkow@68617
   601
  fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
nipkow@68617
   602
  assumes "AR T" "S homeomorphic T"
nipkow@68617
   603
    shows "AR S"
nipkow@68617
   604
unfolding AR_def
nipkow@68617
   605
by (metis assms AR_imp_absolute_retract homeomorphic_trans [of _ S] homeomorphic_sym)
nipkow@68617
   606
nipkow@68617
   607
lemma homeomorphic_AR_iff_AR:
nipkow@68617
   608
  fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
nipkow@68617
   609
  shows "S homeomorphic T \<Longrightarrow> AR S \<longleftrightarrow> AR T"
nipkow@68617
   610
by (metis AR_homeomorphic_AR homeomorphic_sym)
nipkow@68617
   611
nipkow@68617
   612
nipkow@68617
   613
lemma ANR_imp_absolute_neighbourhood_extensor:
nipkow@68617
   614
  fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
nipkow@68617
   615
  assumes "ANR S" and contf: "continuous_on T f" and "f ` T \<subseteq> S"
nipkow@68617
   616
      and cloUT: "closedin (subtopology euclidean U) T"
nipkow@68617
   617
  obtains V g where "T \<subseteq> V" "openin (subtopology euclidean U) V"
nipkow@68617
   618
                    "continuous_on V g"
nipkow@68617
   619
                    "g ` V \<subseteq> S" "\<And>x. x \<in> T \<Longrightarrow> g x = f x"
nipkow@68617
   620
proof -
nipkow@68617
   621
  have "aff_dim S < int (DIM('b \<times> real))"
nipkow@68617
   622
    using aff_dim_le_DIM [of S] by simp
nipkow@68617
   623
  then obtain C and S' :: "('b * real) set"
nipkow@68617
   624
          where C: "convex C" "C \<noteq> {}"
nipkow@68617
   625
            and cloCS: "closedin (subtopology euclidean C) S'"
nipkow@68617
   626
            and hom: "S homeomorphic S'"
nipkow@68617
   627
    by (metis that homeomorphic_closedin_convex)
nipkow@68617
   628
  then obtain D where opD: "openin (subtopology euclidean C) D" and "S' retract_of D"
nipkow@68617
   629
    using \<open>ANR S\<close> by (auto simp: ANR_def)
nipkow@68617
   630
  then obtain r where "S' \<subseteq> D" and contr: "continuous_on D r"
nipkow@68617
   631
                  and "r ` D \<subseteq> S'" and rid: "\<And>x. x \<in> S' \<Longrightarrow> r x = x"
nipkow@68617
   632
    by (auto simp: retraction_def retract_of_def)
nipkow@68617
   633
  obtain g h where homgh: "homeomorphism S S' g h"
nipkow@68617
   634
    using hom by (force simp: homeomorphic_def)
nipkow@68617
   635
  have "continuous_on (f ` T) g"
nipkow@68617
   636
    by (meson \<open>f ` T \<subseteq> S\<close> continuous_on_subset homeomorphism_def homgh)
nipkow@68617
   637
  then have contgf: "continuous_on T (g \<circ> f)"
nipkow@68617
   638
    by (intro continuous_on_compose contf)
nipkow@68617
   639
  have gfTC: "(g \<circ> f) ` T \<subseteq> C"
nipkow@68617
   640
  proof -
nipkow@68617
   641
    have "g ` S = S'"
nipkow@68617
   642
      by (metis (no_types) homeomorphism_def homgh)
nipkow@68617
   643
    then show ?thesis
nipkow@68617
   644
      by (metis (no_types) assms(3) cloCS closedin_def image_comp image_mono order.trans topspace_euclidean_subtopology)
nipkow@68617
   645
  qed
nipkow@68617
   646
  obtain f' where contf': "continuous_on U f'"
nipkow@68617
   647
              and "f' ` U \<subseteq> C"
nipkow@68617
   648
              and eq: "\<And>x. x \<in> T \<Longrightarrow> f' x = (g \<circ> f) x"
nipkow@68617
   649
    by (metis Dugundji [OF C cloUT contgf gfTC])
nipkow@68617
   650
  show ?thesis
nipkow@68617
   651
  proof (rule_tac V = "U \<inter> f' -` D" and g = "h \<circ> r \<circ> f'" in that)
nipkow@68617
   652
    show "T \<subseteq> U \<inter> f' -` D"
nipkow@68617
   653
      using cloUT closedin_imp_subset \<open>S' \<subseteq> D\<close> \<open>f ` T \<subseteq> S\<close> eq homeomorphism_image1 homgh
nipkow@68617
   654
      by fastforce
nipkow@68617
   655
    show ope: "openin (subtopology euclidean U) (U \<inter> f' -` D)"
nipkow@68617
   656
      using  \<open>f' ` U \<subseteq> C\<close> by (auto simp: opD contf' continuous_openin_preimage)
nipkow@68617
   657
    have conth: "continuous_on (r ` f' ` (U \<inter> f' -` D)) h"
nipkow@68617
   658
      apply (rule continuous_on_subset [of S'])
nipkow@68617
   659
      using homeomorphism_def homgh apply blast
nipkow@68617
   660
      using \<open>r ` D \<subseteq> S'\<close> by blast
nipkow@68617
   661
    show "continuous_on (U \<inter> f' -` D) (h \<circ> r \<circ> f')"
nipkow@68617
   662
      apply (intro continuous_on_compose conth
nipkow@68617
   663
                   continuous_on_subset [OF contr] continuous_on_subset [OF contf'], auto)
nipkow@68617
   664
      done
nipkow@68617
   665
    show "(h \<circ> r \<circ> f') ` (U \<inter> f' -` D) \<subseteq> S"
nipkow@68617
   666
      using \<open>homeomorphism S S' g h\<close>  \<open>f' ` U \<subseteq> C\<close>  \<open>r ` D \<subseteq> S'\<close>
nipkow@68617
   667
      by (auto simp: homeomorphism_def)
nipkow@68617
   668
    show "\<And>x. x \<in> T \<Longrightarrow> (h \<circ> r \<circ> f') x = f x"
nipkow@68617
   669
      using \<open>homeomorphism S S' g h\<close> \<open>f ` T \<subseteq> S\<close> eq
nipkow@68617
   670
      by (auto simp: rid homeomorphism_def)
nipkow@68617
   671
  qed
nipkow@68617
   672
qed
nipkow@68617
   673
nipkow@68617
   674
nipkow@68617
   675
corollary ANR_imp_absolute_neighbourhood_retract:
nipkow@68617
   676
  fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
nipkow@68617
   677
  assumes "ANR S" "S homeomorphic S'"
nipkow@68617
   678
      and clo: "closedin (subtopology euclidean U) S'"
nipkow@68617
   679
  obtains V where "openin (subtopology euclidean U) V" "S' retract_of V"
nipkow@68617
   680
proof -
nipkow@68617
   681
  obtain g h where hom: "homeomorphism S S' g h"
nipkow@68617
   682
    using assms by (force simp: homeomorphic_def)
nipkow@68617
   683
  have h: "continuous_on S' h" " h ` S' \<subseteq> S"
nipkow@68617
   684
    using hom homeomorphism_def apply blast
nipkow@68617
   685
    apply (metis hom equalityE homeomorphism_def)
nipkow@68617
   686
    done
nipkow@68617
   687
    from ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR S\<close> h clo]
nipkow@68617
   688
  obtain V h' where "S' \<subseteq> V" and opUV: "openin (subtopology euclidean U) V"
nipkow@68617
   689
                and h': "continuous_on V h'" "h' ` V \<subseteq> S"
nipkow@68617
   690
                and h'h:"\<And>x. x \<in> S' \<Longrightarrow> h' x = h x"
nipkow@68617
   691
    by (blast intro: ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR S\<close> h clo])
nipkow@68617
   692
  have "S' retract_of V"
nipkow@68617
   693
  proof (simp add: retraction_def retract_of_def, intro exI conjI \<open>S' \<subseteq> V\<close>)
nipkow@68617
   694
    show "continuous_on V (g \<circ> h')"
nipkow@68617
   695
      apply (intro continuous_on_compose h')
nipkow@68617
   696
      apply (meson hom continuous_on_subset h' homeomorphism_cont1)
nipkow@68617
   697
      done
nipkow@68617
   698
    show "(g \<circ> h') ` V \<subseteq> S'"
nipkow@68617
   699
      using h'  by clarsimp (metis hom subsetD homeomorphism_def imageI)
nipkow@68617
   700
    show "\<forall>x\<in>S'. (g \<circ> h') x = x"
nipkow@68617
   701
      by clarsimp (metis h'h hom homeomorphism_def)
nipkow@68617
   702
  qed
nipkow@68617
   703
  then show ?thesis
nipkow@68617
   704
    by (rule that [OF opUV])
nipkow@68617
   705
qed
nipkow@68617
   706
nipkow@68617
   707
corollary ANR_imp_absolute_neighbourhood_retract_UNIV:
nipkow@68617
   708
  fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
nipkow@68617
   709
  assumes "ANR S" and hom: "S homeomorphic S'" and clo: "closed S'"
nipkow@68617
   710
  obtains V where "open V" "S' retract_of V"
nipkow@68617
   711
  using ANR_imp_absolute_neighbourhood_retract [OF \<open>ANR S\<close> hom]
nipkow@68617
   712
by (metis clo closed_closedin open_openin subtopology_UNIV)
nipkow@68617
   713
nipkow@68617
   714
corollary neighbourhood_extension_into_ANR:
nipkow@68617
   715
  fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
nipkow@68617
   716
  assumes contf: "continuous_on S f" and fim: "f ` S \<subseteq> T" and "ANR T" "closed S"
nipkow@68617
   717
  obtains V g where "S \<subseteq> V" "open V" "continuous_on V g"
nipkow@68617
   718
                    "g ` V \<subseteq> T" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
nipkow@68617
   719
  using ANR_imp_absolute_neighbourhood_extensor [OF  \<open>ANR T\<close> contf fim]
nipkow@68617
   720
  by (metis \<open>closed S\<close> closed_closedin open_openin subtopology_UNIV)
nipkow@68617
   721
nipkow@68617
   722
lemma absolute_neighbourhood_extensor_imp_ANR:
nipkow@68617
   723
  fixes S :: "'a::euclidean_space set"
nipkow@68617
   724
  assumes "\<And>f :: 'a * real \<Rightarrow> 'a.
nipkow@68617
   725
           \<And>U T. \<lbrakk>continuous_on T f;  f ` T \<subseteq> S;
nipkow@68617
   726
                  closedin (subtopology euclidean U) T\<rbrakk>
nipkow@68617
   727
                 \<Longrightarrow> \<exists>V g. T \<subseteq> V \<and> openin (subtopology euclidean U) V \<and>
nipkow@68617
   728
                       continuous_on V g \<and> g ` V \<subseteq> S \<and> (\<forall>x \<in> T. g x = f x)"
nipkow@68617
   729
  shows "ANR S"
nipkow@68617
   730
proof (clarsimp simp: ANR_def)
nipkow@68617
   731
  fix U and T :: "('a * real) set"
nipkow@68617
   732
  assume "S homeomorphic T" and clo: "closedin (subtopology euclidean U) T"
nipkow@68617
   733
  then obtain g h where hom: "homeomorphism S T g h"
nipkow@68617
   734
    by (force simp: homeomorphic_def)
nipkow@68617
   735
  have h: "continuous_on T h" " h ` T \<subseteq> S"
nipkow@68617
   736
    using hom homeomorphism_def apply blast
nipkow@68617
   737
    apply (metis hom equalityE homeomorphism_def)
nipkow@68617
   738
    done
nipkow@68617
   739
  obtain V h' where "T \<subseteq> V" and opV: "openin (subtopology euclidean U) V"
nipkow@68617
   740
                and h': "continuous_on V h'" "h' ` V \<subseteq> S"
nipkow@68617
   741
              and h'h: "\<forall>x\<in>T. h' x = h x"
nipkow@68617
   742
    using assms [OF h clo] by blast
nipkow@68617
   743
  have [simp]: "T \<subseteq> U"
nipkow@68617
   744
    using clo closedin_imp_subset by auto
nipkow@68617
   745
  have "T retract_of V"
nipkow@68617
   746
  proof (simp add: retraction_def retract_of_def, intro exI conjI \<open>T \<subseteq> V\<close>)
nipkow@68617
   747
    show "continuous_on V (g \<circ> h')"
nipkow@68617
   748
      apply (intro continuous_on_compose h')
nipkow@68617
   749
      apply (meson hom continuous_on_subset h' homeomorphism_cont1)
nipkow@68617
   750
      done
nipkow@68617
   751
    show "(g \<circ> h') ` V \<subseteq> T"
nipkow@68617
   752
      using h'  by clarsimp (metis hom subsetD homeomorphism_def imageI)
nipkow@68617
   753
    show "\<forall>x\<in>T. (g \<circ> h') x = x"
nipkow@68617
   754
      by clarsimp (metis h'h hom homeomorphism_def)
nipkow@68617
   755
  qed
nipkow@68617
   756
  then show "\<exists>V. openin (subtopology euclidean U) V \<and> T retract_of V"
nipkow@68617
   757
    using opV by blast
nipkow@68617
   758
qed
nipkow@68617
   759
nipkow@68617
   760
lemma ANR_eq_absolute_neighbourhood_extensor:
nipkow@68617
   761
  fixes S :: "'a::euclidean_space set"
nipkow@68617
   762
  shows "ANR S \<longleftrightarrow>
nipkow@68617
   763
         (\<forall>f :: 'a * real \<Rightarrow> 'a.
nipkow@68617
   764
          \<forall>U T. continuous_on T f \<longrightarrow> f ` T \<subseteq> S \<longrightarrow>
nipkow@68617
   765
                closedin (subtopology euclidean U) T \<longrightarrow>
nipkow@68617
   766
               (\<exists>V g. T \<subseteq> V \<and> openin (subtopology euclidean U) V \<and>
nipkow@68617
   767
                       continuous_on V g \<and> g ` V \<subseteq> S \<and> (\<forall>x \<in> T. g x = f x)))"
nipkow@68617
   768
apply (rule iffI)
nipkow@68617
   769
 apply (metis ANR_imp_absolute_neighbourhood_extensor)
nipkow@68617
   770
apply (simp add: absolute_neighbourhood_extensor_imp_ANR)
nipkow@68617
   771
done
nipkow@68617
   772
nipkow@68617
   773
lemma ANR_imp_neighbourhood_retract:
nipkow@68617
   774
  fixes S :: "'a::euclidean_space set"
nipkow@68617
   775
  assumes "ANR S" "closedin (subtopology euclidean U) S"
nipkow@68617
   776
  obtains V where "openin (subtopology euclidean U) V" "S retract_of V"
nipkow@68617
   777
using ANR_imp_absolute_neighbourhood_retract assms homeomorphic_refl by blast
nipkow@68617
   778
nipkow@68617
   779
lemma ANR_imp_absolute_closed_neighbourhood_retract:
nipkow@68617
   780
  fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
nipkow@68617
   781
  assumes "ANR S" "S homeomorphic S'" and US': "closedin (subtopology euclidean U) S'"
nipkow@68617
   782
  obtains V W
nipkow@68617
   783
    where "openin (subtopology euclidean U) V"
nipkow@68617
   784
          "closedin (subtopology euclidean U) W"
nipkow@68617
   785
          "S' \<subseteq> V" "V \<subseteq> W" "S' retract_of W"
nipkow@68617
   786
proof -
nipkow@68617
   787
  obtain Z where "openin (subtopology euclidean U) Z" and S'Z: "S' retract_of Z"
nipkow@68617
   788
    by (blast intro: assms ANR_imp_absolute_neighbourhood_retract)
nipkow@68617
   789
  then have UUZ: "closedin (subtopology euclidean U) (U - Z)"
nipkow@68617
   790
    by auto
nipkow@68617
   791
  have "S' \<inter> (U - Z) = {}"
nipkow@68617
   792
    using \<open>S' retract_of Z\<close> closedin_retract closedin_subtopology by fastforce
nipkow@68617
   793
  then obtain V W
nipkow@68617
   794
      where "openin (subtopology euclidean U) V"
nipkow@68617
   795
        and "openin (subtopology euclidean U) W"
nipkow@68617
   796
        and "S' \<subseteq> V" "U - Z \<subseteq> W" "V \<inter> W = {}"
nipkow@68617
   797
      using separation_normal_local [OF US' UUZ]  by auto
nipkow@68617
   798
  moreover have "S' retract_of U - W"
nipkow@68617
   799
    apply (rule retract_of_subset [OF S'Z])
nipkow@68617
   800
    using US' \<open>S' \<subseteq> V\<close> \<open>V \<inter> W = {}\<close> closedin_subset apply fastforce
nipkow@68617
   801
    using Diff_subset_conv \<open>U - Z \<subseteq> W\<close> by blast
nipkow@68617
   802
  ultimately show ?thesis
nipkow@68617
   803
    apply (rule_tac V=V and W = "U-W" in that)
nipkow@68617
   804
    using openin_imp_subset apply force+
nipkow@68617
   805
    done
nipkow@68617
   806
qed
nipkow@68617
   807
nipkow@68617
   808
lemma ANR_imp_closed_neighbourhood_retract:
nipkow@68617
   809
  fixes S :: "'a::euclidean_space set"
nipkow@68617
   810
  assumes "ANR S" "closedin (subtopology euclidean U) S"
nipkow@68617
   811
  obtains V W where "openin (subtopology euclidean U) V"
nipkow@68617
   812
                    "closedin (subtopology euclidean U) W"
nipkow@68617
   813
                    "S \<subseteq> V" "V \<subseteq> W" "S retract_of W"
nipkow@68617
   814
by (meson ANR_imp_absolute_closed_neighbourhood_retract assms homeomorphic_refl)
nipkow@68617
   815
nipkow@68617
   816
lemma ANR_homeomorphic_ANR:
nipkow@68617
   817
  fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
nipkow@68617
   818
  assumes "ANR T" "S homeomorphic T"
nipkow@68617
   819
    shows "ANR S"
nipkow@68617
   820
unfolding ANR_def
nipkow@68617
   821
by (metis assms ANR_imp_absolute_neighbourhood_retract homeomorphic_trans [of _ S] homeomorphic_sym)
nipkow@68617
   822
nipkow@68617
   823
lemma homeomorphic_ANR_iff_ANR:
nipkow@68617
   824
  fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
nipkow@68617
   825
  shows "S homeomorphic T \<Longrightarrow> ANR S \<longleftrightarrow> ANR T"
nipkow@68617
   826
by (metis ANR_homeomorphic_ANR homeomorphic_sym)
nipkow@68617
   827
nipkow@68617
   828
subsubsection \<open>Analogous properties of ENRs\<close>
nipkow@68617
   829
nipkow@68617
   830
lemma ENR_imp_absolute_neighbourhood_retract:
nipkow@68617
   831
  fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
nipkow@68617
   832
  assumes "ENR S" and hom: "S homeomorphic S'"
nipkow@68617
   833
      and "S' \<subseteq> U"
nipkow@68617
   834
  obtains V where "openin (subtopology euclidean U) V" "S' retract_of V"
nipkow@68617
   835
proof -
nipkow@68617
   836
  obtain X where "open X" "S retract_of X"
nipkow@68617
   837
    using \<open>ENR S\<close> by (auto simp: ENR_def)
nipkow@68617
   838
  then obtain r where "retraction X S r"
nipkow@68617
   839
    by (auto simp: retract_of_def)
nipkow@68617
   840
  have "locally compact S'"
nipkow@68617
   841
    using retract_of_locally_compact open_imp_locally_compact
nipkow@68617
   842
          homeomorphic_local_compactness \<open>S retract_of X\<close> \<open>open X\<close> hom by blast
nipkow@68617
   843
  then obtain W where UW: "openin (subtopology euclidean U) W"
nipkow@68617
   844
                  and WS': "closedin (subtopology euclidean W) S'"
nipkow@68617
   845
    apply (rule locally_compact_closedin_open)
nipkow@68617
   846
    apply (rename_tac W)
nipkow@68617
   847
    apply (rule_tac W = "U \<inter> W" in that, blast)
nipkow@68617
   848
    by (simp add: \<open>S' \<subseteq> U\<close> closedin_limpt)
nipkow@68617
   849
  obtain f g where hom: "homeomorphism S S' f g"
nipkow@68617
   850
    using assms by (force simp: homeomorphic_def)
nipkow@68617
   851
  have contg: "continuous_on S' g"
nipkow@68617
   852
    using hom homeomorphism_def by blast
nipkow@68617
   853
  moreover have "g ` S' \<subseteq> S" by (metis hom equalityE homeomorphism_def)
nipkow@68617
   854
  ultimately obtain h where conth: "continuous_on W h" and hg: "\<And>x. x \<in> S' \<Longrightarrow> h x = g x"
nipkow@68617
   855
    using Tietze_unbounded [of S' g W] WS' by blast
nipkow@68617
   856
  have "W \<subseteq> U" using UW openin_open by auto
nipkow@68617
   857
  have "S' \<subseteq> W" using WS' closedin_closed by auto
nipkow@68617
   858
  have him: "\<And>x. x \<in> S' \<Longrightarrow> h x \<in> X"
nipkow@68617
   859
    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)
nipkow@68617
   860
  have "S' retract_of (W \<inter> h -` X)"
nipkow@68617
   861
  proof (simp add: retraction_def retract_of_def, intro exI conjI)
nipkow@68617
   862
    show "S' \<subseteq> W" "S' \<subseteq> h -` X"
nipkow@68617
   863
      using him WS' closedin_imp_subset by blast+
nipkow@68617
   864
    show "continuous_on (W \<inter> h -` X) (f \<circ> r \<circ> h)"
nipkow@68617
   865
    proof (intro continuous_on_compose)
nipkow@68617
   866
      show "continuous_on (W \<inter> h -` X) h"
nipkow@68617
   867
        by (meson conth continuous_on_subset inf_le1)
nipkow@68617
   868
      show "continuous_on (h ` (W \<inter> h -` X)) r"
nipkow@68617
   869
      proof -
nipkow@68617
   870
        have "h ` (W \<inter> h -` X) \<subseteq> X"
nipkow@68617
   871
          by blast
nipkow@68617
   872
        then show "continuous_on (h ` (W \<inter> h -` X)) r"
nipkow@68617
   873
          by (meson \<open>retraction X S r\<close> continuous_on_subset retraction)
nipkow@68617
   874
      qed
nipkow@68617
   875
      show "continuous_on (r ` h ` (W \<inter> h -` X)) f"
nipkow@68617
   876
        apply (rule continuous_on_subset [of S])
nipkow@68617
   877
         using hom homeomorphism_def apply blast
nipkow@68617
   878
        apply clarify
nipkow@68617
   879
        apply (meson \<open>retraction X S r\<close> subsetD imageI retraction_def)
nipkow@68617
   880
        done
nipkow@68617
   881
    qed
nipkow@68617
   882
    show "(f \<circ> r \<circ> h) ` (W \<inter> h -` X) \<subseteq> S'"
nipkow@68617
   883
      using \<open>retraction X S r\<close> hom
nipkow@68617
   884
      by (auto simp: retraction_def homeomorphism_def)
nipkow@68617
   885
    show "\<forall>x\<in>S'. (f \<circ> r \<circ> h) x = x"
nipkow@68617
   886
      using \<open>retraction X S r\<close> hom by (auto simp: retraction_def homeomorphism_def hg)
nipkow@68617
   887
  qed
nipkow@68617
   888
  then show ?thesis
nipkow@68617
   889
    apply (rule_tac V = "W \<inter> h -` X" in that)
nipkow@68617
   890
     apply (rule openin_trans [OF _ UW])
nipkow@68617
   891
     using \<open>continuous_on W h\<close> \<open>open X\<close> continuous_openin_preimage_eq apply blast+
nipkow@68617
   892
     done
nipkow@68617
   893
qed
nipkow@68617
   894
nipkow@68617
   895
corollary ENR_imp_absolute_neighbourhood_retract_UNIV:
nipkow@68617
   896
  fixes S :: "'a::euclidean_space set" and S' :: "'b::euclidean_space set"
nipkow@68617
   897
  assumes "ENR S" "S homeomorphic S'"
nipkow@68617
   898
  obtains T' where "open T'" "S' retract_of T'"
nipkow@68617
   899
by (metis ENR_imp_absolute_neighbourhood_retract UNIV_I assms(1) assms(2) open_openin subsetI subtopology_UNIV)
nipkow@68617
   900
nipkow@68617
   901
lemma ENR_homeomorphic_ENR:
nipkow@68617
   902
  fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
nipkow@68617
   903
  assumes "ENR T" "S homeomorphic T"
nipkow@68617
   904
    shows "ENR S"
nipkow@68617
   905
unfolding ENR_def
nipkow@68617
   906
by (meson ENR_imp_absolute_neighbourhood_retract_UNIV assms homeomorphic_sym)
nipkow@68617
   907
nipkow@68617
   908
lemma homeomorphic_ENR_iff_ENR:
nipkow@68617
   909
  fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
nipkow@68617
   910
  assumes "S homeomorphic T"
nipkow@68617
   911
    shows "ENR S \<longleftrightarrow> ENR T"
nipkow@68617
   912
by (meson ENR_homeomorphic_ENR assms homeomorphic_sym)
nipkow@68617
   913
nipkow@68617
   914
lemma ENR_translation:
nipkow@68617
   915
  fixes S :: "'a::euclidean_space set"
nipkow@68617
   916
  shows "ENR(image (\<lambda>x. a + x) S) \<longleftrightarrow> ENR S"
nipkow@68617
   917
by (meson homeomorphic_sym homeomorphic_translation homeomorphic_ENR_iff_ENR)
nipkow@68617
   918
nipkow@68617
   919
lemma ENR_linear_image_eq:
nipkow@68617
   920
  fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
nipkow@68617
   921
  assumes "linear f" "inj f"
nipkow@68617
   922
  shows "ENR (image f S) \<longleftrightarrow> ENR S"
nipkow@68617
   923
apply (rule homeomorphic_ENR_iff_ENR)
nipkow@68617
   924
using assms homeomorphic_sym linear_homeomorphic_image by auto
nipkow@68617
   925
nipkow@68617
   926
text \<open>Some relations among the concepts. We also relate AR to being a retract of UNIV, which is
nipkow@68617
   927
often a more convenient proxy in the closed case.\<close>
nipkow@68617
   928
nipkow@68617
   929
lemma AR_imp_ANR: "AR S \<Longrightarrow> ANR S"
nipkow@68617
   930
  using ANR_def AR_def by fastforce
nipkow@68617
   931
nipkow@68617
   932
lemma ENR_imp_ANR:
nipkow@68617
   933
  fixes S :: "'a::euclidean_space set"
nipkow@68617
   934
  shows "ENR S \<Longrightarrow> ANR S"
nipkow@68617
   935
apply (simp add: ANR_def)
nipkow@68617
   936
by (metis ENR_imp_absolute_neighbourhood_retract closedin_imp_subset)
nipkow@68617
   937
nipkow@68617
   938
lemma ENR_ANR:
nipkow@68617
   939
  fixes S :: "'a::euclidean_space set"
nipkow@68617
   940
  shows "ENR S \<longleftrightarrow> ANR S \<and> locally compact S"
nipkow@68617
   941
proof
nipkow@68617
   942
  assume "ENR S"
nipkow@68617
   943
  then have "locally compact S"
nipkow@68617
   944
    using ENR_def open_imp_locally_compact retract_of_locally_compact by auto
nipkow@68617
   945
  then show "ANR S \<and> locally compact S"
nipkow@68617
   946
    using ENR_imp_ANR \<open>ENR S\<close> by blast
nipkow@68617
   947
next
nipkow@68617
   948
  assume "ANR S \<and> locally compact S"
nipkow@68617
   949
  then have "ANR S" "locally compact S" by auto
nipkow@68617
   950
  then obtain T :: "('a * real) set" where "closed T" "S homeomorphic T"
nipkow@68617
   951
    using locally_compact_homeomorphic_closed
nipkow@68617
   952
    by (metis DIM_prod DIM_real Suc_eq_plus1 lessI)
nipkow@68617
   953
  then show "ENR S"
nipkow@68617
   954
    using \<open>ANR S\<close>
nipkow@68617
   955
    apply (simp add: ANR_def)
nipkow@68617
   956
    apply (drule_tac x=UNIV in spec)
nipkow@68617
   957
    apply (drule_tac x=T in spec, clarsimp)
nipkow@68617
   958
    apply (meson ENR_def ENR_homeomorphic_ENR open_openin)
nipkow@68617
   959
    done
nipkow@68617
   960
qed
nipkow@68617
   961
nipkow@68617
   962
nipkow@68617
   963
lemma AR_ANR:
nipkow@68617
   964
  fixes S :: "'a::euclidean_space set"
nipkow@68617
   965
  shows "AR S \<longleftrightarrow> ANR S \<and> contractible S \<and> S \<noteq> {}"
nipkow@68617
   966
        (is "?lhs = ?rhs")
nipkow@68617
   967
proof
nipkow@68617
   968
  assume ?lhs
nipkow@68617
   969
  obtain C and S' :: "('a * real) set"
nipkow@68617
   970
    where "convex C" "C \<noteq> {}" "closedin (subtopology euclidean C) S'" "S homeomorphic S'"
nipkow@68617
   971
      apply (rule homeomorphic_closedin_convex [of S, where 'n = "'a * real"])
nipkow@68617
   972
      using aff_dim_le_DIM [of S] by auto
nipkow@68617
   973
  with \<open>AR S\<close> have "contractible S"
nipkow@68617
   974
    apply (simp add: AR_def)
nipkow@68617
   975
    apply (drule_tac x=C in spec)
nipkow@68617
   976
    apply (drule_tac x="S'" in spec, simp)
nipkow@68617
   977
    using convex_imp_contractible homeomorphic_contractible_eq retract_of_contractible by fastforce
nipkow@68617
   978
  with \<open>AR S\<close> show ?rhs
nipkow@68617
   979
    apply (auto simp: AR_imp_ANR)
nipkow@68617
   980
    apply (force simp: AR_def)
nipkow@68617
   981
    done
nipkow@68617
   982
next
nipkow@68617
   983
  assume ?rhs
nipkow@68617
   984
  then obtain a and h:: "real \<times> 'a \<Rightarrow> 'a"
nipkow@68617
   985
      where conth: "continuous_on ({0..1} \<times> S) h"
nipkow@68617
   986
        and hS: "h ` ({0..1} \<times> S) \<subseteq> S"
nipkow@68617
   987
        and [simp]: "\<And>x. h(0, x) = x"
nipkow@68617
   988
        and [simp]: "\<And>x. h(1, x) = a"
nipkow@68617
   989
        and "ANR S" "S \<noteq> {}"
nipkow@68617
   990
    by (auto simp: contractible_def homotopic_with_def)
nipkow@68617
   991
  then have "a \<in> S"
nipkow@68617
   992
    by (metis all_not_in_conv atLeastAtMost_iff image_subset_iff mem_Sigma_iff order_refl zero_le_one)
nipkow@68617
   993
  have "\<exists>g. continuous_on W g \<and> g ` W \<subseteq> S \<and> (\<forall>x\<in>T. g x = f x)"
nipkow@68617
   994
         if      f: "continuous_on T f" "f ` T \<subseteq> S"
nipkow@68617
   995
            and WT: "closedin (subtopology euclidean W) T"
nipkow@68617
   996
         for W T and f :: "'a \<times> real \<Rightarrow> 'a"
nipkow@68617
   997
  proof -
nipkow@68617
   998
    obtain U g
nipkow@68617
   999
      where "T \<subseteq> U" and WU: "openin (subtopology euclidean W) U"
nipkow@68617
  1000
        and contg: "continuous_on U g"
nipkow@68617
  1001
        and "g ` U \<subseteq> S" and gf: "\<And>x. x \<in> T \<Longrightarrow> g x = f x"
nipkow@68617
  1002
      using iffD1 [OF ANR_eq_absolute_neighbourhood_extensor \<open>ANR S\<close>, rule_format, OF f WT]
nipkow@68617
  1003
      by auto
nipkow@68617
  1004
    have WWU: "closedin (subtopology euclidean W) (W - U)"
nipkow@68617
  1005
      using WU closedin_diff by fastforce
nipkow@68617
  1006
    moreover have "(W - U) \<inter> T = {}"
nipkow@68617
  1007
      using \<open>T \<subseteq> U\<close> by auto
nipkow@68617
  1008
    ultimately obtain V V'
nipkow@68617
  1009
      where WV': "openin (subtopology euclidean W) V'"
nipkow@68617
  1010
        and WV: "openin (subtopology euclidean W) V"
nipkow@68617
  1011
        and "W - U \<subseteq> V'" "T \<subseteq> V" "V' \<inter> V = {}"
nipkow@68617
  1012
      using separation_normal_local [of W "W-U" T] WT by blast
nipkow@68617
  1013
    then have WVT: "T \<inter> (W - V) = {}"
nipkow@68617
  1014
      by auto
nipkow@68617
  1015
    have WWV: "closedin (subtopology euclidean W) (W - V)"
nipkow@68617
  1016
      using WV closedin_diff by fastforce
nipkow@68617
  1017
    obtain j :: " 'a \<times> real \<Rightarrow> real"
nipkow@68617
  1018
      where contj: "continuous_on W j"
nipkow@68617
  1019
        and j:  "\<And>x. x \<in> W \<Longrightarrow> j x \<in> {0..1}"
nipkow@68617
  1020
        and j0: "\<And>x. x \<in> W - V \<Longrightarrow> j x = 1"
nipkow@68617
  1021
        and j1: "\<And>x. x \<in> T \<Longrightarrow> j x = 0"
nipkow@68617
  1022
      by (rule Urysohn_local [OF WT WWV WVT, of 0 "1::real"]) (auto simp: in_segment)
nipkow@68617
  1023
    have Weq: "W = (W - V) \<union> (W - V')"
nipkow@68617
  1024
      using \<open>V' \<inter> V = {}\<close> by force
nipkow@68617
  1025
    show ?thesis
nipkow@68617
  1026
    proof (intro conjI exI)
nipkow@68617
  1027
      have *: "continuous_on (W - V') (\<lambda>x. h (j x, g x))"
nipkow@68617
  1028
        apply (rule continuous_on_compose2 [OF conth continuous_on_Pair])
nipkow@68617
  1029
          apply (rule continuous_on_subset [OF contj Diff_subset])
nipkow@68617
  1030
         apply (rule continuous_on_subset [OF contg])
nipkow@68617
  1031
         apply (metis Diff_subset_conv Un_commute \<open>W - U \<subseteq> V'\<close>)
nipkow@68617
  1032
        using j \<open>g ` U \<subseteq> S\<close> \<open>W - U \<subseteq> V'\<close> apply fastforce
nipkow@68617
  1033
        done
nipkow@68617
  1034
      show "continuous_on W (\<lambda>x. if x \<in> W - V then a else h (j x, g x))"
nipkow@68617
  1035
        apply (subst Weq)
nipkow@68617
  1036
        apply (rule continuous_on_cases_local)
nipkow@68617
  1037
            apply (simp_all add: Weq [symmetric] WWV continuous_on_const *)
nipkow@68617
  1038
          using WV' closedin_diff apply fastforce
nipkow@68617
  1039
         apply (auto simp: j0 j1)
nipkow@68617
  1040
        done
nipkow@68617
  1041
    next
nipkow@68617
  1042
      have "h (j (x, y), g (x, y)) \<in> S" if "(x, y) \<in> W" "(x, y) \<in> V" for x y
nipkow@68617
  1043
      proof -
nipkow@68617
  1044
        have "j(x, y) \<in> {0..1}"
nipkow@68617
  1045
          using j that by blast
nipkow@68617
  1046
        moreover have "g(x, y) \<in> S"
nipkow@68617
  1047
          using \<open>V' \<inter> V = {}\<close> \<open>W - U \<subseteq> V'\<close> \<open>g ` U \<subseteq> S\<close> that by fastforce
nipkow@68617
  1048
        ultimately show ?thesis
nipkow@68617
  1049
          using hS by blast
nipkow@68617
  1050
      qed
nipkow@68617
  1051
      with \<open>a \<in> S\<close> \<open>g ` U \<subseteq> S\<close>
nipkow@68617
  1052
      show "(\<lambda>x. if x \<in> W - V then a else h (j x, g x)) ` W \<subseteq> S"
nipkow@68617
  1053
        by auto
nipkow@68617
  1054
    next
nipkow@68617
  1055
      show "\<forall>x\<in>T. (if x \<in> W - V then a else h (j x, g x)) = f x"
nipkow@68617
  1056
        using \<open>T \<subseteq> V\<close> by (auto simp: j0 j1 gf)
nipkow@68617
  1057
    qed
nipkow@68617
  1058
  qed
nipkow@68617
  1059
  then show ?lhs
nipkow@68617
  1060
    by (simp add: AR_eq_absolute_extensor)
nipkow@68617
  1061
qed
nipkow@68617
  1062
nipkow@68617
  1063
nipkow@68617
  1064
lemma ANR_retract_of_ANR:
nipkow@68617
  1065
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1066
  assumes "ANR T" "S retract_of T"
nipkow@68617
  1067
  shows "ANR S"
nipkow@68617
  1068
using assms
nipkow@68617
  1069
apply (simp add: ANR_eq_absolute_neighbourhood_extensor retract_of_def retraction_def)
nipkow@68617
  1070
apply (clarsimp elim!: all_forward)
nipkow@68617
  1071
apply (erule impCE, metis subset_trans)
nipkow@68617
  1072
apply (clarsimp elim!: ex_forward)
nipkow@68617
  1073
apply (rule_tac x="r \<circ> g" in exI)
nipkow@68617
  1074
by (metis comp_apply continuous_on_compose continuous_on_subset subsetD imageI image_comp image_mono subset_trans)
nipkow@68617
  1075
nipkow@68617
  1076
lemma AR_retract_of_AR:
nipkow@68617
  1077
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1078
  shows "\<lbrakk>AR T; S retract_of T\<rbrakk> \<Longrightarrow> AR S"
nipkow@68617
  1079
using ANR_retract_of_ANR AR_ANR retract_of_contractible by fastforce
nipkow@68617
  1080
nipkow@68617
  1081
lemma ENR_retract_of_ENR:
nipkow@68617
  1082
   "\<lbrakk>ENR T; S retract_of T\<rbrakk> \<Longrightarrow> ENR S"
nipkow@68617
  1083
by (meson ENR_def retract_of_trans)
nipkow@68617
  1084
nipkow@68617
  1085
lemma retract_of_UNIV:
nipkow@68617
  1086
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1087
  shows "S retract_of UNIV \<longleftrightarrow> AR S \<and> closed S"
nipkow@68617
  1088
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)
nipkow@68617
  1089
nipkow@68617
  1090
lemma compact_AR:
nipkow@68617
  1091
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1092
  shows "compact S \<and> AR S \<longleftrightarrow> compact S \<and> S retract_of UNIV"
nipkow@68617
  1093
using compact_imp_closed retract_of_UNIV by blast
nipkow@68617
  1094
nipkow@68617
  1095
text \<open>More properties of ARs, ANRs and ENRs\<close>
nipkow@68617
  1096
nipkow@68617
  1097
lemma not_AR_empty [simp]: "~ AR({})"
nipkow@68617
  1098
  by (auto simp: AR_def)
nipkow@68617
  1099
nipkow@68617
  1100
lemma ENR_empty [simp]: "ENR {}"
nipkow@68617
  1101
  by (simp add: ENR_def)
nipkow@68617
  1102
nipkow@68617
  1103
lemma ANR_empty [simp]: "ANR ({} :: 'a::euclidean_space set)"
nipkow@68617
  1104
  by (simp add: ENR_imp_ANR)
nipkow@68617
  1105
nipkow@68617
  1106
lemma convex_imp_AR:
nipkow@68617
  1107
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1108
  shows "\<lbrakk>convex S; S \<noteq> {}\<rbrakk> \<Longrightarrow> AR S"
nipkow@68617
  1109
apply (rule absolute_extensor_imp_AR)
nipkow@68617
  1110
apply (rule Dugundji, assumption+)
nipkow@68617
  1111
by blast
nipkow@68617
  1112
nipkow@68617
  1113
lemma convex_imp_ANR:
nipkow@68617
  1114
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1115
  shows "convex S \<Longrightarrow> ANR S"
nipkow@68617
  1116
using ANR_empty AR_imp_ANR convex_imp_AR by blast
nipkow@68617
  1117
nipkow@68617
  1118
lemma ENR_convex_closed:
nipkow@68617
  1119
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1120
  shows "\<lbrakk>closed S; convex S\<rbrakk> \<Longrightarrow> ENR S"
nipkow@68617
  1121
using ENR_def ENR_empty convex_imp_AR retract_of_UNIV by blast
nipkow@68617
  1122
nipkow@68617
  1123
lemma AR_UNIV [simp]: "AR (UNIV :: 'a::euclidean_space set)"
nipkow@68617
  1124
  using retract_of_UNIV by auto
nipkow@68617
  1125
nipkow@68617
  1126
lemma ANR_UNIV [simp]: "ANR (UNIV :: 'a::euclidean_space set)"
nipkow@68617
  1127
  by (simp add: AR_imp_ANR)
nipkow@68617
  1128
nipkow@68617
  1129
lemma ENR_UNIV [simp]:"ENR UNIV"
nipkow@68617
  1130
  using ENR_def by blast
nipkow@68617
  1131
nipkow@68617
  1132
lemma AR_singleton:
nipkow@68617
  1133
    fixes a :: "'a::euclidean_space"
nipkow@68617
  1134
    shows "AR {a}"
nipkow@68617
  1135
  using retract_of_UNIV by blast
nipkow@68617
  1136
nipkow@68617
  1137
lemma ANR_singleton:
nipkow@68617
  1138
    fixes a :: "'a::euclidean_space"
nipkow@68617
  1139
    shows "ANR {a}"
nipkow@68617
  1140
  by (simp add: AR_imp_ANR AR_singleton)
nipkow@68617
  1141
nipkow@68617
  1142
lemma ENR_singleton: "ENR {a}"
nipkow@68617
  1143
  using ENR_def by blast
nipkow@68617
  1144
nipkow@68617
  1145
text \<open>ARs closed under union\<close>
nipkow@68617
  1146
nipkow@68617
  1147
lemma AR_closed_Un_local_aux:
nipkow@68617
  1148
  fixes U :: "'a::euclidean_space set"
nipkow@68617
  1149
  assumes "closedin (subtopology euclidean U) S"
nipkow@68617
  1150
          "closedin (subtopology euclidean U) T"
nipkow@68617
  1151
          "AR S" "AR T" "AR(S \<inter> T)"
nipkow@68617
  1152
  shows "(S \<union> T) retract_of U"
nipkow@68617
  1153
proof -
nipkow@68617
  1154
  have "S \<inter> T \<noteq> {}"
nipkow@68617
  1155
    using assms AR_def by fastforce
nipkow@68617
  1156
  have "S \<subseteq> U" "T \<subseteq> U"
nipkow@68617
  1157
    using assms by (auto simp: closedin_imp_subset)
nipkow@68617
  1158
  define S' where "S' \<equiv> {x \<in> U. setdist {x} S \<le> setdist {x} T}"
nipkow@68617
  1159
  define T' where "T' \<equiv> {x \<in> U. setdist {x} T \<le> setdist {x} S}"
nipkow@68617
  1160
  define W  where "W \<equiv> {x \<in> U. setdist {x} S = setdist {x} T}"
nipkow@68617
  1161
  have US': "closedin (subtopology euclidean U) S'"
nipkow@68617
  1162
    using continuous_closedin_preimage [of U "\<lambda>x. setdist {x} S - setdist {x} T" "{..0}"]
nipkow@68617
  1163
    by (simp add: S'_def vimage_def Collect_conj_eq continuous_on_diff continuous_on_setdist)
nipkow@68617
  1164
  have UT': "closedin (subtopology euclidean U) T'"
nipkow@68617
  1165
    using continuous_closedin_preimage [of U "\<lambda>x. setdist {x} T - setdist {x} S" "{..0}"]
nipkow@68617
  1166
    by (simp add: T'_def vimage_def Collect_conj_eq continuous_on_diff continuous_on_setdist)
nipkow@68617
  1167
  have "S \<subseteq> S'"
nipkow@68617
  1168
    using S'_def \<open>S \<subseteq> U\<close> setdist_sing_in_set by fastforce
nipkow@68617
  1169
  have "T \<subseteq> T'"
nipkow@68617
  1170
    using T'_def \<open>T \<subseteq> U\<close> setdist_sing_in_set by fastforce
nipkow@68617
  1171
  have "S \<inter> T \<subseteq> W" "W \<subseteq> U"
nipkow@68617
  1172
    using \<open>S \<subseteq> U\<close> by (auto simp: W_def setdist_sing_in_set)
nipkow@68617
  1173
  have "(S \<inter> T) retract_of W"
nipkow@68617
  1174
    apply (rule AR_imp_absolute_retract [OF \<open>AR(S \<inter> T)\<close>])
nipkow@68617
  1175
     apply (simp add: homeomorphic_refl)
nipkow@68617
  1176
    apply (rule closedin_subset_trans [of U])
nipkow@68617
  1177
    apply (simp_all add: assms closedin_Int \<open>S \<inter> T \<subseteq> W\<close> \<open>W \<subseteq> U\<close>)
nipkow@68617
  1178
    done
nipkow@68617
  1179
  then obtain r0
nipkow@68617
  1180
    where "S \<inter> T \<subseteq> W" and contr0: "continuous_on W r0"
nipkow@68617
  1181
      and "r0 ` W \<subseteq> S \<inter> T"
nipkow@68617
  1182
      and r0 [simp]: "\<And>x. x \<in> S \<inter> T \<Longrightarrow> r0 x = x"
nipkow@68617
  1183
      by (auto simp: retract_of_def retraction_def)
nipkow@68617
  1184
  have ST: "x \<in> W \<Longrightarrow> x \<in> S \<longleftrightarrow> x \<in> T" for x
nipkow@68617
  1185
    using setdist_eq_0_closedin \<open>S \<inter> T \<noteq> {}\<close> assms
nipkow@68617
  1186
    by (force simp: W_def setdist_sing_in_set)
nipkow@68617
  1187
  have "S' \<inter> T' = W"
nipkow@68617
  1188
    by (auto simp: S'_def T'_def W_def)
nipkow@68617
  1189
  then have cloUW: "closedin (subtopology euclidean U) W"
nipkow@68617
  1190
    using closedin_Int US' UT' by blast
nipkow@68617
  1191
  define r where "r \<equiv> \<lambda>x. if x \<in> W then r0 x else x"
nipkow@68617
  1192
  have "r ` (W \<union> S) \<subseteq> S" "r ` (W \<union> T) \<subseteq> T"
nipkow@68617
  1193
    using \<open>r0 ` W \<subseteq> S \<inter> T\<close> r_def by auto
nipkow@68617
  1194
  have contr: "continuous_on (W \<union> (S \<union> T)) r"
nipkow@68617
  1195
  unfolding r_def
nipkow@68617
  1196
  proof (rule continuous_on_cases_local [OF _ _ contr0 continuous_on_id])
nipkow@68617
  1197
    show "closedin (subtopology euclidean (W \<union> (S \<union> T))) W"
nipkow@68617
  1198
      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
nipkow@68617
  1199
    show "closedin (subtopology euclidean (W \<union> (S \<union> T))) (S \<union> T)"
nipkow@68617
  1200
      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)
nipkow@68617
  1201
    show "\<And>x. x \<in> W \<and> x \<notin> W \<or> x \<in> S \<union> T \<and> x \<in> W \<Longrightarrow> r0 x = x"
nipkow@68617
  1202
      by (auto simp: ST)
nipkow@68617
  1203
  qed
nipkow@68617
  1204
  have cloUWS: "closedin (subtopology euclidean U) (W \<union> S)"
nipkow@68617
  1205
    by (simp add: cloUW assms closedin_Un)
nipkow@68617
  1206
  obtain g where contg: "continuous_on U g"
nipkow@68617
  1207
             and "g ` U \<subseteq> S" and geqr: "\<And>x. x \<in> W \<union> S \<Longrightarrow> g x = r x"
nipkow@68617
  1208
    apply (rule AR_imp_absolute_extensor [OF \<open>AR S\<close> _ _ cloUWS])
nipkow@68617
  1209
      apply (rule continuous_on_subset [OF contr])
nipkow@68617
  1210
      using \<open>r ` (W \<union> S) \<subseteq> S\<close> apply auto
nipkow@68617
  1211
    done
nipkow@68617
  1212
  have cloUWT: "closedin (subtopology euclidean U) (W \<union> T)"
nipkow@68617
  1213
    by (simp add: cloUW assms closedin_Un)
nipkow@68617
  1214
  obtain h where conth: "continuous_on U h"
nipkow@68617
  1215
             and "h ` U \<subseteq> T" and heqr: "\<And>x. x \<in> W \<union> T \<Longrightarrow> h x = r x"
nipkow@68617
  1216
    apply (rule AR_imp_absolute_extensor [OF \<open>AR T\<close> _ _ cloUWT])
nipkow@68617
  1217
      apply (rule continuous_on_subset [OF contr])
nipkow@68617
  1218
      using \<open>r ` (W \<union> T) \<subseteq> T\<close> apply auto
nipkow@68617
  1219
    done
nipkow@68617
  1220
  have "U = S' \<union> T'"
nipkow@68617
  1221
    by (force simp: S'_def T'_def)
nipkow@68617
  1222
  then have cont: "continuous_on U (\<lambda>x. if x \<in> S' then g x else h x)"
nipkow@68617
  1223
    apply (rule ssubst)
nipkow@68617
  1224
    apply (rule continuous_on_cases_local)
nipkow@68617
  1225
    using US' UT' \<open>S' \<inter> T' = W\<close> \<open>U = S' \<union> T'\<close>
nipkow@68617
  1226
          contg conth continuous_on_subset geqr heqr apply auto
nipkow@68617
  1227
    done
nipkow@68617
  1228
  have UST: "(\<lambda>x. if x \<in> S' then g x else h x) ` U \<subseteq> S \<union> T"
nipkow@68617
  1229
    using \<open>g ` U \<subseteq> S\<close> \<open>h ` U \<subseteq> T\<close> by auto
nipkow@68617
  1230
  show ?thesis
nipkow@68617
  1231
    apply (simp add: retract_of_def retraction_def \<open>S \<subseteq> U\<close> \<open>T \<subseteq> U\<close>)
nipkow@68617
  1232
    apply (rule_tac x="\<lambda>x. if x \<in> S' then g x else h x" in exI)
nipkow@68617
  1233
    apply (intro conjI cont UST)
nipkow@68617
  1234
    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)
nipkow@68617
  1235
qed
nipkow@68617
  1236
nipkow@68617
  1237
nipkow@68617
  1238
lemma AR_closed_Un_local:
nipkow@68617
  1239
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1240
  assumes STS: "closedin (subtopology euclidean (S \<union> T)) S"
nipkow@68617
  1241
      and STT: "closedin (subtopology euclidean (S \<union> T)) T"
nipkow@68617
  1242
      and "AR S" "AR T" "AR(S \<inter> T)"
nipkow@68617
  1243
    shows "AR(S \<union> T)"
nipkow@68617
  1244
proof -
nipkow@68617
  1245
  have "C retract_of U"
nipkow@68617
  1246
       if hom: "S \<union> T homeomorphic C" and UC: "closedin (subtopology euclidean U) C"
nipkow@68617
  1247
       for U and C :: "('a * real) set"
nipkow@68617
  1248
  proof -
nipkow@68617
  1249
    obtain f g where hom: "homeomorphism (S \<union> T) C f g"
nipkow@68617
  1250
      using hom by (force simp: homeomorphic_def)
nipkow@68617
  1251
    have US: "closedin (subtopology euclidean U) (C \<inter> g -` S)"
nipkow@68617
  1252
      apply (rule closedin_trans [OF _ UC])
nipkow@68617
  1253
      apply (rule continuous_closedin_preimage_gen [OF _ _ STS])
nipkow@68617
  1254
      using hom homeomorphism_def apply blast
nipkow@68617
  1255
      apply (metis hom homeomorphism_def set_eq_subset)
nipkow@68617
  1256
      done
nipkow@68617
  1257
    have UT: "closedin (subtopology euclidean U) (C \<inter> g -` T)"
nipkow@68617
  1258
      apply (rule closedin_trans [OF _ UC])
nipkow@68617
  1259
      apply (rule continuous_closedin_preimage_gen [OF _ _ STT])
nipkow@68617
  1260
      using hom homeomorphism_def apply blast
nipkow@68617
  1261
      apply (metis hom homeomorphism_def set_eq_subset)
nipkow@68617
  1262
      done
nipkow@68617
  1263
    have ARS: "AR (C \<inter> g -` S)"
nipkow@68617
  1264
      apply (rule AR_homeomorphic_AR [OF \<open>AR S\<close>])
nipkow@68617
  1265
      apply (simp add: homeomorphic_def)
nipkow@68617
  1266
      apply (rule_tac x=g in exI)
nipkow@68617
  1267
      apply (rule_tac x=f in exI)
nipkow@68617
  1268
      using hom apply (auto simp: homeomorphism_def elim!: continuous_on_subset)
nipkow@68617
  1269
      apply (rule_tac x="f x" in image_eqI, auto)
nipkow@68617
  1270
      done
nipkow@68617
  1271
    have ART: "AR (C \<inter> g -` T)"
nipkow@68617
  1272
      apply (rule AR_homeomorphic_AR [OF \<open>AR T\<close>])
nipkow@68617
  1273
      apply (simp add: homeomorphic_def)
nipkow@68617
  1274
      apply (rule_tac x=g in exI)
nipkow@68617
  1275
      apply (rule_tac x=f in exI)
nipkow@68617
  1276
      using hom apply (auto simp: homeomorphism_def elim!: continuous_on_subset)
nipkow@68617
  1277
      apply (rule_tac x="f x" in image_eqI, auto)
nipkow@68617
  1278
      done
nipkow@68617
  1279
    have ARI: "AR ((C \<inter> g -` S) \<inter> (C \<inter> g -` T))"
nipkow@68617
  1280
      apply (rule AR_homeomorphic_AR [OF \<open>AR (S \<inter> T)\<close>])
nipkow@68617
  1281
      apply (simp add: homeomorphic_def)
nipkow@68617
  1282
      apply (rule_tac x=g in exI)
nipkow@68617
  1283
      apply (rule_tac x=f in exI)
nipkow@68617
  1284
      using hom
nipkow@68617
  1285
      apply (auto simp: homeomorphism_def elim!: continuous_on_subset)
nipkow@68617
  1286
      apply (rule_tac x="f x" in image_eqI, auto)
nipkow@68617
  1287
      done
nipkow@68617
  1288
    have "C = (C \<inter> g -` S) \<union> (C \<inter> g -` T)"
nipkow@68617
  1289
      using hom  by (auto simp: homeomorphism_def)
nipkow@68617
  1290
    then show ?thesis
nipkow@68617
  1291
      by (metis AR_closed_Un_local_aux [OF US UT ARS ART ARI])
nipkow@68617
  1292
  qed
nipkow@68617
  1293
  then show ?thesis
nipkow@68617
  1294
    by (force simp: AR_def)
nipkow@68617
  1295
qed
nipkow@68617
  1296
nipkow@68617
  1297
corollary AR_closed_Un:
nipkow@68617
  1298
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1299
  shows "\<lbrakk>closed S; closed T; AR S; AR T; AR (S \<inter> T)\<rbrakk> \<Longrightarrow> AR (S \<union> T)"
nipkow@68617
  1300
by (metis AR_closed_Un_local_aux closed_closedin retract_of_UNIV subtopology_UNIV)
nipkow@68617
  1301
nipkow@68617
  1302
text \<open>ANRs closed under union\<close>
nipkow@68617
  1303
nipkow@68617
  1304
lemma ANR_closed_Un_local_aux:
nipkow@68617
  1305
  fixes U :: "'a::euclidean_space set"
nipkow@68617
  1306
  assumes US: "closedin (subtopology euclidean U) S"
nipkow@68617
  1307
      and UT: "closedin (subtopology euclidean U) T"
nipkow@68617
  1308
      and "ANR S" "ANR T" "ANR(S \<inter> T)"
nipkow@68617
  1309
  obtains V where "openin (subtopology euclidean U) V" "(S \<union> T) retract_of V"
nipkow@68617
  1310
proof (cases "S = {} \<or> T = {}")
nipkow@68617
  1311
  case True with assms that show ?thesis
nipkow@68617
  1312
    by (metis ANR_imp_neighbourhood_retract Un_commute inf_bot_right sup_inf_absorb)
nipkow@68617
  1313
next
nipkow@68617
  1314
  case False
nipkow@68617
  1315
  then have [simp]: "S \<noteq> {}" "T \<noteq> {}" by auto
nipkow@68617
  1316
  have "S \<subseteq> U" "T \<subseteq> U"
nipkow@68617
  1317
    using assms by (auto simp: closedin_imp_subset)
nipkow@68617
  1318
  define S' where "S' \<equiv> {x \<in> U. setdist {x} S \<le> setdist {x} T}"
nipkow@68617
  1319
  define T' where "T' \<equiv> {x \<in> U. setdist {x} T \<le> setdist {x} S}"
nipkow@68617
  1320
  define W  where "W \<equiv> {x \<in> U. setdist {x} S = setdist {x} T}"
nipkow@68617
  1321
  have cloUS': "closedin (subtopology euclidean U) S'"
nipkow@68617
  1322
    using continuous_closedin_preimage [of U "\<lambda>x. setdist {x} S - setdist {x} T" "{..0}"]
nipkow@68617
  1323
    by (simp add: S'_def vimage_def Collect_conj_eq continuous_on_diff continuous_on_setdist)
nipkow@68617
  1324
  have cloUT': "closedin (subtopology euclidean U) T'"
nipkow@68617
  1325
    using continuous_closedin_preimage [of U "\<lambda>x. setdist {x} T - setdist {x} S" "{..0}"]
nipkow@68617
  1326
    by (simp add: T'_def vimage_def Collect_conj_eq continuous_on_diff continuous_on_setdist)
nipkow@68617
  1327
  have "S \<subseteq> S'"
nipkow@68617
  1328
    using S'_def \<open>S \<subseteq> U\<close> setdist_sing_in_set by fastforce
nipkow@68617
  1329
  have "T \<subseteq> T'"
nipkow@68617
  1330
    using T'_def \<open>T \<subseteq> U\<close> setdist_sing_in_set by fastforce
nipkow@68617
  1331
  have "S' \<union> T' = U"
nipkow@68617
  1332
    by (auto simp: S'_def T'_def)
nipkow@68617
  1333
  have "W \<subseteq> S'"
nipkow@68617
  1334
    by (simp add: Collect_mono S'_def W_def)
nipkow@68617
  1335
  have "W \<subseteq> T'"
nipkow@68617
  1336
    by (simp add: Collect_mono T'_def W_def)
nipkow@68617
  1337
  have ST_W: "S \<inter> T \<subseteq> W" and "W \<subseteq> U"
nipkow@68617
  1338
    using \<open>S \<subseteq> U\<close> by (force simp: W_def setdist_sing_in_set)+
nipkow@68617
  1339
  have "S' \<inter> T' = W"
nipkow@68617
  1340
    by (auto simp: S'_def T'_def W_def)
nipkow@68617
  1341
  then have cloUW: "closedin (subtopology euclidean U) W"
nipkow@68617
  1342
    using closedin_Int cloUS' cloUT' by blast
nipkow@68617
  1343
  obtain W' W0 where "openin (subtopology euclidean W) W'"
nipkow@68617
  1344
                 and cloWW0: "closedin (subtopology euclidean W) W0"
nipkow@68617
  1345
                 and "S \<inter> T \<subseteq> W'" "W' \<subseteq> W0"
nipkow@68617
  1346
                 and ret: "(S \<inter> T) retract_of W0"
nipkow@68617
  1347
    apply (rule ANR_imp_closed_neighbourhood_retract [OF \<open>ANR(S \<inter> T)\<close>])
nipkow@68617
  1348
    apply (rule closedin_subset_trans [of U, OF _ ST_W \<open>W \<subseteq> U\<close>])
nipkow@68617
  1349
    apply (blast intro: assms)+
nipkow@68617
  1350
    done
nipkow@68617
  1351
  then obtain U0 where opeUU0: "openin (subtopology euclidean U) U0"
nipkow@68617
  1352
                   and U0: "S \<inter> T \<subseteq> U0" "U0 \<inter> W \<subseteq> W0"
nipkow@68617
  1353
    unfolding openin_open  using \<open>W \<subseteq> U\<close> by blast
nipkow@68617
  1354
  have "W0 \<subseteq> U"
nipkow@68617
  1355
    using \<open>W \<subseteq> U\<close> cloWW0 closedin_subset by fastforce
nipkow@68617
  1356
  obtain r0
nipkow@68617
  1357
    where "S \<inter> T \<subseteq> W0" and contr0: "continuous_on W0 r0" and "r0 ` W0 \<subseteq> S \<inter> T"
nipkow@68617
  1358
      and r0 [simp]: "\<And>x. x \<in> S \<inter> T \<Longrightarrow> r0 x = x"
nipkow@68617
  1359
    using ret  by (force simp: retract_of_def retraction_def)
nipkow@68617
  1360
  have ST: "x \<in> W \<Longrightarrow> x \<in> S \<longleftrightarrow> x \<in> T" for x
nipkow@68617
  1361
    using assms by (auto simp: W_def setdist_sing_in_set dest!: setdist_eq_0_closedin)
nipkow@68617
  1362
  define r where "r \<equiv> \<lambda>x. if x \<in> W0 then r0 x else x"
nipkow@68617
  1363
  have "r ` (W0 \<union> S) \<subseteq> S" "r ` (W0 \<union> T) \<subseteq> T"
nipkow@68617
  1364
    using \<open>r0 ` W0 \<subseteq> S \<inter> T\<close> r_def by auto
nipkow@68617
  1365
  have contr: "continuous_on (W0 \<union> (S \<union> T)) r"
nipkow@68617
  1366
  unfolding r_def
nipkow@68617
  1367
  proof (rule continuous_on_cases_local [OF _ _ contr0 continuous_on_id])
nipkow@68617
  1368
    show "closedin (subtopology euclidean (W0 \<union> (S \<union> T))) W0"
nipkow@68617
  1369
      apply (rule closedin_subset_trans [of U])
nipkow@68617
  1370
      using cloWW0 cloUW closedin_trans \<open>W0 \<subseteq> U\<close> \<open>S \<subseteq> U\<close> \<open>T \<subseteq> U\<close> apply blast+
nipkow@68617
  1371
      done
nipkow@68617
  1372
    show "closedin (subtopology euclidean (W0 \<union> (S \<union> T))) (S \<union> T)"
nipkow@68617
  1373
      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)
nipkow@68617
  1374
    show "\<And>x. x \<in> W0 \<and> x \<notin> W0 \<or> x \<in> S \<union> T \<and> x \<in> W0 \<Longrightarrow> r0 x = x"
nipkow@68617
  1375
      using ST cloWW0 closedin_subset by fastforce
nipkow@68617
  1376
  qed
nipkow@68617
  1377
  have cloS'WS: "closedin (subtopology euclidean S') (W0 \<union> S)"
nipkow@68617
  1378
    by (meson closedin_subset_trans US cloUS' \<open>S \<subseteq> S'\<close> \<open>W \<subseteq> S'\<close> cloUW cloWW0 
nipkow@68617
  1379
              closedin_Un closedin_imp_subset closedin_trans)
nipkow@68617
  1380
  obtain W1 g where "W0 \<union> S \<subseteq> W1" and contg: "continuous_on W1 g"
nipkow@68617
  1381
                and opeSW1: "openin (subtopology euclidean S') W1"
nipkow@68617
  1382
                and "g ` W1 \<subseteq> S" and geqr: "\<And>x. x \<in> W0 \<union> S \<Longrightarrow> g x = r x"
nipkow@68617
  1383
    apply (rule ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR S\<close> _ \<open>r ` (W0 \<union> S) \<subseteq> S\<close> cloS'WS])
nipkow@68617
  1384
     apply (rule continuous_on_subset [OF contr], blast+)
nipkow@68617
  1385
    done
nipkow@68617
  1386
  have cloT'WT: "closedin (subtopology euclidean T') (W0 \<union> T)"
nipkow@68617
  1387
    by (meson closedin_subset_trans UT cloUT' \<open>T \<subseteq> T'\<close> \<open>W \<subseteq> T'\<close> cloUW cloWW0 
nipkow@68617
  1388
              closedin_Un closedin_imp_subset closedin_trans)
nipkow@68617
  1389
  obtain W2 h where "W0 \<union> T \<subseteq> W2" and conth: "continuous_on W2 h"
nipkow@68617
  1390
                and opeSW2: "openin (subtopology euclidean T') W2"
nipkow@68617
  1391
                and "h ` W2 \<subseteq> T" and heqr: "\<And>x. x \<in> W0 \<union> T \<Longrightarrow> h x = r x"
nipkow@68617
  1392
    apply (rule ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR T\<close> _ \<open>r ` (W0 \<union> T) \<subseteq> T\<close> cloT'WT])
nipkow@68617
  1393
     apply (rule continuous_on_subset [OF contr], blast+)
nipkow@68617
  1394
    done
nipkow@68617
  1395
  have "S' \<inter> T' = W"
nipkow@68617
  1396
    by (force simp: S'_def T'_def W_def)
nipkow@68617
  1397
  obtain O1 O2 where "open O1" "W1 = S' \<inter> O1" "open O2" "W2 = T' \<inter> O2"
nipkow@68617
  1398
    using opeSW1 opeSW2 by (force simp: openin_open)
nipkow@68617
  1399
  show ?thesis
nipkow@68617
  1400
  proof
nipkow@68617
  1401
    have eq: "W1 - (W - U0) \<union> (W2 - (W - U0)) =
nipkow@68617
  1402
         ((U - T') \<inter> O1 \<union> (U - S') \<inter> O2 \<union> U \<inter> O1 \<inter> O2) - (W - U0)"
nipkow@68617
  1403
     using \<open>U0 \<inter> W \<subseteq> W0\<close> \<open>W0 \<union> S \<subseteq> W1\<close> \<open>W0 \<union> T \<subseteq> W2\<close>
nipkow@68617
  1404
      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>)
nipkow@68617
  1405
    show "openin (subtopology euclidean U) (W1 - (W - U0) \<union> (W2 - (W - U0)))"
nipkow@68617
  1406
      apply (subst eq)
nipkow@68617
  1407
      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)
nipkow@68617
  1408
      done
nipkow@68617
  1409
    have cloW1: "closedin (subtopology euclidean (W1 - (W - U0) \<union> (W2 - (W - U0)))) (W1 - (W - U0))"
nipkow@68617
  1410
      using cloUS' apply (simp add: closedin_closed)
nipkow@68617
  1411
      apply (erule ex_forward)
nipkow@68617
  1412
      using U0 \<open>W0 \<union> S \<subseteq> W1\<close>
nipkow@68617
  1413
      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])
nipkow@68617
  1414
      done
nipkow@68617
  1415
    have cloW2: "closedin (subtopology euclidean (W1 - (W - U0) \<union> (W2 - (W - U0)))) (W2 - (W - U0))"
nipkow@68617
  1416
      using cloUT' apply (simp add: closedin_closed)
nipkow@68617
  1417
      apply (erule ex_forward)
nipkow@68617
  1418
      using U0 \<open>W0 \<union> T \<subseteq> W2\<close>
nipkow@68617
  1419
      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])
nipkow@68617
  1420
      done
nipkow@68617
  1421
    have *: "\<forall>x\<in>S \<union> T. (if x \<in> S' then g x else h x) = x"
nipkow@68617
  1422
      using ST \<open>S' \<inter> T' = W\<close> cloT'WT closedin_subset geqr heqr 
nipkow@68617
  1423
      apply (auto simp: r_def, fastforce)
nipkow@68617
  1424
      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
nipkow@68617
  1425
    have "\<exists>r. continuous_on (W1 - (W - U0) \<union> (W2 - (W - U0))) r \<and>
nipkow@68617
  1426
              r ` (W1 - (W - U0) \<union> (W2 - (W - U0))) \<subseteq> S \<union> T \<and> 
nipkow@68617
  1427
              (\<forall>x\<in>S \<union> T. r x = x)"
nipkow@68617
  1428
      apply (rule_tac x = "\<lambda>x. if  x \<in> S' then g x else h x" in exI)
nipkow@68617
  1429
      apply (intro conjI *)
nipkow@68617
  1430
      apply (rule continuous_on_cases_local 
nipkow@68617
  1431
                  [OF cloW1 cloW2 continuous_on_subset [OF contg] continuous_on_subset [OF conth]])
nipkow@68617
  1432
      using \<open>W1 = S' \<inter> O1\<close> \<open>W2 = T' \<inter> O2\<close> \<open>S' \<inter> T' = W\<close>
nipkow@68617
  1433
            \<open>g ` W1 \<subseteq> S\<close> \<open>h ` W2 \<subseteq> T\<close> apply auto
nipkow@68617
  1434
      using \<open>U0 \<inter> W \<subseteq> W0\<close> \<open>W0 \<union> S \<subseteq> W1\<close> apply (fastforce simp add: geqr heqr)+
nipkow@68617
  1435
      done
nipkow@68617
  1436
    then show "S \<union> T retract_of W1 - (W - U0) \<union> (W2 - (W - U0))"
nipkow@68617
  1437
      using  \<open>W0 \<union> S \<subseteq> W1\<close> \<open>W0 \<union> T \<subseteq> W2\<close> ST opeUU0 U0
nipkow@68617
  1438
      by (auto simp: retract_of_def retraction_def)
nipkow@68617
  1439
  qed
nipkow@68617
  1440
qed
nipkow@68617
  1441
nipkow@68617
  1442
nipkow@68617
  1443
lemma ANR_closed_Un_local:
nipkow@68617
  1444
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1445
  assumes STS: "closedin (subtopology euclidean (S \<union> T)) S"
nipkow@68617
  1446
      and STT: "closedin (subtopology euclidean (S \<union> T)) T"
nipkow@68617
  1447
      and "ANR S" "ANR T" "ANR(S \<inter> T)" 
nipkow@68617
  1448
    shows "ANR(S \<union> T)"
nipkow@68617
  1449
proof -
nipkow@68617
  1450
  have "\<exists>T. openin (subtopology euclidean U) T \<and> C retract_of T"
nipkow@68617
  1451
       if hom: "S \<union> T homeomorphic C" and UC: "closedin (subtopology euclidean U) C"
nipkow@68617
  1452
       for U and C :: "('a * real) set"
nipkow@68617
  1453
  proof -
nipkow@68617
  1454
    obtain f g where hom: "homeomorphism (S \<union> T) C f g"
nipkow@68617
  1455
      using hom by (force simp: homeomorphic_def)
nipkow@68617
  1456
    have US: "closedin (subtopology euclidean U) (C \<inter> g -` S)"
nipkow@68617
  1457
      apply (rule closedin_trans [OF _ UC])
nipkow@68617
  1458
      apply (rule continuous_closedin_preimage_gen [OF _ _ STS])
nipkow@68617
  1459
      using hom [unfolded homeomorphism_def] apply blast
nipkow@68617
  1460
      apply (metis hom homeomorphism_def set_eq_subset)
nipkow@68617
  1461
      done
nipkow@68617
  1462
    have UT: "closedin (subtopology euclidean U) (C \<inter> g -` T)"
nipkow@68617
  1463
      apply (rule closedin_trans [OF _ UC])
nipkow@68617
  1464
      apply (rule continuous_closedin_preimage_gen [OF _ _ STT])
nipkow@68617
  1465
      using hom [unfolded homeomorphism_def] apply blast
nipkow@68617
  1466
      apply (metis hom homeomorphism_def set_eq_subset)
nipkow@68617
  1467
      done
nipkow@68617
  1468
    have ANRS: "ANR (C \<inter> g -` S)"
nipkow@68617
  1469
      apply (rule ANR_homeomorphic_ANR [OF \<open>ANR S\<close>])
nipkow@68617
  1470
      apply (simp add: homeomorphic_def)
nipkow@68617
  1471
      apply (rule_tac x=g in exI)
nipkow@68617
  1472
      apply (rule_tac x=f in exI)
nipkow@68617
  1473
      using hom apply (auto simp: homeomorphism_def elim!: continuous_on_subset)
nipkow@68617
  1474
      apply (rule_tac x="f x" in image_eqI, auto)
nipkow@68617
  1475
      done
nipkow@68617
  1476
    have ANRT: "ANR (C \<inter> g -` T)"
nipkow@68617
  1477
      apply (rule ANR_homeomorphic_ANR [OF \<open>ANR T\<close>])
nipkow@68617
  1478
      apply (simp add: homeomorphic_def)
nipkow@68617
  1479
      apply (rule_tac x=g in exI)
nipkow@68617
  1480
      apply (rule_tac x=f in exI)
nipkow@68617
  1481
      using hom apply (auto simp: homeomorphism_def elim!: continuous_on_subset)
nipkow@68617
  1482
      apply (rule_tac x="f x" in image_eqI, auto)
nipkow@68617
  1483
      done
nipkow@68617
  1484
    have ANRI: "ANR ((C \<inter> g -` S) \<inter> (C \<inter> g -` T))"
nipkow@68617
  1485
      apply (rule ANR_homeomorphic_ANR [OF \<open>ANR (S \<inter> T)\<close>])
nipkow@68617
  1486
      apply (simp add: homeomorphic_def)
nipkow@68617
  1487
      apply (rule_tac x=g in exI)
nipkow@68617
  1488
      apply (rule_tac x=f in exI)
nipkow@68617
  1489
      using hom
nipkow@68617
  1490
      apply (auto simp: homeomorphism_def elim!: continuous_on_subset)
nipkow@68617
  1491
      apply (rule_tac x="f x" in image_eqI, auto)
nipkow@68617
  1492
      done
nipkow@68617
  1493
    have "C = (C \<inter> g -` S) \<union> (C \<inter> g -` T)"
nipkow@68617
  1494
      using hom by (auto simp: homeomorphism_def)
nipkow@68617
  1495
    then show ?thesis
nipkow@68617
  1496
      by (metis ANR_closed_Un_local_aux [OF US UT ANRS ANRT ANRI])
nipkow@68617
  1497
  qed
nipkow@68617
  1498
  then show ?thesis
nipkow@68617
  1499
    by (auto simp: ANR_def)
nipkow@68617
  1500
qed    
nipkow@68617
  1501
nipkow@68617
  1502
corollary ANR_closed_Un:
nipkow@68617
  1503
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1504
  shows "\<lbrakk>closed S; closed T; ANR S; ANR T; ANR (S \<inter> T)\<rbrakk> \<Longrightarrow> ANR (S \<union> T)"
nipkow@68617
  1505
by (simp add: ANR_closed_Un_local closedin_def diff_eq open_Compl openin_open_Int)
nipkow@68617
  1506
nipkow@68617
  1507
lemma ANR_openin:
nipkow@68617
  1508
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1509
  assumes "ANR T" and opeTS: "openin (subtopology euclidean T) S"
nipkow@68617
  1510
  shows "ANR S"
nipkow@68617
  1511
proof (clarsimp simp only: ANR_eq_absolute_neighbourhood_extensor)
nipkow@68617
  1512
  fix f :: "'a \<times> real \<Rightarrow> 'a" and U C
nipkow@68617
  1513
  assume contf: "continuous_on C f" and fim: "f ` C \<subseteq> S"
nipkow@68617
  1514
     and cloUC: "closedin (subtopology euclidean U) C"
nipkow@68617
  1515
  have "f ` C \<subseteq> T"
nipkow@68617
  1516
    using fim opeTS openin_imp_subset by blast
nipkow@68617
  1517
  obtain W g where "C \<subseteq> W"
nipkow@68617
  1518
               and UW: "openin (subtopology euclidean U) W"
nipkow@68617
  1519
               and contg: "continuous_on W g"
nipkow@68617
  1520
               and gim: "g ` W \<subseteq> T"
nipkow@68617
  1521
               and geq: "\<And>x. x \<in> C \<Longrightarrow> g x = f x"
nipkow@68617
  1522
    apply (rule ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR T\<close> contf \<open>f ` C \<subseteq> T\<close> cloUC])
nipkow@68617
  1523
    using fim by auto
nipkow@68617
  1524
  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)"
nipkow@68617
  1525
  proof (intro exI conjI)
nipkow@68617
  1526
    show "C \<subseteq> W \<inter> g -` S"
nipkow@68617
  1527
      using \<open>C \<subseteq> W\<close> fim geq by blast
nipkow@68617
  1528
    show "openin (subtopology euclidean U) (W \<inter> g -` S)"
nipkow@68617
  1529
      by (metis (mono_tags, lifting) UW contg continuous_openin_preimage gim opeTS openin_trans)
nipkow@68617
  1530
    show "continuous_on (W \<inter> g -` S) g"
nipkow@68617
  1531
      by (blast intro: continuous_on_subset [OF contg])
nipkow@68617
  1532
    show "g ` (W \<inter> g -` S) \<subseteq> S"
nipkow@68617
  1533
      using gim by blast
nipkow@68617
  1534
    show "\<forall>x\<in>C. g x = f x"
nipkow@68617
  1535
      using geq by blast
nipkow@68617
  1536
  qed
nipkow@68617
  1537
qed
nipkow@68617
  1538
nipkow@68617
  1539
lemma ENR_openin:
nipkow@68617
  1540
    fixes S :: "'a::euclidean_space set"
nipkow@68617
  1541
    assumes "ENR T" and opeTS: "openin (subtopology euclidean T) S"
nipkow@68617
  1542
    shows "ENR S"
nipkow@68617
  1543
  using assms apply (simp add: ENR_ANR)
nipkow@68617
  1544
  using ANR_openin locally_open_subset by blast
nipkow@68617
  1545
nipkow@68617
  1546
lemma ANR_neighborhood_retract:
nipkow@68617
  1547
    fixes S :: "'a::euclidean_space set"
nipkow@68617
  1548
    assumes "ANR U" "S retract_of T" "openin (subtopology euclidean U) T"
nipkow@68617
  1549
    shows "ANR S"
nipkow@68617
  1550
  using ANR_openin ANR_retract_of_ANR assms by blast
nipkow@68617
  1551
nipkow@68617
  1552
lemma ENR_neighborhood_retract:
nipkow@68617
  1553
    fixes S :: "'a::euclidean_space set"
nipkow@68617
  1554
    assumes "ENR U" "S retract_of T" "openin (subtopology euclidean U) T"
nipkow@68617
  1555
    shows "ENR S"
nipkow@68617
  1556
  using ENR_openin ENR_retract_of_ENR assms by blast
nipkow@68617
  1557
nipkow@68617
  1558
lemma ANR_rel_interior:
nipkow@68617
  1559
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1560
  shows "ANR S \<Longrightarrow> ANR(rel_interior S)"
nipkow@68617
  1561
   by (blast intro: ANR_openin openin_set_rel_interior)
nipkow@68617
  1562
nipkow@68617
  1563
lemma ANR_delete:
nipkow@68617
  1564
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1565
  shows "ANR S \<Longrightarrow> ANR(S - {a})"
nipkow@68617
  1566
   by (blast intro: ANR_openin openin_delete openin_subtopology_self)
nipkow@68617
  1567
nipkow@68617
  1568
lemma ENR_rel_interior:
nipkow@68617
  1569
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1570
  shows "ENR S \<Longrightarrow> ENR(rel_interior S)"
nipkow@68617
  1571
   by (blast intro: ENR_openin openin_set_rel_interior)
nipkow@68617
  1572
nipkow@68617
  1573
lemma ENR_delete:
nipkow@68617
  1574
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1575
  shows "ENR S \<Longrightarrow> ENR(S - {a})"
nipkow@68617
  1576
   by (blast intro: ENR_openin openin_delete openin_subtopology_self)
nipkow@68617
  1577
nipkow@68617
  1578
lemma open_imp_ENR: "open S \<Longrightarrow> ENR S"
nipkow@68617
  1579
    using ENR_def by blast
nipkow@68617
  1580
nipkow@68617
  1581
lemma open_imp_ANR:
nipkow@68617
  1582
    fixes S :: "'a::euclidean_space set"
nipkow@68617
  1583
    shows "open S \<Longrightarrow> ANR S"
nipkow@68617
  1584
  by (simp add: ENR_imp_ANR open_imp_ENR)
nipkow@68617
  1585
nipkow@68617
  1586
lemma ANR_ball [iff]:
nipkow@68617
  1587
    fixes a :: "'a::euclidean_space"
nipkow@68617
  1588
    shows "ANR(ball a r)"
nipkow@68617
  1589
  by (simp add: convex_imp_ANR)
nipkow@68617
  1590
nipkow@68617
  1591
lemma ENR_ball [iff]: "ENR(ball a r)"
nipkow@68617
  1592
  by (simp add: open_imp_ENR)
nipkow@68617
  1593
nipkow@68617
  1594
lemma AR_ball [simp]:
nipkow@68617
  1595
    fixes a :: "'a::euclidean_space"
nipkow@68617
  1596
    shows "AR(ball a r) \<longleftrightarrow> 0 < r"
nipkow@68617
  1597
  by (auto simp: AR_ANR convex_imp_contractible)
nipkow@68617
  1598
nipkow@68617
  1599
lemma ANR_cball [iff]:
nipkow@68617
  1600
    fixes a :: "'a::euclidean_space"
nipkow@68617
  1601
    shows "ANR(cball a r)"
nipkow@68617
  1602
  by (simp add: convex_imp_ANR)
nipkow@68617
  1603
nipkow@68617
  1604
lemma ENR_cball:
nipkow@68617
  1605
    fixes a :: "'a::euclidean_space"
nipkow@68617
  1606
    shows "ENR(cball a r)"
nipkow@68617
  1607
  using ENR_convex_closed by blast
nipkow@68617
  1608
nipkow@68617
  1609
lemma AR_cball [simp]:
nipkow@68617
  1610
    fixes a :: "'a::euclidean_space"
nipkow@68617
  1611
    shows "AR(cball a r) \<longleftrightarrow> 0 \<le> r"
nipkow@68617
  1612
  by (auto simp: AR_ANR convex_imp_contractible)
nipkow@68617
  1613
nipkow@68617
  1614
lemma ANR_box [iff]:
nipkow@68617
  1615
    fixes a :: "'a::euclidean_space"
nipkow@68617
  1616
    shows "ANR(cbox a b)" "ANR(box a b)"
nipkow@68617
  1617
  by (auto simp: convex_imp_ANR open_imp_ANR)
nipkow@68617
  1618
nipkow@68617
  1619
lemma ENR_box [iff]:
nipkow@68617
  1620
    fixes a :: "'a::euclidean_space"
nipkow@68617
  1621
    shows "ENR(cbox a b)" "ENR(box a b)"
nipkow@68617
  1622
apply (simp add: ENR_convex_closed closed_cbox)
nipkow@68617
  1623
by (simp add: open_box open_imp_ENR)
nipkow@68617
  1624
nipkow@68617
  1625
lemma AR_box [simp]:
nipkow@68617
  1626
    "AR(cbox a b) \<longleftrightarrow> cbox a b \<noteq> {}" "AR(box a b) \<longleftrightarrow> box a b \<noteq> {}"
nipkow@68617
  1627
  by (auto simp: AR_ANR convex_imp_contractible)
nipkow@68617
  1628
nipkow@68617
  1629
lemma ANR_interior:
nipkow@68617
  1630
     fixes S :: "'a::euclidean_space set"
nipkow@68617
  1631
     shows "ANR(interior S)"
nipkow@68617
  1632
  by (simp add: open_imp_ANR)
nipkow@68617
  1633
nipkow@68617
  1634
lemma ENR_interior:
nipkow@68617
  1635
     fixes S :: "'a::euclidean_space set"
nipkow@68617
  1636
     shows "ENR(interior S)"
nipkow@68617
  1637
  by (simp add: open_imp_ENR)
nipkow@68617
  1638
nipkow@68617
  1639
lemma AR_imp_contractible:
nipkow@68617
  1640
    fixes S :: "'a::euclidean_space set"
nipkow@68617
  1641
    shows "AR S \<Longrightarrow> contractible S"
nipkow@68617
  1642
  by (simp add: AR_ANR)
nipkow@68617
  1643
nipkow@68617
  1644
lemma ENR_imp_locally_compact:
nipkow@68617
  1645
    fixes S :: "'a::euclidean_space set"
nipkow@68617
  1646
    shows "ENR S \<Longrightarrow> locally compact S"
nipkow@68617
  1647
  by (simp add: ENR_ANR)
nipkow@68617
  1648
nipkow@68617
  1649
lemma ANR_imp_locally_path_connected:
nipkow@68617
  1650
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1651
  assumes "ANR S"
nipkow@68617
  1652
    shows "locally path_connected S"
nipkow@68617
  1653
proof -
nipkow@68617
  1654
  obtain U and T :: "('a \<times> real) set"
nipkow@68617
  1655
     where "convex U" "U \<noteq> {}"
nipkow@68617
  1656
       and UT: "closedin (subtopology euclidean U) T"
nipkow@68617
  1657
       and "S homeomorphic T"
nipkow@68617
  1658
    apply (rule homeomorphic_closedin_convex [of S])
nipkow@68617
  1659
    using aff_dim_le_DIM [of S] apply auto
nipkow@68617
  1660
    done
nipkow@68617
  1661
  then have "locally path_connected T"
nipkow@68617
  1662
    by (meson ANR_imp_absolute_neighbourhood_retract
nipkow@68617
  1663
        assms convex_imp_locally_path_connected locally_open_subset retract_of_locally_path_connected)
nipkow@68617
  1664
  then have S: "locally path_connected S"
nipkow@68617
  1665
      if "openin (subtopology euclidean U) V" "T retract_of V" "U \<noteq> {}" for V
nipkow@68617
  1666
    using \<open>S homeomorphic T\<close> homeomorphic_locally homeomorphic_path_connectedness by blast
nipkow@68617
  1667
  show ?thesis
nipkow@68617
  1668
    using assms
nipkow@68617
  1669
    apply (clarsimp simp: ANR_def)
nipkow@68617
  1670
    apply (drule_tac x=U in spec)
nipkow@68617
  1671
    apply (drule_tac x=T in spec)
nipkow@68617
  1672
    using \<open>S homeomorphic T\<close> \<open>U \<noteq> {}\<close> UT  apply (blast intro: S)
nipkow@68617
  1673
    done
nipkow@68617
  1674
qed
nipkow@68617
  1675
nipkow@68617
  1676
lemma ANR_imp_locally_connected:
nipkow@68617
  1677
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1678
  assumes "ANR S"
nipkow@68617
  1679
    shows "locally connected S"
nipkow@68617
  1680
using locally_path_connected_imp_locally_connected ANR_imp_locally_path_connected assms by auto
nipkow@68617
  1681
nipkow@68617
  1682
lemma AR_imp_locally_path_connected:
nipkow@68617
  1683
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1684
  assumes "AR S"
nipkow@68617
  1685
    shows "locally path_connected S"
nipkow@68617
  1686
by (simp add: ANR_imp_locally_path_connected AR_imp_ANR assms)
nipkow@68617
  1687
nipkow@68617
  1688
lemma AR_imp_locally_connected:
nipkow@68617
  1689
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1690
  assumes "AR S"
nipkow@68617
  1691
    shows "locally connected S"
nipkow@68617
  1692
using ANR_imp_locally_connected AR_ANR assms by blast
nipkow@68617
  1693
nipkow@68617
  1694
lemma ENR_imp_locally_path_connected:
nipkow@68617
  1695
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1696
  assumes "ENR S"
nipkow@68617
  1697
    shows "locally path_connected S"
nipkow@68617
  1698
by (simp add: ANR_imp_locally_path_connected ENR_imp_ANR assms)
nipkow@68617
  1699
nipkow@68617
  1700
lemma ENR_imp_locally_connected:
nipkow@68617
  1701
  fixes S :: "'a::euclidean_space set"
nipkow@68617
  1702
  assumes "ENR S"
nipkow@68617
  1703
    shows "locally connected S"
nipkow@68617
  1704
using ANR_imp_locally_connected ENR_ANR assms by blast
nipkow@68617
  1705
nipkow@68617
  1706
lemma ANR_Times:
nipkow@68617
  1707
  fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
nipkow@68617
  1708
  assumes "ANR S" "ANR T" shows "ANR(S \<times> T)"
nipkow@68617
  1709
proof (clarsimp simp only: ANR_eq_absolute_neighbourhood_extensor)
nipkow@68617
  1710
  fix f :: " ('a \<times> 'b) \<times> real \<Rightarrow> 'a \<times> 'b" and U C
nipkow@68617
  1711
  assume "continuous_on C f" and fim: "f ` C \<subseteq> S \<times> T"
nipkow@68617
  1712
     and cloUC: "closedin (subtopology euclidean U) C"
nipkow@68617
  1713
  have contf1: "continuous_on C (fst \<circ> f)"
nipkow@68617
  1714
    by (simp add: \<open>continuous_on C f\<close> continuous_on_fst)
nipkow@68617
  1715
  obtain W1 g where "C \<subseteq> W1"
nipkow@68617
  1716
               and UW1: "openin (subtopology euclidean U) W1"
nipkow@68617
  1717
               and contg: "continuous_on W1 g"
nipkow@68617
  1718
               and gim: "g ` W1 \<subseteq> S"
nipkow@68617
  1719
               and geq: "\<And>x. x \<in> C \<Longrightarrow> g x = (fst \<circ> f) x"
nipkow@68617
  1720
    apply (rule ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR S\<close> contf1 _ cloUC])
nipkow@68617
  1721
    using fim apply auto
nipkow@68617
  1722
    done
nipkow@68617
  1723
  have contf2: "continuous_on C (snd \<circ> f)"
nipkow@68617
  1724
    by (simp add: \<open>continuous_on C f\<close> continuous_on_snd)
nipkow@68617
  1725
  obtain W2 h where "C \<subseteq> W2"
nipkow@68617
  1726
               and UW2: "openin (subtopology euclidean U) W2"
nipkow@68617
  1727
               and conth: "continuous_on W2 h"
nipkow@68617
  1728
               and him: "h ` W2 \<subseteq> T"
nipkow@68617
  1729
               and heq: "\<And>x. x \<in> C \<Longrightarrow> h x = (snd \<circ> f) x"
nipkow@68617
  1730
    apply (rule ANR_imp_absolute_neighbourhood_extensor [OF \<open>ANR T\<close> contf2 _ cloUC])
nipkow@68617
  1731
    using fim apply auto
nipkow@68617
  1732
    done
nipkow@68617
  1733
  show "\<exists>V g. C \<subseteq> V \<and>
nipkow@68617
  1734
               openin (subtopology euclidean U) V \<and>
nipkow@68617
  1735
               continuous_on V g \<and> g ` V \<subseteq> S \<times> T \<and> (\<forall>x\<in>C. g x = f x)"
nipkow@68617
  1736
  proof (intro exI conjI)
nipkow@68617
  1737
    show "C \<subseteq> W1 \<inter> W2"
nipkow@68617
  1738
      by (simp add: \<open>C \<subseteq> W1\<close> \<open>C \<subseteq> W2\<close>)
nipkow@68617
  1739
    show "openin (subtopology euclidean U) (W1 \<inter> W2)"
nipkow@68617
  1740
      by (simp add: UW1 UW2 openin_Int)
nipkow@68617
  1741
    show  "continuous_on (W1 \<inter> W2) (\<lambda>x. (g x, h x))"
nipkow@68617
  1742
      by (metis (no_types) contg conth continuous_on_Pair continuous_on_subset inf_commute inf_le1)
nipkow@68617
  1743
    show  "(\<lambda>x. (g x, h x)) ` (W1 \<inter> W2) \<subseteq> S \<times> T"
nipkow@68617
  1744
      using gim him by blast
nipkow@68617
  1745
    show  "(\<forall>x\<in>C. (g x, h x) = f x)"
nipkow@68617
  1746
      using geq heq by auto
nipkow@68617
  1747
  qed
nipkow@68617
  1748
qed
nipkow@68617
  1749
nipkow@68617
  1750
lemma AR_Times:
nipkow@68617
  1751
  fixes S :: "'a::euclidean_space set" and T :: "'b::euclidean_space set"
nipkow@68617
  1752
  assumes "AR S" "AR T" shows "AR(S \<times> T)"
nipkow@68617
  1753
using assms by (simp add: AR_ANR ANR_Times contractible_Times)
nipkow@68617
  1754
nipkow@68617
  1755
subsection \<open>Kuhn Simplices\<close>
nipkow@68617
  1756
hoelzl@56273
  1757
lemma bij_betw_singleton_eq:
hoelzl@56273
  1758
  assumes f: "bij_betw f A B" and g: "bij_betw g A B" and a: "a \<in> A"
hoelzl@56273
  1759
  assumes eq: "(\<And>x. x \<in> A \<Longrightarrow> x \<noteq> a \<Longrightarrow> f x = g x)"
hoelzl@56273
  1760
  shows "f a = g a"
hoelzl@56273
  1761
proof -
hoelzl@56273
  1762
  have "f ` (A - {a}) = g ` (A - {a})"
hoelzl@56273
  1763
    by (intro image_cong) (simp_all add: eq)
hoelzl@56273
  1764
  then have "B - {f a} = B - {g a}"
paulson@60303
  1765
    using f g a  by (auto simp: bij_betw_def inj_on_image_set_diff set_eq_iff Diff_subset)
hoelzl@56273
  1766
  moreover have "f a \<in> B" "g a \<in> B"
hoelzl@56273
  1767
    using f g a by (auto simp: bij_betw_def)
hoelzl@56273
  1768
  ultimately show ?thesis
hoelzl@56273
  1769
    by auto
hoelzl@56273
  1770
qed
hoelzl@56273
  1771
hoelzl@56273
  1772
lemma swap_image:
hoelzl@56273
  1773
  "Fun.swap i j f ` A = (if i \<in> A then (if j \<in> A then f ` A else f ` ((A - {i}) \<union> {j}))
hoelzl@56273
  1774
                                  else (if j \<in> A then f ` ((A - {j}) \<union> {i}) else f ` A))"
lp15@68022
  1775
  by (auto simp: swap_def image_def) metis
hoelzl@56273
  1776
haftmann@63365
  1777
lemmas swap_apply1 = swap_apply(1)
haftmann@63365
  1778
lemmas swap_apply2 = swap_apply(2)
haftmann@63365
  1779
lemmas Zero_notin_Suc = zero_notin_Suc_image
hoelzl@56273
  1780
hoelzl@56273
  1781
lemma pointwise_minimal_pointwise_maximal:
hoelzl@56273
  1782
  fixes s :: "(nat \<Rightarrow> nat) set"
hoelzl@56273
  1783
  assumes "finite s"
hoelzl@56273
  1784
    and "s \<noteq> {}"
hoelzl@56273
  1785
    and "\<forall>x\<in>s. \<forall>y\<in>s. x \<le> y \<or> y \<le> x"
hoelzl@56273
  1786
  shows "\<exists>a\<in>s. \<forall>x\<in>s. a \<le> x"
hoelzl@56273
  1787
    and "\<exists>a\<in>s. \<forall>x\<in>s. x \<le> a"
hoelzl@56273
  1788
  using assms
hoelzl@56273
  1789
proof (induct s rule: finite_ne_induct)
hoelzl@56273
  1790
  case (insert b s)
hoelzl@56273
  1791
  assume *: "\<forall>x\<in>insert b s. \<forall>y\<in>insert b s. x \<le> y \<or> y \<le> x"
wenzelm@63540
  1792
  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"
hoelzl@56273
  1793
    using insert by auto
wenzelm@63540
  1794
  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"
hoelzl@56273
  1795
    using *[rule_format, of b u] *[rule_format, of b l] by (metis insert_iff order.trans)+
hoelzl@56273
  1796
qed auto
hoelzl@50526
  1797
nipkow@68617
  1798
(* FIXME mv *)
hoelzl@33741
  1799
lemma brouwer_compactness_lemma:
huffman@56226
  1800
  fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
wenzelm@53674
  1801
  assumes "compact s"
wenzelm@53674
  1802
    and "continuous_on s f"
wenzelm@53688
  1803
    and "\<not> (\<exists>x\<in>s. f x = 0)"
wenzelm@53674
  1804
  obtains d where "0 < d" and "\<forall>x\<in>s. d \<le> norm (f x)"
wenzelm@53185
  1805
proof (cases "s = {}")
wenzelm@53674
  1806
  case True
wenzelm@53688
  1807
  show thesis
wenzelm@53688
  1808
    by (rule that [of 1]) (auto simp: True)
wenzelm@53674
  1809
next
wenzelm@49374
  1810
  case False
wenzelm@49374
  1811
  have "continuous_on s (norm \<circ> f)"
hoelzl@56371
  1812
    by (rule continuous_intros continuous_on_norm assms(2))+
wenzelm@53674
  1813
  with False obtain x where x: "x \<in> s" "\<forall>y\<in>s. (norm \<circ> f) x \<le> (norm \<circ> f) y"
wenzelm@53674
  1814
    using continuous_attains_inf[OF assms(1), of "norm \<circ> f"]
wenzelm@53674
  1815
    unfolding o_def
wenzelm@53674
  1816
    by auto
wenzelm@53674
  1817
  have "(norm \<circ> f) x > 0"
wenzelm@53674
  1818
    using assms(3) and x(1)
wenzelm@53674
  1819
    by auto
wenzelm@53674
  1820
  then show ?thesis
wenzelm@53674
  1821
    by (rule that) (insert x(2), auto simp: o_def)
wenzelm@49555
  1822
qed
hoelzl@33741
  1823
wenzelm@49555
  1824
lemma kuhn_labelling_lemma:
hoelzl@50526
  1825
  fixes P Q :: "'a::euclidean_space \<Rightarrow> bool"
hoelzl@56273
  1826
  assumes "\<forall>x. P x \<longrightarrow> P (f x)"
hoelzl@50526
  1827
    and "\<forall>x. P x \<longrightarrow> (\<forall>i\<in>Basis. Q i \<longrightarrow> 0 \<le> x\<bullet>i \<and> x\<bullet>i \<le> 1)"
hoelzl@50526
  1828
  shows "\<exists>l. (\<forall>x.\<forall>i\<in>Basis. l x i \<le> (1::nat)) \<and>
hoelzl@50526
  1829
             (\<forall>x.\<forall>i\<in>Basis. P x \<and> Q i \<and> (x\<bullet>i = 0) \<longrightarrow> (l x i = 0)) \<and>
hoelzl@50526
  1830
             (\<forall>x.\<forall>i\<in>Basis. P x \<and> Q i \<and> (x\<bullet>i = 1) \<longrightarrow> (l x i = 1)) \<and>
hoelzl@56273
  1831
             (\<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>
hoelzl@56273
  1832
             (\<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)"
wenzelm@49374
  1833
proof -
hoelzl@56273
  1834
  { fix x i
hoelzl@56273
  1835
    let ?R = "\<lambda>y. (P x \<and> Q i \<and> x \<bullet> i = 0 \<longrightarrow> y = (0::nat)) \<and>
hoelzl@56273
  1836
        (P x \<and> Q i \<and> x \<bullet> i = 1 \<longrightarrow> y = 1) \<and>
hoelzl@56273
  1837
        (P x \<and> Q i \<and> y = 0 \<longrightarrow> x \<bullet> i \<le> f x \<bullet> i) \<and>
hoelzl@56273
  1838
        (P x \<and> Q i \<and> y = 1 \<longrightarrow> f x \<bullet> i \<le> x \<bullet> i)"
hoelzl@56273
  1839
    { 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 }
hoelzl@56273
  1840
    then have "i \<in> Basis \<Longrightarrow> ?R 0 \<or> ?R 1" by auto }
hoelzl@56273
  1841
  then show ?thesis
hoelzl@56273
  1842
    unfolding all_conj_distrib[symmetric] Ball_def (* FIXME: shouldn't this work by metis? *)
hoelzl@56273
  1843
    by (subst choice_iff[symmetric])+ blast
wenzelm@49374
  1844
qed
wenzelm@49374
  1845
wenzelm@53185
  1846
nipkow@68617
  1847
subsubsection \<open>The key "counting" observation, somewhat abstracted\<close>
hoelzl@33741
  1848
wenzelm@53252
  1849
lemma kuhn_counting_lemma:
hoelzl@56273
  1850
  fixes bnd compo compo' face S F
hoelzl@56273
  1851
  defines "nF s == card {f\<in>F. face f s \<and> compo' f}"
wenzelm@67443
  1852
  assumes [simp, intro]: "finite F" \<comment> \<open>faces\<close> and [simp, intro]: "finite S" \<comment> \<open>simplices\<close>
hoelzl@56273
  1853
    and "\<And>f. f \<in> F \<Longrightarrow> bnd f \<Longrightarrow> card {s\<in>S. face f s} = 1"
hoelzl@56273
  1854
    and "\<And>f. f \<in> F \<Longrightarrow> \<not> bnd f \<Longrightarrow> card {s\<in>S. face f s} = 2"
hoelzl@56273
  1855
    and "\<And>s. s \<in> S \<Longrightarrow> compo s \<Longrightarrow> nF s = 1"
hoelzl@56273
  1856
    and "\<And>s. s \<in> S \<Longrightarrow> \<not> compo s \<Longrightarrow> nF s = 0 \<or> nF s = 2"
hoelzl@56273
  1857
    and "odd (card {f\<in>F. compo' f \<and> bnd f})"
hoelzl@56273
  1858
  shows "odd (card {s\<in>S. compo s})"
wenzelm@53185
  1859
proof -
hoelzl@56273
  1860
  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)"
nipkow@64267
  1861
    by (subst sum.union_disjoint[symmetric]) (auto intro!: sum.cong)
hoelzl@56273
  1862
  also have "\<dots> = (\<Sum>s\<in>S. card {f \<in> {f\<in>F. compo' f \<and> bnd f}. face f s}) +
hoelzl@56273
  1863
                  (\<Sum>s\<in>S. card {f \<in> {f\<in>F. compo' f \<and> \<not> bnd f}. face f s})"
nipkow@64267
  1864
    unfolding sum.distrib[symmetric]
hoelzl@56273
  1865
    by (subst card_Un_disjoint[symmetric])
nipkow@64267
  1866
       (auto simp: nF_def intro!: sum.cong arg_cong[where f=card])
hoelzl@56273
  1867
  also have "\<dots> = 1 * card {f\<in>F. compo' f \<and> bnd f} + 2 * card {f\<in>F. compo' f \<and> \<not> bnd f}"
nipkow@67399
  1868
    using assms(4,5) by (fastforce intro!: arg_cong2[where f="(+)"] sum_multicount)
hoelzl@56273
  1869
  finally have "odd ((\<Sum>s | s \<in> S \<and> \<not> compo s. nF s) + card {s\<in>S. compo s})"
hoelzl@56273
  1870
    using assms(6,8) by simp
hoelzl@56273
  1871
  moreover have "(\<Sum>s | s \<in> S \<and> \<not> compo s. nF s) =
hoelzl@56273
  1872
    (\<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)"
nipkow@64267
  1873
    using assms(7) by (subst sum.union_disjoint[symmetric]) (fastforce intro!: sum.cong)+
wenzelm@53688
  1874
  ultimately show ?thesis
wenzelm@53688
  1875
    by auto
wenzelm@53186
  1876
qed
wenzelm@53186
  1877
nipkow@68617
  1878
subsubsection \<open>The odd/even result for faces of complete vertices, generalized\<close>
hoelzl@56273
  1879
hoelzl@56273
  1880
lemma kuhn_complete_lemma:
hoelzl@56273
  1881
  assumes [simp]: "finite simplices"
hoelzl@56273
  1882
    and face: "\<And>f s. face f s \<longleftrightarrow> (\<exists>a\<in>s. f = s - {a})"
hoelzl@56273
  1883
    and card_s[simp]:  "\<And>s. s \<in> simplices \<Longrightarrow> card s = n + 2"
hoelzl@56273
  1884
    and rl_bd: "\<And>s. s \<in> simplices \<Longrightarrow> rl ` s \<subseteq> {..Suc n}"
hoelzl@56273
  1885
    and bnd: "\<And>f s. s \<in> simplices \<Longrightarrow> face f s \<Longrightarrow> bnd f \<Longrightarrow> card {s\<in>simplices. face f s} = 1"
hoelzl@56273
  1886
    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"
hoelzl@56273
  1887
    and odd_card: "odd (card {f. (\<exists>s\<in>simplices. face f s) \<and> rl ` f = {..n} \<and> bnd f})"
hoelzl@56273
  1888
  shows "odd (card {s\<in>simplices. (rl ` s = {..Suc n})})"
hoelzl@56273
  1889
proof (rule kuhn_counting_lemma)
hoelzl@56273
  1890
  have finite_s[simp]: "\<And>s. s \<in> simplices \<Longrightarrow> finite s"
lp15@61609
  1891
    by (metis add_is_0 zero_neq_numeral card_infinite assms(3))
hoelzl@56273
  1892
hoelzl@56273
  1893
  let ?F = "{f. \<exists>s\<in>simplices. face f s}"
hoelzl@56273
  1894
  have F_eq: "?F = (\<Union>s\<in>simplices. \<Union>a\<in>s. {s - {a}})"
hoelzl@56273
  1895
    by (auto simp: face)
hoelzl@56273
  1896
  show "finite ?F"
wenzelm@60420
  1897
    using \<open>finite simplices\<close> unfolding F_eq by auto
hoelzl@56273
  1898
wenzelm@60421
  1899
  show "card {s \<in> simplices. face f s} = 1" if "f \<in> ?F" "bnd f" for f
wenzelm@60449
  1900
    using bnd that by auto
hoelzl@56273
  1901
wenzelm@60421
  1902
  show "card {s \<in> simplices. face f s} = 2" if "f \<in> ?F" "\<not> bnd f" for f
wenzelm@60449
  1903
    using nbnd that by auto
hoelzl@56273
  1904
hoelzl@56273
  1905
  show "odd (card {f \<in> {f. \<exists>s\<in>simplices. face f s}. rl ` f = {..n} \<and> bnd f})"
hoelzl@56273
  1906
    using odd_card by simp
hoelzl@56273
  1907
hoelzl@56273
  1908
  fix s assume s[simp]: "s \<in> simplices"
hoelzl@56273
  1909
  let ?S = "{f \<in> {f. \<exists>s\<in>simplices. face f s}. face f s \<and> rl ` f = {..n}}"
hoelzl@56273
  1910
  have "?S = (\<lambda>a. s - {a}) ` {a\<in>s. rl ` (s - {a}) = {..n}}"
hoelzl@56273
  1911
    using s by (fastforce simp: face)
hoelzl@56273
  1912
  then have card_S: "card ?S = card {a\<in>s. rl ` (s - {a}) = {..n}}"
hoelzl@56273
  1913
    by (auto intro!: card_image inj_onI)
hoelzl@56273
  1914
hoelzl@56273
  1915
  { assume rl: "rl ` s = {..Suc n}"
hoelzl@56273
  1916
    then have inj_rl: "inj_on rl s"
hoelzl@56273
  1917
      by (intro eq_card_imp_inj_on) auto
hoelzl@56273
  1918
    moreover obtain a where "rl a = Suc n" "a \<in> s"
hoelzl@56273
  1919
      by (metis atMost_iff image_iff le_Suc_eq rl)
hoelzl@56273
  1920
    ultimately have n: "{..n} = rl ` (s - {a})"
lp15@68022
  1921
      by (auto simp: inj_on_image_set_diff Diff_subset rl)
hoelzl@56273
  1922
    have "{a\<in>s. rl ` (s - {a}) = {..n}} = {a}"
lp15@68022
  1923
      using inj_rl \<open>a \<in> s\<close> by (auto simp: n inj_on_image_eq_iff[OF inj_rl] Diff_subset)
hoelzl@56273
  1924
    then show "card ?S = 1"
hoelzl@56273
  1925
      unfolding card_S by simp }
hoelzl@56273
  1926
hoelzl@56273
  1927
  { assume rl: "rl ` s \<noteq> {..Suc n}"
hoelzl@56273
  1928
    show "card ?S = 0 \<or> card ?S = 2"
hoelzl@56273
  1929
    proof cases
hoelzl@56273
  1930
      assume *: "{..n} \<subseteq> rl ` s"
hoelzl@56273
  1931
      with rl rl_bd[OF s] have rl_s: "rl ` s = {..n}"
lp15@68022
  1932
        by (auto simp: atMost_Suc subset_insert_iff split: if_split_asm)
hoelzl@56273
  1933
      then have "\<not> inj_on rl s"
hoelzl@56273
  1934
        by (intro pigeonhole) simp
hoelzl@56273
  1935
      then obtain a b where ab: "a \<in> s" "b \<in> s" "rl a = rl b" "a \<noteq> b"
hoelzl@56273
  1936
        by (auto simp: inj_on_def)
hoelzl@56273
  1937
      then have eq: "rl ` (s - {a}) = rl ` s"
hoelzl@56273
  1938
        by auto
hoelzl@56273
  1939
      with ab have inj: "inj_on rl (s - {a})"
lp15@68022
  1940
        by (intro eq_card_imp_inj_on) (auto simp: rl_s card_Diff_singleton_if)
hoelzl@56273
  1941
hoelzl@56273
  1942
      { fix x assume "x \<in> s" "x \<notin> {a, b}"
hoelzl@56273
  1943
        then have "rl ` s - {rl x} = rl ` ((s - {a}) - {x})"
paulson@60303
  1944
          by (auto simp: eq Diff_subset inj_on_image_set_diff[OF inj])
hoelzl@56273
  1945
        also have "\<dots> = rl ` (s - {x})"
wenzelm@60420
  1946
          using ab \<open>x \<notin> {a, b}\<close> by auto
hoelzl@56273
  1947
        also assume "\<dots> = rl ` s"
hoelzl@56273
  1948
        finally have False
wenzelm@60420
  1949
          using \<open>x\<in>s\<close> by auto }
hoelzl@56273
  1950
      moreover
hoelzl@56273
  1951
      { fix x assume "x \<in> {a, b}" with ab have "x \<in> s \<and> rl ` (s - {x}) = rl ` s"
hoelzl@56273
  1952
          by (simp add: set_eq_iff image_iff Bex_def) metis }
hoelzl@56273
  1953
      ultimately have "{a\<in>s. rl ` (s - {a}) = {..n}} = {a, b}"
hoelzl@56273
  1954
        unfolding rl_s[symmetric] by fastforce
wenzelm@60420
  1955
      with \<open>a \<noteq> b\<close> show "card ?S = 0 \<or> card ?S = 2"
hoelzl@56273
  1956
        unfolding card_S by simp
hoelzl@56273
  1957
    next
hoelzl@56273
  1958
      assume "\<not> {..n} \<subseteq> rl ` s"
hoelzl@56273
  1959
      then have "\<And>x. rl ` (s - {x}) \<noteq> {..n}"
hoelzl@56273
  1960
        by auto
hoelzl@56273
  1961
      then show "card ?S = 0 \<or> card ?S = 2"
hoelzl@56273
  1962
        unfolding card_S by simp
hoelzl@56273
  1963
    qed }
hoelzl@56273
  1964
qed fact
hoelzl@56273
  1965
hoelzl@56273
  1966
locale kuhn_simplex =
hoelzl@56273
  1967
  fixes p n and base upd and s :: "(nat \<Rightarrow> nat) set"
hoelzl@56273
  1968
  assumes base: "base \<in> {..< n} \<rightarrow> {..< p}"
hoelzl@56273
  1969
  assumes base_out: "\<And>i. n \<le> i \<Longrightarrow> base i = p"
hoelzl@56273
  1970
  assumes upd: "bij_betw upd {..< n} {..< n}"
hoelzl@56273
  1971
  assumes s_pre: "s = (\<lambda>i j. if j \<in> upd`{..< i} then Suc (base j) else base j) ` {.. n}"
hoelzl@56273
  1972
begin
hoelzl@56273
  1973
hoelzl@56273
  1974
definition "enum i j = (if j \<in> upd`{..< i} then Suc (base j) else base j)"
hoelzl@56273
  1975
hoelzl@56273
  1976
lemma s_eq: "s = enum ` {.. n}"
hoelzl@56273
  1977
  unfolding s_pre enum_def[abs_def] ..
hoelzl@56273
  1978
hoelzl@56273
  1979
lemma upd_space: "i < n \<Longrightarrow> upd i < n"
hoelzl@56273
  1980
  using upd by (auto dest!: bij_betwE)
hoelzl@56273
  1981
hoelzl@56273
  1982
lemma s_space: "s \<subseteq> {..< n} \<rightarrow> {.. p}"
hoelzl@56273
  1983
proof -
hoelzl@56273
  1984
  { fix i assume "i \<le> n" then have "enum i \<in> {..< n} \<rightarrow> {.. p}"
hoelzl@56273
  1985
    proof (induct i)
hoelzl@56273
  1986
      case 0 then show ?case
hoelzl@56273
  1987
        using base by (auto simp: Pi_iff less_imp_le enum_def)
hoelzl@56273
  1988
    next
hoelzl@56273
  1989
      case (Suc i) with base show ?case
hoelzl@56273
  1990
        by (auto simp: Pi_iff Suc_le_eq less_imp_le enum_def intro: upd_space)
hoelzl@56273
  1991
    qed }
hoelzl@56273
  1992
  then show ?thesis
hoelzl@56273
  1993
    by (auto simp: s_eq)
hoelzl@56273
  1994
qed
hoelzl@56273
  1995
hoelzl@56273
  1996
lemma inj_upd: "inj_on upd {..< n}"
hoelzl@56273
  1997
  using upd by (simp add: bij_betw_def)
hoelzl@56273
  1998
hoelzl@56273
  1999
lemma inj_enum: "inj_on enum {.. n}"
hoelzl@56273
  2000
proof -
hoelzl@56273
  2001
  { fix x y :: nat assume "x \<noteq> y" "x \<le> n" "y \<le> n"
hoelzl@56273
  2002
    with upd have "upd ` {..< x} \<noteq> upd ` {..< y}"
lp15@61609
  2003
      by (subst inj_on_image_eq_iff[where C="{..< n}"]) (auto simp: bij_betw_def)
hoelzl@56273
  2004
    then have "enum x \<noteq> enum y"
lp15@68022
  2005
      by (auto simp: enum_def fun_eq_iff) }
hoelzl@56273
  2006
  then show ?thesis
hoelzl@56273
  2007
    by (auto simp: inj_on_def)
hoelzl@56273
  2008
qed
hoelzl@56273
  2009
hoelzl@56273
  2010
lemma enum_0: "enum 0 = base"
hoelzl@56273
  2011
  by (simp add: enum_def[abs_def])
hoelzl@56273
  2012
hoelzl@56273
  2013
lemma base_in_s: "base \<in> s"
hoelzl@56273
  2014
  unfolding s_eq by (subst enum_0[symmetric]) auto
hoelzl@56273
  2015
hoelzl@56273
  2016
lemma enum_in: "i \<le> n \<Longrightarrow> enum i \<in> s"
hoelzl@56273
  2017
  unfolding s_eq by auto
hoelzl@56273
  2018
hoelzl@56273
  2019
lemma one_step:
hoelzl@56273
  2020
  assumes a: "a \<in> s" "j < n"
hoelzl@56273
  2021
  assumes *: "\<And>a'. a' \<in> s \<Longrightarrow> a' \<noteq> a \<Longrightarrow> a' j = p'"
hoelzl@56273
  2022
  shows "a j \<noteq> p'"
hoelzl@56273
  2023
proof
hoelzl@56273
  2024
  assume "a j = p'"
hoelzl@56273
  2025
  with * a have "\<And>a'. a' \<in> s \<Longrightarrow> a' j = p'"
hoelzl@56273
  2026
    by auto
hoelzl@56273
  2027
  then have "\<And>i. i \<le> n \<Longrightarrow> enum i j = p'"
hoelzl@56273
  2028
    unfolding s_eq by auto
hoelzl@56273
  2029
  from this[of 0] this[of n] have "j \<notin> upd ` {..< n}"
nipkow@62390
  2030
    by (auto simp: enum_def fun_eq_iff split: if_split_asm)
wenzelm@60420
  2031
  with upd \<open>j < n\<close> show False
hoelzl@56273
  2032
    by (auto simp: bij_betw_def)
hoelzl@56273
  2033
qed
hoelzl@56273
  2034
hoelzl@56273
  2035
lemma upd_inj: "i < n \<Longrightarrow> j < n \<Longrightarrow> upd i = upd j \<longleftrightarrow> i = j"
lp15@61520
  2036
  using upd by (auto simp: bij_betw_def inj_on_eq_iff)
hoelzl@56273
  2037
hoelzl@56273
  2038
lemma upd_surj: "upd ` {..< n} = {..< n}"
hoelzl@56273
  2039
  using upd by (auto simp: bij_betw_def)
hoelzl@56273
  2040
hoelzl@56273
  2041
lemma in_upd_image: "A \<subseteq> {..< n} \<Longrightarrow> i < n \<Longrightarrow> upd i \<in> upd ` A \<longleftrightarrow> i \<in> A"
lp15@61520
  2042
  using inj_on_image_mem_iff[of upd "{..< n}"] upd
hoelzl@56273
  2043
  by (auto simp: bij_betw_def)
hoelzl@56273
  2044
hoelzl@56273
  2045
lemma enum_inj: "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> enum i = enum j \<longleftrightarrow> i = j"
lp15@61520
  2046
  using inj_enum by (auto simp: inj_on_eq_iff)
hoelzl@56273
  2047
hoelzl@56273
  2048
lemma in_enum_image: "A \<subseteq> {.. n} \<Longrightarrow> i \<le> n \<Longrightarrow> enum i \<in> enum ` A \<longleftrightarrow> i \<in> A"
lp15@61520
  2049
  using inj_on_image_mem_iff[OF inj_enum] by auto
hoelzl@56273
  2050
hoelzl@56273
  2051
lemma enum_mono: "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> enum i \<le> enum j \<longleftrightarrow> i \<le> j"
hoelzl@56273
  2052
  by (auto simp: enum_def le_fun_def in_upd_image Ball_def[symmetric])
hoelzl@56273
  2053
hoelzl@56273
  2054
lemma enum_strict_mono: "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> enum i < enum j \<longleftrightarrow> i < j"
lp15@68022
  2055
  using enum_mono[of i j] enum_inj[of i j] by (auto simp: le_less)
hoelzl@56273
  2056
hoelzl@56273
  2057
lemma chain: "a \<in> s \<Longrightarrow> b \<in> s \<Longrightarrow> a \<le> b \<or> b \<le> a"
hoelzl@56273
  2058
  by (auto simp: s_eq enum_mono)
hoelzl@56273
  2059
hoelzl@56273
  2060
lemma less: "a \<in> s \<Longrightarrow> b \<in> s \<Longrightarrow> a i < b i \<Longrightarrow> a < b"
hoelzl@56273
  2061
  using chain[of a b] by (auto simp: less_fun_def le_fun_def not_le[symmetric])
hoelzl@56273
  2062
hoelzl@56273
  2063
lemma enum_0_bot: "a \<in> s \<Longrightarrow> a = enum 0 \<longleftrightarrow> (\<forall>a'\<in>s. a \<le> a')"
hoelzl@56273
  2064
  unfolding s_eq by (auto simp: enum_mono Ball_def)
hoelzl@56273
  2065
hoelzl@56273
  2066
lemma enum_n_top: "a \<in> s \<Longrightarrow> a = enum n \<longleftrightarrow> (\<forall>a'\<in>s. a' \<le> a)"
hoelzl@56273
  2067
  unfolding s_eq by (auto simp: enum_mono Ball_def)
hoelzl@56273
  2068
hoelzl@56273
  2069
lemma enum_Suc: "i < n \<Longrightarrow> enum (Suc i) = (enum i)(upd i := Suc (enum i (upd i)))"
hoelzl@56273
  2070
  by (auto simp: fun_eq_iff enum_def upd_inj)
hoelzl@56273
  2071
hoelzl@56273
  2072
lemma enum_eq_p: "i \<le> n \<Longrightarrow> n \<le> j \<Longrightarrow> enum i j = p"
hoelzl@56273
  2073
  by (induct i) (auto simp: enum_Suc enum_0 base_out upd_space not_less[symmetric])
hoelzl@56273
  2074
hoelzl@56273
  2075
lemma out_eq_p: "a \<in> s \<Longrightarrow> n \<le> j \<Longrightarrow> a j = p"
lp15@68022
  2076
  unfolding s_eq by (auto simp: enum_eq_p)
hoelzl@56273
  2077
hoelzl@56273
  2078
lemma s_le_p: "a \<in> s \<Longrightarrow> a j \<le> p"
hoelzl@56273
  2079
  using out_eq_p[of a j] s_space by (cases "j < n") auto
hoelzl@56273
  2080
hoelzl@56273
  2081
lemma le_Suc_base: "a \<in> s \<Longrightarrow> a j \<le> Suc (base j)"
hoelzl@56273
  2082
  unfolding s_eq by (auto simp: enum_def)
hoelzl@56273
  2083
hoelzl@56273
  2084
lemma base_le: "a \<in> s \<Longrightarrow> base j \<le> a j"
hoelzl@56273
  2085
  unfolding s_eq by (auto simp: enum_def)
hoelzl@56273
  2086
hoelzl@56273
  2087
lemma enum_le_p: "i \<le> n \<Longrightarrow> j < n \<Longrightarrow> enum i j \<le> p"
hoelzl@56273
  2088
  using enum_in[of i] s_space by auto
hoelzl@56273
  2089
hoelzl@56273
  2090
lemma enum_less: "a \<in> s \<Longrightarrow> i < n \<Longrightarrow> enum i < a \<longleftrightarrow> enum (Suc i) \<le> a"
hoelzl@56273
  2091
  unfolding s_eq by (auto simp: enum_strict_mono enum_mono)
hoelzl@56273
  2092
hoelzl@56273
  2093
lemma ksimplex_0:
hoelzl@56273
  2094
  "n = 0 \<Longrightarrow> s = {(\<lambda>x. p)}"
hoelzl@56273
  2095
  using s_eq enum_def base_out by auto
hoelzl@56273
  2096
hoelzl@56273
  2097
lemma replace_0:
hoelzl@56273
  2098
  assumes "j < n" "a \<in> s" and p: "\<forall>x\<in>s - {a}. x j = 0" and "x \<in> s"
hoelzl@56273
  2099
  shows "x \<le> a"
hoelzl@56273
  2100
proof cases
hoelzl@56273
  2101
  assume "x \<noteq> a"
hoelzl@56273
  2102
  have "a j \<noteq> 0"
hoelzl@56273
  2103
    using assms by (intro one_step[where a=a]) auto
wenzelm@60420
  2104
  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>
hoelzl@56273
  2105
  show ?thesis
hoelzl@56273
  2106
    by auto
hoelzl@56273
  2107
qed simp
hoelzl@56273
  2108
hoelzl@56273
  2109
lemma replace_1:
hoelzl@56273
  2110
  assumes "j < n" "a \<in> s" and p: "\<forall>x\<in>s - {a}. x j = p" and "x \<in> s"
hoelzl@56273
  2111
  shows "a \<le> x"
hoelzl@56273
  2112
proof cases
hoelzl@56273
  2113
  assume "x \<noteq> a"
hoelzl@56273
  2114
  have "a j \<noteq> p"
hoelzl@56273
  2115
    using assms by (intro one_step[where a=a]) auto
wenzelm@60420
  2116
  with enum_le_p[of _ j] \<open>j < n\<close> \<open>a\<in>s\<close>
hoelzl@56273
  2117
  have "a j < p"
hoelzl@56273
  2118
    by (auto simp: less_le s_eq)
wenzelm@60420
  2119
  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>
hoelzl@56273
  2120
  show ?thesis
hoelzl@56273
  2121
    by auto
hoelzl@56273
  2122
qed simp
hoelzl@56273
  2123
hoelzl@56273
  2124
end
hoelzl@56273
  2125
hoelzl@56273
  2126
locale kuhn_simplex_pair = s: kuhn_simplex p n b_s u_s s + t: kuhn_simplex p n b_t u_t t
hoelzl@56273
  2127
  for p n b_s u_s s b_t u_t t
hoelzl@56273
  2128
begin
hoelzl@56273
  2129
hoelzl@56273
  2130
lemma enum_eq:
hoelzl@56273
  2131
  assumes l: "i \<le> l" "l \<le> j" and "j + d \<le> n"
hoelzl@56273
  2132
  assumes eq: "s.enum ` {i .. j} = t.enum ` {i + d .. j + d}"
hoelzl@56273
  2133
  shows "s.enum l = t.enum (l + d)"
hoelzl@56273
  2134
using l proof (induct l rule: dec_induct)
hoelzl@56273
  2135
  case base
hoelzl@56273
  2136
  then have s: "s.enum i \<in> t.enum ` {i + d .. j + d}" and t: "t.enum (i + d) \<in> s.enum ` {i .. j}"
hoelzl@56273
  2137
    using eq by auto
wenzelm@60420
  2138
  from t \<open>i \<le> j\<close> \<open>j + d \<le> n\<close> have "s.enum i \<le> t.enum (i + d)"
hoelzl@56273
  2139
    by (auto simp: s.enum_mono)
wenzelm@60420
  2140
  moreover from s \<open>i \<le> j\<close> \<open>j + d \<le> n\<close> have "t.enum (i + d) \<le> s.enum i"
hoelzl@56273
  2141
    by (auto simp: t.enum_mono)
hoelzl@56273
  2142
  ultimately show ?case
hoelzl@56273
  2143
    by auto
hoelzl@56273
  2144
next
hoelzl@56273
  2145
  case (step l)
wenzelm@60420
  2146
  moreover from step.prems \<open>j + d \<le> n\<close> have
hoelzl@56273
  2147
      "s.enum l < s.enum (Suc l)"
hoelzl@56273
  2148
      "t.enum (l + d) < t.enum (Suc l + d)"
hoelzl@56273
  2149
    by (simp_all add: s.enum_strict_mono t.enum_strict_mono)
hoelzl@56273
  2150
  moreover have
hoelzl@56273
  2151
      "s.enum (Suc l) \<in> t.enum ` {i + d .. j + d}"
hoelzl@56273
  2152
      "t.enum (Suc l + d) \<in> s.enum ` {i .. j}"
wenzelm@60420
  2153
    using step \<open>j + d \<le> n\<close> eq by (auto simp: s.enum_inj t.enum_inj)
hoelzl@56273
  2154
  ultimately have "s.enum (Suc l) = t.enum (Suc (l + d))"
wenzelm@60420
  2155
    using \<open>j + d \<le> n\<close>
lp15@61609
  2156
    by (intro antisym s.enum_less[THEN iffD1] t.enum_less[THEN iffD1])
hoelzl@56273
  2157
       (auto intro!: s.enum_in t.enum_in)
hoelzl@56273
  2158
  then show ?case by simp
hoelzl@56273
  2159
qed
hoelzl@56273
  2160
hoelzl@56273
  2161
lemma ksimplex_eq_bot:
hoelzl@56273
  2162
  assumes a: "a \<in> s" "\<And>a'. a' \<in> s \<Longrightarrow> a \<le> a'"
hoelzl@56273
  2163
  assumes b: "b \<in> t" "\<And>b'. b' \<in> t \<Longrightarrow> b \<le> b'"
hoelzl@56273
  2164
  assumes eq: "s - {a} = t - {b}"
hoelzl@56273
  2165
  shows "s = t"
hoelzl@56273
  2166
proof cases
hoelzl@56273
  2167
  assume "n = 0" with s.ksimplex_0 t.ksimplex_0 show ?thesis by simp
hoelzl@56273
  2168
next
hoelzl@56273
  2169
  assume "n \<noteq> 0"
hoelzl@56273
  2170
  have "s.enum 0 = (s.enum (Suc 0)) (u_s 0 := s.enum (Suc 0) (u_s 0) - 1)"
hoelzl@56273
  2171
       "t.enum 0 = (t.enum (Suc 0)) (u_t 0 := t.enum (Suc 0) (u_t 0) - 1)"
wenzelm@60420
  2172
    using \<open>n \<noteq> 0\<close> by (simp_all add: s.enum_Suc t.enum_Suc)
hoelzl@56273
  2173
  moreover have e0: "a = s.enum 0" "b = t.enum 0"
hoelzl@56273
  2174
    using a b by (simp_all add: s.enum_0_bot t.enum_0_bot)
hoelzl@56273
  2175
  moreover
lp15@61609
  2176
  { fix j assume "0 < j" "j \<le> n"
hoelzl@56273
  2177
    moreover have "s - {a} = s.enum ` {Suc 0 .. n}" "t - {b} = t.enum ` {Suc 0 .. n}"
hoelzl@56273
  2178
      unfolding s.s_eq t.s_eq e0 by (auto simp: s.enum_inj t.enum_inj)
hoelzl@56273
  2179
    ultimately have "s.enum j = t.enum j"
hoelzl@56273
  2180
      using enum_eq[of "1" j n 0] eq by auto }
hoelzl@56273
  2181
  note enum_eq = this
hoelzl@56273
  2182
  then have "s.enum (Suc 0) = t.enum (Suc 0)"
wenzelm@60420
  2183
    using \<open>n \<noteq> 0\<close> by auto
hoelzl@56273
  2184
  moreover
hoelzl@56273
  2185
  { fix j assume "Suc j < n"
hoelzl@56273
  2186
    with enum_eq[of "Suc j"] enum_eq[of "Suc (Suc j)"]
hoelzl@56273
  2187
    have "u_s (Suc j) = u_t (Suc j)"
hoelzl@56273
  2188
      using s.enum_Suc[of "Suc j"] t.enum_Suc[of "Suc j"]
nipkow@62390
  2189
      by (auto simp: fun_eq_iff split: if_split_asm) }
hoelzl@56273
  2190
  then have "\<And>j. 0 < j \<Longrightarrow> j < n \<Longrightarrow> u_s j = u_t j"
hoelzl@56273
  2191
    by (auto simp: gr0_conv_Suc)
wenzelm@60420
  2192
  with \<open>n \<noteq> 0\<close> have "u_t 0 = u_s 0"
hoelzl@56273
  2193
    by (intro bij_betw_singleton_eq[OF t.upd s.upd, of 0]) auto
hoelzl@56273
  2194
  ultimately have "a = b"
hoelzl@56273
  2195
    by simp
hoelzl@56273
  2196
  with assms show "s = t"
hoelzl@56273
  2197
    by auto
hoelzl@56273
  2198
qed
hoelzl@56273
  2199
hoelzl@56273
  2200
lemma ksimplex_eq_top:
hoelzl@56273
  2201
  assumes a: "a \<in> s" "\<And>a'. a' \<in> s \<Longrightarrow> a' \<le> a"
hoelzl@56273
  2202
  assumes b: "b \<in> t" "\<And>b'. b' \<in> t \<Longrightarrow> b' \<le> b"
hoelzl@56273
  2203
  assumes eq: "s - {a} = t - {b}"
hoelzl@56273
  2204
  shows "s = t"
hoelzl@56273
  2205
proof (cases n)
hoelzl@56273
  2206
  assume "n = 0" with s.ksimplex_0 t.ksimplex_0 show ?thesis by simp
hoelzl@56273
  2207
next
hoelzl@56273
  2208
  case (Suc n')
hoelzl@56273
  2209
  have "s.enum n = (s.enum n') (u_s n' := Suc (s.enum n' (u_s n')))"
hoelzl@56273
  2210
       "t.enum n = (t.enum n') (u_t n' := Suc (t.enum n' (u_t n')))"
hoelzl@56273
  2211
    using Suc by (simp_all add: s.enum_Suc t.enum_Suc)
hoelzl@56273
  2212
  moreover have en: "a = s.enum n" "b = t.enum n"
hoelzl@56273
  2213
    using a b by (simp_all add: s.enum_n_top t.enum_n_top)
hoelzl@56273
  2214
  moreover
lp15@61609
  2215
  { fix j assume "j < n"
hoelzl@56273
  2216
    moreover have "s - {a} = s.enum ` {0 .. n'}" "t - {b} = t.enum ` {0 .. n'}"
hoelzl@56273
  2217
      unfolding s.s_eq t.s_eq en by (auto simp: s.enum_inj t.enum_inj Suc)
hoelzl@56273
  2218
    ultimately have "s.enum j = t.enum j"
hoelzl@56273
  2219
      using enum_eq[of "0" j n' 0] eq Suc by auto }
hoelzl@56273
  2220
  note enum_eq = this
hoelzl@56273
  2221
  then have "s.enum n' = t.enum n'"
hoelzl@56273
  2222
    using Suc by auto
hoelzl@56273
  2223
  moreover
hoelzl@56273
  2224
  { fix j assume "j < n'"
hoelzl@56273
  2225
    with enum_eq[of j] enum_eq[of "Suc j"]
hoelzl@56273
  2226
    have "u_s j = u_t j"
hoelzl@56273
  2227
      using s.enum_Suc[of j] t.enum_Suc[of j]
nipkow@62390
  2228
      by (auto simp: Suc fun_eq_iff split: if_split_asm) }
hoelzl@56273
  2229
  then have "\<And>j. j < n' \<Longrightarrow> u_s j = u_t j"
hoelzl@56273
  2230
    by (auto simp: gr0_conv_Suc)
hoelzl@56273
  2231
  then have "u_t n' = u_s n'"
hoelzl@56273
  2232
    by (intro bij_betw_singleton_eq[OF t.upd s.upd, of n']) (auto simp: Suc)
hoelzl@56273
  2233
  ultimately have "a = b"
hoelzl@56273
  2234
    by simp
hoelzl@56273
  2235
  with assms show "s = t"
hoelzl@56273
  2236
    by auto
hoelzl@56273
  2237
qed
hoelzl@56273
  2238
hoelzl@56273
  2239
end
hoelzl@56273
  2240
hoelzl@56273
  2241
inductive ksimplex for p n :: nat where
hoelzl@56273
  2242
  ksimplex: "kuhn_simplex p n base upd s \<Longrightarrow> ksimplex p n s"
hoelzl@56273
  2243
hoelzl@56273
  2244
lemma finite_ksimplexes: "finite {s. ksimplex p n s}"
hoelzl@56273
  2245
proof (rule finite_subset)
hoelzl@56273
  2246
  { fix a s assume "ksimplex p n s" "a \<in> s"
hoelzl@56273
  2247
    then obtain b u where "kuhn_simplex p n b u s" by (auto elim: ksimplex.cases)
hoelzl@56273
  2248
    then interpret kuhn_simplex p n b u s .
wenzelm@60420
  2249
    from s_space \<open>a \<in> s\<close> out_eq_p[OF \<open>a \<in> s\<close>]
hoelzl@56273
  2250
    have "a \<in> (\<lambda>f x. if n \<le> x then p else f x) ` ({..< n} \<rightarrow>\<^sub>E {.. p})"
nipkow@62390
  2251
      by (auto simp: image_iff subset_eq Pi_iff split: if_split_asm
hoelzl@56273
  2252
               intro!: bexI[of _ "restrict a {..< n}"]) }
hoelzl@56273
  2253
  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}))"
hoelzl@56273
  2254
    by auto
hoelzl@56273
  2255
qed (simp add: finite_PiE)
hoelzl@56273
  2256
hoelzl@56273
  2257
lemma ksimplex_card:
hoelzl@56273
  2258
  assumes "ksimplex p n s" shows "card s = Suc n"
hoelzl@56273
  2259
using assms proof cases
hoelzl@56273
  2260
  case (ksimplex u b)
hoelzl@56273
  2261
  then interpret kuhn_simplex p n u b s .
hoelzl@56273
  2262
  show ?thesis
hoelzl@56273
  2263
    by (simp add: card_image s_eq inj_enum)
hoelzl@56273
  2264
qed
hoelzl@56273
  2265
hoelzl@56273
  2266
lemma simplex_top_face:
hoelzl@56273
  2267
  assumes "0 < p" "\<forall>x\<in>s'. x n = p"
hoelzl@56273
  2268
  shows "ksimplex p n s' \<longleftrightarrow> (\<exists>s a. ksimplex p (Suc n) s \<and> a \<in> s \<and> s' = s - {a})"
hoelzl@56273
  2269
  using assms
hoelzl@56273
  2270
proof safe
hoelzl@56273
  2271
  fix s a assume "ksimplex p (Suc n) s" and a: "a \<in> s" and na: "\<forall>x\<in>s - {a}. x n = p"
hoelzl@56273
  2272
  then show "ksimplex p n (s - {a})"
hoelzl@56273
  2273
  proof cases
hoelzl@56273
  2274
    case (ksimplex base upd)
hoelzl@56273
  2275
    then interpret kuhn_simplex p "Suc n" base upd "s" .
hoelzl@56273
  2276
hoelzl@56273
  2277
    have "a n < p"
wenzelm@60420
  2278
      using one_step[of a n p] na \<open>a\<in>s\<close> s_space by (auto simp: less_le)
hoelzl@56273
  2279
    then have "a = enum 0"
wenzelm@60420
  2280
      using \<open>a \<in> s\<close> na by (subst enum_0_bot) (auto simp: le_less intro!: less[of a _ n])
hoelzl@56273
  2281
    then have s_eq: "s - {a} = enum ` Suc ` {.. n}"
hoelzl@56273
  2282
      using s_eq by (simp add: atMost_Suc_eq_insert_0 insert_ident Zero_notin_Suc in_enum_image subset_eq)
hoelzl@56273
  2283
    then have "enum 1 \<in> s - {a}"
hoelzl@56273
  2284
      by auto
hoelzl@56273
  2285
    then have "upd 0 = n"
wenzelm@60420
  2286
      using \<open>a n < p\<close> \<open>a = enum 0\<close> na[rule_format, of "enum 1"]
nipkow@62390
  2287
      by (auto simp: fun_eq_iff enum_Suc split: if_split_asm)
hoelzl@56273
  2288
    then have "bij_betw upd (Suc ` {..< n}) {..< n}"
hoelzl@56273
  2289
      using upd
hoelzl@56273
  2290
      by (subst notIn_Un_bij_betw3[where b=0])
hoelzl@56273
  2291
         (auto simp: lessThan_Suc[symmetric] lessThan_Suc_eq_insert_0)
hoelzl@56273
  2292
    then have "bij_betw (upd\<circ>Suc) {..<n} {..<n}"
hoelzl@56273
  2293
      by (rule bij_betw_trans[rotated]) (auto simp: bij_betw_def)
hoelzl@56273
  2294
hoelzl@56273
  2295
    have "a n = p - 1"
wenzelm@60420
  2296
      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>)
hoelzl@56273
  2297
hoelzl@56273
  2298
    show ?thesis
wenzelm@61169
  2299
    proof (rule ksimplex.intros, standard)
hoelzl@56273
  2300
      show "bij_betw (upd\<circ>Suc) {..< n} {..< n}" by fact
hoelzl@56273
  2301
      show "base(n := p) \<in> {..<n} \<rightarrow> {..<p}" "\<And>i. n\<le>i \<Longrightarrow> (base(n := p)) i = p"
hoelzl@56273
  2302
        using base base_out by (auto simp: Pi_iff)
hoelzl@56273
  2303
hoelzl@56273
  2304
      have "\<And>i. Suc ` {..< i} = {..< Suc i} - {0}"
hoelzl@56273
  2305
        by (auto simp: image_iff Ball_def) arith
hoelzl@56273
  2306
      then have upd_Suc: "\<And>i. i \<le> n \<Longrightarrow> (upd\<circ>Suc) ` {..< i} = upd ` {..< Suc i} - {n}"
wenzelm@60420
  2307
        using \<open>upd 0 = n\<close> upd_inj
lp15@68022
  2308
        by (auto simp: image_comp[symmetric] inj_on_image_set_diff[OF inj_upd])
hoelzl@56273
  2309
      have n_in_upd: "\<And>i. n \<in> upd ` {..< Suc i}"
wenzelm@60420
  2310
        using \<open>upd 0 = n\<close> by auto
hoelzl@56273
  2311
wenzelm@63040
  2312
      define f' where "f' i j =
wenzelm@63040
  2313
        (if j \<in> (upd\<circ>Suc)`{..< i} then Suc ((base(n := p)) j) else (base(n := p)) j)" for i j
hoelzl@56273
  2314
      { fix x i assume i[arith]: "i \<le> n" then have "enum (Suc i) x = f' i x"
wenzelm@60420
  2315
          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>
hoelzl@56273
  2316
          by (simp add: upd_Suc enum_0 n_in_upd) }
hoelzl@56273
  2317
      then show "s - {a} = f' ` {.. n}"
hoelzl@56273
  2318
        unfolding s_eq image_comp by (intro image_cong) auto
hoelzl@56273
  2319
    qed
hoelzl@56273
  2320
  qed
hoelzl@56273
  2321
next
hoelzl@56273
  2322
  assume "ksimplex p n s'" and *: "\<forall>x\<in>s'. x n = p"
hoelzl@56273
  2323
  then show "\<exists>s a. ksimplex p (Suc n) s \<and> a \<in> s \<and> s' = s - {a}"
hoelzl@56273
  2324
  proof cases
hoelzl@56273
  2325
    case (ksimplex base upd)
hoelzl@56273
  2326
    then interpret kuhn_simplex p n base upd s' .
wenzelm@63040
  2327
    define b where "b = base (n := p - 1)"
wenzelm@63040
  2328
    define u where "u i = (case i of 0 \<Rightarrow> n | Suc i \<Rightarrow> upd i)" for i
hoelzl@56273
  2329
hoelzl@56273
  2330
    have "ksimplex p (Suc n) (s' \<union> {b})"
wenzelm@61169
  2331
    proof (rule ksimplex.intros, standard)
hoelzl@56273
  2332
      show "b \<in> {..<Suc n} \<rightarrow> {..<p}"
wenzelm@60420
  2333
        using base \<open>0 < p\<close> unfolding lessThan_Suc b_def by (auto simp: PiE_iff)
hoelzl@56273
  2334
      show "\<And>i. Suc n \<le> i \<Longrightarrow> b i = p"
hoelzl@56273
  2335
        using base_out by (auto simp: b_def)
hoelzl@56273
  2336
hoelzl@56273
  2337
      have "bij_betw u (Suc ` {..< n} \<union> {0}) ({..<n} \<union> {u 0})"
hoelzl@56273
  2338
        using upd
hoelzl@56273
  2339
        by (intro notIn_Un_bij_betw) (auto simp: u_def bij_betw_def image_comp comp_def inj_on_def)
hoelzl@56273
  2340
      then show "bij_betw u {..<Suc n} {..<Suc n}"
hoelzl@56273
  2341
        by (simp add: u_def lessThan_Suc[symmetric] lessThan_Suc_eq_insert_0)
hoelzl@56273
  2342
wenzelm@63040
  2343
      define f' where "f' i j = (if j \<in> u`{..< i} then Suc (b j) else b j)" for i j
hoelzl@56273
  2344
hoelzl@56273
  2345
      have u_eq: "\<And>i. i \<le> n \<Longrightarrow> u ` {..< Suc i} = upd ` {..< i} \<union> { n }"
hoelzl@56273
  2346
        by (auto simp: u_def image_iff upd_inj Ball_def split: nat.split) arith
hoelzl@56273
  2347
hoelzl@56273
  2348
      { fix x have "x \<le> n \<Longrightarrow> n \<notin> upd ` {..<x}"
hoelzl@56273
  2349
          using upd_space by (simp add: image_iff neq_iff) }
hoelzl@56273
  2350
      note n_not_upd = this
hoelzl@56273
  2351
hoelzl@56273
  2352
      have *: "f' ` {.. Suc n} = f' ` (Suc ` {.. n} \<union> {0})"
hoelzl@56273
  2353
        unfolding atMost_Suc_eq_insert_0 by simp
hoelzl@56273
  2354
      also have "\<dots> = (f' \<circ> Suc) ` {.. n} \<union> {b}"
hoelzl@56273
  2355
        by (auto simp: f'_def)
hoelzl@56273
  2356
      also have "(f' \<circ> Suc) ` {.. n} = s'"
wenzelm@60420
  2357
        using \<open>0 < p\<close> base_out[of n]
hoelzl@56273
  2358
        unfolding s_eq enum_def[abs_def] f'_def[abs_def] upd_space
hoelzl@56273
  2359
        by (intro image_cong) (simp_all add: u_eq b_def fun_eq_iff n_not_upd)
hoelzl@56273
  2360
      finally show "s' \<union> {b} = f' ` {.. Suc n}" ..
hoelzl@56273
  2361
    qed
hoelzl@56273
  2362
    moreover have "b \<notin> s'"
wenzelm@60420
  2363
      using * \<open>0 < p\<close> by (auto simp: b_def)
hoelzl@56273
  2364
    ultimately show ?thesis by auto
hoelzl@56273
  2365
  qed
hoelzl@56273
  2366
qed
hoelzl@56273
  2367
hoelzl@56273
  2368
lemma ksimplex_replace_0:
hoelzl@56273
  2369
  assumes s: "ksimplex p n s" and a: "a \<in> s"
hoelzl@56273
  2370
  assumes j: "j < n" and p: "\<forall>x\<in>s - {a}. x j = 0"
hoelzl@56273
  2371
  shows "card {s'. ksimplex p n s' \<and> (\<exists>b\<in>s'. s' - {b} = s - {a})} = 1"
hoelzl@56273
  2372
  using s
hoelzl@56273
  2373
proof cases
hoelzl@56273
  2374
  case (ksimplex b_s u_s)
hoelzl@56273
  2375
lp15@61609
  2376
  { fix t b assume "ksimplex p n t"
hoelzl@56273
  2377
    then obtain b_t u_t where "kuhn_simplex p n b_t u_t t"
hoelzl@56273
  2378
      by (auto elim: ksimplex.cases)
hoelzl@56273
  2379
    interpret kuhn_simplex_pair p n b_s u_s s b_t u_t t
hoelzl@56273
  2380
      by intro_locales fact+
hoelzl@56273
  2381
hoelzl@56273
  2382
    assume b: "b \<in> t" "t - {b} = s - {a}"
hoelzl@56273
  2383
    with a j p s.replace_0[of _ a] t.replace_0[of _ b] have "s = t"
hoelzl@56273
  2384
      by (intro ksimplex_eq_top[of a b]) auto }
hoelzl@56273
  2385
  then have "{s'. ksimplex p n s' \<and> (\<exists>b\<in>s'. s' - {b} = s - {a})} = {s}"
wenzelm@60420
  2386
    using s \<open>a \<in> s\<close> by auto
hoelzl@56273
  2387
  then show ?thesis
hoelzl@56273
  2388
    by simp
hoelzl@56273
  2389
qed
hoelzl@56273
  2390
hoelzl@56273
  2391
lemma ksimplex_replace_1:
hoelzl@56273
  2392
  assumes s: "ksimplex p n s" and a: "a \<in> s"
hoelzl@56273
  2393
  assumes j: "j < n" and p: "\<forall>x\<in>s - {a}. x j = p"
hoelzl@56273
  2394
  shows "card {s'. ksimplex p n s' \<and> (\<exists>b\<in>s'. s' - {b} = s - {a})} = 1"
hoelzl@56273
  2395
  using s
hoelzl@56273
  2396
proof cases
hoelzl@56273
  2397
  case (ksimplex b_s u_s)
hoelzl@56273
  2398
lp15@61609
  2399
  { fix t b assume "ksimplex p n t"
hoelzl@56273
  2400
    then obtain b_t u_t where "kuhn_simplex p n b_t u_t t"
hoelzl@56273
  2401
      by (auto elim: ksimplex.cases)
hoelzl@56273
  2402
    interpret kuhn_simplex_pair p n b_s u_s s b_t u_t t
hoelzl@56273
  2403
      by intro_locales fact+
hoelzl@56273
  2404
hoelzl@56273
  2405
    assume b: "b \<in> t" "t - {b} = s - {a}"
hoelzl@56273
  2406
    with a j p s.replace_1[of _ a] t.replace_1[of _ b] have "s = t"
hoelzl@56273
  2407
      by (intro ksimplex_eq_bot[of a b]) auto }
hoelzl@56273
  2408
  then have "{s'. ksimplex p n s' \<and> (\<exists>b\<in>s'. s' - {b} = s - {a})} = {s}"
wenzelm@60420
  2409
    using s \<open>a \<in> s\<close> by auto
hoelzl@56273
  2410
  then show ?thesis
hoelzl@56273
  2411
    by simp
hoelzl@56273
  2412
qed
hoelzl@56273
  2413
hoelzl@56273
  2414
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))"
lp15@68022
  2415
  by (auto simp: card_Suc_eq eval_nat_numeral)
hoelzl@56273
  2416
hoelzl@56273
  2417
lemma ksimplex_replace_2:
hoelzl@56273
  2418
  assumes s: "ksimplex p n s" and "a \<in> s" and "n \<noteq> 0"
hoelzl@56273
  2419
    and lb: "\<forall>j<n. \<exists>x\<in>s - {a}. x j \<noteq> 0"
hoelzl@56273
  2420
    and ub: "\<forall>j<n. \<exists>x\<in>s - {a}. x j \<noteq> p"
hoelzl@56273
  2421
  shows "card {s'. ksimplex p n s' \<and> (\<exists>b\<in>s'. s' - {b} = s - {a})} = 2"
hoelzl@56273
  2422
  using s
hoelzl@56273
  2423
proof cases
hoelzl@56273
  2424
  case (ksimplex base upd)
hoelzl@56273
  2425
  then interpret kuhn_simplex p n base upd s .
hoelzl@56273
  2426
wenzelm@60420
  2427
  from \<open>a \<in> s\<close> obtain i where "i \<le> n" "a = enum i"
hoelzl@56273
  2428
    unfolding s_eq by auto
hoelzl@56273
  2429
wenzelm@60420
  2430
  from \<open>i \<le> n\<close> have "i = 0 \<or> i = n \<or> (0 < i \<and> i < n)"
hoelzl@56273
  2431
    by linarith
hoelzl@56273