From 07a0e2f2a1cc7941f0ae03e3f9ce458d9d5a465d Mon Sep 17 00:00:00 2001 From: CharlesCNorton Date: Sun, 14 Jun 2026 19:49:04 -0400 Subject: [PATCH 01/12] Classify short exact sequences by maps of Eilenberg-Mac Lane spaces --- theories/Algebra/AbGroups/AbInjective.v | 30 + theories/Algebra/AbGroups/Cohomology.v | 88 + theories/Algebra/AbSES/Classification.v | 1157 +++++++++ theories/Algebra/AbSES/HigherExt.v | 2366 ++++++++++++++++++ theories/Algebra/AbSES/HigherExtMorphism.v | 153 ++ theories/Algebra/AbSES/HigherExtResolution.v | 70 + theories/Algebra/AbSES/InjectiveExt.v | 57 + theories/Algebra/AbSES/LoopGroup.v | 152 ++ theories/Algebra/AbSES/Pullback.v | 15 + theories/Algebra/AbSES/Pushout.v | 21 + theories/Algebra/AbSES/SixTerm.v | 20 +- theories/Algebra/Rings/Bezout.v | 128 + theories/Algebra/Rings/FinitelyPresented.v | 29 + theories/Algebra/Rings/FreeModule.v | 673 +++++ theories/Algebra/Rings/GroupRing.v | 180 ++ theories/Algebra/Rings/Module.v | 59 +- theories/Algebra/Rings/ZBezout.v | 110 + theories/Homotopy/ClassifyingSpace.v | 33 + theories/Homotopy/EMSpace.v | 405 ++- theories/Homotopy/ExactSequence.v | 164 ++ theories/Pointed/pFiber.v | 68 +- theories/Truncations/Connectedness.v | 14 + 22 files changed, 5969 insertions(+), 23 deletions(-) create mode 100644 theories/Algebra/AbGroups/AbInjective.v create mode 100644 theories/Algebra/AbGroups/Cohomology.v create mode 100644 theories/Algebra/AbSES/Classification.v create mode 100644 theories/Algebra/AbSES/HigherExt.v create mode 100644 theories/Algebra/AbSES/HigherExtMorphism.v create mode 100644 theories/Algebra/AbSES/HigherExtResolution.v create mode 100644 theories/Algebra/AbSES/InjectiveExt.v create mode 100644 theories/Algebra/AbSES/LoopGroup.v create mode 100644 theories/Algebra/Rings/Bezout.v create mode 100644 theories/Algebra/Rings/FinitelyPresented.v create mode 100644 theories/Algebra/Rings/FreeModule.v create mode 100644 theories/Algebra/Rings/GroupRing.v create mode 100644 theories/Algebra/Rings/ZBezout.v diff --git a/theories/Algebra/AbGroups/AbInjective.v b/theories/Algebra/AbGroups/AbInjective.v new file mode 100644 index 00000000000..144f85e24b4 --- /dev/null +++ b/theories/Algebra/AbGroups/AbInjective.v @@ -0,0 +1,30 @@ +From HoTT Require Import Basics Types AbelianGroup AbPushout + WildCat.Core Modalities.ReflectiveSubuniverse Truncations.Core. + +(** * Injective abelian groups *) + +(** We define injective abelian groups and show that [I] is injective if and only if every monomorphism [I -> B] merely splits. This is dual to [AbProjective]. *) + +(** An abelian group [I] is injective if for any map [f : A -> I] and embedding [m : A -> B], there merely exists an extension [g : B -> I] with [g $o m == f]. *) +Class IsAbInjective@{u +} (I : AbGroup@{u}) : Type := + isabinjective : forall (A B : AbGroup@{u}), forall (m : A $-> B), + forall (f : A $-> I), IsEmbedding m -> merely (exists g : B $-> I, g $o m == f). + +(** An abelian group is injective iff monos out of it merely split. *) +Proposition iff_isabinjective_embeddings_split `{Univalence} (I : AbGroup) + : IsAbInjective I + <-> (forall B, forall m : I $-> B, IsEmbedding m -> + merely (exists r : B $-> I, r $o m == grp_homo_id)). +Proof. + split. + - intros hinj B m. + apply hinj. + - intros hsplit A B m f hm. + pose proof (s := hsplit (ab_pushout f m) ab_pushout_inl + (ab_pushout_embedding_inl f m)). + strip_truncations. + destruct s as [r h]. + refine (tr (r $o ab_pushout_inr; _)); intro a. + refine (ap r (ab_pushout_commsq a)^ @ _). + exact (h (f a)). +Defined. diff --git a/theories/Algebra/AbGroups/Cohomology.v b/theories/Algebra/AbGroups/Cohomology.v new file mode 100644 index 00000000000..c8e96949f59 --- /dev/null +++ b/theories/Algebra/AbGroups/Cohomology.v @@ -0,0 +1,88 @@ +From HoTT Require Import Basics Types Truncations.Core. +From HoTT.WildCat Require Import Core. +Require Import AbGroups.AbelianGroup. +Require Import Groups.Group Groups.Subgroup Groups.QuotientGroup. + +Local Open Scope nat_scope. +Local Open Scope mc_add_scope. + +(** * Cochain complexes of abelian groups and their cohomology *) + +(** A cochain complex is a sequence of abelian groups with differentials whose + consecutive composites vanish. *) +Record CochainComplex : Type := { + cc_carrier : nat -> AbGroup ; + cc_diff : forall n, cc_carrier n $-> cc_carrier (S n) ; + cc_iscomplex : forall n, cc_diff (S n) $o cc_diff n == grp_homo_const +}. + +(** Each differential corestricts to the kernel of the next, since the + composite vanishes. *) +Definition cc_diff_corec (C : CochainComplex) (n : nat) + : cc_carrier C n $-> ab_kernel (cc_diff C (S n)) + := grp_kernel_corec (cc_diff C n) (cc_iscomplex C n). + +(** The [n]-th cohomology group: the kernel of the [n]-th differential modulo + the image of the previous one. *) +Definition cohomology (C : CochainComplex) (n : nat) : AbGroup + := match n with + | O => ab_kernel (cc_diff C 0) + | S n => ab_cokernel (cc_diff_corec C n) + end. + +(** In degree zero the cohomology is the kernel of the first differential. *) +Definition cohomology_zero (C : CochainComplex) + : cohomology C 0 = ab_kernel (cc_diff C 0) + := idpath. + +(** ** Morphisms of cochain complexes and functoriality of cohomology *) + +(** A morphism of cochain complexes is a degreewise map commuting with the + differentials. *) +Record CochainMap (C D : CochainComplex) : Type := { + cm_map : forall n, cc_carrier C n $-> cc_carrier D n ; + cm_natural : forall n, cm_map (S n) $o cc_diff C n == cc_diff D n $o cm_map n +}. + +Arguments cm_map {C D}. +Arguments cm_natural {C D}. + +Section Functoriality. + Context `{Funext} {C D : CochainComplex} (f : CochainMap C D). + + (** A cochain map restricts to the kernels of the differentials. *) + Definition cm_kernel (n : nat) + : ab_kernel (cc_diff C n) $-> ab_kernel (cc_diff D n). + Proof. + snapply grp_kernel_corec. + - exact (grp_homo_compose (cm_map f n) (subgroup_incl _)). + - intro x. + lhs exact (cm_natural f n (subgroup_incl _ x))^. + lhs napply (ap (cm_map f (S n)) x.2). + apply grp_homo_unit. + Defined. + + (** The kernel map commutes with the corestricted differentials. *) + Definition cm_kernel_natural (n : nat) (c : cc_carrier C n) + : cm_kernel (S n) (cc_diff_corec C n c) = cc_diff_corec D n (cm_map f n c). + Proof. + apply path_sigma_hprop. + exact (cm_natural f n c). + Defined. + + (** A cochain map induces a map on cohomology in every degree. *) + Definition cohomology_functor (n : nat) + : cohomology C n $-> cohomology D n. + Proof. + destruct n as [|n]. + - exact (cm_kernel 0). + - snapply quotient_abgroup_rec. + + exact (grp_homo_compose grp_quotient_map (cm_kernel (S n))). + + intros y hy; strip_truncations; destruct hy as [c hc]. + lhs napply (ap (fun z => grp_quotient_map (cm_kernel (S n) z)) hc^). + lhs napply (ap grp_quotient_map (cm_kernel_natural n c)). + napply grp_quotient_map_trivial. + exact (grp_image_in (cc_diff_corec D n) (cm_map f n c)). + Defined. + +End Functoriality. diff --git a/theories/Algebra/AbSES/Classification.v b/theories/Algebra/AbSES/Classification.v new file mode 100644 index 00000000000..20c11363842 --- /dev/null +++ b/theories/Algebra/AbSES/Classification.v @@ -0,0 +1,1157 @@ +From HoTT Require Import Basics Types Truncations.Core + Truncations.Connectedness Truncations.SeparatedTrunc. +From HoTT.WildCat Require Import Core Equiv. +Require Import Pointed. +Require Import AbelianGroup AbHom. +Require Import Algebra.AbSES.Core Algebra.AbSES.Ext. +Require Import Universes.Smallness. +Require Import Homotopy.HomotopyGroup Homotopy.EMSpace Homotopy.ExactSequence. +Require Import Groups.Group. +Require Import HSet. +Require Import Modalities.Identity Modalities.Descent. + +(** * Classification of short exact sequences + + Following Christensen and Flaten, "Ext groups in homotopy type theory" + (arXiv:2305.09639, Theorem 2.2.2), short exact sequences [A -> E -> B] + of abelian groups are classified by pointed maps [K(B,2) ->* K(A,3)]. + + Applying [K(-,n.+1)] to a short exact sequence yields a fiber sequence + of Eilenberg-Mac Lane spaces, whose connecting map is the classifying + map [abses_classifying_map]. Conversely, the homotopy groups of the + fiber of a pointed map recover a short exact sequence [abses_pfiber]. + We show these are mutually inverse, giving the equivalence + [equiv_abses_classifying_map]. We deduce that [Ext B A] is the set of + components of the classifying mapping type, and that [AbSES B A] and + [Ext B A] are essentially small. *) + +Local Open Scope pointed_scope. + +(** ** Vanishing of homotopy groups *) + +(** Homotopy groups below the connectivity vanish. *) +Definition contr_pi_isconnected `{Univalence} (n : nat) (X : pType) + `{IsConnected n X} + : Contr (Pi n X). +Proof. + revert X H0; induction n; intros X H0. + - exact H0. + - nrefine (contr_equiv' (Pi n (loops X)) _). + 1: exact (pi_loops n X)^-1*. + napply IHn. + rapply isconnected_loops. +Defined. + +(** A successor-connectivity criterion: an [n.+1]-connected type with + trivial [Pi n.+2] is [n.+2]-connected. *) +Definition isconnected_succ_contr_pi `{Univalence} (n : nat) (X : pType) + `{IsConnected n.+1 X} (c : Contr (Pi n.+2 X)) + : IsConnected n.+2 X. +Proof. + pose proof (isconnected_trunc n.+1 n.+2 (X := X)). + nrefine (contr_equiv' K(Build_AbGroup (Pi n.+2 (pTr n.+2 X)) _, n.+2) _). + 1: exact (pequiv_em_connected_truncated (pTr n.+2 X) n.+1). + napply contr_em_contr. + nrefine (contr_equiv' (Pi n.+2 X) _). + 1: exact (grp_iso_pi_Tr n.+1 X). + exact c. + Unshelve. + all: exact _. +Defined. + +(** ** Injectivity of homotopy groups of fiber inclusions + + If the [n.+1]-st homotopy group of the double fiber of [g] vanishes, + then [Pi n.+1] of the fiber inclusion of [g] is an embedding. *) +Instance isembedding_pi_pfib `{Univalence} {X Y : pType} (g : X ->* Y) + (n : nat) `{Contr (Pi n.+1 (pfiber (pfib g)))} + : IsEmbedding (fmap (Pi n.+1) (pfib g)). +Proof. + snapply isembedding_istrivial_kernel. + intros z w. + pose proof (c := @center _ + (conn_map_isexact + (i := fmap (pTr 0) (fmap (iterated_loops n.+1) (pfib (pfib g)))) + (f := fmap (pTr 0) (fmap (iterated_loops n.+1) (pfib g))) + (z; w))). + strip_truncations. + destruct c as [u q]. + refine ((ap pr1 q)^ @ _). + refine (ap _ (path_contr u (point _)) @ _). + exact (point_eq (fmap (pTr 0) (fmap (iterated_loops n.+1) + (pfib (pfib g))))). +Defined. + +Section EMFiberSequence. + Context `{Univalence} {B A : AbGroup@{u}} (E : AbSES B A) (n : nat). + + (** Applying [K(-,n.+1)] to a short exact sequence yields a complex. *) + Definition iscomplex_em_abses + : IsComplex (em_fmap (inclusion E) n.+1) (em_fmap (projection E) n.+1). + Proof. + refine ((em_fmap_compose (inclusion E) (projection E) n.+1)^* @* _). + refine (phomotopy_path + (ap (fun h => em_fmap h n.+1) (_ : _ = grp_homo_const)) + @* em_fmap_const n.+1). + apply equiv_path_grouphomomorphism; intro a. + exact (iscomplex_abses E a). + Defined. + + (** The [n.+1]-st homotopy group of the double fiber of + [em_fmap (projection E) n.+1] vanishes. *) + Local Instance contr_pi_pfiber_pfib + : Contr (Pi n.+1 (pfiber (pfib (em_fmap (projection E) n.+1)))). + Proof. + nrefine (contr_equiv' (Pi n.+2 K(B, n.+1)) _). + 1: exact (grp_iso_compose + (groupiso_pi_functor n + (pequiv_inverse (pfiber2_loops (em_fmap (projection E) n.+1)))) + (groupiso_pi_loops n K(B, n.+1))). + exact (contr_pi_succ_istrunc n K(B, n.+1)). + Defined. + + (** [Pi n.+1] of the comparison map [cxfib] is surjective, by exactness + of [A -> E -> B] transported along [pi_em_fmap]. *) + Local Definition issurj_pi_cxfib + : IsSurjection (fmap (Pi n.+1) (cxfib iscomplex_em_abses)). + Proof. + intro y. + rapply contr_inhabited_hprop. + (* The image of [y] in [Pi n.+1 K(E, n.+1)] is killed by the projection. *) + pose (x := fmap (Pi n.+1) (pfib (em_fmap (projection E) n.+1)) y). + pose proof (w := cx_isexact + (i := fmap (pTr 0) (fmap (iterated_loops n.+1) + (pfib (em_fmap (projection E) n.+1)))) + (f := fmap (pTr 0) (fmap (iterated_loops n.+1) + (em_fmap (projection E) n.+1))) + y). + (* Hence its preimage in [E] is killed by [projection E]. *) + pose (ee := (equiv_g_pi_n_em E n)^-1 x). + assert (pe : projection E ee = mon_unit). + { apply (equiv_inj (equiv_g_pi_n_em B n)). + refine ((pi_em_fmap (projection E) n ee)^ @ _). + refine (ap (fmap (Pi n.+1) (em_fmap (projection E) n.+1)) + (eisretr (equiv_g_pi_n_em E n) x) @ _). + refine (w @ _). + exact (grp_homo_unit (equiv_g_pi_n_em B n))^. } + (* By exactness, [ee] merely comes from [A]. *) + pose proof (m := @center _ (conn_map_isexact + (i := inclusion E) (f := projection E) (ee; pe))). + strip_truncations. + destruct m as [a q]. + apply tr. + exists (equiv_g_pi_n_em A n a). + (* The two candidates agree after the embedding [pi (pfib _)]. *) + napply (isinj_embedding _ + (isembedding_pi_pfib (em_fmap (projection E) n.+1) n)). + 1: exact _. + refine ((fmap_comp (Pi n.+1) (cxfib iscomplex_em_abses) + (pfib (em_fmap (projection E) n.+1)) _)^ @ _). + refine (fmap2 (Pi n.+1) (pfib_cxfib _) _ @ _). + refine (pi_em_fmap (inclusion E) n a @ _). + exact (ap (equiv_g_pi_n_em E n) (ap pr1 q) @ eisretr _ x). + Defined. + + (** Therefore the comparison map is an equivalence: it is an isomorphism + on [Pi n.+1], and both sides are [n]-connected and [n.+1]-truncated. *) + Local Instance isequiv_pi_cxfib + : IsEquiv (fmap (Pi n.+1) (cxfib iscomplex_em_abses)). + Proof. + apply isequiv_surj_emb. + 1: exact issurj_pi_cxfib. + snapply isembedding_istrivial_kernel. + intros z w. + (* [z] is killed by [Pi n.+1] of [em_fmap (inclusion E) n.+1]. *) + assert (wi : fmap (Pi n.+1) (em_fmap (inclusion E) n.+1) z = mon_unit). + { refine ((fmap2 (Pi n.+1) (pfib_cxfib _) z)^ @ _). + refine (fmap_comp (Pi n.+1) (cxfib iscomplex_em_abses) + (pfib (em_fmap (projection E) n.+1)) z @ _). + refine (ap (fmap (Pi n.+1) (pfib (em_fmap (projection E) n.+1))) w @ _). + apply grp_homo_unit. } + (* Hence [z] vanishes, since the inclusion is an embedding. *) + pose (a := (equiv_g_pi_n_em A n)^-1 z). + refine ((eisretr (equiv_g_pi_n_em A n) z)^ @ _). + refine (ap (equiv_g_pi_n_em A n) (_ : a = mon_unit) @ _). + 2: apply grp_homo_unit. + rapply (isinj_embedding (inclusion E)). + refine (_ @ (grp_homo_unit (inclusion E))^). + apply (equiv_inj (equiv_g_pi_n_em E n)). + refine ((pi_em_fmap (inclusion E) n a)^ @ _). + refine (ap (fmap (Pi n.+1) (em_fmap (inclusion E) n.+1)) + (eisretr (equiv_g_pi_n_em A n) z) @ _). + refine (wi @ _). + exact (grp_homo_unit (equiv_g_pi_n_em E n))^. + Defined. + + (** Both sides of the comparison map are [n]-connected and + [n.+1]-truncated, so it is an equivalence. *) + Local Instance isequiv_cxfib_em : IsEquiv (cxfib iscomplex_em_abses). + Proof. + pose proof (isconnmap_em_fmap (projection E) n (point _)). + (* The identification of [A] with the fiber's homotopy group. *) + pose (psi := grp_iso_compose + (Build_GroupIsomorphism _ _ _ isequiv_pi_cxfib) + (equiv_g_pi_n_em A n)). + (* The induced equivalence onto the fiber. *) + pose (omega := pequiv_em_connected_truncated + (pfiber (em_fmap (projection E) n.+1)) n + o*E pequiv_em_group_iso n.+1 psi). + (* The conjugated comparison map is [em_fmap] of an isomorphism. *) + pose (chi := grp_iso_compose (grp_iso_inverse (equiv_g_pi_n_em A n)) + (grp_iso_compose (groupiso_pi_functor n (pequiv_inverse omega)) + (grp_iso_compose (Build_GroupIsomorphism _ _ _ isequiv_pi_cxfib) + (equiv_g_pi_n_em A n)))). + assert (q : em_fmap chi n.+1 + = pequiv_inverse omega o* cxfib iscomplex_em_abses). + { apply path_em_pmap_pi; intro u. + refine (ap (fmap (Pi n.+1) (em_fmap chi n.+1)) + (eisretr (equiv_g_pi_n_em A n) u)^ @ _). + refine (pi_em_fmap chi n ((equiv_g_pi_n_em A n)^-1 u) @ _). + refine (eisretr (equiv_g_pi_n_em A n) _ @ _). + refine (ap (fun v => fmap (Pi n.+1) (pequiv_inverse omega) + (fmap (Pi n.+1) (cxfib iscomplex_em_abses) v)) + (eisretr (equiv_g_pi_n_em A n) u) @ _). + exact (fmap_comp (Pi n.+1) (cxfib iscomplex_em_abses) + (pequiv_inverse omega) u)^. + } + snapply (isequiv_homotopic + (omega o (pequiv_inverse omega o* cxfib iscomplex_em_abses))). + - napply isequiv_compose. + 2: exact _. + exact (transport (fun (g : _ ->* _) => IsEquiv g) q + (pointed_isequiv _ _ (pequiv_em_fmap chi n.+1))). + - intro x; exact (eisretr omega _). + Defined. + + (** [K(-, n.+1)] sends short exact sequences of abelian groups to fiber + sequences of Eilenberg-Mac Lane spaces. *) + #[export] Instance isexact_em_abses + : IsExact purely (em_fmap (inclusion E) n.+1) + (em_fmap (projection E) n.+1). + Proof. + exists iscomplex_em_abses. + rapply conn_map_isequiv. + Defined. + +End EMFiberSequence. + +(** ** The classifying map of a short exact sequence + + The connecting map of the fiber sequence [K(A,3) -> K(E,3) -> K(B,3)], + expressed as a pointed map [K(B,2) ->* K(A,3)]. *) +Definition abses_classifying_map `{Univalence} {B A : AbGroup@{u}} + (E : AbSES B A) + : K(B, 2) ->* K(A, 3) + := connecting_map (em_fmap (inclusion E) 3) (em_fmap (projection E) 3) + o* pequiv_loops_em_em B 2. + +(** ** The short exact sequence of a pointed map + + Conversely, a pointed map [f : K(B,2) ->* K(A,3)] yields a short exact + sequence [A -> Pi 2 (pfiber f) -> B], by rotating the fiber sequence of + [f] and taking homotopy groups. *) + +(** The retraction law for [grp_iso_inverse], stated so that both sides + use the group-homomorphism spelling. Unifying the equivalence-inverse + and [grp_iso_inverse] spellings on large terms is expensive, so we + bridge them once here, on an abstract isomorphism. *) +Local Definition grp_iso_retr {G H : Group} (e : GroupIsomorphism G H) + (x : H) + : e (grp_iso_inverse e x) = x. +Proof. + destruct e; exact (eisretr _ x). +Defined. + +(** The companion section law. *) +Local Definition grp_iso_sect {G H : Group} (e : GroupIsomorphism G H) + (x : G) + : grp_iso_inverse e (e x) = x. +Proof. + destruct e; exact (eissect _ x). +Defined. + +Section AbSESPfiber. + Context `{Univalence} {B A : AbGroup@{u}} (n : nat) + (f : K(B, n.+2) ->* K(A, n.+3)). + + (** The middle group: [Pi n.+2] of the fiber, abelian by + Eckmann-Hilton. *) + Definition abgroup_pi_pfiber : AbGroup + := Build_AbGroup (Pi n.+2 (pfiber f)) _. + + (** The inclusion, through the rotated fiber sequence + [loops K(A,n+3) -> pfiber f -> K(B,n+2)]. *) + Definition abses_pfiber_incl : A $-> abgroup_pi_pfiber. + Proof. + nrefine (grp_homo_compose _ + (grp_homo_compose (groupiso_pi_loops n.+1 K(A, n.+3)) + (equiv_g_pi_n_em A n.+2))). + exact (fmap (Pi n.+2) (connecting_map (pfib f) f)). + Defined. + + (** The projection, induced by the fiber inclusion of [f]. *) + Definition abses_pfiber_proj : abgroup_pi_pfiber $-> B. + Proof. + nrefine (grp_homo_compose + (grp_iso_inverse (equiv_g_pi_n_em B n.+1)) _). + exact (fmap (Pi n.+2) (pfib f)). + Defined. + + (** The [n.+2]-nd homotopy group of the double fiber of [pfib f] + vanishes. *) + Local Instance contr_pi_pfiber2 + : Contr (Pi n.+2 (pfiber (pfib (pfib f)))). + Proof. + nrefine (contr_equiv' (Pi n.+3 K(B, n.+2)) _). + 1: exact (grp_iso_compose + (groupiso_pi_functor n.+1 (pequiv_inverse (pfiber2_loops (pfib f)))) + (groupiso_pi_loops n.+1 K(B, n.+2))). + exact (contr_pi_succ_istrunc n.+1 K(B, n.+2)). + Defined. + + (** The [n.+2]-nd homotopy group of [K(A,n+3)] vanishes. *) + Local Instance contr_pi_em : Contr (Pi n.+2 K(A, n.+3)). + Proof. + exact (contr_pi_isconnected n.+2 K(A, n.+3)). + Defined. + + Local Instance isembedding_abses_pfiber_incl + : IsEmbedding abses_pfiber_incl. + Proof. + snapply isembedding_istrivial_kernel. + intros a w. + (* The image of [a] in [Pi n.+2 (loops K(A,n+3))]. *) + pose (z := groupiso_pi_loops n.+1 K(A, n.+3) (equiv_g_pi_n_em A n.+2 a)). + assert (wz : fmap (Pi n.+2) ((connect_fiberseq (pfib f) f).2) z + = mon_unit). + { napply (isinj_embedding _ (isembedding_pi_pfib (pfib f) n.+1)). + 1: exact _. + refine ((fmap_comp (Pi n.+2) + ((connect_fiberseq (pfib f) f).2 : _ ->* _) + (pfib (pfib f)) z)^ @ _). + refine (w @ _). + exact (grp_homo_unit (fmap (Pi n.+2) (pfib (pfib f))))^. } + apply (equiv_inj (equiv_g_pi_n_em A n.+2)). + apply (equiv_inj (groupiso_pi_loops n.+1 K(A, n.+3))). + apply (equiv_inj (groupiso_pi_functor n.+1 + ((connect_fiberseq (pfib f) f).2))). + refine (wz @ _). + symmetry. + refine (ap _ (ap _ (grp_homo_unit (equiv_g_pi_n_em A n.+2))) @ _). + refine (ap _ (grp_homo_unit (groupiso_pi_loops n.+1 K(A, n.+3))) @ _). + exact (grp_homo_unit (groupiso_pi_functor n.+1 + ((connect_fiberseq (pfib f) f).2))). + Defined. + + Local Definition issurjection_abses_pfiber_proj + : IsSurjection abses_pfiber_proj. + Proof. + intro b. + rapply contr_inhabited_hprop. + pose proof (c := @center _ (conn_map_isexact + (i := fmap (pTr 0) (fmap (iterated_loops n.+2) (pfib f))) + (f := fmap (pTr 0) (fmap (iterated_loops n.+2) f)) + (equiv_g_pi_n_em B n.+1 b; path_contr _ _))). + strip_truncations. + destruct c as [u q]. + apply tr. + exists u. + apply (equiv_inj (equiv_g_pi_n_em B n.+1)). + refine (grp_iso_retr (equiv_g_pi_n_em B n.+1) _ @ _). + exact (ap pr1 q). + Defined. + + Local Instance isexact_abses_pfiber + : IsExact (Tr (-1)) abses_pfiber_incl abses_pfiber_proj. + Proof. + snapply Build_IsExact. + - (* The composite is constant. *) + srapply phomotopy_homotopy_hset. + intro a. + refine (ap (grp_iso_inverse (equiv_g_pi_n_em B n.+1)) _ + @ grp_homo_unit (grp_iso_inverse (equiv_g_pi_n_em B n.+1))). + refine (ap (fmap (Pi n.+2) (pfib f)) + (fmap_comp (Pi n.+2) ((connect_fiberseq (pfib f) f).2 : _ ->* _) + (pfib (pfib f)) _) @ _). + exact (cx_isexact + (i := fmap (pTr 0) (fmap (iterated_loops n.+2) (pfib (pfib f)))) + (f := fmap (pTr 0) (fmap (iterated_loops n.+2) (pfib f))) + (fmap (Pi n.+2) ((connect_fiberseq (pfib f) f).2) + (grp_homo_compose (groupiso_pi_loops n.+1 K(A, n.+3)) + (equiv_g_pi_n_em A n.+2) a))). + - (* Every element of the kernel merely comes from [A]. *) + intros [x w]. + rapply contr_inhabited_hprop. + assert (w' : fmap (Pi n.+2) (pfib f) x = mon_unit). + { refine ((grp_iso_retr (equiv_g_pi_n_em B n.+1) _)^ @ _ + @ grp_homo_unit (equiv_g_pi_n_em B n.+1)). + exact (ap (equiv_g_pi_n_em B n.+1) w). } + pose proof (c := @center _ (conn_map_isexact + (i := fmap (pTr 0) (fmap (iterated_loops n.+2) (pfib (pfib f)))) + (f := fmap (pTr 0) (fmap (iterated_loops n.+2) (pfib f))) + (x; w'))). + strip_truncations. + destruct c as [u q]. + apply tr. + pose (v := fmap (Pi n.+2) + (pequiv_inverse (connect_fiberseq (pfib f) f).2) u + : Pi n.+2 (loops K(A, n.+3))). + exists ((equiv_g_pi_n_em A n.+2)^-1 + ((groupiso_pi_loops n.+1 K(A, n.+3))^-1 v)). + apply path_sigma_hprop. + refine (ap (fmap (Pi n.+2) (connecting_map (pfib f) f)) + (ap (groupiso_pi_loops n.+1 K(A, n.+3)) + (eisretr (equiv_g_pi_n_em A n.+2) _) + @ eisretr (groupiso_pi_loops n.+1 K(A, n.+3)) _) @ _). + refine (fmap_comp (Pi n.+2) + ((connect_fiberseq (pfib f) f).2 : _ ->* _) + (pfib (pfib f)) _ @ _). + refine (ap (fmap (Pi n.+2) (pfib (pfib f))) _ @ ap pr1 q). + refine ((fmap_comp (Pi n.+2) + (pequiv_inverse (connect_fiberseq (pfib f) f).2 : _ ->* _) + ((connect_fiberseq (pfib f) f).2 : _ ->* _) u)^ @ _). + refine (fmap2 (Pi n.+2) + (peisretr ((connect_fiberseq (pfib f) f).2)) u @ _). + exact (fmap_id (Pi n.+2) _ u). + Defined. + + (** The short exact sequence associated to [f]. *) + Definition abses_pfiber : AbSES B A + := Build_AbSES abgroup_pi_pfiber abses_pfiber_incl abses_pfiber_proj + _ issurjection_abses_pfiber_proj _. + +End AbSESPfiber. + +Section PfiberDeloop. + Context `{Univalence} {B A : AbGroup@{u}} (psi : K(B, 3) ->* K(A, 4)). + + (** The fiber of a map [K(B,3) ->* K(A,4)] is 3-truncated. *) + Local Instance istrunc_pfiber_em : IsTrunc 3 (pfiber psi) + := _. + + (** Its second homotopy group is trivial: it embeds in the trivial + [Pi 2 K(B,3)], since the second homotopy group of the double fiber + is [Pi 3 K(A,4)], which is also trivial. *) + Local Instance contr_pi2_pfiber_em : Contr (Pi 2 (pfiber psi)). + Proof. + assert (contr_pi2_pfib2 : Contr (Pi 2 (pfiber (pfib psi)))). + { nrefine (contr_equiv' (Pi 3 K(A, 4)) _). + 1: exact (grp_iso_compose + (groupiso_pi_functor 1 (pequiv_inverse (pfiber2_loops psi))) + (groupiso_pi_loops 1 K(A, 4))). + exact (contr_pi_isconnected 3 K(A, 4)). } + apply (Build_Contr _ mon_unit). + intro y. + napply (isinj_embedding _ (isembedding_pi_pfib psi 1)). + 1: exact _. + napply path_contr. + exact (contr_pi_isconnected 2 K(B, 3)). + Defined. + + (** The fiber is 2-connected. *) + Local Instance isconnected_pfiber_em : IsConnected 2 (pfiber psi). + Proof. + napply (isconnected_succ_contr_pi 0). + - pose @O_lex_leq_Tr. + pose proof (@isconnected_pred 2 K(A, 4) (isconnected_em 3)). + pose proof (isconnected_em (G:=B) 2). + rapply OO_isconnected_hfiber. + - exact _. + Defined. + + (** The fiber is the Eilenberg-Mac Lane space of its third homotopy + group. *) + Local Definition pequiv_em_pfiber_psi + : K(abgroup_pi_pfiber 1 psi, 3) <~>* pfiber psi + := pequiv_em_connected_truncated (pfiber psi) 2. + + (** The induced identification of third homotopy groups. *) + Local Definition eta_pfiber_psi + : GroupIsomorphism (abgroup_pi_pfiber 1 psi) (abgroup_pi_pfiber 1 psi) + := grp_iso_compose + (groupiso_pi_functor 2 pequiv_em_pfiber_psi) + (equiv_g_pi_n_em (abgroup_pi_pfiber 1 psi) 2). + + (** The bridge, twisted by [eta_pfiber_psi] so that the projection + square below holds by construction. *) + Local Definition pequiv_em_pfiber_psi' + : K(abgroup_pi_pfiber 1 psi, 3) <~>* pfiber psi. + Proof. + snapply Build_pEquiv. + 1: exact (pequiv_em_pfiber_psi + o* pequiv_em_fmap (grp_iso_inverse eta_pfiber_psi) 3). + exact (isequiv_compose + (pequiv_em_fmap (grp_iso_inverse eta_pfiber_psi) 3) + pequiv_em_pfiber_psi). + Defined. + + (** On [Pi 3], the bridge inverts [equiv_g_pi_n_em], by construction. *) + Local Definition pi_bridge_psi (x : Pi 3 K(abgroup_pi_pfiber 1 psi, 3)) + : fmap (Pi 3) (pequiv_em_pfiber_psi' : _ ->* _) x + = grp_iso_inverse (equiv_g_pi_n_em (abgroup_pi_pfiber 1 psi) 2) x. + Proof. + refine (fmap_comp (Pi 3) + (em_fmap (grp_iso_inverse eta_pfiber_psi) 3) + (pequiv_em_pfiber_psi : _ ->* _) x @ _). + refine (ap (fmap (Pi 3) (pequiv_em_pfiber_psi : _ ->* _)) + (ap (fmap (Pi 3) (em_fmap (grp_iso_inverse eta_pfiber_psi) 3)) + (grp_iso_retr + (equiv_g_pi_n_em (abgroup_pi_pfiber 1 psi) 2) x)^) @ _). + refine (ap (fmap (Pi 3) (pequiv_em_pfiber_psi : _ ->* _)) + (pi_em_fmap (grp_iso_inverse eta_pfiber_psi) 2 _) @ _). + exact (grp_iso_retr eta_pfiber_psi _). + Defined. + + (** Through the bridge, [em_fmap] of the projection is the fiber + inclusion of [psi]. *) + Local Definition path_em_proj_pfib_psi + : em_fmap (abses_pfiber_proj 1 psi) 3 + = pfib psi o* pequiv_em_pfiber_psi'. + Proof. + snapply (path_em_pmap_pi_connected 1). + 1: exact (isconnected_em (G:=B) 2). + 1: exact _. + intro x. + refine (ap (fmap (Pi 3) (em_fmap (abses_pfiber_proj 1 psi) 3)) + (grp_iso_retr (equiv_g_pi_n_em (abgroup_pi_pfiber 1 psi) 2) x)^ + @ _). + refine (pi_em_fmap (abses_pfiber_proj 1 psi) 2 _ @ _). + refine (grp_iso_retr (equiv_g_pi_n_em B 2) _ @ _). + refine (_ @ (fmap_comp (Pi 3) + (pequiv_em_pfiber_psi' : _ ->* _) (pfib psi) x)^). + exact (ap (fmap (Pi 3) (pfib psi)) (pi_bridge_psi x)^). + Defined. + + (** Through the bridge, [em_fmap] of the inclusion is the connecting + map of [psi], modulo the loop identification of [K(A,3)]. *) + Local Definition path_em_incl_delta_psi + : pequiv_em_pfiber_psi' o* em_fmap (abses_pfiber_incl 1 psi) 3 + = connecting_map (pfib psi) psi o* pequiv_loops_em_em A 3. + Proof. + snapply (path_em_pmap_pi_connected 1). + 1: exact _. + 1: exact _. + intro x. + refine (fmap_comp (Pi 3) + (em_fmap (abses_pfiber_incl 1 psi) 3) + (pequiv_em_pfiber_psi' : _ ->* _) x @ _). + refine (ap (fmap (Pi 3) (pequiv_em_pfiber_psi' : _ ->* _)) + (ap (fmap (Pi 3) (em_fmap (abses_pfiber_incl 1 psi) 3)) + (grp_iso_retr (equiv_g_pi_n_em A 2) x)^) @ _). + refine (ap (fmap (Pi 3) (pequiv_em_pfiber_psi' : _ ->* _)) + (pi_em_fmap (abses_pfiber_incl 1 psi) 2 _) @ _). + refine (pi_bridge_psi _ @ _). + refine (grp_iso_sect + (equiv_g_pi_n_em (abgroup_pi_pfiber 1 psi) 2) _ @ _). + refine (_ @ (fmap_comp (Pi 3) + (pequiv_loops_em_em A 3 : _ ->* _) + (connecting_map (pfib psi) psi) x)^). + refine (ap (fmap (Pi 3) (connecting_map (pfib psi) psi)) _). + refine (grp_iso_retr (groupiso_pi_loops 2 K(A, 4)) _ @ _). + exact (ap (fmap (Pi 3) (pequiv_loops_em_em A 3 : _ ->* _)) + (grp_iso_retr (equiv_g_pi_n_em A 2) x)). + Defined. + + (** The projection square as a square of pointed maps. *) + Local Definition square_em_proj_pfib_psi + : pequiv_pmap_idmap o* em_fmap (projection (abses_pfiber 1 psi)) 3 + ==* pfib psi o* pequiv_em_pfiber_psi' + := pmap_postcompose_idmap _ @* phomotopy_path path_em_proj_pfib_psi. + + (** The third homotopy group of the double fiber of [pfib psi] + vanishes, so [Pi 3] of its fiber inclusion is an embedding. *) + Local Instance contr_pi3_pfiber2_psi + : Contr (Pi 3 (pfiber (pfib (pfib psi)))) + := contr_pi_pfiber2 1 psi. + + (** Through the bridge, [cxfib] of the extracted sequence is the + connecting identification of [psi], modulo the loop identification + of [K(A,3)]. Both sides are determined by their effect on [Pi 3], + since [Pi 3] of the double fiber inclusion is an embedding. *) + Local Definition path_cxfib_connect_psi + : pequiv_pfiber pequiv_em_pfiber_psi' pequiv_pmap_idmap + square_em_proj_pfib_psi + o* pequiv_cxfib (i := em_fmap (inclusion (abses_pfiber 1 psi)) 3) + (f := em_fmap (projection (abses_pfiber 1 psi)) 3) + = (connect_fiberseq (pfib psi) psi).2 o* pequiv_loops_em_em A 3. + Proof. + snapply (path_em_pmap_pi_connected 1). + 1: exact (isconnected_equiv' 2 (loops K(A, 4)) + ((connect_fiberseq (pfib psi) psi).2) + (@isconnected_loops _ 2 K(A, 4) (isconnected_em 3))). + 1: exact _. + intro x. + napply (isinj_embedding _ (isembedding_pi_pfib (pfib psi) 2)). + 1: exact _. + refine (ap (fmap (Pi 3) (pfib (pfib psi))) + (fmap_comp (Pi 3) + (pequiv_cxfib (i := em_fmap (inclusion (abses_pfiber 1 psi)) 3) + (f := em_fmap (projection (abses_pfiber 1 psi)) 3) : _ ->* _) + (pequiv_pfiber pequiv_em_pfiber_psi' pequiv_pmap_idmap + square_em_proj_pfib_psi : _ ->* _) x) @ _). + refine ((fmap_comp (Pi 3) + (pequiv_pfiber pequiv_em_pfiber_psi' pequiv_pmap_idmap + square_em_proj_pfib_psi : _ ->* _) + (pfib (pfib psi)) _)^ @ _). + refine ((fmap2 (Pi 3) + (square_pequiv_pfiber pequiv_em_pfiber_psi' pequiv_pmap_idmap + square_em_proj_pfib_psi) _)^ @ _). + refine (fmap_comp (Pi 3) + (pfib (em_fmap (projection (abses_pfiber 1 psi)) 3)) + (pequiv_em_pfiber_psi' : _ ->* _) _ @ _). + refine (ap (fmap (Pi 3) (pequiv_em_pfiber_psi' : _ ->* _)) + ((fmap_comp (Pi 3) + (pequiv_cxfib (i := em_fmap (inclusion (abses_pfiber 1 psi)) 3) + (f := em_fmap (projection (abses_pfiber 1 psi)) 3) : _ ->* _) + (pfib (em_fmap (projection (abses_pfiber 1 psi)) 3)) x)^ + @ fmap2 (Pi 3) (pfib_cxfib _) x) @ _). + refine ((fmap_comp (Pi 3) + (em_fmap (abses_pfiber_incl 1 psi) 3) + (pequiv_em_pfiber_psi' : _ ->* _) x)^ @ _). + refine (ap (fun (m : _ ->* _) => fmap (Pi 3) m x) + path_em_incl_delta_psi @ _). + refine (fmap_comp (Pi 3) + (pequiv_loops_em_em A 3 : _ ->* _) + (connecting_map (pfib psi) psi) x @ _). + refine (fmap_comp (Pi 3) + ((connect_fiberseq (pfib psi) psi).2 : _ ->* _) + (pfib (pfib psi)) _ @ _). + exact (ap (fmap (Pi 3) (pfib (pfib psi))) + (fmap_comp (Pi 3) + (pequiv_loops_em_em A 3 : _ ->* _) + ((connect_fiberseq (pfib psi) psi).2 : _ ->* _) x))^. + Defined. + + (** The connecting identification of [psi] inverts [pfiber2_loops], + since the underlying [pequiv_pfiber] square is tautological. *) + Local Definition pfiber2_loops_connect_psi + : pfiber2_loops psi o* ((connect_fiberseq (pfib psi) psi).2 : _ ->* _) + ==* pmap_idmap. + Proof. + refine (pmap_prewhisker _ _ @* peisretr + ((pfiber2_loops psi) + o*E (pequiv_pfiber _ _ (square_pfib_pequiv_cxfib (pfib psi) psi)))). + refine (_ @* (compose_cate_fun (A:=pType) _ _)^*). + refine (_ @* (pmap_postwhisker _ (pequiv_pfiber_cxfib_taut psi) + @* pmap_precompose_idmap _)^*). + reflexivity. + Defined. + + (** Through the loop identification of [K(A,3)], the connecting map of + the extracted fiber sequence is [loops psi], twisted by loop + inversion. *) + Local Definition connecting_map_em_loops_psi + : pequiv_loops_em_em A 3 + o* connecting_map (em_fmap (inclusion (abses_pfiber 1 psi)) 3) + (em_fmap (projection (abses_pfiber 1 psi)) 3) + ==* fmap loops psi o* loops_inv K(B, 3). + Proof. + (* Insert the identity [pfiber2_loops psi o* connect] in front. *) + refine ((pmap_postcompose_idmap _)^* @* _). + refine (pmap_prewhisker _ pfiber2_loops_connect_psi^* @* _). + (* Reassociate to expose the connecting composite, then the cxfib + square. *) + refine (pmap_compose_assoc _ _ _ @* _). + refine (pmap_postwhisker _ (pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_postwhisker _ + (pmap_prewhisker _ (phomotopy_path path_cxfib_connect_psi^)) @* _). + (* Compare the connecting maps across the bridge. *) + refine (pmap_postwhisker _ (pmap_compose_assoc _ _ _) @* _). + refine (pmap_postwhisker _ + (pmap_postwhisker _ (connecting_map_cxfib _ _)) @* _). + refine (pmap_postwhisker _ + (connecting_map_natural _ _ square_em_proj_pfib_psi) @* _). + refine (pmap_postwhisker _ + (pmap_postwhisker _ (fmap_id loops _) + @* pmap_precompose_idmap _) @* _). + exact (connecting_map_pfib2 psi). + Defined. + + (** Negation on [K(B,2)], realised as loop inversion conjugated by the + loop identification. This is the sign by which the classifying map + of the extracted sequence differs from the delooping equivalence. *) + Local Definition pequiv_neg_em : K(B, 2) <~>* K(B, 2) + := (pequiv_loops_em_em B 2)^-1* + o*E (loops_inv K(B, 3) o*E pequiv_loops_em_em B 2). + + (** Under the loop identification, [pequiv_neg_em] is loop inversion. *) + Local Definition pequiv_neg_em_loops + : pequiv_loops_em_em B 2 o* pequiv_neg_em + ==* loops_inv K(B, 3) o* pequiv_loops_em_em B 2. + Proof. + refine (pmap_postwhisker _ + (compose_cate_fun (A:=pType) _ _) @* _). + refine ((pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_prewhisker _ (peisretr (pequiv_loops_em_em B 2)) @* _). + refine (pmap_postcompose_idmap _ @* _). + exact (compose_cate_fun (A:=pType) _ _). + Defined. + + (** The classifying map of the extracted sequence is the delooping + equivalence applied to [psi], twisted by [pequiv_neg_em]. *) + Local Definition abses_classifying_pfiber_deloop + : abses_classifying_map (abses_pfiber 1 psi) + ==* equiv_deloop_em_pmap B A psi o* pequiv_neg_em. + Proof. + refine (_ @* (pmap_prewhisker pequiv_neg_em + (equiv_deloop_em_pmap_unfold B A psi) + @* pmap_compose_assoc _ _ _ + @* pmap_postwhisker _ (pmap_compose_assoc _ _ _))^*). + refine (pmap_prewhisker (pequiv_loops_em_em B 2) + (moveL_pequiv_Vf _ _ _ connecting_map_em_loops_psi) @* _). + refine (pmap_compose_assoc _ _ _ @* _). + refine (pmap_postwhisker _ (pmap_compose_assoc _ _ _) @* _). + napply pmap_postwhisker. + napply pmap_postwhisker. + symmetry; exact pequiv_neg_em_loops. + Defined. + +End PfiberDeloop. + +(** ** The first round trip + + The short exact sequence extracted from the classifying map of [E] is + [E] itself. *) + +Section ClassifyingRoundTrip. + Context `{Univalence} {B A : AbGroup@{u}} (E : AbSES B A). + + (** The classifying map equals the connecting map after the loop + identification, as a square. *) + Local Definition rt1_square + : pequiv_pmap_idmap o* abses_classifying_map E + ==* connecting_map (em_fmap (inclusion E) 3) + (em_fmap (projection E) 3) + o* pequiv_loops_em_em B 2 + := pmap_postcompose_idmap _. + + (** The fiber of the connecting map's defining presentation. *) + Local Definition rt1_pfiber_delta + : pfiber (connecting_map (em_fmap (inclusion E) 3) + (em_fmap (projection E) 3)) + <~>* pfiber (pfib (em_fmap (inclusion E) 3)). + Proof. + refine (pequiv_pfiber + ((connect_fiberseq (em_fmap (inclusion E) 3) + (em_fmap (projection E) 3)).2) + pequiv_pmap_idmap _). + exact (pmap_postcompose_idmap _). + Defined. + + (** Its defining square. *) + Local Definition rt1_pfiber_delta_square + : (connect_fiberseq (em_fmap (inclusion E) 3) + (em_fmap (projection E) 3)).2 + o* pfib (connecting_map (em_fmap (inclusion E) 3) + (em_fmap (projection E) 3)) + ==* pfib (pfib (em_fmap (inclusion E) 3)) o* rt1_pfiber_delta. + Proof. + refine (square_pequiv_pfiber + ((connect_fiberseq (em_fmap (inclusion E) 3) + (em_fmap (projection E) 3)).2) + pequiv_pmap_idmap _). + Defined. + + (** Hence the fiber of the classifying map is [loops K(E,3)]: transport + the fiber along [rt1_square] and the presentation of the connecting + map, identify the double fiber via [pfiber2_loops], and invert. The + inversion makes both round-trip squares commute. *) + Local Definition pequiv_pfiber_classifying + : pfiber (abses_classifying_map E) <~>* loops K(E, 3). + Proof. + snapply Build_pEquiv. + 1: exact (loops_inv _ + o* (pfiber2_loops (em_fmap (inclusion E) 3) + o* (rt1_pfiber_delta + o* pequiv_pfiber (pequiv_loops_em_em B 2) pequiv_pmap_idmap + rt1_square))). + exact _. + Defined. + + (** Through this identification, the fiber inclusion of the classifying + map is [loops] of the projection. *) + Local Definition rt1_pfib_square + : pequiv_loops_em_em B 2 o* pfib (abses_classifying_map E) + ==* fmap loops (em_fmap (projection E) 3) + o* pequiv_pfiber_classifying. + Proof. + assert (X : pfib (connecting_map (em_fmap (inclusion E) 3) + (em_fmap (projection E) 3)) + ==* fmap loops (em_fmap (projection E) 3) + o* (loops_inv _ + o* (pfiber2_loops (em_fmap (inclusion E) 3) + o* rt1_pfiber_delta))). + { refine ((pmap_postcompose_idmap _)^* @* _). + refine (pmap_prewhisker _ + (peisretr ((pfiber2_loops (em_fmap (projection E) 3)) + o*E (pequiv_pfiber _ _ + (square_pfib_pequiv_cxfib + (em_fmap (inclusion E) 3) + (em_fmap (projection E) 3)))))^* @* _). + refine (pmap_compose_assoc _ _ _ @* _). + refine (pmap_postwhisker _ rt1_pfiber_delta_square @* _). + refine ((pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_prewhisker _ (pfiber2_loops_pfib2 _ _) @* _). + refine (pmap_compose_assoc _ _ _ @* _). + napply pmap_postwhisker. + exact (pmap_compose_assoc _ _ _). } + refine (square_pequiv_pfiber _ _ rt1_square @* _). + refine (pmap_prewhisker _ X @* _). + refine (pmap_compose_assoc _ _ _ @* _). + napply pmap_postwhisker. + refine (pmap_compose_assoc _ _ _ @* _). + napply pmap_postwhisker. + exact (pmap_compose_assoc _ _ _). + Defined. + + (** Loop inversion is an involution. *) + Local Definition loops_inv_inv (X : pType) + : loops_inv X o* loops_inv X ==* pmap_idmap. + Proof. + snapply Build_pHomotopy. + - intro p; exact (inv_V p). + - reflexivity. + Defined. + + (** Loop inversion is natural. *) + Local Definition loops_inv_natural {X Y : pType} (f : X ->* Y) + : fmap loops f o* loops_inv X ==* loops_inv Y o* fmap loops f. + Proof. + pointed_reduce_pmap f. + snapply Build_pHomotopy. + - intro p. + exact (whiskerL 1 (whiskerR (ap_V f p) 1) + @ (concat_1p _ @ concat_p1 _) + @ (inverse2 (concat_1p _ @ concat_p1 _))^). + - reflexivity. + Defined. + + (** Through [pequiv_pfiber_classifying], the connecting map of the + classifying map's fiber sequence is [loops] of the inclusion. *) + Local Definition rt1_conn_square + : pequiv_pfiber_classifying + o* connecting_map (pfib (abses_classifying_map E)) + (abses_classifying_map E) + ==* fmap loops (em_fmap (inclusion E) 3). + Proof. + assert (N1 : pequiv_pfiber (pequiv_loops_em_em B 2) pequiv_pmap_idmap + rt1_square + o* connecting_map (pfib (abses_classifying_map E)) + (abses_classifying_map E) + ==* connecting_map + (pfib (connecting_map (em_fmap (inclusion E) 3) + (em_fmap (projection E) 3))) + (connecting_map (em_fmap (inclusion E) 3) + (em_fmap (projection E) 3))). + { refine (connecting_map_natural _ _ rt1_square @* _). + refine (pmap_postwhisker _ (fmap_id loops _) @* _). + apply pmap_precompose_idmap. } + assert (N2 : rt1_pfiber_delta + o* connecting_map + (pfib (connecting_map (em_fmap (inclusion E) 3) + (em_fmap (projection E) 3))) + (connecting_map (em_fmap (inclusion E) 3) + (em_fmap (projection E) 3)) + ==* connecting_map + (pfib (pfib (em_fmap (inclusion E) 3))) + (pfib (em_fmap (inclusion E) 3))). + { refine (connecting_map_natural _ _ _ @* _). + refine (pmap_postwhisker _ (fmap_id loops _) @* _). + apply pmap_precompose_idmap. } + refine (pmap_compose_assoc _ _ _ @* _). + refine (pmap_postwhisker _ (pmap_compose_assoc _ _ _) @* _). + refine (pmap_postwhisker _ + (pmap_postwhisker _ (pmap_compose_assoc _ _ _)) @* _). + refine (pmap_postwhisker _ (pmap_postwhisker _ + (pmap_postwhisker _ N1)) @* _). + refine (pmap_postwhisker _ (pmap_postwhisker _ N2) @* _). + refine (pmap_postwhisker _ (connecting_map_pfib2 _) @* _). + refine (pmap_postwhisker _ + (loops_inv_natural (em_fmap (inclusion E) 3)) @* _). + refine ((pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_prewhisker _ (loops_inv_inv _) @* _). + apply pmap_postcompose_idmap. + Defined. + + (** The middle isomorphism of the round trip. *) + Local Definition rt1_middle + : GroupIsomorphism (abgroup_pi_pfiber 0 (abses_classifying_map E)) E. + Proof. + nrefine (grp_iso_compose (grp_iso_inverse (equiv_g_pi_n_em E 2)) _). + nrefine (grp_iso_compose + (grp_iso_inverse (groupiso_pi_loops 1 K(E, 3))) _). + exact (groupiso_pi_functor 1 pequiv_pfiber_classifying). + Defined. + + (** The inclusion square of the round trip. *) + Local Definition rt1_incl_square (a : A) + : rt1_middle (abses_pfiber_incl 0 (abses_classifying_map E) a) + = inclusion E a. + Proof. + apply (equiv_inj (equiv_g_pi_n_em E 2)). + refine (grp_iso_retr (equiv_g_pi_n_em E 2) _ @ _). + apply (equiv_inj (groupiso_pi_loops 1 K(E, 3))). + refine (grp_iso_retr (groupiso_pi_loops 1 K(E, 3)) _ @ _). + assert (CORE : fmap (Pi 2) (pequiv_pfiber_classifying : _ ->* _) + (fmap (Pi 2) + (connecting_map (pfib (abses_classifying_map E)) + (abses_classifying_map E)) + (groupiso_pi_loops 1 K(A, 3) + (equiv_g_pi_n_em A 2 a))) + = groupiso_pi_loops 1 K(E, 3) + (equiv_g_pi_n_em E 2 (inclusion E a))). + { refine ((fmap_comp (Pi 2) + (connecting_map (pfib (abses_classifying_map E)) + (abses_classifying_map E)) + (pequiv_pfiber_classifying : _ ->* _) + (groupiso_pi_loops 1 K(A, 3) + (equiv_g_pi_n_em A 2 a)))^ @ _). + refine (fmap2 (Pi 2) rt1_conn_square _ @ _). + refine ((fmap_pi_loops 2 (em_fmap (inclusion E) 3) + (equiv_g_pi_n_em A 2 a))^ @ _). + exact (ap (pi_loops 2 K(E, 3)) (pi_em_fmap (inclusion E) 2 a)). } + exact CORE. + Defined. + + (** The projection square of the round trip. The last step unfolds + [equiv_g_pi_n_em B 2] definitionally. *) + Local Definition rt1_proj_square (x : Pi 2 (pfiber (abses_classifying_map E))) + : abses_pfiber_proj 0 (abses_classifying_map E) x + = projection E (rt1_middle x). + Proof. + apply (equiv_inj (equiv_g_pi_n_em B 1)). + refine (grp_iso_retr (equiv_g_pi_n_em B 1) _ @ _). + apply (equiv_inj (groupiso_pi_functor 1 (pequiv_loops_em_em B 2))). + (* The left side, through the pointed square. *) + refine ((fmap_comp (Pi 2) (pfib (abses_classifying_map E)) + (pequiv_loops_em_em B 2 : _ ->* _) x)^ @ _). + refine (fmap2 (Pi 2) rt1_pfib_square x @ _). + refine (fmap_comp (Pi 2) (pequiv_pfiber_classifying : _ ->* _) + (fmap loops (em_fmap (projection E) 3)) x @ _). + (* The right side, through naturality of [pi_loops] and [pi_em_fmap]. *) + refine (ap (fmap (pPi 2) (fmap loops (em_fmap (projection E) 3))) + (grp_iso_retr (groupiso_pi_loops 1 K(E, 3)) + (fmap (Pi 2) (pequiv_pfiber_classifying : _ ->* _) x))^ @ _). + refine ((fmap_pi_loops 2 (em_fmap (projection E) 3) _)^ @ _). + refine (ap (groupiso_pi_loops 1 K(B, 3)) _ @ _). + { refine (ap (fmap (Pi 3) (em_fmap (projection E) 3)) + (grp_iso_retr (equiv_g_pi_n_em E 2) _)^ @ _). + exact (pi_em_fmap (projection E) 2 (rt1_middle x)). } + exact (grp_iso_retr (groupiso_pi_loops 1 K(B, 3)) _). + Defined. + + (** The first round trip: the short exact sequence extracted from the + classifying map of [E] is [E]. *) + Definition abses_pfiber_classifying + : abses_pfiber 0 (abses_classifying_map E) = E + := path_abses (E := abses_pfiber 0 (abses_classifying_map E)) (F := E) + rt1_middle rt1_incl_square rt1_proj_square. + +End ClassifyingRoundTrip. + +(** ** The classification theorem + + [abses_classifying_map] is an equivalence, with inverse [abses_pfiber]. + This is Theorem 2.2.2 of Christensen-Flaten. *) + +Section Classification. + Context `{Univalence} {B A : AbGroup@{u}}. + + (** A section of the classifying map: the delooping preimage of [f] + untwisted by the sign extracts to a sequence whose classifying map + is [f]. This uses the [psi := K(B,3) ->* K(A,4)] analysis. *) + Local Definition abses_classifying_section (f : K(B, 2) ->* K(A, 3)) + : abses_classifying_map + (abses_pfiber 1 ((equiv_deloop_em_pmap B A)^-1 + (f o* pequiv_neg_em^-1*))) + = f. + Proof. + apply path_pforall. + refine (abses_classifying_pfiber_deloop _ @* _). + refine (pmap_prewhisker pequiv_neg_em + (phomotopy_path (eisretr (equiv_deloop_em_pmap B A) _)) @* _). + refine (pmap_compose_assoc _ _ _ @* _). + refine (pmap_postwhisker _ (peissect pequiv_neg_em) @* _). + apply pmap_precompose_idmap. + Defined. + + (** The second round trip: since [abses_pfiber 0] is a retraction of + [abses_classifying_map] (the first round trip) and the above is a + section, the two agree and the section round trip holds. *) + Local Definition abses_classifying_map_pfiber (f : K(B, 2) ->* K(A, 3)) + : abses_classifying_map (abses_pfiber 0 f) = f. + Proof. + transitivity (abses_classifying_map + (abses_pfiber 1 ((equiv_deloop_em_pmap B A)^-1 + (f o* pequiv_neg_em^-1*)))). + - apply (ap abses_classifying_map). + refine ((ap (abses_pfiber 0) (abses_classifying_section f))^ @ _). + exact (abses_pfiber_classifying _). + - exact (abses_classifying_section f). + Defined. + + (** Short exact sequences [A -> E -> B] are classified by pointed maps + [K(B,2) ->* K(A,3)]. *) + Definition equiv_abses_classifying_map + : AbSES B A <~> (K(B, 2) ->* K(A, 3)) + := equiv_adjointify abses_classifying_map (abses_pfiber 0) + abses_classifying_map_pfiber abses_pfiber_classifying. + + (** Consequently [Ext B A] is the set of path components of the + classifying mapping type. *) + Definition equiv_ext_classifying + : Ext B A <~> Tr 0 (K(B, 2) ->* K(A, 3)) + := Trunc_functor_equiv 0 equiv_abses_classifying_map. + + (** Since the classifying mapping type lives in the universe of [A] and + [B], the a priori large type [AbSES B A] is essentially small, as is + [Ext B A]. In particular both are independent of the universe in + which the extensions are formed (Remark 2.2.5). *) + Definition issmall_abses : IsSmall@{u _} (AbSES B A) + := issmall_equiv_issmall (equiv_abses_classifying_map)^-1%equiv + (issmall_in _). + + Definition issmall_ext : IsSmall@{u _} (Ext B A) + := issmall_equiv_issmall (equiv_ext_classifying)^-1%equiv + (issmall_in _). + +End Classification. + +(** ** Naturality of the classifying map + + A morphism of short exact sequences induces, after applying [K(-,3)], + a commuting square relating the two classifying maps. Taking the + [B]-component to be the identity gives naturality in [A] (pushout); + taking the [A]-component to be the identity gives naturality in [B] + (pullback). *) + +(** Inverting the [cxfib] equivalences below would otherwise force the + elaborator to reduce the large witnesses that they are equivalences; + we keep those witnesses opaque so that the inverses stay inert. *) +Opaque isequiv_cxfib_em isequiv_cxfib. + +Section Naturality. + Context `{Univalence} {B A Y X : AbGroup@{u}} + {E : AbSES B A} {F : AbSES Y X} (phi : AbSESMorphism E F). + + (** [K(-,3)] of the projection square of [phi]. *) + Local Definition em_proj_square + : em_fmap (projection F) 3 o* em_fmap (component2 phi) 3 + ==* em_fmap (component3 phi) 3 o* em_fmap (projection E) 3. + Proof. + refine ((em_fmap_compose _ _ 3)^* @* _ @* em_fmap_compose _ _ 3). + refine (phomotopy_path (ap (fun h => em_fmap h 3) _)). + apply equiv_path_grouphomomorphism; intro e. + exact (right_square phi e). + Defined. + + (** [K(-,3)] of the inclusion square of [phi]. *) + Local Definition em_incl_square + : em_fmap (component2 phi) 3 o* em_fmap (inclusion E) 3 + ==* em_fmap (inclusion F) 3 o* em_fmap (component1 phi) 3. + Proof. + refine ((em_fmap_compose _ _ 3)^* @* _ @* em_fmap_compose _ _ 3). + refine (phomotopy_path (ap (fun h => em_fmap h 3) _)). + apply equiv_path_grouphomomorphism; intro a. + exact (left_square phi a)^. + Defined. + + (** The fiber inclusions, as equivalences. *) + Local Definition em_cxfib_E + : K(A, 3) <~>* pfiber (em_fmap (projection E) 3) + := @pequiv_cxfib _ _ _ (em_fmap (inclusion E) 3) + (em_fmap (projection E) 3) (isexact_em_abses E 2). + + Local Definition em_cxfib_F + : K(X, 3) <~>* pfiber (em_fmap (projection F) 3) + := @pequiv_cxfib _ _ _ (em_fmap (inclusion F) 3) + (em_fmap (projection F) 3) (isexact_em_abses F 2). + + (** The fiber-inclusion comparison commutes with the morphism on + fibers. Both sides are determined on [Pi 3], where the double-fiber + inclusion is an embedding, reducing to the inclusion square. *) + Local Definition em_cxfib_square + : functor_pfiber (em_proj_square^*) o* em_cxfib_E + = em_cxfib_F o* em_fmap (component1 phi) 3. + Proof. + snapply (path_em_pmap_pi_connected 1). + 1: exact (isconnected_equiv' 2 K(X, 3) em_cxfib_F (isconnected_em 2)). + 1: exact _. + intro x. + napply (isinj_embedding _ + (@isembedding_pi_pfib _ _ _ (em_fmap (projection F) 3) 2 + (contr_pi_pfiber_pfib F 2))). + refine (ap (fmap (Pi 3) (pfib (em_fmap (projection F) 3))) + (fmap_comp (Pi 3) (em_cxfib_E : _ ->* _) + (functor_pfiber (em_proj_square^*) : _ ->* _) x) @ _). + refine ((fmap_comp (Pi 3) + (functor_pfiber (em_proj_square^*) : _ ->* _) + (pfib (em_fmap (projection F) 3)) _)^ @ _). + refine ((fmap2 (Pi 3) (square_functor_pfiber (em_proj_square^*)) _)^ @ _). + refine (fmap_comp (Pi 3) (pfib (em_fmap (projection E) 3)) + (em_fmap (component2 phi) 3) _ @ _). + refine (ap (fmap (Pi 3) (em_fmap (component2 phi) 3)) + ((fmap_comp (Pi 3) (em_cxfib_E : _ ->* _) + (pfib (em_fmap (projection E) 3)) x)^ + @ fmap2 (Pi 3) (pfib_cxfib _) x) @ _). + refine ((fmap_comp (Pi 3) (em_fmap (inclusion E) 3) + (em_fmap (component2 phi) 3) x)^ @ _). + refine (fmap2 (Pi 3) em_incl_square x @ _). + refine (fmap_comp (Pi 3) (em_fmap (component1 phi) 3) + (em_fmap (inclusion F) 3) x @ _). + refine ((fmap2 (Pi 3) (pfib_cxfib _) + (fmap (Pi 3) (em_fmap (component1 phi) 3) x))^ @ _). + refine (fmap_comp (Pi 3) (em_cxfib_F : _ ->* _) + (pfib (em_fmap (projection F) 3)) _ @ _). + exact (ap (fmap (Pi 3) (pfib (em_fmap (projection F) 3))) + (fmap_comp (Pi 3) (em_fmap (component1 phi) 3) + (em_cxfib_F : _ ->* _) x))^. + Qed. + + (** Hence the connecting maps of the two sequences are related by the + morphism, through the loop identification of the bases. *) + Local Definition cm_natural + : em_fmap (component1 phi) 3 + o* connecting_map (em_fmap (inclusion E) 3) (em_fmap (projection E) 3) + ==* connecting_map (em_fmap (inclusion F) 3) (em_fmap (projection F) 3) + o* fmap loops (em_fmap (component3 phi) 3). + Proof. + refine (pmap_prewhisker _ + (moveR_pequiv_Vf em_cxfib_F (em_fmap (component1 phi) 3) + (functor_pfiber (em_proj_square^*) o* em_cxfib_E) + (phomotopy_path em_cxfib_square))^* @* _). + refine (pmap_compose_assoc _ _ _ @* _). + refine (pmap_postwhisker _ (pmap_compose_assoc _ _ _) @* _). + refine (pmap_postwhisker _ (pmap_postwhisker _ + (connecting_map_cxfib (em_fmap (inclusion E) 3) + (em_fmap (projection E) 3))) @* _). + refine (pmap_postwhisker _ + (connecting_map_natural_functor (em_proj_square^*)) @* _). + refine ((pmap_compose_assoc _ _ _)^* @* _). + napply pmap_prewhisker. + exact (moveR_pequiv_Vf em_cxfib_F + (connecting_map (em_fmap (inclusion F) 3) (em_fmap (projection F) 3)) + (connecting_map (pfib (em_fmap (projection F) 3)) + (em_fmap (projection F) 3)) + (connecting_map_cxfib (em_fmap (inclusion F) 3) + (em_fmap (projection F) 3))^*). + Defined. + + (** A morphism of short exact sequences induces a commuting square of + classifying maps. *) + Definition abses_classifying_map_natural + : em_fmap (component1 phi) 3 o* abses_classifying_map E + ==* abses_classifying_map F o* em_fmap (component3 phi) 2. + Proof. + refine ((pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_prewhisker _ cm_natural @* _). + refine (pmap_compose_assoc _ _ _ @* _). + refine (pmap_postwhisker _ (em_fmap_loops_natural (component3 phi) 2) + @* _). + exact (pmap_compose_assoc _ _ _)^*. + Defined. + +End Naturality. + +Transparent isequiv_cxfib_em isequiv_cxfib. + diff --git a/theories/Algebra/AbSES/HigherExt.v b/theories/Algebra/AbSES/HigherExt.v new file mode 100644 index 00000000000..93b196039b5 --- /dev/null +++ b/theories/Algebra/AbSES/HigherExt.v @@ -0,0 +1,2366 @@ +From HoTT Require Import Basics Types. +From HoTT.WildCat Require Import Core. +Require Import Truncations.Core Truncations.SeparatedTrunc. +Require Import Universes.HSet. +Require Import Pointed.Core. +Require Import Homotopy.ExactSequence. +Require Import Colimits.Quotient. +Require Import AbelianGroup AbHom Biproduct AbProjective. +Require Import Spaces.FreeInt. +Require Import Groups.Group. +Require Import Algebra.AbSES.Core Algebra.AbSES.Pushout Algebra.AbSES.Pullback + Algebra.AbSES.BaerSum Algebra.AbSES.DirectSum Algebra.AbSES.Ext + Algebra.AbSES.PullbackFiberSequence. + +(** * Higher Ext groups via length-[n] exact sequences + + Following Christensen and Flaten, "Ext groups in homotopy type theory", + we define the higher Ext groups [abses_ext n B A] as set-quotients of + length-[n] exact sequences. A length-[0] sequence is a homomorphism, a + length-[1] sequence is a short exact sequence, and a length-[m.+1] + sequence is a short exact sequence [B <- ... <- C] spliced onto a + length-[m] sequence [C <- ... <- A]. + + The development proceeds in four stages: the type of length-[n] + sequences and the splice; the functorial operations (pullback, pushout, + direct sum and Baer sum) on sequences; the relation [⤳] of the paper, + shown to be an equivalence relation respected by all the operations; and + the higher Ext groups, with their bifunctoriality, the Yoneda product + and the Baer sum. *) + +Local Open Scope type_scope. + +(** ** The type of length-[n] exact sequences *) + +Section LengthNSequences. + Context `{Univalence}. + + Fixpoint abses_es (n : nat) (B A : AbGroup@{u}) : Type := + match n with + | 0%nat => ab_hom B A + | 1%nat => pointed_type (AbSES B A) + | S (S _ as m) => { C : AbGroup@{u} & abses_es m C A * pointed_type (AbSES B C) } + end. + + (** The splice operation, attaching a short exact sequence [B <- ... <- C] + to the front of a length-[m] sequence [C <- ... <- A]. When [m] is + zero this pushes the short exact sequence out along the homomorphism; + otherwise it records the new module and prepends. *) + Definition abses_es_splice {A B C : AbGroup@{u}} (m : nat) + : abses_es m C A -> AbSES B C -> abses_es m.+1%nat B A. + Proof. + destruct m as [|m]. + - exact (fun f s => abses_pushout f s). + - exact (fun e s => (C; (e, s))). + Defined. + +End LengthNSequences. + +(** ** Operations on length-[n] sequences *) + +Section Operations. + Context `{Univalence}. + + (** Pulling a length-[n] sequence back along [beta : B' -> B] changes only + the leading short exact sequence (precomposition when [n] is zero). *) + Definition abses_es_pullback {A : AbGroup@{u}} (n : nat) + {B B' : AbGroup@{u}} (beta : B' $-> B) + : abses_es n B A -> abses_es n B' A. + Proof. + destruct n as [|[|n]]. + - exact (fun f => grp_homo_compose f beta). + - exact (fun s => abses_pullback beta s). + - exact (fun e => (e.1; (fst e.2, abses_pullback beta (snd e.2)))). + Defined. + + (** Pulling back along the identity is the identity. *) + Definition abses_es_pullback_id (n : nat) {B A : AbGroup@{u}} + (E : abses_es n B A) + : abses_es_pullback n grp_homo_id E = E. + Proof. + destruct n as [|[|n0]]. + - apply equiv_path_grouphomomorphism; reflexivity. + - apply abses_pullback_id. + - exact (path_sigma' _ 1 + (path_prod (fst E.2, abses_pullback grp_homo_id (snd E.2)) E.2 + 1 (abses_pullback_id (snd E.2)))). + Defined. + + (** Pullback is contravariantly functorial in the base. *) + Definition abses_es_pullback_compose (n : nat) + {A B0 B1 B2 : AbGroup@{u}} (f : B0 $-> B1) (g : B1 $-> B2) + (Z : abses_es n B2 A) + : abses_es_pullback n (g $o f) Z + = abses_es_pullback n f (abses_es_pullback n g Z). + Proof. + destruct n as [|[|n0]]. + - apply equiv_path_grouphomomorphism; reflexivity. + - exact (abses_pullback_compose f g Z)^. + - exact (path_sigma' _ 1 + (path_prod (fst Z.2, abses_pullback (g $o f) (snd Z.2)) + (fst Z.2, abses_pullback f (abses_pullback g (snd Z.2))) + 1 (abses_pullback_compose f g (snd Z.2))^)). + Defined. + + (** Pushing a length-[n] sequence out along [alpha : A -> A'] acts on the + deep end, recursing into the trailing sequence (postcomposition when + [n] is zero). *) + Definition abses_es_pushout (n : nat) + {A A' : AbGroup@{u}} (alpha : A $-> A') + : forall {B : AbGroup@{u}}, abses_es n B A -> abses_es n B A'. + Proof. + induction n as [|n1 IH]; intro B. + - exact (fun f => grp_homo_compose alpha f). + - destruct n1 as [|n0]. + + exact (fun s => abses_pushout alpha s). + + exact (fun e => (e.1; (IH e.1 (fst e.2), snd e.2))). + Defined. + + (** Pushing out along the identity is the identity. *) + Definition abses_es_pushout_id (n : nat) {B A : AbGroup@{u}} + (E : abses_es n B A) + : abses_es_pushout n grp_homo_id E = E. + Proof. + revert B A E; induction n as [|n1 IH]; intros B A E. + - apply equiv_path_grouphomomorphism; reflexivity. + - destruct n1 as [|n0]. + + apply abses_pushout_id. + + exact (path_sigma' _ 1 + (path_prod (abses_es_pushout n0.+1 grp_homo_id (fst E.2), snd E.2) + (fst E.2, snd E.2) + (IH E.1 A (fst E.2)) 1)). + Defined. + + (** Pushout is covariantly functorial in the deep end. *) + Definition abses_es_pushout_compose (n : nat) + {A0 A1 A2 : AbGroup@{u}} (f : A0 $-> A1) (g : A1 $-> A2) (B : AbGroup@{u}) + : forall E : abses_es n B A0, + abses_es_pushout n (g $o f) E + = abses_es_pushout n g (abses_es_pushout n f E). + Proof. + revert B; induction n as [|n1 IH]; intro B. + - intro E; apply equiv_path_grouphomomorphism; reflexivity. + - destruct n1 as [|n0]. + + intro E; exact (abses_pushout_compose f g E). + + intro E. + exact (path_sigma' _ 1 + (path_prod + (abses_es_pushout n0.+1 (g $o f) (fst E.2), snd E.2) + (abses_es_pushout n0.+1 g (abses_es_pushout n0.+1 f (fst E.2)), snd E.2) + (IH E.1 (fst E.2)) 1)). + Defined. + + (** Pushout and pullback act on disjoint ends, so they commute. *) + Definition abses_es_pushout_pullback (n : nat) + {A A' B B' : AbGroup@{u}} (alpha : A $-> A') (beta : B' $-> B) + (E : abses_es n B A) + : abses_es_pushout n alpha (abses_es_pullback n beta E) + = abses_es_pullback n beta (abses_es_pushout n alpha E). + Proof. + destruct n as [|[|n0]]. + - apply equiv_path_grouphomomorphism; reflexivity. + - apply abses_pushout_pullback_reorder. + - reflexivity. + Defined. + + (** The direct sum of two length-[n] sequences, taken componentwise; the + intermediate modules become biproducts. *) + Definition abses_es_direct_sum (n : nat) + : forall {B A B' A' : AbGroup@{u}}, + abses_es n B A -> abses_es n B' A' -> abses_es n (ab_biprod B B') (ab_biprod A A'). + Proof. + induction n as [|n1 IH]; intros B A B' A'. + - exact (fun E F => functor_ab_biprod E F). + - destruct n1 as [|n0]. + + exact (fun E F => abses_direct_sum E F). + + exact (fun E F => (ab_biprod E.1 F.1; + (IH E.1 A F.1 A' (fst E.2) (fst F.2), + abses_direct_sum (snd E.2) (snd F.2)))). + Defined. + + (** The direct sum commutes with pullback along [functor_ab_biprod]; + pullback touches only the leading sequence, so no recursion is + needed. *) + Definition abses_es_directsum_pullback (n : nat) + {A A' B B' D D' : AbGroup@{u}} (beta : B' $-> B) (delta : D' $-> D) + (X : abses_es n B A) (Y : abses_es n D A') + : abses_es_direct_sum n (abses_es_pullback n beta X) (abses_es_pullback n delta Y) + = abses_es_pullback n (functor_ab_biprod beta delta) (abses_es_direct_sum n X Y). + Proof. + destruct n as [|[|n0]]. + - apply equiv_path_grouphomomorphism; reflexivity. + - exact (abses_directsum_distributive_pullbacks beta delta)^. + - srapply path_sigma'. + 1: reflexivity. + srapply path_prod. + 1: reflexivity. + exact (abses_directsum_distributive_pullbacks beta delta)^. + Defined. + + (** The direct sum commutes with pushout along [functor_ab_biprod]; pushout + recurses into the trailing sequence. *) + Definition abses_es_directsum_pushout (n : nat) + {A A2 A' A'2 : AbGroup@{u}} (alpha : A $-> A2) (alpha' : A' $-> A'2) + : forall {B B' : AbGroup@{u}} (X : abses_es n B A) (Y : abses_es n B' A'), + abses_es_pushout n (functor_ab_biprod alpha alpha') (abses_es_direct_sum n X Y) + = abses_es_direct_sum n (abses_es_pushout n alpha X) (abses_es_pushout n alpha' Y). + Proof. + induction n as [|n1 IH]; intros B B' X Y. + - apply equiv_path_grouphomomorphism; reflexivity. + - destruct n1 as [|n0]. + + apply abses_directsum_distributive_pushouts. + + exact (path_sigma' _ 1 + (path_prod + (abses_es_pushout n0.+1 (functor_ab_biprod alpha alpha') + (abses_es_direct_sum n0.+1 (fst X.2) (fst Y.2)), + abses_direct_sum (snd X.2) (snd Y.2)) + (abses_es_direct_sum n0.+1 (abses_es_pushout n0.+1 alpha (fst X.2)) + (abses_es_pushout n0.+1 alpha' (fst Y.2)), + abses_direct_sum (snd X.2) (snd Y.2)) + (IH X.1 Y.1 (fst X.2) (fst Y.2)) 1)). + Defined. + + (** The twist morphism on a triple direct sum, for arbitrary objects (the + analogous library construction is stated only for equal objects). *) + Definition abses_twist_directsum' {A1 B1 A2 B2 A3 B3 : AbGroup@{u}} + (E : AbSES B1 A1) (F : AbSES B2 A2) (G : AbSES B3 A3) + : AbSESMorphism (abses_direct_sum (abses_direct_sum E F) G) + (abses_direct_sum (abses_direct_sum G F) E). + Proof. + snapply Build_AbSESMorphism. + 1,2,3: exact ab_biprod_twist. + all: reflexivity. + Defined. + + (** The Baer sum of two length-[n] sequences with the same endpoints: take + the direct sum, push out along the codiagonal and pull back along the + diagonal. *) + Definition abses_es_baer_sum (n : nat) {B A : AbGroup@{u}} + (E F : abses_es n B A) : abses_es n B A + := abses_es_pullback n ab_diagonal + (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F)). + + (** The biproduct with the trivial group is the identity, projecting away + the trivial factor. *) + Definition ab_biprod_trivial_r (A : AbGroup@{u}) + : GroupIsomorphism (ab_biprod A abgroup_trivial) A. + Proof. + snapply Build_GroupIsomorphism. + - exact ab_biprod_pr1. + - snapply isequiv_adjointify. + + exact (fun a => (a, mon_unit)). + + reflexivity. + + intro x; srapply path_prod; [ reflexivity | apply path_contr ]. + Defined. + + (** Adding the split trivial summand on the deep end and projecting away the + trivial factor leaves a short exact sequence unchanged, up to reindexing + the base along the projection. *) + Definition abses_absorb_trivial {C A : AbGroup@{u}} (X : AbSES C A) + : abses_pushout ab_codiagonal + (abses_direct_sum X (point (AbSES abgroup_trivial A))) + = abses_pullback ab_biprod_pr1 X. + Proof. + pose (cst := @grp_homo_const abgroup_trivial C). + transitivity (abses_pushout ab_codiagonal + (abses_direct_sum X (abses_pullback cst X))). + 1: napply (ap (fun s => abses_pushout ab_codiagonal (abses_direct_sum X s))); + exact (abses_pullback_const X). + transitivity (abses_pushout ab_codiagonal + (abses_direct_sum (abses_pullback grp_homo_id X) + (abses_pullback cst X))). + 1: napply (ap (fun s => abses_pushout ab_codiagonal (abses_direct_sum s _))); + exact (abses_pullback_id X)^. + transitivity (abses_pushout ab_codiagonal + (abses_pullback (functor_ab_biprod grp_homo_id cst) + (abses_direct_sum X X))). + 1: napply (ap (abses_pushout ab_codiagonal)); + exact (abses_directsum_distributive_pullbacks grp_homo_id cst)^. + transitivity (abses_pullback (functor_ab_biprod grp_homo_id cst) + (abses_pushout ab_codiagonal (abses_direct_sum X X))). + 1: exact (abses_pushout_pullback_reorder _ _ _). + transitivity (abses_pullback (functor_ab_biprod grp_homo_id cst) + (abses_pullback ab_codiagonal X)). + 1: napply (ap (abses_pullback (functor_ab_biprod grp_homo_id cst))); + exact (abses_pushout_is_pullback (abses_codiagonal X)). + transitivity (abses_pullback + (ab_codiagonal $o functor_ab_biprod grp_homo_id cst) X). + 1: exact (abses_pullback_compose + (functor_ab_biprod grp_homo_id cst) ab_codiagonal X). + napply (ap (fun h => abses_pullback h X)). + apply equiv_path_grouphomomorphism; intro x; cbn. + apply grp_unit_r. + Defined. + + (** The trinary Baer sum, used to organise the proof of associativity. *) + Definition abses_es_trinary_baer_sum (n : nat) {B A : AbGroup@{u}} + (E F G : abses_es n B A) : abses_es n B A + := abses_es_pullback n ab_triagonal + (abses_es_pushout n ab_cotriagonal + (abses_es_direct_sum n (abses_es_direct_sum n E F) G)). + + (** The split length-[n] sequence, the neutral element for the Baer sum: the + zero homomorphism, the split short exact sequence, and otherwise the + trivial group spliced in. *) + Definition abses_es_zero (n : nat) {A : AbGroup@{u}} + : forall {B : AbGroup@{u}}, abses_es n B A. + Proof. + induction n as [|n1 IH]; intro B. + - exact grp_homo_const. + - destruct n1 as [|n0]. + + exact (point (AbSES B A)). + + exact (abgroup_trivial; (IH abgroup_trivial, point (AbSES B abgroup_trivial))). + Defined. + + (** Pulling the zero sequence back along the unique map to the trivial group + gives the zero sequence again. *) + Definition abses_es_pullback_zero (m : nat) {A C : AbGroup@{u}} + : abses_es_pullback m (@grp_homo_const C abgroup_trivial) + (@abses_es_zero m A abgroup_trivial) + = @abses_es_zero m A C. + Proof. + destruct m as [|[|m0]]. + - apply equiv_path_grouphomomorphism; reflexivity. + - exact (abses_pullback_const _)^. + - srapply path_sigma'. + 1: reflexivity. + srapply path_prod. + 1: reflexivity. + exact (abses_pullback_const (point (AbSES abgroup_trivial abgroup_trivial)))^. + Defined. + + (** Pushout is additive for the Baer sum, by naturality of the codiagonal. *) + Definition abses_es_pushout_baer_sum (n : nat) {A A' : AbGroup@{u}} + (alpha : A $-> A') {B : AbGroup@{u}} (E F : abses_es n B A) + : abses_es_pushout n alpha (abses_es_baer_sum n E F) + = abses_es_baer_sum n (abses_es_pushout n alpha E) (abses_es_pushout n alpha F). + Proof. + unfold abses_es_baer_sum. + transitivity (abses_es_pullback n ab_diagonal + (abses_es_pushout n alpha + (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F)))). + 1: exact (abses_es_pushout_pullback n alpha ab_diagonal _). + napply (ap (abses_es_pullback n ab_diagonal)). + transitivity (abses_es_pushout n (alpha $o ab_codiagonal) + (abses_es_direct_sum n E F)). + 1: exact (abses_es_pushout_compose n ab_codiagonal alpha (ab_biprod B B) + (abses_es_direct_sum n E F))^. + transitivity (abses_es_pushout n (ab_codiagonal $o functor_ab_biprod alpha alpha) + (abses_es_direct_sum n E F)). + 1: napply (ap (fun h => abses_es_pushout n h (abses_es_direct_sum n E F))); + exact (equiv_path_grouphomomorphism (ab_codiagonal_natural alpha)). + transitivity (abses_es_pushout n ab_codiagonal + (abses_es_pushout n (functor_ab_biprod alpha alpha) + (abses_es_direct_sum n E F))). + 1: exact (abses_es_pushout_compose n (functor_ab_biprod alpha alpha) ab_codiagonal + (ab_biprod B B) (abses_es_direct_sum n E F)). + napply (ap (abses_es_pushout n ab_codiagonal)). + exact (abses_es_directsum_pushout n alpha alpha E F). + Defined. + + (** Pullback is additive for the Baer sum, by naturality of the diagonal. *) + Definition abses_es_pullback_baer_sum (n : nat) {A : AbGroup@{u}} + {B B' : AbGroup@{u}} (beta : B' $-> B) (E F : abses_es n B A) + : abses_es_pullback n beta (abses_es_baer_sum n E F) + = abses_es_baer_sum n (abses_es_pullback n beta E) (abses_es_pullback n beta F). + Proof. + unfold abses_es_baer_sum. + transitivity (abses_es_pullback n (ab_diagonal $o beta) + (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F))). + 1: exact (abses_es_pullback_compose n beta ab_diagonal _)^. + transitivity (abses_es_pullback n (functor_ab_biprod beta beta $o ab_diagonal) + (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F))). + 1: napply (ap (fun h => abses_es_pullback n h + (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F)))); + apply equiv_path_grouphomomorphism; reflexivity. + transitivity (abses_es_pullback n ab_diagonal + (abses_es_pullback n (functor_ab_biprod beta beta) + (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F)))). + 1: exact (abses_es_pullback_compose n ab_diagonal (functor_ab_biprod beta beta) _). + napply (ap (abses_es_pullback n ab_diagonal)). + transitivity (abses_es_pushout n ab_codiagonal + (abses_es_pullback n (functor_ab_biprod beta beta) + (abses_es_direct_sum n E F))). + 1: exact (abses_es_pushout_pullback n ab_codiagonal (functor_ab_biprod beta beta) _)^. + napply (ap (abses_es_pushout n ab_codiagonal)). + exact (abses_es_directsum_pullback n beta beta E F)^. + Defined. + + (** Splicing a short exact sequence [xi : AbSES A'' A] of coefficients onto + the deep end of a length-[n] sequence raises the degree; this is the + connecting map of the long exact sequence. At degree zero it is pullback + along the homomorphism; otherwise it recurses to the deepest sequence. *) + Definition abses_es_dsplice (n : nat) {A A'' : AbGroup@{u}} (xi : AbSES A'' A) + : forall {B : AbGroup@{u}}, abses_es n B A'' -> abses_es n.+1 B A. + Proof. + induction n as [|n1 IH]; intro B. + - exact (fun f => abses_pullback f xi). + - destruct n1 as [|n0]. + + exact (fun s => (A''; (xi, s))). + + exact (fun e => (e.1; (IH e.1 (fst e.2), snd e.2))). + Defined. + + (** The deep-end splice commutes with pullback in the base. *) + Definition abses_es_dsplice_pullback (n : nat) {A A'' : AbGroup@{u}} + (xi : AbSES A'' A) {B B' : AbGroup@{u}} (beta : B' $-> B) + (X : abses_es n B A'') + : abses_es_dsplice n xi (abses_es_pullback n beta X) + = abses_es_pullback n.+1 beta (abses_es_dsplice n xi X). + Proof. + destruct n as [|[|n0]]. + - exact (abses_pullback_compose beta X xi)^. + - reflexivity. + - reflexivity. + Defined. + + (** Pushing out the deep end of a spliced sequence is the same as splicing + with the pushed-out short exact sequence: the pushout in degree [n.+1] + acts on the deepest sequence, which is exactly [xi]. *) + Definition abses_es_dsplice_pushout (n : nat) {A A2 A'' : AbGroup@{u}} + (xi : AbSES A'' A) (alpha : A $-> A2) + : forall {B : AbGroup@{u}} (Y : abses_es n B A''), + abses_es_pushout n.+1 alpha (abses_es_dsplice n xi Y) + = abses_es_dsplice n (abses_pushout alpha xi) Y. + Proof. + induction n as [|n1 IH]; intro B. + - exact (fun Y => abses_pushout_pullback_reorder xi alpha Y). + - destruct n1 as [|n0]. + + exact (fun s => idpath). + + intro e. + srapply path_sigma'. + 1: reflexivity. + srapply path_prod. + 1: exact (IH e.1 (fst e.2)). + reflexivity. + Defined. + + (** The deep-end splice distributes over the direct sum: the direct sum of + two splices by [xi] is the splice by [xi (+) xi] of the direct sum. The + pullback at the deepest level is handled by the distributivity of the + direct sum over pullbacks. *) + Definition abses_es_directsum_dsplice (n : nat) {A A'' : AbGroup@{u}} + (xi : AbSES A'' A) + : forall {B B' : AbGroup@{u}} (E : abses_es n B A'') (F : abses_es n B' A''), + abses_es_direct_sum n.+1 (abses_es_dsplice n xi E) (abses_es_dsplice n xi F) + = abses_es_dsplice n (abses_direct_sum xi xi) (abses_es_direct_sum n E F). + Proof. + induction n as [|n1 IH]; intros B B' E F. + - exact (abses_directsum_distributive_pullbacks E F)^. + - destruct n1 as [|n0]. + + reflexivity. + + srapply path_sigma'. + 1: reflexivity. + srapply path_prod. + 1: exact (IH E.1 F.1 (fst E.2) (fst F.2)). + reflexivity. + Defined. + +End Operations. + +(** ** The relation [⤳] *) + +Section Relation. + Context `{Univalence}. + + (** The relation [E ⤳ F] of Christensen-Flaten: equality in low degrees, + and otherwise a homomorphism of the intermediate modules under which + the leading sequences push out and the trailing sequences pull back to + matching ones. *) + Definition abses_es_rel (n : nat) {B A : AbGroup@{u}} + : abses_es n B A -> abses_es n B A -> Type. + Proof. + revert B A; induction n as [|n1 IH]; intros B A. + - exact (fun E F => E = F). + - destruct n1 as [|n0]. + + exact (fun E F => E = F). + + intros E F. + exact { beta : ab_hom E.1 F.1 + & IH E.1 A (fst E.2) (abses_es_pullback n0.+1 beta (fst F.2)) + * (abses_pushout beta (snd E.2) = snd F.2) }. + Defined. + + (** The relation is preserved by pullback along [beta], since [beta] only + touches the leading short exact sequence. *) + Definition abses_es_rel_pullback (n : nat) + {A B B' : AbGroup@{u}} (beta : B' $-> B) + : forall X Y : abses_es n B A, abses_es_rel n X Y + -> abses_es_rel n (abses_es_pullback n beta X) (abses_es_pullback n beta Y). + Proof. + destruct n as [|[|n0]]; intros X Y r. + - exact (ap (abses_es_pullback 0 beta) r). + - exact (ap (abses_es_pullback 1 beta) r). + - exists r.1. + exact (fst r.2, + abses_pushout_pullback_reorder (snd X.2) r.1 beta + @ ap (abses_pullback beta) (snd r.2)). + Defined. + + (** The relation is preserved by pushout along [alpha], using that pushout + commutes with the pullback appearing in the relation. *) + Definition abses_es_rel_pushout (n : nat) + {A A' : AbGroup@{u}} (alpha : A $-> A') (B : AbGroup@{u}) + : forall E F : abses_es n B A, abses_es_rel n E F + -> abses_es_rel n (abses_es_pushout n alpha E) (abses_es_pushout n alpha F). + Proof. + revert B; induction n as [|n1 IH]; intro B. + - intros E F r; exact (ap (abses_es_pushout 0 alpha) r). + - destruct n1 as [|n0]. + + intros E F r; exact (ap (abses_es_pushout 1 alpha) r). + + intros E F r. + exists r.1. + exact (transport + (abses_es_rel n0.+1 (abses_es_pushout n0.+1 alpha (fst E.2))) + (abses_es_pushout_pullback n0.+1 alpha r.1 (fst F.2)) + (IH E.1 (fst E.2) (abses_es_pullback n0.+1 r.1 (fst F.2)) (fst r.2)), + snd r.2). + Defined. + + (** The relation is reflexive, witnessed by the identity homomorphism. *) + Definition abses_es_rel_refl (n : nat) {B A : AbGroup@{u}} + (E : abses_es n B A) + : abses_es_rel n E E. + Proof. + revert B A E; induction n as [|n1 IH]; intros B A E. + - reflexivity. + - destruct n1 as [|n0]. + + reflexivity. + + exists grp_homo_id. + exact (transport (abses_es_rel n0.+1 (fst E.2)) + (abses_es_pullback_id n0.+1 (fst E.2))^ + (IH E.1 A (fst E.2)), + abses_pushout_id (snd E.2)). + Defined. + + (** The relation is transitive: compose the intermediate homomorphisms, + pulling the second witness back along the first and reassembling the + pushout square by functoriality. *) + Definition abses_es_rel_trans (n : nat) {B A : AbGroup@{u}} + : forall X Y Z : abses_es n B A, + abses_es_rel n X Y -> abses_es_rel n Y Z -> abses_es_rel n X Z. + Proof. + revert B A; induction n as [|n1 IH]; intros B A. + - intros X Y Z r1 r2; exact (r1 @ r2). + - destruct n1 as [|n0]. + + intros X Y Z r1 r2; exact (r1 @ r2). + + intros X Y Z r1 r2. + exists (grp_homo_compose r2.1 r1.1). + refine (_, _). + * refine (IH _ _ _ _ _ (fst r1.2) _). + exact (transport + (abses_es_rel n0.+1 (abses_es_pullback n0.+1 r1.1 (fst Y.2))) + (abses_es_pullback_compose n0.+1 r1.1 r2.1 (fst Z.2))^ + (abses_es_rel_pullback n0.+1 r1.1 (fst Y.2) + (abses_es_pullback n0.+1 r2.1 (fst Z.2)) (fst r2.2))). + * exact (abses_pushout_compose r1.1 r2.1 (snd X.2) + @ ap (abses_pushout r2.1) (snd r1.2) @ snd r2.2). + Defined. + + (** The direct sum respects the relation in both arguments, composing the + two intermediate homomorphisms with [functor_ab_biprod]. *) + Definition abses_es_direct_sum_rel (n : nat) + : forall {B A B' A' : AbGroup@{u}} (E E' : abses_es n B A) (F F' : abses_es n B' A'), + abses_es_rel n E E' -> abses_es_rel n F F' + -> abses_es_rel n (abses_es_direct_sum n E F) (abses_es_direct_sum n E' F'). + Proof. + induction n as [|n1 IH]; intros B A B' A'. + - intros E E' F F' rE rF; exact (ap011 (abses_es_direct_sum 0) rE rF). + - destruct n1 as [|n0]. + + intros E E' F F' rE rF; exact (ap011 (abses_es_direct_sum 1) rE rF). + + intros E E' F F' rE rF. + exists (functor_ab_biprod rE.1 rF.1). + refine (_, _). + * exact (transport + (abses_es_rel n0.+1 (abses_es_direct_sum n0.+1 (fst E.2) (fst F.2))) + (abses_es_directsum_pullback n0.+1 rE.1 rF.1 (fst E'.2) (fst F'.2)) + (IH E.1 A F.1 A' (fst E.2) (abses_es_pullback n0.+1 rE.1 (fst E'.2)) + (fst F.2) (abses_es_pullback n0.+1 rF.1 (fst F'.2)) + (fst rE.2) (fst rF.2))). + * exact (abses_directsum_distributive_pushouts rE.1 rF.1 + @ ap011 abses_direct_sum (snd rE.2) (snd rF.2)). + Defined. + + (** Swapping the two summands of a direct sum is, up to the relation, the + same as conjugating by [direct_sum_swap] on both ends. In degrees at + least two the intermediate modules differ, so this is a relation rather + than an equality. *) + Definition abses_es_directsum_swap (n : nat) + : forall {B A B' A' : AbGroup@{u}} (E : abses_es n B A) (F : abses_es n B' A'), + abses_es_rel n (abses_es_direct_sum n E F) + (abses_es_pushout n direct_sum_swap + (abses_es_pullback n direct_sum_swap (abses_es_direct_sum n F E))). + Proof. + induction n as [|n1 IH]; intros B A B' A'. + - intros E F; apply equiv_path_grouphomomorphism; reflexivity. + - destruct n1 as [|n0]. + + intros E F. + transitivity (abses_pushout grp_homo_id (abses_direct_sum E F)). + 1: exact (abses_pushout_id _)^. + transitivity (abses_pushout (grp_homo_compose direct_sum_swap direct_sum_swap) + (abses_direct_sum E F)). + { napply (ap (fun h => abses_pushout h (abses_direct_sum E F))). + symmetry; apply equiv_path_grouphomomorphism; reflexivity. } + refine (abses_pushout_compose direct_sum_swap direct_sum_swap _ @ _). + exact (ap (abses_pushout direct_sum_swap) + (abses_pushout_is_pullback (abses_swap_morphism E F))). + + intros E F. + exists direct_sum_swap. + refine (_, _). + * exact (transport + (abses_es_rel n0.+1 (abses_es_direct_sum n0.+1 (fst E.2) (fst F.2))) + (abses_es_pushout_pullback n0.+1 direct_sum_swap direct_sum_swap + (abses_es_direct_sum n0.+1 (fst F.2) (fst E.2))) + (IH E.1 A F.1 A' (fst E.2) (fst F.2))). + * exact (abses_pushout_is_pullback (abses_swap_morphism (snd E.2) (snd F.2))). + Defined. + + (** The triple direct sum, twisted by [ab_biprod_twist], is the conjugate of + the reversed triple sum; the analog of [abses_es_directsum_swap] used for + associativity. *) + Definition abses_es_directsum_twist (n : nat) + : forall {B1 A1 B2 A2 B3 A3 : AbGroup@{u}} + (E : abses_es n B1 A1) (F : abses_es n B2 A2) (G : abses_es n B3 A3), + abses_es_rel n (abses_es_direct_sum n (abses_es_direct_sum n E F) G) + (abses_es_pushout n ab_biprod_twist + (abses_es_pullback n ab_biprod_twist + (abses_es_direct_sum n (abses_es_direct_sum n G F) E))). + Proof. + induction n as [|n1 IH]; intros B1 A1 B2 A2 B3 A3. + - intros E F G; apply equiv_path_grouphomomorphism; reflexivity. + - destruct n1 as [|n0]. + + intros E F G. + transitivity (abses_pushout grp_homo_id + (abses_direct_sum (abses_direct_sum E F) G)). + 1: exact (abses_pushout_id _)^. + transitivity (abses_pushout (grp_homo_compose ab_biprod_twist ab_biprod_twist) + (abses_direct_sum (abses_direct_sum E F) G)). + { napply (ap (fun h => abses_pushout h + (abses_direct_sum (abses_direct_sum E F) G))). + symmetry; apply equiv_path_grouphomomorphism; reflexivity. } + refine (abses_pushout_compose ab_biprod_twist ab_biprod_twist _ @ _). + exact (ap (abses_pushout ab_biprod_twist) + (abses_pushout_is_pullback (abses_twist_directsum' E F G))). + + intros E F G. + exists ab_biprod_twist. + refine (_, _). + * exact (transport + (abses_es_rel n0.+1 (abses_es_direct_sum n0.+1 + (abses_es_direct_sum n0.+1 (fst E.2) (fst F.2)) (fst G.2))) + (abses_es_pushout_pullback n0.+1 ab_biprod_twist ab_biprod_twist + (abses_es_direct_sum n0.+1 + (abses_es_direct_sum n0.+1 (fst G.2) (fst F.2)) (fst E.2))) + (IH E.1 A1 F.1 A2 G.1 A3 (fst E.2) (fst F.2) (fst G.2))). + * exact (abses_pushout_is_pullback + (abses_twist_directsum' (snd E.2) (snd F.2) (snd G.2))). + Defined. + + (** The Baer sum respects the relation in both arguments, since each of its + three constituent operations does. *) + Definition abses_es_baer_sum_rel (n : nat) {B A : AbGroup@{u}} + {E E' F F' : abses_es n B A} + (rE : abses_es_rel n E E') (rF : abses_es_rel n F F') + : abses_es_rel n (abses_es_baer_sum n E F) (abses_es_baer_sum n E' F') + := abses_es_rel_pullback n ab_diagonal _ _ + (abses_es_rel_pushout n ab_codiagonal _ _ _ + (abses_es_direct_sum_rel n E E' F F' rE rF)). + + (** The Baer sum is commutative: the swap-conjugation relation is carried + by the codiagonal pushout and diagonal pullback, which absorb the swap + on each end. *) + Definition abses_es_baer_sum_comm (n : nat) {B A : AbGroup@{u}} + (E F : abses_es n B A) + : abses_es_rel n (abses_es_baer_sum n E F) (abses_es_baer_sum n F E). + Proof. + snrefine (transport (abses_es_rel n (abses_es_baer_sum n E F)) _ + (abses_es_rel_pullback n ab_diagonal _ _ + (abses_es_rel_pushout n ab_codiagonal _ _ _ + (abses_es_directsum_swap n E F)))). + unfold abses_es_baer_sum. + transitivity (abses_es_pullback n ab_diagonal + (abses_es_pushout n ab_codiagonal + (abses_es_pullback n direct_sum_swap (abses_es_direct_sum n F E)))). + { napply (ap (abses_es_pullback n ab_diagonal)). + refine ((abses_es_pushout_compose n direct_sum_swap ab_codiagonal _ _)^ @ _). + napply (ap (fun h => abses_es_pushout n h + (abses_es_pullback n direct_sum_swap (abses_es_direct_sum n F E)))). + exact ab_codiagonal_swap. } + transitivity (abses_es_pullback n ab_diagonal + (abses_es_pullback n direct_sum_swap + (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n F E)))). + { napply (ap (abses_es_pullback n ab_diagonal)). + exact (abses_es_pushout_pullback n ab_codiagonal direct_sum_swap + (abses_es_direct_sum n F E)). } + exact (abses_es_pullback_compose n ab_diagonal direct_sum_swap + (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n F E)))^. + Defined. + + (** The trinary Baer sum is symmetric under reversing the outer summands, + by the same argument as commutativity with [ab_biprod_twist] in place of + [direct_sum_swap]. *) + Definition abses_es_trinary_twist (n : nat) {B A : AbGroup@{u}} + (E F G : abses_es n B A) + : abses_es_rel n (abses_es_trinary_baer_sum n E F G) + (abses_es_trinary_baer_sum n G F E). + Proof. + snrefine (transport (abses_es_rel n (abses_es_trinary_baer_sum n E F G)) _ + (abses_es_rel_pullback n ab_triagonal _ _ + (abses_es_rel_pushout n ab_cotriagonal _ _ _ + (abses_es_directsum_twist n E F G)))). + unfold abses_es_trinary_baer_sum. + transitivity (abses_es_pullback n ab_triagonal + (abses_es_pushout n ab_cotriagonal + (abses_es_pullback n ab_biprod_twist + (abses_es_direct_sum n (abses_es_direct_sum n G F) E)))). + { napply (ap (abses_es_pullback n ab_triagonal)). + refine ((abses_es_pushout_compose n ab_biprod_twist ab_cotriagonal _ _)^ @ _). + napply (ap (fun h => abses_es_pushout n h + (abses_es_pullback n ab_biprod_twist + (abses_es_direct_sum n (abses_es_direct_sum n G F) E)))). + exact ab_cotriagonal_twist. } + transitivity (abses_es_pullback n ab_triagonal + (abses_es_pullback n ab_biprod_twist + (abses_es_pushout n ab_cotriagonal + (abses_es_direct_sum n (abses_es_direct_sum n G F) E)))). + { napply (ap (abses_es_pullback n ab_triagonal)). + exact (abses_es_pushout_pullback n ab_cotriagonal ab_biprod_twist + (abses_es_direct_sum n (abses_es_direct_sum n G F) E)). } + exact (abses_es_pullback_compose n ab_triagonal ab_biprod_twist + (abses_es_pushout n ab_cotriagonal + (abses_es_direct_sum n (abses_es_direct_sum n G F) E)))^. + Defined. + + (** The left-associated Baer sum equals the trinary Baer sum: move the inner + diagonal and codiagonal out through the outer direct sum, then combine + with the outer ones into the triagonal and cotriagonal. *) + Definition abses_es_baer_sum_is_trinary (n : nat) {B A : AbGroup@{u}} + (E F G : abses_es n B A) + : abses_es_baer_sum n (abses_es_baer_sum n E F) G + = abses_es_trinary_baer_sum n E F G. + Proof. + unfold abses_es_baer_sum, abses_es_trinary_baer_sum. + transitivity (abses_es_pullback n ab_diagonal + (abses_es_pushout n ab_codiagonal + (abses_es_pullback n (functor_ab_biprod ab_diagonal grp_homo_id) + (abses_es_pushout n (functor_ab_biprod ab_codiagonal grp_homo_id) + (abses_es_direct_sum n (abses_es_direct_sum n E F) G))))). + { napply (ap (fun z => abses_es_pullback n ab_diagonal + (abses_es_pushout n ab_codiagonal z))). + transitivity (abses_es_direct_sum n + (abses_es_pullback n ab_diagonal + (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F))) + (abses_es_pullback n grp_homo_id G)). + 1: exact (ap (abses_es_direct_sum n _) (abses_es_pullback_id n G)^). + transitivity (abses_es_pullback n (functor_ab_biprod ab_diagonal grp_homo_id) + (abses_es_direct_sum n + (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F)) G)). + 1: exact (abses_es_directsum_pullback n ab_diagonal grp_homo_id _ G). + napply (ap (abses_es_pullback n (functor_ab_biprod ab_diagonal grp_homo_id))). + transitivity (abses_es_direct_sum n + (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F)) + (abses_es_pushout n grp_homo_id G)). + 1: exact (ap (abses_es_direct_sum n _) (abses_es_pushout_id n G)^). + exact (abses_es_directsum_pushout n ab_codiagonal grp_homo_id _ G)^. } + transitivity (abses_es_pullback n ab_diagonal + (abses_es_pullback n (functor_ab_biprod ab_diagonal grp_homo_id) + (abses_es_pushout n ab_codiagonal + (abses_es_pushout n (functor_ab_biprod ab_codiagonal grp_homo_id) + (abses_es_direct_sum n (abses_es_direct_sum n E F) G))))). + { napply (ap (abses_es_pullback n ab_diagonal)). + exact (abses_es_pushout_pullback n ab_codiagonal + (functor_ab_biprod ab_diagonal grp_homo_id) + (abses_es_pushout n (functor_ab_biprod ab_codiagonal grp_homo_id) + (abses_es_direct_sum n (abses_es_direct_sum n E F) G))). } + refine ((abses_es_pullback_compose n ab_diagonal + (functor_ab_biprod ab_diagonal grp_homo_id) _)^ @ _). + napply (ap (abses_es_pullback n ab_triagonal)). + exact (abses_es_pushout_compose n (functor_ab_biprod ab_codiagonal grp_homo_id) + ab_codiagonal _ (abses_es_direct_sum n (abses_es_direct_sum n E F) G))^. + Defined. + + (** Twisting the order of a left-associated triple Baer sum, via the trinary + form. *) + Definition abses_es_baer_sum_twist (n : nat) {B A : AbGroup@{u}} + (E F G : abses_es n B A) + : abses_es_rel n (abses_es_baer_sum n (abses_es_baer_sum n E F) G) + (abses_es_baer_sum n (abses_es_baer_sum n G F) E) + := transport (fun p => abses_es_rel n p + (abses_es_baer_sum n (abses_es_baer_sum n G F) E)) + (abses_es_baer_sum_is_trinary n E F G)^ + (transport (abses_es_rel n (abses_es_trinary_baer_sum n E F G)) + (abses_es_baer_sum_is_trinary n G F E)^ + (abses_es_trinary_twist n E F G)). + + (** The Baer sum is associative, by combining the twist with commutativity. *) + Definition abses_es_baer_sum_assoc (n : nat) {B A : AbGroup@{u}} + (E F G : abses_es n B A) + : abses_es_rel n (abses_es_baer_sum n (abses_es_baer_sum n E F) G) + (abses_es_baer_sum n E (abses_es_baer_sum n F G)). + Proof. + refine (abses_es_rel_trans n _ _ _ (abses_es_baer_sum_twist n E F G) _). + refine (abses_es_rel_trans n _ _ _ + (abses_es_baer_sum_comm n (abses_es_baer_sum n G F) E) _). + exact (abses_es_baer_sum_rel n (abses_es_rel_refl n E) + (abses_es_baer_sum_comm n G F)). + Defined. + + (** Adding the split zero sequence on the deep end and projecting away the + trivial factor recovers the original, up to reindexing the base. This is + the engine of the unit law; the leading sequence uses [abses_absorb_trivial] + and the trailing sequence recurses. *) + Definition abses_es_absorb_zero (m : nat) {A : AbGroup@{u}} + : forall {C : AbGroup@{u}} (X : abses_es m C A), + abses_es_rel m + (abses_es_pushout m ab_codiagonal + (abses_es_direct_sum m X (@abses_es_zero _ m A abgroup_trivial))) + (abses_es_pullback m ab_biprod_pr1 X). + Proof. + induction m as [|m1 IH]; intros C X. + - apply equiv_path_grouphomomorphism; intro x; cbn; apply grp_unit_r. + - destruct m1 as [|m0]. + + exact (abses_absorb_trivial X). + + exists ab_biprod_pr1. + refine (IH X.1 (fst X.2), _). + pose (cst := @grp_homo_const abgroup_trivial X.1). + transitivity (abses_pushout (ab_codiagonal $o functor_ab_biprod grp_homo_id cst) + (abses_direct_sum (snd X.2) + (point (AbSES abgroup_trivial abgroup_trivial)))). + { napply (ap (fun h => abses_pushout h + (abses_direct_sum (snd X.2) + (point (AbSES abgroup_trivial abgroup_trivial))))). + apply equiv_path_grouphomomorphism; intro x; cbn; symmetry; apply grp_unit_r. } + transitivity (abses_pushout ab_codiagonal + (abses_pushout (functor_ab_biprod grp_homo_id cst) + (abses_direct_sum (snd X.2) + (point (AbSES abgroup_trivial abgroup_trivial))))). + 1: exact (abses_pushout_compose _ _ _). + transitivity (abses_pushout ab_codiagonal + (abses_direct_sum (abses_pushout grp_homo_id (snd X.2)) + (abses_pushout cst + (point (AbSES abgroup_trivial abgroup_trivial))))). + 1: napply (ap (abses_pushout ab_codiagonal)); + exact (abses_directsum_distributive_pushouts _ _). + transitivity (abses_pushout ab_codiagonal + (abses_direct_sum (snd X.2) + (point (AbSES abgroup_trivial X.1)))). + { napply (ap (abses_pushout ab_codiagonal)). + napply (ap011 abses_direct_sum). + - exact (abses_pushout_id _). + - exact (abses_pushout_const _). } + exact (abses_absorb_trivial (snd X.2)). + Defined. + + (** The split sequence is a right unit for the Baer sum: the trailing + sequence is handled by [abses_es_absorb_zero] and the leading one by the + degree-one unit law. *) + Definition abses_es_baer_sum_unit (n : nat) {B A : AbGroup@{u}} + (E : abses_es n B A) + : abses_es_rel n (abses_es_baer_sum n E (abses_es_zero n)) E. + Proof. + destruct n as [|[|n0]]. + - apply equiv_path_grouphomomorphism; intro x; cbn; apply grp_unit_r. + - exact (baer_sum_unit_r E). + - exists ab_biprod_pr1. + refine (abses_es_absorb_zero n0.+1 (fst E.2), _). + pose (cst := @grp_homo_const abgroup_trivial E.1). + transitivity (abses_pullback ab_diagonal + (abses_pushout ab_biprod_pr1 + (abses_direct_sum (snd E.2) (point (AbSES B abgroup_trivial))))). + 1: exact (abses_pushout_pullback_reorder _ _ _). + transitivity (abses_pullback ab_diagonal + (abses_pushout (ab_codiagonal $o functor_ab_biprod grp_homo_id cst) + (abses_direct_sum (snd E.2) (point (AbSES B abgroup_trivial))))). + { napply (ap (fun h => abses_pullback ab_diagonal + (abses_pushout h + (abses_direct_sum (snd E.2) (point (AbSES B abgroup_trivial)))))). + apply equiv_path_grouphomomorphism; intro x; cbn; symmetry; apply grp_unit_r. } + transitivity (abses_pullback ab_diagonal + (abses_pushout ab_codiagonal + (abses_pushout (functor_ab_biprod grp_homo_id cst) + (abses_direct_sum (snd E.2) + (point (AbSES B abgroup_trivial)))))). + 1: napply (ap (abses_pullback ab_diagonal)); exact (abses_pushout_compose _ _ _). + transitivity (abses_pullback ab_diagonal + (abses_pushout ab_codiagonal + (abses_direct_sum (abses_pushout grp_homo_id (snd E.2)) + (abses_pushout cst (point (AbSES B abgroup_trivial)))))). + 1: napply (ap (fun s => abses_pullback ab_diagonal (abses_pushout ab_codiagonal s))); + exact (abses_directsum_distributive_pushouts _ _). + transitivity (abses_pullback ab_diagonal + (abses_pushout ab_codiagonal + (abses_direct_sum (snd E.2) (point (AbSES B E.1))))). + { napply (ap (fun s => abses_pullback ab_diagonal (abses_pushout ab_codiagonal s))); + napply (ap011 abses_direct_sum); + [ exact (abses_pushout_id _) | exact (abses_pushout_const _) ]. } + exact (baer_sum_unit_r (snd E.2)). + Defined. + + (** Pushing a sequence out along the zero map gives the split sequence: the + leading sequence becomes split and the trailing sequence recurses. *) + Definition abses_es_zero_absorb (m : nat) {A A' : AbGroup@{u}} + : forall {C : AbGroup@{u}} (X : abses_es m C A), + abses_es_rel m (abses_es_pushout m (@grp_homo_const A A') X) + (@abses_es_zero _ m A' C). + Proof. + induction m as [|m1 IH]; intros C X. + - apply equiv_path_grouphomomorphism; reflexivity. + - destruct m1 as [|m0]. + + exact (abses_pushout_const X). + + exists grp_homo_const. + refine (transport + (abses_es_rel m0.+1 + (abses_es_pushout m0.+1 (@grp_homo_const A A') (fst X.2))) + (@abses_es_pullback_zero _ m0.+1 A' X.1)^ + (IH X.1 (fst X.2)), _). + exact (abses_pushout_const (snd X.2)). + Defined. + + (** Pushing out along the diagonal of the deep end agrees, up to the + relation, with pulling the self-direct-sum back along the diagonal of the + base; the length-[n] analogue of [abses_pushout_is_pullback] for the + diagonal morphism. *) + Definition abses_es_diagonal_is_pullback (n : nat) + : forall {B A : AbGroup@{u}} (E : abses_es n B A), + abses_es_rel n (abses_es_pushout n ab_diagonal E) + (abses_es_pullback n ab_diagonal (abses_es_direct_sum n E E)). + Proof. + induction n as [|n1 IH]; intros B A E. + - apply equiv_path_grouphomomorphism; reflexivity. + - destruct n1 as [|n0]. + + exact (abses_pushout_is_pullback (abses_diagonal E)). + + exists ab_diagonal. + refine (IH E.1 A (fst E.2), _). + exact (abses_pushout_is_pullback (abses_diagonal (snd E.2))). + Defined. + + (** The Baer sum of [E] with its negation [pushout (-id) E] is related to the + split sequence: feeding the diagonal lemma through [phi = a - a'] turns it + into [pushout 0 E], which the zero-absorb lemma sends to the split. *) + Definition abses_es_baer_sum_inv (n : nat) {B A : AbGroup@{u}} + (E : abses_es n B A) + : abses_es_rel n (abses_es_pushout n grp_homo_const E) + (abses_es_baer_sum n E (abses_es_pushout n ab_homo_negation E)). + Proof. + pose (phi := ab_codiagonal $o functor_ab_biprod grp_homo_id (ab_homo_negation : A $-> A)). + assert (eq1 : abses_es_pushout n grp_homo_const E + = abses_es_pushout n phi (abses_es_pushout n ab_diagonal E)). + { transitivity (abses_es_pushout n (phi $o ab_diagonal) E). + - napply (ap (fun h => abses_es_pushout n h E)). + apply equiv_path_grouphomomorphism; intro a; cbn; symmetry; apply grp_inv_r. + - exact (abses_es_pushout_compose n ab_diagonal phi B E). } + assert (eq2 : abses_es_pushout n phi + (abses_es_pullback n ab_diagonal (abses_es_direct_sum n E E)) + = abses_es_baer_sum n E (abses_es_pushout n ab_homo_negation E)). + { unfold abses_es_baer_sum. + transitivity (abses_es_pullback n ab_diagonal + (abses_es_pushout n phi (abses_es_direct_sum n E E))). + 1: exact (abses_es_pushout_pullback n phi ab_diagonal (abses_es_direct_sum n E E)). + napply (ap (abses_es_pullback n ab_diagonal)). + transitivity (abses_es_pushout n ab_codiagonal + (abses_es_pushout n (functor_ab_biprod grp_homo_id (ab_homo_negation : A $-> A)) + (abses_es_direct_sum n E E))). + 1: exact (abses_es_pushout_compose n + (functor_ab_biprod grp_homo_id (ab_homo_negation : A $-> A)) ab_codiagonal + (ab_biprod B B) (abses_es_direct_sum n E E)). + napply (ap (abses_es_pushout n ab_codiagonal)). + transitivity (abses_es_direct_sum n (abses_es_pushout n grp_homo_id E) + (abses_es_pushout n ab_homo_negation E)). + 1: exact (abses_es_directsum_pushout n grp_homo_id (ab_homo_negation : A $-> A) E E). + napply (ap (fun s => abses_es_direct_sum n s + (abses_es_pushout n ab_homo_negation E))). + exact (abses_es_pushout_id n E). } + exact (transport (abses_es_rel n (abses_es_pushout n grp_homo_const E)) eq2 + (transport (fun X => abses_es_rel n X + (abses_es_pushout n phi + (abses_es_pullback n ab_diagonal (abses_es_direct_sum n E E)))) + eq1^ + (abses_es_rel_pushout n phi B _ _ + (abses_es_diagonal_is_pullback n E)))). + Defined. + + (** The deep-end splice respects the relation, so the connecting map is + well-defined on Ext. *) + Definition abses_es_dsplice_rel (n : nat) {A A'' : AbGroup@{u}} + (xi : AbSES A'' A) (B : AbGroup@{u}) + : forall e e' : abses_es n B A'', abses_es_rel n e e' + -> abses_es_rel n.+1 (abses_es_dsplice n xi e) (abses_es_dsplice n xi e'). + Proof. + revert B; induction n as [|n1 IH]; intro B. + - intros e e' r; exact (ap (fun f => abses_pullback f xi) r). + - destruct n1 as [|n0]. + + intros e e' r. + exact (transport (abses_es_rel 2 (abses_es_dsplice 1 xi e)) + (ap (abses_es_dsplice 1 xi) r) + (abses_es_rel_refl 2 (abses_es_dsplice 1 xi e))). + + intros e e' r. + exists r.1. + refine (transport (abses_es_rel n0.+2 (abses_es_dsplice n0.+1 xi (fst e.2))) + (abses_es_dsplice_pullback n0.+1 xi r.1 (fst e'.2)) + (IH e.1 (fst e.2) (abses_es_pullback n0.+1 r.1 (fst e'.2)) (fst r.2)), + snd r.2). + Defined. + + (** The junction identity for the connecting map: splicing the pullback + [abses_pullback g zeta] onto [W] is related to splicing [zeta] onto [W] + after pushing the deep end out along [g]. At the deepest level this is + the pushout-pullback adjunction [abses_pushout_is_pullback]; for the base + case it is the composition of pullbacks; deeper levels recurse with the + identity. *) + Definition abses_es_dsplice_pushout_rel (n : nat) {A C D : AbGroup@{u}} + (zeta : AbSES C A) (g : D $-> C) + : forall {B : AbGroup@{u}} (W : abses_es n B D), + abses_es_rel n.+1 + (abses_es_dsplice n (abses_pullback g zeta) W) + (abses_es_dsplice n zeta (abses_es_pushout n g W)). + Proof. + induction n as [|n1 IH]; intro B. + - exact (fun W => abses_pullback_compose W g zeta). + - destruct n1 as [|n0]. + + intro W. + exists g. + exact (idpath, idpath). + + intro W. + exists grp_homo_id. + exact (transport + (abses_es_rel n0.+2 + (abses_es_dsplice n0.+1 (abses_pullback g zeta) (fst W.2))) + (abses_es_pullback_id n0.+2 + (abses_es_dsplice n0.+1 zeta (abses_es_pushout n0.+1 g (fst W.2))))^ + (IH W.1 (fst W.2)), + abses_pushout_id (snd W.2)). + Defined. + + (** Splicing the split short exact sequence onto the deep end gives the zero + sequence: the spliced [pt] becomes split and the recursion proceeds as in + [abses_es_zero_absorb]. *) + Definition abses_es_dsplice_point (n : nat) {A A'' : AbGroup@{u}} + : forall {B : AbGroup@{u}} (X : abses_es n B A''), + abses_es_rel n.+1 (abses_es_dsplice n (point (AbSES A'' A)) X) + (@abses_es_zero _ n.+1 A B). + Proof. + induction n as [|n1 IH]; intros B X. + - exact (abses_pullback_point X). + - destruct n1 as [|n0]. + + exists grp_homo_const. + exact ((abses_pullback_point _)^, abses_pushout_const X). + + exists grp_homo_const. + refine (transport + (abses_es_rel n0.+2 + (abses_es_dsplice n0.+1 (point (AbSES A'' A)) (fst X.2))) + (@abses_es_pullback_zero _ n0.+2 A X.1)^ + (IH X.1 (fst X.2)), _). + exact (abses_pushout_const (snd X.2)). + Defined. + + (** Splicing a fixed short exact sequence onto the front respects the + relation in the trailing sequence, witnessed by the identity. *) + Definition abses_es_splice_rel {A C : AbGroup@{u}} (m : nat) + {B : AbGroup@{u}} (s : AbSES B C) {E E' : abses_es m C A} + (r : abses_es_rel m E E') + : abses_es_rel m.+1 (abses_es_splice m E s) (abses_es_splice m E' s). + Proof. + destruct m as [|m0]. + - exact (ap (fun f => abses_pushout f s) r). + - exists grp_homo_id. + exact (transport (abses_es_rel m0.+1 E) + (abses_es_pullback_id m0.+1 E')^ r, + abses_pushout_id s). + Defined. + + (** The base splice is additive: it carries the Baer sum to the Baer sum, so + the contravariant connecting map is a homomorphism. Since the base splice + merely prepends [xi] (no recursion), the witness for [n >= 1] is the + diagonal, with the trailing reflexive and the leading short exact sequence + handled by [abses_pushout_is_pullback (abses_diagonal xi)]. In degree zero + it is the distributivity of the Baer sum over pushouts. *) + Definition abses_es_splice_baer_sum (n : nat) {A B' B'' : AbGroup@{u}} + (xi : AbSES B'' B') (E F : abses_es n B' A) + : abses_es_rel n.+1 (abses_es_splice n (abses_es_baer_sum n E F) xi) + (abses_es_baer_sum n.+1 (abses_es_splice n E xi) (abses_es_splice n F xi)). + Proof. + destruct n as [|n0]. + - change (abses_pushout (abses_es_baer_sum 0 E F) xi + = abses_baer_sum (abses_pushout E xi) (abses_pushout F xi)). + refine (_ @ baer_sum_distributive_pushouts (E:=xi) E F). + napply (ap (fun h => abses_pushout h xi)). + apply equiv_path_grouphomomorphism; intro b; reflexivity. + - exists ab_diagonal. + exact (abses_es_rel_refl n0.+1 _, abses_pushout_is_pullback (abses_diagonal xi)). + Defined. + + (** Splicing commutes with pullback in the base: the pulled-back base only + meets the leading sequence. *) + Definition abses_es_splice_pullback {A C : AbGroup@{u}} (m : nat) + {B B' : AbGroup@{u}} (beta : B' $-> B) (E : abses_es m C A) (s : AbSES B C) + : abses_es_pullback m.+1 beta (abses_es_splice m E s) + = abses_es_splice m E (abses_pullback beta s). + Proof. + destruct m as [|m0]. + - exact (abses_pushout_pullback_reorder s E beta)^. + - reflexivity. + Defined. + + (** Splicing commutes with pushout in the deep end. *) + Definition abses_es_splice_pushout {C : AbGroup@{u}} (m : nat) + {A A' : AbGroup@{u}} (alpha : A $-> A') {B : AbGroup@{u}} + (E : abses_es m C A) (s : AbSES B C) + : abses_es_pushout m.+1 alpha (abses_es_splice m E s) + = abses_es_splice m (abses_es_pushout m alpha E) s. + Proof. + destruct m as [|m0]. + - exact (abses_pushout_compose E alpha s)^. + - reflexivity. + Defined. + + (** The direct sum of two base-splices is the base-splice of the direct + sums. *) + Definition abses_es_directsum_splice (m : nat) + {A C A' C' B B' : AbGroup@{u}} (s : AbSES B C) (t : AbSES B' C') + (X : abses_es m C A) (Y : abses_es m C' A') + : abses_es_direct_sum m.+1 (abses_es_splice m X s) (abses_es_splice m Y t) + = abses_es_splice m (abses_es_direct_sum m X Y) (abses_direct_sum s t). + Proof. + destruct m as [|m0]. + - exact (abses_directsum_distributive_pushouts X Y)^. + - reflexivity. + Defined. + + (** The junction identity for the base splice: splicing the pullback + [pullback g X] onto [s] is related to splicing [X] onto [s] pushed out + along [g]. As the base splice merely prepends, this is a single + relation witnessed by [g]. *) + Definition abses_es_splice_pushout_rel {A C C' : AbGroup@{u}} (m : nat) + (g : C' $-> C) {B : AbGroup@{u}} (s : AbSES B C') (X : abses_es m C A) + : abses_es_rel m.+1 (abses_es_splice m (abses_es_pullback m g X) s) + (abses_es_splice m X (abses_pushout g s)). + Proof. + destruct m as [|m0]. + - exact (abses_pushout_compose g X s). + - exists g. + exact (abses_es_rel_refl m0.+1 _, idpath). + Defined. + + (** The length-[n] analogue of [abses_pushout_is_pullback] for the + codiagonal: pushing the self-direct-sum out along the deep codiagonal + agrees, up to the relation, with pulling back along the base + codiagonal. *) + Definition abses_es_codiagonal_is_pullback (n : nat) + : forall {B A : AbGroup@{u}} (E : abses_es n B A), + abses_es_rel n (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E E)) + (abses_es_pullback n ab_codiagonal E). + Proof. + induction n as [|n1 IH]; intros B A E. + - apply equiv_path_grouphomomorphism; intro x; exact (grp_homo_op E _ _)^. + - destruct n1 as [|n0]. + + exact (abses_pushout_is_pullback (abses_codiagonal E)). + + exists ab_codiagonal. + exact (IH E.1 A (fst E.2), + abses_pushout_is_pullback (abses_codiagonal (snd E.2))). + Defined. + +End Relation. + +(** ** The higher Ext groups *) + +Section HigherExt. + Context `{Univalence}. + + (** The set-quotient of a type by its path relation is its 0-truncation. *) + Definition equiv_quotient_paths_tr (X : Type@{u}) + : Quotient (fun x y : X => x = y) <~> Tr 0 X. + Proof. + srapply equiv_adjointify. + - srapply Quotient_rec. + + exact tr. + + intros x y p; exact (ap tr p). + - srapply Trunc_rec; exact (class_of _). + - srapply Trunc_ind; intro x; reflexivity. + - srapply Quotient_ind_hprop; intro x; reflexivity. + Defined. + + (** The [n]-th Ext group is the set-quotient of length-[n] exact sequences + by the relation [abses_es_rel]. For [n] at most one this recovers the + set of homomorphisms and the usual [Ext]. *) + Definition abses_ext (n : nat) (B A : AbGroup@{u}) : Type + := Quotient (abses_es_rel n (B:=B) (A:=A)). + + (** In degree zero the relation is equality of homomorphisms, so the + quotient is the group of homomorphisms. *) + Definition equiv_abses_ext_hom (B A : AbGroup@{u}) + : abses_ext 0 B A <~> ab_hom B A + := (@equiv_tr 0 (ab_hom B A) _)^-1%equiv oE equiv_quotient_paths_tr _. + + (** In degree one the relation is equality of short exact sequences, so the + quotient is the usual [Ext]. *) + Definition equiv_abses_ext_one (B A : AbGroup@{u}) + : abses_ext 1 B A <~> Ext B A + := equiv_quotient_paths_tr _. + + (** Pullback descends to the quotient, making [abses_ext n -- A] a + contravariant functor. *) + Definition abses_ext_pullback (n : nat) {A : AbGroup@{u}} + {B B' : AbGroup@{u}} (beta : B' $-> B) + : abses_ext n B A -> abses_ext n B' A + := Quotient_functor _ _ (abses_es_pullback n beta) (abses_es_rel_pullback n beta). + + (** Pullback along the identity is the identity. *) + Definition abses_ext_pullback_id (n : nat) {B A : AbGroup@{u}} + : abses_ext_pullback n (A:=A) (grp_homo_id (G:=B)) == idmap. + Proof. + srapply Quotient_ind_hprop; intro E. + apply (ap (class_of _)), abses_es_pullback_id. + Defined. + + (** Pullback is contravariantly functorial. *) + Definition abses_ext_pullback_compose (n : nat) + {A B0 B1 B2 : AbGroup@{u}} (f : B0 $-> B1) (g : B1 $-> B2) + : abses_ext_pullback n (A:=A) (g $o f) + == abses_ext_pullback n f o abses_ext_pullback n g. + Proof. + srapply Quotient_ind_hprop; intro E. + apply (ap (class_of _)), abses_es_pullback_compose. + Defined. + + (** Pushout descends to the quotient, making [abses_ext n B --] a covariant + functor. *) + Definition abses_ext_pushout (n : nat) {B : AbGroup@{u}} + {A A' : AbGroup@{u}} (alpha : A $-> A') + : abses_ext n B A -> abses_ext n B A' + := Quotient_functor _ _ (abses_es_pushout n alpha) (abses_es_rel_pushout n alpha B). + + (** Pushout along the identity is the identity. *) + Definition abses_ext_pushout_id (n : nat) {B A : AbGroup@{u}} + : abses_ext_pushout n (B:=B) (grp_homo_id (G:=A)) == idmap. + Proof. + srapply Quotient_ind_hprop; intro E. + apply (ap (class_of _)), abses_es_pushout_id. + Defined. + + (** Pushout is covariantly functorial. *) + Definition abses_ext_pushout_compose (n : nat) {B : AbGroup@{u}} + {A0 A1 A2 : AbGroup@{u}} (f : A0 $-> A1) (g : A1 $-> A2) + : abses_ext_pushout n (B:=B) (g $o f) + == abses_ext_pushout n g o abses_ext_pushout n f. + Proof. + srapply Quotient_ind_hprop; intro E. + apply (ap (class_of _)), abses_es_pushout_compose. + Defined. + + (** The pushout and pullback actions on Ext commute, so [abses_ext n] is a + bifunctor, contravariant in the base and covariant in the deep end. *) + Definition abses_ext_pushout_pullback (n : nat) + {A A' B B' : AbGroup@{u}} (alpha : A $-> A') (beta : B' $-> B) + : abses_ext_pushout n alpha o abses_ext_pullback n beta + == abses_ext_pullback n beta o abses_ext_pushout n alpha. + Proof. + srapply Quotient_ind_hprop; intro E. + apply (ap (class_of _)), abses_es_pushout_pullback. + Defined. + + (** Splicing a fixed short exact sequence descends to a map of Ext groups, + raising the degree. *) + Definition abses_ext_splice {A C : AbGroup@{u}} (m : nat) + {B : AbGroup@{u}} (s : AbSES B C) + : abses_ext m C A -> abses_ext m.+1 B A + := Quotient_functor _ _ (fun E => abses_es_splice m E s) + (fun E E' => abses_es_splice_rel m s (E:=E) (E':=E')). + + (** The splice depends only on the class of the short exact sequence in + [Ext], since the target is a set. This is the Yoneda product + [Ext B C -> Ext^m C A -> Ext^{m+1} B A]. *) + Definition abses_ext_yoneda {A C : AbGroup@{u}} (m : nat) + {B : AbGroup@{u}} (t : Ext B C) + : abses_ext m C A -> abses_ext m.+1 B A + := fun x => Trunc_rec (fun s => abses_ext_splice m s x) t. + + (** On a represented class it computes to the underlying splice. *) + Definition abses_ext_yoneda_tr {A C : AbGroup@{u}} (m : nat) + {B : AbGroup@{u}} (s : AbSES B C) (x : abses_ext m C A) + : abses_ext_yoneda m (tr s) x = abses_ext_splice m s x + := idpath. + + (** The connecting map of the long exact sequence: a short exact sequence + [xi : AbSES A'' A] of coefficients raises the degree, [Ext^n B A'' -> + Ext^{n+1} B A]. *) + Definition abses_ext_dsplice (n : nat) {A A'' : AbGroup@{u}} (xi : AbSES A'' A) + {B : AbGroup@{u}} + : abses_ext n B A'' -> abses_ext n.+1 B A + := Quotient_functor _ _ (abses_es_dsplice n xi) (abses_es_dsplice_rel n xi B). + + (** The connecting map is natural in the deep coefficient: pushing out along + [alpha] after splicing [xi] is splicing the pushed-out sequence. *) + Definition abses_ext_dsplice_pushout (n : nat) {A A2 A'' : AbGroup@{u}} + (xi : AbSES A'' A) (alpha : A $-> A2) {B : AbGroup@{u}} + (x : abses_ext n B A'') + : abses_ext_pushout n.+1 alpha (abses_ext_dsplice n xi x) + = abses_ext_dsplice n (abses_pushout alpha xi) x. + Proof. + revert x; srapply Quotient_ind_hprop; intro Y. + exact (ap (class_of _) (abses_es_dsplice_pushout n xi alpha Y)). + Defined. + + (** The connecting map is natural in the base: splicing [xi] commutes with + pullback along [beta]. *) + Definition abses_ext_dsplice_pullback (n : nat) {A A'' : AbGroup@{u}} + (xi : AbSES A'' A) {B B' : AbGroup@{u}} (beta : B' $-> B) + (x : abses_ext n B A'') + : abses_ext_dsplice n xi (abses_ext_pullback n beta x) + = abses_ext_pullback n.+1 beta (abses_ext_dsplice n xi x). + Proof. + revert x; srapply Quotient_ind_hprop; intro Y. + exact (ap (class_of _) (abses_es_dsplice_pullback n xi beta Y)). + Defined. + + (** The Baer sum descends to a binary operation on the [n]-th Ext. *) + Definition abses_ext_baer_sum (n : nat) {B A : AbGroup@{u}} + : abses_ext n B A -> abses_ext n B A -> abses_ext n B A. + Proof. + srapply Quotient_rec2. + - exact (fun E F => class_of _ (abses_es_baer_sum n E F)). + - intros E E' F rE; apply qglue. + exact (abses_es_baer_sum_rel n rE (abses_es_rel_refl n F)). + - intros E F F' rF; apply qglue. + exact (abses_es_baer_sum_rel n (abses_es_rel_refl n E) rF). + Defined. + + (** The connecting map is additive: it carries the Baer sum to the Baer sum, + so the splice [Ext^n B A'' -> Ext^{n+1} B A] is a homomorphism. This is + the bilinearity of the Yoneda splice in the deep-end variable; the only + nontrivial step is the junction identity [abses_es_dsplice_pushout_rel], + after rewriting [abses_pullback ab_codiagonal xi] as a pushout via + [abses_pushout_is_pullback]. *) + Definition abses_ext_dsplice_baer_sum (n : nat) {A A'' : AbGroup@{u}} + (xi : AbSES A'' A) {B : AbGroup@{u}} (x y : abses_ext n B A'') + : abses_ext_dsplice n xi (abses_ext_baer_sum n x y) + = abses_ext_baer_sum n.+1 (abses_ext_dsplice n xi x) (abses_ext_dsplice n xi y). + Proof. + revert x y; srapply Quotient_ind2_hprop; intros E F. + refine (ap (class_of _) + (abses_es_dsplice_pullback n xi ab_diagonal + (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F))) @ _). + refine (_ @ (ap (class_of _) + (ap (abses_es_pullback n.+1 ab_diagonal) + (ap (abses_es_pushout n.+1 ab_codiagonal) + (abses_es_directsum_dsplice n xi E F) + @ abses_es_dsplice_pushout n (abses_direct_sum xi xi) + ab_codiagonal (abses_es_direct_sum n E F))))^). + refine (_ @ (ap (class_of _) + (ap (abses_es_pullback n.+1 ab_diagonal) + (ap (fun z => abses_es_dsplice n z (abses_es_direct_sum n E F)) + (abses_pushout_is_pullback (abses_codiagonal xi)))))^). + symmetry; apply qglue. + exact (abses_es_rel_pullback n.+1 ab_diagonal _ _ + (abses_es_dsplice_pushout_rel n xi ab_codiagonal + (abses_es_direct_sum n E F))). + Defined. + + (** The contravariant connecting map (base splice) is additive: it carries the + Baer sum to the Baer sum, so it is a homomorphism [Ext^n B' A -> + Ext^{n+1} B'' A]. *) + Definition abses_ext_splice_baer_sum (n : nat) {A B' B'' : AbGroup@{u}} + (xi : AbSES B'' B') (x y : abses_ext n B' A) + : abses_ext_splice n xi (abses_ext_baer_sum n x y) + = abses_ext_baer_sum n.+1 (abses_ext_splice n xi x) (abses_ext_splice n xi y). + Proof. + revert x y; srapply Quotient_ind2_hprop; intros E F. + exact (qglue (abses_es_splice_baer_sum n xi E F)). + Defined. + + (** The base splice is additive in the short exact sequence slot: it carries + the Baer sum of [s] and [t] to the Baer sum of the splices. Both sides + reduce, via the base-pullback and deep-pushout commutations and the + junction, to a splice of [pullback Delta (direct_sum s t)]; the two deep + arguments [pullback codiagonal X] and [pushout codiagonal (X (+) X)] are + then identified by [abses_es_codiagonal_is_pullback]. *) + Definition abses_ext_splice_baer_sum_ses (n : nat) {A B' B'' : AbGroup@{u}} + (s t : AbSES B'' B') (x : abses_ext n B' A) + : abses_ext_splice n (abses_baer_sum s t) x + = abses_ext_baer_sum n.+1 (abses_ext_splice n s x) (abses_ext_splice n t x). + Proof. + revert x; srapply Quotient_ind_hprop; intro X. + refine (ap (class_of _) (abses_es_splice_pullback n ab_diagonal X + (abses_pushout ab_codiagonal (abses_direct_sum s t)))^ @ _). + refine ((qglue (abses_es_rel_pullback n.+1 ab_diagonal _ _ + (abses_es_splice_pushout_rel n ab_codiagonal + (abses_direct_sum s t) X)))^ @ _). + refine (ap (class_of _) (abses_es_splice_pullback n ab_diagonal + (abses_es_pullback n ab_codiagonal X) (abses_direct_sum s t)) @ _). + refine ((qglue (abses_es_splice_rel n + (abses_pullback ab_diagonal (abses_direct_sum s t)) + (abses_es_codiagonal_is_pullback n X)))^ @ _). + refine (ap (class_of _) (abses_es_splice_pullback n ab_diagonal + (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n X X)) + (abses_direct_sum s t))^ @ _). + refine (ap (class_of _) (ap (abses_es_pullback n.+1 ab_diagonal) + (abses_es_splice_pushout n ab_codiagonal + (abses_es_direct_sum n X X) (abses_direct_sum s t))^) @ _). + exact (ap (class_of _) (ap (abses_es_pullback n.+1 ab_diagonal) + (ap (abses_es_pushout n.+1 ab_codiagonal) + (abses_es_directsum_splice n s t X X)^))). + Defined. + + (** The Baer sum on the [n]-th Ext is commutative. *) + Definition abses_ext_baer_sum_comm (n : nat) {B A : AbGroup@{u}} + (x y : abses_ext n B A) + : abses_ext_baer_sum n x y = abses_ext_baer_sum n y x. + Proof. + revert x y; srapply Quotient_ind2_hprop; intros E F. + exact (qglue (abses_es_baer_sum_comm n E F)). + Defined. + + (** The Baer sum on the [n]-th Ext is associative. *) + Definition abses_ext_baer_sum_assoc (n : nat) {B A : AbGroup@{u}} + (x y z : abses_ext n B A) + : abses_ext_baer_sum n (abses_ext_baer_sum n x y) z + = abses_ext_baer_sum n x (abses_ext_baer_sum n y z). + Proof. + revert x y z. + srapply Quotient_ind_hprop; intro E. + srapply Quotient_ind_hprop; intro F. + srapply Quotient_ind_hprop; intro G. + exact (qglue (abses_es_baer_sum_assoc n E F G)). + Defined. + + (** The class of the split sequence is the neutral element. *) + Definition abses_ext_zero (n : nat) (B A : AbGroup@{u}) : abses_ext n B A + := class_of _ (@abses_es_zero _ n A B). + + (** It is a right and left unit for the Baer sum. *) + Definition abses_ext_baer_sum_unit_r (n : nat) {B A : AbGroup@{u}} + (x : abses_ext n B A) + : abses_ext_baer_sum n x (abses_ext_zero n B A) = x. + Proof. + revert x; srapply Quotient_ind_hprop; intro E. + exact (qglue (abses_es_baer_sum_unit n E)). + Defined. + + Definition abses_ext_baer_sum_unit_l (n : nat) {B A : AbGroup@{u}} + (x : abses_ext n B A) + : abses_ext_baer_sum n (abses_ext_zero n B A) x = x + := abses_ext_baer_sum_comm n _ x @ abses_ext_baer_sum_unit_r n x. + + (** Pushout along negation is an additive inverse for the Baer sum. *) + Definition abses_ext_baer_sum_inv_r (n : nat) {B A : AbGroup@{u}} + (x : abses_ext n B A) + : abses_ext_baer_sum n x (abses_ext_pushout n ab_homo_negation x) + = abses_ext_zero n B A. + Proof. + revert x; srapply Quotient_ind_hprop; intro E. + exact ((qglue (abses_es_baer_sum_inv n E))^ @ qglue (abses_es_zero_absorb n E)). + Defined. + + Definition abses_ext_baer_sum_inv_l (n : nat) {B A : AbGroup@{u}} + (x : abses_ext n B A) + : abses_ext_baer_sum n (abses_ext_pushout n ab_homo_negation x) x + = abses_ext_zero n B A + := abses_ext_baer_sum_comm n _ x @ abses_ext_baer_sum_inv_r n x. + + (** The [n]-th Ext is a group under the Baer sum. *) + Definition grp_abses_ext (n : nat) (B A : AbGroup@{u}) : Group. + Proof. + snapply (Build_Group (abses_ext n B A)). + - exact (abses_ext_baer_sum n). + - exact (abses_ext_zero n B A). + - exact (abses_ext_pushout n ab_homo_negation). + - repeat split. + + exact _. + + intros x y z; symmetry; apply abses_ext_baer_sum_assoc. + + intro x; apply abses_ext_baer_sum_unit_l. + + intro x; apply abses_ext_baer_sum_unit_r. + + intro x; apply abses_ext_baer_sum_inv_l. + + intro x; apply abses_ext_baer_sum_inv_r. + Defined. + + (** In fact it is abelian. *) + Definition ab_abses_ext (n : nat) (B A : AbGroup@{u}) : AbGroup. + Proof. + snapply (Build_AbGroup (grp_abses_ext n B A)). + intros x y; apply abses_ext_baer_sum_comm. + Defined. + + (** Pushout and pullback are group homomorphisms for the Baer sum, so + [ab_abses_ext n] is a bifunctor valued in abelian groups. *) + Definition grp_homo_abses_ext_pushout (n : nat) {B : AbGroup@{u}} + {A A' : AbGroup@{u}} (alpha : A $-> A') + : ab_abses_ext n B A $-> ab_abses_ext n B A'. + Proof. + snapply Build_GroupHomomorphism. + - exact (abses_ext_pushout n alpha). + - intros x y; revert x y. + srapply Quotient_ind2_hprop; intros E F. + exact (ap (class_of _) (abses_es_pushout_baer_sum n alpha E F)). + Defined. + + Definition grp_homo_abses_ext_pullback (n : nat) {A : AbGroup@{u}} + {B B' : AbGroup@{u}} (beta : B' $-> B) + : ab_abses_ext n B A $-> ab_abses_ext n B' A. + Proof. + snapply Build_GroupHomomorphism. + - exact (abses_ext_pullback n beta). + - intros x y; revert x y. + srapply Quotient_ind2_hprop; intros E F. + exact (ap (class_of _) (abses_es_pullback_baer_sum n beta E F)). + Defined. + + (** The connecting map of the long exact sequence, as a homomorphism + [Ext^n B A'' -> Ext^{n+1} B A]. *) + Definition grp_homo_abses_ext_dsplice (n : nat) {A A'' : AbGroup@{u}} + (xi : AbSES A'' A) {B : AbGroup@{u}} + : ab_abses_ext n B A'' $-> ab_abses_ext n.+1 B A. + Proof. + snapply Build_GroupHomomorphism. + - exact (abses_ext_dsplice n xi). + - intros x y; apply abses_ext_dsplice_baer_sum. + Defined. + + (** The contravariant connecting map, as a homomorphism + [Ext^n B' A -> Ext^{n+1} B'' A] from a short exact sequence of bases. *) + Definition grp_homo_abses_ext_splice (n : nat) {A B' B'' : AbGroup@{u}} + (xi : AbSES B'' B') + : ab_abses_ext n B' A $-> ab_abses_ext n.+1 B'' A. + Proof. + snapply Build_GroupHomomorphism. + - exact (abses_ext_splice n xi). + - intros x y; apply abses_ext_splice_baer_sum. + Defined. + + (** Pushing out along the zero map lands in the zero class. *) + Definition abses_ext_pushout_const (n : nat) {B A A' : AbGroup@{u}} + (x : abses_ext n B A) + : abses_ext_pushout n (@grp_homo_const A A') x = abses_ext_zero n B A'. + Proof. + revert x; srapply Quotient_ind_hprop; intro E. + exact (qglue (abses_es_zero_absorb n E)). + Defined. + + (** The covariant Ext sequence of a coefficient short exact sequence is a + complex: pushing out along the inclusion then the projection vanishes. *) + Definition abses_ext_pushout_iscomplex (n : nat) {B A A'' : AbGroup@{u}} + (xi : AbSES A'' A) (x : abses_ext n B A) + : abses_ext_pushout n (projection xi) (abses_ext_pushout n (inclusion xi) x) + = abses_ext_zero n B A''. + Proof. + refine ((abses_ext_pushout_compose n (inclusion xi) (projection xi) x)^ @ _). + refine (_ @ abses_ext_pushout_const n x). + napply (ap (fun h => abses_ext_pushout n h x)). + apply equiv_path_grouphomomorphism; intro a. + pose proof (iscomplex_abses xi) as hc; unfold ExactSequence.IsComplex in hc. + destruct hc as [hc0 hc1]; exact (hc0 a). + Defined. + + (** Splicing the split short exact sequence descends to the zero class. *) + Definition abses_ext_dsplice_point (n : nat) {A A'' : AbGroup@{u}} + {B : AbGroup@{u}} (x : abses_ext n B A'') + : abses_ext_dsplice n (point (AbSES A'' A)) x = abses_ext_zero n.+1 B A. + Proof. + revert x; srapply Quotient_ind_hprop; intro X. + exact (qglue (abses_es_dsplice_point n X)). + Defined. + + (** The junction identity, descended to Ext. *) + Definition abses_ext_dsplice_junction (n : nat) {A C D : AbGroup@{u}} + (zeta : AbSES C A) (g : D $-> C) {B : AbGroup@{u}} (w : abses_ext n B D) + : abses_ext_dsplice n (abses_pullback g zeta) w + = abses_ext_dsplice n zeta (abses_ext_pushout n g w). + Proof. + revert w; srapply Quotient_ind_hprop; intro W. + exact (qglue (abses_es_dsplice_pushout_rel n zeta g W)). + Defined. + + (** The connecting map kills the image of the projection: the covariant Ext + sequence is a complex at [Ext^n B A'']. *) + Definition abses_ext_dsplice_projection_iscomplex (n : nat) + {A A'' : AbGroup@{u}} (xi : AbSES A'' A) {B : AbGroup@{u}} + (x : abses_ext n B xi) + : abses_ext_dsplice n xi (abses_ext_pushout n (projection xi) x) + = abses_ext_zero n.+1 B A. + Proof. + refine ((abses_ext_dsplice_junction n xi (projection xi) x)^ @ _). + refine (ap (fun z => abses_ext_dsplice n z x) (abses_pullback_projection xi)^ @ _). + exact (abses_ext_dsplice_point n x). + Defined. + + (** The image of the connecting map is killed by the inclusion: the covariant + Ext sequence is a complex at [Ext^{n+1} B A]. *) + Definition abses_ext_inclusion_dsplice_iscomplex (n : nat) + {A A'' : AbGroup@{u}} (xi : AbSES A'' A) {B : AbGroup@{u}} + (x : abses_ext n B A'') + : abses_ext_pushout n.+1 (inclusion xi) (abses_ext_dsplice n xi x) + = abses_ext_zero n.+1 B xi. + Proof. + refine (abses_ext_dsplice_pushout n xi (inclusion xi) x @ _). + refine (ap (fun z => abses_ext_dsplice n z x) (abses_pushout_inclusion xi) @ _). + exact (abses_ext_dsplice_point n x). + Defined. + + (** The connecting map is natural in the coefficient short exact sequence: a + morphism [phi : xi -> xi'] gives a commuting square relating the two + connecting maps via pushout along its end components. The proof routes + [abses_pushout_is_pullback phi] through the junction identity. *) + Definition abses_ext_dsplice_natural (n : nat) + {A A' A'' A''' : AbGroup@{u}} {xi : AbSES A'' A} {xi' : AbSES A''' A'} + (phi : AbSESMorphism xi xi') {B : AbGroup@{u}} (x : abses_ext n B A'') + : abses_ext_pushout n.+1 (component1 phi) (abses_ext_dsplice n xi x) + = abses_ext_dsplice n xi' (abses_ext_pushout n (component3 phi) x). + Proof. + refine (abses_ext_dsplice_pushout n xi (component1 phi) x @ _). + refine (ap (fun z => abses_ext_dsplice n z x) (abses_pushout_is_pullback phi) @ _). + exact (abses_ext_dsplice_junction n xi' (component3 phi) x). + Defined. + + (** Base pullback commutes with the base splice, descended to Ext. *) + Definition abses_ext_splice_pullback (n : nat) {A C B B2 : AbGroup@{u}} + (s : AbSES B C) (beta : B2 $-> B) (x : abses_ext n C A) + : abses_ext_pullback n.+1 beta (abses_ext_splice n s x) + = abses_ext_splice n (abses_pullback beta s) x. + Proof. + revert x; srapply Quotient_ind_hprop; intro X. + exact (ap (class_of _) (abses_es_splice_pullback n beta X s)). + Defined. + + (** The junction identity for the base splice, descended to Ext. *) + Definition abses_ext_splice_pullback_junction (n : nat) {A C C' : AbGroup@{u}} + (g : C' $-> C) {B : AbGroup@{u}} (s : AbSES B C') (y : abses_ext n C A) + : abses_ext_splice n s (abses_ext_pullback n g y) + = abses_ext_splice n (abses_pushout g s) y. + Proof. + revert y; srapply Quotient_ind_hprop; intro X. + exact (qglue (abses_es_splice_pushout_rel n g s X)). + Defined. + + (** Splicing the split short exact sequence onto the base is the zero map: + by additivity in the sequence slot the splice [Z] of [point] satisfies + [Z = Z + Z], hence [Z = 0]. *) + Definition abses_ext_splice_point (n : nat) {A B' B'' : AbGroup@{u}} + (x : abses_ext n B' A) + : abses_ext_splice n (point (AbSES B'' B')) x = abses_ext_zero n.+1 B'' A. + Proof. + refine ((grp_cancelL1 (G := ab_abses_ext n.+1 B'' A) + (z := abses_ext_splice n (point (AbSES B'' B')) x))^-1 _). + exact ((abses_ext_splice_baer_sum_ses n (point _) (point _) x)^ + @ ap (fun s => abses_ext_splice n s x) (baer_sum_unit_r (point _))). + Defined. + + (** The contravariant Ext sequence is a complex at [Ext^{n+1} B'' A]: the + connecting map [delta' = splice xi] composed with the projection pullback + vanishes. *) + Definition abses_ext_splice_projection_iscomplex (n : nat) + {A B' B'' : AbGroup@{u}} (xi : AbSES B'' B') (x : abses_ext n B' A) + : abses_ext_pullback n.+1 (projection xi) (abses_ext_splice n xi x) + = abses_ext_zero n.+1 xi A. + Proof. + refine (abses_ext_splice_pullback n xi (projection xi) x @ _). + refine (ap (fun s => abses_ext_splice n s x) (abses_pullback_projection xi)^ @ _). + exact (abses_ext_splice_point n x). + Defined. + + (** The contravariant Ext sequence is a complex at [Ext^n B' A]: the + inclusion pullback followed by the connecting map vanishes. *) + Definition abses_ext_inclusion_splice_iscomplex (n : nat) + {A B' B'' : AbGroup@{u}} (xi : AbSES B'' B') (x : abses_ext n xi A) + : abses_ext_splice n xi (abses_ext_pullback n (inclusion xi) x) + = abses_ext_zero n.+1 B'' A. + Proof. + refine (abses_ext_splice_pullback_junction n (inclusion xi) xi x @ _). + refine (ap (fun s => abses_ext_splice n s x) (abses_pushout_inclusion xi) @ _). + exact (abses_ext_splice_point n x). + Defined. + + (** Pulling back along the zero map lands in the zero class. *) + Definition abses_ext_pullback_const (n : nat) {A B' B'' : AbGroup@{u}} + (x : abses_ext n B'' A) + : abses_ext_pullback n (@grp_homo_const B' B'') x = abses_ext_zero n B' A. + Proof. + destruct n as [|[|n0]]; revert x; srapply Quotient_ind_hprop; intro X. + - apply (ap (class_of _)). + apply equiv_path_grouphomomorphism; intro b; exact (grp_homo_unit X). + - exact (ap (class_of _) (abses_pullback_const X)^). + - refine (ap (class_of _) (ap (fun s => (X.1; (fst X.2, s)) : abses_es n0.+2 B' A) + (abses_pullback_const (snd X.2))^) @ _). + exact (abses_ext_splice_point n0.+1 (class_of _ (fst X.2))). + Defined. + + (** The contravariant Ext sequence is a complex at [Ext^n M A]: the projection + pullback followed by the inclusion pullback vanishes. *) + Definition abses_ext_projection_inclusion_iscomplex (n : nat) + {A B' B'' : AbGroup@{u}} (xi : AbSES B'' B') (x : abses_ext n B'' A) + : abses_ext_pullback n (inclusion xi) (abses_ext_pullback n (projection xi) x) + = abses_ext_zero n B' A. + Proof. + refine ((abses_ext_pullback_compose n (inclusion xi) (projection xi) x)^ @ _). + refine (ap (fun h => abses_ext_pullback n h x) _ @ abses_ext_pullback_const n x). + apply equiv_path_grouphomomorphism; intro a. + pose proof (iscomplex_abses xi) as hc; unfold ExactSequence.IsComplex in hc. + destruct hc as [hc0 hc1]; exact (hc0 a). + Defined. + + (** The contravariant connecting map is natural in the base short exact + sequence: a morphism [phi : xi -> xi'] gives a commuting square relating + the two connecting maps via pullback along its end components. *) + Definition abses_ext_splice_natural (n : nat) + {A B' B'' D' D'' : AbGroup@{u}} {xi : AbSES B'' B'} {xi' : AbSES D'' D'} + (phi : AbSESMorphism xi xi') (x : abses_ext n D' A) + : abses_ext_splice n xi (abses_ext_pullback n (component1 phi) x) + = abses_ext_pullback n.+1 (component3 phi) (abses_ext_splice n xi' x). + Proof. + refine (abses_ext_splice_pullback_junction n (component1 phi) xi x @ _). + refine (ap (fun s => abses_ext_splice n s x) (abses_pushout_is_pullback phi) @ _). + exact (abses_ext_splice_pullback n xi' (component3 phi) x)^. + Defined. + + (** The Yoneda product, as a homomorphism in the second variable: a class + [t : Ext B C] gives a homomorphism [Ext^m C A -> Ext^{m+1} B A]. It is + well-defined on [Ext] because the splice is additive, and the target is a + set of homomorphisms. *) + Definition grp_homo_abses_ext_yoneda {A C : AbGroup@{u}} (m : nat) + {B : AbGroup@{u}} (t : Ext B C) + : ab_abses_ext m C A $-> ab_abses_ext m.+1 B A + := Trunc_rec (fun s => grp_homo_abses_ext_splice m s) t. + + (** If [E] splits after pushing out along [inclusion xi], it is the pullback + of [xi] along some [g : B $-> A'']. *) + Definition abses_inclusion_pushout_exact {A A'' : AbGroup@{u}} + (xi : AbSES A'' A) {B : AbGroup@{u}} (E : AbSES B A) + (h : abses_pushout (inclusion xi) E = point (AbSES B xi)) + : merely { g : ab_hom B A'' & abses_pullback g xi = E }. + Proof. + pose proof (abses_pushout_trivial_factors_inclusion (inclusion xi) E h) + as [phi hphi]. + assert (hkill : forall n : middle E, grp_image (inclusion E) n + -> (projection xi $o phi) n = mon_unit). + { intro n; srapply Trunc_rec; intros [a p]. + refine (ap (projection xi $o phi) p^ @ _). + refine (ap (projection xi) (equiv_path_grouphomomorphism^-1 hphi a)^ @ _). + pose proof (iscomplex_abses xi) as hc; unfold ExactSequence.IsComplex in hc. + destruct hc as [hc0 hc1]; exact (hc0 a). } + pose (g0 := quotient_abgroup_rec (grp_image (inclusion E)) A'' + (projection xi $o phi) hkill). + pose (g := grp_homo_compose g0 + (grp_iso_inverse (abses_cokernel_iso (inclusion E) (projection E)))). + snrefine (tr (g; (abses_pullback_component1_id + (Build_AbSESMorphism grp_homo_id phi g _ _) + (fun _ => idpath))^)). + - exact (equiv_path_grouphomomorphism^-1 hphi). + - intro e. + exact (ap g0 (abses_cokernel_iso_inv_beta (inclusion E) (projection E) e))^. + Defined. + + (** If [v] splits after pulling back along [projection xi], it is the pushout + of [xi] along some [g : B' $-> A]. *) + Definition abses_projection_pullback_exact {A B' B'' : AbGroup@{u}} + (xi : AbSES B'' B') (v : AbSES B'' A) + (h : abses_pullback (projection xi) v = point (AbSES xi A)) + : merely { g : ab_hom B' A & abses_pushout g xi = v }. + Proof. + pose proof (abses_pullback_trivial_factors_projection (projection xi) v h) + as [phi hphi]. + pose proof (iscomplex_abses xi) as hc; unfold ExactSequence.IsComplex in hc. + destruct hc as [hc0 hc1]. + pose (g0 := grp_kernel_corec (f:=projection v) (phi $o inclusion xi) + (fun b => (equiv_path_grouphomomorphism^-1 hphi (inclusion xi b))^ + @ hc0 b)). + pose (g := grp_homo_compose + (grp_iso_inverse (abses_kernel_iso (inclusion v) (projection v))) g0). + snrefine (tr (g; abses_pushout_component3_id + (Build_AbSESMorphism g phi grp_homo_id _ _) + (fun _ => idpath))). + - intro b. + exact (abses_kernel_iso_inv_beta (inclusion v) (projection v) (g0 b)). + - exact (fun m => (equiv_path_grouphomomorphism^-1 hphi m)^). + Defined. + + (** If [E] splits after pushing out along [projection xi], it is the pushout + along [inclusion xi] of some [E' : AbSES B A]. The witness [E'] is the + sub-extension of [E] on the kernel of the factoring map [phi]. *) + Definition abses_pushout_projection_exact {A A'' : AbGroup@{u}} + (xi : AbSES A'' A) {B : AbGroup@{u}} (E : AbSES B xi) + (h : abses_pushout (projection xi) E = point (AbSES B A'')) + : merely { E' : AbSES B A & abses_pushout (inclusion xi) E' = E }. + Proof. + pose proof (abses_pushout_trivial_factors_inclusion (projection xi) E h) + as [phi hphi]. + pose proof (iscomplex_abses xi) as hcx; unfold ExactSequence.IsComplex in hcx. + destruct hcx as [hcx0 hcx1]. + pose proof (iscomplex_abses E) as hcE; unfold ExactSequence.IsComplex in hcE. + destruct hcE as [hcE0 hcE1]. + assert (hkill : phi $o (inclusion E $o inclusion xi) == grp_homo_const). + { intro a. + exact ((equiv_path_grouphomomorphism^-1 hphi (inclusion xi a))^ @ hcx0 a). } + pose (iE' := grp_kernel_corec (inclusion E $o inclusion xi) hkill). + pose (sub := subgroup_incl (grp_kernel phi)). + snrefine (tr (Build_AbSES (ab_kernel phi) iE' + (grp_homo_compose (projection E) sub) _ _ _; _)). + - apply isembedding_isinj_hset; intros a a' p. + assert (beta : forall x, sub (iE' x) = inclusion E (inclusion xi x)) + by reflexivity. + exact (isinj_embedding (inclusion xi) _ a a' + (isinj_embedding (inclusion E) _ _ _ + ((beta a)^ @ ap sub p @ beta a'))). + - intro b. + rapply contr_inhabited_hprop. + assert (fe : merely (hfiber (projection E) b)) + by apply center, issurjection_projection. + strip_truncations; destruct fe as [e qe]. + assert (fm : merely (hfiber (projection xi) (phi e))) + by apply center, issurjection_projection. + strip_truncations; destruct fm as [mu qmu]. + assert (mem : phi (sg_op e (inv (inclusion E mu))) = mon_unit). + { refine (grp_homo_op phi e (inv (inclusion E mu)) @ _). + refine (ap (sg_op (phi e)) (grp_homo_inv phi (inclusion E mu)) @ _). + refine (ap (fun z => sg_op (phi e) (inv z)) + ((equiv_path_grouphomomorphism^-1 hphi mu)^ @ qmu) @ _). + exact (grp_inv_r (phi e)). } + refine (tr (((sg_op e (inv (inclusion E mu)); mem) + : grp_kernel phi); _)). + refine (grp_homo_op (projection E) e (inv (inclusion E mu)) @ _). + refine (ap (sg_op (projection E e)) + (grp_homo_inv (projection E) (inclusion E mu)) @ _). + refine (ap (fun z => sg_op (projection E e) (inv z)) (hcE0 mu) @ _). + refine (ap (sg_op (projection E e)) grp_inv_unit @ _). + exact (grp_unit_r _ @ qe). + - snapply Build_IsExact. + + srapply phomotopy_homotopy_hset. + intro a. + exact (hcE0 (inclusion xi a)). + + intros [m q]. + rapply contr_inhabited_hprop. + assert (fmu : merely (hfiber (inclusion E) (sub m))) + by exact (isexact_preimage (Tr (-1)) (inclusion E) (projection E) (sub m) q). + strip_truncations; destruct fmu as [mu rmu]. + assert (fa : merely (hfiber (inclusion xi) mu)) + by exact (isexact_preimage (Tr (-1)) (inclusion xi) (projection xi) mu + (equiv_path_grouphomomorphism^-1 hphi mu @ (ap phi rmu @ m.2))). + strip_truncations; destruct fa as [a ra]. + refine (tr (a; _)). + apply path_sigma_hprop. + apply path_sigma_hprop; cbn. + exact (ap (inclusion E) ra @ rmu). + - snrefine (abses_pushout_component3_id + (Build_AbSESMorphism (inclusion xi) _ grp_homo_id _ _) + (fun _ => idpath)). + + exact sub. + + exact (fun _ => idpath). + + exact (fun _ => idpath). + Defined. + + (** Exactness of the covariant sequence at [Ext B A]: the kernel of + [pushout (inclusion xi)] is the image of the connecting map from + [Hom B A'']. *) + Definition abses_ext_inclusion_exact_one {A A'' : AbGroup@{u}} (xi : AbSES A'' A) + {B : AbGroup@{u}} (v : abses_ext 1 B A) + : abses_ext_pushout 1 (inclusion xi) v = abses_ext_zero 1 B xi + -> merely { w : abses_ext 0 B A'' & abses_ext_dsplice 0 xi w = v }. + Proof. + revert v; srapply Quotient_ind_hprop; intros V h. + pose proof ((equiv_path_Tr _ _)^-1 + (ap (equiv_quotient_paths_tr (AbSES B xi)) h)) as hm. + strip_truncations. + pose proof (abses_inclusion_pushout_exact xi V hm) as hg. + strip_truncations; destruct hg as [g pq]. + exact (tr (class_of _ g; ap (class_of _) pq)). + Defined. + + (** Exactness of the covariant sequence at [Ext B (middle xi)]: the kernel of + [pushout (projection xi)] is the image of [pushout (inclusion xi)]. *) + Definition abses_ext_pushout_inclusion_exact_one {A A'' : AbGroup@{u}} + (xi : AbSES A'' A) {B : AbGroup@{u}} (v : abses_ext 1 B xi) + : abses_ext_pushout 1 (projection xi) v = abses_ext_zero 1 B A'' + -> merely { w : abses_ext 1 B A & abses_ext_pushout 1 (inclusion xi) w = v }. + Proof. + revert v; srapply Quotient_ind_hprop; intros V h. + pose proof ((equiv_path_Tr _ _)^-1 + (ap (equiv_quotient_paths_tr (AbSES B A'')) h)) as hm. + strip_truncations. + pose proof (abses_pushout_projection_exact xi V hm) as hE. + strip_truncations; destruct hE as [E' pq]. + exact (tr (class_of _ E'; ap (class_of _) pq)). + Defined. + + (** Exactness of the contravariant sequence at [Ext B'' A]: the kernel of + [pullback (projection xi)] is the image of the connecting map from + [Hom B' A]. *) + Definition abses_ext_pullback_projection_exact_one {A B' B'' : AbGroup@{u}} + (xi : AbSES B'' B') (v : abses_ext 1 B'' A) + : abses_ext_pullback 1 (projection xi) v = abses_ext_zero 1 xi A + -> merely { w : abses_ext 0 B' A & abses_ext_splice 0 xi w = v }. + Proof. + revert v; srapply Quotient_ind_hprop; intros V h. + pose proof ((equiv_path_Tr _ _)^-1 + (ap (equiv_quotient_paths_tr (AbSES xi A)) h)) as hm. + strip_truncations. + pose proof (abses_projection_pullback_exact xi V hm) as hg. + strip_truncations; destruct hg as [g pq]. + exact (tr (class_of _ g; ap (class_of _) pq)). + Defined. + + (** Exactness of the contravariant sequence at [Ext (middle xi) A]: the kernel + of [pullback (inclusion xi)] is the image of [pullback (projection xi)]. *) + Definition abses_ext_pullback_inclusion_exact_one {A B' B'' : AbGroup@{u}} + (xi : AbSES B'' B') (v : abses_ext 1 xi A) + : abses_ext_pullback 1 (inclusion xi) v = abses_ext_zero 1 B' A + -> merely { v'' : abses_ext 1 B'' A + & abses_ext_pullback 1 (projection xi) v'' = v }. + Proof. + revert v; srapply Quotient_ind_hprop; intros V h. + pose proof ((equiv_path_Tr _ _)^-1 + (ap (equiv_quotient_paths_tr (AbSES B' A)) h)) as hm. + strip_truncations. + pose (p := equiv_path_abses_iso^-1 hm). + refine (tr (class_of _ (abses_pullback_trivial_preimage xi V p); _)). + exact (ap (class_of _) (abses_pullback_component1_id + (abses_pullback_inclusion0_map' xi V p) (fun _ => idpath))^). + Defined. + + (** Exactness of the covariant sequence at [Hom B A'']: the kernel of the + connecting map is the image of postcomposition with [projection xi]. *) + Definition abses_ext_dsplice_projection_exact_zero {A A'' : AbGroup@{u}} + (xi : AbSES A'' A) {B : AbGroup@{u}} (w : abses_ext 0 B A'') + : abses_ext_dsplice 0 xi w = abses_ext_zero 1 B A + -> merely { w' : abses_ext 0 B xi + & abses_ext_pushout 0 (projection xi) w' = w }. + Proof. + revert w; srapply Quotient_ind_hprop; intros W h. + pose proof ((equiv_path_Tr _ _)^-1 + (ap (equiv_quotient_paths_tr (AbSES B A)) h)) as hm. + strip_truncations. + destruct (abses_pullback_trivial_factors_projection W xi hm) as [phi pq]. + exact (tr (class_of _ phi; ap (class_of _) pq^)). + Defined. + + (** Exactness of the covariant sequence at [Hom B (middle xi)]: the kernel of + postcomposition with [projection xi] is the image of postcomposition with + [inclusion xi]. *) + Definition abses_ext_pushout_projection_exact_zero {A A'' : AbGroup@{u}} + (xi : AbSES A'' A) {B : AbGroup@{u}} (f : abses_ext 0 B xi) + : abses_ext_pushout 0 (projection xi) f = abses_ext_zero 0 B A'' + -> merely { f' : abses_ext 0 B A & abses_ext_pushout 0 (inclusion xi) f' = f }. + Proof. + revert f; srapply Quotient_ind_hprop; intros F h. + pose proof ((equiv_path_Tr _ _)^-1 + (ap (equiv_quotient_paths_tr (ab_hom B A'')) h)) as hm. + strip_truncations. + pose (k := grp_kernel_corec (f:=projection xi) F + (equiv_path_grouphomomorphism^-1 hm)). + refine (tr (class_of _ (grp_homo_compose + (grp_iso_inverse (abses_kernel_iso (inclusion xi) (projection xi))) k); _)). + apply (ap (class_of _)). + apply equiv_path_grouphomomorphism; intro b. + exact (abses_kernel_iso_inv_beta (inclusion xi) (projection xi) (k b)). + Defined. + + (** Exactness of the contravariant sequence at [Hom (middle xi) A]: the kernel + of precomposition with [inclusion xi] is the image of precomposition with + [projection xi]. *) + Definition abses_ext_pullback_inclusion_exact_zero {A B' B'' : AbGroup@{u}} + (xi : AbSES B'' B') (g : abses_ext 0 xi A) + : abses_ext_pullback 0 (inclusion xi) g = abses_ext_zero 0 B' A + -> merely { f : abses_ext 0 B'' A & abses_ext_pullback 0 (projection xi) f = g }. + Proof. + revert g; srapply Quotient_ind_hprop; intros G h. + pose proof ((equiv_path_Tr _ _)^-1 + (ap (equiv_quotient_paths_tr (ab_hom B' A)) h)) as hm. + strip_truncations. + assert (hkill : forall n : middle xi, grp_image (inclusion xi) n -> G n = mon_unit). + { intros n; srapply Trunc_rec; intros [b r]. + refine (ap G r^ @ _). + exact (equiv_path_grouphomomorphism^-1 hm b). } + pose (f := grp_homo_compose + (quotient_abgroup_rec (grp_image (inclusion xi)) A G hkill) + (grp_iso_inverse (abses_cokernel_iso (inclusion xi) (projection xi)))). + refine (tr (class_of _ f; _)). + apply (ap (class_of _)). + apply equiv_path_grouphomomorphism; intro x. + exact (ap (quotient_abgroup_rec (grp_image (inclusion xi)) A G hkill) + (abses_cokernel_iso_inv_beta (inclusion xi) (projection xi) x)). + Defined. + + (** Exactness of the contravariant sequence at [Hom B' A]: the kernel of the + connecting map is the image of precomposition with [inclusion xi]. *) + Definition abses_ext_splice_inclusion_exact_zero {A B' B'' : AbGroup@{u}} + (xi : AbSES B'' B') (g : abses_ext 0 B' A) + : abses_ext_splice 0 xi g = abses_ext_zero 1 B'' A + -> merely { h : abses_ext 0 xi A & abses_ext_pullback 0 (inclusion xi) h = g }. + Proof. + revert g; srapply Quotient_ind_hprop; intros G h. + pose proof ((equiv_path_Tr _ _)^-1 + (ap (equiv_quotient_paths_tr (AbSES B'' A)) h)) as hm. + strip_truncations. + pose proof (abses_pushout_trivial_factors_inclusion G xi hm) as [phi hphi]. + exact (tr (class_of _ phi; ap (class_of _) hphi^)). + Defined. + + (** The covariant sequence is exact at [Hom B A]: postcomposition with + [inclusion xi] has trivial kernel. *) + Definition abses_ext_pushout_inclusion_injective_zero {A A'' : AbGroup@{u}} + (xi : AbSES A'' A) {B : AbGroup@{u}} (v : abses_ext 0 B A) + : abses_ext_pushout 0 (inclusion xi) v = abses_ext_zero 0 B xi + -> v = abses_ext_zero 0 B A. + Proof. + revert v; srapply Quotient_ind_hprop; intros F h. + pose proof ((equiv_path_Tr _ _)^-1 + (ap (equiv_quotient_paths_tr (ab_hom B xi)) h)) as hm. + strip_truncations. + apply (ap (class_of _)). + apply equiv_path_grouphomomorphism; intro b. + apply (isinj_embedding (inclusion xi) _). + exact (equiv_path_grouphomomorphism^-1 hm b @ (grp_homo_unit (inclusion xi))^). + Defined. + + (** The contravariant sequence is exact at [Hom B'' A]: precomposition with + [projection xi] has trivial kernel. *) + Definition abses_ext_pullback_projection_injective_zero {A B' B'' : AbGroup@{u}} + (xi : AbSES B'' B') (v : abses_ext 0 B'' A) + : abses_ext_pullback 0 (projection xi) v = abses_ext_zero 0 xi A + -> v = abses_ext_zero 0 B'' A. + Proof. + revert v; srapply Quotient_ind_hprop; intros F h. + pose proof ((equiv_path_Tr _ _)^-1 + (ap (equiv_quotient_paths_tr (ab_hom xi A)) h)) as hm. + strip_truncations. + apply (ap (class_of _)). + apply equiv_path_grouphomomorphism; intro b. + assert (fm : merely (hfiber (projection xi) b)) + by apply center, issurjection_projection. + strip_truncations; destruct fm as [m qm]. + exact ((ap F qm)^ @ equiv_path_grouphomomorphism^-1 hm m). + Defined. + + (** The Yoneda product is additive in the first variable: it carries the Baer + sum to the Baer sum of the products. *) + Definition abses_ext_yoneda_baer_sum_l {A C : AbGroup@{u}} (m : nat) + {B : AbGroup@{u}} (t t' : grp_ext B C) (x : abses_ext m C A) + : abses_ext_yoneda m (sg_op t t') x + = abses_ext_baer_sum m.+1 (abses_ext_yoneda m t x) (abses_ext_yoneda m t' x). + Proof. + revert t t'; srapply Trunc_ind; intro s; srapply Trunc_ind; intro s'. + exact (abses_ext_splice_baer_sum_ses m s s' x). + Defined. + + (** Splicing is surjective onto [Ext^{m+2}]: every length-[m.+2] extension is + a splice of a short exact sequence onto a length-[m.+1] extension. *) + Definition abses_ext_splice_surjective (m : nat) {A B : AbGroup@{u}} + (w : abses_ext m.+2 B A) + : merely { C : AbGroup@{u} & { s : AbSES B C + & { t : abses_ext m.+1 C A & w = abses_ext_splice m.+1 s t } } }. + Proof. + revert w; srapply Quotient_ind_hprop; intros [C [t s]]. + exact (tr (C; (s; (class_of _ t; idpath)))). + Defined. + + (** Higher Ext of a projective vanishes: [Ext^{n+1}(P, A)] is trivial for + every [A] when [P] is projective. *) + Definition abses_ext_projective_vanish {P : AbGroup@{u}} `{IsAbProjective P} + (n : nat) {A : AbGroup@{u}} (x : abses_ext n.+1 P A) + : x = abses_ext_zero n.+1 P A. + Proof. + destruct n as [|n]. + - pose proof (contr_equiv' (Ext P A) + (equiv_inverse (equiv_abses_ext_one P A))) as cc. + exact (path_contr x (abses_ext_zero 1 P A)). + - pose proof (abses_ext_splice_surjective n x) as hsurj. + strip_truncations. + destruct hsurj as [C [s [t p]]]. + refine (p @ (abses_ext_yoneda_tr n.+1 s t)^ @ _). + refine (ap (fun u => abses_ext_yoneda n.+1 u t) + (path_contr (tr s) (tr (point (AbSES P C)))) @ _). + refine (abses_ext_yoneda_tr n.+1 (point (AbSES P C)) t @ _). + exact (abses_ext_splice_point n.+1 t). + Defined. + + (** Splicing with a projective-middle short exact sequence is surjective onto + [Ext^{n+1}(B, A)]. *) + Definition abses_ext_splice_projective_surjective {K B : AbGroup@{u}} + (zeta : AbSES B K) `{IsAbProjective (middle zeta)} {A : AbGroup@{u}} + (n : nat) (w : abses_ext n.+1 B A) + : merely { x : abses_ext n K A & abses_ext_splice n zeta x = w }. + Proof. + destruct n as [|n]. + - refine (abses_ext_pullback_projection_exact_one zeta w _). + pose proof (contr_equiv' (Ext (middle zeta) A) + (equiv_inverse (equiv_abses_ext_one (middle zeta) A))) as cc. + exact (path_contr _ _). + - pose proof (abses_ext_splice_surjective n w) as hsurj. + strip_truncations; destruct hsurj as [C [s [t p]]]. + pose proof (contr_equiv' (Ext (middle zeta) C) + (equiv_inverse (equiv_abses_ext_one (middle zeta) C))) as cc. + pose proof (abses_ext_pullback_projection_exact_one zeta (class_of _ s) + (path_contr _ _)) as hg. + revert hg; apply Trunc_rec; intros [g pg]; revert g pg. + srapply Quotient_ind_hprop; intros g0 pg. + pose proof ((equiv_path_Tr _ _)^-1 + (ap (equiv_quotient_paths_tr (AbSES B C)) pg)) as hs. + strip_truncations. + refine (tr (abses_ext_pullback (S n) g0 t; _)). + refine (abses_ext_splice_pullback_junction (S n) g0 zeta t @ _). + exact (ap (fun S0 => abses_ext_splice (S n) S0 t) hs @ p^). + Defined. + + (** For a projective-middle [zeta], [Ext^1(B, A)] is the cokernel of + precomposition with [inclusion zeta]. *) + Definition ext_one_projective_presentation {K B : AbGroup@{u}} + (zeta : AbSES B K) `{IsAbProjective (middle zeta)} {A : AbGroup@{u}} + : GroupIsomorphism + (ab_cokernel (grp_homo_abses_ext_pullback 0 (A:=A) (inclusion zeta))) + (ab_abses_ext 1 B A). + Proof. + snapply (abses_cokernel_iso (grp_homo_abses_ext_pullback 0 (A:=A) (inclusion zeta)) + (grp_homo_abses_ext_splice 0 zeta)). + - intro b; rapply contr_inhabited_hprop. + exact (abses_ext_splice_projective_surjective zeta 0 b). + - snapply Build_IsExact. + + srapply phomotopy_homotopy_hset; intro f. + exact (abses_ext_inclusion_splice_iscomplex 0 zeta f). + + intros [g0 hg0]. + rapply contr_inhabited_hprop. + pose proof (abses_ext_splice_inclusion_exact_zero zeta g0 hg0) as hpre. + strip_truncations; destruct hpre as [h ph]. + refine (tr (h; _)). + apply path_sigma_hprop; exact ph. + Defined. + + (** [Ext^{n+2}(B, A)] vanishes when [zeta : AbSES B K] has projective middle + and projective kernel. *) + Definition abses_ext_vanish_short_resolution {K B : AbGroup@{u}} + (zeta : AbSES B K) `{IsAbProjective (middle zeta)} `{IsAbProjective K} + {A : AbGroup@{u}} (n : nat) (x : abses_ext n.+2 B A) + : x = abses_ext_zero n.+2 B A. + Proof. + pose proof (abses_ext_splice_projective_surjective zeta n.+1 x) as hsurj. + strip_truncations; destruct hsurj as [y py]. + refine (py^ @ ap (abses_ext_splice n.+1 zeta) (abses_ext_projective_vanish n y) @ _). + exact (grp_homo_unit (grp_homo_abses_ext_splice n.+1 zeta)). + Defined. + + (** The higher Ext groups [Ext^{m+2}(Z/n, A)] of a cyclic group vanish. *) + Definition abses_ext_cyclic_higher_vanish (n : nat) + `{IsEmbedding (Z1_mul_nat n)} {A : AbGroup@{u}} (m : nat) + (x : abses_ext m.+2 (ab_cokernel_embedding (Z1_mul_nat n)) A) + : x = abses_ext_zero m.+2 (ab_cokernel_embedding (Z1_mul_nat n)) A + := abses_ext_vanish_short_resolution (abses_from_inclusion (Z1_mul_nat n)) m x. + + (** Pulling back along a sum of homomorphisms is the Baer sum of the + pullbacks, so [Ext^n(-, A)] is additive in the homomorphism. *) + Definition abses_ext_pullback_plus (n : nat) {A B B' : AbGroup@{u}} + (f g : B' $-> B) (x : abses_ext n B A) + : abses_ext_pullback n (sg_op f g) x + = abses_ext_baer_sum n (abses_ext_pullback n f x) (abses_ext_pullback n g x). + Proof. + destruct n as [|[|n]]; revert x; srapply Quotient_ind_hprop. + - intro phi. + apply (ap (class_of _)). + apply equiv_path_grouphomomorphism; intro b. + exact (grp_homo_op phi (f b) (g b)). + - intro E. + exact (ap (class_of _) (baer_sum_distributive_pullbacks f g)). + - intros [C [t s]]. + refine (abses_ext_splice_pullback n.+1 s (sg_op f g) (class_of _ t) @ _). + refine (ap (fun S0 => abses_ext_splice n.+1 S0 (class_of _ t)) + (baer_sum_distributive_pullbacks f g) @ _). + refine (abses_ext_splice_baer_sum_ses n.+1 (abses_pullback f s) + (abses_pullback g s) (class_of _ t) @ _). + exact (ap011 (abses_ext_baer_sum n.+2) + (abses_ext_splice_pullback n.+1 s f (class_of _ t))^ + (abses_ext_splice_pullback n.+1 s g (class_of _ t))^). + Defined. + +End HigherExt. + +(** ** Universality of the higher Ext delta-functor *) + +(** A coefficient [G] and a target contravariant additive family [T] with + connecting maps [Tdelta], natural in the short exact sequence. *) + +Section ExtUniversal. + Context `{Univalence} (G : AbGroup@{u}). + Context (T : nat -> AbGroup@{u} -> AbGroup@{u}) + (Tmap : forall (n : nat) {B B' : AbGroup@{u}}, + (B' $-> B) -> (T n B $-> T n B')) + (Tmap_id : forall (n : nat) (B : AbGroup@{u}) (x : T n B), + Tmap n grp_homo_id x = x) + (Tmap_comp : forall (n : nat) {B B' B'' : AbGroup@{u}} + (f : B' $-> B) (g : B'' $-> B') (x : T n B), + Tmap n (f $o g) x = Tmap n g (Tmap n f x)) + (Tdelta : forall (n : nat) {A B : AbGroup@{u}}, + AbSES B A -> (T n A $-> T (S n) B)) + (Tdelta_nat : forall (n : nat) {A B A' B' : AbGroup@{u}} + (E : AbSES B A) (E' : AbSES B' A') (phi : AbSESMorphism E E') + (x : T n A'), + Tdelta n E (Tmap n (component1 phi) x) + = Tmap (S n) (component3 phi) (Tdelta n E' x)). + + Arguments Tmap n {B B'} _. + Arguments Tmap_id n {B} _. + Arguments Tmap_comp n {B B' B''} _ _ _. + Arguments Tdelta n {A B} _. + Arguments Tdelta_nat n {A B A' B'} _ _ _ _. + + Local Open Scope nat_scope. + + (** The comparison map on representatives, by recursion on the length. *) + Definition d_rep : forall (n : nat) {B : AbGroup@{u}}, + abses_es n B G -> (T 0 G $-> T n B). + Proof. + induction n as [|n IHn]; intros B w. + - exact (Tmap 0 (w : B $-> G)). + - destruct n as [|n]. + + exact (Tdelta 0 (w : AbSES B G)). + + exact (grp_homo_compose (Tdelta (S n) (snd w.2)) (IHn w.1 (fst w.2))). + Defined. + + (** The connecting map commutes with pullback in the base. *) + Definition Tdelta_pullback (n : nat) {A B B' : AbGroup@{u}} (beta : B' $-> B) + (E : AbSES B A) + : Tdelta n (abses_pullback beta E) + = grp_homo_compose (Tmap (S n) beta) (Tdelta n E). + Proof. + apply equiv_path_grouphomomorphism; intro x. + exact ((ap (Tdelta n (abses_pullback beta E)) (Tmap_id n x))^ + @ Tdelta_nat n (abses_pullback beta E) E (abses_pullback_morphism E beta) x). + Defined. + + (** The comparison map is natural in the base. *) + Definition d_rep_natural (n : nat) {B B' : AbGroup@{u}} (beta : B' $-> B) + (w : abses_es n B G) + : d_rep n (abses_es_pullback n beta w) + = grp_homo_compose (Tmap n beta) (d_rep n w). + Proof. + destruct n as [|[|n]]. + - apply equiv_path_grouphomomorphism; intro x. + exact (Tmap_comp 0 (w : B $-> G) beta x). + - exact (Tdelta_pullback 0 beta (w : AbSES B G)). + - destruct w as [C [F E]]. + refine (ap (fun d => grp_homo_compose d (d_rep (S n) F)) + (Tdelta_pullback (S n) beta E) @ _). + apply equiv_path_grouphomomorphism; intro x; reflexivity. + Defined. + + (** The connecting map commutes with pushout in the coefficient. *) + Definition Tdelta_pushout (n : nat) {A A' B : AbGroup@{u}} (alpha : A $-> A') + (E : AbSES B A) + : Tdelta n (abses_pushout alpha E) + = grp_homo_compose (Tdelta n E) (Tmap n alpha). + Proof. + apply equiv_path_grouphomomorphism; intro x. + exact ((Tdelta_nat n E (abses_pushout alpha E) (abses_pushout_morphism E alpha) x + @ Tmap_id (S n) (Tdelta n (abses_pushout alpha E) x))^). + Defined. + + (** The comparison map respects the relation, hence descends to [Ext]. *) + Definition d_rep_rel (n : nat) {B : AbGroup@{u}} (w w' : abses_es n B G) + (r : abses_es_rel n w w') + : d_rep n w = d_rep n w'. + Proof. + revert B w w' r; induction n as [|[|n] IHn]; intros B w w' r. + - exact (ap (d_rep 0) r). + - exact (ap (d_rep 1) r). + - destruct w as [C [F E]], w' as [C' [F' E']], r as [beta [rF rE]]. + apply equiv_path_grouphomomorphism; intro x. + refine (ap (fun y => Tdelta (S n) E y) + (equiv_path_grouphomomorphism^-1 + (IHn C F (abses_es_pullback (S n) beta F') rF) x + @ equiv_path_grouphomomorphism^-1 (d_rep_natural (S n) beta F') x) @ _). + refine (_ @ ap (fun E0 => Tdelta (S n) E0 (d_rep (S n) F' x)) rE). + exact (equiv_path_grouphomomorphism^-1 + (Tdelta_pushout (S n) beta E) (d_rep (S n) F' x))^. + Defined. + + (** The comparison map descends to a map out of [Ext]. *) + Definition d_ext (n : nat) {B : AbGroup@{u}} + : abses_ext n B G -> (T 0 G $-> T n B) + := Quotient_rec (abses_es_rel n) (T 0 G $-> T n B) (@d_rep n B) (@d_rep_rel n B). + + (** It is natural in the base and carries the splice to the connecting map. *) + Definition d_ext_natural (n : nat) {B B' : AbGroup@{u}} (beta : B' $-> B) + (x : abses_ext n B G) + : d_ext n (abses_ext_pullback n beta x) + = grp_homo_compose (Tmap n beta) (d_ext n x). + Proof. + revert x; srapply Quotient_ind_hprop; intro w. + exact (d_rep_natural n beta w). + Defined. + + Definition d_ext_splice (n : nat) {B C : AbGroup@{u}} (E : AbSES B C) + (x : abses_ext n C G) + : d_ext (S n) (abses_ext_splice n E x) + = grp_homo_compose (Tdelta n E) (d_ext n x). + Proof. + revert x; srapply Quotient_ind_hprop; intro w. + destruct n as [|n]. + - exact (Tdelta_pushout 0 (w : C $-> G) E). + - reflexivity. + Defined. + + (** The induced map of delta-functors out of [Ext^* (- , G)] extending a + degree-zero element [eta : T 0 G]. *) + Definition d_morph (n : nat) {B : AbGroup@{u}} (eta : T 0 G) + (x : abses_ext n B G) : T n B + := d_ext n x eta. + + Definition d_morph_natural (n : nat) {B B' : AbGroup@{u}} (beta : B' $-> B) + (eta : T 0 G) (x : abses_ext n B G) + : d_morph n eta (abses_ext_pullback n beta x) = Tmap n beta (d_morph n eta x) + := equiv_path_grouphomomorphism^-1 (d_ext_natural n beta x) eta. + + Definition d_morph_splice (n : nat) {B C : AbGroup@{u}} (E : AbSES B C) + (eta : T 0 G) (x : abses_ext n C G) + : d_morph (S n) eta (abses_ext_splice n E x) = Tdelta n E (d_morph n eta x) + := equiv_path_grouphomomorphism^-1 (d_ext_splice n E x) eta. + + (** A family agreeing with the connecting maps and the degree-zero values + equals [d_morph]. *) + Definition d_morph_unique (eta : T 0 G) + (v : forall (n : nat) (B : AbGroup@{u}), abses_ext n B G -> T n B) + (v_zero : forall (B : AbGroup@{u}) (phi : ab_hom B G), + v 0 B (class_of _ phi) = Tmap 0 phi eta) + (v_splice : forall (n : nat) (B C : AbGroup@{u}) (E : AbSES B C) + (x : abses_ext n C G), + v (S n) B (abses_ext_splice n E x) = Tdelta n E (v n C x)) + : forall (n : nat) (B : AbGroup@{u}) (x : abses_ext n B G), + v n B x = d_morph n eta x. + Proof. + intro n; induction n as [|[|n] IHn]; intros B x. + - revert x; srapply Quotient_ind_hprop; intro phi. + exact (v_zero B phi). + - revert x; srapply Quotient_ind_hprop; intro E. + refine (ap (v 1%nat B) (ap (class_of _) (abses_pushout_id E))^ @ _). + refine (v_splice 0 B G E (class_of _ grp_homo_id) @ _). + refine (ap (fun y => Tdelta 0 E y) (v_zero G grp_homo_id) @ _). + exact (ap (fun y => Tdelta 0 E y) (Tmap_id 0 eta)). + - revert x; srapply Quotient_ind_hprop; intros [C [F E]]. + refine (v_splice (S n) B C E (class_of _ F) @ _). + exact (ap (fun y => Tdelta (S n) E y) (IHn C (class_of _ F))). + Defined. + + (** A map of delta-functors from [Ext^* (- , G)] to [T]. *) + Definition ExtDeltaMor : Type + := { v : forall (n : nat) (B : AbGroup@{u}), abses_ext n B G -> T n B + & (forall (n : nat) (B B' : AbGroup@{u}) (beta : B' $-> B) + (x : abses_ext n B G), + v n B' (abses_ext_pullback n beta x) = Tmap n beta (v n B x)) + * (forall (n : nat) (B C : AbGroup@{u}) (E : AbSES B C) + (x : abses_ext n C G), + v (S n) B (abses_ext_splice n E x) = Tdelta n E (v n C x)) }. + + (** Maps of delta-functors out of [Ext^* (- , G)] correspond to elements of + [T 0 G]. *) + Definition ext_universal_equiv : ExtDeltaMor <~> T 0 G. + Proof. + srapply equiv_adjointify. + - exact (fun m => m.1 0%nat G (class_of _ grp_homo_id)). + - intro eta. + exists (fun n B => @d_morph n B eta). + exact ((fun n B B' beta x => @d_morph_natural n B B' beta eta x), + (fun n B C E x => @d_morph_splice n B C E eta x)). + - intro eta; exact (Tmap_id 0 eta). + - intro m. + srapply path_sigma_hprop. + apply path_forall; intro n; apply path_forall; intro B; apply path_forall; intro x. + symmetry; srapply d_morph_unique. + + intros B0 phi. + transitivity (m.1 0%nat B0 (abses_ext_pullback 0 phi (class_of _ grp_homo_id))). + * apply (ap (m.1 0%nat B0)); symmetry. + apply (ap (class_of _)). + apply equiv_path_grouphomomorphism; intro b; reflexivity. + * exact (fst m.2 0%nat G B0 phi (class_of _ grp_homo_id)). + + exact (snd m.2). + Defined. + +End ExtUniversal. diff --git a/theories/Algebra/AbSES/HigherExtMorphism.v b/theories/Algebra/AbSES/HigherExtMorphism.v new file mode 100644 index 00000000000..6e061ee00c6 --- /dev/null +++ b/theories/Algebra/AbSES/HigherExtMorphism.v @@ -0,0 +1,153 @@ +From HoTT Require Import Basics Types. +From HoTT.WildCat Require Import Core. +Require Import Truncations.Core. +Require Import Colimits.Quotient. +Require Import AbGroups.AbelianGroup AbGroups.AbHom. +Require Import Algebra.AbSES.Core Algebra.AbSES.Pushout Algebra.AbSES.Pullback + Algebra.AbSES.BaerSum Algebra.AbSES.HigherExt. +Require Import Groups.Group. + +Local Open Scope type_scope. + +(** * Morphisms of length-[n] exact sequences + + A morphism of length-[n] sequences (Christensen and Flaten, Definition 2.4.4) + fixes the two endpoints and gives a map of each intermediate module + commuting with the splice maps. We show that the relation [abses_es_rel] + and the existence of such a morphism are logically equivalent (Lemma 2.4.5), + and deduce that the set-quotient by morphisms agrees with [abses_ext] + (Remark 2.4.6). *) + +Section LengthNMorphism. + Context `{Univalence}. + + (** A morphism of length-[n] sequences over a base map [β], fixing the deep + coefficient. *) + Definition abses_es_mor + : forall (n : nat) (B B' A : AbGroup@{u}), (B $-> B') + -> abses_es n B A -> abses_es n B' A -> Type. + Proof. + induction n as [|n IH]; intros B B' A β. + - exact (fun E F => E = grp_homo_compose F β). + - revert IH; destruct n as [|p]; intro IH. + + exact (fun E F => { φ : AbSESMorphism E F + & (component1 φ == grp_homo_id) + * (component3 φ == β) }). + + exact (fun E F => { γ : E.1 $-> F.1 + & IH E.1 F.1 A γ (fst E.2) (fst F.2) + * { φ : AbSESMorphism (snd E.2) (snd F.2) + & (component1 φ == γ) + * (component3 φ == β) } }). + Defined. + + Arguments abses_es_mor n {B B' A} β. + + (** The identity-ends morphism induced by a path of short exact sequences. *) + Definition abses_morphism_of_path {B A : AbGroup@{u}} {E F : AbSES B A} + (p : E = F) + : AbSESMorphism E F + := transport (fun X => AbSESMorphism E X) p (abses_morphism_id E). + + Definition component1_abses_morphism_of_path {B A : AbGroup@{u}} + {E F : AbSES B A} (p : E = F) + : component1 (abses_morphism_of_path p) == grp_homo_id. + Proof. + destruct p; exact (fun _ => idpath). + Defined. + + Definition component3_abses_morphism_of_path {B A : AbGroup@{u}} + {E F : AbSES B A} (p : E = F) + : component3 (abses_morphism_of_path p) == grp_homo_id. + Proof. + destruct p; exact (fun _ => idpath). + Defined. + + (** A morphism over [β] yields the relation to the pullback along [β]. *) + Definition abses_es_mor_to_rel + : forall (n : nat) {B B' A : AbGroup@{u}} (β : B $-> B') + (E : abses_es n B A) (F : abses_es n B' A), + abses_es_mor n β E F -> abses_es_rel n E (abses_es_pullback n β F). + Proof. + intro n; induction n as [|[|n] IH]; intros B B' A β E F mor. + - exact mor. + - destruct mor as [φ [hα hβ]]. + refine (abses_pullback_component1_id φ hα @ _). + exact (ap (fun g => abses_pullback g F) (equiv_path_grouphomomorphism hβ)). + - destruct mor as [γ [morrec [φ [hα hβ]]]]. + exists γ. + refine (IH _ _ _ γ (fst E.2) (fst F.2) morrec, _). + refine ((ap (fun g => abses_pushout g (snd E.2)) + (equiv_path_grouphomomorphism hα))^ @ _). + refine (abses_pushout_is_pullback φ @ _). + exact (ap (fun g => abses_pullback g (snd F.2)) + (equiv_path_grouphomomorphism hβ)). + Defined. + + (** Conversely, the relation to the pullback along [β] yields a morphism. *) + Definition abses_es_rel_to_mor + : forall (n : nat) {B B' A : AbGroup@{u}} (β : B $-> B') + (E : abses_es n B A) (F : abses_es n B' A), + abses_es_rel n E (abses_es_pullback n β F) -> abses_es_mor n β E F. + Proof. + intro n; induction n as [|[|n] IH]; intros B B' A β E F rel. + - exact rel. + - exists (absesmorphism_compose (abses_pullback_morphism F β) + (abses_morphism_of_path rel)). + refine (_, _). + + intro x; exact (component1_abses_morphism_of_path rel x). + + intro x; exact (ap β (component3_abses_morphism_of_path rel x)). + - destruct rel as [γ [relrec q]]. + exists γ. + refine (IH _ _ _ γ (fst E.2) (fst F.2) relrec, _). + exists (absesmorphism_compose (abses_pullback_morphism (snd F.2) β) + (absesmorphism_compose (abses_morphism_of_path q) + (abses_pushout_morphism (snd E.2) γ))). + refine (_, _). + + intro x. + exact (component1_abses_morphism_of_path q (γ x)). + + intro x. + exact (ap β (component3_abses_morphism_of_path q x)). + Defined. + + (** A morphism of length-[n] sequences fixing both endpoints (the base map is + the identity). *) + Definition abses_es_morphism (n : nat) {B A : AbGroup@{u}} + (E F : abses_es n B A) : Type + := abses_es_mor n grp_homo_id E F. + + (** The relation and morphism-existence are logically equivalent. *) + Definition iff_abses_es_rel_morphism (n : nat) {B A : AbGroup@{u}} + (E F : abses_es n B A) + : abses_es_rel n E F <-> abses_es_morphism n E F. + Proof. + split. + - intro rel. + apply (abses_es_rel_to_mor n grp_homo_id E F). + exact (transport (abses_es_rel n E) (abses_es_pullback_id n F)^ rel). + - intro mor. + refine (transport (abses_es_rel n E) (abses_es_pullback_id n F) _). + exact (abses_es_mor_to_rel n grp_homo_id E F mor). + Defined. + +End LengthNMorphism. + +(** ** The morphism quotient *) + +Section MorphismQuotient. + Context `{Univalence}. + + (** The set-quotient of length-[n] sequences by morphism-existence agrees + with [abses_ext]. *) + Definition equiv_abses_ext_morphism (n : nat) (B A : AbGroup@{u}) + : abses_ext n B A <~> Quotient (abses_es_morphism n (B:=B) (A:=A)). + Proof. + srapply equiv_adjointify. + - srapply (Quotient_functor _ _ idmap). + exact (fun E F => fst (iff_abses_es_rel_morphism n E F)). + - srapply (Quotient_functor _ _ idmap). + exact (fun E F => snd (iff_abses_es_rel_morphism n E F)). + - srapply Quotient_ind_hprop; intro E; reflexivity. + - srapply Quotient_ind_hprop; intro E; reflexivity. + Defined. + +End MorphismQuotient. diff --git a/theories/Algebra/AbSES/HigherExtResolution.v b/theories/Algebra/AbSES/HigherExtResolution.v new file mode 100644 index 00000000000..31e5bf18024 --- /dev/null +++ b/theories/Algebra/AbSES/HigherExtResolution.v @@ -0,0 +1,70 @@ +From HoTT Require Import Basics Types Truncations.Core. +From HoTT.WildCat Require Import Core. +Require Import Spaces.Nat.Core. +Require Import AbGroups.AbelianGroup AbGroups.AbProjective. +Require Import Algebra.AbSES.Core Algebra.AbSES.HigherExt. +Require Import Groups.Group. + +Local Open Scope nat_scope. + +(** * Vanishing of higher Ext above a projective resolution + + Following the dimension-shifting argument behind Christensen and Flaten, + Proposition 2.5.4: if a short exact sequence has projective middle and its + kernel already has vanishing Ext one degree down, then [B] has vanishing + Ext one degree further up. *) + +(** The dimension-shift step: splicing with a projective-middle sequence carries + the vanishing of [Ext^{m+1}(K,-)] to the vanishing of [Ext^{m+2}(B,-)]. *) +Definition abses_ext_vanish_step `{Univalence} {K B : AbGroup} (zeta : AbSES B K) + `{IsAbProjective (middle zeta)} {A : AbGroup} (m : nat) + (hK : forall x : abses_ext m.+1 K A, x = abses_ext_zero m.+1 K A) + (x : abses_ext m.+2 B A) + : x = abses_ext_zero m.+2 B A. +Proof. + pose proof (abses_ext_splice_projective_surjective zeta m.+1 x) as hsurj. + strip_truncations; destruct hsurj as [y py]. + refine (py^ @ ap (abses_ext_splice m.+1 zeta) (hK y) @ _). + exact (grp_homo_unit (grp_homo_abses_ext_splice m.+1 zeta)). +Defined. + +(** Iterating once: a length-two projective resolution + [L -> P1 -> K] and [K -> P0 -> B] forces [Ext^{n+3}(B,-)] to vanish when + [L] is projective. *) +Definition abses_ext_vanish_two `{Univalence} {L K B : AbGroup} + (eta : AbSES K L) (zeta : AbSES B K) + `{IsAbProjective (middle eta)} `{IsAbProjective (middle zeta)} + `{IsAbProjective L} {A : AbGroup} (n : nat) + (x : abses_ext n.+3 B A) + : x = abses_ext_zero n.+3 B A. +Proof. + refine (abses_ext_vanish_step zeta n.+1 _ x). + intro y. + exact (abses_ext_vanish_step eta n + (fun z => abses_ext_projective_vanish n z) y). +Defined. + +(** A projective resolution of length [k]: a tower of short exact sequences with + projective middles ending in a projective module. *) +Fixpoint proj_resolution `{Univalence} (k : nat) (B : AbGroup@{u}) : Type := + match k with + | 0%nat => IsAbProjective B + | S k => { K : AbGroup@{u} + & { zeta : AbSES B K + & (IsAbProjective (middle zeta) * proj_resolution k K)%type } } + end. + +(** Higher Ext vanishes above the length of a projective resolution. *) +Definition abses_ext_vanish_resolution `{Univalence} (k : nat) + : forall (B : AbGroup@{u}), proj_resolution k B + -> forall (A : AbGroup@{u}) (n : nat) (x : abses_ext (k + n).+1 B A), + x = abses_ext_zero (k + n).+1 B A. +Proof. + induction k as [|k IH]; intros B res A n x. + - assert (res' : IsAbProjective B) by exact res. + exact (abses_ext_projective_vanish n x). + - destruct res as [K [zeta [hp rK]]]. + refine (abses_ext_vanish_step zeta (k + n) _ x). + intro y. + exact (IH K rK A n y). +Defined. diff --git a/theories/Algebra/AbSES/InjectiveExt.v b/theories/Algebra/AbSES/InjectiveExt.v new file mode 100644 index 00000000000..7d0a9097ffb --- /dev/null +++ b/theories/Algebra/AbSES/InjectiveExt.v @@ -0,0 +1,57 @@ +From HoTT Require Import Basics Types Truncations.Core. +From HoTT.WildCat Require Import Core. +Require Import AbGroups.AbelianGroup AbGroups.Biproduct AbGroups.AbInjective. +Require Import Algebra.AbSES.Core Algebra.AbSES.Ext. + +(** * Injectivity and the vanishing of Ext + + An injective abelian group has no nontrivial extensions; the dual of + Proposition 2.5.2. *) + +(** Every extension of an injective group is trivial. *) +Definition isabinjective_ext_trivial `{Univalence} {I : AbGroup} `{IsAbInjective I} + {B : AbGroup} (E : AbSES B I) + : tr E = point (Ext B I). +Proof. + pose proof (isabinjective I (middle E) (inclusion E) grp_homo_id _) as hr. + strip_truncations. + destruct hr as [r hr]. + pose proof (iscomplex_abses E) as hc; destruct hc as [hc0 hc1]. + pose (phi := ab_biprod_corec r (projection E) : middle E $-> ab_biprod I B). + assert (p0 : phi $o inclusion E == ab_biprod_inl). + { intro a; snapply path_prod'. + - exact (hr a). + - exact (hc0 a). } + assert (p1 : projection E == ab_biprod_pr2 $o phi) + by reflexivity. + apply (ap tr). + snapply equiv_path_abses_iso. + exact (Build_GroupIsomorphism _ _ phi + (short_five_lemma (F := point (AbSES B I)) phi p0 p1); + (p0, p1)). +Defined. + +(** Conversely, a group all of whose extensions are trivial is injective. *) +Definition isabinjective_from_ext_trivial `{Univalence} {I : AbGroup} + (triv : forall (B : AbGroup) (E : AbSES B I), tr E = point (Ext B I)) + : IsAbInjective I. +Proof. + apply (snd (iff_isabinjective_embeddings_split I)). + intros C m hm. + pose proof ((iff_ab_ext_trivial_split (abses_from_inclusion m))^-1 + (triv _ (abses_from_inclusion m))) as hs. + strip_truncations. + destruct hs as [s hsp]. + apply tr. + exists (ab_biprod_pr1 $o projection_split_iso (abses_from_inclusion m) hsp). + intro a. + exact (ap ab_biprod_pr1 + (projection_split_beta (abses_from_inclusion m) hsp a)). +Defined. + +(** Injectivity is equivalent to the vanishing of all extensions. *) +Definition iff_isabinjective_ext_trivial `{Univalence} (I : AbGroup) + : IsAbInjective I + <-> (forall (B : AbGroup) (E : AbSES B I), tr E = point (Ext B I)) + := (fun inj B E => @isabinjective_ext_trivial _ I inj B E, + isabinjective_from_ext_trivial). diff --git a/theories/Algebra/AbSES/LoopGroup.v b/theories/Algebra/AbSES/LoopGroup.v new file mode 100644 index 00000000000..1e82be4e473 --- /dev/null +++ b/theories/Algebra/AbSES/LoopGroup.v @@ -0,0 +1,152 @@ +From HoTT Require Import Basics Types Truncations.Core HFiber. +From HoTT.WildCat Require Import Core Equiv. +Require Import Pointed. +Require Import AbelianGroup AbGroups.Biproduct AbHom. +Require Import Algebra.AbSES.Core Algebra.AbSES.Pullback Algebra.AbSES.BaerSum. +Require Import Homotopy.HomotopyGroup Homotopy.ClassifyingSpace Homotopy.EMSpace + Homotopy.Cover. +Require Import Modalities.ReflectiveSubuniverse Modalities.Modality. +Require Import Groups.Group. + +Local Open Scope pointed_scope. +Local Open Scope mc_add_scope. + +(** * The fundamental group of [AbSES B A] + + [AbSES.Core] gives an equivalence of types + [loops_abses : (B $-> A) <~> loops (AbSES B A)]. We show that it is an + isomorphism of groups: concatenation of loops corresponds to addition of + homomorphisms. The Baer sum laws hold at the level of [AbSES B A], so + translation by [E] is a self-equivalence taking the split sequence to + [E], and the fundamental group is [ab_hom B A] at every basepoint. It + follows that each path component of [AbSES B A] is a classifying space + [K(ab_hom B A, 1)]. *) + +Section LoopGroup. + Context `{Univalence} {B A : AbGroup@{u}}. + + (** The path data on the split sequence corresponding to [f : B $-> A]. + [loops_abses f] is definitionally [equiv_path_abses_iso (tdata f)], and + the underlying automorphism of [tdata f] sends [(a, b)] to + [(a + f b, mon_unit + b)]. *) + Local Definition tdata (f : B $-> A) + : abses_path_data_iso (point (AbSES B A)) (point (AbSES B A)) + := equiv_path_abses_data _ _ (abses_endomorphism_trivial^-1 f). + + (** [loops_abses] is additive: composition of path data on the split + sequence corresponds to addition of the off-diagonal homomorphisms. *) + Definition loops_abses_add (f g : B $-> A) + : loops_abses (f + g) = loops_abses f @ loops_abses g. + Proof. + refine (_ @ (abses_path_data_compose_beta (tdata f) (tdata g))^). + napply (ap equiv_path_abses_iso). + rapply path_sigma_hprop. + rapply equiv_path_groupisomorphism. + intros [a b]. + (* LHS: [(a + (f b + g b), 0 + b)]; RHS: [((a + f b) + g (0 + b), 0 + (0 + b))]. *) + snapply path_prod'; cbn. + - exact (associativity a (f b) (g b) + @ ap (fun w => (a + f b) + w) (ap g (left_identity b))^). + - exact (ap (fun z => mon_unit + z) (left_identity b))^. + Defined. + + (** The fundamental group of [AbSES B A] at the split sequence. *) + Definition grp_iso_pi1_abses + : GroupIsomorphism (ab_hom B A) (Pi 1 (AbSES B A)). + Proof. + snapply Build_GroupIsomorphism. + - snapply Build_GroupHomomorphism. + + exact (fun f => tr (loops_abses f)). + + intros f g. + exact (ap tr (loops_abses_add f g)). + - exact (equiv_isequiv (equiv_tr 0 _ oE loops_abses)). + Defined. + +End LoopGroup. + +(** * Translation by a short exact sequence *) + +Section Translation. + Context `{Univalence} {B A : AbGroup@{u}}. + + (** Translation by [E] under the Baer sum is a self-equivalence of + [AbSES B A], with inverse given by translation by the Baer inverse + [abses_pullback (- grp_homo_id) E]. *) + Definition equiv_abses_translate (E : AbSES B A) + : AbSES B A <~> AbSES B A. + Proof. + srapply equiv_adjointify. + - exact (fun F => abses_baer_sum F E). + - exact (fun F => abses_baer_sum F (abses_pullback (- grp_homo_id) E)). + - intro F. + refine (baer_sum_associative _ _ _ @ _). + refine (ap (abses_baer_sum F) (baer_sum_inverse_r E) @ _). + apply baer_sum_unit_r. + - intro F. + refine (baer_sum_associative _ _ _ @ _). + refine (ap (abses_baer_sum F) (baer_sum_inverse_l E) @ _). + apply baer_sum_unit_r. + Defined. + + (** Translation takes the split sequence to [E]. *) + Definition pequiv_abses_translate (E : AbSES B A) + : AbSES B A <~>* [AbSES B A, E] + := Build_pEquiv' (equiv_abses_translate E) (baer_sum_unit_l E). + + (** The fundamental group of [AbSES B A] at any basepoint is [ab_hom B A], + even though [E] need not be merely equal to the split sequence. *) + Definition grp_iso_pi1_abses_at (E : AbSES B A) + : GroupIsomorphism (ab_hom B A) (Pi 1 [AbSES B A, E]) + := grp_iso_compose + (groupiso_pi_functor 0 (pequiv_abses_translate E)) + grp_iso_pi1_abses. + +End Translation. + +(** * Components of [AbSES B A] are classifying spaces *) + +Section Component. + Context `{Univalence} {B A : AbGroup@{u}} (E : AbSES B A). + + (** The inclusion of the component of [E] is an embedding, since being in + a given component is a proposition. *) + Local Instance isembedding_pcomp_abses + : IsEmbedding (pr1 : pcomp (AbSES B A) E -> AbSES B A). + Proof. + intro F. + exact (istrunc_equiv_istrunc _ (hfiber_fibration F _)). + Qed. + + Local Instance isconnected_pcomp_abses + : IsConnected (Tr 0) (pcomp (AbSES B A) E) + := _. + + Local Instance istrunc_pcomp_abses + : IsTrunc 1 (pcomp (AbSES B A) E) + := _. + + (** The inclusion of the component of [E] induces an isomorphism of + fundamental groups. *) + Definition grp_iso_pi1_pcomp_abses + : GroupIsomorphism (Pi 1 (pcomp (AbSES B A) E)) (Pi 1 [AbSES B A, E]). + Proof. + snapply Build_GroupIsomorphism. + - snapply Build_GroupHomomorphism. + + exact (Trunc_functor 0 (ap pr1)). + + intros p q; strip_truncations. + exact (ap tr (ap_pp pr1 p q)). + - exact _. + Defined. + + (** Each component of [AbSES B A] is a classifying space of [ab_hom B A]. *) + Definition pequiv_pcomp_abses_em + : pcomp (AbSES B A) E <~>* K(ab_hom B A, 1). + Proof. + refine (_ o*E (pequiv_pclassifyingspace_pi1 (pcomp (AbSES B A) E))^-1*). + exact (emap pClassifyingSpace + (grp_iso_compose + (grp_iso_inverse (grp_iso_pi1_abses_at E)) + grp_iso_pi1_pcomp_abses)). + Defined. + +End Component. diff --git a/theories/Algebra/AbSES/Pullback.v b/theories/Algebra/AbSES/Pullback.v index 8236ea6e540..1948c8024b9 100644 --- a/theories/Algebra/AbSES/Pullback.v +++ b/theories/Algebra/AbSES/Pullback.v @@ -499,3 +499,18 @@ Proof. - exact abses_pullback_pmap_id. - symmetry; apply abses_pullback_pcompose. Defined. + +(** Dual to [abses_pushout_trivial_factors_inclusion]: if a pullback + [abses_pullback beta E] is trivial, then [beta] factors through + [projection E]. The splitting of the trivial pullback provides the + factoring map through the pullback's middle. *) +Definition abses_pullback_trivial_factors_projection `{Univalence} + {A B B' : AbGroup} (beta : B' $-> B) (E : AbSES B A) + : abses_pullback beta E = pt -> exists phi, beta = projection E $o phi. +Proof. + intro h. + destruct (snd (iff_abses_trivial_split (abses_pullback beta E)) h) as [s hs]. + exists (component2 (abses_pullback_morphism E beta) $o s). + apply equiv_path_grouphomomorphism; intro b. + exact (right_square (abses_pullback_morphism E beta) (s b) @ ap beta (hs b))^. +Defined. diff --git a/theories/Algebra/AbSES/Pushout.v b/theories/Algebra/AbSES/Pushout.v index 9534074fb79..628055043a2 100644 --- a/theories/Algebra/AbSES/Pushout.v +++ b/theories/Algebra/AbSES/Pushout.v @@ -1,5 +1,6 @@ From HoTT Require Import Basics Types Truncations.Core. From HoTT.WildCat Require Import Core Universe Opposite NatTrans. +Require Import Universes.HSet. Require Import Pointed.Core Homotopy.ExactSequence HIT.epi. Require Import Modalities.ReflectiveSubuniverse. Require Import AbelianGroup AbPushout AbHom AbGroups.Biproduct. @@ -451,3 +452,23 @@ Proof. - apply abses_pushout_pmap_id. - apply abses_pushout_pcompose. Defined. + +(** If a pushout [abses_pushout alpha E] is trivial, then [alpha] factors through [inclusion E]. *) +Lemma abses_pushout_trivial_factors_inclusion `{Univalence} + {B A A' : AbGroup} (alpha : A $-> A') (E : AbSES B A) + : abses_pushout alpha E = pt -> exists phi, alpha = phi $o inclusion E. +Proof. + equiv_intros (equiv_path_abses (E:=abses_pushout alpha E) (F:=pt)) p. + destruct p as [phi [p q]]. + exists (ab_biprod_pr1 $o phi $o ab_pushout_inr). + apply equiv_path_grouphomomorphism; intro a. + (* We embed into the biproduct and prove equality there. *) + apply (isinj_embedding (@ab_biprod_inl A' B) _). + refine ((p (alpha a))^ @ _). + refine (ap phi _ @ _). + 1: exact (left_square (abses_pushout_morphism E alpha) a). + apply (path_prod' idpath). + refine ((q _)^ @ _). + refine (right_square (abses_pushout_morphism E alpha) _ @ _); cbn. + apply isexact_inclusion_projection. +Defined. diff --git a/theories/Algebra/AbSES/SixTerm.v b/theories/Algebra/AbSES/SixTerm.v index c4f5bd615a2..5c30cb1ea0a 100644 --- a/theories/Algebra/AbSES/SixTerm.v +++ b/theories/Algebra/AbSES/SixTerm.v @@ -57,25 +57,7 @@ Defined. (** *** Exactness of [ab_hom E G -> ab_hom A G -> Ext B G] *) -(** If a pushout [abses_pushout alpha E] is trivial, then [alpha] factors through [inclusion E]. *) -Lemma abses_pushout_trivial_factors_inclusion `{Univalence} - {B A A' : AbGroup} (alpha : A $-> A') (E : AbSES B A) - : abses_pushout alpha E = pt -> exists phi, alpha = phi $o inclusion E. -Proof. - equiv_intros (equiv_path_abses (E:=abses_pushout alpha E) (F:=pt)) p. - destruct p as [phi [p q]]. - exists (ab_biprod_pr1 $o phi $o ab_pushout_inr). - apply equiv_path_grouphomomorphism; intro a. - (* We embed into the biproduct and prove equality there. *) - apply (isinj_embedding (@ab_biprod_inl A' B) _). - refine ((p (alpha a))^ @ _). - refine (ap phi _ @ _). - 1: exact (left_square (abses_pushout_morphism E alpha) a). - apply (path_prod' idpath). - refine ((q _)^ @ _). - refine (right_square (abses_pushout_morphism E alpha) _ @ _); cbn. - apply isexact_inclusion_projection. -Defined. +(** [abses_pushout_trivial_factors_inclusion] now lives in [AbSES.Pushout]. *) Instance isexact_ext_contra_sixterm_iii@{u v +} `{Univalence} {B A G : AbGroup@{u}} (E : AbSES@{u v} B A) diff --git a/theories/Algebra/Rings/Bezout.v b/theories/Algebra/Rings/Bezout.v new file mode 100644 index 00000000000..6b47c7c4502 --- /dev/null +++ b/theories/Algebra/Rings/Bezout.v @@ -0,0 +1,128 @@ +From HoTT Require Import Basics Types Truncations.Core. +From HoTT.WildCat Require Import Core. +Require Import Spaces.Finite.Fin. +Require Import Algebra.Rings.Ring Algebra.Rings.CRing Algebra.Rings.Ideal. + +Local Open Scope ring_scope. +Local Open Scope mc_scope. +Local Open Scope predicate_scope. + +(** * Bézout rings and principal ideal domains + + Constructive definitions following Christensen and Flaten, Definitions + 2.6.2-2.6.3, with Lemma 2.6.4 (translating Lombardi and Quitté). *) + +(** Divisibility: [a] divides [b] if [b] is a multiple of [a]. *) +Definition rng_divides {R : CRing} (a b : R) : Type + := merely { c : R & b = c * a }. + +(** An element is regular if multiplication by it is injective. *) +Definition IsRegular {R : CRing} (a : R) : Type + := forall x y : R, a * x = a * y -> x = y. + +(** An integral domain: every element is zero or regular. *) +Class IsIntegralDomain (R : CRing) : Type + := intdom_zero_or_regular : forall x : R, (x = 0) + IsRegular x. + +(** A greatest common divisor of [x] and [y] is a common divisor divisible by + every common divisor. *) +Definition IsGcd {R : CRing} (x y g : R) : Type + := (rng_divides g x) * (rng_divides g y) + * (forall z : R, rng_divides z x -> rng_divides z y -> rng_divides z g). + +(** A Bézout ring: every pair has a Bézout combination that is a gcd. *) +Class IsBezoutRing (R : CRing) : Type + := bezout_relation : forall x y : R, + merely { u : R & { v : R & IsGcd x y (u * x + v * y) } }. + +(** A Bézout domain is a Bézout ring that is an integral domain. *) +Class IsBezoutDomain (R : CRing) : Type := { + bezoutdomain_bezout :: IsBezoutRing R ; + bezoutdomain_domain :: IsIntegralDomain R +}. + +(** A principal ideal domain: a Bézout domain in which every ascending chain of + ideals merely has two equal consecutive terms. *) +Class IsPID (R : CRing) : Type := { + pid_bezout :: IsBezoutDomain R ; + pid_noetherian : forall I : nat -> Ideal R, + (forall n, I n ⊆ I (S n)) -> merely { n : nat & I n = I (S n) } +}. + +(** An ideal is principal if it is merely generated by a single element. *) +Definition IsPrincipal {R : Ring} (I : Ideal R) : Type + := merely { a : R & ideal_generated_finite (fun _ : Fin 1 => a) = I }. + +(** ** Divisibility algebra *) + +Definition rng_divides_refl {R : CRing} (a : R) : rng_divides a a. +Proof. + apply tr; exists 1; exact (rng_mult_one_l a)^. +Defined. + +Definition rng_divides_trans {R : CRing} {a b c : R} + (p : rng_divides a b) (q : rng_divides b c) : rng_divides a c. +Proof. + strip_truncations; destruct p as [u pu], q as [v pv]. + apply tr; exists (v * u). + exact (pv @ ap (fun w => v * w) pu @ rng_mult_assoc v u a). +Defined. + +Definition rng_divides_mul_l {R : CRing} {a b : R} (r : R) + (p : rng_divides a b) : rng_divides a (r * b). +Proof. + strip_truncations; destruct p as [u pu]. + apply tr; exists (r * u). + exact (ap (fun w => r * w) pu @ rng_mult_assoc r u a). +Defined. + +(** ** A finitely generated ideal of a Bézout ring is principal *) + +(** A gcd of the [X i] lying in the ideal they generate and dividing each. *) +Definition finite_gcd {R : CRing} `{IsBezoutRing R} + : forall (n : nat) (X : Fin n -> R), + merely { g : R + & ((forall i, rng_divides g (X i)) * ideal_generated_finite X g)%type }. +Proof. + induction n as [|n IH]; intro X. + - apply tr; exists 0; split. + + intro i; destruct i. + + apply ideal_in_zero. + - pose proof (IH (fun i => X (inl i))) as IH'. + strip_truncations; destruct IH' as [a' [hdiv' hin']]. + pose proof (bezout_relation a' (X (inr tt))) as hb. + strip_truncations; destruct hb as [u [v hgcd]]. + destruct hgcd as [[gda' gdlast] _]. + apply tr; exists (u * a' + v * X (inr tt)); split. + + intro j; destruct j as [i | t]. + * exact (rng_divides_trans gda' (hdiv' i)). + * destruct t; exact gdlast. + + napply ideal_in_plus. + { rapply isleftideal. + exact (ideal_generated_rec + (X := hfiber (fun i => X (inl i))) + (I := ideal_generated_finite X) + (fun r hf => tr (igt_in (inl hf.1; hf.2))) a' (tr hin')). } + rapply isleftideal. + exact (tr (igt_in (inr tt; idpath))). +Defined. + +(** A finitely generated ideal of a Bézout ring is principal. *) +Definition isprincipal_finite_bezout `{Univalence} {R : CRing} `{IsBezoutRing R} + {n : nat} (X : Fin n -> R) + : IsPrincipal (ideal_generated_finite X). +Proof. + pose proof (finite_gcd n X) as hg. + strip_truncations; destruct hg as [g [gdiv gin]]. + apply tr; exists g. + apply equiv_path_ideal; split. + - napply (ideal_generated_rec (I := ideal_generated_finite X)). + intros r hf. + exact (transport (ideal_generated_finite X) hf.2 gin). + - napply (ideal_generated_rec (I := ideal_generated_finite (fun _ : Fin 1 => g))). + intros r hf. + pose proof (gdiv hf.1) as hd; strip_truncations; destruct hd as [c pc]. + apply tr. + exact (transport (ideal_generated_type _) (pc^ @ hf.2) + (igt_mul_l (r := c) (igt_in (fin_zero; idpath)))). +Defined. diff --git a/theories/Algebra/Rings/FinitelyPresented.v b/theories/Algebra/Rings/FinitelyPresented.v new file mode 100644 index 00000000000..afcac0c02ef --- /dev/null +++ b/theories/Algebra/Rings/FinitelyPresented.v @@ -0,0 +1,29 @@ +From HoTT Require Import Basics Types Truncations.Core. +From HoTT.WildCat Require Import Core. +Require Import Algebra.AbGroups.AbelianGroup. +Require Import Algebra.Rings.Ring Algebra.Rings.Module Algebra.Rings.Vector. + +Local Open Scope mc_add_scope. + +(** * Finitely generated and finitely presented modules + + Following Christensen and Flaten, Definition 2.6.1. *) + +(** The free module [R^n]. *) +Definition module_rn (R : Ring) (n : nat) : LeftModule R + := Build_LeftModule R (abgroup_vector R n) (isleftmodule_isleftmodule_vector R n). + +(** A module is finitely generated if some [R^n] surjects onto it. *) +Definition IsFinitelyGenerated {R : Ring} (M : LeftModule R) : Type + := merely { n : nat + & { f : LeftModuleHomomorphism (module_rn R n) M & IsSurjection f } }. + +(** A module is finitely presented if it admits a finite presentation: an + [R^n] surjecting onto it whose kernel is the image of some [R^m]. *) +Definition IsFinitelyPresented {R : Ring} (M : LeftModule R) : Type + := merely { n : nat + & { f : LeftModuleHomomorphism (module_rn R n) M + & IsSurjection f + * merely { m : nat + & { g : LeftModuleHomomorphism (module_rn R m) (module_rn R n) + & forall x, (f x = 0) <-> hexists (fun y => g y = x) } } } }. diff --git a/theories/Algebra/Rings/FreeModule.v b/theories/Algebra/Rings/FreeModule.v new file mode 100644 index 00000000000..ab661c8d205 --- /dev/null +++ b/theories/Algebra/Rings/FreeModule.v @@ -0,0 +1,673 @@ +From HoTT Require Import Basics Types. +From HoTT.WildCat Require Import Core. +Require Import Classes.interfaces.canonical_names. +Require Import Spaces.Nat.Core. +Require Import HSet Truncations.Core Modalities.ReflectiveSubuniverse. +Require Import Algebra.Groups.Group Algebra.Groups.Subgroup. +Require Import Algebra.AbGroups.AbelianGroup Algebra.AbGroups.AbHom. +Require Import Algebra.Rings.Ring Algebra.Rings.CRing Algebra.Rings.Module. +Require Import Algebra.Rings.Bezout. + +Local Open Scope module_scope. +Local Open Scope mc_add_scope. + +(** * Splitting of module homomorphisms with a section *) + +(** The inclusion of a submodule as a module homomorphism. *) +Definition lm_subincl {R : Ring} {M : LeftModule R} (N : LeftSubmodule M) + : leftmodule_leftsubmodule N $-> M. +Proof. + snapply Build_LeftModuleHomomorphism'. + - exact pr1. + - intros r x y; reflexivity. +Defined. + +Section Splitting. + Context {R : Ring} {M Q : LeftModule R} + (f : M $-> Q) (s : Q $-> M) (hs : forall q, f (s q) = q). + + (** The complementary projection [id - s ∘ f]. *) + Definition lm_split_endo : M $-> M. + Proof. + snapply Build_LeftModuleHomomorphism. + - exact (grp_homo_id - grp_homo_compose s f). + - intros r m; cbn. + assert (p : s (f (r *L m)) = r *L s (f m)). + { transitivity (s (r *L f m)). + - apply ap; napply lm_homo_lact. + - napply lm_homo_lact. } + lhs napply (ap (fun z => r *L m - z) p). + symmetry. + lhs napply (lm_dist_l r m (- s (f m))). + refine (ap (fun z => r *L m + z) _). + exact (lm_neg r (s (f m))). + Defined. + + (** The projection of [M] onto the kernel of [f]. *) + Definition lm_split_proj : M $-> lm_kernel f. + Proof. + snapply (lm_corestrict (lm_kernel f) lm_split_endo). + intro m; cbn. + lhs napply grp_homo_op. + lhs napply (ap (fun z => f m + z) (grp_homo_inv f (s (f m)))). + lhs napply (ap (fun z => f m + (- z)) (hs (f m))). + apply right_inverse. + Defined. + + (** The forward map of the splitting. *) + Definition lm_split_fwd : M $-> lm_prod (lm_kernel f) Q + := lm_prod_corec M lm_split_proj f. + + (** The backward map of the splitting. *) + Definition lm_split_bwd : lm_prod (lm_kernel f) Q $-> M + := lm_prod_rec (lm_subincl (lm_kernel f)) s. + + Definition lm_split_bwd_fwd (m : M) : lm_split_bwd (lm_split_fwd m) = m. + Proof. + cbn. + refine ((grp_assoc m (- s (f m)) (s (f m)))^ @ _). + refine (ap (fun z => m + z) (left_inverse (s (f m))) @ _). + apply right_identity. + Defined. + + Definition lm_split_fwd_bwd (kq : lm_prod (lm_kernel f) Q) + : lm_split_fwd (lm_split_bwd kq) = kq. + Proof. + destruct kq as [[k1 k2] q]. + assert (faux : f (k1 + s q) = q). + { lhs napply grp_homo_op. + lhs napply (ap (fun z => z + f (s q)) k2). + lhs napply (ap (fun z => mon_unit + z) (hs q)). + apply left_identity. } + snapply path_prod'. + - apply path_sigma_hprop; cbn. + lhs napply (ap (fun w => k1 + s q - s w) faux). + refine ((grp_assoc k1 (s q) (- s q))^ @ _). + refine (ap (fun z => k1 + z) (right_inverse (s q)) @ _). + apply right_identity. + - exact faux. + Defined. + + (** [M] is the direct sum of the kernel of [f] and [Q]. *) + Definition lm_split_iso + : LeftModuleIsomorphism M (lm_prod (lm_kernel f) Q). + Proof. + snapply Build_LeftModuleIsomorphism'. + - snapply Build_GroupIsomorphism. + + exact lm_split_fwd. + + exact (isequiv_adjointify lm_split_fwd lm_split_bwd + lm_split_fwd_bwd lm_split_bwd_fwd). + - intros r m; napply lm_homo_lact. + Defined. + +End Splitting. + +(** * Free modules *) + +(** The trivial (zero) module. *) +Definition lm_zero (R : Ring) : LeftModule R. +Proof. + snapply (Build_LeftModule R abgroup_trivial). + snapply Build_IsLeftModule. + - exact (fun _ x => x). + - intros r m n; apply path_contr. + - intros r s m; apply path_contr. + - intros r s m; apply path_contr. + - intros m; apply path_contr. +Defined. + +(** The regular module: a ring as a module over itself. *) +Definition lm_regular (R : Ring) : LeftModule R + := Build_LeftModule R R _. + +(** The free module [R^n]. *) +Fixpoint lm_power (R : Ring) (n : nat) : LeftModule R := + match n with + | 0%nat => lm_zero R + | S k => lm_prod (lm_regular R) (lm_power R k) + end. + +(** A module is free if it is isomorphic to some [R^n]. *) +Definition IsFreeModule {R : Ring} (M : LeftModule R) : Type + := merely { n : nat & LeftModuleIsomorphism M (lm_power R n) }. + +(** Composition of module isomorphisms. *) +Definition lm_iso_compose {R : Ring} {M N L : LeftModule R} + (g : LeftModuleIsomorphism N L) (f : LeftModuleIsomorphism M N) + : LeftModuleIsomorphism M L. +Proof. + snapply Build_LeftModuleIsomorphism. + - exact (lm_homo_compose g f). + - rapply isequiv_compose. +Defined. + +(** Freeness transports across isomorphisms. *) +Definition isfreemodule_iso {R : Ring} {M N : LeftModule R} + (e : LeftModuleIsomorphism M N) (H : IsFreeModule N) : IsFreeModule M. +Proof. + strip_truncations. + exact (tr (H.1; lm_iso_compose H.2 e)). +Defined. + +(** The zero module is a left unit for the direct product. *) +Definition lm_prod_zero_l {R : Ring} {X : LeftModule R} + : LeftModuleIsomorphism (lm_prod (lm_zero R) X) X. +Proof. + snapply Build_LeftModuleIsomorphism. + - exact lm_prod_snd. + - snapply isequiv_adjointify. + + exact lm_prod_inr. + + intro x; reflexivity. + + intros [z x]; snapply path_prod'; [apply path_contr | reflexivity]. +Defined. + +(** The zero module is a right unit for the direct product. *) +Definition lm_prod_zero_r {R : Ring} {X : LeftModule R} + : LeftModuleIsomorphism (lm_prod X (lm_zero R)) X. +Proof. + snapply Build_LeftModuleIsomorphism. + - exact lm_prod_fst. + - snapply isequiv_adjointify. + + exact lm_prod_inl. + + intro x; reflexivity. + + intros [x z]; snapply path_prod'; [reflexivity | apply path_contr]. +Defined. + +(** Associativity of the direct product. *) +Definition lm_prod_assoc {R : Ring} {A B C : LeftModule R} + : LeftModuleIsomorphism (lm_prod (lm_prod A B) C) (lm_prod A (lm_prod B C)). +Proof. + snapply Build_LeftModuleIsomorphism. + - exact (lm_prod_corec _ (lm_homo_compose lm_prod_fst lm_prod_fst) + (lm_prod_corec _ (lm_homo_compose lm_prod_snd lm_prod_fst) lm_prod_snd)). + - snapply isequiv_adjointify. + + exact (lm_prod_corec _ + (lm_prod_corec _ lm_prod_fst (lm_homo_compose lm_prod_fst lm_prod_snd)) + (lm_homo_compose lm_prod_snd lm_prod_snd)). + + intros [a [b c]]; reflexivity. + + intros [[a b] c]; reflexivity. +Defined. + +(** The direct product is functorial in its second argument. *) +Definition lm_prod_iso_r {R : Ring} {A B B' : LeftModule R} + (eB : LeftModuleIsomorphism B B') + : LeftModuleIsomorphism (lm_prod A B) (lm_prod A B'). +Proof. + snapply Build_LeftModuleIsomorphism. + - exact (lm_prod_corec _ lm_prod_fst (lm_homo_compose eB lm_prod_snd)). + - snapply isequiv_adjointify. + + exact (lm_prod_corec _ lm_prod_fst + (lm_homo_compose (lm_iso_inverse eB) lm_prod_snd)). + + intros [a b']; snapply path_prod'; [ reflexivity | exact (eisretr _ b') ]. + + intros [a b]; snapply path_prod'; [ reflexivity | exact (eissect _ b) ]. +Defined. + +(** The direct product is functorial in both arguments. *) +Definition lm_prod_iso2 {R : Ring} {A A' B B' : LeftModule R} + (eA : LeftModuleIsomorphism A A') (eB : LeftModuleIsomorphism B B') + : LeftModuleIsomorphism (lm_prod A B) (lm_prod A' B'). +Proof. + snapply Build_LeftModuleIsomorphism. + - exact (lm_prod_corec _ (lm_homo_compose eA lm_prod_fst) + (lm_homo_compose eB lm_prod_snd)). + - snapply isequiv_adjointify. + + exact (lm_prod_corec _ (lm_homo_compose (lm_iso_inverse eA) lm_prod_fst) + (lm_homo_compose (lm_iso_inverse eB) lm_prod_snd)). + + intros [a' b']; snapply path_prod'; [ exact (eisretr _ a') | exact (eisretr _ b') ]. + + intros [a b]; snapply path_prod'; [ exact (eissect _ a) | exact (eissect _ b) ]. +Defined. + +(** [R^m] direct sum [R^n] is [R^(m+n)]. *) +Definition lm_power_add {R : Ring} (m n : nat) + : LeftModuleIsomorphism (lm_prod (lm_power R m) (lm_power R n)) + (lm_power R (m + n)%nat). +Proof. + induction m as [|k IH]. + - exact lm_prod_zero_l. + - exact (lm_iso_compose (lm_prod_iso_r IH) lm_prod_assoc). +Defined. + +(** A direct sum of free modules is free. *) +Definition isfreemodule_prod {R : Ring} {M N : LeftModule R} + (HM : IsFreeModule M) (HN : IsFreeModule N) + : IsFreeModule (lm_prod M N). +Proof. + strip_truncations. + exact (tr ((HM.1 + HN.1)%nat; + lm_iso_compose (lm_power_add HM.1 HN.1) (lm_prod_iso2 HM.2 HN.2))). +Defined. + +(** A homomorphism with a section and free kernel and codomain has a free + domain. *) +Definition isfreemodule_split {R : Ring} {M Q : LeftModule R} + (f : M $-> Q) (s : Q $-> M) (hs : forall q, f (s q) = q) + (Hk : IsFreeModule (lm_kernel f)) (HQ : IsFreeModule Q) + : IsFreeModule M + := isfreemodule_iso (lm_split_iso f s hs) (isfreemodule_prod Hk HQ). + +(** [R^n] is free. *) +Definition isfreemodule_lm_power {R : Ring} (n : nat) + : IsFreeModule (lm_power R n). +Proof. + apply tr; exists n. + snapply Build_LeftModuleIsomorphism. + - exact (lm_homo_id _). + - exact _. +Defined. + +(** The regular module is free. *) +Definition isfreemodule_lm_regular {R : Ring} + : IsFreeModule (lm_regular R) + := tr (1%nat; lm_iso_inverse lm_prod_zero_r). + +(** A contractible module is free of rank zero. *) +Definition isfreemodule_contr {R : Ring} (M : LeftModule R) `{Contr M} + : IsFreeModule M. +Proof. + apply tr; exists 0%nat. + snapply Build_LeftModuleIsomorphism. + - snapply Build_LeftModuleHomomorphism'. + + exact (fun _ => 0). + + intros r x y; apply path_contr. + - rapply isequiv_contr_contr. +Defined. + +(** An injective homomorphism corestricts to an isomorphism onto its image. *) +Definition lm_iso_image {R : Ring} {M N : LeftModule R} (f : M $-> N) + `{IsEmbedding f} + : LeftModuleIsomorphism M (lm_image f). +Proof. + snapply Build_LeftModuleIsomorphism. + - exact (lm_corestrict (lm_image f) f (fun m => tr (m; idpath))). + - snapply isequiv_surj_emb. + + apply BuildIsSurjection. + intro b. + napply (Trunc_functor (-1) _ b.2). + intros [x q]. + exists x; apply path_sigma_hprop; exact q. + + apply isembedding_isinj_hset. + intros a b r. + exact (isinj_embedding f _ a b (ap pr1 r)). +Defined. + +(** Submodules with the same membership are isomorphic as modules. *) +Definition lm_iso_of_submodule_iff {R : Ring} {M : LeftModule R} + (N N' : LeftSubmodule M) (h : forall y, N y <-> N' y) + : LeftModuleIsomorphism (leftmodule_leftsubmodule N) + (leftmodule_leftsubmodule N'). +Proof. + snapply Build_LeftModuleIsomorphism. + - snapply Build_LeftModuleHomomorphism'. + + exact (fun yn => (yn.1; fst (h yn.1) yn.2)). + + intros r x y; by apply path_sigma_hprop. + - snapply isequiv_adjointify. + + exact (fun yn => (yn.1; snd (h yn.1) yn.2)). + + intros [y hy]; by apply path_sigma_hprop. + + intros [y hy]; by apply path_sigma_hprop. +Defined. + +(** A homomorphism out of the regular module is multiplication by the image + of [1]. *) +Definition lm_homo_regular_mult {R : Ring} {M : LeftModule R} + (h : lm_regular R $-> M) (r : R) : h r = r *L h 1. +Proof. + lhs napply (ap h (rng_mult_one_r r)^). + napply lm_homo_lact. +Defined. + +(** Divisibility is preserved by sums. *) +Definition rng_divides_plus {R : CRing} {d a b : R} + (pa : rng_divides d a) (pb : rng_divides d b) : rng_divides d (a + b). +Proof. + strip_truncations; destruct pa as [c1 p1], pb as [c2 p2]. + apply tr; exists (c1 + c2). + exact (ap011 (+) p1 p2 @ (rng_dist_r c1 c2 d)^). +Defined. + +(** Right multiplication by a ring element. *) +Definition lm_right_mult {R : Ring} (d : R) : lm_regular R $-> lm_regular R. +Proof. + snapply Build_LeftModuleHomomorphism. + - exact (grp_homo_rng_right_mult d). + - intros r x; symmetry; rapply rng_mult_assoc. +Defined. + +(** Over a commutative ring, multiplication by a regular element is an + embedding. *) +Definition isembedding_lm_right_mult {R : CRing} (d : R) (hd : IsRegular d) + : IsEmbedding (lm_right_mult (R:=R) d). +Proof. + apply isembedding_isinj_hset. + intros x y p. + apply hd. + exact (rng_mult_comm d x @ p @ rng_mult_comm y d). +Defined. + +(** The principal submodule generated by a regular element is free of rank + one. *) +Definition isfreemodule_image_right_mult {R : CRing} (d : R) (hd : IsRegular d) + : IsFreeModule (lm_image (lm_right_mult (R:=R) d)) + := isfreemodule_iso + (lm_iso_inverse + (@lm_iso_image _ _ _ (lm_right_mult d) (isembedding_lm_right_mult d hd))) + isfreemodule_lm_regular. + +(** * Finitely generated submodules of [R] are free *) + +(** A homomorphism out of [R^(S j)] decomposes along the first coordinate. *) +Definition lm_image_decomp {R : Ring} {j : nat} + (g : lm_power R (S j) $-> lm_regular R) (x : lm_power R (S j)) + : g x = fst x *L g (lm_prod_inl 1) + + lm_homo_compose g lm_prod_inr (snd x). +Proof. + transitivity (g (lm_prod_inl (fst x) + lm_prod_inr (snd x))). + - apply ap; snapply path_prod'. + + exact (right_identity (fst x))^. + + exact (left_identity (snd x))^. + - lhs napply grp_homo_op. + f_ap. + exact (lm_homo_regular_mult (lm_homo_compose g lm_prod_inl) (fst x)). +Defined. + +(** The image of a homomorphism [R^k -> R] over a Bézout ring is principal. *) +Definition lm_image_principal {R : CRing} `{IsBezoutRing R} + : forall (k : nat) (g : lm_power R k $-> lm_regular R), + merely { d : R & forall y, lm_image g y <-> rng_divides d y }. +Proof. + induction k as [|j IH]; intro g. + - apply tr; exists 0; intro y; split. + + intros hy; strip_truncations; destruct hy as [x p]. + apply tr; exists 0. + refine (p^ @ ap g (path_ishprop x mon_unit) @ grp_homo_unit g @ _). + exact (rng_mult_zero_r 0)^. + + intros hd; strip_truncations; destruct hd as [c p]. + apply tr; exists mon_unit. + refine (grp_homo_unit g @ _). + exact (p @ rng_mult_zero_r c)^. + - pose (a := g (lm_prod_inl 1)). + pose (g' := lm_homo_compose g lm_prod_inr). + pose proof (IH g') as IHg'; strip_truncations; destruct IHg' as [d' H']. + pose proof (bezout_relation a d') as hb; strip_truncations. + destruct hb as [u [v hg]]. + apply tr; exists (u * a + v * d'); intro y; split. + + intros hy; strip_truncations; destruct hy as [x p]. + refine (transport (rng_divides (u * a + v * d')) ((lm_image_decomp g x)^ @ p) _). + apply rng_divides_plus. + * exact (rng_divides_mul_l (fst x) (fst (fst hg))). + * refine (rng_divides_trans (snd (fst hg)) _). + exact (fst (H' (g' (snd x))) (tr (snd x; idpath))). + + intros hd; strip_truncations; destruct hd as [c p]. + assert (hd' : lm_image g' d') by exact (snd (H' d') (rng_divides_refl d')). + strip_truncations; destruct hd' as [x'' q]. + assert (hgg : lm_image g (u * a + v * d')). + { apply tr. + exists (u *L lm_prod_inl 1 + v *L lm_prod_inr x''). + lhs napply grp_homo_op. + f_ap. + - lhs napply lm_homo_lact; reflexivity. + - lhs napply lm_homo_lact; exact (ap (fun z => v *L z) q). } + refine (transport (lm_image g) p^ _). + rapply is_left_submodule; exact hgg. +Defined. + +(** The difference of two module homomorphisms. *) +Definition lm_homo_sub {R : Ring} {M N : LeftModule R} (f g : M $-> N) + : M $-> N. +Proof. + snapply Build_LeftModuleHomomorphism. + - exact (@lm_homo_map _ _ _ f - @lm_homo_map _ _ _ g). + - intros r m; cbn. + lhs napply (ap (fun z => z - g (r *L m)) (@lm_homo_lact _ _ _ f r m)). + lhs napply (ap (fun z => r *L f m - z) (@lm_homo_lact _ _ _ g r m)). + symmetry. + lhs napply (lm_dist_l r (f m) (- g m)). + napply (ap (fun z => r *L f m + z) (lm_neg r (g m))). +Defined. + +(** Scalar multiplication by a fixed element, as a homomorphism out of the + regular module. *) +Definition lm_scalar {R : Ring} {M : LeftModule R} (x : M) + : lm_regular R $-> M. +Proof. + snapply Build_LeftModuleHomomorphism. + - snapply Build_GroupHomomorphism. + + exact (fun c => c *L x). + + intros c c'; napply lm_dist_r. + - intros r c; symmetry; napply lm_assoc. +Defined. + +(** Division by a regular element is well-defined. *) +Definition rng_div_regular {R : CRing} {d : R} (dreg : IsRegular d) {y : R} + (h : rng_divides d y) : { c : R & y = c * d }. +Proof. + napply (Trunc_rec (A := { c : R & y = c * d }) _ h). + - apply hprop_allpath; intros [c p] [c' p']; apply path_sigma_hprop; cbn. + apply dreg. + exact (rng_mult_comm d c @ p^ @ p' @ rng_mult_comm c' d). + - exact idmap. +Defined. + +(** Dividing a homomorphism whose values are divisible by a regular [d]. *) +Definition lm_div_d {R : CRing} {d : R} (dreg : IsRegular d) {L : LeftModule R} + (h : L $-> lm_regular R) (hdiv : forall l, rng_divides d (h l)) + : L $-> lm_regular R. +Proof. + snapply Build_LeftModuleHomomorphism. + - snapply Build_GroupHomomorphism. + + exact (fun l => (rng_div_regular dreg (hdiv l)).1). + + intros l l'; apply dreg. + lhs napply rng_mult_comm. + lhs_V napply (rng_div_regular dreg (hdiv (l + l'))).2. + lhs napply grp_homo_op. + lhs napply (ap011 (+) (rng_div_regular dreg (hdiv l)).2 + (rng_div_regular dreg (hdiv l')).2). + lhs_V napply rng_dist_r. + napply rng_mult_comm. + - intros r l; apply dreg. + lhs napply rng_mult_comm. + lhs_V napply (rng_div_regular dreg (hdiv (r *L l))).2. + lhs napply (@lm_homo_lact _ _ _ h r l). + lhs napply (ap (fun z => r * z) (rng_div_regular dreg (hdiv l)).2). + lhs napply rng_mult_assoc. + napply rng_mult_comm. +Defined. + +(** A finitely generated submodule of [R] over a Bézout domain is free. *) +Definition isfreemodule_image_to_regular {R : CRing} `{IsBezoutDomain R} (k : nat) + (g : lm_power R k $-> lm_regular R) : IsFreeModule (lm_image g). +Proof. + pose proof (lm_image_principal k g) as hp; strip_truncations. + destruct hp as [d Hg]. + destruct (intdom_zero_or_regular d) as [d0 | dreg]. + - napply isfreemodule_contr. + snapply (Build_Contr _ (0; snd (Hg 0) (tr (0; (rng_mult_zero_l d)^)))). + intros [y hy]; apply path_sigma_hprop; cbn. + pose proof (transport (fun z => rng_divides z y) d0 (fst (Hg y) hy)) as hdy. + strip_truncations; destruct hdy as [c q]. + exact (q @ rng_mult_zero_r c)^. + - assert (hrm : forall y, lm_image g y <-> lm_image (lm_right_mult d) y). + { intro y; split; intro h. + - exact (Trunc_functor (-1) (fun cp => (cp.1; cp.2^)) (fst (Hg y) h)). + - exact (snd (Hg y) (Trunc_functor (-1) (fun cp => (cp.1; cp.2^)) h)). } + exact (isfreemodule_iso (lm_iso_of_submodule_iff _ _ hrm) + (isfreemodule_image_right_mult d dreg)). +Defined. + +(** A homomorphism landing in [{0} × R^m] has image isomorphic to that of its + second component. *) +Definition lm_iso_image_snd {R : Ring} {L : LeftModule R} {m : nat} + (h : L $-> lm_power R (S m)) (hfst : forall l, fst (h l) = 0) + : LeftModuleIsomorphism (lm_image h) + (lm_image (lm_homo_compose lm_prod_snd h)). +Proof. + snapply Build_LeftModuleIsomorphism. + - snapply (lm_corestrict (lm_image (lm_homo_compose lm_prod_snd h)) + (lm_homo_compose lm_prod_snd (lm_subincl (lm_image h)))). + intros [y py]. + exact (Trunc_functor (-1) (fun lq => (lq.1; ap snd lq.2)) py). + - snapply isequiv_adjointify. + + snapply (lm_corestrict (lm_image h) + (lm_homo_compose lm_prod_inr + (lm_subincl (lm_image (lm_homo_compose lm_prod_snd h))))). + intros [z pz]. + exact (Trunc_functor (-1) + (fun lq => (lq.1; path_prod' (hfst lq.1) lq.2)) pz). + + intros [z pz]; by apply path_sigma_hprop. + + intros [y py]; apply path_sigma_hprop; cbn. + strip_truncations; destruct py as [l q]. + exact (path_prod' (hfst l)^ (ap snd q)^ @ q). +Defined. + +(** * Submodules generated by a family *) + +(** The closure of [X] under zero and [n + r *L m]. *) +Inductive sm_gen_type {R : Ring} {M : LeftModule R} (X : M -> Type) : M -> Type := +| smgt_in (x : M) : X x -> sm_gen_type X x +| smgt_zero : sm_gen_type X 0 +| smgt_comb (r : R) (n m : M) + : sm_gen_type X n -> sm_gen_type X m -> sm_gen_type X (n + r *L m). + +(** The submodule generated by a predicate. *) +Definition submodule_generated {R : Ring} {M : LeftModule R} (X : M -> Type) + : LeftSubmodule M. +Proof. + snapply (Build_LeftSubmodule' (fun m => merely (sm_gen_type X m))). + - exact _. + - exact (tr (smgt_zero X)). + - intros r n m hn hm; strip_truncations. + exact (tr (smgt_comb X r n m hn hm)). +Defined. + +(** The generators lie in the generated submodule. *) +Definition submodule_generated_in {R : Ring} {M : LeftModule R} (X : M -> Type) + (x : M) (hx : X x) : submodule_generated X x + := tr (smgt_in X x hx). + +(** The generated submodule is the smallest one containing the generators. *) +Definition submodule_generated_rec {R : Ring} {M : LeftModule R} (X : M -> Type) + (N : LeftSubmodule M) (HX : forall x, X x -> N x) + : forall m, submodule_generated X m -> N m. +Proof. + intros m; rapply Trunc_rec; intro hm. + induction hm as [x hx | | r n m' hn IHn hm' IHm]. + - exact (HX x hx). + - exact issubgroup_in_unit. + - rapply issubgroup_in_op. + + exact IHn. + + rapply is_left_submodule; exact IHm. +Defined. + +(** The image of a homomorphism into a contractible module is free. *) +Definition isfreemodule_image_into_contr {R : Ring} {M N : LeftModule R} + `{Contr N} (f : M $-> N) : IsFreeModule (lm_image f). +Proof. + napply isfreemodule_contr. + snapply Build_Contr. + - exact (0; tr (0; grp_homo_unit f)). + - intros [y hy]; apply path_sigma_hprop; apply path_contr. +Defined. + +(** The image of a homomorphism from a contractible module is free. *) +Definition isfreemodule_image_from_contr {R : Ring} {M N : LeftModule R} + `{Contr M} (f : M $-> N) : IsFreeModule (lm_image f). +Proof. + napply isfreemodule_contr. + snapply Build_Contr. + - exact (f (center M); tr (center M; idpath)). + - intros [y hy]; apply path_sigma_hprop; cbn. + strip_truncations; destruct hy as [x p]. + exact (ap f (path_contr (center M) x) @ p). +Defined. + +(** * Finitely generated submodules of [R^n] are free *) + +(** A finitely generated submodule of [R^n] over a Bézout domain is free; the + image of any homomorphism [R^k -> R^n] is free. *) +Definition isfreemodule_image_power {R : CRing} `{IsBezoutDomain R} + : forall (n k : nat) (phi : lm_power R k $-> lm_power R n), + IsFreeModule (lm_image phi). +Proof. + induction n as [|m IHn]; intros k phi. + - exact (isfreemodule_image_into_contr phi). + - pose (g := lm_homo_compose lm_prod_fst phi). + pose proof (lm_image_principal k g) as hp; strip_truncations. + destruct hp as [d Hg]. + assert (hdivg : forall x, rng_divides d (g x)) + by exact (fun x => fst (Hg (g x)) (grp_image_in g x)). + destruct (intdom_zero_or_regular d) as [d0 | dreg]. + + (* The principal generator vanishes, so [phi] lands in the second factor. *) + assert (hfst : forall x, fst (phi x) = 0). + { intro x. + pose proof (transport (fun z => rng_divides z (g x)) d0 (hdivg x)) as hx. + strip_truncations; destruct hx as [c q]. + exact (q @ rng_mult_zero_r c). } + napply (isfreemodule_iso (lm_iso_image_snd phi hfst)). + exact (IHn k (lm_homo_compose lm_prod_snd phi)). + + (* The principal generator is regular; split off a free rank-one summand. *) + pose proof (snd (Hg d) (rng_divides_refl d)) as hd0; strip_truncations. + destruct hd0 as [x0 qx0]. + pose (q := lm_div_d dreg g hdivg). + pose (kappa := lm_homo_sub phi (lm_homo_compose (lm_scalar (phi x0)) q)). + assert (hfstk : forall x, fst (kappa x) = 0). + { intro x. + lhs napply (ap (fun z => g x - q x * z) qx0). + lhs_V napply (ap (fun z => g x - z) (rng_div_regular dreg (hdivg x)).2). + exact (right_inverse (g x)). } + assert (hqzero : forall x, g x = 0 -> q x = 0). + { intros x hgx; apply dreg. + lhs napply rng_mult_comm. + lhs_V napply (rng_div_regular dreg (hdivg x)).2. + lhs napply hgx. + exact (rng_mult_zero_r d)^. } + assert (hkphi : forall x, phi (x - q x *L x0) = kappa x). + { intro x. + lhs napply grp_homo_op. + napply (ap (fun z => phi x + z)). + lhs napply grp_homo_inv. + napply (ap (fun z => - z)). + napply (@lm_homo_lact _ _ _ phi (q x) x0). } + pose (f := lm_corestrict (lm_image g) + (lm_homo_compose lm_prod_fst (lm_subincl (lm_image phi))) + (fun mm => Trunc_functor (-1) + (fun xp => (xp.1; ap fst xp.2)) mm.2)). + pose (m0 := (phi x0; tr (x0; idpath)) : lm_image phi). + pose (cQ := lm_div_d dreg (lm_subincl (lm_image g)) + (fun qq => fst (Hg qq.1) qq.2)). + pose (s := lm_homo_compose + (lm_scalar (M := leftmodule_leftsubmodule (lm_image phi)) m0) cQ). + assert (hs : forall qq, f (s qq) = qq). + { intro qq; apply path_sigma_hprop. + lhs napply (ap (fun z => cQ qq * z) qx0). + exact (rng_div_regular dreg (fst (Hg qq.1) qq.2)).2^. } + assert (Hk : IsFreeModule (lm_kernel f)). + { snapply (isfreemodule_iso (N := lm_image kappa)). + - snapply Build_LeftModuleIsomorphism. + + snapply Build_LeftModuleHomomorphism'. + * intro mp. + exists mp.1.1. + refine (Trunc_functor (-1) _ mp.1.2). + intro xp. + exists xp.1. + pose (hg0 := ap fst xp.2 @ ap pr1 mp.2). + refine (_ @ xp.2). + lhs napply (ap (fun z => phi xp.1 - z *L phi x0) + (hqzero xp.1 hg0)). + lhs napply (ap (fun z => phi xp.1 - z) (lm_zero_l (phi x0))). + exact (ap (fun z => phi xp.1 + z) grp_inv_unit + @ grp_unit_r (phi xp.1)). + * intros r x y; apply path_sigma_hprop; reflexivity. + + snapply isequiv_adjointify. + * intro zp. + snrefine ((zp.1; _); _). + -- exact (Trunc_functor (-1) + (fun xp => (xp.1 - q xp.1 *L x0; hkphi xp.1 @ xp.2)) zp.2). + -- apply path_sigma_hprop. + pose proof zp.2 as pz; strip_truncations; destruct pz as [x px]. + exact ((ap fst px)^ @ hfstk x). + * intros [z pz]; apply path_sigma_hprop; reflexivity. + * intros [[w pw] pf]; apply path_sigma_hprop; + apply path_sigma_hprop; reflexivity. + - exact (isfreemodule_iso (lm_iso_image_snd kappa hfstk) + (IHn k (lm_homo_compose lm_prod_snd kappa))). } + exact (isfreemodule_split f s hs Hk (isfreemodule_image_to_regular k g)). +Defined. diff --git a/theories/Algebra/Rings/GroupRing.v b/theories/Algebra/Rings/GroupRing.v new file mode 100644 index 00000000000..47eb8253aad --- /dev/null +++ b/theories/Algebra/Rings/GroupRing.v @@ -0,0 +1,180 @@ +From HoTT Require Import Basics Types. +From HoTT.WildCat Require Import Core. +Require Import Classes.interfaces.canonical_names. +Require Import Algebra.Groups.Group. +Require Import Algebra.AbGroups.AbelianGroup Algebra.AbGroups.AbHom + Algebra.AbGroups.FreeAbelianGroup. +Require Import Algebra.Rings.Ring. + +Local Open Scope mc_scope. +Local Open Scope mc_add_scope. + +(** * The group ring [ℤG] + + Following Christensen and Flaten, Construction 2.7.1 and Proposition 2.7.2: + the group ring of [G] is the free abelian group on [G] with multiplication + extending the group operation, together with its universal property. *) + +Section GroupRing. + Context `{Funext} (G : Group). + + Definition group_ring_ab : AbGroup := FreeAbGroup G. + + Local Notation ZG := group_ring_ab. + + (** Multiplication, as a homomorphism into the endomorphism group. *) + Definition group_ring_mult_hom : ZG $-> ab_hom ZG ZG + := FreeAbGroup_rec (A := ab_hom ZG ZG) + (fun g => FreeAbGroup_rec (A := ZG) (fun h => freeabgroup_in (sg_op g h))). + + Instance group_ring_mult : Mult ZG + := fun x y => group_ring_mult_hom x y. + + Instance group_ring_one : One ZG := freeabgroup_in mon_unit. + + (** Generators multiply by the group operation. *) + Definition group_ring_mult_in (g h : G) + : (freeabgroup_in g * freeabgroup_in h : ZG) = freeabgroup_in (sg_op g h) + := idpath. + + (** Evaluation at a point, as a homomorphism out of the endomorphism group. *) + Definition group_ring_eval (y : ZG) : ab_hom ZG ZG $-> ZG. + Proof. + snapply Build_GroupHomomorphism. + - exact (fun phi => phi y). + - intros phi psi; reflexivity. + Defined. + + Instance group_ring_left_distribute : LeftDistribute (A:=ZG) (.*.) (+). + Proof. + intros x y z; exact (grp_homo_op (group_ring_mult_hom x) y z). + Defined. + + Instance group_ring_right_distribute : RightDistribute (A:=ZG) (.*.) (+). + Proof. + intros x y z. + refine (ap (fun phi : ab_hom ZG ZG => phi z) + (grp_homo_op group_ring_mult_hom x y) @ _). + reflexivity. + Defined. + + Instance group_ring_left_identity : LeftIdentity (A:=ZG) (.*.) 1. + Proof. + intro x. + exact (FreeAbGroup_ind_homotopy + (f := group_ring_mult_hom (freeabgroup_in mon_unit)) + (f' := grp_homo_id) + (fun g => ap freeabgroup_in (left_identity g)) x). + Defined. + + Instance group_ring_right_identity : RightIdentity (A:=ZG) (.*.) 1. + Proof. + intro x. + exact (FreeAbGroup_ind_homotopy + (f := group_ring_eval (freeabgroup_in mon_unit) $o group_ring_mult_hom) + (f' := grp_homo_id) + (fun g => ap freeabgroup_in (right_identity g)) x). + Defined. + + (** Left multiplication by a fixed element, as a homomorphism. *) + Definition group_ring_lmul (a : ZG) : ZG $-> ZG := group_ring_mult_hom a. + + (** Associativity on generators reduces to associativity in [G]. *) + Definition group_ring_assoc_gen (g h k : G) + : (freeabgroup_in g * (freeabgroup_in h * freeabgroup_in k) : ZG) + = (freeabgroup_in g * freeabgroup_in h) * freeabgroup_in k. + Proof. + exact (ap freeabgroup_in (simple_associativity g h k)). + Defined. + + Instance group_ring_associative : Associative (A:=ZG) (.*.). + Proof. + intros x y z. + change ((group_ring_eval (y * z) $o group_ring_mult_hom) x + = (group_ring_eval z $o (group_ring_mult_hom + $o (group_ring_eval y $o group_ring_mult_hom))) x). + revert x; rapply FreeAbGroup_ind_homotopy; intro g. + change ((group_ring_lmul (freeabgroup_in g) + $o (group_ring_eval z $o group_ring_mult_hom)) y + = (group_ring_eval z $o (group_ring_mult_hom + $o group_ring_lmul (freeabgroup_in g))) y). + revert y; rapply FreeAbGroup_ind_homotopy; intro h. + change ((group_ring_lmul (freeabgroup_in g) + $o group_ring_lmul (freeabgroup_in h)) z + = group_ring_lmul (freeabgroup_in g * freeabgroup_in h) z). + revert z; rapply FreeAbGroup_ind_homotopy; intro k. + exact (group_ring_assoc_gen g h k). + Defined. + + Definition group_ring : Ring := Build_Ring ZG _ _ _ _ _ _ _. + + (** The universal property: a homomorphism from [G] to the units of a ring + [R] extends to a ring homomorphism out of [ℤG]. *) + Definition group_ring_rec (R : Ring) + (psi : GroupHomomorphism G (rng_unit_group R)) + : RingHomomorphism group_ring R. + Proof. + pose (map := FreeAbGroup_rec (A := R) (fun g => (psi g).1) + : group_ring_ab $-> R). + snapply (Build_RingHomomorphism' group_ring R map). + snapply Build_IsMonoidPreserving. + - intros x y. + change ((grp_homo_compose map (group_ring_eval y $o group_ring_mult_hom)) x + = grp_homo_compose (grp_homo_rng_right_mult (map y)) map x). + revert x; rapply FreeAbGroup_ind_homotopy; intro g. + change ((grp_homo_compose map (group_ring_lmul (freeabgroup_in g))) y + = grp_homo_compose + (grp_homo_rng_left_mult (map (freeabgroup_in g))) map y). + revert y; rapply FreeAbGroup_ind_homotopy; intro h. + exact (ap pr1 (grp_homo_op psi g h)). + - exact (ap pr1 (grp_homo_unit psi)). + Defined. + + (** Conversely, a ring homomorphism out of [ℤG] restricts to a homomorphism + from [G] to the units, since each generator is invertible. *) + Definition group_ring_restrict (R : Ring) + (phi : RingHomomorphism group_ring R) + : GroupHomomorphism G (rng_unit_group R). + Proof. + snapply Build_GroupHomomorphism. + - intro g. + exists (phi (freeabgroup_in g)). + rapply (Build_IsInvertible (phi (freeabgroup_in g)) + (phi (freeabgroup_in (inv g)))). + + refine ((rng_homo_mult phi + (freeabgroup_in (inv g)) (freeabgroup_in g))^ @ _). + refine (ap phi (group_ring_mult_in (inv g) g) @ _). + refine (ap (fun u => phi (freeabgroup_in u)) (left_inverse g) @ _). + exact (rng_homo_one phi). + + refine ((rng_homo_mult phi + (freeabgroup_in g) (freeabgroup_in (inv g)))^ @ _). + refine (ap phi (group_ring_mult_in g (inv g)) @ _). + refine (ap (fun u => phi (freeabgroup_in u)) (right_inverse g) @ _). + exact (rng_homo_one phi). + - intros g g'. + apply path_sigma_hprop; cbn. + refine ((ap phi (group_ring_mult_in g g'))^ @ _). + exact (rng_homo_mult phi (freeabgroup_in g) (freeabgroup_in g')). + Defined. + + (** Ring homomorphisms out of [ℤG] correspond to homomorphisms from [G] to + the units. *) + Definition equiv_group_ring_rec (R : Ring) + : RingHomomorphism group_ring R <~> GroupHomomorphism G (rng_unit_group R). + Proof. + snapply equiv_adjointify. + - exact (group_ring_restrict R). + - exact (group_ring_rec R). + - intro psi. + apply equiv_path_grouphomomorphism; intro g. + by apply path_sigma_hprop. + - intro phi. + apply equiv_path_ringhomomorphism. + intro x; revert x. + rapply (FreeAbGroup_ind_homotopy + (f := grp_homo_rng_homo (group_ring_rec R (group_ring_restrict R phi))) + (f' := grp_homo_rng_homo phi)). + intro g; reflexivity. + Defined. + +End GroupRing. diff --git a/theories/Algebra/Rings/Module.v b/theories/Algebra/Rings/Module.v index 8764c4150f1..6a726774eb7 100644 --- a/theories/Algebra/Rings/Module.v +++ b/theories/Algebra/Rings/Module.v @@ -529,6 +529,20 @@ Definition rm_image {R : Ring} {M N : RightModule R} (f : M $-> N) : RightSubmodule N := lm_image (R:=rng_op R) f. +(** ** Corestriction to a submodule *) + +(** A homomorphism whose image lands in a submodule corestricts to it. *) +Definition lm_corestrict {R : Ring} {L M : LeftModule R} (P : LeftSubmodule M) + (h : L $-> M) (hP : forall l, P (h l)) + : L $-> P. +Proof. + snapply Build_LeftModuleHomomorphism'. + - exact (fun l => (h l; hP l)). + - intros r x y; apply path_sigma_hprop; cbn. + exact (grp_homo_op h (r *L x) y + @ ap (fun z => z + h y) (@lm_homo_lact _ _ _ h r x)). +Defined. + (** ** Quotient Modules *) (** The quotient abelian group of a module and a submodule has a natural ring action. *) @@ -607,8 +621,7 @@ Definition rm_first_iso `{Funext} {R : Ring} {M N : RightModule R} (f : M $-> N) (** ** Direct products *) -(** TODO: generalise to biproducts *) -(** The direct product of modules *) +(** The direct product of modules. *) Definition lm_prod {R : Ring} : LeftModule R -> LeftModule R -> LeftModule R. Proof. intros M N. @@ -683,6 +696,48 @@ Instance hasbinaryproducts_rightmodule {R : Ring} : HasBinaryProducts (RightModule R) := hasbinaryproducts_leftmodule (R:=rng_op R). +(** The direct product is also a coproduct: the injections and the recursor. *) + +Definition lm_prod_inl {R : Ring} {M N : LeftModule R} : M $-> lm_prod M N. +Proof. + snapply Build_LeftModuleHomomorphism. + - exact grp_prod_inl. + - intros r m; snapply path_prod'. + + reflexivity. + + exact (lm_zero_r r)^. +Defined. + +Definition lm_prod_inr {R : Ring} {M N : LeftModule R} : N $-> lm_prod M N. +Proof. + snapply Build_LeftModuleHomomorphism. + - exact grp_prod_inr. + - intros r n; snapply path_prod'. + + exact (lm_zero_r r)^. + + reflexivity. +Defined. + +Definition lm_prod_rec {R : Ring} {M N L : LeftModule R} + (f : M $-> L) (g : N $-> L) + : lm_prod M N $-> L. +Proof. + snapply Build_LeftModuleHomomorphism. + - exact (ab_biprod_rec f g). + - intros r mn; cbn. + refine (ap011 (+) (@lm_homo_lact _ _ _ f r (fst mn)) + (@lm_homo_lact _ _ _ g r (snd mn)) @ _). + exact (lm_dist_l r (f (fst mn)) (g (snd mn)))^. +Defined. + +Definition lm_prod_rec_beta_inl {R : Ring} {M N L : LeftModule R} + (f : M $-> L) (g : N $-> L) (m : M) + : lm_prod_rec f g (lm_prod_inl m) = f m + := ab_biprod_rec_beta_inl f g m. + +Definition lm_prod_rec_beta_inr {R : Ring} {M N L : LeftModule R} + (f : M $-> L) (g : N $-> L) (n : N) + : lm_prod_rec f g (lm_prod_inr n) = g n + := ab_biprod_rec_beta_inr f g n. + (** ** Finite Sums *) (** Left scalar multiplication distributes over finite sums of left module elements. *) diff --git a/theories/Algebra/Rings/ZBezout.v b/theories/Algebra/Rings/ZBezout.v new file mode 100644 index 00000000000..abdc705a7fb --- /dev/null +++ b/theories/Algebra/Rings/ZBezout.v @@ -0,0 +1,110 @@ +From HoTT Require Import Basics Types Truncations.Core. +From HoTT.WildCat Require Import Core. +Require Import Spaces.Int Spaces.Nat.Core Spaces.Nat.Division. +Require Import Algebra.AbGroups.AbelianGroup Algebra.AbGroups.Z. +Require Import Algebra.Rings.Ring Algebra.Rings.CRing Algebra.Rings.Z + Algebra.Rings.Bezout. + +Local Open Scope mc_scope. + +(** * The integers form a Bézout domain *) + +(** The absolute value of an integer, as a natural number. *) +Definition int_abs (x : Int) : nat := + match x with + | negS n => n.+1 + | posS n => n.+1 + | _ => 0%nat + end. + +Definition int_abs_of_nat (n : nat) : int_abs (int_of_nat n) = n. +Proof. + by destruct n. +Defined. + +Definition int_abs_neg (x : Int) : int_abs (int_neg x) = int_abs x. +Proof. + by destruct x. +Defined. + +(** Every integer is its absolute value up to sign. *) +Definition int_abs_decomp (x : Int) + : (x = int_of_nat (int_abs x)) + (x = int_neg (int_of_nat (int_abs x))). +Proof. + destruct x. + - exact (inr idpath). + - exact (inl idpath). + - exact (inl idpath). +Defined. + +(** Absolute value of a product of two naturals coerced into [Int]. *) +Definition int_abs_of_nat_mul (a b : nat) + : int_abs (int_mul (int_of_nat a) (int_of_nat b)) = (a * b)%nat + := ap int_abs (int_nat_mul a b) @ int_abs_of_nat (a * b). + +(** Absolute value is multiplicative. *) +Definition int_abs_mul (x y : Int) + : int_abs (int_mul x y) = (int_abs x * int_abs y)%nat. +Proof. + destruct (int_abs_decomp x) as [px | px], (int_abs_decomp y) as [py | py]; + lhs napply (ap int_abs (ap011 int_mul px py)). + - napply int_abs_of_nat_mul. + - lhs napply (ap int_abs (int_mul_neg_r _ _)). + lhs napply int_abs_neg. + napply int_abs_of_nat_mul. + - lhs napply (ap int_abs (int_mul_neg_l _ _)). + lhs napply int_abs_neg. + napply int_abs_of_nat_mul. + - lhs napply (ap int_abs (int_mul_neg_l _ _)). + lhs napply int_abs_neg. + lhs napply (ap int_abs (int_mul_neg_r _ _)). + lhs napply int_abs_neg. + napply int_abs_of_nat_mul. +Defined. + +(** An integer with trivial absolute value is zero. *) +Definition int_abs_is_zero {x : cring_Z} (p : int_abs x = 0%nat) : x = 0. +Proof. + destruct x. + - exact (Empty_rec (neq_nat_zero_succ _ p^)). + - reflexivity. + - exact (Empty_rec (neq_nat_zero_succ _ p^)). +Defined. + +(** A product of naturals vanishes only if a factor does. *) +Definition nat_mul_is_zero {a b : nat} (p : (a * b)%nat = 0%nat) + : (a = 0%nat) + (b = 0%nat). +Proof. + destruct a as [|a]; [ exact (inl idpath) | ]. + destruct b as [|b]; [ exact (inr idpath) | ]. + napply Empty_rec. + exact (neq_nat_zero_succ _ (p^ @ nat_mul_succ_l a b.+1 @ nat_add_succ_l b _)). +Defined. + +(** [cring_Z] has no zero divisors. *) +Definition int_mul_is_zero {x y : cring_Z} (p : x * y = 0) + : (x = 0) + (y = 0). +Proof. + assert (q : (int_abs x * int_abs y)%nat = 0%nat) + by exact ((int_abs_mul x y)^ @ ap int_abs p). + destruct (nat_mul_is_zero q) as [hx | hy]. + - exact (inl (int_abs_is_zero hx)). + - exact (inr (int_abs_is_zero hy)). +Defined. + +(** The integers form an integral domain. *) +Instance isintegraldomain_cring_Z : IsIntegralDomain cring_Z. +Proof. + intro x. + destruct (dec (x = 0)) as [p | np]. + - exact (inl p). + - right; intros y z h. + assert (hxyz : x * (y - z) = 0). + { lhs napply rng_dist_l. + lhs napply (ap (fun w => x * y + w) (rng_mult_negate_r x z)). + lhs napply (ap (fun w => w - x * z) h). + exact (right_inverse (x * z)). } + destruct (int_mul_is_zero hxyz) as [h0 | hyz]. + + exact (Empty_rec (np h0)). + + napply grp_moveL_1M; exact hyz. +Defined. diff --git a/theories/Homotopy/ClassifyingSpace.v b/theories/Homotopy/ClassifyingSpace.v index 3c015b8f89f..9e78e2e2344 100644 --- a/theories/Homotopy/ClassifyingSpace.v +++ b/theories/Homotopy/ClassifyingSpace.v @@ -29,6 +29,8 @@ Module Export ClassifyingSpace. Section ClassifyingSpace. + Local Set Polymorphic Inductive Cumulativity. + Private Inductive ClassifyingSpace (G : Group) := | bbase : ClassifyingSpace G. @@ -404,6 +406,16 @@ Section HSpace_bg. End HSpace_bg. +(** The classifying space of a contractible group is contractible. *) +Instance contr_pclassifyingspace `{Univalence} (G : Group) `{Contr G} + : Contr (B G). +Proof. + (* The map to [pUnit] is an equivalence, since it is one on loops. *) + pose proof (contr_equiv' G equiv_g_loops_bg). + rapply (contr_equiv' pUnit (equiv_inverse (Build_Equiv _ _ pconst _))). + rapply isequiv_is0connected_isequiv_loops. +Defined. + (** Functoriality of B(-) *) Instance is0functor_pclassifyingspace : Is0Functor B. @@ -442,6 +454,27 @@ Proof. apply pbloop_natural. Defined. +(** [fmap B] of a surjective group homomorphism is a 0-connected map. *) +Instance isconnmap_fmap_pclassifyingspace `{Univalence} {G K : Group} + (f : GroupHomomorphism G K) `{!IsSurjection f} + : IsConnMap 0 (fmap B f). +Proof. + (* By [isconnmap_isconnmap_ap_surj] it suffices to show that [fmap B f] + and its [ap]s are surjective; both follow from surjectivity of [f]. *) + snapply isconnmap_isconnmap_ap_surj. + - exact (issurjection_is0connected _ _ (tr bbase) _). + - rapply (conn_point_elim (-1) (A:=B G)). + rapply (conn_point_elim (-1) (A:=B G)). + srapply (equiv_ind equiv_g_loops_bg). + intro h. + rapply contr_inhabited_hprop. + pose proof (m := center (Tr (-1) (hfiber f h))). + strip_truncations. + destruct m as [g p]. + exact (tr (bloop g; + ClassifyingSpace_rec_beta_bloop _ _ _ _ g @ ap bloop p)). +Defined. + Instance is1functor_pclassifyingspace : Is1Functor B. Proof. apply Build_Is1Functor. diff --git a/theories/Homotopy/EMSpace.v b/theories/Homotopy/EMSpace.v index 822edca9784..2aba8e70e71 100644 --- a/theories/Homotopy/EMSpace.v +++ b/theories/Homotopy/EMSpace.v @@ -5,6 +5,7 @@ Require Import Cubical.DPath. Require Import Algebra.AbGroups.AbelianGroup. Require Import Homotopy.Suspension. Require Import Homotopy.ClassifyingSpace. +Import ClassifyingSpaceNotation. Require Import Homotopy.HSpace.Coherent. Require Import Homotopy.HomotopyGroup. Require Import Homotopy.Hopf. @@ -110,7 +111,7 @@ Section EilenbergMacLane. exact iscohhspace_loops. Defined. - (** If [G] and [G'] are isomorphic, then [K(G,n)] and [K(G',n)] are equivalent. TODO: We should show that [K(-,n)] is a functor, which implies this. *) + (** If [G] and [G'] are isomorphic, then [K(G,n)] and [K(G',n)] are equivalent. This also follows from [em_fmap] below. *) Definition pequiv_em_group_iso {G G' : Group} (n : nat) (e : G $<~> G') : K(G, n) <~>* K(G', n). @@ -118,6 +119,268 @@ Section EilenbergMacLane. by destruct (equiv_path_group e). Defined. + (** The action of [K(-,n)] on group homomorphisms, giving the functoriality + of [K(-,n)]. Note that [fmap B] and the WildCat functoriality of + [psusp] and [pTr] constrain the two groups to a single universe. *) + Definition em_fmap {G G' : AbGroup} (f : GroupHomomorphism G G') (n : nat) + : K(G, n) ->* K(G', n). + Proof. + induction n as [|n IHn]. + - exact (Build_pMap f (grp_homo_unit f)). + - destruct n as [|m]. + + exact (fmap B f). + + exact (fmap (pTr m.+2) (fmap psusp IHn)). + Defined. + + (** [em_fmap] preserves the identity. *) + Definition em_fmap_idmap {G : AbGroup} (n : nat) + : em_fmap (G:=G) grp_homo_id n ==* pmap_idmap. + Proof. + induction n as [|[|m] IH]. + - snapply Build_pHomotopy. + + reflexivity. + + rapply path_ishprop. + - exact (fmap_id B G). + - refine (_ @* fmap_id (pTr m.+2) _). + tapply (fmap2 (pTr m.+2)). + refine (_ @* fmap_id psusp _). + tapply (fmap2 psusp). + exact (pointed_htpy IH). + Defined. + + (** [em_fmap] preserves composition. *) + Definition em_fmap_compose {G G' G'' : AbGroup} + (f : GroupHomomorphism G G') (g : GroupHomomorphism G' G'') (n : nat) + : em_fmap (grp_homo_compose g f) n ==* em_fmap g n o* em_fmap f n. + Proof. + induction n as [|[|m] IH]. + - snapply Build_pHomotopy. + + reflexivity. + + rapply path_ishprop. + - exact (fmap_comp B f g). + - refine (_ @* fmap_comp (pTr m.+2) _ _). + tapply (fmap2 (pTr m.+2)). + refine (_ @* fmap_comp psusp _ _). + tapply (fmap2 psusp). + exact (pointed_htpy IH). + Defined. + + (** At positive levels, [pequiv_loops_em_em] is the canonical comparison + map: the loop-suspension unit followed by [loops] of the truncation + map. This presentation makes its naturality transparent, without + reference to the Hopf-construction input used to show that it is an + equivalence. *) + Definition loops_em_em_ptr_unit (G : AbGroup) (n : nat) + : pequiv_loops_em_em G n.+1 + ==* fmap loops ptr o* loop_susp_unit K(G, n.+1). + Proof. + destruct n as [|n]. + all: refine (compose_cate_fun (A:=pType) _ _ @* _). + all: refine (pmap_postwhisker _ (compose_cate_fun (A:=pType) _ _) @* _). + 1: refine (pmap_postwhisker _ (pto_O_natural (Tr _) _) @* _). + 2: refine (pmap_postwhisker _ (ptr_natural _ _) @* _). + all: refine ((pmap_compose_assoc _ _ _)^* @* _). + all: exact (pmap_prewhisker _ (ptr_loops_commutes _ _)). + Defined. + + (** [em_fmap] commutes with the loop-space identifications, so it is a + map of spectra. *) + Definition em_fmap_loops_natural {G G' : AbGroup} + (f : GroupHomomorphism G G') (n : nat) + : fmap loops (em_fmap f n.+1) o* pequiv_loops_em_em G n + ==* pequiv_loops_em_em G' n o* em_fmap f n. + Proof. + destruct n as [|n]. + - exact (pbloop_natural G G' f). + - refine (pmap_postwhisker _ (loops_em_em_ptr_unit G n) @* _). + refine (_ @* pmap_prewhisker _ (loops_em_em_ptr_unit G' n)^*). + refine ((pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_prewhisker _ (fmap_comp loops _ _)^* @* _). + refine (pmap_prewhisker _ (fmap2 loops (ptr_natural _ _)) @* _). + refine (pmap_prewhisker _ (fmap_comp loops _ _) @* _). + refine (pmap_compose_assoc _ _ _ @* _). + refine (pmap_postwhisker _ (loop_susp_unit_natural _)^* @* _). + exact (pmap_compose_assoc _ _ _)^*. + Defined. + + (** [equiv_g_pi_n_em] at level [n.+1] unfolds to the level-[n] map + conjugated by [groupiso_pi_loops] and [pequiv_loops_em_em]. *) + Local Definition equiv_g_pi_n_em_succ (G : AbGroup) (n : nat) (x : G) + : equiv_g_pi_n_em G n.+1 x + = grp_iso_inverse (groupiso_pi_loops _ _) + (groupiso_pi_functor _ (pequiv_loops_em_em G n.+1) + (equiv_g_pi_n_em G n x)) + := idpath. + + (** The action of [em_fmap f n.+1] on [Pi n.+1] agrees with [f] under the + identifications [equiv_g_pi_n_em]. *) + Definition pi_em_fmap {G G' : AbGroup} + (f : GroupHomomorphism G G') (n : nat) + : fmap (Pi n.+1) (em_fmap f n.+1) o equiv_g_pi_n_em G n + == equiv_g_pi_n_em G' n o f. + Proof. + induction n as [|n IHn]; intro g. + - exact (ap tr (bloop_natural G G' f g)). + - lhs napply (ap _ (equiv_g_pi_n_em_succ G n g)). + rhs napply (equiv_g_pi_n_em_succ G' n (f g)). + apply (equiv_inj (groupiso_pi_loops n _)). + rhs napply (eisretr (groupiso_pi_loops n _) _). + lhs napply (fmap_pi_loops n.+1 (em_fmap f n.+2) _). + lhs napply (ap _ (eisretr (groupiso_pi_loops n _) _)). + lhs_V exact (fmap_comp (pPi n.+1) + (pequiv_loops_em_em G n.+1 : _ ->* _) + (fmap loops (em_fmap f n.+2)) (equiv_g_pi_n_em G n g)). + lhs exact (fmap2 (pPi n.+1) (em_fmap_loops_natural f n.+1) + (equiv_g_pi_n_em G n g)). + lhs exact (fmap_comp (pPi n.+1) + (em_fmap f n.+1) (pequiv_loops_em_em G' n.+1 : _ ->* _) + (equiv_g_pi_n_em G n g)). + exact (ap _ (IHn g)). + Defined. + + (** Eilenberg-Mac Lane spaces of a contractible group are contractible. *) + #[export] Instance contr_em_contr {G : AbGroup} `{Contr G} (n : nat) + : Contr K(G, n). + Proof. + induction n as [|[|n] IHn]. + - exact _. + - exact _. + - apply (Build_Contr _ (tr (center _))). + srapply Trunc_ind; intro a. + exact (ap tr (contr a)). + Defined. + + (** Any pointed map into a contractible type is homotopic to the constant + map. *) + Local Definition phomotopy_pconst_contr {X Y : pType} `{Contr Y} + (f : X ->* Y) + : f ==* pconst. + Proof. + snapply Build_pHomotopy. + - intro x; apply path_contr. + - apply path_contr. + Defined. + + (** [em_fmap] sends the constant homomorphism to the constant map. *) + Definition em_fmap_const {G G' : AbGroup} (n : nat) + : em_fmap (G:=G) (G':=G') grp_homo_const n ==* pconst. + Proof. + refine (phomotopy_path (ap (fun h => em_fmap h n) _) + @* em_fmap_compose (G':=abgroup_trivial) + (grp_trivial_corec G) (grp_trivial_rec G') n + @* pmap_postwhisker _ (phomotopy_pconst_contr _) + @* precompose_pconst _). + napply equiv_path_grouphomomorphism; intro x; reflexivity. + Defined. + + (** [em_fmap f n.+1] of a surjective homomorphism is an [n]-connected + map. Both surjectivity of the map and of its [ap]s reduce to the + previous level through the loop-space identifications. *) + #[export] Instance isconnmap_em_fmap {G G' : AbGroup} + (f : GroupHomomorphism G G') `{!IsSurjection f} (n : nat) + : IsConnMap n (em_fmap f n.+1). + Proof. + induction n as [|n IHn]. + - exact (isconnmap_fmap_pclassifyingspace f). + - snapply isconnmap_isconnmap_ap_surj. + + exact (issurjection_is0connected _ _ (tr (point _)) _). + + assert (c : IsConnMap n (fmap loops (em_fmap f n.+2))). + { napply (conn_map_homotopic _ + ((pequiv_loops_em_em G' n.+1 o* em_fmap f n.+1) + o* (pequiv_loops_em_em G n.+1)^-1*) _ + (fun p => + (moveR_pequiv_fV _ _ _ (em_fmap_loops_natural f n.+1))^* p)). + exact _. } + snapply (conn_point_elim (-1) (A:=K(G, n.+2))). + 1,2: exact _. + snapply (conn_point_elim (-1) (A:=K(G, n.+2))). + 1,2: exact _. + intro q. + pose (e2 := equiv_concat_l (point_eq (em_fmap f n.+2))^ _ + oE equiv_concat_r (point_eq (em_fmap f n.+2)) _). + exact (isconnected_equiv' n _ + (equiv_functor_sigma_id (fun p => equiv_ap e2 _ _))^-1%equiv + (c _)). + Defined. + + (** [em_fmap] is an equivalence from group homomorphisms to pointed maps, + extending [isequiv_fmap_pclassifyingspace] to all levels. In + particular, pointed maps between Eilenberg-Mac Lane spaces of the same + level are determined by their effect on homotopy groups. *) + #[export] Instance isequiv_em_fmap (G G' : AbGroup) (n : nat) + : IsEquiv (fun f : GroupHomomorphism G G' => em_fmap f n.+1). + Proof. + induction n as [|n IHn]. + - exact (isequiv_fmap_pclassifyingspace G G'). + - (* The ladder [pequiv_ptr_rec], [loop_susp_adjoint], postcomposition + with [pequiv_loops_em_em], and the inductive hypothesis. *) + pose (L := ((Build_Equiv _ _ _ IHn)^-1%equiv) + oE (pequiv_pequiv_postcompose (pequiv_loops_em_em G' n.+1)^-1* + : (K(G, n.+1) ->** loops K(G', n.+2)) <~> _) + oE (loop_susp_adjoint K(G, n.+1) K(G', n.+2) + : (psusp K(G, n.+1) ->** _) <~> _) + oE (pequiv_ptr_rec + : (K(G, n.+2) ->** K(G', n.+2)) <~> _)). + napply (isequiv_homotopic' L^-1%equiv). + intro f. + apply moveR_equiv_V; symmetry. + apply moveR_equiv_V. + apply path_pforall. + refine (pmap_postwhisker _ + (pmap_prewhisker _ (fmap2 loops (ptr_natural _ _))) @* _). + refine (pmap_postwhisker _ + (pmap_prewhisker _ (fmap_comp loops _ _)) @* _). + refine (pmap_postwhisker _ (pmap_compose_assoc _ _ _) @* _). + refine (pmap_postwhisker _ + (pmap_postwhisker _ (loop_susp_unit_natural _)^*) @* _). + refine (pmap_postwhisker _ (pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_postwhisker _ + (pmap_prewhisker _ (loops_em_em_ptr_unit G' n)^*) @* _). + refine ((pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_prewhisker _ (peissect _) @* _). + apply pmap_postcompose_idmap. + Defined. + + (** Pointed maps between Eilenberg-Mac Lane spaces of the same level + which agree on homotopy groups are equal. *) + Definition path_em_pmap_pi {G G' : AbGroup} (n : nat) + (phi psi : K(G, n.+1) ->* K(G', n.+1)) + (h : fmap (Pi n.+1) phi == fmap (Pi n.+1) psi) + : phi = psi. + Proof. + pose (e := Build_Equiv _ _ _ (isequiv_em_fmap G G' n)). + refine ((eisretr e phi)^ @ ap e _ @ eisretr e psi). + apply equiv_path_grouphomomorphism; intro g. + apply (equiv_inj (equiv_g_pi_n_em G' n)). + refine ((pi_em_fmap _ n g)^ @ _ @ pi_em_fmap _ n g). + refine (ap (fun (m : _ ->* _) => fmap (Pi n.+1) m _) (eisretr e phi) @ _). + refine (_ @ ap (fun (m : _ ->* _) => fmap (Pi n.+1) m _) (eisretr e psi)^). + apply h. + Defined. + + (** [em_fmap] of a group isomorphism is a pointed equivalence. *) + Definition pequiv_em_fmap {G G' : AbGroup} + (e : GroupIsomorphism G G') (n : nat) + : K(G, n) <~>* K(G', n). + Proof. + snapply Build_pEquiv. + 1: exact (em_fmap e n). + snapply isequiv_adjointify. + 1: exact (em_fmap (grp_iso_inverse e) n). + - intro x. + lhs_V exact (em_fmap_compose (G':=G) (grp_iso_inverse e) e n x). + refine (phomotopy_path + (ap (fun h => em_fmap h n) (_ : _ = grp_homo_id)) x + @ em_fmap_idmap n x). + by apply equiv_path_grouphomomorphism; intro g; apply eisretr. + - intro x. + lhs_V exact (em_fmap_compose (G':=G') e (grp_iso_inverse e) n x). + refine (phomotopy_path + (ap (fun h => em_fmap h n) (_ : _ = grp_homo_id)) x + @ em_fmap_idmap n x). + by apply equiv_path_grouphomomorphism; intro g; apply eissect. + Defined. + (** Every pointed (n-1)-connected n-type is an Eilenberg-Mac Lane space. *) Definition pequiv_em_connected_truncated (X : pType) (n : nat) `{IsConnected n X} `{IsTrunc n.+1 X} @@ -146,3 +409,143 @@ Section EilenbergMacLane. Defined. End EilenbergMacLane. + +(** ** Delooping Eilenberg-Mac Lane mapping types *) + +(** The [n.+2]-nd homotopy group of an [n.+1]-truncated type vanishes. *) +Definition contr_pi_succ_istrunc `{Univalence} (n : nat) (X : pType) + `{IsTrunc n.+1 X} + : Contr (Pi n.+2 X). +Proof. + pose proof (c := equiv_istrunc_contr_iterated_loops n.+2 X _ (point _)). + apply (Build_Contr _ (tr (center _))). + srapply Trunc_ind; intro a. + exact (ap tr (contr a)). +Defined. + +Section Deloop. + Context `{Univalence} (B A : AbGroup@{u}). + + (** By Freudenthal, the loop-suspension unit of [K(B,2)] is 2-connected, + so [Pi 3] of the unit is surjective; since [Pi 3 K(B,2)] is trivial, + [psusp K(B,2)] has trivial [Pi 4]. *) + Local Instance contr_pi4_psusp_em : Contr (Pi 4 (psusp K(B, 2))). + Proof. + nrefine (contr_equiv' (Pi 3 (loops (psusp K(B, 2)))) _). + 1: exact (grp_iso_inverse (groupiso_pi_loops 2 (psusp K(B, 2)))). + pose proof (C := @conn_map_loop_susp_unit _ 0 K(B, 2) + (isconnected_em 1) + : IsConnMap 2 (loop_susp_unit K(B, 2))). + pose proof (contr_pi_succ_istrunc 1 K(B, 2)). + pose proof (S := issurj_pi_connmap 2 (loop_susp_unit K(B, 2))). + pose (fu := fmap (pPi 3) (loop_susp_unit K(B, 2)) + : Pi 3 K(B, 2) -> Pi 3 (loops (psusp K(B, 2)))). + apply (Build_Contr _ (fu (center _))). + intro y. + pose proof (m := @center _ (S y)). + strip_truncations. + destruct m as [x p]. + refine (_ @ p). + exact (ap _ (path_contr _ x)). + Defined. + + (** Hence the 4-truncation of [psusp K(B,2)] is already 3-truncated. *) + Local Instance istrunc_ptr4_psusp_em + : IsTrunc 3 (pTr 4 (psusp K(B, 2))). + Proof. + apply (equiv_istrunc_contr_iterated_loops 4 _)^-1. + pose proof (@isconnected_susp 1 K(B, 2) (isconnected_em 1)). + pose proof (is0connected_isconnected 0 (psusp K(B, 2))). + pose proof (isconnected_trunc 0 4 (X := psusp K(B, 2))). + snapply (conn_point_elim (-1)). + 1,2: exact _. + nrefine (contr_equiv' (Pi 4 (pTr 4 (psusp K(B, 2)))) _). + 1: exact (equiv_tr 0 _)^-1%equiv. + nrefine (contr_equiv' (Pi 4 (psusp K(B, 2))) _). + 1: exact (grp_iso_pi_Tr 3 (psusp K(B, 2))). + exact _. + Defined. + + (** [K(B,3)] sits inside the 3-truncation of [pTr 4 (psusp K(B,2))] + via [fmap (pTr 3) ptr]; this is an equivalence since the source is + already 3-truncated. *) + Local Definition pequiv_ptr3_ptr4_psusp_em + : K(B, 3) <~>* pTr 3 (pTr 4 (psusp K(B, 2))). + Proof. + snapply Build_pEquiv. + 1: exact (fmap (pTr 3) ptr). + napply O_inverts_conn_map. + exact (isconnmap_pred' 4 _). + Defined. + + (** The canonical equivalence between the 4- and 3-truncations. *) + Local Definition pequiv_ptr4_ptr3_psusp_em + : pTr 4 (psusp K(B, 2)) <~>* K(B, 3) + := pequiv_ptr3_ptr4_psusp_em^-1* o*E pequiv_ptr (n:=3). + + (** The comparison map collapses the two truncation units of + [psusp K(B,2)], by naturality of [ptr]. *) + Local Definition tau_ptr4_ptr3_psusp_em + : pequiv_ptr4_ptr3_psusp_em o* ptr ==* ptr. + Proof. + refine (pmap_prewhisker ptr (compose_cate_fun (A:=pType) _ _) @* _). + refine (pmap_compose_assoc _ _ _ @* _). + refine (pmap_postwhisker _ (ptr_natural 3 ptr)^* @* _). + refine ((pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_prewhisker ptr (peissect pequiv_ptr3_ptr4_psusp_em) @* _). + apply pmap_postcompose_idmap. + Defined. + + (** Pointed maps [K(B,3) ->* K(A,4)] are equivalent to pointed maps + [K(B,2) ->* K(A,3)], by looping. *) + Definition equiv_deloop_em_pmap + : (K(B, 3) ->* K(A, 4)) <~> (K(B, 2) ->* K(A, 3)) + := pequiv_pequiv_postcompose (pequiv_loops_em_em A 3)^-1* + oE loop_susp_adjoint K(B, 2) K(A, 4) + oE pequiv_ptr_rec + oE pequiv_pequiv_precompose pequiv_ptr4_ptr3_psusp_em. + + (** The delooping equivalence, unfolded: postcompose by the inverse loop + identification, loop the map, precompose by the loop identification. *) + Definition equiv_deloop_em_pmap_unfold (psi : K(B, 3) ->* K(A, 4)) + : equiv_deloop_em_pmap psi + ==* (pequiv_loops_em_em A 3)^-1* + o* (fmap loops psi o* pequiv_loops_em_em B 2). + Proof. + transitivity ((pequiv_loops_em_em A 3)^-1* + o* (fmap loops (psi o* pequiv_ptr4_ptr3_psusp_em o* ptr) + o* loop_susp_unit K(B, 2))). + 1: reflexivity. + symmetry. + napply pmap_postwhisker. + refine (pmap_postwhisker _ (loops_em_em_ptr_unit B 1) @* _). + refine ((pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_prewhisker _ (fmap_comp loops _ _)^* @* _). + napply pmap_prewhisker. + tapply (fmap2 loops). + exact (pmap_compose_assoc psi _ ptr + @* pmap_postwhisker psi tau_ptr4_ptr3_psusp_em)^*. + Defined. + +End Deloop. + +(** Pointed maps from an Eilenberg-Mac Lane space to a connected truncated + type of the same level which agree on homotopy groups are equal. *) +Definition path_em_pmap_pi_connected `{Univalence} {G : AbGroup@{u}} + (n : nat) {Y : pType} `{IsConnected n.+1 Y} `{IsTrunc n.+2 Y} + (phi psi : K(G, n.+2) ->* Y) + (h : fmap (Pi n.+2) phi == fmap (Pi n.+2) psi) + : phi = psi. +Proof. + apply (equiv_inj (pequiv_pequiv_postcompose + (pequiv_em_connected_truncated Y n.+1)^-1*)). + napply (path_em_pmap_pi (G' := Build_AbGroup (Pi n.+2 Y) _)). + intro x. + refine (fmap_comp (Pi n.+2) phi + ((pequiv_em_connected_truncated Y n.+1)^-1* : _ ->* _) x @ _). + refine (ap _ (h x) @ _). + exact (fmap_comp (Pi n.+2) psi + ((pequiv_em_connected_truncated Y n.+1)^-1* : _ ->* _) x)^%path. + Unshelve. + all: exact _. +Defined. diff --git a/theories/Homotopy/ExactSequence.v b/theories/Homotopy/ExactSequence.v index 4cdfb4c6329..a67ec31fc22 100644 --- a/theories/Homotopy/ExactSequence.v +++ b/theories/Homotopy/ExactSequence.v @@ -492,6 +492,170 @@ Proof. - reflexivity. Defined. +(** ** Naturality and rotation of the connecting map *) + +(** The fiber functor of the tautological [cxfib] square is the + identity. *) +Definition pequiv_pfiber_cxfib_taut {X Y : pType} (f : X ->* Y) + : pequiv_pfiber pequiv_cxfib pequiv_pmap_idmap + (square_pfib_pequiv_cxfib (pfib f) f) + ==* pmap_idmap. +Proof. + pointed_reduce_pmap f. + snapply Build_pHomotopy. + - intros [[x w] v]. + snapply path_sigma'. + + reflexivity. + + cbn. + exact (concat_p1 _ @ (concat_1p _ @ ap_idmap v)). + - reflexivity. +Defined. + +(** The connecting map of the tautological fiber sequence is natural in + arbitrary squares of pointed maps. *) +Definition connecting_map_natural_functor {X Y X' Y' : pType} + {f : X ->* Y} {f' : X' ->* Y'} {h : X' ->* X} {k : Y' ->* Y} + (q : k o* f' ==* f o* h) + : functor_pfiber q o* connecting_map (pfib f') f' + ==* connecting_map (pfib f) f o* fmap loops k. +Proof. + (* The inverse-free square between the double-fiber identifications. *) + assert (S : ((pfiber2_loops f) + o*E (pequiv_pfiber _ _ (square_pfib_pequiv_cxfib (pfib f) f)) + : _ ->* _) + o* functor_pfiber (square_functor_pfiber q) + ==* fmap loops k + o* ((pfiber2_loops f') + o*E (pequiv_pfiber _ _ + (square_pfib_pequiv_cxfib (pfib f') f')) + : _ ->* _)). + { refine (pmap_prewhisker _ (compose_cate_fun (A:=pType) _ _) @* _ + @* pmap_postwhisker _ (compose_cate_fun (A:=pType) _ _)^*). + refine (pmap_prewhisker _ + (pmap_postwhisker _ (pequiv_pfiber_cxfib_taut f) + @* pmap_precompose_idmap _) @* _ + @* pmap_postwhisker _ + (pmap_postwhisker _ (pequiv_pfiber_cxfib_taut f') + @* pmap_precompose_idmap _)^*). + exact (pfiber2_loops_natural_functor q). } + refine ((pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_prewhisker _ + (square_functor_pfiber (square_functor_pfiber q)) @* _). + refine (pmap_compose_assoc _ _ _ @* _). + refine (_ @* (pmap_compose_assoc _ _ _)^*). + napply pmap_postwhisker. + napply moveL_pequiv_Vf. + refine ((pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_prewhisker _ S @* _). + refine (pmap_compose_assoc _ _ _ @* _). + refine (pmap_postwhisker _ (peisretr _) @* _). + apply pmap_precompose_idmap. +Defined. + +(** The same for an equivalence square. *) +Definition connecting_map_natural {X Y X' Y' : pType} + {f : X ->* Y} {f' : X' ->* Y'} (h : X' <~>* X) (k : Y' <~>* Y) + (q : k o* f' ==* f o* h) + : pequiv_pfiber h k q o* connecting_map (pfib f') f' + ==* connecting_map (pfib f) f o* fmap loops k + := connecting_map_natural_functor q. + +(** Through [cxfib], the connecting map of an exact sequence agrees with + the connecting map of the tautological fiber sequence. *) +Definition connecting_map_cxfib {F X Y : pType} + (i : F ->* X) (f : X ->* Y) `{IsExact purely F X Y i f} + : pequiv_cxfib o* connecting_map i f ==* connecting_map (pfib f) f. +Proof. + assert (WQV : ((pfiber2_loops f) + o*E (pequiv_pfiber _ _ + (square_pfib_pequiv_cxfib (pfib f) f)) + : _ ->* _) + o* pequiv_pfiber _ _ (square_pfib_pequiv_cxfib i f) + ==* ((pfiber2_loops f) + o*E (pequiv_pfiber _ _ (square_pfib_pequiv_cxfib i f)) + : _ ->* _)). + { refine (pmap_prewhisker _ (compose_cate_fun (A:=pType) _ _) @* _ + @* (compose_cate_fun (A:=pType) _ _)^*). + refine (pmap_compose_assoc _ _ _ @* _). + napply pmap_postwhisker. + refine (pmap_prewhisker _ (pequiv_pfiber_cxfib_taut f) @* _). + apply pmap_postcompose_idmap. } + refine ((pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_prewhisker _ + (square_pequiv_pfiber _ _ (square_pfib_pequiv_cxfib i f)) @* _). + refine (pmap_compose_assoc _ _ _ @* _). + napply pmap_postwhisker. + refine (_ @* pmap_precompose_idmap _). + napply moveL_pequiv_Vf. + refine ((pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_prewhisker _ WQV @* _). + exact (peisretr _). +Defined. + +(** Through [pfiber2_loops], the connecting map of the doubly-iterated + tautological fiber sequence is loop inversion followed by [loops] of + the map. *) +Definition connecting_map_pfib2 {F X : pType} (i : F ->* X) + : pfiber2_loops i o* connecting_map (pfib (pfib i)) (pfib i) + ==* fmap loops i o* loops_inv F. +Proof. + assert (S : pfiber2_loops i o* pfib (pfib (pfib i)) + ==* (fmap loops i o* loops_inv F) + o* ((pfiber2_loops (pfib i)) + o*E (pequiv_pfiber _ _ + (square_pfib_pequiv_cxfib + (pfib (pfib i)) (pfib i))) + : _ ->* _)). + { refine (pfiber2_fmap_loops i @* _). + refine ((pmap_compose_assoc _ _ _)^* @* _). + napply pmap_postwhisker. + refine (_ @* (compose_cate_fun (A:=pType) _ _)^*). + refine (_ @* (pmap_postwhisker _ (pequiv_pfiber_cxfib_taut (pfib i)) + @* pmap_precompose_idmap _)^*). + reflexivity. } + refine ((pmap_compose_assoc _ _ _)^* @* _). + refine (pmap_prewhisker _ S @* _). + refine (pmap_compose_assoc _ _ _ @* _). + refine (pmap_postwhisker _ (peisretr _) @* _). + apply pmap_precompose_idmap. +Defined. + +(** Through [pfiber2_loops], the double fiber projection of an exact + sequence is loop inversion followed by [loops] of the projection. *) +Definition pfiber2_loops_pfib2 {F X Y : pType} + (i : F ->* X) (f : X ->* Y) `{IsExact purely F X Y i f} + : ((pfiber2_loops f) + o*E (pequiv_pfiber _ _ (square_pfib_pequiv_cxfib i f)) : _ ->* _) + o* pfib (pfib i) + ==* fmap loops f o* (loops_inv X o* pfiber2_loops i). +Proof. + destruct H as [cx conn]; revert conn. + destruct cx as [cxpw cxcell]; intro conn. + pointed_reduce. + snapply Build_pHomotopy. + - intros [[u w] v]. + cbn in v. + revert w; revert v; revert u. + refine (paths_ind_r _ _ _). + intro w. + refine (pfiber2_loops_beta f 1 (i point1) (cxpw point1) _ @ _). + refine (whiskerL _ (whiskerL _ cxcell) @ _). + exact (ap (concat 1) + (whiskerR + (inverse2 (ap (ap f) (concat_p1 _ @ (concat_1p _ @ ap_idmap w))) + @ (ap_V f w)^) _)). + - cbn; cbv beta iota delta + [point_htpy square_pfib_pequiv_cxfib phomotopy_transitive + phomotopy_symmetric pmap_postcompose_idmap pfib_cxfib pequiv_cxfib + cxfib HFiber.functor_hfiber2 ispointed_fiber functor_sigma + functor_pfiber pmap_compose pointed_htpy point_eq]; + cbn. + generalize dependent (cxpw point1). + refine (paths_ind_r _ _ _). + cbn. + reflexivity. +Defined. + (** ** Long exact sequences *) Record LongExactSequence (k : Modality) (N : SuccStr) : Type := diff --git a/theories/Pointed/pFiber.v b/theories/Pointed/pFiber.v index c503e10cace..13ae1659811 100644 --- a/theories/Pointed/pFiber.v +++ b/theories/Pointed/pFiber.v @@ -92,7 +92,10 @@ Proof. srapply Build_pHomotopy. - intros x; reflexivity. - apply moveL_pV. cbn; unfold functor_sigma; cbn. - abstract (rewrite ap_pr1_path_sigma, concat_p1; reflexivity). + refine (ap (concat 1) (concat_p1 _ @ _)). + exact (ap_pr1_path_sigma + (u := functor_hfiber2 p (point_eq k) (ispointed_fiber f)) + (v := ispointed_fiber g) (point_eq h) _). Defined. Definition square_pequiv_pfiber {A B C D} @@ -122,3 +125,66 @@ Proof. apply concat_p1. - reflexivity. Qed. + +(** The value of [pfiber2_loops] on a general element of the double + fiber. *) +Definition pfiber2_loops_beta {C D : Type} {c0 : C} {d0 : D} + (g : C -> D) (de : g c0 = d0) (c : C) (w : g c = d0) (v : c = c0) + : pfiber2_loops (Build_pMap (A:=[C, c0]) (B:=[D, d0]) g de) + (((c; w); v)) + = de^ @ ((ap g v)^ @ w). +Proof. + destruct v; destruct de. + exact ((concat_1p w)^ @ ap (concat 1) (concat_1p w)^). +Defined. + +(** The path algebra underlying the pointwise part of + [pfiber2_loops_natural], with all endpoints free. *) +Local Definition pfiber2_loops_natural_core {D : Type} {y x : D} + (X : y = x) (l : x = x) + : X^ @ (1 @ (((1 @ (1 @ X)^)^ @ l) @ 1)) = 1 @ (l @ 1). +Proof. + destruct X. + exact (ap (concat 1) (concat_1p _ @ whiskerR (concat_1p l) 1)). +Defined. + +(** [pfiber2_loops] commutes with the fiber functor of a square, for an + arbitrary square of pointed maps. *) +Definition pfiber2_loops_natural_functor {A B C D : pType} + {f : A ->* B} {g : C ->* D} {h : A ->* C} {k : B ->* D} + (p : k o* f ==* g o* h) + : pfiber2_loops g o* functor_pfiber (square_functor_pfiber p) + ==* fmap loops k o* pfiber2_loops f. +Proof. + pointed_reduce. + snapply Build_pHomotopy. + - intros [[c w] v]. + cbn in v. + revert w; revert v; revert c. + napply paths_ind_r. + intro w. + refine (pfiber2_loops_beta _ _ _ _ _ @ _). + refine (ap (fun q => dpoint_eq1^ @ (1 @ ((q^ @ ap k w) @ 1))) H @ _). + exact (pfiber2_loops_natural_core dpoint_eq1 (ap k w)). + - cbn; cbv beta iota delta + [point_htpy square_functor_pfiber + HFiber.functor_hfiber2 ispointed_fiber functor_sigma + functor_pfiber pmap_compose pointed_htpy point_eq]; + cbn. + generalize dependent (p point2). + napply paths_ind_r. + cbn. + generalize dependent (k (f point2)). + intros x dpe; destruct dpe. + reflexivity. +Defined. + +(** The same for an equivalence square; the underlying double-fiber map is + [functor_pfiber] of the same square. *) +Definition pfiber2_loops_natural {A B C D : pType} + {f : A ->* B} {g : C ->* D} (h : A <~>* C) (k : B <~>* D) + (p : k o* f ==* g o* h) + : pfiber2_loops g + o* pequiv_pfiber (pequiv_pfiber h k p) h (square_pequiv_pfiber h k p) + ==* fmap loops k o* pfiber2_loops f + := pfiber2_loops_natural_functor p. diff --git a/theories/Truncations/Connectedness.v b/theories/Truncations/Connectedness.v index c372dfa6d01..fad4d240291 100644 --- a/theories/Truncations/Connectedness.v +++ b/theories/Truncations/Connectedness.v @@ -244,6 +244,20 @@ Proof. exact (contr_inhabited_hprop _ (p x y)). Defined. +(** Any map from a merely inhabited type to a 0-connected type is + surjective. *) +Definition issurjection_is0connected `{Univalence} + (X Y : Type) (mX : merely X) `{IsConnected 0 Y} (f : X -> Y) + : IsSurjection f. +Proof. + intro y. + rapply contr_inhabited_hprop. + strip_truncations. + pose proof (p := merely_path_is0connected Y (f mX) y). + strip_truncations. + exact (tr (mX; p)). +Defined. + (** The path component of a point [x : X] is connected. *) Instance is0connected_component {X : Type} (x : X) : IsConnected 0 { z : X & merely (z = x) }. From 478887347da6448bd7cc6151daa5bb35b6e82eff Mon Sep 17 00:00:00 2001 From: CharlesCNorton Date: Mon, 15 Jun 2026 12:03:04 -0400 Subject: [PATCH 02/12] =?UTF-8?q?Prove=20the=20integers=20form=20a=20B?= =?UTF-8?q?=C3=A9zout=20domain?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add theories/Algebra/Rings/ZBezout.v: integer absolute value and its multiplicativity, the integral-domain instance for cring_Z, the lift of NatBezout to an integer Bézout combination, and the IsBezoutDomain instance. Move rng_divides_plus from FreeModule.v to Bezout.v. --- theories/Algebra/Rings/Bezout.v | 8 ++ theories/Algebra/Rings/FreeModule.v | 9 -- theories/Algebra/Rings/ZBezout.v | 126 ++++++++++++++++++++++++++++ 3 files changed, 134 insertions(+), 9 deletions(-) diff --git a/theories/Algebra/Rings/Bezout.v b/theories/Algebra/Rings/Bezout.v index 6b47c7c4502..f3b29368b1b 100644 --- a/theories/Algebra/Rings/Bezout.v +++ b/theories/Algebra/Rings/Bezout.v @@ -76,6 +76,14 @@ Proof. exact (ap (fun w => r * w) pu @ rng_mult_assoc r u a). Defined. +Definition rng_divides_plus {R : CRing} {d a b : R} + (pa : rng_divides d a) (pb : rng_divides d b) : rng_divides d (a + b). +Proof. + strip_truncations; destruct pa as [c1 p1], pb as [c2 p2]. + apply tr; exists (c1 + c2). + exact (ap011 (+) p1 p2 @ (rng_dist_r c1 c2 d)^). +Defined. + (** ** A finitely generated ideal of a Bézout ring is principal *) (** A gcd of the [X i] lying in the ideal they generate and dividing each. *) diff --git a/theories/Algebra/Rings/FreeModule.v b/theories/Algebra/Rings/FreeModule.v index ab661c8d205..e8dfa275e2a 100644 --- a/theories/Algebra/Rings/FreeModule.v +++ b/theories/Algebra/Rings/FreeModule.v @@ -315,15 +315,6 @@ Proof. napply lm_homo_lact. Defined. -(** Divisibility is preserved by sums. *) -Definition rng_divides_plus {R : CRing} {d a b : R} - (pa : rng_divides d a) (pb : rng_divides d b) : rng_divides d (a + b). -Proof. - strip_truncations; destruct pa as [c1 p1], pb as [c2 p2]. - apply tr; exists (c1 + c2). - exact (ap011 (+) p1 p2 @ (rng_dist_r c1 c2 d)^). -Defined. - (** Right multiplication by a ring element. *) Definition lm_right_mult {R : Ring} (d : R) : lm_regular R $-> lm_regular R. Proof. diff --git a/theories/Algebra/Rings/ZBezout.v b/theories/Algebra/Rings/ZBezout.v index abdc705a7fb..b84f9caec61 100644 --- a/theories/Algebra/Rings/ZBezout.v +++ b/theories/Algebra/Rings/ZBezout.v @@ -108,3 +108,129 @@ Proof. + exact (Empty_rec (np h0)). + napply grp_moveL_1M; exact hyz. Defined. + +(** A divisibility of naturals lifts to the integers. *) +Definition rng_divides_int_nat {d n : nat} (h : (d | n)%nat) + : rng_divides (R:=cring_Z) (int_of_nat d) (int_of_nat n). +Proof. + destruct h as [k p]. + apply tr; exists (int_of_nat k). + exact ((ap int_of_nat p)^ @ (int_nat_mul k d)^). +Defined. + +(** Divisibility is preserved under negating the dividend. *) +Definition rng_divides_neg_r {g x : cring_Z} (h : rng_divides g x) + : rng_divides g (- x). +Proof. + strip_truncations; destruct h as [c p]. + apply tr; exists (- c). + exact (ap (fun w => - w) p @ (rng_mult_negate_l c g)^). +Defined. + +(** Divisibility is preserved under negating the divisor. *) +Definition rng_divides_neg_l {g x : cring_Z} (h : rng_divides g x) + : rng_divides (- g) x. +Proof. + strip_truncations; destruct h as [c p]. + apply tr; exists (- c). + exact (p @ (rng_mult_negate_r (- c) g + @ ap (fun w => - w) (rng_mult_negate_l c g) + @ negate_involutive (c * g))^). +Defined. + +(** Divisibility by [g] only depends on the dividend up to sign. *) +Definition rng_divides_int_abs_r {g x : cring_Z} + (h : rng_divides g (int_of_nat (int_abs x))) : rng_divides g x. +Proof. + destruct (int_abs_decomp x) as [px | px]. + - exact (transport (rng_divides g) px^ h). + - exact (transport (rng_divides g) px^ (rng_divides_neg_r h)). +Defined. + +(** Divisibility only depends on the divisor up to sign. *) +Definition rng_divides_int_abs_l {g x : cring_Z} + (h : rng_divides (int_of_nat (int_abs g) : cring_Z) x) : rng_divides g x. +Proof. + destruct (int_abs_decomp g) as [pg | pg]. + - exact (transport (fun w => rng_divides w x) pg^ h). + - exact (transport (fun w => rng_divides w x) pg^ (rng_divides_neg_l h)). +Defined. + +(** An integer divisibility restricts to a divisibility of absolute values. *) +Definition nat_divides_of_rng_divides {z w c : cring_Z} (p : w = c * z) + : (int_abs z | int_abs w)%nat. +Proof. + exists (int_abs c). + exact ((int_abs_mul c z)^ @ (ap int_abs p)^). +Defined. + +(** A natural number as an element of the ring [cring_Z], pinning the typing so + that ring operations resolve without flipping back to [Int]. *) +Definition znat (n : nat) : cring_Z := int_of_nat n. + +Definition znat_mul (a b : nat) : znat (a * b) = znat a * znat b + := (int_nat_mul a b)^. + +Definition znat_add (a b : nat) : znat (a + b) = znat a + znat b + := (int_nat_add a b)^. + +(** Bézout's identity for the integers, on nonnegative representatives. *) +Definition int_bezout_nat (a b : nat) + : merely { u : cring_Z & { v : cring_Z + & u * znat a + v * znat b = znat (nat_gcd a b) } }. +Proof. + destruct a as [|a]. + - apply tr; exists 0, 1. + exact (ap011 (+) (rng_mult_zero_l (znat 0)) (rng_mult_one_l (znat b)) + @ left_identity (znat b)). + - pose proof (nat_bezout_pos_l a.+1 b _) as hbz. + destruct hbz as [c [e r]]. + apply tr; exists (znat c), (- znat e). + pose (Rint := (znat_mul c a.+1)^ @ ap znat r @ znat_add _ _ + @ ap (fun w => znat (nat_gcd a.+1 b) + w) (znat_mul e b)). + lhs napply (ap (fun w => w + (- znat e) * znat b) Rint). + lhs_V napply grp_assoc. + exact (ap (fun w => znat (nat_gcd a.+1 b) + w) + ((rng_dist_r (znat e) (- znat e) (znat b))^ + @ ap (fun s => s * znat b) (right_inverse (znat e)) + @ rng_mult_zero_l (znat b)) + @ right_identity (znat (nat_gcd a.+1 b))). +Defined. + +(** Rewriting a multiple of [|x|] as a multiple of [x], absorbing the sign. *) +Definition znat_abs_to_var (u x : cring_Z) + : { U : cring_Z & u * znat (int_abs x) = U * x }. +Proof. + destruct (int_abs_decomp x) as [px | px]. + - exists u; exact (ap (fun w => u * w) px^). + - exists (- u). + exact ((rng_mult_negate_l u (- znat (int_abs x)) + @ ap (fun w => - w) (rng_mult_negate_r u (znat (int_abs x))) + @ negate_involutive (u * znat (int_abs x)))^ + @ ap (fun w => (- u) * w) px^). +Defined. + +(** The integers form a Bézout ring: any two have a gcd that is a Bézout + combination of them. *) +Instance isbezoutring_cring_Z : IsBezoutRing cring_Z. +Proof. + intros x y. + pose proof (int_bezout_nat (int_abs x) (int_abs y)) as hbz. + strip_truncations; destruct hbz as [u0 [v0 hcombo]]. + destruct (znat_abs_to_var u0 x) as [U pU]. + destruct (znat_abs_to_var v0 y) as [V pV]. + pose (combo := (ap011 (+) pU pV)^ @ hcombo). + apply tr; exists U, V. + refine (_, _, _). + - exact (transport (fun w => rng_divides w x) combo^ + (rng_divides_int_abs_r + (rng_divides_int_nat (nat_divides_l_gcd_l (int_abs x) (int_abs y))))). + - exact (transport (fun w => rng_divides w y) combo^ + (rng_divides_int_abs_r + (rng_divides_int_nat (divides_l_nat_gcd_r (int_abs x) (int_abs y))))). + - intros z hzx hzy. + exact (rng_divides_plus (rng_divides_mul_l U hzx) (rng_divides_mul_l V hzy)). +Defined. + +(** Hence the integers form a Bézout domain. *) +Instance isbezoutdomain_cring_Z : IsBezoutDomain cring_Z := {}. From 02fed61915d19d09d990bdd745dc783583b24152 Mon Sep 17 00:00:00 2001 From: CharlesCNorton Date: Mon, 15 Jun 2026 19:10:17 -0400 Subject: [PATCH 03/12] Lean imports, remove dead definitions, relocate lemmas to home files A house-style cleanup over the higher-Ext and rings development. Imports trimmed to what each file uses: - AbInjective.v: drop Modalities.ReflectiveSubuniverse. - Classification.v: drop AbHom. - HigherExtMorphism.v: drop Truncations.Core and AbHom. - HigherExtResolution.v: drop WildCat.Core. - LoopGroup.v: drop AbGroups.Biproduct. - FinitelyPresented.v: drop Types, WildCat.Core, AbGroups.AbelianGroup. - ZBezout.v: drop WildCat.Core, AbGroups.AbelianGroup, AbGroups.Z. Dead definitions removed: - HigherExt.v: ab_biprod_trivial_r. - HigherExtResolution.v: abses_ext_vanish_two, subsumed by abses_ext_vanish_resolution. - FreeModule.v: the unused span layer sm_gen_type, submodule_generated, submodule_generated_in, submodule_generated_rec, and isfreemodule_image_from_contr. - ZBezout.v: rng_divides_neg_r, rng_divides_neg_l, rng_divides_int_abs_l, nat_divides_of_rng_divides. Lemmas relocated to their proper files: - int_abs and its lemmas (int_abs_of_nat, int_abs_neg, int_abs_decomp, int_abs_of_nat_mul, int_abs_mul) move from ZBezout.v to Spaces/Int.v. - nat_mul_is_zero moves from ZBezout.v to Spaces/Nat/Core.v. - rng_divides_negate_r is generalized from cring_Z to any CRing and added to Rings/Bezout.v beside rng_divides_plus; ZBezout.v uses it. Other: - Eliminate the znat synonym, together with znat_mul and znat_add; int_bezout_nat and int_abs_to_var are now stated over Int and int_of_nat directly. --- theories/Algebra/AbGroups/AbInjective.v | 2 +- theories/Algebra/AbSES/Classification.v | 2 +- theories/Algebra/AbSES/HigherExt.v | 13 -- theories/Algebra/AbSES/HigherExtMorphism.v | 3 +- theories/Algebra/AbSES/HigherExtResolution.v | 17 -- theories/Algebra/AbSES/LoopGroup.v | 2 +- theories/Algebra/Rings/Bezout.v | 8 + theories/Algebra/Rings/FinitelyPresented.v | 4 +- theories/Algebra/Rings/FreeModule.v | 51 ------ theories/Algebra/Rings/ZBezout.v | 158 +++---------------- theories/Spaces/Int.v | 55 +++++++ theories/Spaces/Nat/Core.v | 9 ++ 12 files changed, 100 insertions(+), 224 deletions(-) diff --git a/theories/Algebra/AbGroups/AbInjective.v b/theories/Algebra/AbGroups/AbInjective.v index 144f85e24b4..773b7ecbd61 100644 --- a/theories/Algebra/AbGroups/AbInjective.v +++ b/theories/Algebra/AbGroups/AbInjective.v @@ -1,5 +1,5 @@ From HoTT Require Import Basics Types AbelianGroup AbPushout - WildCat.Core Modalities.ReflectiveSubuniverse Truncations.Core. + WildCat.Core Truncations.Core. (** * Injective abelian groups *) diff --git a/theories/Algebra/AbSES/Classification.v b/theories/Algebra/AbSES/Classification.v index 20c11363842..1c3f3ed3802 100644 --- a/theories/Algebra/AbSES/Classification.v +++ b/theories/Algebra/AbSES/Classification.v @@ -2,7 +2,7 @@ From HoTT Require Import Basics Types Truncations.Core Truncations.Connectedness Truncations.SeparatedTrunc. From HoTT.WildCat Require Import Core Equiv. Require Import Pointed. -Require Import AbelianGroup AbHom. +Require Import AbelianGroup. Require Import Algebra.AbSES.Core Algebra.AbSES.Ext. Require Import Universes.Smallness. Require Import Homotopy.HomotopyGroup Homotopy.EMSpace Homotopy.ExactSequence. diff --git a/theories/Algebra/AbSES/HigherExt.v b/theories/Algebra/AbSES/HigherExt.v index 93b196039b5..59707a2c948 100644 --- a/theories/Algebra/AbSES/HigherExt.v +++ b/theories/Algebra/AbSES/HigherExt.v @@ -240,19 +240,6 @@ Section Operations. := abses_es_pullback n ab_diagonal (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F)). - (** The biproduct with the trivial group is the identity, projecting away - the trivial factor. *) - Definition ab_biprod_trivial_r (A : AbGroup@{u}) - : GroupIsomorphism (ab_biprod A abgroup_trivial) A. - Proof. - snapply Build_GroupIsomorphism. - - exact ab_biprod_pr1. - - snapply isequiv_adjointify. - + exact (fun a => (a, mon_unit)). - + reflexivity. - + intro x; srapply path_prod; [ reflexivity | apply path_contr ]. - Defined. - (** Adding the split trivial summand on the deep end and projecting away the trivial factor leaves a short exact sequence unchanged, up to reindexing the base along the projection. *) diff --git a/theories/Algebra/AbSES/HigherExtMorphism.v b/theories/Algebra/AbSES/HigherExtMorphism.v index 6e061ee00c6..a298055f9eb 100644 --- a/theories/Algebra/AbSES/HigherExtMorphism.v +++ b/theories/Algebra/AbSES/HigherExtMorphism.v @@ -1,8 +1,7 @@ From HoTT Require Import Basics Types. From HoTT.WildCat Require Import Core. -Require Import Truncations.Core. Require Import Colimits.Quotient. -Require Import AbGroups.AbelianGroup AbGroups.AbHom. +Require Import AbGroups.AbelianGroup. Require Import Algebra.AbSES.Core Algebra.AbSES.Pushout Algebra.AbSES.Pullback Algebra.AbSES.BaerSum Algebra.AbSES.HigherExt. Require Import Groups.Group. diff --git a/theories/Algebra/AbSES/HigherExtResolution.v b/theories/Algebra/AbSES/HigherExtResolution.v index 31e5bf18024..33a9c5648c2 100644 --- a/theories/Algebra/AbSES/HigherExtResolution.v +++ b/theories/Algebra/AbSES/HigherExtResolution.v @@ -1,5 +1,4 @@ From HoTT Require Import Basics Types Truncations.Core. -From HoTT.WildCat Require Import Core. Require Import Spaces.Nat.Core. Require Import AbGroups.AbelianGroup AbGroups.AbProjective. Require Import Algebra.AbSES.Core Algebra.AbSES.HigherExt. @@ -28,22 +27,6 @@ Proof. exact (grp_homo_unit (grp_homo_abses_ext_splice m.+1 zeta)). Defined. -(** Iterating once: a length-two projective resolution - [L -> P1 -> K] and [K -> P0 -> B] forces [Ext^{n+3}(B,-)] to vanish when - [L] is projective. *) -Definition abses_ext_vanish_two `{Univalence} {L K B : AbGroup} - (eta : AbSES K L) (zeta : AbSES B K) - `{IsAbProjective (middle eta)} `{IsAbProjective (middle zeta)} - `{IsAbProjective L} {A : AbGroup} (n : nat) - (x : abses_ext n.+3 B A) - : x = abses_ext_zero n.+3 B A. -Proof. - refine (abses_ext_vanish_step zeta n.+1 _ x). - intro y. - exact (abses_ext_vanish_step eta n - (fun z => abses_ext_projective_vanish n z) y). -Defined. - (** A projective resolution of length [k]: a tower of short exact sequences with projective middles ending in a projective module. *) Fixpoint proj_resolution `{Univalence} (k : nat) (B : AbGroup@{u}) : Type := diff --git a/theories/Algebra/AbSES/LoopGroup.v b/theories/Algebra/AbSES/LoopGroup.v index 1e82be4e473..749674d2650 100644 --- a/theories/Algebra/AbSES/LoopGroup.v +++ b/theories/Algebra/AbSES/LoopGroup.v @@ -1,7 +1,7 @@ From HoTT Require Import Basics Types Truncations.Core HFiber. From HoTT.WildCat Require Import Core Equiv. Require Import Pointed. -Require Import AbelianGroup AbGroups.Biproduct AbHom. +Require Import AbelianGroup AbHom. Require Import Algebra.AbSES.Core Algebra.AbSES.Pullback Algebra.AbSES.BaerSum. Require Import Homotopy.HomotopyGroup Homotopy.ClassifyingSpace Homotopy.EMSpace Homotopy.Cover. diff --git a/theories/Algebra/Rings/Bezout.v b/theories/Algebra/Rings/Bezout.v index f3b29368b1b..faaf7406d4d 100644 --- a/theories/Algebra/Rings/Bezout.v +++ b/theories/Algebra/Rings/Bezout.v @@ -84,6 +84,14 @@ Proof. exact (ap011 (+) p1 p2 @ (rng_dist_r c1 c2 d)^). Defined. +Definition rng_divides_negate_r {R : CRing} {a b : R} + (p : rng_divides a b) : rng_divides a (- b). +Proof. + strip_truncations; destruct p as [c pc]. + apply tr; exists (- c). + exact (ap (fun w => - w) pc @ (rng_mult_negate_l c a)^). +Defined. + (** ** A finitely generated ideal of a Bézout ring is principal *) (** A gcd of the [X i] lying in the ideal they generate and dividing each. *) diff --git a/theories/Algebra/Rings/FinitelyPresented.v b/theories/Algebra/Rings/FinitelyPresented.v index afcac0c02ef..6e4e5c35a8c 100644 --- a/theories/Algebra/Rings/FinitelyPresented.v +++ b/theories/Algebra/Rings/FinitelyPresented.v @@ -1,6 +1,4 @@ -From HoTT Require Import Basics Types Truncations.Core. -From HoTT.WildCat Require Import Core. -Require Import Algebra.AbGroups.AbelianGroup. +From HoTT Require Import Basics Truncations.Core. Require Import Algebra.Rings.Ring Algebra.Rings.Module Algebra.Rings.Vector. Local Open Scope mc_add_scope. diff --git a/theories/Algebra/Rings/FreeModule.v b/theories/Algebra/Rings/FreeModule.v index e8dfa275e2a..e540a5d45ac 100644 --- a/theories/Algebra/Rings/FreeModule.v +++ b/theories/Algebra/Rings/FreeModule.v @@ -509,45 +509,6 @@ Proof. exact (path_prod' (hfst l)^ (ap snd q)^ @ q). Defined. -(** * Submodules generated by a family *) - -(** The closure of [X] under zero and [n + r *L m]. *) -Inductive sm_gen_type {R : Ring} {M : LeftModule R} (X : M -> Type) : M -> Type := -| smgt_in (x : M) : X x -> sm_gen_type X x -| smgt_zero : sm_gen_type X 0 -| smgt_comb (r : R) (n m : M) - : sm_gen_type X n -> sm_gen_type X m -> sm_gen_type X (n + r *L m). - -(** The submodule generated by a predicate. *) -Definition submodule_generated {R : Ring} {M : LeftModule R} (X : M -> Type) - : LeftSubmodule M. -Proof. - snapply (Build_LeftSubmodule' (fun m => merely (sm_gen_type X m))). - - exact _. - - exact (tr (smgt_zero X)). - - intros r n m hn hm; strip_truncations. - exact (tr (smgt_comb X r n m hn hm)). -Defined. - -(** The generators lie in the generated submodule. *) -Definition submodule_generated_in {R : Ring} {M : LeftModule R} (X : M -> Type) - (x : M) (hx : X x) : submodule_generated X x - := tr (smgt_in X x hx). - -(** The generated submodule is the smallest one containing the generators. *) -Definition submodule_generated_rec {R : Ring} {M : LeftModule R} (X : M -> Type) - (N : LeftSubmodule M) (HX : forall x, X x -> N x) - : forall m, submodule_generated X m -> N m. -Proof. - intros m; rapply Trunc_rec; intro hm. - induction hm as [x hx | | r n m' hn IHn hm' IHm]. - - exact (HX x hx). - - exact issubgroup_in_unit. - - rapply issubgroup_in_op. - + exact IHn. - + rapply is_left_submodule; exact IHm. -Defined. - (** The image of a homomorphism into a contractible module is free. *) Definition isfreemodule_image_into_contr {R : Ring} {M N : LeftModule R} `{Contr N} (f : M $-> N) : IsFreeModule (lm_image f). @@ -558,18 +519,6 @@ Proof. - intros [y hy]; apply path_sigma_hprop; apply path_contr. Defined. -(** The image of a homomorphism from a contractible module is free. *) -Definition isfreemodule_image_from_contr {R : Ring} {M N : LeftModule R} - `{Contr M} (f : M $-> N) : IsFreeModule (lm_image f). -Proof. - napply isfreemodule_contr. - snapply Build_Contr. - - exact (f (center M); tr (center M; idpath)). - - intros [y hy]; apply path_sigma_hprop; cbn. - strip_truncations; destruct hy as [x p]. - exact (ap f (path_contr (center M) x) @ p). -Defined. - (** * Finitely generated submodules of [R^n] are free *) (** A finitely generated submodule of [R^n] over a Bézout domain is free; the diff --git a/theories/Algebra/Rings/ZBezout.v b/theories/Algebra/Rings/ZBezout.v index b84f9caec61..f7769037113 100644 --- a/theories/Algebra/Rings/ZBezout.v +++ b/theories/Algebra/Rings/ZBezout.v @@ -1,7 +1,5 @@ From HoTT Require Import Basics Types Truncations.Core. -From HoTT.WildCat Require Import Core. Require Import Spaces.Int Spaces.Nat.Core Spaces.Nat.Division. -Require Import Algebra.AbGroups.AbelianGroup Algebra.AbGroups.Z. Require Import Algebra.Rings.Ring Algebra.Rings.CRing Algebra.Rings.Z Algebra.Rings.Bezout. @@ -9,59 +7,6 @@ Local Open Scope mc_scope. (** * The integers form a Bézout domain *) -(** The absolute value of an integer, as a natural number. *) -Definition int_abs (x : Int) : nat := - match x with - | negS n => n.+1 - | posS n => n.+1 - | _ => 0%nat - end. - -Definition int_abs_of_nat (n : nat) : int_abs (int_of_nat n) = n. -Proof. - by destruct n. -Defined. - -Definition int_abs_neg (x : Int) : int_abs (int_neg x) = int_abs x. -Proof. - by destruct x. -Defined. - -(** Every integer is its absolute value up to sign. *) -Definition int_abs_decomp (x : Int) - : (x = int_of_nat (int_abs x)) + (x = int_neg (int_of_nat (int_abs x))). -Proof. - destruct x. - - exact (inr idpath). - - exact (inl idpath). - - exact (inl idpath). -Defined. - -(** Absolute value of a product of two naturals coerced into [Int]. *) -Definition int_abs_of_nat_mul (a b : nat) - : int_abs (int_mul (int_of_nat a) (int_of_nat b)) = (a * b)%nat - := ap int_abs (int_nat_mul a b) @ int_abs_of_nat (a * b). - -(** Absolute value is multiplicative. *) -Definition int_abs_mul (x y : Int) - : int_abs (int_mul x y) = (int_abs x * int_abs y)%nat. -Proof. - destruct (int_abs_decomp x) as [px | px], (int_abs_decomp y) as [py | py]; - lhs napply (ap int_abs (ap011 int_mul px py)). - - napply int_abs_of_nat_mul. - - lhs napply (ap int_abs (int_mul_neg_r _ _)). - lhs napply int_abs_neg. - napply int_abs_of_nat_mul. - - lhs napply (ap int_abs (int_mul_neg_l _ _)). - lhs napply int_abs_neg. - napply int_abs_of_nat_mul. - - lhs napply (ap int_abs (int_mul_neg_l _ _)). - lhs napply int_abs_neg. - lhs napply (ap int_abs (int_mul_neg_r _ _)). - lhs napply int_abs_neg. - napply int_abs_of_nat_mul. -Defined. - (** An integer with trivial absolute value is zero. *) Definition int_abs_is_zero {x : cring_Z} (p : int_abs x = 0%nat) : x = 0. Proof. @@ -71,16 +16,6 @@ Proof. - exact (Empty_rec (neq_nat_zero_succ _ p^)). Defined. -(** A product of naturals vanishes only if a factor does. *) -Definition nat_mul_is_zero {a b : nat} (p : (a * b)%nat = 0%nat) - : (a = 0%nat) + (b = 0%nat). -Proof. - destruct a as [|a]; [ exact (inl idpath) | ]. - destruct b as [|b]; [ exact (inr idpath) | ]. - napply Empty_rec. - exact (neq_nat_zero_succ _ (p^ @ nat_mul_succ_l a b.+1 @ nat_add_succ_l b _)). -Defined. - (** [cring_Z] has no zero divisors. *) Definition int_mul_is_zero {x y : cring_Z} (p : x * y = 0) : (x = 0) + (y = 0). @@ -118,95 +53,48 @@ Proof. exact ((ap int_of_nat p)^ @ (int_nat_mul k d)^). Defined. -(** Divisibility is preserved under negating the dividend. *) -Definition rng_divides_neg_r {g x : cring_Z} (h : rng_divides g x) - : rng_divides g (- x). -Proof. - strip_truncations; destruct h as [c p]. - apply tr; exists (- c). - exact (ap (fun w => - w) p @ (rng_mult_negate_l c g)^). -Defined. - -(** Divisibility is preserved under negating the divisor. *) -Definition rng_divides_neg_l {g x : cring_Z} (h : rng_divides g x) - : rng_divides (- g) x. -Proof. - strip_truncations; destruct h as [c p]. - apply tr; exists (- c). - exact (p @ (rng_mult_negate_r (- c) g - @ ap (fun w => - w) (rng_mult_negate_l c g) - @ negate_involutive (c * g))^). -Defined. - (** Divisibility by [g] only depends on the dividend up to sign. *) Definition rng_divides_int_abs_r {g x : cring_Z} (h : rng_divides g (int_of_nat (int_abs x))) : rng_divides g x. Proof. destruct (int_abs_decomp x) as [px | px]. - exact (transport (rng_divides g) px^ h). - - exact (transport (rng_divides g) px^ (rng_divides_neg_r h)). -Defined. - -(** Divisibility only depends on the divisor up to sign. *) -Definition rng_divides_int_abs_l {g x : cring_Z} - (h : rng_divides (int_of_nat (int_abs g) : cring_Z) x) : rng_divides g x. -Proof. - destruct (int_abs_decomp g) as [pg | pg]. - - exact (transport (fun w => rng_divides w x) pg^ h). - - exact (transport (fun w => rng_divides w x) pg^ (rng_divides_neg_l h)). -Defined. - -(** An integer divisibility restricts to a divisibility of absolute values. *) -Definition nat_divides_of_rng_divides {z w c : cring_Z} (p : w = c * z) - : (int_abs z | int_abs w)%nat. -Proof. - exists (int_abs c). - exact ((int_abs_mul c z)^ @ (ap int_abs p)^). + - exact (transport (rng_divides g) px^ (rng_divides_negate_r h)). Defined. -(** A natural number as an element of the ring [cring_Z], pinning the typing so - that ring operations resolve without flipping back to [Int]. *) -Definition znat (n : nat) : cring_Z := int_of_nat n. - -Definition znat_mul (a b : nat) : znat (a * b) = znat a * znat b - := (int_nat_mul a b)^. - -Definition znat_add (a b : nat) : znat (a + b) = znat a + znat b - := (int_nat_add a b)^. - (** Bézout's identity for the integers, on nonnegative representatives. *) Definition int_bezout_nat (a b : nat) - : merely { u : cring_Z & { v : cring_Z - & u * znat a + v * znat b = znat (nat_gcd a b) } }. + : merely { u : Int & { v : Int + & (u * int_of_nat a + v * int_of_nat b)%int = int_of_nat (nat_gcd a b) } }. Proof. destruct a as [|a]. - - apply tr; exists 0, 1. - exact (ap011 (+) (rng_mult_zero_l (znat 0)) (rng_mult_one_l (znat b)) - @ left_identity (znat b)). + - apply tr; exists 0%int, 1%int. + exact (ap011 int_add (int_mul_0_l _) (int_mul_1_l _) @ int_add_0_l _). - pose proof (nat_bezout_pos_l a.+1 b _) as hbz. destruct hbz as [c [e r]]. - apply tr; exists (znat c), (- znat e). - pose (Rint := (znat_mul c a.+1)^ @ ap znat r @ znat_add _ _ - @ ap (fun w => znat (nat_gcd a.+1 b) + w) (znat_mul e b)). - lhs napply (ap (fun w => w + (- znat e) * znat b) Rint). - lhs_V napply grp_assoc. - exact (ap (fun w => znat (nat_gcd a.+1 b) + w) - ((rng_dist_r (znat e) (- znat e) (znat b))^ - @ ap (fun s => s * znat b) (right_inverse (znat e)) - @ rng_mult_zero_l (znat b)) - @ right_identity (znat (nat_gcd a.+1 b))). + apply tr; exists (int_of_nat c), (- int_of_nat e)%int. + pose (Rint := int_nat_mul c a.+1 @ ap int_of_nat r @ (int_nat_add _ _)^ + @ ap (fun w => (int_of_nat (nat_gcd a.+1 b) + w)%int) + (int_nat_mul e b)^). + lhs napply (ap (fun w => (w + (- int_of_nat e) * int_of_nat b)%int) Rint). + lhs_V napply int_add_assoc. + exact (ap (fun w => (int_of_nat (nat_gcd a.+1 b) + w)%int) + ((int_dist_r (int_of_nat e) (- int_of_nat e) (int_of_nat b))^ + @ ap (fun s => (s * int_of_nat b)%int) (int_add_neg_r (int_of_nat e)) + @ int_mul_0_l (int_of_nat b)) + @ int_add_0_r (int_of_nat (nat_gcd a.+1 b))). Defined. (** Rewriting a multiple of [|x|] as a multiple of [x], absorbing the sign. *) -Definition znat_abs_to_var (u x : cring_Z) - : { U : cring_Z & u * znat (int_abs x) = U * x }. +Definition int_abs_to_var (u x : cring_Z) + : { U : cring_Z & u * (int_of_nat (int_abs x) : cring_Z) = U * x }. Proof. destruct (int_abs_decomp x) as [px | px]. - exists u; exact (ap (fun w => u * w) px^). - exists (- u). - exact ((rng_mult_negate_l u (- znat (int_abs x)) - @ ap (fun w => - w) (rng_mult_negate_r u (znat (int_abs x))) - @ negate_involutive (u * znat (int_abs x)))^ + exact ((rng_mult_negate_l u (- (int_of_nat (int_abs x) : cring_Z)) + @ ap (fun w => - w) (rng_mult_negate_r u (int_of_nat (int_abs x) : cring_Z)) + @ negate_involutive (u * (int_of_nat (int_abs x) : cring_Z)))^ @ ap (fun w => (- u) * w) px^). Defined. @@ -217,8 +105,8 @@ Proof. intros x y. pose proof (int_bezout_nat (int_abs x) (int_abs y)) as hbz. strip_truncations; destruct hbz as [u0 [v0 hcombo]]. - destruct (znat_abs_to_var u0 x) as [U pU]. - destruct (znat_abs_to_var v0 y) as [V pV]. + destruct (int_abs_to_var u0 x) as [U pU]. + destruct (int_abs_to_var v0 y) as [V pV]. pose (combo := (ap011 (+) pU pV)^ @ hcombo). apply tr; exists U, V. refine (_, _, _). diff --git a/theories/Spaces/Int.v b/theories/Spaces/Int.v index 9cae12d26c9..5fc11c1c324 100644 --- a/theories/Spaces/Int.v +++ b/theories/Spaces/Int.v @@ -783,3 +783,58 @@ Proof. rhs_V napply int_nat_add. exact (ap _ IHn). Defined. + +(** ** Absolute value *) + +(** The absolute value of an integer, as a natural number. *) +Definition int_abs (x : Int) : nat := + match x with + | negS n => S n + | posS n => S n + | _ => O + end. + +Definition int_abs_of_nat (n : nat) : int_abs (int_of_nat n) = n. +Proof. + by destruct n. +Defined. + +Definition int_abs_neg (x : Int) : int_abs (int_neg x) = int_abs x. +Proof. + by destruct x. +Defined. + +(** Every integer is its absolute value up to sign. *) +Definition int_abs_decomp (x : Int) + : ((x = int_of_nat (int_abs x)) + (x = int_neg (int_of_nat (int_abs x))))%type. +Proof. + destruct x. + - exact (inr idpath). + - exact (inl idpath). + - exact (inl idpath). +Defined. + +(** The absolute value of a product of two natural numbers. *) +Definition int_abs_of_nat_mul (a b : nat) + : int_abs (int_mul (int_of_nat a) (int_of_nat b)) = (a * b)%nat + := ap int_abs (int_nat_mul a b) @ int_abs_of_nat (a * b)%nat. + +(** Absolute value is multiplicative. *) +Definition int_abs_mul (x y : Int) + : int_abs (int_mul x y) = (int_abs x * int_abs y)%nat. +Proof. + destruct (int_abs_decomp x) as [px | px], (int_abs_decomp y) as [py | py]; + lhs napply (ap int_abs (ap011 int_mul px py)). + - napply int_abs_of_nat_mul. + - lhs napply (ap int_abs (int_mul_neg_r _ _)). + lhs napply int_abs_neg. + napply int_abs_of_nat_mul. + - lhs napply (ap int_abs (int_mul_neg_l _ _)). + lhs napply int_abs_neg. + napply int_abs_of_nat_mul. + - lhs napply (ap int_abs (int_mul_neg_l _ _)). + lhs napply int_abs_neg. + lhs napply (ap int_abs (int_mul_neg_r _ _)). + lhs napply int_abs_neg. + napply int_abs_of_nat_mul. +Defined. diff --git a/theories/Spaces/Nat/Core.v b/theories/Spaces/Nat/Core.v index bd54b431d42..dcc2df60c53 100644 --- a/theories/Spaces/Nat/Core.v +++ b/theories/Spaces/Nat/Core.v @@ -357,6 +357,15 @@ Proof. exact IHn. Defined. +(** A product of natural numbers is zero only if one of the factors is. *) +Definition nat_mul_is_zero@{} {n m : nat} (p : n * m = 0) : (n = 0) + (m = 0). +Proof. + destruct n as [|n]; [ exact (inl idpath) | ]. + destruct m as [|m]; [ exact (inr idpath) | ]. + napply Empty_rec. + exact (neq_nat_zero_succ _ (p^ @ nat_mul_succ_l n m.+1 @ nat_add_succ_l m _)). +Defined. + (** Multiplication of natural numbers is commutative. *) Definition nat_mul_comm@{} n m : n * m = m * n. Proof. From 6c6a30cfff0d846c8cc0889ae46efd99ed7289e8 Mon Sep 17 00:00:00 2001 From: CharlesCNorton Date: Wed, 17 Jun 2026 16:43:06 -0400 Subject: [PATCH 04/12] Remove the higher Ext development, keeping the EM-space classification The remaining changes classify short exact sequences by pointed maps of Eilenberg-Mac Lane spaces, in Classification.v and LoopGroup.v, with supporting changes to EMSpace.v, ExactSequence.v, ClassifyingSpace.v, pFiber.v and Connectedness.v. --- theories/Algebra/AbGroups/AbInjective.v | 30 - theories/Algebra/AbGroups/Cohomology.v | 88 - theories/Algebra/AbSES/HigherExt.v | 2353 ------------------ theories/Algebra/AbSES/HigherExtMorphism.v | 152 -- theories/Algebra/AbSES/HigherExtResolution.v | 53 - theories/Algebra/AbSES/InjectiveExt.v | 57 - theories/Algebra/AbSES/Pullback.v | 15 - theories/Algebra/AbSES/Pushout.v | 21 - theories/Algebra/AbSES/SixTerm.v | 20 +- theories/Algebra/Rings/Bezout.v | 144 -- theories/Algebra/Rings/FinitelyPresented.v | 27 - theories/Algebra/Rings/FreeModule.v | 613 ----- theories/Algebra/Rings/GroupRing.v | 180 -- theories/Algebra/Rings/Module.v | 59 +- theories/Algebra/Rings/ZBezout.v | 124 - theories/Spaces/Int.v | 55 - theories/Spaces/Nat/Core.v | 9 - 17 files changed, 21 insertions(+), 3979 deletions(-) delete mode 100644 theories/Algebra/AbGroups/AbInjective.v delete mode 100644 theories/Algebra/AbGroups/Cohomology.v delete mode 100644 theories/Algebra/AbSES/HigherExt.v delete mode 100644 theories/Algebra/AbSES/HigherExtMorphism.v delete mode 100644 theories/Algebra/AbSES/HigherExtResolution.v delete mode 100644 theories/Algebra/AbSES/InjectiveExt.v delete mode 100644 theories/Algebra/Rings/Bezout.v delete mode 100644 theories/Algebra/Rings/FinitelyPresented.v delete mode 100644 theories/Algebra/Rings/FreeModule.v delete mode 100644 theories/Algebra/Rings/GroupRing.v delete mode 100644 theories/Algebra/Rings/ZBezout.v diff --git a/theories/Algebra/AbGroups/AbInjective.v b/theories/Algebra/AbGroups/AbInjective.v deleted file mode 100644 index 773b7ecbd61..00000000000 --- a/theories/Algebra/AbGroups/AbInjective.v +++ /dev/null @@ -1,30 +0,0 @@ -From HoTT Require Import Basics Types AbelianGroup AbPushout - WildCat.Core Truncations.Core. - -(** * Injective abelian groups *) - -(** We define injective abelian groups and show that [I] is injective if and only if every monomorphism [I -> B] merely splits. This is dual to [AbProjective]. *) - -(** An abelian group [I] is injective if for any map [f : A -> I] and embedding [m : A -> B], there merely exists an extension [g : B -> I] with [g $o m == f]. *) -Class IsAbInjective@{u +} (I : AbGroup@{u}) : Type := - isabinjective : forall (A B : AbGroup@{u}), forall (m : A $-> B), - forall (f : A $-> I), IsEmbedding m -> merely (exists g : B $-> I, g $o m == f). - -(** An abelian group is injective iff monos out of it merely split. *) -Proposition iff_isabinjective_embeddings_split `{Univalence} (I : AbGroup) - : IsAbInjective I - <-> (forall B, forall m : I $-> B, IsEmbedding m -> - merely (exists r : B $-> I, r $o m == grp_homo_id)). -Proof. - split. - - intros hinj B m. - apply hinj. - - intros hsplit A B m f hm. - pose proof (s := hsplit (ab_pushout f m) ab_pushout_inl - (ab_pushout_embedding_inl f m)). - strip_truncations. - destruct s as [r h]. - refine (tr (r $o ab_pushout_inr; _)); intro a. - refine (ap r (ab_pushout_commsq a)^ @ _). - exact (h (f a)). -Defined. diff --git a/theories/Algebra/AbGroups/Cohomology.v b/theories/Algebra/AbGroups/Cohomology.v deleted file mode 100644 index c8e96949f59..00000000000 --- a/theories/Algebra/AbGroups/Cohomology.v +++ /dev/null @@ -1,88 +0,0 @@ -From HoTT Require Import Basics Types Truncations.Core. -From HoTT.WildCat Require Import Core. -Require Import AbGroups.AbelianGroup. -Require Import Groups.Group Groups.Subgroup Groups.QuotientGroup. - -Local Open Scope nat_scope. -Local Open Scope mc_add_scope. - -(** * Cochain complexes of abelian groups and their cohomology *) - -(** A cochain complex is a sequence of abelian groups with differentials whose - consecutive composites vanish. *) -Record CochainComplex : Type := { - cc_carrier : nat -> AbGroup ; - cc_diff : forall n, cc_carrier n $-> cc_carrier (S n) ; - cc_iscomplex : forall n, cc_diff (S n) $o cc_diff n == grp_homo_const -}. - -(** Each differential corestricts to the kernel of the next, since the - composite vanishes. *) -Definition cc_diff_corec (C : CochainComplex) (n : nat) - : cc_carrier C n $-> ab_kernel (cc_diff C (S n)) - := grp_kernel_corec (cc_diff C n) (cc_iscomplex C n). - -(** The [n]-th cohomology group: the kernel of the [n]-th differential modulo - the image of the previous one. *) -Definition cohomology (C : CochainComplex) (n : nat) : AbGroup - := match n with - | O => ab_kernel (cc_diff C 0) - | S n => ab_cokernel (cc_diff_corec C n) - end. - -(** In degree zero the cohomology is the kernel of the first differential. *) -Definition cohomology_zero (C : CochainComplex) - : cohomology C 0 = ab_kernel (cc_diff C 0) - := idpath. - -(** ** Morphisms of cochain complexes and functoriality of cohomology *) - -(** A morphism of cochain complexes is a degreewise map commuting with the - differentials. *) -Record CochainMap (C D : CochainComplex) : Type := { - cm_map : forall n, cc_carrier C n $-> cc_carrier D n ; - cm_natural : forall n, cm_map (S n) $o cc_diff C n == cc_diff D n $o cm_map n -}. - -Arguments cm_map {C D}. -Arguments cm_natural {C D}. - -Section Functoriality. - Context `{Funext} {C D : CochainComplex} (f : CochainMap C D). - - (** A cochain map restricts to the kernels of the differentials. *) - Definition cm_kernel (n : nat) - : ab_kernel (cc_diff C n) $-> ab_kernel (cc_diff D n). - Proof. - snapply grp_kernel_corec. - - exact (grp_homo_compose (cm_map f n) (subgroup_incl _)). - - intro x. - lhs exact (cm_natural f n (subgroup_incl _ x))^. - lhs napply (ap (cm_map f (S n)) x.2). - apply grp_homo_unit. - Defined. - - (** The kernel map commutes with the corestricted differentials. *) - Definition cm_kernel_natural (n : nat) (c : cc_carrier C n) - : cm_kernel (S n) (cc_diff_corec C n c) = cc_diff_corec D n (cm_map f n c). - Proof. - apply path_sigma_hprop. - exact (cm_natural f n c). - Defined. - - (** A cochain map induces a map on cohomology in every degree. *) - Definition cohomology_functor (n : nat) - : cohomology C n $-> cohomology D n. - Proof. - destruct n as [|n]. - - exact (cm_kernel 0). - - snapply quotient_abgroup_rec. - + exact (grp_homo_compose grp_quotient_map (cm_kernel (S n))). - + intros y hy; strip_truncations; destruct hy as [c hc]. - lhs napply (ap (fun z => grp_quotient_map (cm_kernel (S n) z)) hc^). - lhs napply (ap grp_quotient_map (cm_kernel_natural n c)). - napply grp_quotient_map_trivial. - exact (grp_image_in (cc_diff_corec D n) (cm_map f n c)). - Defined. - -End Functoriality. diff --git a/theories/Algebra/AbSES/HigherExt.v b/theories/Algebra/AbSES/HigherExt.v deleted file mode 100644 index 59707a2c948..00000000000 --- a/theories/Algebra/AbSES/HigherExt.v +++ /dev/null @@ -1,2353 +0,0 @@ -From HoTT Require Import Basics Types. -From HoTT.WildCat Require Import Core. -Require Import Truncations.Core Truncations.SeparatedTrunc. -Require Import Universes.HSet. -Require Import Pointed.Core. -Require Import Homotopy.ExactSequence. -Require Import Colimits.Quotient. -Require Import AbelianGroup AbHom Biproduct AbProjective. -Require Import Spaces.FreeInt. -Require Import Groups.Group. -Require Import Algebra.AbSES.Core Algebra.AbSES.Pushout Algebra.AbSES.Pullback - Algebra.AbSES.BaerSum Algebra.AbSES.DirectSum Algebra.AbSES.Ext - Algebra.AbSES.PullbackFiberSequence. - -(** * Higher Ext groups via length-[n] exact sequences - - Following Christensen and Flaten, "Ext groups in homotopy type theory", - we define the higher Ext groups [abses_ext n B A] as set-quotients of - length-[n] exact sequences. A length-[0] sequence is a homomorphism, a - length-[1] sequence is a short exact sequence, and a length-[m.+1] - sequence is a short exact sequence [B <- ... <- C] spliced onto a - length-[m] sequence [C <- ... <- A]. - - The development proceeds in four stages: the type of length-[n] - sequences and the splice; the functorial operations (pullback, pushout, - direct sum and Baer sum) on sequences; the relation [⤳] of the paper, - shown to be an equivalence relation respected by all the operations; and - the higher Ext groups, with their bifunctoriality, the Yoneda product - and the Baer sum. *) - -Local Open Scope type_scope. - -(** ** The type of length-[n] exact sequences *) - -Section LengthNSequences. - Context `{Univalence}. - - Fixpoint abses_es (n : nat) (B A : AbGroup@{u}) : Type := - match n with - | 0%nat => ab_hom B A - | 1%nat => pointed_type (AbSES B A) - | S (S _ as m) => { C : AbGroup@{u} & abses_es m C A * pointed_type (AbSES B C) } - end. - - (** The splice operation, attaching a short exact sequence [B <- ... <- C] - to the front of a length-[m] sequence [C <- ... <- A]. When [m] is - zero this pushes the short exact sequence out along the homomorphism; - otherwise it records the new module and prepends. *) - Definition abses_es_splice {A B C : AbGroup@{u}} (m : nat) - : abses_es m C A -> AbSES B C -> abses_es m.+1%nat B A. - Proof. - destruct m as [|m]. - - exact (fun f s => abses_pushout f s). - - exact (fun e s => (C; (e, s))). - Defined. - -End LengthNSequences. - -(** ** Operations on length-[n] sequences *) - -Section Operations. - Context `{Univalence}. - - (** Pulling a length-[n] sequence back along [beta : B' -> B] changes only - the leading short exact sequence (precomposition when [n] is zero). *) - Definition abses_es_pullback {A : AbGroup@{u}} (n : nat) - {B B' : AbGroup@{u}} (beta : B' $-> B) - : abses_es n B A -> abses_es n B' A. - Proof. - destruct n as [|[|n]]. - - exact (fun f => grp_homo_compose f beta). - - exact (fun s => abses_pullback beta s). - - exact (fun e => (e.1; (fst e.2, abses_pullback beta (snd e.2)))). - Defined. - - (** Pulling back along the identity is the identity. *) - Definition abses_es_pullback_id (n : nat) {B A : AbGroup@{u}} - (E : abses_es n B A) - : abses_es_pullback n grp_homo_id E = E. - Proof. - destruct n as [|[|n0]]. - - apply equiv_path_grouphomomorphism; reflexivity. - - apply abses_pullback_id. - - exact (path_sigma' _ 1 - (path_prod (fst E.2, abses_pullback grp_homo_id (snd E.2)) E.2 - 1 (abses_pullback_id (snd E.2)))). - Defined. - - (** Pullback is contravariantly functorial in the base. *) - Definition abses_es_pullback_compose (n : nat) - {A B0 B1 B2 : AbGroup@{u}} (f : B0 $-> B1) (g : B1 $-> B2) - (Z : abses_es n B2 A) - : abses_es_pullback n (g $o f) Z - = abses_es_pullback n f (abses_es_pullback n g Z). - Proof. - destruct n as [|[|n0]]. - - apply equiv_path_grouphomomorphism; reflexivity. - - exact (abses_pullback_compose f g Z)^. - - exact (path_sigma' _ 1 - (path_prod (fst Z.2, abses_pullback (g $o f) (snd Z.2)) - (fst Z.2, abses_pullback f (abses_pullback g (snd Z.2))) - 1 (abses_pullback_compose f g (snd Z.2))^)). - Defined. - - (** Pushing a length-[n] sequence out along [alpha : A -> A'] acts on the - deep end, recursing into the trailing sequence (postcomposition when - [n] is zero). *) - Definition abses_es_pushout (n : nat) - {A A' : AbGroup@{u}} (alpha : A $-> A') - : forall {B : AbGroup@{u}}, abses_es n B A -> abses_es n B A'. - Proof. - induction n as [|n1 IH]; intro B. - - exact (fun f => grp_homo_compose alpha f). - - destruct n1 as [|n0]. - + exact (fun s => abses_pushout alpha s). - + exact (fun e => (e.1; (IH e.1 (fst e.2), snd e.2))). - Defined. - - (** Pushing out along the identity is the identity. *) - Definition abses_es_pushout_id (n : nat) {B A : AbGroup@{u}} - (E : abses_es n B A) - : abses_es_pushout n grp_homo_id E = E. - Proof. - revert B A E; induction n as [|n1 IH]; intros B A E. - - apply equiv_path_grouphomomorphism; reflexivity. - - destruct n1 as [|n0]. - + apply abses_pushout_id. - + exact (path_sigma' _ 1 - (path_prod (abses_es_pushout n0.+1 grp_homo_id (fst E.2), snd E.2) - (fst E.2, snd E.2) - (IH E.1 A (fst E.2)) 1)). - Defined. - - (** Pushout is covariantly functorial in the deep end. *) - Definition abses_es_pushout_compose (n : nat) - {A0 A1 A2 : AbGroup@{u}} (f : A0 $-> A1) (g : A1 $-> A2) (B : AbGroup@{u}) - : forall E : abses_es n B A0, - abses_es_pushout n (g $o f) E - = abses_es_pushout n g (abses_es_pushout n f E). - Proof. - revert B; induction n as [|n1 IH]; intro B. - - intro E; apply equiv_path_grouphomomorphism; reflexivity. - - destruct n1 as [|n0]. - + intro E; exact (abses_pushout_compose f g E). - + intro E. - exact (path_sigma' _ 1 - (path_prod - (abses_es_pushout n0.+1 (g $o f) (fst E.2), snd E.2) - (abses_es_pushout n0.+1 g (abses_es_pushout n0.+1 f (fst E.2)), snd E.2) - (IH E.1 (fst E.2)) 1)). - Defined. - - (** Pushout and pullback act on disjoint ends, so they commute. *) - Definition abses_es_pushout_pullback (n : nat) - {A A' B B' : AbGroup@{u}} (alpha : A $-> A') (beta : B' $-> B) - (E : abses_es n B A) - : abses_es_pushout n alpha (abses_es_pullback n beta E) - = abses_es_pullback n beta (abses_es_pushout n alpha E). - Proof. - destruct n as [|[|n0]]. - - apply equiv_path_grouphomomorphism; reflexivity. - - apply abses_pushout_pullback_reorder. - - reflexivity. - Defined. - - (** The direct sum of two length-[n] sequences, taken componentwise; the - intermediate modules become biproducts. *) - Definition abses_es_direct_sum (n : nat) - : forall {B A B' A' : AbGroup@{u}}, - abses_es n B A -> abses_es n B' A' -> abses_es n (ab_biprod B B') (ab_biprod A A'). - Proof. - induction n as [|n1 IH]; intros B A B' A'. - - exact (fun E F => functor_ab_biprod E F). - - destruct n1 as [|n0]. - + exact (fun E F => abses_direct_sum E F). - + exact (fun E F => (ab_biprod E.1 F.1; - (IH E.1 A F.1 A' (fst E.2) (fst F.2), - abses_direct_sum (snd E.2) (snd F.2)))). - Defined. - - (** The direct sum commutes with pullback along [functor_ab_biprod]; - pullback touches only the leading sequence, so no recursion is - needed. *) - Definition abses_es_directsum_pullback (n : nat) - {A A' B B' D D' : AbGroup@{u}} (beta : B' $-> B) (delta : D' $-> D) - (X : abses_es n B A) (Y : abses_es n D A') - : abses_es_direct_sum n (abses_es_pullback n beta X) (abses_es_pullback n delta Y) - = abses_es_pullback n (functor_ab_biprod beta delta) (abses_es_direct_sum n X Y). - Proof. - destruct n as [|[|n0]]. - - apply equiv_path_grouphomomorphism; reflexivity. - - exact (abses_directsum_distributive_pullbacks beta delta)^. - - srapply path_sigma'. - 1: reflexivity. - srapply path_prod. - 1: reflexivity. - exact (abses_directsum_distributive_pullbacks beta delta)^. - Defined. - - (** The direct sum commutes with pushout along [functor_ab_biprod]; pushout - recurses into the trailing sequence. *) - Definition abses_es_directsum_pushout (n : nat) - {A A2 A' A'2 : AbGroup@{u}} (alpha : A $-> A2) (alpha' : A' $-> A'2) - : forall {B B' : AbGroup@{u}} (X : abses_es n B A) (Y : abses_es n B' A'), - abses_es_pushout n (functor_ab_biprod alpha alpha') (abses_es_direct_sum n X Y) - = abses_es_direct_sum n (abses_es_pushout n alpha X) (abses_es_pushout n alpha' Y). - Proof. - induction n as [|n1 IH]; intros B B' X Y. - - apply equiv_path_grouphomomorphism; reflexivity. - - destruct n1 as [|n0]. - + apply abses_directsum_distributive_pushouts. - + exact (path_sigma' _ 1 - (path_prod - (abses_es_pushout n0.+1 (functor_ab_biprod alpha alpha') - (abses_es_direct_sum n0.+1 (fst X.2) (fst Y.2)), - abses_direct_sum (snd X.2) (snd Y.2)) - (abses_es_direct_sum n0.+1 (abses_es_pushout n0.+1 alpha (fst X.2)) - (abses_es_pushout n0.+1 alpha' (fst Y.2)), - abses_direct_sum (snd X.2) (snd Y.2)) - (IH X.1 Y.1 (fst X.2) (fst Y.2)) 1)). - Defined. - - (** The twist morphism on a triple direct sum, for arbitrary objects (the - analogous library construction is stated only for equal objects). *) - Definition abses_twist_directsum' {A1 B1 A2 B2 A3 B3 : AbGroup@{u}} - (E : AbSES B1 A1) (F : AbSES B2 A2) (G : AbSES B3 A3) - : AbSESMorphism (abses_direct_sum (abses_direct_sum E F) G) - (abses_direct_sum (abses_direct_sum G F) E). - Proof. - snapply Build_AbSESMorphism. - 1,2,3: exact ab_biprod_twist. - all: reflexivity. - Defined. - - (** The Baer sum of two length-[n] sequences with the same endpoints: take - the direct sum, push out along the codiagonal and pull back along the - diagonal. *) - Definition abses_es_baer_sum (n : nat) {B A : AbGroup@{u}} - (E F : abses_es n B A) : abses_es n B A - := abses_es_pullback n ab_diagonal - (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F)). - - (** Adding the split trivial summand on the deep end and projecting away the - trivial factor leaves a short exact sequence unchanged, up to reindexing - the base along the projection. *) - Definition abses_absorb_trivial {C A : AbGroup@{u}} (X : AbSES C A) - : abses_pushout ab_codiagonal - (abses_direct_sum X (point (AbSES abgroup_trivial A))) - = abses_pullback ab_biprod_pr1 X. - Proof. - pose (cst := @grp_homo_const abgroup_trivial C). - transitivity (abses_pushout ab_codiagonal - (abses_direct_sum X (abses_pullback cst X))). - 1: napply (ap (fun s => abses_pushout ab_codiagonal (abses_direct_sum X s))); - exact (abses_pullback_const X). - transitivity (abses_pushout ab_codiagonal - (abses_direct_sum (abses_pullback grp_homo_id X) - (abses_pullback cst X))). - 1: napply (ap (fun s => abses_pushout ab_codiagonal (abses_direct_sum s _))); - exact (abses_pullback_id X)^. - transitivity (abses_pushout ab_codiagonal - (abses_pullback (functor_ab_biprod grp_homo_id cst) - (abses_direct_sum X X))). - 1: napply (ap (abses_pushout ab_codiagonal)); - exact (abses_directsum_distributive_pullbacks grp_homo_id cst)^. - transitivity (abses_pullback (functor_ab_biprod grp_homo_id cst) - (abses_pushout ab_codiagonal (abses_direct_sum X X))). - 1: exact (abses_pushout_pullback_reorder _ _ _). - transitivity (abses_pullback (functor_ab_biprod grp_homo_id cst) - (abses_pullback ab_codiagonal X)). - 1: napply (ap (abses_pullback (functor_ab_biprod grp_homo_id cst))); - exact (abses_pushout_is_pullback (abses_codiagonal X)). - transitivity (abses_pullback - (ab_codiagonal $o functor_ab_biprod grp_homo_id cst) X). - 1: exact (abses_pullback_compose - (functor_ab_biprod grp_homo_id cst) ab_codiagonal X). - napply (ap (fun h => abses_pullback h X)). - apply equiv_path_grouphomomorphism; intro x; cbn. - apply grp_unit_r. - Defined. - - (** The trinary Baer sum, used to organise the proof of associativity. *) - Definition abses_es_trinary_baer_sum (n : nat) {B A : AbGroup@{u}} - (E F G : abses_es n B A) : abses_es n B A - := abses_es_pullback n ab_triagonal - (abses_es_pushout n ab_cotriagonal - (abses_es_direct_sum n (abses_es_direct_sum n E F) G)). - - (** The split length-[n] sequence, the neutral element for the Baer sum: the - zero homomorphism, the split short exact sequence, and otherwise the - trivial group spliced in. *) - Definition abses_es_zero (n : nat) {A : AbGroup@{u}} - : forall {B : AbGroup@{u}}, abses_es n B A. - Proof. - induction n as [|n1 IH]; intro B. - - exact grp_homo_const. - - destruct n1 as [|n0]. - + exact (point (AbSES B A)). - + exact (abgroup_trivial; (IH abgroup_trivial, point (AbSES B abgroup_trivial))). - Defined. - - (** Pulling the zero sequence back along the unique map to the trivial group - gives the zero sequence again. *) - Definition abses_es_pullback_zero (m : nat) {A C : AbGroup@{u}} - : abses_es_pullback m (@grp_homo_const C abgroup_trivial) - (@abses_es_zero m A abgroup_trivial) - = @abses_es_zero m A C. - Proof. - destruct m as [|[|m0]]. - - apply equiv_path_grouphomomorphism; reflexivity. - - exact (abses_pullback_const _)^. - - srapply path_sigma'. - 1: reflexivity. - srapply path_prod. - 1: reflexivity. - exact (abses_pullback_const (point (AbSES abgroup_trivial abgroup_trivial)))^. - Defined. - - (** Pushout is additive for the Baer sum, by naturality of the codiagonal. *) - Definition abses_es_pushout_baer_sum (n : nat) {A A' : AbGroup@{u}} - (alpha : A $-> A') {B : AbGroup@{u}} (E F : abses_es n B A) - : abses_es_pushout n alpha (abses_es_baer_sum n E F) - = abses_es_baer_sum n (abses_es_pushout n alpha E) (abses_es_pushout n alpha F). - Proof. - unfold abses_es_baer_sum. - transitivity (abses_es_pullback n ab_diagonal - (abses_es_pushout n alpha - (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F)))). - 1: exact (abses_es_pushout_pullback n alpha ab_diagonal _). - napply (ap (abses_es_pullback n ab_diagonal)). - transitivity (abses_es_pushout n (alpha $o ab_codiagonal) - (abses_es_direct_sum n E F)). - 1: exact (abses_es_pushout_compose n ab_codiagonal alpha (ab_biprod B B) - (abses_es_direct_sum n E F))^. - transitivity (abses_es_pushout n (ab_codiagonal $o functor_ab_biprod alpha alpha) - (abses_es_direct_sum n E F)). - 1: napply (ap (fun h => abses_es_pushout n h (abses_es_direct_sum n E F))); - exact (equiv_path_grouphomomorphism (ab_codiagonal_natural alpha)). - transitivity (abses_es_pushout n ab_codiagonal - (abses_es_pushout n (functor_ab_biprod alpha alpha) - (abses_es_direct_sum n E F))). - 1: exact (abses_es_pushout_compose n (functor_ab_biprod alpha alpha) ab_codiagonal - (ab_biprod B B) (abses_es_direct_sum n E F)). - napply (ap (abses_es_pushout n ab_codiagonal)). - exact (abses_es_directsum_pushout n alpha alpha E F). - Defined. - - (** Pullback is additive for the Baer sum, by naturality of the diagonal. *) - Definition abses_es_pullback_baer_sum (n : nat) {A : AbGroup@{u}} - {B B' : AbGroup@{u}} (beta : B' $-> B) (E F : abses_es n B A) - : abses_es_pullback n beta (abses_es_baer_sum n E F) - = abses_es_baer_sum n (abses_es_pullback n beta E) (abses_es_pullback n beta F). - Proof. - unfold abses_es_baer_sum. - transitivity (abses_es_pullback n (ab_diagonal $o beta) - (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F))). - 1: exact (abses_es_pullback_compose n beta ab_diagonal _)^. - transitivity (abses_es_pullback n (functor_ab_biprod beta beta $o ab_diagonal) - (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F))). - 1: napply (ap (fun h => abses_es_pullback n h - (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F)))); - apply equiv_path_grouphomomorphism; reflexivity. - transitivity (abses_es_pullback n ab_diagonal - (abses_es_pullback n (functor_ab_biprod beta beta) - (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F)))). - 1: exact (abses_es_pullback_compose n ab_diagonal (functor_ab_biprod beta beta) _). - napply (ap (abses_es_pullback n ab_diagonal)). - transitivity (abses_es_pushout n ab_codiagonal - (abses_es_pullback n (functor_ab_biprod beta beta) - (abses_es_direct_sum n E F))). - 1: exact (abses_es_pushout_pullback n ab_codiagonal (functor_ab_biprod beta beta) _)^. - napply (ap (abses_es_pushout n ab_codiagonal)). - exact (abses_es_directsum_pullback n beta beta E F)^. - Defined. - - (** Splicing a short exact sequence [xi : AbSES A'' A] of coefficients onto - the deep end of a length-[n] sequence raises the degree; this is the - connecting map of the long exact sequence. At degree zero it is pullback - along the homomorphism; otherwise it recurses to the deepest sequence. *) - Definition abses_es_dsplice (n : nat) {A A'' : AbGroup@{u}} (xi : AbSES A'' A) - : forall {B : AbGroup@{u}}, abses_es n B A'' -> abses_es n.+1 B A. - Proof. - induction n as [|n1 IH]; intro B. - - exact (fun f => abses_pullback f xi). - - destruct n1 as [|n0]. - + exact (fun s => (A''; (xi, s))). - + exact (fun e => (e.1; (IH e.1 (fst e.2), snd e.2))). - Defined. - - (** The deep-end splice commutes with pullback in the base. *) - Definition abses_es_dsplice_pullback (n : nat) {A A'' : AbGroup@{u}} - (xi : AbSES A'' A) {B B' : AbGroup@{u}} (beta : B' $-> B) - (X : abses_es n B A'') - : abses_es_dsplice n xi (abses_es_pullback n beta X) - = abses_es_pullback n.+1 beta (abses_es_dsplice n xi X). - Proof. - destruct n as [|[|n0]]. - - exact (abses_pullback_compose beta X xi)^. - - reflexivity. - - reflexivity. - Defined. - - (** Pushing out the deep end of a spliced sequence is the same as splicing - with the pushed-out short exact sequence: the pushout in degree [n.+1] - acts on the deepest sequence, which is exactly [xi]. *) - Definition abses_es_dsplice_pushout (n : nat) {A A2 A'' : AbGroup@{u}} - (xi : AbSES A'' A) (alpha : A $-> A2) - : forall {B : AbGroup@{u}} (Y : abses_es n B A''), - abses_es_pushout n.+1 alpha (abses_es_dsplice n xi Y) - = abses_es_dsplice n (abses_pushout alpha xi) Y. - Proof. - induction n as [|n1 IH]; intro B. - - exact (fun Y => abses_pushout_pullback_reorder xi alpha Y). - - destruct n1 as [|n0]. - + exact (fun s => idpath). - + intro e. - srapply path_sigma'. - 1: reflexivity. - srapply path_prod. - 1: exact (IH e.1 (fst e.2)). - reflexivity. - Defined. - - (** The deep-end splice distributes over the direct sum: the direct sum of - two splices by [xi] is the splice by [xi (+) xi] of the direct sum. The - pullback at the deepest level is handled by the distributivity of the - direct sum over pullbacks. *) - Definition abses_es_directsum_dsplice (n : nat) {A A'' : AbGroup@{u}} - (xi : AbSES A'' A) - : forall {B B' : AbGroup@{u}} (E : abses_es n B A'') (F : abses_es n B' A''), - abses_es_direct_sum n.+1 (abses_es_dsplice n xi E) (abses_es_dsplice n xi F) - = abses_es_dsplice n (abses_direct_sum xi xi) (abses_es_direct_sum n E F). - Proof. - induction n as [|n1 IH]; intros B B' E F. - - exact (abses_directsum_distributive_pullbacks E F)^. - - destruct n1 as [|n0]. - + reflexivity. - + srapply path_sigma'. - 1: reflexivity. - srapply path_prod. - 1: exact (IH E.1 F.1 (fst E.2) (fst F.2)). - reflexivity. - Defined. - -End Operations. - -(** ** The relation [⤳] *) - -Section Relation. - Context `{Univalence}. - - (** The relation [E ⤳ F] of Christensen-Flaten: equality in low degrees, - and otherwise a homomorphism of the intermediate modules under which - the leading sequences push out and the trailing sequences pull back to - matching ones. *) - Definition abses_es_rel (n : nat) {B A : AbGroup@{u}} - : abses_es n B A -> abses_es n B A -> Type. - Proof. - revert B A; induction n as [|n1 IH]; intros B A. - - exact (fun E F => E = F). - - destruct n1 as [|n0]. - + exact (fun E F => E = F). - + intros E F. - exact { beta : ab_hom E.1 F.1 - & IH E.1 A (fst E.2) (abses_es_pullback n0.+1 beta (fst F.2)) - * (abses_pushout beta (snd E.2) = snd F.2) }. - Defined. - - (** The relation is preserved by pullback along [beta], since [beta] only - touches the leading short exact sequence. *) - Definition abses_es_rel_pullback (n : nat) - {A B B' : AbGroup@{u}} (beta : B' $-> B) - : forall X Y : abses_es n B A, abses_es_rel n X Y - -> abses_es_rel n (abses_es_pullback n beta X) (abses_es_pullback n beta Y). - Proof. - destruct n as [|[|n0]]; intros X Y r. - - exact (ap (abses_es_pullback 0 beta) r). - - exact (ap (abses_es_pullback 1 beta) r). - - exists r.1. - exact (fst r.2, - abses_pushout_pullback_reorder (snd X.2) r.1 beta - @ ap (abses_pullback beta) (snd r.2)). - Defined. - - (** The relation is preserved by pushout along [alpha], using that pushout - commutes with the pullback appearing in the relation. *) - Definition abses_es_rel_pushout (n : nat) - {A A' : AbGroup@{u}} (alpha : A $-> A') (B : AbGroup@{u}) - : forall E F : abses_es n B A, abses_es_rel n E F - -> abses_es_rel n (abses_es_pushout n alpha E) (abses_es_pushout n alpha F). - Proof. - revert B; induction n as [|n1 IH]; intro B. - - intros E F r; exact (ap (abses_es_pushout 0 alpha) r). - - destruct n1 as [|n0]. - + intros E F r; exact (ap (abses_es_pushout 1 alpha) r). - + intros E F r. - exists r.1. - exact (transport - (abses_es_rel n0.+1 (abses_es_pushout n0.+1 alpha (fst E.2))) - (abses_es_pushout_pullback n0.+1 alpha r.1 (fst F.2)) - (IH E.1 (fst E.2) (abses_es_pullback n0.+1 r.1 (fst F.2)) (fst r.2)), - snd r.2). - Defined. - - (** The relation is reflexive, witnessed by the identity homomorphism. *) - Definition abses_es_rel_refl (n : nat) {B A : AbGroup@{u}} - (E : abses_es n B A) - : abses_es_rel n E E. - Proof. - revert B A E; induction n as [|n1 IH]; intros B A E. - - reflexivity. - - destruct n1 as [|n0]. - + reflexivity. - + exists grp_homo_id. - exact (transport (abses_es_rel n0.+1 (fst E.2)) - (abses_es_pullback_id n0.+1 (fst E.2))^ - (IH E.1 A (fst E.2)), - abses_pushout_id (snd E.2)). - Defined. - - (** The relation is transitive: compose the intermediate homomorphisms, - pulling the second witness back along the first and reassembling the - pushout square by functoriality. *) - Definition abses_es_rel_trans (n : nat) {B A : AbGroup@{u}} - : forall X Y Z : abses_es n B A, - abses_es_rel n X Y -> abses_es_rel n Y Z -> abses_es_rel n X Z. - Proof. - revert B A; induction n as [|n1 IH]; intros B A. - - intros X Y Z r1 r2; exact (r1 @ r2). - - destruct n1 as [|n0]. - + intros X Y Z r1 r2; exact (r1 @ r2). - + intros X Y Z r1 r2. - exists (grp_homo_compose r2.1 r1.1). - refine (_, _). - * refine (IH _ _ _ _ _ (fst r1.2) _). - exact (transport - (abses_es_rel n0.+1 (abses_es_pullback n0.+1 r1.1 (fst Y.2))) - (abses_es_pullback_compose n0.+1 r1.1 r2.1 (fst Z.2))^ - (abses_es_rel_pullback n0.+1 r1.1 (fst Y.2) - (abses_es_pullback n0.+1 r2.1 (fst Z.2)) (fst r2.2))). - * exact (abses_pushout_compose r1.1 r2.1 (snd X.2) - @ ap (abses_pushout r2.1) (snd r1.2) @ snd r2.2). - Defined. - - (** The direct sum respects the relation in both arguments, composing the - two intermediate homomorphisms with [functor_ab_biprod]. *) - Definition abses_es_direct_sum_rel (n : nat) - : forall {B A B' A' : AbGroup@{u}} (E E' : abses_es n B A) (F F' : abses_es n B' A'), - abses_es_rel n E E' -> abses_es_rel n F F' - -> abses_es_rel n (abses_es_direct_sum n E F) (abses_es_direct_sum n E' F'). - Proof. - induction n as [|n1 IH]; intros B A B' A'. - - intros E E' F F' rE rF; exact (ap011 (abses_es_direct_sum 0) rE rF). - - destruct n1 as [|n0]. - + intros E E' F F' rE rF; exact (ap011 (abses_es_direct_sum 1) rE rF). - + intros E E' F F' rE rF. - exists (functor_ab_biprod rE.1 rF.1). - refine (_, _). - * exact (transport - (abses_es_rel n0.+1 (abses_es_direct_sum n0.+1 (fst E.2) (fst F.2))) - (abses_es_directsum_pullback n0.+1 rE.1 rF.1 (fst E'.2) (fst F'.2)) - (IH E.1 A F.1 A' (fst E.2) (abses_es_pullback n0.+1 rE.1 (fst E'.2)) - (fst F.2) (abses_es_pullback n0.+1 rF.1 (fst F'.2)) - (fst rE.2) (fst rF.2))). - * exact (abses_directsum_distributive_pushouts rE.1 rF.1 - @ ap011 abses_direct_sum (snd rE.2) (snd rF.2)). - Defined. - - (** Swapping the two summands of a direct sum is, up to the relation, the - same as conjugating by [direct_sum_swap] on both ends. In degrees at - least two the intermediate modules differ, so this is a relation rather - than an equality. *) - Definition abses_es_directsum_swap (n : nat) - : forall {B A B' A' : AbGroup@{u}} (E : abses_es n B A) (F : abses_es n B' A'), - abses_es_rel n (abses_es_direct_sum n E F) - (abses_es_pushout n direct_sum_swap - (abses_es_pullback n direct_sum_swap (abses_es_direct_sum n F E))). - Proof. - induction n as [|n1 IH]; intros B A B' A'. - - intros E F; apply equiv_path_grouphomomorphism; reflexivity. - - destruct n1 as [|n0]. - + intros E F. - transitivity (abses_pushout grp_homo_id (abses_direct_sum E F)). - 1: exact (abses_pushout_id _)^. - transitivity (abses_pushout (grp_homo_compose direct_sum_swap direct_sum_swap) - (abses_direct_sum E F)). - { napply (ap (fun h => abses_pushout h (abses_direct_sum E F))). - symmetry; apply equiv_path_grouphomomorphism; reflexivity. } - refine (abses_pushout_compose direct_sum_swap direct_sum_swap _ @ _). - exact (ap (abses_pushout direct_sum_swap) - (abses_pushout_is_pullback (abses_swap_morphism E F))). - + intros E F. - exists direct_sum_swap. - refine (_, _). - * exact (transport - (abses_es_rel n0.+1 (abses_es_direct_sum n0.+1 (fst E.2) (fst F.2))) - (abses_es_pushout_pullback n0.+1 direct_sum_swap direct_sum_swap - (abses_es_direct_sum n0.+1 (fst F.2) (fst E.2))) - (IH E.1 A F.1 A' (fst E.2) (fst F.2))). - * exact (abses_pushout_is_pullback (abses_swap_morphism (snd E.2) (snd F.2))). - Defined. - - (** The triple direct sum, twisted by [ab_biprod_twist], is the conjugate of - the reversed triple sum; the analog of [abses_es_directsum_swap] used for - associativity. *) - Definition abses_es_directsum_twist (n : nat) - : forall {B1 A1 B2 A2 B3 A3 : AbGroup@{u}} - (E : abses_es n B1 A1) (F : abses_es n B2 A2) (G : abses_es n B3 A3), - abses_es_rel n (abses_es_direct_sum n (abses_es_direct_sum n E F) G) - (abses_es_pushout n ab_biprod_twist - (abses_es_pullback n ab_biprod_twist - (abses_es_direct_sum n (abses_es_direct_sum n G F) E))). - Proof. - induction n as [|n1 IH]; intros B1 A1 B2 A2 B3 A3. - - intros E F G; apply equiv_path_grouphomomorphism; reflexivity. - - destruct n1 as [|n0]. - + intros E F G. - transitivity (abses_pushout grp_homo_id - (abses_direct_sum (abses_direct_sum E F) G)). - 1: exact (abses_pushout_id _)^. - transitivity (abses_pushout (grp_homo_compose ab_biprod_twist ab_biprod_twist) - (abses_direct_sum (abses_direct_sum E F) G)). - { napply (ap (fun h => abses_pushout h - (abses_direct_sum (abses_direct_sum E F) G))). - symmetry; apply equiv_path_grouphomomorphism; reflexivity. } - refine (abses_pushout_compose ab_biprod_twist ab_biprod_twist _ @ _). - exact (ap (abses_pushout ab_biprod_twist) - (abses_pushout_is_pullback (abses_twist_directsum' E F G))). - + intros E F G. - exists ab_biprod_twist. - refine (_, _). - * exact (transport - (abses_es_rel n0.+1 (abses_es_direct_sum n0.+1 - (abses_es_direct_sum n0.+1 (fst E.2) (fst F.2)) (fst G.2))) - (abses_es_pushout_pullback n0.+1 ab_biprod_twist ab_biprod_twist - (abses_es_direct_sum n0.+1 - (abses_es_direct_sum n0.+1 (fst G.2) (fst F.2)) (fst E.2))) - (IH E.1 A1 F.1 A2 G.1 A3 (fst E.2) (fst F.2) (fst G.2))). - * exact (abses_pushout_is_pullback - (abses_twist_directsum' (snd E.2) (snd F.2) (snd G.2))). - Defined. - - (** The Baer sum respects the relation in both arguments, since each of its - three constituent operations does. *) - Definition abses_es_baer_sum_rel (n : nat) {B A : AbGroup@{u}} - {E E' F F' : abses_es n B A} - (rE : abses_es_rel n E E') (rF : abses_es_rel n F F') - : abses_es_rel n (abses_es_baer_sum n E F) (abses_es_baer_sum n E' F') - := abses_es_rel_pullback n ab_diagonal _ _ - (abses_es_rel_pushout n ab_codiagonal _ _ _ - (abses_es_direct_sum_rel n E E' F F' rE rF)). - - (** The Baer sum is commutative: the swap-conjugation relation is carried - by the codiagonal pushout and diagonal pullback, which absorb the swap - on each end. *) - Definition abses_es_baer_sum_comm (n : nat) {B A : AbGroup@{u}} - (E F : abses_es n B A) - : abses_es_rel n (abses_es_baer_sum n E F) (abses_es_baer_sum n F E). - Proof. - snrefine (transport (abses_es_rel n (abses_es_baer_sum n E F)) _ - (abses_es_rel_pullback n ab_diagonal _ _ - (abses_es_rel_pushout n ab_codiagonal _ _ _ - (abses_es_directsum_swap n E F)))). - unfold abses_es_baer_sum. - transitivity (abses_es_pullback n ab_diagonal - (abses_es_pushout n ab_codiagonal - (abses_es_pullback n direct_sum_swap (abses_es_direct_sum n F E)))). - { napply (ap (abses_es_pullback n ab_diagonal)). - refine ((abses_es_pushout_compose n direct_sum_swap ab_codiagonal _ _)^ @ _). - napply (ap (fun h => abses_es_pushout n h - (abses_es_pullback n direct_sum_swap (abses_es_direct_sum n F E)))). - exact ab_codiagonal_swap. } - transitivity (abses_es_pullback n ab_diagonal - (abses_es_pullback n direct_sum_swap - (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n F E)))). - { napply (ap (abses_es_pullback n ab_diagonal)). - exact (abses_es_pushout_pullback n ab_codiagonal direct_sum_swap - (abses_es_direct_sum n F E)). } - exact (abses_es_pullback_compose n ab_diagonal direct_sum_swap - (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n F E)))^. - Defined. - - (** The trinary Baer sum is symmetric under reversing the outer summands, - by the same argument as commutativity with [ab_biprod_twist] in place of - [direct_sum_swap]. *) - Definition abses_es_trinary_twist (n : nat) {B A : AbGroup@{u}} - (E F G : abses_es n B A) - : abses_es_rel n (abses_es_trinary_baer_sum n E F G) - (abses_es_trinary_baer_sum n G F E). - Proof. - snrefine (transport (abses_es_rel n (abses_es_trinary_baer_sum n E F G)) _ - (abses_es_rel_pullback n ab_triagonal _ _ - (abses_es_rel_pushout n ab_cotriagonal _ _ _ - (abses_es_directsum_twist n E F G)))). - unfold abses_es_trinary_baer_sum. - transitivity (abses_es_pullback n ab_triagonal - (abses_es_pushout n ab_cotriagonal - (abses_es_pullback n ab_biprod_twist - (abses_es_direct_sum n (abses_es_direct_sum n G F) E)))). - { napply (ap (abses_es_pullback n ab_triagonal)). - refine ((abses_es_pushout_compose n ab_biprod_twist ab_cotriagonal _ _)^ @ _). - napply (ap (fun h => abses_es_pushout n h - (abses_es_pullback n ab_biprod_twist - (abses_es_direct_sum n (abses_es_direct_sum n G F) E)))). - exact ab_cotriagonal_twist. } - transitivity (abses_es_pullback n ab_triagonal - (abses_es_pullback n ab_biprod_twist - (abses_es_pushout n ab_cotriagonal - (abses_es_direct_sum n (abses_es_direct_sum n G F) E)))). - { napply (ap (abses_es_pullback n ab_triagonal)). - exact (abses_es_pushout_pullback n ab_cotriagonal ab_biprod_twist - (abses_es_direct_sum n (abses_es_direct_sum n G F) E)). } - exact (abses_es_pullback_compose n ab_triagonal ab_biprod_twist - (abses_es_pushout n ab_cotriagonal - (abses_es_direct_sum n (abses_es_direct_sum n G F) E)))^. - Defined. - - (** The left-associated Baer sum equals the trinary Baer sum: move the inner - diagonal and codiagonal out through the outer direct sum, then combine - with the outer ones into the triagonal and cotriagonal. *) - Definition abses_es_baer_sum_is_trinary (n : nat) {B A : AbGroup@{u}} - (E F G : abses_es n B A) - : abses_es_baer_sum n (abses_es_baer_sum n E F) G - = abses_es_trinary_baer_sum n E F G. - Proof. - unfold abses_es_baer_sum, abses_es_trinary_baer_sum. - transitivity (abses_es_pullback n ab_diagonal - (abses_es_pushout n ab_codiagonal - (abses_es_pullback n (functor_ab_biprod ab_diagonal grp_homo_id) - (abses_es_pushout n (functor_ab_biprod ab_codiagonal grp_homo_id) - (abses_es_direct_sum n (abses_es_direct_sum n E F) G))))). - { napply (ap (fun z => abses_es_pullback n ab_diagonal - (abses_es_pushout n ab_codiagonal z))). - transitivity (abses_es_direct_sum n - (abses_es_pullback n ab_diagonal - (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F))) - (abses_es_pullback n grp_homo_id G)). - 1: exact (ap (abses_es_direct_sum n _) (abses_es_pullback_id n G)^). - transitivity (abses_es_pullback n (functor_ab_biprod ab_diagonal grp_homo_id) - (abses_es_direct_sum n - (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F)) G)). - 1: exact (abses_es_directsum_pullback n ab_diagonal grp_homo_id _ G). - napply (ap (abses_es_pullback n (functor_ab_biprod ab_diagonal grp_homo_id))). - transitivity (abses_es_direct_sum n - (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F)) - (abses_es_pushout n grp_homo_id G)). - 1: exact (ap (abses_es_direct_sum n _) (abses_es_pushout_id n G)^). - exact (abses_es_directsum_pushout n ab_codiagonal grp_homo_id _ G)^. } - transitivity (abses_es_pullback n ab_diagonal - (abses_es_pullback n (functor_ab_biprod ab_diagonal grp_homo_id) - (abses_es_pushout n ab_codiagonal - (abses_es_pushout n (functor_ab_biprod ab_codiagonal grp_homo_id) - (abses_es_direct_sum n (abses_es_direct_sum n E F) G))))). - { napply (ap (abses_es_pullback n ab_diagonal)). - exact (abses_es_pushout_pullback n ab_codiagonal - (functor_ab_biprod ab_diagonal grp_homo_id) - (abses_es_pushout n (functor_ab_biprod ab_codiagonal grp_homo_id) - (abses_es_direct_sum n (abses_es_direct_sum n E F) G))). } - refine ((abses_es_pullback_compose n ab_diagonal - (functor_ab_biprod ab_diagonal grp_homo_id) _)^ @ _). - napply (ap (abses_es_pullback n ab_triagonal)). - exact (abses_es_pushout_compose n (functor_ab_biprod ab_codiagonal grp_homo_id) - ab_codiagonal _ (abses_es_direct_sum n (abses_es_direct_sum n E F) G))^. - Defined. - - (** Twisting the order of a left-associated triple Baer sum, via the trinary - form. *) - Definition abses_es_baer_sum_twist (n : nat) {B A : AbGroup@{u}} - (E F G : abses_es n B A) - : abses_es_rel n (abses_es_baer_sum n (abses_es_baer_sum n E F) G) - (abses_es_baer_sum n (abses_es_baer_sum n G F) E) - := transport (fun p => abses_es_rel n p - (abses_es_baer_sum n (abses_es_baer_sum n G F) E)) - (abses_es_baer_sum_is_trinary n E F G)^ - (transport (abses_es_rel n (abses_es_trinary_baer_sum n E F G)) - (abses_es_baer_sum_is_trinary n G F E)^ - (abses_es_trinary_twist n E F G)). - - (** The Baer sum is associative, by combining the twist with commutativity. *) - Definition abses_es_baer_sum_assoc (n : nat) {B A : AbGroup@{u}} - (E F G : abses_es n B A) - : abses_es_rel n (abses_es_baer_sum n (abses_es_baer_sum n E F) G) - (abses_es_baer_sum n E (abses_es_baer_sum n F G)). - Proof. - refine (abses_es_rel_trans n _ _ _ (abses_es_baer_sum_twist n E F G) _). - refine (abses_es_rel_trans n _ _ _ - (abses_es_baer_sum_comm n (abses_es_baer_sum n G F) E) _). - exact (abses_es_baer_sum_rel n (abses_es_rel_refl n E) - (abses_es_baer_sum_comm n G F)). - Defined. - - (** Adding the split zero sequence on the deep end and projecting away the - trivial factor recovers the original, up to reindexing the base. This is - the engine of the unit law; the leading sequence uses [abses_absorb_trivial] - and the trailing sequence recurses. *) - Definition abses_es_absorb_zero (m : nat) {A : AbGroup@{u}} - : forall {C : AbGroup@{u}} (X : abses_es m C A), - abses_es_rel m - (abses_es_pushout m ab_codiagonal - (abses_es_direct_sum m X (@abses_es_zero _ m A abgroup_trivial))) - (abses_es_pullback m ab_biprod_pr1 X). - Proof. - induction m as [|m1 IH]; intros C X. - - apply equiv_path_grouphomomorphism; intro x; cbn; apply grp_unit_r. - - destruct m1 as [|m0]. - + exact (abses_absorb_trivial X). - + exists ab_biprod_pr1. - refine (IH X.1 (fst X.2), _). - pose (cst := @grp_homo_const abgroup_trivial X.1). - transitivity (abses_pushout (ab_codiagonal $o functor_ab_biprod grp_homo_id cst) - (abses_direct_sum (snd X.2) - (point (AbSES abgroup_trivial abgroup_trivial)))). - { napply (ap (fun h => abses_pushout h - (abses_direct_sum (snd X.2) - (point (AbSES abgroup_trivial abgroup_trivial))))). - apply equiv_path_grouphomomorphism; intro x; cbn; symmetry; apply grp_unit_r. } - transitivity (abses_pushout ab_codiagonal - (abses_pushout (functor_ab_biprod grp_homo_id cst) - (abses_direct_sum (snd X.2) - (point (AbSES abgroup_trivial abgroup_trivial))))). - 1: exact (abses_pushout_compose _ _ _). - transitivity (abses_pushout ab_codiagonal - (abses_direct_sum (abses_pushout grp_homo_id (snd X.2)) - (abses_pushout cst - (point (AbSES abgroup_trivial abgroup_trivial))))). - 1: napply (ap (abses_pushout ab_codiagonal)); - exact (abses_directsum_distributive_pushouts _ _). - transitivity (abses_pushout ab_codiagonal - (abses_direct_sum (snd X.2) - (point (AbSES abgroup_trivial X.1)))). - { napply (ap (abses_pushout ab_codiagonal)). - napply (ap011 abses_direct_sum). - - exact (abses_pushout_id _). - - exact (abses_pushout_const _). } - exact (abses_absorb_trivial (snd X.2)). - Defined. - - (** The split sequence is a right unit for the Baer sum: the trailing - sequence is handled by [abses_es_absorb_zero] and the leading one by the - degree-one unit law. *) - Definition abses_es_baer_sum_unit (n : nat) {B A : AbGroup@{u}} - (E : abses_es n B A) - : abses_es_rel n (abses_es_baer_sum n E (abses_es_zero n)) E. - Proof. - destruct n as [|[|n0]]. - - apply equiv_path_grouphomomorphism; intro x; cbn; apply grp_unit_r. - - exact (baer_sum_unit_r E). - - exists ab_biprod_pr1. - refine (abses_es_absorb_zero n0.+1 (fst E.2), _). - pose (cst := @grp_homo_const abgroup_trivial E.1). - transitivity (abses_pullback ab_diagonal - (abses_pushout ab_biprod_pr1 - (abses_direct_sum (snd E.2) (point (AbSES B abgroup_trivial))))). - 1: exact (abses_pushout_pullback_reorder _ _ _). - transitivity (abses_pullback ab_diagonal - (abses_pushout (ab_codiagonal $o functor_ab_biprod grp_homo_id cst) - (abses_direct_sum (snd E.2) (point (AbSES B abgroup_trivial))))). - { napply (ap (fun h => abses_pullback ab_diagonal - (abses_pushout h - (abses_direct_sum (snd E.2) (point (AbSES B abgroup_trivial)))))). - apply equiv_path_grouphomomorphism; intro x; cbn; symmetry; apply grp_unit_r. } - transitivity (abses_pullback ab_diagonal - (abses_pushout ab_codiagonal - (abses_pushout (functor_ab_biprod grp_homo_id cst) - (abses_direct_sum (snd E.2) - (point (AbSES B abgroup_trivial)))))). - 1: napply (ap (abses_pullback ab_diagonal)); exact (abses_pushout_compose _ _ _). - transitivity (abses_pullback ab_diagonal - (abses_pushout ab_codiagonal - (abses_direct_sum (abses_pushout grp_homo_id (snd E.2)) - (abses_pushout cst (point (AbSES B abgroup_trivial)))))). - 1: napply (ap (fun s => abses_pullback ab_diagonal (abses_pushout ab_codiagonal s))); - exact (abses_directsum_distributive_pushouts _ _). - transitivity (abses_pullback ab_diagonal - (abses_pushout ab_codiagonal - (abses_direct_sum (snd E.2) (point (AbSES B E.1))))). - { napply (ap (fun s => abses_pullback ab_diagonal (abses_pushout ab_codiagonal s))); - napply (ap011 abses_direct_sum); - [ exact (abses_pushout_id _) | exact (abses_pushout_const _) ]. } - exact (baer_sum_unit_r (snd E.2)). - Defined. - - (** Pushing a sequence out along the zero map gives the split sequence: the - leading sequence becomes split and the trailing sequence recurses. *) - Definition abses_es_zero_absorb (m : nat) {A A' : AbGroup@{u}} - : forall {C : AbGroup@{u}} (X : abses_es m C A), - abses_es_rel m (abses_es_pushout m (@grp_homo_const A A') X) - (@abses_es_zero _ m A' C). - Proof. - induction m as [|m1 IH]; intros C X. - - apply equiv_path_grouphomomorphism; reflexivity. - - destruct m1 as [|m0]. - + exact (abses_pushout_const X). - + exists grp_homo_const. - refine (transport - (abses_es_rel m0.+1 - (abses_es_pushout m0.+1 (@grp_homo_const A A') (fst X.2))) - (@abses_es_pullback_zero _ m0.+1 A' X.1)^ - (IH X.1 (fst X.2)), _). - exact (abses_pushout_const (snd X.2)). - Defined. - - (** Pushing out along the diagonal of the deep end agrees, up to the - relation, with pulling the self-direct-sum back along the diagonal of the - base; the length-[n] analogue of [abses_pushout_is_pullback] for the - diagonal morphism. *) - Definition abses_es_diagonal_is_pullback (n : nat) - : forall {B A : AbGroup@{u}} (E : abses_es n B A), - abses_es_rel n (abses_es_pushout n ab_diagonal E) - (abses_es_pullback n ab_diagonal (abses_es_direct_sum n E E)). - Proof. - induction n as [|n1 IH]; intros B A E. - - apply equiv_path_grouphomomorphism; reflexivity. - - destruct n1 as [|n0]. - + exact (abses_pushout_is_pullback (abses_diagonal E)). - + exists ab_diagonal. - refine (IH E.1 A (fst E.2), _). - exact (abses_pushout_is_pullback (abses_diagonal (snd E.2))). - Defined. - - (** The Baer sum of [E] with its negation [pushout (-id) E] is related to the - split sequence: feeding the diagonal lemma through [phi = a - a'] turns it - into [pushout 0 E], which the zero-absorb lemma sends to the split. *) - Definition abses_es_baer_sum_inv (n : nat) {B A : AbGroup@{u}} - (E : abses_es n B A) - : abses_es_rel n (abses_es_pushout n grp_homo_const E) - (abses_es_baer_sum n E (abses_es_pushout n ab_homo_negation E)). - Proof. - pose (phi := ab_codiagonal $o functor_ab_biprod grp_homo_id (ab_homo_negation : A $-> A)). - assert (eq1 : abses_es_pushout n grp_homo_const E - = abses_es_pushout n phi (abses_es_pushout n ab_diagonal E)). - { transitivity (abses_es_pushout n (phi $o ab_diagonal) E). - - napply (ap (fun h => abses_es_pushout n h E)). - apply equiv_path_grouphomomorphism; intro a; cbn; symmetry; apply grp_inv_r. - - exact (abses_es_pushout_compose n ab_diagonal phi B E). } - assert (eq2 : abses_es_pushout n phi - (abses_es_pullback n ab_diagonal (abses_es_direct_sum n E E)) - = abses_es_baer_sum n E (abses_es_pushout n ab_homo_negation E)). - { unfold abses_es_baer_sum. - transitivity (abses_es_pullback n ab_diagonal - (abses_es_pushout n phi (abses_es_direct_sum n E E))). - 1: exact (abses_es_pushout_pullback n phi ab_diagonal (abses_es_direct_sum n E E)). - napply (ap (abses_es_pullback n ab_diagonal)). - transitivity (abses_es_pushout n ab_codiagonal - (abses_es_pushout n (functor_ab_biprod grp_homo_id (ab_homo_negation : A $-> A)) - (abses_es_direct_sum n E E))). - 1: exact (abses_es_pushout_compose n - (functor_ab_biprod grp_homo_id (ab_homo_negation : A $-> A)) ab_codiagonal - (ab_biprod B B) (abses_es_direct_sum n E E)). - napply (ap (abses_es_pushout n ab_codiagonal)). - transitivity (abses_es_direct_sum n (abses_es_pushout n grp_homo_id E) - (abses_es_pushout n ab_homo_negation E)). - 1: exact (abses_es_directsum_pushout n grp_homo_id (ab_homo_negation : A $-> A) E E). - napply (ap (fun s => abses_es_direct_sum n s - (abses_es_pushout n ab_homo_negation E))). - exact (abses_es_pushout_id n E). } - exact (transport (abses_es_rel n (abses_es_pushout n grp_homo_const E)) eq2 - (transport (fun X => abses_es_rel n X - (abses_es_pushout n phi - (abses_es_pullback n ab_diagonal (abses_es_direct_sum n E E)))) - eq1^ - (abses_es_rel_pushout n phi B _ _ - (abses_es_diagonal_is_pullback n E)))). - Defined. - - (** The deep-end splice respects the relation, so the connecting map is - well-defined on Ext. *) - Definition abses_es_dsplice_rel (n : nat) {A A'' : AbGroup@{u}} - (xi : AbSES A'' A) (B : AbGroup@{u}) - : forall e e' : abses_es n B A'', abses_es_rel n e e' - -> abses_es_rel n.+1 (abses_es_dsplice n xi e) (abses_es_dsplice n xi e'). - Proof. - revert B; induction n as [|n1 IH]; intro B. - - intros e e' r; exact (ap (fun f => abses_pullback f xi) r). - - destruct n1 as [|n0]. - + intros e e' r. - exact (transport (abses_es_rel 2 (abses_es_dsplice 1 xi e)) - (ap (abses_es_dsplice 1 xi) r) - (abses_es_rel_refl 2 (abses_es_dsplice 1 xi e))). - + intros e e' r. - exists r.1. - refine (transport (abses_es_rel n0.+2 (abses_es_dsplice n0.+1 xi (fst e.2))) - (abses_es_dsplice_pullback n0.+1 xi r.1 (fst e'.2)) - (IH e.1 (fst e.2) (abses_es_pullback n0.+1 r.1 (fst e'.2)) (fst r.2)), - snd r.2). - Defined. - - (** The junction identity for the connecting map: splicing the pullback - [abses_pullback g zeta] onto [W] is related to splicing [zeta] onto [W] - after pushing the deep end out along [g]. At the deepest level this is - the pushout-pullback adjunction [abses_pushout_is_pullback]; for the base - case it is the composition of pullbacks; deeper levels recurse with the - identity. *) - Definition abses_es_dsplice_pushout_rel (n : nat) {A C D : AbGroup@{u}} - (zeta : AbSES C A) (g : D $-> C) - : forall {B : AbGroup@{u}} (W : abses_es n B D), - abses_es_rel n.+1 - (abses_es_dsplice n (abses_pullback g zeta) W) - (abses_es_dsplice n zeta (abses_es_pushout n g W)). - Proof. - induction n as [|n1 IH]; intro B. - - exact (fun W => abses_pullback_compose W g zeta). - - destruct n1 as [|n0]. - + intro W. - exists g. - exact (idpath, idpath). - + intro W. - exists grp_homo_id. - exact (transport - (abses_es_rel n0.+2 - (abses_es_dsplice n0.+1 (abses_pullback g zeta) (fst W.2))) - (abses_es_pullback_id n0.+2 - (abses_es_dsplice n0.+1 zeta (abses_es_pushout n0.+1 g (fst W.2))))^ - (IH W.1 (fst W.2)), - abses_pushout_id (snd W.2)). - Defined. - - (** Splicing the split short exact sequence onto the deep end gives the zero - sequence: the spliced [pt] becomes split and the recursion proceeds as in - [abses_es_zero_absorb]. *) - Definition abses_es_dsplice_point (n : nat) {A A'' : AbGroup@{u}} - : forall {B : AbGroup@{u}} (X : abses_es n B A''), - abses_es_rel n.+1 (abses_es_dsplice n (point (AbSES A'' A)) X) - (@abses_es_zero _ n.+1 A B). - Proof. - induction n as [|n1 IH]; intros B X. - - exact (abses_pullback_point X). - - destruct n1 as [|n0]. - + exists grp_homo_const. - exact ((abses_pullback_point _)^, abses_pushout_const X). - + exists grp_homo_const. - refine (transport - (abses_es_rel n0.+2 - (abses_es_dsplice n0.+1 (point (AbSES A'' A)) (fst X.2))) - (@abses_es_pullback_zero _ n0.+2 A X.1)^ - (IH X.1 (fst X.2)), _). - exact (abses_pushout_const (snd X.2)). - Defined. - - (** Splicing a fixed short exact sequence onto the front respects the - relation in the trailing sequence, witnessed by the identity. *) - Definition abses_es_splice_rel {A C : AbGroup@{u}} (m : nat) - {B : AbGroup@{u}} (s : AbSES B C) {E E' : abses_es m C A} - (r : abses_es_rel m E E') - : abses_es_rel m.+1 (abses_es_splice m E s) (abses_es_splice m E' s). - Proof. - destruct m as [|m0]. - - exact (ap (fun f => abses_pushout f s) r). - - exists grp_homo_id. - exact (transport (abses_es_rel m0.+1 E) - (abses_es_pullback_id m0.+1 E')^ r, - abses_pushout_id s). - Defined. - - (** The base splice is additive: it carries the Baer sum to the Baer sum, so - the contravariant connecting map is a homomorphism. Since the base splice - merely prepends [xi] (no recursion), the witness for [n >= 1] is the - diagonal, with the trailing reflexive and the leading short exact sequence - handled by [abses_pushout_is_pullback (abses_diagonal xi)]. In degree zero - it is the distributivity of the Baer sum over pushouts. *) - Definition abses_es_splice_baer_sum (n : nat) {A B' B'' : AbGroup@{u}} - (xi : AbSES B'' B') (E F : abses_es n B' A) - : abses_es_rel n.+1 (abses_es_splice n (abses_es_baer_sum n E F) xi) - (abses_es_baer_sum n.+1 (abses_es_splice n E xi) (abses_es_splice n F xi)). - Proof. - destruct n as [|n0]. - - change (abses_pushout (abses_es_baer_sum 0 E F) xi - = abses_baer_sum (abses_pushout E xi) (abses_pushout F xi)). - refine (_ @ baer_sum_distributive_pushouts (E:=xi) E F). - napply (ap (fun h => abses_pushout h xi)). - apply equiv_path_grouphomomorphism; intro b; reflexivity. - - exists ab_diagonal. - exact (abses_es_rel_refl n0.+1 _, abses_pushout_is_pullback (abses_diagonal xi)). - Defined. - - (** Splicing commutes with pullback in the base: the pulled-back base only - meets the leading sequence. *) - Definition abses_es_splice_pullback {A C : AbGroup@{u}} (m : nat) - {B B' : AbGroup@{u}} (beta : B' $-> B) (E : abses_es m C A) (s : AbSES B C) - : abses_es_pullback m.+1 beta (abses_es_splice m E s) - = abses_es_splice m E (abses_pullback beta s). - Proof. - destruct m as [|m0]. - - exact (abses_pushout_pullback_reorder s E beta)^. - - reflexivity. - Defined. - - (** Splicing commutes with pushout in the deep end. *) - Definition abses_es_splice_pushout {C : AbGroup@{u}} (m : nat) - {A A' : AbGroup@{u}} (alpha : A $-> A') {B : AbGroup@{u}} - (E : abses_es m C A) (s : AbSES B C) - : abses_es_pushout m.+1 alpha (abses_es_splice m E s) - = abses_es_splice m (abses_es_pushout m alpha E) s. - Proof. - destruct m as [|m0]. - - exact (abses_pushout_compose E alpha s)^. - - reflexivity. - Defined. - - (** The direct sum of two base-splices is the base-splice of the direct - sums. *) - Definition abses_es_directsum_splice (m : nat) - {A C A' C' B B' : AbGroup@{u}} (s : AbSES B C) (t : AbSES B' C') - (X : abses_es m C A) (Y : abses_es m C' A') - : abses_es_direct_sum m.+1 (abses_es_splice m X s) (abses_es_splice m Y t) - = abses_es_splice m (abses_es_direct_sum m X Y) (abses_direct_sum s t). - Proof. - destruct m as [|m0]. - - exact (abses_directsum_distributive_pushouts X Y)^. - - reflexivity. - Defined. - - (** The junction identity for the base splice: splicing the pullback - [pullback g X] onto [s] is related to splicing [X] onto [s] pushed out - along [g]. As the base splice merely prepends, this is a single - relation witnessed by [g]. *) - Definition abses_es_splice_pushout_rel {A C C' : AbGroup@{u}} (m : nat) - (g : C' $-> C) {B : AbGroup@{u}} (s : AbSES B C') (X : abses_es m C A) - : abses_es_rel m.+1 (abses_es_splice m (abses_es_pullback m g X) s) - (abses_es_splice m X (abses_pushout g s)). - Proof. - destruct m as [|m0]. - - exact (abses_pushout_compose g X s). - - exists g. - exact (abses_es_rel_refl m0.+1 _, idpath). - Defined. - - (** The length-[n] analogue of [abses_pushout_is_pullback] for the - codiagonal: pushing the self-direct-sum out along the deep codiagonal - agrees, up to the relation, with pulling back along the base - codiagonal. *) - Definition abses_es_codiagonal_is_pullback (n : nat) - : forall {B A : AbGroup@{u}} (E : abses_es n B A), - abses_es_rel n (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E E)) - (abses_es_pullback n ab_codiagonal E). - Proof. - induction n as [|n1 IH]; intros B A E. - - apply equiv_path_grouphomomorphism; intro x; exact (grp_homo_op E _ _)^. - - destruct n1 as [|n0]. - + exact (abses_pushout_is_pullback (abses_codiagonal E)). - + exists ab_codiagonal. - exact (IH E.1 A (fst E.2), - abses_pushout_is_pullback (abses_codiagonal (snd E.2))). - Defined. - -End Relation. - -(** ** The higher Ext groups *) - -Section HigherExt. - Context `{Univalence}. - - (** The set-quotient of a type by its path relation is its 0-truncation. *) - Definition equiv_quotient_paths_tr (X : Type@{u}) - : Quotient (fun x y : X => x = y) <~> Tr 0 X. - Proof. - srapply equiv_adjointify. - - srapply Quotient_rec. - + exact tr. - + intros x y p; exact (ap tr p). - - srapply Trunc_rec; exact (class_of _). - - srapply Trunc_ind; intro x; reflexivity. - - srapply Quotient_ind_hprop; intro x; reflexivity. - Defined. - - (** The [n]-th Ext group is the set-quotient of length-[n] exact sequences - by the relation [abses_es_rel]. For [n] at most one this recovers the - set of homomorphisms and the usual [Ext]. *) - Definition abses_ext (n : nat) (B A : AbGroup@{u}) : Type - := Quotient (abses_es_rel n (B:=B) (A:=A)). - - (** In degree zero the relation is equality of homomorphisms, so the - quotient is the group of homomorphisms. *) - Definition equiv_abses_ext_hom (B A : AbGroup@{u}) - : abses_ext 0 B A <~> ab_hom B A - := (@equiv_tr 0 (ab_hom B A) _)^-1%equiv oE equiv_quotient_paths_tr _. - - (** In degree one the relation is equality of short exact sequences, so the - quotient is the usual [Ext]. *) - Definition equiv_abses_ext_one (B A : AbGroup@{u}) - : abses_ext 1 B A <~> Ext B A - := equiv_quotient_paths_tr _. - - (** Pullback descends to the quotient, making [abses_ext n -- A] a - contravariant functor. *) - Definition abses_ext_pullback (n : nat) {A : AbGroup@{u}} - {B B' : AbGroup@{u}} (beta : B' $-> B) - : abses_ext n B A -> abses_ext n B' A - := Quotient_functor _ _ (abses_es_pullback n beta) (abses_es_rel_pullback n beta). - - (** Pullback along the identity is the identity. *) - Definition abses_ext_pullback_id (n : nat) {B A : AbGroup@{u}} - : abses_ext_pullback n (A:=A) (grp_homo_id (G:=B)) == idmap. - Proof. - srapply Quotient_ind_hprop; intro E. - apply (ap (class_of _)), abses_es_pullback_id. - Defined. - - (** Pullback is contravariantly functorial. *) - Definition abses_ext_pullback_compose (n : nat) - {A B0 B1 B2 : AbGroup@{u}} (f : B0 $-> B1) (g : B1 $-> B2) - : abses_ext_pullback n (A:=A) (g $o f) - == abses_ext_pullback n f o abses_ext_pullback n g. - Proof. - srapply Quotient_ind_hprop; intro E. - apply (ap (class_of _)), abses_es_pullback_compose. - Defined. - - (** Pushout descends to the quotient, making [abses_ext n B --] a covariant - functor. *) - Definition abses_ext_pushout (n : nat) {B : AbGroup@{u}} - {A A' : AbGroup@{u}} (alpha : A $-> A') - : abses_ext n B A -> abses_ext n B A' - := Quotient_functor _ _ (abses_es_pushout n alpha) (abses_es_rel_pushout n alpha B). - - (** Pushout along the identity is the identity. *) - Definition abses_ext_pushout_id (n : nat) {B A : AbGroup@{u}} - : abses_ext_pushout n (B:=B) (grp_homo_id (G:=A)) == idmap. - Proof. - srapply Quotient_ind_hprop; intro E. - apply (ap (class_of _)), abses_es_pushout_id. - Defined. - - (** Pushout is covariantly functorial. *) - Definition abses_ext_pushout_compose (n : nat) {B : AbGroup@{u}} - {A0 A1 A2 : AbGroup@{u}} (f : A0 $-> A1) (g : A1 $-> A2) - : abses_ext_pushout n (B:=B) (g $o f) - == abses_ext_pushout n g o abses_ext_pushout n f. - Proof. - srapply Quotient_ind_hprop; intro E. - apply (ap (class_of _)), abses_es_pushout_compose. - Defined. - - (** The pushout and pullback actions on Ext commute, so [abses_ext n] is a - bifunctor, contravariant in the base and covariant in the deep end. *) - Definition abses_ext_pushout_pullback (n : nat) - {A A' B B' : AbGroup@{u}} (alpha : A $-> A') (beta : B' $-> B) - : abses_ext_pushout n alpha o abses_ext_pullback n beta - == abses_ext_pullback n beta o abses_ext_pushout n alpha. - Proof. - srapply Quotient_ind_hprop; intro E. - apply (ap (class_of _)), abses_es_pushout_pullback. - Defined. - - (** Splicing a fixed short exact sequence descends to a map of Ext groups, - raising the degree. *) - Definition abses_ext_splice {A C : AbGroup@{u}} (m : nat) - {B : AbGroup@{u}} (s : AbSES B C) - : abses_ext m C A -> abses_ext m.+1 B A - := Quotient_functor _ _ (fun E => abses_es_splice m E s) - (fun E E' => abses_es_splice_rel m s (E:=E) (E':=E')). - - (** The splice depends only on the class of the short exact sequence in - [Ext], since the target is a set. This is the Yoneda product - [Ext B C -> Ext^m C A -> Ext^{m+1} B A]. *) - Definition abses_ext_yoneda {A C : AbGroup@{u}} (m : nat) - {B : AbGroup@{u}} (t : Ext B C) - : abses_ext m C A -> abses_ext m.+1 B A - := fun x => Trunc_rec (fun s => abses_ext_splice m s x) t. - - (** On a represented class it computes to the underlying splice. *) - Definition abses_ext_yoneda_tr {A C : AbGroup@{u}} (m : nat) - {B : AbGroup@{u}} (s : AbSES B C) (x : abses_ext m C A) - : abses_ext_yoneda m (tr s) x = abses_ext_splice m s x - := idpath. - - (** The connecting map of the long exact sequence: a short exact sequence - [xi : AbSES A'' A] of coefficients raises the degree, [Ext^n B A'' -> - Ext^{n+1} B A]. *) - Definition abses_ext_dsplice (n : nat) {A A'' : AbGroup@{u}} (xi : AbSES A'' A) - {B : AbGroup@{u}} - : abses_ext n B A'' -> abses_ext n.+1 B A - := Quotient_functor _ _ (abses_es_dsplice n xi) (abses_es_dsplice_rel n xi B). - - (** The connecting map is natural in the deep coefficient: pushing out along - [alpha] after splicing [xi] is splicing the pushed-out sequence. *) - Definition abses_ext_dsplice_pushout (n : nat) {A A2 A'' : AbGroup@{u}} - (xi : AbSES A'' A) (alpha : A $-> A2) {B : AbGroup@{u}} - (x : abses_ext n B A'') - : abses_ext_pushout n.+1 alpha (abses_ext_dsplice n xi x) - = abses_ext_dsplice n (abses_pushout alpha xi) x. - Proof. - revert x; srapply Quotient_ind_hprop; intro Y. - exact (ap (class_of _) (abses_es_dsplice_pushout n xi alpha Y)). - Defined. - - (** The connecting map is natural in the base: splicing [xi] commutes with - pullback along [beta]. *) - Definition abses_ext_dsplice_pullback (n : nat) {A A'' : AbGroup@{u}} - (xi : AbSES A'' A) {B B' : AbGroup@{u}} (beta : B' $-> B) - (x : abses_ext n B A'') - : abses_ext_dsplice n xi (abses_ext_pullback n beta x) - = abses_ext_pullback n.+1 beta (abses_ext_dsplice n xi x). - Proof. - revert x; srapply Quotient_ind_hprop; intro Y. - exact (ap (class_of _) (abses_es_dsplice_pullback n xi beta Y)). - Defined. - - (** The Baer sum descends to a binary operation on the [n]-th Ext. *) - Definition abses_ext_baer_sum (n : nat) {B A : AbGroup@{u}} - : abses_ext n B A -> abses_ext n B A -> abses_ext n B A. - Proof. - srapply Quotient_rec2. - - exact (fun E F => class_of _ (abses_es_baer_sum n E F)). - - intros E E' F rE; apply qglue. - exact (abses_es_baer_sum_rel n rE (abses_es_rel_refl n F)). - - intros E F F' rF; apply qglue. - exact (abses_es_baer_sum_rel n (abses_es_rel_refl n E) rF). - Defined. - - (** The connecting map is additive: it carries the Baer sum to the Baer sum, - so the splice [Ext^n B A'' -> Ext^{n+1} B A] is a homomorphism. This is - the bilinearity of the Yoneda splice in the deep-end variable; the only - nontrivial step is the junction identity [abses_es_dsplice_pushout_rel], - after rewriting [abses_pullback ab_codiagonal xi] as a pushout via - [abses_pushout_is_pullback]. *) - Definition abses_ext_dsplice_baer_sum (n : nat) {A A'' : AbGroup@{u}} - (xi : AbSES A'' A) {B : AbGroup@{u}} (x y : abses_ext n B A'') - : abses_ext_dsplice n xi (abses_ext_baer_sum n x y) - = abses_ext_baer_sum n.+1 (abses_ext_dsplice n xi x) (abses_ext_dsplice n xi y). - Proof. - revert x y; srapply Quotient_ind2_hprop; intros E F. - refine (ap (class_of _) - (abses_es_dsplice_pullback n xi ab_diagonal - (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n E F))) @ _). - refine (_ @ (ap (class_of _) - (ap (abses_es_pullback n.+1 ab_diagonal) - (ap (abses_es_pushout n.+1 ab_codiagonal) - (abses_es_directsum_dsplice n xi E F) - @ abses_es_dsplice_pushout n (abses_direct_sum xi xi) - ab_codiagonal (abses_es_direct_sum n E F))))^). - refine (_ @ (ap (class_of _) - (ap (abses_es_pullback n.+1 ab_diagonal) - (ap (fun z => abses_es_dsplice n z (abses_es_direct_sum n E F)) - (abses_pushout_is_pullback (abses_codiagonal xi)))))^). - symmetry; apply qglue. - exact (abses_es_rel_pullback n.+1 ab_diagonal _ _ - (abses_es_dsplice_pushout_rel n xi ab_codiagonal - (abses_es_direct_sum n E F))). - Defined. - - (** The contravariant connecting map (base splice) is additive: it carries the - Baer sum to the Baer sum, so it is a homomorphism [Ext^n B' A -> - Ext^{n+1} B'' A]. *) - Definition abses_ext_splice_baer_sum (n : nat) {A B' B'' : AbGroup@{u}} - (xi : AbSES B'' B') (x y : abses_ext n B' A) - : abses_ext_splice n xi (abses_ext_baer_sum n x y) - = abses_ext_baer_sum n.+1 (abses_ext_splice n xi x) (abses_ext_splice n xi y). - Proof. - revert x y; srapply Quotient_ind2_hprop; intros E F. - exact (qglue (abses_es_splice_baer_sum n xi E F)). - Defined. - - (** The base splice is additive in the short exact sequence slot: it carries - the Baer sum of [s] and [t] to the Baer sum of the splices. Both sides - reduce, via the base-pullback and deep-pushout commutations and the - junction, to a splice of [pullback Delta (direct_sum s t)]; the two deep - arguments [pullback codiagonal X] and [pushout codiagonal (X (+) X)] are - then identified by [abses_es_codiagonal_is_pullback]. *) - Definition abses_ext_splice_baer_sum_ses (n : nat) {A B' B'' : AbGroup@{u}} - (s t : AbSES B'' B') (x : abses_ext n B' A) - : abses_ext_splice n (abses_baer_sum s t) x - = abses_ext_baer_sum n.+1 (abses_ext_splice n s x) (abses_ext_splice n t x). - Proof. - revert x; srapply Quotient_ind_hprop; intro X. - refine (ap (class_of _) (abses_es_splice_pullback n ab_diagonal X - (abses_pushout ab_codiagonal (abses_direct_sum s t)))^ @ _). - refine ((qglue (abses_es_rel_pullback n.+1 ab_diagonal _ _ - (abses_es_splice_pushout_rel n ab_codiagonal - (abses_direct_sum s t) X)))^ @ _). - refine (ap (class_of _) (abses_es_splice_pullback n ab_diagonal - (abses_es_pullback n ab_codiagonal X) (abses_direct_sum s t)) @ _). - refine ((qglue (abses_es_splice_rel n - (abses_pullback ab_diagonal (abses_direct_sum s t)) - (abses_es_codiagonal_is_pullback n X)))^ @ _). - refine (ap (class_of _) (abses_es_splice_pullback n ab_diagonal - (abses_es_pushout n ab_codiagonal (abses_es_direct_sum n X X)) - (abses_direct_sum s t))^ @ _). - refine (ap (class_of _) (ap (abses_es_pullback n.+1 ab_diagonal) - (abses_es_splice_pushout n ab_codiagonal - (abses_es_direct_sum n X X) (abses_direct_sum s t))^) @ _). - exact (ap (class_of _) (ap (abses_es_pullback n.+1 ab_diagonal) - (ap (abses_es_pushout n.+1 ab_codiagonal) - (abses_es_directsum_splice n s t X X)^))). - Defined. - - (** The Baer sum on the [n]-th Ext is commutative. *) - Definition abses_ext_baer_sum_comm (n : nat) {B A : AbGroup@{u}} - (x y : abses_ext n B A) - : abses_ext_baer_sum n x y = abses_ext_baer_sum n y x. - Proof. - revert x y; srapply Quotient_ind2_hprop; intros E F. - exact (qglue (abses_es_baer_sum_comm n E F)). - Defined. - - (** The Baer sum on the [n]-th Ext is associative. *) - Definition abses_ext_baer_sum_assoc (n : nat) {B A : AbGroup@{u}} - (x y z : abses_ext n B A) - : abses_ext_baer_sum n (abses_ext_baer_sum n x y) z - = abses_ext_baer_sum n x (abses_ext_baer_sum n y z). - Proof. - revert x y z. - srapply Quotient_ind_hprop; intro E. - srapply Quotient_ind_hprop; intro F. - srapply Quotient_ind_hprop; intro G. - exact (qglue (abses_es_baer_sum_assoc n E F G)). - Defined. - - (** The class of the split sequence is the neutral element. *) - Definition abses_ext_zero (n : nat) (B A : AbGroup@{u}) : abses_ext n B A - := class_of _ (@abses_es_zero _ n A B). - - (** It is a right and left unit for the Baer sum. *) - Definition abses_ext_baer_sum_unit_r (n : nat) {B A : AbGroup@{u}} - (x : abses_ext n B A) - : abses_ext_baer_sum n x (abses_ext_zero n B A) = x. - Proof. - revert x; srapply Quotient_ind_hprop; intro E. - exact (qglue (abses_es_baer_sum_unit n E)). - Defined. - - Definition abses_ext_baer_sum_unit_l (n : nat) {B A : AbGroup@{u}} - (x : abses_ext n B A) - : abses_ext_baer_sum n (abses_ext_zero n B A) x = x - := abses_ext_baer_sum_comm n _ x @ abses_ext_baer_sum_unit_r n x. - - (** Pushout along negation is an additive inverse for the Baer sum. *) - Definition abses_ext_baer_sum_inv_r (n : nat) {B A : AbGroup@{u}} - (x : abses_ext n B A) - : abses_ext_baer_sum n x (abses_ext_pushout n ab_homo_negation x) - = abses_ext_zero n B A. - Proof. - revert x; srapply Quotient_ind_hprop; intro E. - exact ((qglue (abses_es_baer_sum_inv n E))^ @ qglue (abses_es_zero_absorb n E)). - Defined. - - Definition abses_ext_baer_sum_inv_l (n : nat) {B A : AbGroup@{u}} - (x : abses_ext n B A) - : abses_ext_baer_sum n (abses_ext_pushout n ab_homo_negation x) x - = abses_ext_zero n B A - := abses_ext_baer_sum_comm n _ x @ abses_ext_baer_sum_inv_r n x. - - (** The [n]-th Ext is a group under the Baer sum. *) - Definition grp_abses_ext (n : nat) (B A : AbGroup@{u}) : Group. - Proof. - snapply (Build_Group (abses_ext n B A)). - - exact (abses_ext_baer_sum n). - - exact (abses_ext_zero n B A). - - exact (abses_ext_pushout n ab_homo_negation). - - repeat split. - + exact _. - + intros x y z; symmetry; apply abses_ext_baer_sum_assoc. - + intro x; apply abses_ext_baer_sum_unit_l. - + intro x; apply abses_ext_baer_sum_unit_r. - + intro x; apply abses_ext_baer_sum_inv_l. - + intro x; apply abses_ext_baer_sum_inv_r. - Defined. - - (** In fact it is abelian. *) - Definition ab_abses_ext (n : nat) (B A : AbGroup@{u}) : AbGroup. - Proof. - snapply (Build_AbGroup (grp_abses_ext n B A)). - intros x y; apply abses_ext_baer_sum_comm. - Defined. - - (** Pushout and pullback are group homomorphisms for the Baer sum, so - [ab_abses_ext n] is a bifunctor valued in abelian groups. *) - Definition grp_homo_abses_ext_pushout (n : nat) {B : AbGroup@{u}} - {A A' : AbGroup@{u}} (alpha : A $-> A') - : ab_abses_ext n B A $-> ab_abses_ext n B A'. - Proof. - snapply Build_GroupHomomorphism. - - exact (abses_ext_pushout n alpha). - - intros x y; revert x y. - srapply Quotient_ind2_hprop; intros E F. - exact (ap (class_of _) (abses_es_pushout_baer_sum n alpha E F)). - Defined. - - Definition grp_homo_abses_ext_pullback (n : nat) {A : AbGroup@{u}} - {B B' : AbGroup@{u}} (beta : B' $-> B) - : ab_abses_ext n B A $-> ab_abses_ext n B' A. - Proof. - snapply Build_GroupHomomorphism. - - exact (abses_ext_pullback n beta). - - intros x y; revert x y. - srapply Quotient_ind2_hprop; intros E F. - exact (ap (class_of _) (abses_es_pullback_baer_sum n beta E F)). - Defined. - - (** The connecting map of the long exact sequence, as a homomorphism - [Ext^n B A'' -> Ext^{n+1} B A]. *) - Definition grp_homo_abses_ext_dsplice (n : nat) {A A'' : AbGroup@{u}} - (xi : AbSES A'' A) {B : AbGroup@{u}} - : ab_abses_ext n B A'' $-> ab_abses_ext n.+1 B A. - Proof. - snapply Build_GroupHomomorphism. - - exact (abses_ext_dsplice n xi). - - intros x y; apply abses_ext_dsplice_baer_sum. - Defined. - - (** The contravariant connecting map, as a homomorphism - [Ext^n B' A -> Ext^{n+1} B'' A] from a short exact sequence of bases. *) - Definition grp_homo_abses_ext_splice (n : nat) {A B' B'' : AbGroup@{u}} - (xi : AbSES B'' B') - : ab_abses_ext n B' A $-> ab_abses_ext n.+1 B'' A. - Proof. - snapply Build_GroupHomomorphism. - - exact (abses_ext_splice n xi). - - intros x y; apply abses_ext_splice_baer_sum. - Defined. - - (** Pushing out along the zero map lands in the zero class. *) - Definition abses_ext_pushout_const (n : nat) {B A A' : AbGroup@{u}} - (x : abses_ext n B A) - : abses_ext_pushout n (@grp_homo_const A A') x = abses_ext_zero n B A'. - Proof. - revert x; srapply Quotient_ind_hprop; intro E. - exact (qglue (abses_es_zero_absorb n E)). - Defined. - - (** The covariant Ext sequence of a coefficient short exact sequence is a - complex: pushing out along the inclusion then the projection vanishes. *) - Definition abses_ext_pushout_iscomplex (n : nat) {B A A'' : AbGroup@{u}} - (xi : AbSES A'' A) (x : abses_ext n B A) - : abses_ext_pushout n (projection xi) (abses_ext_pushout n (inclusion xi) x) - = abses_ext_zero n B A''. - Proof. - refine ((abses_ext_pushout_compose n (inclusion xi) (projection xi) x)^ @ _). - refine (_ @ abses_ext_pushout_const n x). - napply (ap (fun h => abses_ext_pushout n h x)). - apply equiv_path_grouphomomorphism; intro a. - pose proof (iscomplex_abses xi) as hc; unfold ExactSequence.IsComplex in hc. - destruct hc as [hc0 hc1]; exact (hc0 a). - Defined. - - (** Splicing the split short exact sequence descends to the zero class. *) - Definition abses_ext_dsplice_point (n : nat) {A A'' : AbGroup@{u}} - {B : AbGroup@{u}} (x : abses_ext n B A'') - : abses_ext_dsplice n (point (AbSES A'' A)) x = abses_ext_zero n.+1 B A. - Proof. - revert x; srapply Quotient_ind_hprop; intro X. - exact (qglue (abses_es_dsplice_point n X)). - Defined. - - (** The junction identity, descended to Ext. *) - Definition abses_ext_dsplice_junction (n : nat) {A C D : AbGroup@{u}} - (zeta : AbSES C A) (g : D $-> C) {B : AbGroup@{u}} (w : abses_ext n B D) - : abses_ext_dsplice n (abses_pullback g zeta) w - = abses_ext_dsplice n zeta (abses_ext_pushout n g w). - Proof. - revert w; srapply Quotient_ind_hprop; intro W. - exact (qglue (abses_es_dsplice_pushout_rel n zeta g W)). - Defined. - - (** The connecting map kills the image of the projection: the covariant Ext - sequence is a complex at [Ext^n B A'']. *) - Definition abses_ext_dsplice_projection_iscomplex (n : nat) - {A A'' : AbGroup@{u}} (xi : AbSES A'' A) {B : AbGroup@{u}} - (x : abses_ext n B xi) - : abses_ext_dsplice n xi (abses_ext_pushout n (projection xi) x) - = abses_ext_zero n.+1 B A. - Proof. - refine ((abses_ext_dsplice_junction n xi (projection xi) x)^ @ _). - refine (ap (fun z => abses_ext_dsplice n z x) (abses_pullback_projection xi)^ @ _). - exact (abses_ext_dsplice_point n x). - Defined. - - (** The image of the connecting map is killed by the inclusion: the covariant - Ext sequence is a complex at [Ext^{n+1} B A]. *) - Definition abses_ext_inclusion_dsplice_iscomplex (n : nat) - {A A'' : AbGroup@{u}} (xi : AbSES A'' A) {B : AbGroup@{u}} - (x : abses_ext n B A'') - : abses_ext_pushout n.+1 (inclusion xi) (abses_ext_dsplice n xi x) - = abses_ext_zero n.+1 B xi. - Proof. - refine (abses_ext_dsplice_pushout n xi (inclusion xi) x @ _). - refine (ap (fun z => abses_ext_dsplice n z x) (abses_pushout_inclusion xi) @ _). - exact (abses_ext_dsplice_point n x). - Defined. - - (** The connecting map is natural in the coefficient short exact sequence: a - morphism [phi : xi -> xi'] gives a commuting square relating the two - connecting maps via pushout along its end components. The proof routes - [abses_pushout_is_pullback phi] through the junction identity. *) - Definition abses_ext_dsplice_natural (n : nat) - {A A' A'' A''' : AbGroup@{u}} {xi : AbSES A'' A} {xi' : AbSES A''' A'} - (phi : AbSESMorphism xi xi') {B : AbGroup@{u}} (x : abses_ext n B A'') - : abses_ext_pushout n.+1 (component1 phi) (abses_ext_dsplice n xi x) - = abses_ext_dsplice n xi' (abses_ext_pushout n (component3 phi) x). - Proof. - refine (abses_ext_dsplice_pushout n xi (component1 phi) x @ _). - refine (ap (fun z => abses_ext_dsplice n z x) (abses_pushout_is_pullback phi) @ _). - exact (abses_ext_dsplice_junction n xi' (component3 phi) x). - Defined. - - (** Base pullback commutes with the base splice, descended to Ext. *) - Definition abses_ext_splice_pullback (n : nat) {A C B B2 : AbGroup@{u}} - (s : AbSES B C) (beta : B2 $-> B) (x : abses_ext n C A) - : abses_ext_pullback n.+1 beta (abses_ext_splice n s x) - = abses_ext_splice n (abses_pullback beta s) x. - Proof. - revert x; srapply Quotient_ind_hprop; intro X. - exact (ap (class_of _) (abses_es_splice_pullback n beta X s)). - Defined. - - (** The junction identity for the base splice, descended to Ext. *) - Definition abses_ext_splice_pullback_junction (n : nat) {A C C' : AbGroup@{u}} - (g : C' $-> C) {B : AbGroup@{u}} (s : AbSES B C') (y : abses_ext n C A) - : abses_ext_splice n s (abses_ext_pullback n g y) - = abses_ext_splice n (abses_pushout g s) y. - Proof. - revert y; srapply Quotient_ind_hprop; intro X. - exact (qglue (abses_es_splice_pushout_rel n g s X)). - Defined. - - (** Splicing the split short exact sequence onto the base is the zero map: - by additivity in the sequence slot the splice [Z] of [point] satisfies - [Z = Z + Z], hence [Z = 0]. *) - Definition abses_ext_splice_point (n : nat) {A B' B'' : AbGroup@{u}} - (x : abses_ext n B' A) - : abses_ext_splice n (point (AbSES B'' B')) x = abses_ext_zero n.+1 B'' A. - Proof. - refine ((grp_cancelL1 (G := ab_abses_ext n.+1 B'' A) - (z := abses_ext_splice n (point (AbSES B'' B')) x))^-1 _). - exact ((abses_ext_splice_baer_sum_ses n (point _) (point _) x)^ - @ ap (fun s => abses_ext_splice n s x) (baer_sum_unit_r (point _))). - Defined. - - (** The contravariant Ext sequence is a complex at [Ext^{n+1} B'' A]: the - connecting map [delta' = splice xi] composed with the projection pullback - vanishes. *) - Definition abses_ext_splice_projection_iscomplex (n : nat) - {A B' B'' : AbGroup@{u}} (xi : AbSES B'' B') (x : abses_ext n B' A) - : abses_ext_pullback n.+1 (projection xi) (abses_ext_splice n xi x) - = abses_ext_zero n.+1 xi A. - Proof. - refine (abses_ext_splice_pullback n xi (projection xi) x @ _). - refine (ap (fun s => abses_ext_splice n s x) (abses_pullback_projection xi)^ @ _). - exact (abses_ext_splice_point n x). - Defined. - - (** The contravariant Ext sequence is a complex at [Ext^n B' A]: the - inclusion pullback followed by the connecting map vanishes. *) - Definition abses_ext_inclusion_splice_iscomplex (n : nat) - {A B' B'' : AbGroup@{u}} (xi : AbSES B'' B') (x : abses_ext n xi A) - : abses_ext_splice n xi (abses_ext_pullback n (inclusion xi) x) - = abses_ext_zero n.+1 B'' A. - Proof. - refine (abses_ext_splice_pullback_junction n (inclusion xi) xi x @ _). - refine (ap (fun s => abses_ext_splice n s x) (abses_pushout_inclusion xi) @ _). - exact (abses_ext_splice_point n x). - Defined. - - (** Pulling back along the zero map lands in the zero class. *) - Definition abses_ext_pullback_const (n : nat) {A B' B'' : AbGroup@{u}} - (x : abses_ext n B'' A) - : abses_ext_pullback n (@grp_homo_const B' B'') x = abses_ext_zero n B' A. - Proof. - destruct n as [|[|n0]]; revert x; srapply Quotient_ind_hprop; intro X. - - apply (ap (class_of _)). - apply equiv_path_grouphomomorphism; intro b; exact (grp_homo_unit X). - - exact (ap (class_of _) (abses_pullback_const X)^). - - refine (ap (class_of _) (ap (fun s => (X.1; (fst X.2, s)) : abses_es n0.+2 B' A) - (abses_pullback_const (snd X.2))^) @ _). - exact (abses_ext_splice_point n0.+1 (class_of _ (fst X.2))). - Defined. - - (** The contravariant Ext sequence is a complex at [Ext^n M A]: the projection - pullback followed by the inclusion pullback vanishes. *) - Definition abses_ext_projection_inclusion_iscomplex (n : nat) - {A B' B'' : AbGroup@{u}} (xi : AbSES B'' B') (x : abses_ext n B'' A) - : abses_ext_pullback n (inclusion xi) (abses_ext_pullback n (projection xi) x) - = abses_ext_zero n B' A. - Proof. - refine ((abses_ext_pullback_compose n (inclusion xi) (projection xi) x)^ @ _). - refine (ap (fun h => abses_ext_pullback n h x) _ @ abses_ext_pullback_const n x). - apply equiv_path_grouphomomorphism; intro a. - pose proof (iscomplex_abses xi) as hc; unfold ExactSequence.IsComplex in hc. - destruct hc as [hc0 hc1]; exact (hc0 a). - Defined. - - (** The contravariant connecting map is natural in the base short exact - sequence: a morphism [phi : xi -> xi'] gives a commuting square relating - the two connecting maps via pullback along its end components. *) - Definition abses_ext_splice_natural (n : nat) - {A B' B'' D' D'' : AbGroup@{u}} {xi : AbSES B'' B'} {xi' : AbSES D'' D'} - (phi : AbSESMorphism xi xi') (x : abses_ext n D' A) - : abses_ext_splice n xi (abses_ext_pullback n (component1 phi) x) - = abses_ext_pullback n.+1 (component3 phi) (abses_ext_splice n xi' x). - Proof. - refine (abses_ext_splice_pullback_junction n (component1 phi) xi x @ _). - refine (ap (fun s => abses_ext_splice n s x) (abses_pushout_is_pullback phi) @ _). - exact (abses_ext_splice_pullback n xi' (component3 phi) x)^. - Defined. - - (** The Yoneda product, as a homomorphism in the second variable: a class - [t : Ext B C] gives a homomorphism [Ext^m C A -> Ext^{m+1} B A]. It is - well-defined on [Ext] because the splice is additive, and the target is a - set of homomorphisms. *) - Definition grp_homo_abses_ext_yoneda {A C : AbGroup@{u}} (m : nat) - {B : AbGroup@{u}} (t : Ext B C) - : ab_abses_ext m C A $-> ab_abses_ext m.+1 B A - := Trunc_rec (fun s => grp_homo_abses_ext_splice m s) t. - - (** If [E] splits after pushing out along [inclusion xi], it is the pullback - of [xi] along some [g : B $-> A'']. *) - Definition abses_inclusion_pushout_exact {A A'' : AbGroup@{u}} - (xi : AbSES A'' A) {B : AbGroup@{u}} (E : AbSES B A) - (h : abses_pushout (inclusion xi) E = point (AbSES B xi)) - : merely { g : ab_hom B A'' & abses_pullback g xi = E }. - Proof. - pose proof (abses_pushout_trivial_factors_inclusion (inclusion xi) E h) - as [phi hphi]. - assert (hkill : forall n : middle E, grp_image (inclusion E) n - -> (projection xi $o phi) n = mon_unit). - { intro n; srapply Trunc_rec; intros [a p]. - refine (ap (projection xi $o phi) p^ @ _). - refine (ap (projection xi) (equiv_path_grouphomomorphism^-1 hphi a)^ @ _). - pose proof (iscomplex_abses xi) as hc; unfold ExactSequence.IsComplex in hc. - destruct hc as [hc0 hc1]; exact (hc0 a). } - pose (g0 := quotient_abgroup_rec (grp_image (inclusion E)) A'' - (projection xi $o phi) hkill). - pose (g := grp_homo_compose g0 - (grp_iso_inverse (abses_cokernel_iso (inclusion E) (projection E)))). - snrefine (tr (g; (abses_pullback_component1_id - (Build_AbSESMorphism grp_homo_id phi g _ _) - (fun _ => idpath))^)). - - exact (equiv_path_grouphomomorphism^-1 hphi). - - intro e. - exact (ap g0 (abses_cokernel_iso_inv_beta (inclusion E) (projection E) e))^. - Defined. - - (** If [v] splits after pulling back along [projection xi], it is the pushout - of [xi] along some [g : B' $-> A]. *) - Definition abses_projection_pullback_exact {A B' B'' : AbGroup@{u}} - (xi : AbSES B'' B') (v : AbSES B'' A) - (h : abses_pullback (projection xi) v = point (AbSES xi A)) - : merely { g : ab_hom B' A & abses_pushout g xi = v }. - Proof. - pose proof (abses_pullback_trivial_factors_projection (projection xi) v h) - as [phi hphi]. - pose proof (iscomplex_abses xi) as hc; unfold ExactSequence.IsComplex in hc. - destruct hc as [hc0 hc1]. - pose (g0 := grp_kernel_corec (f:=projection v) (phi $o inclusion xi) - (fun b => (equiv_path_grouphomomorphism^-1 hphi (inclusion xi b))^ - @ hc0 b)). - pose (g := grp_homo_compose - (grp_iso_inverse (abses_kernel_iso (inclusion v) (projection v))) g0). - snrefine (tr (g; abses_pushout_component3_id - (Build_AbSESMorphism g phi grp_homo_id _ _) - (fun _ => idpath))). - - intro b. - exact (abses_kernel_iso_inv_beta (inclusion v) (projection v) (g0 b)). - - exact (fun m => (equiv_path_grouphomomorphism^-1 hphi m)^). - Defined. - - (** If [E] splits after pushing out along [projection xi], it is the pushout - along [inclusion xi] of some [E' : AbSES B A]. The witness [E'] is the - sub-extension of [E] on the kernel of the factoring map [phi]. *) - Definition abses_pushout_projection_exact {A A'' : AbGroup@{u}} - (xi : AbSES A'' A) {B : AbGroup@{u}} (E : AbSES B xi) - (h : abses_pushout (projection xi) E = point (AbSES B A'')) - : merely { E' : AbSES B A & abses_pushout (inclusion xi) E' = E }. - Proof. - pose proof (abses_pushout_trivial_factors_inclusion (projection xi) E h) - as [phi hphi]. - pose proof (iscomplex_abses xi) as hcx; unfold ExactSequence.IsComplex in hcx. - destruct hcx as [hcx0 hcx1]. - pose proof (iscomplex_abses E) as hcE; unfold ExactSequence.IsComplex in hcE. - destruct hcE as [hcE0 hcE1]. - assert (hkill : phi $o (inclusion E $o inclusion xi) == grp_homo_const). - { intro a. - exact ((equiv_path_grouphomomorphism^-1 hphi (inclusion xi a))^ @ hcx0 a). } - pose (iE' := grp_kernel_corec (inclusion E $o inclusion xi) hkill). - pose (sub := subgroup_incl (grp_kernel phi)). - snrefine (tr (Build_AbSES (ab_kernel phi) iE' - (grp_homo_compose (projection E) sub) _ _ _; _)). - - apply isembedding_isinj_hset; intros a a' p. - assert (beta : forall x, sub (iE' x) = inclusion E (inclusion xi x)) - by reflexivity. - exact (isinj_embedding (inclusion xi) _ a a' - (isinj_embedding (inclusion E) _ _ _ - ((beta a)^ @ ap sub p @ beta a'))). - - intro b. - rapply contr_inhabited_hprop. - assert (fe : merely (hfiber (projection E) b)) - by apply center, issurjection_projection. - strip_truncations; destruct fe as [e qe]. - assert (fm : merely (hfiber (projection xi) (phi e))) - by apply center, issurjection_projection. - strip_truncations; destruct fm as [mu qmu]. - assert (mem : phi (sg_op e (inv (inclusion E mu))) = mon_unit). - { refine (grp_homo_op phi e (inv (inclusion E mu)) @ _). - refine (ap (sg_op (phi e)) (grp_homo_inv phi (inclusion E mu)) @ _). - refine (ap (fun z => sg_op (phi e) (inv z)) - ((equiv_path_grouphomomorphism^-1 hphi mu)^ @ qmu) @ _). - exact (grp_inv_r (phi e)). } - refine (tr (((sg_op e (inv (inclusion E mu)); mem) - : grp_kernel phi); _)). - refine (grp_homo_op (projection E) e (inv (inclusion E mu)) @ _). - refine (ap (sg_op (projection E e)) - (grp_homo_inv (projection E) (inclusion E mu)) @ _). - refine (ap (fun z => sg_op (projection E e) (inv z)) (hcE0 mu) @ _). - refine (ap (sg_op (projection E e)) grp_inv_unit @ _). - exact (grp_unit_r _ @ qe). - - snapply Build_IsExact. - + srapply phomotopy_homotopy_hset. - intro a. - exact (hcE0 (inclusion xi a)). - + intros [m q]. - rapply contr_inhabited_hprop. - assert (fmu : merely (hfiber (inclusion E) (sub m))) - by exact (isexact_preimage (Tr (-1)) (inclusion E) (projection E) (sub m) q). - strip_truncations; destruct fmu as [mu rmu]. - assert (fa : merely (hfiber (inclusion xi) mu)) - by exact (isexact_preimage (Tr (-1)) (inclusion xi) (projection xi) mu - (equiv_path_grouphomomorphism^-1 hphi mu @ (ap phi rmu @ m.2))). - strip_truncations; destruct fa as [a ra]. - refine (tr (a; _)). - apply path_sigma_hprop. - apply path_sigma_hprop; cbn. - exact (ap (inclusion E) ra @ rmu). - - snrefine (abses_pushout_component3_id - (Build_AbSESMorphism (inclusion xi) _ grp_homo_id _ _) - (fun _ => idpath)). - + exact sub. - + exact (fun _ => idpath). - + exact (fun _ => idpath). - Defined. - - (** Exactness of the covariant sequence at [Ext B A]: the kernel of - [pushout (inclusion xi)] is the image of the connecting map from - [Hom B A'']. *) - Definition abses_ext_inclusion_exact_one {A A'' : AbGroup@{u}} (xi : AbSES A'' A) - {B : AbGroup@{u}} (v : abses_ext 1 B A) - : abses_ext_pushout 1 (inclusion xi) v = abses_ext_zero 1 B xi - -> merely { w : abses_ext 0 B A'' & abses_ext_dsplice 0 xi w = v }. - Proof. - revert v; srapply Quotient_ind_hprop; intros V h. - pose proof ((equiv_path_Tr _ _)^-1 - (ap (equiv_quotient_paths_tr (AbSES B xi)) h)) as hm. - strip_truncations. - pose proof (abses_inclusion_pushout_exact xi V hm) as hg. - strip_truncations; destruct hg as [g pq]. - exact (tr (class_of _ g; ap (class_of _) pq)). - Defined. - - (** Exactness of the covariant sequence at [Ext B (middle xi)]: the kernel of - [pushout (projection xi)] is the image of [pushout (inclusion xi)]. *) - Definition abses_ext_pushout_inclusion_exact_one {A A'' : AbGroup@{u}} - (xi : AbSES A'' A) {B : AbGroup@{u}} (v : abses_ext 1 B xi) - : abses_ext_pushout 1 (projection xi) v = abses_ext_zero 1 B A'' - -> merely { w : abses_ext 1 B A & abses_ext_pushout 1 (inclusion xi) w = v }. - Proof. - revert v; srapply Quotient_ind_hprop; intros V h. - pose proof ((equiv_path_Tr _ _)^-1 - (ap (equiv_quotient_paths_tr (AbSES B A'')) h)) as hm. - strip_truncations. - pose proof (abses_pushout_projection_exact xi V hm) as hE. - strip_truncations; destruct hE as [E' pq]. - exact (tr (class_of _ E'; ap (class_of _) pq)). - Defined. - - (** Exactness of the contravariant sequence at [Ext B'' A]: the kernel of - [pullback (projection xi)] is the image of the connecting map from - [Hom B' A]. *) - Definition abses_ext_pullback_projection_exact_one {A B' B'' : AbGroup@{u}} - (xi : AbSES B'' B') (v : abses_ext 1 B'' A) - : abses_ext_pullback 1 (projection xi) v = abses_ext_zero 1 xi A - -> merely { w : abses_ext 0 B' A & abses_ext_splice 0 xi w = v }. - Proof. - revert v; srapply Quotient_ind_hprop; intros V h. - pose proof ((equiv_path_Tr _ _)^-1 - (ap (equiv_quotient_paths_tr (AbSES xi A)) h)) as hm. - strip_truncations. - pose proof (abses_projection_pullback_exact xi V hm) as hg. - strip_truncations; destruct hg as [g pq]. - exact (tr (class_of _ g; ap (class_of _) pq)). - Defined. - - (** Exactness of the contravariant sequence at [Ext (middle xi) A]: the kernel - of [pullback (inclusion xi)] is the image of [pullback (projection xi)]. *) - Definition abses_ext_pullback_inclusion_exact_one {A B' B'' : AbGroup@{u}} - (xi : AbSES B'' B') (v : abses_ext 1 xi A) - : abses_ext_pullback 1 (inclusion xi) v = abses_ext_zero 1 B' A - -> merely { v'' : abses_ext 1 B'' A - & abses_ext_pullback 1 (projection xi) v'' = v }. - Proof. - revert v; srapply Quotient_ind_hprop; intros V h. - pose proof ((equiv_path_Tr _ _)^-1 - (ap (equiv_quotient_paths_tr (AbSES B' A)) h)) as hm. - strip_truncations. - pose (p := equiv_path_abses_iso^-1 hm). - refine (tr (class_of _ (abses_pullback_trivial_preimage xi V p); _)). - exact (ap (class_of _) (abses_pullback_component1_id - (abses_pullback_inclusion0_map' xi V p) (fun _ => idpath))^). - Defined. - - (** Exactness of the covariant sequence at [Hom B A'']: the kernel of the - connecting map is the image of postcomposition with [projection xi]. *) - Definition abses_ext_dsplice_projection_exact_zero {A A'' : AbGroup@{u}} - (xi : AbSES A'' A) {B : AbGroup@{u}} (w : abses_ext 0 B A'') - : abses_ext_dsplice 0 xi w = abses_ext_zero 1 B A - -> merely { w' : abses_ext 0 B xi - & abses_ext_pushout 0 (projection xi) w' = w }. - Proof. - revert w; srapply Quotient_ind_hprop; intros W h. - pose proof ((equiv_path_Tr _ _)^-1 - (ap (equiv_quotient_paths_tr (AbSES B A)) h)) as hm. - strip_truncations. - destruct (abses_pullback_trivial_factors_projection W xi hm) as [phi pq]. - exact (tr (class_of _ phi; ap (class_of _) pq^)). - Defined. - - (** Exactness of the covariant sequence at [Hom B (middle xi)]: the kernel of - postcomposition with [projection xi] is the image of postcomposition with - [inclusion xi]. *) - Definition abses_ext_pushout_projection_exact_zero {A A'' : AbGroup@{u}} - (xi : AbSES A'' A) {B : AbGroup@{u}} (f : abses_ext 0 B xi) - : abses_ext_pushout 0 (projection xi) f = abses_ext_zero 0 B A'' - -> merely { f' : abses_ext 0 B A & abses_ext_pushout 0 (inclusion xi) f' = f }. - Proof. - revert f; srapply Quotient_ind_hprop; intros F h. - pose proof ((equiv_path_Tr _ _)^-1 - (ap (equiv_quotient_paths_tr (ab_hom B A'')) h)) as hm. - strip_truncations. - pose (k := grp_kernel_corec (f:=projection xi) F - (equiv_path_grouphomomorphism^-1 hm)). - refine (tr (class_of _ (grp_homo_compose - (grp_iso_inverse (abses_kernel_iso (inclusion xi) (projection xi))) k); _)). - apply (ap (class_of _)). - apply equiv_path_grouphomomorphism; intro b. - exact (abses_kernel_iso_inv_beta (inclusion xi) (projection xi) (k b)). - Defined. - - (** Exactness of the contravariant sequence at [Hom (middle xi) A]: the kernel - of precomposition with [inclusion xi] is the image of precomposition with - [projection xi]. *) - Definition abses_ext_pullback_inclusion_exact_zero {A B' B'' : AbGroup@{u}} - (xi : AbSES B'' B') (g : abses_ext 0 xi A) - : abses_ext_pullback 0 (inclusion xi) g = abses_ext_zero 0 B' A - -> merely { f : abses_ext 0 B'' A & abses_ext_pullback 0 (projection xi) f = g }. - Proof. - revert g; srapply Quotient_ind_hprop; intros G h. - pose proof ((equiv_path_Tr _ _)^-1 - (ap (equiv_quotient_paths_tr (ab_hom B' A)) h)) as hm. - strip_truncations. - assert (hkill : forall n : middle xi, grp_image (inclusion xi) n -> G n = mon_unit). - { intros n; srapply Trunc_rec; intros [b r]. - refine (ap G r^ @ _). - exact (equiv_path_grouphomomorphism^-1 hm b). } - pose (f := grp_homo_compose - (quotient_abgroup_rec (grp_image (inclusion xi)) A G hkill) - (grp_iso_inverse (abses_cokernel_iso (inclusion xi) (projection xi)))). - refine (tr (class_of _ f; _)). - apply (ap (class_of _)). - apply equiv_path_grouphomomorphism; intro x. - exact (ap (quotient_abgroup_rec (grp_image (inclusion xi)) A G hkill) - (abses_cokernel_iso_inv_beta (inclusion xi) (projection xi) x)). - Defined. - - (** Exactness of the contravariant sequence at [Hom B' A]: the kernel of the - connecting map is the image of precomposition with [inclusion xi]. *) - Definition abses_ext_splice_inclusion_exact_zero {A B' B'' : AbGroup@{u}} - (xi : AbSES B'' B') (g : abses_ext 0 B' A) - : abses_ext_splice 0 xi g = abses_ext_zero 1 B'' A - -> merely { h : abses_ext 0 xi A & abses_ext_pullback 0 (inclusion xi) h = g }. - Proof. - revert g; srapply Quotient_ind_hprop; intros G h. - pose proof ((equiv_path_Tr _ _)^-1 - (ap (equiv_quotient_paths_tr (AbSES B'' A)) h)) as hm. - strip_truncations. - pose proof (abses_pushout_trivial_factors_inclusion G xi hm) as [phi hphi]. - exact (tr (class_of _ phi; ap (class_of _) hphi^)). - Defined. - - (** The covariant sequence is exact at [Hom B A]: postcomposition with - [inclusion xi] has trivial kernel. *) - Definition abses_ext_pushout_inclusion_injective_zero {A A'' : AbGroup@{u}} - (xi : AbSES A'' A) {B : AbGroup@{u}} (v : abses_ext 0 B A) - : abses_ext_pushout 0 (inclusion xi) v = abses_ext_zero 0 B xi - -> v = abses_ext_zero 0 B A. - Proof. - revert v; srapply Quotient_ind_hprop; intros F h. - pose proof ((equiv_path_Tr _ _)^-1 - (ap (equiv_quotient_paths_tr (ab_hom B xi)) h)) as hm. - strip_truncations. - apply (ap (class_of _)). - apply equiv_path_grouphomomorphism; intro b. - apply (isinj_embedding (inclusion xi) _). - exact (equiv_path_grouphomomorphism^-1 hm b @ (grp_homo_unit (inclusion xi))^). - Defined. - - (** The contravariant sequence is exact at [Hom B'' A]: precomposition with - [projection xi] has trivial kernel. *) - Definition abses_ext_pullback_projection_injective_zero {A B' B'' : AbGroup@{u}} - (xi : AbSES B'' B') (v : abses_ext 0 B'' A) - : abses_ext_pullback 0 (projection xi) v = abses_ext_zero 0 xi A - -> v = abses_ext_zero 0 B'' A. - Proof. - revert v; srapply Quotient_ind_hprop; intros F h. - pose proof ((equiv_path_Tr _ _)^-1 - (ap (equiv_quotient_paths_tr (ab_hom xi A)) h)) as hm. - strip_truncations. - apply (ap (class_of _)). - apply equiv_path_grouphomomorphism; intro b. - assert (fm : merely (hfiber (projection xi) b)) - by apply center, issurjection_projection. - strip_truncations; destruct fm as [m qm]. - exact ((ap F qm)^ @ equiv_path_grouphomomorphism^-1 hm m). - Defined. - - (** The Yoneda product is additive in the first variable: it carries the Baer - sum to the Baer sum of the products. *) - Definition abses_ext_yoneda_baer_sum_l {A C : AbGroup@{u}} (m : nat) - {B : AbGroup@{u}} (t t' : grp_ext B C) (x : abses_ext m C A) - : abses_ext_yoneda m (sg_op t t') x - = abses_ext_baer_sum m.+1 (abses_ext_yoneda m t x) (abses_ext_yoneda m t' x). - Proof. - revert t t'; srapply Trunc_ind; intro s; srapply Trunc_ind; intro s'. - exact (abses_ext_splice_baer_sum_ses m s s' x). - Defined. - - (** Splicing is surjective onto [Ext^{m+2}]: every length-[m.+2] extension is - a splice of a short exact sequence onto a length-[m.+1] extension. *) - Definition abses_ext_splice_surjective (m : nat) {A B : AbGroup@{u}} - (w : abses_ext m.+2 B A) - : merely { C : AbGroup@{u} & { s : AbSES B C - & { t : abses_ext m.+1 C A & w = abses_ext_splice m.+1 s t } } }. - Proof. - revert w; srapply Quotient_ind_hprop; intros [C [t s]]. - exact (tr (C; (s; (class_of _ t; idpath)))). - Defined. - - (** Higher Ext of a projective vanishes: [Ext^{n+1}(P, A)] is trivial for - every [A] when [P] is projective. *) - Definition abses_ext_projective_vanish {P : AbGroup@{u}} `{IsAbProjective P} - (n : nat) {A : AbGroup@{u}} (x : abses_ext n.+1 P A) - : x = abses_ext_zero n.+1 P A. - Proof. - destruct n as [|n]. - - pose proof (contr_equiv' (Ext P A) - (equiv_inverse (equiv_abses_ext_one P A))) as cc. - exact (path_contr x (abses_ext_zero 1 P A)). - - pose proof (abses_ext_splice_surjective n x) as hsurj. - strip_truncations. - destruct hsurj as [C [s [t p]]]. - refine (p @ (abses_ext_yoneda_tr n.+1 s t)^ @ _). - refine (ap (fun u => abses_ext_yoneda n.+1 u t) - (path_contr (tr s) (tr (point (AbSES P C)))) @ _). - refine (abses_ext_yoneda_tr n.+1 (point (AbSES P C)) t @ _). - exact (abses_ext_splice_point n.+1 t). - Defined. - - (** Splicing with a projective-middle short exact sequence is surjective onto - [Ext^{n+1}(B, A)]. *) - Definition abses_ext_splice_projective_surjective {K B : AbGroup@{u}} - (zeta : AbSES B K) `{IsAbProjective (middle zeta)} {A : AbGroup@{u}} - (n : nat) (w : abses_ext n.+1 B A) - : merely { x : abses_ext n K A & abses_ext_splice n zeta x = w }. - Proof. - destruct n as [|n]. - - refine (abses_ext_pullback_projection_exact_one zeta w _). - pose proof (contr_equiv' (Ext (middle zeta) A) - (equiv_inverse (equiv_abses_ext_one (middle zeta) A))) as cc. - exact (path_contr _ _). - - pose proof (abses_ext_splice_surjective n w) as hsurj. - strip_truncations; destruct hsurj as [C [s [t p]]]. - pose proof (contr_equiv' (Ext (middle zeta) C) - (equiv_inverse (equiv_abses_ext_one (middle zeta) C))) as cc. - pose proof (abses_ext_pullback_projection_exact_one zeta (class_of _ s) - (path_contr _ _)) as hg. - revert hg; apply Trunc_rec; intros [g pg]; revert g pg. - srapply Quotient_ind_hprop; intros g0 pg. - pose proof ((equiv_path_Tr _ _)^-1 - (ap (equiv_quotient_paths_tr (AbSES B C)) pg)) as hs. - strip_truncations. - refine (tr (abses_ext_pullback (S n) g0 t; _)). - refine (abses_ext_splice_pullback_junction (S n) g0 zeta t @ _). - exact (ap (fun S0 => abses_ext_splice (S n) S0 t) hs @ p^). - Defined. - - (** For a projective-middle [zeta], [Ext^1(B, A)] is the cokernel of - precomposition with [inclusion zeta]. *) - Definition ext_one_projective_presentation {K B : AbGroup@{u}} - (zeta : AbSES B K) `{IsAbProjective (middle zeta)} {A : AbGroup@{u}} - : GroupIsomorphism - (ab_cokernel (grp_homo_abses_ext_pullback 0 (A:=A) (inclusion zeta))) - (ab_abses_ext 1 B A). - Proof. - snapply (abses_cokernel_iso (grp_homo_abses_ext_pullback 0 (A:=A) (inclusion zeta)) - (grp_homo_abses_ext_splice 0 zeta)). - - intro b; rapply contr_inhabited_hprop. - exact (abses_ext_splice_projective_surjective zeta 0 b). - - snapply Build_IsExact. - + srapply phomotopy_homotopy_hset; intro f. - exact (abses_ext_inclusion_splice_iscomplex 0 zeta f). - + intros [g0 hg0]. - rapply contr_inhabited_hprop. - pose proof (abses_ext_splice_inclusion_exact_zero zeta g0 hg0) as hpre. - strip_truncations; destruct hpre as [h ph]. - refine (tr (h; _)). - apply path_sigma_hprop; exact ph. - Defined. - - (** [Ext^{n+2}(B, A)] vanishes when [zeta : AbSES B K] has projective middle - and projective kernel. *) - Definition abses_ext_vanish_short_resolution {K B : AbGroup@{u}} - (zeta : AbSES B K) `{IsAbProjective (middle zeta)} `{IsAbProjective K} - {A : AbGroup@{u}} (n : nat) (x : abses_ext n.+2 B A) - : x = abses_ext_zero n.+2 B A. - Proof. - pose proof (abses_ext_splice_projective_surjective zeta n.+1 x) as hsurj. - strip_truncations; destruct hsurj as [y py]. - refine (py^ @ ap (abses_ext_splice n.+1 zeta) (abses_ext_projective_vanish n y) @ _). - exact (grp_homo_unit (grp_homo_abses_ext_splice n.+1 zeta)). - Defined. - - (** The higher Ext groups [Ext^{m+2}(Z/n, A)] of a cyclic group vanish. *) - Definition abses_ext_cyclic_higher_vanish (n : nat) - `{IsEmbedding (Z1_mul_nat n)} {A : AbGroup@{u}} (m : nat) - (x : abses_ext m.+2 (ab_cokernel_embedding (Z1_mul_nat n)) A) - : x = abses_ext_zero m.+2 (ab_cokernel_embedding (Z1_mul_nat n)) A - := abses_ext_vanish_short_resolution (abses_from_inclusion (Z1_mul_nat n)) m x. - - (** Pulling back along a sum of homomorphisms is the Baer sum of the - pullbacks, so [Ext^n(-, A)] is additive in the homomorphism. *) - Definition abses_ext_pullback_plus (n : nat) {A B B' : AbGroup@{u}} - (f g : B' $-> B) (x : abses_ext n B A) - : abses_ext_pullback n (sg_op f g) x - = abses_ext_baer_sum n (abses_ext_pullback n f x) (abses_ext_pullback n g x). - Proof. - destruct n as [|[|n]]; revert x; srapply Quotient_ind_hprop. - - intro phi. - apply (ap (class_of _)). - apply equiv_path_grouphomomorphism; intro b. - exact (grp_homo_op phi (f b) (g b)). - - intro E. - exact (ap (class_of _) (baer_sum_distributive_pullbacks f g)). - - intros [C [t s]]. - refine (abses_ext_splice_pullback n.+1 s (sg_op f g) (class_of _ t) @ _). - refine (ap (fun S0 => abses_ext_splice n.+1 S0 (class_of _ t)) - (baer_sum_distributive_pullbacks f g) @ _). - refine (abses_ext_splice_baer_sum_ses n.+1 (abses_pullback f s) - (abses_pullback g s) (class_of _ t) @ _). - exact (ap011 (abses_ext_baer_sum n.+2) - (abses_ext_splice_pullback n.+1 s f (class_of _ t))^ - (abses_ext_splice_pullback n.+1 s g (class_of _ t))^). - Defined. - -End HigherExt. - -(** ** Universality of the higher Ext delta-functor *) - -(** A coefficient [G] and a target contravariant additive family [T] with - connecting maps [Tdelta], natural in the short exact sequence. *) - -Section ExtUniversal. - Context `{Univalence} (G : AbGroup@{u}). - Context (T : nat -> AbGroup@{u} -> AbGroup@{u}) - (Tmap : forall (n : nat) {B B' : AbGroup@{u}}, - (B' $-> B) -> (T n B $-> T n B')) - (Tmap_id : forall (n : nat) (B : AbGroup@{u}) (x : T n B), - Tmap n grp_homo_id x = x) - (Tmap_comp : forall (n : nat) {B B' B'' : AbGroup@{u}} - (f : B' $-> B) (g : B'' $-> B') (x : T n B), - Tmap n (f $o g) x = Tmap n g (Tmap n f x)) - (Tdelta : forall (n : nat) {A B : AbGroup@{u}}, - AbSES B A -> (T n A $-> T (S n) B)) - (Tdelta_nat : forall (n : nat) {A B A' B' : AbGroup@{u}} - (E : AbSES B A) (E' : AbSES B' A') (phi : AbSESMorphism E E') - (x : T n A'), - Tdelta n E (Tmap n (component1 phi) x) - = Tmap (S n) (component3 phi) (Tdelta n E' x)). - - Arguments Tmap n {B B'} _. - Arguments Tmap_id n {B} _. - Arguments Tmap_comp n {B B' B''} _ _ _. - Arguments Tdelta n {A B} _. - Arguments Tdelta_nat n {A B A' B'} _ _ _ _. - - Local Open Scope nat_scope. - - (** The comparison map on representatives, by recursion on the length. *) - Definition d_rep : forall (n : nat) {B : AbGroup@{u}}, - abses_es n B G -> (T 0 G $-> T n B). - Proof. - induction n as [|n IHn]; intros B w. - - exact (Tmap 0 (w : B $-> G)). - - destruct n as [|n]. - + exact (Tdelta 0 (w : AbSES B G)). - + exact (grp_homo_compose (Tdelta (S n) (snd w.2)) (IHn w.1 (fst w.2))). - Defined. - - (** The connecting map commutes with pullback in the base. *) - Definition Tdelta_pullback (n : nat) {A B B' : AbGroup@{u}} (beta : B' $-> B) - (E : AbSES B A) - : Tdelta n (abses_pullback beta E) - = grp_homo_compose (Tmap (S n) beta) (Tdelta n E). - Proof. - apply equiv_path_grouphomomorphism; intro x. - exact ((ap (Tdelta n (abses_pullback beta E)) (Tmap_id n x))^ - @ Tdelta_nat n (abses_pullback beta E) E (abses_pullback_morphism E beta) x). - Defined. - - (** The comparison map is natural in the base. *) - Definition d_rep_natural (n : nat) {B B' : AbGroup@{u}} (beta : B' $-> B) - (w : abses_es n B G) - : d_rep n (abses_es_pullback n beta w) - = grp_homo_compose (Tmap n beta) (d_rep n w). - Proof. - destruct n as [|[|n]]. - - apply equiv_path_grouphomomorphism; intro x. - exact (Tmap_comp 0 (w : B $-> G) beta x). - - exact (Tdelta_pullback 0 beta (w : AbSES B G)). - - destruct w as [C [F E]]. - refine (ap (fun d => grp_homo_compose d (d_rep (S n) F)) - (Tdelta_pullback (S n) beta E) @ _). - apply equiv_path_grouphomomorphism; intro x; reflexivity. - Defined. - - (** The connecting map commutes with pushout in the coefficient. *) - Definition Tdelta_pushout (n : nat) {A A' B : AbGroup@{u}} (alpha : A $-> A') - (E : AbSES B A) - : Tdelta n (abses_pushout alpha E) - = grp_homo_compose (Tdelta n E) (Tmap n alpha). - Proof. - apply equiv_path_grouphomomorphism; intro x. - exact ((Tdelta_nat n E (abses_pushout alpha E) (abses_pushout_morphism E alpha) x - @ Tmap_id (S n) (Tdelta n (abses_pushout alpha E) x))^). - Defined. - - (** The comparison map respects the relation, hence descends to [Ext]. *) - Definition d_rep_rel (n : nat) {B : AbGroup@{u}} (w w' : abses_es n B G) - (r : abses_es_rel n w w') - : d_rep n w = d_rep n w'. - Proof. - revert B w w' r; induction n as [|[|n] IHn]; intros B w w' r. - - exact (ap (d_rep 0) r). - - exact (ap (d_rep 1) r). - - destruct w as [C [F E]], w' as [C' [F' E']], r as [beta [rF rE]]. - apply equiv_path_grouphomomorphism; intro x. - refine (ap (fun y => Tdelta (S n) E y) - (equiv_path_grouphomomorphism^-1 - (IHn C F (abses_es_pullback (S n) beta F') rF) x - @ equiv_path_grouphomomorphism^-1 (d_rep_natural (S n) beta F') x) @ _). - refine (_ @ ap (fun E0 => Tdelta (S n) E0 (d_rep (S n) F' x)) rE). - exact (equiv_path_grouphomomorphism^-1 - (Tdelta_pushout (S n) beta E) (d_rep (S n) F' x))^. - Defined. - - (** The comparison map descends to a map out of [Ext]. *) - Definition d_ext (n : nat) {B : AbGroup@{u}} - : abses_ext n B G -> (T 0 G $-> T n B) - := Quotient_rec (abses_es_rel n) (T 0 G $-> T n B) (@d_rep n B) (@d_rep_rel n B). - - (** It is natural in the base and carries the splice to the connecting map. *) - Definition d_ext_natural (n : nat) {B B' : AbGroup@{u}} (beta : B' $-> B) - (x : abses_ext n B G) - : d_ext n (abses_ext_pullback n beta x) - = grp_homo_compose (Tmap n beta) (d_ext n x). - Proof. - revert x; srapply Quotient_ind_hprop; intro w. - exact (d_rep_natural n beta w). - Defined. - - Definition d_ext_splice (n : nat) {B C : AbGroup@{u}} (E : AbSES B C) - (x : abses_ext n C G) - : d_ext (S n) (abses_ext_splice n E x) - = grp_homo_compose (Tdelta n E) (d_ext n x). - Proof. - revert x; srapply Quotient_ind_hprop; intro w. - destruct n as [|n]. - - exact (Tdelta_pushout 0 (w : C $-> G) E). - - reflexivity. - Defined. - - (** The induced map of delta-functors out of [Ext^* (- , G)] extending a - degree-zero element [eta : T 0 G]. *) - Definition d_morph (n : nat) {B : AbGroup@{u}} (eta : T 0 G) - (x : abses_ext n B G) : T n B - := d_ext n x eta. - - Definition d_morph_natural (n : nat) {B B' : AbGroup@{u}} (beta : B' $-> B) - (eta : T 0 G) (x : abses_ext n B G) - : d_morph n eta (abses_ext_pullback n beta x) = Tmap n beta (d_morph n eta x) - := equiv_path_grouphomomorphism^-1 (d_ext_natural n beta x) eta. - - Definition d_morph_splice (n : nat) {B C : AbGroup@{u}} (E : AbSES B C) - (eta : T 0 G) (x : abses_ext n C G) - : d_morph (S n) eta (abses_ext_splice n E x) = Tdelta n E (d_morph n eta x) - := equiv_path_grouphomomorphism^-1 (d_ext_splice n E x) eta. - - (** A family agreeing with the connecting maps and the degree-zero values - equals [d_morph]. *) - Definition d_morph_unique (eta : T 0 G) - (v : forall (n : nat) (B : AbGroup@{u}), abses_ext n B G -> T n B) - (v_zero : forall (B : AbGroup@{u}) (phi : ab_hom B G), - v 0 B (class_of _ phi) = Tmap 0 phi eta) - (v_splice : forall (n : nat) (B C : AbGroup@{u}) (E : AbSES B C) - (x : abses_ext n C G), - v (S n) B (abses_ext_splice n E x) = Tdelta n E (v n C x)) - : forall (n : nat) (B : AbGroup@{u}) (x : abses_ext n B G), - v n B x = d_morph n eta x. - Proof. - intro n; induction n as [|[|n] IHn]; intros B x. - - revert x; srapply Quotient_ind_hprop; intro phi. - exact (v_zero B phi). - - revert x; srapply Quotient_ind_hprop; intro E. - refine (ap (v 1%nat B) (ap (class_of _) (abses_pushout_id E))^ @ _). - refine (v_splice 0 B G E (class_of _ grp_homo_id) @ _). - refine (ap (fun y => Tdelta 0 E y) (v_zero G grp_homo_id) @ _). - exact (ap (fun y => Tdelta 0 E y) (Tmap_id 0 eta)). - - revert x; srapply Quotient_ind_hprop; intros [C [F E]]. - refine (v_splice (S n) B C E (class_of _ F) @ _). - exact (ap (fun y => Tdelta (S n) E y) (IHn C (class_of _ F))). - Defined. - - (** A map of delta-functors from [Ext^* (- , G)] to [T]. *) - Definition ExtDeltaMor : Type - := { v : forall (n : nat) (B : AbGroup@{u}), abses_ext n B G -> T n B - & (forall (n : nat) (B B' : AbGroup@{u}) (beta : B' $-> B) - (x : abses_ext n B G), - v n B' (abses_ext_pullback n beta x) = Tmap n beta (v n B x)) - * (forall (n : nat) (B C : AbGroup@{u}) (E : AbSES B C) - (x : abses_ext n C G), - v (S n) B (abses_ext_splice n E x) = Tdelta n E (v n C x)) }. - - (** Maps of delta-functors out of [Ext^* (- , G)] correspond to elements of - [T 0 G]. *) - Definition ext_universal_equiv : ExtDeltaMor <~> T 0 G. - Proof. - srapply equiv_adjointify. - - exact (fun m => m.1 0%nat G (class_of _ grp_homo_id)). - - intro eta. - exists (fun n B => @d_morph n B eta). - exact ((fun n B B' beta x => @d_morph_natural n B B' beta eta x), - (fun n B C E x => @d_morph_splice n B C E eta x)). - - intro eta; exact (Tmap_id 0 eta). - - intro m. - srapply path_sigma_hprop. - apply path_forall; intro n; apply path_forall; intro B; apply path_forall; intro x. - symmetry; srapply d_morph_unique. - + intros B0 phi. - transitivity (m.1 0%nat B0 (abses_ext_pullback 0 phi (class_of _ grp_homo_id))). - * apply (ap (m.1 0%nat B0)); symmetry. - apply (ap (class_of _)). - apply equiv_path_grouphomomorphism; intro b; reflexivity. - * exact (fst m.2 0%nat G B0 phi (class_of _ grp_homo_id)). - + exact (snd m.2). - Defined. - -End ExtUniversal. diff --git a/theories/Algebra/AbSES/HigherExtMorphism.v b/theories/Algebra/AbSES/HigherExtMorphism.v deleted file mode 100644 index a298055f9eb..00000000000 --- a/theories/Algebra/AbSES/HigherExtMorphism.v +++ /dev/null @@ -1,152 +0,0 @@ -From HoTT Require Import Basics Types. -From HoTT.WildCat Require Import Core. -Require Import Colimits.Quotient. -Require Import AbGroups.AbelianGroup. -Require Import Algebra.AbSES.Core Algebra.AbSES.Pushout Algebra.AbSES.Pullback - Algebra.AbSES.BaerSum Algebra.AbSES.HigherExt. -Require Import Groups.Group. - -Local Open Scope type_scope. - -(** * Morphisms of length-[n] exact sequences - - A morphism of length-[n] sequences (Christensen and Flaten, Definition 2.4.4) - fixes the two endpoints and gives a map of each intermediate module - commuting with the splice maps. We show that the relation [abses_es_rel] - and the existence of such a morphism are logically equivalent (Lemma 2.4.5), - and deduce that the set-quotient by morphisms agrees with [abses_ext] - (Remark 2.4.6). *) - -Section LengthNMorphism. - Context `{Univalence}. - - (** A morphism of length-[n] sequences over a base map [β], fixing the deep - coefficient. *) - Definition abses_es_mor - : forall (n : nat) (B B' A : AbGroup@{u}), (B $-> B') - -> abses_es n B A -> abses_es n B' A -> Type. - Proof. - induction n as [|n IH]; intros B B' A β. - - exact (fun E F => E = grp_homo_compose F β). - - revert IH; destruct n as [|p]; intro IH. - + exact (fun E F => { φ : AbSESMorphism E F - & (component1 φ == grp_homo_id) - * (component3 φ == β) }). - + exact (fun E F => { γ : E.1 $-> F.1 - & IH E.1 F.1 A γ (fst E.2) (fst F.2) - * { φ : AbSESMorphism (snd E.2) (snd F.2) - & (component1 φ == γ) - * (component3 φ == β) } }). - Defined. - - Arguments abses_es_mor n {B B' A} β. - - (** The identity-ends morphism induced by a path of short exact sequences. *) - Definition abses_morphism_of_path {B A : AbGroup@{u}} {E F : AbSES B A} - (p : E = F) - : AbSESMorphism E F - := transport (fun X => AbSESMorphism E X) p (abses_morphism_id E). - - Definition component1_abses_morphism_of_path {B A : AbGroup@{u}} - {E F : AbSES B A} (p : E = F) - : component1 (abses_morphism_of_path p) == grp_homo_id. - Proof. - destruct p; exact (fun _ => idpath). - Defined. - - Definition component3_abses_morphism_of_path {B A : AbGroup@{u}} - {E F : AbSES B A} (p : E = F) - : component3 (abses_morphism_of_path p) == grp_homo_id. - Proof. - destruct p; exact (fun _ => idpath). - Defined. - - (** A morphism over [β] yields the relation to the pullback along [β]. *) - Definition abses_es_mor_to_rel - : forall (n : nat) {B B' A : AbGroup@{u}} (β : B $-> B') - (E : abses_es n B A) (F : abses_es n B' A), - abses_es_mor n β E F -> abses_es_rel n E (abses_es_pullback n β F). - Proof. - intro n; induction n as [|[|n] IH]; intros B B' A β E F mor. - - exact mor. - - destruct mor as [φ [hα hβ]]. - refine (abses_pullback_component1_id φ hα @ _). - exact (ap (fun g => abses_pullback g F) (equiv_path_grouphomomorphism hβ)). - - destruct mor as [γ [morrec [φ [hα hβ]]]]. - exists γ. - refine (IH _ _ _ γ (fst E.2) (fst F.2) morrec, _). - refine ((ap (fun g => abses_pushout g (snd E.2)) - (equiv_path_grouphomomorphism hα))^ @ _). - refine (abses_pushout_is_pullback φ @ _). - exact (ap (fun g => abses_pullback g (snd F.2)) - (equiv_path_grouphomomorphism hβ)). - Defined. - - (** Conversely, the relation to the pullback along [β] yields a morphism. *) - Definition abses_es_rel_to_mor - : forall (n : nat) {B B' A : AbGroup@{u}} (β : B $-> B') - (E : abses_es n B A) (F : abses_es n B' A), - abses_es_rel n E (abses_es_pullback n β F) -> abses_es_mor n β E F. - Proof. - intro n; induction n as [|[|n] IH]; intros B B' A β E F rel. - - exact rel. - - exists (absesmorphism_compose (abses_pullback_morphism F β) - (abses_morphism_of_path rel)). - refine (_, _). - + intro x; exact (component1_abses_morphism_of_path rel x). - + intro x; exact (ap β (component3_abses_morphism_of_path rel x)). - - destruct rel as [γ [relrec q]]. - exists γ. - refine (IH _ _ _ γ (fst E.2) (fst F.2) relrec, _). - exists (absesmorphism_compose (abses_pullback_morphism (snd F.2) β) - (absesmorphism_compose (abses_morphism_of_path q) - (abses_pushout_morphism (snd E.2) γ))). - refine (_, _). - + intro x. - exact (component1_abses_morphism_of_path q (γ x)). - + intro x. - exact (ap β (component3_abses_morphism_of_path q x)). - Defined. - - (** A morphism of length-[n] sequences fixing both endpoints (the base map is - the identity). *) - Definition abses_es_morphism (n : nat) {B A : AbGroup@{u}} - (E F : abses_es n B A) : Type - := abses_es_mor n grp_homo_id E F. - - (** The relation and morphism-existence are logically equivalent. *) - Definition iff_abses_es_rel_morphism (n : nat) {B A : AbGroup@{u}} - (E F : abses_es n B A) - : abses_es_rel n E F <-> abses_es_morphism n E F. - Proof. - split. - - intro rel. - apply (abses_es_rel_to_mor n grp_homo_id E F). - exact (transport (abses_es_rel n E) (abses_es_pullback_id n F)^ rel). - - intro mor. - refine (transport (abses_es_rel n E) (abses_es_pullback_id n F) _). - exact (abses_es_mor_to_rel n grp_homo_id E F mor). - Defined. - -End LengthNMorphism. - -(** ** The morphism quotient *) - -Section MorphismQuotient. - Context `{Univalence}. - - (** The set-quotient of length-[n] sequences by morphism-existence agrees - with [abses_ext]. *) - Definition equiv_abses_ext_morphism (n : nat) (B A : AbGroup@{u}) - : abses_ext n B A <~> Quotient (abses_es_morphism n (B:=B) (A:=A)). - Proof. - srapply equiv_adjointify. - - srapply (Quotient_functor _ _ idmap). - exact (fun E F => fst (iff_abses_es_rel_morphism n E F)). - - srapply (Quotient_functor _ _ idmap). - exact (fun E F => snd (iff_abses_es_rel_morphism n E F)). - - srapply Quotient_ind_hprop; intro E; reflexivity. - - srapply Quotient_ind_hprop; intro E; reflexivity. - Defined. - -End MorphismQuotient. diff --git a/theories/Algebra/AbSES/HigherExtResolution.v b/theories/Algebra/AbSES/HigherExtResolution.v deleted file mode 100644 index 33a9c5648c2..00000000000 --- a/theories/Algebra/AbSES/HigherExtResolution.v +++ /dev/null @@ -1,53 +0,0 @@ -From HoTT Require Import Basics Types Truncations.Core. -Require Import Spaces.Nat.Core. -Require Import AbGroups.AbelianGroup AbGroups.AbProjective. -Require Import Algebra.AbSES.Core Algebra.AbSES.HigherExt. -Require Import Groups.Group. - -Local Open Scope nat_scope. - -(** * Vanishing of higher Ext above a projective resolution - - Following the dimension-shifting argument behind Christensen and Flaten, - Proposition 2.5.4: if a short exact sequence has projective middle and its - kernel already has vanishing Ext one degree down, then [B] has vanishing - Ext one degree further up. *) - -(** The dimension-shift step: splicing with a projective-middle sequence carries - the vanishing of [Ext^{m+1}(K,-)] to the vanishing of [Ext^{m+2}(B,-)]. *) -Definition abses_ext_vanish_step `{Univalence} {K B : AbGroup} (zeta : AbSES B K) - `{IsAbProjective (middle zeta)} {A : AbGroup} (m : nat) - (hK : forall x : abses_ext m.+1 K A, x = abses_ext_zero m.+1 K A) - (x : abses_ext m.+2 B A) - : x = abses_ext_zero m.+2 B A. -Proof. - pose proof (abses_ext_splice_projective_surjective zeta m.+1 x) as hsurj. - strip_truncations; destruct hsurj as [y py]. - refine (py^ @ ap (abses_ext_splice m.+1 zeta) (hK y) @ _). - exact (grp_homo_unit (grp_homo_abses_ext_splice m.+1 zeta)). -Defined. - -(** A projective resolution of length [k]: a tower of short exact sequences with - projective middles ending in a projective module. *) -Fixpoint proj_resolution `{Univalence} (k : nat) (B : AbGroup@{u}) : Type := - match k with - | 0%nat => IsAbProjective B - | S k => { K : AbGroup@{u} - & { zeta : AbSES B K - & (IsAbProjective (middle zeta) * proj_resolution k K)%type } } - end. - -(** Higher Ext vanishes above the length of a projective resolution. *) -Definition abses_ext_vanish_resolution `{Univalence} (k : nat) - : forall (B : AbGroup@{u}), proj_resolution k B - -> forall (A : AbGroup@{u}) (n : nat) (x : abses_ext (k + n).+1 B A), - x = abses_ext_zero (k + n).+1 B A. -Proof. - induction k as [|k IH]; intros B res A n x. - - assert (res' : IsAbProjective B) by exact res. - exact (abses_ext_projective_vanish n x). - - destruct res as [K [zeta [hp rK]]]. - refine (abses_ext_vanish_step zeta (k + n) _ x). - intro y. - exact (IH K rK A n y). -Defined. diff --git a/theories/Algebra/AbSES/InjectiveExt.v b/theories/Algebra/AbSES/InjectiveExt.v deleted file mode 100644 index 7d0a9097ffb..00000000000 --- a/theories/Algebra/AbSES/InjectiveExt.v +++ /dev/null @@ -1,57 +0,0 @@ -From HoTT Require Import Basics Types Truncations.Core. -From HoTT.WildCat Require Import Core. -Require Import AbGroups.AbelianGroup AbGroups.Biproduct AbGroups.AbInjective. -Require Import Algebra.AbSES.Core Algebra.AbSES.Ext. - -(** * Injectivity and the vanishing of Ext - - An injective abelian group has no nontrivial extensions; the dual of - Proposition 2.5.2. *) - -(** Every extension of an injective group is trivial. *) -Definition isabinjective_ext_trivial `{Univalence} {I : AbGroup} `{IsAbInjective I} - {B : AbGroup} (E : AbSES B I) - : tr E = point (Ext B I). -Proof. - pose proof (isabinjective I (middle E) (inclusion E) grp_homo_id _) as hr. - strip_truncations. - destruct hr as [r hr]. - pose proof (iscomplex_abses E) as hc; destruct hc as [hc0 hc1]. - pose (phi := ab_biprod_corec r (projection E) : middle E $-> ab_biprod I B). - assert (p0 : phi $o inclusion E == ab_biprod_inl). - { intro a; snapply path_prod'. - - exact (hr a). - - exact (hc0 a). } - assert (p1 : projection E == ab_biprod_pr2 $o phi) - by reflexivity. - apply (ap tr). - snapply equiv_path_abses_iso. - exact (Build_GroupIsomorphism _ _ phi - (short_five_lemma (F := point (AbSES B I)) phi p0 p1); - (p0, p1)). -Defined. - -(** Conversely, a group all of whose extensions are trivial is injective. *) -Definition isabinjective_from_ext_trivial `{Univalence} {I : AbGroup} - (triv : forall (B : AbGroup) (E : AbSES B I), tr E = point (Ext B I)) - : IsAbInjective I. -Proof. - apply (snd (iff_isabinjective_embeddings_split I)). - intros C m hm. - pose proof ((iff_ab_ext_trivial_split (abses_from_inclusion m))^-1 - (triv _ (abses_from_inclusion m))) as hs. - strip_truncations. - destruct hs as [s hsp]. - apply tr. - exists (ab_biprod_pr1 $o projection_split_iso (abses_from_inclusion m) hsp). - intro a. - exact (ap ab_biprod_pr1 - (projection_split_beta (abses_from_inclusion m) hsp a)). -Defined. - -(** Injectivity is equivalent to the vanishing of all extensions. *) -Definition iff_isabinjective_ext_trivial `{Univalence} (I : AbGroup) - : IsAbInjective I - <-> (forall (B : AbGroup) (E : AbSES B I), tr E = point (Ext B I)) - := (fun inj B E => @isabinjective_ext_trivial _ I inj B E, - isabinjective_from_ext_trivial). diff --git a/theories/Algebra/AbSES/Pullback.v b/theories/Algebra/AbSES/Pullback.v index 1948c8024b9..8236ea6e540 100644 --- a/theories/Algebra/AbSES/Pullback.v +++ b/theories/Algebra/AbSES/Pullback.v @@ -499,18 +499,3 @@ Proof. - exact abses_pullback_pmap_id. - symmetry; apply abses_pullback_pcompose. Defined. - -(** Dual to [abses_pushout_trivial_factors_inclusion]: if a pullback - [abses_pullback beta E] is trivial, then [beta] factors through - [projection E]. The splitting of the trivial pullback provides the - factoring map through the pullback's middle. *) -Definition abses_pullback_trivial_factors_projection `{Univalence} - {A B B' : AbGroup} (beta : B' $-> B) (E : AbSES B A) - : abses_pullback beta E = pt -> exists phi, beta = projection E $o phi. -Proof. - intro h. - destruct (snd (iff_abses_trivial_split (abses_pullback beta E)) h) as [s hs]. - exists (component2 (abses_pullback_morphism E beta) $o s). - apply equiv_path_grouphomomorphism; intro b. - exact (right_square (abses_pullback_morphism E beta) (s b) @ ap beta (hs b))^. -Defined. diff --git a/theories/Algebra/AbSES/Pushout.v b/theories/Algebra/AbSES/Pushout.v index 628055043a2..9534074fb79 100644 --- a/theories/Algebra/AbSES/Pushout.v +++ b/theories/Algebra/AbSES/Pushout.v @@ -1,6 +1,5 @@ From HoTT Require Import Basics Types Truncations.Core. From HoTT.WildCat Require Import Core Universe Opposite NatTrans. -Require Import Universes.HSet. Require Import Pointed.Core Homotopy.ExactSequence HIT.epi. Require Import Modalities.ReflectiveSubuniverse. Require Import AbelianGroup AbPushout AbHom AbGroups.Biproduct. @@ -452,23 +451,3 @@ Proof. - apply abses_pushout_pmap_id. - apply abses_pushout_pcompose. Defined. - -(** If a pushout [abses_pushout alpha E] is trivial, then [alpha] factors through [inclusion E]. *) -Lemma abses_pushout_trivial_factors_inclusion `{Univalence} - {B A A' : AbGroup} (alpha : A $-> A') (E : AbSES B A) - : abses_pushout alpha E = pt -> exists phi, alpha = phi $o inclusion E. -Proof. - equiv_intros (equiv_path_abses (E:=abses_pushout alpha E) (F:=pt)) p. - destruct p as [phi [p q]]. - exists (ab_biprod_pr1 $o phi $o ab_pushout_inr). - apply equiv_path_grouphomomorphism; intro a. - (* We embed into the biproduct and prove equality there. *) - apply (isinj_embedding (@ab_biprod_inl A' B) _). - refine ((p (alpha a))^ @ _). - refine (ap phi _ @ _). - 1: exact (left_square (abses_pushout_morphism E alpha) a). - apply (path_prod' idpath). - refine ((q _)^ @ _). - refine (right_square (abses_pushout_morphism E alpha) _ @ _); cbn. - apply isexact_inclusion_projection. -Defined. diff --git a/theories/Algebra/AbSES/SixTerm.v b/theories/Algebra/AbSES/SixTerm.v index 5c30cb1ea0a..c4f5bd615a2 100644 --- a/theories/Algebra/AbSES/SixTerm.v +++ b/theories/Algebra/AbSES/SixTerm.v @@ -57,7 +57,25 @@ Defined. (** *** Exactness of [ab_hom E G -> ab_hom A G -> Ext B G] *) -(** [abses_pushout_trivial_factors_inclusion] now lives in [AbSES.Pushout]. *) +(** If a pushout [abses_pushout alpha E] is trivial, then [alpha] factors through [inclusion E]. *) +Lemma abses_pushout_trivial_factors_inclusion `{Univalence} + {B A A' : AbGroup} (alpha : A $-> A') (E : AbSES B A) + : abses_pushout alpha E = pt -> exists phi, alpha = phi $o inclusion E. +Proof. + equiv_intros (equiv_path_abses (E:=abses_pushout alpha E) (F:=pt)) p. + destruct p as [phi [p q]]. + exists (ab_biprod_pr1 $o phi $o ab_pushout_inr). + apply equiv_path_grouphomomorphism; intro a. + (* We embed into the biproduct and prove equality there. *) + apply (isinj_embedding (@ab_biprod_inl A' B) _). + refine ((p (alpha a))^ @ _). + refine (ap phi _ @ _). + 1: exact (left_square (abses_pushout_morphism E alpha) a). + apply (path_prod' idpath). + refine ((q _)^ @ _). + refine (right_square (abses_pushout_morphism E alpha) _ @ _); cbn. + apply isexact_inclusion_projection. +Defined. Instance isexact_ext_contra_sixterm_iii@{u v +} `{Univalence} {B A G : AbGroup@{u}} (E : AbSES@{u v} B A) diff --git a/theories/Algebra/Rings/Bezout.v b/theories/Algebra/Rings/Bezout.v deleted file mode 100644 index faaf7406d4d..00000000000 --- a/theories/Algebra/Rings/Bezout.v +++ /dev/null @@ -1,144 +0,0 @@ -From HoTT Require Import Basics Types Truncations.Core. -From HoTT.WildCat Require Import Core. -Require Import Spaces.Finite.Fin. -Require Import Algebra.Rings.Ring Algebra.Rings.CRing Algebra.Rings.Ideal. - -Local Open Scope ring_scope. -Local Open Scope mc_scope. -Local Open Scope predicate_scope. - -(** * Bézout rings and principal ideal domains - - Constructive definitions following Christensen and Flaten, Definitions - 2.6.2-2.6.3, with Lemma 2.6.4 (translating Lombardi and Quitté). *) - -(** Divisibility: [a] divides [b] if [b] is a multiple of [a]. *) -Definition rng_divides {R : CRing} (a b : R) : Type - := merely { c : R & b = c * a }. - -(** An element is regular if multiplication by it is injective. *) -Definition IsRegular {R : CRing} (a : R) : Type - := forall x y : R, a * x = a * y -> x = y. - -(** An integral domain: every element is zero or regular. *) -Class IsIntegralDomain (R : CRing) : Type - := intdom_zero_or_regular : forall x : R, (x = 0) + IsRegular x. - -(** A greatest common divisor of [x] and [y] is a common divisor divisible by - every common divisor. *) -Definition IsGcd {R : CRing} (x y g : R) : Type - := (rng_divides g x) * (rng_divides g y) - * (forall z : R, rng_divides z x -> rng_divides z y -> rng_divides z g). - -(** A Bézout ring: every pair has a Bézout combination that is a gcd. *) -Class IsBezoutRing (R : CRing) : Type - := bezout_relation : forall x y : R, - merely { u : R & { v : R & IsGcd x y (u * x + v * y) } }. - -(** A Bézout domain is a Bézout ring that is an integral domain. *) -Class IsBezoutDomain (R : CRing) : Type := { - bezoutdomain_bezout :: IsBezoutRing R ; - bezoutdomain_domain :: IsIntegralDomain R -}. - -(** A principal ideal domain: a Bézout domain in which every ascending chain of - ideals merely has two equal consecutive terms. *) -Class IsPID (R : CRing) : Type := { - pid_bezout :: IsBezoutDomain R ; - pid_noetherian : forall I : nat -> Ideal R, - (forall n, I n ⊆ I (S n)) -> merely { n : nat & I n = I (S n) } -}. - -(** An ideal is principal if it is merely generated by a single element. *) -Definition IsPrincipal {R : Ring} (I : Ideal R) : Type - := merely { a : R & ideal_generated_finite (fun _ : Fin 1 => a) = I }. - -(** ** Divisibility algebra *) - -Definition rng_divides_refl {R : CRing} (a : R) : rng_divides a a. -Proof. - apply tr; exists 1; exact (rng_mult_one_l a)^. -Defined. - -Definition rng_divides_trans {R : CRing} {a b c : R} - (p : rng_divides a b) (q : rng_divides b c) : rng_divides a c. -Proof. - strip_truncations; destruct p as [u pu], q as [v pv]. - apply tr; exists (v * u). - exact (pv @ ap (fun w => v * w) pu @ rng_mult_assoc v u a). -Defined. - -Definition rng_divides_mul_l {R : CRing} {a b : R} (r : R) - (p : rng_divides a b) : rng_divides a (r * b). -Proof. - strip_truncations; destruct p as [u pu]. - apply tr; exists (r * u). - exact (ap (fun w => r * w) pu @ rng_mult_assoc r u a). -Defined. - -Definition rng_divides_plus {R : CRing} {d a b : R} - (pa : rng_divides d a) (pb : rng_divides d b) : rng_divides d (a + b). -Proof. - strip_truncations; destruct pa as [c1 p1], pb as [c2 p2]. - apply tr; exists (c1 + c2). - exact (ap011 (+) p1 p2 @ (rng_dist_r c1 c2 d)^). -Defined. - -Definition rng_divides_negate_r {R : CRing} {a b : R} - (p : rng_divides a b) : rng_divides a (- b). -Proof. - strip_truncations; destruct p as [c pc]. - apply tr; exists (- c). - exact (ap (fun w => - w) pc @ (rng_mult_negate_l c a)^). -Defined. - -(** ** A finitely generated ideal of a Bézout ring is principal *) - -(** A gcd of the [X i] lying in the ideal they generate and dividing each. *) -Definition finite_gcd {R : CRing} `{IsBezoutRing R} - : forall (n : nat) (X : Fin n -> R), - merely { g : R - & ((forall i, rng_divides g (X i)) * ideal_generated_finite X g)%type }. -Proof. - induction n as [|n IH]; intro X. - - apply tr; exists 0; split. - + intro i; destruct i. - + apply ideal_in_zero. - - pose proof (IH (fun i => X (inl i))) as IH'. - strip_truncations; destruct IH' as [a' [hdiv' hin']]. - pose proof (bezout_relation a' (X (inr tt))) as hb. - strip_truncations; destruct hb as [u [v hgcd]]. - destruct hgcd as [[gda' gdlast] _]. - apply tr; exists (u * a' + v * X (inr tt)); split. - + intro j; destruct j as [i | t]. - * exact (rng_divides_trans gda' (hdiv' i)). - * destruct t; exact gdlast. - + napply ideal_in_plus. - { rapply isleftideal. - exact (ideal_generated_rec - (X := hfiber (fun i => X (inl i))) - (I := ideal_generated_finite X) - (fun r hf => tr (igt_in (inl hf.1; hf.2))) a' (tr hin')). } - rapply isleftideal. - exact (tr (igt_in (inr tt; idpath))). -Defined. - -(** A finitely generated ideal of a Bézout ring is principal. *) -Definition isprincipal_finite_bezout `{Univalence} {R : CRing} `{IsBezoutRing R} - {n : nat} (X : Fin n -> R) - : IsPrincipal (ideal_generated_finite X). -Proof. - pose proof (finite_gcd n X) as hg. - strip_truncations; destruct hg as [g [gdiv gin]]. - apply tr; exists g. - apply equiv_path_ideal; split. - - napply (ideal_generated_rec (I := ideal_generated_finite X)). - intros r hf. - exact (transport (ideal_generated_finite X) hf.2 gin). - - napply (ideal_generated_rec (I := ideal_generated_finite (fun _ : Fin 1 => g))). - intros r hf. - pose proof (gdiv hf.1) as hd; strip_truncations; destruct hd as [c pc]. - apply tr. - exact (transport (ideal_generated_type _) (pc^ @ hf.2) - (igt_mul_l (r := c) (igt_in (fin_zero; idpath)))). -Defined. diff --git a/theories/Algebra/Rings/FinitelyPresented.v b/theories/Algebra/Rings/FinitelyPresented.v deleted file mode 100644 index 6e4e5c35a8c..00000000000 --- a/theories/Algebra/Rings/FinitelyPresented.v +++ /dev/null @@ -1,27 +0,0 @@ -From HoTT Require Import Basics Truncations.Core. -Require Import Algebra.Rings.Ring Algebra.Rings.Module Algebra.Rings.Vector. - -Local Open Scope mc_add_scope. - -(** * Finitely generated and finitely presented modules - - Following Christensen and Flaten, Definition 2.6.1. *) - -(** The free module [R^n]. *) -Definition module_rn (R : Ring) (n : nat) : LeftModule R - := Build_LeftModule R (abgroup_vector R n) (isleftmodule_isleftmodule_vector R n). - -(** A module is finitely generated if some [R^n] surjects onto it. *) -Definition IsFinitelyGenerated {R : Ring} (M : LeftModule R) : Type - := merely { n : nat - & { f : LeftModuleHomomorphism (module_rn R n) M & IsSurjection f } }. - -(** A module is finitely presented if it admits a finite presentation: an - [R^n] surjecting onto it whose kernel is the image of some [R^m]. *) -Definition IsFinitelyPresented {R : Ring} (M : LeftModule R) : Type - := merely { n : nat - & { f : LeftModuleHomomorphism (module_rn R n) M - & IsSurjection f - * merely { m : nat - & { g : LeftModuleHomomorphism (module_rn R m) (module_rn R n) - & forall x, (f x = 0) <-> hexists (fun y => g y = x) } } } }. diff --git a/theories/Algebra/Rings/FreeModule.v b/theories/Algebra/Rings/FreeModule.v deleted file mode 100644 index e540a5d45ac..00000000000 --- a/theories/Algebra/Rings/FreeModule.v +++ /dev/null @@ -1,613 +0,0 @@ -From HoTT Require Import Basics Types. -From HoTT.WildCat Require Import Core. -Require Import Classes.interfaces.canonical_names. -Require Import Spaces.Nat.Core. -Require Import HSet Truncations.Core Modalities.ReflectiveSubuniverse. -Require Import Algebra.Groups.Group Algebra.Groups.Subgroup. -Require Import Algebra.AbGroups.AbelianGroup Algebra.AbGroups.AbHom. -Require Import Algebra.Rings.Ring Algebra.Rings.CRing Algebra.Rings.Module. -Require Import Algebra.Rings.Bezout. - -Local Open Scope module_scope. -Local Open Scope mc_add_scope. - -(** * Splitting of module homomorphisms with a section *) - -(** The inclusion of a submodule as a module homomorphism. *) -Definition lm_subincl {R : Ring} {M : LeftModule R} (N : LeftSubmodule M) - : leftmodule_leftsubmodule N $-> M. -Proof. - snapply Build_LeftModuleHomomorphism'. - - exact pr1. - - intros r x y; reflexivity. -Defined. - -Section Splitting. - Context {R : Ring} {M Q : LeftModule R} - (f : M $-> Q) (s : Q $-> M) (hs : forall q, f (s q) = q). - - (** The complementary projection [id - s ∘ f]. *) - Definition lm_split_endo : M $-> M. - Proof. - snapply Build_LeftModuleHomomorphism. - - exact (grp_homo_id - grp_homo_compose s f). - - intros r m; cbn. - assert (p : s (f (r *L m)) = r *L s (f m)). - { transitivity (s (r *L f m)). - - apply ap; napply lm_homo_lact. - - napply lm_homo_lact. } - lhs napply (ap (fun z => r *L m - z) p). - symmetry. - lhs napply (lm_dist_l r m (- s (f m))). - refine (ap (fun z => r *L m + z) _). - exact (lm_neg r (s (f m))). - Defined. - - (** The projection of [M] onto the kernel of [f]. *) - Definition lm_split_proj : M $-> lm_kernel f. - Proof. - snapply (lm_corestrict (lm_kernel f) lm_split_endo). - intro m; cbn. - lhs napply grp_homo_op. - lhs napply (ap (fun z => f m + z) (grp_homo_inv f (s (f m)))). - lhs napply (ap (fun z => f m + (- z)) (hs (f m))). - apply right_inverse. - Defined. - - (** The forward map of the splitting. *) - Definition lm_split_fwd : M $-> lm_prod (lm_kernel f) Q - := lm_prod_corec M lm_split_proj f. - - (** The backward map of the splitting. *) - Definition lm_split_bwd : lm_prod (lm_kernel f) Q $-> M - := lm_prod_rec (lm_subincl (lm_kernel f)) s. - - Definition lm_split_bwd_fwd (m : M) : lm_split_bwd (lm_split_fwd m) = m. - Proof. - cbn. - refine ((grp_assoc m (- s (f m)) (s (f m)))^ @ _). - refine (ap (fun z => m + z) (left_inverse (s (f m))) @ _). - apply right_identity. - Defined. - - Definition lm_split_fwd_bwd (kq : lm_prod (lm_kernel f) Q) - : lm_split_fwd (lm_split_bwd kq) = kq. - Proof. - destruct kq as [[k1 k2] q]. - assert (faux : f (k1 + s q) = q). - { lhs napply grp_homo_op. - lhs napply (ap (fun z => z + f (s q)) k2). - lhs napply (ap (fun z => mon_unit + z) (hs q)). - apply left_identity. } - snapply path_prod'. - - apply path_sigma_hprop; cbn. - lhs napply (ap (fun w => k1 + s q - s w) faux). - refine ((grp_assoc k1 (s q) (- s q))^ @ _). - refine (ap (fun z => k1 + z) (right_inverse (s q)) @ _). - apply right_identity. - - exact faux. - Defined. - - (** [M] is the direct sum of the kernel of [f] and [Q]. *) - Definition lm_split_iso - : LeftModuleIsomorphism M (lm_prod (lm_kernel f) Q). - Proof. - snapply Build_LeftModuleIsomorphism'. - - snapply Build_GroupIsomorphism. - + exact lm_split_fwd. - + exact (isequiv_adjointify lm_split_fwd lm_split_bwd - lm_split_fwd_bwd lm_split_bwd_fwd). - - intros r m; napply lm_homo_lact. - Defined. - -End Splitting. - -(** * Free modules *) - -(** The trivial (zero) module. *) -Definition lm_zero (R : Ring) : LeftModule R. -Proof. - snapply (Build_LeftModule R abgroup_trivial). - snapply Build_IsLeftModule. - - exact (fun _ x => x). - - intros r m n; apply path_contr. - - intros r s m; apply path_contr. - - intros r s m; apply path_contr. - - intros m; apply path_contr. -Defined. - -(** The regular module: a ring as a module over itself. *) -Definition lm_regular (R : Ring) : LeftModule R - := Build_LeftModule R R _. - -(** The free module [R^n]. *) -Fixpoint lm_power (R : Ring) (n : nat) : LeftModule R := - match n with - | 0%nat => lm_zero R - | S k => lm_prod (lm_regular R) (lm_power R k) - end. - -(** A module is free if it is isomorphic to some [R^n]. *) -Definition IsFreeModule {R : Ring} (M : LeftModule R) : Type - := merely { n : nat & LeftModuleIsomorphism M (lm_power R n) }. - -(** Composition of module isomorphisms. *) -Definition lm_iso_compose {R : Ring} {M N L : LeftModule R} - (g : LeftModuleIsomorphism N L) (f : LeftModuleIsomorphism M N) - : LeftModuleIsomorphism M L. -Proof. - snapply Build_LeftModuleIsomorphism. - - exact (lm_homo_compose g f). - - rapply isequiv_compose. -Defined. - -(** Freeness transports across isomorphisms. *) -Definition isfreemodule_iso {R : Ring} {M N : LeftModule R} - (e : LeftModuleIsomorphism M N) (H : IsFreeModule N) : IsFreeModule M. -Proof. - strip_truncations. - exact (tr (H.1; lm_iso_compose H.2 e)). -Defined. - -(** The zero module is a left unit for the direct product. *) -Definition lm_prod_zero_l {R : Ring} {X : LeftModule R} - : LeftModuleIsomorphism (lm_prod (lm_zero R) X) X. -Proof. - snapply Build_LeftModuleIsomorphism. - - exact lm_prod_snd. - - snapply isequiv_adjointify. - + exact lm_prod_inr. - + intro x; reflexivity. - + intros [z x]; snapply path_prod'; [apply path_contr | reflexivity]. -Defined. - -(** The zero module is a right unit for the direct product. *) -Definition lm_prod_zero_r {R : Ring} {X : LeftModule R} - : LeftModuleIsomorphism (lm_prod X (lm_zero R)) X. -Proof. - snapply Build_LeftModuleIsomorphism. - - exact lm_prod_fst. - - snapply isequiv_adjointify. - + exact lm_prod_inl. - + intro x; reflexivity. - + intros [x z]; snapply path_prod'; [reflexivity | apply path_contr]. -Defined. - -(** Associativity of the direct product. *) -Definition lm_prod_assoc {R : Ring} {A B C : LeftModule R} - : LeftModuleIsomorphism (lm_prod (lm_prod A B) C) (lm_prod A (lm_prod B C)). -Proof. - snapply Build_LeftModuleIsomorphism. - - exact (lm_prod_corec _ (lm_homo_compose lm_prod_fst lm_prod_fst) - (lm_prod_corec _ (lm_homo_compose lm_prod_snd lm_prod_fst) lm_prod_snd)). - - snapply isequiv_adjointify. - + exact (lm_prod_corec _ - (lm_prod_corec _ lm_prod_fst (lm_homo_compose lm_prod_fst lm_prod_snd)) - (lm_homo_compose lm_prod_snd lm_prod_snd)). - + intros [a [b c]]; reflexivity. - + intros [[a b] c]; reflexivity. -Defined. - -(** The direct product is functorial in its second argument. *) -Definition lm_prod_iso_r {R : Ring} {A B B' : LeftModule R} - (eB : LeftModuleIsomorphism B B') - : LeftModuleIsomorphism (lm_prod A B) (lm_prod A B'). -Proof. - snapply Build_LeftModuleIsomorphism. - - exact (lm_prod_corec _ lm_prod_fst (lm_homo_compose eB lm_prod_snd)). - - snapply isequiv_adjointify. - + exact (lm_prod_corec _ lm_prod_fst - (lm_homo_compose (lm_iso_inverse eB) lm_prod_snd)). - + intros [a b']; snapply path_prod'; [ reflexivity | exact (eisretr _ b') ]. - + intros [a b]; snapply path_prod'; [ reflexivity | exact (eissect _ b) ]. -Defined. - -(** The direct product is functorial in both arguments. *) -Definition lm_prod_iso2 {R : Ring} {A A' B B' : LeftModule R} - (eA : LeftModuleIsomorphism A A') (eB : LeftModuleIsomorphism B B') - : LeftModuleIsomorphism (lm_prod A B) (lm_prod A' B'). -Proof. - snapply Build_LeftModuleIsomorphism. - - exact (lm_prod_corec _ (lm_homo_compose eA lm_prod_fst) - (lm_homo_compose eB lm_prod_snd)). - - snapply isequiv_adjointify. - + exact (lm_prod_corec _ (lm_homo_compose (lm_iso_inverse eA) lm_prod_fst) - (lm_homo_compose (lm_iso_inverse eB) lm_prod_snd)). - + intros [a' b']; snapply path_prod'; [ exact (eisretr _ a') | exact (eisretr _ b') ]. - + intros [a b]; snapply path_prod'; [ exact (eissect _ a) | exact (eissect _ b) ]. -Defined. - -(** [R^m] direct sum [R^n] is [R^(m+n)]. *) -Definition lm_power_add {R : Ring} (m n : nat) - : LeftModuleIsomorphism (lm_prod (lm_power R m) (lm_power R n)) - (lm_power R (m + n)%nat). -Proof. - induction m as [|k IH]. - - exact lm_prod_zero_l. - - exact (lm_iso_compose (lm_prod_iso_r IH) lm_prod_assoc). -Defined. - -(** A direct sum of free modules is free. *) -Definition isfreemodule_prod {R : Ring} {M N : LeftModule R} - (HM : IsFreeModule M) (HN : IsFreeModule N) - : IsFreeModule (lm_prod M N). -Proof. - strip_truncations. - exact (tr ((HM.1 + HN.1)%nat; - lm_iso_compose (lm_power_add HM.1 HN.1) (lm_prod_iso2 HM.2 HN.2))). -Defined. - -(** A homomorphism with a section and free kernel and codomain has a free - domain. *) -Definition isfreemodule_split {R : Ring} {M Q : LeftModule R} - (f : M $-> Q) (s : Q $-> M) (hs : forall q, f (s q) = q) - (Hk : IsFreeModule (lm_kernel f)) (HQ : IsFreeModule Q) - : IsFreeModule M - := isfreemodule_iso (lm_split_iso f s hs) (isfreemodule_prod Hk HQ). - -(** [R^n] is free. *) -Definition isfreemodule_lm_power {R : Ring} (n : nat) - : IsFreeModule (lm_power R n). -Proof. - apply tr; exists n. - snapply Build_LeftModuleIsomorphism. - - exact (lm_homo_id _). - - exact _. -Defined. - -(** The regular module is free. *) -Definition isfreemodule_lm_regular {R : Ring} - : IsFreeModule (lm_regular R) - := tr (1%nat; lm_iso_inverse lm_prod_zero_r). - -(** A contractible module is free of rank zero. *) -Definition isfreemodule_contr {R : Ring} (M : LeftModule R) `{Contr M} - : IsFreeModule M. -Proof. - apply tr; exists 0%nat. - snapply Build_LeftModuleIsomorphism. - - snapply Build_LeftModuleHomomorphism'. - + exact (fun _ => 0). - + intros r x y; apply path_contr. - - rapply isequiv_contr_contr. -Defined. - -(** An injective homomorphism corestricts to an isomorphism onto its image. *) -Definition lm_iso_image {R : Ring} {M N : LeftModule R} (f : M $-> N) - `{IsEmbedding f} - : LeftModuleIsomorphism M (lm_image f). -Proof. - snapply Build_LeftModuleIsomorphism. - - exact (lm_corestrict (lm_image f) f (fun m => tr (m; idpath))). - - snapply isequiv_surj_emb. - + apply BuildIsSurjection. - intro b. - napply (Trunc_functor (-1) _ b.2). - intros [x q]. - exists x; apply path_sigma_hprop; exact q. - + apply isembedding_isinj_hset. - intros a b r. - exact (isinj_embedding f _ a b (ap pr1 r)). -Defined. - -(** Submodules with the same membership are isomorphic as modules. *) -Definition lm_iso_of_submodule_iff {R : Ring} {M : LeftModule R} - (N N' : LeftSubmodule M) (h : forall y, N y <-> N' y) - : LeftModuleIsomorphism (leftmodule_leftsubmodule N) - (leftmodule_leftsubmodule N'). -Proof. - snapply Build_LeftModuleIsomorphism. - - snapply Build_LeftModuleHomomorphism'. - + exact (fun yn => (yn.1; fst (h yn.1) yn.2)). - + intros r x y; by apply path_sigma_hprop. - - snapply isequiv_adjointify. - + exact (fun yn => (yn.1; snd (h yn.1) yn.2)). - + intros [y hy]; by apply path_sigma_hprop. - + intros [y hy]; by apply path_sigma_hprop. -Defined. - -(** A homomorphism out of the regular module is multiplication by the image - of [1]. *) -Definition lm_homo_regular_mult {R : Ring} {M : LeftModule R} - (h : lm_regular R $-> M) (r : R) : h r = r *L h 1. -Proof. - lhs napply (ap h (rng_mult_one_r r)^). - napply lm_homo_lact. -Defined. - -(** Right multiplication by a ring element. *) -Definition lm_right_mult {R : Ring} (d : R) : lm_regular R $-> lm_regular R. -Proof. - snapply Build_LeftModuleHomomorphism. - - exact (grp_homo_rng_right_mult d). - - intros r x; symmetry; rapply rng_mult_assoc. -Defined. - -(** Over a commutative ring, multiplication by a regular element is an - embedding. *) -Definition isembedding_lm_right_mult {R : CRing} (d : R) (hd : IsRegular d) - : IsEmbedding (lm_right_mult (R:=R) d). -Proof. - apply isembedding_isinj_hset. - intros x y p. - apply hd. - exact (rng_mult_comm d x @ p @ rng_mult_comm y d). -Defined. - -(** The principal submodule generated by a regular element is free of rank - one. *) -Definition isfreemodule_image_right_mult {R : CRing} (d : R) (hd : IsRegular d) - : IsFreeModule (lm_image (lm_right_mult (R:=R) d)) - := isfreemodule_iso - (lm_iso_inverse - (@lm_iso_image _ _ _ (lm_right_mult d) (isembedding_lm_right_mult d hd))) - isfreemodule_lm_regular. - -(** * Finitely generated submodules of [R] are free *) - -(** A homomorphism out of [R^(S j)] decomposes along the first coordinate. *) -Definition lm_image_decomp {R : Ring} {j : nat} - (g : lm_power R (S j) $-> lm_regular R) (x : lm_power R (S j)) - : g x = fst x *L g (lm_prod_inl 1) - + lm_homo_compose g lm_prod_inr (snd x). -Proof. - transitivity (g (lm_prod_inl (fst x) + lm_prod_inr (snd x))). - - apply ap; snapply path_prod'. - + exact (right_identity (fst x))^. - + exact (left_identity (snd x))^. - - lhs napply grp_homo_op. - f_ap. - exact (lm_homo_regular_mult (lm_homo_compose g lm_prod_inl) (fst x)). -Defined. - -(** The image of a homomorphism [R^k -> R] over a Bézout ring is principal. *) -Definition lm_image_principal {R : CRing} `{IsBezoutRing R} - : forall (k : nat) (g : lm_power R k $-> lm_regular R), - merely { d : R & forall y, lm_image g y <-> rng_divides d y }. -Proof. - induction k as [|j IH]; intro g. - - apply tr; exists 0; intro y; split. - + intros hy; strip_truncations; destruct hy as [x p]. - apply tr; exists 0. - refine (p^ @ ap g (path_ishprop x mon_unit) @ grp_homo_unit g @ _). - exact (rng_mult_zero_r 0)^. - + intros hd; strip_truncations; destruct hd as [c p]. - apply tr; exists mon_unit. - refine (grp_homo_unit g @ _). - exact (p @ rng_mult_zero_r c)^. - - pose (a := g (lm_prod_inl 1)). - pose (g' := lm_homo_compose g lm_prod_inr). - pose proof (IH g') as IHg'; strip_truncations; destruct IHg' as [d' H']. - pose proof (bezout_relation a d') as hb; strip_truncations. - destruct hb as [u [v hg]]. - apply tr; exists (u * a + v * d'); intro y; split. - + intros hy; strip_truncations; destruct hy as [x p]. - refine (transport (rng_divides (u * a + v * d')) ((lm_image_decomp g x)^ @ p) _). - apply rng_divides_plus. - * exact (rng_divides_mul_l (fst x) (fst (fst hg))). - * refine (rng_divides_trans (snd (fst hg)) _). - exact (fst (H' (g' (snd x))) (tr (snd x; idpath))). - + intros hd; strip_truncations; destruct hd as [c p]. - assert (hd' : lm_image g' d') by exact (snd (H' d') (rng_divides_refl d')). - strip_truncations; destruct hd' as [x'' q]. - assert (hgg : lm_image g (u * a + v * d')). - { apply tr. - exists (u *L lm_prod_inl 1 + v *L lm_prod_inr x''). - lhs napply grp_homo_op. - f_ap. - - lhs napply lm_homo_lact; reflexivity. - - lhs napply lm_homo_lact; exact (ap (fun z => v *L z) q). } - refine (transport (lm_image g) p^ _). - rapply is_left_submodule; exact hgg. -Defined. - -(** The difference of two module homomorphisms. *) -Definition lm_homo_sub {R : Ring} {M N : LeftModule R} (f g : M $-> N) - : M $-> N. -Proof. - snapply Build_LeftModuleHomomorphism. - - exact (@lm_homo_map _ _ _ f - @lm_homo_map _ _ _ g). - - intros r m; cbn. - lhs napply (ap (fun z => z - g (r *L m)) (@lm_homo_lact _ _ _ f r m)). - lhs napply (ap (fun z => r *L f m - z) (@lm_homo_lact _ _ _ g r m)). - symmetry. - lhs napply (lm_dist_l r (f m) (- g m)). - napply (ap (fun z => r *L f m + z) (lm_neg r (g m))). -Defined. - -(** Scalar multiplication by a fixed element, as a homomorphism out of the - regular module. *) -Definition lm_scalar {R : Ring} {M : LeftModule R} (x : M) - : lm_regular R $-> M. -Proof. - snapply Build_LeftModuleHomomorphism. - - snapply Build_GroupHomomorphism. - + exact (fun c => c *L x). - + intros c c'; napply lm_dist_r. - - intros r c; symmetry; napply lm_assoc. -Defined. - -(** Division by a regular element is well-defined. *) -Definition rng_div_regular {R : CRing} {d : R} (dreg : IsRegular d) {y : R} - (h : rng_divides d y) : { c : R & y = c * d }. -Proof. - napply (Trunc_rec (A := { c : R & y = c * d }) _ h). - - apply hprop_allpath; intros [c p] [c' p']; apply path_sigma_hprop; cbn. - apply dreg. - exact (rng_mult_comm d c @ p^ @ p' @ rng_mult_comm c' d). - - exact idmap. -Defined. - -(** Dividing a homomorphism whose values are divisible by a regular [d]. *) -Definition lm_div_d {R : CRing} {d : R} (dreg : IsRegular d) {L : LeftModule R} - (h : L $-> lm_regular R) (hdiv : forall l, rng_divides d (h l)) - : L $-> lm_regular R. -Proof. - snapply Build_LeftModuleHomomorphism. - - snapply Build_GroupHomomorphism. - + exact (fun l => (rng_div_regular dreg (hdiv l)).1). - + intros l l'; apply dreg. - lhs napply rng_mult_comm. - lhs_V napply (rng_div_regular dreg (hdiv (l + l'))).2. - lhs napply grp_homo_op. - lhs napply (ap011 (+) (rng_div_regular dreg (hdiv l)).2 - (rng_div_regular dreg (hdiv l')).2). - lhs_V napply rng_dist_r. - napply rng_mult_comm. - - intros r l; apply dreg. - lhs napply rng_mult_comm. - lhs_V napply (rng_div_regular dreg (hdiv (r *L l))).2. - lhs napply (@lm_homo_lact _ _ _ h r l). - lhs napply (ap (fun z => r * z) (rng_div_regular dreg (hdiv l)).2). - lhs napply rng_mult_assoc. - napply rng_mult_comm. -Defined. - -(** A finitely generated submodule of [R] over a Bézout domain is free. *) -Definition isfreemodule_image_to_regular {R : CRing} `{IsBezoutDomain R} (k : nat) - (g : lm_power R k $-> lm_regular R) : IsFreeModule (lm_image g). -Proof. - pose proof (lm_image_principal k g) as hp; strip_truncations. - destruct hp as [d Hg]. - destruct (intdom_zero_or_regular d) as [d0 | dreg]. - - napply isfreemodule_contr. - snapply (Build_Contr _ (0; snd (Hg 0) (tr (0; (rng_mult_zero_l d)^)))). - intros [y hy]; apply path_sigma_hprop; cbn. - pose proof (transport (fun z => rng_divides z y) d0 (fst (Hg y) hy)) as hdy. - strip_truncations; destruct hdy as [c q]. - exact (q @ rng_mult_zero_r c)^. - - assert (hrm : forall y, lm_image g y <-> lm_image (lm_right_mult d) y). - { intro y; split; intro h. - - exact (Trunc_functor (-1) (fun cp => (cp.1; cp.2^)) (fst (Hg y) h)). - - exact (snd (Hg y) (Trunc_functor (-1) (fun cp => (cp.1; cp.2^)) h)). } - exact (isfreemodule_iso (lm_iso_of_submodule_iff _ _ hrm) - (isfreemodule_image_right_mult d dreg)). -Defined. - -(** A homomorphism landing in [{0} × R^m] has image isomorphic to that of its - second component. *) -Definition lm_iso_image_snd {R : Ring} {L : LeftModule R} {m : nat} - (h : L $-> lm_power R (S m)) (hfst : forall l, fst (h l) = 0) - : LeftModuleIsomorphism (lm_image h) - (lm_image (lm_homo_compose lm_prod_snd h)). -Proof. - snapply Build_LeftModuleIsomorphism. - - snapply (lm_corestrict (lm_image (lm_homo_compose lm_prod_snd h)) - (lm_homo_compose lm_prod_snd (lm_subincl (lm_image h)))). - intros [y py]. - exact (Trunc_functor (-1) (fun lq => (lq.1; ap snd lq.2)) py). - - snapply isequiv_adjointify. - + snapply (lm_corestrict (lm_image h) - (lm_homo_compose lm_prod_inr - (lm_subincl (lm_image (lm_homo_compose lm_prod_snd h))))). - intros [z pz]. - exact (Trunc_functor (-1) - (fun lq => (lq.1; path_prod' (hfst lq.1) lq.2)) pz). - + intros [z pz]; by apply path_sigma_hprop. - + intros [y py]; apply path_sigma_hprop; cbn. - strip_truncations; destruct py as [l q]. - exact (path_prod' (hfst l)^ (ap snd q)^ @ q). -Defined. - -(** The image of a homomorphism into a contractible module is free. *) -Definition isfreemodule_image_into_contr {R : Ring} {M N : LeftModule R} - `{Contr N} (f : M $-> N) : IsFreeModule (lm_image f). -Proof. - napply isfreemodule_contr. - snapply Build_Contr. - - exact (0; tr (0; grp_homo_unit f)). - - intros [y hy]; apply path_sigma_hprop; apply path_contr. -Defined. - -(** * Finitely generated submodules of [R^n] are free *) - -(** A finitely generated submodule of [R^n] over a Bézout domain is free; the - image of any homomorphism [R^k -> R^n] is free. *) -Definition isfreemodule_image_power {R : CRing} `{IsBezoutDomain R} - : forall (n k : nat) (phi : lm_power R k $-> lm_power R n), - IsFreeModule (lm_image phi). -Proof. - induction n as [|m IHn]; intros k phi. - - exact (isfreemodule_image_into_contr phi). - - pose (g := lm_homo_compose lm_prod_fst phi). - pose proof (lm_image_principal k g) as hp; strip_truncations. - destruct hp as [d Hg]. - assert (hdivg : forall x, rng_divides d (g x)) - by exact (fun x => fst (Hg (g x)) (grp_image_in g x)). - destruct (intdom_zero_or_regular d) as [d0 | dreg]. - + (* The principal generator vanishes, so [phi] lands in the second factor. *) - assert (hfst : forall x, fst (phi x) = 0). - { intro x. - pose proof (transport (fun z => rng_divides z (g x)) d0 (hdivg x)) as hx. - strip_truncations; destruct hx as [c q]. - exact (q @ rng_mult_zero_r c). } - napply (isfreemodule_iso (lm_iso_image_snd phi hfst)). - exact (IHn k (lm_homo_compose lm_prod_snd phi)). - + (* The principal generator is regular; split off a free rank-one summand. *) - pose proof (snd (Hg d) (rng_divides_refl d)) as hd0; strip_truncations. - destruct hd0 as [x0 qx0]. - pose (q := lm_div_d dreg g hdivg). - pose (kappa := lm_homo_sub phi (lm_homo_compose (lm_scalar (phi x0)) q)). - assert (hfstk : forall x, fst (kappa x) = 0). - { intro x. - lhs napply (ap (fun z => g x - q x * z) qx0). - lhs_V napply (ap (fun z => g x - z) (rng_div_regular dreg (hdivg x)).2). - exact (right_inverse (g x)). } - assert (hqzero : forall x, g x = 0 -> q x = 0). - { intros x hgx; apply dreg. - lhs napply rng_mult_comm. - lhs_V napply (rng_div_regular dreg (hdivg x)).2. - lhs napply hgx. - exact (rng_mult_zero_r d)^. } - assert (hkphi : forall x, phi (x - q x *L x0) = kappa x). - { intro x. - lhs napply grp_homo_op. - napply (ap (fun z => phi x + z)). - lhs napply grp_homo_inv. - napply (ap (fun z => - z)). - napply (@lm_homo_lact _ _ _ phi (q x) x0). } - pose (f := lm_corestrict (lm_image g) - (lm_homo_compose lm_prod_fst (lm_subincl (lm_image phi))) - (fun mm => Trunc_functor (-1) - (fun xp => (xp.1; ap fst xp.2)) mm.2)). - pose (m0 := (phi x0; tr (x0; idpath)) : lm_image phi). - pose (cQ := lm_div_d dreg (lm_subincl (lm_image g)) - (fun qq => fst (Hg qq.1) qq.2)). - pose (s := lm_homo_compose - (lm_scalar (M := leftmodule_leftsubmodule (lm_image phi)) m0) cQ). - assert (hs : forall qq, f (s qq) = qq). - { intro qq; apply path_sigma_hprop. - lhs napply (ap (fun z => cQ qq * z) qx0). - exact (rng_div_regular dreg (fst (Hg qq.1) qq.2)).2^. } - assert (Hk : IsFreeModule (lm_kernel f)). - { snapply (isfreemodule_iso (N := lm_image kappa)). - - snapply Build_LeftModuleIsomorphism. - + snapply Build_LeftModuleHomomorphism'. - * intro mp. - exists mp.1.1. - refine (Trunc_functor (-1) _ mp.1.2). - intro xp. - exists xp.1. - pose (hg0 := ap fst xp.2 @ ap pr1 mp.2). - refine (_ @ xp.2). - lhs napply (ap (fun z => phi xp.1 - z *L phi x0) - (hqzero xp.1 hg0)). - lhs napply (ap (fun z => phi xp.1 - z) (lm_zero_l (phi x0))). - exact (ap (fun z => phi xp.1 + z) grp_inv_unit - @ grp_unit_r (phi xp.1)). - * intros r x y; apply path_sigma_hprop; reflexivity. - + snapply isequiv_adjointify. - * intro zp. - snrefine ((zp.1; _); _). - -- exact (Trunc_functor (-1) - (fun xp => (xp.1 - q xp.1 *L x0; hkphi xp.1 @ xp.2)) zp.2). - -- apply path_sigma_hprop. - pose proof zp.2 as pz; strip_truncations; destruct pz as [x px]. - exact ((ap fst px)^ @ hfstk x). - * intros [z pz]; apply path_sigma_hprop; reflexivity. - * intros [[w pw] pf]; apply path_sigma_hprop; - apply path_sigma_hprop; reflexivity. - - exact (isfreemodule_iso (lm_iso_image_snd kappa hfstk) - (IHn k (lm_homo_compose lm_prod_snd kappa))). } - exact (isfreemodule_split f s hs Hk (isfreemodule_image_to_regular k g)). -Defined. diff --git a/theories/Algebra/Rings/GroupRing.v b/theories/Algebra/Rings/GroupRing.v deleted file mode 100644 index 47eb8253aad..00000000000 --- a/theories/Algebra/Rings/GroupRing.v +++ /dev/null @@ -1,180 +0,0 @@ -From HoTT Require Import Basics Types. -From HoTT.WildCat Require Import Core. -Require Import Classes.interfaces.canonical_names. -Require Import Algebra.Groups.Group. -Require Import Algebra.AbGroups.AbelianGroup Algebra.AbGroups.AbHom - Algebra.AbGroups.FreeAbelianGroup. -Require Import Algebra.Rings.Ring. - -Local Open Scope mc_scope. -Local Open Scope mc_add_scope. - -(** * The group ring [ℤG] - - Following Christensen and Flaten, Construction 2.7.1 and Proposition 2.7.2: - the group ring of [G] is the free abelian group on [G] with multiplication - extending the group operation, together with its universal property. *) - -Section GroupRing. - Context `{Funext} (G : Group). - - Definition group_ring_ab : AbGroup := FreeAbGroup G. - - Local Notation ZG := group_ring_ab. - - (** Multiplication, as a homomorphism into the endomorphism group. *) - Definition group_ring_mult_hom : ZG $-> ab_hom ZG ZG - := FreeAbGroup_rec (A := ab_hom ZG ZG) - (fun g => FreeAbGroup_rec (A := ZG) (fun h => freeabgroup_in (sg_op g h))). - - Instance group_ring_mult : Mult ZG - := fun x y => group_ring_mult_hom x y. - - Instance group_ring_one : One ZG := freeabgroup_in mon_unit. - - (** Generators multiply by the group operation. *) - Definition group_ring_mult_in (g h : G) - : (freeabgroup_in g * freeabgroup_in h : ZG) = freeabgroup_in (sg_op g h) - := idpath. - - (** Evaluation at a point, as a homomorphism out of the endomorphism group. *) - Definition group_ring_eval (y : ZG) : ab_hom ZG ZG $-> ZG. - Proof. - snapply Build_GroupHomomorphism. - - exact (fun phi => phi y). - - intros phi psi; reflexivity. - Defined. - - Instance group_ring_left_distribute : LeftDistribute (A:=ZG) (.*.) (+). - Proof. - intros x y z; exact (grp_homo_op (group_ring_mult_hom x) y z). - Defined. - - Instance group_ring_right_distribute : RightDistribute (A:=ZG) (.*.) (+). - Proof. - intros x y z. - refine (ap (fun phi : ab_hom ZG ZG => phi z) - (grp_homo_op group_ring_mult_hom x y) @ _). - reflexivity. - Defined. - - Instance group_ring_left_identity : LeftIdentity (A:=ZG) (.*.) 1. - Proof. - intro x. - exact (FreeAbGroup_ind_homotopy - (f := group_ring_mult_hom (freeabgroup_in mon_unit)) - (f' := grp_homo_id) - (fun g => ap freeabgroup_in (left_identity g)) x). - Defined. - - Instance group_ring_right_identity : RightIdentity (A:=ZG) (.*.) 1. - Proof. - intro x. - exact (FreeAbGroup_ind_homotopy - (f := group_ring_eval (freeabgroup_in mon_unit) $o group_ring_mult_hom) - (f' := grp_homo_id) - (fun g => ap freeabgroup_in (right_identity g)) x). - Defined. - - (** Left multiplication by a fixed element, as a homomorphism. *) - Definition group_ring_lmul (a : ZG) : ZG $-> ZG := group_ring_mult_hom a. - - (** Associativity on generators reduces to associativity in [G]. *) - Definition group_ring_assoc_gen (g h k : G) - : (freeabgroup_in g * (freeabgroup_in h * freeabgroup_in k) : ZG) - = (freeabgroup_in g * freeabgroup_in h) * freeabgroup_in k. - Proof. - exact (ap freeabgroup_in (simple_associativity g h k)). - Defined. - - Instance group_ring_associative : Associative (A:=ZG) (.*.). - Proof. - intros x y z. - change ((group_ring_eval (y * z) $o group_ring_mult_hom) x - = (group_ring_eval z $o (group_ring_mult_hom - $o (group_ring_eval y $o group_ring_mult_hom))) x). - revert x; rapply FreeAbGroup_ind_homotopy; intro g. - change ((group_ring_lmul (freeabgroup_in g) - $o (group_ring_eval z $o group_ring_mult_hom)) y - = (group_ring_eval z $o (group_ring_mult_hom - $o group_ring_lmul (freeabgroup_in g))) y). - revert y; rapply FreeAbGroup_ind_homotopy; intro h. - change ((group_ring_lmul (freeabgroup_in g) - $o group_ring_lmul (freeabgroup_in h)) z - = group_ring_lmul (freeabgroup_in g * freeabgroup_in h) z). - revert z; rapply FreeAbGroup_ind_homotopy; intro k. - exact (group_ring_assoc_gen g h k). - Defined. - - Definition group_ring : Ring := Build_Ring ZG _ _ _ _ _ _ _. - - (** The universal property: a homomorphism from [G] to the units of a ring - [R] extends to a ring homomorphism out of [ℤG]. *) - Definition group_ring_rec (R : Ring) - (psi : GroupHomomorphism G (rng_unit_group R)) - : RingHomomorphism group_ring R. - Proof. - pose (map := FreeAbGroup_rec (A := R) (fun g => (psi g).1) - : group_ring_ab $-> R). - snapply (Build_RingHomomorphism' group_ring R map). - snapply Build_IsMonoidPreserving. - - intros x y. - change ((grp_homo_compose map (group_ring_eval y $o group_ring_mult_hom)) x - = grp_homo_compose (grp_homo_rng_right_mult (map y)) map x). - revert x; rapply FreeAbGroup_ind_homotopy; intro g. - change ((grp_homo_compose map (group_ring_lmul (freeabgroup_in g))) y - = grp_homo_compose - (grp_homo_rng_left_mult (map (freeabgroup_in g))) map y). - revert y; rapply FreeAbGroup_ind_homotopy; intro h. - exact (ap pr1 (grp_homo_op psi g h)). - - exact (ap pr1 (grp_homo_unit psi)). - Defined. - - (** Conversely, a ring homomorphism out of [ℤG] restricts to a homomorphism - from [G] to the units, since each generator is invertible. *) - Definition group_ring_restrict (R : Ring) - (phi : RingHomomorphism group_ring R) - : GroupHomomorphism G (rng_unit_group R). - Proof. - snapply Build_GroupHomomorphism. - - intro g. - exists (phi (freeabgroup_in g)). - rapply (Build_IsInvertible (phi (freeabgroup_in g)) - (phi (freeabgroup_in (inv g)))). - + refine ((rng_homo_mult phi - (freeabgroup_in (inv g)) (freeabgroup_in g))^ @ _). - refine (ap phi (group_ring_mult_in (inv g) g) @ _). - refine (ap (fun u => phi (freeabgroup_in u)) (left_inverse g) @ _). - exact (rng_homo_one phi). - + refine ((rng_homo_mult phi - (freeabgroup_in g) (freeabgroup_in (inv g)))^ @ _). - refine (ap phi (group_ring_mult_in g (inv g)) @ _). - refine (ap (fun u => phi (freeabgroup_in u)) (right_inverse g) @ _). - exact (rng_homo_one phi). - - intros g g'. - apply path_sigma_hprop; cbn. - refine ((ap phi (group_ring_mult_in g g'))^ @ _). - exact (rng_homo_mult phi (freeabgroup_in g) (freeabgroup_in g')). - Defined. - - (** Ring homomorphisms out of [ℤG] correspond to homomorphisms from [G] to - the units. *) - Definition equiv_group_ring_rec (R : Ring) - : RingHomomorphism group_ring R <~> GroupHomomorphism G (rng_unit_group R). - Proof. - snapply equiv_adjointify. - - exact (group_ring_restrict R). - - exact (group_ring_rec R). - - intro psi. - apply equiv_path_grouphomomorphism; intro g. - by apply path_sigma_hprop. - - intro phi. - apply equiv_path_ringhomomorphism. - intro x; revert x. - rapply (FreeAbGroup_ind_homotopy - (f := grp_homo_rng_homo (group_ring_rec R (group_ring_restrict R phi))) - (f' := grp_homo_rng_homo phi)). - intro g; reflexivity. - Defined. - -End GroupRing. diff --git a/theories/Algebra/Rings/Module.v b/theories/Algebra/Rings/Module.v index 6a726774eb7..8764c4150f1 100644 --- a/theories/Algebra/Rings/Module.v +++ b/theories/Algebra/Rings/Module.v @@ -529,20 +529,6 @@ Definition rm_image {R : Ring} {M N : RightModule R} (f : M $-> N) : RightSubmodule N := lm_image (R:=rng_op R) f. -(** ** Corestriction to a submodule *) - -(** A homomorphism whose image lands in a submodule corestricts to it. *) -Definition lm_corestrict {R : Ring} {L M : LeftModule R} (P : LeftSubmodule M) - (h : L $-> M) (hP : forall l, P (h l)) - : L $-> P. -Proof. - snapply Build_LeftModuleHomomorphism'. - - exact (fun l => (h l; hP l)). - - intros r x y; apply path_sigma_hprop; cbn. - exact (grp_homo_op h (r *L x) y - @ ap (fun z => z + h y) (@lm_homo_lact _ _ _ h r x)). -Defined. - (** ** Quotient Modules *) (** The quotient abelian group of a module and a submodule has a natural ring action. *) @@ -621,7 +607,8 @@ Definition rm_first_iso `{Funext} {R : Ring} {M N : RightModule R} (f : M $-> N) (** ** Direct products *) -(** The direct product of modules. *) +(** TODO: generalise to biproducts *) +(** The direct product of modules *) Definition lm_prod {R : Ring} : LeftModule R -> LeftModule R -> LeftModule R. Proof. intros M N. @@ -696,48 +683,6 @@ Instance hasbinaryproducts_rightmodule {R : Ring} : HasBinaryProducts (RightModule R) := hasbinaryproducts_leftmodule (R:=rng_op R). -(** The direct product is also a coproduct: the injections and the recursor. *) - -Definition lm_prod_inl {R : Ring} {M N : LeftModule R} : M $-> lm_prod M N. -Proof. - snapply Build_LeftModuleHomomorphism. - - exact grp_prod_inl. - - intros r m; snapply path_prod'. - + reflexivity. - + exact (lm_zero_r r)^. -Defined. - -Definition lm_prod_inr {R : Ring} {M N : LeftModule R} : N $-> lm_prod M N. -Proof. - snapply Build_LeftModuleHomomorphism. - - exact grp_prod_inr. - - intros r n; snapply path_prod'. - + exact (lm_zero_r r)^. - + reflexivity. -Defined. - -Definition lm_prod_rec {R : Ring} {M N L : LeftModule R} - (f : M $-> L) (g : N $-> L) - : lm_prod M N $-> L. -Proof. - snapply Build_LeftModuleHomomorphism. - - exact (ab_biprod_rec f g). - - intros r mn; cbn. - refine (ap011 (+) (@lm_homo_lact _ _ _ f r (fst mn)) - (@lm_homo_lact _ _ _ g r (snd mn)) @ _). - exact (lm_dist_l r (f (fst mn)) (g (snd mn)))^. -Defined. - -Definition lm_prod_rec_beta_inl {R : Ring} {M N L : LeftModule R} - (f : M $-> L) (g : N $-> L) (m : M) - : lm_prod_rec f g (lm_prod_inl m) = f m - := ab_biprod_rec_beta_inl f g m. - -Definition lm_prod_rec_beta_inr {R : Ring} {M N L : LeftModule R} - (f : M $-> L) (g : N $-> L) (n : N) - : lm_prod_rec f g (lm_prod_inr n) = g n - := ab_biprod_rec_beta_inr f g n. - (** ** Finite Sums *) (** Left scalar multiplication distributes over finite sums of left module elements. *) diff --git a/theories/Algebra/Rings/ZBezout.v b/theories/Algebra/Rings/ZBezout.v deleted file mode 100644 index f7769037113..00000000000 --- a/theories/Algebra/Rings/ZBezout.v +++ /dev/null @@ -1,124 +0,0 @@ -From HoTT Require Import Basics Types Truncations.Core. -Require Import Spaces.Int Spaces.Nat.Core Spaces.Nat.Division. -Require Import Algebra.Rings.Ring Algebra.Rings.CRing Algebra.Rings.Z - Algebra.Rings.Bezout. - -Local Open Scope mc_scope. - -(** * The integers form a Bézout domain *) - -(** An integer with trivial absolute value is zero. *) -Definition int_abs_is_zero {x : cring_Z} (p : int_abs x = 0%nat) : x = 0. -Proof. - destruct x. - - exact (Empty_rec (neq_nat_zero_succ _ p^)). - - reflexivity. - - exact (Empty_rec (neq_nat_zero_succ _ p^)). -Defined. - -(** [cring_Z] has no zero divisors. *) -Definition int_mul_is_zero {x y : cring_Z} (p : x * y = 0) - : (x = 0) + (y = 0). -Proof. - assert (q : (int_abs x * int_abs y)%nat = 0%nat) - by exact ((int_abs_mul x y)^ @ ap int_abs p). - destruct (nat_mul_is_zero q) as [hx | hy]. - - exact (inl (int_abs_is_zero hx)). - - exact (inr (int_abs_is_zero hy)). -Defined. - -(** The integers form an integral domain. *) -Instance isintegraldomain_cring_Z : IsIntegralDomain cring_Z. -Proof. - intro x. - destruct (dec (x = 0)) as [p | np]. - - exact (inl p). - - right; intros y z h. - assert (hxyz : x * (y - z) = 0). - { lhs napply rng_dist_l. - lhs napply (ap (fun w => x * y + w) (rng_mult_negate_r x z)). - lhs napply (ap (fun w => w - x * z) h). - exact (right_inverse (x * z)). } - destruct (int_mul_is_zero hxyz) as [h0 | hyz]. - + exact (Empty_rec (np h0)). - + napply grp_moveL_1M; exact hyz. -Defined. - -(** A divisibility of naturals lifts to the integers. *) -Definition rng_divides_int_nat {d n : nat} (h : (d | n)%nat) - : rng_divides (R:=cring_Z) (int_of_nat d) (int_of_nat n). -Proof. - destruct h as [k p]. - apply tr; exists (int_of_nat k). - exact ((ap int_of_nat p)^ @ (int_nat_mul k d)^). -Defined. - -(** Divisibility by [g] only depends on the dividend up to sign. *) -Definition rng_divides_int_abs_r {g x : cring_Z} - (h : rng_divides g (int_of_nat (int_abs x))) : rng_divides g x. -Proof. - destruct (int_abs_decomp x) as [px | px]. - - exact (transport (rng_divides g) px^ h). - - exact (transport (rng_divides g) px^ (rng_divides_negate_r h)). -Defined. - -(** Bézout's identity for the integers, on nonnegative representatives. *) -Definition int_bezout_nat (a b : nat) - : merely { u : Int & { v : Int - & (u * int_of_nat a + v * int_of_nat b)%int = int_of_nat (nat_gcd a b) } }. -Proof. - destruct a as [|a]. - - apply tr; exists 0%int, 1%int. - exact (ap011 int_add (int_mul_0_l _) (int_mul_1_l _) @ int_add_0_l _). - - pose proof (nat_bezout_pos_l a.+1 b _) as hbz. - destruct hbz as [c [e r]]. - apply tr; exists (int_of_nat c), (- int_of_nat e)%int. - pose (Rint := int_nat_mul c a.+1 @ ap int_of_nat r @ (int_nat_add _ _)^ - @ ap (fun w => (int_of_nat (nat_gcd a.+1 b) + w)%int) - (int_nat_mul e b)^). - lhs napply (ap (fun w => (w + (- int_of_nat e) * int_of_nat b)%int) Rint). - lhs_V napply int_add_assoc. - exact (ap (fun w => (int_of_nat (nat_gcd a.+1 b) + w)%int) - ((int_dist_r (int_of_nat e) (- int_of_nat e) (int_of_nat b))^ - @ ap (fun s => (s * int_of_nat b)%int) (int_add_neg_r (int_of_nat e)) - @ int_mul_0_l (int_of_nat b)) - @ int_add_0_r (int_of_nat (nat_gcd a.+1 b))). -Defined. - -(** Rewriting a multiple of [|x|] as a multiple of [x], absorbing the sign. *) -Definition int_abs_to_var (u x : cring_Z) - : { U : cring_Z & u * (int_of_nat (int_abs x) : cring_Z) = U * x }. -Proof. - destruct (int_abs_decomp x) as [px | px]. - - exists u; exact (ap (fun w => u * w) px^). - - exists (- u). - exact ((rng_mult_negate_l u (- (int_of_nat (int_abs x) : cring_Z)) - @ ap (fun w => - w) (rng_mult_negate_r u (int_of_nat (int_abs x) : cring_Z)) - @ negate_involutive (u * (int_of_nat (int_abs x) : cring_Z)))^ - @ ap (fun w => (- u) * w) px^). -Defined. - -(** The integers form a Bézout ring: any two have a gcd that is a Bézout - combination of them. *) -Instance isbezoutring_cring_Z : IsBezoutRing cring_Z. -Proof. - intros x y. - pose proof (int_bezout_nat (int_abs x) (int_abs y)) as hbz. - strip_truncations; destruct hbz as [u0 [v0 hcombo]]. - destruct (int_abs_to_var u0 x) as [U pU]. - destruct (int_abs_to_var v0 y) as [V pV]. - pose (combo := (ap011 (+) pU pV)^ @ hcombo). - apply tr; exists U, V. - refine (_, _, _). - - exact (transport (fun w => rng_divides w x) combo^ - (rng_divides_int_abs_r - (rng_divides_int_nat (nat_divides_l_gcd_l (int_abs x) (int_abs y))))). - - exact (transport (fun w => rng_divides w y) combo^ - (rng_divides_int_abs_r - (rng_divides_int_nat (divides_l_nat_gcd_r (int_abs x) (int_abs y))))). - - intros z hzx hzy. - exact (rng_divides_plus (rng_divides_mul_l U hzx) (rng_divides_mul_l V hzy)). -Defined. - -(** Hence the integers form a Bézout domain. *) -Instance isbezoutdomain_cring_Z : IsBezoutDomain cring_Z := {}. diff --git a/theories/Spaces/Int.v b/theories/Spaces/Int.v index 5fc11c1c324..9cae12d26c9 100644 --- a/theories/Spaces/Int.v +++ b/theories/Spaces/Int.v @@ -783,58 +783,3 @@ Proof. rhs_V napply int_nat_add. exact (ap _ IHn). Defined. - -(** ** Absolute value *) - -(** The absolute value of an integer, as a natural number. *) -Definition int_abs (x : Int) : nat := - match x with - | negS n => S n - | posS n => S n - | _ => O - end. - -Definition int_abs_of_nat (n : nat) : int_abs (int_of_nat n) = n. -Proof. - by destruct n. -Defined. - -Definition int_abs_neg (x : Int) : int_abs (int_neg x) = int_abs x. -Proof. - by destruct x. -Defined. - -(** Every integer is its absolute value up to sign. *) -Definition int_abs_decomp (x : Int) - : ((x = int_of_nat (int_abs x)) + (x = int_neg (int_of_nat (int_abs x))))%type. -Proof. - destruct x. - - exact (inr idpath). - - exact (inl idpath). - - exact (inl idpath). -Defined. - -(** The absolute value of a product of two natural numbers. *) -Definition int_abs_of_nat_mul (a b : nat) - : int_abs (int_mul (int_of_nat a) (int_of_nat b)) = (a * b)%nat - := ap int_abs (int_nat_mul a b) @ int_abs_of_nat (a * b)%nat. - -(** Absolute value is multiplicative. *) -Definition int_abs_mul (x y : Int) - : int_abs (int_mul x y) = (int_abs x * int_abs y)%nat. -Proof. - destruct (int_abs_decomp x) as [px | px], (int_abs_decomp y) as [py | py]; - lhs napply (ap int_abs (ap011 int_mul px py)). - - napply int_abs_of_nat_mul. - - lhs napply (ap int_abs (int_mul_neg_r _ _)). - lhs napply int_abs_neg. - napply int_abs_of_nat_mul. - - lhs napply (ap int_abs (int_mul_neg_l _ _)). - lhs napply int_abs_neg. - napply int_abs_of_nat_mul. - - lhs napply (ap int_abs (int_mul_neg_l _ _)). - lhs napply int_abs_neg. - lhs napply (ap int_abs (int_mul_neg_r _ _)). - lhs napply int_abs_neg. - napply int_abs_of_nat_mul. -Defined. diff --git a/theories/Spaces/Nat/Core.v b/theories/Spaces/Nat/Core.v index dcc2df60c53..bd54b431d42 100644 --- a/theories/Spaces/Nat/Core.v +++ b/theories/Spaces/Nat/Core.v @@ -357,15 +357,6 @@ Proof. exact IHn. Defined. -(** A product of natural numbers is zero only if one of the factors is. *) -Definition nat_mul_is_zero@{} {n m : nat} (p : n * m = 0) : (n = 0) + (m = 0). -Proof. - destruct n as [|n]; [ exact (inl idpath) | ]. - destruct m as [|m]; [ exact (inr idpath) | ]. - napply Empty_rec. - exact (neq_nat_zero_succ _ (p^ @ nat_mul_succ_l n m.+1 @ nat_add_succ_l m _)). -Defined. - (** Multiplication of natural numbers is commutative. *) Definition nat_mul_comm@{} n m : n * m = m * n. Proof. From 006333a1117878edf6b14064fa3ecb973477ffa2 Mon Sep 17 00:00:00 2001 From: CharlesCNorton Date: Wed, 17 Jun 2026 17:36:07 -0400 Subject: [PATCH 05/12] Shorten comments in Classification.v and LoopGroup.v Reduce the file headers to the title and the result, and trim the multi-sentence docstrings in Classification.v to a single statement each. --- theories/Algebra/AbSES/Classification.v | 74 +++++++------------------ theories/Algebra/AbSES/LoopGroup.v | 10 +--- 2 files changed, 23 insertions(+), 61 deletions(-) diff --git a/theories/Algebra/AbSES/Classification.v b/theories/Algebra/AbSES/Classification.v index 1c3f3ed3802..f6d584477aa 100644 --- a/theories/Algebra/AbSES/Classification.v +++ b/theories/Algebra/AbSES/Classification.v @@ -12,18 +12,9 @@ Require Import Modalities.Identity Modalities.Descent. (** * Classification of short exact sequences - Following Christensen and Flaten, "Ext groups in homotopy type theory" - (arXiv:2305.09639, Theorem 2.2.2), short exact sequences [A -> E -> B] - of abelian groups are classified by pointed maps [K(B,2) ->* K(A,3)]. - - Applying [K(-,n.+1)] to a short exact sequence yields a fiber sequence - of Eilenberg-Mac Lane spaces, whose connecting map is the classifying - map [abses_classifying_map]. Conversely, the homotopy groups of the - fiber of a pointed map recover a short exact sequence [abses_pfiber]. - We show these are mutually inverse, giving the equivalence - [equiv_abses_classifying_map]. We deduce that [Ext B A] is the set of - components of the classifying mapping type, and that [AbSES B A] and - [Ext B A] are essentially small. *) + Short exact sequences [A -> E -> B] of abelian groups are classified by + pointed maps [K(B,2) ->* K(A,3)] (Christensen and Flaten, "Ext groups in + homotopy type theory", Theorem 2.2.2). *) Local Open Scope pointed_scope. @@ -110,8 +101,7 @@ Section EMFiberSequence. exact (contr_pi_succ_istrunc n K(B, n.+1)). Defined. - (** [Pi n.+1] of the comparison map [cxfib] is surjective, by exactness - of [A -> E -> B] transported along [pi_em_fmap]. *) + (** [Pi n.+1] of the comparison map [cxfib] is surjective. *) Local Definition issurj_pi_cxfib : IsSurjection (fmap (Pi n.+1) (cxfib iscomplex_em_abses)). Proof. @@ -251,10 +241,8 @@ Definition abses_classifying_map `{Univalence} {B A : AbGroup@{u}} sequence [A -> Pi 2 (pfiber f) -> B], by rotating the fiber sequence of [f] and taking homotopy groups. *) -(** The retraction law for [grp_iso_inverse], stated so that both sides - use the group-homomorphism spelling. Unifying the equivalence-inverse - and [grp_iso_inverse] spellings on large terms is expensive, so we - bridge them once here, on an abstract isomorphism. *) +(** The retraction law for [grp_iso_inverse], in the group-homomorphism + spelling. *) Local Definition grp_iso_retr {G H : Group} (e : GroupIsomorphism G H) (x : H) : e (grp_iso_inverse e x) = x. @@ -472,8 +460,7 @@ Section PfiberDeloop. (groupiso_pi_functor 2 pequiv_em_pfiber_psi) (equiv_g_pi_n_em (abgroup_pi_pfiber 1 psi) 2). - (** The bridge, twisted by [eta_pfiber_psi] so that the projection - square below holds by construction. *) + (** The bridge, twisted by [eta_pfiber_psi]. *) Local Definition pequiv_em_pfiber_psi' : K(abgroup_pi_pfiber 1 psi, 3) <~>* pfiber psi. Proof. @@ -566,8 +553,7 @@ Section PfiberDeloop. (** Through the bridge, [cxfib] of the extracted sequence is the connecting identification of [psi], modulo the loop identification - of [K(A,3)]. Both sides are determined by their effect on [Pi 3], - since [Pi 3] of the double fiber inclusion is an embedding. *) + of [K(A,3)]. *) Local Definition path_cxfib_connect_psi : pequiv_pfiber pequiv_em_pfiber_psi' pequiv_pmap_idmap square_em_proj_pfib_psi @@ -667,9 +653,8 @@ Section PfiberDeloop. exact (connecting_map_pfib2 psi). Defined. - (** Negation on [K(B,2)], realised as loop inversion conjugated by the - loop identification. This is the sign by which the classifying map - of the extracted sequence differs from the delooping equivalence. *) + (** Negation on [K(B,2)], as loop inversion conjugated by the loop + identification. *) Local Definition pequiv_neg_em : K(B, 2) <~>* K(B, 2) := (pequiv_loops_em_em B 2)^-1* o*E (loops_inv K(B, 3) o*E pequiv_loops_em_em B 2). @@ -752,10 +737,7 @@ Section ClassifyingRoundTrip. pequiv_pmap_idmap _). Defined. - (** Hence the fiber of the classifying map is [loops K(E,3)]: transport - the fiber along [rt1_square] and the presentation of the connecting - map, identify the double fiber via [pfiber2_loops], and invert. The - inversion makes both round-trip squares commute. *) + (** The fiber of the classifying map is [loops K(E,3)]. *) Local Definition pequiv_pfiber_classifying : pfiber (abses_classifying_map E) <~>* loops K(E, 3). Proof. @@ -913,8 +895,7 @@ Section ClassifyingRoundTrip. exact CORE. Defined. - (** The projection square of the round trip. The last step unfolds - [equiv_g_pi_n_em B 2] definitionally. *) + (** The projection square of the round trip. *) Local Definition rt1_proj_square (x : Pi 2 (pfiber (abses_classifying_map E))) : abses_pfiber_proj 0 (abses_classifying_map E) x = projection E (rt1_middle x). @@ -951,15 +932,12 @@ End ClassifyingRoundTrip. (** ** The classification theorem - [abses_classifying_map] is an equivalence, with inverse [abses_pfiber]. - This is Theorem 2.2.2 of Christensen-Flaten. *) + [abses_classifying_map] is an equivalence, with inverse [abses_pfiber]. *) Section Classification. Context `{Univalence} {B A : AbGroup@{u}}. - (** A section of the classifying map: the delooping preimage of [f] - untwisted by the sign extracts to a sequence whose classifying map - is [f]. This uses the [psi := K(B,3) ->* K(A,4)] analysis. *) + (** A section of the classifying map. *) Local Definition abses_classifying_section (f : K(B, 2) ->* K(A, 3)) : abses_classifying_map (abses_pfiber 1 ((equiv_deloop_em_pmap B A)^-1 @@ -975,9 +953,7 @@ Section Classification. apply pmap_precompose_idmap. Defined. - (** The second round trip: since [abses_pfiber 0] is a retraction of - [abses_classifying_map] (the first round trip) and the above is a - section, the two agree and the section round trip holds. *) + (** The second round trip. *) Local Definition abses_classifying_map_pfiber (f : K(B, 2) ->* K(A, 3)) : abses_classifying_map (abses_pfiber 0 f) = f. Proof. @@ -1003,10 +979,7 @@ Section Classification. : Ext B A <~> Tr 0 (K(B, 2) ->* K(A, 3)) := Trunc_functor_equiv 0 equiv_abses_classifying_map. - (** Since the classifying mapping type lives in the universe of [A] and - [B], the a priori large type [AbSES B A] is essentially small, as is - [Ext B A]. In particular both are independent of the universe in - which the extensions are formed (Remark 2.2.5). *) + (** [AbSES B A] is essentially small, and so is [Ext B A] (Remark 2.2.5). *) Definition issmall_abses : IsSmall@{u _} (AbSES B A) := issmall_equiv_issmall (equiv_abses_classifying_map)^-1%equiv (issmall_in _). @@ -1019,15 +992,11 @@ End Classification. (** ** Naturality of the classifying map - A morphism of short exact sequences induces, after applying [K(-,3)], - a commuting square relating the two classifying maps. Taking the - [B]-component to be the identity gives naturality in [A] (pushout); - taking the [A]-component to be the identity gives naturality in [B] - (pullback). *) + A morphism of short exact sequences induces a commuting square relating + the two classifying maps. *) -(** Inverting the [cxfib] equivalences below would otherwise force the - elaborator to reduce the large witnesses that they are equivalences; - we keep those witnesses opaque so that the inverses stay inert. *) +(** Keep the [cxfib] equivalence witnesses opaque so their inverses stay + inert. *) Opaque isequiv_cxfib_em isequiv_cxfib. Section Naturality. @@ -1068,8 +1037,7 @@ Section Naturality. (em_fmap (projection F) 3) (isexact_em_abses F 2). (** The fiber-inclusion comparison commutes with the morphism on - fibers. Both sides are determined on [Pi 3], where the double-fiber - inclusion is an embedding, reducing to the inclusion square. *) + fibers. *) Local Definition em_cxfib_square : functor_pfiber (em_proj_square^*) o* em_cxfib_E = em_cxfib_F o* em_fmap (component1 phi) 3. diff --git a/theories/Algebra/AbSES/LoopGroup.v b/theories/Algebra/AbSES/LoopGroup.v index 749674d2650..44f7f0e462a 100644 --- a/theories/Algebra/AbSES/LoopGroup.v +++ b/theories/Algebra/AbSES/LoopGroup.v @@ -13,14 +13,8 @@ Local Open Scope mc_add_scope. (** * The fundamental group of [AbSES B A] - [AbSES.Core] gives an equivalence of types - [loops_abses : (B $-> A) <~> loops (AbSES B A)]. We show that it is an - isomorphism of groups: concatenation of loops corresponds to addition of - homomorphisms. The Baer sum laws hold at the level of [AbSES B A], so - translation by [E] is a self-equivalence taking the split sequence to - [E], and the fundamental group is [ab_hom B A] at every basepoint. It - follows that each path component of [AbSES B A] is a classifying space - [K(ab_hom B A, 1)]. *) + The fundamental group of [AbSES B A] at any basepoint is [ab_hom B A], + and each path component is a classifying space [K(ab_hom B A, 1)]. *) Section LoopGroup. Context `{Univalence} {B A : AbGroup@{u}}. From 5e1a5d6dba975cbbf7c9cf77d078a6858f680a48 Mon Sep 17 00:00:00 2001 From: CharlesCNorton Date: Wed, 17 Jun 2026 18:34:04 -0400 Subject: [PATCH 06/12] Remove LoopGroup.v The classification in Classification.v does not depend on LoopGroup.v (the computation of Pi 1 (AbSES B A) and the path components as classifying spaces), so it is removed from this PR. --- theories/Algebra/AbSES/LoopGroup.v | 146 ----------------------------- 1 file changed, 146 deletions(-) delete mode 100644 theories/Algebra/AbSES/LoopGroup.v diff --git a/theories/Algebra/AbSES/LoopGroup.v b/theories/Algebra/AbSES/LoopGroup.v deleted file mode 100644 index 44f7f0e462a..00000000000 --- a/theories/Algebra/AbSES/LoopGroup.v +++ /dev/null @@ -1,146 +0,0 @@ -From HoTT Require Import Basics Types Truncations.Core HFiber. -From HoTT.WildCat Require Import Core Equiv. -Require Import Pointed. -Require Import AbelianGroup AbHom. -Require Import Algebra.AbSES.Core Algebra.AbSES.Pullback Algebra.AbSES.BaerSum. -Require Import Homotopy.HomotopyGroup Homotopy.ClassifyingSpace Homotopy.EMSpace - Homotopy.Cover. -Require Import Modalities.ReflectiveSubuniverse Modalities.Modality. -Require Import Groups.Group. - -Local Open Scope pointed_scope. -Local Open Scope mc_add_scope. - -(** * The fundamental group of [AbSES B A] - - The fundamental group of [AbSES B A] at any basepoint is [ab_hom B A], - and each path component is a classifying space [K(ab_hom B A, 1)]. *) - -Section LoopGroup. - Context `{Univalence} {B A : AbGroup@{u}}. - - (** The path data on the split sequence corresponding to [f : B $-> A]. - [loops_abses f] is definitionally [equiv_path_abses_iso (tdata f)], and - the underlying automorphism of [tdata f] sends [(a, b)] to - [(a + f b, mon_unit + b)]. *) - Local Definition tdata (f : B $-> A) - : abses_path_data_iso (point (AbSES B A)) (point (AbSES B A)) - := equiv_path_abses_data _ _ (abses_endomorphism_trivial^-1 f). - - (** [loops_abses] is additive: composition of path data on the split - sequence corresponds to addition of the off-diagonal homomorphisms. *) - Definition loops_abses_add (f g : B $-> A) - : loops_abses (f + g) = loops_abses f @ loops_abses g. - Proof. - refine (_ @ (abses_path_data_compose_beta (tdata f) (tdata g))^). - napply (ap equiv_path_abses_iso). - rapply path_sigma_hprop. - rapply equiv_path_groupisomorphism. - intros [a b]. - (* LHS: [(a + (f b + g b), 0 + b)]; RHS: [((a + f b) + g (0 + b), 0 + (0 + b))]. *) - snapply path_prod'; cbn. - - exact (associativity a (f b) (g b) - @ ap (fun w => (a + f b) + w) (ap g (left_identity b))^). - - exact (ap (fun z => mon_unit + z) (left_identity b))^. - Defined. - - (** The fundamental group of [AbSES B A] at the split sequence. *) - Definition grp_iso_pi1_abses - : GroupIsomorphism (ab_hom B A) (Pi 1 (AbSES B A)). - Proof. - snapply Build_GroupIsomorphism. - - snapply Build_GroupHomomorphism. - + exact (fun f => tr (loops_abses f)). - + intros f g. - exact (ap tr (loops_abses_add f g)). - - exact (equiv_isequiv (equiv_tr 0 _ oE loops_abses)). - Defined. - -End LoopGroup. - -(** * Translation by a short exact sequence *) - -Section Translation. - Context `{Univalence} {B A : AbGroup@{u}}. - - (** Translation by [E] under the Baer sum is a self-equivalence of - [AbSES B A], with inverse given by translation by the Baer inverse - [abses_pullback (- grp_homo_id) E]. *) - Definition equiv_abses_translate (E : AbSES B A) - : AbSES B A <~> AbSES B A. - Proof. - srapply equiv_adjointify. - - exact (fun F => abses_baer_sum F E). - - exact (fun F => abses_baer_sum F (abses_pullback (- grp_homo_id) E)). - - intro F. - refine (baer_sum_associative _ _ _ @ _). - refine (ap (abses_baer_sum F) (baer_sum_inverse_r E) @ _). - apply baer_sum_unit_r. - - intro F. - refine (baer_sum_associative _ _ _ @ _). - refine (ap (abses_baer_sum F) (baer_sum_inverse_l E) @ _). - apply baer_sum_unit_r. - Defined. - - (** Translation takes the split sequence to [E]. *) - Definition pequiv_abses_translate (E : AbSES B A) - : AbSES B A <~>* [AbSES B A, E] - := Build_pEquiv' (equiv_abses_translate E) (baer_sum_unit_l E). - - (** The fundamental group of [AbSES B A] at any basepoint is [ab_hom B A], - even though [E] need not be merely equal to the split sequence. *) - Definition grp_iso_pi1_abses_at (E : AbSES B A) - : GroupIsomorphism (ab_hom B A) (Pi 1 [AbSES B A, E]) - := grp_iso_compose - (groupiso_pi_functor 0 (pequiv_abses_translate E)) - grp_iso_pi1_abses. - -End Translation. - -(** * Components of [AbSES B A] are classifying spaces *) - -Section Component. - Context `{Univalence} {B A : AbGroup@{u}} (E : AbSES B A). - - (** The inclusion of the component of [E] is an embedding, since being in - a given component is a proposition. *) - Local Instance isembedding_pcomp_abses - : IsEmbedding (pr1 : pcomp (AbSES B A) E -> AbSES B A). - Proof. - intro F. - exact (istrunc_equiv_istrunc _ (hfiber_fibration F _)). - Qed. - - Local Instance isconnected_pcomp_abses - : IsConnected (Tr 0) (pcomp (AbSES B A) E) - := _. - - Local Instance istrunc_pcomp_abses - : IsTrunc 1 (pcomp (AbSES B A) E) - := _. - - (** The inclusion of the component of [E] induces an isomorphism of - fundamental groups. *) - Definition grp_iso_pi1_pcomp_abses - : GroupIsomorphism (Pi 1 (pcomp (AbSES B A) E)) (Pi 1 [AbSES B A, E]). - Proof. - snapply Build_GroupIsomorphism. - - snapply Build_GroupHomomorphism. - + exact (Trunc_functor 0 (ap pr1)). - + intros p q; strip_truncations. - exact (ap tr (ap_pp pr1 p q)). - - exact _. - Defined. - - (** Each component of [AbSES B A] is a classifying space of [ab_hom B A]. *) - Definition pequiv_pcomp_abses_em - : pcomp (AbSES B A) E <~>* K(ab_hom B A, 1). - Proof. - refine (_ o*E (pequiv_pclassifyingspace_pi1 (pcomp (AbSES B A) E))^-1*). - exact (emap pClassifyingSpace - (grp_iso_compose - (grp_iso_inverse (grp_iso_pi1_abses_at E)) - grp_iso_pi1_pcomp_abses)). - Defined. - -End Component. From 777f889171b8349dfa5687396a3f5670a093e790 Mon Sep 17 00:00:00 2001 From: Dan Christensen Date: Wed, 17 Jun 2026 21:00:48 -0400 Subject: [PATCH 07/12] ClassifyingSpace.v: minor simplification to proof (avoid inverse) --- theories/Homotopy/ClassifyingSpace.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/theories/Homotopy/ClassifyingSpace.v b/theories/Homotopy/ClassifyingSpace.v index 9e78e2e2344..94a2ad72447 100644 --- a/theories/Homotopy/ClassifyingSpace.v +++ b/theories/Homotopy/ClassifyingSpace.v @@ -410,9 +410,9 @@ End HSpace_bg. Instance contr_pclassifyingspace `{Univalence} (G : Group) `{Contr G} : Contr (B G). Proof. - (* The map to [pUnit] is an equivalence, since it is one on loops. *) + rapply (contr_equiv' pUnit (Build_Equiv _ _ pconst _)). + (* The map from [pUnit] is an equivalence, since it is one on loops, as both have contractible loop spaces. *) pose proof (contr_equiv' G equiv_g_loops_bg). - rapply (contr_equiv' pUnit (equiv_inverse (Build_Equiv _ _ pconst _))). rapply isequiv_is0connected_isequiv_loops. Defined. From 29de1d893855c3b27253d2852de099c61ebc07ef Mon Sep 17 00:00:00 2001 From: CharlesCNorton Date: Sat, 20 Jun 2026 09:03:19 -0400 Subject: [PATCH 08/12] Replace issurjection_is0connected with the general isconnmap_isconnected --- theories/Homotopy/ClassifyingSpace.v | 2 +- theories/Homotopy/EMSpace.v | 2 +- theories/Truncations/Connectedness.v | 14 -------------- 3 files changed, 2 insertions(+), 16 deletions(-) diff --git a/theories/Homotopy/ClassifyingSpace.v b/theories/Homotopy/ClassifyingSpace.v index 94a2ad72447..26032f193ae 100644 --- a/theories/Homotopy/ClassifyingSpace.v +++ b/theories/Homotopy/ClassifyingSpace.v @@ -462,7 +462,7 @@ Proof. (* By [isconnmap_isconnmap_ap_surj] it suffices to show that [fmap B f] and its [ap]s are surjective; both follow from surjectivity of [f]. *) snapply isconnmap_isconnmap_ap_surj. - - exact (issurjection_is0connected _ _ (tr bbase) _). + - rapply (isconnmap_isconnected (-1)). - rapply (conn_point_elim (-1) (A:=B G)). rapply (conn_point_elim (-1) (A:=B G)). srapply (equiv_ind equiv_g_loops_bg). diff --git a/theories/Homotopy/EMSpace.v b/theories/Homotopy/EMSpace.v index 2aba8e70e71..935b7f64174 100644 --- a/theories/Homotopy/EMSpace.v +++ b/theories/Homotopy/EMSpace.v @@ -283,7 +283,7 @@ Section EilenbergMacLane. induction n as [|n IHn]. - exact (isconnmap_fmap_pclassifyingspace f). - snapply isconnmap_isconnmap_ap_surj. - + exact (issurjection_is0connected _ _ (tr (point _)) _). + + rapply (isconnmap_isconnected (-1)). + assert (c : IsConnMap n (fmap loops (em_fmap f n.+2))). { napply (conn_map_homotopic _ ((pequiv_loops_em_em G' n.+1 o* em_fmap f n.+1) diff --git a/theories/Truncations/Connectedness.v b/theories/Truncations/Connectedness.v index fad4d240291..c372dfa6d01 100644 --- a/theories/Truncations/Connectedness.v +++ b/theories/Truncations/Connectedness.v @@ -244,20 +244,6 @@ Proof. exact (contr_inhabited_hprop _ (p x y)). Defined. -(** Any map from a merely inhabited type to a 0-connected type is - surjective. *) -Definition issurjection_is0connected `{Univalence} - (X Y : Type) (mX : merely X) `{IsConnected 0 Y} (f : X -> Y) - : IsSurjection f. -Proof. - intro y. - rapply contr_inhabited_hprop. - strip_truncations. - pose proof (p := merely_path_is0connected Y (f mX) y). - strip_truncations. - exact (tr (mX; p)). -Defined. - (** The path component of a point [x : X] is connected. *) Instance is0connected_component {X : Type} (x : X) : IsConnected 0 { z : X & merely (z = x) }. From 5d293171be9196596e80457a88d60566cad62782 Mon Sep 17 00:00:00 2001 From: CharlesCNorton Date: Sat, 20 Jun 2026 10:17:40 -0400 Subject: [PATCH 09/12] Reflow comments and relocate two helper lemmas - Remove line breaks from the added comments (STYLE.md). - Move contr_pi_succ_istrunc from EMSpace.v to HomotopyGroup.v. - Generalize pmap_punit_pconst to a contractible codomain (phomotopy_pconst_contr); drop the local copy in EMSpace.v. --- theories/Homotopy/ClassifyingSpace.v | 3 +- theories/Homotopy/EMSpace.v | 78 ++++++---------------------- theories/Homotopy/ExactSequence.v | 16 ++---- theories/Homotopy/HomotopyGroup.v | 11 ++++ theories/Pointed/Core.v | 11 ++-- theories/Pointed/pFiber.v | 12 ++--- theories/Pointed/pMap.v | 2 +- 7 files changed, 44 insertions(+), 89 deletions(-) diff --git a/theories/Homotopy/ClassifyingSpace.v b/theories/Homotopy/ClassifyingSpace.v index 26032f193ae..b1e89595d5a 100644 --- a/theories/Homotopy/ClassifyingSpace.v +++ b/theories/Homotopy/ClassifyingSpace.v @@ -459,8 +459,7 @@ Instance isconnmap_fmap_pclassifyingspace `{Univalence} {G K : Group} (f : GroupHomomorphism G K) `{!IsSurjection f} : IsConnMap 0 (fmap B f). Proof. - (* By [isconnmap_isconnmap_ap_surj] it suffices to show that [fmap B f] - and its [ap]s are surjective; both follow from surjectivity of [f]. *) + (* By [isconnmap_isconnmap_ap_surj] it suffices to show that [fmap B f] and its [ap]s are surjective; both follow from surjectivity of [f]. *) snapply isconnmap_isconnmap_ap_surj. - rapply (isconnmap_isconnected (-1)). - rapply (conn_point_elim (-1) (A:=B G)). diff --git a/theories/Homotopy/EMSpace.v b/theories/Homotopy/EMSpace.v index 935b7f64174..0ba80cc489e 100644 --- a/theories/Homotopy/EMSpace.v +++ b/theories/Homotopy/EMSpace.v @@ -119,9 +119,7 @@ Section EilenbergMacLane. by destruct (equiv_path_group e). Defined. - (** The action of [K(-,n)] on group homomorphisms, giving the functoriality - of [K(-,n)]. Note that [fmap B] and the WildCat functoriality of - [psusp] and [pTr] constrain the two groups to a single universe. *) + (** The action of [K(-,n)] on group homomorphisms, giving the functoriality of [K(-,n)]. Note that [fmap B] and the WildCat functoriality of [psusp] and [pTr] constrain the two groups to a single universe. *) Definition em_fmap {G G' : AbGroup} (f : GroupHomomorphism G G') (n : nat) : K(G, n) ->* K(G', n). Proof. @@ -165,11 +163,7 @@ Section EilenbergMacLane. exact (pointed_htpy IH). Defined. - (** At positive levels, [pequiv_loops_em_em] is the canonical comparison - map: the loop-suspension unit followed by [loops] of the truncation - map. This presentation makes its naturality transparent, without - reference to the Hopf-construction input used to show that it is an - equivalence. *) + (** At positive levels, [pequiv_loops_em_em] is the canonical comparison map: the loop-suspension unit followed by [loops] of the truncation map. This presentation makes its naturality transparent, without reference to the Hopf-construction input used to show that it is an equivalence. *) Definition loops_em_em_ptr_unit (G : AbGroup) (n : nat) : pequiv_loops_em_em G n.+1 ==* fmap loops ptr o* loop_susp_unit K(G, n.+1). @@ -183,8 +177,7 @@ Section EilenbergMacLane. all: exact (pmap_prewhisker _ (ptr_loops_commutes _ _)). Defined. - (** [em_fmap] commutes with the loop-space identifications, so it is a - map of spectra. *) + (** [em_fmap] commutes with the loop-space identifications, so it is a map of spectra. *) Definition em_fmap_loops_natural {G G' : AbGroup} (f : GroupHomomorphism G G') (n : nat) : fmap loops (em_fmap f n.+1) o* pequiv_loops_em_em G n @@ -203,8 +196,7 @@ Section EilenbergMacLane. exact (pmap_compose_assoc _ _ _)^*. Defined. - (** [equiv_g_pi_n_em] at level [n.+1] unfolds to the level-[n] map - conjugated by [groupiso_pi_loops] and [pequiv_loops_em_em]. *) + (** [equiv_g_pi_n_em] at level [n.+1] unfolds to the level-[n] map conjugated by [groupiso_pi_loops] and [pequiv_loops_em_em]. *) Local Definition equiv_g_pi_n_em_succ (G : AbGroup) (n : nat) (x : G) : equiv_g_pi_n_em G n.+1 x = grp_iso_inverse (groupiso_pi_loops _ _) @@ -212,8 +204,7 @@ Section EilenbergMacLane. (equiv_g_pi_n_em G n x)) := idpath. - (** The action of [em_fmap f n.+1] on [Pi n.+1] agrees with [f] under the - identifications [equiv_g_pi_n_em]. *) + (** The action of [em_fmap f n.+1] on [Pi n.+1] agrees with [f] under the identifications [equiv_g_pi_n_em]. *) Definition pi_em_fmap {G G' : AbGroup} (f : GroupHomomorphism G G') (n : nat) : fmap (Pi n.+1) (em_fmap f n.+1) o equiv_g_pi_n_em G n @@ -250,17 +241,6 @@ Section EilenbergMacLane. exact (ap tr (contr a)). Defined. - (** Any pointed map into a contractible type is homotopic to the constant - map. *) - Local Definition phomotopy_pconst_contr {X Y : pType} `{Contr Y} - (f : X ->* Y) - : f ==* pconst. - Proof. - snapply Build_pHomotopy. - - intro x; apply path_contr. - - apply path_contr. - Defined. - (** [em_fmap] sends the constant homomorphism to the constant map. *) Definition em_fmap_const {G G' : AbGroup} (n : nat) : em_fmap (G:=G) (G':=G') grp_homo_const n ==* pconst. @@ -268,14 +248,12 @@ Section EilenbergMacLane. refine (phomotopy_path (ap (fun h => em_fmap h n) _) @* em_fmap_compose (G':=abgroup_trivial) (grp_trivial_corec G) (grp_trivial_rec G') n - @* pmap_postwhisker _ (phomotopy_pconst_contr _) + @* pmap_postwhisker _ ((phomotopy_pconst_contr _)^*) @* precompose_pconst _). napply equiv_path_grouphomomorphism; intro x; reflexivity. Defined. - (** [em_fmap f n.+1] of a surjective homomorphism is an [n]-connected - map. Both surjectivity of the map and of its [ap]s reduce to the - previous level through the loop-space identifications. *) + (** [em_fmap f n.+1] of a surjective homomorphism is an [n]-connected map. Both surjectivity of the map and of its [ap]s reduce to the previous level through the loop-space identifications. *) #[export] Instance isconnmap_em_fmap {G G' : AbGroup} (f : GroupHomomorphism G G') `{!IsSurjection f} (n : nat) : IsConnMap n (em_fmap f n.+1). @@ -303,17 +281,13 @@ Section EilenbergMacLane. (c _)). Defined. - (** [em_fmap] is an equivalence from group homomorphisms to pointed maps, - extending [isequiv_fmap_pclassifyingspace] to all levels. In - particular, pointed maps between Eilenberg-Mac Lane spaces of the same - level are determined by their effect on homotopy groups. *) + (** [em_fmap] is an equivalence from group homomorphisms to pointed maps, extending [isequiv_fmap_pclassifyingspace] to all levels. In particular, pointed maps between Eilenberg-Mac Lane spaces of the same level are determined by their effect on homotopy groups. *) #[export] Instance isequiv_em_fmap (G G' : AbGroup) (n : nat) : IsEquiv (fun f : GroupHomomorphism G G' => em_fmap f n.+1). Proof. induction n as [|n IHn]. - exact (isequiv_fmap_pclassifyingspace G G'). - - (* The ladder [pequiv_ptr_rec], [loop_susp_adjoint], postcomposition - with [pequiv_loops_em_em], and the inductive hypothesis. *) + - (* The ladder [pequiv_ptr_rec], [loop_susp_adjoint], postcomposition with [pequiv_loops_em_em], and the inductive hypothesis. *) pose (L := ((Build_Equiv _ _ _ IHn)^-1%equiv) oE (pequiv_pequiv_postcompose (pequiv_loops_em_em G' n.+1)^-1* : (K(G, n.+1) ->** loops K(G', n.+2)) <~> _) @@ -341,8 +315,7 @@ Section EilenbergMacLane. apply pmap_postcompose_idmap. Defined. - (** Pointed maps between Eilenberg-Mac Lane spaces of the same level - which agree on homotopy groups are equal. *) + (** Pointed maps between Eilenberg-Mac Lane spaces of the same level which agree on homotopy groups are equal. *) Definition path_em_pmap_pi {G G' : AbGroup} (n : nat) (phi psi : K(G, n.+1) ->* K(G', n.+1)) (h : fmap (Pi n.+1) phi == fmap (Pi n.+1) psi) @@ -412,23 +385,10 @@ End EilenbergMacLane. (** ** Delooping Eilenberg-Mac Lane mapping types *) -(** The [n.+2]-nd homotopy group of an [n.+1]-truncated type vanishes. *) -Definition contr_pi_succ_istrunc `{Univalence} (n : nat) (X : pType) - `{IsTrunc n.+1 X} - : Contr (Pi n.+2 X). -Proof. - pose proof (c := equiv_istrunc_contr_iterated_loops n.+2 X _ (point _)). - apply (Build_Contr _ (tr (center _))). - srapply Trunc_ind; intro a. - exact (ap tr (contr a)). -Defined. - Section Deloop. Context `{Univalence} (B A : AbGroup@{u}). - (** By Freudenthal, the loop-suspension unit of [K(B,2)] is 2-connected, - so [Pi 3] of the unit is surjective; since [Pi 3 K(B,2)] is trivial, - [psusp K(B,2)] has trivial [Pi 4]. *) + (** By Freudenthal, the loop-suspension unit of [K(B,2)] is 2-connected, so [Pi 3] of the unit is surjective; since [Pi 3 K(B,2)] is trivial, [psusp K(B,2)] has trivial [Pi 4]. *) Local Instance contr_pi4_psusp_em : Contr (Pi 4 (psusp K(B, 2))). Proof. nrefine (contr_equiv' (Pi 3 (loops (psusp K(B, 2)))) _). @@ -466,9 +426,7 @@ Section Deloop. exact _. Defined. - (** [K(B,3)] sits inside the 3-truncation of [pTr 4 (psusp K(B,2))] - via [fmap (pTr 3) ptr]; this is an equivalence since the source is - already 3-truncated. *) + (** [K(B,3)] sits inside the 3-truncation of [pTr 4 (psusp K(B,2))] via [fmap (pTr 3) ptr]; this is an equivalence since the source is already 3-truncated. *) Local Definition pequiv_ptr3_ptr4_psusp_em : K(B, 3) <~>* pTr 3 (pTr 4 (psusp K(B, 2))). Proof. @@ -483,8 +441,7 @@ Section Deloop. : pTr 4 (psusp K(B, 2)) <~>* K(B, 3) := pequiv_ptr3_ptr4_psusp_em^-1* o*E pequiv_ptr (n:=3). - (** The comparison map collapses the two truncation units of - [psusp K(B,2)], by naturality of [ptr]. *) + (** The comparison map collapses the two truncation units of [psusp K(B,2)], by naturality of [ptr]. *) Local Definition tau_ptr4_ptr3_psusp_em : pequiv_ptr4_ptr3_psusp_em o* ptr ==* ptr. Proof. @@ -496,8 +453,7 @@ Section Deloop. apply pmap_postcompose_idmap. Defined. - (** Pointed maps [K(B,3) ->* K(A,4)] are equivalent to pointed maps - [K(B,2) ->* K(A,3)], by looping. *) + (** Pointed maps [K(B,3) ->* K(A,4)] are equivalent to pointed maps [K(B,2) ->* K(A,3)], by looping. *) Definition equiv_deloop_em_pmap : (K(B, 3) ->* K(A, 4)) <~> (K(B, 2) ->* K(A, 3)) := pequiv_pequiv_postcompose (pequiv_loops_em_em A 3)^-1* @@ -505,8 +461,7 @@ Section Deloop. oE pequiv_ptr_rec oE pequiv_pequiv_precompose pequiv_ptr4_ptr3_psusp_em. - (** The delooping equivalence, unfolded: postcompose by the inverse loop - identification, loop the map, precompose by the loop identification. *) + (** The delooping equivalence, unfolded: postcompose by the inverse loop identification, loop the map, precompose by the loop identification. *) Definition equiv_deloop_em_pmap_unfold (psi : K(B, 3) ->* K(A, 4)) : equiv_deloop_em_pmap psi ==* (pequiv_loops_em_em A 3)^-1* @@ -529,8 +484,7 @@ Section Deloop. End Deloop. -(** Pointed maps from an Eilenberg-Mac Lane space to a connected truncated - type of the same level which agree on homotopy groups are equal. *) +(** Pointed maps from an Eilenberg-Mac Lane space to a connected truncated type of the same level which agree on homotopy groups are equal. *) Definition path_em_pmap_pi_connected `{Univalence} {G : AbGroup@{u}} (n : nat) {Y : pType} `{IsConnected n.+1 Y} `{IsTrunc n.+2 Y} (phi psi : K(G, n.+2) ->* Y) diff --git a/theories/Homotopy/ExactSequence.v b/theories/Homotopy/ExactSequence.v index a67ec31fc22..70b5a4c5487 100644 --- a/theories/Homotopy/ExactSequence.v +++ b/theories/Homotopy/ExactSequence.v @@ -494,8 +494,7 @@ Defined. (** ** Naturality and rotation of the connecting map *) -(** The fiber functor of the tautological [cxfib] square is the - identity. *) +(** The fiber functor of the tautological [cxfib] square is the identity. *) Definition pequiv_pfiber_cxfib_taut {X Y : pType} (f : X ->* Y) : pequiv_pfiber pequiv_cxfib pequiv_pmap_idmap (square_pfib_pequiv_cxfib (pfib f) f) @@ -511,8 +510,7 @@ Proof. - reflexivity. Defined. -(** The connecting map of the tautological fiber sequence is natural in - arbitrary squares of pointed maps. *) +(** The connecting map of the tautological fiber sequence is natural in arbitrary squares of pointed maps. *) Definition connecting_map_natural_functor {X Y X' Y' : pType} {f : X ->* Y} {f' : X' ->* Y'} {h : X' ->* X} {k : Y' ->* Y} (q : k o* f' ==* f o* h) @@ -560,8 +558,7 @@ Definition connecting_map_natural {X Y X' Y' : pType} ==* connecting_map (pfib f) f o* fmap loops k := connecting_map_natural_functor q. -(** Through [cxfib], the connecting map of an exact sequence agrees with - the connecting map of the tautological fiber sequence. *) +(** Through [cxfib], the connecting map of an exact sequence agrees with the connecting map of the tautological fiber sequence. *) Definition connecting_map_cxfib {F X Y : pType} (i : F ->* X) (f : X ->* Y) `{IsExact purely F X Y i f} : pequiv_cxfib o* connecting_map i f ==* connecting_map (pfib f) f. @@ -592,9 +589,7 @@ Proof. exact (peisretr _). Defined. -(** Through [pfiber2_loops], the connecting map of the doubly-iterated - tautological fiber sequence is loop inversion followed by [loops] of - the map. *) +(** Through [pfiber2_loops], the connecting map of the doubly-iterated tautological fiber sequence is loop inversion followed by [loops] of the map. *) Definition connecting_map_pfib2 {F X : pType} (i : F ->* X) : pfiber2_loops i o* connecting_map (pfib (pfib i)) (pfib i) ==* fmap loops i o* loops_inv F. @@ -620,8 +615,7 @@ Proof. apply pmap_precompose_idmap. Defined. -(** Through [pfiber2_loops], the double fiber projection of an exact - sequence is loop inversion followed by [loops] of the projection. *) +(** Through [pfiber2_loops], the double fiber projection of an exact sequence is loop inversion followed by [loops] of the projection. *) Definition pfiber2_loops_pfib2 {F X Y : pType} (i : F ->* X) (f : X ->* Y) `{IsExact purely F X Y i f} : ((pfiber2_loops f) diff --git a/theories/Homotopy/HomotopyGroup.v b/theories/Homotopy/HomotopyGroup.v index 067cc000054..f06b29b7db5 100644 --- a/theories/Homotopy/HomotopyGroup.v +++ b/theories/Homotopy/HomotopyGroup.v @@ -350,3 +350,14 @@ Proof. exact (fmap_id (pPi n) X x). Defined. +(** The [n.+2]-nd homotopy group of an [n.+1]-truncated type vanishes. *) +Definition contr_pi_succ_istrunc `{Univalence} (n : nat) (X : pType) + `{IsTrunc n.+1 X} + : Contr (Pi n.+2 X). +Proof. + pose proof (c := equiv_istrunc_contr_iterated_loops n.+2 X _ (point _)). + apply (Build_Contr _ (tr (center _))). + srapply Trunc_ind; intro a. + exact (ap tr (contr a)). +Defined. + diff --git a/theories/Pointed/Core.v b/theories/Pointed/Core.v index b5f4d48a568..2681d55c4ea 100644 --- a/theories/Pointed/Core.v +++ b/theories/Pointed/Core.v @@ -509,11 +509,12 @@ Definition ppMap (A B : pType) : pType Infix "->**" := ppMap : pointed_scope. -Lemma pmap_punit_pconst {A : pType} (f : A ->* pUnit) : pconst ==* f. +Lemma phomotopy_pconst_contr {A B : pType} `{Contr B} (f : A ->* B) + : pconst ==* f. Proof. - srapply Build_pHomotopy. - 1: intro; apply path_unit. - apply path_contr. + snapply Build_pHomotopy. + - intro x; apply path_contr. + - apply path_contr. Defined. Lemma punit_pmap_pconst {A : pType} (f : pUnit ->* A) : pconst ==* f. @@ -594,7 +595,7 @@ Proof. exact punit_pmap_pconst. + intro B. exists pconst. - exact pmap_punit_pconst. + exact phomotopy_pconst_contr. Defined. (** The constant map is definitionally equal to the zero_morphism of a pointed category *) diff --git a/theories/Pointed/pFiber.v b/theories/Pointed/pFiber.v index 13ae1659811..777eda1735a 100644 --- a/theories/Pointed/pFiber.v +++ b/theories/Pointed/pFiber.v @@ -126,8 +126,7 @@ Proof. - reflexivity. Qed. -(** The value of [pfiber2_loops] on a general element of the double - fiber. *) +(** The value of [pfiber2_loops] on a general element of the double fiber. *) Definition pfiber2_loops_beta {C D : Type} {c0 : C} {d0 : D} (g : C -> D) (de : g c0 = d0) (c : C) (w : g c = d0) (v : c = c0) : pfiber2_loops (Build_pMap (A:=[C, c0]) (B:=[D, d0]) g de) @@ -138,8 +137,7 @@ Proof. exact ((concat_1p w)^ @ ap (concat 1) (concat_1p w)^). Defined. -(** The path algebra underlying the pointwise part of - [pfiber2_loops_natural], with all endpoints free. *) +(** The path algebra underlying the pointwise part of [pfiber2_loops_natural], with all endpoints free. *) Local Definition pfiber2_loops_natural_core {D : Type} {y x : D} (X : y = x) (l : x = x) : X^ @ (1 @ (((1 @ (1 @ X)^)^ @ l) @ 1)) = 1 @ (l @ 1). @@ -148,8 +146,7 @@ Proof. exact (ap (concat 1) (concat_1p _ @ whiskerR (concat_1p l) 1)). Defined. -(** [pfiber2_loops] commutes with the fiber functor of a square, for an - arbitrary square of pointed maps. *) +(** [pfiber2_loops] commutes with the fiber functor of a square, for an arbitrary square of pointed maps. *) Definition pfiber2_loops_natural_functor {A B C D : pType} {f : A ->* B} {g : C ->* D} {h : A ->* C} {k : B ->* D} (p : k o* f ==* g o* h) @@ -179,8 +176,7 @@ Proof. reflexivity. Defined. -(** The same for an equivalence square; the underlying double-fiber map is - [functor_pfiber] of the same square. *) +(** The same for an equivalence square; the underlying double-fiber map is [functor_pfiber] of the same square. *) Definition pfiber2_loops_natural {A B C D : pType} {f : A ->* B} {g : C ->* D} (h : A <~>* C) (k : B <~>* D) (p : k o* f ==* g o* h) diff --git a/theories/Pointed/pMap.v b/theories/Pointed/pMap.v index 80312bbb620..afc4aa23a82 100644 --- a/theories/Pointed/pMap.v +++ b/theories/Pointed/pMap.v @@ -44,7 +44,7 @@ Proof. refine (_ @* precompose_pconst f). apply pmap_postwhisker. symmetry. - apply pmap_punit_pconst. + apply phomotopy_pconst_contr. Defined. (* We note that the inverse of [path_pmap] computes definitionally on reflexivity, and hence [path_pmap] itself computes typally so. *) From 232829f1430a78599029811f51fa7c2340694fc3 Mon Sep 17 00:00:00 2001 From: CharlesCNorton Date: Sun, 21 Jun 2026 09:28:02 -0400 Subject: [PATCH 10/12] EMSpace: make K(-,n) a wild category functor Register K(-,n) as an Is0Functor, Is1Functor and IsPointedFunctor from abelian groups to pointed types, with em_fmap as the action on morphisms. em_fmap_const now follows from fmap_zero_morphism and pequiv_em_fmap from emap, removing their bespoke proofs. --- theories/Homotopy/EMSpace.v | 65 ++++++++++++++++++++----------------- 1 file changed, 36 insertions(+), 29 deletions(-) diff --git a/theories/Homotopy/EMSpace.v b/theories/Homotopy/EMSpace.v index 0ba80cc489e..422e89267bc 100644 --- a/theories/Homotopy/EMSpace.v +++ b/theories/Homotopy/EMSpace.v @@ -1,5 +1,5 @@ From HoTT Require Import Basics Types. -From HoTT.WildCat Require Import Core Universe Equiv. +From HoTT.WildCat Require Import Core Universe Equiv PointedCat. Require Import Pointed. Require Import Cubical.DPath. Require Import Algebra.AbGroups.AbelianGroup. @@ -163,6 +163,27 @@ Section EilenbergMacLane. exact (pointed_htpy IH). Defined. + (** [K(-,n)] is a functor from abelian groups to pointed types, with [em_fmap] as its action on morphisms. *) + #[export] Instance is0functor_em (n : nat) + : Is0Functor (fun G : AbGroup => K(G, n)). + Proof. + napply Build_Is0Functor. + intros G G' f; exact (em_fmap f n). + Defined. + + #[export] Instance is1functor_em (n : nat) + : Is1Functor (fun G : AbGroup => K(G, n)). + Proof. + napply Build_Is1Functor. + - intros G G' f g p. + napply phomotopy_path. + napply (ap (fun h => em_fmap h n)). + apply equiv_path_grouphomomorphism. + exact p. + - intros G; exact (em_fmap_idmap n). + - intros G G' G'' f g; exact (em_fmap_compose f g n). + Defined. + (** At positive levels, [pequiv_loops_em_em] is the canonical comparison map: the loop-suspension unit followed by [loops] of the truncation map. This presentation makes its naturality transparent, without reference to the Hopf-construction input used to show that it is an equivalence. *) Definition loops_em_em_ptr_unit (G : AbGroup) (n : nat) : pequiv_loops_em_em G n.+1 @@ -241,18 +262,21 @@ Section EilenbergMacLane. exact (ap tr (contr a)). Defined. - (** [em_fmap] sends the constant homomorphism to the constant map. *) - Definition em_fmap_const {G G' : AbGroup} (n : nat) - : em_fmap (G:=G) (G':=G') grp_homo_const n ==* pconst. + (** [K(-,n)] is a pointed functor: it sends the trivial group to a contractible space. *) + #[export] Instance ispointedfunctor_em (n : nat) + : IsPointedFunctor (fun G : AbGroup => K(G, n)). Proof. - refine (phomotopy_path (ap (fun h => em_fmap h n) _) - @* em_fmap_compose (G':=abgroup_trivial) - (grp_trivial_corec G) (grp_trivial_rec G') n - @* pmap_postwhisker _ ((phomotopy_pconst_contr _)^*) - @* precompose_pconst _). - napply equiv_path_grouphomomorphism; intro x; reflexivity. + rapply Build_IsPointedFunctor'. + snapply Build_pEquiv. + 1: exact pconst. + rapply isequiv_contr_contr. Defined. + (** [em_fmap] sends the constant homomorphism to the constant map. *) + Definition em_fmap_const {G G' : AbGroup} (n : nat) + : em_fmap (G:=G) (G':=G') grp_homo_const n ==* pconst + := fmap_zero_morphism (fun G : AbGroup => K(G, n)). + (** [em_fmap f n.+1] of a surjective homomorphism is an [n]-connected map. Both surjectivity of the map and of its [ap]s reduce to the previous level through the loop-space identifications. *) #[export] Instance isconnmap_em_fmap {G G' : AbGroup} (f : GroupHomomorphism G G') `{!IsSurjection f} (n : nat) @@ -334,25 +358,8 @@ Section EilenbergMacLane. (** [em_fmap] of a group isomorphism is a pointed equivalence. *) Definition pequiv_em_fmap {G G' : AbGroup} (e : GroupIsomorphism G G') (n : nat) - : K(G, n) <~>* K(G', n). - Proof. - snapply Build_pEquiv. - 1: exact (em_fmap e n). - snapply isequiv_adjointify. - 1: exact (em_fmap (grp_iso_inverse e) n). - - intro x. - lhs_V exact (em_fmap_compose (G':=G) (grp_iso_inverse e) e n x). - refine (phomotopy_path - (ap (fun h => em_fmap h n) (_ : _ = grp_homo_id)) x - @ em_fmap_idmap n x). - by apply equiv_path_grouphomomorphism; intro g; apply eisretr. - - intro x. - lhs_V exact (em_fmap_compose (G':=G') e (grp_iso_inverse e) n x). - refine (phomotopy_path - (ap (fun h => em_fmap h n) (_ : _ = grp_homo_id)) x - @ em_fmap_idmap n x). - by apply equiv_path_grouphomomorphism; intro g; apply eissect. - Defined. + : K(G, n) <~>* K(G', n) + := emap (fun G : AbGroup => K(G, n)) (Build_CatEquiv e). (** Every pointed (n-1)-connected n-type is an Eilenberg-Mac Lane space. *) Definition pequiv_em_connected_truncated (X : pType) From c2653509e1944a645379316319b81629b17120c8 Mon Sep 17 00:00:00 2001 From: CharlesCNorton Date: Sun, 21 Jun 2026 11:21:04 -0400 Subject: [PATCH 11/12] EMSpace: generalize the delooping equivalence to all levels Also rewrite the isequiv_em_fmap proof using lhs'/rhs'. --- theories/Algebra/AbSES/Classification.v | 10 +- theories/Homotopy/EMSpace.v | 138 +++++++++++++----------- 2 files changed, 80 insertions(+), 68 deletions(-) diff --git a/theories/Algebra/AbSES/Classification.v b/theories/Algebra/AbSES/Classification.v index f6d584477aa..8b6ddd33e0c 100644 --- a/theories/Algebra/AbSES/Classification.v +++ b/theories/Algebra/AbSES/Classification.v @@ -676,10 +676,10 @@ Section PfiberDeloop. equivalence applied to [psi], twisted by [pequiv_neg_em]. *) Local Definition abses_classifying_pfiber_deloop : abses_classifying_map (abses_pfiber 1 psi) - ==* equiv_deloop_em_pmap B A psi o* pequiv_neg_em. + ==* equiv_deloop_em_pmap B A 0 psi o* pequiv_neg_em. Proof. refine (_ @* (pmap_prewhisker pequiv_neg_em - (equiv_deloop_em_pmap_unfold B A psi) + (equiv_deloop_em_pmap_unfold B A 0 psi) @* pmap_compose_assoc _ _ _ @* pmap_postwhisker _ (pmap_compose_assoc _ _ _))^*). refine (pmap_prewhisker (pequiv_loops_em_em B 2) @@ -940,14 +940,14 @@ Section Classification. (** A section of the classifying map. *) Local Definition abses_classifying_section (f : K(B, 2) ->* K(A, 3)) : abses_classifying_map - (abses_pfiber 1 ((equiv_deloop_em_pmap B A)^-1 + (abses_pfiber 1 ((equiv_deloop_em_pmap B A 0)^-1 (f o* pequiv_neg_em^-1*))) = f. Proof. apply path_pforall. refine (abses_classifying_pfiber_deloop _ @* _). refine (pmap_prewhisker pequiv_neg_em - (phomotopy_path (eisretr (equiv_deloop_em_pmap B A) _)) @* _). + (phomotopy_path (eisretr (equiv_deloop_em_pmap B A 0) _)) @* _). refine (pmap_compose_assoc _ _ _ @* _). refine (pmap_postwhisker _ (peissect pequiv_neg_em) @* _). apply pmap_precompose_idmap. @@ -958,7 +958,7 @@ Section Classification. : abses_classifying_map (abses_pfiber 0 f) = f. Proof. transitivity (abses_classifying_map - (abses_pfiber 1 ((equiv_deloop_em_pmap B A)^-1 + (abses_pfiber 1 ((equiv_deloop_em_pmap B A 0)^-1 (f o* pequiv_neg_em^-1*)))). - apply (ap abses_classifying_map). refine ((ap (abses_pfiber 0) (abses_classifying_section f))^ @ _). diff --git a/theories/Homotopy/EMSpace.v b/theories/Homotopy/EMSpace.v index 422e89267bc..867f3269d87 100644 --- a/theories/Homotopy/EMSpace.v +++ b/theories/Homotopy/EMSpace.v @@ -262,7 +262,7 @@ Section EilenbergMacLane. exact (ap tr (contr a)). Defined. - (** [K(-,n)] is a pointed functor: it sends the trivial group to a contractible space. *) + (** [K(-,n)] is a pointed functor. *) #[export] Instance ispointedfunctor_em (n : nat) : IsPointedFunctor (fun G : AbGroup => K(G, n)). Proof. @@ -324,18 +324,18 @@ Section EilenbergMacLane. apply moveR_equiv_V; symmetry. apply moveR_equiv_V. apply path_pforall. - refine (pmap_postwhisker _ - (pmap_prewhisker _ (fmap2 loops (ptr_natural _ _))) @* _). - refine (pmap_postwhisker _ - (pmap_prewhisker _ (fmap_comp loops _ _)) @* _). - refine (pmap_postwhisker _ (pmap_compose_assoc _ _ _) @* _). - refine (pmap_postwhisker _ - (pmap_postwhisker _ (loop_susp_unit_natural _)^*) @* _). - refine (pmap_postwhisker _ (pmap_compose_assoc _ _ _)^* @* _). - refine (pmap_postwhisker _ - (pmap_prewhisker _ (loops_em_em_ptr_unit G' n)^*) @* _). - refine ((pmap_compose_assoc _ _ _)^* @* _). - refine (pmap_prewhisker _ (peissect _) @* _). + lhs' refine (pmap_postwhisker _ + (pmap_prewhisker _ (fmap2 loops (ptr_natural _ _)))). + lhs' refine (pmap_postwhisker _ + (pmap_prewhisker _ (fmap_comp loops _ _))). + lhs' refine (pmap_postwhisker _ (pmap_compose_assoc _ _ _)). + lhs' refine (pmap_postwhisker _ + (pmap_postwhisker _ (loop_susp_unit_natural _)^*)). + lhs' refine (pmap_postwhisker _ (pmap_compose_assoc _ _ _)^*). + lhs' refine (pmap_postwhisker _ + (pmap_prewhisker _ (loops_em_em_ptr_unit G' n)^*)). + lhs_V' refine (pmap_compose_assoc _ _ _). + lhs' refine (pmap_prewhisker _ (peissect _)). apply pmap_postcompose_idmap. Defined. @@ -392,21 +392,32 @@ End EilenbergMacLane. (** ** Delooping Eilenberg-Mac Lane mapping types *) +(** The [k]-fold loop space of a [k]-truncated type is a set. *) +Definition istrunc_iterated_loops_O `{Funext} (k : nat) (X : pType) `{H0 : IsTrunc k X} + : IsTrunc 0 (iterated_loops k X). +Proof. + revert X H0; induction k as [|k IH]; intros X H0. + - exact H0. + - rewrite (unfold_iterated_loops k X). + rapply IH. +Defined. + Section Deloop. - Context `{Univalence} (B A : AbGroup@{u}). + Context `{Univalence} (B A : AbGroup@{u}) (n : nat). - (** By Freudenthal, the loop-suspension unit of [K(B,2)] is 2-connected, so [Pi 3] of the unit is surjective; since [Pi 3 K(B,2)] is trivial, [psusp K(B,2)] has trivial [Pi 4]. *) - Local Instance contr_pi4_psusp_em : Contr (Pi 4 (psusp K(B, 2))). + (** [Pi n.+4 (psusp K(B,n.+2))] is trivial. *) + Local Instance contr_pi_psusp_em : Contr (Pi n.+4 (psusp K(B, n.+2))). Proof. - nrefine (contr_equiv' (Pi 3 (loops (psusp K(B, 2)))) _). - 1: exact (grp_iso_inverse (groupiso_pi_loops 2 (psusp K(B, 2)))). - pose proof (C := @conn_map_loop_susp_unit _ 0 K(B, 2) - (isconnected_em 1) - : IsConnMap 2 (loop_susp_unit K(B, 2))). - pose proof (contr_pi_succ_istrunc 1 K(B, 2)). - pose proof (S := issurj_pi_connmap 2 (loop_susp_unit K(B, 2))). - pose (fu := fmap (pPi 3) (loop_susp_unit K(B, 2)) - : Pi 3 K(B, 2) -> Pi 3 (loops (psusp K(B, 2)))). + nrefine (contr_equiv' (Pi n.+3 (loops (psusp K(B, n.+2)))) _). + 1: exact (grp_iso_inverse (groupiso_pi_loops n.+2 (psusp K(B, n.+2)))). + assert (C : IsConnMap n.+2 (loop_susp_unit K(B, n.+2))). + { napply (isconnmap_pred_add n.-2). + rewrite 2 trunc_index_add_succ. + exact (conn_map_loop_susp_unit n K(B, n.+2)). } + pose proof (contr_pi_succ_istrunc n.+1 K(B, n.+2)). + pose proof (S := issurj_pi_connmap n.+2 (loop_susp_unit K(B, n.+2))). + pose (fu := fmap (pPi n.+3) (loop_susp_unit K(B, n.+2)) + : Pi n.+3 K(B, n.+2) -> Pi n.+3 (loops (psusp K(B, n.+2)))). apply (Build_Contr _ (fu (center _))). intro y. pose proof (m := @center _ (S y)). @@ -416,77 +427,78 @@ Section Deloop. exact (ap _ (path_contr _ x)). Defined. - (** Hence the 4-truncation of [psusp K(B,2)] is already 3-truncated. *) - Local Instance istrunc_ptr4_psusp_em - : IsTrunc 3 (pTr 4 (psusp K(B, 2))). + (** [pTr n.+4 (psusp K(B,n.+2))] is [n.+3]-truncated. *) + Local Instance istrunc_ptr_psusp_em + : IsTrunc n.+3 (pTr n.+4 (psusp K(B, n.+2))). Proof. - apply (equiv_istrunc_contr_iterated_loops 4 _)^-1. - pose proof (@isconnected_susp 1 K(B, 2) (isconnected_em 1)). - pose proof (is0connected_isconnected 0 (psusp K(B, 2))). - pose proof (isconnected_trunc 0 4 (X := psusp K(B, 2))). + apply (equiv_istrunc_contr_iterated_loops n.+4 _)^-1. + pose proof (istrunc_iterated_loops_O n.+4 (pTr n.+4 (psusp K(B, n.+2)))). + pose proof (@isconnected_susp n.+1 K(B, n.+2) (isconnected_em n.+1)). + pose proof (is0connected_isconnected n (psusp K(B, n.+2))). + pose proof (isconnected_trunc 0 n.+4 (X := psusp K(B, n.+2))). snapply (conn_point_elim (-1)). 1,2: exact _. - nrefine (contr_equiv' (Pi 4 (pTr 4 (psusp K(B, 2)))) _). + nrefine (contr_equiv' (Pi n.+4 (pTr n.+4 (psusp K(B, n.+2)))) _). 1: exact (equiv_tr 0 _)^-1%equiv. - nrefine (contr_equiv' (Pi 4 (psusp K(B, 2))) _). - 1: exact (grp_iso_pi_Tr 3 (psusp K(B, 2))). + nrefine (contr_equiv' (Pi n.+4 (psusp K(B, n.+2))) _). + 1: exact (grp_iso_pi_Tr n.+3 (psusp K(B, n.+2))). exact _. Defined. - (** [K(B,3)] sits inside the 3-truncation of [pTr 4 (psusp K(B,2))] via [fmap (pTr 3) ptr]; this is an equivalence since the source is already 3-truncated. *) - Local Definition pequiv_ptr3_ptr4_psusp_em - : K(B, 3) <~>* pTr 3 (pTr 4 (psusp K(B, 2))). + (** [K(B,n.+3)] is the [n.+3]-truncation of [pTr n.+4 (psusp K(B,n.+2))]. *) + Local Definition pequiv_ptr_ptr_psusp_em + : K(B, n.+3) <~>* pTr n.+3 (pTr n.+4 (psusp K(B, n.+2))). Proof. snapply Build_pEquiv. - 1: exact (fmap (pTr 3) ptr). + 1: exact (fmap (pTr n.+3) ptr). napply O_inverts_conn_map. - exact (isconnmap_pred' 4 _). + exact (isconnmap_pred' n.+4 _). Defined. - (** The canonical equivalence between the 4- and 3-truncations. *) - Local Definition pequiv_ptr4_ptr3_psusp_em - : pTr 4 (psusp K(B, 2)) <~>* K(B, 3) - := pequiv_ptr3_ptr4_psusp_em^-1* o*E pequiv_ptr (n:=3). + (** The canonical equivalence between the [n.+4]- and [n.+3]-truncations. *) + Local Definition pequiv_ptr_psusp_em + : pTr n.+4 (psusp K(B, n.+2)) <~>* K(B, n.+3) + := pequiv_ptr_ptr_psusp_em^-1* o*E pequiv_ptr (n:=n.+3). - (** The comparison map collapses the two truncation units of [psusp K(B,2)], by naturality of [ptr]. *) - Local Definition tau_ptr4_ptr3_psusp_em - : pequiv_ptr4_ptr3_psusp_em o* ptr ==* ptr. + (** [pequiv_ptr_psusp_em] commutes with the truncation unit [ptr]. *) + Local Definition tau_ptr_psusp_em + : pequiv_ptr_psusp_em o* ptr ==* ptr. Proof. refine (pmap_prewhisker ptr (compose_cate_fun (A:=pType) _ _) @* _). refine (pmap_compose_assoc _ _ _ @* _). - refine (pmap_postwhisker _ (ptr_natural 3 ptr)^* @* _). + refine (pmap_postwhisker _ (ptr_natural n.+3 ptr)^* @* _). refine ((pmap_compose_assoc _ _ _)^* @* _). - refine (pmap_prewhisker ptr (peissect pequiv_ptr3_ptr4_psusp_em) @* _). + refine (pmap_prewhisker ptr (peissect pequiv_ptr_ptr_psusp_em) @* _). apply pmap_postcompose_idmap. Defined. - (** Pointed maps [K(B,3) ->* K(A,4)] are equivalent to pointed maps [K(B,2) ->* K(A,3)], by looping. *) + (** Pointed maps [K(B,n.+3) ->* K(A,n.+4)] are equivalent to pointed maps [K(B,n.+2) ->* K(A,n.+3)]. *) Definition equiv_deloop_em_pmap - : (K(B, 3) ->* K(A, 4)) <~> (K(B, 2) ->* K(A, 3)) - := pequiv_pequiv_postcompose (pequiv_loops_em_em A 3)^-1* - oE loop_susp_adjoint K(B, 2) K(A, 4) + : (K(B, n.+3) ->* K(A, n.+4)) <~> (K(B, n.+2) ->* K(A, n.+3)) + := pequiv_pequiv_postcompose (pequiv_loops_em_em A n.+3)^-1* + oE loop_susp_adjoint K(B, n.+2) K(A, n.+4) oE pequiv_ptr_rec - oE pequiv_pequiv_precompose pequiv_ptr4_ptr3_psusp_em. + oE pequiv_pequiv_precompose pequiv_ptr_psusp_em. - (** The delooping equivalence, unfolded: postcompose by the inverse loop identification, loop the map, precompose by the loop identification. *) - Definition equiv_deloop_em_pmap_unfold (psi : K(B, 3) ->* K(A, 4)) + (** [equiv_deloop_em_pmap] as looping conjugated by the loop identifications. *) + Definition equiv_deloop_em_pmap_unfold (psi : K(B, n.+3) ->* K(A, n.+4)) : equiv_deloop_em_pmap psi - ==* (pequiv_loops_em_em A 3)^-1* - o* (fmap loops psi o* pequiv_loops_em_em B 2). + ==* (pequiv_loops_em_em A n.+3)^-1* + o* (fmap loops psi o* pequiv_loops_em_em B n.+2). Proof. - transitivity ((pequiv_loops_em_em A 3)^-1* - o* (fmap loops (psi o* pequiv_ptr4_ptr3_psusp_em o* ptr) - o* loop_susp_unit K(B, 2))). + transitivity ((pequiv_loops_em_em A n.+3)^-1* + o* (fmap loops (psi o* pequiv_ptr_psusp_em o* ptr) + o* loop_susp_unit K(B, n.+2))). 1: reflexivity. symmetry. napply pmap_postwhisker. - refine (pmap_postwhisker _ (loops_em_em_ptr_unit B 1) @* _). + refine (pmap_postwhisker _ (loops_em_em_ptr_unit B n.+1) @* _). refine ((pmap_compose_assoc _ _ _)^* @* _). refine (pmap_prewhisker _ (fmap_comp loops _ _)^* @* _). napply pmap_prewhisker. tapply (fmap2 loops). exact (pmap_compose_assoc psi _ ptr - @* pmap_postwhisker psi tau_ptr4_ptr3_psusp_em)^*. + @* pmap_postwhisker psi tau_ptr_psusp_em)^*. Defined. End Deloop. From ebd0d3565ece360a6461ad348d187fde3b3d39fe Mon Sep 17 00:00:00 2001 From: CharlesCNorton <135471798+CharlesCNorton@users.noreply.github.com> Date: Sun, 21 Jun 2026 16:20:24 -0400 Subject: [PATCH 12/12] pFiber: build functor_pfiber's basepoint path with path_sigma' The path_hfiber form carries a moveR_Vp/point_htpy coherence that the kernel re-traverses when type-checking the pfiber2_loops naturality lemmas (pfiber2_loops_natural_functor, and through it ExactSequence's pfiber2_loops_pfib2). Building the path directly with path_sigma' avoids that, dropping pFiber.v ~9.5s->3.0s and ExactSequence.v ~14.9s->3.6s with no change to statements or downstream proofs. --- theories/Pointed/pFiber.v | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/theories/Pointed/pFiber.v b/theories/Pointed/pFiber.v index 777eda1735a..b9517ceea02 100644 --- a/theories/Pointed/pFiber.v +++ b/theories/Pointed/pFiber.v @@ -73,9 +73,13 @@ Definition functor_pfiber {A B C D} Proof. srapply Build_pMap. + cbn. exact (functor_hfiber2 p (point_eq k)). - + srapply path_hfiber. - - apply point_eq. - - refine (concat_pp_p _ _ _ @ _). apply moveR_Vp. exact (point_htpy p)^. + + snapply path_sigma'. + - exact (point_eq h). + - lhs napply transport_paths_Fl. + lhs napply (whiskerL _ (concat_pp_p _ _ _)). + lhs napply (whiskerL _ (whiskerL _ (point_htpy p)^)). + lhs napply (whiskerL _ (concat_V_pp _ _)). + napply concat_V_pp. Defined. Definition pequiv_pfiber {A B C D}