--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Admin/lib/Tools/regenerate_cooper Wed Apr 10 15:45:16 2019 +0200
@@ -0,0 +1,12 @@
+#!/usr/bin/env bash
+#
+# Author: Florian Haftmann, TU Muenchen
+#
+# DESCRIPTION: regenerate ~~/src/HOL/Tools/Qelim/cooper_procedure.ML from ~~/src/HOL/Decision_Proc/Cooper.thy
+
+session=HOL-Decision_Procs
+src='HOL-Decision_Procs.Cooper:code/cooper_procedure.ML'
+dst='~~/src/HOL/Tools/Qelim/'
+
+"${ISABELLE_TOOL}" build "${session}"
+"${ISABELLE_TOOL}" export -x "${src}" -p 2 -O "${dst}" "${session}"
--- a/NEWS Wed Apr 10 15:10:43 2019 +0200
+++ b/NEWS Wed Apr 10 15:45:16 2019 +0200
@@ -243,7 +243,10 @@
* Session HOL-Number_Theory: More material on residue rings in
Carmichael's function, primitive roots, more properties for "ord".
-* Session HOL-Analysis: More material and better organization.
+* Session HOL-Analysis: Better organization and much more material,
+including algebraic topology.
+
+* Session HOL-Algebra: Much more material on group theory.
* Session HOL-SPARK: .prv files are no longer written to the
file-system, but exported to the session database. Results may be
--- a/src/HOL/Algebra/Group.thy Wed Apr 10 15:10:43 2019 +0200
+++ b/src/HOL/Algebra/Group.thy Wed Apr 10 15:45:16 2019 +0200
@@ -913,6 +913,9 @@
"\<lbrakk>h \<in> hom G H; bij_betw h (carrier G) (carrier H)\<rbrakk> \<Longrightarrow> h \<in> iso G H"
by (auto simp: iso_def)
+lemma is_isoI: "h \<in> iso G H \<Longrightarrow> G \<cong> H"
+ using is_iso_def by auto
+
lemma epi_iff_subset:
"f \<in> epi G G' \<longleftrightarrow> f \<in> hom G G' \<and> carrier G' \<subseteq> f ` carrier G"
by (auto simp: epi_def hom_def)
--- a/src/HOL/Analysis/Abstract_Euclidean_Space.thy Wed Apr 10 15:10:43 2019 +0200
+++ b/src/HOL/Analysis/Abstract_Euclidean_Space.thy Wed Apr 10 15:45:16 2019 +0200
@@ -89,6 +89,51 @@
unfolding Euclidean_space_def continuous_map_in_subtopology
by (fastforce simp add: continuous_map_componentwise_UNIV continuous_map_diff)
+lemma continuous_map_Euclidean_space_iff:
+ "continuous_map (Euclidean_space m) euclideanreal g
+ = continuous_on (topspace (Euclidean_space m)) g"
+proof
+ assume "continuous_map (Euclidean_space m) euclideanreal g"
+ then have "continuous_map (top_of_set {f. \<forall>n\<ge>m. f n = 0}) euclideanreal g"
+ by (simp add: Euclidean_space_def euclidean_product_topology)
+ then show "continuous_on (topspace (Euclidean_space m)) g"
+ by (metis continuous_map_subtopology_eu subtopology_topspace topspace_Euclidean_space)
+next
+ assume "continuous_on (topspace (Euclidean_space m)) g"
+ then have "continuous_map (top_of_set {f. \<forall>n\<ge>m. f n = 0}) euclideanreal g"
+ by (metis (lifting) continuous_map_into_fulltopology continuous_map_subtopology_eu order_refl topspace_Euclidean_space)
+ then show "continuous_map (Euclidean_space m) euclideanreal g"
+ by (simp add: Euclidean_space_def euclidean_product_topology)
+qed
+
+lemma cm_Euclidean_space_iff_continuous_on:
+ "continuous_map (subtopology (Euclidean_space m) S) (Euclidean_space n) f
+ \<longleftrightarrow> continuous_on (topspace (subtopology (Euclidean_space m) S)) f \<and>
+ f ` (topspace (subtopology (Euclidean_space m) S)) \<subseteq> topspace (Euclidean_space n)"
+ (is "?P \<longleftrightarrow> ?Q \<and> ?R")
+proof -
+ have ?Q if ?P
+ proof -
+ have "\<And>n. Euclidean_space n = top_of_set {f. \<forall>m\<ge>n. f m = 0}"
+ by (simp add: Euclidean_space_def euclidean_product_topology)
+ with that show ?thesis
+ by (simp add: subtopology_subtopology)
+ qed
+ moreover
+ have ?R if ?P
+ using that by (simp add: image_subset_iff continuous_map_def)
+ moreover
+ have ?P if ?Q ?R
+ proof -
+ have "continuous_map (top_of_set (topspace (subtopology (subtopology (powertop_real UNIV) {f. \<forall>n\<ge>m. f n = 0}) S))) (top_of_set (topspace (subtopology (powertop_real UNIV) {f. \<forall>na\<ge>n. f na = 0}))) f"
+ using Euclidean_space_def that by auto
+ then show ?thesis
+ by (simp add: Euclidean_space_def euclidean_product_topology subtopology_subtopology)
+ qed
+ ultimately show ?thesis
+ by auto
+qed
+
lemma homeomorphic_Euclidean_space_product_topology:
"Euclidean_space n homeomorphic_space product_topology (\<lambda>i. euclideanreal) {..<n}"
proof -
@@ -125,6 +170,7 @@
"compact_space (Euclidean_space n) \<longleftrightarrow> n = 0"
by (auto simp: homeomorphic_compact_space [OF homeomorphic_Euclidean_space_product_topology] compact_space_product_topology)
+
subsection\<open>n-dimensional spheres\<close>
definition nsphere where
--- a/src/HOL/Analysis/Abstract_Topology.thy Wed Apr 10 15:10:43 2019 +0200
+++ b/src/HOL/Analysis/Abstract_Topology.thy Wed Apr 10 15:45:16 2019 +0200
@@ -2728,7 +2728,7 @@
"X homeomorphic_space Y \<longleftrightarrow> Y homeomorphic_space X"
unfolding homeomorphic_space_def by (metis homeomorphic_maps_sym)
-lemma homeomorphic_space_trans:
+lemma homeomorphic_space_trans [trans]:
"\<lbrakk>X1 homeomorphic_space X2; X2 homeomorphic_space X3\<rbrakk> \<Longrightarrow> X1 homeomorphic_space X3"
unfolding homeomorphic_space_def by (metis homeomorphic_maps_compose)
--- a/src/HOL/Analysis/Convex.thy Wed Apr 10 15:10:43 2019 +0200
+++ b/src/HOL/Analysis/Convex.thy Wed Apr 10 15:45:16 2019 +0200
@@ -1,4 +1,4 @@
-(* Title: HOL/Analysis/Convex_Euclidean_Space.thy
+(* Title: HOL/Analysis/Convex.thy
Author: L C Paulson, University of Cambridge
Author: Robert Himmelmann, TU Muenchen
Author: Bogdan Grechuk, University of Edinburgh
--- a/src/HOL/Analysis/Function_Topology.thy Wed Apr 10 15:10:43 2019 +0200
+++ b/src/HOL/Analysis/Function_Topology.thy Wed Apr 10 15:45:16 2019 +0200
@@ -642,6 +642,17 @@
shows "continuous_on (A \<inter> S) f \<longleftrightarrow> (\<forall>i. continuous_on (A \<inter> S) (\<lambda>x. f x i))"
by (auto simp: continuous_on_product_then_coordinatewise continuous_on_coordinatewise_then_product)
+lemma continuous_map_span_sum:
+ fixes B :: "'a::real_inner set"
+ assumes biB: "\<And>i. i \<in> I \<Longrightarrow> b i \<in> B"
+ shows "continuous_map euclidean (top_of_set (span B)) (\<lambda>x. \<Sum>i\<in>I. x i *\<^sub>R b i)"
+proof (rule continuous_map_euclidean_top_of_set)
+ show "(\<lambda>x. \<Sum>i\<in>I. x i *\<^sub>R b i) -` span B = UNIV"
+ by auto (meson biB lessThan_iff span_base span_scale span_sum)
+ show "continuous_on UNIV (\<lambda>x. \<Sum>i\<in> I. x i *\<^sub>R b i)"
+ by (intro continuous_intros) auto
+qed
+
subsubsection%important \<open>Topological countability for product spaces\<close>
text \<open>The next two lemmas are useful to prove first or second countability
@@ -867,7 +878,6 @@
apply standard
using product_topology_countable_basis topological_basis_imp_subbasis by auto
-
subsection \<open>Metrics on product spaces\<close>
@@ -1242,7 +1252,7 @@
qed
instance "fun" :: (countable, polish_space) polish_space
-by standard
+ by standard
subsection\<open>The Alexander subbase theorem\<close>
--- a/src/HOL/Analysis/Topology_Euclidean_Space.thy Wed Apr 10 15:10:43 2019 +0200
+++ b/src/HOL/Analysis/Topology_Euclidean_Space.thy Wed Apr 10 15:45:16 2019 +0200
@@ -34,6 +34,9 @@
subsection \<open>Continuity of the representation WRT an orthogonal basis\<close>
+lemma orthogonal_Basis: "pairwise orthogonal Basis"
+ by (simp add: inner_not_same_Basis orthogonal_def pairwise_def)
+
lemma representation_bound:
fixes B :: "'N::real_inner set"
assumes "finite B" "independent B" "b \<in> B" and orth: "pairwise orthogonal B"
--- a/src/HOL/Decision_Procs/Cooper.thy Wed Apr 10 15:10:43 2019 +0200
+++ b/src/HOL/Decision_Procs/Cooper.thy Wed Apr 10 15:45:16 2019 +0200
@@ -2,15 +2,15 @@
Author: Amine Chaieb
*)
+section \<open>Presburger arithmetic based on Cooper's algorithm\<close>
+
theory Cooper
imports
Complex_Main
"HOL-Library.Code_Target_Numeral"
begin
-section \<open>Periodicity of \<open>dvd\<close>\<close>
-
-subsection \<open>Shadow syntax and semantics\<close>
+subsection \<open>Basic formulae\<close>
datatype (plugins del: size) num = C int | Bound nat | CN nat int num
| Neg num | Add num num | Sub num num
@@ -146,7 +146,7 @@
| "qfree p \<longleftrightarrow> True"
-text \<open>Boundedness and substitution\<close>
+subsection \<open>Boundedness and substitution\<close>
primrec numbound0 :: "num \<Rightarrow> bool" \<comment> \<open>a \<open>num\<close> is \<^emph>\<open>independent\<close> of Bound 0\<close>
where
@@ -418,7 +418,7 @@
qed
-text \<open>Simplification\<close>
+subsection \<open>Simplification\<close>
text \<open>Algebraic simplifications for nums\<close>
@@ -819,7 +819,9 @@
apply (case_tac "simpnum a", auto)+
done
-text \<open>Generic quantifier elimination\<close>
+
+subsection \<open>Generic quantifier elimination\<close>
+
fun qelim :: "fm \<Rightarrow> (fm \<Rightarrow> fm) \<Rightarrow> fm"
where
"qelim (E p) = (\<lambda>qe. DJ qe (qelim p qe))"
@@ -2249,7 +2251,7 @@
qed
-text \<open>Cooper's Algorithm\<close>
+subsection \<open>Cooper's Algorithm\<close>
definition cooper :: "fm \<Rightarrow> fm"
where
@@ -2371,16 +2373,8 @@
theorem mirqe: "Ifm bbs bs (pa p) = Ifm bbs bs p \<and> qfree (pa p)"
using qelim_ci cooper prep by (auto simp add: pa_def)
-definition cooper_test :: "unit \<Rightarrow> fm"
- where "cooper_test u =
- pa (E (A (Imp (Ge (Sub (Bound 0) (Bound 1)))
- (E (E (Eq (Sub (Add (Mul 3 (Bound 1)) (Mul 5 (Bound 0))) (Bound 2))))))))"
-ML_val \<open>@{code cooper_test} ()\<close>
-
-(*code_reflect Cooper_Procedure
- functions pa T Bound nat_of_integer integer_of_nat int_of_integer integer_of_int
- file "~~/src/HOL/Tools/Qelim/cooper_procedure.ML"*)
+subsection \<open>Setup\<close>
oracle linzqe_oracle = \<open>
let
@@ -2535,7 +2529,7 @@
\<close> "decision procedure for linear integer arithmetic"
-text \<open>Tests\<close>
+subsection \<open>Tests\<close>
lemma "\<exists>(j::int). \<forall>x\<ge>j. \<exists>a b. x = 3*a+5*b"
by cooper
@@ -2666,4 +2660,10 @@
theorem "(\<exists>m::nat. n = 2 * m) \<longrightarrow> (n + 1) div 2 = n div 2"
by cooper
+
+subsection \<open>Variant for HOL-Main\<close>
+
+export_code pa T Bound nat_of_integer integer_of_nat int_of_integer integer_of_int
+ in Eval module_name Cooper_Procedure file_prefix cooper_procedure
+
end
--- a/src/HOL/Euclidean_Division.thy Wed Apr 10 15:10:43 2019 +0200
+++ b/src/HOL/Euclidean_Division.thy Wed Apr 10 15:45:16 2019 +0200
@@ -165,25 +165,31 @@
subsection \<open>Euclidean (semi)rings with cancel rules\<close>
-class euclidean_semiring_cancel = euclidean_semiring +
- assumes div_mult_self1 [simp]: "b \<noteq> 0 \<Longrightarrow> (a + c * b) div b = c + a div b"
- and div_mult_mult1 [simp]: "c \<noteq> 0 \<Longrightarrow> (c * a) div (c * b) = a div b"
+class euclidean_semiring_cancel = euclidean_semiring + semidom_divide_cancel
begin
+context
+ fixes b
+ assumes "b \<noteq> 0"
+begin
+
+lemma div_mult_self1 [simp]:
+ "(a + c * b) div b = c + a div b"
+ using \<open>b \<noteq> 0\<close> by (rule div_mult_self1)
+
lemma div_mult_self2 [simp]:
- assumes "b \<noteq> 0"
- shows "(a + b * c) div b = c + a div b"
- using assms div_mult_self1 [of b a c] by (simp add: mult.commute)
+ "(a + b * c) div b = c + a div b"
+ using \<open>b \<noteq> 0\<close> by (rule div_mult_self2)
lemma div_mult_self3 [simp]:
- assumes "b \<noteq> 0"
- shows "(c * b + a) div b = c + a div b"
- using assms by (simp add: add.commute)
+ "(c * b + a) div b = c + a div b"
+ using \<open>b \<noteq> 0\<close> by (rule div_mult_self3)
lemma div_mult_self4 [simp]:
- assumes "b \<noteq> 0"
- shows "(b * c + a) div b = c + a div b"
- using assms by (simp add: add.commute)
+ "(b * c + a) div b = c + a div b"
+ using \<open>b \<noteq> 0\<close> by (rule div_mult_self4)
+
+end
lemma mod_mult_self1 [simp]: "(a + c * b) mod b = a mod b"
proof (cases "b = 0")
@@ -194,7 +200,7 @@
by (simp add: div_mult_mod_eq)
also from False div_mult_self1 [of b a c] have
"\<dots> = (c + a div b) * b + (a + c * b) mod b"
- by (simp add: algebra_simps)
+ by (simp add: algebra_simps)
finally have "a = a div b * b + (a + c * b) mod b"
by (simp add: add.commute [of a] add.assoc distrib_right)
then have "a div b * b + (a + c * b) mod b = a div b * b + a mod b"
@@ -222,16 +228,6 @@
"a * b mod b = 0"
using mod_mult_self1 [of 0 a b] by simp
-lemma div_add_self1:
- assumes "b \<noteq> 0"
- shows "(b + a) div b = a div b + 1"
- using assms div_mult_self1 [of b a 1] by (simp add: add.commute)
-
-lemma div_add_self2:
- assumes "b \<noteq> 0"
- shows "(a + b) div b = a div b + 1"
- using assms div_add_self1 [of b a] by (simp add: add.commute)
-
lemma mod_add_self1 [simp]:
"(b + a) mod b = a mod b"
using mod_mult_self1 [of a 1 b] by (simp add: add.commute)
@@ -284,14 +280,6 @@
finally show ?thesis .
qed
-lemma div_mult_mult2 [simp]:
- "c \<noteq> 0 \<Longrightarrow> (a * c) div (b * c) = a div b"
- by (drule div_mult_mult1) (simp add: mult.commute)
-
-lemma div_mult_mult1_if [simp]:
- "(c * a) div (c * b) = (if c = 0 then 0 else a div b)"
- by simp_all
-
lemma mod_mult_mult1:
"(c * a) mod (c * b) = c * (a mod b)"
proof (cases "c = 0")
@@ -448,23 +436,14 @@
class euclidean_ring_cancel = euclidean_ring + euclidean_semiring_cancel
begin
-subclass idom_divide ..
-
-lemma div_minus_minus [simp]: "(- a) div (- b) = a div b"
- using div_mult_mult1 [of "- 1" a b] by simp
+subclass idom_divide_cancel ..
lemma mod_minus_minus [simp]: "(- a) mod (- b) = - (a mod b)"
using mod_mult_mult1 [of "- 1" a b] by simp
-lemma div_minus_right: "a div (- b) = (- a) div b"
- using div_minus_minus [of "- a" b] by simp
-
lemma mod_minus_right: "a mod (- b) = - ((- a) mod b)"
using mod_minus_minus [of "- a" b] by simp
-lemma div_minus1_right [simp]: "a div (- 1) = - a"
- using div_minus_right [of a 1] by simp
-
lemma mod_minus1_right [simp]: "a mod (- 1) = 0"
using mod_minus_right [of a 1] by simp
--- a/src/HOL/Fields.thy Wed Apr 10 15:10:43 2019 +0200
+++ b/src/HOL/Fields.thy Wed Apr 10 15:45:16 2019 +0200
@@ -378,30 +378,42 @@
by (simp add: divide_inverse)
qed
+subclass idom_divide_cancel
+proof
+ fix a b c
+ assume [simp]: "c \<noteq> 0"
+ show "(c * a) / (c * b) = a / b"
+ proof (cases "b = 0")
+ case True then show ?thesis
+ by simp
+ next
+ case False
+ then have "(c * a) / (c * b) = c * a * (inverse b * inverse c)"
+ by (simp add: divide_inverse nonzero_inverse_mult_distrib)
+ also have "... = a * inverse b * (inverse c * c)"
+ by (simp only: ac_simps)
+ also have "... = a * inverse b" by simp
+ finally show ?thesis by (simp add: divide_inverse)
+ qed
+next
+ fix a b c
+ assume "b \<noteq> 0"
+ have "((a * inverse b) * b + c * b) = (c + a * inverse b) * b"
+ using distrib [of c "a * inverse b" b] by (simp add: ac_simps)
+ also have "(a * inverse b) * b = a"
+ using \<open>b \<noteq> 0\<close> by (simp add: ac_simps)
+ finally show "(a + c * b) / b = c + a / b"
+ using \<open>b \<noteq> 0\<close> by (simp add: ac_simps divide_inverse [symmetric])
+qed
+
+lemmas nonzero_mult_divide_mult_cancel_left = div_mult_mult1 \<comment> \<open>duplicate\<close>
+lemmas nonzero_mult_divide_mult_cancel_right = div_mult_mult2 \<comment> \<open>duplicate\<close>
+
text\<open>There is no slick version using division by zero.\<close>
lemma inverse_add:
"a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> inverse a + inverse b = (a + b) * inverse a * inverse b"
by (simp add: division_ring_inverse_add ac_simps)
-lemma nonzero_mult_divide_mult_cancel_left [simp]:
- assumes [simp]: "c \<noteq> 0"
- shows "(c * a) / (c * b) = a / b"
-proof (cases "b = 0")
- case True then show ?thesis by simp
-next
- case False
- then have "(c*a)/(c*b) = c * a * (inverse b * inverse c)"
- by (simp add: divide_inverse nonzero_inverse_mult_distrib)
- also have "... = a * inverse b * (inverse c * c)"
- by (simp only: ac_simps)
- also have "... = a * inverse b" by simp
- finally show ?thesis by (simp add: divide_inverse)
-qed
-
-lemma nonzero_mult_divide_mult_cancel_right [simp]:
- "c \<noteq> 0 \<Longrightarrow> (a * c) / (b * c) = a / b"
- using nonzero_mult_divide_mult_cancel_left [of c a b] by (simp add: ac_simps)
-
lemma times_divide_eq_left [simp]: "(b / c) * a = (b * a) / c"
by (simp add: divide_inverse ac_simps)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Homology/Brouwer_Degree.thy Wed Apr 10 15:45:16 2019 +0200
@@ -0,0 +1,1687 @@
+section\<open>Homology, III: Brouwer Degree\<close>
+
+theory Brouwer_Degree
+ imports Homology_Groups
+
+begin
+
+lemma Eps_cong:
+ assumes "\<And>x. P x = Q x"
+ shows "Eps P = Eps Q"
+ using ext[of P Q, OF assms] by simp
+
+subsection\<open>Reduced Homology\<close>
+
+definition reduced_homology_group :: "int \<Rightarrow> 'a topology \<Rightarrow> 'a chain set monoid"
+ where "reduced_homology_group p X \<equiv>
+ subgroup_generated (homology_group p X)
+ (kernel (homology_group p X) (homology_group p (discrete_topology {()}))
+ (hom_induced p X {} (discrete_topology {()}) {} (\<lambda>x. ())))"
+
+lemma one_reduced_homology_group: "\<one>\<^bsub>reduced_homology_group p X\<^esub> = \<one>\<^bsub>homology_group p X\<^esub>"
+ by (simp add: reduced_homology_group_def)
+
+lemma group_reduced_homology_group [simp]: "group (reduced_homology_group p X)"
+ by (simp add: reduced_homology_group_def group.group_subgroup_generated)
+
+lemma carrier_reduced_homology_group:
+ "carrier (reduced_homology_group p X) =
+ kernel (homology_group p X) (homology_group p (discrete_topology {()}))
+ (hom_induced p X {} (discrete_topology {()}) {} (\<lambda>x. ()))"
+ (is "_ = kernel ?G ?H ?h")
+proof -
+ interpret subgroup "kernel ?G ?H ?h" ?G
+ by (simp add: hom_induced_empty_hom group_hom_axioms_def group_hom_def group_hom.subgroup_kernel)
+ show ?thesis
+ unfolding reduced_homology_group_def
+ using carrier_subgroup_generated_subgroup by blast
+qed
+
+lemma carrier_reduced_homology_group_subset:
+ "carrier (reduced_homology_group p X) \<subseteq> carrier (homology_group p X)"
+ by (simp add: group.carrier_subgroup_generated_subset reduced_homology_group_def)
+
+lemma un_reduced_homology_group:
+ assumes "p \<noteq> 0"
+ shows "reduced_homology_group p X = homology_group p X"
+proof -
+ have "(kernel (homology_group p X) (homology_group p (discrete_topology {()}))
+ (hom_induced p X {} (discrete_topology {()}) {} (\<lambda>x. ())))
+ = carrier (homology_group p X)"
+ proof (rule group_hom.kernel_to_trivial_group)
+ show "group_hom (homology_group p X) (homology_group p (discrete_topology {()}))
+ (hom_induced p X {} (discrete_topology {()}) {} (\<lambda>x. ()))"
+ by (auto simp: hom_induced_empty_hom group_hom_def group_hom_axioms_def)
+ show "trivial_group (homology_group p (discrete_topology {()}))"
+ by (simp add: homology_dimension_axiom [OF _ assms])
+ qed
+ then show ?thesis
+ by (simp add: reduced_homology_group_def group.subgroup_generated_group_carrier)
+qed
+
+lemma trivial_reduced_homology_group:
+ "p < 0 \<Longrightarrow> trivial_group(reduced_homology_group p X)"
+ by (simp add: trivial_homology_group un_reduced_homology_group)
+
+lemma hom_induced_reduced_hom:
+ "(hom_induced p X {} Y {} f) \<in> hom (reduced_homology_group p X) (reduced_homology_group p Y)"
+proof (cases "continuous_map X Y f")
+ case True
+ have eq: "continuous_map X Y f
+ \<Longrightarrow> hom_induced p X {} (discrete_topology {()}) {} (\<lambda>x. ())
+ = (hom_induced p Y {} (discrete_topology {()}) {} (\<lambda>x. ()) \<circ> hom_induced p X {} Y {} f)"
+ by (simp flip: hom_induced_compose_empty)
+ interpret subgroup "kernel (homology_group p X)
+ (homology_group p (discrete_topology {()}))
+ (hom_induced p X {} (discrete_topology {()}) {} (\<lambda>x. ()))"
+ "homology_group p X"
+ by (meson group_hom.subgroup_kernel group_hom_axioms_def group_hom_def group_relative_homology_group hom_induced)
+ have sb: "hom_induced p X {} Y {} f ` carrier (homology_group p X) \<subseteq> carrier (homology_group p Y)"
+ using hom_induced_carrier by blast
+ show ?thesis
+ using True
+ unfolding reduced_homology_group_def
+ apply (simp add: hom_into_subgroup_eq group_hom.subgroup_kernel hom_induced_empty_hom group.hom_from_subgroup_generated group_hom_def group_hom_axioms_def)
+ unfolding kernel_def using eq sb by auto
+next
+ case False
+ then have "hom_induced p X {} Y {} f = (\<lambda>c. one(reduced_homology_group p Y))"
+ by (force simp: hom_induced_default reduced_homology_group_def)
+ then show ?thesis
+ by (simp add: trivial_hom)
+qed
+
+
+lemma hom_induced_reduced:
+ "c \<in> carrier(reduced_homology_group p X)
+ \<Longrightarrow> hom_induced p X {} Y {} f c \<in> carrier(reduced_homology_group p Y)"
+ by (meson hom_in_carrier hom_induced_reduced_hom)
+
+lemma hom_boundary_reduced_hom:
+ "hom_boundary p X S
+ \<in> hom (relative_homology_group p X S) (reduced_homology_group (p-1) (subtopology X S))"
+proof -
+ have *: "continuous_map X (discrete_topology {()}) (\<lambda>x. ())" "(\<lambda>x. ()) ` S \<subseteq> {()}"
+ by auto
+ interpret group_hom "relative_homology_group p (discrete_topology {()}) {()}"
+ "homology_group (p-1) (discrete_topology {()})"
+ "hom_boundary p (discrete_topology {()}) {()}"
+ apply (clarsimp simp: group_hom_def group_hom_axioms_def)
+ by (metis UNIV_unit hom_boundary_hom subtopology_UNIV)
+ have "hom_boundary p X S `
+ carrier (relative_homology_group p X S)
+ \<subseteq> kernel (homology_group (p - 1) (subtopology X S))
+ (homology_group (p - 1) (discrete_topology {()}))
+ (hom_induced (p - 1) (subtopology X S) {}
+ (discrete_topology {()}) {} (\<lambda>x. ()))"
+ proof (clarsimp simp add: kernel_def hom_boundary_carrier)
+ fix c
+ assume c: "c \<in> carrier (relative_homology_group p X S)"
+ have triv: "trivial_group (relative_homology_group p (discrete_topology {()}) {()})"
+ by (metis topspace_discrete_topology trivial_relative_homology_group_topspace)
+ have "hom_boundary p (discrete_topology {()}) {()}
+ (hom_induced p X S (discrete_topology {()}) {()} (\<lambda>x. ()) c)
+ = \<one>\<^bsub>homology_group (p - 1) (discrete_topology {()})\<^esub>"
+ by (metis hom_induced_carrier local.hom_one singletonD triv trivial_group_def)
+ then show "hom_induced (p - 1) (subtopology X S) {} (discrete_topology {()}) {} (\<lambda>x. ()) (hom_boundary p X S c) =
+ \<one>\<^bsub>homology_group (p - 1) (discrete_topology {()})\<^esub>"
+ using naturality_hom_induced [OF *, of p, symmetric] by (simp add: o_def fun_eq_iff)
+ qed
+ then show ?thesis
+ by (simp add: reduced_homology_group_def hom_boundary_hom hom_into_subgroup)
+qed
+
+
+lemma homotopy_equivalence_reduced_homology_group_isomorphisms:
+ assumes contf: "continuous_map X Y f" and contg: "continuous_map Y X g"
+ and gf: "homotopic_with (\<lambda>h. True) X X (g \<circ> f) id"
+ and fg: "homotopic_with (\<lambda>k. True) Y Y (f \<circ> g) id"
+ shows "group_isomorphisms (reduced_homology_group p X) (reduced_homology_group p Y)
+ (hom_induced p X {} Y {} f) (hom_induced p Y {} X {} g)"
+proof (simp add: hom_induced_reduced_hom group_isomorphisms_def, intro conjI ballI)
+ fix a
+ assume "a \<in> carrier (reduced_homology_group p X)"
+ then have "(hom_induced p Y {} X {} g \<circ> hom_induced p X {} Y {} f) a = a"
+ apply (simp add: contf contg flip: hom_induced_compose)
+ using carrier_reduced_homology_group_subset gf hom_induced_id homology_homotopy_empty by fastforce
+ then show "hom_induced p Y {} X {} g (hom_induced p X {} Y {} f a) = a"
+ by simp
+next
+ fix b
+ assume "b \<in> carrier (reduced_homology_group p Y)"
+ then have "(hom_induced p X {} Y {} f \<circ> hom_induced p Y {} X {} g) b = b"
+ apply (simp add: contf contg flip: hom_induced_compose)
+ using carrier_reduced_homology_group_subset fg hom_induced_id homology_homotopy_empty by fastforce
+ then show "hom_induced p X {} Y {} f (hom_induced p Y {} X {} g b) = b"
+ by (simp add: carrier_reduced_homology_group)
+qed
+
+lemma homotopy_equivalence_reduced_homology_group_isomorphism:
+ assumes "continuous_map X Y f" "continuous_map Y X g"
+ and "homotopic_with (\<lambda>h. True) X X (g \<circ> f) id" "homotopic_with (\<lambda>k. True) Y Y (f \<circ> g) id"
+ shows "(hom_induced p X {} Y {} f)
+ \<in> iso (reduced_homology_group p X) (reduced_homology_group p Y)"
+proof (rule group_isomorphisms_imp_iso)
+ show "group_isomorphisms (reduced_homology_group p X) (reduced_homology_group p Y)
+ (hom_induced p X {} Y {} f) (hom_induced p Y {} X {} g)"
+ by (simp add: assms homotopy_equivalence_reduced_homology_group_isomorphisms)
+qed
+
+lemma homotopy_equivalent_space_imp_isomorphic_reduced_homology_groups:
+ "X homotopy_equivalent_space Y
+ \<Longrightarrow> reduced_homology_group p X \<cong> reduced_homology_group p Y"
+ unfolding homotopy_equivalent_space_def
+ using homotopy_equivalence_reduced_homology_group_isomorphism is_isoI by blast
+
+lemma homeomorphic_space_imp_isomorphic_reduced_homology_groups:
+ "X homeomorphic_space Y \<Longrightarrow> reduced_homology_group p X \<cong> reduced_homology_group p Y"
+ by (simp add: homeomorphic_imp_homotopy_equivalent_space homotopy_equivalent_space_imp_isomorphic_reduced_homology_groups)
+
+lemma trivial_reduced_homology_group_empty:
+ "topspace X = {} \<Longrightarrow> trivial_group(reduced_homology_group p X)"
+ by (metis carrier_reduced_homology_group_subset group.trivial_group_alt group_reduced_homology_group trivial_group_def trivial_homology_group_empty)
+
+lemma homology_dimension_reduced:
+ assumes "topspace X = {a}"
+ shows "trivial_group (reduced_homology_group p X)"
+proof -
+ have iso: "(hom_induced p X {} (discrete_topology {()}) {} (\<lambda>x. ()))
+ \<in> iso (homology_group p X) (homology_group p (discrete_topology {()}))"
+ apply (rule homeomorphic_map_homology_iso)
+ apply (force simp: homeomorphic_map_maps homeomorphic_maps_def assms)
+ done
+ show ?thesis
+ unfolding reduced_homology_group_def
+ by (rule group.trivial_group_subgroup_generated) (use iso in \<open>auto simp: iso_kernel_image\<close>)
+qed
+
+
+lemma trivial_reduced_homology_group_contractible_space:
+ "contractible_space X \<Longrightarrow> trivial_group (reduced_homology_group p X)"
+ apply (simp add: contractible_eq_homotopy_equivalent_singleton_subtopology)
+ apply (auto simp: trivial_reduced_homology_group_empty)
+ using isomorphic_group_triviality
+ by (metis (full_types) group_reduced_homology_group homology_dimension_reduced homotopy_equivalent_space_imp_isomorphic_reduced_homology_groups path_connectedin_def path_connectedin_singleton topspace_subtopology_subset)
+
+
+lemma image_reduced_homology_group:
+ assumes "topspace X \<inter> S \<noteq> {}"
+ shows "hom_induced p X {} X S id ` carrier (reduced_homology_group p X)
+ = hom_induced p X {} X S id ` carrier (homology_group p X)"
+ (is "?h ` carrier ?G = ?h ` carrier ?H")
+proof -
+ obtain a where a: "a \<in> topspace X" and "a \<in> S"
+ using assms by blast
+ have [simp]: "A \<inter> {x \<in> A. P x} = {x \<in> A. P x}" for A P
+ by blast
+ interpret comm_group "homology_group p X"
+ by (rule abelian_relative_homology_group)
+ have *: "\<exists>x'. ?h y = ?h x' \<and>
+ x' \<in> carrier ?H \<and>
+ hom_induced p X {} (discrete_topology {()}) {} (\<lambda>x. ()) x'
+ = \<one>\<^bsub>homology_group p (discrete_topology {()})\<^esub>"
+ if "y \<in> carrier ?H" for y
+ proof -
+ let ?f = "hom_induced p (discrete_topology {()}) {} X {} (\<lambda>x. a)"
+ let ?g = "hom_induced p X {} (discrete_topology {()}) {} (\<lambda>x. ())"
+ have bcarr: "?f (?g y) \<in> carrier ?H"
+ by (simp add: hom_induced_carrier)
+ interpret gh1:
+ group_hom "relative_homology_group p X S" "relative_homology_group p (discrete_topology {()}) {()}"
+ "hom_induced p X S (discrete_topology {()}) {()} (\<lambda>x. ())"
+ by (meson group_hom_axioms_def group_hom_def hom_induced_hom group_relative_homology_group)
+ interpret gh2:
+ group_hom "relative_homology_group p (discrete_topology {()}) {()}" "relative_homology_group p X S"
+ "hom_induced p (discrete_topology {()}) {()} X S (\<lambda>x. a)"
+ by (meson group_hom_axioms_def group_hom_def hom_induced_hom group_relative_homology_group)
+ interpret gh3:
+ group_hom "homology_group p X" "relative_homology_group p X S" "?h"
+ by (meson group_hom_axioms_def group_hom_def hom_induced_hom group_relative_homology_group)
+ interpret gh4:
+ group_hom "homology_group p X" "homology_group p (discrete_topology {()})"
+ "?g"
+ by (meson group_hom_axioms_def group_hom_def hom_induced_hom group_relative_homology_group)
+ interpret gh5:
+ group_hom "homology_group p (discrete_topology {()})" "homology_group p X"
+ "?f"
+ by (meson group_hom_axioms_def group_hom_def hom_induced_hom group_relative_homology_group)
+ interpret gh6:
+ group_hom "homology_group p (discrete_topology {()})" "relative_homology_group p (discrete_topology {()}) {()}"
+ "hom_induced p (discrete_topology {()}) {} (discrete_topology {()}) {()} id"
+ by (meson group_hom_axioms_def group_hom_def hom_induced_hom group_relative_homology_group)
+ show ?thesis
+ proof (intro exI conjI)
+ have "(?h \<circ> ?f \<circ> ?g) y
+ = (hom_induced p (discrete_topology {()}) {()} X S (\<lambda>x. a) \<circ>
+ hom_induced p (discrete_topology {()}) {} (discrete_topology {()}) {()} id \<circ> ?g) y"
+ by (simp add: a \<open>a \<in> S\<close> flip: hom_induced_compose)
+ also have "\<dots> = \<one>\<^bsub>relative_homology_group p X S\<^esub>"
+ using trivial_relative_homology_group_topspace [of p "discrete_topology {()}"]
+ apply simp
+ by (metis (full_types) empty_iff gh1.H.one_closed gh1.H.trivial_group gh2.hom_one hom_induced_carrier insert_iff)
+ finally have "?h (?f (?g y)) = \<one>\<^bsub>relative_homology_group p X S\<^esub>"
+ by simp
+ then show "?h y = ?h (y \<otimes>\<^bsub>?H\<^esub> inv\<^bsub>?H\<^esub> ?f (?g y))"
+ by (simp add: that hom_induced_carrier)
+ show "(y \<otimes>\<^bsub>?H\<^esub> inv\<^bsub>?H\<^esub> ?f (?g y)) \<in> carrier (homology_group p X)"
+ by (simp add: hom_induced_carrier that)
+ have *: "(?g \<circ> hom_induced p X {} X {} (\<lambda>x. a)) y = hom_induced p X {} (discrete_topology {()}) {} (\<lambda>a. ()) y"
+ by (simp add: a \<open>a \<in> S\<close> flip: hom_induced_compose)
+ have "?g (y \<otimes>\<^bsub>?H\<^esub> inv\<^bsub>?H\<^esub> (?f \<circ> ?g) y)
+ = \<one>\<^bsub>homology_group p (discrete_topology {()})\<^esub>"
+ by (simp add: a \<open>a \<in> S\<close> that hom_induced_carrier flip: hom_induced_compose * [unfolded o_def])
+ then show "?g (y \<otimes>\<^bsub>?H\<^esub> inv\<^bsub>?H\<^esub> ?f (?g y))
+ = \<one>\<^bsub>homology_group p (discrete_topology {()})\<^esub>"
+ by simp
+ qed
+ qed
+ show ?thesis
+ apply (auto simp: reduced_homology_group_def carrier_subgroup_generated kernel_def image_iff)
+ apply (metis (no_types, lifting) generate_in_carrier mem_Collect_eq subsetI)
+ apply (force simp: dest: * intro: generate.incl)
+ done
+qed
+
+
+lemma homology_exactness_reduced_1:
+ assumes "topspace X \<inter> S \<noteq> {}"
+ shows "exact_seq([reduced_homology_group(p - 1) (subtopology X S),
+ relative_homology_group p X S,
+ reduced_homology_group p X],
+ [hom_boundary p X S, hom_induced p X {} X S id])"
+ (is "exact_seq ([?G1,?G2,?G3], [?h1,?h2])")
+proof -
+ have *: "?h2 ` carrier (homology_group p X)
+ = kernel ?G2 (homology_group (p - 1) (subtopology X S)) ?h1"
+ using homology_exactness_axiom_1 [of p X S] by simp
+ have gh: "group_hom ?G3 ?G2 ?h2"
+ by (simp add: reduced_homology_group_def group_hom_def group_hom_axioms_def
+ group.group_subgroup_generated group.hom_from_subgroup_generated hom_induced_hom)
+ show ?thesis
+ apply (simp add: hom_boundary_reduced_hom gh * image_reduced_homology_group [OF assms])
+ apply (simp add: kernel_def one_reduced_homology_group)
+ done
+qed
+
+
+lemma homology_exactness_reduced_2:
+ "exact_seq([reduced_homology_group(p - 1) X,
+ reduced_homology_group(p - 1) (subtopology X S),
+ relative_homology_group p X S],
+ [hom_induced (p - 1) (subtopology X S) {} X {} id, hom_boundary p X S])"
+ (is "exact_seq ([?G1,?G2,?G3], [?h1,?h2])")
+ using homology_exactness_axiom_2 [of p X S]
+ apply (simp add: group_hom_axioms_def group_hom_def hom_boundary_reduced_hom hom_induced_reduced_hom)
+ apply (simp add: reduced_homology_group_def group_hom.subgroup_kernel group_hom_axioms_def group_hom_def hom_induced_hom)
+ using hom_boundary_reduced_hom [of p X S]
+ apply (auto simp: image_def set_eq_iff)
+ by (metis carrier_reduced_homology_group hom_in_carrier set_eq_iff)
+
+
+lemma homology_exactness_reduced_3:
+ "exact_seq([relative_homology_group p X S,
+ reduced_homology_group p X,
+ reduced_homology_group p (subtopology X S)],
+ [hom_induced p X {} X S id, hom_induced p (subtopology X S) {} X {} id])"
+ (is "exact_seq ([?G1,?G2,?G3], [?h1,?h2])")
+proof -
+ have "kernel ?G2 ?G1 ?h1 =
+ ?h2 ` carrier ?G3"
+ proof -
+ obtain U where U:
+ "(hom_induced p (subtopology X S) {} X {} id) ` carrier ?G3 \<subseteq> U"
+ "(hom_induced p (subtopology X S) {} X {} id) ` carrier ?G3
+ \<subseteq> (hom_induced p (subtopology X S) {} X {} id) ` carrier (homology_group p (subtopology X S))"
+ "U \<inter> kernel (homology_group p X) ?G1 (hom_induced p X {} X S id)
+ = kernel ?G2 ?G1 (hom_induced p X {} X S id)"
+ "U \<inter> (hom_induced p (subtopology X S) {} X {} id) ` carrier (homology_group p (subtopology X S))
+ \<subseteq> (hom_induced p (subtopology X S) {} X {} id) ` carrier ?G3"
+ proof
+ show "?h2 ` carrier ?G3 \<subseteq> carrier ?G2"
+ by (simp add: hom_induced_reduced image_subset_iff)
+ show "?h2 ` carrier ?G3 \<subseteq> ?h2 ` carrier (homology_group p (subtopology X S))"
+ by (meson carrier_reduced_homology_group_subset image_mono)
+ have "subgroup (kernel (homology_group p X) (homology_group p (discrete_topology {()}))
+ (hom_induced p X {} (discrete_topology {()}) {} (\<lambda>x. ())))
+ (homology_group p X)"
+ by (simp add: group.normal_invE(1) group_hom.normal_kernel group_hom_axioms_def group_hom_def hom_induced_empty_hom)
+ then show "carrier ?G2 \<inter> kernel (homology_group p X) ?G1 ?h1 = kernel ?G2 ?G1 ?h1"
+ unfolding carrier_reduced_homology_group
+ by (auto simp: reduced_homology_group_def)
+ show "carrier ?G2 \<inter> ?h2 ` carrier (homology_group p (subtopology X S))
+ \<subseteq> ?h2 ` carrier ?G3"
+ by (force simp: carrier_reduced_homology_group kernel_def hom_induced_compose')
+ qed
+ with homology_exactness_axiom_3 [of p X S] show ?thesis
+ by (fastforce simp add:)
+qed
+ then show ?thesis
+ apply (simp add: group_hom_axioms_def group_hom_def hom_boundary_reduced_hom hom_induced_reduced_hom)
+ apply (simp add: group.hom_from_subgroup_generated hom_induced_hom reduced_homology_group_def)
+ done
+qed
+
+
+subsection\<open>More homology properties of deformations, retracts, contractible spaces\<close>
+
+lemma iso_relative_homology_of_contractible:
+ "\<lbrakk>contractible_space X; topspace X \<inter> S \<noteq> {}\<rbrakk>
+ \<Longrightarrow> hom_boundary p X S
+ \<in> iso (relative_homology_group p X S) (reduced_homology_group(p - 1) (subtopology X S))"
+ using very_short_exact_sequence
+ [of "reduced_homology_group (p - 1) X"
+ "reduced_homology_group (p - 1) (subtopology X S)"
+ "relative_homology_group p X S"
+ "reduced_homology_group p X"
+ "hom_induced (p - 1) (subtopology X S) {} X {} id"
+ "hom_boundary p X S"
+ "hom_induced p X {} X S id"]
+ by (meson exact_seq_cons_iff homology_exactness_reduced_1 homology_exactness_reduced_2 trivial_reduced_homology_group_contractible_space)
+
+lemma isomorphic_group_relative_homology_of_contractible:
+ "\<lbrakk>contractible_space X; topspace X \<inter> S \<noteq> {}\<rbrakk>
+ \<Longrightarrow> relative_homology_group p X S \<cong>
+ reduced_homology_group(p - 1) (subtopology X S)"
+ by (meson iso_relative_homology_of_contractible is_isoI)
+
+lemma isomorphic_group_reduced_homology_of_contractible:
+ "\<lbrakk>contractible_space X; topspace X \<inter> S \<noteq> {}\<rbrakk>
+ \<Longrightarrow> reduced_homology_group p (subtopology X S) \<cong> relative_homology_group(p + 1) X S"
+ by (metis add.commute add_diff_cancel_left' group.iso_sym group_relative_homology_group isomorphic_group_relative_homology_of_contractible)
+
+lemma iso_reduced_homology_by_contractible:
+ "\<lbrakk>contractible_space(subtopology X S); topspace X \<inter> S \<noteq> {}\<rbrakk>
+ \<Longrightarrow> (hom_induced p X {} X S id) \<in> iso (reduced_homology_group p X) (relative_homology_group p X S)"
+ using very_short_exact_sequence
+ [of "reduced_homology_group (p - 1) (subtopology X S)"
+ "relative_homology_group p X S"
+ "reduced_homology_group p X"
+ "reduced_homology_group p (subtopology X S)"
+ "hom_boundary p X S"
+ "hom_induced p X {} X S id"
+ "hom_induced p (subtopology X S) {} X {} id"]
+ by (meson exact_seq_cons_iff homology_exactness_reduced_1 homology_exactness_reduced_3 trivial_reduced_homology_group_contractible_space)
+
+lemma isomorphic_reduced_homology_by_contractible:
+ "\<lbrakk>contractible_space(subtopology X S); topspace X \<inter> S \<noteq> {}\<rbrakk>
+ \<Longrightarrow> reduced_homology_group p X \<cong> relative_homology_group p X S"
+ using is_isoI iso_reduced_homology_by_contractible by blast
+
+lemma isomorphic_relative_homology_by_contractible:
+ "\<lbrakk>contractible_space(subtopology X S); topspace X \<inter> S \<noteq> {}\<rbrakk>
+ \<Longrightarrow> relative_homology_group p X S \<cong> reduced_homology_group p X"
+ using group.iso_sym group_reduced_homology_group isomorphic_reduced_homology_by_contractible by blast
+
+lemma isomorphic_reduced_homology_by_singleton:
+ "a \<in> topspace X \<Longrightarrow> reduced_homology_group p X \<cong> relative_homology_group p X ({a})"
+ by (simp add: contractible_space_subtopology_singleton isomorphic_reduced_homology_by_contractible)
+
+lemma isomorphic_relative_homology_by_singleton:
+ "a \<in> topspace X \<Longrightarrow> relative_homology_group p X ({a}) \<cong> reduced_homology_group p X"
+ by (simp add: group.iso_sym isomorphic_reduced_homology_by_singleton)
+
+lemma reduced_homology_group_pair:
+ assumes "t1_space X" and a: "a \<in> topspace X" and b: "b \<in> topspace X" and "a \<noteq> b"
+ shows "reduced_homology_group p (subtopology X {a,b}) \<cong> homology_group p (subtopology X {a})"
+ (is "?lhs \<cong> ?rhs")
+proof -
+ have "?lhs \<cong> relative_homology_group p (subtopology X {a,b}) {b}"
+ by (simp add: b isomorphic_reduced_homology_by_singleton topspace_subtopology)
+ also have "\<dots> \<cong> ?rhs"
+ proof -
+ have sub: "subtopology X {a, b} closure_of {b} \<subseteq> subtopology X {a, b} interior_of {b}"
+ by (simp add: assms t1_space_subtopology closure_of_singleton subtopology_eq_discrete_topology_finite discrete_topology_closure_of)
+ show ?thesis
+ using homology_excision_axiom [OF sub, of "{a,b}" p]
+ by (simp add: assms(4) group.iso_sym is_isoI subtopology_subtopology)
+ qed
+ finally show ?thesis .
+qed
+
+
+lemma deformation_retraction_relative_homology_group_isomorphisms:
+ "\<lbrakk>retraction_maps X Y r s; r ` U \<subseteq> V; s ` V \<subseteq> U; homotopic_with (\<lambda>h. h ` U \<subseteq> U) X X (s \<circ> r) id\<rbrakk>
+ \<Longrightarrow> group_isomorphisms (relative_homology_group p X U) (relative_homology_group p Y V)
+ (hom_induced p X U Y V r) (hom_induced p Y V X U s)"
+ apply (simp add: retraction_maps_def)
+ apply (rule homotopy_equivalence_relative_homology_group_isomorphisms)
+ apply (auto simp: image_subset_iff continuous_map_compose homotopic_with_equal)
+ done
+
+
+lemma deformation_retract_relative_homology_group_isomorphisms:
+ "\<lbrakk>retraction_maps X Y r id; V \<subseteq> U; r ` U \<subseteq> V; homotopic_with (\<lambda>h. h ` U \<subseteq> U) X X r id\<rbrakk>
+ \<Longrightarrow> group_isomorphisms (relative_homology_group p X U) (relative_homology_group p Y V)
+ (hom_induced p X U Y V r) (hom_induced p Y V X U id)"
+ by (simp add: deformation_retraction_relative_homology_group_isomorphisms)
+
+lemma deformation_retract_relative_homology_group_isomorphism:
+ "\<lbrakk>retraction_maps X Y r id; V \<subseteq> U; r ` U \<subseteq> V; homotopic_with (\<lambda>h. h ` U \<subseteq> U) X X r id\<rbrakk>
+ \<Longrightarrow> (hom_induced p X U Y V r) \<in> iso (relative_homology_group p X U) (relative_homology_group p Y V)"
+ by (metis deformation_retract_relative_homology_group_isomorphisms group_isomorphisms_imp_iso)
+
+lemma deformation_retract_relative_homology_group_isomorphism_id:
+ "\<lbrakk>retraction_maps X Y r id; V \<subseteq> U; r ` U \<subseteq> V; homotopic_with (\<lambda>h. h ` U \<subseteq> U) X X r id\<rbrakk>
+ \<Longrightarrow> (hom_induced p Y V X U id) \<in> iso (relative_homology_group p Y V) (relative_homology_group p X U)"
+ by (metis deformation_retract_relative_homology_group_isomorphisms group_isomorphisms_imp_iso group_isomorphisms_sym)
+
+lemma deformation_retraction_imp_isomorphic_relative_homology_groups:
+ "\<lbrakk>retraction_maps X Y r s; r ` U \<subseteq> V; s ` V \<subseteq> U; homotopic_with (\<lambda>h. h ` U \<subseteq> U) X X (s \<circ> r) id\<rbrakk>
+ \<Longrightarrow> relative_homology_group p X U \<cong> relative_homology_group p Y V"
+ by (blast intro: is_isoI group_isomorphisms_imp_iso deformation_retraction_relative_homology_group_isomorphisms)
+
+lemma deformation_retraction_imp_isomorphic_homology_groups:
+ "\<lbrakk>retraction_maps X Y r s; homotopic_with (\<lambda>h. True) X X (s \<circ> r) id\<rbrakk>
+ \<Longrightarrow> homology_group p X \<cong> homology_group p Y"
+ by (simp add: deformation_retraction_imp_homotopy_equivalent_space homotopy_equivalent_space_imp_isomorphic_homology_groups)
+
+lemma deformation_retract_imp_isomorphic_relative_homology_groups:
+ "\<lbrakk>retraction_maps X X' r id; V \<subseteq> U; r ` U \<subseteq> V; homotopic_with (\<lambda>h. h ` U \<subseteq> U) X X r id\<rbrakk>
+ \<Longrightarrow> relative_homology_group p X U \<cong> relative_homology_group p X' V"
+ by (simp add: deformation_retraction_imp_isomorphic_relative_homology_groups)
+
+lemma deformation_retract_imp_isomorphic_homology_groups:
+ "\<lbrakk>retraction_maps X X' r id; homotopic_with (\<lambda>h. True) X X r id\<rbrakk>
+ \<Longrightarrow> homology_group p X \<cong> homology_group p X'"
+ by (simp add: deformation_retraction_imp_isomorphic_homology_groups)
+
+
+lemma epi_hom_induced_inclusion:
+ assumes "homotopic_with (\<lambda>x. True) X X id f" and "f ` (topspace X) \<subseteq> S"
+ shows "(hom_induced p (subtopology X S) {} X {} id)
+ \<in> epi (homology_group p (subtopology X S)) (homology_group p X)"
+proof (rule epi_right_invertible)
+ show "hom_induced p (subtopology X S) {} X {} id
+ \<in> hom (homology_group p (subtopology X S)) (homology_group p X)"
+ by (simp add: hom_induced_empty_hom)
+ show "hom_induced p X {} (subtopology X S) {} f
+ \<in> carrier (homology_group p X) \<rightarrow> carrier (homology_group p (subtopology X S))"
+ by (simp add: hom_induced_carrier)
+ fix x
+ assume "x \<in> carrier (homology_group p X)"
+ then show "hom_induced p (subtopology X S) {} X {} id (hom_induced p X {} (subtopology X S) {} f x) = x"
+ by (metis assms continuous_map_id_subt continuous_map_in_subtopology hom_induced_compose' hom_induced_id homology_homotopy_empty homotopic_with_imp_continuous_maps image_empty order_refl)
+qed
+
+
+lemma trivial_homomorphism_hom_induced_relativization:
+ assumes "homotopic_with (\<lambda>x. True) X X id f" and "f ` (topspace X) \<subseteq> S"
+ shows "trivial_homomorphism (homology_group p X) (relative_homology_group p X S)
+ (hom_induced p X {} X S id)"
+proof -
+ have "(hom_induced p (subtopology X S) {} X {} id)
+ \<in> epi (homology_group p (subtopology X S)) (homology_group p X)"
+ by (metis assms epi_hom_induced_inclusion)
+ then show ?thesis
+ using homology_exactness_axiom_3 [of p X S] homology_exactness_axiom_1 [of p X S]
+ by (simp add: epi_def group.trivial_homomorphism_image group_hom.trivial_hom_iff)
+qed
+
+
+lemma mon_hom_boundary_inclusion:
+ assumes "homotopic_with (\<lambda>x. True) X X id f" and "f ` (topspace X) \<subseteq> S"
+ shows "(hom_boundary p X S) \<in> mon
+ (relative_homology_group p X S) (homology_group (p - 1) (subtopology X S))"
+proof -
+ have "(hom_induced p (subtopology X S) {} X {} id)
+ \<in> epi (homology_group p (subtopology X S)) (homology_group p X)"
+ by (metis assms epi_hom_induced_inclusion)
+ then show ?thesis
+ using homology_exactness_axiom_3 [of p X S] homology_exactness_axiom_1 [of p X S]
+ apply (simp add: mon_def epi_def hom_boundary_hom)
+ by (metis (no_types, hide_lams) group_hom.trivial_hom_iff group_hom.trivial_ker_imp_inj group_hom_axioms_def group_hom_def group_relative_homology_group hom_boundary_hom)
+qed
+
+lemma short_exact_sequence_hom_induced_relativization:
+ assumes "homotopic_with (\<lambda>x. True) X X id f" and "f ` (topspace X) \<subseteq> S"
+ shows "short_exact_sequence (homology_group (p-1) X) (homology_group (p-1) (subtopology X S)) (relative_homology_group p X S)
+ (hom_induced (p-1) (subtopology X S) {} X {} id) (hom_boundary p X S)"
+ unfolding short_exact_sequence_iff
+ by (intro conjI homology_exactness_axiom_2 epi_hom_induced_inclusion [OF assms] mon_hom_boundary_inclusion [OF assms])
+
+
+lemma group_isomorphisms_homology_group_prod_deformation:
+ fixes p::int
+ assumes "homotopic_with (\<lambda>x. True) X X id f" and "f ` (topspace X) \<subseteq> S"
+ obtains H K where
+ "subgroup H (homology_group p (subtopology X S))"
+ "subgroup K (homology_group p (subtopology X S))"
+ "(\<lambda>(x, y). x \<otimes>\<^bsub>homology_group p (subtopology X S)\<^esub> y)
+ \<in> Group.iso (subgroup_generated (homology_group p (subtopology X S)) H \<times>\<times>
+ subgroup_generated (homology_group p (subtopology X S)) K)
+ (homology_group p (subtopology X S))"
+ "hom_boundary (p + 1) X S
+ \<in> Group.iso (relative_homology_group (p + 1) X S)
+ (subgroup_generated (homology_group p (subtopology X S)) H)"
+ "hom_induced p (subtopology X S) {} X {} id
+ \<in> Group.iso
+ (subgroup_generated (homology_group p (subtopology X S)) K)
+ (homology_group p X)"
+proof -
+ let ?rhs = "relative_homology_group (p + 1) X S"
+ let ?pXS = "homology_group p (subtopology X S)"
+ let ?pX = "homology_group p X"
+ let ?hb = "hom_boundary (p + 1) X S"
+ let ?hi = "hom_induced p (subtopology X S) {} X {} id"
+ have x: "short_exact_sequence (?pX) ?pXS ?rhs ?hi ?hb"
+ using short_exact_sequence_hom_induced_relativization [OF assms, of "p + 1"] by simp
+ have contf: "continuous_map X (subtopology X S) f"
+ by (meson assms continuous_map_in_subtopology homotopic_with_imp_continuous_maps)
+ obtain H K where HK: "H \<lhd> ?pXS" "subgroup K ?pXS" "H \<inter> K \<subseteq> {one ?pXS}" "set_mult ?pXS H K = carrier ?pXS"
+ and iso: "?hb \<in> iso ?rhs (subgroup_generated ?pXS H)" "?hi \<in> iso (subgroup_generated ?pXS K) ?pX"
+ apply (rule splitting_lemma_right [OF x, where g' = "hom_induced p X {} (subtopology X S) {} f"])
+ apply (simp add: hom_induced_empty_hom)
+ apply (simp add: contf hom_induced_compose')
+ apply (metis (full_types) assms(1) hom_induced_id homology_homotopy_empty)
+ apply blast
+ done
+ show ?thesis
+ proof
+ show "subgroup H ?pXS"
+ using HK(1) normal_imp_subgroup by blast
+ then show "(\<lambda>(x, y). x \<otimes>\<^bsub>?pXS\<^esub> y)
+ \<in> Group.iso (subgroup_generated (?pXS) H \<times>\<times> subgroup_generated (?pXS) K) (?pXS)"
+ by (meson HK abelian_relative_homology_group group_disjoint_sum.iso_group_mul group_disjoint_sum_def group_relative_homology_group)
+ show "subgroup K ?pXS"
+ by (rule HK)
+ show "hom_boundary (p + 1) X S \<in> Group.iso ?rhs (subgroup_generated (?pXS) H)"
+ using iso int_ops(4) by presburger
+ show "hom_induced p (subtopology X S) {} X {} id \<in> Group.iso (subgroup_generated (?pXS) K) (?pX)"
+ by (simp add: iso(2))
+ qed
+qed
+
+lemma iso_homology_group_prod_deformation:
+ assumes "homotopic_with (\<lambda>x. True) X X id f" and "f ` (topspace X) \<subseteq> S"
+ shows "homology_group p (subtopology X S)
+ \<cong> DirProd (homology_group p X) (relative_homology_group(p + 1) X S)"
+ (is "?G \<cong> DirProd ?H ?R")
+proof -
+ obtain H K where HK:
+ "(\<lambda>(x, y). x \<otimes>\<^bsub>?G\<^esub> y)
+ \<in> Group.iso (subgroup_generated (?G) H \<times>\<times> subgroup_generated (?G) K) (?G)"
+ "hom_boundary (p + 1) X S \<in> Group.iso (?R) (subgroup_generated (?G) H)"
+ "hom_induced p (subtopology X S) {} X {} id \<in> Group.iso (subgroup_generated (?G) K) (?H)"
+ by (blast intro: group_isomorphisms_homology_group_prod_deformation [OF assms])
+ have "?G \<cong> DirProd (subgroup_generated (?G) H) (subgroup_generated (?G) K)"
+ by (meson DirProd_group HK(1) group.group_subgroup_generated group.iso_sym group_relative_homology_group is_isoI)
+ also have "\<dots> \<cong> DirProd ?R ?H"
+ by (meson HK group.DirProd_iso_trans group.group_subgroup_generated group.iso_sym group_relative_homology_group is_isoI)
+ also have "\<dots> \<cong> DirProd ?H ?R"
+ by (simp add: DirProd_commute_iso)
+ finally show ?thesis .
+qed
+
+
+
+lemma iso_homology_contractible_space_subtopology1:
+ assumes "contractible_space X" "S \<subseteq> topspace X" "S \<noteq> {}"
+ shows "homology_group 0 (subtopology X S) \<cong> DirProd integer_group (relative_homology_group(1) X S)"
+proof -
+ obtain f where "homotopic_with (\<lambda>x. True) X X id f" and "f ` (topspace X) \<subseteq> S"
+ using assms contractible_space_alt by fastforce
+ then have "homology_group 0 (subtopology X S) \<cong> homology_group 0 X \<times>\<times> relative_homology_group 1 X S"
+ using iso_homology_group_prod_deformation [of X _ S 0] by auto
+ also have "\<dots> \<cong> integer_group \<times>\<times> relative_homology_group 1 X S"
+ using assms contractible_imp_path_connected_space group.DirProd_iso_trans group_relative_homology_group iso_refl isomorphic_integer_zeroth_homology_group by blast
+ finally show ?thesis .
+qed
+
+lemma iso_homology_contractible_space_subtopology2:
+ "\<lbrakk>contractible_space X; S \<subseteq> topspace X; p \<noteq> 0; S \<noteq> {}\<rbrakk>
+ \<Longrightarrow> homology_group p (subtopology X S) \<cong> relative_homology_group (p + 1) X S"
+ by (metis (no_types, hide_lams) add.commute isomorphic_group_reduced_homology_of_contractible topspace_subtopology topspace_subtopology_subset un_reduced_homology_group)
+
+lemma trivial_relative_homology_group_contractible_spaces:
+ "\<lbrakk>contractible_space X; contractible_space(subtopology X S); topspace X \<inter> S \<noteq> {}\<rbrakk>
+ \<Longrightarrow> trivial_group(relative_homology_group p X S)"
+ using group_reduced_homology_group group_relative_homology_group isomorphic_group_triviality isomorphic_relative_homology_by_contractible trivial_reduced_homology_group_contractible_space by blast
+
+lemma trivial_relative_homology_group_alt:
+ assumes contf: "continuous_map X (subtopology X S) f" and hom: "homotopic_with (\<lambda>k. k ` S \<subseteq> S) X X f id"
+ shows "trivial_group (relative_homology_group p X S)"
+proof (rule trivial_relative_homology_group_gen [OF contf])
+ show "homotopic_with (\<lambda>h. True) (subtopology X S) (subtopology X S) f id"
+ using hom unfolding homotopic_with_def
+ apply (rule ex_forward)
+ apply (auto simp: prod_topology_subtopology continuous_map_in_subtopology continuous_map_from_subtopology image_subset_iff topspace_subtopology)
+ done
+ show "homotopic_with (\<lambda>k. True) X X f id"
+ using assms by (force simp: homotopic_with_def)
+qed
+
+
+lemma iso_hom_induced_relativization_contractible:
+ assumes "contractible_space(subtopology X S)" "contractible_space(subtopology X T)" "T \<subseteq> S" "topspace X \<inter> T \<noteq> {}"
+ shows "(hom_induced p X T X S id) \<in> iso (relative_homology_group p X T) (relative_homology_group p X S)"
+proof (rule very_short_exact_sequence)
+ show "exact_seq
+ ([relative_homology_group(p - 1) (subtopology X S) T, relative_homology_group p X S, relative_homology_group p X T, relative_homology_group p (subtopology X S) T],
+ [hom_relboundary p X S T, hom_induced p X T X S id, hom_induced p (subtopology X S) T X T id])"
+ using homology_exactness_triple_1 [OF \<open>T \<subseteq> S\<close>] homology_exactness_triple_3 [OF \<open>T \<subseteq> S\<close>]
+ by fastforce
+ show "trivial_group (relative_homology_group p (subtopology X S) T)" "trivial_group (relative_homology_group(p - 1) (subtopology X S) T)"
+ using assms
+ by (force simp: inf.absorb_iff2 subtopology_subtopology topspace_subtopology intro!: trivial_relative_homology_group_contractible_spaces)+
+qed
+
+corollary isomorphic_relative_homology_groups_relativization_contractible:
+ assumes "contractible_space(subtopology X S)" "contractible_space(subtopology X T)" "T \<subseteq> S" "topspace X \<inter> T \<noteq> {}"
+ shows "relative_homology_group p X T \<cong> relative_homology_group p X S"
+ by (rule is_isoI) (rule iso_hom_induced_relativization_contractible [OF assms])
+
+lemma iso_hom_induced_inclusion_contractible:
+ assumes "contractible_space X" "contractible_space(subtopology X S)" "T \<subseteq> S" "topspace X \<inter> S \<noteq> {}"
+ shows "(hom_induced p (subtopology X S) T X T id)
+ \<in> iso (relative_homology_group p (subtopology X S) T) (relative_homology_group p X T)"
+proof (rule very_short_exact_sequence)
+ show "exact_seq
+ ([relative_homology_group p X S, relative_homology_group p X T,
+ relative_homology_group p (subtopology X S) T, relative_homology_group (p+1) X S],
+ [hom_induced p X T X S id, hom_induced p (subtopology X S) T X T id, hom_relboundary (p+1) X S T])"
+ using homology_exactness_triple_2 [OF \<open>T \<subseteq> S\<close>] homology_exactness_triple_3 [OF \<open>T \<subseteq> S\<close>]
+ by (metis add_diff_cancel_left' diff_add_cancel exact_seq_cons_iff)
+ show "trivial_group (relative_homology_group (p+1) X S)" "trivial_group (relative_homology_group p X S)"
+ using assms
+ by (auto simp: subtopology_subtopology topspace_subtopology intro!: trivial_relative_homology_group_contractible_spaces)
+qed
+
+corollary isomorphic_relative_homology_groups_inclusion_contractible:
+ assumes "contractible_space X" "contractible_space(subtopology X S)" "T \<subseteq> S" "topspace X \<inter> S \<noteq> {}"
+ shows "relative_homology_group p (subtopology X S) T \<cong> relative_homology_group p X T"
+ by (rule is_isoI) (rule iso_hom_induced_inclusion_contractible [OF assms])
+
+lemma iso_hom_relboundary_contractible:
+ assumes "contractible_space X" "contractible_space(subtopology X T)" "T \<subseteq> S" "topspace X \<inter> T \<noteq> {}"
+ shows "hom_relboundary p X S T
+ \<in> iso (relative_homology_group p X S) (relative_homology_group (p - 1) (subtopology X S) T)"
+proof (rule very_short_exact_sequence)
+ show "exact_seq
+ ([relative_homology_group (p - 1) X T, relative_homology_group (p - 1) (subtopology X S) T, relative_homology_group p X S, relative_homology_group p X T],
+ [hom_induced (p - 1) (subtopology X S) T X T id, hom_relboundary p X S T, hom_induced p X T X S id])"
+ using homology_exactness_triple_1 [OF \<open>T \<subseteq> S\<close>] homology_exactness_triple_2 [OF \<open>T \<subseteq> S\<close>] by simp
+ show "trivial_group (relative_homology_group p X T)" "trivial_group (relative_homology_group (p - 1) X T)"
+ using assms
+ by (auto simp: subtopology_subtopology topspace_subtopology intro!: trivial_relative_homology_group_contractible_spaces)
+qed
+
+corollary isomorphic_relative_homology_groups_relboundary_contractible:
+ assumes "contractible_space X" "contractible_space(subtopology X T)" "T \<subseteq> S" "topspace X \<inter> T \<noteq> {}"
+ shows "relative_homology_group p X S \<cong> relative_homology_group (p - 1) (subtopology X S) T"
+ by (rule is_isoI) (rule iso_hom_relboundary_contractible [OF assms])
+
+lemma isomorphic_relative_contractible_space_imp_homology_groups:
+ assumes "contractible_space X" "contractible_space Y" "S \<subseteq> topspace X" "T \<subseteq> topspace Y"
+ and ST: "S = {} \<longleftrightarrow> T = {}"
+ and iso: "\<And>p. relative_homology_group p X S \<cong> relative_homology_group p Y T"
+ shows "homology_group p (subtopology X S) \<cong> homology_group p (subtopology Y T)"
+proof (cases "T = {}")
+ case True
+ have "homology_group p (subtopology X {}) \<cong> homology_group p (subtopology Y {})"
+ by (simp add: homeomorphic_empty_space_eq homeomorphic_space_imp_isomorphic_homology_groups)
+ then show ?thesis
+ using ST True by blast
+next
+ case False
+ show ?thesis
+ proof (cases "p = 0")
+ case True
+ have "homology_group p (subtopology X S) \<cong> integer_group \<times>\<times> relative_homology_group 1 X S"
+ using assms True \<open>T \<noteq> {}\<close>
+ by (simp add: iso_homology_contractible_space_subtopology1)
+ also have "\<dots> \<cong> integer_group \<times>\<times> relative_homology_group 1 Y T"
+ by (simp add: assms group.DirProd_iso_trans iso_refl)
+ also have "\<dots> \<cong> homology_group p (subtopology Y T)"
+ by (simp add: True \<open>T \<noteq> {}\<close> assms group.iso_sym iso_homology_contractible_space_subtopology1)
+ finally show ?thesis .
+ next
+ case False
+ have "homology_group p (subtopology X S) \<cong> relative_homology_group (p+1) X S"
+ using assms False \<open>T \<noteq> {}\<close>
+ by (simp add: iso_homology_contractible_space_subtopology2)
+ also have "\<dots> \<cong> relative_homology_group (p+1) Y T"
+ by (simp add: assms)
+ also have "\<dots> \<cong> homology_group p (subtopology Y T)"
+ by (simp add: False \<open>T \<noteq> {}\<close> assms group.iso_sym iso_homology_contractible_space_subtopology2)
+ finally show ?thesis .
+ qed
+qed
+
+
+subsection\<open>Homology groups of spheres\<close>
+
+lemma iso_reduced_homology_group_lower_hemisphere:
+ assumes "k \<le> n"
+ shows "hom_induced p (nsphere n) {} (nsphere n) {x. x k \<le> 0} id
+ \<in> iso (reduced_homology_group p (nsphere n)) (relative_homology_group p (nsphere n) {x. x k \<le> 0})"
+proof (rule iso_reduced_homology_by_contractible)
+ show "contractible_space (subtopology (nsphere n) {x. x k \<le> 0})"
+ by (simp add: assms contractible_space_lower_hemisphere)
+ have "(\<lambda>i. if i = k then -1 else 0) \<in> topspace (nsphere n) \<inter> {x. x k \<le> 0}"
+ using assms by (simp add: nsphere if_distrib [of "\<lambda>x. x ^ 2"] cong: if_cong)
+ then show "topspace (nsphere n) \<inter> {x. x k \<le> 0} \<noteq> {}"
+ by blast
+qed
+
+
+lemma topspace_nsphere_1:
+ assumes "x \<in> topspace (nsphere n)" shows "(x k)\<^sup>2 \<le> 1"
+proof (cases "k \<le> n")
+ case True
+ have "(\<Sum>i \<in> {..n} - {k}. (x i)\<^sup>2) = (\<Sum>i\<le>n. (x i)\<^sup>2) - (x k)\<^sup>2"
+ using \<open>k \<le> n\<close> by (simp add: sum_diff)
+ then show ?thesis
+ using assms
+ apply (simp add: nsphere)
+ by (metis diff_ge_0_iff_ge sum_nonneg zero_le_power2)
+next
+ case False
+ then show ?thesis
+ using assms by (simp add: nsphere)
+qed
+
+lemma topspace_nsphere_1_eq_0:
+ fixes x :: "nat \<Rightarrow> real"
+ assumes x: "x \<in> topspace (nsphere n)" and xk: "(x k)\<^sup>2 = 1" and "i \<noteq> k"
+ shows "x i = 0"
+proof (cases "i \<le> n")
+ case True
+ have "k \<le> n"
+ using x
+ by (simp add: nsphere) (metis not_less xk zero_neq_one zero_power2)
+ have "(\<Sum>i \<in> {..n} - {k}. (x i)\<^sup>2) = (\<Sum>i\<le>n. (x i)\<^sup>2) - (x k)\<^sup>2"
+ using \<open>k \<le> n\<close> by (simp add: sum_diff)
+ also have "\<dots> = 0"
+ using assms by (simp add: nsphere)
+ finally have "\<forall>i\<in>{..n} - {k}. (x i)\<^sup>2 = 0"
+ by (simp add: sum_nonneg_eq_0_iff)
+ then show ?thesis
+ using True \<open>i \<noteq> k\<close> by auto
+next
+ case False
+ with x show ?thesis
+ by (simp add: nsphere)
+qed
+
+
+proposition iso_relative_homology_group_upper_hemisphere:
+ "(hom_induced p (subtopology (nsphere n) {x. x k \<ge> 0}) {x. x k = 0} (nsphere n) {x. x k \<le> 0} id)
+ \<in> iso (relative_homology_group p (subtopology (nsphere n) {x. x k \<ge> 0}) {x. x k = 0})
+ (relative_homology_group p (nsphere n) {x. x k \<le> 0})" (is "?h \<in> iso ?G ?H")
+proof -
+ have "topspace (nsphere n) \<inter> {x. x k < - 1 / 2} \<subseteq> {x \<in> topspace (nsphere n). x k \<in> {y. y \<le> - 1 / 2}}"
+ by force
+ moreover have "closedin (nsphere n) {x \<in> topspace (nsphere n). x k \<in> {y. y \<le> - 1 / 2}}"
+ apply (rule closedin_continuous_map_preimage [OF continuous_map_nsphere_projection])
+ using closed_Collect_le [of id "\<lambda>x::real. -1/2"] apply simp
+ done
+ ultimately have "nsphere n closure_of {x. x k < -1/2} \<subseteq> {x \<in> topspace (nsphere n). x k \<in> {y. y \<le> -1/2}}"
+ by (metis (no_types, lifting) closure_of_eq closure_of_mono closure_of_restrict)
+ also have "\<dots> \<subseteq> {x \<in> topspace (nsphere n). x k \<in> {y. y < 0}}"
+ by force
+ also have "\<dots> \<subseteq> nsphere n interior_of {x. x k \<le> 0}"
+ proof (rule interior_of_maximal)
+ show "{x \<in> topspace (nsphere n). x k \<in> {y. y < 0}} \<subseteq> {x. x k \<le> 0}"
+ by force
+ show "openin (nsphere n) {x \<in> topspace (nsphere n). x k \<in> {y. y < 0}}"
+ apply (rule openin_continuous_map_preimage [OF continuous_map_nsphere_projection])
+ using open_Collect_less [of id "\<lambda>x::real. 0"] apply simp
+ done
+ qed
+ finally have nn: "nsphere n closure_of {x. x k < -1/2} \<subseteq> nsphere n interior_of {x. x k \<le> 0}" .
+ have [simp]: "{x::nat\<Rightarrow>real. x k \<le> 0} - {x. x k < - (1/2)} = {x. -1/2 \<le> x k \<and> x k \<le> 0}"
+ "UNIV - {x::nat\<Rightarrow>real. x k < a} = {x. a \<le> x k}" for a
+ by auto
+ let ?T01 = "top_of_set {0..1::real}"
+ let ?X12 = "subtopology (nsphere n) {x. -1/2 \<le> x k}"
+ have 1: "hom_induced p ?X12 {x. -1/2 \<le> x k \<and> x k \<le> 0} (nsphere n) {x. x k \<le> 0} id
+ \<in> iso (relative_homology_group p ?X12 {x. -1/2 \<le> x k \<and> x k \<le> 0})
+ ?H"
+ using homology_excision_axiom [OF nn subset_UNIV, of p] by simp
+ define h where "h \<equiv> \<lambda>(T,x). let y = max (x k) (-T) in
+ (\<lambda>i. if i = k then y else sqrt(1 - y ^ 2) / sqrt(1 - x k ^ 2) * x i)"
+ have h: "h(T,x) = x" if "0 \<le> T" "T \<le> 1" "(\<Sum>i\<le>n. (x i)\<^sup>2) = 1" and 0: "\<forall>i>n. x i = 0" "-T \<le> x k" for T x
+ using that by (force simp: nsphere h_def Let_def max_def intro!: topspace_nsphere_1_eq_0)
+ have "continuous_map (prod_topology ?T01 ?X12) euclideanreal (\<lambda>x. h x i)" for i
+ proof -
+ show ?thesis
+ proof (rule continuous_map_eq)
+ show "continuous_map (prod_topology ?T01 ?X12)
+ euclideanreal (\<lambda>(T, x). if 0 \<le> x k then x i else h (T, x) i)"
+ unfolding case_prod_unfold
+ proof (rule continuous_map_cases_le)
+ show "continuous_map (prod_topology ?T01 ?X12) euclideanreal (\<lambda>x. snd x k)"
+ apply (subst continuous_map_of_snd [unfolded o_def])
+ by (simp add: continuous_map_from_subtopology continuous_map_nsphere_projection)
+ next
+ show "continuous_map (subtopology (prod_topology ?T01 ?X12) {p \<in> topspace (prod_topology ?T01 ?X12). 0 \<le> snd p k})
+ euclideanreal (\<lambda>x. snd x i)"
+ apply (rule continuous_map_from_subtopology)
+ apply (subst continuous_map_of_snd [unfolded o_def])
+ by (simp add: continuous_map_from_subtopology continuous_map_nsphere_projection)
+ next
+ note fst = continuous_map_into_fulltopology [OF continuous_map_subtopology_fst]
+ have snd: "continuous_map (subtopology (prod_topology ?T01 (subtopology (nsphere n) T)) S) euclideanreal (\<lambda>x. snd x k)" for k S T
+ apply (simp add: nsphere)
+ apply (rule continuous_map_from_subtopology)
+ apply (subst continuous_map_of_snd [unfolded o_def])
+ using continuous_map_from_subtopology continuous_map_nsphere_projection nsphere by fastforce
+ show "continuous_map (subtopology (prod_topology ?T01 ?X12) {p \<in> topspace (prod_topology ?T01 ?X12). snd p k \<le> 0})
+ euclideanreal (\<lambda>x. h (fst x, snd x) i)"
+ apply (simp add: h_def case_prod_unfold Let_def)
+ apply (intro conjI impI fst snd continuous_intros)
+ apply (auto simp: nsphere power2_eq_1_iff)
+ done
+ qed (auto simp: nsphere h)
+ qed (auto simp: nsphere h)
+ qed
+ moreover
+ have "h ` ({0..1} \<times> (topspace (nsphere n) \<inter> {x. - (1/2) \<le> x k}))
+ \<subseteq> {x. (\<Sum>i\<le>n. (x i)\<^sup>2) = 1 \<and> (\<forall>i>n. x i = 0)}"
+ proof -
+ have "(\<Sum>i\<le>n. (h (T,x) i)\<^sup>2) = 1"
+ if x: "x \<in> topspace (nsphere n)" and xk: "- (1/2) \<le> x k" and T: "0 \<le> T" "T \<le> 1" for T x
+ proof (cases "-T \<le> x k ")
+ case True
+ then show ?thesis
+ using that by (auto simp: nsphere h)
+ next
+ case False
+ with x \<open>0 \<le> T\<close> have "k \<le> n"
+ apply (simp add: nsphere)
+ by (metis neg_le_0_iff_le not_le)
+ have "1 - (x k)\<^sup>2 \<ge> 0"
+ using topspace_nsphere_1 x by auto
+ with False T \<open>k \<le> n\<close>
+ have "(\<Sum>i\<le>n. (h (T,x) i)\<^sup>2) = T\<^sup>2 + (1 - T\<^sup>2) * (\<Sum>i\<in>{..n} - {k}. (x i)\<^sup>2 / (1 - (x k)\<^sup>2))"
+ unfolding h_def Let_def max_def
+ by (simp add: not_le square_le_1 power_mult_distrib power_divide if_distrib [of "\<lambda>x. x ^ 2"]
+ sum.delta_remove sum_distrib_left)
+ also have "\<dots> = 1"
+ using x False xk \<open>0 \<le> T\<close>
+ by (simp add: nsphere sum_diff not_le \<open>k \<le> n\<close> power2_eq_1_iff flip: sum_divide_distrib)
+ finally show ?thesis .
+ qed
+ moreover
+ have "h (T,x) i = 0"
+ if "x \<in> topspace (nsphere n)" "- (1/2) \<le> x k" and "n < i" "0 \<le> T" "T \<le> 1"
+ for T x i
+ proof (cases "-T \<le> x k ")
+ case False
+ then show ?thesis
+ using that by (auto simp: nsphere h_def Let_def not_le max_def)
+ qed (use that in \<open>auto simp: nsphere h\<close>)
+ ultimately show ?thesis
+ by auto
+ qed
+ ultimately
+ have cmh: "continuous_map (prod_topology ?T01 ?X12) (nsphere n) h"
+ by (subst (2) nsphere) (simp add: continuous_map_in_subtopology continuous_map_componentwise_UNIV)
+ have "hom_induced p (subtopology (nsphere n) {x. 0 \<le> x k})
+ (topspace (subtopology (nsphere n) {x. 0 \<le> x k}) \<inter> {x. x k = 0}) ?X12
+ (topspace ?X12 \<inter> {x. - 1/2 \<le> x k \<and> x k \<le> 0}) id
+ \<in> iso (relative_homology_group p (subtopology (nsphere n) {x. 0 \<le> x k})
+ (topspace (subtopology (nsphere n) {x. 0 \<le> x k}) \<inter> {x. x k = 0}))
+ (relative_homology_group p ?X12 (topspace ?X12 \<inter> {x. - 1/2 \<le> x k \<and> x k \<le> 0}))"
+ proof (rule deformation_retract_relative_homology_group_isomorphism_id)
+ show "retraction_maps ?X12 (subtopology (nsphere n) {x. 0 \<le> x k}) (h \<circ> (\<lambda>x. (0,x))) id"
+ unfolding retraction_maps_def
+ proof (intro conjI ballI)
+ show "continuous_map ?X12 (subtopology (nsphere n) {x. 0 \<le> x k}) (h \<circ> Pair 0)"
+ apply (simp add: continuous_map_in_subtopology)
+ apply (intro conjI continuous_map_compose [OF _ cmh] continuous_intros)
+ apply (auto simp: h_def Let_def)
+ done
+ show "continuous_map (subtopology (nsphere n) {x. 0 \<le> x k}) ?X12 id"
+ by (simp add: continuous_map_in_subtopology) (auto simp: nsphere)
+ qed (simp add: nsphere h)
+ next
+ have h0: "\<And>xa. \<lbrakk>xa \<in> topspace (nsphere n); - (1/2) \<le> xa k; xa k \<le> 0\<rbrakk> \<Longrightarrow> h (0, xa) k = 0"
+ by (simp add: h_def Let_def)
+ show "(h \<circ> (\<lambda>x. (0,x))) ` (topspace ?X12 \<inter> {x. - 1 / 2 \<le> x k \<and> x k \<le> 0})
+ \<subseteq> topspace (subtopology (nsphere n) {x. 0 \<le> x k}) \<inter> {x. x k = 0}"
+ apply (auto simp: h0)
+ apply (rule subsetD [OF continuous_map_image_subset_topspace [OF cmh]])
+ apply (force simp: nsphere)
+ done
+ have hin: "\<And>t x. \<lbrakk>x \<in> topspace (nsphere n); - (1/2) \<le> x k; 0 \<le> t; t \<le> 1\<rbrakk> \<Longrightarrow> h (t,x) \<in> topspace (nsphere n)"
+ apply (rule subsetD [OF continuous_map_image_subset_topspace [OF cmh]])
+ apply (force simp: nsphere)
+ done
+ have h1: "\<And>x. \<lbrakk>x \<in> topspace (nsphere n); - (1/2) \<le> x k\<rbrakk> \<Longrightarrow> h (1, x) = x"
+ by (simp add: h nsphere)
+ have "continuous_map (prod_topology ?T01 ?X12) (nsphere n) h"
+ using cmh by force
+ then show "homotopic_with
+ (\<lambda>h. h ` (topspace ?X12 \<inter> {x. - 1 / 2 \<le> x k \<and> x k \<le> 0}) \<subseteq> topspace ?X12 \<inter> {x. - 1 / 2 \<le> x k \<and> x k \<le> 0})
+ ?X12 ?X12 (h \<circ> (\<lambda>x. (0,x))) id"
+ apply (subst homotopic_with, force)
+ apply (rule_tac x=h in exI)
+ apply (auto simp: hin h1 continuous_map_in_subtopology)
+ apply (auto simp: h_def Let_def max_def)
+ done
+ qed auto
+ then have 2: "hom_induced p (subtopology (nsphere n) {x. 0 \<le> x k}) {x. x k = 0}
+ ?X12 {x. - 1/2 \<le> x k \<and> x k \<le> 0} id
+ \<in> Group.iso
+ (relative_homology_group p (subtopology (nsphere n) {x. 0 \<le> x k}) {x. x k = 0})
+ (relative_homology_group p ?X12 {x. - 1/2 \<le> x k \<and> x k \<le> 0})"
+ by (metis hom_induced_restrict relative_homology_group_restrict topspace_subtopology)
+ show ?thesis
+ using iso_set_trans [OF 2 1]
+ by (simp add: subset_iff continuous_map_in_subtopology flip: hom_induced_compose)
+qed
+
+
+corollary iso_upper_hemisphere_reduced_homology_group:
+ "(hom_boundary (1 + p) (subtopology (nsphere (Suc n)) {x. x(Suc n) \<ge> 0}) {x. x(Suc n) = 0})
+ \<in> iso (relative_homology_group (1 + p) (subtopology (nsphere (Suc n)) {x. x(Suc n) \<ge> 0}) {x. x(Suc n) = 0})
+ (reduced_homology_group p (nsphere n))"
+proof -
+ have "{x. 0 \<le> x (Suc n)} \<inter> {x. x (Suc n) = 0} = {x. x (Suc n) = (0::real)}"
+ by auto
+ then have n: "nsphere n = subtopology (subtopology (nsphere (Suc n)) {x. x(Suc n) \<ge> 0}) {x. x(Suc n) = 0}"
+ by (simp add: subtopology_nsphere_equator subtopology_subtopology)
+ have ne: "(\<lambda>i. if i = n then 1 else 0) \<in> topspace (subtopology (nsphere (Suc n)) {x. 0 \<le> x (Suc n)}) \<inter> {x. x (Suc n) = 0}"
+ by (simp add: nsphere if_distrib [of "\<lambda>x. x ^ 2"] cong: if_cong)
+ show ?thesis
+ unfolding n
+ apply (rule iso_relative_homology_of_contractible [where p = "1 + p", simplified])
+ using contractible_space_upper_hemisphere ne apply blast+
+ done
+qed
+
+corollary iso_reduced_homology_group_upper_hemisphere:
+ assumes "k \<le> n"
+ shows "hom_induced p (nsphere n) {} (nsphere n) {x. x k \<ge> 0} id
+ \<in> iso (reduced_homology_group p (nsphere n)) (relative_homology_group p (nsphere n) {x. x k \<ge> 0})"
+proof (rule iso_reduced_homology_by_contractible [OF contractible_space_upper_hemisphere [OF assms]])
+ have "(\<lambda>i. if i = k then 1 else 0) \<in> topspace (nsphere n) \<inter> {x. 0 \<le> x k}"
+ using assms by (simp add: nsphere if_distrib [of "\<lambda>x. x ^ 2"] cong: if_cong)
+ then show "topspace (nsphere n) \<inter> {x. 0 \<le> x k} \<noteq> {}"
+ by blast
+qed
+
+
+lemma iso_relative_homology_group_lower_hemisphere:
+ "hom_induced p (subtopology (nsphere n) {x. x k \<le> 0}) {x. x k = 0} (nsphere n) {x. x k \<ge> 0} id
+ \<in> iso (relative_homology_group p (subtopology (nsphere n) {x. x k \<le> 0}) {x. x k = 0})
+ (relative_homology_group p (nsphere n) {x. x k \<ge> 0})" (is "?k \<in> iso ?G ?H")
+proof -
+ define r where "r \<equiv> \<lambda>x i. if i = k then -x i else (x i::real)"
+ then have [simp]: "r \<circ> r = id"
+ by force
+ have cmr: "continuous_map (subtopology (nsphere n) S) (nsphere n) r" for S
+ using continuous_map_nsphere_reflection [of n k]
+ by (simp add: continuous_map_from_subtopology r_def)
+ let ?f = "hom_induced p (subtopology (nsphere n) {x. x k \<le> 0}) {x. x k = 0}
+ (subtopology (nsphere n) {x. x k \<ge> 0}) {x. x k = 0} r"
+ let ?g = "hom_induced p (subtopology (nsphere n) {x. x k \<ge> 0}) {x. x k = 0} (nsphere n) {x. x k \<le> 0} id"
+ let ?h = "hom_induced p (nsphere n) {x. x k \<le> 0} (nsphere n) {x. x k \<ge> 0} r"
+ obtain f h where
+ f: "f \<in> iso ?G (relative_homology_group p (subtopology (nsphere n) {x. x k \<ge> 0}) {x. x k = 0})"
+ and h: "h \<in> iso (relative_homology_group p (nsphere n) {x. x k \<le> 0}) ?H"
+ and eq: "h \<circ> ?g \<circ> f = ?k"
+ proof
+ have hmr: "homeomorphic_map (nsphere n) (nsphere n) r"
+ unfolding homeomorphic_map_maps
+ by (metis \<open>r \<circ> r = id\<close> cmr homeomorphic_maps_involution pointfree_idE subtopology_topspace)
+ then have hmrs: "homeomorphic_map (subtopology (nsphere n) {x. x k \<le> 0}) (subtopology (nsphere n) {x. x k \<ge> 0}) r"
+ by (simp add: homeomorphic_map_subtopologies_alt r_def)
+ have rimeq: "r ` (topspace (subtopology (nsphere n) {x. x k \<le> 0}) \<inter> {x. x k = 0})
+ = topspace (subtopology (nsphere n) {x. 0 \<le> x k}) \<inter> {x. x k = 0}"
+ using continuous_map_eq_topcontinuous_at continuous_map_nsphere_reflection topcontinuous_at_atin
+ by (fastforce simp: r_def)
+ show "?f \<in> iso ?G (relative_homology_group p (subtopology (nsphere n) {x. x k \<ge> 0}) {x. x k = 0})"
+ using homeomorphic_map_relative_homology_iso [OF hmrs Int_lower1 rimeq]
+ by (metis hom_induced_restrict relative_homology_group_restrict)
+ have rimeq: "r ` (topspace (nsphere n) \<inter> {x. x k \<le> 0}) = topspace (nsphere n) \<inter> {x. 0 \<le> x k}"
+ by (metis hmrs homeomorphic_imp_surjective_map topspace_subtopology)
+ show "?h \<in> Group.iso (relative_homology_group p (nsphere n) {x. x k \<le> 0}) ?H"
+ using homeomorphic_map_relative_homology_iso [OF hmr Int_lower1 rimeq] by simp
+ have [simp]: "\<And>x. x k = 0 \<Longrightarrow> r x k = 0"
+ by (auto simp: r_def)
+ have "?h \<circ> ?g \<circ> ?f
+ = hom_induced p (subtopology (nsphere n) {x. 0 \<le> x k}) {x. x k = 0} (nsphere n) {x. 0 \<le> x k} r \<circ>
+ hom_induced p (subtopology (nsphere n) {x. x k \<le> 0}) {x. x k = 0} (subtopology (nsphere n) {x. 0 \<le> x k}) {x. x k = 0} r"
+ apply (subst hom_induced_compose [symmetric])
+ using continuous_map_nsphere_reflection apply (force simp: r_def)+
+ done
+ also have "\<dots> = ?k"
+ apply (subst hom_induced_compose [symmetric])
+ apply (simp_all add: image_subset_iff cmr)
+ using hmrs homeomorphic_imp_continuous_map apply blast
+ done
+ finally show "?h \<circ> ?g \<circ> ?f = ?k" .
+ qed
+ with iso_relative_homology_group_upper_hemisphere [of p n k]
+ have "h \<circ> hom_induced p (subtopology (nsphere n) {f. 0 \<le> f k}) {f. f k = 0} (nsphere n) {f. f k \<le> 0} id \<circ> f
+ \<in> Group.iso ?G (relative_homology_group p (nsphere n) {f. 0 \<le> f k})"
+ using f h iso_set_trans by blast
+ then show ?thesis
+ by (simp add: eq)
+qed
+
+
+lemma iso_lower_hemisphere_reduced_homology_group:
+ "hom_boundary (1 + p) (subtopology (nsphere (Suc n)) {x. x(Suc n) \<le> 0}) {x. x(Suc n) = 0}
+ \<in> iso (relative_homology_group (1 + p) (subtopology (nsphere (Suc n)) {x. x(Suc n) \<le> 0})
+ {x. x(Suc n) = 0})
+ (reduced_homology_group p (nsphere n))"
+proof -
+ have "{x. (\<Sum>i\<le>n. (x i)\<^sup>2) = 1 \<and> (\<forall>i>n. x i = 0)} =
+ ({x. (\<Sum>i\<le>n. (x i)\<^sup>2) + (x (Suc n))\<^sup>2 = 1 \<and> (\<forall>i>Suc n. x i = 0)} \<inter> {x. x (Suc n) \<le> 0} \<inter>
+ {x. x (Suc n) = (0::real)})"
+ by (force simp: dest: Suc_lessI)
+ then have n: "nsphere n = subtopology (subtopology (nsphere (Suc n)) {x. x(Suc n) \<le> 0}) {x. x(Suc n) = 0}"
+ by (simp add: nsphere subtopology_subtopology)
+ have ne: "(\<lambda>i. if i = n then 1 else 0) \<in> topspace (subtopology (nsphere (Suc n)) {x. x (Suc n) \<le> 0}) \<inter> {x. x (Suc n) = 0}"
+ by (simp add: nsphere if_distrib [of "\<lambda>x. x ^ 2"] cong: if_cong)
+ show ?thesis
+ unfolding n
+ apply (rule iso_relative_homology_of_contractible [where p = "1 + p", simplified])
+ using contractible_space_lower_hemisphere ne apply blast+
+ done
+qed
+
+lemma isomorphism_sym:
+ "\<lbrakk>f \<in> iso G1 G2; \<And>x. x \<in> carrier G1 \<Longrightarrow> r'(f x) = f(r x);
+ \<And>x. x \<in> carrier G1 \<Longrightarrow> r x \<in> carrier G1; group G1; group G2\<rbrakk>
+ \<Longrightarrow> \<exists>f \<in> iso G2 G1. \<forall>x \<in> carrier G2. r(f x) = f(r' x)"
+ apply (clarsimp simp add: group.iso_iff_group_isomorphisms Bex_def)
+ by (metis (full_types) group_isomorphisms_def group_isomorphisms_sym hom_in_carrier)
+
+lemma isomorphism_trans:
+ "\<lbrakk>\<exists>f \<in> iso G1 G2. \<forall>x \<in> carrier G1. r2(f x) = f(r1 x); \<exists>f \<in> iso G2 G3. \<forall>x \<in> carrier G2. r3(f x) = f(r2 x)\<rbrakk>
+ \<Longrightarrow> \<exists>f \<in> iso G1 G3. \<forall>x \<in> carrier G1. r3(f x) = f(r1 x)"
+ apply clarify
+ apply (rename_tac g f)
+ apply (rule_tac x="f \<circ> g" in bexI)
+ apply (metis iso_iff comp_apply hom_in_carrier)
+ using iso_set_trans by blast
+
+lemma reduced_homology_group_nsphere_step:
+ "\<exists>f \<in> iso(reduced_homology_group p (nsphere n))
+ (reduced_homology_group (1 + p) (nsphere (Suc n))).
+ \<forall>c \<in> carrier(reduced_homology_group p (nsphere n)).
+ hom_induced (1 + p) (nsphere(Suc n)) {} (nsphere(Suc n)) {}
+ (\<lambda>x i. if i = 0 then -x i else x i) (f c)
+ = f (hom_induced p (nsphere n) {} (nsphere n) {} (\<lambda>x i. if i = 0 then -x i else x i) c)"
+proof -
+ define r where "r \<equiv> \<lambda>x::nat\<Rightarrow>real. \<lambda>i. if i = 0 then -x i else x i"
+ have cmr: "continuous_map (nsphere n) (nsphere n) r" for n
+ unfolding r_def by (rule continuous_map_nsphere_reflection)
+ have rsub: "r ` {x. 0 \<le> x (Suc n)} \<subseteq> {x. 0 \<le> x (Suc n)}" "r ` {x. x (Suc n) \<le> 0} \<subseteq> {x. x (Suc n) \<le> 0}" "r ` {x. x (Suc n) = 0} \<subseteq> {x. x (Suc n) = 0}"
+ by (force simp: r_def)+
+ let ?sub = "subtopology (nsphere (Suc n)) {x. x (Suc n) \<ge> 0}"
+ let ?G2 = "relative_homology_group (1 + p) ?sub {x. x (Suc n) = 0}"
+ let ?r2 = "hom_induced (1 + p) ?sub {x. x (Suc n) = 0} ?sub {x. x (Suc n) = 0} r"
+ let ?j = "\<lambda>p n. hom_induced p (nsphere n) {} (nsphere n) {} r"
+ show ?thesis
+ unfolding r_def [symmetric]
+ proof (rule isomorphism_trans)
+ let ?f = "hom_boundary (1 + p) ?sub {x. x (Suc n) = 0}"
+ show "\<exists>f\<in>Group.iso (reduced_homology_group p (nsphere n)) ?G2.
+ \<forall>c\<in>carrier (reduced_homology_group p (nsphere n)). ?r2 (f c) = f (?j p n c)"
+ proof (rule isomorphism_sym)
+ show "?f \<in> Group.iso ?G2 (reduced_homology_group p (nsphere n))"
+ using iso_upper_hemisphere_reduced_homology_group
+ by (metis add.commute)
+ next
+ fix c
+ assume "c \<in> carrier ?G2"
+ have cmrs: "continuous_map ?sub ?sub r"
+ by (metis (mono_tags, lifting) IntE cmr continuous_map_from_subtopology continuous_map_in_subtopology image_subset_iff rsub(1) topspace_subtopology)
+ have "hom_induced p (nsphere n) {} (nsphere n) {} r \<circ> hom_boundary (1 + p) ?sub {x. x (Suc n) = 0}
+ = hom_boundary (1 + p) ?sub {x. x (Suc n) = 0} \<circ>
+ hom_induced (1 + p) ?sub {x. x (Suc n) = 0} ?sub {x. x (Suc n) = 0} r"
+ using naturality_hom_induced [OF cmrs rsub(3), symmetric, of "1+p", simplified]
+ by (simp add: subtopology_subtopology subtopology_nsphere_equator flip: Collect_conj_eq cong: rev_conj_cong)
+ then show "?j p n (?f c) = ?f (hom_induced (1 + p) ?sub {x. x (Suc n) = 0} ?sub {x. x (Suc n) = 0} r c)"
+ by (metis comp_def)
+ next
+ fix c
+ assume "c \<in> carrier ?G2"
+ show "hom_induced (1 + p) ?sub {x. x (Suc n) = 0} ?sub {x. x (Suc n) = 0} r c \<in> carrier ?G2"
+ using hom_induced_carrier by blast
+ qed auto
+ next
+ let ?H2 = "relative_homology_group (1 + p) (nsphere (Suc n)) {x. x (Suc n) \<le> 0}"
+ let ?s2 = "hom_induced (1 + p) (nsphere (Suc n)) {x. x (Suc n) \<le> 0} (nsphere (Suc n)) {x. x (Suc n) \<le> 0} r"
+ show "\<exists>f\<in>Group.iso ?G2 (reduced_homology_group (1 + p) (nsphere (Suc n))). \<forall>c\<in>carrier ?G2. ?j (1 + p) (Suc n) (f c)
+ = f (?r2 c)"
+ proof (rule isomorphism_trans)
+ show "\<exists>f\<in>Group.iso ?G2 ?H2.
+ \<forall>c\<in>carrier ?G2.
+ ?s2 (f c) = f (hom_induced (1 + p) ?sub {x. x (Suc n) = 0} ?sub {x. x (Suc n) = 0} r c)"
+ proof (intro ballI bexI)
+ fix c
+ assume "c \<in> carrier (relative_homology_group (1 + p) ?sub {x. x (Suc n) = 0})"
+ show "?s2 (hom_induced (1 + p) ?sub {x. x (Suc n) = 0} (nsphere (Suc n)) {x. x (Suc n) \<le> 0} id c)
+ = hom_induced (1 + p) ?sub {x. x (Suc n) = 0} (nsphere (Suc n)) {x. x (Suc n) \<le> 0} id (?r2 c)"
+ apply (simp add: rsub hom_induced_compose' Collect_mono_iff cmr)
+ apply (subst hom_induced_compose')
+ apply (simp_all add: continuous_map_in_subtopology continuous_map_from_subtopology [OF cmr] rsub)
+ apply (auto simp: r_def)
+ done
+ qed (simp add: iso_relative_homology_group_upper_hemisphere)
+ next
+ let ?h = "hom_induced (1 + p) (nsphere(Suc n)) {} (nsphere (Suc n)) {x. x(Suc n) \<le> 0} id"
+ show "\<exists>f\<in>Group.iso ?H2 (reduced_homology_group (1 + p) (nsphere (Suc n))).
+ \<forall>c\<in>carrier ?H2. ?j (1 + p) (Suc n) (f c) = f (?s2 c)"
+ proof (rule isomorphism_sym)
+ show "?h \<in> Group.iso (reduced_homology_group (1 + p) (nsphere (Suc n)))
+ (relative_homology_group (1 + p) (nsphere (Suc n)) {x. x (Suc n) \<le> 0})"
+ using iso_reduced_homology_group_lower_hemisphere by blast
+ next
+ fix c
+ assume "c \<in> carrier (reduced_homology_group (1 + p) (nsphere (Suc n)))"
+ show "?s2 (?h c) = ?h (?j (1 + p) (Suc n) c)"
+ by (simp add: hom_induced_compose' cmr rsub)
+ next
+ fix c
+ assume "c \<in> carrier (reduced_homology_group (1 + p) (nsphere (Suc n)))"
+ then show "hom_induced (1 + p) (nsphere (Suc n)) {} (nsphere (Suc n)) {} r c
+ \<in> carrier (reduced_homology_group (1 + p) (nsphere (Suc n)))"
+ by (simp add: hom_induced_reduced)
+ qed auto
+ qed
+ qed
+qed
+
+
+lemma reduced_homology_group_nsphere_aux:
+ "if p = int n then reduced_homology_group n (nsphere n) \<cong> integer_group
+ else trivial_group(reduced_homology_group p (nsphere n))"
+proof (induction n arbitrary: p)
+ case 0
+ let ?a = "\<lambda>i::nat. if i = 0 then 1 else (0::real)"
+ let ?b = "\<lambda>i::nat. if i = 0 then -1 else (0::real)"
+ have st: "subtopology (powertop_real UNIV) {?a, ?b} = nsphere 0"
+ proof -
+ have "{?a, ?b} = {x. (x 0)\<^sup>2 = 1 \<and> (\<forall>i>0. x i = 0)}"
+ using power2_eq_iff by fastforce
+ then show ?thesis
+ by (simp add: nsphere)
+ qed
+ have *: "reduced_homology_group p (subtopology (powertop_real UNIV) {?a, ?b}) \<cong>
+ homology_group p (subtopology (powertop_real UNIV) {?a})"
+ apply (rule reduced_homology_group_pair)
+ apply (simp_all add: fun_eq_iff)
+ apply (simp add: open_fun_def separation_t1 t1_space_def)
+ done
+ have "reduced_homology_group 0 (nsphere 0) \<cong> integer_group" if "p=0"
+ proof -
+ have "reduced_homology_group 0 (nsphere 0) \<cong> homology_group 0 (top_of_set {?a})" if "p=0"
+ by (metis * euclidean_product_topology st that)
+ also have "\<dots> \<cong> integer_group"
+ by (simp add: homology_coefficients)
+ finally show ?thesis
+ using that by blast
+ qed
+ moreover have "trivial_group (reduced_homology_group p (nsphere 0))" if "p\<noteq>0"
+ using * that homology_dimension_axiom [of "subtopology (powertop_real UNIV) {?a}" ?a p]
+ using isomorphic_group_triviality st by force
+ ultimately show ?case
+ by auto
+next
+ case (Suc n)
+ have eq: "reduced_homology_group (int n) (nsphere n) \<cong> integer_group" if "p-1 = n"
+ by (simp add: Suc.IH)
+ have neq: "trivial_group (reduced_homology_group (p-1) (nsphere n))" if "p-1 \<noteq> n"
+ by (simp add: Suc.IH that)
+ have iso: "reduced_homology_group p (nsphere (Suc n)) \<cong> reduced_homology_group (p-1) (nsphere n)"
+ using reduced_homology_group_nsphere_step [of "p-1" n] group.iso_sym [OF _ is_isoI] group_reduced_homology_group
+ by fastforce
+ then show ?case
+ using eq iso_trans iso isomorphic_group_triviality neq
+ by (metis (no_types, hide_lams) add.commute add_left_cancel diff_add_cancel group_reduced_homology_group of_nat_Suc)
+qed
+
+
+lemma reduced_homology_group_nsphere:
+ "reduced_homology_group n (nsphere n) \<cong> integer_group"
+ "p \<noteq> n \<Longrightarrow> trivial_group(reduced_homology_group p (nsphere n))"
+ using reduced_homology_group_nsphere_aux by auto
+
+lemma cyclic_reduced_homology_group_nsphere:
+ "cyclic_group(reduced_homology_group p (nsphere n))"
+ by (metis reduced_homology_group_nsphere trivial_imp_cyclic_group cyclic_integer_group
+ group_integer_group group_reduced_homology_group isomorphic_group_cyclicity)
+
+lemma trivial_reduced_homology_group_nsphere:
+ "trivial_group(reduced_homology_group p (nsphere n)) \<longleftrightarrow> (p \<noteq> n)"
+ using group_integer_group isomorphic_group_triviality nontrivial_integer_group reduced_homology_group_nsphere(1) reduced_homology_group_nsphere(2) trivial_group_def by blast
+
+lemma non_contractible_space_nsphere: "\<not> (contractible_space(nsphere n))"
+ proof (clarsimp simp add: contractible_eq_homotopy_equivalent_singleton_subtopology)
+ fix a :: "nat \<Rightarrow> real"
+ assume a: "a \<in> topspace (nsphere n)"
+ and he: "nsphere n homotopy_equivalent_space subtopology (nsphere n) {a}"
+ have "trivial_group (reduced_homology_group (int n) (subtopology (nsphere n) {a}))"
+ by (simp add: a homology_dimension_reduced [where a=a])
+ then show "False"
+ using isomorphic_group_triviality [OF homotopy_equivalent_space_imp_isomorphic_reduced_homology_groups [OF he, of n]]
+ by (simp add: trivial_reduced_homology_group_nsphere)
+qed
+
+
+subsection\<open>Brouwer degree of a Map\<close>
+
+definition Brouwer_degree2 :: "nat \<Rightarrow> ((nat \<Rightarrow> real) \<Rightarrow> nat \<Rightarrow> real) \<Rightarrow> int"
+ where
+ "Brouwer_degree2 p f \<equiv>
+ @d::int. \<forall>x \<in> carrier(reduced_homology_group p (nsphere p)).
+ hom_induced p (nsphere p) {} (nsphere p) {} f x = pow (reduced_homology_group p (nsphere p)) x d"
+
+lemma Brouwer_degree2_eq:
+ "(\<And>x. x \<in> topspace(nsphere p) \<Longrightarrow> f x = g x) \<Longrightarrow> Brouwer_degree2 p f = Brouwer_degree2 p g"
+ unfolding Brouwer_degree2_def Ball_def
+ apply (intro Eps_cong all_cong)
+ by (metis (mono_tags, lifting) hom_induced_eq)
+
+lemma Brouwer_degree2:
+ assumes "x \<in> carrier(reduced_homology_group p (nsphere p))"
+ shows "hom_induced p (nsphere p) {} (nsphere p) {} f x
+ = pow (reduced_homology_group p (nsphere p)) x (Brouwer_degree2 p f)"
+ (is "?h x = pow ?G x _")
+proof (cases "continuous_map(nsphere p) (nsphere p) f")
+ case True
+ interpret group ?G
+ by simp
+ interpret group_hom ?G ?G ?h
+ using hom_induced_reduced_hom group_hom_axioms_def group_hom_def is_group by blast
+ obtain a where a: "a \<in> carrier ?G"
+ and aeq: "subgroup_generated ?G {a} = ?G"
+ using cyclic_reduced_homology_group_nsphere [of p p] by (auto simp: cyclic_group_def)
+ then have carra: "carrier (subgroup_generated ?G {a}) = range (\<lambda>n::int. pow ?G a n)"
+ using carrier_subgroup_generated_by_singleton by blast
+ moreover have "?h a \<in> carrier (subgroup_generated ?G {a})"
+ by (simp add: a aeq hom_induced_reduced)
+ ultimately obtain d::int where d: "?h a = pow ?G a d"
+ by auto
+ have *: "hom_induced (int p) (nsphere p) {} (nsphere p) {} f x = x [^]\<^bsub>?G\<^esub> d"
+ if x: "x \<in> carrier ?G" for x
+ proof -
+ obtain n::int where xeq: "x = pow ?G a n"
+ using carra x aeq by moura
+ show ?thesis
+ by (simp add: xeq a d hom_int_pow int_pow_pow mult.commute)
+ qed
+ show ?thesis
+ unfolding Brouwer_degree2_def
+ apply (rule someI2 [where a=d])
+ using assms * apply blast+
+ done
+next
+ case False
+ show ?thesis
+ unfolding Brouwer_degree2_def
+ by (rule someI2 [where a=0]) (simp_all add: hom_induced_default False one_reduced_homology_group assms)
+qed
+
+
+
+lemma Brouwer_degree2_iff:
+ assumes f: "continuous_map (nsphere p) (nsphere p) f"
+ and x: "x \<in> carrier(reduced_homology_group p (nsphere p))"
+ shows "(hom_induced (int p) (nsphere p) {} (nsphere p) {} f x =
+ x [^]\<^bsub>reduced_homology_group (int p) (nsphere p)\<^esub> d)
+ \<longleftrightarrow> (x = \<one>\<^bsub>reduced_homology_group (int p) (nsphere p)\<^esub> \<or> Brouwer_degree2 p f = d)"
+ (is "(?h x = x [^]\<^bsub>?G\<^esub> d) \<longleftrightarrow> _")
+proof -
+ interpret group "?G"
+ by simp
+ obtain a where a: "a \<in> carrier ?G"
+ and aeq: "subgroup_generated ?G {a} = ?G"
+ using cyclic_reduced_homology_group_nsphere [of p p] by (auto simp: cyclic_group_def)
+ then obtain i::int where i: "x = (a [^]\<^bsub>?G\<^esub> i)"
+ using carrier_subgroup_generated_by_singleton x by fastforce
+ then have "a [^]\<^bsub>?G\<^esub> i \<in> carrier ?G"
+ using x by blast
+ have [simp]: "ord a = 0"
+ by (simp add: a aeq iso_finite [OF reduced_homology_group_nsphere(1)] flip: infinite_cyclic_subgroup_order)
+ show ?thesis
+ by (auto simp: Brouwer_degree2 int_pow_eq_id x i a int_pow_pow int_pow_eq)
+qed
+
+
+lemma Brouwer_degree2_unique:
+ assumes f: "continuous_map (nsphere p) (nsphere p) f"
+ and hi: "\<And>x. x \<in> carrier(reduced_homology_group p (nsphere p))
+ \<Longrightarrow> hom_induced p (nsphere p) {} (nsphere p) {} f x = pow (reduced_homology_group p (nsphere p)) x d"
+ (is "\<And>x. x \<in> carrier ?G \<Longrightarrow> ?h x = _")
+ shows "Brouwer_degree2 p f = d"
+proof -
+ obtain a where a: "a \<in> carrier ?G"
+ and aeq: "subgroup_generated ?G {a} = ?G"
+ using cyclic_reduced_homology_group_nsphere [of p p] by (auto simp: cyclic_group_def)
+ show ?thesis
+ using hi [OF a]
+ apply (simp add: Brouwer_degree2 a)
+ by (metis Brouwer_degree2_iff a aeq f group.trivial_group_subgroup_generated group_reduced_homology_group subsetI trivial_reduced_homology_group_nsphere)
+qed
+
+lemma Brouwer_degree2_unique_generator:
+ assumes f: "continuous_map (nsphere p) (nsphere p) f"
+ and eq: "subgroup_generated (reduced_homology_group p (nsphere p)) {a}
+ = reduced_homology_group p (nsphere p)"
+ and hi: "hom_induced p (nsphere p) {} (nsphere p) {} f a = pow (reduced_homology_group p (nsphere p)) a d"
+ (is "?h a = pow ?G a _")
+ shows "Brouwer_degree2 p f = d"
+proof (cases "a \<in> carrier ?G")
+ case True
+ then show ?thesis
+ by (metis Brouwer_degree2_iff hi eq f group.trivial_group_subgroup_generated group_reduced_homology_group
+ subset_singleton_iff trivial_reduced_homology_group_nsphere)
+next
+ case False
+ then show ?thesis
+ using trivial_reduced_homology_group_nsphere [of p p]
+ by (metis group.trivial_group_subgroup_generated_eq disjoint_insert(1) eq group_reduced_homology_group inf_bot_right subset_singleton_iff)
+qed
+
+lemma Brouwer_degree2_homotopic:
+ assumes "homotopic_with (\<lambda>x. True) (nsphere p) (nsphere p) f g"
+ shows "Brouwer_degree2 p f = Brouwer_degree2 p g"
+proof -
+ have "continuous_map (nsphere p) (nsphere p) f"
+ using homotopic_with_imp_continuous_maps [OF assms] by auto
+ show ?thesis
+ using Brouwer_degree2_def assms homology_homotopy_empty by fastforce
+qed
+
+lemma Brouwer_degree2_id [simp]: "Brouwer_degree2 p id = 1"
+proof (rule Brouwer_degree2_unique)
+ fix x
+ assume x: "x \<in> carrier (reduced_homology_group (int p) (nsphere p))"
+ then have "x \<in> carrier (homology_group (int p) (nsphere p))"
+ using carrier_reduced_homology_group_subset by blast
+ then show "hom_induced (int p) (nsphere p) {} (nsphere p) {} id x =
+ x [^]\<^bsub>reduced_homology_group (int p) (nsphere p)\<^esub> (1::int)"
+ by (simp add: hom_induced_id group.int_pow_1 x)
+qed auto
+
+lemma Brouwer_degree2_compose:
+ assumes f: "continuous_map (nsphere p) (nsphere p) f" and g: "continuous_map (nsphere p) (nsphere p) g"
+ shows "Brouwer_degree2 p (g \<circ> f) = Brouwer_degree2 p g * Brouwer_degree2 p f"
+proof (rule Brouwer_degree2_unique)
+ show "continuous_map (nsphere p) (nsphere p) (g \<circ> f)"
+ by (meson continuous_map_compose f g)
+next
+ fix x
+ assume x: "x \<in> carrier (reduced_homology_group (int p) (nsphere p))"
+ have "hom_induced (int p) (nsphere p) {} (nsphere p) {} (g \<circ> f) =
+ hom_induced (int p) (nsphere p) {} (nsphere p) {} g \<circ>
+ hom_induced (int p) (nsphere p) {} (nsphere p) {} f"
+ by (blast intro: hom_induced_compose [OF f _ g])
+ with x show "hom_induced (int p) (nsphere p) {} (nsphere p) {} (g \<circ> f) x =
+ x [^]\<^bsub>reduced_homology_group (int p) (nsphere p)\<^esub> (Brouwer_degree2 p g * Brouwer_degree2 p f)"
+ by (simp add: mult.commute hom_induced_reduced flip: Brouwer_degree2 group.int_pow_pow)
+qed
+
+lemma Brouwer_degree2_homotopy_equivalence:
+ assumes f: "continuous_map (nsphere p) (nsphere p) f" and g: "continuous_map (nsphere p) (nsphere p) g"
+ and hom: "homotopic_with (\<lambda>x. True) (nsphere p) (nsphere p) (f \<circ> g) id"
+ obtains "\<bar>Brouwer_degree2 p f\<bar> = 1" "\<bar>Brouwer_degree2 p g\<bar> = 1" "Brouwer_degree2 p g = Brouwer_degree2 p f"
+ using Brouwer_degree2_homotopic [OF hom] Brouwer_degree2_compose f g zmult_eq_1_iff by auto
+
+lemma Brouwer_degree2_homeomorphic_maps:
+ assumes "homeomorphic_maps (nsphere p) (nsphere p) f g"
+ obtains "\<bar>Brouwer_degree2 p f\<bar> = 1" "\<bar>Brouwer_degree2 p g\<bar> = 1" "Brouwer_degree2 p g = Brouwer_degree2 p f"
+ using assms
+ by (auto simp: homeomorphic_maps_def homotopic_with_equal continuous_map_compose intro: Brouwer_degree2_homotopy_equivalence)
+
+
+lemma Brouwer_degree2_retraction_map:
+ assumes "retraction_map (nsphere p) (nsphere p) f"
+ shows "\<bar>Brouwer_degree2 p f\<bar> = 1"
+proof -
+ obtain g where g: "retraction_maps (nsphere p) (nsphere p) f g"
+ using assms by (auto simp: retraction_map_def)
+ show ?thesis
+ proof (rule Brouwer_degree2_homotopy_equivalence)
+ show "homotopic_with (\<lambda>x. True) (nsphere p) (nsphere p) (f \<circ> g) id"
+ using g apply (auto simp: retraction_maps_def)
+ by (simp add: homotopic_with_equal continuous_map_compose)
+ show "continuous_map (nsphere p) (nsphere p) f" "continuous_map (nsphere p) (nsphere p) g"
+ using g retraction_maps_def by blast+
+ qed
+qed
+
+lemma Brouwer_degree2_section_map:
+ assumes "section_map (nsphere p) (nsphere p) f"
+ shows "\<bar>Brouwer_degree2 p f\<bar> = 1"
+proof -
+ obtain g where g: "retraction_maps (nsphere p) (nsphere p) g f"
+ using assms by (auto simp: section_map_def)
+ show ?thesis
+ proof (rule Brouwer_degree2_homotopy_equivalence)
+ show "homotopic_with (\<lambda>x. True) (nsphere p) (nsphere p) (g \<circ> f) id"
+ using g apply (auto simp: retraction_maps_def)
+ by (simp add: homotopic_with_equal continuous_map_compose)
+ show "continuous_map (nsphere p) (nsphere p) g" "continuous_map (nsphere p) (nsphere p) f"
+ using g retraction_maps_def by blast+
+ qed
+qed
+
+lemma Brouwer_degree2_homeomorphic_map:
+ "homeomorphic_map (nsphere p) (nsphere p) f \<Longrightarrow> \<bar>Brouwer_degree2 p f\<bar> = 1"
+ using Brouwer_degree2_retraction_map section_and_retraction_eq_homeomorphic_map by blast
+
+
+lemma Brouwer_degree2_nullhomotopic:
+ assumes "homotopic_with (\<lambda>x. True) (nsphere p) (nsphere p) f (\<lambda>x. a)"
+ shows "Brouwer_degree2 p f = 0"
+proof -
+ have contf: "continuous_map (nsphere p) (nsphere p) f"
+ and contc: "continuous_map (nsphere p) (nsphere p) (\<lambda>x. a)"
+ using homotopic_with_imp_continuous_maps [OF assms] by metis+
+ have "Brouwer_degree2 p f = Brouwer_degree2 p (\<lambda>x. a)"
+ using Brouwer_degree2_homotopic [OF assms] .
+ moreover
+ let ?G = "reduced_homology_group (int p) (nsphere p)"
+ interpret group ?G
+ by simp
+ have "Brouwer_degree2 p (\<lambda>x. a) = 0"
+ proof (rule Brouwer_degree2_unique [OF contc])
+ fix c
+ assume c: "c \<in> carrier ?G"
+ have "continuous_map (nsphere p) (subtopology (nsphere p) {a}) (\<lambda>f. a)"
+ using contc continuous_map_in_subtopology by blast
+ then have he: "hom_induced p (nsphere p) {} (nsphere p) {} (\<lambda>x. a)
+ = hom_induced p (subtopology (nsphere p) {a}) {} (nsphere p) {} id \<circ>
+ hom_induced p (nsphere p) {} (subtopology (nsphere p) {a}) {} (\<lambda>x. a)"
+ by (metis continuous_map_id_subt hom_induced_compose id_comp image_empty order_refl)
+ have 1: "hom_induced p (nsphere p) {} (subtopology (nsphere p) {a}) {} (\<lambda>x. a) c =
+ \<one>\<^bsub>reduced_homology_group (int p) (subtopology (nsphere p) {a})\<^esub>"
+ using c trivial_reduced_homology_group_contractible_space [of "subtopology (nsphere p) {a}" p]
+ by (simp add: hom_induced_reduced contractible_space_subtopology_singleton trivial_group_subset group.trivial_group_subset subset_iff)
+ show "hom_induced (int p) (nsphere p) {} (nsphere p) {} (\<lambda>x. a) c =
+ c [^]\<^bsub>?G\<^esub> (0::int)"
+ apply (simp add: he 1)
+ using hom_induced_reduced_hom group_hom.hom_one group_hom_axioms_def group_hom_def group_reduced_homology_group by blast
+ qed
+ ultimately show ?thesis
+ by metis
+qed
+
+
+lemma Brouwer_degree2_const: "Brouwer_degree2 p (\<lambda>x. a) = 0"
+proof (cases "continuous_map(nsphere p) (nsphere p) (\<lambda>x. a)")
+ case True
+ then show ?thesis
+ by (auto intro: Brouwer_degree2_nullhomotopic [where a=a])
+next
+ case False
+ let ?G = "reduced_homology_group (int p) (nsphere p)"
+ let ?H = "homology_group (int p) (nsphere p)"
+ interpret group ?G
+ by simp
+ have eq1: "\<one>\<^bsub>?H\<^esub> = \<one>\<^bsub>?G\<^esub>"
+ by (simp add: one_reduced_homology_group)
+ have *: "\<forall>x\<in>carrier ?G. hom_induced (int p) (nsphere p) {} (nsphere p) {} (\<lambda>x. a) x = \<one>\<^bsub>?H\<^esub>"
+ by (metis False hom_induced_default one_relative_homology_group)
+ obtain c where c: "c \<in> carrier ?G" and ceq: "subgroup_generated ?G {c} = ?G"
+ using cyclic_reduced_homology_group_nsphere [of p p] by (force simp: cyclic_group_def)
+ have [simp]: "ord c = 0"
+ by (simp add: c ceq iso_finite [OF reduced_homology_group_nsphere(1)] flip: infinite_cyclic_subgroup_order)
+ show ?thesis
+ unfolding Brouwer_degree2_def
+ proof (rule some_equality)
+ fix d :: "int"
+ assume "\<forall>x\<in>carrier ?G. hom_induced (int p) (nsphere p) {} (nsphere p) {} (\<lambda>x. a) x = x [^]\<^bsub>?G\<^esub> d"
+ then have "c [^]\<^bsub>?G\<^esub> d = \<one>\<^bsub>?H\<^esub>"
+ using "*" c by blast
+ then have "int (ord c) dvd d"
+ using c eq1 int_pow_eq_id by auto
+ then show "d = 0"
+ by (simp add: * del: one_relative_homology_group)
+ qed (use "*" eq1 in force)
+qed
+
+
+corollary Brouwer_degree2_nonsurjective:
+ "\<lbrakk>continuous_map(nsphere p) (nsphere p) f; f ` topspace (nsphere p) \<noteq> topspace (nsphere p)\<rbrakk>
+ \<Longrightarrow> Brouwer_degree2 p f = 0"
+ by (meson Brouwer_degree2_nullhomotopic nullhomotopic_nonsurjective_sphere_map)
+
+
+proposition Brouwer_degree2_reflection:
+ "Brouwer_degree2 p (\<lambda>x i. if i = 0 then -x i else x i) = -1" (is "Brouwer_degree2 _ ?r = -1")
+proof (induction p)
+ case 0
+ let ?G = "homology_group 0 (nsphere 0)"
+ let ?D = "homology_group 0 (discrete_topology {()})"
+ interpret group ?G
+ by simp
+ define r where "r \<equiv> \<lambda>x::nat\<Rightarrow>real. \<lambda>i. if i = 0 then -x i else x i"
+ then have [simp]: "r \<circ> r = id"
+ by force
+ have cmr: "continuous_map (nsphere 0) (nsphere 0) r"
+ by (simp add: r_def continuous_map_nsphere_reflection)
+ have *: "hom_induced 0 (nsphere 0) {} (nsphere 0) {} r c = inv\<^bsub>?G\<^esub> c"
+ if "c \<in> carrier(reduced_homology_group 0 (nsphere 0))" for c
+ proof -
+ have c: "c \<in> carrier ?G"
+ and ceq: "hom_induced 0 (nsphere 0) {} (discrete_topology {()}) {} (\<lambda>x. ()) c = \<one>\<^bsub>?D\<^esub>"
+ using that by (auto simp: carrier_reduced_homology_group kernel_def)
+ define pp::"nat\<Rightarrow>real" where "pp \<equiv> \<lambda>i. if i = 0 then 1 else 0"
+ define nn::"nat\<Rightarrow>real" where "nn \<equiv> \<lambda>i. if i = 0 then -1 else 0"
+ have topn0: "topspace(nsphere 0) = {pp,nn}"
+ by (auto simp: nsphere pp_def nn_def fun_eq_iff power2_eq_1_iff split: if_split_asm)
+ have "t1_space (nsphere 0)"
+ unfolding nsphere
+ apply (rule t1_space_subtopology)
+ by (metis (full_types) open_fun_def t1_space t1_space_def)
+ then have dtn0: "discrete_topology {pp,nn} = nsphere 0"
+ using finite_t1_space_imp_discrete_topology [OF topn0] by auto
+ have "pp \<noteq> nn"
+ by (auto simp: pp_def nn_def fun_eq_iff)
+ have [simp]: "r pp = nn" "r nn = pp"
+ by (auto simp: r_def pp_def nn_def fun_eq_iff)
+ have iso: "(\<lambda>(a,b). hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} id a
+ \<otimes>\<^bsub>?G\<^esub> hom_induced 0 (subtopology (nsphere 0) {nn}) {} (nsphere 0) {} id b)
+ \<in> iso (homology_group 0 (subtopology (nsphere 0) {pp}) \<times>\<times> homology_group 0 (subtopology (nsphere 0) {nn}))
+ ?G" (is "?f \<in> iso (?P \<times>\<times> ?N) ?G")
+ apply (rule homology_additivity_explicit)
+ using dtn0 \<open>pp \<noteq> nn\<close> by (auto simp: discrete_topology_unique)
+ then have fim: "?f ` carrier(?P \<times>\<times> ?N) = carrier ?G"
+ by (simp add: iso_def bij_betw_def)
+ obtain d d' where d: "d \<in> carrier ?P" and d': "d' \<in> carrier ?N" and eqc: "?f(d,d') = c"
+ using c by (force simp flip: fim)
+ let ?h = "\<lambda>xx. hom_induced 0 (subtopology (nsphere 0) {xx}) {} (discrete_topology {()}) {} (\<lambda>x. ())"
+ have "retraction_map (subtopology (nsphere 0) {pp}) (subtopology (nsphere 0) {nn}) r"
+ apply (simp add: retraction_map_def retraction_maps_def continuous_map_in_subtopology continuous_map_from_subtopology cmr image_subset_iff)
+ apply (rule_tac x=r in exI)
+ apply (force simp: retraction_map_def retraction_maps_def continuous_map_in_subtopology continuous_map_from_subtopology cmr)
+ done
+ then have "carrier ?N = (hom_induced 0 (subtopology (nsphere 0) {pp}) {} (subtopology (nsphere 0) {nn}) {} r) ` carrier ?P"
+ by (rule surj_hom_induced_retraction_map)
+ then obtain e where e: "e \<in> carrier ?P" and eqd': "hom_induced 0 (subtopology (nsphere 0) {pp}) {} (subtopology (nsphere 0) {nn}) {} r e = d'"
+ using d' by auto
+ have "section_map (subtopology (nsphere 0) {pp}) (discrete_topology {()}) (\<lambda>x. ())"
+ by (force simp: section_map_def retraction_maps_def topn0)
+ then have "?h pp \<in> mon ?P ?D"
+ by (rule mon_hom_induced_section_map)
+ then have one: "x = one ?P"
+ if "?h pp x = \<one>\<^bsub>?D\<^esub>" "x \<in> carrier ?P" for x
+ using that by (simp add: mon_iff_hom_one)
+ interpret hpd: group_hom ?P ?D "?h pp"
+ using hom_induced_empty_hom by (simp add: hom_induced_empty_hom group_hom_axioms_def group_hom_def)
+ interpret hgd: group_hom ?G ?D "hom_induced 0 (nsphere 0) {} (discrete_topology {()}) {} (\<lambda>x. ())"
+ using hom_induced_empty_hom by (simp add: hom_induced_empty_hom group_hom_axioms_def group_hom_def)
+ interpret hpg: group_hom ?P ?G "hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} r"
+ using hom_induced_empty_hom by (simp add: hom_induced_empty_hom group_hom_axioms_def group_hom_def)
+ interpret hgg: group_hom ?G ?G "hom_induced 0 (nsphere 0) {} (nsphere 0) {} r"
+ using hom_induced_empty_hom by (simp add: hom_induced_empty_hom group_hom_axioms_def group_hom_def)
+ have "?h pp d =
+ (hom_induced 0 (nsphere 0) {} (discrete_topology {()}) {} (\<lambda>x. ())
+ \<circ> hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} id) d"
+ by (simp flip: hom_induced_compose_empty)
+ moreover
+ have "?h pp = ?h nn \<circ> hom_induced 0 (subtopology (nsphere 0) {pp}) {} (subtopology (nsphere 0) {nn}) {} r"
+ by (simp add: cmr continuous_map_from_subtopology continuous_map_in_subtopology image_subset_iff flip: hom_induced_compose_empty)
+ then have "?h pp e =
+ (hom_induced 0 (nsphere 0) {} (discrete_topology {()}) {} (\<lambda>x. ())
+ \<circ> hom_induced 0 (subtopology (nsphere 0) {nn}) {} (nsphere 0) {} id) d'"
+ by (simp flip: hom_induced_compose_empty eqd')
+ ultimately have "?h pp (d \<otimes>\<^bsub>?P\<^esub> e) = hom_induced 0 (nsphere 0) {} (discrete_topology {()}) {} (\<lambda>x. ()) (?f(d,d'))"
+ by (simp add: d e hom_induced_carrier)
+ then have "?h pp (d \<otimes>\<^bsub>?P\<^esub> e) = \<one>\<^bsub>?D\<^esub>"
+ using ceq eqc by simp
+ then have inv_p: "inv\<^bsub>?P\<^esub> d = e"
+ by (metis (no_types, lifting) Group.group_def d e group.inv_equality group.r_inv group_relative_homology_group one monoid.m_closed)
+ have cmr_pn: "continuous_map (subtopology (nsphere 0) {pp}) (subtopology (nsphere 0) {nn}) r"
+ by (simp add: cmr continuous_map_from_subtopology continuous_map_in_subtopology image_subset_iff)
+ then have "hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} (id \<circ> r) =
+ hom_induced 0 (subtopology (nsphere 0) {nn}) {} (nsphere 0) {} id \<circ>
+ hom_induced 0 (subtopology (nsphere 0) {pp}) {} (subtopology (nsphere 0) {nn}) {} r"
+ using hom_induced_compose_empty continuous_map_id_subt by blast
+ then have "inv\<^bsub>?G\<^esub> hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} r d =
+ hom_induced 0 (subtopology (nsphere 0) {nn}) {} (nsphere 0) {} id d'"
+ apply (simp add: flip: inv_p eqd')
+ using d hpg.hom_inv by auto
+ then have c: "c = (hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} id d)
+ \<otimes>\<^bsub>?G\<^esub> inv\<^bsub>?G\<^esub> (hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} r d)"
+ by (simp flip: eqc)
+ have "hom_induced 0 (nsphere 0) {} (nsphere 0) {} r \<circ>
+ hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} id =
+ hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} r"
+ by (metis cmr comp_id continuous_map_id_subt hom_induced_compose_empty)
+ moreover
+ have "hom_induced 0 (nsphere 0) {} (nsphere 0) {} r \<circ>
+ hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} r =
+ hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} id"
+ by (metis \<open>r \<circ> r = id\<close> cmr continuous_map_from_subtopology hom_induced_compose_empty)
+ ultimately show ?thesis
+ by (metis inv_p c comp_def d e hgg.hom_inv hgg.hom_mult hom_induced_carrier hpd.G.inv_inv hpg.hom_inv inv_mult_group)
+ qed
+ show ?case
+ unfolding r_def [symmetric]
+ using Brouwer_degree2_unique [OF cmr]
+ by (auto simp: * group.int_pow_neg group.int_pow_1 reduced_homology_group_def intro!: Brouwer_degree2_unique [OF cmr])
+next
+ case (Suc p)
+ let ?G = "reduced_homology_group (int p) (nsphere p)"
+ let ?G1 = "reduced_homology_group (1 + int p) (nsphere (Suc p))"
+ obtain f g where fg: "group_isomorphisms ?G ?G1 f g"
+ and *: "\<forall>c\<in>carrier ?G.
+ hom_induced (1 + int p) (nsphere (Suc p)) {} (nsphere (Suc p)) {} ?r (f c) =
+ f (hom_induced p (nsphere p) {} (nsphere p) {} ?r c)"
+ using reduced_homology_group_nsphere_step
+ by (meson group.iso_iff_group_isomorphisms group_reduced_homology_group)
+ then have eq: "carrier ?G1 = f ` carrier ?G"
+ by (fastforce simp add: iso_iff dest: group_isomorphisms_imp_iso)
+ interpret group_hom ?G ?G1 f
+ by (meson fg group_hom_axioms_def group_hom_def group_isomorphisms_def group_reduced_homology_group)
+ have homf: "f \<in> hom ?G ?G1"
+ using fg group_isomorphisms_def by blast
+ have "hom_induced (1 + int p) (nsphere (Suc p)) {} (nsphere (Suc p)) {} ?r (f y) = f y [^]\<^bsub>?G1\<^esub> (-1::int)"
+ if "y \<in> carrier ?G" for y
+ by (simp add: that * Brouwer_degree2 Suc hom_int_pow)
+ then show ?case
+ by (fastforce simp: eq intro: Brouwer_degree2_unique [OF continuous_map_nsphere_reflection])
+qed
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Homology/Homology.thy Wed Apr 10 15:45:16 2019 +0200
@@ -0,0 +1,5 @@
+theory Homology
+ imports Brouwer_Degree
+begin
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Homology/Homology_Groups.thy Wed Apr 10 15:45:16 2019 +0200
@@ -0,0 +1,2569 @@
+section\<open>Homology, II: Homology Groups\<close>
+
+theory Homology_Groups
+ imports Simplices "HOL-Algebra.Exact_Sequence"
+
+begin
+subsection\<open>Homology Groups\<close>
+
+text\<open>Now actually connect to group theory and set up homology groups. Note that we define homomogy
+groups for all \emph{integers} @{term p}, since this seems to avoid some special-case reasoning,
+though they are trivial for @{term"p < 0"}.\<close>
+
+definition chain_group :: "nat \<Rightarrow> 'a topology \<Rightarrow> 'a chain monoid"
+ where "chain_group p X \<equiv> free_Abelian_group (singular_simplex_set p X)"
+
+lemma carrier_chain_group [simp]: "carrier(chain_group p X) = singular_chain_set p X"
+ by (auto simp: chain_group_def singular_chain_def free_Abelian_group_def)
+
+lemma one_chain_group [simp]: "one(chain_group p X) = 0"
+ by (auto simp: chain_group_def free_Abelian_group_def)
+
+lemma mult_chain_group [simp]: "monoid.mult(chain_group p X) = (+)"
+ by (auto simp: chain_group_def free_Abelian_group_def)
+
+lemma m_inv_chain_group [simp]: "Poly_Mapping.keys a \<subseteq> singular_simplex_set p X \<Longrightarrow> inv\<^bsub>chain_group p X\<^esub> a = -a"
+ unfolding chain_group_def by simp
+
+lemma group_chain_group [simp]: "Group.group (chain_group p X)"
+ by (simp add: chain_group_def)
+
+lemma abelian_chain_group: "comm_group(chain_group p X)"
+ by (simp add: free_Abelian_group_def group.group_comm_groupI [OF group_chain_group])
+
+lemma subgroup_singular_relcycle:
+ "subgroup (singular_relcycle_set p X S) (chain_group p X)"
+proof
+ show "x \<otimes>\<^bsub>chain_group p X\<^esub> y \<in> singular_relcycle_set p X S"
+ if "x \<in> singular_relcycle_set p X S" and "y \<in> singular_relcycle_set p X S" for x y
+ using that by (simp add: singular_relcycle_add)
+next
+ show "inv\<^bsub>chain_group p X\<^esub> x \<in> singular_relcycle_set p X S"
+ if "x \<in> singular_relcycle_set p X S" for x
+ using that
+ by clarsimp (metis m_inv_chain_group singular_chain_def singular_relcycle singular_relcycle_minus)
+qed (auto simp: singular_relcycle)
+
+
+definition relcycle_group :: "nat \<Rightarrow> 'a topology \<Rightarrow> 'a set \<Rightarrow> ('a chain) monoid"
+ where "relcycle_group p X S \<equiv>
+ subgroup_generated (chain_group p X) (Collect(singular_relcycle p X S))"
+
+lemma carrier_relcycle_group [simp]:
+ "carrier (relcycle_group p X S) = singular_relcycle_set p X S"
+proof -
+ have "carrier (chain_group p X) \<inter> singular_relcycle_set p X S = singular_relcycle_set p X S"
+ using subgroup.subset subgroup_singular_relcycle by blast
+ moreover have "generate (chain_group p X) (singular_relcycle_set p X S) \<subseteq> singular_relcycle_set p X S"
+ by (simp add: group.generate_subgroup_incl group_chain_group subgroup_singular_relcycle)
+ ultimately show ?thesis
+ by (auto simp: relcycle_group_def subgroup_generated_def generate.incl)
+qed
+
+lemma one_relcycle_group [simp]: "one(relcycle_group p X S) = 0"
+ by (simp add: relcycle_group_def)
+
+lemma mult_relcycle_group [simp]: "(\<otimes>\<^bsub>relcycle_group p X S\<^esub>) = (+)"
+ by (simp add: relcycle_group_def)
+
+lemma abelian_relcycle_group [simp]:
+ "comm_group(relcycle_group p X S)"
+ unfolding relcycle_group_def
+ by (intro group.abelian_subgroup_generated group_chain_group) (auto simp: abelian_chain_group singular_relcycle)
+
+lemma group_relcycle_group [simp]: "group(relcycle_group p X S)"
+ by (simp add: comm_group.axioms(2))
+
+lemma relcycle_group_restrict [simp]:
+ "relcycle_group p X (topspace X \<inter> S) = relcycle_group p X S"
+ by (metis relcycle_group_def singular_relcycle_restrict)
+
+
+definition relative_homology_group :: "int \<Rightarrow> 'a topology \<Rightarrow> 'a set \<Rightarrow> ('a chain) set monoid"
+ where
+ "relative_homology_group p X S \<equiv>
+ if p < 0 then singleton_group undefined else
+ (relcycle_group (nat p) X S) Mod (singular_relboundary_set (nat p) X S)"
+
+abbreviation homology_group
+ where "homology_group p X \<equiv> relative_homology_group p X {}"
+
+lemma relative_homology_group_restrict [simp]:
+ "relative_homology_group p X (topspace X \<inter> S) = relative_homology_group p X S"
+ by (simp add: relative_homology_group_def)
+
+lemma nontrivial_relative_homology_group:
+ fixes p::nat
+ shows "relative_homology_group p X S
+ = relcycle_group p X S Mod singular_relboundary_set p X S"
+ by (simp add: relative_homology_group_def)
+
+lemma singular_relboundary_ss:
+ "singular_relboundary p X S x \<Longrightarrow> Poly_Mapping.keys x \<subseteq> singular_simplex_set p X"
+ using singular_chain_def singular_relboundary_imp_chain by blast
+
+lemma trivial_relative_homology_group [simp]:
+ "p < 0 \<Longrightarrow> trivial_group(relative_homology_group p X S)"
+ by (simp add: relative_homology_group_def)
+
+lemma subgroup_singular_relboundary:
+ "subgroup (singular_relboundary_set p X S) (chain_group p X)"
+ unfolding chain_group_def
+proof unfold_locales
+ show "singular_relboundary_set p X S
+ \<subseteq> carrier (free_Abelian_group (singular_simplex_set p X))"
+ using singular_chain_def singular_relboundary_imp_chain by fastforce
+next
+ fix x
+ assume "x \<in> singular_relboundary_set p X S"
+ then show "inv\<^bsub>free_Abelian_group (singular_simplex_set p X)\<^esub> x
+ \<in> singular_relboundary_set p X S"
+ by (simp add: singular_relboundary_ss singular_relboundary_minus)
+qed (auto simp: free_Abelian_group_def singular_relboundary_add)
+
+lemma subgroup_singular_relboundary_relcycle:
+ "subgroup (singular_relboundary_set p X S) (relcycle_group p X S)"
+ unfolding relcycle_group_def
+ apply (rule group.subgroup_of_subgroup_generated)
+ by (auto simp: singular_relcycle subgroup_singular_relboundary intro: singular_relboundary_imp_relcycle)
+
+lemma normal_subgroup_singular_relboundary_relcycle:
+ "(singular_relboundary_set p X S) \<lhd> (relcycle_group p X S)"
+ by (simp add: comm_group.normal_iff_subgroup subgroup_singular_relboundary_relcycle)
+
+lemma group_relative_homology_group [simp]:
+ "group (relative_homology_group p X S)"
+ by (simp add: relative_homology_group_def normal.factorgroup_is_group
+ normal_subgroup_singular_relboundary_relcycle)
+
+lemma right_coset_singular_relboundary:
+ "r_coset (relcycle_group p X S) (singular_relboundary_set p X S)
+ = (\<lambda>a. {b. homologous_rel p X S a b})"
+ using singular_relboundary_minus
+ by (force simp: r_coset_def homologous_rel_def relcycle_group_def subgroup_generated_def)
+
+lemma carrier_relative_homology_group:
+ "carrier(relative_homology_group (int p) X S)
+ = (homologous_rel_set p X S) ` singular_relcycle_set p X S"
+ by (auto simp: set_eq_iff image_iff relative_homology_group_def FactGroup_def RCOSETS_def right_coset_singular_relboundary)
+
+lemma carrier_relative_homology_group_0:
+ "carrier(relative_homology_group 0 X S)
+ = (homologous_rel_set 0 X S) ` singular_relcycle_set 0 X S"
+ using carrier_relative_homology_group [of 0 X S] by simp
+
+lemma one_relative_homology_group [simp]:
+ "one(relative_homology_group (int p) X S) = singular_relboundary_set p X S"
+ by (simp add: relative_homology_group_def FactGroup_def)
+
+lemma mult_relative_homology_group:
+ "(\<otimes>\<^bsub>relative_homology_group (int p) X S\<^esub>) = (\<lambda>R S. (\<Union>r\<in>R. \<Union>s\<in>S. {r + s}))"
+ unfolding relcycle_group_def subgroup_generated_def chain_group_def free_Abelian_group_def set_mult_def relative_homology_group_def FactGroup_def
+ by force
+
+lemma inv_relative_homology_group:
+ assumes "R \<in> carrier (relative_homology_group (int p) X S)"
+ shows "m_inv(relative_homology_group (int p) X S) R = uminus ` R"
+proof (rule group.inv_equality [OF group_relative_homology_group _ assms])
+ obtain c where c: "R = homologous_rel_set p X S c" "singular_relcycle p X S c"
+ using assms by (auto simp: carrier_relative_homology_group)
+ have "singular_relboundary p X S (b - a)"
+ if "a \<in> R" and "b \<in> R" for a b
+ using c that
+ by clarify (metis homologous_rel_def homologous_rel_eq)
+ moreover
+ have "x \<in> (\<Union>x\<in>R. \<Union>y\<in>R. {y - x})"
+ if "singular_relboundary p X S x" for x
+ using c
+ by simp (metis diff_eq_eq homologous_rel_def homologous_rel_refl homologous_rel_sym that)
+ ultimately
+ have "(\<Union>x\<in>R. \<Union>xa\<in>R. {xa - x}) = singular_relboundary_set p X S"
+ by auto
+ then show "uminus ` R \<otimes>\<^bsub>relative_homology_group (int p) X S\<^esub> R =
+ \<one>\<^bsub>relative_homology_group (int p) X S\<^esub>"
+ by (auto simp: carrier_relative_homology_group mult_relative_homology_group)
+ have "singular_relcycle p X S (-c)"
+ using c by (simp add: singular_relcycle_minus)
+ moreover have "homologous_rel p X S c x \<Longrightarrow> homologous_rel p X S (-c) (- x)" for x
+ by (metis homologous_rel_def homologous_rel_sym minus_diff_eq minus_diff_minus)
+ moreover have "homologous_rel p X S (-c) x \<Longrightarrow> x \<in> uminus ` homologous_rel_set p X S c" for x
+ by (clarsimp simp: image_iff) (metis add.inverse_inverse diff_0 homologous_rel_diff homologous_rel_refl)
+ ultimately show "uminus ` R \<in> carrier (relative_homology_group (int p) X S)"
+ using c by (auto simp: carrier_relative_homology_group)
+qed
+
+lemma homologous_rel_eq_relboundary:
+ "homologous_rel p X S c = singular_relboundary p X S
+ \<longleftrightarrow> singular_relboundary p X S c" (is "?lhs = ?rhs")
+proof
+ assume ?lhs
+ then show ?rhs
+ unfolding homologous_rel_def
+ by (metis diff_zero singular_relboundary_0)
+next
+ assume R: ?rhs
+ show ?lhs
+ unfolding homologous_rel_def
+ using singular_relboundary_diff R by fastforce
+qed
+
+lemma homologous_rel_set_eq_relboundary:
+ "homologous_rel_set p X S c = singular_relboundary_set p X S \<longleftrightarrow> singular_relboundary p X S c"
+ by (auto simp flip: homologous_rel_eq_relboundary)
+
+text\<open>Lift the boundary and induced maps to homology groups. We totalize both
+ quite aggressively to the appropriate group identity in all "undefined"
+ situations, which makes several of the properties cleaner and simpler.\<close>
+
+lemma homomorphism_chain_boundary:
+ "chain_boundary p \<in> hom (relcycle_group p X S) (relcycle_group(p - Suc 0) (subtopology X S) {})"
+ (is "?h \<in> hom ?G ?H")
+proof (rule homI)
+ show "\<And>x. x \<in> carrier ?G \<Longrightarrow> ?h x \<in> carrier ?H"
+ by (auto simp: singular_relcycle_def mod_subset_def chain_boundary_boundary)
+qed (simp add: relcycle_group_def subgroup_generated_def chain_boundary_add)
+
+
+lemma hom_boundary1:
+ "\<exists>d. \<forall>p X S.
+ d p X S \<in> hom (relative_homology_group (int p) X S)
+ (homology_group (int (p - Suc 0)) (subtopology X S))
+ \<and> (\<forall>c. singular_relcycle p X S c
+ \<longrightarrow> d p X S (homologous_rel_set p X S c)
+ = homologous_rel_set (p - Suc 0) (subtopology X S) {} (chain_boundary p c))"
+ (is "\<exists>d. \<forall>p X S. ?\<Phi> (d p X S) p X S")
+proof ((subst choice_iff [symmetric])+, clarify)
+ fix p X and S :: "'a set"
+ define \<theta> where "\<theta> \<equiv> r_coset (relcycle_group(p - Suc 0) (subtopology X S) {})
+ (singular_relboundary_set (p - Suc 0) (subtopology X S) {}) \<circ> chain_boundary p"
+ define H where "H \<equiv> relative_homology_group (int (p - Suc 0)) (subtopology X S) {}"
+ define J where "J \<equiv> relcycle_group (p - Suc 0) (subtopology X S) {}"
+
+ have \<theta>: "\<theta> \<in> hom (relcycle_group p X S) H"
+ unfolding \<theta>_def
+ proof (rule hom_compose)
+ show "chain_boundary p \<in> hom (relcycle_group p X S) J"
+ by (simp add: J_def homomorphism_chain_boundary)
+ show "(#>\<^bsub>relcycle_group (p - Suc 0) (subtopology X S) {}\<^esub>)
+ (singular_relboundary_set (p - Suc 0) (subtopology X S) {}) \<in> hom J H"
+ by (simp add: H_def J_def nontrivial_relative_homology_group
+ normal.r_coset_hom_Mod normal_subgroup_singular_relboundary_relcycle)
+ qed
+ have *: "singular_relboundary (p - Suc 0) (subtopology X S) {} (chain_boundary p c)"
+ if "singular_relboundary p X S c" for c
+ proof (cases "p=0")
+ case True
+ then show ?thesis
+ by (metis chain_boundary_def singular_relboundary_0)
+ next
+ case False
+ with that have "\<exists>d. singular_chain p (subtopology X S) d \<and> chain_boundary p d = chain_boundary p c"
+ by (metis add.left_neutral chain_boundary_add chain_boundary_boundary_alt singular_relboundary)
+ with that False show ?thesis
+ by (auto simp: singular_boundary)
+ qed
+ have \<theta>_eq: "\<theta> x = \<theta> y"
+ if x: "x \<in> singular_relcycle_set p X S" and y: "y \<in> singular_relcycle_set p X S"
+ and eq: "singular_relboundary_set p X S #>\<^bsub>relcycle_group p X S\<^esub> x
+ = singular_relboundary_set p X S #>\<^bsub>relcycle_group p X S\<^esub> y" for x y
+ proof -
+ have "singular_relboundary p X S (x-y)"
+ by (metis eq homologous_rel_def homologous_rel_eq mem_Collect_eq right_coset_singular_relboundary)
+ with * have "(singular_relboundary (p - Suc 0) (subtopology X S) {}) (chain_boundary p (x-y))"
+ by blast
+ then show ?thesis
+ unfolding \<theta>_def comp_def
+ by (metis chain_boundary_diff homologous_rel_def homologous_rel_eq right_coset_singular_relboundary)
+qed
+ obtain d
+ where "d \<in> hom ((relcycle_group p X S) Mod (singular_relboundary_set p X S)) H"
+ and d: "\<And>u. u \<in> singular_relcycle_set p X S \<Longrightarrow> d (homologous_rel_set p X S u) = \<theta> u"
+ by (metis FactGroup_universal [OF \<theta> normal_subgroup_singular_relboundary_relcycle \<theta>_eq] right_coset_singular_relboundary carrier_relcycle_group)
+ then have "d \<in> hom (relative_homology_group p X S) H"
+ by (simp add: nontrivial_relative_homology_group)
+ then show "\<exists>d. ?\<Phi> d p X S"
+ by (force simp: H_def right_coset_singular_relboundary d \<theta>_def)
+qed
+
+lemma hom_boundary2:
+ "\<exists>d. (\<forall>p X S.
+ (d p X S) \<in> hom (relative_homology_group p X S)
+ (homology_group (p - 1) (subtopology X S)))
+ \<and> (\<forall>p X S c. singular_relcycle p X S c \<and> Suc 0 \<le> p
+ \<longrightarrow> d p X S (homologous_rel_set p X S c)
+ = homologous_rel_set (p - Suc 0) (subtopology X S) {} (chain_boundary p c))"
+ (is "\<exists>d. ?\<Phi> d")
+proof -
+ have *: "\<exists>f. \<Phi>(\<lambda>p. if p \<le> 0 then \<lambda>q r t. undefined else f(nat p)) \<Longrightarrow> \<exists>f. \<Phi> f" for \<Phi>
+ by blast
+ show ?thesis
+ apply (rule * [OF ex_forward [OF hom_boundary1]])
+ apply (simp add: not_le relative_homology_group_def nat_diff_distrib' int_eq_iff nat_diff_distrib flip: nat_1)
+ by (simp add: hom_def singleton_group_def)
+qed
+
+lemma hom_boundary3:
+ "\<exists>d. ((\<forall>p X S c. c \<notin> carrier(relative_homology_group p X S)
+ \<longrightarrow> d p X S c = one(homology_group (p-1) (subtopology X S))) \<and>
+ (\<forall>p X S.
+ d p X S \<in> hom (relative_homology_group p X S)
+ (homology_group (p-1) (subtopology X S))) \<and>
+ (\<forall>p X S c.
+ singular_relcycle p X S c \<and> 1 \<le> p
+ \<longrightarrow> d p X S (homologous_rel_set p X S c)
+ = homologous_rel_set (p - Suc 0) (subtopology X S) {} (chain_boundary p c)) \<and>
+ (\<forall>p X S. d p X S = d p X (topspace X \<inter> S))) \<and>
+ (\<forall>p X S c. d p X S c \<in> carrier(homology_group (p-1) (subtopology X S))) \<and>
+ (\<forall>p. p \<le> 0 \<longrightarrow> d p = (\<lambda>q r t. undefined))"
+ (is "\<exists>x. ?P x \<and> ?Q x \<and> ?R x")
+proof -
+ have "\<And>x. ?Q x \<Longrightarrow> ?R x"
+ by (erule all_forward) (force simp: relative_homology_group_def)
+ moreover have "\<exists>x. ?P x \<and> ?Q x"
+ proof -
+ obtain d:: "[int, 'a topology, 'a set, ('a chain) set] \<Rightarrow> ('a chain) set"
+ where 1: "\<And>p X S. d p X S \<in> hom (relative_homology_group p X S)
+ (homology_group (p - 1) (subtopology X S))"
+ and 2: "\<And>n X S c. singular_relcycle n X S c \<and> Suc 0 \<le> n
+ \<Longrightarrow> d n X S (homologous_rel_set n X S c)
+ = homologous_rel_set (n - Suc 0) (subtopology X S) {} (chain_boundary n c)"
+ using hom_boundary2 by blast
+ have 4: "c \<in> carrier (relative_homology_group p X S) \<Longrightarrow>
+ d p X (topspace X \<inter> S) c \<in> carrier (relative_homology_group (p-1) (subtopology X S) {})"
+ for p X S c
+ using hom_carrier [OF 1 [of p X "topspace X \<inter> S"]]
+ by (simp add: image_subset_iff subtopology_restrict)
+ show ?thesis
+ apply (rule_tac x="\<lambda>p X S c.
+ if c \<in> carrier(relative_homology_group p X S)
+ then d p X (topspace X \<inter> S) c
+ else one(homology_group (p - 1) (subtopology X S))" in exI)
+ apply (simp add: Int_left_absorb subtopology_restrict carrier_relative_homology_group
+ group.is_monoid group.restrict_hom_iff 4 cong: if_cong)
+ apply (rule conjI)
+ apply (metis 1 relative_homology_group_restrict subtopology_restrict)
+ apply (metis 2 homologous_rel_restrict singular_relcycle_def subtopology_restrict)
+ done
+ qed
+ ultimately show ?thesis
+ by auto
+qed
+
+
+consts hom_boundary :: "[int,'a topology,'a set,'a chain set] \<Rightarrow> 'a chain set"
+specification (hom_boundary)
+ hom_boundary:
+ "((\<forall>p X S c. c \<notin> carrier(relative_homology_group p X S)
+ \<longrightarrow> hom_boundary p X S c = one(homology_group (p-1) (subtopology X (S::'a set)))) \<and>
+ (\<forall>p X S.
+ hom_boundary p X S \<in> hom (relative_homology_group p X S)
+ (homology_group (p-1) (subtopology X (S::'a set)))) \<and>
+ (\<forall>p X S c.
+ singular_relcycle p X S c \<and> 1 \<le> p
+ \<longrightarrow> hom_boundary p X S (homologous_rel_set p X S c)
+ = homologous_rel_set (p - Suc 0) (subtopology X (S::'a set)) {} (chain_boundary p c)) \<and>
+ (\<forall>p X S. hom_boundary p X S = hom_boundary p X (topspace X \<inter> (S::'a set)))) \<and>
+ (\<forall>p X S c. hom_boundary p X S c \<in> carrier(homology_group (p-1) (subtopology X (S::'a set)))) \<and>
+ (\<forall>p. p \<le> 0 \<longrightarrow> hom_boundary p = (\<lambda>q r. \<lambda>t::'a chain set. undefined))"
+ by (fact hom_boundary3)
+
+lemma hom_boundary_default:
+ "c \<notin> carrier(relative_homology_group p X S)
+ \<Longrightarrow> hom_boundary p X S c = one(homology_group (p-1) (subtopology X S))"
+ and hom_boundary_hom: "hom_boundary p X S \<in> hom (relative_homology_group p X S) (homology_group (p-1) (subtopology X S))"
+ and hom_boundary_restrict [simp]: "hom_boundary p X (topspace X \<inter> S) = hom_boundary p X S"
+ and hom_boundary_carrier: "hom_boundary p X S c \<in> carrier(homology_group (p-1) (subtopology X S))"
+ and hom_boundary_trivial: "p \<le> 0 \<Longrightarrow> hom_boundary p = (\<lambda>q r t. undefined)"
+ by (metis hom_boundary)+
+
+lemma hom_boundary_chain_boundary:
+ "\<lbrakk>singular_relcycle p X S c; 1 \<le> p\<rbrakk>
+ \<Longrightarrow> hom_boundary (int p) X S (homologous_rel_set p X S c) =
+ homologous_rel_set (p - Suc 0) (subtopology X S) {} (chain_boundary p c)"
+ by (metis hom_boundary)+
+
+lemma hom_chain_map:
+ "\<lbrakk>continuous_map X Y f; f ` S \<subseteq> T\<rbrakk>
+ \<Longrightarrow> (chain_map p f) \<in> hom (relcycle_group p X S) (relcycle_group p Y T)"
+ by (force simp: chain_map_add singular_relcycle_chain_map hom_def)
+
+
+lemma hom_induced1:
+ "\<exists>hom_relmap.
+ (\<forall>p X S Y T f.
+ continuous_map X Y f \<and> f ` (topspace X \<inter> S) \<subseteq> T
+ \<longrightarrow> (hom_relmap p X S Y T f) \<in> hom (relative_homology_group (int p) X S)
+ (relative_homology_group (int p) Y T)) \<and>
+ (\<forall>p X S Y T f c.
+ continuous_map X Y f \<and> f ` (topspace X \<inter> S) \<subseteq> T \<and>
+ singular_relcycle p X S c
+ \<longrightarrow> hom_relmap p X S Y T f (homologous_rel_set p X S c) =
+ homologous_rel_set p Y T (chain_map p f c))"
+proof -
+ have "\<exists>y. (y \<in> hom (relative_homology_group (int p) X S) (relative_homology_group (int p) Y T)) \<and>
+ (\<forall>c. singular_relcycle p X S c \<longrightarrow>
+ y (homologous_rel_set p X S c) = homologous_rel_set p Y T (chain_map p f c))"
+ if contf: "continuous_map X Y f" and fim: "f ` (topspace X \<inter> S) \<subseteq> T"
+ for p X S Y T and f :: "'a \<Rightarrow> 'b"
+ proof -
+ let ?f = "(#>\<^bsub>relcycle_group p Y T\<^esub>) (singular_relboundary_set p Y T) \<circ> chain_map p f"
+ let ?F = "\<lambda>x. singular_relboundary_set p X S #>\<^bsub>relcycle_group p X S\<^esub> x"
+ have 1: "?f \<in> hom (relcycle_group p X S) (relative_homology_group (int p) Y T)"
+ apply (rule hom_compose [where H = "relcycle_group p Y T"])
+ apply (metis contf fim hom_chain_map relcycle_group_restrict)
+ by (simp add: nontrivial_relative_homology_group normal.r_coset_hom_Mod normal_subgroup_singular_relboundary_relcycle)
+ have 2: "singular_relboundary_set p X S \<lhd> relcycle_group p X S"
+ using normal_subgroup_singular_relboundary_relcycle by blast
+ have 3: "?f x = ?f y"
+ if "singular_relcycle p X S x" "singular_relcycle p X S y" "?F x = ?F y" for x y
+ proof -
+ have "singular_relboundary p Y T (chain_map p f (x - y))"
+ apply (rule singular_relboundary_chain_map [OF _ contf fim])
+ by (metis homologous_rel_def homologous_rel_eq mem_Collect_eq right_coset_singular_relboundary singular_relboundary_restrict that(3))
+ then have "singular_relboundary p Y T (chain_map p f x - chain_map p f y)"
+ by (simp add: chain_map_diff)
+ with that
+ show ?thesis
+ apply (simp add: right_coset_singular_relboundary homologous_rel_set_eq)
+ apply (simp add: homologous_rel_def)
+ done
+ qed
+ obtain g where "g \<in> hom (relcycle_group p X S Mod singular_relboundary_set p X S)
+ (relative_homology_group (int p) Y T)"
+ "\<And>x. x \<in> singular_relcycle_set p X S \<Longrightarrow> g (?F x) = ?f x"
+ using FactGroup_universal [OF 1 2 3, unfolded carrier_relcycle_group] by blast
+ then show ?thesis
+ by (force simp: right_coset_singular_relboundary nontrivial_relative_homology_group)
+ qed
+ then show ?thesis
+ apply (simp flip: all_conj_distrib)
+ apply ((subst choice_iff [symmetric])+)
+ apply metis
+ done
+qed
+
+lemma hom_induced2:
+ "\<exists>hom_relmap.
+ (\<forall>p X S Y T f.
+ continuous_map X Y f \<and>
+ f ` (topspace X \<inter> S) \<subseteq> T
+ \<longrightarrow> (hom_relmap p X S Y T f) \<in> hom (relative_homology_group p X S)
+ (relative_homology_group p Y T)) \<and>
+ (\<forall>p X S Y T f c.
+ continuous_map X Y f \<and>
+ f ` (topspace X \<inter> S) \<subseteq> T \<and>
+ singular_relcycle p X S c
+ \<longrightarrow> hom_relmap p X S Y T f (homologous_rel_set p X S c) =
+ homologous_rel_set p Y T (chain_map p f c)) \<and>
+ (\<forall>p. p < 0 \<longrightarrow> hom_relmap p = (\<lambda>X S Y T f c. undefined))"
+ (is "\<exists>d. ?\<Phi> d")
+proof -
+ have *: "\<exists>f. \<Phi>(\<lambda>p. if p < 0 then \<lambda>X S Y T f c. undefined else f(nat p)) \<Longrightarrow> \<exists>f. \<Phi> f" for \<Phi>
+ by blast
+ show ?thesis
+ apply (rule * [OF ex_forward [OF hom_induced1]])
+ apply (simp add: not_le relative_homology_group_def nat_diff_distrib' int_eq_iff nat_diff_distrib flip: nat_1)
+ done
+qed
+
+lemma hom_induced3:
+ "\<exists>hom_relmap.
+ ((\<forall>p X S Y T f c.
+ ~(continuous_map X Y f \<and> f ` (topspace X \<inter> S) \<subseteq> T \<and>
+ c \<in> carrier(relative_homology_group p X S))
+ \<longrightarrow> hom_relmap p X S Y T f c = one(relative_homology_group p Y T)) \<and>
+ (\<forall>p X S Y T f.
+ hom_relmap p X S Y T f \<in> hom (relative_homology_group p X S) (relative_homology_group p Y T)) \<and>
+ (\<forall>p X S Y T f c.
+ continuous_map X Y f \<and> f ` (topspace X \<inter> S) \<subseteq> T \<and> singular_relcycle p X S c
+ \<longrightarrow> hom_relmap p X S Y T f (homologous_rel_set p X S c) =
+ homologous_rel_set p Y T (chain_map p f c)) \<and>
+ (\<forall>p X S Y T.
+ hom_relmap p X S Y T =
+ hom_relmap p X (topspace X \<inter> S) Y (topspace Y \<inter> T))) \<and>
+ (\<forall>p X S Y f T c.
+ hom_relmap p X S Y T f c \<in> carrier(relative_homology_group p Y T)) \<and>
+ (\<forall>p. p < 0 \<longrightarrow> hom_relmap p = (\<lambda>X S Y T f c. undefined))"
+ (is "\<exists>x. ?P x \<and> ?Q x \<and> ?R x")
+proof -
+ have "\<And>x. ?Q x \<Longrightarrow> ?R x"
+ by (erule all_forward) (fastforce simp: relative_homology_group_def)
+ moreover have "\<exists>x. ?P x \<and> ?Q x"
+ proof -
+ obtain hom_relmap:: "[int,'a topology,'a set,'b topology,'b set,'a \<Rightarrow> 'b,('a chain) set] \<Rightarrow> ('b chain) set"
+ where 1: "\<And>p X S Y T f. \<lbrakk>continuous_map X Y f; f ` (topspace X \<inter> S) \<subseteq> T\<rbrakk> \<Longrightarrow>
+ hom_relmap p X S Y T f
+ \<in> hom (relative_homology_group p X S) (relative_homology_group p Y T)"
+ and 2: "\<And>p X S Y T f c.
+ \<lbrakk>continuous_map X Y f; f ` (topspace X \<inter> S) \<subseteq> T; singular_relcycle p X S c\<rbrakk>
+ \<Longrightarrow>
+ hom_relmap (int p) X S Y T f (homologous_rel_set p X S c) =
+ homologous_rel_set p Y T (chain_map p f c)"
+ and 3: "(\<forall>p. p < 0 \<longrightarrow> hom_relmap p = (\<lambda>X S Y T f c. undefined))"
+ using hom_induced2 [where ?'a='a and ?'b='b]
+ apply clarify
+ apply (rule_tac hom_relmap=hom_relmap in that, auto)
+ done
+ have 4: "\<lbrakk>continuous_map X Y f; f ` (topspace X \<inter> S) \<subseteq> T; c \<in> carrier (relative_homology_group p X S)\<rbrakk> \<Longrightarrow>
+ hom_relmap p X (topspace X \<inter> S) Y (topspace Y \<inter> T) f c
+ \<in> carrier (relative_homology_group p Y T)"
+ for p X S Y f T c
+ using hom_carrier [OF 1 [of X Y f "topspace X \<inter> S" "topspace Y \<inter> T" p]]
+ by (simp add: image_subset_iff subtopology_restrict continuous_map_def)
+ have inhom: "(\<lambda>c. if continuous_map X Y f \<and> f ` (topspace X \<inter> S) \<subseteq> T \<and>
+ c \<in> carrier (relative_homology_group p X S)
+ then hom_relmap p X (topspace X \<inter> S) Y (topspace Y \<inter> T) f c
+ else \<one>\<^bsub>relative_homology_group p Y T\<^esub>)
+ \<in> hom (relative_homology_group p X S) (relative_homology_group p Y T)" (is "?h \<in> hom ?GX ?GY")
+ for p X S Y T f
+ proof (rule homI)
+ show "\<And>x. x \<in> carrier ?GX \<Longrightarrow> ?h x \<in> carrier ?GY"
+ by (auto simp: 4 group.is_monoid)
+ show "?h (x \<otimes>\<^bsub>?GX\<^esub> y) = ?h x \<otimes>\<^bsub>?GY\<^esub>?h y" if "x \<in> carrier ?GX" "y \<in> carrier ?GX" for x y
+ proof (cases "p < 0")
+ case True
+ with that show ?thesis
+ by (simp add: relative_homology_group_def singleton_group_def 3)
+ next
+ case False
+ show ?thesis
+ proof (cases "continuous_map X Y f")
+ case True
+ then have "f ` (topspace X \<inter> S) \<subseteq> topspace Y"
+ by (meson IntE continuous_map_def image_subsetI)
+ then show ?thesis
+ using True False that
+ using 1 [of X Y f "topspace X \<inter> S" "topspace Y \<inter> T" p]
+ by (simp add: 4 continuous_map_image_subset_topspace hom_mult not_less group.is_monoid monoid.m_closed Int_left_absorb)
+ qed (simp add: group.is_monoid)
+ qed
+ qed
+ have hrel: "\<lbrakk>continuous_map X Y f; f ` (topspace X \<inter> S) \<subseteq> T; singular_relcycle p X S c\<rbrakk>
+ \<Longrightarrow> hom_relmap (int p) X (topspace X \<inter> S) Y (topspace Y \<inter> T)
+ f (homologous_rel_set p X S c) = homologous_rel_set p Y T (chain_map p f c)"
+ for p X S Y T f c
+ using 2 [of X Y f "topspace X \<inter> S" "topspace Y \<inter> T" p c]
+ by simp (meson IntE continuous_map_def image_subsetI)
+ show ?thesis
+ apply (rule_tac x="\<lambda>p X S Y T f c.
+ if continuous_map X Y f \<and> f ` (topspace X \<inter> S) \<subseteq> T \<and>
+ c \<in> carrier(relative_homology_group p X S)
+ then hom_relmap p X (topspace X \<inter> S) Y (topspace Y \<inter> T) f c
+ else one(relative_homology_group p Y T)" in exI)
+ apply (simp add: Int_left_absorb subtopology_restrict carrier_relative_homology_group
+ group.is_monoid group.restrict_hom_iff 4 inhom hrel cong: if_cong)
+ apply (force simp: continuous_map_def intro!: ext)
+ done
+ qed
+ ultimately show ?thesis
+ by auto
+qed
+
+
+consts hom_induced:: "[int,'a topology,'a set,'b topology,'b set,'a \<Rightarrow> 'b,('a chain) set] \<Rightarrow> ('b chain) set"
+specification (hom_induced)
+ hom_induced:
+ "((\<forall>p X S Y T f c.
+ ~(continuous_map X Y f \<and>
+ f ` (topspace X \<inter> S) \<subseteq> T \<and>
+ c \<in> carrier(relative_homology_group p X S))
+ \<longrightarrow> hom_induced p X (S::'a set) Y (T::'b set) f c =
+ one(relative_homology_group p Y T)) \<and>
+ (\<forall>p X S Y T f.
+ (hom_induced p X (S::'a set) Y (T::'b set) f) \<in> hom (relative_homology_group p X S)
+ (relative_homology_group p Y T)) \<and>
+ (\<forall>p X S Y T f c.
+ continuous_map X Y f \<and>
+ f ` (topspace X \<inter> S) \<subseteq> T \<and>
+ singular_relcycle p X S c
+ \<longrightarrow> hom_induced p X (S::'a set) Y (T::'b set) f (homologous_rel_set p X S c) =
+ homologous_rel_set p Y T (chain_map p f c)) \<and>
+ (\<forall>p X S Y T.
+ hom_induced p X (S::'a set) Y (T::'b set) =
+ hom_induced p X (topspace X \<inter> S) Y (topspace Y \<inter> T))) \<and>
+ (\<forall>p X S Y f T c.
+ hom_induced p X (S::'a set) Y (T::'b set) f c \<in>
+ carrier(relative_homology_group p Y T)) \<and>
+ (\<forall>p. p < 0 \<longrightarrow> hom_induced p = (\<lambda>X S Y T. \<lambda>f::'a\<Rightarrow>'b. \<lambda>c. undefined))"
+ by (fact hom_induced3)
+
+lemma hom_induced_default:
+ "~(continuous_map X Y f \<and> f ` (topspace X \<inter> S) \<subseteq> T \<and> c \<in> carrier(relative_homology_group p X S))
+ \<Longrightarrow> hom_induced p X S Y T f c = one(relative_homology_group p Y T)"
+ and hom_induced_hom:
+ "hom_induced p X S Y T f \<in> hom (relative_homology_group p X S) (relative_homology_group p Y T)"
+ and hom_induced_restrict [simp]:
+ "hom_induced p X (topspace X \<inter> S) Y (topspace Y \<inter> T) = hom_induced p X S Y T"
+ and hom_induced_carrier:
+ "hom_induced p X S Y T f c \<in> carrier(relative_homology_group p Y T)"
+ and hom_induced_trivial: "p < 0 \<Longrightarrow> hom_induced p = (\<lambda>X S Y T f c. undefined)"
+ by (metis hom_induced)+
+
+lemma hom_induced_chain_map_gen:
+ "\<lbrakk>continuous_map X Y f; f ` (topspace X \<inter> S) \<subseteq> T; singular_relcycle p X S c\<rbrakk>
+ \<Longrightarrow> hom_induced p X S Y T f (homologous_rel_set p X S c) = homologous_rel_set p Y T (chain_map p f c)"
+ by (metis hom_induced)
+
+lemma hom_induced_chain_map:
+ "\<lbrakk>continuous_map X Y f; f ` S \<subseteq> T; singular_relcycle p X S c\<rbrakk>
+ \<Longrightarrow> hom_induced p X S Y T f (homologous_rel_set p X S c)
+ = homologous_rel_set p Y T (chain_map p f c)"
+ by (meson Int_lower2 hom_induced image_subsetI image_subset_iff subset_iff)
+
+
+lemma hom_induced_eq:
+ assumes "\<And>x. x \<in> topspace X \<Longrightarrow> f x = g x"
+ shows "hom_induced p X S Y T f = hom_induced p X S Y T g"
+proof -
+ consider "p < 0" | n where "p = int n"
+ by (metis int_nat_eq not_less)
+ then show ?thesis
+ proof cases
+ case 1
+ then show ?thesis
+ by (simp add: hom_induced_trivial)
+ next
+ case 2
+ have "hom_induced n X S Y T f C = hom_induced n X S Y T g C" for C
+ proof -
+ have "continuous_map X Y f \<and> f ` (topspace X \<inter> S) \<subseteq> T \<and> C \<in> carrier (relative_homology_group n X S)
+ \<longleftrightarrow> continuous_map X Y g \<and> g ` (topspace X \<inter> S) \<subseteq> T \<and> C \<in> carrier (relative_homology_group n X S)"
+ (is "?P = ?Q")
+ by (metis IntD1 assms continuous_map_eq image_cong)
+ then consider "\<not> ?P \<and> \<not> ?Q" | "?P \<and> ?Q"
+ by blast
+ then show ?thesis
+ proof cases
+ case 1
+ then show ?thesis
+ by (simp add: hom_induced_default)
+ next
+ case 2
+ have "homologous_rel_set n Y T (chain_map n f c) = homologous_rel_set n Y T (chain_map n g c)"
+ if "continuous_map X Y f" "f ` (topspace X \<inter> S) \<subseteq> T"
+ "continuous_map X Y g" "g ` (topspace X \<inter> S) \<subseteq> T"
+ "C = homologous_rel_set n X S c" "singular_relcycle n X S c"
+ for c
+ proof -
+ have "chain_map n f c = chain_map n g c"
+ using assms chain_map_eq singular_relcycle that by blast
+ then show ?thesis
+ by simp
+ qed
+ with 2 show ?thesis
+ by (auto simp: relative_homology_group_def carrier_FactGroup
+ right_coset_singular_relboundary hom_induced_chain_map_gen)
+ qed
+ qed
+ with 2 show ?thesis
+ by auto
+ qed
+qed
+
+
+subsection\<open>Towards the Eilenberg-Steenrod axioms\<close>
+
+text\<open>First prove we get functors into abelian groups with the boundary map
+ being a natural transformation between them, and prove Eilenberg-Steenrod
+ axioms (we also prove additivity a bit later on if one counts that). \<close>
+(*1. Exact sequence from the inclusions and boundary map
+ H_{p+1} X --(j')\<longlongrightarrow> H_{p+1}X (A) --(d')\<longlongrightarrow> H_p A --(i')\<longlongrightarrow> H_p X
+ 2. Dimension axiom: H_p X is trivial for one-point X and p =/= 0
+ 3. Homotopy invariance of the induced map
+ 4. Excision: inclusion (X - U,A - U) --(i')\<longlongrightarrow> X (A) induces an isomorphism
+when cl U \<subseteq> int A*)
+
+
+lemma abelian_relative_homology_group [simp]:
+ "comm_group(relative_homology_group p X S)"
+ apply (simp add: relative_homology_group_def)
+ apply (metis comm_group.abelian_FactGroup abelian_relcycle_group subgroup_singular_relboundary_relcycle)
+ done
+
+lemma abelian_homology_group: "comm_group(homology_group p X)"
+ by simp
+
+
+lemma hom_induced_id_gen:
+ assumes contf: "continuous_map X X f" and feq: "\<And>x. x \<in> topspace X \<Longrightarrow> f x = x"
+ and c: "c \<in> carrier (relative_homology_group p X S)"
+ shows "hom_induced p X S X S f c = c"
+proof -
+ consider "p < 0" | n where "p = int n"
+ by (metis int_nat_eq not_less)
+ then show ?thesis
+ proof cases
+ case 1
+ with c show ?thesis
+ by (simp add: hom_induced_trivial relative_homology_group_def)
+ next
+ case 2
+ have cm: "chain_map n f d = d" if "singular_relcycle n X S d" for d
+ using that assms by (auto simp: chain_map_id_gen singular_relcycle)
+ have "f ` (topspace X \<inter> S) \<subseteq> S"
+ using feq by auto
+ with 2 c show ?thesis
+ by (auto simp: nontrivial_relative_homology_group carrier_FactGroup
+ cm right_coset_singular_relboundary hom_induced_chain_map_gen assms)
+ qed
+qed
+
+
+lemma hom_induced_id:
+ "c \<in> carrier (relative_homology_group p X S) \<Longrightarrow> hom_induced p X S X S id c = c"
+ by (rule hom_induced_id_gen) auto
+
+lemma hom_induced_compose:
+ assumes "continuous_map X Y f" "f ` S \<subseteq> T" "continuous_map Y Z g" "g ` T \<subseteq> U"
+ shows "hom_induced p X S Z U (g \<circ> f) = hom_induced p Y T Z U g \<circ> hom_induced p X S Y T f"
+proof -
+ consider (neg) "p < 0" | (int) n where "p = int n"
+ by (metis int_nat_eq not_less)
+ then show ?thesis
+ proof cases
+ case int
+ have gf: "continuous_map X Z (g \<circ> f)"
+ using assms continuous_map_compose by fastforce
+ have gfim: "(g \<circ> f) ` S \<subseteq> U"
+ unfolding o_def using assms by blast
+ have sr: "\<And>a. singular_relcycle n X S a \<Longrightarrow> singular_relcycle n Y T (chain_map n f a)"
+ by (simp add: assms singular_relcycle_chain_map)
+ show ?thesis
+ proof
+ fix c
+ show "hom_induced p X S Z U (g \<circ> f) c = (hom_induced p Y T Z U g \<circ> hom_induced p X S Y T f) c"
+ proof (cases "c \<in> carrier(relative_homology_group p X S)")
+ case True
+ with gfim show ?thesis
+ unfolding int
+ by (auto simp: carrier_relative_homology_group gf gfim assms sr chain_map_compose hom_induced_chain_map)
+ next
+ case False
+ then show ?thesis
+ by (simp add: hom_induced_default hom_one [OF hom_induced_hom])
+ qed
+ qed
+ qed (force simp: hom_induced_trivial)
+qed
+
+lemma hom_induced_compose':
+ assumes "continuous_map X Y f" "f ` S \<subseteq> T" "continuous_map Y Z g" "g ` T \<subseteq> U"
+ shows "hom_induced p Y T Z U g (hom_induced p X S Y T f x) = hom_induced p X S Z U (g \<circ> f) x"
+ using hom_induced_compose [OF assms] by simp
+
+lemma naturality_hom_induced:
+ assumes "continuous_map X Y f" "f ` S \<subseteq> T"
+ shows "hom_boundary q Y T \<circ> hom_induced q X S Y T f
+ = hom_induced (q - 1) (subtopology X S) {} (subtopology Y T) {} f \<circ> hom_boundary q X S"
+proof (cases "q \<le> 0")
+ case False
+ then obtain p where p1: "p \<ge> Suc 0" and q: "q = int p"
+ using zero_le_imp_eq_int by force
+ show ?thesis
+ proof
+ fix c
+ show "(hom_boundary q Y T \<circ> hom_induced q X S Y T f) c =
+ (hom_induced (q - 1) (subtopology X S) {} (subtopology Y T) {} f \<circ> hom_boundary q X S) c"
+ proof (cases "c \<in> carrier(relative_homology_group p X S)")
+ case True
+ then obtain a where ceq: "c = homologous_rel_set p X S a" and a: "singular_relcycle p X S a"
+ by (force simp: carrier_relative_homology_group)
+ then have sr: "singular_relcycle p Y T (chain_map p f a)"
+ using assms singular_relcycle_chain_map by fastforce
+ then have sb: "singular_relcycle (p - Suc 0) (subtopology X S) {} (chain_boundary p a)"
+ by (metis One_nat_def a chain_boundary_boundary singular_chain_0 singular_relcycle)
+ have p1_eq: "int p - 1 = int (p - Suc 0)"
+ using p1 by auto
+ have cbm: "(chain_boundary p (chain_map p f a))
+ = (chain_map (p - Suc 0) f (chain_boundary p a))"
+ using a chain_boundary_chain_map singular_relcycle by blast
+ have contf: "continuous_map (subtopology X S) (subtopology Y T) f"
+ using assms
+ by (auto simp: continuous_map_in_subtopology topspace_subtopology
+ continuous_map_from_subtopology)
+ show ?thesis
+ unfolding q using assms p1 a
+ apply (simp add: ceq assms hom_induced_chain_map hom_boundary_chain_boundary
+ hom_boundary_chain_boundary [OF sr] singular_relcycle_def mod_subset_def)
+ apply (simp add: p1_eq contf sb cbm hom_induced_chain_map)
+ done
+ next
+ case False
+ with assms show ?thesis
+ unfolding q o_def using assms
+ apply (simp add: hom_induced_default hom_boundary_default)
+ by (metis group_relative_homology_group hom_boundary hom_induced hom_one one_relative_homology_group)
+ qed
+ qed
+qed (force simp: hom_induced_trivial hom_boundary_trivial)
+
+
+
+lemma homology_exactness_axiom_1:
+ "exact_seq ([homology_group (p-1) (subtopology X S), relative_homology_group p X S, homology_group p X],
+ [hom_boundary p X S,hom_induced p X {} X S id])"
+proof -
+ consider (neg) "p < 0" | (int) n where "p = int n"
+ by (metis int_nat_eq not_less)
+ then have "(hom_induced p X {} X S id) ` carrier (homology_group p X)
+ = kernel (relative_homology_group p X S) (homology_group (p-1) (subtopology X S))
+ (hom_boundary p X S)"
+ proof cases
+ case neg
+ then show ?thesis
+ unfolding kernel_def singleton_group_def relative_homology_group_def
+ by (auto simp: hom_induced_trivial hom_boundary_trivial)
+ next
+ case int
+ have "hom_induced (int m) X {} X S id ` carrier (relative_homology_group (int m) X {})
+ = carrier (relative_homology_group (int m) X S) \<inter>
+ {c. hom_boundary (int m) X S c = \<one>\<^bsub>relative_homology_group (int m - 1) (subtopology X S) {}\<^esub>}" for m
+ proof (cases m)
+ case 0
+ have "hom_induced 0 X {} X S id ` carrier (relative_homology_group 0 X {})
+ = carrier (relative_homology_group 0 X S)" (is "?lhs = ?rhs")
+ proof
+ show "?lhs \<subseteq> ?rhs"
+ using hom_induced_hom [of 0 X "{}" X S id]
+ by (simp add: hom_induced_hom hom_carrier)
+ show "?rhs \<subseteq> ?lhs"
+ apply (clarsimp simp add: image_iff carrier_relative_homology_group [of 0, simplified] singular_relcycle)
+ apply (force simp: chain_map_id_gen chain_boundary_def singular_relcycle
+ hom_induced_chain_map [of concl: 0, simplified])
+ done
+ qed
+ with 0 show ?thesis
+ by (simp add: hom_boundary_trivial relative_homology_group_def [of "-1"] singleton_group_def)
+ next
+ case (Suc n)
+ have "(hom_induced (int (Suc n)) X {} X S id \<circ>
+ homologous_rel_set (Suc n) X {}) ` singular_relcycle_set (Suc n) X {}
+ = homologous_rel_set (Suc n) X S `
+ (singular_relcycle_set (Suc n) X S \<inter>
+ {c. hom_boundary (int (Suc n)) X S (homologous_rel_set (Suc n) X S c)
+ = singular_relboundary_set n (subtopology X S) {}})"
+ (is "?lhs = ?rhs")
+ proof -
+ have 1: "(\<And>x. x \<in> A \<Longrightarrow> x \<in> B \<longleftrightarrow> x \<in> C) \<Longrightarrow> f ` (A \<inter> B) = f ` (A \<inter> C)" for f A B C
+ by blast
+ have 2: "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> \<exists>y. y \<in> B \<and> f x = f y; \<And>x. x \<in> B \<Longrightarrow> \<exists>y. y \<in> A \<and> f x = f y\<rbrakk>
+ \<Longrightarrow> f ` A = f ` B" for f A B
+ by blast
+ have "?lhs = homologous_rel_set (Suc n) X S ` singular_relcycle_set (Suc n) X {}"
+ apply (rule image_cong [OF refl])
+ apply (simp add: o_def hom_induced_chain_map chain_map_ident [of _ X] singular_relcycle
+ del: of_nat_Suc)
+ done
+ also have "\<dots> = homologous_rel_set (Suc n) X S `
+ (singular_relcycle_set (Suc n) X S \<inter>
+ {c. singular_relboundary n (subtopology X S) {} (chain_boundary (Suc n) c)})"
+ proof (rule 2)
+ fix c
+ assume "c \<in> singular_relcycle_set (Suc n) X {}"
+ then show "\<exists>y. y \<in> singular_relcycle_set (Suc n) X S \<inter>
+ {c. singular_relboundary n (subtopology X S) {} (chain_boundary (Suc n) c)} \<and>
+ homologous_rel_set (Suc n) X S c = homologous_rel_set (Suc n) X S y"
+ apply (rule_tac x=c in exI)
+ by (simp add: singular_boundary) (metis chain_boundary_0 singular_cycle singular_relcycle singular_relcycle_0)
+ next
+ fix c
+ assume c: "c \<in> singular_relcycle_set (Suc n) X S \<inter>
+ {c. singular_relboundary n (subtopology X S) {} (chain_boundary (Suc n) c)}"
+ then obtain d where d: "singular_chain (Suc n) (subtopology X S) d"
+ "chain_boundary (Suc n) d = chain_boundary (Suc n) c"
+ by (auto simp: singular_boundary)
+ with c have "c - d \<in> singular_relcycle_set (Suc n) X {}"
+ by (auto simp: singular_cycle chain_boundary_diff singular_chain_subtopology singular_relcycle singular_chain_diff)
+ moreover have "homologous_rel_set (Suc n) X S c = homologous_rel_set (Suc n) X S (c - d)"
+ proof (simp add: homologous_rel_set_eq)
+ show "homologous_rel (Suc n) X S c (c - d)"
+ using d by (simp add: homologous_rel_def singular_chain_imp_relboundary)
+ qed
+ ultimately show "\<exists>y. y \<in> singular_relcycle_set (Suc n) X {} \<and>
+ homologous_rel_set (Suc n) X S c = homologous_rel_set (Suc n) X S y"
+ by blast
+ qed
+ also have "\<dots> = ?rhs"
+ by (rule 1) (simp add: hom_boundary_chain_boundary homologous_rel_set_eq_relboundary del: of_nat_Suc)
+ finally show "?lhs = ?rhs" .
+ qed
+ with Suc show ?thesis
+ unfolding carrier_relative_homology_group image_comp id_def by auto
+ qed
+ then show ?thesis
+ by (auto simp: kernel_def int)
+ qed
+ then show ?thesis
+ using hom_boundary_hom hom_induced_hom
+ by (force simp: group_hom_def group_hom_axioms_def)
+qed
+
+
+lemma homology_exactness_axiom_2:
+ "exact_seq ([homology_group (p-1) X, homology_group (p-1) (subtopology X S), relative_homology_group p X S],
+ [hom_induced (p-1) (subtopology X S) {} X {} id, hom_boundary p X S])"
+proof -
+ consider (neg) "p \<le> 0" | (int) n where "p = int (Suc n)"
+ by (metis linear not0_implies_Suc of_nat_0 zero_le_imp_eq_int)
+ then have "kernel (relative_homology_group (p - 1) (subtopology X S) {})
+ (relative_homology_group (p - 1) X {})
+ (hom_induced (p - 1) (subtopology X S) {} X {} id)
+ = hom_boundary p X S ` carrier (relative_homology_group p X S)"
+ proof cases
+ case neg
+ obtain x where "x \<in> carrier (relative_homology_group p X S)"
+ using group_relative_homology_group group.is_monoid by blast
+ with neg show ?thesis
+ unfolding kernel_def singleton_group_def relative_homology_group_def
+ by (force simp: hom_induced_trivial hom_boundary_trivial)
+ next
+ case int
+ have "hom_boundary (int (Suc n)) X S ` carrier (relative_homology_group (int (Suc n)) X S)
+ = carrier (relative_homology_group n (subtopology X S) {}) \<inter>
+ {c. hom_induced n (subtopology X S) {} X {} id c =
+ \<one>\<^bsub>relative_homology_group n X {}\<^esub>}"
+ (is "?lhs = ?rhs")
+ proof -
+ have 1: "(\<And>x. x \<in> A \<Longrightarrow> x \<in> B \<longleftrightarrow> x \<in> C) \<Longrightarrow> f ` (A \<inter> B) = f ` (A \<inter> C)" for f A B C
+ by blast
+ have 2: "(\<And>x. x \<in> A \<Longrightarrow> x \<in> B \<longleftrightarrow> x \<in> f -` C) \<Longrightarrow> f ` (A \<inter> B) = f ` A \<inter> C" for f A B C
+ by blast
+ have "?lhs = homologous_rel_set n (subtopology X S) {}
+ ` (chain_boundary (Suc n) ` singular_relcycle_set (Suc n) X S)"
+ unfolding carrier_relative_homology_group image_comp
+ by (rule image_cong [OF refl]) (simp add: o_def hom_boundary_chain_boundary del: of_nat_Suc)
+ also have "\<dots> = homologous_rel_set n (subtopology X S) {} `
+ (singular_relcycle_set n (subtopology X S) {} \<inter> singular_relboundary_set n X {})"
+ by (force simp: singular_relcycle singular_boundary chain_boundary_boundary_alt)
+ also have "\<dots> = ?rhs"
+ unfolding carrier_relative_homology_group vimage_def
+ apply (rule 2)
+ apply (auto simp: hom_induced_chain_map chain_map_ident homologous_rel_set_eq_relboundary singular_relcycle)
+ done
+ finally show ?thesis .
+ qed
+ then show ?thesis
+ by (auto simp: kernel_def int)
+ qed
+ then show ?thesis
+ using hom_boundary_hom hom_induced_hom
+ by (force simp: group_hom_def group_hom_axioms_def)
+qed
+
+
+lemma homology_exactness_axiom_3:
+ "exact_seq ([relative_homology_group p X S, homology_group p X, homology_group p (subtopology X S)],
+ [hom_induced p X {} X S id, hom_induced p (subtopology X S) {} X {} id])"
+proof (cases "p < 0")
+ case True
+ then show ?thesis
+ apply (simp add: relative_homology_group_def hom_induced_trivial group_hom_def group_hom_axioms_def)
+ apply (auto simp: kernel_def singleton_group_def)
+ done
+next
+ case False
+ then obtain n where peq: "p = int n"
+ by (metis int_ops(1) linorder_neqE_linordered_idom pos_int_cases)
+ have "hom_induced n (subtopology X S) {} X {} id `
+ (homologous_rel_set n (subtopology X S) {} `
+ singular_relcycle_set n (subtopology X S) {})
+ = {c \<in> homologous_rel_set n X {} ` singular_relcycle_set n X {}.
+ hom_induced n X {} X S id c = singular_relboundary_set n X S}"
+ (is "?lhs = ?rhs")
+ proof -
+ have 2: "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> \<exists>y. y \<in> B \<and> f x = f y; \<And>x. x \<in> B \<Longrightarrow> \<exists>y. y \<in> A \<and> f x = f y\<rbrakk>
+ \<Longrightarrow> f ` A = f ` B" for f A B
+ by blast
+ have "?lhs = homologous_rel_set n X {} ` (singular_relcycle_set n (subtopology X S) {})"
+ unfolding image_comp o_def
+ apply (rule image_cong [OF refl])
+ apply (simp add: hom_induced_chain_map singular_relcycle)
+ apply (metis chain_map_ident)
+ done
+ also have "\<dots> = homologous_rel_set n X {} ` (singular_relcycle_set n X {} \<inter> singular_relboundary_set n X S)"
+ proof (rule 2)
+ fix c
+ assume "c \<in> singular_relcycle_set n (subtopology X S) {}"
+ then show "\<exists>y. y \<in> singular_relcycle_set n X {} \<inter> singular_relboundary_set n X S \<and>
+ homologous_rel_set n X {} c = homologous_rel_set n X {} y"
+ using singular_chain_imp_relboundary singular_cycle singular_relboundary_imp_chain singular_relcycle by fastforce
+ next
+ fix c
+ assume "c \<in> singular_relcycle_set n X {} \<inter> singular_relboundary_set n X S"
+ then obtain d e where c: "singular_relcycle n X {} c" "singular_relboundary n X S c"
+ and d: "singular_chain n (subtopology X S) d"
+ and e: "singular_chain (Suc n) X e" "chain_boundary (Suc n) e = c + d"
+ using singular_relboundary_alt by blast
+ then have "chain_boundary n (c + d) = 0"
+ using chain_boundary_boundary_alt by fastforce
+ then have "chain_boundary n c + chain_boundary n d = 0"
+ by (metis chain_boundary_add)
+ with c have "singular_relcycle n (subtopology X S) {} (- d)"
+ by (metis (no_types) d eq_add_iff singular_cycle singular_relcycle_minus)
+ moreover have "homologous_rel n X {} c (- d)"
+ using c
+ by (metis diff_minus_eq_add e homologous_rel_def singular_boundary)
+ ultimately
+ show "\<exists>y. y \<in> singular_relcycle_set n (subtopology X S) {} \<and>
+ homologous_rel_set n X {} c = homologous_rel_set n X {} y"
+ by (force simp: homologous_rel_set_eq)
+ qed
+ also have "\<dots> = homologous_rel_set n X {} `
+ (singular_relcycle_set n X {} \<inter> homologous_rel_set n X {} -` {x. hom_induced n X {} X S id x = singular_relboundary_set n X S})"
+ by (rule 2) (auto simp: hom_induced_chain_map homologous_rel_set_eq_relboundary chain_map_ident [of _ X] singular_cycle cong: conj_cong)
+ also have "\<dots> = ?rhs"
+ by blast
+ finally show ?thesis .
+ qed
+ then have "kernel (relative_homology_group p X {}) (relative_homology_group p X S) (hom_induced p X {} X S id)
+ = hom_induced p (subtopology X S) {} X {} id ` carrier (relative_homology_group p (subtopology X S) {})"
+ by (simp add: kernel_def carrier_relative_homology_group peq)
+ then show ?thesis
+ by (simp add: not_less group_hom_def group_hom_axioms_def hom_induced_hom)
+qed
+
+
+lemma homology_dimension_axiom:
+ assumes X: "topspace X = {a}" and "p \<noteq> 0"
+ shows "trivial_group(homology_group p X)"
+proof (cases "p < 0")
+ case True
+ then show ?thesis
+ by simp
+next
+ case False
+ then obtain n where peq: "p = int n" "n > 0"
+ by (metis assms(2) neq0_conv nonneg_int_cases not_less of_nat_0)
+ have "homologous_rel_set n X {} ` singular_relcycle_set n X {} = {singular_relcycle_set n X {}}"
+ (is "?lhs = ?rhs")
+ proof
+ show "?lhs \<subseteq> ?rhs"
+ using peq assms
+ by (auto simp: image_subset_iff homologous_rel_set_eq_relboundary simp flip: singular_boundary_set_eq_cycle_singleton)
+ have "singular_relboundary n X {} 0"
+ by simp
+ with peq assms
+ show "?rhs \<subseteq> ?lhs"
+ by (auto simp: image_iff simp flip: homologous_rel_eq_relboundary singular_boundary_set_eq_cycle_singleton)
+ qed
+ with peq assms show ?thesis
+ unfolding trivial_group_def
+ by (simp add: carrier_relative_homology_group singular_boundary_set_eq_cycle_singleton [OF X])
+qed
+
+
+proposition homology_homotopy_axiom:
+ assumes "homotopic_with (\<lambda>h. h ` S \<subseteq> T) X Y f g"
+ shows "hom_induced p X S Y T f = hom_induced p X S Y T g"
+proof (cases "p < 0")
+ case True
+ then show ?thesis
+ by (simp add: hom_induced_trivial)
+next
+ case False
+ then obtain n where peq: "p = int n"
+ by (metis int_nat_eq not_le)
+ have cont: "continuous_map X Y f" "continuous_map X Y g"
+ using assms homotopic_with_imp_continuous_maps by blast+
+ have im: "f ` (topspace X \<inter> S) \<subseteq> T" "g ` (topspace X \<inter> S) \<subseteq> T"
+ using homotopic_with_imp_property assms by blast+
+ show ?thesis
+ proof
+ fix c show "hom_induced p X S Y T f c = hom_induced p X S Y T g c"
+ proof (cases "c \<in> carrier(relative_homology_group p X S)")
+ case True
+ then obtain a where a: "c = homologous_rel_set n X S a" "singular_relcycle n X S a"
+ unfolding carrier_relative_homology_group peq by auto
+ then show ?thesis
+ apply (simp add: peq hom_induced_chain_map_gen cont im homologous_rel_set_eq)
+ apply (blast intro: assms homotopic_imp_homologous_rel_chain_maps)
+ done
+ qed (simp add: hom_induced_default)
+ qed
+qed
+
+proposition homology_excision_axiom:
+ assumes "X closure_of U \<subseteq> X interior_of T" "T \<subseteq> S"
+ shows
+ "hom_induced p (subtopology X (S - U)) (T - U) (subtopology X S) T id
+ \<in> iso (relative_homology_group p (subtopology X (S - U)) (T - U))
+ (relative_homology_group p (subtopology X S) T)"
+proof (cases "p < 0")
+ case True
+ then show ?thesis
+ unfolding iso_def bij_betw_def relative_homology_group_def by (simp add: hom_induced_trivial)
+next
+ case False
+ then obtain n where peq: "p = int n"
+ by (metis int_nat_eq not_le)
+ have cont: "continuous_map (subtopology X (S - U)) (subtopology X S) id"
+ by (simp add: closure_of_subtopology_mono continuous_map_eq_image_closure_subset)
+ have TU: "topspace X \<inter> (S - U) \<inter> (T - U) \<subseteq> T"
+ by auto
+ show ?thesis
+ proof (simp add: iso_def peq carrier_relative_homology_group bij_betw_def hom_induced_hom, intro conjI)
+ show "inj_on (hom_induced n (subtopology X (S - U)) (T - U) (subtopology X S) T id)
+ (homologous_rel_set n (subtopology X (S - U)) (T - U) `
+ singular_relcycle_set n (subtopology X (S - U)) (T - U))"
+ unfolding inj_on_def
+ proof (clarsimp simp add: homologous_rel_set_eq)
+ fix c d
+ assume c: "singular_relcycle n (subtopology X (S - U)) (T - U) c"
+ and d: "singular_relcycle n (subtopology X (S - U)) (T - U) d"
+ and hh: "hom_induced n (subtopology X (S - U)) (T - U) (subtopology X S) T id
+ (homologous_rel_set n (subtopology X (S - U)) (T - U) c)
+ = hom_induced n (subtopology X (S - U)) (T - U) (subtopology X S) T id
+ (homologous_rel_set n (subtopology X (S - U)) (T - U) d)"
+ then have scc: "singular_chain n (subtopology X (S - U)) c"
+ and scd: "singular_chain n (subtopology X (S - U)) d"
+ using singular_relcycle by blast+
+ have "singular_relboundary n (subtopology X (S - U)) (T - U) c"
+ if srb: "singular_relboundary n (subtopology X S) T c"
+ and src: "singular_relcycle n (subtopology X (S - U)) (T - U) c" for c
+ proof -
+ have [simp]: "(S - U) \<inter> (T - U) = T - U" "S \<inter> T = T"
+ using \<open>T \<subseteq> S\<close> by blast+
+ have c: "singular_chain n (subtopology X (S - U)) c"
+ "singular_chain (n - Suc 0) (subtopology X (T - U)) (chain_boundary n c)"
+ using that by (auto simp: singular_relcycle_def mod_subset_def subtopology_subtopology)
+ obtain d e where d: "singular_chain (Suc n) (subtopology X S) d"
+ and e: "singular_chain n (subtopology X T) e"
+ and dce: "chain_boundary (Suc n) d = c + e"
+ using srb by (auto simp: singular_relboundary_alt subtopology_subtopology)
+ obtain m f g where f: "singular_chain (Suc n) (subtopology X (S - U)) f"
+ and g: "singular_chain (Suc n) (subtopology X T) g"
+ and dfg: "(singular_subdivision (Suc n) ^^ m) d = f + g"
+ using excised_chain_exists [OF assms d] .
+ obtain h where
+ h0: "\<And>p. h p 0 = (0 :: 'a chain)"
+ and hdiff: "\<And>p c1 c2. h p (c1-c2) = h p c1 - h p c2"
+ and hSuc: "\<And>p X c. singular_chain p X c \<Longrightarrow> singular_chain (Suc p) X (h p c)"
+ and hchain: "\<And>p X c. singular_chain p X c
+ \<Longrightarrow> chain_boundary (Suc p) (h p c) + h (p - Suc 0) (chain_boundary p c)
+ = (singular_subdivision p ^^ m) c - c"
+ using chain_homotopic_iterated_singular_subdivision by blast
+ have hadd: "\<And>p c1 c2. h p (c1 + c2) = h p c1 + h p c2"
+ by (metis add_diff_cancel diff_add_cancel hdiff)
+ define c1 where "c1 \<equiv> f - h n c"
+ define c2 where "c2 \<equiv> chain_boundary (Suc n) (h n e) - (chain_boundary (Suc n) g - e)"
+ show ?thesis
+ unfolding singular_relboundary_alt
+ proof (intro exI conjI)
+ show c1: "singular_chain (Suc n) (subtopology X (S - U)) c1"
+ by (simp add: \<open>singular_chain n (subtopology X (S - U)) c\<close> c1_def f hSuc singular_chain_diff)
+ have "chain_boundary (Suc n) (chain_boundary (Suc (Suc n)) (h (Suc n) d) + h n (c+e))
+ = chain_boundary (Suc n) (f + g - d)"
+ using hchain [OF d] by (simp add: dce dfg)
+ then have "chain_boundary (Suc n) (h n (c + e))
+ = chain_boundary (Suc n) f + chain_boundary (Suc n) g - (c + e)"
+ using chain_boundary_boundary_alt [of "Suc n" "subtopology X S"]
+ by (simp add: chain_boundary_add chain_boundary_diff d hSuc dce)
+ then have "chain_boundary (Suc n) (h n c) + chain_boundary (Suc n) (h n e)
+ = chain_boundary (Suc n) f + chain_boundary (Suc n) g - (c + e)"
+ by (simp add: chain_boundary_add hadd)
+ then have *: "chain_boundary (Suc n) (f - h n c) = c + (chain_boundary (Suc n) (h n e) - (chain_boundary (Suc n) g - e))"
+ by (simp add: algebra_simps chain_boundary_diff)
+ then show "chain_boundary (Suc n) c1 = c + c2"
+ unfolding c1_def c2_def
+ by (simp add: algebra_simps chain_boundary_diff)
+ have "singular_chain n (subtopology X (S - U)) c2" "singular_chain n (subtopology X T) c2"
+ using singular_chain_diff c c1 *
+ unfolding c1_def c2_def
+ apply (metis add_diff_cancel_left' singular_chain_boundary_alt)
+ by (simp add: e g hSuc singular_chain_boundary_alt singular_chain_diff)
+ then show "singular_chain n (subtopology (subtopology X (S - U)) (T - U)) c2"
+ by (fastforce simp add: singular_chain_subtopology)
+ qed
+ qed
+ then have "singular_relboundary n (subtopology X S) T (c - d) \<Longrightarrow>
+ singular_relboundary n (subtopology X (S - U)) (T - U) (c - d)"
+ using c d singular_relcycle_diff by metis
+ with hh show "homologous_rel n (subtopology X (S - U)) (T - U) c d"
+ apply (simp add: hom_induced_chain_map cont c d chain_map_ident [OF scc] chain_map_ident [OF scd])
+ using homologous_rel_set_eq homologous_rel_def by metis
+ qed
+ next
+ have h: "homologous_rel_set n (subtopology X S) T a
+ \<in> (\<lambda>x. homologous_rel_set n (subtopology X S) T (chain_map n id x)) `
+ singular_relcycle_set n (subtopology X (S - U)) (T - U)"
+ if a: "singular_relcycle n (subtopology X S) T a" for a
+ proof -
+ obtain c' where c': "singular_relcycle n (subtopology X (S - U)) (T - U) c'"
+ "homologous_rel n (subtopology X S) T a c'"
+ using a by (blast intro: excised_relcycle_exists [OF assms])
+ then have scc': "singular_chain n (subtopology X S) c'"
+ using homologous_rel_singular_chain singular_relcycle that by blast
+ then show ?thesis
+ apply (rule_tac x="c'" in image_eqI)
+ apply (auto simp: scc' chain_map_ident [of _ "subtopology X S"] c' homologous_rel_set_eq)
+ done
+ qed
+ show "hom_induced n (subtopology X (S - U)) (T - U) (subtopology X S) T id `
+ homologous_rel_set n (subtopology X (S - U)) (T - U) `
+ singular_relcycle_set n (subtopology X (S - U)) (T - U)
+ = homologous_rel_set n (subtopology X S) T ` singular_relcycle_set n (subtopology X S) T"
+ apply (simp add: image_comp o_def hom_induced_chain_map_gen cont TU topspace_subtopology
+ cong: image_cong_simp)
+ apply (force simp: cont h singular_relcycle_chain_map)
+ done
+ qed
+qed
+
+
+subsection\<open>Additivity axiom\<close>
+
+text\<open>Not in the original Eilenberg-Steenrod list but usually included nowadays,
+following Milnor's "On Axiomatic Homology Theory".\<close>
+
+lemma iso_chain_group_sum:
+ assumes disj: "pairwise disjnt \<U>" and UU: "\<Union>\<U> = topspace X"
+ and subs: "\<And>C T. \<lbrakk>compactin X C; path_connectedin X C; T \<in> \<U>; ~ disjnt C T\<rbrakk> \<Longrightarrow> C \<subseteq> T"
+ shows "(\<lambda>f. sum' f \<U>) \<in> iso (sum_group \<U> (\<lambda>S. chain_group p (subtopology X S))) (chain_group p X)"
+proof -
+ have pw: "pairwise (\<lambda>i j. disjnt (singular_simplex_set p (subtopology X i))
+ (singular_simplex_set p (subtopology X j))) \<U>"
+ proof
+ fix S T
+ assume "S \<in> \<U>" "T \<in> \<U>" "S \<noteq> T"
+ then show "disjnt (singular_simplex_set p (subtopology X S))
+ (singular_simplex_set p (subtopology X T))"
+ using nonempty_standard_simplex [of p] disj
+ by (fastforce simp: pairwise_def disjnt_def singular_simplex_subtopology image_subset_iff)
+ qed
+ have "\<exists>S\<in>\<U>. singular_simplex p (subtopology X S) f"
+ if f: "singular_simplex p X f" for f
+ proof -
+ obtain x where x: "x \<in> topspace X" "x \<in> f ` standard_simplex p"
+ using f nonempty_standard_simplex [of p] continuous_map_image_subset_topspace
+ unfolding singular_simplex_def by fastforce
+ then obtain S where "S \<in> \<U>" "x \<in> S"
+ using UU by auto
+ have "f ` standard_simplex p \<subseteq> S"
+ proof (rule subs)
+ have cont: "continuous_map (subtopology (powertop_real UNIV)
+ (standard_simplex p)) X f"
+ using f singular_simplex_def by auto
+ show "compactin X (f ` standard_simplex p)"
+ by (simp add: compactin_subtopology compactin_standard_simplex image_compactin [OF _ cont])
+ show "path_connectedin X (f ` standard_simplex p)"
+ by (simp add: path_connectedin_subtopology path_connectedin_standard_simplex path_connectedin_continuous_map_image [OF cont])
+ have "standard_simplex p \<noteq> {}"
+ by (simp add: nonempty_standard_simplex)
+ then
+ show "\<not> disjnt (f ` standard_simplex p) S"
+ using x \<open>x \<in> S\<close> by (auto simp: disjnt_def)
+ qed (auto simp: \<open>S \<in> \<U>\<close>)
+ then show ?thesis
+ by (meson \<open>S \<in> \<U>\<close> singular_simplex_subtopology that)
+ qed
+ then have "(\<Union>i\<in>\<U>. singular_simplex_set p (subtopology X i)) = singular_simplex_set p X"
+ by (auto simp: singular_simplex_subtopology)
+ then show ?thesis
+ using iso_free_Abelian_group_sum [OF pw] by (simp add: chain_group_def)
+qed
+
+lemma relcycle_group_0_eq_chain_group: "relcycle_group 0 X {} = chain_group 0 X"
+ apply (rule monoid.equality, simp)
+ apply (simp_all add: relcycle_group_def chain_group_def)
+ by (metis chain_boundary_def singular_cycle)
+
+
+proposition iso_cycle_group_sum:
+ assumes disj: "pairwise disjnt \<U>" and UU: "\<Union>\<U> = topspace X"
+ and subs: "\<And>C T. \<lbrakk>compactin X C; path_connectedin X C; T \<in> \<U>; \<not> disjnt C T\<rbrakk> \<Longrightarrow> C \<subseteq> T"
+ shows "(\<lambda>f. sum' f \<U>) \<in> iso (sum_group \<U> (\<lambda>T. relcycle_group p (subtopology X T) {}))
+ (relcycle_group p X {})"
+proof (cases "p = 0")
+ case True
+ then show ?thesis
+ by (simp add: relcycle_group_0_eq_chain_group iso_chain_group_sum [OF assms])
+next
+ case False
+ let ?SG = "(sum_group \<U> (\<lambda>T. chain_group p (subtopology X T)))"
+ let ?PI = "(\<Pi>\<^sub>E T\<in>\<U>. singular_relcycle_set p (subtopology X T) {})"
+ have "(\<lambda>f. sum' f \<U>) \<in> Group.iso (subgroup_generated ?SG (carrier ?SG \<inter> ?PI))
+ (subgroup_generated (chain_group p X) (singular_relcycle_set p X {}))"
+ proof (rule group_hom.iso_between_subgroups)
+ have iso: "(\<lambda>f. sum' f \<U>) \<in> Group.iso ?SG (chain_group p X)"
+ by (auto simp: assms iso_chain_group_sum)
+ then show "group_hom ?SG (chain_group p X) (\<lambda>f. sum' f \<U>)"
+ by (auto simp: iso_imp_homomorphism group_hom_def group_hom_axioms_def)
+ have B: "sum' f \<U> \<in> singular_relcycle_set p X {} \<longleftrightarrow> f \<in> (carrier ?SG \<inter> ?PI)"
+ if "f \<in> (carrier ?SG)" for f
+ proof -
+ have f: "\<And>S. S \<in> \<U> \<longrightarrow> singular_chain p (subtopology X S) (f S)"
+ "f \<in> extensional \<U>" "finite {i \<in> \<U>. f i \<noteq> 0}"
+ using that by (auto simp: carrier_sum_group PiE_def Pi_def)
+ then have rfin: "finite {S \<in> \<U>. restrict (chain_boundary p \<circ> f) \<U> S \<noteq> 0}"
+ by (auto elim: rev_finite_subset)
+ have "chain_boundary p ((\<Sum>x | x \<in> \<U> \<and> f x \<noteq> 0. f x)) = 0
+ \<longleftrightarrow> (\<forall>S \<in> \<U>. chain_boundary p (f S) = 0)" (is "?cb = 0 \<longleftrightarrow> ?rhs")
+ proof
+ assume "?cb = 0"
+ moreover have "?cb = sum' (\<lambda>S. chain_boundary p (f S)) \<U>"
+ unfolding sum.G_def using rfin f
+ by (force simp: chain_boundary_sum intro: sum.mono_neutral_right cong: conj_cong)
+ ultimately have eq0: "sum' (\<lambda>S. chain_boundary p (f S)) \<U> = 0"
+ by simp
+ have "(\<lambda>f. sum' f \<U>) \<in> hom (sum_group \<U> (\<lambda>S. chain_group (p - Suc 0) (subtopology X S)))
+ (chain_group (p - Suc 0) X)"
+ and inj: "inj_on (\<lambda>f. sum' f \<U>) (carrier (sum_group \<U> (\<lambda>S. chain_group (p - Suc 0) (subtopology X S))))"
+ using iso_chain_group_sum [OF assms, of "p-1"] by (auto simp: iso_def bij_betw_def)
+ then have eq: "\<lbrakk>f \<in> (\<Pi>\<^sub>E i\<in>\<U>. singular_chain_set (p - Suc 0) (subtopology X i));
+ finite {S \<in> \<U>. f S \<noteq> 0}; sum' f \<U> = 0; S \<in> \<U>\<rbrakk> \<Longrightarrow> f S = 0" for f S
+ apply (simp add: group_hom_def group_hom_axioms_def group_hom.inj_on_one_iff [of _ "chain_group (p-1) X"])
+ apply (auto simp: carrier_sum_group fun_eq_iff that)
+ done
+ show ?rhs
+ proof clarify
+ fix S assume "S \<in> \<U>"
+ then show "chain_boundary p (f S) = 0"
+ using eq [of "restrict (chain_boundary p \<circ> f) \<U>" S] rfin f eq0
+ by (simp add: singular_chain_boundary cong: conj_cong)
+ qed
+ next
+ assume ?rhs
+ then show "?cb = 0"
+ by (force simp: chain_boundary_sum intro: sum.mono_neutral_right)
+ qed
+ moreover
+ have "(\<And>S. S \<in> \<U> \<longrightarrow> singular_chain p (subtopology X S) (f S))
+ \<Longrightarrow> singular_chain p X (\<Sum>x | x \<in> \<U> \<and> f x \<noteq> 0. f x)"
+ by (metis (no_types, lifting) mem_Collect_eq singular_chain_subtopology singular_chain_sum)
+ ultimately show ?thesis
+ using f by (auto simp: carrier_sum_group sum.G_def singular_cycle PiE_iff)
+ qed
+ have "singular_relcycle_set p X {} \<subseteq> carrier (chain_group p X)"
+ using subgroup.subset subgroup_singular_relcycle by blast
+ then show "(\<lambda>f. sum' f \<U>) ` (carrier ?SG \<inter> ?PI) = singular_relcycle_set p X {}"
+ using iso B
+ apply (auto simp: iso_def bij_betw_def)
+ apply (force simp: singular_relcycle)
+ done
+ qed (auto simp: assms iso_chain_group_sum)
+ then show ?thesis
+ by (simp add: relcycle_group_def sum_group_subgroup_generated subgroup_singular_relcycle)
+qed
+
+
+proposition homology_additivity_axiom_gen:
+ assumes disj: "pairwise disjnt \<U>" and UU: "\<Union>\<U> = topspace X"
+ and subs: "\<And>C T. \<lbrakk>compactin X C; path_connectedin X C; T \<in> \<U>; \<not> disjnt C T\<rbrakk> \<Longrightarrow> C \<subseteq> T"
+ shows "(\<lambda>x. gfinprod (homology_group p X)
+ (\<lambda>V. hom_induced p (subtopology X V) {} X {} id (x V)) \<U>)
+ \<in> iso (sum_group \<U> (\<lambda>S. homology_group p (subtopology X S))) (homology_group p X)"
+ (is "?h \<in> iso ?SG ?HG")
+proof (cases "p < 0")
+ case True
+ then have [simp]: "gfinprod (singleton_group undefined) (\<lambda>v. undefined) \<U> = undefined"
+ by (metis Pi_I carrier_singleton_group comm_group_def comm_monoid.gfinprod_closed singletonD singleton_abelian_group)
+ show ?thesis
+ using True
+ apply (simp add: iso_def relative_homology_group_def hom_induced_trivial carrier_sum_group)
+ apply (auto simp: singleton_group_def bij_betw_def inj_on_def fun_eq_iff)
+ done
+next
+ case False
+ then obtain n where peq: "p = int n"
+ by (metis int_ops(1) linorder_neqE_linordered_idom pos_int_cases)
+ interpret comm_group "homology_group p X"
+ by (rule abelian_homology_group)
+ show ?thesis
+ proof (simp add: iso_def bij_betw_def, intro conjI)
+ show "?h \<in> hom ?SG ?HG"
+ by (rule hom_group_sum) (simp_all add: hom_induced_hom)
+ then interpret group_hom ?SG ?HG ?h
+ by (simp add: group_hom_def group_hom_axioms_def)
+ have carrSG: "carrier ?SG
+ = (\<lambda>x. \<lambda>S\<in>\<U>. homologous_rel_set n (subtopology X S) {} (x S))
+ ` (carrier (sum_group \<U> (\<lambda>S. relcycle_group n (subtopology X S) {})))" (is "?lhs = ?rhs")
+ proof
+ show "?lhs \<subseteq> ?rhs"
+ proof (clarsimp simp: carrier_sum_group carrier_relative_homology_group peq)
+ fix z
+ assume z: "z \<in> (\<Pi>\<^sub>E S\<in>\<U>. homologous_rel_set n (subtopology X S) {} ` singular_relcycle_set n (subtopology X S) {})"
+ and fin: "finite {S \<in> \<U>. z S \<noteq> singular_relboundary_set n (subtopology X S) {}}"
+ then obtain c where c: "\<forall>S\<in>\<U>. singular_relcycle n (subtopology X S) {} (c S)
+ \<and> z S = homologous_rel_set n (subtopology X S) {} (c S)"
+ by (simp add: PiE_def Pi_def image_def) metis
+ let ?f = "\<lambda>S\<in>\<U>. if singular_relboundary n (subtopology X S) {} (c S) then 0 else c S"
+ have "z = (\<lambda>S\<in>\<U>. homologous_rel_set n (subtopology X S) {} (?f S))"
+ apply (simp_all add: c fun_eq_iff PiE_arb [OF z])
+ apply (metis homologous_rel_eq_relboundary singular_boundary singular_relboundary_0)
+ done
+ moreover have "?f \<in> (\<Pi>\<^sub>E i\<in>\<U>. singular_relcycle_set n (subtopology X i) {})"
+ by (simp add: c fun_eq_iff PiE_arb [OF z])
+ moreover have "finite {i \<in> \<U>. ?f i \<noteq> 0}"
+ apply (rule finite_subset [OF _ fin])
+ using z apply (clarsimp simp: PiE_def Pi_def image_def)
+ by (metis c homologous_rel_set_eq_relboundary singular_boundary)
+ ultimately
+ show "z \<in> (\<lambda>x. \<lambda>S\<in>\<U>. homologous_rel_set n (subtopology X S) {} (x S)) `
+ {x \<in> \<Pi>\<^sub>E i\<in>\<U>. singular_relcycle_set n (subtopology X i) {}. finite {i \<in> \<U>. x i \<noteq> 0}}"
+ by blast
+ qed
+ show "?rhs \<subseteq> ?lhs"
+ by (force simp: peq carrier_sum_group carrier_relative_homology_group homologous_rel_set_eq_relboundary
+ elim: rev_finite_subset)
+ qed
+ have gf: "gfinprod (homology_group p X)
+ (\<lambda>V. hom_induced n (subtopology X V) {} X {} id
+ ((\<lambda>S\<in>\<U>. homologous_rel_set n (subtopology X S) {} (z S)) V)) \<U>
+ = homologous_rel_set n X {} (sum' z \<U>)" (is "?lhs = ?rhs")
+ if z: "z \<in> carrier (sum_group \<U> (\<lambda>S. relcycle_group n (subtopology X S) {}))" for z
+ proof -
+ have hom_pi: "(\<lambda>S. homologous_rel_set n X {} (z S)) \<in> \<U> \<rightarrow> carrier (homology_group p X)"
+ apply (rule Pi_I)
+ using z
+ apply (force simp: peq carrier_sum_group carrier_relative_homology_group singular_chain_subtopology singular_cycle)
+ done
+ have fin: "finite {S \<in> \<U>. z S \<noteq> 0}"
+ using that by (force simp: carrier_sum_group)
+ have "?lhs = gfinprod (homology_group p X) (\<lambda>S. homologous_rel_set n X {} (z S)) \<U>"
+ apply (rule gfinprod_cong [OF refl Pi_I])
+ apply (simp add: hom_induced_carrier peq)
+ using that
+ apply (auto simp: peq simp_implies_def carrier_sum_group PiE_def Pi_def chain_map_ident singular_cycle hom_induced_chain_map)
+ done
+ also have "\<dots> = gfinprod (homology_group p X)
+ (\<lambda>S. homologous_rel_set n X {} (z S)) {S \<in> \<U>. z S \<noteq> 0}"
+ apply (rule gfinprod_mono_neutral_cong_right, simp_all add: hom_pi)
+ apply (simp add: relative_homology_group_def peq)
+ apply (metis homologous_rel_eq_relboundary singular_relboundary_0)
+ done
+ also have "\<dots> = ?rhs"
+ proof -
+ have "gfinprod (homology_group p X) (\<lambda>S. homologous_rel_set n X {} (z S)) \<F>
+ = homologous_rel_set n X {} (sum z \<F>)"
+ if "finite \<F>" "\<F> \<subseteq> {S \<in> \<U>. z S \<noteq> 0}" for \<F>
+ using that
+ proof (induction \<F>)
+ case empty
+ have "\<one>\<^bsub>homology_group p X\<^esub> = homologous_rel_set n X {} 0"
+ apply (simp add: relative_homology_group_def peq)
+ by (metis diff_zero homologous_rel_def homologous_rel_sym)
+ then show ?case
+ by simp
+ next
+ case (insert S \<F>)
+ with z have pi: "(\<lambda>S. homologous_rel_set n X {} (z S)) \<in> \<F> \<rightarrow> carrier (homology_group p X)"
+ "homologous_rel_set n X {} (z S) \<in> carrier (homology_group p X)"
+ by (force simp: peq carrier_sum_group carrier_relative_homology_group singular_chain_subtopology singular_cycle)+
+ have hom: "homologous_rel_set n X {} (z S) \<in> carrier (homology_group p X)"
+ using insert z
+ by (force simp: peq carrier_sum_group carrier_relative_homology_group singular_chain_subtopology singular_cycle)
+ show ?case
+ using insert z
+ proof (simp add: pi)
+ show "homologous_rel_set n X {} (z S) \<otimes>\<^bsub>homology_group p X\<^esub> homologous_rel_set n X {} (sum z \<F>)
+ = homologous_rel_set n X {} (z S + sum z \<F>)"
+ using insert z apply (auto simp: peq homologous_rel_add mult_relative_homology_group)
+ by (metis (no_types, lifting) diff_add_cancel diff_diff_eq2 homologous_rel_def homologous_rel_refl)
+ qed
+ qed
+ with fin show ?thesis
+ by (simp add: sum.G_def)
+ qed
+ finally show ?thesis .
+ qed
+ show "inj_on ?h (carrier ?SG)"
+ proof (clarsimp simp add: inj_on_one_iff)
+ fix x
+ assume x: "x \<in> carrier (sum_group \<U> (\<lambda>S. homology_group p (subtopology X S)))"
+ and 1: "gfinprod (homology_group p X) (\<lambda>V. hom_induced p (subtopology X V) {} X {} id (x V)) \<U>
+ = \<one>\<^bsub>homology_group p X\<^esub>"
+ have feq: "(\<lambda>S\<in>\<U>. homologous_rel_set n (subtopology X S) {} (z S))
+ = (\<lambda>S\<in>\<U>. \<one>\<^bsub>homology_group p (subtopology X S)\<^esub>)"
+ if z: "z \<in> carrier (sum_group \<U> (\<lambda>S. relcycle_group n (subtopology X S) {}))"
+ and eq: "homologous_rel_set n X {} (sum' z \<U>) = \<one>\<^bsub>homology_group p X\<^esub>" for z
+ proof -
+ have "z \<in> (\<Pi>\<^sub>E S\<in>\<U>. singular_relcycle_set n (subtopology X S) {})" "finite {S \<in> \<U>. z S \<noteq> 0}"
+ using z by (auto simp: carrier_sum_group)
+ have "singular_relboundary n X {} (sum' z \<U>)"
+ using eq singular_chain_imp_relboundary by (auto simp: relative_homology_group_def peq)
+ then obtain d where scd: "singular_chain (Suc n) X d" and cbd: "chain_boundary (Suc n) d = sum' z \<U>"
+ by (auto simp: singular_boundary)
+ have *: "\<exists>d. singular_chain (Suc n) (subtopology X S) d \<and> chain_boundary (Suc n) d = z S"
+ if "S \<in> \<U>" for S
+ proof -
+ have inj': "inj_on (\<lambda>f. sum' f \<U>) {x \<in> \<Pi>\<^sub>E S\<in>\<U>. singular_chain_set (Suc n) (subtopology X S). finite {S \<in> \<U>. x S \<noteq> 0}}"
+ using iso_chain_group_sum [OF assms, of "Suc n"]
+ by (simp add: iso_iff_mon_epi mon_def carrier_sum_group)
+ obtain w where w: "w \<in> (\<Pi>\<^sub>E S\<in>\<U>. singular_chain_set (Suc n) (subtopology X S))"
+ and finw: "finite {S \<in> \<U>. w S \<noteq> 0}"
+ and deq: "d = sum' w \<U>"
+ using iso_chain_group_sum [OF assms, of "Suc n"] scd
+ by (auto simp: iso_iff_mon_epi epi_def carrier_sum_group set_eq_iff)
+ with \<open>S \<in> \<U>\<close> have scwS: "singular_chain (Suc n) (subtopology X S) (w S)"
+ by blast
+ have "inj_on (\<lambda>f. sum' f \<U>) {x \<in> \<Pi>\<^sub>E S\<in>\<U>. singular_chain_set n (subtopology X S). finite {S \<in> \<U>. x S \<noteq> 0}}"
+ using iso_chain_group_sum [OF assms, of n]
+ by (simp add: iso_iff_mon_epi mon_def carrier_sum_group)
+ then have "(\<lambda>S\<in>\<U>. chain_boundary (Suc n) (w S)) = z"
+ proof (rule inj_onD)
+ have "sum' (\<lambda>S\<in>\<U>. chain_boundary (Suc n) (w S)) \<U> = sum' (chain_boundary (Suc n) \<circ> w) {S \<in> \<U>. w S \<noteq> 0}"
+ by (auto simp: o_def intro: sum.mono_neutral_right')
+ also have "\<dots> = chain_boundary (Suc n) d"
+ by (auto simp: sum.G_def deq chain_boundary_sum finw intro: finite_subset [OF _ finw] sum.mono_neutral_left)
+ finally show "sum' (\<lambda>S\<in>\<U>. chain_boundary (Suc n) (w S)) \<U> = sum' z \<U>"
+ by (simp add: cbd)
+ show "(\<lambda>S\<in>\<U>. chain_boundary (Suc n) (w S)) \<in> {x \<in> \<Pi>\<^sub>E S\<in>\<U>. singular_chain_set n (subtopology X S). finite {S \<in> \<U>. x S \<noteq> 0}}"
+ using w by (auto simp: PiE_iff singular_chain_boundary_alt cong: rev_conj_cong intro: finite_subset [OF _ finw])
+ show "z \<in> {x \<in> \<Pi>\<^sub>E S\<in>\<U>. singular_chain_set n (subtopology X S). finite {S \<in> \<U>. x S \<noteq> 0}}"
+ using z by (simp_all add: carrier_sum_group PiE_iff singular_cycle)
+ qed
+ with \<open>S \<in> \<U>\<close> scwS show ?thesis
+ by force
+ qed
+ show ?thesis
+ apply (rule restrict_ext)
+ using that *
+ apply (simp add: singular_boundary relative_homology_group_def homologous_rel_set_eq_relboundary peq)
+ done
+ qed
+ show "x = (\<lambda>S\<in>\<U>. \<one>\<^bsub>homology_group p (subtopology X S)\<^esub>)"
+ using x 1 carrSG gf
+ by (auto simp: peq feq)
+ qed
+ show "?h ` carrier ?SG = carrier ?HG"
+ proof safe
+ fix A
+ assume "A \<in> carrier (homology_group p X)"
+ then obtain y where y: "singular_relcycle n X {} y" and xeq: "A = homologous_rel_set n X {} y"
+ by (auto simp: peq carrier_relative_homology_group)
+ then obtain x where "x \<in> carrier (sum_group \<U> (\<lambda>T. relcycle_group n (subtopology X T) {}))"
+ "y = sum' x \<U>"
+ using iso_cycle_group_sum [OF assms, of n] that by (force simp: iso_iff_mon_epi epi_def)
+ then show "A \<in> (\<lambda>x. gfinprod (homology_group p X) (\<lambda>V. hom_induced p (subtopology X V) {} X {} id (x V)) \<U>) `
+ carrier (sum_group \<U> (\<lambda>S. homology_group p (subtopology X S)))"
+ apply (simp add: carrSG image_comp o_def xeq)
+ apply (simp add: hom_induced_carrier peq flip: gf cong: gfinprod_cong)
+ done
+ qed auto
+ qed
+qed
+
+
+corollary homology_additivity_axiom:
+ assumes disj: "pairwise disjnt \<U>" and UU: "\<Union>\<U> = topspace X"
+ and ope: "\<And>v. v \<in> \<U> \<Longrightarrow> openin X v"
+ shows "(\<lambda>x. gfinprod (homology_group p X)
+ (\<lambda>v. hom_induced p (subtopology X v) {} X {} id (x v)) \<U>)
+ \<in> iso (sum_group \<U> (\<lambda>S. homology_group p (subtopology X S))) (homology_group p X)"
+proof (rule homology_additivity_axiom_gen [OF disj UU])
+ fix C T
+ assume
+ "compactin X C" and
+ "path_connectedin X C" and
+ "T \<in> \<U>" and
+ "\<not> disjnt C T"
+ then have "C \<subseteq> topspace X"
+ and *: "\<And>B. \<lbrakk>openin X T; T \<inter> B \<inter> C = {}; C \<subseteq> T \<union> B; openin X B\<rbrakk> \<Longrightarrow> B \<inter> C = {}"
+ apply (auto simp: connectedin disjnt_def dest!: path_connectedin_imp_connectedin, blast)
+ done
+ have "C \<subseteq> Union \<U>"
+ using \<open>C \<subseteq> topspace X\<close> UU by blast
+ moreover have "\<Union> (\<U> - {T}) \<inter> C = {}"
+ proof (rule *)
+ show "T \<inter> \<Union> (\<U> - {T}) \<inter> C = {}"
+ using \<open>T \<in> \<U>\<close> disj disjointD by fastforce
+ show "C \<subseteq> T \<union> \<Union> (\<U> - {T})"
+ using \<open>C \<subseteq> \<Union> \<U>\<close> by fastforce
+ qed (auto simp: \<open>T \<in> \<U>\<close> ope)
+ ultimately show "C \<subseteq> T"
+ by blast
+qed
+
+
+subsection\<open>Special properties of singular homology\<close>
+
+text\<open>In particular: the zeroth homology group is isomorphic to the free abelian group
+generated by the path components. So, the "coefficient group" is the integers.\<close>
+
+lemma iso_integer_zeroth_homology_group_aux:
+ assumes X: "path_connected_space X" and f: "singular_simplex 0 X f" and f': "singular_simplex 0 X f'"
+ shows "homologous_rel 0 X {} (frag_of f) (frag_of f')"
+proof -
+ let ?p = "\<lambda>j. if j = 0 then 1 else 0"
+ have "f ?p \<in> topspace X" "f' ?p \<in> topspace X"
+ using assms by (auto simp: singular_simplex_def continuous_map_def)
+ then obtain g where g: "pathin X g"
+ and g0: "g 0 = f ?p"
+ and g1: "g 1 = f' ?p"
+ using assms by (force simp: path_connected_space_def)
+ then have contg: "continuous_map (subtopology euclideanreal {0..1}) X g"
+ by (simp add: pathin_def)
+ have "singular_chain (Suc 0) X (frag_of (restrict (g \<circ> (\<lambda>x. x 0)) (standard_simplex 1)))"
+ proof -
+ have "continuous_map (subtopology (powertop_real UNIV) (standard_simplex (Suc 0)))
+ (top_of_set {0..1}) (\<lambda>x. x 0)"
+ apply (auto simp: continuous_map_in_subtopology g)
+ apply (metis (mono_tags) UNIV_I continuous_map_from_subtopology continuous_map_product_projection)
+ apply (simp_all add: standard_simplex_def)
+ done
+ moreover have "continuous_map (top_of_set {0..1}) X g"
+ using contg by blast
+ ultimately show ?thesis
+ by (force simp: singular_chain_of chain_boundary_of singular_simplex_def continuous_map_compose)
+ qed
+ moreover
+ have "chain_boundary (Suc 0) (frag_of (restrict (g \<circ> (\<lambda>x. x 0)) (standard_simplex 1))) =
+ frag_of f - frag_of f'"
+ proof -
+ have "singular_face (Suc 0) 0 (g \<circ> (\<lambda>x. x 0)) = f"
+ "singular_face (Suc 0) (Suc 0) (g \<circ> (\<lambda>x. x 0)) = f'"
+ using assms
+ by (auto simp: singular_face_def singular_simplex_def extensional_def simplical_face_def standard_simplex_0 g0 g1)
+ then show ?thesis
+ by (simp add: singular_chain_of chain_boundary_of)
+ qed
+ ultimately
+ show ?thesis
+ by (auto simp: homologous_rel_def singular_boundary)
+qed
+
+
+proposition iso_integer_zeroth_homology_group:
+ assumes X: "path_connected_space X" and f: "singular_simplex 0 X f"
+ shows "pow (homology_group 0 X) (homologous_rel_set 0 X {} (frag_of f))
+ \<in> iso integer_group (homology_group 0 X)" (is "pow ?H ?q \<in> iso _ ?H")
+proof -
+ have srf: "singular_relcycle 0 X {} (frag_of f)"
+ by (simp add: chain_boundary_def f singular_chain_of singular_cycle)
+ then have qcarr: "?q \<in> carrier ?H"
+ by (simp add: carrier_relative_homology_group_0)
+ have 1: "homologous_rel_set 0 X {} a \<in> range (\<lambda>n. homologous_rel_set 0 X {} (frag_cmul n (frag_of f)))"
+ if "singular_relcycle 0 X {} a" for a
+ proof -
+ have "singular_chain 0 X d \<Longrightarrow>
+ homologous_rel_set 0 X {} d \<in> range (\<lambda>n. homologous_rel_set 0 X {} (frag_cmul n (frag_of f)))" for d
+ unfolding singular_chain_def
+ proof (induction d rule: frag_induction)
+ case zero
+ then show ?case
+ by (metis frag_cmul_zero rangeI)
+ next
+ case (one x)
+ then have "\<exists>i. homologous_rel_set 0 X {} (frag_cmul i (frag_of f))
+ = homologous_rel_set 0 X {} (frag_of x)"
+ by (metis (no_types) iso_integer_zeroth_homology_group_aux [OF X] f frag_cmul_one homologous_rel_eq mem_Collect_eq)
+ with one show ?case
+ by auto
+ next
+ case (diff a b)
+ then obtain c d where
+ "homologous_rel 0 X {} (a - b) (frag_cmul c (frag_of f) - frag_cmul d (frag_of f))"
+ using homologous_rel_diff by (fastforce simp add: homologous_rel_set_eq)
+ then show ?case
+ by (rule_tac x="c-d" in image_eqI) (auto simp: homologous_rel_set_eq frag_cmul_diff_distrib)
+ qed
+ with that show ?thesis
+ unfolding singular_relcycle_def by blast
+ qed
+ have 2: "n = 0"
+ if "homologous_rel_set 0 X {} (frag_cmul n (frag_of f)) = \<one>\<^bsub>relative_homology_group 0 X {}\<^esub>"
+ for n
+ proof -
+ have "singular_chain (Suc 0) X d
+ \<Longrightarrow> frag_extend (\<lambda>x. frag_of f) (chain_boundary (Suc 0) d) = 0" for d
+ unfolding singular_chain_def
+ proof (induction d rule: frag_induction)
+ case (one x)
+ then show ?case
+ by (simp add: frag_extend_diff chain_boundary_of)
+ next
+ case (diff a b)
+ then show ?case
+ by (simp add: chain_boundary_diff frag_extend_diff)
+ qed auto
+ with that show ?thesis
+ by (force simp: singular_boundary relative_homology_group_def homologous_rel_set_eq_relboundary frag_extend_cmul)
+ qed
+ interpret GH : group_hom integer_group ?H "([^]\<^bsub>?H\<^esub>) ?q"
+ by (simp add: group_hom_def group_hom_axioms_def qcarr group.hom_integer_group_pow)
+ have eq: "pow ?H ?q = (\<lambda>n. homologous_rel_set 0 X {} (frag_cmul n (frag_of f)))"
+ proof
+ fix n
+ have "frag_of f
+ \<in> carrier (subgroup_generated
+ (free_Abelian_group (singular_simplex_set 0 X)) (singular_relcycle_set 0 X {}))"
+ by (metis carrier_relcycle_group chain_group_def mem_Collect_eq relcycle_group_def srf)
+ then have ff: "frag_of f [^]\<^bsub>relcycle_group 0 X {}\<^esub> n = frag_cmul n (frag_of f)"
+ by (simp add: relcycle_group_def chain_group_def group.int_pow_subgroup_generated f)
+ show "pow ?H ?q n = homologous_rel_set 0 X {} (frag_cmul n (frag_of f))"
+ apply (rule subst [OF right_coset_singular_relboundary])
+ apply (simp add: relative_homology_group_def)
+ apply (simp add: srf ff normal.FactGroup_int_pow normal_subgroup_singular_relboundary_relcycle)
+ done
+ qed
+ show ?thesis
+ apply (subst GH.iso_iff)
+ apply (simp add: eq)
+ apply (auto simp: carrier_relative_homology_group_0 1 2)
+ done
+qed
+
+
+corollary isomorphic_integer_zeroth_homology_group:
+ assumes X: "path_connected_space X" "topspace X \<noteq> {}"
+ shows "homology_group 0 X \<cong> integer_group"
+proof -
+ obtain a where a: "a \<in> topspace X"
+ using assms by auto
+ have "singular_simplex 0 X (restrict (\<lambda>x. a) (standard_simplex 0))"
+ by (simp add: singular_simplex_def a)
+ then show ?thesis
+ using X group.iso_sym group_integer_group is_isoI iso_integer_zeroth_homology_group by blast
+qed
+
+
+corollary homology_coefficients:
+ "topspace X = {a} \<Longrightarrow> homology_group 0 X \<cong> integer_group"
+ using isomorphic_integer_zeroth_homology_group path_connectedin_topspace by fastforce
+
+proposition zeroth_homology_group:
+ "homology_group 0 X \<cong> free_Abelian_group (path_components_of X)"
+proof -
+ obtain h where h: "h \<in> iso (sum_group (path_components_of X) (\<lambda>S. homology_group 0 (subtopology X S)))
+ (homology_group 0 X)"
+ proof (rule that [OF homology_additivity_axiom_gen])
+ show "disjoint (path_components_of X)"
+ by (simp add: pairwise_disjoint_path_components_of)
+ show "\<Union>(path_components_of X) = topspace X"
+ by (rule Union_path_components_of)
+ next
+ fix C T
+ assume "path_connectedin X C" "T \<in> path_components_of X" "\<not> disjnt C T"
+ then show "C \<subseteq> T"
+ by (metis path_components_of_maximal disjnt_sym)+
+ qed
+ have "homology_group 0 X \<cong> sum_group (path_components_of X) (\<lambda>S. homology_group 0 (subtopology X S))"
+ by (rule group.iso_sym) (use h is_iso_def in auto)
+ also have "\<dots> \<cong> sum_group (path_components_of X) (\<lambda>i. integer_group)"
+ proof (rule iso_sum_groupI)
+ show "homology_group 0 (subtopology X i) \<cong> integer_group" if "i \<in> path_components_of X" for i
+ by (metis that isomorphic_integer_zeroth_homology_group nonempty_path_components_of
+ path_connectedin_def path_connectedin_path_components_of topspace_subtopology_subset)
+ qed auto
+ also have "\<dots> \<cong> free_Abelian_group (path_components_of X)"
+ using path_connectedin_path_components_of nonempty_path_components_of
+ by (simp add: isomorphic_sum_integer_group path_connectedin_def)
+ finally show ?thesis .
+qed
+
+
+lemma isomorphic_homology_imp_path_components:
+ assumes "homology_group 0 X \<cong> homology_group 0 Y"
+ shows "path_components_of X \<approx> path_components_of Y"
+proof -
+ have "free_Abelian_group (path_components_of X) \<cong> homology_group 0 X"
+ by (rule group.iso_sym) (auto simp: zeroth_homology_group)
+ also have "\<dots> \<cong> homology_group 0 Y"
+ by (rule assms)
+ also have "\<dots> \<cong> free_Abelian_group (path_components_of Y)"
+ by (rule zeroth_homology_group)
+ finally have "free_Abelian_group (path_components_of X) \<cong> free_Abelian_group (path_components_of Y)" .
+ then show ?thesis
+ by (simp add: isomorphic_free_Abelian_groups)
+qed
+
+
+lemma isomorphic_homology_imp_path_connectedness:
+ assumes "homology_group 0 X \<cong> homology_group 0 Y"
+ shows "path_connected_space X \<longleftrightarrow> path_connected_space Y"
+proof -
+ obtain h where h: "bij_betw h (path_components_of X) (path_components_of Y)"
+ using assms isomorphic_homology_imp_path_components eqpoll_def by blast
+ have 1: "path_components_of X \<subseteq> {a} \<Longrightarrow> path_components_of Y \<subseteq> {h a}" for a
+ using h unfolding bij_betw_def by blast
+ have 2: "path_components_of Y \<subseteq> {a}
+ \<Longrightarrow> path_components_of X \<subseteq> {inv_into (path_components_of X) h a}" for a
+ using h [THEN bij_betw_inv_into] unfolding bij_betw_def by blast
+ show ?thesis
+ unfolding path_connected_space_iff_components_subset_singleton
+ by (blast intro: dest: 1 2)
+qed
+
+
+subsection\<open>More basic properties of homology groups, deduced from the E-S axioms\<close>
+
+lemma trivial_homology_group:
+ "p < 0 \<Longrightarrow> trivial_group(homology_group p X)"
+ by simp
+
+lemma hom_induced_empty_hom:
+ "(hom_induced p X {} X' {} f) \<in> hom (homology_group p X) (homology_group p X')"
+ by (simp add: hom_induced_hom)
+
+lemma hom_induced_compose_empty:
+ "\<lbrakk>continuous_map X Y f; continuous_map Y Z g\<rbrakk>
+ \<Longrightarrow> hom_induced p X {} Z {} (g \<circ> f) = hom_induced p Y {} Z {} g \<circ> hom_induced p X {} Y {} f"
+ by (simp add: hom_induced_compose)
+
+lemma homology_homotopy_empty:
+ "homotopic_with (\<lambda>h. True) X Y f g \<Longrightarrow> hom_induced p X {} Y {} f = hom_induced p X {} Y {} g"
+ by (simp add: homology_homotopy_axiom)
+
+lemma homotopy_equivalence_relative_homology_group_isomorphisms:
+ assumes contf: "continuous_map X Y f" and fim: "f ` S \<subseteq> T"
+ and contg: "continuous_map Y X g" and gim: "g ` T \<subseteq> S"
+ and gf: "homotopic_with (\<lambda>h. h ` S \<subseteq> S) X X (g \<circ> f) id"
+ and fg: "homotopic_with (\<lambda>k. k ` T \<subseteq> T) Y Y (f \<circ> g) id"
+ shows "group_isomorphisms (relative_homology_group p X S) (relative_homology_group p Y T)
+ (hom_induced p X S Y T f) (hom_induced p Y T X S g)"
+ unfolding group_isomorphisms_def
+proof (intro conjI ballI)
+ fix x
+ assume x: "x \<in> carrier (relative_homology_group p X S)"
+ then show "hom_induced p Y T X S g (hom_induced p X S Y T f x) = x"
+ using homology_homotopy_axiom [OF gf, of p]
+ apply (simp add: hom_induced_compose [OF contf fim contg gim])
+ apply (metis comp_apply hom_induced_id)
+ done
+next
+ fix y
+ assume "y \<in> carrier (relative_homology_group p Y T)"
+ then show "hom_induced p X S Y T f (hom_induced p Y T X S g y) = y"
+ using homology_homotopy_axiom [OF fg, of p]
+ apply (simp add: hom_induced_compose [OF contg gim contf fim])
+ apply (metis comp_apply hom_induced_id)
+ done
+qed (auto simp: hom_induced_hom)
+
+
+lemma homotopy_equivalence_relative_homology_group_isomorphism:
+ assumes "continuous_map X Y f" and fim: "f ` S \<subseteq> T"
+ and "continuous_map Y X g" and gim: "g ` T \<subseteq> S"
+ and "homotopic_with (\<lambda>h. h ` S \<subseteq> S) X X (g \<circ> f) id"
+ and "homotopic_with (\<lambda>k. k ` T \<subseteq> T) Y Y (f \<circ> g) id"
+ shows "(hom_induced p X S Y T f) \<in> iso (relative_homology_group p X S) (relative_homology_group p Y T)"
+ using homotopy_equivalence_relative_homology_group_isomorphisms [OF assms] group_isomorphisms_imp_iso
+ by metis
+
+lemma homotopy_equivalence_homology_group_isomorphism:
+ assumes "continuous_map X Y f"
+ and "continuous_map Y X g"
+ and "homotopic_with (\<lambda>h. True) X X (g \<circ> f) id"
+ and "homotopic_with (\<lambda>k. True) Y Y (f \<circ> g) id"
+ shows "(hom_induced p X {} Y {} f) \<in> iso (homology_group p X) (homology_group p Y)"
+ apply (rule homotopy_equivalence_relative_homology_group_isomorphism)
+ using assms by auto
+
+lemma homotopy_equivalent_space_imp_isomorphic_relative_homology_groups:
+ assumes "continuous_map X Y f" and fim: "f ` S \<subseteq> T"
+ and "continuous_map Y X g" and gim: "g ` T \<subseteq> S"
+ and "homotopic_with (\<lambda>h. h ` S \<subseteq> S) X X (g \<circ> f) id"
+ and "homotopic_with (\<lambda>k. k ` T \<subseteq> T) Y Y (f \<circ> g) id"
+ shows "relative_homology_group p X S \<cong> relative_homology_group p Y T"
+ using homotopy_equivalence_relative_homology_group_isomorphism [OF assms]
+ unfolding is_iso_def by blast
+
+lemma homotopy_equivalent_space_imp_isomorphic_homology_groups:
+ "X homotopy_equivalent_space Y \<Longrightarrow> homology_group p X \<cong> homology_group p Y"
+ unfolding homotopy_equivalent_space_def
+ by (auto intro: homotopy_equivalent_space_imp_isomorphic_relative_homology_groups)
+
+lemma homeomorphic_space_imp_isomorphic_homology_groups:
+ "X homeomorphic_space Y \<Longrightarrow> homology_group p X \<cong> homology_group p Y"
+ by (simp add: homeomorphic_imp_homotopy_equivalent_space homotopy_equivalent_space_imp_isomorphic_homology_groups)
+
+lemma trivial_relative_homology_group_gen:
+ assumes "continuous_map X (subtopology X S) f"
+ "homotopic_with (\<lambda>h. True) (subtopology X S) (subtopology X S) f id"
+ "homotopic_with (\<lambda>k. True) X X f id"
+ shows "trivial_group(relative_homology_group p X S)"
+proof (rule exact_seq_imp_triviality)
+ show "exact_seq ([homology_group (p-1) X,
+ homology_group (p-1) (subtopology X S),
+ relative_homology_group p X S, homology_group p X, homology_group p (subtopology X S)],
+ [hom_induced (p-1) (subtopology X S) {} X {} id,
+ hom_boundary p X S,
+ hom_induced p X {} X S id,
+ hom_induced p (subtopology X S) {} X {} id])"
+ using homology_exactness_axiom_1 homology_exactness_axiom_2 homology_exactness_axiom_3
+ by (metis exact_seq_cons_iff)
+next
+ show "hom_induced p (subtopology X S) {} X {} id
+ \<in> iso (homology_group p (subtopology X S)) (homology_group p X)"
+ "hom_induced (p - 1) (subtopology X S) {} X {} id
+ \<in> iso (homology_group (p - 1) (subtopology X S)) (homology_group (p - 1) X)"
+ using assms
+ by (auto intro: homotopy_equivalence_relative_homology_group_isomorphism)
+qed
+
+
+lemma trivial_relative_homology_group_topspace:
+ "trivial_group(relative_homology_group p X (topspace X))"
+ by (rule trivial_relative_homology_group_gen [where f=id]) auto
+
+lemma trivial_relative_homology_group_empty:
+ "topspace X = {} \<Longrightarrow> trivial_group(relative_homology_group p X S)"
+ by (metis Int_absorb2 empty_subsetI relative_homology_group_restrict trivial_relative_homology_group_topspace)
+
+lemma trivial_homology_group_empty:
+ "topspace X = {} \<Longrightarrow> trivial_group(homology_group p X)"
+ by (simp add: trivial_relative_homology_group_empty)
+
+lemma homeomorphic_maps_relative_homology_group_isomorphisms:
+ assumes "homeomorphic_maps X Y f g" and im: "f ` S \<subseteq> T" "g ` T \<subseteq> S"
+ shows "group_isomorphisms (relative_homology_group p X S) (relative_homology_group p Y T)
+ (hom_induced p X S Y T f) (hom_induced p Y T X S g)"
+proof -
+ have fg: "continuous_map X Y f" "continuous_map Y X g"
+ "(\<forall>x\<in>topspace X. g (f x) = x)" "(\<forall>y\<in>topspace Y. f (g y) = y)"
+ using assms by (simp_all add: homeomorphic_maps_def)
+ have "group_isomorphisms
+ (relative_homology_group p X (topspace X \<inter> S))
+ (relative_homology_group p Y (topspace Y \<inter> T))
+ (hom_induced p X (topspace X \<inter> S) Y (topspace Y \<inter> T) f)
+ (hom_induced p Y (topspace Y \<inter> T) X (topspace X \<inter> S) g)"
+ proof (rule homotopy_equivalence_relative_homology_group_isomorphisms)
+ show "homotopic_with (\<lambda>h. h ` (topspace X \<inter> S) \<subseteq> topspace X \<inter> S) X X (g \<circ> f) id"
+ using fg im by (auto intro: homotopic_with_equal continuous_map_compose)
+ next
+ show "homotopic_with (\<lambda>k. k ` (topspace Y \<inter> T) \<subseteq> topspace Y \<inter> T) Y Y (f \<circ> g) id"
+ using fg im by (auto intro: homotopic_with_equal continuous_map_compose)
+ qed (use im fg in \<open>auto simp: continuous_map_def\<close>)
+ then show ?thesis
+ by simp
+qed
+
+lemma homeomorphic_map_relative_homology_iso:
+ assumes f: "homeomorphic_map X Y f" and S: "S \<subseteq> topspace X" "f ` S = T"
+ shows "(hom_induced p X S Y T f) \<in> iso (relative_homology_group p X S) (relative_homology_group p Y T)"
+proof -
+ obtain g where g: "homeomorphic_maps X Y f g"
+ using homeomorphic_map_maps f by metis
+ then have "group_isomorphisms (relative_homology_group p X S) (relative_homology_group p Y T)
+ (hom_induced p X S Y T f) (hom_induced p Y T X S g)"
+ using S g by (auto simp: homeomorphic_maps_def intro!: homeomorphic_maps_relative_homology_group_isomorphisms)
+ then show ?thesis
+ by (rule group_isomorphisms_imp_iso)
+qed
+
+lemma inj_on_hom_induced_section_map:
+ assumes "section_map X Y f"
+ shows "inj_on (hom_induced p X {} Y {} f) (carrier (homology_group p X))"
+proof -
+ obtain g where cont: "continuous_map X Y f" "continuous_map Y X g"
+ and gf: "\<And>x. x \<in> topspace X \<Longrightarrow> g (f x) = x"
+ using assms by (auto simp: section_map_def retraction_maps_def)
+ show ?thesis
+ proof (rule inj_on_inverseI)
+ fix x
+ assume x: "x \<in> carrier (homology_group p X)"
+ have "continuous_map X X (\<lambda>x. g (f x))"
+ by (metis (no_types, lifting) continuous_map_eq continuous_map_id gf id_apply)
+ with x show "hom_induced p Y {} X {} g (hom_induced p X {} Y {} f x) = x"
+ using hom_induced_compose_empty [OF cont, symmetric]
+ apply (simp add: o_def fun_eq_iff)
+ apply (rule hom_induced_id_gen)
+ apply (auto simp: gf)
+ done
+ qed
+qed
+
+corollary mon_hom_induced_section_map:
+ assumes "section_map X Y f"
+ shows "(hom_induced p X {} Y {} f) \<in> mon (homology_group p X) (homology_group p Y)"
+ by (simp add: hom_induced_empty_hom inj_on_hom_induced_section_map [OF assms] mon_def)
+
+lemma surj_hom_induced_retraction_map:
+ assumes "retraction_map X Y f"
+ shows "carrier (homology_group p Y) = (hom_induced p X {} Y {} f) ` carrier (homology_group p X)"
+ (is "?lhs = ?rhs")
+proof -
+ obtain g where cont: "continuous_map Y X g" "continuous_map X Y f"
+ and fg: "\<And>x. x \<in> topspace Y \<Longrightarrow> f (g x) = x"
+ using assms by (auto simp: retraction_map_def retraction_maps_def)
+ have "x = hom_induced p X {} Y {} f (hom_induced p Y {} X {} g x)"
+ if x: "x \<in> carrier (homology_group p Y)" for x
+ proof -
+ have "continuous_map Y Y (\<lambda>x. f (g x))"
+ by (metis (no_types, lifting) continuous_map_eq continuous_map_id fg id_apply)
+ with x show ?thesis
+ using hom_induced_compose_empty [OF cont, symmetric]
+ apply (simp add: o_def fun_eq_iff)
+ apply (rule hom_induced_id_gen [symmetric])
+ apply (auto simp: fg)
+ done
+ qed
+ moreover
+ have "(hom_induced p Y {} X {} g x) \<in> carrier (homology_group p X)"
+ if "x \<in> carrier (homology_group p Y)" for x
+ by (metis hom_induced)
+ ultimately have "?lhs \<subseteq> ?rhs"
+ by auto
+ moreover have "?rhs \<subseteq> ?lhs"
+ using hom_induced_hom [of p X "{}" Y "{}" f]
+ by (simp add: hom_def flip: image_subset_iff_funcset)
+ ultimately show ?thesis
+ by auto
+qed
+
+
+corollary epi_hom_induced_retraction_map:
+ assumes "retraction_map X Y f"
+ shows "(hom_induced p X {} Y {} f) \<in> epi (homology_group p X) (homology_group p Y)"
+ using assms epi_iff_subset hom_induced_empty_hom surj_hom_induced_retraction_map by fastforce
+
+
+lemma homeomorphic_map_homology_iso:
+ assumes "homeomorphic_map X Y f"
+ shows "(hom_induced p X {} Y {} f) \<in> iso (homology_group p X) (homology_group p Y)"
+ using assms
+ apply (simp add: iso_def bij_betw_def flip: section_and_retraction_eq_homeomorphic_map)
+ by (metis inj_on_hom_induced_section_map surj_hom_induced_retraction_map hom_induced_hom)
+
+(*See also hom_hom_induced_inclusion*)
+lemma inj_on_hom_induced_inclusion:
+ assumes "S = {} \<or> S retract_of_space X"
+ shows "inj_on (hom_induced p (subtopology X S) {} X {} id) (carrier (homology_group p (subtopology X S)))"
+ using assms
+proof
+ assume "S = {}"
+ then have "trivial_group(homology_group p (subtopology X S))"
+ by (auto simp: topspace_subtopology intro: trivial_homology_group_empty)
+ then show ?thesis
+ by (auto simp: inj_on_def trivial_group_def)
+next
+ assume "S retract_of_space X"
+ then show ?thesis
+ by (simp add: retract_of_space_section_map inj_on_hom_induced_section_map)
+qed
+
+lemma trivial_homomorphism_hom_boundary_inclusion:
+ assumes "S = {} \<or> S retract_of_space X"
+ shows "trivial_homomorphism
+ (relative_homology_group p X S) (homology_group (p-1) (subtopology X S))
+ (hom_boundary p X S)"
+ apply (rule iffD1 [OF exact_seq_mon_eq_triviality inj_on_hom_induced_inclusion [OF assms]])
+ apply (rule exact_seq.intros)
+ apply (rule homology_exactness_axiom_1 [of p])
+ using homology_exactness_axiom_2 [of p]
+ by auto
+
+lemma epi_hom_induced_relativization:
+ assumes "S = {} \<or> S retract_of_space X"
+ shows "(hom_induced p X {} X S id) ` carrier (homology_group p X) = carrier (relative_homology_group p X S)"
+ apply (rule iffD2 [OF exact_seq_epi_eq_triviality trivial_homomorphism_hom_boundary_inclusion])
+ apply (rule exact_seq.intros)
+ apply (rule homology_exactness_axiom_1 [of p])
+ using homology_exactness_axiom_2 [of p] apply (auto simp: assms)
+ done
+
+(*different in HOL Light because we don't need short_exact_sequence*)
+lemmas short_exact_sequence_hom_induced_inclusion = homology_exactness_axiom_3
+
+lemma group_isomorphisms_homology_group_prod_retract:
+ assumes "S = {} \<or> S retract_of_space X"
+ obtains \<H> \<K> where
+ "subgroup \<H> (homology_group p X)"
+ "subgroup \<K> (homology_group p X)"
+ "(\<lambda>(x, y). x \<otimes>\<^bsub>homology_group p X\<^esub> y)
+ \<in> iso (DirProd (subgroup_generated (homology_group p X) \<H>) (subgroup_generated (homology_group p X) \<K>))
+ (homology_group p X)"
+ "(hom_induced p (subtopology X S) {} X {} id)
+ \<in> iso (homology_group p (subtopology X S)) (subgroup_generated (homology_group p X) \<H>)"
+ "(hom_induced p X {} X S id)
+ \<in> iso (subgroup_generated (homology_group p X) \<K>) (relative_homology_group p X S)"
+ using assms
+proof
+ assume "S = {}"
+ show thesis
+ proof (rule splitting_lemma_left [OF homology_exactness_axiom_3 [of p]])
+ let ?f = "\<lambda>x. one(homology_group p (subtopology X {}))"
+ show "?f \<in> hom (homology_group p X) (homology_group p (subtopology X {}))"
+ by (simp add: trivial_hom)
+ have tg: "trivial_group (homology_group p (subtopology X {}))"
+ by (auto simp: topspace_subtopology trivial_homology_group_empty)
+ then have [simp]: "carrier (homology_group p (subtopology X {})) = {one (homology_group p (subtopology X {}))}"
+ by (auto simp: trivial_group_def)
+ then show "?f (hom_induced p (subtopology X {}) {} X {} id x) = x"
+ if "x \<in> carrier (homology_group p (subtopology X {}))" for x
+ using that by auto
+ show "inj_on (hom_induced p (subtopology X {}) {} X {} id)
+ (carrier (homology_group p (subtopology X {})))"
+ by auto
+ show "hom_induced p X {} X {} id ` carrier (homology_group p X) = carrier (homology_group p X)"
+ by (metis epi_hom_induced_relativization)
+ next
+ fix \<H> \<K>
+ assume *: "\<H> \<lhd> homology_group p X" "\<K> \<lhd> homology_group p X"
+ "\<H> \<inter> \<K> \<subseteq> {\<one>\<^bsub>homology_group p X\<^esub>}"
+ "hom_induced p (subtopology X {}) {} X {} id
+ \<in> Group.iso (homology_group p (subtopology X {})) (subgroup_generated (homology_group p X) \<H>)"
+ "hom_induced p X {} X {} id
+ \<in> Group.iso (subgroup_generated (homology_group p X) \<K>) (relative_homology_group p X {})"
+ "\<H> <#>\<^bsub>homology_group p X\<^esub> \<K> = carrier (homology_group p X)"
+ show thesis
+ proof (rule that)
+ show "(\<lambda>(x, y). x \<otimes>\<^bsub>homology_group p X\<^esub> y)
+ \<in> iso (subgroup_generated (homology_group p X) \<H> \<times>\<times> subgroup_generated (homology_group p X) \<K>)
+ (homology_group p X)"
+ using * by (simp add: group_disjoint_sum.iso_group_mul normal_def group_disjoint_sum_def)
+ qed (use \<open>S = {}\<close> * in \<open>auto simp: normal_def\<close>)
+ qed
+next
+ assume "S retract_of_space X"
+ then obtain r where "S \<subseteq> topspace X" and r: "continuous_map X (subtopology X S) r"
+ and req: "\<forall>x \<in> S. r x = x"
+ by (auto simp: retract_of_space_def)
+ show thesis
+ proof (rule splitting_lemma_left [OF homology_exactness_axiom_3 [of p]])
+ let ?f = "hom_induced p X {} (subtopology X S) {} r"
+ show "?f \<in> hom (homology_group p X) (homology_group p (subtopology X S))"
+ by (simp add: hom_induced_empty_hom)
+ show eqx: "?f (hom_induced p (subtopology X S) {} X {} id x) = x"
+ if "x \<in> carrier (homology_group p (subtopology X S))" for x
+ proof -
+ have "hom_induced p (subtopology X S) {} (subtopology X S) {} r x = x"
+ by (metis \<open>S \<subseteq> topspace X\<close> continuous_map_from_subtopology hom_induced_id_gen inf.absorb_iff2 r req that topspace_subtopology)
+ then show ?thesis
+ by (simp add: r hom_induced_compose [unfolded o_def fun_eq_iff, rule_format, symmetric])
+ qed
+ then show "inj_on (hom_induced p (subtopology X S) {} X {} id)
+ (carrier (homology_group p (subtopology X S)))"
+ unfolding inj_on_def by metis
+ show "hom_induced p X {} X S id ` carrier (homology_group p X) = carrier (relative_homology_group p X S)"
+ by (simp add: \<open>S retract_of_space X\<close> epi_hom_induced_relativization)
+ next
+ fix \<H> \<K>
+ assume *: "\<H> \<lhd> homology_group p X" "\<K> \<lhd> homology_group p X"
+ "\<H> \<inter> \<K> \<subseteq> {\<one>\<^bsub>homology_group p X\<^esub>}"
+ "\<H> <#>\<^bsub>homology_group p X\<^esub> \<K> = carrier (homology_group p X)"
+ "hom_induced p (subtopology X S) {} X {} id
+ \<in> Group.iso (homology_group p (subtopology X S)) (subgroup_generated (homology_group p X) \<H>)"
+ "hom_induced p X {} X S id
+ \<in> Group.iso (subgroup_generated (homology_group p X) \<K>) (relative_homology_group p X S)"
+ show "thesis"
+ proof (rule that)
+ show "(\<lambda>(x, y). x \<otimes>\<^bsub>homology_group p X\<^esub> y)
+ \<in> iso (subgroup_generated (homology_group p X) \<H> \<times>\<times> subgroup_generated (homology_group p X) \<K>)
+ (homology_group p X)"
+ using *
+ by (simp add: group_disjoint_sum.iso_group_mul normal_def group_disjoint_sum_def)
+ qed (use * in \<open>auto simp: normal_def\<close>)
+ qed
+qed
+
+
+
+lemma isomorphic_group_homology_group_prod_retract:
+ assumes "S = {} \<or> S retract_of_space X"
+ shows "homology_group p X \<cong> homology_group p (subtopology X S) \<times>\<times> relative_homology_group p X S"
+ (is "?lhs \<cong> ?rhs")
+proof -
+ obtain \<H> \<K> where
+ "subgroup \<H> (homology_group p X)"
+ "subgroup \<K> (homology_group p X)"
+ and 1: "(\<lambda>(x, y). x \<otimes>\<^bsub>homology_group p X\<^esub> y)
+ \<in> iso (DirProd (subgroup_generated (homology_group p X) \<H>) (subgroup_generated (homology_group p X) \<K>))
+ (homology_group p X)"
+ "(hom_induced p (subtopology X S) {} X {} id)
+ \<in> iso (homology_group p (subtopology X S)) (subgroup_generated (homology_group p X) \<H>)"
+ "(hom_induced p X {} X S id)
+ \<in> iso (subgroup_generated (homology_group p X) \<K>) (relative_homology_group p X S)"
+ using group_isomorphisms_homology_group_prod_retract [OF assms] by blast
+ have "?lhs \<cong> subgroup_generated (homology_group p X) \<H> \<times>\<times> subgroup_generated (homology_group p X) \<K>"
+ by (meson DirProd_group 1 abelian_homology_group comm_group_def group.abelian_subgroup_generated group.iso_sym is_isoI)
+ also have "\<dots> \<cong> ?rhs"
+ by (meson "1"(2) "1"(3) abelian_homology_group comm_group_def group.DirProd_iso_trans group.abelian_subgroup_generated group.iso_sym is_isoI)
+ finally show ?thesis .
+qed
+
+
+lemma homology_additivity_explicit:
+ assumes "openin X S" "openin X T" "disjnt S T" and SUT: "S \<union> T = topspace X"
+ shows "(\<lambda>(a,b).(hom_induced p (subtopology X S) {} X {} id a)
+ \<otimes>\<^bsub>homology_group p X\<^esub>
+ (hom_induced p (subtopology X T) {} X {} id b))
+ \<in> iso (DirProd (homology_group p (subtopology X S)) (homology_group p (subtopology X T)))
+ (homology_group p X)"
+proof -
+ have "closedin X S" "closedin X T"
+ using assms Un_commute disjnt_sym
+ by (metis Diff_cancel Diff_triv Un_Diff disjnt_def openin_closedin_eq sup_bot.right_neutral)+
+ with \<open>openin X S\<close> \<open>openin X T\<close> have SS: "X closure_of S \<subseteq> X interior_of S" and TT: "X closure_of T \<subseteq> X interior_of T"
+ by (simp_all add: closure_of_closedin interior_of_openin)
+ have [simp]: "S \<union> T - T = S" "S \<union> T - S = T"
+ using \<open>disjnt S T\<close>
+ by (auto simp: Diff_triv Un_Diff disjnt_def)
+ let ?f = "hom_induced p X {} X T id"
+ let ?g = "hom_induced p X {} X S id"
+ let ?h = "hom_induced p (subtopology X S) {} X T id"
+ let ?i = "hom_induced p (subtopology X S) {} X {} id"
+ let ?j = "hom_induced p (subtopology X T) {} X {} id"
+ let ?k = "hom_induced p (subtopology X T) {} X S id"
+ let ?A = "homology_group p (subtopology X S)"
+ let ?B = "homology_group p (subtopology X T)"
+ let ?C = "relative_homology_group p X T"
+ let ?D = "relative_homology_group p X S"
+ let ?G = "homology_group p X"
+ have h: "?h \<in> iso ?A ?C" and k: "?k \<in> iso ?B ?D"
+ using homology_excision_axiom [OF TT, of "S \<union> T" p]
+ using homology_excision_axiom [OF SS, of "S \<union> T" p]
+ by auto (simp_all add: SUT)
+ have 1: "\<And>x. (hom_induced p X {} X T id \<circ> hom_induced p (subtopology X S) {} X {} id) x
+ = hom_induced p (subtopology X S) {} X T id x"
+ by (simp flip: hom_induced_compose)
+ have 2: "\<And>x. (hom_induced p X {} X S id \<circ> hom_induced p (subtopology X T) {} X {} id) x
+ = hom_induced p (subtopology X T) {} X S id x"
+ by (simp flip: hom_induced_compose)
+ show ?thesis
+ using exact_sequence_sum_lemma
+ [OF abelian_homology_group h k homology_exactness_axiom_3 homology_exactness_axiom_3] 1 2
+ by auto
+qed
+
+
+subsection\<open>Generalize exact homology sequence to triples\<close>
+
+definition hom_relboundary :: "[int,'a topology,'a set,'a set,'a chain set] \<Rightarrow> 'a chain set"
+ where
+ "hom_relboundary p X S T =
+ hom_induced (p - 1) (subtopology X S) {} (subtopology X S) T id \<circ>
+ hom_boundary p X S"
+
+lemma group_homomorphism_hom_relboundary:
+ "hom_relboundary p X S T
+ \<in> hom (relative_homology_group p X S) (relative_homology_group (p - 1) (subtopology X S) T)"
+ unfolding hom_relboundary_def
+ proof (rule hom_compose)
+ show "hom_boundary p X S \<in> hom (relative_homology_group p X S) (homology_group(p - 1) (subtopology X S))"
+ by (simp add: hom_boundary_hom)
+ show "hom_induced (p - 1) (subtopology X S) {} (subtopology X S) T id
+ \<in> hom (homology_group(p - 1) (subtopology X S)) (relative_homology_group (p - 1) (subtopology X S) T)"
+ by (simp add: hom_induced_hom)
+qed
+
+lemma hom_relboundary:
+ "hom_relboundary p X S T c \<in> carrier (relative_homology_group (p - 1) (subtopology X S) T)"
+ by (simp add: hom_relboundary_def hom_induced_carrier)
+
+lemma hom_relboundary_empty: "hom_relboundary p X S {} = hom_boundary p X S"
+ apply (simp add: hom_relboundary_def o_def)
+ apply (subst hom_induced_id)
+ apply (metis hom_boundary_carrier, auto)
+ done
+
+lemma naturality_hom_induced_relboundary:
+ assumes "continuous_map X Y f" "f ` S \<subseteq> U" "f ` T \<subseteq> V"
+ shows "hom_relboundary p Y U V \<circ>
+ hom_induced p X S Y (U) f =
+ hom_induced (p - 1) (subtopology X S) T (subtopology Y U) V f \<circ>
+ hom_relboundary p X S T"
+proof -
+ have [simp]: "continuous_map (subtopology X S) (subtopology Y U) f"
+ using assms continuous_map_from_subtopology continuous_map_in_subtopology topspace_subtopology by fastforce
+ have "hom_induced (p - 1) (subtopology Y U) {} (subtopology Y U) V id \<circ>
+ hom_induced (p - 1) (subtopology X S) {} (subtopology Y U) {} f
+ = hom_induced (p - 1) (subtopology X S) T (subtopology Y U) V f \<circ>
+ hom_induced (p - 1) (subtopology X S) {} (subtopology X S) T id"
+ using assms by (simp flip: hom_induced_compose)
+ then show ?thesis
+ apply (simp add: hom_relboundary_def comp_assoc naturality_hom_induced assms)
+ apply (simp flip: comp_assoc)
+ done
+qed
+
+proposition homology_exactness_triple_1:
+ assumes "T \<subseteq> S"
+ shows "exact_seq ([relative_homology_group(p - 1) (subtopology X S) T,
+ relative_homology_group p X S,
+ relative_homology_group p X T],
+ [hom_relboundary p X S T, hom_induced p X T X S id])"
+ (is "exact_seq ([?G1,?G2,?G3], [?h1,?h2])")
+proof -
+ have iTS: "id ` T \<subseteq> S" and [simp]: "S \<inter> T = T"
+ using assms by auto
+ have "?h2 B \<in> kernel ?G2 ?G1 ?h1" for B
+ proof -
+ have "hom_boundary p X T B \<in> carrier (relative_homology_group (p - 1) (subtopology X T) {})"
+ by (metis (no_types) hom_boundary)
+ then have *: "hom_induced (p - 1) (subtopology X S) {} (subtopology X S) T id
+ (hom_induced (p - 1) (subtopology X T) {} (subtopology X S) {} id
+ (hom_boundary p X T B))
+ = \<one>\<^bsub>?G1\<^esub>"
+ using homology_exactness_axiom_3 [of "p-1" "subtopology X S" T]
+ by (auto simp: subtopology_subtopology kernel_def)
+ show ?thesis
+ apply (simp add: kernel_def hom_induced_carrier hom_relboundary_def flip: *)
+ by (metis comp_def naturality_hom_induced [OF continuous_map_id iTS])
+ qed
+ moreover have "B \<in> ?h2 ` carrier ?G3" if "B \<in> kernel ?G2 ?G1 ?h1" for B
+ proof -
+ have Bcarr: "B \<in> carrier ?G2"
+ and Beq: "?h1 B = \<one>\<^bsub>?G1\<^esub>"
+ using that by (auto simp: kernel_def)
+ have "\<exists>A' \<in> carrier (homology_group (p - 1) (subtopology X T)). hom_induced (p - 1) (subtopology X T) {} (subtopology X S) {} id A' = A"
+ if "A \<in> carrier (homology_group (p - 1) (subtopology X S))"
+ "hom_induced (p - 1) (subtopology X S) {} (subtopology X S) T id A =
+ \<one>\<^bsub>?G1\<^esub>" for A
+ using homology_exactness_axiom_3 [of "p-1" "subtopology X S" T] that
+ by (simp add: kernel_def subtopology_subtopology image_iff set_eq_iff) meson
+ then obtain C where Ccarr: "C \<in> carrier (homology_group (p - 1) (subtopology X T))"
+ and Ceq: "hom_induced (p - 1) (subtopology X T) {} (subtopology X S) {} id C = hom_boundary p X S B"
+ using Beq by (simp add: hom_relboundary_def) (metis hom_boundary_carrier)
+ let ?hi_XT = "hom_induced (p - 1) (subtopology X T) {} X {} id"
+ have "?hi_XT
+ = hom_induced (p - 1) (subtopology X S) {} X {} id
+ \<circ> (hom_induced (p - 1) (subtopology X T) {} (subtopology X S) {} id)"
+ by (metis assms comp_id continuous_map_id_subt hom_induced_compose_empty inf.absorb_iff2 subtopology_subtopology)
+ then have "?hi_XT C
+ = hom_induced (p - 1) (subtopology X S) {} X {} id (hom_boundary p X S B)"
+ by (simp add: Ceq)
+ also have eq: "\<dots> = \<one>\<^bsub>homology_group (p - 1) X\<^esub>"
+ using homology_exactness_axiom_2 [of p X S] Bcarr by (auto simp: kernel_def)
+ finally have "?hi_XT C = \<one>\<^bsub>homology_group (p - 1) X\<^esub>" .
+ then obtain D where Dcarr: "D \<in> carrier ?G3" and Deq: "hom_boundary p X T D = C"
+ using homology_exactness_axiom_2 [of p X T] Ccarr
+ by (auto simp: kernel_def image_iff set_eq_iff) meson
+ interpret hb: group_hom "?G2" "homology_group (p-1) (subtopology X S)"
+ "hom_boundary p X S"
+ using hom_boundary_hom group_hom_axioms_def group_hom_def by fastforce
+ let ?A = "B \<otimes>\<^bsub>?G2\<^esub> inv\<^bsub>?G2\<^esub> ?h2 D"
+ have "\<exists>A' \<in> carrier (homology_group p X). hom_induced p X {} X S id A' = A"
+ if "A \<in> carrier ?G2"
+ "hom_boundary p X S A = one (homology_group (p - 1) (subtopology X S))" for A
+ using that homology_exactness_axiom_1 [of p X S]
+ by (simp add: kernel_def subtopology_subtopology image_iff set_eq_iff) meson
+ moreover
+ have "?A \<in> carrier ?G2"
+ by (simp add: Bcarr abelian_relative_homology_group comm_groupE(1) hom_induced_carrier)
+ moreover have "hom_boundary p X S (?h2 D) = hom_boundary p X S B"
+ by (metis (mono_tags, lifting) Ceq Deq comp_eq_dest continuous_map_id iTS naturality_hom_induced)
+ then have "hom_boundary p X S ?A = one (homology_group (p - 1) (subtopology X S))"
+ by (simp add: hom_induced_carrier Bcarr)
+ ultimately obtain W where Wcarr: "W \<in> carrier (homology_group p X)"
+ and Weq: "hom_induced p X {} X S id W = ?A"
+ by blast
+ let ?W = "D \<otimes>\<^bsub>?G3\<^esub> hom_induced p X {} X T id W"
+ show ?thesis
+ proof
+ interpret comm_group "?G2"
+ by (rule abelian_relative_homology_group)
+ have "B = (?h2 \<circ> hom_induced p X {} X T id) W \<otimes>\<^bsub>?G2\<^esub> ?h2 D"
+ apply (simp add: hom_induced_compose [symmetric] assms)
+ by (metis Bcarr Weq hb.G.inv_solve_right hom_induced_carrier)
+ then have "B \<otimes>\<^bsub>?G2\<^esub> inv\<^bsub>?G2\<^esub> ?h2 D
+ = ?h2 (hom_induced p X {} X T id W)"
+ by (simp add: hb.G.m_assoc hom_induced_carrier)
+ then show "B = ?h2 ?W"
+ apply (simp add: Dcarr hom_induced_carrier hom_mult [OF hom_induced_hom])
+ by (metis Bcarr hb.G.inv_solve_right hom_induced_carrier m_comm)
+ show "?W \<in> carrier ?G3"
+ by (simp add: Dcarr abelian_relative_homology_group comm_groupE(1) hom_induced_carrier)
+ qed
+ qed
+ ultimately show ?thesis
+ by (auto simp: group_hom_def group_hom_axioms_def hom_induced_hom group_homomorphism_hom_relboundary)
+qed
+
+
+proposition homology_exactness_triple_2:
+ assumes "T \<subseteq> S"
+ shows "exact_seq ([relative_homology_group(p - 1) X T,
+ relative_homology_group(p - 1) (subtopology X S) T,
+ relative_homology_group p X S],
+ [hom_induced (p - 1) (subtopology X S) T X T id, hom_relboundary p X S T])"
+ (is "exact_seq ([?G1,?G2,?G3], [?h1,?h2])")
+proof -
+ let ?H2 = "homology_group (p - 1) (subtopology X S)"
+ have iTS: "id ` T \<subseteq> S" and [simp]: "S \<inter> T = T"
+ using assms by auto
+ have "?h2 C \<in> kernel ?G2 ?G1 ?h1" for C
+ proof -
+ have "?h1 (?h2 C)
+ = (hom_induced (p - 1) X {} X T id \<circ> hom_induced (p - 1) (subtopology X S) {} X {} id \<circ> hom_boundary p X S) C"
+ unfolding hom_relboundary_def
+ by (metis (no_types, lifting) comp_apply continuous_map_id continuous_map_id_subt empty_subsetI hom_induced_compose id_apply image_empty image_id order_refl)
+ also have "\<dots> = \<one>\<^bsub>?G1\<^esub>"
+ proof -
+ have *: "hom_boundary p X S C \<in> carrier ?H2"
+ by (simp add: hom_boundary_carrier)
+ moreover have "hom_boundary p X S C \<in> hom_boundary p X S ` carrier ?G3"
+ using homology_exactness_axiom_2 [of p X S] *
+ apply (simp add: kernel_def set_eq_iff)
+ by (metis group_relative_homology_group hom_boundary_default hom_one image_eqI)
+ ultimately
+ have 1: "hom_induced (p - 1) (subtopology X S) {} X {} id (hom_boundary p X S C)
+ = \<one>\<^bsub>homology_group (p - 1) X\<^esub>"
+ using homology_exactness_axiom_2 [of p X S] by (simp add: kernel_def) blast
+ show ?thesis
+ by (simp add: 1 hom_one [OF hom_induced_hom])
+ qed
+ finally have "?h1 (?h2 C) = \<one>\<^bsub>?G1\<^esub>" .
+ then show ?thesis
+ by (simp add: kernel_def hom_relboundary_def hom_induced_carrier)
+ qed
+ moreover have "x \<in> ?h2 ` carrier ?G3" if "x \<in> kernel ?G2 ?G1 ?h1" for x
+ proof -
+ let ?homX = "hom_induced (p - 1) (subtopology X S) {} X {} id"
+ let ?homXS = "hom_induced (p - 1) (subtopology X S) {} (subtopology X S) T id"
+ have "x \<in> carrier (relative_homology_group (p - 1) (subtopology X S) T)"
+ using that by (simp add: kernel_def)
+ moreover
+ have "hom_boundary (p-1) X T \<circ> hom_induced (p-1) (subtopology X S) T X T id = hom_boundary (p-1) (subtopology X S) T"
+ by (metis Int_lower2 \<open>S \<inter> T = T\<close> continuous_map_id_subt hom_relboundary_def hom_relboundary_empty id_apply image_id naturality_hom_induced subtopology_subtopology)
+ then have "hom_boundary (p - 1) (subtopology X S) T x = \<one>\<^bsub>homology_group (p - 2) (subtopology (subtopology X S) T)\<^esub>"
+ using naturality_hom_induced [of "subtopology X S" X id T T "p-1"] that
+ hom_one [OF hom_boundary_hom group_relative_homology_group group_relative_homology_group, of "p-1" X T]
+ apply (simp add: kernel_def subtopology_subtopology)
+ by (metis comp_apply)
+ ultimately
+ obtain y where ycarr: "y \<in> carrier ?H2"
+ and yeq: "?homXS y = x"
+ using homology_exactness_axiom_1 [of "p-1" "subtopology X S" T]
+ by (simp add: kernel_def image_def set_eq_iff) meson
+ have "?homX y \<in> carrier (homology_group (p - 1) X)"
+ by (simp add: hom_induced_carrier)
+ moreover
+ have "(hom_induced (p - 1) X {} X T id \<circ> ?homX) y = \<one>\<^bsub>relative_homology_group (p - 1) X T\<^esub>"
+ apply (simp flip: hom_induced_compose)
+ using hom_induced_compose [of "subtopology X S" "subtopology X S" id "{}" T X id T "p-1"]
+ apply simp
+ by (metis (mono_tags, lifting) kernel_def mem_Collect_eq that yeq)
+ then have "hom_induced (p - 1) X {} X T id (?homX y) = \<one>\<^bsub>relative_homology_group (p - 1) X T\<^esub>"
+ by simp
+ ultimately obtain z where zcarr: "z \<in> carrier (homology_group (p - 1) (subtopology X T))"
+ and zeq: "hom_induced (p - 1) (subtopology X T) {} X {} id z = ?homX y"
+ using homology_exactness_axiom_3 [of "p-1" X T]
+ by (auto simp: kernel_def dest!: equalityD1 [of "Collect _"])
+ have *: "\<And>t. \<lbrakk>t \<in> carrier ?H2;
+ hom_induced (p - 1) (subtopology X S) {} X {} id t = \<one>\<^bsub>homology_group (p - 1) X\<^esub>\<rbrakk>
+ \<Longrightarrow> t \<in> hom_boundary p X S ` carrier ?G3"
+ using homology_exactness_axiom_2 [of p X S]
+ by (auto simp: kernel_def dest!: equalityD1 [of "Collect _"])
+ interpret comm_group "?H2"
+ by (rule abelian_relative_homology_group)
+ interpret gh: group_hom ?H2 "homology_group (p - 1) X" "hom_induced (p-1) (subtopology X S) {} X {} id"
+ by (meson group_hom_axioms_def group_hom_def group_relative_homology_group hom_induced)
+ let ?yz = "y \<otimes>\<^bsub>?H2\<^esub> inv\<^bsub>?H2\<^esub> hom_induced (p - 1) (subtopology X T) {} (subtopology X S) {} id z"
+ have yzcarr: "?yz \<in> carrier ?H2"
+ by (simp add: hom_induced_carrier ycarr)
+ have yzeq: "hom_induced (p - 1) (subtopology X S) {} X {} id ?yz = \<one>\<^bsub>homology_group (p - 1) X\<^esub>"
+ apply (simp add: hom_induced_carrier ycarr gh.inv_solve_right')
+ by (metis assms continuous_map_id_subt hom_induced_compose_empty inf.absorb_iff2 o_apply o_id subtopology_subtopology zeq)
+ obtain w where wcarr: "w \<in> carrier ?G3" and weq: "hom_boundary p X S w = ?yz"
+ using * [OF yzcarr yzeq] by blast
+ interpret gh2: group_hom ?H2 ?G2 ?homXS
+ by (simp add: group_hom_axioms_def group_hom_def hom_induced_hom)
+ have "?homXS (hom_induced (p - 1) (subtopology X T) {} (subtopology X S) {} id z)
+ = \<one>\<^bsub>relative_homology_group (p - 1) (subtopology X S) T\<^esub>"
+ using homology_exactness_axiom_3 [of "p-1" "subtopology X S" T] zcarr
+ by (auto simp: kernel_def subtopology_subtopology)
+ then show ?thesis
+ apply (rule_tac x=w in image_eqI)
+ apply (simp_all add: hom_relboundary_def weq wcarr)
+ by (metis gh2.hom_inv gh2.hom_mult gh2.inv_one gh2.r_one group.inv_closed group_l_invI hom_induced_carrier l_inv_ex ycarr yeq)
+ qed
+ ultimately show ?thesis
+ by (auto simp: group_hom_axioms_def group_hom_def group_homomorphism_hom_relboundary hom_induced_hom)
+qed
+
+proposition homology_exactness_triple_3:
+ assumes "T \<subseteq> S"
+ shows "exact_seq ([relative_homology_group p X S,
+ relative_homology_group p X T,
+ relative_homology_group p (subtopology X S) T],
+ [hom_induced p X T X S id, hom_induced p (subtopology X S) T X T id])"
+ (is "exact_seq ([?G1,?G2,?G3], [?h1,?h2])")
+proof -
+ have iTS: "id ` T \<subseteq> S" and [simp]: "S \<inter> T = T"
+ using assms by auto
+ have 1: "?h2 x \<in> kernel ?G2 ?G1 ?h1" for x
+ proof -
+ have "?h1 (?h2 x)
+ = (hom_induced p (subtopology X S) S X S id \<circ>
+ hom_induced p (subtopology X S) T (subtopology X S) S id) x"
+ by (metis comp_eq_dest_lhs continuous_map_id continuous_map_id_subt hom_induced_compose iTS id_apply image_subsetI)
+ also have "\<dots> = \<one>\<^bsub>relative_homology_group p X S\<^esub>"
+ proof -
+ have "trivial_group (relative_homology_group p (subtopology X S) S)"
+ using trivial_relative_homology_group_topspace [of p "subtopology X S"]
+ by (metis inf_right_idem relative_homology_group_restrict topspace_subtopology)
+ then have 1: "hom_induced p (subtopology X S) T (subtopology X S) S id x
+ = \<one>\<^bsub>relative_homology_group p (subtopology X S) S\<^esub>"
+ using hom_induced_carrier by (fastforce simp add: trivial_group_def)
+ show ?thesis
+ by (simp add: 1 hom_one [OF hom_induced_hom])
+ qed
+ finally have "?h1 (?h2 x) = \<one>\<^bsub>relative_homology_group p X S\<^esub>" .
+ then show ?thesis
+ by (simp add: hom_induced_carrier kernel_def)
+ qed
+ moreover have "x \<in> ?h2 ` carrier ?G3" if x: "x \<in> kernel ?G2 ?G1 ?h1" for x
+ proof -
+ have xcarr: "x \<in> carrier ?G2"
+ using that by (auto simp: kernel_def)
+ interpret G2: comm_group "?G2"
+ by (rule abelian_relative_homology_group)
+ let ?b = "hom_boundary p X T x"
+ have bcarr: "?b \<in> carrier(homology_group(p - 1) (subtopology X T))"
+ by (simp add: hom_boundary_carrier)
+ have "hom_boundary p X S (hom_induced p X T X S id x)
+ = hom_induced (p - 1) (subtopology X T) {} (subtopology X S) {} id
+ (hom_boundary p X T x)"
+ using naturality_hom_induced [of X X id T S p] by (simp add: assms o_def) meson
+ with bcarr have "hom_boundary p X T x \<in> hom_boundary p (subtopology X S) T ` carrier ?G3"
+ using homology_exactness_axiom_2 [of p "subtopology X S" T] x
+ apply (simp add: kernel_def set_eq_iff subtopology_subtopology)
+ by (metis group_relative_homology_group hom_boundary_hom hom_one set_eq_iff)
+ then obtain u where ucarr: "u \<in> carrier ?G3"
+ and ueq: "hom_boundary p X T x = hom_boundary p (subtopology X S) T u"
+ by (auto simp: kernel_def set_eq_iff subtopology_subtopology hom_boundary_carrier)
+ define y where "y = x \<otimes>\<^bsub>?G2\<^esub> inv\<^bsub>?G2\<^esub> ?h2 u"
+ have ycarr: "y \<in> carrier ?G2"
+ using x by (simp add: y_def kernel_def hom_induced_carrier)
+ interpret hb: group_hom ?G2 "homology_group (p-1) (subtopology X T)" "hom_boundary p X T"
+ by (simp add: group_hom_axioms_def group_hom_def hom_boundary_hom)
+ have yyy: "hom_boundary p X T y = \<one>\<^bsub>homology_group (p - 1) (subtopology X T)\<^esub>"
+ apply (simp add: y_def bcarr xcarr hom_induced_carrier hom_boundary_carrier hb.inv_solve_right')
+ using naturality_hom_induced [of concl: p X T "subtopology X S" T id]
+ apply (simp add: o_def fun_eq_iff subtopology_subtopology)
+ by (metis hom_boundary_carrier hom_induced_id ueq)
+ then have "y \<in> hom_induced p X {} X T id ` carrier (homology_group p X)"
+ using homology_exactness_axiom_1 [of p X T] x ycarr by (auto simp: kernel_def)
+ then obtain z where zcarr: "z \<in> carrier (homology_group p X)"
+ and zeq: "hom_induced p X {} X T id z = y"
+ by auto
+ interpret gh1: group_hom ?G2 ?G1 ?h1
+ by (meson group_hom_axioms_def group_hom_def group_relative_homology_group hom_induced)
+
+ have "hom_induced p X {} X S id z = (hom_induced p X T X S id \<circ> hom_induced p X {} X T id) z"
+ by (simp add: assms flip: hom_induced_compose)
+ also have "\<dots> = \<one>\<^bsub>relative_homology_group p X S\<^esub>"
+ using x 1 by (simp add: kernel_def zeq y_def)
+ finally have "hom_induced p X {} X S id z = \<one>\<^bsub>relative_homology_group p X S\<^esub>" .
+ then have "z \<in> hom_induced p (subtopology X S) {} X {} id `
+ carrier (homology_group p (subtopology X S))"
+ using homology_exactness_axiom_3 [of p X S] zcarr by (auto simp: kernel_def)
+ then obtain w where wcarr: "w \<in> carrier (homology_group p (subtopology X S))"
+ and weq: "hom_induced p (subtopology X S) {} X {} id w = z"
+ by blast
+ let ?u = "hom_induced p (subtopology X S) {} (subtopology X S) T id w \<otimes>\<^bsub>?G3\<^esub> u"
+ show ?thesis
+ proof
+ have *: "x = z \<otimes>\<^bsub>?G2\<^esub> u"
+ if "z = x \<otimes>\<^bsub>?G2\<^esub> inv\<^bsub>?G2\<^esub> u" "z \<in> carrier ?G2" "u \<in> carrier ?G2" for z u
+ using that by (simp add: group.inv_solve_right xcarr)
+ have eq: "?h2 \<circ> hom_induced p (subtopology X S) {} (subtopology X S) T id
+ = hom_induced p X {} X T id \<circ> hom_induced p (subtopology X S) {} X {} id"
+ by (simp flip: hom_induced_compose)
+ show "x = hom_induced p (subtopology X S) T X T id ?u"
+ apply (simp add: hom_mult [OF hom_induced_hom] hom_induced_carrier ucarr)
+ apply (rule *)
+ using eq apply (simp_all add: fun_eq_iff hom_induced_carrier flip: y_def zeq weq)
+ done
+ show "?u \<in> carrier (relative_homology_group p (subtopology X S) T)"
+ by (simp add: abelian_relative_homology_group comm_groupE(1) hom_induced_carrier ucarr)
+ qed
+ qed
+ ultimately show ?thesis
+ by (auto simp: group_hom_axioms_def group_hom_def hom_induced_hom)
+qed
+
+end
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Homology/Simplices.thy Wed Apr 10 15:45:16 2019 +0200
@@ -0,0 +1,3282 @@
+section\<open>Homology, I: Simplices\<close>
+
+theory "Simplices"
+ imports "HOL-Analysis.Abstract_Euclidean_Space" "HOL-Algebra.Free_Abelian_Groups"
+
+begin
+
+subsection\<open>Standard simplices, all of which are topological subspaces of @{text"R^n"}. \<close>
+
+type_synonym 'a chain = "((nat \<Rightarrow> real) \<Rightarrow> 'a) \<Rightarrow>\<^sub>0 int"
+
+definition standard_simplex :: "nat \<Rightarrow> (nat \<Rightarrow> real) set" where
+ "standard_simplex p \<equiv>
+ {x. (\<forall>i. 0 \<le> x i \<and> x i \<le> 1) \<and> (\<forall>i>p. x i = 0) \<and> (\<Sum>i\<le>p. x i) = 1}"
+
+lemma topspace_standard_simplex:
+ "topspace(subtopology (powertop_real UNIV) (standard_simplex p))
+ = standard_simplex p"
+ by simp
+
+lemma basis_in_standard_simplex [simp]:
+ "(\<lambda>j. if j = i then 1 else 0) \<in> standard_simplex p \<longleftrightarrow> i \<le> p"
+ by (auto simp: standard_simplex_def)
+
+lemma nonempty_standard_simplex: "standard_simplex p \<noteq> {}"
+ using basis_in_standard_simplex by blast
+
+lemma standard_simplex_0: "standard_simplex 0 = {(\<lambda>j. if j = 0 then 1 else 0)}"
+ by (auto simp: standard_simplex_def)
+
+lemma standard_simplex_mono:
+ assumes "p \<le> q"
+ shows "standard_simplex p \<subseteq> standard_simplex q"
+ using assms
+proof (clarsimp simp: standard_simplex_def)
+ fix x :: "nat \<Rightarrow> real"
+ assume "\<forall>i. 0 \<le> x i \<and> x i \<le> 1" and "\<forall>i>p. x i = 0" and "sum x {..p} = 1"
+ then show "sum x {..q} = 1"
+ using sum.mono_neutral_left [of "{..q}" "{..p}" x] assms by auto
+qed
+
+lemma closedin_standard_simplex:
+ "closedin (powertop_real UNIV) (standard_simplex p)"
+ (is "closedin ?X ?S")
+proof -
+ have eq: "standard_simplex p =
+ (\<Inter>i. {x. x \<in> topspace ?X \<and> x i \<in> {0..1}}) \<inter>
+ (\<Inter>i \<in> {p<..}. {x \<in> topspace ?X. x i \<in> {0}}) \<inter>
+ {x \<in> topspace ?X. (\<Sum>i\<le>p. x i) \<in> {1}}"
+ by (auto simp: standard_simplex_def topspace_product_topology)
+ show ?thesis
+ unfolding eq
+ by (rule closedin_Int closedin_Inter continuous_map_sum
+ continuous_map_product_projection closedin_continuous_map_preimage | force | clarify)+
+qed
+
+lemma standard_simplex_01: "standard_simplex p \<subseteq> UNIV \<rightarrow>\<^sub>E {0..1}"
+ using standard_simplex_def by auto
+
+lemma compactin_standard_simplex:
+ "compactin (powertop_real UNIV) (standard_simplex p)"
+ apply (rule closed_compactin [where K = "PiE UNIV (\<lambda>i. {0..1})"])
+ apply (simp_all add: compactin_PiE standard_simplex_01 closedin_standard_simplex)
+ done
+
+lemma convex_standard_simplex:
+ "\<lbrakk>x \<in> standard_simplex p; y \<in> standard_simplex p;
+ 0 \<le> u; u \<le> 1\<rbrakk>
+ \<Longrightarrow> (\<lambda>i. (1 - u) * x i + u * y i) \<in> standard_simplex p"
+ by (simp add: standard_simplex_def sum.distrib convex_bound_le flip: sum_distrib_left)
+
+lemma path_connectedin_standard_simplex:
+ "path_connectedin (powertop_real UNIV) (standard_simplex p)"
+proof -
+ define g where "g \<equiv> \<lambda>x y::nat\<Rightarrow>real. \<lambda>u i. (1 - u) * x i + u * y i"
+ have 1: "continuous_map
+ (subtopology euclideanreal {0..1}) (powertop_real UNIV)
+ (g x y)"
+ if "x \<in> standard_simplex p" "y \<in> standard_simplex p" for x y
+ unfolding g_def continuous_map_componentwise
+ by (force intro: continuous_intros)
+ have 2: "g x y ` {0..1} \<subseteq> standard_simplex p" "g x y 0 = x" "g x y 1 = y"
+ if "x \<in> standard_simplex p" "y \<in> standard_simplex p" for x y
+ using that by (auto simp: convex_standard_simplex g_def)
+ show ?thesis
+ unfolding path_connectedin_def path_connected_space_def pathin_def
+ apply (simp add: topspace_standard_simplex topspace_product_topology continuous_map_in_subtopology)
+ by (metis 1 2)
+qed
+
+lemma connectedin_standard_simplex:
+ "connectedin (powertop_real UNIV) (standard_simplex p)"
+ by (simp add: path_connectedin_imp_connectedin path_connectedin_standard_simplex)
+
+subsection\<open>Face map\<close>
+
+definition simplical_face :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a::comm_monoid_add" where
+ "simplical_face k x \<equiv> \<lambda>i. if i < k then x i else if i = k then 0 else x(i -1)"
+
+lemma simplical_face_in_standard_simplex:
+ assumes "1 \<le> p" "k \<le> p" "x \<in> standard_simplex (p - Suc 0)"
+ shows "(simplical_face k x) \<in> standard_simplex p"
+proof -
+ have x01: "\<And>i. 0 \<le> x i \<and> x i \<le> 1" and sumx: "sum x {..p - Suc 0} = 1"
+ using assms by (auto simp: standard_simplex_def simplical_face_def)
+ have gg: "\<And>g. sum g {..p} = sum g {..<k} + sum g {k..p}"
+ using \<open>k \<le> p\<close> sum.union_disjoint [of "{..<k}" "{k..p}"]
+ by (force simp: ivl_disj_un ivl_disj_int)
+ have eq: "(\<Sum>i\<le>p. if i < k then x i else if i = k then 0 else x (i -1))
+ = (\<Sum>i < k. x i) + (\<Sum>i \<in> {k..p}. if i = k then 0 else x (i -1))"
+ by (simp add: gg)
+ consider "k \<le> p - Suc 0" | "k = p"
+ using \<open>k \<le> p\<close> by linarith
+ then have "(\<Sum>i\<le>p. if i < k then x i else if i = k then 0 else x (i -1)) = 1"
+ proof cases
+ case 1
+ have [simp]: "Suc (p - Suc 0) = p"
+ using \<open>1 \<le> p\<close> by auto
+ have "(\<Sum>i = k..p. if i = k then 0 else x (i -1)) = (\<Sum>i = k+1..p. if i = k then 0 else x (i -1))"
+ by (rule sum.mono_neutral_right) auto
+ also have "\<dots> = (\<Sum>i = k+1..p. x (i -1))"
+ by simp
+ also have "\<dots> = (\<Sum>i = k..p-1. x i)"
+ using sum.atLeastAtMost_reindex [of Suc k "p-1" "\<lambda>i. x (i - Suc 0)"] 1 by simp
+ finally have eq2: "(\<Sum>i = k..p. if i = k then 0 else x (i -1)) = (\<Sum>i = k..p-1. x i)" .
+ with 1 show ?thesis
+ apply (simp add: eq eq2)
+ by (metis (mono_tags, lifting) One_nat_def assms(3) finite_atLeastAtMost finite_lessThan ivl_disj_int(4) ivl_disj_un(10) mem_Collect_eq standard_simplex_def sum.union_disjoint)
+ next
+ case 2
+ have [simp]: "({..p} \<inter> {x. x < p}) = {..p - Suc 0}"
+ using assms by auto
+ have "(\<Sum>i\<le>p. if i < p then x i else if i = k then 0 else x (i -1)) = (\<Sum>i\<le>p. if i < p then x i else 0)"
+ by (rule sum.cong) (auto simp: 2)
+ also have "\<dots> = sum x {..p-1}"
+ by (simp add: sum.If_cases)
+ also have "\<dots> = 1"
+ by (simp add: sumx)
+ finally show ?thesis
+ using 2 by simp
+ qed
+ then show ?thesis
+ using assms by (auto simp: standard_simplex_def simplical_face_def)
+qed
+
+subsection\<open>Singular simplices, forcing canonicity outside the intended domain\<close>
+
+definition singular_simplex :: "nat \<Rightarrow> 'a topology \<Rightarrow> ((nat \<Rightarrow> real) \<Rightarrow> 'a) \<Rightarrow> bool" where
+ "singular_simplex p X f \<equiv>
+ continuous_map(subtopology (powertop_real UNIV) (standard_simplex p)) X f
+ \<and> f \<in> extensional (standard_simplex p)"
+
+abbreviation singular_simplex_set :: "nat \<Rightarrow> 'a topology \<Rightarrow> ((nat \<Rightarrow> real) \<Rightarrow> 'a) set" where
+ "singular_simplex_set p X \<equiv> Collect (singular_simplex p X)"
+
+lemma singular_simplex_empty:
+ "topspace X = {} \<Longrightarrow> \<not> singular_simplex p X f"
+ by (simp add: singular_simplex_def continuous_map nonempty_standard_simplex)
+
+lemma singular_simplex_mono:
+ "\<lbrakk>singular_simplex p (subtopology X T) f; T \<subseteq> S\<rbrakk> \<Longrightarrow> singular_simplex p (subtopology X S) f"
+ by (auto simp: singular_simplex_def continuous_map_in_subtopology)
+
+lemma singular_simplex_subtopology:
+ "singular_simplex p (subtopology X S) f \<longleftrightarrow>
+ singular_simplex p X f \<and> f ` (standard_simplex p) \<subseteq> S"
+ by (auto simp: singular_simplex_def continuous_map_in_subtopology)
+
+subsubsection\<open>Singular face\<close>
+
+definition singular_face :: "nat \<Rightarrow> nat \<Rightarrow> ((nat \<Rightarrow> real) \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> real) \<Rightarrow> 'a"
+ where "singular_face p k f \<equiv> restrict (f \<circ> simplical_face k) (standard_simplex (p - Suc 0))"
+
+lemma singular_simplex_singular_face:
+ assumes f: "singular_simplex p X f" and "1 \<le> p" "k \<le> p"
+ shows "singular_simplex (p - Suc 0) X (singular_face p k f)"
+proof -
+ let ?PT = "(powertop_real UNIV)"
+ have 0: "simplical_face k ` standard_simplex (p - Suc 0) \<subseteq> standard_simplex p"
+ using assms simplical_face_in_standard_simplex by auto
+ have 1: "continuous_map (subtopology ?PT (standard_simplex (p - Suc 0)))
+ (subtopology ?PT (standard_simplex p))
+ (simplical_face k)"
+ proof (clarsimp simp add: continuous_map_in_subtopology simplical_face_in_standard_simplex continuous_map_componentwise 0)
+ fix i
+ have "continuous_map ?PT euclideanreal (\<lambda>x. if i < k then x i else if i = k then 0 else x (i -1))"
+ by (auto intro: continuous_map_product_projection)
+ then show "continuous_map (subtopology ?PT (standard_simplex (p - Suc 0))) euclideanreal
+ (\<lambda>x. simplical_face k x i)"
+ by (simp add: simplical_face_def continuous_map_from_subtopology)
+ qed
+ have 2: "continuous_map (subtopology ?PT (standard_simplex p)) X f"
+ using assms(1) singular_simplex_def by blast
+ show ?thesis
+ by (simp add: singular_simplex_def singular_face_def continuous_map_compose [OF 1 2])
+qed
+
+
+subsection\<open>Singular chains\<close>
+
+definition singular_chain :: "[nat, 'a topology, 'a chain] \<Rightarrow> bool"
+ where "singular_chain p X c \<equiv> Poly_Mapping.keys c \<subseteq> singular_simplex_set p X"
+
+abbreviation singular_chain_set :: "[nat, 'a topology] \<Rightarrow> ('a chain) set"
+ where "singular_chain_set p X \<equiv> Collect (singular_chain p X)"
+
+lemma singular_chain_empty:
+ "topspace X = {} \<Longrightarrow> singular_chain p X c \<longleftrightarrow> c = 0"
+ by (auto simp: singular_chain_def singular_simplex_empty subset_eq poly_mapping_eqI)
+
+lemma singular_chain_mono:
+ "\<lbrakk>singular_chain p (subtopology X T) c; T \<subseteq> S\<rbrakk>
+ \<Longrightarrow> singular_chain p (subtopology X S) c"
+ unfolding singular_chain_def using singular_simplex_mono by blast
+
+lemma singular_chain_subtopology:
+ "singular_chain p (subtopology X S) c \<longleftrightarrow>
+ singular_chain p X c \<and> (\<forall>f \<in> Poly_Mapping.keys c. f ` (standard_simplex p) \<subseteq> S)"
+ unfolding singular_chain_def
+ by (fastforce simp add: singular_simplex_subtopology subset_eq)
+
+lemma singular_chain_0 [iff]: "singular_chain p X 0"
+ by (auto simp: singular_chain_def)
+
+lemma singular_chain_of:
+ "singular_chain p X (frag_of c) \<longleftrightarrow> singular_simplex p X c"
+ by (auto simp: singular_chain_def)
+
+lemma singular_chain_cmul:
+ "singular_chain p X c \<Longrightarrow> singular_chain p X (frag_cmul a c)"
+ by (auto simp: singular_chain_def)
+
+lemma singular_chain_minus:
+ "singular_chain p X (-c) \<longleftrightarrow> singular_chain p X c"
+ by (auto simp: singular_chain_def)
+
+lemma singular_chain_add:
+ "\<lbrakk>singular_chain p X a; singular_chain p X b\<rbrakk> \<Longrightarrow> singular_chain p X (a+b)"
+ unfolding singular_chain_def
+ using keys_add [of a b] by blast
+
+lemma singular_chain_diff:
+ "\<lbrakk>singular_chain p X a; singular_chain p X b\<rbrakk> \<Longrightarrow> singular_chain p X (a-b)"
+ unfolding singular_chain_def
+ using keys_diff [of a b] by blast
+
+lemma singular_chain_sum:
+ "(\<And>i. i \<in> I \<Longrightarrow> singular_chain p X (f i)) \<Longrightarrow> singular_chain p X (\<Sum>i\<in>I. f i)"
+ unfolding singular_chain_def
+ using keys_sum [of f I] by blast
+
+lemma singular_chain_extend:
+ "(\<And>c. c \<in> Poly_Mapping.keys x \<Longrightarrow> singular_chain p X (f c))
+ \<Longrightarrow> singular_chain p X (frag_extend f x)"
+ by (simp add: frag_extend_def singular_chain_cmul singular_chain_sum)
+
+subsection\<open>Boundary homomorphism for singular chains\<close>
+
+definition chain_boundary :: "nat \<Rightarrow> ('a chain) \<Rightarrow> 'a chain"
+ where "chain_boundary p c \<equiv>
+ (if p = 0 then 0 else
+ frag_extend (\<lambda>f. (\<Sum>k\<le>p. frag_cmul ((-1) ^ k) (frag_of(singular_face p k f)))) c)"
+
+lemma singular_chain_boundary:
+ "singular_chain p X c
+ \<Longrightarrow> singular_chain (p - Suc 0) X (chain_boundary p c)"
+ unfolding chain_boundary_def
+ apply (clarsimp intro!: singular_chain_extend singular_chain_sum singular_chain_cmul)
+ apply (auto simp: singular_chain_def intro: singular_simplex_singular_face)
+ done
+
+lemma singular_chain_boundary_alt:
+ "singular_chain (Suc p) X c \<Longrightarrow> singular_chain p X (chain_boundary (Suc p) c)"
+ using singular_chain_boundary by force
+
+lemma chain_boundary_0 [simp]: "chain_boundary p 0 = 0"
+ by (simp add: chain_boundary_def)
+
+lemma chain_boundary_cmul:
+ "chain_boundary p (frag_cmul k c) = frag_cmul k (chain_boundary p c)"
+ by (auto simp: chain_boundary_def frag_extend_cmul)
+
+lemma chain_boundary_minus:
+ "chain_boundary p (- c) = - (chain_boundary p c)"
+ by (metis chain_boundary_cmul frag_cmul_minus_one)
+
+lemma chain_boundary_add:
+ "chain_boundary p (a+b) = chain_boundary p a + chain_boundary p b"
+ by (simp add: chain_boundary_def frag_extend_add)
+
+lemma chain_boundary_diff:
+ "chain_boundary p (a-b) = chain_boundary p a - chain_boundary p b"
+ using chain_boundary_add [of p a "-b"]
+ by (simp add: chain_boundary_minus)
+
+lemma chain_boundary_sum:
+ "chain_boundary p (sum g I) = sum (chain_boundary p \<circ> g) I"
+ by (induction I rule: infinite_finite_induct) (simp_all add: chain_boundary_add)
+
+lemma chain_boundary_sum':
+ "finite I \<Longrightarrow> chain_boundary p (sum' g I) = sum' (chain_boundary p \<circ> g) I"
+ by (induction I rule: finite_induct) (simp_all add: chain_boundary_add)
+
+lemma chain_boundary_of:
+ "chain_boundary p (frag_of f) =
+ (if p = 0 then 0
+ else (\<Sum>k\<le>p. frag_cmul ((-1) ^ k) (frag_of(singular_face p k f))))"
+ by (simp add: chain_boundary_def)
+
+subsection\<open>Factoring out chains in a subtopology for relative homology\<close>
+
+definition mod_subset
+ where "mod_subset p X \<equiv> {(a,b). singular_chain p X (a - b)}"
+
+lemma mod_subset_empty [simp]:
+ "(a,b) \<in> (mod_subset p (subtopology X {})) \<longleftrightarrow> a = b"
+ by (simp add: mod_subset_def singular_chain_empty topspace_subtopology)
+
+lemma mod_subset_refl [simp]: "(c,c) \<in> mod_subset p X"
+ by (auto simp: mod_subset_def)
+
+lemma mod_subset_cmul:
+ "(a,b) \<in> (mod_subset p X) \<Longrightarrow> (frag_cmul k a, frag_cmul k b) \<in> (mod_subset p X)"
+ apply (simp add: mod_subset_def)
+ by (metis add_diff_cancel diff_add_cancel frag_cmul_distrib2 singular_chain_cmul)
+
+lemma mod_subset_add:
+ "\<lbrakk>(c1,c2) \<in> (mod_subset p X); (d1,d2) \<in> (mod_subset p X)\<rbrakk>
+ \<Longrightarrow> (c1+d1, c2+d2) \<in> (mod_subset p X)"
+ apply (simp add: mod_subset_def)
+ by (simp add: add_diff_add singular_chain_add)
+
+subsection\<open>Relative cycles $Z_pX (S)$ where $X$ is a topology and $S$ a subset \<close>
+
+definition singular_relcycle :: "nat \<Rightarrow> 'a topology \<Rightarrow> 'a set \<Rightarrow> ('a chain) \<Rightarrow> bool"
+ where "singular_relcycle p X S \<equiv>
+ \<lambda>c. singular_chain p X c \<and> (chain_boundary p c, 0) \<in> mod_subset (p-1) (subtopology X S)"
+
+abbreviation singular_relcycle_set
+ where "singular_relcycle_set p X S \<equiv> Collect (singular_relcycle p X S)"
+
+lemma singular_relcycle_restrict [simp]:
+ "singular_relcycle p X (topspace X \<inter> S) = singular_relcycle p X S"
+proof -
+ have eq: "subtopology X (topspace X \<inter> S) = subtopology X S"
+ by (metis subtopology_subtopology subtopology_topspace)
+ show ?thesis
+ by (force simp: singular_relcycle_def eq)
+qed
+
+lemma singular_relcycle:
+ "singular_relcycle p X S c \<longleftrightarrow>
+ singular_chain p X c \<and> singular_chain (p-1) (subtopology X S) (chain_boundary p c)"
+ by (simp add: singular_relcycle_def mod_subset_def)
+
+lemma singular_relcycle_0 [simp]: "singular_relcycle p X S 0"
+ by (auto simp: singular_relcycle_def)
+
+lemma singular_relcycle_cmul:
+ "singular_relcycle p X S c \<Longrightarrow> singular_relcycle p X S (frag_cmul k c)"
+ by (auto simp: singular_relcycle_def chain_boundary_cmul dest: singular_chain_cmul mod_subset_cmul)
+
+lemma singular_relcycle_minus:
+ "singular_relcycle p X S (-c) \<longleftrightarrow> singular_relcycle p X S c"
+ by (simp add: chain_boundary_minus singular_chain_minus singular_relcycle)
+
+lemma singular_relcycle_add:
+ "\<lbrakk>singular_relcycle p X S a; singular_relcycle p X S b\<rbrakk>
+ \<Longrightarrow> singular_relcycle p X S (a+b)"
+ by (simp add: singular_relcycle_def chain_boundary_add mod_subset_def singular_chain_add)
+
+lemma singular_relcycle_sum:
+ "\<lbrakk>\<And>i. i \<in> I \<Longrightarrow> singular_relcycle p X S (f i)\<rbrakk>
+ \<Longrightarrow> singular_relcycle p X S (sum f I)"
+ by (induction I rule: infinite_finite_induct) (auto simp: singular_relcycle_add)
+
+lemma singular_relcycle_diff:
+ "\<lbrakk>singular_relcycle p X S a; singular_relcycle p X S b\<rbrakk>
+ \<Longrightarrow> singular_relcycle p X S (a-b)"
+ by (metis singular_relcycle_add singular_relcycle_minus uminus_add_conv_diff)
+
+lemma singular_cycle:
+ "singular_relcycle p X {} c \<longleftrightarrow> singular_chain p X c \<and> chain_boundary p c = 0"
+ by (simp add: singular_relcycle_def)
+
+lemma singular_cycle_mono:
+ "\<lbrakk>singular_relcycle p (subtopology X T) {} c; T \<subseteq> S\<rbrakk>
+ \<Longrightarrow> singular_relcycle p (subtopology X S) {} c"
+ by (auto simp: singular_cycle elim: singular_chain_mono)
+
+
+subsection\<open>Relative boundaries $B_p X S$, where $X$ is a topology and $S$ a subset.\<close>
+
+definition singular_relboundary :: "nat \<Rightarrow> 'a topology \<Rightarrow> 'a set \<Rightarrow> ('a chain) \<Rightarrow> bool"
+ where
+ "singular_relboundary p X S \<equiv>
+ \<lambda>c. \<exists>d. singular_chain (Suc p) X d \<and> (chain_boundary (Suc p) d, c) \<in> (mod_subset p (subtopology X S))"
+
+abbreviation singular_relboundary_set :: "nat \<Rightarrow> 'a topology \<Rightarrow> 'a set \<Rightarrow> ('a chain) set"
+ where "singular_relboundary_set p X S \<equiv> Collect (singular_relboundary p X S)"
+
+lemma singular_relboundary_restrict [simp]:
+ "singular_relboundary p X (topspace X \<inter> S) = singular_relboundary p X S"
+ unfolding singular_relboundary_def
+ by (metis (no_types, hide_lams) subtopology_subtopology subtopology_topspace)
+
+lemma singular_relboundary_alt:
+ "singular_relboundary p X S c \<longleftrightarrow>
+ (\<exists>d e. singular_chain (Suc p) X d \<and> singular_chain p (subtopology X S) e \<and>
+ chain_boundary (Suc p) d = c + e)"
+ unfolding singular_relboundary_def mod_subset_def by fastforce
+
+lemma singular_relboundary:
+ "singular_relboundary p X S c \<longleftrightarrow>
+ (\<exists>d e. singular_chain (Suc p) X d \<and> singular_chain p (subtopology X S) e \<and>
+ (chain_boundary (Suc p) d) + e = c)"
+ using singular_chain_minus
+ by (fastforce simp add: singular_relboundary_alt)
+
+lemma singular_boundary:
+ "singular_relboundary p X {} c \<longleftrightarrow>
+ (\<exists>d. singular_chain (Suc p) X d \<and> chain_boundary (Suc p) d = c)"
+ by (simp add: singular_relboundary_def)
+
+lemma singular_boundary_imp_chain:
+ "singular_relboundary p X {} c \<Longrightarrow> singular_chain p X c"
+ by (auto simp: singular_relboundary singular_chain_boundary_alt singular_chain_empty topspace_subtopology)
+
+lemma singular_boundary_mono:
+ "\<lbrakk>T \<subseteq> S; singular_relboundary p (subtopology X T) {} c\<rbrakk>
+ \<Longrightarrow> singular_relboundary p (subtopology X S) {} c"
+ by (metis mod_subset_empty singular_chain_mono singular_relboundary_def)
+
+lemma singular_relboundary_imp_chain:
+ "singular_relboundary p X S c \<Longrightarrow> singular_chain p X c"
+ unfolding singular_relboundary singular_chain_subtopology
+ by (blast intro: singular_chain_add singular_chain_boundary_alt)
+
+lemma singular_chain_imp_relboundary:
+ "singular_chain p (subtopology X S) c \<Longrightarrow> singular_relboundary p X S c"
+ unfolding singular_relboundary_def
+ apply (rule_tac x=0 in exI)
+ using mod_subset_def singular_chain_diff by fastforce
+
+lemma singular_relboundary_0 [simp]: "singular_relboundary p X S 0"
+ unfolding singular_relboundary_def
+ by (rule_tac x=0 in exI) auto
+
+lemma singular_relboundary_cmul:
+ "singular_relboundary p X S c \<Longrightarrow> singular_relboundary p X S (frag_cmul a c)"
+ unfolding singular_relboundary_def
+ by (metis chain_boundary_cmul mod_subset_cmul singular_chain_cmul)
+
+lemma singular_relboundary_minus:
+ "singular_relboundary p X S (-c) \<longleftrightarrow> singular_relboundary p X S c"
+ using singular_relboundary_cmul
+ by (metis add.inverse_inverse frag_cmul_minus_one)
+
+lemma singular_relboundary_add:
+ "\<lbrakk>singular_relboundary p X S a; singular_relboundary p X S b\<rbrakk> \<Longrightarrow> singular_relboundary p X S (a+b)"
+ unfolding singular_relboundary_def
+ by (metis chain_boundary_add mod_subset_add singular_chain_add)
+
+lemma singular_relboundary_diff:
+ "\<lbrakk>singular_relboundary p X S a; singular_relboundary p X S b\<rbrakk> \<Longrightarrow> singular_relboundary p X S (a-b)"
+ by (metis uminus_add_conv_diff singular_relboundary_minus singular_relboundary_add)
+
+subsection\<open>The (relative) homology relation\<close>
+
+definition homologous_rel :: "[nat,'a topology,'a set,'a chain,'a chain] \<Rightarrow> bool"
+ where "homologous_rel p X S \<equiv> \<lambda>a b. singular_relboundary p X S (a-b)"
+
+abbreviation homologous_rel_set
+ where "homologous_rel_set p X S a \<equiv> Collect (homologous_rel p X S a)"
+
+lemma homologous_rel_restrict [simp]:
+ "homologous_rel p X (topspace X \<inter> S) = homologous_rel p X S"
+ unfolding homologous_rel_def by (metis singular_relboundary_restrict)
+
+lemma homologous_rel_refl [simp]: "homologous_rel p X S c c"
+ unfolding homologous_rel_def by auto
+
+lemma homologous_rel_sym:
+ "homologous_rel p X S a b = homologous_rel p X S b a"
+ unfolding homologous_rel_def
+ using singular_relboundary_minus by fastforce
+
+lemma homologous_rel_trans:
+ assumes "homologous_rel p X S b c" "homologous_rel p X S a b"
+ shows "homologous_rel p X S a c"
+ using homologous_rel_def
+proof -
+ have "singular_relboundary p X S (b - c)"
+ using assms unfolding homologous_rel_def by blast
+ moreover have "singular_relboundary p X S (b - a)"
+ using assms by (meson homologous_rel_def homologous_rel_sym)
+ ultimately have "singular_relboundary p X S (c - a)"
+ using singular_relboundary_diff by fastforce
+ then show ?thesis
+ by (meson homologous_rel_def homologous_rel_sym)
+qed
+
+lemma homologous_rel_eq:
+ "homologous_rel p X S a = homologous_rel p X S b \<longleftrightarrow>
+ homologous_rel p X S a b"
+ using homologous_rel_sym homologous_rel_trans by fastforce
+
+lemma homologous_rel_set_eq:
+ "homologous_rel_set p X S a = homologous_rel_set p X S b \<longleftrightarrow>
+ homologous_rel p X S a b"
+ by (metis homologous_rel_eq mem_Collect_eq)
+
+lemma homologous_rel_singular_chain:
+ "homologous_rel p X S a b \<Longrightarrow> (singular_chain p X a \<longleftrightarrow> singular_chain p X b)"
+ unfolding homologous_rel_def
+ using singular_chain_diff singular_chain_add
+ by (fastforce dest: singular_relboundary_imp_chain)
+
+lemma homologous_rel_add:
+ "\<lbrakk>homologous_rel p X S a a'; homologous_rel p X S b b'\<rbrakk>
+ \<Longrightarrow> homologous_rel p X S (a+b) (a'+b')"
+ unfolding homologous_rel_def
+ by (simp add: add_diff_add singular_relboundary_add)
+
+lemma homologous_rel_diff:
+ assumes "homologous_rel p X S a a'" "homologous_rel p X S b b'"
+ shows "homologous_rel p X S (a - b) (a' - b')"
+proof -
+ have "singular_relboundary p X S ((a - a') - (b - b'))"
+ using assms singular_relboundary_diff unfolding homologous_rel_def by blast
+ then show ?thesis
+ by (simp add: homologous_rel_def algebra_simps)
+qed
+
+lemma homologous_rel_sum:
+ assumes f: "finite {i \<in> I. f i \<noteq> 0}" and g: "finite {i \<in> I. g i \<noteq> 0}"
+ and h: "\<And>i. i \<in> I \<Longrightarrow> homologous_rel p X S (f i) (g i)"
+ shows "homologous_rel p X S (sum f I) (sum g I)"
+proof (cases "finite I")
+ case True
+ let ?L = "{i \<in> I. f i \<noteq> 0} \<union> {i \<in> I. g i \<noteq> 0}"
+ have L: "finite ?L" "?L \<subseteq> I"
+ using f g by blast+
+ have "sum f I = sum f ?L"
+ by (rule comm_monoid_add_class.sum.mono_neutral_right [OF True]) auto
+ moreover have "sum g I = sum g ?L"
+ by (rule comm_monoid_add_class.sum.mono_neutral_right [OF True]) auto
+ moreover have *: "homologous_rel p X S (f i) (g i)" if "i \<in> ?L" for i
+ using h that by auto
+ have "homologous_rel p X S (sum f ?L) (sum g ?L)"
+ using L
+ proof induction
+ case (insert j J)
+ then show ?case
+ by (simp add: h homologous_rel_add)
+ qed auto
+ ultimately show ?thesis
+ by simp
+qed auto
+
+
+lemma chain_homotopic_imp_homologous_rel:
+ assumes
+ "\<And>c. singular_chain p X c \<Longrightarrow> singular_chain (Suc p) X' (h c)"
+ "\<And>c. singular_chain (p -1) (subtopology X S) c \<Longrightarrow> singular_chain p (subtopology X' T) (h' c)"
+ "\<And>c. singular_chain p X c
+ \<Longrightarrow> (chain_boundary (Suc p) (h c)) + (h'(chain_boundary p c)) = f c - g c"
+ "singular_relcycle p X S c"
+ shows "homologous_rel p X' T (f c) (g c)"
+ using assms
+ unfolding singular_relcycle_def mod_subset_def homologous_rel_def singular_relboundary_def
+ apply (rule_tac x="h c" in exI, simp)
+ by (metis (no_types, lifting) add_diff_cancel_left' minus_diff_eq singular_chain_minus)
+
+
+subsection\<open>Show that all boundaries are cycles, the key "chain complex" property.\<close>
+
+lemma sum_Int_Diff: "finite A \<Longrightarrow> sum f A = sum f (A \<inter> B) + sum f (A - B)"
+ by (metis Diff_Diff_Int Diff_subset sum.subset_diff)
+
+lemma chain_boundary_boundary:
+ assumes "singular_chain p X c"
+ shows "chain_boundary (p - Suc 0) (chain_boundary p c) = 0"
+proof (cases "p -1 = 0")
+ case False
+ then have "2 \<le> p"
+ by auto
+ show ?thesis
+ using assms
+ unfolding singular_chain_def
+ proof (induction rule: frag_induction)
+ case (one g)
+ then have ss: "singular_simplex p X g"
+ by simp
+ have eql: "{..p} \<times> {..p - Suc 0} \<inter> {(x, y). y < x} = (\<lambda>(j,i). (Suc i, j)) ` {(i,j). i \<le> j \<and> j \<le> p -1}"
+ using False
+ by (auto simp: image_def) (metis One_nat_def diff_Suc_1 diff_le_mono le_refl lessE less_imp_le_nat)
+ have eqr: "{..p} \<times> {..p - Suc 0} - {(x, y). y < x} = {(i,j). i \<le> j \<and> j \<le> p -1}"
+ by auto
+ have eqf: "singular_face (p - Suc 0) i (singular_face p (Suc j) g) =
+ singular_face (p - Suc 0) j (singular_face p i g)" if "i \<le> j" "j \<le> p - Suc 0" for i j
+ proof (rule ext)
+ fix t
+ show "singular_face (p - Suc 0) i (singular_face p (Suc j) g) t =
+ singular_face (p - Suc 0) j (singular_face p i g) t"
+ proof (cases "t \<in> standard_simplex (p -1 -1)")
+ case True
+ have fi: "simplical_face i t \<in> standard_simplex (p - Suc 0)"
+ using False True simplical_face_in_standard_simplex that by force
+ have fj: "simplical_face j t \<in> standard_simplex (p - Suc 0)"
+ by (metis False One_nat_def True simplical_face_in_standard_simplex less_one not_less that(2))
+ have eq: "simplical_face (Suc j) (simplical_face i t) = simplical_face i (simplical_face j t)"
+ using True that ss
+ unfolding standard_simplex_def simplical_face_def by fastforce
+ show ?thesis by (simp add: singular_face_def fi fj eq)
+ qed (simp add: singular_face_def)
+ qed
+ show ?case
+ proof (cases "p = 1")
+ case False
+ have eq0: "frag_cmul (-1) a = b \<Longrightarrow> a + b = 0" for a b
+ by (simp add: neg_eq_iff_add_eq_0)
+ have *: "(\<Sum>x\<le>p. \<Sum>i\<le>p - Suc 0.
+ frag_cmul ((-1) ^ (x + i)) (frag_of (singular_face (p - Suc 0) i (singular_face p x g))))
+ = 0"
+ apply (simp add: sum.cartesian_product sum_Int_Diff [of "_ \<times> _" _ "{(x,y). y < x}"])
+ apply (rule eq0)
+ apply (simp only: frag_cmul_sum prod.case_distrib [of "frag_cmul (-1)"] frag_cmul_cmul eql eqr flip: power_Suc)
+ apply (force simp: simp add: inj_on_def sum.reindex add.commute eqf intro: sum.cong)
+ done
+ show ?thesis
+ using False by (simp add: chain_boundary_of chain_boundary_sum chain_boundary_cmul frag_cmul_sum * flip: power_add)
+ qed (simp add: chain_boundary_def)
+ next
+ case (diff a b)
+ then show ?case
+ by (simp add: chain_boundary_diff)
+ qed auto
+qed (simp add: chain_boundary_def)
+
+
+lemma chain_boundary_boundary_alt:
+ "singular_chain (Suc p) X c \<Longrightarrow> chain_boundary p (chain_boundary (Suc p) c) = 0"
+ using chain_boundary_boundary by force
+
+lemma singular_relboundary_imp_relcycle:
+ assumes "singular_relboundary p X S c"
+ shows "singular_relcycle p X S c"
+proof -
+ obtain d e where d: "singular_chain (Suc p) X d"
+ and e: "singular_chain p (subtopology X S) e"
+ and c: "c = chain_boundary (Suc p) d + e"
+ using assms by (auto simp: singular_relboundary singular_relcycle)
+ have 1: "singular_chain (p - Suc 0) (subtopology X S) (chain_boundary p (chain_boundary (Suc p) d))"
+ using d chain_boundary_boundary_alt by fastforce
+ have 2: "singular_chain (p - Suc 0) (subtopology X S) (chain_boundary p e)"
+ using \<open>singular_chain p (subtopology X S) e\<close> singular_chain_boundary by auto
+ have "singular_chain p X c"
+ using assms singular_relboundary_imp_chain by auto
+ moreover have "singular_chain (p - Suc 0) (subtopology X S) (chain_boundary p c)"
+ by (simp add: c chain_boundary_add singular_chain_add 1 2)
+ ultimately show ?thesis
+ by (simp add: singular_relcycle)
+qed
+
+lemma homologous_rel_singular_relcycle_1:
+ assumes "homologous_rel p X S c1 c2" "singular_relcycle p X S c1"
+ shows "singular_relcycle p X S c2"
+ using assms
+ by (metis diff_add_cancel homologous_rel_def homologous_rel_sym singular_relboundary_imp_relcycle singular_relcycle_add)
+
+lemma homologous_rel_singular_relcycle:
+ assumes "homologous_rel p X S c1 c2"
+ shows "singular_relcycle p X S c1 = singular_relcycle p X S c2"
+ using assms homologous_rel_singular_relcycle_1
+ using homologous_rel_sym by blast
+
+
+subsection\<open>Operations induced by a continuous map g between topological spaces\<close>
+
+definition simplex_map :: "nat \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> ((nat \<Rightarrow> real) \<Rightarrow> 'b) \<Rightarrow> (nat \<Rightarrow> real) \<Rightarrow> 'a"
+ where "simplex_map p g c \<equiv> restrict (g \<circ> c) (standard_simplex p)"
+
+lemma singular_simplex_simplex_map:
+ "\<lbrakk>singular_simplex p X f; continuous_map X X' g\<rbrakk>
+ \<Longrightarrow> singular_simplex p X' (simplex_map p g f)"
+ unfolding singular_simplex_def simplex_map_def
+ by (auto simp: continuous_map_compose)
+
+lemma simplex_map_eq:
+ "\<lbrakk>singular_simplex p X c;
+ \<And>x. x \<in> topspace X \<Longrightarrow> f x = g x\<rbrakk>
+ \<Longrightarrow> simplex_map p f c = simplex_map p g c"
+ by (auto simp: singular_simplex_def simplex_map_def continuous_map_def)
+
+lemma simplex_map_id_gen:
+ "\<lbrakk>singular_simplex p X c;
+ \<And>x. x \<in> topspace X \<Longrightarrow> f x = x\<rbrakk>
+ \<Longrightarrow> simplex_map p f c = c"
+ unfolding singular_simplex_def simplex_map_def continuous_map_def
+ using extensional_arb by fastforce
+
+lemma simplex_map_id [simp]:
+ "simplex_map p id = (\<lambda>c. restrict c (standard_simplex p))"
+ by (auto simp: simplex_map_def)
+
+lemma simplex_map_compose:
+ "simplex_map p (h \<circ> g) = simplex_map p h \<circ> simplex_map p g"
+ unfolding simplex_map_def by force
+
+lemma singular_face_simplex_map:
+ "\<lbrakk>1 \<le> p; k \<le> p\<rbrakk>
+ \<Longrightarrow> singular_face p k (simplex_map p f c) = simplex_map (p - Suc 0) f (c \<circ> simplical_face k)"
+ unfolding simplex_map_def singular_face_def
+ by (force simp: simplical_face_in_standard_simplex)
+
+lemma singular_face_restrict [simp]:
+ assumes "p > 0" "i \<le> p"
+ shows "singular_face p i (restrict f (standard_simplex p)) = singular_face p i f"
+ by (metis assms One_nat_def Suc_leI simplex_map_id singular_face_def singular_face_simplex_map)
+
+
+definition chain_map :: "nat \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> (((nat \<Rightarrow> real) \<Rightarrow> 'b) \<Rightarrow>\<^sub>0 int) \<Rightarrow> 'a chain"
+ where "chain_map p g c \<equiv> frag_extend (frag_of \<circ> simplex_map p g) c"
+
+lemma singular_chain_chain_map:
+ "\<lbrakk>singular_chain p X c; continuous_map X X' g\<rbrakk> \<Longrightarrow> singular_chain p X' (chain_map p g c)"
+ unfolding chain_map_def
+ apply (rule singular_chain_extend)
+ by (metis comp_apply subsetD mem_Collect_eq singular_chain_def singular_chain_of singular_simplex_simplex_map)
+
+lemma chain_map_0 [simp]: "chain_map p g 0 = 0"
+ by (auto simp: chain_map_def)
+
+lemma chain_map_of [simp]: "chain_map p g (frag_of f) = frag_of (simplex_map p g f)"
+ by (simp add: chain_map_def)
+
+lemma chain_map_cmul [simp]:
+ "chain_map p g (frag_cmul a c) = frag_cmul a (chain_map p g c)"
+ by (simp add: frag_extend_cmul chain_map_def)
+
+lemma chain_map_minus: "chain_map p g (-c) = - (chain_map p g c)"
+ by (simp add: frag_extend_minus chain_map_def)
+
+lemma chain_map_add:
+ "chain_map p g (a+b) = chain_map p g a + chain_map p g b"
+ by (simp add: frag_extend_add chain_map_def)
+
+lemma chain_map_diff:
+ "chain_map p g (a-b) = chain_map p g a - chain_map p g b"
+ by (simp add: frag_extend_diff chain_map_def)
+
+lemma chain_map_sum:
+ "finite I \<Longrightarrow> chain_map p g (sum f I) = sum (chain_map p g \<circ> f) I"
+ by (simp add: frag_extend_sum chain_map_def)
+
+lemma chain_map_eq:
+ "\<lbrakk>singular_chain p X c; \<And>x. x \<in> topspace X \<Longrightarrow> f x = g x\<rbrakk>
+ \<Longrightarrow> chain_map p f c = chain_map p g c"
+ unfolding singular_chain_def
+ apply (erule frag_induction)
+ apply (auto simp: chain_map_diff)
+ apply (metis simplex_map_eq)
+ done
+
+lemma chain_map_id_gen:
+ "\<lbrakk>singular_chain p X c; \<And>x. x \<in> topspace X \<Longrightarrow> f x = x\<rbrakk>
+ \<Longrightarrow> chain_map p f c = c"
+ unfolding singular_chain_def
+ by (erule frag_induction) (auto simp: chain_map_diff simplex_map_id_gen)
+
+lemma chain_map_ident:
+ "singular_chain p X c \<Longrightarrow> chain_map p id c = c"
+ by (simp add: chain_map_id_gen)
+
+lemma chain_map_id:
+ "chain_map p id = frag_extend (frag_of \<circ> (\<lambda>f. restrict f (standard_simplex p)))"
+ by (auto simp: chain_map_def)
+
+lemma chain_map_compose:
+ "chain_map p (h \<circ> g) = chain_map p h \<circ> chain_map p g"
+proof
+ show "chain_map p (h \<circ> g) c = (chain_map p h \<circ> chain_map p g) c" for c
+ using subset_UNIV
+ proof (induction c rule: frag_induction)
+ case (one x)
+ then show ?case
+ by simp (metis (mono_tags, lifting) comp_eq_dest_lhs restrict_apply simplex_map_def)
+ next
+ case (diff a b)
+ then show ?case
+ by (simp add: chain_map_diff)
+ qed auto
+qed
+
+lemma singular_simplex_chain_map_id:
+ assumes "singular_simplex p X f"
+ shows "chain_map p f (frag_of (restrict id (standard_simplex p))) = frag_of f"
+proof -
+ have "(restrict (f \<circ> restrict id (standard_simplex p)) (standard_simplex p)) = f"
+ by (rule ext) (metis assms comp_apply extensional_arb id_apply restrict_apply singular_simplex_def)
+ then show ?thesis
+ by (simp add: simplex_map_def)
+qed
+
+lemma chain_boundary_chain_map:
+ assumes "singular_chain p X c"
+ shows "chain_boundary p (chain_map p g c) = chain_map (p - Suc 0) g (chain_boundary p c)"
+ using assms unfolding singular_chain_def
+proof (induction c rule: frag_induction)
+ case (one x)
+ then have "singular_face p i (simplex_map p g x) = simplex_map (p - Suc 0) g (singular_face p i x)"
+ if "0 \<le> i" "i \<le> p" "p \<noteq> 0" for i
+ using that
+ by (fastforce simp add: singular_face_def simplex_map_def simplical_face_in_standard_simplex)
+ then show ?case
+ by (auto simp: chain_boundary_of chain_map_sum)
+next
+ case (diff a b)
+ then show ?case
+ by (simp add: chain_boundary_diff chain_map_diff)
+qed auto
+
+lemma singular_relcycle_chain_map:
+ assumes "singular_relcycle p X S c" "continuous_map X X' g" "g ` S \<subseteq> T"
+ shows "singular_relcycle p X' T (chain_map p g c)"
+proof -
+ have "continuous_map (subtopology X S) (subtopology X' T) g"
+ using assms
+ using continuous_map_from_subtopology continuous_map_in_subtopology topspace_subtopology by fastforce
+ then show ?thesis
+ using chain_boundary_chain_map [of p X c g]
+ by (metis One_nat_def assms(1) assms(2) singular_chain_chain_map singular_relcycle)
+qed
+
+lemma singular_relboundary_chain_map:
+ assumes "singular_relboundary p X S c" "continuous_map X X' g" "g ` S \<subseteq> T"
+ shows "singular_relboundary p X' T (chain_map p g c)"
+proof -
+ obtain d e where d: "singular_chain (Suc p) X d"
+ and e: "singular_chain p (subtopology X S) e" and c: "c = chain_boundary (Suc p) d + e"
+ using assms by (auto simp: singular_relboundary)
+ have "singular_chain (Suc p) X' (chain_map (Suc p) g d)"
+ using assms(2) d singular_chain_chain_map by blast
+ moreover have "singular_chain p (subtopology X' T) (chain_map p g e)"
+ proof -
+ have "\<forall>t. g ` topspace (subtopology t S) \<subseteq> T"
+ by (metis assms(3) closure_of_subset_subtopology closure_of_topspace dual_order.trans image_mono)
+ then show ?thesis
+ by (meson assms(2) continuous_map_from_subtopology continuous_map_in_subtopology e singular_chain_chain_map)
+ qed
+ moreover have "chain_boundary (Suc p) (chain_map (Suc p) g d) + chain_map p g e =
+ chain_map p g (chain_boundary (Suc p) d + e)"
+ by (metis One_nat_def chain_boundary_chain_map chain_map_add d diff_Suc_1)
+ ultimately show ?thesis
+ unfolding singular_relboundary
+ using c by blast
+qed
+
+
+subsection\<open>Homology of one-point spaces degenerates except for $p = 0$.\<close>
+
+lemma singular_simplex_singleton:
+ assumes "topspace X = {a}"
+ shows "singular_simplex p X f \<longleftrightarrow> f = restrict (\<lambda>x. a) (standard_simplex p)" (is "?lhs = ?rhs")
+proof
+ assume L: ?lhs
+ then show ?rhs
+ proof -
+ have "continuous_map (subtopology (product_topology (\<lambda>n. euclideanreal) UNIV) (standard_simplex p)) X f"
+ using \<open>singular_simplex p X f\<close> singular_simplex_def by blast
+ then have "\<And>c. c \<notin> standard_simplex p \<or> f c = a"
+ by (simp add: assms continuous_map_def)
+ then show ?thesis
+ by (metis (no_types) L extensional_restrict restrict_ext singular_simplex_def)
+ qed
+next
+ assume ?rhs
+ with assms show ?lhs
+ by (auto simp: singular_simplex_def topspace_subtopology)
+qed
+
+lemma singular_chain_singleton:
+ assumes "topspace X = {a}"
+ shows "singular_chain p X c \<longleftrightarrow>
+ (\<exists>b. c = frag_cmul b (frag_of(restrict (\<lambda>x. a) (standard_simplex p))))"
+ (is "?lhs = ?rhs")
+proof
+ let ?f = "restrict (\<lambda>x. a) (standard_simplex p)"
+ assume L: ?lhs
+ with assms have "Poly_Mapping.keys c \<subseteq> {?f}"
+ by (auto simp: singular_chain_def singular_simplex_singleton)
+ then consider "Poly_Mapping.keys c = {}" | "Poly_Mapping.keys c = {?f}"
+ by blast
+ then show ?rhs
+ proof cases
+ case 1
+ with L show ?thesis
+ by (metis frag_cmul_zero keys_eq_empty)
+ next
+ case 2
+ then have "\<exists>b. frag_extend frag_of c = frag_cmul b (frag_of (\<lambda>x\<in>standard_simplex p. a))"
+ by (force simp: frag_extend_def)
+ then show ?thesis
+ by (metis frag_expansion)
+ qed
+next
+ assume ?rhs
+ with assms show ?lhs
+ by (auto simp: singular_chain_def singular_simplex_singleton)
+qed
+
+lemma chain_boundary_of_singleton:
+ assumes tX: "topspace X = {a}" and sc: "singular_chain p X c"
+ shows "chain_boundary p c =
+ (if p = 0 \<or> odd p then 0
+ else frag_extend (\<lambda>f. frag_of(restrict (\<lambda>x. a) (standard_simplex (p -1)))) c)"
+ (is "?lhs = ?rhs")
+proof (cases "p = 0")
+ case False
+ have "?lhs = frag_extend (\<lambda>f. if odd p then 0 else frag_of(restrict (\<lambda>x. a) (standard_simplex (p -1)))) c"
+ proof (simp only: chain_boundary_def False if_False, rule frag_extend_eq)
+ fix f
+ assume "f \<in> Poly_Mapping.keys c"
+ with assms have "singular_simplex p X f"
+ by (auto simp: singular_chain_def)
+ then have *: "\<And>k. k \<le> p \<Longrightarrow> singular_face p k f = (\<lambda>x\<in>standard_simplex (p -1). a)"
+ apply (subst singular_simplex_singleton [OF tX, symmetric])
+ using False singular_simplex_singular_face by fastforce
+ define c where "c \<equiv> frag_of (\<lambda>x\<in>standard_simplex (p -1). a)"
+ have "(\<Sum>k\<le>p. frag_cmul ((-1) ^ k) (frag_of (singular_face p k f)))
+ = (\<Sum>k\<le>p. frag_cmul ((-1) ^ k) c)"
+ by (auto simp: c_def * intro: sum.cong)
+ also have "\<dots> = (if odd p then 0 else c)"
+ by (induction p) (auto simp: c_def restrict_def)
+ finally show "(\<Sum>k\<le>p. frag_cmul ((-1) ^ k) (frag_of (singular_face p k f)))
+ = (if odd p then 0 else frag_of (\<lambda>x\<in>standard_simplex (p -1). a))"
+ unfolding c_def .
+ qed
+ also have "\<dots> = ?rhs"
+ by (auto simp: False frag_extend_eq_0)
+ finally show ?thesis .
+qed (simp add: chain_boundary_def)
+
+
+lemma singular_cycle_singleton:
+ assumes "topspace X = {a}"
+ shows "singular_relcycle p X {} c \<longleftrightarrow> singular_chain p X c \<and> (p = 0 \<or> odd p \<or> c = 0)"
+proof -
+ have "c = 0" if "singular_chain p X c" and "chain_boundary p c = 0" and "even p" and "p \<noteq> 0"
+ using that assms singular_chain_singleton [of X a p c] chain_boundary_of_singleton [OF assms]
+ by (auto simp: frag_extend_cmul)
+ moreover
+ have "chain_boundary p c = 0" if sc: "singular_chain p X c" and "odd p"
+ by (simp add: chain_boundary_of_singleton [OF assms sc] that)
+ moreover have "chain_boundary 0 c = 0" if "singular_chain 0 X c" and "p = 0"
+ by (simp add: chain_boundary_def)
+ ultimately show ?thesis
+ using assms by (auto simp: singular_cycle)
+qed
+
+
+lemma singular_boundary_singleton:
+ assumes "topspace X = {a}"
+ shows "singular_relboundary p X {} c \<longleftrightarrow> singular_chain p X c \<and> (odd p \<or> c = 0)"
+proof (cases "singular_chain p X c")
+ case True
+ have eq: "frag_extend (\<lambda>f. frag_of (\<lambda>x\<in>standard_simplex p. a)) (frag_of (\<lambda>x\<in>standard_simplex (Suc p). a))
+ = frag_of (\<lambda>x\<in>standard_simplex p. a)"
+ by (simp add: singular_chain_singleton frag_extend_cmul assms)
+ have "\<exists>d. singular_chain (Suc p) X d \<and> chain_boundary (Suc p) d = c"
+ if "singular_chain p X c" and "odd p"
+ using assms that
+ apply (clarsimp simp: singular_chain_singleton)
+ apply (rule_tac x = "frag_cmul b (frag_of (\<lambda>x\<in>standard_simplex (Suc p). a))" in exI)
+ apply (subst chain_boundary_of_singleton [of X a "Suc p"])
+ apply (auto simp: singular_chain_singleton frag_extend_cmul eq)
+ done
+ with True assms show ?thesis
+ by (auto simp: singular_boundary chain_boundary_of_singleton)
+next
+ case False
+ with assms singular_boundary_imp_chain show ?thesis
+ by metis
+qed
+
+
+lemma singular_boundary_eq_cycle_singleton:
+ assumes "topspace X = {a}" "1 \<le> p"
+ shows "singular_relboundary p X {} c \<longleftrightarrow> singular_relcycle p X {} c"
+ using assms
+ apply (auto simp: singular_boundary chain_boundary_boundary_alt singular_chain_boundary_alt singular_cycle)
+ by (metis Suc_neq_Zero le_zero_eq singular_boundary singular_boundary_singleton singular_chain_0 singular_cycle_singleton singular_relcycle)
+
+lemma singular_boundary_set_eq_cycle_singleton:
+ assumes "topspace X = {a}" "1 \<le> p"
+ shows "singular_relboundary_set p X {} = singular_relcycle_set p X {}"
+ using singular_boundary_eq_cycle_singleton [OF assms]
+ by blast
+
+subsection\<open>Simplicial chains\<close>
+
+text\<open>Simplicial chains, effectively those resulting from linear maps.
+ We still allow the map to be singular, so the name is questionable.
+These are intended as building-blocks for singular subdivision, rather than as a axis
+for 1 simplicial homology.\<close>
+
+definition oriented_simplex
+ where "oriented_simplex p l \<equiv> (\<lambda>x\<in>standard_simplex p. \<lambda>i. (\<Sum>j\<le>p. l j i * x j))"
+
+definition simplicial_simplex
+ where
+ "simplicial_simplex p S f \<equiv>
+ singular_simplex p (subtopology (powertop_real UNIV) S) f \<and>
+ (\<exists>l. f = oriented_simplex p l)"
+
+lemma simplicial_simplex:
+ "simplicial_simplex p S f \<longleftrightarrow> f ` (standard_simplex p) \<subseteq> S \<and> (\<exists>l. f = oriented_simplex p l)"
+ (is "?lhs = ?rhs")
+proof
+ assume R: ?rhs
+ show ?lhs
+ using R
+ apply (clarsimp simp: simplicial_simplex_def singular_simplex_subtopology)
+ apply (simp add: singular_simplex_def oriented_simplex_def)
+ apply (clarsimp simp: continuous_map_componentwise)
+ apply (intro continuous_intros continuous_map_from_subtopology continuous_map_product_projection, auto)
+ done
+qed (simp add: simplicial_simplex_def singular_simplex_subtopology)
+
+lemma simplicial_simplex_empty [simp]: "\<not> simplicial_simplex p {} f"
+ by (simp add: nonempty_standard_simplex simplicial_simplex)
+
+definition simplicial_chain
+ where "simplicial_chain p S c \<equiv> Poly_Mapping.keys c \<subseteq> Collect (simplicial_simplex p S)"
+
+lemma simplicial_chain_0 [simp]: "simplicial_chain p S 0"
+ by (simp add: simplicial_chain_def)
+
+lemma simplicial_chain_of [simp]:
+ "simplicial_chain p S (frag_of c) \<longleftrightarrow> simplicial_simplex p S c"
+ by (simp add: simplicial_chain_def)
+
+lemma simplicial_chain_cmul:
+ "simplicial_chain p S c \<Longrightarrow> simplicial_chain p S (frag_cmul a c)"
+ by (auto simp: simplicial_chain_def)
+
+lemma simplicial_chain_diff:
+ "\<lbrakk>simplicial_chain p S c1; simplicial_chain p S c2\<rbrakk> \<Longrightarrow> simplicial_chain p S (c1 - c2)"
+ unfolding simplicial_chain_def by (meson UnE keys_diff subset_iff)
+
+lemma simplicial_chain_sum:
+ "(\<And>i. i \<in> I \<Longrightarrow> simplicial_chain p S (f i)) \<Longrightarrow> simplicial_chain p S (sum f I)"
+ unfolding simplicial_chain_def
+ using order_trans [OF keys_sum [of f I]]
+ by (simp add: UN_least)
+
+lemma simplicial_simplex_oriented_simplex:
+ "simplicial_simplex p S (oriented_simplex p l)
+ \<longleftrightarrow> ((\<lambda>x i. \<Sum>j\<le>p. l j i * x j) ` standard_simplex p \<subseteq> S)"
+ by (auto simp: simplicial_simplex oriented_simplex_def)
+
+lemma simplicial_imp_singular_simplex:
+ "simplicial_simplex p S f
+ \<Longrightarrow> singular_simplex p (subtopology (powertop_real UNIV) S) f"
+ by (simp add: simplicial_simplex_def)
+
+lemma simplicial_imp_singular_chain:
+ "simplicial_chain p S c
+ \<Longrightarrow> singular_chain p (subtopology (powertop_real UNIV) S) c"
+ unfolding simplicial_chain_def singular_chain_def
+ by (auto intro: simplicial_imp_singular_simplex)
+
+lemma oriented_simplex_eq:
+ "oriented_simplex p l = oriented_simplex p l' \<longleftrightarrow> (\<forall>i. i \<le> p \<longrightarrow> l i = l' i)"
+ (is "?lhs = ?rhs")
+proof
+ assume L: ?lhs
+ show ?rhs
+ proof clarify
+ fix i
+ assume "i \<le> p"
+ let ?fi = "(\<lambda>j. if j = i then 1 else 0)"
+ have "(\<Sum>j\<le>p. l j k * ?fi j) = (\<Sum>j\<le>p. l' j k * ?fi j)" for k
+ apply (rule fun_cong [where x=k])
+ using fun_cong [OF L, of ?fi]
+ apply (simp add: \<open>i \<le> p\<close> oriented_simplex_def)
+ done
+ with \<open>i \<le> p\<close> show "l i = l' i"
+ by (simp add: if_distrib ext cong: if_cong)
+ qed
+qed (auto simp: oriented_simplex_def)
+
+lemma sum_zero_middle:
+ fixes g :: "nat \<Rightarrow> 'a::comm_monoid_add"
+ assumes "1 \<le> p" "k \<le> p"
+ shows "(\<Sum>j\<le>p. if j < k then f j else if j = k then 0 else g (j - Suc 0))
+ = (\<Sum>j\<le>p - Suc 0. if j < k then f j else g j)" (is "?lhs = ?rhs")
+proof -
+ have [simp]: "{..p - Suc 0} \<inter> {j. j < k} = {..<k}" "{..p - Suc 0} \<inter> - {j. j < k} = {k..p - Suc 0}"
+ using assms by auto
+ have "?lhs = (\<Sum>j<k. f j) + (\<Sum>j = k..p. if j = k then 0 else g (j - Suc 0))"
+ using sum.union_disjoint [of "{..<k}" "{k..p}", where 'a='a] assms
+ by (simp add: ivl_disj_int_one ivl_disj_un_one)
+ also have "\<dots> = (\<Sum>j<k. f j) + (\<Sum>j = Suc k..p. g (j - Suc 0))"
+ by (simp add: sum_head_Suc [of k p] assms)
+ also have "\<dots> = (\<Sum>j<k. f j) + (\<Sum>j = k..p - Suc 0. g j)"
+ using sum.reindex [of Suc "{k..p - Suc 0}", where 'a='a] assms by simp
+ also have "\<dots> = ?rhs"
+ by (simp add: comm_monoid_add_class.sum.If_cases)
+ finally show ?thesis .
+qed
+
+lemma singular_face_oriented_simplex:
+ assumes "1 \<le> p" "k \<le> p"
+ shows "singular_face p k (oriented_simplex p l) =
+ oriented_simplex (p -1) (\<lambda>j. if j < k then l j else l (Suc j))"
+proof -
+ have "(\<Sum>j\<le>p. l j i * simplical_face k x j)
+ = (\<Sum>j\<le>p - Suc 0. (if j < k then l j else l (Suc j)) i * x j)"
+ if "x \<in> standard_simplex (p - Suc 0)" for i x
+ proof -
+ show ?thesis
+ unfolding simplical_face_def
+ using sum_zero_middle [OF assms, where 'a=real, symmetric]
+ apply (simp add: if_distrib [of "\<lambda>x. _ * x"] if_distrib [of "\<lambda>f. f i * _"] atLeast0AtMost cong: if_cong)
+ done
+ qed
+ then show ?thesis
+ using simplical_face_in_standard_simplex assms
+ by (auto simp: singular_face_def oriented_simplex_def restrict_def)
+qed
+
+lemma simplicial_simplex_singular_face:
+ fixes f :: "(nat \<Rightarrow> real) \<Rightarrow> nat \<Rightarrow> real"
+ assumes ss: "simplicial_simplex p S f" and p: "1 \<le> p" "k \<le> p"
+ shows "simplicial_simplex (p - Suc 0) S (singular_face p k f)"
+proof -
+ let ?X = "subtopology (powertop_real UNIV) S"
+ obtain m where l: "singular_simplex p ?X (oriented_simplex p m)"
+ and feq: "f = oriented_simplex p m"
+ using assms by (force simp: simplicial_simplex_def)
+ moreover have "\<exists>l. singular_face p k f = oriented_simplex (p - Suc 0) l"
+ apply (simp add: feq singular_face_def oriented_simplex_def)
+ apply (simp add: simplical_face_in_standard_simplex [OF p] restrict_compose_left subset_eq)
+ apply (rule_tac x="\<lambda>i. if i < k then m i else m (Suc i)" in exI)
+ using sum_zero_middle [OF p, where 'a=real, symmetric] unfolding simplical_face_def o_def
+ apply (simp add: if_distrib [of "\<lambda>x. _ * x"] if_distrib [of "\<lambda>f. f _ * _"] atLeast0AtMost cong: if_cong)
+ done
+ ultimately
+ show ?thesis
+ using assms by (simp add: singular_simplex_singular_face simplicial_simplex_def)
+qed
+
+lemma simplicial_chain_boundary:
+ "simplicial_chain p S c \<Longrightarrow> simplicial_chain (p -1) S (chain_boundary p c)"
+ unfolding simplicial_chain_def
+proof (induction rule: frag_induction)
+ case (one f)
+ then have "simplicial_simplex p S f"
+ by simp
+ have "simplicial_chain (p - Suc 0) S (frag_of (singular_face p i f))"
+ if "0 < p" "i \<le> p" for i
+ using that one
+ apply (simp add: simplicial_simplex_def singular_simplex_singular_face)
+ apply (force simp: singular_face_oriented_simplex)
+ done
+ then have "simplicial_chain (p - Suc 0) S (chain_boundary p (frag_of f))"
+ unfolding chain_boundary_def frag_extend_of
+ by (auto intro!: simplicial_chain_cmul simplicial_chain_sum)
+ then show ?case
+ by (simp add: simplicial_chain_def [symmetric])
+next
+ case (diff a b)
+ then show ?case
+ by (metis chain_boundary_diff simplicial_chain_def simplicial_chain_diff)
+qed auto
+
+
+subsection\<open>The cone construction on simplicial simplices.\<close>
+
+consts simplex_cone :: "[nat, nat \<Rightarrow> real, [nat \<Rightarrow> real, nat] \<Rightarrow> real, nat \<Rightarrow> real, nat] \<Rightarrow> real"
+specification (simplex_cone)
+ simplex_cone:
+ "\<And>p v l. simplex_cone p v (oriented_simplex p l) =
+ oriented_simplex (Suc p) (\<lambda>i. if i = 0 then v else l(i -1))"
+proof -
+ have *: "\<And>x. \<exists>y. \<forall>v. (\<lambda>l. oriented_simplex (Suc x) (\<lambda>i. if i = 0 then v else l (i -1)))
+ = (y v \<circ> (oriented_simplex x))"
+ apply (subst choice_iff [symmetric])
+ apply (subst function_factors_left [symmetric])
+ by (simp add: oriented_simplex_eq)
+ then show ?thesis
+ apply (subst choice_iff [symmetric])
+ apply (subst fun_eq_iff [symmetric])
+ unfolding o_def
+ apply (blast intro: sym)
+ done
+qed
+
+lemma simplicial_simplex_simplex_cone:
+ assumes f: "simplicial_simplex p S f"
+ and T: "\<And>x u. \<lbrakk>0 \<le> u; u \<le> 1; x \<in> S\<rbrakk> \<Longrightarrow> (\<lambda>i. (1 - u) * v i + u * x i) \<in> T"
+ shows "simplicial_simplex (Suc p) T (simplex_cone p v f)"
+proof -
+ obtain l where l: "\<And>x. x \<in> standard_simplex p \<Longrightarrow> oriented_simplex p l x \<in> S"
+ and feq: "f = oriented_simplex p l"
+ using f by (auto simp: simplicial_simplex)
+ have "oriented_simplex p l x \<in> S" if "x \<in> standard_simplex p" for x
+ using f that by (auto simp: simplicial_simplex feq)
+ then have S: "\<And>x. \<lbrakk>\<And>i. 0 \<le> x i \<and> x i \<le> 1; \<And>i. i>p \<Longrightarrow> x i = 0; sum x {..p} = 1\<rbrakk>
+ \<Longrightarrow> (\<lambda>i. \<Sum>j\<le>p. l j i * x j) \<in> S"
+ by (simp add: oriented_simplex_def standard_simplex_def)
+ have "oriented_simplex (Suc p) (\<lambda>i. if i = 0 then v else l (i -1)) x \<in> T"
+ if "x \<in> standard_simplex (Suc p)" for x
+ proof (simp add: that oriented_simplex_def sum_atMost_Suc_shift del: sum_atMost_Suc)
+ have x01: "\<And>i. 0 \<le> x i \<and> x i \<le> 1" and x0: "\<And>i. i > Suc p \<Longrightarrow> x i = 0" and x1: "sum x {..Suc p} = 1"
+ using that by (auto simp: oriented_simplex_def standard_simplex_def)
+ obtain a where "a \<in> S"
+ using f by force
+ show "(\<lambda>i. v i * x 0 + (\<Sum>j\<le>p. l j i * x (Suc j))) \<in> T"
+ proof (cases "x 0 = 1")
+ case True
+ then have "sum x {Suc 0..Suc p} = 0"
+ using x1 by (simp add: atMost_atLeast0 sum_head_Suc)
+ then have [simp]: "x (Suc j) = 0" if "j\<le>p" for j
+ unfolding sum.atLeast_Suc_atMost_Suc_shift
+ using x01 that by (simp add: sum_nonneg_eq_0_iff)
+ then show ?thesis
+ using T [of 0 a] \<open>a \<in> S\<close> by (auto simp: True)
+ next
+ case False
+ then have "(\<lambda>i. v i * x 0 + (\<Sum>j\<le>p. l j i * x (Suc j))) = (\<lambda>i. (1 - (1 - x 0)) * v i + (1 - x 0) * (inverse (1 - x 0) * (\<Sum>j\<le>p. l j i * x (Suc j))))"
+ by (force simp: field_simps)
+ also have "\<dots> \<in> T"
+ proof (rule T)
+ have "x 0 < 1"
+ by (simp add: False less_le x01)
+ have xle: "x (Suc i) \<le> (1 - x 0)" for i
+ proof (cases "i \<le> p")
+ case True
+ have "sum x {0, Suc i} \<le> sum x {..Suc p}"
+ by (rule sum_mono2) (auto simp: True x01)
+ then show ?thesis
+ using x1 x01 by (simp add: algebra_simps not_less)
+ qed (simp add: x0 x01)
+ have "(\<lambda>i. (\<Sum>j\<le>p. l j i * (x (Suc j) * inverse (1 - x 0)))) \<in> S"
+ proof (rule S)
+ have "x 0 + (\<Sum>j\<le>p. x (Suc j)) = sum x {..Suc p}"
+ by (metis sum_atMost_Suc_shift)
+ with x1 have "(\<Sum>j\<le>p. x (Suc j)) = 1 - x 0"
+ by simp
+ with False show "(\<Sum>j\<le>p. x (Suc j) * inverse (1 - x 0)) = 1"
+ by (metis add_diff_cancel_left' diff_diff_eq2 diff_zero right_inverse sum_distrib_right)
+ qed (use x01 x0 xle \<open>x 0 < 1\<close> in \<open>auto simp: divide_simps\<close>)
+ then show "(\<lambda>i. inverse (1 - x 0) * (\<Sum>j\<le>p. l j i * x (Suc j))) \<in> S"
+ by (simp add: field_simps sum_divide_distrib)
+ qed (use x01 in auto)
+ finally show ?thesis .
+ qed
+qed
+ then show ?thesis
+ by (auto simp: simplicial_simplex feq simplex_cone)
+qed
+
+definition simplicial_cone
+ where "simplicial_cone p v \<equiv> frag_extend (frag_of \<circ> simplex_cone p v)"
+
+lemma simplicial_chain_simplicial_cone:
+ assumes c: "simplicial_chain p S c"
+ and T: "\<And>x u. \<lbrakk>0 \<le> u; u \<le> 1; x \<in> S\<rbrakk> \<Longrightarrow> (\<lambda>i. (1 - u) * v i + u * x i) \<in> T"
+ shows "simplicial_chain (Suc p) T (simplicial_cone p v c)"
+ using c unfolding simplicial_chain_def simplicial_cone_def
+proof (induction rule: frag_induction)
+ case (one x)
+ then show ?case
+ by (simp add: T simplicial_simplex_simplex_cone)
+next
+ case (diff a b)
+ then show ?case
+ by (metis frag_extend_diff simplicial_chain_def simplicial_chain_diff)
+qed auto
+
+
+lemma chain_boundary_simplicial_cone_of':
+ assumes "f = oriented_simplex p l"
+ shows "chain_boundary (Suc p) (simplicial_cone p v (frag_of f)) =
+ frag_of f
+ - (if p = 0 then frag_of (\<lambda>u\<in>standard_simplex p. v)
+ else simplicial_cone (p -1) v (chain_boundary p (frag_of f)))"
+proof (simp, intro impI conjI)
+ assume "p = 0"
+ have eq: "(oriented_simplex 0 (\<lambda>j. if j = 0 then v else l j)) = (\<lambda>u\<in>standard_simplex 0. v)"
+ by (force simp: oriented_simplex_def standard_simplex_def)
+ show "chain_boundary (Suc 0) (simplicial_cone 0 v (frag_of f))
+ = frag_of f - frag_of (\<lambda>u\<in>standard_simplex 0. v)"
+ by (simp add: assms simplicial_cone_def chain_boundary_of \<open>p = 0\<close> simplex_cone singular_face_oriented_simplex eq cong: if_cong)
+next
+ assume "0 < p"
+ have 0: "simplex_cone (p - Suc 0) v (singular_face p x (oriented_simplex p l))
+ = oriented_simplex p
+ (\<lambda>j. if j < Suc x
+ then if j = 0 then v else l (j -1)
+ else if Suc j = 0 then v else l (Suc j -1))" if "x \<le> p" for x
+ using \<open>0 < p\<close> that
+ by (auto simp: Suc_leI singular_face_oriented_simplex simplex_cone oriented_simplex_eq)
+ have 1: "frag_extend (frag_of \<circ> simplex_cone (p - Suc 0) v)
+ (\<Sum>k = 0..p. frag_cmul ((-1) ^ k) (frag_of (singular_face p k (oriented_simplex p l))))
+ = - (\<Sum>k = Suc 0..Suc p. frag_cmul ((-1) ^ k)
+ (frag_of (singular_face (Suc p) k (simplex_cone p v (oriented_simplex p l)))))"
+ apply (subst sum.atLeast_Suc_atMost_Suc_shift)
+ apply (simp add: frag_extend_sum frag_extend_cmul flip: sum_negf)
+ apply (auto simp: simplex_cone singular_face_oriented_simplex 0 intro: sum.cong)
+ done
+ moreover have 2: "singular_face (Suc p) 0 (simplex_cone p v (oriented_simplex p l))
+ = oriented_simplex p l"
+ by (simp add: simplex_cone singular_face_oriented_simplex)
+ show "chain_boundary (Suc p) (simplicial_cone p v (frag_of f))
+ = frag_of f - simplicial_cone (p - Suc 0) v (chain_boundary p (frag_of f))"
+ using \<open>p > 0\<close>
+ apply (simp add: assms simplicial_cone_def chain_boundary_of atMost_atLeast0 del: sum_atMost_Suc)
+ apply (subst sum_head_Suc [of 0])
+ apply (simp_all add: 1 2 del: sum_atMost_Suc)
+ done
+qed
+
+lemma chain_boundary_simplicial_cone_of:
+ assumes "simplicial_simplex p S f"
+ shows "chain_boundary (Suc p) (simplicial_cone p v (frag_of f)) =
+ frag_of f
+ - (if p = 0 then frag_of (\<lambda>u\<in>standard_simplex p. v)
+ else simplicial_cone (p -1) v (chain_boundary p (frag_of f)))"
+ using chain_boundary_simplicial_cone_of' assms unfolding simplicial_simplex_def
+ by blast
+
+lemma chain_boundary_simplicial_cone:
+ "simplicial_chain p S c
+ \<Longrightarrow> chain_boundary (Suc p) (simplicial_cone p v c) =
+ c - (if p = 0 then frag_extend (\<lambda>f. frag_of (\<lambda>u\<in>standard_simplex p. v)) c
+ else simplicial_cone (p -1) v (chain_boundary p c))"
+ unfolding simplicial_chain_def
+proof (induction rule: frag_induction)
+ case (one x)
+ then show ?case
+ by (auto simp: chain_boundary_simplicial_cone_of)
+qed (auto simp: chain_boundary_diff simplicial_cone_def frag_extend_diff)
+
+lemma simplex_map_oriented_simplex:
+ assumes l: "simplicial_simplex p (standard_simplex q) (oriented_simplex p l)"
+ and g: "simplicial_simplex r S g" and "q \<le> r"
+ shows "simplex_map p g (oriented_simplex p l) = oriented_simplex p (g \<circ> l)"
+proof -
+ obtain m where geq: "g = oriented_simplex r m"
+ using g by (auto simp: simplicial_simplex_def)
+ have "g (\<lambda>i. \<Sum>j\<le>p. l j i * x j) i = (\<Sum>j\<le>p. g (l j) i * x j)"
+ if "x \<in> standard_simplex p" for x i
+ proof -
+ have ssr: "(\<lambda>i. \<Sum>j\<le>p. l j i * x j) \<in> standard_simplex r"
+ using l that standard_simplex_mono [OF \<open>q \<le> r\<close>]
+ unfolding simplicial_simplex_oriented_simplex by auto
+ have lss: "l j \<in> standard_simplex r" if "j\<le>p" for j
+ proof -
+ have q: "(\<lambda>x i. \<Sum>j\<le>p. l j i * x j) ` standard_simplex p \<subseteq> standard_simplex q"
+ using l by (simp add: simplicial_simplex_oriented_simplex)
+ have p: "l j \<in> (\<lambda>x i. \<Sum>j\<le>p. l j i * x j) ` standard_simplex p"
+ apply (rule_tac x="(\<lambda>i. if i = j then 1 else 0)" in rev_image_eqI)
+ using \<open>j\<le>p\<close> by (force simp: basis_in_standard_simplex if_distrib cong: if_cong)+
+ show ?thesis
+ apply (rule subsetD [OF standard_simplex_mono [OF \<open>q \<le> r\<close>]])
+ apply (rule subsetD [OF q p])
+ done
+ qed
+ show ?thesis
+ apply (simp add: geq oriented_simplex_def sum_distrib_left sum_distrib_right mult.assoc ssr lss)
+ by (rule sum.swap)
+ qed
+ then show ?thesis
+ by (force simp: oriented_simplex_def simplex_map_def o_def)
+qed
+
+
+lemma chain_map_simplicial_cone:
+ assumes g: "simplicial_simplex r S g"
+ and c: "simplicial_chain p (standard_simplex q) c"
+ and v: "v \<in> standard_simplex q" and "q \<le> r"
+ shows "chain_map (Suc p) g (simplicial_cone p v c) = simplicial_cone p (g v) (chain_map p g c)"
+proof -
+ have *: "simplex_map (Suc p) g (simplex_cone p v f) = simplex_cone p (g v) (simplex_map p g f)"
+ if "f \<in> Poly_Mapping.keys c" for f
+ proof -
+ have "simplicial_simplex p (standard_simplex q) f"
+ using c that by (auto simp: simplicial_chain_def)
+ then obtain m where feq: "f = oriented_simplex p m"
+ by (auto simp: simplicial_simplex)
+ have 0: "simplicial_simplex p (standard_simplex q) (oriented_simplex p m)"
+ using \<open>simplicial_simplex p (standard_simplex q) f\<close> feq by blast
+ then have 1: "simplicial_simplex (Suc p) (standard_simplex q)
+ (oriented_simplex (Suc p) (\<lambda>i. if i = 0 then v else m (i -1)))"
+ using convex_standard_simplex v
+ by (simp flip: simplex_cone add: simplicial_simplex_simplex_cone)
+ show ?thesis
+ using simplex_map_oriented_simplex [OF 1 g \<open>q \<le> r\<close>]
+ simplex_map_oriented_simplex [of p q m r S g, OF 0 g \<open>q \<le> r\<close>]
+ by (simp add: feq oriented_simplex_eq simplex_cone)
+ qed
+ show ?thesis
+ by (auto simp: chain_map_def simplicial_cone_def frag_extend_compose * intro: frag_extend_eq)
+qed
+
+
+subsection\<open>Barycentric subdivision of a linear ("simplicial") simplex's image\<close>
+
+definition simplicial_vertex
+ where "simplicial_vertex i f = f(\<lambda>j. if j = i then 1 else 0)"
+
+lemma simplicial_vertex_oriented_simplex:
+ "simplicial_vertex i (oriented_simplex p l) = (if i \<le> p then l i else undefined)"
+ by (simp add: simplicial_vertex_def oriented_simplex_def if_distrib cong: if_cong)
+
+
+primrec simplicial_subdivision
+where
+ "simplicial_subdivision 0 = id"
+| "simplicial_subdivision (Suc p) =
+ frag_extend
+ (\<lambda>f. simplicial_cone p
+ (\<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j f i) / (p + 2))
+ (simplicial_subdivision p (chain_boundary (Suc p) (frag_of f))))"
+
+
+lemma simplicial_subdivision_0 [simp]:
+ "simplicial_subdivision p 0 = 0"
+ by (induction p) auto
+
+lemma simplicial_subdivision_diff:
+ "simplicial_subdivision p (c1-c2) = simplicial_subdivision p c1 - simplicial_subdivision p c2"
+ by (induction p) (auto simp: frag_extend_diff)
+
+lemma simplicial_subdivision_of:
+ "simplicial_subdivision p (frag_of f) =
+ (if p = 0 then frag_of f
+ else simplicial_cone (p -1)
+ (\<lambda>i. (\<Sum>j\<le>p. simplicial_vertex j f i) / (Suc p))
+ (simplicial_subdivision (p -1) (chain_boundary p (frag_of f))))"
+ by (induction p) (auto simp: add.commute)
+
+
+lemma simplicial_chain_simplicial_subdivision:
+ "simplicial_chain p S c
+ \<Longrightarrow> simplicial_chain p S (simplicial_subdivision p c)"
+proof (induction p arbitrary: S c)
+ case (Suc p)
+ show ?case
+ using Suc.prems [unfolded simplicial_chain_def]
+ proof (induction c rule: frag_induction)
+ case (one f)
+ then have f: "simplicial_simplex (Suc p) S f"
+ by auto
+ then have "simplicial_chain p (f ` standard_simplex (Suc p))
+ (simplicial_subdivision p (chain_boundary (Suc p) (frag_of f)))"
+ by (metis Suc.IH diff_Suc_1 simplicial_chain_boundary simplicial_chain_of simplicial_simplex subsetI)
+ moreover
+ obtain l where l: "\<And>x. x \<in> standard_simplex (Suc p) \<Longrightarrow> (\<lambda>i. (\<Sum>j\<le>Suc p. l j i * x j)) \<in> S"
+ and feq: "f = oriented_simplex (Suc p) l"
+ using f by (fastforce simp: simplicial_simplex oriented_simplex_def simp del: sum_atMost_Suc)
+ have "(\<lambda>i. (1 - u) * ((\<Sum>j\<le>Suc p. simplicial_vertex j f i) / (real p + 2)) + u * y i) \<in> S"
+ if "0 \<le> u" "u \<le> 1" and y: "y \<in> f ` standard_simplex (Suc p)" for y u
+ proof -
+ obtain x where x: "x \<in> standard_simplex (Suc p)" and yeq: "y = oriented_simplex (Suc p) l x"
+ using y feq by blast
+ have "(\<lambda>i. \<Sum>j\<le>Suc p. l j i * ((if j \<le> Suc p then (1 - u) * inverse (p + 2) + u * x j else 0))) \<in> S"
+ proof (rule l)
+ have i2p: "inverse (2 + real p) \<le> 1"
+ by (simp add: divide_simps)
+ show "(\<lambda>j. if j \<le> Suc p then (1 - u) * inverse (real (p + 2)) + u * x j else 0) \<in> standard_simplex (Suc p)"
+ using x \<open>0 \<le> u\<close> \<open>u \<le> 1\<close>
+ apply (simp add: sum.distrib standard_simplex_def i2p linepath_le_1 flip: sum_distrib_left del: sum_atMost_Suc)
+ apply (simp add: divide_simps)
+ done
+ qed
+ moreover have "(\<lambda>i. \<Sum>j\<le>Suc p. l j i * ((1 - u) * inverse (2 + real p) + u * x j))
+ = (\<lambda>i. (1 - u) * (\<Sum>j\<le>Suc p. l j i) / (real p + 2) + u * (\<Sum>j\<le>Suc p. l j i * x j))"
+ proof
+ fix i
+ have "(\<Sum>j\<le>Suc p. l j i * ((1 - u) * inverse (2 + real p) + u * x j))
+ = (\<Sum>j\<le>Suc p. (1 - u) * l j i / (real p + 2) + u * l j i * x j)" (is "?lhs = _")
+ by (simp add: field_simps cong: sum.cong)
+ also have "\<dots> = (1 - u) * (\<Sum>j\<le>Suc p. l j i) / (real p + 2) + u * (\<Sum>j\<le>Suc p. l j i * x j)" (is "_ = ?rhs")
+ by (simp add: sum_distrib_left sum.distrib sum_divide_distrib mult.assoc del: sum_atMost_Suc)
+ finally show "?lhs = ?rhs" .
+ qed
+ ultimately show ?thesis
+ using feq x yeq
+ by (simp add: simplicial_vertex_oriented_simplex) (simp add: oriented_simplex_def)
+ qed
+ ultimately show ?case
+ by (simp add: simplicial_chain_simplicial_cone)
+ next
+ case (diff a b)
+ then show ?case
+ by (metis simplicial_chain_diff simplicial_subdivision_diff)
+ qed auto
+qed auto
+
+lemma chain_boundary_simplicial_subdivision:
+ "simplicial_chain p S c
+ \<Longrightarrow> chain_boundary p (simplicial_subdivision p c) = simplicial_subdivision (p -1) (chain_boundary p c)"
+proof (induction p arbitrary: c)
+ case (Suc p)
+ show ?case
+ using Suc.prems [unfolded simplicial_chain_def]
+ proof (induction c rule: frag_induction)
+ case (one f)
+ then have f: "simplicial_simplex (Suc p) S f"
+ by simp
+ then have "simplicial_chain p S (simplicial_subdivision p (chain_boundary (Suc p) (frag_of f)))"
+ by (metis diff_Suc_1 simplicial_chain_boundary simplicial_chain_of simplicial_chain_simplicial_subdivision)
+ moreover have "simplicial_chain p S (chain_boundary (Suc p) (frag_of f))"
+ using one simplicial_chain_boundary simplicial_chain_of by fastforce
+ moreover have "simplicial_subdivision (p - Suc 0) (chain_boundary p (chain_boundary (Suc p) (frag_of f))) = 0"
+ by (metis f chain_boundary_boundary_alt simplicial_simplex_def simplicial_subdivision_0 singular_chain_of)
+ ultimately show ?case
+ apply (simp add: chain_boundary_simplicial_cone Suc)
+ apply (auto simp: chain_boundary_of frag_extend_diff simplicial_cone_def)
+ done
+ next
+ case (diff a b)
+ then show ?case
+ by (simp add: simplicial_subdivision_diff chain_boundary_diff frag_extend_diff)
+ qed auto
+qed auto
+
+
+(*A MESS AND USED ONLY ONCE*)
+lemma simplicial_subdivision_shrinks:
+ "\<lbrakk>simplicial_chain p S c;
+ \<And>f x y. \<lbrakk>f \<in> Poly_Mapping.keys c; x \<in> standard_simplex p; y \<in> standard_simplex p\<rbrakk> \<Longrightarrow> \<bar>f x k - f y k\<bar> \<le> d;
+ f \<in> Poly_Mapping.keys(simplicial_subdivision p c);
+ x \<in> standard_simplex p; y \<in> standard_simplex p\<rbrakk>
+ \<Longrightarrow> \<bar>f x k - f y k\<bar> \<le> (p / (Suc p)) * d"
+proof (induction p arbitrary: d c f x y)
+ case (Suc p)
+ define Sigp where "Sigp \<equiv> \<lambda>f:: (nat \<Rightarrow> real) \<Rightarrow> nat \<Rightarrow> real. \<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j f i) / real (p + 2)"
+ let ?CB = "\<lambda>f. chain_boundary (Suc p) (frag_of f)"
+ have *: "Poly_Mapping.keys
+ (simplicial_cone p (Sigp f)
+ (simplicial_subdivision p (?CB f)))
+ \<subseteq> {f. \<forall>x\<in>standard_simplex (Suc p). \<forall>y\<in>standard_simplex (Suc p).
+ \<bar>f x k - f y k\<bar> \<le> real (Suc p) / real (Suc p + 1) * d}" (is "?lhs \<subseteq> ?rhs")
+ if f: "f \<in> Poly_Mapping.keys c" for f
+ proof -
+ have ssf: "simplicial_simplex (Suc p) S f"
+ using Suc.prems(1) simplicial_chain_def that by auto
+ have 2: "\<And>x y. \<lbrakk>x \<in> standard_simplex (Suc p); y \<in> standard_simplex (Suc p)\<rbrakk> \<Longrightarrow> \<bar>f x k - f y k\<bar> \<le> d"
+ by (meson Suc.prems(2) f subsetD le_Suc_eq order_refl standard_simplex_mono)
+ have sub: "Poly_Mapping.keys ((frag_of \<circ> simplex_cone p (Sigp f)) g) \<subseteq> ?rhs"
+ if "g \<in> Poly_Mapping.keys (simplicial_subdivision p (?CB f))" for g
+ proof -
+ have 1: "simplicial_chain p S (?CB f)"
+ using ssf simplicial_chain_boundary simplicial_chain_of by fastforce
+ have "simplicial_chain (Suc p) (f ` standard_simplex(Suc p)) (frag_of f)"
+ by (metis simplicial_chain_of simplicial_simplex ssf subset_refl)
+ then have sc_sub: "Poly_Mapping.keys (?CB f)
+ \<subseteq> Collect (simplicial_simplex p (f ` standard_simplex (Suc p)))"
+ by (metis diff_Suc_1 simplicial_chain_boundary simplicial_chain_def)
+ have led: "\<And>h x y. \<lbrakk>h \<in> Poly_Mapping.keys (chain_boundary (Suc p) (frag_of f));
+ x \<in> standard_simplex p; y \<in> standard_simplex p\<rbrakk> \<Longrightarrow> \<bar>h x k - h y k\<bar> \<le> d"
+ using Suc.prems(2) f sc_sub
+ by (simp add: simplicial_simplex subset_iff image_iff) metis
+ have "\<And>f' x y. \<lbrakk>f' \<in> Poly_Mapping.keys (simplicial_subdivision p (?CB f)); x \<in> standard_simplex p; y \<in> standard_simplex p\<rbrakk>
+ \<Longrightarrow> \<bar>f' x k - f' y k\<bar> \<le> (p / (Suc p)) * d"
+ by (blast intro: led Suc.IH [of "chain_boundary (Suc p) (frag_of f)", OF 1])
+ then have g: "\<And>x y. \<lbrakk>x \<in> standard_simplex p; y \<in> standard_simplex p\<rbrakk> \<Longrightarrow> \<bar>g x k - g y k\<bar> \<le> (p / (Suc p)) * d"
+ using that by blast
+ have "d \<ge> 0"
+ using Suc.prems(2)[OF f] \<open>x \<in> standard_simplex (Suc p)\<close> by force
+ have 3: "simplex_cone p (Sigp f) g \<in> ?rhs"
+ proof -
+ have "simplicial_simplex p (f ` standard_simplex(Suc p)) g"
+ by (metis (mono_tags, hide_lams) sc_sub mem_Collect_eq simplicial_chain_def simplicial_chain_simplicial_subdivision subsetD that)
+ then obtain m where m: "g ` standard_simplex p \<subseteq> f ` standard_simplex (Suc p)"
+ and geq: "g = oriented_simplex p m"
+ using ssf by (auto simp: simplicial_simplex)
+ have m_in_gim: "\<And>i. i \<le> p \<Longrightarrow> m i \<in> g ` standard_simplex p"
+ apply (rule_tac x = "\<lambda>j. if j = i then 1 else 0" in image_eqI)
+ apply (simp_all add: geq oriented_simplex_def if_distrib cong: if_cong)
+ done
+ obtain l where l: "f ` standard_simplex (Suc p) \<subseteq> S"
+ and feq: "f = oriented_simplex (Suc p) l"
+ using ssf by (auto simp: simplicial_simplex)
+ show ?thesis
+ proof (clarsimp simp add: geq simp del: sum_atMost_Suc)
+ fix x y
+ assume x: "x \<in> standard_simplex (Suc p)" and y: "y \<in> standard_simplex (Suc p)"
+ then have x': "(\<forall>i. 0 \<le> x i \<and> x i \<le> 1) \<and> (\<forall>i>Suc p. x i = 0) \<and> (\<Sum>i\<le>Suc p. x i) = 1"
+ and y': "(\<forall>i. 0 \<le> y i \<and> y i \<le> 1) \<and> (\<forall>i>Suc p. y i = 0) \<and> (\<Sum>i\<le>Suc p. y i) = 1"
+ by (auto simp: standard_simplex_def)
+ have "\<bar>(\<Sum>j\<le>Suc p. (if j = 0 then \<lambda>i. (\<Sum>j\<le>Suc p. l j i) / (2 + real p) else m (j -1)) k * x j) -
+ (\<Sum>j\<le>Suc p. (if j = 0 then \<lambda>i. (\<Sum>j\<le>Suc p. l j i) / (2 + real p) else m (j -1)) k * y j)\<bar>
+ \<le> (1 + real p) * d / (2 + real p)"
+ proof -
+ have zero: "\<bar>m (s - Suc 0) k - (\<Sum>j\<le>Suc p. l j k) / (2 + real p)\<bar> \<le> (1 + real p) * d / (2 + real p)"
+ if "0 < s" and "s \<le> Suc p" for s
+ proof -
+ have "m (s - Suc 0) \<in> f ` standard_simplex (Suc p)"
+ using m m_in_gim that(2) by auto
+ then obtain z where eq: "m (s - Suc 0) = (\<lambda>i. \<Sum>j\<le>Suc p. l j i * z j)" and z: "z \<in> standard_simplex (Suc p)"
+ using feq unfolding oriented_simplex_def by auto
+ show ?thesis
+ unfolding eq
+ proof (rule convex_sum_bound_le)
+ fix i
+ assume i: "i \<in> {..Suc p}"
+ then have [simp]: "card ({..Suc p} - {i}) = Suc p"
+ by (simp add: card_Suc_Diff1)
+ have "(\<Sum>j\<le>Suc p. \<bar>l i k / (p + 2) - l j k / (p + 2)\<bar>) = (\<Sum>j\<le>Suc p. \<bar>l i k - l j k\<bar> / (p + 2))"
+ by (rule sum.cong) (simp_all add: flip: diff_divide_distrib)
+ also have "\<dots> = (\<Sum>j \<in> {..Suc p} - {i}. \<bar>l i k - l j k\<bar> / (p + 2))"
+ by (rule sum.mono_neutral_right) auto
+ also have "\<dots> \<le> (1 + real p) * d / (p + 2)"
+ proof (rule sum_bounded_above_divide)
+ fix i' :: "nat"
+ assume i': "i' \<in> {..Suc p} - {i}"
+ have lf: "\<And>r. r \<le> Suc p \<Longrightarrow> l r \<in> f ` standard_simplex(Suc p)"
+ apply (rule_tac x="\<lambda>j. if j = r then 1 else 0" in image_eqI)
+ apply (auto simp: feq oriented_simplex_def if_distrib [of "\<lambda>x. _ * x"] cong: if_cong)
+ done
+ show "\<bar>l i k - l i' k\<bar> / real (p + 2) \<le> (1 + real p) * d / real (p + 2) / real (card ({..Suc p} - {i}))"
+ using i i' lf [of i] lf [of i'] 2
+ by (auto simp: divide_simps image_iff)
+ qed auto
+ finally have "(\<Sum>j\<le>Suc p. \<bar>l i k / (p + 2) - l j k / (p + 2)\<bar>) \<le> (1 + real p) * d / (p + 2)" .
+ then have "\<bar>\<Sum>j\<le>Suc p. l i k / (p + 2) - l j k / (p + 2)\<bar> \<le> (1 + real p) * d / (p + 2)"
+ by (rule order_trans [OF sum_abs])
+ then show "\<bar>l i k - (\<Sum>j\<le>Suc p. l j k) / (2 + real p)\<bar> \<le> (1 + real p) * d / (2 + real p)"
+ by (simp add: sum_subtractf sum_divide_distrib del: sum_atMost_Suc)
+ qed (use standard_simplex_def z in auto)
+ qed
+ have nonz: "\<bar>m (s - Suc 0) k - m (r - Suc 0) k\<bar> \<le> (1 + real p) * d / (2 + real p)" (is "?lhs \<le> ?rhs")
+ if "r < s" and "0 < r" and "r \<le> Suc p" and "s \<le> Suc p" for r s
+ proof -
+ have "?lhs \<le> (p / (Suc p)) * d"
+ using m_in_gim [of "r - Suc 0"] m_in_gim [of "s - Suc 0"] that g by fastforce
+ also have "\<dots> \<le> ?rhs"
+ by (simp add: field_simps \<open>0 \<le> d\<close>)
+ finally show ?thesis .
+ qed
+ have jj: "j \<le> Suc p \<and> j' \<le> Suc p
+ \<longrightarrow> \<bar>(if j' = 0 then \<lambda>i. (\<Sum>j\<le>Suc p. l j i) / (2 + real p) else m (j' -1)) k -
+ (if j = 0 then \<lambda>i. (\<Sum>j\<le>Suc p. l j i) / (2 + real p) else m (j -1)) k\<bar>
+ \<le> (1 + real p) * d / (2 + real p)" for j j'
+ apply (rule_tac a=j and b = "j'" in linorder_less_wlog)
+ apply (force simp: zero nonz \<open>0 \<le> d\<close> simp del: sum_atMost_Suc)+
+ done
+ show ?thesis
+ apply (rule convex_sum_bound_le)
+ using x' apply blast
+ using x' apply blast
+ apply (subst abs_minus_commute)
+ apply (rule convex_sum_bound_le)
+ using y' apply blast
+ using y' apply blast
+ using jj by blast
+ qed
+ then show "\<bar>simplex_cone p (Sigp f) (oriented_simplex p m) x k - simplex_cone p (Sigp f) (oriented_simplex p m) y k\<bar>
+ \<le> (1 + real p) * d / (2 + real p)"
+ apply (simp add: feq Sigp_def simplicial_vertex_oriented_simplex simplex_cone del: sum_atMost_Suc)
+ apply (simp add: oriented_simplex_def x y del: sum_atMost_Suc)
+ done
+ qed
+ qed
+ show ?thesis
+ using Suc.IH [OF 1, where f=g] 2 3 by simp
+ qed
+ then show ?thesis
+ unfolding simplicial_chain_def simplicial_cone_def
+ by (simp add: order_trans [OF keys_frag_extend] sub UN_subset_iff)
+ qed
+ show ?case
+ using Suc
+ apply (simp del: sum_atMost_Suc)
+ apply (drule subsetD [OF keys_frag_extend])
+ apply (simp del: sum_atMost_Suc)
+ apply clarify (*OBTAIN?*)
+ apply (rename_tac FFF)
+ using *
+ apply (simp add: add.commute Sigp_def subset_iff)
+ done
+qed (auto simp: standard_simplex_0)
+
+
+subsection\<open>Singular subdivision\<close>
+
+definition singular_subdivision
+ where "singular_subdivision p \<equiv>
+ frag_extend
+ (\<lambda>f. chain_map p f
+ (simplicial_subdivision p
+ (frag_of(restrict id (standard_simplex p)))))"
+
+lemma singular_subdivision_0 [simp]: "singular_subdivision p 0 = 0"
+ by (simp add: singular_subdivision_def)
+
+lemma singular_subdivision_add:
+ "singular_subdivision p (a + b) = singular_subdivision p a + singular_subdivision p b"
+ by (simp add: singular_subdivision_def frag_extend_add)
+
+lemma singular_subdivision_diff:
+ "singular_subdivision p (a - b) = singular_subdivision p a - singular_subdivision p b"
+ by (simp add: singular_subdivision_def frag_extend_diff)
+
+lemma simplicial_simplex_id [simp]:
+ "simplicial_simplex p S (restrict id (standard_simplex p)) \<longleftrightarrow> standard_simplex p \<subseteq> S"
+ (is "?lhs = ?rhs")
+proof
+ assume ?lhs
+ then show ?rhs
+ by (simp add: simplicial_simplex_def singular_simplex_def continuous_map_in_subtopology set_mp)
+next
+ assume R: ?rhs
+ then have cm: "continuous_map
+ (subtopology (powertop_real UNIV) (standard_simplex p))
+ (subtopology (powertop_real UNIV) S) id"
+ using continuous_map_from_subtopology_mono continuous_map_id by blast
+ moreover have "\<exists>l. restrict id (standard_simplex p) = oriented_simplex p l"
+ apply (rule_tac x="\<lambda>i j. if i = j then 1 else 0" in exI)
+ apply (force simp: oriented_simplex_def standard_simplex_def if_distrib [of "\<lambda>u. u * _"] cong: if_cong)
+ done
+ ultimately show ?lhs
+ by (simp add: simplicial_simplex_def singular_simplex_def)
+qed
+
+lemma singular_chain_singular_subdivision:
+ "singular_chain p X c
+ \<Longrightarrow> singular_chain p X (singular_subdivision p c)"
+ unfolding singular_subdivision_def
+ apply (rule singular_chain_extend)
+ apply (rule singular_chain_chain_map [where X = "subtopology (powertop_real UNIV)
+ (standard_simplex p)"])
+ apply (simp add: simplicial_chain_simplicial_subdivision simplicial_imp_singular_chain)
+ by (simp add: singular_chain_def singular_simplex_def subset_iff)
+
+lemma naturality_singular_subdivision:
+ "singular_chain p X c
+ \<Longrightarrow> singular_subdivision p (chain_map p g c) = chain_map p g (singular_subdivision p c)"
+ unfolding singular_chain_def
+proof (induction rule: frag_induction)
+ case (one f)
+ then have "singular_simplex p X f"
+ by auto
+ have "\<lbrakk>simplicial_chain p (standard_simplex p) d\<rbrakk>
+ \<Longrightarrow> chain_map p (simplex_map p g f) d = chain_map p g (chain_map p f d)" for d
+ unfolding simplicial_chain_def
+ proof (induction rule: frag_induction)
+ case (one x)
+ then have "simplex_map p (simplex_map p g f) x = simplex_map p g (simplex_map p f x)"
+ by (force simp: simplex_map_def restrict_compose_left simplicial_simplex)
+ then show ?case
+ by auto
+ qed (auto simp: chain_map_diff)
+ then show ?case
+ using simplicial_chain_simplicial_subdivision [of p "standard_simplex p" "frag_of (restrict id (standard_simplex p))"]
+ by (simp add: singular_subdivision_def)
+next
+ case (diff a b)
+ then show ?case
+ by (simp add: chain_map_diff singular_subdivision_diff)
+qed auto
+
+lemma simplicial_chain_chain_map:
+ assumes f: "simplicial_simplex q X f" and c: "simplicial_chain p (standard_simplex q) c"
+ shows "simplicial_chain p X (chain_map p f c)"
+ using c unfolding simplicial_chain_def
+proof (induction c rule: frag_induction)
+ case (one g)
+ have "\<exists>n. simplex_map p (oriented_simplex q l)
+ (oriented_simplex p m) = oriented_simplex p n"
+ if m: "singular_simplex p
+ (subtopology (powertop_real UNIV) (standard_simplex q)) (oriented_simplex p m)"
+ for l m
+ proof -
+ have "(\<lambda>i. \<Sum>j\<le>p. m j i * x j) \<in> standard_simplex q"
+ if "x \<in> standard_simplex p" for x
+ using that m unfolding oriented_simplex_def singular_simplex_def
+ by (auto simp: continuous_map_in_subtopology image_subset_iff)
+ then show ?thesis
+ unfolding oriented_simplex_def simplex_map_def
+ apply (rule_tac x="\<lambda>j k. (\<Sum>i\<le>q. l i k * m j i)" in exI)
+ apply (force simp: sum_distrib_left sum_distrib_right mult.assoc intro: sum.swap)
+ done
+ qed
+ then show ?case
+ using f one
+ apply (auto simp: simplicial_simplex_def)
+ apply (rule singular_simplex_simplex_map
+ [where X = "subtopology (powertop_real UNIV) (standard_simplex q)"])
+ unfolding singular_simplex_def apply (fastforce simp add:)+
+ done
+next
+ case (diff a b)
+ then show ?case
+ by (metis chain_map_diff simplicial_chain_def simplicial_chain_diff)
+qed auto
+
+
+lemma singular_subdivision_simplicial_simplex:
+ "simplicial_chain p S c
+ \<Longrightarrow> singular_subdivision p c = simplicial_subdivision p c"
+proof (induction p arbitrary: S c)
+ case 0
+ then show ?case
+ unfolding simplicial_chain_def
+ proof (induction rule: frag_induction)
+ case (one x)
+ then show ?case
+ using singular_simplex_chain_map_id simplicial_imp_singular_simplex
+ by (fastforce simp: singular_subdivision_def simplicial_subdivision_def)
+ qed (auto simp: singular_subdivision_diff)
+next
+ case (Suc p)
+ show ?case
+ using Suc.prems unfolding simplicial_chain_def
+ proof (induction rule: frag_induction)
+ case (one f)
+ then have ssf: "simplicial_simplex (Suc p) S f"
+ by (auto simp: simplicial_simplex)
+ then have 1: "simplicial_chain p (standard_simplex (Suc p))
+ (simplicial_subdivision p
+ (chain_boundary (Suc p)
+ (frag_of (restrict id (standard_simplex (Suc p))))))"
+ by (metis diff_Suc_1 order_refl simplicial_chain_boundary simplicial_chain_of simplicial_chain_simplicial_subdivision simplicial_simplex_id)
+ have 2: "(\<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j (restrict id (standard_simplex (Suc p))) i) / (real p + 2))
+ \<in> standard_simplex (Suc p)"
+ by (simp add: simplicial_vertex_def standard_simplex_def del: sum_atMost_Suc)
+ have ss_Sp: "(\<lambda>i. (if i \<le> Suc p then 1 else 0) / (real p + 2)) \<in> standard_simplex (Suc p)"
+ by (simp add: standard_simplex_def divide_simps)
+ obtain l where feq: "f = oriented_simplex (Suc p) l"
+ using one unfolding simplicial_simplex by blast
+ then have 3: "f (\<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j (restrict id (standard_simplex (Suc p))) i) / (real p + 2))
+ = (\<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j f i) / (real p + 2))"
+ unfolding simplicial_vertex_def oriented_simplex_def
+ by (simp add: ss_Sp if_distrib [of "\<lambda>x. _ * x"] sum_divide_distrib del: sum_atMost_Suc cong: if_cong)
+ have scp: "singular_chain (Suc p)
+ (subtopology (powertop_real UNIV) (standard_simplex (Suc p)))
+ (frag_of (restrict id (standard_simplex (Suc p))))"
+ by (simp add: simplicial_imp_singular_chain)
+ have scps: "simplicial_chain p (standard_simplex (Suc p))
+ (chain_boundary (Suc p) (frag_of (restrict id (standard_simplex (Suc p)))))"
+ by (metis diff_Suc_1 order_refl simplicial_chain_boundary simplicial_chain_of simplicial_simplex_id)
+ have scpf: "simplicial_chain p S
+ (chain_map p f
+ (chain_boundary (Suc p) (frag_of (restrict id (standard_simplex (Suc p))))))"
+ using scps simplicial_chain_chain_map ssf by blast
+ have 4: "chain_map p f
+ (simplicial_subdivision p
+ (chain_boundary (Suc p) (frag_of (restrict id (standard_simplex (Suc p))))))
+ = simplicial_subdivision p (chain_boundary (Suc p) (frag_of f))"
+ apply (simp add: chain_boundary_chain_map [OF scp] del: chain_map_of
+ flip: singular_simplex_chain_map_id [OF simplicial_imp_singular_simplex [OF ssf]])
+ by (metis (no_types) scp singular_chain_boundary_alt Suc.IH [OF scps] Suc.IH [OF scpf] naturality_singular_subdivision)
+ show ?case
+ apply (simp add: singular_subdivision_def del: sum_atMost_Suc)
+ apply (simp only: ssf 1 2 3 4 chain_map_simplicial_cone [of "Suc p" S _ p "Suc p"])
+ done
+ qed (auto simp: frag_extend_diff singular_subdivision_diff)
+qed
+
+
+lemma naturality_simplicial_subdivision:
+ "\<lbrakk>simplicial_chain p (standard_simplex q) c; simplicial_simplex q S g\<rbrakk>
+ \<Longrightarrow> simplicial_subdivision p (chain_map p g c) = chain_map p g (simplicial_subdivision p c)"
+apply (simp flip: singular_subdivision_simplicial_simplex)
+ by (metis naturality_singular_subdivision simplicial_chain_chain_map simplicial_imp_singular_chain singular_subdivision_simplicial_simplex)
+
+lemma chain_boundary_singular_subdivision:
+ "singular_chain p X c
+ \<Longrightarrow> chain_boundary p (singular_subdivision p c) =
+ singular_subdivision (p - Suc 0) (chain_boundary p c)"
+ unfolding singular_chain_def
+proof (induction rule: frag_induction)
+ case (one f)
+ then have ssf: "singular_simplex p X f"
+ by (auto simp: singular_simplex_def)
+ then have scp: "simplicial_chain p (standard_simplex p) (frag_of (restrict id (standard_simplex p)))"
+ by simp
+ have scp1: "simplicial_chain (p - Suc 0) (standard_simplex p)
+ (chain_boundary p (frag_of (restrict id (standard_simplex p))))"
+ using simplicial_chain_boundary by force
+ have sgp1: "singular_chain (p - Suc 0)
+ (subtopology (powertop_real UNIV) (standard_simplex p))
+ (chain_boundary p (frag_of (restrict id (standard_simplex p))))"
+ using scp1 simplicial_imp_singular_chain by blast
+ have scpp: "singular_chain p (subtopology (powertop_real UNIV) (standard_simplex p))
+ (frag_of (restrict id (standard_simplex p)))"
+ using scp simplicial_imp_singular_chain by blast
+ then show ?case
+ unfolding singular_subdivision_def
+ using chain_boundary_chain_map [of p "subtopology (powertop_real UNIV)
+ (standard_simplex p)" _ f]
+ apply (simp add: simplicial_chain_simplicial_subdivision
+ simplicial_imp_singular_chain chain_boundary_simplicial_subdivision [OF scp]
+ flip: singular_subdivision_simplicial_simplex [OF scp1] naturality_singular_subdivision [OF sgp1])
+ by (metis (full_types) singular_subdivision_def chain_boundary_chain_map [OF scpp] singular_simplex_chain_map_id [OF ssf])
+qed (auto simp: singular_subdivision_def frag_extend_diff chain_boundary_diff)
+
+lemma singular_subdivision_zero:
+ "singular_chain 0 X c \<Longrightarrow> singular_subdivision 0 c = c"
+ unfolding singular_chain_def
+proof (induction rule: frag_induction)
+ case (one f)
+ then have "restrict (f \<circ> restrict id (standard_simplex 0)) (standard_simplex 0) = f"
+ by (simp add: extensional_restrict restrict_compose_right singular_simplex_def)
+ then show ?case
+ by (auto simp: singular_subdivision_def simplex_map_def)
+qed (auto simp: singular_subdivision_def frag_extend_diff)
+
+
+primrec subd where
+ "subd 0 = (\<lambda>x. 0)"
+| "subd (Suc p) =
+ frag_extend
+ (\<lambda>f. simplicial_cone (Suc p) (\<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j f i) / real (Suc p + 1))
+ (simplicial_subdivision (Suc p) (frag_of f) - frag_of f -
+ subd p (chain_boundary (Suc p) (frag_of f))))"
+
+lemma subd_0 [simp]: "subd p 0 = 0"
+ by (induction p) auto
+
+lemma subd_diff [simp]: "subd p (c1 - c2) = subd p c1 - subd p c2"
+ by (induction p) (auto simp: frag_extend_diff)
+
+lemma subd_uminus [simp]: "subd p (-c) = - subd p c"
+ by (metis diff_0 subd_0 subd_diff)
+
+lemma subd_power_uminus: "subd p (frag_cmul ((-1) ^ k) c) = frag_cmul ((-1) ^ k) (subd p c)"
+ apply (induction k, simp_all)
+ by (metis minus_frag_cmul subd_uminus)
+
+lemma subd_power_sum: "subd p (sum f I) = sum (subd p \<circ> f) I"
+ apply (induction I rule: infinite_finite_induct)
+ by auto (metis add_diff_cancel_left' diff_add_cancel subd_diff)
+
+lemma subd: "simplicial_chain p (standard_simplex s) c
+ \<Longrightarrow> (\<forall>r g. simplicial_simplex s (standard_simplex r) g \<longrightarrow> chain_map (Suc p) g (subd p c) = subd p (chain_map p g c))
+ \<and> simplicial_chain (Suc p) (standard_simplex s) (subd p c)
+ \<and> (chain_boundary (Suc p) (subd p c)) + (subd (p - Suc 0) (chain_boundary p c)) = (simplicial_subdivision p c) - c"
+proof (induction p arbitrary: c)
+ case (Suc p)
+ show ?case
+ using Suc.prems [unfolded simplicial_chain_def]
+ proof (induction rule: frag_induction)
+ case (one f)
+ then obtain l where l: "(\<lambda>x i. \<Sum>j\<le>Suc p. l j i * x j) ` standard_simplex (Suc p) \<subseteq> standard_simplex s"
+ and feq: "f = oriented_simplex (Suc p) l"
+ by (metis (mono_tags) mem_Collect_eq simplicial_simplex simplicial_simplex_oriented_simplex)
+ have scf: "simplicial_chain (Suc p) (standard_simplex s) (frag_of f)"
+ using one by simp
+ have lss: "l i \<in> standard_simplex s" if "i \<le> Suc p" for i
+ proof -
+ have "(\<lambda>i'. \<Sum>j\<le>Suc p. l j i' * (if j = i then 1 else 0)) \<in> standard_simplex s"
+ using subsetD [OF l] basis_in_standard_simplex that by blast
+ moreover have "(\<lambda>i'. \<Sum>j\<le>Suc p. l j i' * (if j = i then 1 else 0)) = l i"
+ using that by (simp add: if_distrib [of "\<lambda>x. _ * x"] del: sum_atMost_Suc cong: if_cong)
+ ultimately show ?thesis
+ by simp
+ qed
+ have *: "(\<And>i. i \<le> n \<Longrightarrow> l i \<in> standard_simplex s)
+ \<Longrightarrow> (\<lambda>i. (\<Sum>j\<le>n. l j i) / (Suc n)) \<in> standard_simplex s" for n
+ proof (induction n)
+ case (Suc n)
+ let ?x = "\<lambda>i. (1 - inverse (n + 2)) * ((\<Sum>j\<le>n. l j i) / (Suc n)) + inverse (n + 2) * l (Suc n) i"
+ have "?x \<in> standard_simplex s"
+ proof (rule convex_standard_simplex)
+ show "(\<lambda>i. (\<Sum>j\<le>n. l j i) / real (Suc n)) \<in> standard_simplex s"
+ using Suc by simp
+ qed (auto simp: lss Suc inverse_le_1_iff)
+ moreover have "?x = (\<lambda>i. (\<Sum>j\<le>Suc n. l j i) / real (Suc (Suc n)))"
+ by (force simp: divide_simps)
+ ultimately show ?case
+ by simp
+ qed auto
+ have **: "(\<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j f i) / (2 + real p)) \<in> standard_simplex s"
+ using * [of "Suc p"] lss by (simp add: simplicial_vertex_oriented_simplex feq)
+ show ?case
+ proof (intro conjI impI allI)
+ fix r g
+ assume g: "simplicial_simplex s (standard_simplex r) g"
+ then obtain m where geq: "g = oriented_simplex s m"
+ using simplicial_simplex by blast
+ have 1: "simplicial_chain (Suc p) (standard_simplex s) (simplicial_subdivision (Suc p) (frag_of f))"
+ by (metis mem_Collect_eq one.hyps simplicial_chain_of simplicial_chain_simplicial_subdivision)
+ have 2: "(\<Sum>j\<le>Suc p. \<Sum>i\<le>s. m i k * simplicial_vertex j f i)
+ = (\<Sum>j\<le>Suc p. simplicial_vertex j
+ (simplex_map (Suc p) (oriented_simplex s m) f) k)" for k
+ proof (rule sum.cong [OF refl])
+ fix j
+ assume j: "j \<in> {..Suc p}"
+ have eq: "simplex_map (Suc p) (oriented_simplex s m) (oriented_simplex (Suc p) l)
+ = oriented_simplex (Suc p) (oriented_simplex s m \<circ> l)"
+ proof (rule simplex_map_oriented_simplex)
+ show "simplicial_simplex (Suc p) (standard_simplex s) (oriented_simplex (Suc p) l)"
+ using one by (simp add: feq flip: oriented_simplex_def)
+ show "simplicial_simplex s (standard_simplex r) (oriented_simplex s m)"
+ using g by (simp add: geq)
+ qed auto
+ show "(\<Sum>i\<le>s. m i k * simplicial_vertex j f i)
+ = simplicial_vertex j (simplex_map (Suc p) (oriented_simplex s m) f) k"
+ using one j
+ apply (simp add: feq eq simplicial_vertex_oriented_simplex simplicial_simplex_oriented_simplex image_subset_iff)
+ apply (drule_tac x="(\<lambda>i. if i = j then 1 else 0)" in bspec)
+ apply (auto simp: oriented_simplex_def lss)
+ done
+ qed
+ have 4: "chain_map (Suc p) g (subd p (chain_boundary (Suc p) (frag_of f)))
+ = subd p (chain_boundary (Suc p) (frag_of (simplex_map (Suc p) g f)))"
+ by (metis (no_types) One_nat_def scf Suc.IH chain_boundary_chain_map chain_map_of diff_Suc_Suc diff_zero g simplicial_chain_boundary simplicial_imp_singular_chain)
+ show "chain_map (Suc (Suc p)) g (subd (Suc p) (frag_of f)) = subd (Suc p) (chain_map (Suc p) g (frag_of f))"
+ using g
+ apply (simp only: subd.simps frag_extend_of)
+ apply (subst chain_map_simplicial_cone [of s "standard_simplex r" _ "Suc p" s], assumption)
+ apply (intro simplicial_chain_diff)
+ using "1" apply auto[1]
+ using one.hyps apply auto[1]
+ apply (metis Suc.IH diff_Suc_1 mem_Collect_eq one.hyps simplicial_chain_boundary simplicial_chain_of)
+ using "**" apply auto[1]
+ apply (rule order_refl)
+ apply (simp only: chain_map_of frag_extend_of)
+ apply (rule arg_cong2 [where f = "simplicial_cone (Suc p)"])
+ apply (simp add: geq sum_distrib_left oriented_simplex_def ** del: sum_atMost_Suc flip: sum_divide_distrib)
+ using 2 apply (simp only: oriented_simplex_def sum.swap [where A = "{..s}"])
+ using naturality_simplicial_subdivision scf apply (fastforce simp add: 4 chain_map_diff)
+ done
+ next
+ have sc: "simplicial_chain (Suc p) (standard_simplex s)
+ (simplicial_cone p
+ (\<lambda>i. (\<Sum>j\<le>Suc p. simplicial_vertex j f i) / (Suc (Suc p)))
+ (simplicial_subdivision p
+ (chain_boundary (Suc p) (frag_of f))))"
+ by (metis diff_Suc_1 nat.simps(3) simplicial_subdivision_of scf simplicial_chain_simplicial_subdivision)
+ have ff: "simplicial_chain (Suc p) (standard_simplex s) (subd p (chain_boundary (Suc p) (frag_of f)))"
+ by (metis (no_types) Suc.IH diff_Suc_1 scf simplicial_chain_boundary)
+ show "simplicial_chain (Suc (Suc p)) (standard_simplex s) (subd (Suc p) (frag_of f))"
+ using one
+ apply (simp only: subd.simps frag_extend_of)
+ apply (rule_tac S="standard_simplex s" in simplicial_chain_simplicial_cone)
+ apply (intro simplicial_chain_diff ff)
+ using sc apply (simp add: algebra_simps)
+ using "**" convex_standard_simplex apply force+
+ done
+ have "simplicial_chain p (standard_simplex s) (chain_boundary (Suc p) (frag_of f))"
+ using scf simplicial_chain_boundary by fastforce
+ then have "chain_boundary (Suc p) (simplicial_subdivision (Suc p) (frag_of f) - frag_of f
+ - subd p (chain_boundary (Suc p) (frag_of f))) = 0"
+ apply (simp only: chain_boundary_diff)
+ using Suc.IH chain_boundary_boundary [of "Suc p" "subtopology (powertop_real UNIV)
+ (standard_simplex s)" "frag_of f"]
+ by (metis One_nat_def add_diff_cancel_left' subd_0 chain_boundary_simplicial_subdivision plus_1_eq_Suc scf simplicial_imp_singular_chain)
+ then show "chain_boundary (Suc (Suc p)) (subd (Suc p) (frag_of f))
+ + subd (Suc p - Suc 0) (chain_boundary (Suc p) (frag_of f))
+ = simplicial_subdivision (Suc p) (frag_of f) - frag_of f"
+ apply (simp only: subd.simps frag_extend_of)
+ apply (subst chain_boundary_simplicial_cone [of "Suc p" "standard_simplex s"])
+ apply (meson ff scf simplicial_chain_diff simplicial_chain_simplicial_subdivision)
+ apply (simp add: simplicial_cone_def del: sum_atMost_Suc simplicial_subdivision.simps)
+ done
+ qed
+ next
+ case (diff a b)
+ then show ?case
+ apply safe
+ apply (metis chain_map_diff subd_diff)
+ apply (metis simplicial_chain_diff subd_diff)
+ apply (auto simp: simplicial_subdivision_diff chain_boundary_diff
+ simp del: simplicial_subdivision.simps subd.simps)
+ by (metis (no_types, lifting) add_diff_add add_uminus_conv_diff diff_0 diff_diff_add)
+ qed auto
+qed simp
+
+lemma chain_homotopic_simplicial_subdivision1:
+ "\<lbrakk>simplicial_chain p (standard_simplex q) c; simplicial_simplex q (standard_simplex r) g\<rbrakk>
+ \<Longrightarrow> chain_map (Suc p) g (subd p c) = subd p (chain_map p g c)"
+ by (simp add: subd)
+
+lemma chain_homotopic_simplicial_subdivision2:
+ "simplicial_chain p (standard_simplex q) c
+ \<Longrightarrow> simplicial_chain (Suc p) (standard_simplex q) (subd p c)"
+ by (simp add: subd)
+
+lemma chain_homotopic_simplicial_subdivision3:
+ "simplicial_chain p (standard_simplex q) c
+ \<Longrightarrow> chain_boundary (Suc p) (subd p c) = (simplicial_subdivision p c) - c - subd (p - Suc 0) (chain_boundary p c)"
+ by (simp add: subd algebra_simps)
+
+lemma chain_homotopic_simplicial_subdivision:
+ "\<exists>h. (\<forall>p. h p 0 = 0) \<and>
+ (\<forall>p c1 c2. h p (c1-c2) = h p c1 - h p c2) \<and>
+ (\<forall>p q r g c.
+ simplicial_chain p (standard_simplex q) c
+ \<longrightarrow> simplicial_simplex q (standard_simplex r) g
+ \<longrightarrow> chain_map (Suc p) g (h p c) = h p (chain_map p g c)) \<and>
+ (\<forall>p q c. simplicial_chain p (standard_simplex q) c
+ \<longrightarrow> simplicial_chain (Suc p) (standard_simplex q) (h p c)) \<and>
+ (\<forall>p q c. simplicial_chain p (standard_simplex q) c
+ \<longrightarrow> chain_boundary (Suc p) (h p c) + h (p - Suc 0) (chain_boundary p c)
+ = (simplicial_subdivision p c) - c)"
+ by (rule_tac x=subd in exI) (fastforce simp: subd)
+
+lemma chain_homotopic_singular_subdivision:
+ obtains h where
+ "\<And>p. h p 0 = 0"
+ "\<And>p c1 c2. h p (c1-c2) = h p c1 - h p c2"
+ "\<And>p X c. singular_chain p X c \<Longrightarrow> singular_chain (Suc p) X (h p c)"
+ "\<And>p X c. singular_chain p X c
+ \<Longrightarrow> chain_boundary (Suc p) (h p c) + h (p - Suc 0) (chain_boundary p c) = singular_subdivision p c - c"
+proof -
+ define k where "k \<equiv> \<lambda>p. frag_extend (\<lambda>f:: (nat \<Rightarrow> real) \<Rightarrow> 'a. chain_map (Suc p) f (subd p (frag_of(restrict id (standard_simplex p)))))"
+ show ?thesis
+ proof
+ fix p X and c :: "'a chain"
+ assume c: "singular_chain p X c"
+ have "singular_chain (Suc p) X (k p c) \<and>
+ chain_boundary (Suc p) (k p c) + k (p - Suc 0) (chain_boundary p c) = singular_subdivision p c - c"
+ using c [unfolded singular_chain_def]
+ proof (induction rule: frag_induction)
+ case (one f)
+ let ?X = "subtopology (powertop_real UNIV) (standard_simplex p)"
+ show ?case
+ proof (simp add: k_def, intro conjI)
+ show "singular_chain (Suc p) X (chain_map (Suc p) f (subd p (frag_of (restrict id (standard_simplex p)))))"
+ proof (rule singular_chain_chain_map)
+ show "singular_chain (Suc p) ?X (subd p (frag_of (restrict id (standard_simplex p))))"
+ by (simp add: chain_homotopic_simplicial_subdivision2 simplicial_imp_singular_chain)
+ show "continuous_map ?X X f"
+ using one.hyps singular_simplex_def by auto
+ qed
+ next
+ have scp: "singular_chain (Suc p) ?X (subd p (frag_of (restrict id (standard_simplex p))))"
+ by (simp add: chain_homotopic_simplicial_subdivision2 simplicial_imp_singular_chain)
+ have feqf: "frag_of (simplex_map p f (restrict id (standard_simplex p))) = frag_of f"
+ using one.hyps singular_simplex_chain_map_id by auto
+ have *: "chain_map p f
+ (subd (p - Suc 0)
+ (\<Sum>k\<le>p. frag_cmul ((-1) ^ k) (frag_of (singular_face p k id))))
+ = (\<Sum>x\<le>p. frag_cmul ((-1) ^ x)
+ (chain_map p (singular_face p x f)
+ (subd (p - Suc 0) (frag_of (restrict id (standard_simplex (p - Suc 0)))))))"
+ (is "?lhs = ?rhs")
+ if "p > 0"
+ proof -
+ have eqc: "subd (p - Suc 0) (frag_of (singular_face p i id))
+ = chain_map p (singular_face p i id)
+ (subd (p - Suc 0) (frag_of (restrict id (standard_simplex (p - Suc 0)))))"
+ if "i \<le> p" for i
+ proof -
+ have 1: "simplicial_chain (p - Suc 0) (standard_simplex (p - Suc 0))
+ (frag_of (restrict id (standard_simplex (p - Suc 0))))"
+ by simp
+ have 2: "simplicial_simplex (p - Suc 0) (standard_simplex p) (singular_face p i id)"
+ by (metis One_nat_def Suc_leI \<open>0 < p\<close> simplicial_simplex_id simplicial_simplex_singular_face singular_face_restrict subsetI that)
+ have 3: "simplex_map (p - Suc 0) (singular_face p i id) (restrict id (standard_simplex (p - Suc 0)))
+ = singular_face p i id"
+ by (force simp: simplex_map_def singular_face_def)
+ show ?thesis
+ using chain_homotopic_simplicial_subdivision1 [OF 1 2]
+ that \<open>p > 0\<close> by (simp add: 3)
+ qed
+ have xx: "simplicial_chain p (standard_simplex(p - Suc 0))
+ (subd (p - Suc 0) (frag_of (restrict id (standard_simplex (p - Suc 0)))))"
+ by (metis Suc_pred chain_homotopic_simplicial_subdivision2 order_refl simplicial_chain_of simplicial_simplex_id that)
+ have yy: "\<And>k. k \<le> p \<Longrightarrow>
+ chain_map p f
+ (chain_map p (singular_face p k id) h) = chain_map p (singular_face p k f) h"
+ if "simplicial_chain p (standard_simplex(p - Suc 0)) h" for h
+ using that unfolding simplicial_chain_def
+ proof (induction h rule: frag_induction)
+ case (one x)
+ then show ?case
+ using one
+ apply (simp add: chain_map_of singular_simplex_def simplicial_simplex_def, auto)
+ apply (rule_tac f=frag_of in arg_cong, rule)
+ apply (simp add: simplex_map_def)
+ by (simp add: continuous_map_in_subtopology image_subset_iff singular_face_def)
+ qed (auto simp: chain_map_diff)
+ have "?lhs
+ = chain_map p f
+ (\<Sum>k\<le>p. frag_cmul ((-1) ^ k)
+ (chain_map p (singular_face p k id)
+ (subd (p - Suc 0) (frag_of (restrict id (standard_simplex (p - Suc 0)))))))"
+ by (simp add: subd_power_sum subd_power_uminus eqc)
+ also have "\<dots> = ?rhs"
+ by (simp add: chain_map_sum xx yy)
+ finally show ?thesis .
+ qed
+ have "chain_map p f
+ (simplicial_subdivision p (frag_of (restrict id (standard_simplex p)))
+ - subd (p - Suc 0) (chain_boundary p (frag_of (restrict id (standard_simplex p)))))
+ = singular_subdivision p (frag_of f)
+ - frag_extend
+ (\<lambda>f. chain_map (Suc (p - Suc 0)) f
+ (subd (p - Suc 0) (frag_of (restrict id (standard_simplex (p - Suc 0))))))
+ (chain_boundary p (frag_of f))"
+ apply (simp add: singular_subdivision_def chain_map_diff)
+ apply (clarsimp simp add: chain_boundary_def)
+ apply (simp add: frag_extend_sum frag_extend_cmul *)
+ done
+ then show "chain_boundary (Suc p) (chain_map (Suc p) f (subd p (frag_of (restrict id (standard_simplex p)))))
+ + frag_extend
+ (\<lambda>f. chain_map (Suc (p - Suc 0)) f
+ (subd (p - Suc 0) (frag_of (restrict id (standard_simplex (p - Suc 0))))))
+ (chain_boundary p (frag_of f))
+ = singular_subdivision p (frag_of f) - frag_of f"
+ by (simp add: chain_boundary_chain_map [OF scp] chain_homotopic_simplicial_subdivision3 [where q=p] chain_map_diff feqf)
+ qed
+ next
+ case (diff a b)
+ then show ?case
+ apply (simp only: k_def singular_chain_diff chain_boundary_diff frag_extend_diff singular_subdivision_diff)
+ by (metis (no_types, lifting) add_diff_add diff_add_cancel)
+ qed (auto simp: k_def)
+ then show "singular_chain (Suc p) X (k p c)" "chain_boundary (Suc p) (k p c) + k (p - Suc 0) (chain_boundary p c) = singular_subdivision p c - c"
+ by auto
+ qed (auto simp: k_def frag_extend_diff)
+qed
+
+
+lemma homologous_rel_singular_subdivision:
+ assumes "singular_relcycle p X T c"
+ shows "homologous_rel p X T (singular_subdivision p c) c"
+proof (cases "p = 0")
+ case True
+ with assms show ?thesis
+ by (auto simp: singular_relcycle_def singular_subdivision_zero)
+next
+ case False
+ with assms show ?thesis
+ unfolding homologous_rel_def singular_relboundary singular_relcycle
+ by (metis One_nat_def Suc_diff_1 chain_homotopic_singular_subdivision gr_zeroI)
+qed
+
+
+subsection\<open>Excision argument that we keep doing singular subdivision\<close>
+
+lemma singular_subdivision_power_0 [simp]: "(singular_subdivision p ^^ n) 0 = 0"
+ by (induction n) auto
+
+lemma singular_subdivision_power_diff:
+ "(singular_subdivision p ^^ n) (a - b) = (singular_subdivision p ^^ n) a - (singular_subdivision p ^^ n) b"
+ by (induction n) (auto simp: singular_subdivision_diff)
+
+lemma iterated_singular_subdivision:
+ "singular_chain p X c
+ \<Longrightarrow> (singular_subdivision p ^^ n) c =
+ frag_extend
+ (\<lambda>f. chain_map p f
+ ((simplicial_subdivision p ^^ n)
+ (frag_of(restrict id (standard_simplex p))))) c"
+proof (induction n arbitrary: c)
+ case 0
+ then show ?case
+ unfolding singular_chain_def
+ proof (induction c rule: frag_induction)
+ case (one f)
+ then have "restrict f (standard_simplex p) = f"
+ by (simp add: extensional_restrict singular_simplex_def)
+ then show ?case
+ by (auto simp: simplex_map_def cong: restrict_cong)
+ qed (auto simp: frag_extend_diff)
+next
+ case (Suc n)
+ show ?case
+ using Suc.prems unfolding singular_chain_def
+ proof (induction c rule: frag_induction)
+ case (one f)
+ then have "singular_simplex p X f"
+ by simp
+ have scp: "simplicial_chain p (standard_simplex p)
+ ((simplicial_subdivision p ^^ n) (frag_of (restrict id (standard_simplex p))))"
+ proof (induction n)
+ case 0
+ then show ?case
+ by (metis funpow_0 order_refl simplicial_chain_of simplicial_simplex_id)
+ next
+ case (Suc n)
+ then show ?case
+ by (simp add: simplicial_chain_simplicial_subdivision)
+ qed
+ have scnp: "simplicial_chain p (standard_simplex p)
+ ((simplicial_subdivision p ^^ n) (frag_of (\<lambda>x\<in>standard_simplex p. x)))"
+ proof (induction n)
+ case 0
+ then show ?case
+ by (metis eq_id_iff funpow_0 order_refl simplicial_chain_of simplicial_simplex_id)
+ next
+ case (Suc n)
+ then show ?case
+ by (simp add: simplicial_chain_simplicial_subdivision)
+ qed
+ have sff: "singular_chain p X (frag_of f)"
+ by (simp add: \<open>singular_simplex p X f\<close> singular_chain_of)
+ then show ?case
+ using Suc.IH [OF sff] naturality_singular_subdivision [OF simplicial_imp_singular_chain [OF scp], of f] singular_subdivision_simplicial_simplex [OF scnp]
+ by (simp add: singular_chain_of id_def del: restrict_apply)
+ qed (auto simp: singular_subdivision_power_diff singular_subdivision_diff frag_extend_diff)
+qed
+
+
+lemma chain_homotopic_iterated_singular_subdivision:
+ obtains h where
+ "\<And>p. h p 0 = (0 :: 'a chain)"
+ "\<And>p c1 c2. h p (c1-c2) = h p c1 - h p c2"
+ "\<And>p X c. singular_chain p X c \<Longrightarrow> singular_chain (Suc p) X (h p c)"
+ "\<And>p X c. singular_chain p X c
+ \<Longrightarrow> chain_boundary (Suc p) (h p c) + h (p - Suc 0) (chain_boundary p c)
+ = (singular_subdivision p ^^ n) c - c"
+proof (induction n arbitrary: thesis)
+ case 0
+ show ?case
+ by (rule 0 [of "(\<lambda>p x. 0)"]) auto
+next
+ case (Suc n)
+ then obtain k where k:
+ "\<And>p. k p 0 = (0 :: 'a chain)"
+ "\<And>p c1 c2. k p (c1-c2) = k p c1 - k p c2"
+ "\<And>p X c. singular_chain p X c \<Longrightarrow> singular_chain (Suc p) X (k p c)"
+ "\<And>p X c. singular_chain p X c
+ \<Longrightarrow> chain_boundary (Suc p) (k p c) + k (p - Suc 0) (chain_boundary p c)
+ = (singular_subdivision p ^^ n) c - c"
+ by metis
+ obtain h where h:
+ "\<And>p. h p 0 = (0 :: 'a chain)"
+ "\<And>p c1 c2. h p (c1-c2) = h p c1 - h p c2"
+ "\<And>p X c. singular_chain p X c \<Longrightarrow> singular_chain (Suc p) X (h p c)"
+ "\<And>p X c. singular_chain p X c
+ \<Longrightarrow> chain_boundary (Suc p) (h p c) + h (p - Suc 0) (chain_boundary p c) = singular_subdivision p c - c"
+ by (blast intro: chain_homotopic_singular_subdivision)
+ let ?h = "(\<lambda>p c. singular_subdivision (Suc p) (k p c) + h p c)"
+ show ?case
+ proof (rule Suc.prems)
+ fix p X and c :: "'a chain"
+ assume "singular_chain p X c"
+ then show "singular_chain (Suc p) X (?h p c)"
+ by (simp add: h k singular_chain_add singular_chain_singular_subdivision)
+ next
+ fix p :: "nat" and X :: "'a topology" and c :: "'a chain"
+ assume sc: "singular_chain p X c"
+ have f5: "chain_boundary (Suc p) (singular_subdivision (Suc p) (k p c)) = singular_subdivision p (chain_boundary (Suc p) (k p c))"
+ using chain_boundary_singular_subdivision k(3) sc by fastforce
+ have [simp]: "singular_subdivision (Suc (p - Suc 0)) (k (p - Suc 0) (chain_boundary p c)) =
+ singular_subdivision p (k (p - Suc 0) (chain_boundary p c))"
+ proof (cases p)
+ case 0
+ then show ?thesis
+ by (simp add: k chain_boundary_def)
+ qed auto
+ show "chain_boundary (Suc p) (?h p c) + ?h (p - Suc 0) (chain_boundary p c) = (singular_subdivision p ^^ Suc n) c - c"
+ using chain_boundary_singular_subdivision [of "Suc p" X]
+ apply (simp add: chain_boundary_add f5 h k algebra_simps)
+ apply (erule thin_rl)
+ using h(4) [OF sc] k(4) [OF sc] singular_subdivision_add [of p "chain_boundary (Suc p) (k p c)" "k (p - Suc 0) (chain_boundary p c)"]
+ apply (simp add: algebra_simps)
+ by (smt add.assoc add.left_commute singular_subdivision_add)
+ qed (auto simp: k h singular_subdivision_diff)
+qed
+
+lemma llemma:
+ assumes p: "standard_simplex p \<subseteq> \<Union>\<C>"
+ and \<C>: "\<And>U. U \<in> \<C> \<Longrightarrow> openin (powertop_real UNIV) U"
+ obtains d where "0 < d"
+ "\<And>K. \<lbrakk>K \<subseteq> standard_simplex p;
+ \<And>x y i. \<lbrakk>i \<le> p; x \<in> K; y \<in> K\<rbrakk> \<Longrightarrow> \<bar>x i - y i\<bar> \<le> d\<rbrakk>
+ \<Longrightarrow> \<exists>U. U \<in> \<C> \<and> K \<subseteq> U"
+proof -
+ have "\<exists>e U. 0 < e \<and> U \<in> \<C> \<and> x \<in> U \<and>
+ (\<forall>y. (\<forall>i\<le>p. \<bar>y i - x i\<bar> \<le> 2 * e) \<and> (\<forall>i>p. y i = 0) \<longrightarrow> y \<in> U)"
+ if x: "x \<in> standard_simplex p" for x
+ proof-
+ obtain U where U: "U \<in> \<C>" "x \<in> U"
+ using x p by blast
+ then obtain V where finV: "finite {i. V i \<noteq> UNIV}" and openV: "\<And>i. open (V i)"
+ and xV: "x \<in> Pi\<^sub>E UNIV V" and UV: "Pi\<^sub>E UNIV V \<subseteq> U"
+ using \<C> unfolding openin_product_topology_alt by force
+ have xVi: "x i \<in> V i" for i
+ using PiE_mem [OF xV] by simp
+ have "\<And>i. \<exists>e>0. \<forall>x'. \<bar>x' - x i\<bar> < e \<longrightarrow> x' \<in> V i"
+ by (rule openV [unfolded open_real, rule_format, OF xVi])
+ then obtain d where d: "\<And>i. d i > 0" and dV: "\<And>i x'. \<bar>x' - x i\<bar> < d i \<Longrightarrow> x' \<in> V i"
+ by metis
+ define e where "e \<equiv> Inf (insert 1 (d ` {i. V i \<noteq> UNIV})) / 3"
+ have ed3: "e \<le> d i / 3" if "V i \<noteq> UNIV" for i
+ using that finV by (auto simp: e_def intro: cInf_le_finite)
+ show "\<exists>e U. 0 < e \<and> U \<in> \<C> \<and> x \<in> U \<and>
+ (\<forall>y. (\<forall>i\<le>p. \<bar>y i - x i\<bar> \<le> 2 * e) \<and> (\<forall>i>p. y i = 0) \<longrightarrow> y \<in> U)"
+ proof (intro exI conjI allI impI)
+ show "e > 0"
+ using d finV by (simp add: e_def finite_less_Inf_iff)
+ fix y assume y: "(\<forall>i\<le>p. \<bar>y i - x i\<bar> \<le> 2 * e) \<and> (\<forall>i>p. y i = 0)"
+ have "y \<in> Pi\<^sub>E UNIV V"
+ proof
+ show "y i \<in> V i" for i
+ proof (cases "p < i")
+ case True
+ then show ?thesis
+ by (metis (mono_tags, lifting) y x mem_Collect_eq standard_simplex_def xVi)
+ next
+ case False show ?thesis
+ proof (cases "V i = UNIV")
+ case False show ?thesis
+ proof (rule dV)
+ have "\<bar>y i - x i\<bar> \<le> 2 * e"
+ using y \<open>\<not> p < i\<close> by simp
+ also have "\<dots> < d i"
+ using ed3 [OF False] \<open>e > 0\<close> by simp
+ finally show "\<bar>y i - x i\<bar> < d i" .
+ qed
+ qed auto
+ qed
+ qed auto
+ with UV show "y \<in> U"
+ by blast
+ qed (use U in auto)
+ qed
+ then obtain e U where
+ eU: "\<And>x. x \<in> standard_simplex p \<Longrightarrow>
+ 0 < e x \<and> U x \<in> \<C> \<and> x \<in> U x"
+ and UI: "\<And>x y. \<lbrakk>x \<in> standard_simplex p; \<And>i. i \<le> p \<Longrightarrow> \<bar>y i - x i\<bar> \<le> 2 * e x; \<And>i. i > p \<Longrightarrow> y i = 0\<rbrakk>
+ \<Longrightarrow> y \<in> U x"
+ by metis
+ define F where "F \<equiv> \<lambda>x. Pi\<^sub>E UNIV (\<lambda>i. if i \<le> p then {x i - e x<..<x i + e x} else UNIV)"
+ have "\<forall>S \<in> F ` standard_simplex p. openin (powertop_real UNIV) S"
+ by (simp add: F_def openin_PiE_gen)
+ moreover have pF: "standard_simplex p \<subseteq> \<Union>(F ` standard_simplex p)"
+ by (force simp: F_def PiE_iff eU)
+ ultimately have "\<exists>\<F>. finite \<F> \<and> \<F> \<subseteq> F ` standard_simplex p \<and> standard_simplex p \<subseteq> \<Union>\<F>"
+ using compactin_standard_simplex [of p]
+ unfolding compactin_def by force
+ then obtain S where "finite S" and ssp: "S \<subseteq> standard_simplex p" "standard_simplex p \<subseteq> \<Union>(F ` S)"
+ unfolding exists_finite_subset_image by (auto simp: exists_finite_subset_image)
+ then have "S \<noteq> {}"
+ by (auto simp: nonempty_standard_simplex)
+ show ?thesis
+ proof
+ show "Inf (e ` S) > 0"
+ using \<open>finite S\<close> \<open>S \<noteq> {}\<close> ssp eU by (auto simp: finite_less_Inf_iff)
+ fix k :: "(nat \<Rightarrow> real) set"
+ assume k: "k \<subseteq> standard_simplex p"
+ and kle: "\<And>x y i. \<lbrakk>i \<le> p; x \<in> k; y \<in> k\<rbrakk> \<Longrightarrow> \<bar>x i - y i\<bar> \<le> Inf (e ` S)"
+ show "\<exists>U. U \<in> \<C> \<and> k \<subseteq> U"
+ proof (cases "k = {}")
+ case True
+ then show ?thesis
+ using \<open>S \<noteq> {}\<close> eU equals0I ssp(1) subset_eq p by auto
+ next
+ case False
+ with k ssp obtain x a where "x \<in> k" "x \<in> standard_simplex p"
+ and a: "a \<in> S" and Fa: "x \<in> F a"
+ by blast
+ then have le_ea: "\<And>i. i \<le> p \<Longrightarrow> abs (x i - a i) < e a"
+ by (simp add: F_def PiE_iff if_distrib abs_diff_less_iff cong: if_cong)
+ show ?thesis
+ proof (intro exI conjI)
+ show "U a \<in> \<C>"
+ using a eU ssp(1) by auto
+ show "k \<subseteq> U a"
+ proof clarify
+ fix y assume "y \<in> k"
+ with k have y: "y \<in> standard_simplex p"
+ by blast
+ show "y \<in> U a"
+ proof (rule UI)
+ show "a \<in> standard_simplex p"
+ using a ssp(1) by auto
+ fix i :: "nat"
+ assume "i \<le> p"
+ then have "\<bar>x i - y i\<bar> \<le> e a"
+ by (meson kle [OF \<open>i \<le> p\<close>] a \<open>finite S\<close> \<open>x \<in> k\<close> \<open>y \<in> k\<close> cInf_le_finite finite_imageI imageI order_trans)
+ then show "\<bar>y i - a i\<bar> \<le> 2 * e a"
+ using le_ea [OF \<open>i \<le> p\<close>] by linarith
+ next
+ fix i assume "p < i"
+ then show "y i = 0"
+ using standard_simplex_def y by auto
+ qed
+ qed
+ qed
+ qed
+ qed
+qed
+
+
+proposition sufficient_iterated_singular_subdivision_exists:
+ assumes \<C>: "\<And>U. U \<in> \<C> \<Longrightarrow> openin X U"
+ and X: "topspace X \<subseteq> \<Union>\<C>"
+ and p: "singular_chain p X c"
+ obtains n where "\<And>m f. \<lbrakk>n \<le> m; f \<in> Poly_Mapping.keys ((singular_subdivision p ^^ m) c)\<rbrakk>
+ \<Longrightarrow> \<exists>V \<in> \<C>. f ` (standard_simplex p) \<subseteq> V"
+proof (cases "c = 0")
+ case False
+ then show ?thesis
+ proof (cases "topspace X = {}")
+ case True
+ show ?thesis
+ using p that by (force simp: singular_chain_empty True)
+ next
+ case False
+ show ?thesis
+ proof (cases "\<C> = {}")
+ case True
+ then show ?thesis
+ using False X by blast
+ next
+ case False
+ have "\<exists>e. 0 < e \<and>
+ (\<forall>K. K \<subseteq> standard_simplex p \<longrightarrow> (\<forall>x y i. x \<in> K \<and> y \<in> K \<and> i \<le> p \<longrightarrow> \<bar>x i - y i\<bar> \<le> e)
+ \<longrightarrow> (\<exists>V. V \<in> \<C> \<and> f ` K \<subseteq> V))"
+ if f: "f \<in> Poly_Mapping.keys c" for f
+ proof -
+ have ssf: "singular_simplex p X f"
+ using f p by (auto simp: singular_chain_def)
+ then have fp: "\<And>x. x \<in> standard_simplex p \<Longrightarrow> f x \<in> topspace X"
+ by (auto simp: singular_simplex_def image_subset_iff dest: continuous_map_image_subset_topspace)
+ have "\<exists>T. openin (powertop_real UNIV) T \<and>
+ standard_simplex p \<inter> f -` V = T \<inter> standard_simplex p"
+ if V: "V \<in> \<C>" for V
+ proof -
+ have "singular_simplex p X f"
+ using p f unfolding singular_chain_def by blast
+ then have "openin (subtopology (powertop_real UNIV) (standard_simplex p))
+ {x \<in> standard_simplex p. f x \<in> V}"
+ using \<C> [OF \<open>V \<in> \<C>\<close>] by (simp add: singular_simplex_def continuous_map_def)
+ moreover have "standard_simplex p \<inter> f -` V = {x \<in> standard_simplex p. f x \<in> V}"
+ by blast
+ ultimately show ?thesis
+ by (simp add: openin_subtopology)
+ qed
+ then obtain g where gope: "\<And>V. V \<in> \<C> \<Longrightarrow> openin (powertop_real UNIV) (g V)"
+ and geq: "\<And>V. V \<in> \<C> \<Longrightarrow> standard_simplex p \<inter> f -` V = g V \<inter> standard_simplex p"
+ by metis
+ obtain d where "0 < d"
+ and d: "\<And>K. \<lbrakk>K \<subseteq> standard_simplex p; \<And>x y i. \<lbrakk>i \<le> p; x \<in> K; y \<in> K\<rbrakk> \<Longrightarrow> \<bar>x i - y i\<bar> \<le> d\<rbrakk>
+ \<Longrightarrow> \<exists>U. U \<in> g ` \<C> \<and> K \<subseteq> U"
+ proof (rule llemma [of p "g ` \<C>"])
+ show "standard_simplex p \<subseteq> \<Union>(g ` \<C>)"
+ using geq X fp by (fastforce simp add:)
+ show "openin (powertop_real UNIV) U" if "U \<in> g ` \<C>" for U :: "(nat \<Rightarrow> real) set"
+ using gope that by blast
+ qed auto
+ show ?thesis
+ proof (rule exI, intro allI conjI impI)
+ fix K :: "(nat \<Rightarrow> real) set"
+ assume K: "K \<subseteq> standard_simplex p"
+ and Kd: "\<forall>x y i. x \<in> K \<and> y \<in> K \<and> i \<le> p \<longrightarrow> \<bar>x i - y i\<bar> \<le> d"
+ then have "\<exists>U. U \<in> g ` \<C> \<and> K \<subseteq> U"
+ using d [OF K] by auto
+ then show "\<exists>V. V \<in> \<C> \<and> f ` K \<subseteq> V"
+ using K geq by fastforce
+ qed (rule \<open>d > 0\<close>)
+ qed
+ then obtain \<psi> where epos: "\<forall>f \<in> Poly_Mapping.keys c. 0 < \<psi> f"
+ and e: "\<And>f K. \<lbrakk>f \<in> Poly_Mapping.keys c; K \<subseteq> standard_simplex p;
+ \<And>x y i. x \<in> K \<and> y \<in> K \<and> i \<le> p \<Longrightarrow> \<bar>x i - y i\<bar> \<le> \<psi> f\<rbrakk>
+ \<Longrightarrow> \<exists>V. V \<in> \<C> \<and> f ` K \<subseteq> V"
+ by metis
+ obtain d where "0 < d"
+ and d: "\<And>f K. \<lbrakk>f \<in> Poly_Mapping.keys c; K \<subseteq> standard_simplex p;
+ \<And>x y i. \<lbrakk>x \<in> K; y \<in> K; i \<le> p\<rbrakk> \<Longrightarrow> \<bar>x i - y i\<bar> \<le> d\<rbrakk>
+ \<Longrightarrow> \<exists>V. V \<in> \<C> \<and> f ` K \<subseteq> V"
+ proof
+ show "Inf (\<psi> ` Poly_Mapping.keys c) > 0"
+ by (simp add: finite_less_Inf_iff \<open>c \<noteq> 0\<close> epos)
+ fix f K
+ assume fK: "f \<in> Poly_Mapping.keys c" "K \<subseteq> standard_simplex p"
+ and le: "\<And>x y i. \<lbrakk>x \<in> K; y \<in> K; i \<le> p\<rbrakk> \<Longrightarrow> \<bar>x i - y i\<bar> \<le> Inf (\<psi> ` Poly_Mapping.keys c)"
+ then have lef: "Inf (\<psi> ` Poly_Mapping.keys c) \<le> \<psi> f"
+ by (auto intro: cInf_le_finite)
+ show "\<exists>V. V \<in> \<C> \<and> f ` K \<subseteq> V"
+ using le lef by (blast intro: dual_order.trans e [OF fK])
+ qed
+ let ?d = "\<lambda>m. (simplicial_subdivision p ^^ m) (frag_of (restrict id (standard_simplex p)))"
+ obtain n where n: "(p / (Suc p)) ^ n < d"
+ using real_arch_pow_inv \<open>0 < d\<close> by fastforce
+ show ?thesis
+ proof
+ fix m h
+ assume "n \<le> m" and "h \<in> Poly_Mapping.keys ((singular_subdivision p ^^ m) c)"
+ then obtain f where "f \<in> Poly_Mapping.keys c" "h \<in> Poly_Mapping.keys (chain_map p f (?d m))"
+ using subsetD [OF keys_frag_extend] iterated_singular_subdivision [OF p, of m] by force
+ then obtain g where g: "g \<in> Poly_Mapping.keys (?d m)" and heq: "h = restrict (f \<circ> g) (standard_simplex p)"
+ using keys_frag_extend by (force simp: chain_map_def simplex_map_def)
+ have xx: "simplicial_chain p (standard_simplex p) (?d n) \<and>
+ (\<forall>f \<in> Poly_Mapping.keys(?d n). \<forall>x \<in> standard_simplex p. \<forall>y \<in> standard_simplex p.
+ \<bar>f x i - f y i\<bar> \<le> (p / (Suc p)) ^ n)"
+ for n i
+ proof (induction n)
+ case 0
+ have "simplicial_simplex p (standard_simplex p) (\<lambda>a\<in>standard_simplex p. a)"
+ by (metis eq_id_iff order_refl simplicial_simplex_id)
+ moreover have "(\<forall>x\<in>standard_simplex p. \<forall>y\<in>standard_simplex p. \<bar>x i - y i\<bar> \<le> 1)"
+ unfolding standard_simplex_def
+ by (auto simp: abs_if dest!: spec [where x=i])
+ ultimately show ?case
+ unfolding power_0 funpow_0 by simp
+ next
+ case (Suc n)
+ show ?case
+ unfolding power_Suc funpow.simps o_def
+ proof (intro conjI ballI)
+ show "simplicial_chain p (standard_simplex p) (simplicial_subdivision p (?d n))"
+ by (simp add: Suc simplicial_chain_simplicial_subdivision)
+ show "\<bar>f x i - f y i\<bar> \<le> real p / real (Suc p) * (real p / real (Suc p)) ^ n"
+ if "f \<in> Poly_Mapping.keys (simplicial_subdivision p (?d n))"
+ and "x \<in> standard_simplex p" and "y \<in> standard_simplex p" for f x y
+ using Suc that by (blast intro: simplicial_subdivision_shrinks)
+ qed
+ qed
+ have "g ` standard_simplex p \<subseteq> standard_simplex p"
+ using g xx [of m] unfolding simplicial_chain_def simplicial_simplex by auto
+ moreover
+ have "\<bar>g x i - g y i\<bar> \<le> d" if "i \<le> p" "x \<in> standard_simplex p" "y \<in> standard_simplex p" for x y i
+ proof -
+ have "\<bar>g x i - g y i\<bar> \<le> (p / (Suc p)) ^ m"
+ using g xx [of m] that by blast
+ also have "\<dots> \<le> (p / (Suc p)) ^ n"
+ by (auto intro: power_decreasing [OF \<open>n \<le> m\<close>])
+ finally show ?thesis using n by simp
+ qed
+ then have "\<bar>x i - y i\<bar> \<le> d"
+ if "x \<in> g ` (standard_simplex p)" "y \<in> g ` (standard_simplex p)" "i \<le> p" for i x y
+ using that by blast
+ ultimately show "\<exists>V\<in>\<C>. h ` standard_simplex p \<subseteq> V"
+ using \<open>f \<in> Poly_Mapping.keys c\<close> d [of f "g ` standard_simplex p"]
+ by (simp add: Bex_def heq image_image)
+ qed
+ qed
+ qed
+qed force
+
+
+lemma small_homologous_rel_relcycle_exists:
+ assumes \<C>: "\<And>U. U \<in> \<C> \<Longrightarrow> openin X U"
+ and X: "topspace X \<subseteq> \<Union>\<C>"
+ and p: "singular_relcycle p X S c"
+ obtains c' where "singular_relcycle p X S c'" "homologous_rel p X S c c'"
+ "\<And>f. f \<in> Poly_Mapping.keys c' \<Longrightarrow> \<exists>V \<in> \<C>. f ` (standard_simplex p) \<subseteq> V"
+proof -
+ have "singular_chain p X c"
+ "(chain_boundary p c, 0) \<in> (mod_subset (p - Suc 0) (subtopology X S))"
+ using p unfolding singular_relcycle_def by auto
+ then obtain n where n: "\<And>m f. \<lbrakk>n \<le> m; f \<in> Poly_Mapping.keys ((singular_subdivision p ^^ m) c)\<rbrakk>
+ \<Longrightarrow> \<exists>V \<in> \<C>. f ` (standard_simplex p) \<subseteq> V"
+ by (blast intro: sufficient_iterated_singular_subdivision_exists [OF \<C> X])
+ let ?c' = "(singular_subdivision p ^^ n) c"
+ show ?thesis
+ proof
+ show "homologous_rel p X S c ?c'"
+ apply (induction n, simp_all)
+ by (metis p homologous_rel_singular_subdivision homologous_rel_singular_relcycle homologous_rel_trans homologous_rel_sym)
+ then show "singular_relcycle p X S ?c'"
+ by (metis homologous_rel_singular_relcycle p)
+ next
+ fix f :: "(nat \<Rightarrow> real) \<Rightarrow> 'a"
+ assume "f \<in> Poly_Mapping.keys ?c'"
+ then show "\<exists>V\<in>\<C>. f ` standard_simplex p \<subseteq> V"
+ by (rule n [OF order_refl])
+ qed
+qed
+
+lemma excised_chain_exists:
+ fixes S :: "'a set"
+ assumes "X closure_of U \<subseteq> X interior_of T" "T \<subseteq> S" "singular_chain p (subtopology X S) c"
+ obtains n d e where "singular_chain p (subtopology X (S - U)) d"
+ "singular_chain p (subtopology X T) e"
+ "(singular_subdivision p ^^ n) c = d + e"
+proof -
+ have *: "\<exists>n d e. singular_chain p (subtopology X (S - U)) d \<and>
+ singular_chain p (subtopology X T) e \<and>
+ (singular_subdivision p ^^ n) c = d + e"
+ if c: "singular_chain p (subtopology X S) c"
+ and X: "X closure_of U \<subseteq> X interior_of T" "U \<subseteq> topspace X" and S: "T \<subseteq> S" "S \<subseteq> topspace X"
+ for p X c S and T U :: "'a set"
+ proof -
+ obtain n where n: "\<And>m f. \<lbrakk>n \<le> m; f \<in> Poly_Mapping.keys ((singular_subdivision p ^^ m) c)\<rbrakk>
+ \<Longrightarrow> \<exists>V \<in> {S \<inter> X interior_of T, S - X closure_of U}. f ` standard_simplex p \<subseteq> V"
+ apply (rule sufficient_iterated_singular_subdivision_exists
+ [of "{S \<inter> X interior_of T, S - X closure_of U}"])
+ using X S c
+ by (auto simp: topspace_subtopology openin_subtopology_Int2 openin_subtopology_diff_closed)
+ let ?c' = "\<lambda>n. (singular_subdivision p ^^ n) c"
+ have "singular_chain p (subtopology X S) (?c' m)" for m
+ by (induction m) (auto simp: singular_chain_singular_subdivision c)
+ then have scp: "singular_chain p (subtopology X S) (?c' n)" .
+
+ have SS: "Poly_Mapping.keys (?c' n) \<subseteq> singular_simplex_set p (subtopology X (S - U))
+ \<union> singular_simplex_set p (subtopology X T)"
+ proof (clarsimp)
+ fix f
+ assume f: "f \<in> Poly_Mapping.keys ((singular_subdivision p ^^ n) c)"
+ and non: "\<not> singular_simplex p (subtopology X T) f"
+ show "singular_simplex p (subtopology X (S - U)) f"
+ using n [OF order_refl f] scp f non closure_of_subset [OF \<open>U \<subseteq> topspace X\<close>] interior_of_subset [of X T]
+ by (fastforce simp: image_subset_iff singular_simplex_subtopology singular_chain_def)
+ qed
+ show ?thesis
+ unfolding singular_chain_def using frag_split [OF SS] by metis
+ qed
+ have "(subtopology X (topspace X \<inter> S)) = (subtopology X S)"
+ by (metis subtopology_subtopology subtopology_topspace)
+ with assms have c: "singular_chain p (subtopology X (topspace X \<inter> S)) c"
+ by simp
+ have Xsub: "X closure_of (topspace X \<inter> U) \<subseteq> X interior_of (topspace X \<inter> T)"
+ using assms closure_of_restrict interior_of_restrict by fastforce
+ obtain n d e where
+ d: "singular_chain p (subtopology X (topspace X \<inter> S - topspace X \<inter> U)) d"
+ and e: "singular_chain p (subtopology X (topspace X \<inter> T)) e"
+ and de: "(singular_subdivision p ^^ n) c = d + e"
+ using *[OF c Xsub, simplified] assms by force
+ show thesis
+ proof
+ show "singular_chain p (subtopology X (S - U)) d"
+ by (metis d Diff_Int_distrib inf.cobounded2 singular_chain_mono)
+ show "singular_chain p (subtopology X T) e"
+ by (metis e inf.cobounded2 singular_chain_mono)
+ show "(singular_subdivision p ^^ n) c = d + e"
+ by (rule de)
+ qed
+qed
+
+
+lemma excised_relcycle_exists:
+ fixes S :: "'a set"
+ assumes X: "X closure_of U \<subseteq> X interior_of T" and "T \<subseteq> S"
+ and c: "singular_relcycle p (subtopology X S) T c"
+ obtains c' where "singular_relcycle p (subtopology X (S - U)) (T - U) c'"
+ "homologous_rel p (subtopology X S) T c c'"
+proof -
+ have [simp]: "(S - U) \<inter> (T - U) = T - U" "S \<inter> T = T"
+ using \<open>T \<subseteq> S\<close> by auto
+ have scc: "singular_chain p (subtopology X S) c"
+ and scp1: "singular_chain (p - Suc 0) (subtopology X T) (chain_boundary p c)"
+ using c by (auto simp: singular_relcycle_def mod_subset_def subtopology_subtopology)
+ obtain n d e where d: "singular_chain p (subtopology X (S - U)) d"
+ and e: "singular_chain p (subtopology X T) e"
+ and de: "(singular_subdivision p ^^ n) c = d + e"
+ using excised_chain_exists [OF X \<open>T \<subseteq> S\<close> scc] .
+ have scSUd: "singular_chain (p - Suc 0) (subtopology X (S - U)) (chain_boundary p d)"
+ by (simp add: singular_chain_boundary d)
+ have sccn: "singular_chain p (subtopology X S) ((singular_subdivision p ^^ n) c)" for n
+ by (induction n) (auto simp: singular_chain_singular_subdivision scc)
+ have "singular_chain (p - Suc 0) (subtopology X T) (chain_boundary p ((singular_subdivision p ^^ n) c))"
+ proof (induction n)
+ case (Suc n)
+ then show ?case
+ by (simp add: singular_chain_singular_subdivision chain_boundary_singular_subdivision [OF sccn])
+ qed (auto simp: scp1)
+ then have "singular_chain (p - Suc 0) (subtopology X T) (chain_boundary p ((singular_subdivision p ^^ n) c - e))"
+ by (simp add: chain_boundary_diff singular_chain_diff singular_chain_boundary e)
+ with de have scTd: "singular_chain (p - Suc 0) (subtopology X T) (chain_boundary p d)"
+ by simp
+ show thesis
+ proof
+ have "singular_chain (p - Suc 0) X (chain_boundary p d)"
+ using scTd singular_chain_subtopology by blast
+ with scSUd scTd have "singular_chain (p - Suc 0) (subtopology X (T - U)) (chain_boundary p d)"
+ by (fastforce simp add: singular_chain_subtopology)
+ then show "singular_relcycle p (subtopology X (S - U)) (T - U) d"
+ by (auto simp: singular_relcycle_def mod_subset_def subtopology_subtopology d)
+ have "homologous_rel p (subtopology X S) T (c-0) ((singular_subdivision p ^^ n) c - e)"
+ proof (rule homologous_rel_diff)
+ show "homologous_rel p (subtopology X S) T c ((singular_subdivision p ^^ n) c)"
+ proof (induction n)
+ case (Suc n)
+ then show ?case
+ apply simp
+ apply (rule homologous_rel_trans)
+ using c homologous_rel_singular_relcycle_1 homologous_rel_singular_subdivision homologous_rel_sym by blast
+ qed auto
+ show "homologous_rel p (subtopology X S) T 0 e"
+ unfolding homologous_rel_def using e
+ by (intro singular_relboundary_diff singular_chain_imp_relboundary; simp add: subtopology_subtopology)
+ qed
+ with de show "homologous_rel p (subtopology X S) T c d"
+ by simp
+ qed
+qed
+
+
+subsection\<open>Homotopy invariance\<close>
+
+theorem homotopic_imp_homologous_rel_chain_maps:
+ assumes hom: "homotopic_with (\<lambda>h. h ` T \<subseteq> V) S U f g" and c: "singular_relcycle p S T c"
+ shows "homologous_rel p U V (chain_map p f c) (chain_map p g c)"
+proof -
+ note sum_atMost_Suc [simp del]
+ have contf: "continuous_map S U f" and contg: "continuous_map S U g"
+ using homotopic_with_imp_continuous_maps [OF hom] by metis+
+ obtain h where conth: "continuous_map (prod_topology (top_of_set {0..1::real}) S) U h"
+ and h0: "\<And>x. h(0, x) = f x"
+ and h1: "\<And>x. h(1, x) = g x"
+ and hV: "\<And>t x. \<lbrakk>0 \<le> t; t \<le> 1; x \<in> T\<rbrakk> \<Longrightarrow> h(t,x) \<in> V"
+ using hom by (fastforce simp: homotopic_with_def)
+ define vv where "vv \<equiv> \<lambda>j i. if i = Suc j then 1 else (0::real)"
+ define ww where "ww \<equiv> \<lambda>j i. if i=0 \<or> i = Suc j then 1 else (0::real)"
+ define simp where "simp \<equiv> \<lambda>q i. oriented_simplex (Suc q) (\<lambda>j. if j \<le> i then vv j else ww(j -1))"
+ define pr where "pr \<equiv> \<lambda>q c. \<Sum>i\<le>q. frag_cmul ((-1) ^ i)
+ (frag_of (simplex_map (Suc q) (\<lambda>z. h(z 0, c(z \<circ> Suc))) (simp q i)))"
+ have ss_ss: "simplicial_simplex (Suc q) ({x. x 0 \<in> {0..1} \<and> (x \<circ> Suc) \<in> standard_simplex q}) (simp q i)"
+ if "i \<le> q" for q i
+ proof -
+ have "(\<Sum>j\<le>Suc q. (if j \<le> i then vv j 0 else ww (j -1) 0) * x j) \<in> {0..1}"
+ if "x \<in> standard_simplex (Suc q)" for x
+ proof -
+ have "(\<Sum>j\<le>Suc q. if j \<le> i then 0 else x j) \<le> sum x {..Suc q}"
+ using that unfolding standard_simplex_def
+ by (force intro!: sum_mono)
+ with \<open>i \<le> q\<close> that show ?thesis
+ by (simp add: vv_def ww_def standard_simplex_def if_distrib [of "\<lambda>u. u * _"] sum_nonneg cong: if_cong)
+ qed
+ moreover
+ have "(\<lambda>k. \<Sum>j\<le>Suc q. (if j \<le> i then vv j k else ww (j -1) k) * x j) \<circ> Suc \<in> standard_simplex q"
+ if "x \<in> standard_simplex (Suc q)" for x
+ proof -
+ have card: "({..q} \<inter> {k. Suc k = j}) = {j-1}" if "0 < j" "j \<le> Suc q" for j
+ using that by auto
+ have eq: "(\<Sum>j\<le>Suc q. \<Sum>k\<le>q. if j \<le> i then if k = j then x j else 0 else if Suc k = j then x j else 0)
+ = (\<Sum>j\<le>Suc q. x j)"
+ by (rule sum.cong [OF refl]) (use \<open>i \<le> q\<close> in \<open>simp add: sum.If_cases card\<close>)
+ have "(\<Sum>j\<le>Suc q. if j \<le> i then if k = j then x j else 0 else if Suc k = j then x j else 0)
+ \<le> sum x {..Suc q}" for k
+ using that unfolding standard_simplex_def
+ by (force intro!: sum_mono)
+ then show ?thesis
+ using \<open>i \<le> q\<close> that
+ by (simp add: vv_def ww_def standard_simplex_def if_distrib [of "\<lambda>u. u * _"] sum_nonneg
+ sum.swap [where A = "atMost q"] eq cong: if_cong)
+ qed
+ ultimately show ?thesis
+ by (simp add: that simplicial_simplex_oriented_simplex simp_def image_subset_iff if_distribR)
+ qed
+ obtain prism where prism: "\<And>q. prism q 0 = 0"
+ "\<And>q c. singular_chain q S c \<Longrightarrow> singular_chain (Suc q) U (prism q c)"
+ "\<And>q c. singular_chain q (subtopology S T) c
+ \<Longrightarrow> singular_chain (Suc q) (subtopology U V) (prism q c)"
+ "\<And>q c. singular_chain q S c
+ \<Longrightarrow> chain_boundary (Suc q) (prism q c) =
+ chain_map q g c - chain_map q f c - prism (q -1) (chain_boundary q c)"
+ proof
+ show "(frag_extend \<circ> pr) q 0 = 0" for q
+ by (simp add: pr_def)
+ next
+ show "singular_chain (Suc q) U ((frag_extend \<circ> pr) q c)"
+ if "singular_chain q S c" for q c
+ using that [unfolded singular_chain_def]
+ proof (induction c rule: frag_induction)
+ case (one m)
+ show ?case
+ proof (simp add: pr_def, intro singular_chain_cmul singular_chain_sum)
+ fix i :: "nat"
+ assume "i \<in> {..q}"
+ define X where "X = subtopology (powertop_real UNIV) {x. x 0 \<in> {0..1} \<and> (x \<circ> Suc) \<in> standard_simplex q}"
+ show "singular_chain (Suc q) U
+ (frag_of (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i)))"
+ unfolding singular_chain_of
+ proof (rule singular_simplex_simplex_map)
+ show "singular_simplex (Suc q) X (simp q i)"
+ unfolding X_def using \<open>i \<in> {..q}\<close> simplicial_imp_singular_simplex ss_ss by blast
+ have 0: "continuous_map X (top_of_set {0..1}) (\<lambda>x. x 0)"
+ unfolding continuous_map_in_subtopology topspace_subtopology X_def
+ by (auto intro: continuous_map_product_projection continuous_map_from_subtopology)
+ have 1: "continuous_map X S (m \<circ> (\<lambda>x j. x (Suc j)))"
+ proof (rule continuous_map_compose)
+ have "continuous_map (powertop_real UNIV) (powertop_real UNIV) (\<lambda>x j. x (Suc j))"
+ by (auto intro: continuous_map_product_projection)
+ then show "continuous_map X (subtopology (powertop_real UNIV) (standard_simplex q)) (\<lambda>x j. x (Suc j))"
+ unfolding X_def o_def
+ by (auto simp: continuous_map_in_subtopology intro: continuous_map_from_subtopology continuous_map_product_projection)
+ qed (use one in \<open>simp add: singular_simplex_def\<close>)
+ show "continuous_map X U (\<lambda>z. h (z 0, m (z \<circ> Suc)))"
+ apply (rule continuous_map_compose [unfolded o_def, OF _ conth])
+ using 0 1 by (simp add: continuous_map_pairwise o_def)
+ qed
+ qed
+ next
+ case (diff a b)
+ then show ?case
+ apply (simp add: frag_extend_diff keys_diff)
+ using singular_chain_def singular_chain_diff by blast
+ qed auto
+ next
+ show "singular_chain (Suc q) (subtopology U V) ((frag_extend \<circ> pr) q c)"
+ if "singular_chain q (subtopology S T) c" for q c
+ using that [unfolded singular_chain_def]
+ proof (induction c rule: frag_induction)
+ case (one m)
+ show ?case
+ proof (simp add: pr_def, intro singular_chain_cmul singular_chain_sum)
+ fix i :: "nat"
+ assume "i \<in> {..q}"
+ define X where "X = subtopology (powertop_real UNIV) {x. x 0 \<in> {0..1} \<and> (x \<circ> Suc) \<in> standard_simplex q}"
+ show "singular_chain (Suc q) (subtopology U V)
+ (frag_of (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i)))"
+ unfolding singular_chain_of
+ proof (rule singular_simplex_simplex_map)
+ show "singular_simplex (Suc q) X (simp q i)"
+ unfolding X_def using \<open>i \<in> {..q}\<close> simplicial_imp_singular_simplex ss_ss by blast
+ have 0: "continuous_map X (top_of_set {0..1}) (\<lambda>x. x 0)"
+ unfolding continuous_map_in_subtopology topspace_subtopology X_def
+ by (auto intro: continuous_map_product_projection continuous_map_from_subtopology)
+ have 1: "continuous_map X (subtopology S T) (m \<circ> (\<lambda>x j. x (Suc j)))"
+ proof (rule continuous_map_compose)
+ have "continuous_map (powertop_real UNIV) (powertop_real UNIV) (\<lambda>x j. x (Suc j))"
+ by (auto intro: continuous_map_product_projection)
+ then show "continuous_map X (subtopology (powertop_real UNIV) (standard_simplex q)) (\<lambda>x j. x (Suc j))"
+ unfolding X_def o_def
+ by (auto simp: continuous_map_in_subtopology intro: continuous_map_from_subtopology continuous_map_product_projection)
+ show "continuous_map (subtopology (powertop_real UNIV) (standard_simplex q)) (subtopology S T) m"
+ using one continuous_map_into_fulltopology by (auto simp: singular_simplex_def)
+ qed
+ have "continuous_map X (subtopology U V) (h \<circ> (\<lambda>z. (z 0, m (z \<circ> Suc))))"
+ proof (rule continuous_map_compose)
+ show "continuous_map X (prod_topology (top_of_set {0..1::real}) (subtopology S T)) (\<lambda>z. (z 0, m (z \<circ> Suc)))"
+ using 0 1 by (simp add: continuous_map_pairwise o_def)
+ have "continuous_map (subtopology (prod_topology euclideanreal S) ({0..1} \<times> T)) U h"
+ by (metis conth continuous_map_from_subtopology subtopology_Times subtopology_topspace)
+ with hV show "continuous_map (prod_topology (top_of_set {0..1::real}) (subtopology S T)) (subtopology U V) h"
+ by (force simp: topspace_subtopology continuous_map_in_subtopology subtopology_restrict subtopology_Times)
+ qed
+ then show "continuous_map X (subtopology U V) (\<lambda>z. h (z 0, m (z \<circ> Suc)))"
+ by (simp add: o_def)
+ qed
+ qed
+ next
+ case (diff a b)
+ then show ?case
+ by (metis comp_apply frag_extend_diff singular_chain_diff)
+ qed auto
+ next
+ show "chain_boundary (Suc q) ((frag_extend \<circ> pr) q c) =
+ chain_map q g c - chain_map q f c - (frag_extend \<circ> pr) (q -1) (chain_boundary q c)"
+ if "singular_chain q S c" for q c
+ using that [unfolded singular_chain_def]
+ proof (induction c rule: frag_induction)
+ case (one m)
+ have eq2: "Sigma S T = (\<lambda>i. (i,i)) ` {i \<in> S. i \<in> T i} \<union> (Sigma S (\<lambda>i. T i - {i}))" for S :: "nat set" and T
+ by force
+ have 1: "(\<Sum>(i,j)\<in>(\<lambda>i. (i, i)) ` {i. i \<le> q \<and> i \<le> Suc q}.
+ frag_cmul (((-1) ^ i) * (-1) ^ j)
+ (frag_of
+ (singular_face (Suc q) j
+ (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i)))))
+ + (\<Sum>(i,j)\<in>(\<lambda>i. (i, i)) ` {i. i \<le> q}.
+ frag_cmul (- ((-1) ^ i * (-1) ^ j))
+ (frag_of
+ (singular_face (Suc q) (Suc j)
+ (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i)))))
+ = frag_of (simplex_map q g m) - frag_of (simplex_map q f m)"
+ proof -
+ have "restrict ((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> (simp q 0 \<circ> simplical_face 0)) (standard_simplex q)
+ = restrict (g \<circ> m) (standard_simplex q)"
+ proof (rule restrict_ext)
+ fix x
+ assume x: "x \<in> standard_simplex q"
+ have "(\<Sum>j\<le>Suc q. if j = 0 then 0 else x (j - Suc 0)) = (\<Sum>j\<le>q. x j)"
+ by (simp add: sum_atMost_Suc_shift)
+ with x have "simp q 0 (simplical_face 0 x) 0 = 1"
+ apply (simp add: oriented_simplex_def simp_def simplical_face_in_standard_simplex)
+ apply (simp add: simplical_face_def if_distrib ww_def standard_simplex_def cong: if_cong)
+ done
+ moreover
+ have "(\<lambda>n. if n \<le> q then x n else 0) = x"
+ using standard_simplex_def x by auto
+ then have "(\<lambda>n. simp q 0 (simplical_face 0 x) (Suc n)) = x"
+ unfolding oriented_simplex_def simp_def ww_def using x
+ apply (simp add: simplical_face_in_standard_simplex)
+ apply (simp add: simplical_face_def if_distrib)
+ apply (simp add: if_distribR if_distrib cong: if_cong)
+ done
+ ultimately show "((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> (simp q 0 \<circ> simplical_face 0)) x = (g \<circ> m) x"
+ by (simp add: o_def h1)
+ qed
+ then have a: "frag_of (singular_face (Suc q) 0 (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q 0)))
+ = frag_of (simplex_map q g m)"
+ by (simp add: singular_face_simplex_map) (simp add: simplex_map_def)
+ have "restrict ((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> (simp q q \<circ> simplical_face (Suc q))) (standard_simplex q)
+ = restrict (f \<circ> m) (standard_simplex q)"
+ proof (rule restrict_ext)
+ fix x
+ assume x: "x \<in> standard_simplex q"
+ then have "simp q q (simplical_face (Suc q) x) 0 = 0"
+ unfolding oriented_simplex_def simp_def
+ by (simp add: simplical_face_in_standard_simplex sum_atMost_Suc) (simp add: simplical_face_def vv_def)
+ moreover have "(\<lambda>n. simp q q (simplical_face (Suc q) x) (Suc n)) = x"
+ unfolding oriented_simplex_def simp_def vv_def using x
+ apply (simp add: simplical_face_in_standard_simplex)
+ apply (force simp: standard_simplex_def simplical_face_def if_distribR if_distrib [of "\<lambda>x. x * _"] sum_atMost_Suc cong: if_cong)
+ done
+ ultimately show "((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> (simp q q \<circ> simplical_face (Suc q))) x = (f \<circ> m) x"
+ by (simp add: o_def h0)
+ qed
+ then have b: "frag_of (singular_face (Suc q) (Suc q)
+ (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q q)))
+ = frag_of (simplex_map q f m)"
+ by (simp add: singular_face_simplex_map) (simp add: simplex_map_def)
+ have sfeq: "simplex_map q (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q (Suc i) \<circ> simplical_face (Suc i))
+ = simplex_map q (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i \<circ> simplical_face (Suc i))"
+ if "i < q" for i
+ unfolding simplex_map_def
+ proof (rule restrict_ext)
+ fix x
+ assume "x \<in> standard_simplex q"
+ then have "(simp q (Suc i) \<circ> simplical_face (Suc i)) x = (simp q i \<circ> simplical_face (Suc i)) x"
+ unfolding oriented_simplex_def simp_def simplical_face_def
+ by (force intro: sum.cong)
+ then show "((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> (simp q (Suc i) \<circ> simplical_face (Suc i))) x
+ = ((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> (simp q i \<circ> simplical_face (Suc i))) x"
+ by simp
+ qed
+ have eqq: "{i. i \<le> q \<and> i \<le> Suc q} = {..q}"
+ by force
+ have qeq: "{..q} = insert 0 ((\<lambda>i. Suc i) ` {i. i < q})" "{i. i \<le> q} = insert q {i. i < q}"
+ using le_imp_less_Suc less_Suc_eq_0_disj by auto
+ show ?thesis
+ using a b
+ apply (simp add: sum.reindex inj_on_def eqq)
+ apply (simp add: qeq sum.insert_if sum.reindex sum_negf singular_face_simplex_map sfeq)
+ done
+ qed
+ have 2: "(\<Sum>(i,j)\<in>(SIGMA i:{..q}. {0..min (Suc q) i} - {i}).
+ frag_cmul ((-1) ^ i * (-1) ^ j)
+ (frag_of
+ (singular_face (Suc q) j
+ (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i)))))
+ + (\<Sum>(i,j)\<in>(SIGMA i:{..q}. {i..q} - {i}).
+ frag_cmul (- ((-1) ^ i * (-1) ^ j))
+ (frag_of
+ (singular_face (Suc q) (Suc j)
+ (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i)))))
+ = - frag_extend (pr (q - Suc 0)) (chain_boundary q (frag_of m))"
+ proof (cases "q=0")
+ case True
+ then show ?thesis
+ by (simp add: chain_boundary_def flip: sum.Sigma)
+ next
+ case False
+ have eq: "{..q - Suc 0} \<times> {..q} = Sigma {..q - Suc 0} (\<lambda>i. {0..min q i}) \<union> Sigma {..q} (\<lambda>i. {i<..q})"
+ by force
+ have I: "(\<Sum>(i,j)\<in>(SIGMA i:{..q}. {0..min (Suc q) i} - {i}).
+ frag_cmul ((-1) ^ (i + j))
+ (frag_of
+ (singular_face (Suc q) j
+ (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i)))))
+ = (\<Sum>(i,j)\<in>(SIGMA i:{..q - Suc 0}. {0..min q i}).
+ frag_cmul (- ((-1) ^ (j + i)))
+ (frag_of
+ (simplex_map q (\<lambda>z. h (z 0, singular_face q j m (z \<circ> Suc)))
+ (simp (q - Suc 0) i))))"
+ proof -
+ have seq: "simplex_map q (\<lambda>z. h (z 0, singular_face q j m (z \<circ> Suc)))
+ (simp (q - Suc 0) (i - Suc 0))
+ = simplex_map q (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i \<circ> simplical_face j)"
+ if ij: "i \<le> q" "j \<noteq> i" "j \<le> i" for i j
+ unfolding simplex_map_def
+ proof (rule restrict_ext)
+ fix x
+ assume x: "x \<in> standard_simplex q"
+ have "i > 0"
+ using that by force
+ then have iq: "i - Suc 0 \<le> q - Suc 0"
+ using \<open>i \<le> q\<close> False by simp
+ have q0_eq: "{..Suc q} = insert 0 (Suc ` {..q})"
+ by (auto simp: image_def gr0_conv_Suc)
+ have \<alpha>: "simp (q - Suc 0) (i - Suc 0) x 0 = simp q i (simplical_face j x) 0"
+ using False x ij
+ unfolding oriented_simplex_def simp_def vv_def ww_def
+ apply (simp add: simplical_face_in_standard_simplex)
+ apply (force simp: simplical_face_def q0_eq sum.reindex intro!: sum.cong)
+ done
+ have \<beta>: "simplical_face j (simp (q - Suc 0) (i - Suc 0) x \<circ> Suc) = simp q i (simplical_face j x) \<circ> Suc"
+ proof
+ fix k
+ show "simplical_face j (simp (q - Suc 0) (i - Suc 0) x \<circ> Suc) k
+ = (simp q i (simplical_face j x) \<circ> Suc) k"
+ using False x ij
+ unfolding oriented_simplex_def simp_def o_def vv_def ww_def
+ apply (simp add: simplical_face_in_standard_simplex if_distribR)
+ apply (simp add: simplical_face_def if_distrib [of "\<lambda>u. u * _"] cong: if_cong)
+ apply (intro impI conjI)
+ apply (force simp: sum_atMost_Suc intro: sum.cong)
+ apply (force simp: q0_eq sum.reindex intro!: sum.cong)
+ done
+ qed
+ have "simp (q - Suc 0) (i - Suc 0) x \<circ> Suc \<in> standard_simplex (q - Suc 0)"
+ using ss_ss [OF iq] \<open>i \<le> q\<close> False \<open>i > 0\<close>
+ apply (simp add: simplicial_simplex image_subset_iff)
+ using \<open>x \<in> standard_simplex q\<close> by blast
+ then show "((\<lambda>z. h (z 0, singular_face q j m (z \<circ> Suc))) \<circ> simp (q - Suc 0) (i - Suc 0)) x
+ = ((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> (simp q i \<circ> simplical_face j)) x"
+ by (simp add: singular_face_def \<alpha> \<beta>)
+ qed
+ have [simp]: "(-1::int) ^ (i + j - Suc 0) = - ((-1) ^ (i + j))" if "i \<noteq> j" for i j::nat
+ proof -
+ have "i + j > 0"
+ using that by blast
+ then show ?thesis
+ by (metis (no_types, hide_lams) One_nat_def Suc_diff_1 add.inverse_inverse mult.left_neutral mult_minus_left power_Suc)
+ qed
+ show ?thesis
+ apply (rule sum.eq_general_inverses [where h = "\<lambda>(a,b). (a-1,b)" and k = "\<lambda>(a,b). (Suc a,b)"])
+ using False apply (auto simp: singular_face_simplex_map seq add.commute)
+ done
+ qed
+ have *: "singular_face (Suc q) (Suc j) (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i))
+ = simplex_map q (\<lambda>z. h (z 0, singular_face q j m (z \<circ> Suc))) (simp (q - Suc 0) i)"
+ if ij: "i < j" "j \<le> q" for i j
+ proof -
+ have iq: "i \<le> q - Suc 0"
+ using that by auto
+ have sf_eqh: "singular_face (Suc q) (Suc j)
+ (\<lambda>x. if x \<in> standard_simplex (Suc q)
+ then ((\<lambda>z. h (z 0, m (z \<circ> Suc))) \<circ> simp q i) x else undefined) x
+ = h (simp (q - Suc 0) i x 0,
+ singular_face q j m (\<lambda>xa. simp (q - Suc 0) i x (Suc xa)))"
+ if x: "x \<in> standard_simplex q" for x
+ proof -
+ let ?f = "\<lambda>k. \<Sum>j\<le>q. if j \<le> i then if k = j then x j else 0
+ else if Suc k = j then x j else 0"
+ have fm: "simplical_face (Suc j) x \<in> standard_simplex (Suc q)"
+ using ss_ss [OF iq] that ij
+ by (simp add: simplical_face_in_standard_simplex)
+ have ss: "?f \<in> standard_simplex (q - Suc 0)"
+ unfolding standard_simplex_def
+ proof (intro CollectI conjI impI allI)
+ fix k
+ show "0 \<le> ?f k"
+ using that by (simp add: sum_nonneg standard_simplex_def)
+ show "?f k \<le> 1"
+ using x sum_le_included [of "{..q}" "{..q}" x "id"]
+ by (simp add: standard_simplex_def)
+ assume k: "q - Suc 0 < k"
+ show "?f k = 0"
+ by (rule sum.neutral) (use that x iq k standard_simplex_def in auto)
+ next
+ have "(\<Sum>k\<le>q - Suc 0. ?f k)
+ = (\<Sum>(k,j) \<in> ({..q - Suc 0} \<times> {..q}) \<inter> {(k,j). if j \<le> i then k = j else Suc k = j}. x j)"
+ apply (simp add: sum.Sigma)
+ by (rule sum.mono_neutral_cong) (auto simp: split: if_split_asm)
+ also have "\<dots> = sum x {..q}"
+ apply (rule sum.eq_general_inverses
+ [where h = "\<lambda>(k,j). if j\<le>i \<and> k=j \<or> j>i \<and> Suc k = j then j else Suc q"
+ and k = "\<lambda>j. if j \<le> i then (j,j) else (j - Suc 0, j)"])
+ using ij by auto
+ also have "\<dots> = 1"
+ using x by (simp add: standard_simplex_def)
+ finally show "(\<Sum>k\<le>q - Suc 0. ?f k) = 1"
+ by (simp add: standard_simplex_def)
+ qed
+ let ?g = "\<lambda>k. if k \<le> i then 0
+ else if k < Suc j then x k
+ else if k = Suc j then 0 else x (k - Suc 0)"
+ have eq: "{..Suc q} = {..j} \<union> {Suc j} \<union> Suc`{j<..q}" "{..q} = {..j} \<union> {j<..q}"
+ using ij image_iff less_Suc_eq_0_disj less_Suc_eq_le
+ by (force simp: image_iff)+
+ then have "(\<Sum>k\<le>Suc q. ?g k) = (\<Sum>k\<in>{..j} \<union> {Suc j} \<union> Suc`{j<..q}. ?g k)"
+ by simp
+ also have "\<dots> = (\<Sum>k\<in>{..j} \<union> Suc`{j<..q}. ?g k)"
+ by (rule sum.mono_neutral_right) auto
+ also have "\<dots> = (\<Sum>k\<in>{..j}. ?g k) + (\<Sum>k\<in>Suc`{j<..q}. ?g k)"
+ by (rule sum.union_disjoint) auto
+ also have "\<dots> = (\<Sum>k\<in>{..j}. ?g k) + (\<Sum>k\<in>{j<..q}. ?g (Suc k))"
+ by (auto simp: sum.reindex)
+ also have "\<dots> = (\<Sum>k\<in>{..j}. if k \<le> i then 0 else x k)
+ + (\<Sum>k\<in>{j<..q}. if k \<le> i then 0 else x k)"
+ by (intro sum.cong arg_cong2 [of concl: "(+)"]) (use ij in auto)
+ also have "\<dots> = (\<Sum>k\<le>q. if k \<le> i then 0 else x k)"
+ unfolding eq by (subst sum.union_disjoint) auto
+ finally have "(\<Sum>k\<le>Suc q. ?g k) = (\<Sum>k\<le>q. if k \<le> i then 0 else x k)" .
+ then have QQ: "(\<Sum>l\<le>Suc q. if l \<le> i then 0 else simplical_face (Suc j) x l) = (\<Sum>j\<le>q. if j \<le> i then 0 else x j)"
+ by (simp add: simplical_face_def cong: if_cong)
+ have WW: "(\<lambda>k. \<Sum>l\<le>Suc q. if l \<le> i
+ then if k = l then simplical_face (Suc j) x l else 0
+ else if Suc k = l then simplical_face (Suc j) x l
+ else 0)
+ = simplical_face j
+ (\<lambda>k. \<Sum>j\<le>q. if j \<le> i then if k = j then x j else 0
+ else if Suc k = j then x j else 0)"
+ proof -
+ have *: "(\<Sum>l\<le>q. if l \<le> i then 0 else if Suc k = l then x (l - Suc 0) else 0)
+ = (\<Sum>l\<le>q. if l \<le> i then if k - Suc 0 = l then x l else 0 else if k = l then x l else 0)"
+ (is "?lhs = ?rhs")
+ if "k \<noteq> q" "k > j" for k
+ proof (cases "k \<le> q")
+ case True
+ have "?lhs = sum (\<lambda>l. x (l - Suc 0)) {Suc k}" "?rhs = sum x {k}"
+ by (rule sum.mono_neutral_cong_right; use True ij that in auto)+
+ then show ?thesis
+ by simp
+ next
+ case False
+ have "?lhs = 0" "?rhs = 0"
+ by (rule sum.neutral; use False ij in auto)+
+ then show ?thesis
+ by simp
+ qed
+ show ?thesis
+ apply (rule ext)
+ unfolding simplical_face_def using ij
+ apply (auto simp: sum_atMost_Suc cong: if_cong)
+ apply (force simp flip: ivl_disj_un(2) intro: sum.neutral)
+ apply (auto simp: *)
+ done
+ qed
+ show ?thesis
+ using False that iq
+ unfolding oriented_simplex_def simp_def vv_def ww_def
+ apply (simp add: if_distribR cong: if_cong)
+ apply (simp add: simplical_face_def if_distrib [of "\<lambda>u. u * _"] o_def cong: if_cong)
+ apply (simp add: singular_face_def fm ss QQ WW)
+ done
+ qed
+ show ?thesis
+ unfolding simplex_map_def restrict_def
+ apply (rule ext)
+ apply (simp add: simplicial_simplex image_subset_iff o_def sf_eqh)
+ apply (simp add: singular_face_def)
+ done
+ qed
+ have sgeq: "(SIGMA i:{..q}. {i..q} - {i}) = (SIGMA i:{..q}. {i<..q})"
+ by force
+ have II: "(\<Sum>(i,j)\<in>(SIGMA i:{..q}. {i..q} - {i}).
+ frag_cmul (- ((-1) ^ (i + j)))
+ (frag_of
+ (singular_face (Suc q) (Suc j)
+ (simplex_map (Suc q) (\<lambda>z. h (z 0, m (z \<circ> Suc))) (simp q i))))) =
+ (\<Sum>(i,j)\<in>(SIGMA i:{..q}. {i<..q}).
+ frag_cmul (- ((-1) ^ (j + i)))
+ (frag_of
+ (simplex_map q (\<lambda>z. h (z 0, singular_face q j m (z \<circ> Suc)))
+ (simp (q - Suc 0) i))))"
+ by (force simp: * sgeq add.commute intro: sum.cong)
+ show ?thesis
+ using False
+ apply (simp add: chain_boundary_def frag_extend_sum frag_extend_cmul frag_cmul_sum pr_def flip: sum_negf power_add)
+ apply (subst sum.swap [where A = "{..q}"])
+ apply (simp add: sum.cartesian_product eq sum.union_disjoint disjoint_iff_not_equal I II)
+ done
+ qed
+ have *: "\<lbrakk>a+b = w; c+d = -z\<rbrakk> \<Longrightarrow> (a + c) + (b+d) = w-z" for a b w c d z :: "'c \<Rightarrow>\<^sub>0 int"
+ by (auto simp: algebra_simps)
+ have eq: "{..q} \<times> {..Suc q} =
+ Sigma {..q} (\<lambda>i. {0..min (Suc q) i})
+ \<union> Sigma {..q} (\<lambda>i. {Suc i..Suc q})"
+ by force
+ show ?case
+ apply (subst pr_def)
+ apply (simp add: chain_boundary_sum chain_boundary_cmul)
+ apply (subst chain_boundary_def)
+ apply (simp add: frag_cmul_sum sum.cartesian_product eq sum.union_disjoint disjoint_iff_not_equal
+ sum.atLeast_Suc_atMost_Suc_shift del: sum_cl_ivl_Suc flip: comm_monoid_add_class.sum.Sigma)
+ apply (simp add: comm_monoid_add_class.sum.Sigma eq2 [of _ "\<lambda>i. {_ i.._ i}"])
+ apply (simp add: sum.union_disjoint disjoint_iff_not_equal * [OF 1 2])
+ done
+ next
+ case (diff a b)
+ then show ?case
+ by (simp add: chain_boundary_diff frag_extend_diff chain_map_diff)
+ qed auto
+ qed
+ have *: "singular_chain p (subtopology U V) (prism (p - Suc 0) (chain_boundary p c))"
+ if "singular_chain p S c" "singular_chain (p - Suc 0) (subtopology S T) (chain_boundary p c)"
+ proof (cases "p")
+ case 0 then show ?thesis by (simp add: chain_boundary_def prism)
+ next
+ case (Suc p')
+ with prism that show ?thesis by auto
+ qed
+ then show ?thesis
+ using c
+ unfolding singular_relcycle_def homologous_rel_def singular_relboundary_def mod_subset_def
+ apply (rule_tac x="- prism p c" in exI)
+ by (simp add: chain_boundary_minus prism(2) prism(4) singular_chain_minus)
+qed
+
+end
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Homology/document/root.tex Wed Apr 10 15:45:16 2019 +0200
@@ -0,0 +1,42 @@
+\documentclass[11pt,a4paper]{book}
+\usepackage{graphicx}
+\usepackage{isabelle}
+\usepackage{isabellesym}
+\usepackage{latexsym}
+\usepackage{textcomp}
+\usepackage{amsmath}
+\usepackage{amssymb}
+\usepackage[only,bigsqcap]{stmaryrd}
+\usepackage{pdfsetup}
+
+\usepackage{tocloft}
+\setlength{\cftsubsecnumwidth}{3em}
+\cftsetpnumwidth{2em}
+\cftsetrmarg{3em}
+
+\urlstyle{rm}
+\isabellestyle{literalunderscore}
+\pagestyle{myheadings}
+
+\begin{document}
+
+\title{Homology}
+\maketitle
+
+\tableofcontents
+
+\begin{center}
+ \includegraphics[height=\textheight]{session_graph}
+\end{center}
+
+\newpage
+
+\renewcommand{\setisabellecontext}[1]{\markright{\href{#1.html}{#1.thy}}}
+
+\parindent 0pt\parskip 0.5ex
+\input{session}
+
+\pagestyle{headings}
+\bibliographystyle{abbrv}
+
+\end{document}
--- a/src/HOL/ROOT Wed Apr 10 15:10:43 2019 +0200
+++ b/src/HOL/ROOT Wed Apr 10 15:45:16 2019 +0200
@@ -74,6 +74,16 @@
theories
Approximations
+session "HOL-Homology" (main timing) in Homology = "HOL-Analysis" +
+ options [document_tags = "theorem%important,corollary%important,proposition%important,class%important,instantiation%important,subsubsection%unimportant,%unimportant",
+ document_variants = "document:manual=-proof,-ML,-unimportant"]
+ sessions
+ "HOL-Algebra"
+ theories
+ Homology
+ document_files
+ "root.tex"
+
session "HOL-Computational_Algebra" (main timing) in "Computational_Algebra" = "HOL-Library" +
theories
Computational_Algebra
--- a/src/HOL/Rings.thy Wed Apr 10 15:10:43 2019 +0200
+++ b/src/HOL/Rings.thy Wed Apr 10 15:45:16 2019 +0200
@@ -1699,6 +1699,69 @@
end
+text \<open>Integral (semi)domains with cancellation rules\<close>
+
+class semidom_divide_cancel = semidom_divide +
+ assumes div_mult_self1: "b \<noteq> 0 \<Longrightarrow> (a + c * b) div b = c + a div b"
+ and div_mult_mult1: "c \<noteq> 0 \<Longrightarrow> (c * a) div (c * b) = a div b"
+begin
+
+context
+ fixes b
+ assumes "b \<noteq> 0"
+begin
+
+lemma div_mult_self2:
+ "(a + b * c) div b = c + a div b"
+ using \<open>b \<noteq> 0\<close> div_mult_self1 [of b a c] by (simp add: ac_simps)
+
+lemma div_mult_self3:
+ "(c * b + a) div b = c + a div b"
+ using \<open>b \<noteq> 0\<close> div_mult_self1 [of b a c] by (simp add: ac_simps)
+
+lemma div_mult_self4:
+ "(b * c + a) div b = c + a div b"
+ using \<open>b \<noteq> 0\<close> div_mult_self1 [of b a c] by (simp add: ac_simps)
+
+lemma div_add_self1:
+ "(b + a) div b = a div b + 1"
+ using \<open>b \<noteq> 0\<close> div_mult_self1 [of b a 1] by (simp add: ac_simps)
+
+lemma div_add_self2:
+ "(a + b) div b = a div b + 1"
+ using \<open>b \<noteq> 0\<close> div_add_self1 [of a] by (simp add: ac_simps)
+
+end
+
+lemma div_mult_mult2:
+ "(a * c) div (b * c) = a div b" if "c \<noteq> 0"
+ using that div_mult_mult1 [of c a b] by (simp add: ac_simps)
+
+lemma div_mult_mult1_if [simp]:
+ "(c * a) div (c * b) = (if c = 0 then 0 else a div b)"
+ by (simp add: div_mult_mult1)
+
+lemma div_mult_mult2_if [simp]:
+ "(a * c) div (b * c) = (if c = 0 then 0 else a div b)"
+ using div_mult_mult1_if [of c a b] by (simp add: ac_simps)
+
+end
+
+class idom_divide_cancel = idom_divide + semidom_divide_cancel
+begin
+
+lemma div_minus_minus [simp]: "(- a) div (- b) = a div b"
+ using div_mult_mult1 [of "- 1" a b] by simp
+
+lemma div_minus_right: "a div (- b) = (- a) div b"
+ using div_minus_minus [of "- a" b] by simp
+
+lemma div_minus1_right [simp]: "a div (- 1) = - a"
+ using div_minus_right [of a 1] by simp
+
+end
+
+
text \<open>Quotient and remainder in integral domains\<close>
class semidom_modulo = algebraic_semidom + semiring_modulo
--- a/src/HOL/Tools/Qelim/cooper_procedure.ML Wed Apr 10 15:10:43 2019 +0200
+++ b/src/HOL/Tools/Qelim/cooper_procedure.ML Wed Apr 10 15:45:16 2019 +0200
@@ -1,5 +1,3 @@
-(* Generated from Cooper.thy; DO NOT EDIT! *)
-
structure Cooper_Procedure : sig
datatype inta = Int_of_integer of int
val integer_of_int : inta -> int
@@ -89,25 +87,29 @@
val minus_int = {minus = minus_inta} : inta minus;
-fun sgn_integer k =
- (if k = (0 : IntInf.int) then (0 : IntInf.int)
- else (if k < (0 : IntInf.int) then (~1 : IntInf.int)
- else (1 : IntInf.int)));
-
fun apsnd f (x, y) = (x, f y);
fun divmod_integer k l =
(if k = (0 : IntInf.int) then ((0 : IntInf.int), (0 : IntInf.int))
- else (if l = (0 : IntInf.int) then ((0 : IntInf.int), k)
- else (apsnd o (fn a => fn b => a * b) o sgn_integer) l
- (if sgn_integer k = sgn_integer l
- then Integer.div_mod (abs k) (abs l)
- else let
- val (r, s) = Integer.div_mod (abs k) (abs l);
- in
- (if s = (0 : IntInf.int) then (~ r, (0 : IntInf.int))
- else (~ r - (1 : IntInf.int), abs l - s))
- end)));
+ else (if (0 : IntInf.int) < l
+ then (if (0 : IntInf.int) < k then Integer.div_mod (abs k) (abs l)
+ else let
+ val (r, s) = Integer.div_mod (abs k) (abs l);
+ in
+ (if s = (0 : IntInf.int) then (~ r, (0 : IntInf.int))
+ else (~ r - (1 : IntInf.int), l - s))
+ end)
+ else (if l = (0 : IntInf.int) then ((0 : IntInf.int), k)
+ else apsnd (fn a => ~ a)
+ (if k < (0 : IntInf.int)
+ then Integer.div_mod (abs k) (abs l)
+ else let
+ val (r, s) = Integer.div_mod (abs k) (abs l);
+ in
+ (if s = (0 : IntInf.int)
+ then (~ r, (0 : IntInf.int))
+ else (~ r - (1 : IntInf.int), ~ l - s))
+ end))));
fun fst (x1, x2) = x1;
@@ -506,6 +508,11 @@
semiring_no_zero_divisors_cancel_int}
: inta semidom_divide;
+type 'a algebraic_semidom =
+ {semidom_divide_algebraic_semidom : 'a semidom_divide};
+val semidom_divide_algebraic_semidom = #semidom_divide_algebraic_semidom :
+ 'a algebraic_semidom -> 'a semidom_divide;
+
type 'a semiring_modulo =
{comm_semiring_1_cancel_semiring_modulo : 'a comm_semiring_1_cancel,
modulo_semiring_modulo : 'a modulo};
@@ -515,20 +522,6 @@
val modulo_semiring_modulo = #modulo_semiring_modulo :
'a semiring_modulo -> 'a modulo;
-val semiring_modulo_int =
- {comm_semiring_1_cancel_semiring_modulo = comm_semiring_1_cancel_int,
- modulo_semiring_modulo = modulo_int}
- : inta semiring_modulo;
-
-type 'a algebraic_semidom =
- {semidom_divide_algebraic_semidom : 'a semidom_divide};
-val semidom_divide_algebraic_semidom = #semidom_divide_algebraic_semidom :
- 'a algebraic_semidom -> 'a semidom_divide;
-
-val algebraic_semidom_int =
- {semidom_divide_algebraic_semidom = semidom_divide_int} :
- inta algebraic_semidom;
-
type 'a semidom_modulo =
{algebraic_semidom_semidom_modulo : 'a algebraic_semidom,
semiring_modulo_semidom_modulo : 'a semiring_modulo};
@@ -537,6 +530,15 @@
val semiring_modulo_semidom_modulo = #semiring_modulo_semidom_modulo :
'a semidom_modulo -> 'a semiring_modulo;
+val algebraic_semidom_int =
+ {semidom_divide_algebraic_semidom = semidom_divide_int} :
+ inta algebraic_semidom;
+
+val semiring_modulo_int =
+ {comm_semiring_1_cancel_semiring_modulo = comm_semiring_1_cancel_int,
+ modulo_semiring_modulo = modulo_int}
+ : inta semiring_modulo;
+
val semidom_modulo_int =
{algebraic_semidom_semidom_modulo = algebraic_semidom_int,
semiring_modulo_semidom_modulo = semiring_modulo_int}
@@ -1153,15 +1155,15 @@
fun abs_int i = (if less_int i zero_inta then uminus_int i else i);
fun dvd (A1_, A2_) a b =
- eq A2_
- (modulo ((modulo_semiring_modulo o semiring_modulo_semidom_modulo) A1_) b a)
+ eq A1_
+ (modulo ((modulo_semiring_modulo o semiring_modulo_semidom_modulo) A2_) b a)
(zero ((zero_mult_zero o mult_zero_semiring_0 o semiring_0_semiring_1 o
semiring_1_comm_semiring_1 o
comm_semiring_1_comm_semiring_1_cancel o
comm_semiring_1_cancel_semidom o semidom_semidom_divide o
semidom_divide_algebraic_semidom o
algebraic_semidom_semidom_modulo)
- A1_));
+ A2_));
fun nummul i (C j) = C (times_inta i j)
| nummul i (CN (n, c, t)) = CN (n, times_inta c i, nummul i t)
@@ -1175,78 +1177,78 @@
fun less_eq_nat m n = integer_of_nat m <= integer_of_nat n;
-fun numadd (CN (n1, c1, r1), CN (n2, c2, r2)) =
+fun numadd (CN (n1, c1, r1)) (CN (n2, c2, r2)) =
(if equal_nat n1 n2
then let
val c = plus_inta c1 c2;
in
- (if equal_inta c zero_inta then numadd (r1, r2)
- else CN (n1, c, numadd (r1, r2)))
+ (if equal_inta c zero_inta then numadd r1 r2
+ else CN (n1, c, numadd r1 r2))
end
else (if less_eq_nat n1 n2
- then CN (n1, c1, numadd (r1, Add (Mul (c2, Bound n2), r2)))
- else CN (n2, c2, numadd (Add (Mul (c1, Bound n1), r1), r2))))
- | numadd (CN (n1, c1, r1), C dd) = CN (n1, c1, numadd (r1, C dd))
- | numadd (CN (n1, c1, r1), Bound de) = CN (n1, c1, numadd (r1, Bound de))
- | numadd (CN (n1, c1, r1), Neg di) = CN (n1, c1, numadd (r1, Neg di))
- | numadd (CN (n1, c1, r1), Add (dj, dk)) =
- CN (n1, c1, numadd (r1, Add (dj, dk)))
- | numadd (CN (n1, c1, r1), Sub (dl, dm)) =
- CN (n1, c1, numadd (r1, Sub (dl, dm)))
- | numadd (CN (n1, c1, r1), Mul (dn, doa)) =
- CN (n1, c1, numadd (r1, Mul (dn, doa)))
- | numadd (C w, CN (n2, c2, r2)) = CN (n2, c2, numadd (C w, r2))
- | numadd (Bound x, CN (n2, c2, r2)) = CN (n2, c2, numadd (Bound x, r2))
- | numadd (Neg ac, CN (n2, c2, r2)) = CN (n2, c2, numadd (Neg ac, r2))
- | numadd (Add (ad, ae), CN (n2, c2, r2)) =
- CN (n2, c2, numadd (Add (ad, ae), r2))
- | numadd (Sub (af, ag), CN (n2, c2, r2)) =
- CN (n2, c2, numadd (Sub (af, ag), r2))
- | numadd (Mul (ah, ai), CN (n2, c2, r2)) =
- CN (n2, c2, numadd (Mul (ah, ai), r2))
- | numadd (C b1, C b2) = C (plus_inta b1 b2)
- | numadd (C aj, Bound bi) = Add (C aj, Bound bi)
- | numadd (C aj, Neg bm) = Add (C aj, Neg bm)
- | numadd (C aj, Add (bn, bo)) = Add (C aj, Add (bn, bo))
- | numadd (C aj, Sub (bp, bq)) = Add (C aj, Sub (bp, bq))
- | numadd (C aj, Mul (br, bs)) = Add (C aj, Mul (br, bs))
- | numadd (Bound ak, C cf) = Add (Bound ak, C cf)
- | numadd (Bound ak, Bound cg) = Add (Bound ak, Bound cg)
- | numadd (Bound ak, Neg ck) = Add (Bound ak, Neg ck)
- | numadd (Bound ak, Add (cl, cm)) = Add (Bound ak, Add (cl, cm))
- | numadd (Bound ak, Sub (cn, co)) = Add (Bound ak, Sub (cn, co))
- | numadd (Bound ak, Mul (cp, cq)) = Add (Bound ak, Mul (cp, cq))
- | numadd (Neg ao, C en) = Add (Neg ao, C en)
- | numadd (Neg ao, Bound eo) = Add (Neg ao, Bound eo)
- | numadd (Neg ao, Neg et) = Add (Neg ao, Neg et)
- | numadd (Neg ao, Add (eu, ev)) = Add (Neg ao, Add (eu, ev))
- | numadd (Neg ao, Sub (ew, ex)) = Add (Neg ao, Sub (ew, ex))
- | numadd (Neg ao, Mul (ey, ez)) = Add (Neg ao, Mul (ey, ez))
- | numadd (Add (ap, aq), C fm) = Add (Add (ap, aq), C fm)
- | numadd (Add (ap, aq), Bound fna) = Add (Add (ap, aq), Bound fna)
- | numadd (Add (ap, aq), Neg fr) = Add (Add (ap, aq), Neg fr)
- | numadd (Add (ap, aq), Add (fs, ft)) = Add (Add (ap, aq), Add (fs, ft))
- | numadd (Add (ap, aq), Sub (fu, fv)) = Add (Add (ap, aq), Sub (fu, fv))
- | numadd (Add (ap, aq), Mul (fw, fx)) = Add (Add (ap, aq), Mul (fw, fx))
- | numadd (Sub (ar, asa), C gk) = Add (Sub (ar, asa), C gk)
- | numadd (Sub (ar, asa), Bound gl) = Add (Sub (ar, asa), Bound gl)
- | numadd (Sub (ar, asa), Neg gp) = Add (Sub (ar, asa), Neg gp)
- | numadd (Sub (ar, asa), Add (gq, gr)) = Add (Sub (ar, asa), Add (gq, gr))
- | numadd (Sub (ar, asa), Sub (gs, gt)) = Add (Sub (ar, asa), Sub (gs, gt))
- | numadd (Sub (ar, asa), Mul (gu, gv)) = Add (Sub (ar, asa), Mul (gu, gv))
- | numadd (Mul (at, au), C hi) = Add (Mul (at, au), C hi)
- | numadd (Mul (at, au), Bound hj) = Add (Mul (at, au), Bound hj)
- | numadd (Mul (at, au), Neg hn) = Add (Mul (at, au), Neg hn)
- | numadd (Mul (at, au), Add (ho, hp)) = Add (Mul (at, au), Add (ho, hp))
- | numadd (Mul (at, au), Sub (hq, hr)) = Add (Mul (at, au), Sub (hq, hr))
- | numadd (Mul (at, au), Mul (hs, ht)) = Add (Mul (at, au), Mul (hs, ht));
+ then CN (n1, c1, numadd r1 (Add (Mul (c2, Bound n2), r2)))
+ else CN (n2, c2, numadd (Add (Mul (c1, Bound n1), r1)) r2)))
+ | numadd (CN (n1, c1, r1)) (C v) = CN (n1, c1, numadd r1 (C v))
+ | numadd (CN (n1, c1, r1)) (Bound v) = CN (n1, c1, numadd r1 (Bound v))
+ | numadd (CN (n1, c1, r1)) (Neg v) = CN (n1, c1, numadd r1 (Neg v))
+ | numadd (CN (n1, c1, r1)) (Add (v, va)) =
+ CN (n1, c1, numadd r1 (Add (v, va)))
+ | numadd (CN (n1, c1, r1)) (Sub (v, va)) =
+ CN (n1, c1, numadd r1 (Sub (v, va)))
+ | numadd (CN (n1, c1, r1)) (Mul (v, va)) =
+ CN (n1, c1, numadd r1 (Mul (v, va)))
+ | numadd (C v) (CN (n2, c2, r2)) = CN (n2, c2, numadd (C v) r2)
+ | numadd (Bound v) (CN (n2, c2, r2)) = CN (n2, c2, numadd (Bound v) r2)
+ | numadd (Neg v) (CN (n2, c2, r2)) = CN (n2, c2, numadd (Neg v) r2)
+ | numadd (Add (v, va)) (CN (n2, c2, r2)) =
+ CN (n2, c2, numadd (Add (v, va)) r2)
+ | numadd (Sub (v, va)) (CN (n2, c2, r2)) =
+ CN (n2, c2, numadd (Sub (v, va)) r2)
+ | numadd (Mul (v, va)) (CN (n2, c2, r2)) =
+ CN (n2, c2, numadd (Mul (v, va)) r2)
+ | numadd (C b1) (C b2) = C (plus_inta b1 b2)
+ | numadd (C v) (Bound va) = Add (C v, Bound va)
+ | numadd (C v) (Neg va) = Add (C v, Neg va)
+ | numadd (C v) (Add (va, vb)) = Add (C v, Add (va, vb))
+ | numadd (C v) (Sub (va, vb)) = Add (C v, Sub (va, vb))
+ | numadd (C v) (Mul (va, vb)) = Add (C v, Mul (va, vb))
+ | numadd (Bound v) (C va) = Add (Bound v, C va)
+ | numadd (Bound v) (Bound va) = Add (Bound v, Bound va)
+ | numadd (Bound v) (Neg va) = Add (Bound v, Neg va)
+ | numadd (Bound v) (Add (va, vb)) = Add (Bound v, Add (va, vb))
+ | numadd (Bound v) (Sub (va, vb)) = Add (Bound v, Sub (va, vb))
+ | numadd (Bound v) (Mul (va, vb)) = Add (Bound v, Mul (va, vb))
+ | numadd (Neg v) (C va) = Add (Neg v, C va)
+ | numadd (Neg v) (Bound va) = Add (Neg v, Bound va)
+ | numadd (Neg v) (Neg va) = Add (Neg v, Neg va)
+ | numadd (Neg v) (Add (va, vb)) = Add (Neg v, Add (va, vb))
+ | numadd (Neg v) (Sub (va, vb)) = Add (Neg v, Sub (va, vb))
+ | numadd (Neg v) (Mul (va, vb)) = Add (Neg v, Mul (va, vb))
+ | numadd (Add (v, va)) (C vb) = Add (Add (v, va), C vb)
+ | numadd (Add (v, va)) (Bound vb) = Add (Add (v, va), Bound vb)
+ | numadd (Add (v, va)) (Neg vb) = Add (Add (v, va), Neg vb)
+ | numadd (Add (v, va)) (Add (vb, vc)) = Add (Add (v, va), Add (vb, vc))
+ | numadd (Add (v, va)) (Sub (vb, vc)) = Add (Add (v, va), Sub (vb, vc))
+ | numadd (Add (v, va)) (Mul (vb, vc)) = Add (Add (v, va), Mul (vb, vc))
+ | numadd (Sub (v, va)) (C vb) = Add (Sub (v, va), C vb)
+ | numadd (Sub (v, va)) (Bound vb) = Add (Sub (v, va), Bound vb)
+ | numadd (Sub (v, va)) (Neg vb) = Add (Sub (v, va), Neg vb)
+ | numadd (Sub (v, va)) (Add (vb, vc)) = Add (Sub (v, va), Add (vb, vc))
+ | numadd (Sub (v, va)) (Sub (vb, vc)) = Add (Sub (v, va), Sub (vb, vc))
+ | numadd (Sub (v, va)) (Mul (vb, vc)) = Add (Sub (v, va), Mul (vb, vc))
+ | numadd (Mul (v, va)) (C vb) = Add (Mul (v, va), C vb)
+ | numadd (Mul (v, va)) (Bound vb) = Add (Mul (v, va), Bound vb)
+ | numadd (Mul (v, va)) (Neg vb) = Add (Mul (v, va), Neg vb)
+ | numadd (Mul (v, va)) (Add (vb, vc)) = Add (Mul (v, va), Add (vb, vc))
+ | numadd (Mul (v, va)) (Sub (vb, vc)) = Add (Mul (v, va), Sub (vb, vc))
+ | numadd (Mul (v, va)) (Mul (vb, vc)) = Add (Mul (v, va), Mul (vb, vc));
-fun numsub s t = (if equal_numa s t then C zero_inta else numadd (s, numneg t));
+fun numsub s t = (if equal_numa s t then C zero_inta else numadd s (numneg t));
fun simpnum (C j) = C j
| simpnum (Bound n) = CN (n, one_inta, C zero_inta)
| simpnum (Neg t) = numneg (simpnum t)
- | simpnum (Add (t, s)) = numadd (simpnum t, simpnum s)
+ | simpnum (Add (t, s)) = numadd (simpnum t) (simpnum s)
| simpnum (Sub (t, s)) = numsub (simpnum t) (simpnum s)
| simpnum (Mul (i, t)) =
(if equal_inta i zero_inta then C zero_inta else nummul i (simpnum t))
@@ -1356,7 +1358,7 @@
in
(case aa
of C v =>
- (if dvd (semidom_modulo_int, equal_int) i v then T
+ (if dvd (equal_int, semidom_modulo_int) i v then T
else F)
| Bound _ => Dvd (i, aa) | CN (_, _, _) => Dvd (i, aa)
| Neg _ => Dvd (i, aa) | Add (_, _) => Dvd (i, aa)
@@ -1370,7 +1372,7 @@
in
(case aa
of C v =>
- (if not (dvd (semidom_modulo_int, equal_int) i v) then T
+ (if not (dvd (equal_int, semidom_modulo_int) i v) then T
else F)
| Bound _ => NDvd (i, aa) | CN (_, _, _) => NDvd (i, aa)
| Neg _ => NDvd (i, aa) | Add (_, _) => NDvd (i, aa)