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