Library HoTT.Colimits.GraphQuotient
Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids Basics.Equivalences.
Require Import Types.Universe Types.Paths Types.Forall Types.Arrow Types.Sigma Cubical.DPath.
Require Import Homotopy.IdentitySystems.
Require Import Types.Universe Types.Paths Types.Forall Types.Arrow Types.Sigma Cubical.DPath.
Require Import Homotopy.IdentitySystems.
Quotient of a graph
Definition
Local Unset Elimination Schemes.
Module Export GraphQuotient.
Section GraphQuotient.
Universes i j u.
Constraint i ≤ u, j ≤ u.
Context {A : Type@{i}}.
Private Inductive GraphQuotient (R : A → A → Type@{j}) : Type@{u} :=
| gq : A → GraphQuotient R.
Arguments gq {R} a.
Context {R : A → A → Type@{j}}.
Axiom gqglue : ∀ {a b : A},
R a b → paths (@gq R a) (gq b).
Definition GraphQuotient_ind
(P : GraphQuotient R → Type@{k})
(gq' : ∀ a, P (gq a))
(gqglue' : ∀ a b (s : R a b), gqglue s # gq' a = gq' b)
: ∀ x, P x := fun x ⇒
match x with
| gq a ⇒ fun _ ⇒ gq' a
end gqglue'.
Above we did a match with output type a function, and then outside of the match we provided the argument gqglue'. If we instead end with | gq a ⇒ gq' a end., the definition will not depend on gqglue', which would be incorrect. This is the idiom referred to in ../../test/bugs/github1758.v and github1759.v.
Axiom GraphQuotient_ind_beta_gqglue
: ∀ (P : GraphQuotient R → Type@{k})
(gq' : ∀ a, P (gq a))
(gqglue' : ∀ a b (s : R a b), gqglue s # gq' a = gq' b)
(a b: A) (s : R a b),
apD (GraphQuotient_ind P gq' gqglue') (gqglue s) = gqglue' a b s.
End GraphQuotient.
End GraphQuotient.
Arguments gq {A R} a.
Definition GraphQuotient_rec {A R P} (c : A → P) (g : ∀ a b, R a b → c a = c b)
: GraphQuotient R → P.
Proof.
srapply GraphQuotient_ind.
1: exact c.
intros a b s.
exact (transport_const _ _ @ g a b s).
Defined.
Definition GraphQuotient_rec_beta_gqglue {A R P}
(c : A → P) (g : ∀ a b, R a b → c a = c b)
(a b : A) (s : R a b)
: ap (GraphQuotient_rec c g) (gqglue s) = g a b s.
Proof.
unfold GraphQuotient_rec.
refine (cancelL _ _ _ _ ).
refine ((apD_const _ _)^ @ _).
rapply GraphQuotient_ind_beta_gqglue.
Defined.
Descent
Descent data over a graph A and R is an "equifibrant" or "cartesian" type family gqd_fam : A → Type. If a b : A are related by r : R a b, then the fibers gqd_fam a and gqd_fam b are equivalent, witnessed by gqd_e.
Record gqDescent {A : Type} {R : A → A → Type} := {
gqd_fam (a : A) : Type;
gqd_e {a b : A} (r : R a b) : gqd_fam a <~> gqd_fam b
}.
Global Arguments gqDescent {A} R.
gqd_fam (a : A) : Type;
gqd_e {a b : A} (r : R a b) : gqd_fam a <~> gqd_fam b
}.
Global Arguments gqDescent {A} R.
Descent data induces a type family over GraphQuotient R.
Definition fam_gqdescent (Pe : gqDescent R)
: GraphQuotient R → Type.
Proof.
snapply (GraphQuotient_rec (gqd_fam Pe)).
intros a b r.
exact (path_universe_uncurried (gqd_e Pe r)).
Defined.
: GraphQuotient R → Type.
Proof.
snapply (GraphQuotient_rec (gqd_fam Pe)).
intros a b r.
exact (path_universe_uncurried (gqd_e Pe r)).
Defined.
A type family over GraphQuotient R induces descent data.
Definition gqdescent_fam (P : GraphQuotient R → Type) : gqDescent R.
Proof.
snapply Build_gqDescent.
- exact (P o gq).
- intros a b r.
exact (equiv_transport P (gqglue r)).
Defined.
Proof.
snapply Build_gqDescent.
- exact (P o gq).
- intros a b r.
exact (equiv_transport P (gqglue r)).
Defined.
Definition transport_fam_gqdescent_gqglue
(Pe : gqDescent R) {a b : A} (r : R a b) (pa : gqd_fam Pe a)
: transport (fam_gqdescent Pe) (gqglue r) pa = gqd_e Pe r pa.
Proof.
napply transport_path_universe'.
napply GraphQuotient_rec_beta_gqglue.
Defined.
(Pe : gqDescent R) {a b : A} (r : R a b) (pa : gqd_fam Pe a)
: transport (fam_gqdescent Pe) (gqglue r) pa = gqd_e Pe r pa.
Proof.
napply transport_path_universe'.
napply GraphQuotient_rec_beta_gqglue.
Defined.
A section on the descent data is a fiberwise section that respects the equivalences.
Record gqDescentSection {Pe : gqDescent R} := {
gqds_sect (a : A) : gqd_fam Pe a;
gqds_e {a b : A} (r : R a b)
: gqd_e Pe r (gqds_sect a) = gqds_sect b
}.
Global Arguments gqDescentSection Pe : clear implicits.
gqds_sect (a : A) : gqd_fam Pe a;
gqds_e {a b : A} (r : R a b)
: gqd_e Pe r (gqds_sect a) = gqds_sect b
}.
Global Arguments gqDescentSection Pe : clear implicits.
A descent section induces a genuine section of fam_gqdescent Pe.
Definition gqdescent_ind {Pe : gqDescent R}
(f : gqDescentSection Pe)
: ∀ (x : GraphQuotient R), fam_gqdescent Pe x.
Proof.
snapply (GraphQuotient_ind _ (gqds_sect f)).
intros a b r.
exact (transport_fam_gqdescent_gqglue Pe r _ @ gqds_e f r).
Defined.
(f : gqDescentSection Pe)
: ∀ (x : GraphQuotient R), fam_gqdescent Pe x.
Proof.
snapply (GraphQuotient_ind _ (gqds_sect f)).
intros a b r.
exact (transport_fam_gqdescent_gqglue Pe r _ @ gqds_e f r).
Defined.
We record its computation rule
Definition gqdescent_ind_beta_gqglue {Pe : gqDescent R}
(f : gqDescentSection Pe) {a b : A} (r : R a b)
: apD (gqdescent_ind f) (gqglue r) = transport_fam_gqdescent_gqglue Pe r _ @ gqds_e f r
:= GraphQuotient_ind_beta_gqglue _ (gqds_sect f) _ _ _ _.
(f : gqDescentSection Pe) {a b : A} (r : R a b)
: apD (gqdescent_ind f) (gqglue r) = transport_fam_gqdescent_gqglue Pe r _ @ gqds_e f r
:= GraphQuotient_ind_beta_gqglue _ (gqds_sect f) _ _ _ _.
Dependent descent data over descent data Pe : gqDescent R consists of a type family gqdd_fam : ∀ (a : A), gqd_fam Pe a → Type together with coherences gqdd_e r pa.
Record gqDepDescent {Pe : gqDescent R} := {
gqdd_fam (a : A) (pa : gqd_fam Pe a) : Type;
gqdd_e {a b : A} (r : R a b) (pa : gqd_fam Pe a)
: gqdd_fam a pa <~> gqdd_fam b (gqd_e Pe r pa)
}.
Global Arguments gqDepDescent Pe : clear implicits.
gqdd_fam (a : A) (pa : gqd_fam Pe a) : Type;
gqdd_e {a b : A} (r : R a b) (pa : gqd_fam Pe a)
: gqdd_fam a pa <~> gqdd_fam b (gqd_e Pe r pa)
}.
Global Arguments gqDepDescent Pe : clear implicits.
Definition gqdepdescent_fam {Pe : gqDescent R}
(Q : ∀ (x : GraphQuotient R), (fam_gqdescent Pe) x → Type)
: gqDepDescent Pe.
Proof.
snapply Build_gqDepDescent.
- intro a; cbn.
exact (Q (gq a)).
- intros a b r pa.
exact (equiv_transportDD (fam_gqdescent Pe) Q
(gqglue r) (transport_fam_gqdescent_gqglue Pe r pa)).
Defined.
(Q : ∀ (x : GraphQuotient R), (fam_gqdescent Pe) x → Type)
: gqDepDescent Pe.
Proof.
snapply Build_gqDepDescent.
- intro a; cbn.
exact (Q (gq a)).
- intros a b r pa.
exact (equiv_transportDD (fam_gqdescent Pe) Q
(gqglue r) (transport_fam_gqdescent_gqglue Pe r pa)).
Defined.
Definition fam_gqdepdescent {Pe : gqDescent R} (Qe : gqDepDescent Pe)
: ∀ (x : GraphQuotient R), (fam_gqdescent Pe x) → Type.
Proof.
snapply GraphQuotient_ind.
- exact (gqdd_fam Qe).
- intros a b r.
napply (moveR_transport_p _ (gqglue r)).
funext pa.
rhs napply transport_arrow_toconst.
rhs nrefine (ap (gqdd_fam Qe b) _).
+ exact (path_universe (gqdd_e Qe r pa)).
+ lhs napply (ap (fun x ⇒ (transport _ x _)) (inv_V (gqglue r))).
exact (transport_fam_gqdescent_gqglue _ _ _).
Defined.
: ∀ (x : GraphQuotient R), (fam_gqdescent Pe x) → Type.
Proof.
snapply GraphQuotient_ind.
- exact (gqdd_fam Qe).
- intros a b r.
napply (moveR_transport_p _ (gqglue r)).
funext pa.
rhs napply transport_arrow_toconst.
rhs nrefine (ap (gqdd_fam Qe b) _).
+ exact (path_universe (gqdd_e Qe r pa)).
+ lhs napply (ap (fun x ⇒ (transport _ x _)) (inv_V (gqglue r))).
exact (transport_fam_gqdescent_gqglue _ _ _).
Defined.
A section of dependent descent data Qe : gqDepDescent Pe is a fiberwise section gqdds_sect, together with coherences gqdd_e.
Record gqDepDescentSection {Pe : gqDescent R} {Qe : gqDepDescent Pe} := {
gqdds_sect (a : A) (pa : gqd_fam Pe a) : gqdd_fam Qe a pa;
gqdds_e {a b : A} (r : R a b) (pa : gqd_fam Pe a)
: gqdd_e Qe r pa (gqdds_sect a pa) = gqdds_sect b (gqd_e Pe r pa)
}.
Global Arguments gqDepDescentSection {Pe} Qe.
gqdds_sect (a : A) (pa : gqd_fam Pe a) : gqdd_fam Qe a pa;
gqdds_e {a b : A} (r : R a b) (pa : gqd_fam Pe a)
: gqdd_e Qe r pa (gqdds_sect a pa) = gqdds_sect b (gqd_e Pe r pa)
}.
Global Arguments gqDepDescentSection {Pe} Qe.
A dependent descent section induces a genuine section over the total space of fam_gqdescent Pe.
Definition gqdepdescent_ind {Pe : gqDescent R}
{Q : ∀ (x : GraphQuotient R), (fam_gqdescent Pe) x → Type}
(f : gqDepDescentSection (gqdepdescent_fam Q))
: ∀ (x : GraphQuotient R) (px : fam_gqdescent Pe x), Q x px.
Proof.
napply (GraphQuotient_ind _ (gqdds_sect f) _).
intros a b r.
apply dpath_forall.
intro pa.
apply (equiv_inj (transport (Q (gq b)) (transport_fam_gqdescent_gqglue Pe r pa))).
rhs exact (apD (gqdds_sect f b) (transport_fam_gqdescent_gqglue Pe r pa)).
exact (gqdds_e f r pa).
Defined.
{Q : ∀ (x : GraphQuotient R), (fam_gqdescent Pe) x → Type}
(f : gqDepDescentSection (gqdepdescent_fam Q))
: ∀ (x : GraphQuotient R) (px : fam_gqdescent Pe x), Q x px.
Proof.
napply (GraphQuotient_ind _ (gqdds_sect f) _).
intros a b r.
apply dpath_forall.
intro pa.
apply (equiv_inj (transport (Q (gq b)) (transport_fam_gqdescent_gqglue Pe r pa))).
rhs exact (apD (gqdds_sect f b) (transport_fam_gqdescent_gqglue Pe r pa)).
exact (gqdds_e f r pa).
Defined.
The data for a section into a constant type family.
Record gqDepDescentConstSection {Pe : gqDescent R} {Q : Type} := {
gqddcs_sect (a : A) (pa : gqd_fam Pe a) : Q;
gqddcs_e {a b : A} (r : R a b) (pa : gqd_fam Pe a)
: gqddcs_sect a pa = gqddcs_sect b (gqd_e Pe r pa)
}.
Global Arguments gqDepDescentConstSection Pe Q : clear implicits.
gqddcs_sect (a : A) (pa : gqd_fam Pe a) : Q;
gqddcs_e {a b : A} (r : R a b) (pa : gqd_fam Pe a)
: gqddcs_sect a pa = gqddcs_sect b (gqd_e Pe r pa)
}.
Global Arguments gqDepDescentConstSection Pe Q : clear implicits.
The data for a section of a constant family induces a section over the total space of fam_gqdescent Pe.
Definition gqdepdescent_rec {Pe : gqDescent R} {Q : Type}
(f : gqDepDescentConstSection Pe Q)
: ∀ (x : GraphQuotient R), fam_gqdescent Pe x → Q.
Proof.
snapply (GraphQuotient_ind _ (gqddcs_sect f)).
intros a b r.
napply dpath_arrow.
intro pa.
lhs napply transport_const.
rhs napply (ap _ (transport_fam_gqdescent_gqglue Pe r pa)).
exact (gqddcs_e f r pa).
Defined.
(f : gqDepDescentConstSection Pe Q)
: ∀ (x : GraphQuotient R), fam_gqdescent Pe x → Q.
Proof.
snapply (GraphQuotient_ind _ (gqddcs_sect f)).
intros a b r.
napply dpath_arrow.
intro pa.
lhs napply transport_const.
rhs napply (ap _ (transport_fam_gqdescent_gqglue Pe r pa)).
exact (gqddcs_e f r pa).
Defined.
Here is the computation rule on paths.
Definition gqdepdescent_rec_beta_gqglue {Pe : gqDescent R} {Q : Type}
(f : gqDepDescentConstSection Pe Q)
{a b : A} {pa : gqd_fam Pe a} {pb : gqd_fam Pe b} (r : R a b) (pr : gqd_e Pe r pa = pb)
: ap (sig_rec (gqdepdescent_rec f)) (path_sigma _ (gq a; pa) (gq b; pb) (gqglue r) (transport_fam_gqdescent_gqglue Pe r pa @ pr))
= gqddcs_e f r pa @ ap (gqddcs_sect f b) pr.
Proof.
Open Scope long_path_scope.
destruct pr.
rhs napply concat_p1.
lhs napply ap_sig_rec_path_sigma.
lhs napply (ap (fun x ⇒ _ (ap10 x _) @ _)).
1: napply GraphQuotient_ind_beta_gqglue.
do 3 lhs napply concat_pp_p.
apply moveR_Vp.
lhs nrefine (1 @@ (1 @@ (_ @@ 1))).
1: napply (ap10_dpath_arrow (fam_gqdescent Pe) (fun _ ⇒ Q) (gqglue r)).
lhs nrefine (1 @@ _).
{ lhs napply (1 @@ concat_pp_p _ _ _).
lhs napply (1 @@ concat_pp_p _ _ _).
lhs napply concat_V_pp.
lhs napply (1 @@ concat_pp_p _ _ _).
rewrite concat_p1.
exact (1 @@ (1 @@ concat_pV_p _ _)). }
napply concat_V_pp.
Close Scope long_path_scope.
Defined.
End Descent.
(f : gqDepDescentConstSection Pe Q)
{a b : A} {pa : gqd_fam Pe a} {pb : gqd_fam Pe b} (r : R a b) (pr : gqd_e Pe r pa = pb)
: ap (sig_rec (gqdepdescent_rec f)) (path_sigma _ (gq a; pa) (gq b; pb) (gqglue r) (transport_fam_gqdescent_gqglue Pe r pa @ pr))
= gqddcs_e f r pa @ ap (gqddcs_sect f b) pr.
Proof.
Open Scope long_path_scope.
destruct pr.
rhs napply concat_p1.
lhs napply ap_sig_rec_path_sigma.
lhs napply (ap (fun x ⇒ _ (ap10 x _) @ _)).
1: napply GraphQuotient_ind_beta_gqglue.
do 3 lhs napply concat_pp_p.
apply moveR_Vp.
lhs nrefine (1 @@ (1 @@ (_ @@ 1))).
1: napply (ap10_dpath_arrow (fam_gqdescent Pe) (fun _ ⇒ Q) (gqglue r)).
lhs nrefine (1 @@ _).
{ lhs napply (1 @@ concat_pp_p _ _ _).
lhs napply (1 @@ concat_pp_p _ _ _).
lhs napply concat_V_pp.
lhs napply (1 @@ concat_pp_p _ _ _).
rewrite concat_p1.
exact (1 @@ (1 @@ concat_pV_p _ _)). }
napply concat_V_pp.
Close Scope long_path_scope.
Defined.
End Descent.
The flattening lemma
We mimic the constructors of GraphQuotient for the total space. Here is the point constructor, in curried form.
And here is the path constructor.
Definition flatten_gqd_glue {a b : A} (r : R a b)
{pa : gqd_fam Pe a} {pb : gqd_fam Pe b} (pr : gqd_e Pe r pa = pb)
: flatten_gqd pa = flatten_gqd pb.
Proof.
snapply path_sigma.
- by apply gqglue.
- lhs napply transport_fam_gqdescent_gqglue.
exact pr.
Defined.
{pa : gqd_fam Pe a} {pb : gqd_fam Pe b} (pr : gqd_e Pe r pa = pb)
: flatten_gqd pa = flatten_gqd pb.
Proof.
snapply path_sigma.
- by apply gqglue.
- lhs napply transport_fam_gqdescent_gqglue.
exact pr.
Defined.
Now that we've shown that fam_gqdescent Pe acts like a GraphQuotient of sig (gqd_fam Pe) by an appropriate relation, we can use this to prove the flattening lemma. The maps back and forth are very easy so this could almost be a formal consequence of the induction principle.
Lemma equiv_gqd_flatten : sig (fam_gqdescent Pe) <~>
GraphQuotient (fun a b ⇒ {r : R a.1 b.1 & gqd_e Pe r a.2 = b.2}).
Proof.
snapply equiv_adjointify.
- snapply sig_rec.
snapply gqdepdescent_rec.
snapply Build_gqDepDescentConstSection.
+ exact (fun a x ⇒ gq (a; x)).
+ intros a b r pa.
apply gqglue; exact (r; 1).
- snapply GraphQuotient_rec.
+ exact (fun '(a; x) ⇒ (gq a; x)).
+ intros [a x] [b y] [r pr]; cbn in r, pr; cbn.
exact (flatten_gqd_glue r pr).
- snapply GraphQuotient_ind.
1: reflexivity.
intros [a x] [b y] [r pr]; cbn in r, pr; cbn.
destruct pr.
transport_paths FFlr; apply equiv_p1_1q.
rewrite GraphQuotient_rec_beta_gqglue.
lhs napply gqdepdescent_rec_beta_gqglue.
napply concat_p1.
- intros [x px]; revert x px.
snapply gqdepdescent_ind.
snapply Build_gqDepDescentSection.
+ by intros a pa.
+ intros a b r pa; cbn.
lhs napply transportDD_is_transport.
transport_paths FFlr; apply equiv_p1_1q.
rewrite <- (concat_p1 (transport_fam_gqdescent_gqglue _ _ _)).
rewrite gqdepdescent_rec_beta_gqglue. (* This needs to be in the form transport_fam_gqdescent_gqglue Pe r pa @ p to work, and the other @ 1 introduced comes in handy as well. *)
lhs napply (ap _ (concat_p1 _)).
exact (GraphQuotient_rec_beta_gqglue _ _ (a; pa) (b; _) (r; 1)).
Defined.
End Flattening.
GraphQuotient (fun a b ⇒ {r : R a.1 b.1 & gqd_e Pe r a.2 = b.2}).
Proof.
snapply equiv_adjointify.
- snapply sig_rec.
snapply gqdepdescent_rec.
snapply Build_gqDepDescentConstSection.
+ exact (fun a x ⇒ gq (a; x)).
+ intros a b r pa.
apply gqglue; exact (r; 1).
- snapply GraphQuotient_rec.
+ exact (fun '(a; x) ⇒ (gq a; x)).
+ intros [a x] [b y] [r pr]; cbn in r, pr; cbn.
exact (flatten_gqd_glue r pr).
- snapply GraphQuotient_ind.
1: reflexivity.
intros [a x] [b y] [r pr]; cbn in r, pr; cbn.
destruct pr.
transport_paths FFlr; apply equiv_p1_1q.
rewrite GraphQuotient_rec_beta_gqglue.
lhs napply gqdepdescent_rec_beta_gqglue.
napply concat_p1.
- intros [x px]; revert x px.
snapply gqdepdescent_ind.
snapply Build_gqDepDescentSection.
+ by intros a pa.
+ intros a b r pa; cbn.
lhs napply transportDD_is_transport.
transport_paths FFlr; apply equiv_p1_1q.
rewrite <- (concat_p1 (transport_fam_gqdescent_gqglue _ _ _)).
rewrite gqdepdescent_rec_beta_gqglue. (* This needs to be in the form transport_fam_gqdescent_gqglue Pe r pa @ p to work, and the other @ 1 introduced comes in handy as well. *)
lhs napply (ap _ (concat_p1 _)).
exact (GraphQuotient_rec_beta_gqglue _ _ (a; pa) (b; _) (r; 1)).
Defined.
End Flattening.
Characterization of path spaces
Let A and R be a graph, with a distinguished point a0 : A. Let Pe : gqDescent R be descent data over A and R with a distinguished point p0 : gqd_fam Pe a0. Assume that any dependent descent data Qe : gqDepDescent Pe with a distinguished point q0 : gqdd_fam Qe a0 p0 has a section that respects the distinguished points. This is the induction principle provided by Kraus and von Raumer.
Context `{Univalence} {A : Type} {R : A → A → Type} (a0 : A)
(Pe : gqDescent R) (p0 : gqd_fam Pe a0)
(based_gqdepdescent_ind : ∀ (Qe : gqDepDescent Pe) (q0 : gqdd_fam Qe a0 p0),
gqDepDescentSection Qe)
(based_gqdepdescent_ind_beta : ∀ (Qe : gqDepDescent Pe) (q0 : gqdd_fam Qe a0 p0),
gqdds_sect (based_gqdepdescent_ind Qe q0) a0 p0 = q0).
(Pe : gqDescent R) (p0 : gqd_fam Pe a0)
(based_gqdepdescent_ind : ∀ (Qe : gqDepDescent Pe) (q0 : gqdd_fam Qe a0 p0),
gqDepDescentSection Qe)
(based_gqdepdescent_ind_beta : ∀ (Qe : gqDepDescent Pe) (q0 : gqdd_fam Qe a0 p0),
gqdds_sect (based_gqdepdescent_ind Qe q0) a0 p0 = q0).
Under these hypotheses, we get an identity system structure on fam_gqdescent Pe.
Local Instance idsys_flatten_gqdescent
: @IsIdentitySystem _ (gq a0) (fam_gqdescent Pe) p0.
Proof.
snapply Build_IsIdentitySystem.
- intros Q q0 x p.
snapply gqdepdescent_ind.
by apply based_gqdepdescent_ind.
- intros Q q0; cbn.
napply (based_gqdepdescent_ind_beta (gqdepdescent_fam Q)).
Defined.
: @IsIdentitySystem _ (gq a0) (fam_gqdescent Pe) p0.
Proof.
snapply Build_IsIdentitySystem.
- intros Q q0 x p.
snapply gqdepdescent_ind.
by apply based_gqdepdescent_ind.
- intros Q q0; cbn.
napply (based_gqdepdescent_ind_beta (gqdepdescent_fam Q)).
Defined.
Definition fam_gqdescent_equiv_path (x : GraphQuotient R)
: (gq a0) = x <~> fam_gqdescent Pe x
:= @equiv_transport_identitysystem _ (gq a0) (fam_gqdescent Pe) p0 _ x.
End Paths.
: (gq a0) = x <~> fam_gqdescent Pe x
:= @equiv_transport_identitysystem _ (gq a0) (fam_gqdescent Pe) p0 _ x.
End Paths.
Lemma functor_gq {A B : Type} (f : A → B)
{R : A → A → Type} {S : B → B → Type} (e : ∀ a b, R a b → S (f a) (f b))
: GraphQuotient R → GraphQuotient S.
Proof.
snapply GraphQuotient_rec.
1: exact (fun x ⇒ gq (f x)).
intros a b r.
apply gqglue.
apply e.
exact r.
Defined.
Definition functor_gq_beta_gqglue {A B : Type} (f : A → B)
{R : A → A → Type} {S : B → B → Type}
(e : ∀ a b, R a b → S (f a) (f b))
{a b : A} (s : R a b)
: ap (functor_gq f e) (gqglue s) = gqglue (e a b s)
:= GraphQuotient_rec_beta_gqglue _ _ _ _ _.
Lemma functor_gq_idmap {A : Type} {R : A → A → Type}
: functor_gq (A:=A) (B:=A) (S:=R) idmap (fun a b r ⇒ r) == idmap.
Proof.
snapply GraphQuotient_ind.
1: reflexivity.
intros a b r.
transport_paths Flr.
apply equiv_p1_1q.
napply GraphQuotient_rec_beta_gqglue.
Defined.
Lemma functor_gq_compose {A B C : Type} (f : A → B) (g : B → C)
{R : A → A → Type} {S : B → B → Type} {T : C → C → Type}
(e : ∀ a b, R a b → S (f a) (f b)) (e' : ∀ a b, S a b → T (g a) (g b))
: functor_gq g e' o (functor_gq f e) == functor_gq (g o f) (fun a b r ⇒ e' _ _ (e _ _ r)).
Proof.
snapply GraphQuotient_ind.
1: reflexivity.
intros a b s; cbn beta.
transport_paths FFlFr.
apply equiv_p1_1q.
lhs napply ap.
1: apply functor_gq_beta_gqglue.
rhs napply (functor_gq_beta_gqglue (g o f)).
napply (functor_gq_beta_gqglue g).
Defined.
Lemma functor2_gq {A B : Type} (f f' : A → B)
{R : A → A → Type} {S : B → B → Type}
(e : ∀ a b, R a b → S (f a) (f b)) (e' : ∀ a b, R a b → S (f' a) (f' b))
(p : f == f')
(q : ∀ a b r, transport011 S (p a) (p b) (e a b r) = e' a b r)
: functor_gq f e == functor_gq f' e'.
Proof.
snapply GraphQuotient_ind.
- simpl; intro.
apply ap.
apply p.
- intros a b s; simpl.
transport_paths (transport_paths_FlFr (gqglue s)).
rhs napply whiskerL.
2: napply functor_gq_beta_gqglue.
lhs napply whiskerR.
1: napply functor_gq_beta_gqglue.
apply moveL_Mp.
symmetry.
destruct (q a b s).
lhs napply (ap_transport011 _ _ (fun s _ ⇒ gqglue)).
rhs napply concat_p_pp.
napply transport011_paths.
Defined.
Instance isequiv_functor_gq {A B : Type} (f : A → B) `{IsEquiv _ _ f}
{R : A → A → Type} {S : B → B → Type} (e : ∀ a b, R a b → S (f a) (f b))
`{∀ a b, IsEquiv (e a b)}
: IsEquiv (functor_gq f e).
Proof.
srapply isequiv_adjointify.
- napply (functor_gq f^-1).
intros a b s.
apply (e _ _)^-1.
exact (transport011 S (eisretr f a)^ (eisretr f b)^ s).
- intros x.
lhs napply functor_gq_compose.
rhs_V napply functor_gq_idmap.
snapply functor2_gq; cbn beta.
1: apply eisretr.
intros a b s.
rewrite (eisretr (e (f^-1 a) (f^-1 b))).
lhs_V napply transport011_pp.
by rewrite 2 concat_Vp.
- intros x.
lhs napply functor_gq_compose.
rhs_V napply functor_gq_idmap.
snapply functor2_gq; cbn beta.
1: apply eissect.
intros a b r.
rewrite 2 eisadj.
rewrite <- 2 ap_V.
rewrite <- (transport011_compose S).
rewrite <- (ap_transport011 (Q := fun x y ⇒ S (f x) (f y)) (eissect f a)^ (eissect f b)^ e).
rewrite (eissect (e (f^-1 (f a)) (f^-1 (f b)))).
lhs_V napply transport011_pp.
by rewrite 2 concat_Vp.
Defined.
Definition equiv_functor_gq {A B : Type} (f : A <~> B)
(R : A → A → Type) (S : B → B → Type) (e : ∀ a b, R a b <~> S (f a) (f b))
: GraphQuotient R <~> GraphQuotient S
:= Build_Equiv _ _ (functor_gq f e) _.