# HG changeset patch
# User paulson
# Date 1554840348 -3600
# Node ID c4f2cac288d27da17567dbc75ef8b96504695efe
# Parent  a93e6472ac9c3b050c966f29bc951aee44f1c4e4# Parent  e8f4ce87012b82dc229541ff0da60b6981f60593
merged

diff -r a93e6472ac9c -r c4f2cac288d2 src/HOL/Algebra/Group.thy
--- a/src/HOL/Algebra/Group.thy	Tue Apr 09 16:59:00 2019 +0000
+++ b/src/HOL/Algebra/Group.thy	Tue Apr 09 21:05:48 2019 +0100
@@ -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)
diff -r a93e6472ac9c -r c4f2cac288d2 src/HOL/Homology/Brouwer_Degree.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Homology/Brouwer_Degree.thy	Tue Apr 09 21:05:48 2019 +0100
@@ -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
diff -r a93e6472ac9c -r c4f2cac288d2 src/HOL/Homology/Homology.thy
--- a/src/HOL/Homology/Homology.thy	Tue Apr 09 16:59:00 2019 +0000
+++ b/src/HOL/Homology/Homology.thy	Tue Apr 09 21:05:48 2019 +0100
@@ -1,6 +1,5 @@
 theory Homology
-  imports
-  Simplices
+  imports Brouwer_Degree 
 begin
 
 end
diff -r a93e6472ac9c -r c4f2cac288d2 src/HOL/Homology/Homology_Groups.thy
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Homology/Homology_Groups.thy	Tue Apr 09 21:05:48 2019 +0100
@@ -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
+
+
diff -r a93e6472ac9c -r c4f2cac288d2 src/HOL/Homology/Simplices.thy
--- a/src/HOL/Homology/Simplices.thy	Tue Apr 09 16:59:00 2019 +0000
+++ b/src/HOL/Homology/Simplices.thy	Tue Apr 09 21:05:48 2019 +0100
@@ -4,6 +4,7 @@
   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"
@@ -2781,5 +2782,501 @@
   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