diff --git a/HoTTLean/ForMathlib.lean b/HoTTLean/ForMathlib.lean index cea2bcc2..947a8996 100644 --- a/HoTTLean/ForMathlib.lean +++ b/HoTTLean/ForMathlib.lean @@ -533,35 +533,6 @@ lemma ofYoneda_isPullback {C : Type u} [Category.{v} C] {TL TR BL BR : C} · specialize h (some .right) exact h -variable {C : Type u₁} [SmallCategory C] {F G : Cᵒᵖ ⥤ Type u₁} - (app : ∀ {X : C}, (yoneda.obj X ⟶ F) → (yoneda.obj X ⟶ G)) - (naturality : ∀ {X Y : C} (f : X ⟶ Y) (α : yoneda.obj Y ⟶ F), - app (yoneda.map f ≫ α) = yoneda.map f ≫ app α) - -variable (F) in -/-- - A presheaf `F` on a small category `C` is isomorphic to - the hom-presheaf `Hom(y(•),F)`. --/ -def yonedaIso : yoneda.op ⋙ yoneda.obj F ≅ F := - NatIso.ofComponents (fun _ => Equiv.toIso yonedaEquiv) - (fun f => by ext : 1; dsimp; rw [yonedaEquiv_naturality']) - -def yonedaIsoMap : yoneda.op ⋙ yoneda.obj F ⟶ yoneda.op ⋙ yoneda.obj G where - app _ := app - naturality _ _ _ := by ext : 1; apply naturality - -/-- Build natural transformations between presheaves on a small category - by defining their action when precomposing by a morphism with - representable domain -/ -def NatTrans.yonedaMk : F ⟶ G := - (yonedaIso F).inv ≫ yonedaIsoMap app naturality ≫ (yonedaIso G).hom - -theorem NatTrans.yonedaMk_app {X : C} (α : yoneda.obj X ⟶ F) : - α ≫ yonedaMk app naturality = app α := by - rw [← yonedaEquiv.apply_eq_iff_eq, yonedaEquiv_comp] - simp [yonedaMk, yonedaIso, yonedaIsoMap] - namespace Functor theorem precomp_heq_of_heq_id {A B : Type u} {C : Type*} [Category.{v} A] [Category.{v} B] [Category C] @@ -583,4 +554,89 @@ theorem comp_heq_of_heq_id {A B : Type u} {C : Type*} [Category.{v} A] [Category end Functor +lemma eqToHom_heq_id {C : Type*} [Category C] (x y z : C) (h : x = y) + (hz : z = x) : eqToHom h ≍ 𝟙 z := by cat_disch + +lemma Cat.inv_heq_inv {C C' : Cat} (hC : C ≍ C') {X Y : C} {X' Y' : C'} + (hX : X ≍ X') (hY : Y ≍ Y') {f : X ⟶ Y} {f' : X' ⟶ Y'} (hf : f ≍ f') [IsIso f] : + have : IsIso f' := by aesop + inv f ≍ inv f' := by + subst hC hX hY hf + rfl + +lemma inv_heq_of_heq_inv {C : Grpd} {X Y X' Y' : C} + (hX : X = X') (hY : Y = Y') {f : X ⟶ Y} {g : Y' ⟶ X'} (hf : f ≍ inv g) : + inv f ≍ g := by + aesop_cat + +lemma inv_heq_inv {C : Type*} [Category C] {X Y : C} {X' Y' : C} + (hX : X = X') (hY : Y = Y') {f : X ⟶ Y} {f' : X' ⟶ Y'} (hf : f ≍ f') [IsIso f] : + have : IsIso f' := by aesop + inv f ≍ inv f' := by + subst hX hY hf + rfl + +lemma Discrete.as_heq_as {α α' : Type u} (hα : α ≍ α') (x : Discrete α) (x' : Discrete α') + (hx : x ≍ x') : x.as ≍ x'.as := by + aesop_cat + +lemma Discrete.functor_ext' {X C : Type*} [Category C] {F G : X → C} (h : ∀ x : X, F x = G x) : + Discrete.functor F = Discrete.functor G := by + have : F = G := by aesop + subst this + rfl + +lemma Discrete.functor_eq {X C : Type*} [Category C] {F : Discrete X ⥤ C} : + F = Discrete.functor fun x ↦ F.obj ⟨x⟩ := by + fapply CategoryTheory.Functor.ext + · aesop + · intro x y f + cases x ; rcases f with ⟨⟨h⟩⟩ + cases h + simp + +lemma Discrete.hext {X Y : Type u} (a : Discrete X) (b : Discrete Y) (hXY : X ≍ Y) + (hab : a.1 ≍ b.1) : a ≍ b := by + aesop_cat + +lemma Discrete.Hom.hext {α β : Type u} {x y : Discrete α} (x' y' : Discrete β) (hαβ : α ≍ β) + (hx : x ≍ x') (hy : y ≍ y') (f : x ⟶ y) (f' : x' ⟶ y') : f ≍ f' := by + aesop_cat + +open Prod in +lemma Prod.sectR_comp_snd {C : Type u₁} [Category.{v₁} C] (Z : C) + (D : Type u₂) [Category.{v₂} D] : sectR Z D ⋙ snd C D = 𝟭 D := + rfl + +section +variable {C : Type u} [Category.{v} C] {D : Type u₁} [Category.{v₁} D] (P Q : ObjectProperty D) + (F : C ⥤ D) (hF : ∀ X, P (F.obj X)) + +theorem ObjectProperty.lift_comp_inclusion_eq : + P.lift F hF ⋙ P.ι = F := + rfl + +end + +lemma eqToHom_heq_eqToHom {C : Type*} [Category C] (x y x' y' : C) (hx : x = x') + (h : x = y) (h' : x' = y') : eqToHom h ≍ eqToHom h' := by aesop + end CategoryTheory + +lemma hcongr_fun {α α' : Type u} (hα : α ≍ α') (β : α → Type v) (β' : α' → Type v) (hβ : β ≍ β') + (f : (x : α) → β x) (f' : (x : α') → β' x) (hf : f ≍ f') + {x : α} {x' : α'} (hx : x ≍ x') : f x ≍ f' x' := by + subst hα hβ hf hx + rfl + +lemma fun_hext {α α' : Type u} (hα : α ≍ α') (β : α → Type v) (β' : α' → Type v) (hβ : β ≍ β') + (f : (x : α) → β x) (f' : (x : α') → β' x) + (hf : {x : α} → {x' : α'} → (hx : x ≍ x') → f x ≍ f' x') : f ≍ f' := by + aesop + +lemma Subtype.hext {α α' : Sort u} (hα : α ≍ α') {p : α → Prop} {p' : α' → Prop} + (hp : p ≍ p') {a : { x // p x }} {a' : { x // p' x }} (ha : a.1 ≍ a'.1) : a ≍ a' := by + subst hα hp + simp only [heq_eq_eq] + ext + simpa [← heq_eq_eq] diff --git a/HoTTLean/ForMathlib/CategoryTheory/Adjunction/Basic.lean b/HoTTLean/ForMathlib/CategoryTheory/Adjunction/Basic.lean new file mode 100644 index 00000000..1e458884 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Adjunction/Basic.lean @@ -0,0 +1,49 @@ +import Mathlib.CategoryTheory.Adjunction.Basic + +namespace CategoryTheory + +open CategoryTheory.Functor NatIso Category + +-- declare the `v`'s first; see `CategoryTheory.Category` for an explanation +universe v₁ v₂ v₃ u₁ u₂ u₃ +variable {C : Type u₁} [Category.{v₁} C] {D : Type u₂} + +/-- The natural hom-set isomorphism `C(F(-),⋆) ≅ D(-,G(⋆))` given by an adjunction. -/ +def Adjunction.homIso [Category.{v₁} D] {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G) : + yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj (F.op) ≅ G ⋙ yoneda := + NatIso.ofComponents + (fun X => (adj.representableBy X).toIso.symm) + (fun {X Y} f => by ext; simp [Functor.RepresentableBy.toIso, Functor.representableByEquiv, + adj.homEquiv_naturality_right]) + +namespace Equivalence + +variable [Category.{v₂} D] {e : C ≌ D} + +def isoCompInverse {J : Type*} [Category J] {X : J ⥤ C} {Y : J ⥤ D} (α : X ⋙ e.functor ≅ Y) : + X ≅ Y ⋙ e.inverse := + calc X + _ ≅ X ⋙ 𝟭 _ := X.rightUnitor.symm + _ ≅ X ⋙ e.functor ⋙ e.inverse := Functor.isoWhiskerLeft X e.unitIso + _ ≅ (X ⋙ e.functor) ⋙ e.inverse := Functor.associator .. + _ ≅ Y ⋙ e.inverse := Functor.isoWhiskerRight α e.inverse + +@[simp] +lemma isoCompInverse_hom_app {J : Type*} [Category J] {X : J ⥤ C} {Y : J ⥤ D} + (α : X ⋙ e.functor ≅ Y) (A : J) : + (isoCompInverse α).hom.app A = e.unitIso.hom.app (X.obj A) ≫ e.inverse.map (α.hom.app A) := by + simp [isoCompInverse, Trans.trans] + +@[simp] +lemma isoCompInverse_inv_app {J : Type*} [Category J] {X : J ⥤ C} {Y : J ⥤ D} + (α : X ⋙ e.functor ≅ Y) (A : J) : + (isoCompInverse α).inv.app A = e.inverse.map (α.inv.app A) ≫ e.unitIso.inv.app (X.obj A) := by + simp [isoCompInverse, Trans.trans] + +@[simps] +def compFunctorNatIsoEquiv {J : Type*} [Category J] (X : J ⥤ C) (Y : J ⥤ D) : + (X ⋙ e.functor ≅ Y) ≃ (X ≅ Y ⋙ e.inverse) where + toFun := isoCompInverse + invFun α := (e.symm.isoCompInverse α.symm).symm + left_inv := by cat_disch + right_inv := by cat_disch diff --git a/HoTTLean/ForMathlib/CategoryTheory/Adjunction/PartialAdjoint.lean b/HoTTLean/ForMathlib/CategoryTheory/Adjunction/PartialAdjoint.lean new file mode 100644 index 00000000..8058dd1f --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Adjunction/PartialAdjoint.lean @@ -0,0 +1,66 @@ +import Mathlib.CategoryTheory.Adjunction.PartialAdjoint + + +universe v₁ v₂ u₁ u₂ + +namespace CategoryTheory + +namespace Functor + +open Category Opposite Limits + +section PartialRightAdjoint + +variable {C : Type u₁} [Category.{v₁} C] {D : Type u₂} [Category.{v₂} D] (F : C ⥤ D) + +structure PartialRightAdjoint (G : F.PartialRightAdjointSource ⥤ C) where + (repr : ∀ Y, (F.op ⋙ yoneda.obj Y.obj).RepresentableBy (G.obj Y)) + (repr_homEquiv : ∀ X Y (f : X ⟶ Y), (repr Y).homEquiv (G.map f) = + (repr X).homEquiv (𝟙 _) ≫ f) + +@[simps] +noncomputable def partialRightAdjoint.partialRightAdjoint : + PartialRightAdjoint F (partialRightAdjoint F) where + repr _ := Functor.representableBy _ + repr_homEquiv _ _ _ := by + simp only [partialRightAdjoint_obj, comp_obj, op_obj, yoneda_obj_obj, partialRightAdjoint_map, + partialRightAdjointMap, partialRightAdjointHomEquiv] + erw [Equiv.apply_symm_apply] + +@[simps] +noncomputable def rightAdjoint.partialRightAdjoint (L : C ⥤ D) [IsLeftAdjoint L] : + PartialRightAdjoint L (ObjectProperty.ι _ ⋙ rightAdjoint L) where + repr Y := Adjunction.representableBy (Adjunction.ofIsLeftAdjoint L) _ + repr_homEquiv a b c := by + simp [Equiv.symm_apply_eq, Adjunction.homEquiv_naturality_right] + +lemma PartialRightAdjoint.repr_homEquiv_comp {G : F.PartialRightAdjointSource ⥤ C} + (P : PartialRightAdjoint F G) {X Y Z} (f : X ⟶ Y) (a : Z ⟶ G.obj X) : + (P.repr Y).homEquiv (a ≫ G.map f) = (P.repr X).homEquiv a ≫ f := by + have := (P.repr X).homEquiv_comp a (𝟙 _) + rw [(P.repr Y).homEquiv_comp, P.repr_homEquiv] + cat_disch + +lemma PartialRightAdjoint.repr_homEquiv_symm_comp {G : F.PartialRightAdjointSource ⥤ C} + (P : PartialRightAdjoint F G) {X Y Z} (f : X ⟶ Y) (a : F.obj Z ⟶ X.obj) : + (P.repr Y).homEquiv.symm (a ≫ f) = (P.repr X).homEquiv.symm a ≫ G.map f := by + rw [Equiv.symm_apply_eq, repr_homEquiv_comp, Equiv.apply_symm_apply] + +def PartialRightAdjoint.uniqueUpToIso {G G' : F.PartialRightAdjointSource ⥤ C} + (P : PartialRightAdjoint F G) (P' : PartialRightAdjoint F G') : G ≅ G' := + NatIso.ofComponents (fun X => (P.repr _).uniqueUpToIso (P'.repr _)) + (fun {X Y} f => by + apply yoneda.map_injective + ext Z a + simp only [yoneda_obj_obj, RepresentableBy.uniqueUpToIso_hom, comp_obj, op_obj, map_comp, + FullyFaithful.map_preimage, FunctorToTypes.comp, yoneda_map_app, NatIso.ofComponents_hom_app, + Function.comp_apply] + calc (P'.repr Y).homEquiv.symm ((P.repr Y).homEquiv (a ≫ G.map f)) + _ = (P'.repr Y).homEquiv.symm ((P.repr X).homEquiv a ≫ f) := by + simpa using PartialRightAdjoint.repr_homEquiv_comp .. + _ = (P'.repr X).homEquiv.symm ((P.repr X).homEquiv a) ≫ G'.map f := by + apply repr_homEquiv_symm_comp) + +noncomputable abbrev isoPartialRightAdjoint (G : F.PartialRightAdjointSource ⥤ C) + (P : PartialRightAdjoint F G) : G ≅ partialRightAdjoint F := + PartialRightAdjoint.uniqueUpToIso _ P (partialRightAdjoint.partialRightAdjoint _) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean index fd2adab7..32b23508 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean @@ -585,6 +585,43 @@ def toTransport_fiber (x : ∫ F) {c : C} (t : x.base ⟶ c) : (toTransport x t).fiber = 𝟙 _ := rfl +lemma transport_id {x : ∫ F} : + transport x (𝟙 x.base) = x := by + fapply Grothendieck.ext <;> simp [transport] + +lemma transport_eqToHom {X: C} {X' : ∫ F} (hX': (forget F).obj X' = X): + X'.transport (eqToHom hX') = X' := by + subst hX' + simp [transport_id] + +lemma toTransport_id {X : ∫ F} : + toTransport X (𝟙 X.base) = eqToHom transport_id.symm := by + apply Grothendieck.Hom.ext <;> simp + +lemma toTransport_eqToHom {X: C} {X' : ∫ F} (hX': (forget F).obj X' = X): + toTransport X' (eqToHom hX') = eqToHom (by subst hX'; simp[transport_id]) := by + subst hX' + simp [toTransport_id] + +lemma transport_comp (x : ∫ F) {c d: C} (t : x.base ⟶ c) (t': c ⟶ d): + transport x (t ≫ t') = transport (c:= d) (transport x t) t' := by + simp [transport] + +lemma toTransport_comp (x : ∫ F) {c d: C} (t : x.base ⟶ c) (t': c ⟶ d): + toTransport x (t ≫ t') = + toTransport x t ≫ toTransport (transport x t) t' ≫ eqToHom (transport_comp x t t').symm := by + simp only [← Category.assoc, ← heq_eq_eq, heq_comp_eqToHom_iff] + simp only [toTransport, transport_base, transport_fiber] + fapply Grothendieck.Hom.hext' + · rfl + · rfl + · simp [transport_comp] + · simp + · simp only [transport_base, Hom.mk_base, transport_fiber, Hom.comp_base, Hom.comp_fiber, map_id, + Category.comp_id] + symm + apply eqToHom_heq_id_dom + /-- Construct an isomorphism in a Grothendieck construction from isomorphisms in its base and fiber. -/ @@ -851,6 +888,14 @@ lemma toPseudoFunctor'Iso.inv_comp_forget : toPseudoFunctor'Iso.inv F ⋙ forget Pseudofunctor.Grothendieck.forget _ := rfl +lemma map_eq_pseudofunctor_map {G} (α : F ⟶ G) : map α = (toPseudoFunctor'Iso F).hom ⋙ + Pseudofunctor.Grothendieck.map α.toStrongTrans' ⋙ + (toPseudoFunctor'Iso G).inv := by + fapply Functor.ext + · aesop + · intro _ + aesop + end Pseudofunctor section @@ -1146,7 +1191,7 @@ include hom_id in lemma functorFromCompHom_id (c : C) : functorFromCompHom fib hom G (𝟙 c) = eqToHom (by simp [Cat.id_eq_id, Functor.id_comp]) := by ext x - simp [hom_id, functorFromCompHom] + simp [hom_id, eqToHom_map, functorFromCompHom] include hom_comp in lemma functorFromCompHom_comp (c₁ c₂ c₃ : C) (f : c₁ ⟶ c₂) (g : c₂ ⟶ c₃): @@ -1155,7 +1200,7 @@ lemma functorFromCompHom_comp (c₁ c₂ c₃ : C) (f : c₁ ⟶ c₂) (g : c₂ Functor.whiskerLeft (F.map f) (functorFromCompHom fib hom G g) ≫ eqToHom (by simp[Cat.comp_eq_comp, Functor.map_comp, Functor.assoc]) := by ext - simp [functorFromCompHom, hom_comp] + simp [functorFromCompHom, hom_comp, eqToHom_map] theorem functorFrom_comp : functorFrom fib hom hom_id hom_comp ⋙ G = functorFrom (functorFromCompFib fib G) (functorFromCompHom fib hom G) @@ -1390,6 +1435,55 @@ def mapWhiskerRightAsSmallFunctor (α : F ⟶ G) : end AsSmall +noncomputable section + +variable {F} {x y : ∫ F} (f : x ⟶ y) [IsIso f] + +instance : IsIso f.base := by + refine ⟨ (CategoryTheory.inv f).base , ?_, ?_ ⟩ + · simp [← Grothendieck.Hom.comp_base] + · simp [← Grothendieck.Hom.comp_base] + +def invFiber : y.fiber ⟶ (F.map f.base).obj x.fiber := + eqToHom (by simp [← Functor.comp_obj, ← Cat.comp_eq_comp, ← Functor.map_comp, + ← Grothendieck.Hom.comp_base]) ≫ + (F.map f.base).map (CategoryTheory.inv f).fiber + +@[simp] +lemma fiber_comp_invFiber : f.fiber ≫ invFiber f = 𝟙 ((F.map f.base).obj x.fiber) := by + have h := Functor.Grothendieck.Hom.comp_fiber f (CategoryTheory.inv f) + rw! [IsIso.hom_inv_id] at h + have h0 : F.map (CategoryTheory.inv f).base ⋙ F.map f.base = 𝟭 _ := by + simp [← Cat.comp_eq_comp, ← Functor.map_comp, ← Grothendieck.Hom.comp_base, Cat.id_eq_id] + have h1 := Functor.congr_map (F.map f.base) h + simp [← heq_eq_eq, eqToHom_map, ← Functor.comp_map, Functor.congr_hom h0] at h1 + dsimp [invFiber] + rw! [← h1] + simp + +@[simp] +lemma invFiber_comp_fiber : invFiber f ≫ f.fiber = 𝟙 _ := by + have h := Functor.Grothendieck.Hom.comp_fiber (CategoryTheory.inv f) f + rw! [IsIso.inv_hom_id] at h + simp [invFiber] + convert h.symm + · simp + · simp + · simpa using (eqToHom_heq_id_cod _ _ _).symm + +instance : IsIso f.fiber := + ⟨invFiber f , fiber_comp_invFiber f, invFiber_comp_fiber f⟩ + +lemma inv_base : CategoryTheory.inv f.base = Grothendieck.Hom.base (CategoryTheory.inv f) := by + apply IsIso.inv_eq_of_hom_inv_id + simp [← Hom.comp_base] + +lemma inv_fiber : CategoryTheory.inv f.fiber = invFiber f := by + apply IsIso.inv_eq_of_hom_inv_id + simp + +end + end Grothendieck end Functor diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean new file mode 100644 index 00000000..90cfa743 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -0,0 +1,553 @@ +import HoTTLean.ForMathlib.CategoryTheory.MorphismProperty.OverAdjunction +import Mathlib.CategoryTheory.Functor.TwoSquare +import HoTTLean.ForMathlib.CategoryTheory.Comma.Over.Pushforward +import HoTTLean.ForMathlib.CategoryTheory.MorphismProperty.Limits +import HoTTLean.ForMathlib.CategoryTheory.Limits.Shapes.Pullback.CommSq +import Mathlib.CategoryTheory.Limits.Constructions.Over.Basic +import HoTTLean.ForMathlib +import HoTTLean.ForMathlib.CategoryTheory.NatTrans +import Mathlib.Tactic.DepRewrite +import Poly.ForMathlib.CategoryTheory.LocallyCartesianClosed.BeckChevalley +import HoTTLean.ForMathlib.CategoryTheory.Yoneda +import Poly.ForMathlib.CategoryTheory.LocallyCartesianClosed.Presheaf +import HoTTLean.ForMathlib.CategoryTheory.Adjunction.PartialAdjoint +import HoTTLean.ForMathlib.CategoryTheory.Comma.Presheaf.Basic +import HoTTLean.ForMathlib.CategoryTheory.Functor.FullyFaithful + +universe w v u v₁ u₁ + +noncomputable section + +namespace CategoryTheory + +open Category Limits MorphismProperty + +variable {C : Type u} [Category.{v} C] {C' : Type u₁} [Category.{v₁} C'] (F : C ⥤ C') + +class Functor.PreservesMorphismProperty (R : MorphismProperty C) (R' : MorphismProperty C') where + map_mem {X Y : C} (f : X ⟶ Y) : R f → R' (F.map f) + +abbrev Functor.map_mem {R : MorphismProperty C} {R' : MorphismProperty C'} + [F.PreservesMorphismProperty R R'] {X Y : C} (f : X ⟶ Y) : R f → R' (F.map f) := + PreservesMorphismProperty.map_mem f + +class Functor.PreservesPullbacksOf (R : MorphismProperty C) where + pb {P X Y Z : C} (fst : P ⟶ X) (snd : P ⟶ Y) (f : X ⟶ Z) (g : Y ⟶ Z) : + R snd → IsPullback fst snd f g → IsPullback (F.map fst) (F.map snd) (F.map f) (F.map g) + +-- NOTE this definition should refactor NaturalModel.Universe +structure RepresentableChosenPullbacks {X Y : Psh C} (f : X ⟶ Y) where + ext {Γ : C} (A : y(Γ) ⟶ Y) : C + disp {Γ : C} (A : y(Γ) ⟶ Y) : ext A ⟶ Γ + var {Γ : C} (A : y(Γ) ⟶ Y) : y(ext A) ⟶ X + disp_pullback {Γ : C} (A : y(Γ) ⟶ Y) : + IsPullback (var A) ym(disp A) f A + +open Functor in +theorem NatTrans.isIso_of_whiskerRight_isIso {C D E : Type*} [Category C] [Category D] [Category E] + {G H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) [IsIso (whiskerRight α F)] [F.ReflectsIsomorphisms] : + IsIso α := by + rw [NatTrans.isIso_iff_isIso_app] at * + intro + apply (config := {allowSynthFailures:= true}) Functor.ReflectsIsomorphisms.reflects F + cat_disch + +namespace MorphismProperty + +variable (R : MorphismProperty C) + +section pullback + +variable {R} [R.HasPullbacks] {X : C} + +variable (X) + +end pullback + +abbrev chosenTerminal [R.ContainsIdentities] (X) : R.Over ⊤ X := .mk ⊤ (𝟙 X) (R.id_mem _) + +def Over.pullback_obj_chosenTerminal [R.IsStableUnderBaseChange] [R.ContainsIdentities] + {X Y : C} (f : X ⟶ Y) [R.HasPullbacksAlong f] : + (Over.pullback R ⊤ f).obj (R.chosenTerminal Y) ≅ R.chosenTerminal X := + have : HasPullback (𝟙 Y) f := HasPullbacksAlong.hasPullback (𝟙 Y) (R.id_mem Y) + MorphismProperty.Over.isoMk (IsPullback.id_vert f).isoPullback.symm + +variable [R.HasPullbacks] [R.IsStableUnderBaseChange] + +@[simp] +protected abbrev Over.yoneda (X : C) : R.Over ⊤ X ⥤ CategoryTheory.Over y(X) := + Over.forget _ _ _ ⋙ CategoryTheory.Over.post yoneda + +-- @[simps] +-- protected def Over.yoneda (X : C) : R.Over ⊤ X ⥤ CategoryTheory.Over y(X) where +-- obj A := .mk ym(A.hom) +-- map {A1 A2} f := CategoryTheory.Over.homMk ym(f.left) + +-- instance (X : C) : (Over.yoneda R X).Full where +-- map_surjective {A B} f := +-- ⟨Over.homMk (yoneda.preimage f.left) (by +-- apply yoneda.map_injective; simpa using CategoryTheory.Over.w f), +-- by cat_disch⟩ + +-- instance (X : C) : (Over.yoneda R X).Faithful where +-- map_injective {A B} f f' hf := by +-- ext +-- apply yoneda.map_injective +-- exact Functor.congr_map (CategoryTheory.Over.forget _) hf + +variable (F : Psh C) + +instance : (⊤ : MorphismProperty C).HasOfPostcompProperty ⊤ where + of_postcomp := by simp + +instance (P : MorphismProperty C) {X} : P.HasPullbacksAlong (𝟙 X) where + hasPullback g hg := + have : IsPullback (𝟙 _) g g (𝟙 X) := IsPullback.of_horiz_isIso (by simp) + IsPullback.hasPullback this + +/-- `Over.pullback` commutes with composition. -/ +@[simps! hom_app_left inv_app_left] +noncomputable def Over.pullbackId (P Q : MorphismProperty C) (X) + [Q.IsMultiplicative] [P.IsStableUnderBaseChange] [Q.IsStableUnderBaseChange] + [Q.RespectsIso] : Over.pullback P Q (𝟙 X) ≅ 𝟭 _ := + NatIso.ofComponents (fun X ↦ Over.isoMk (asIso (pullback.fst X.hom (𝟙 _))) + (by simp [pullback.condition])) + +def pullbackPullbackTwoSquare {T : Type u} [Category.{v} T] {R : MorphismProperty T} + {X Y Z W : T} (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) (sq : h ≫ g = f ≫ k) + [R.IsStableUnderBaseChangeAlong h] [R.IsStableUnderBaseChangeAlong f] + [R.IsStableUnderBaseChangeAlong g] [R.IsStableUnderBaseChangeAlong k] + [R.HasPullbacksAlong h] [R.HasPullbacksAlong f] [R.HasPullbacksAlong g] + [R.HasPullbacksAlong k] : TwoSquare (Over.pullback R ⊤ k) (Over.pullback R ⊤ g) + (Over.pullback R ⊤ f) (Over.pullback R ⊤ h) := + (Over.pullbackComp _ _).inv ≫ (Over.pullbackCongr sq).inv ≫ (Over.pullbackComp _ _).hom + +@[simp] +lemma pullbackPullbackTwoSquare_app_left {T : Type u} [Category.{v} T] {R : MorphismProperty T} + {X Y Z W : T} (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) (sq : h ≫ g = f ≫ k) + [R.IsStableUnderBaseChangeAlong h] [R.IsStableUnderBaseChangeAlong f] + [R.IsStableUnderBaseChangeAlong g] [R.IsStableUnderBaseChangeAlong k] + [R.HasPullbacksAlong h] [R.HasPullbacksAlong f] [R.HasPullbacksAlong g] + [R.HasPullbacksAlong k] (A : R.Over ⊤ W) : + ((pullbackPullbackTwoSquare h f g k sq).app A).left = + pullback.lift (pullback.map _ _ _ _ (pullback.fst _ _) h k + (by simp [pullback.condition]) sq.symm) (pullback.snd _ _) (by cat_disch) := by + dsimp [pullbackPullbackTwoSquare] + ext <;> simp + +/-- Fixing a commutative square, +``` + Y - k → W + ∧ ∧ + f | | g + | | + X - h → Z +``` +`pullbackMapTwoSquare` is the Beck-Chevalley natural transformation for `Over.map` between +the `MorphismProperty.Over` categories, +of type `pullback f ⋙ map h ⟶ map k ⋙ pullback g`. +``` + map k + R.Over Y --------> R.Over W + | | + | | +pullback f ↗ pullback g + | | + v V + R.Over X --------> R.Over Z + map h +``` +-/ +def pullbackMapTwoSquare {T : Type u} [Category.{v} T] (R : MorphismProperty T) + [R.IsStableUnderComposition] + {X Y Z W : T} (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) (rk : R k) (rh : R h) + [R.IsStableUnderBaseChangeAlong h] [R.IsStableUnderBaseChangeAlong f] + [R.IsStableUnderBaseChangeAlong g] [R.IsStableUnderBaseChangeAlong k] + [R.HasPullbacksAlong h] [R.HasPullbacksAlong f] [R.HasPullbacksAlong g] [R.HasPullbacksAlong k] + (sq : h ≫ g = f ≫ k) : + TwoSquare (MorphismProperty.Over.pullback R ⊤ f) (MorphismProperty.Over.map ⊤ rk) + (MorphismProperty.Over.map ⊤ rh) + (MorphismProperty.Over.pullback R ⊤ g) := + (mateEquiv (MorphismProperty.Over.mapPullbackAdj k rk trivial) + (MorphismProperty.Over.mapPullbackAdj h rh trivial)).symm <| + pullbackPullbackTwoSquare _ _ _ _ sq + +@[simp] +lemma pullbackMapTwoSquare_app_left {T : Type u} [Category.{v} T] (R : MorphismProperty T) + [R.IsStableUnderComposition] {X Y Z W : T} (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) + (rk : R k) (rh : R h) (sq : h ≫ g = f ≫ k) + [R.IsStableUnderBaseChangeAlong h] [R.IsStableUnderBaseChangeAlong f] + [R.IsStableUnderBaseChangeAlong g] [R.IsStableUnderBaseChangeAlong k] + [R.HasPullbacksAlong h] [R.HasPullbacksAlong f] [R.HasPullbacksAlong g] [R.HasPullbacksAlong k] + (A : R.Over ⊤ Y) : + have : HasPullback (A.hom ≫ k) g := + HasPullbacksAlong.hasPullback (A.hom ≫ k) (R.comp_mem _ _ A.prop rk) + ((R.pullbackMapTwoSquare h f g k rk rh sq).app A).left = + pullback.map A.hom f (A.hom ≫ k) g (𝟙 _) (by cat_disch) k (by cat_disch) (by cat_disch) := by + have : HasPullback (A.hom ≫ k) g := + HasPullbacksAlong.hasPullback (A.hom ≫ k) (R.comp_mem _ _ A.prop rk) + apply pullback.hom_ext <;> simp [pullbackMapTwoSquare] + +theorem isCartesian_pullbackMapTwoSquare {T : Type u} [Category.{v} T] (R : MorphismProperty T) + [R.IsStableUnderComposition] + {X Y Z W : T} (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) (rk : R k) (rh : R h) + [R.IsStableUnderBaseChangeAlong h] [R.IsStableUnderBaseChangeAlong f] + [R.IsStableUnderBaseChangeAlong g] [R.IsStableUnderBaseChangeAlong k] + [R.HasPullbacksAlong h] [R.HasPullbacksAlong f] [R.HasPullbacksAlong g] [R.HasPullbacksAlong k] + (sq : h ≫ g = f ≫ k) : (pullbackMapTwoSquare R h f g k rk rh sq).IsCartesian := by + intro A B t + apply Functor.reflect_isPullback (Over.forget _ _ _ ⋙ CategoryTheory.Over.forget _) + have (X : R.Over ⊤ Y) : HasPullback (X.hom ≫ k) g := + HasPullbacksAlong.hasPullback (X.hom ≫ k) (R.comp_mem _ _ X.prop rk) + rw [CategoryTheory.IsPullback.flip_iff] + fapply CategoryTheory.IsPullback.of_right (v₁₃ := t.left) + (h₁₂ := pullback.fst (A.hom ≫ k) g) (h₂₂ := (pullback.fst (B.hom ≫ k) g)) + · convert_to (CategoryTheory.IsPullback (pullback.fst A.hom f) + (pullback.lift (pullback.fst A.hom f ≫ t.left) (pullback.snd A.hom f) + (by simp[pullback.condition])) t.left (pullback.fst B.hom f)) + · simp + · simp + · apply CategoryTheory.IsPullback.of_bot _ (by simp) (IsPullback.of_hasPullback B.hom f) + convert_to (IsPullback (pullback.fst A.hom f) (pullback.snd A.hom f) A.hom f) + · simp + · simp + · exact (IsPullback.of_hasPullback A.hom f) + · ext <;> simp + · convert_to + (CategoryTheory.IsPullback + (pullback.fst (A.hom ≫ k) g) + (pullback.map (A.hom ≫ k) g (B.hom ≫ k) g t.left (𝟙 _) (𝟙 _) (by simp only [Functor.id_obj, + Functor.const_obj_obj, comp_id, CategoryTheory.Over.w_assoc]) (by simp)) t.left + (pullback.fst (B.hom ≫ k) g) ) + · simp [pullback.map] + · apply CategoryTheory.IsPullback.of_bot _ (by simp) (IsPullback.of_hasPullback (B.hom ≫ k) g) + convert_to (IsPullback (pullback.fst (A.hom ≫ k) g) + (pullback.snd (A.hom ≫ k) g) (A.hom ≫ k) g) + · simp + · simp + · exact (IsPullback.of_hasPullback (A.hom ≫ k) g) + +/-- +The Beck-Chevalley two-square `pushforwardPullbackTwoSquare` is a natural isomorphism +``` + map k + R.Over Y --------> R.Over W + | | + | | +pullback f ≅ pullback g + | | + v V + R.Over X --------> R.Over Z + map h +``` +when the commutativity +condition is strengthened to a pullback condition. +``` + Y - k → W + ∧ ∧ + f | (pb) | g + | | + X - h → Z +``` +-/ +instance pullbackMapTwoSquare_isIso {T : Type u} [Category.{v} T] (R : MorphismProperty T) + [R.HasPullbacks] [R.IsStableUnderBaseChange] [R.IsStableUnderComposition] + {X Y Z W : T} (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) + (rk : R k) (rh : R h) (pb : IsPullback h f g k) : + IsIso <| pullbackMapTwoSquare R h f g k rk rh pb.w := by + apply (config := {allowSynthFailures:= true}) NatIso.isIso_of_isIso_app + intro A + have : HasPullback (A.hom ≫ k) g := + HasPullbacksAlong.hasPullback (A.hom ≫ k) (R.comp_mem _ _ A.prop rk) + apply (config := {allowSynthFailures:= true}) Functor.ReflectsIsomorphisms.reflects + (Over.forget _ _ _ ⋙ CategoryTheory.Over.forget _) + simp only [Functor.comp_obj, Comma.forget_obj, Over.forget_obj, Over.map_obj_left, + Over.pullback_obj_left, Over.map_obj_hom, Functor.comp_map, Comma.forget_map, Over.forget_map, + pullbackMapTwoSquare_app_left, Functor.id_obj, Functor.const_obj_obj] + apply CategoryTheory.IsPullback.pullback.map_isIso_of_pullback_right_of_comm_cube + · cat_disch + · assumption + +@[simps] +def _root_.CategoryTheory.ExponentiableMorphism.isPushforward + {T : Type u} [Category.{v} T] [HasPullbacks T] + {X Y : T} (f : X ⟶ Y) [ExponentiableMorphism f] (h : Over X) : + IsPushforward f h ((ExponentiableMorphism.pushforward f).obj h) where + homEquiv := ((ExponentiableMorphism.adj f).homEquiv _ _).symm + homEquiv_comp := by intros; simp [Adjunction.homEquiv_naturality_left_symm] + +def _root_.CategoryTheory.ExponentiableMorphism.hasPushforward + {T : Type u} [Category.{v} T] [HasPullbacks T] + {X Y : T} (f : X ⟶ Y) [ExponentiableMorphism f] (h : Over X) : + HasPushforward f h where + has_representation := ⟨(ExponentiableMorphism.pushforward f).obj h, + ⟨ExponentiableMorphism.isPushforward f h⟩⟩ + +attribute [local instance] ExponentiableMorphism.hasPushforward + +instance {T : Type u} [Category.{v} T] (R : MorphismProperty T) {X Y : T} (f : X ⟶ Y) + [HasPullbacksAlong f] [HasPushforwardsAlong f] : R.HasPushforwardsAlong f where + hasPushforward := inferInstance + +/-- Given an exponentiable morphism, global pushforward (defined using the +`ExponentiableMorphism` API) commutes with local pushforward +(defined using the `HasPushforward` API). -/ +def pushforwardCompForget' {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks T] + {R : MorphismProperty T} {X Y : T} (f : X ⟶ Y) [ExponentiableMorphism f] + [R.IsStableUnderPushforwardsAlong f] : R.pushforward f ⋙ Over.forget R ⊤ Y ≅ + Over.forget R ⊤ X ⋙ ExponentiableMorphism.pushforward f := + calc R.pushforward f ⋙ Over.forget R ⊤ Y + _ ≅ R.pushforwardPartial f := pushforwardCompForget .. + _ ≅ pushforwardPartial.lift R f ⋙ ObjectProperty.ι _ ⋙ ExponentiableMorphism.pushforward f := + (Functor.isoWhiskerLeft _ + (Functor.isoPartialRightAdjoint _ _ (Functor.rightAdjoint.partialRightAdjoint _))).symm + _ ≅ Over.forget R ⊤ X ⋙ ExponentiableMorphism.pushforward f := Iso.refl _ + +def pullbackPostYonedaIso {T : Type u} [Category.{v} T] + {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] : + CategoryTheory.Over.pullback f ⋙ Over.post yoneda ≅ + Over.post yoneda ⋙ CategoryTheory.Over.pullback ym(f) := + NatIso.ofComponents + (fun A => CategoryTheory.Over.isoMk (PreservesPullback.iso yoneda A.hom f)) + (fun {A B} g => by + apply (CategoryTheory.Over.forget _).map_injective + apply pullback.hom_ext <;> simp) + +def pullbackYonedaIso {T : Type u} [Category.{max u v} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y : T} (f : X ⟶ Y) : Over.pullback R ⊤ f ⋙ Over.yoneda R X ≅ + Over.yoneda R Y ⋙ CategoryTheory.Over.pullback ym(f) := + NatIso.ofComponents + (fun A => CategoryTheory.Over.isoMk (PreservesPullback.iso yoneda A.hom f)) + (fun {A B} g => by + apply (CategoryTheory.Over.forget _).map_injective + apply pullback.hom_ext <;> simp) + +/-- The inclusions of `Over.yoneda` commute with pushforward. -/ +def pushforwardYonedaIso {T : Type u} [Category.{u} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] + [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : + R.pushforward f ⋙ Over.yoneda R Y ≅ + Over.yoneda R X ⋙ ExponentiableMorphism.pushforward ym(f) := + -- instead of proving directly that + -- `R.pushforward f ⋙ Over.yoneda R Y ≅ Over.yoneda R X ⋙ ExponentiableMorphism.pushforward ym(f)` + -- e.g. using the universal property of `ExponentiableMorphism.pushforward ym(f)` + -- which is universal among *all* objects of `Over y(Y)`, + -- we prove that both sides are universal among objects of `Over Y` + -- (rather, their images under `Over.post yoneda`). This is `Over.yonedaNatIsoMk` + Over.yonedaNatIsoMk <| + let postFF {X} := (Functor.FullyFaithful.ofFullyFaithful (Over.post (X := X) yoneda)).homIso + -- `Over y(Y) (Over.post yoneda (-), Over.yoneda (R.pushforward f (⋆)))` + calc (R.pushforward f ⋙ Over.yoneda R Y) ⋙ yoneda ⋙ + (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op + _ ≅ R.pushforward f ⋙ Over.forget _ _ _ ⋙ Over.post yoneda ⋙ yoneda ⋙ + (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op := + Functor.associator .. ≪≫ Functor.isoWhiskerLeft _ (Functor.associator ..) + -- `Over Y (-, Over.forget (R.pushforward f (⋆)))` + _ ≅ R.pushforward f ⋙ Over.forget _ _ _ ⋙ yoneda := + -- `Over.post yoneda` is fully faithful + (Functor.isoWhiskerLeft _ (Functor.isoWhiskerLeft _ postFF)).symm + -- `Over Y (pullback f (-), Over.forget (⋆))` + _ ≅ Over.forget _ _ _ ⋙ yoneda ⋙ + (Functor.whiskeringLeft _ _ _).obj (CategoryTheory.Over.pullback f).op := + -- homIso for partial adjunction `Over.pullback f ∂⊣ R.pushforward f` + pushforward.homIso.symm + -- `Over (y(Y)) (pullback f ⋙ Over.post yoneda (-), Over.forget ⋙ Over.post yoneda (⋆))` + _ ≅ Over.forget _ _ _ ⋙ (Over.post yoneda ⋙ yoneda ⋙ + (Functor.whiskeringLeft _ _ _).obj ((Over.post yoneda).op)) ⋙ + (Functor.whiskeringLeft _ _ _).obj (CategoryTheory.Over.pullback f).op := + -- `Over.post yoneda` is fully faithful + Functor.isoWhiskerLeft _ (Functor.isoWhiskerRight postFF _) + _ ≅ Over.forget _ _ _ ⋙ Over.post yoneda ⋙ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj + (CategoryTheory.Over.pullback f ⋙ Over.post yoneda).op := + Functor.isoWhiskerLeft _ (Functor.associator .. ≪≫ Functor.isoWhiskerLeft _ + (Functor.isoWhiskerLeft _ ((Functor.whiskeringLeftObjCompIso ..).symm ≪≫ + Functor.mapIso _ (Functor.opComp ..).symm))) + -- `Over (y(Y)) (pullback f ⋙ Over.post yoneda (-), Over.yoneda (⋆))` + _ ≅ Over.yoneda R X ⋙ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj + (CategoryTheory.Over.pullback f ⋙ Over.post yoneda).op := + (Functor.associator ..).symm + -- `Over (y(Y)) (pullback ym(f) (-), pushforward ym(f) (Over.yoneda (⋆)))` + _ ≅ Over.yoneda R X ⋙ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj + (Over.post yoneda ⋙ CategoryTheory.Over.pullback ym(f)).op := + -- `Over.post yoneda` preserves pullback + Functor.isoWhiskerLeft _ (Functor.isoWhiskerLeft _ (Functor.mapIso _ + (NatIso.op (pullbackPostYonedaIso ..).symm))) + _ ≅ Over.yoneda R X ⋙ yoneda ⋙ + (Functor.whiskeringLeft _ _ _).obj (CategoryTheory.Over.pullback ym(f)).op ⋙ + (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op := + Functor.isoWhiskerLeft _ (Functor.isoWhiskerLeft _ + (Functor.mapIso _ (Functor.opComp ..) ≪≫ Functor.whiskeringLeftObjCompIso ..)) + -- `Over (y(Y)) (Over.post yoneda (-), pushforward ym(f) (Over.yoneda (⋆)))` + _ ≅ Over.yoneda R X ⋙ ExponentiableMorphism.pushforward ym(f) ⋙ yoneda ⋙ + (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op := + -- by homIso for adjunction `pullback ym(f) ⊣ pushforward ym(f)` + Functor.isoWhiskerLeft _ ((Functor.associator ..).symm ≪≫ (Functor.isoWhiskerRight + (ExponentiableMorphism.adj ym(f)).homIso _) ≪≫ Functor.associator ..) + _ ≅ (Over.yoneda R X ⋙ ExponentiableMorphism.pushforward ym(f)) ⋙ yoneda ⋙ + (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op := + (Functor.associator ..).symm + +/-- Fixing a pullback square, +``` + Z - g → W + ∧ ∧ + h | (pb) | k + | | + X - f → Y +``` +`pushforwardPullbackIso` is the Beck-Chevalley natural isomorphism for pushforwards between +the `MorphismProperty.Over` categories, +of type `pushforward g ⋙ pullback k ≅ pullback h ⋙ pushforward f`. +``` + R.Over ⊤ Z - pushforward g → R.Over ⊤ W + | | +pullback h | ↙≅ | pullback k + V V + R.Over ⊤ X - pushforward f → R.Over ⊤ Y +``` +-/ +def pushforwardPullbackIso {T : Type u} [Category.{u} T] {R : MorphismProperty T} + [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y Z W : T} (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) + [HasPullbacksAlong f] [HasPullbacksAlong g] + [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] + [R.HasPushforwardsAlong g] [R.IsStableUnderPushforwardsAlong g] + (pb : IsPullback h f g k) : + R.pushforward g ⋙ Over.pullback R ⊤ k ≅ Over.pullback R ⊤ h ⋙ R.pushforward f := + -- since `Over.yoneda R Y : R.Over ⊤ Y ⥤ Over y(Y)` is fully faithful, + -- it suffices to define an isomorphism between the post-composed functors + (Functor.FullyFaithful.whiskeringRight + (Functor.FullyFaithful.ofFullyFaithful (Over.yoneda R Y)) (R.Over ⊤ Z)).preimageIso <| + calc (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ Over.yoneda R Y + _ ≅ R.pushforward g ⋙ Over.pullback R ⊤ k ⋙ Over.yoneda R Y := Functor.associator _ _ _ + _ ≅ R.pushforward g ⋙ Over.yoneda R W ⋙ CategoryTheory.Over.pullback ym(k) := + -- pullback commutes with `Over.yoneda` + Functor.isoWhiskerLeft _ (pullbackYonedaIso R k) + _ ≅ (R.pushforward g ⋙ Over.yoneda R W) ⋙ CategoryTheory.Over.pullback ym(k) := + (Functor.associator _ _ _).symm + _ ≅ (Over.yoneda R Z ⋙ ExponentiableMorphism.pushforward ym(g)) ⋙ + CategoryTheory.Over.pullback ym(k) := + -- pushforward commutes with `Over.yoneda` + Functor.isoWhiskerRight (pushforwardYonedaIso ..) _ + _ ≅ Over.yoneda R Z ⋙ ExponentiableMorphism.pushforward ym(g) ⋙ + CategoryTheory.Over.pullback ym(k) := Functor.associator _ _ _ + _ ≅ Over.yoneda R Z ⋙ CategoryTheory.Over.pullback ym(h) ⋙ + ExponentiableMorphism.pushforward ym(f) := + -- Beck-Chevalley isomorphism in `Psh T` + Functor.isoWhiskerLeft _ (pushforwardPullbackIsoSquare (Functor.map_isPullback _ pb)) + _ ≅ (Over.yoneda R Z ⋙ CategoryTheory.Over.pullback ym(h)) ⋙ + ExponentiableMorphism.pushforward ym(f) := (Functor.associator _ _ _).symm + _ ≅ (Over.pullback R ⊤ h ⋙ Over.yoneda R X) ⋙ ExponentiableMorphism.pushforward ym(f) := + -- pullback commutes with `Over.yoneda` + Functor.isoWhiskerRight (pullbackYonedaIso R h).symm _ + _ ≅ Over.pullback R ⊤ h ⋙ Over.yoneda R X ⋙ ExponentiableMorphism.pushforward ym(f) := + Functor.associator _ _ _ + _ ≅ Over.pullback R ⊤ h ⋙ R.pushforward f ⋙ Over.yoneda R Y := + -- pushforward commutes with `Over.yoneda` + Functor.isoWhiskerLeft _ (pushforwardYonedaIso ..).symm + _ ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ Over.yoneda R Y := (Functor.associator _ _ _).symm + +/-- Fixing a commutative square, +``` + Z - g → W + ∧ ∧ + h | | k + | | + X - f → Y +``` +`pushforwardPullbackTwoSquare` is the Beck-Chevalley natural transformation for pushforwards between +the `MorphismProperty.Over` categories, +of type `pushforward g ⋙ pullback k ⟶ pullback h ⋙ pushforward f`. +``` + R.Over ⊤ Z - pushforward g → R.Over ⊤ W + | | +pullback h | ↙ | pullback k + V V + R.Over ⊤ X - pushforward f → R.Over ⊤ Y +``` +It is the mate of the square of pullback functors +`pullback k ⋙ pullback g ⟶ pullback f ⋙ pullback h`. +-/ +def pushforwardPullbackTwoSquare {T : Type u} [Category.{v} T] {R : MorphismProperty T} + [R.HasPullbacks] [R.IsStableUnderBaseChange] {X Y Z W : T} + (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) (sq : h ≫ g = f ≫ k) + [HasPullbacksAlong f] [HasPullbacksAlong g] + [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] + [R.HasPushforwardsAlong g] [R.IsStableUnderPushforwardsAlong g] : + TwoSquare (pushforward R g) (Over.pullback R ⊤ h) (Over.pullback R ⊤ k) + (pushforward R f) := + mateEquiv (pullbackPushforwardAdjunction R g) (pullbackPushforwardAdjunction R f) + (pullbackPullbackTwoSquare _ _ _ _ sq) + +lemma pushforwardPullbackTwoSquare_app {T : Type u} [Category.{v} T] {R : MorphismProperty T} + [R.HasPullbacks] [R.IsStableUnderBaseChange] {X Y Z W : T} + (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) (sq : h ≫ g = f ≫ k) + [HasPullbacksAlong f] [HasPullbacksAlong g] + [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] + [R.HasPushforwardsAlong g] [R.IsStableUnderPushforwardsAlong g] + (A : R.Over ⊤ Z) : + Comma.Hom.hom ((pushforwardPullbackTwoSquare h f g k sq).app A) = sorry := by + simp [pushforwardPullbackTwoSquare] + -- apply ((pullbackPushforwardAdjunction R f).homEquiv _ _).symm.injective + -- ext : 1 + -- · simp [Comma.Hom.hom, TwoSquare.natTrans] + -- erw [commaCategory.id] + -- simp [- EmbeddingLike.apply_eq_iff_eq, pullbackPushforwardAdjunction] + -- rw [pushforward.homEquiv_map_comp] + -- erw [pushforward.homEquiv.apply_symm_apply] + -- erw [Category.id_comp] + -- apply (pushforwardPullbackAdjunction.homEquiv i p).injective + sorry + -- · sorry + +-- TODO: currently this theorem is unnecessary, +-- but it would be nice to show that these two definitions actually line up. +-- We have both definitions because +-- `pushforwardPullbackTwoSquare` can be defined under more general conditions, +-- without a pullback condition on the commuting square +-- but constructing an isomorphism directly `pushforwardPullbackIso` is easier +-- than showing `pushforwardPullbackTwoSquare` is an isomorphism. + +/- +/-- +The Beck-Chevalley two-square `pushforwardPullbackTwoSquare` is a natural isomorphism +``` + R.Over ⊤ Z - pushforward g → R.Over ⊤ W + | | +pullback h | ≅ | pullback k + V V + R.Over ⊤ X - pushforward f → R.Over ⊤ Y +``` +when the commutativity +condition is strengthened to a pullback condition. +``` + Z - g → W + ∧ ∧ + h | (pb) | k + | | + X - f → Y +``` +TODO: in what generality does this theorem hold? +NOTE: we know it holds when for π-clans with `R = Q = the π-clan` +([Joyal, Notes on Clans and Tribes, Cor 2.4.11](https://arxiv.org/pdf/1710.10238)). +NOTE: we also know it holds in a category with pullbacks with `R = ⊤` and `Q = ExponentiableMaps`. +-/ +theorem pushforwardPullbackTwoSquare_isIso {T : Type u} [Category.{u} T] + (R : MorphismProperty T) + [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y Z W : T} (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) + [HasPullbacksAlong f] [HasPullbacksAlong g] + [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] + [R.HasPushforwardsAlong g] [R.IsStableUnderPushforwardsAlong g] + (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by + have eq : (pushforwardPullbackTwoSquare h f g k pb.w) = + (pushforwardPullbackIso (R := R) h f g k pb).hom := by + ext A : 1 + -- simp [pushforwardPullbackTwoSquare, pushforwardPullbackIso] + sorry + rw [eq] + infer_instance +-/ diff --git a/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean new file mode 100644 index 00000000..5155a053 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean @@ -0,0 +1,800 @@ +import Mathlib.CategoryTheory.FiberedCategory.HomLift +import Mathlib.CategoryTheory.FiberedCategory.Fiber +import HoTTLean.Grothendieck.Groupoidal.IsPullback +import HoTTLean.Grothendieck.Groupoidal.Basic +import HoTTLean.Groupoids.Pi + +universe w v u v₁ u₁ v₂ u₂ v₃ u₃ + +noncomputable section + +namespace CategoryTheory + +namespace Functor + +namespace Fiber +section + +variable {𝒮 : Type u₁} {𝒳 : Type u₂} [Category.{v₁} 𝒮] [Category.{v₂} 𝒳] +variable {p : 𝒳 ⥤ 𝒮} {S : 𝒮} + +@[simp] +lemma functor_obj_fiberInclusion_obj (a : Fiber p S) : + p.obj (Fiber.fiberInclusion.obj a) = S := + a.2 + +lemma functor_map_fiberInclusion_map {a b : Fiber p S} + (f : a ⟶ b) : + p.map (Fiber.fiberInclusion.map f) = eqToHom (by simp) := by + have H := f.2 + simpa using IsHomLift.fac' p (𝟙 S) f.1 + +lemma hext {S'} (hS : S' ≍ S) {a : Fiber p S} + {a' : Fiber p S'} (h : Fiber.fiberInclusion.obj a ≍ Fiber.fiberInclusion.obj a') : a ≍ a' := by + subst hS + simpa using Subtype.ext h.eq + +lemma hom_hext {S'} (hS : S' ≍ S) {a b : Fiber p S} + {a' b' : Fiber p S'} (ha : a ≍ a') (hb : b ≍ b') {φ : a ⟶ b} + {ψ : a' ⟶ b'} (h : Fiber.fiberInclusion.map φ ≍ Fiber.fiberInclusion.map ψ) : φ ≍ ψ := by + aesop_cat + +end + +variable {Γ : Type u} {E : Type u} [Groupoid.{v} Γ] [Groupoid.{v} E] {F : E ⥤ Γ} + +instance {X : Γ} : IsGroupoid (F.Fiber X) where + all_isIso f := { + out := + have := f.2 + ⟨Fiber.homMk F _ (CategoryTheory.inv f.1), by cat_disch, by cat_disch⟩ } + +instance {X : Γ} : Groupoid (F.Fiber X) := Groupoid.ofIsGroupoid + +end Fiber + +section + +structure ClovenIsofibration {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] + (F : C ⥤ D) where + liftObj {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X) : C + liftIso {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X) : X' ⟶ liftObj f hX' + isHomLift {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X) : + F.IsHomLift f (liftIso f hX') + liftIso_IsIso {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X) : + IsIso (liftIso f hX') + +namespace ClovenIsofibration + +section + +variable {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] {F : C ⥤ D} + (I : ClovenIsofibration F) + +instance {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X) : + F.IsHomLift f (I.liftIso f hX') := I.isHomLift f hX' + +instance {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X): + IsIso (ClovenIsofibration.liftIso I f hX') := ClovenIsofibration.liftIso_IsIso I f hX' + +@[simp] +lemma obj_liftObj {X Y : D} (f : X ⟶ Y) [IsIso f] + {X' : C} (hX' : F.obj X' = X) : F.obj (I.liftObj f hX') = Y := + IsHomLift.codomain_eq F f (I.liftIso f hX') + +lemma map_liftIso {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} + (hX' : F.obj X' = X) : + eqToHom hX'.symm ≫ F.map (I.liftIso f hX') ≫ eqToHom (obj_liftObj ..) = f := by + have i : F.IsHomLift f (I.liftIso f hX') := I.isHomLift .. + symm + apply IsHomLift.fac + +lemma map_liftIso' {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} + (hX' : F.obj X' = X) : F.map (I.liftIso f hX') = + eqToHom hX' ≫ f ≫ eqToHom (by simp[obj_liftObj]) := by + simp[← map_liftIso I f hX'] + +@[simp] +lemma liftObj_comp_aux {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} + (hX' : F.obj X' = X) (Y' : C) (hY' : I.liftObj f hX' = Y') : F.obj Y' = Y := by + subst hY' + apply ClovenIsofibration.obj_liftObj I f + +lemma eqToHom_comp_liftIso {X Y : D} (f : X ⟶ Y) [IsIso f] {X' X'' : C} + (hX' : F.obj X' = X) (hX'' : X'' = X') : + eqToHom hX'' ≫ I.liftIso f hX' = + I.liftIso f (X' := X'') (by rw [hX'', hX']) ≫ eqToHom (by subst hX''; rfl) := by + subst hX'' + simp + +class IsSplit {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] + {F : C ⥤ D} (I : ClovenIsofibration F) where + liftObj_id {X : D} {X' : C} (hX' : F.obj X' = X) : I.liftObj (𝟙 X) hX' = X' + liftIso_id {X : D} {X' : C} (hX' : F.obj X' = X) : I.liftIso (𝟙 X) hX' = + eqToHom (liftObj_id hX').symm + liftObj_comp {X Y Z : D} (f : X ⟶ Y) [IsIso f] (g : Y ⟶ Z) [IsIso g] {X' : C} + (hX' : F.obj X' = X) {Y' : C} (hY' : I.liftObj f hX' = Y') : I.liftObj (f ≫ g) hX' = + I.liftObj g (X' := Y') (I.liftObj_comp_aux f hX' Y' hY') + liftIso_comp {X Y Z : D} (f : X ⟶ Y) [IsIso f] (g : Y ⟶ Z) [IsIso g] {X' : C} + (hX' : F.obj X' = X) {Y' : C} (hY' : I.liftObj f hX' = Y') : I.liftIso (f ≫ g) hX' = + I.liftIso f hX' ≫ eqToHom hY' ≫ + I.liftIso g (X' := Y') (I.liftObj_comp_aux f hX' Y' hY') ≫ + eqToHom (liftObj_comp f g hX' hY').symm + +end + +open IsSplit + +@[simp] +lemma liftObj_eqToHom {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] + {F : C ⥤ D} (I : ClovenIsofibration F) [IsSplit I] {X Y : D} (h : X = Y) {X' : C} + (hX' : F.obj X' = X) : I.liftObj (eqToHom h) hX' = X' := by + subst h + simp [IsSplit.liftObj_id] + +@[simp] +lemma liftIso_eqToHom {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] (F : C ⥤ D) + (I : ClovenIsofibration F) [IsSplit I] {X Y : D} (h : X = Y) {X' : C} (hX' : F.obj X' = X) : + I.liftIso (eqToHom h) hX' = eqToHom (by simp) := by + subst h + simp [IsSplit.liftIso_id] + +section +variable {Γ : Type u} {E : Type u} [Groupoid.{v} Γ] [Groupoid.{v} E] {F : E ⥤ Γ} + (I : ClovenIsofibration F) + +def classifier.map.obj {X Y : Γ} (f : X ⟶ Y) (a : F.Fiber X) : F.Fiber Y := + ⟨I.liftObj f a.2, ClovenIsofibration.obj_liftObj ..⟩ + +def classifier.map.map {X Y} (f: X ⟶ Y) {a b : F.Fiber X} (m : a ⟶ b) : + map.obj I f a ⟶ map.obj I f b := + let i1 : a.1 ⟶ I.liftObj f a.2 := I.liftIso f a.2 + let i2 := I.liftIso f b.2 + let i := Groupoid.inv i1 ≫ Fiber.fiberInclusion.map m ≫ i2 + have e :𝟙 Y = eqToHom (by simp[obj_liftObj]) ≫ + F.map (CategoryTheory.inv i1 ≫ Fiber.fiberInclusion.map m ≫ i2) ≫ eqToHom (by simp[obj_liftObj]) + := by simp[i1, i2, Fiber.functor_map_fiberInclusion_map, Functor.map_inv,map_liftIso'] + have : F.IsHomLift (𝟙 Y) i := by + simp only[i, e] + apply IsHomLift.of_fac _ _ _ (ClovenIsofibration.obj_liftObj ..) + (ClovenIsofibration.obj_liftObj ..) + simp + Fiber.homMk F _ i + +lemma classifier.map.map_id {X Y} (f : X ⟶ Y) (a: F.Fiber X): + map.map I f (𝟙 a) = 𝟙 (map.obj I f a) := by + ext + simp only [map, Fiber.fiberInclusion_homMk, Groupoid.inv_eq_inv, Functor.map_id, + IsIso.inv_comp_eq] + simp [Fiber.fiberInclusion, classifier.map.obj] + +lemma classifier.map.map_comp {X Y} (f: X ⟶ Y) {a b c: F.Fiber X} (m1 : a ⟶ b) (m2: b ⟶ c): + map.map I f (m1 ≫ m2) = map.map I f m1 ≫ map.map I f m2 := by + ext + simp[classifier.map.map] + +@[simps] +def classifier.map {X Y} (f : X ⟶ Y) : F.Fiber X ⥤ F.Fiber Y where + obj := classifier.map.obj I f + map := classifier.map.map I f + map_id := classifier.map.map_id I f + map_comp := classifier.map.map_comp I f + +variable [IsSplit I] + +lemma classifier.map_id (X : Γ) : classifier.map I (𝟙 X) = 𝟙 (Grpd.of (F.Fiber X)) := by + fapply Functor.ext + · intro a + apply Subtype.ext + simp [map.obj, liftObj_id] + · intro a b f + simp + ext + simp [map.map, liftIso_id, eqToHom_map] + +lemma classifier.map_comp {X Y Z: Γ} (f : X⟶ Y) (g : Y ⟶ Z): + classifier.map I (f ≫ g) = classifier.map I f ⋙ classifier.map I g := by + fapply Functor.ext + · intro a + simp[map.obj, liftObj_comp] + · intro a b f + simp + ext + simp only [map.map, Fiber.fiberInclusion_homMk, Groupoid.inv_eq_inv, ← Category.assoc, + Functor.map_comp, eqToHom_map, ← heq_eq_eq, heq_comp_eqToHom_iff] + simp [liftIso_comp,← Category.assoc] + +/-- Any split isofibration of groupoids is classified up to isomorphism +as the (groupoidal) Grothendieck construction on the functor `classifier`. -/ +def classifier : Γ ⥤ Grpd.{v,u} where + obj X := Grpd.of (F.Fiber X) + map f := Grpd.homOf (classifier.map I f) + map_id _ := classifier.map_id .. + map_comp _ _ := classifier.map_comp .. + +@[simp] +lemma fiberInclusion_obj_classifier_map_obj {x y} (f : x ⟶ y) (p) : + Fiber.fiberInclusion.obj ((I.classifier.map f).obj p) = I.liftObj f p.2 := by + simp [classifier, classifier.map.obj, Fiber.fiberInclusion] + +open CategoryTheory.Functor.Groupoidal + +def grothendieckClassifierIso.hom.obj (pair: ∫ I.classifier) : E := pair.fiber.1 + +lemma grothendieckClassifierIso.hom.map_aux {X Y: Γ} (f: X ⟶ Y) (a: I.classifier.obj X) : + (I.classifier.map f).obj a = ⟨I.liftObj (X' := a.1) f a.2, obj_liftObj ..⟩ := by + simp[classifier,classifier.map.obj] + +lemma grothendieckClassifierIso.hom.map_aux2 + (X: Γ) (a: I.classifier.obj X) : F.obj a.1 = X := by + simp[classifier] at a + simp[a.2] + +def grothendieckClassifierIso.hom.map {p1 p2: ∫ I.classifier} (h: p1 ⟶ p2) : + (p1.fiber.1 ⟶ p2.fiber.1) := + I.liftIso h.base (hom.map_aux2 ..) ≫ + (eqToHom (by simp[grothendieckClassifierIso.hom.map_aux] )) ≫ h.fiber.1 + +def grothendieckClassifierIso.hom.map' {p1 p2: ∫ I.classifier} (h: p1 ⟶ p2) : + (p1.fiber.1 ⟶ p2.fiber.1) := + I.liftIso h.base (hom.map_aux2 ..) ≫ + (eqToHom (by simp[grothendieckClassifierIso.hom.map_aux,Fiber.fiberInclusion] )) ≫ + Fiber.fiberInclusion.map h.fiber ≫ (eqToHom (by simp[Fiber.fiberInclusion] )) + +lemma grothendieckClassifierIso.hom.map_id (X : ∫ I.classifier) : + hom.map I (𝟙 X) = 𝟙 _ := by + convert_to _ ≫ _ ≫ Fiber.fiberInclusion.map (Hom.fiber (𝟙 X)) = _ + simp [liftIso_id, eqToHom_map] + +lemma grothendieckClassifierIso.hom.map_comp {X Y Z: ∫ I.classifier} (f : X ⟶ Y) (g : Y ⟶ Z) : + hom.map' I (f ≫ g) = hom.map' I f ≫ hom.map' I g := by + simp [map', liftIso_comp, eqToHom_map, classifier, classifier.map.map] + +@[simps!] +def grothendieckClassifierIso.hom.hom {X Y} (f : X ⟶ Y) : + Fiber.fiberInclusion ⟶ I.classifier.map f ⋙ Fiber.fiberInclusion where + app _ := I.liftIso f .. + naturality := by + intro a b g + simp[Fiber.fiberInclusion,classifier,classifier.map.map,Fiber.homMk] + +def grothendieckClassifierIso.hom : ∫ I.classifier ⥤ E := + Groupoidal.functorFrom (fun x => Fiber.fiberInclusion) + (grothendieckClassifierIso.hom.hom I) + (by intro X; ext;simp[hom.hom,liftIso_id]) + (by intro X Y Z f g; ext; simp[hom.hom,liftIso_comp]) + +def grothendieckClassifierIso.inv.fibMap {X Y}(f : X ⟶ Y) : + ((F ⋙ I.classifier).map f).obj ⟨X,rfl⟩ ⟶ ⟨Y, rfl⟩ := by + refine @Fiber.homMk _ _ _ _ F (F.obj Y) _ _ ?_ ?_ + · exact CategoryTheory.inv (I.liftIso (F.map f) rfl) ≫ f + · simp + fapply IsHomLift.of_fac + · simp[ClovenIsofibration.obj_liftObj] + · rfl + · simp[Functor.map_inv,ClovenIsofibration.map_liftIso'] + +lemma grothendieckClassifierIso.inv.fibMap_id (x : E) : + inv.fibMap I (𝟙 x) = eqToHom (by simp) := by + apply Fiber.hom_ext + simp only [comp_obj, comp_map, fibMap, Fiber.fiberInclusion_homMk, Category.comp_id] + rw![Functor.map_id,liftIso_id] + simp[inv_eqToHom,eqToHom_map] + +lemma grothendieckClassifierIso.inv.fibMap_comp {x y z : E} (f : x ⟶ y) (g : y ⟶ z) : + inv.fibMap I (f ≫ g) = + eqToHom (by simp) ≫ + (I.classifier.map (F.map g)).map (inv.fibMap I f) ≫ inv.fibMap I g := by + simp only [comp_obj, comp_map, fibMap] + apply Fiber.hom_ext + rw! [Functor.map_comp] + simp [liftIso_comp, eqToHom_map,classifier,classifier.map.map] + +lemma ι_classifier_comp_forget {x} : ι I.classifier x ⋙ Groupoidal.forget = + Fiber.fiberInclusion ⋙ F := by + fapply Functor.ext + · intro p + exact p.2.symm + · intro p q f + simpa using IsHomLift.fac .. + +@[simp] +lemma liftObj_map_fiberInclusion_map {S} {X Y : Fiber F S} {X' : E} (f : X ⟶ Y) + [IsIso (F.map (Fiber.fiberInclusion.map f))] {hX' : X' = Fiber.fiberInclusion.obj X} : + I.liftObj (F.map (Fiber.fiberInclusion.map f)) (X' := X') (by simp [hX']) + = Fiber.fiberInclusion.obj X := by + rw! [Fiber.functor_map_fiberInclusion_map, liftObj_eqToHom, hX'] + +@[simp] +lemma liftIso_map_fiberInclusion_map {S} {X Y : Fiber F S} {X' : E} (f : X ⟶ Y) + [IsIso (F.map (Fiber.fiberInclusion.map f))] {hX' : X' = Fiber.fiberInclusion.obj X} : + I.liftIso (F.map (Fiber.fiberInclusion.map f)) (X' := X') (by simp [hX']) + = eqToHom (by simp [hX']) := by + rw! [Fiber.functor_map_fiberInclusion_map, liftIso_eqToHom] + +open grothendieckClassifierIso in +/-- A split isofibration `F : E ⥤ Γ` is classified by the functor `I.classifier : Γ ⥤ Grpd`. +This means that the (groupoidal) Grothendieck construction on `I.classifier` is isomorphic to +`E` over `Γ`. This isomorphism is called `grothendieckClassifierIso`. -/ +def grothendieckClassifierIso : ∫ I.classifier ≅≅ E := + Groupoidal.functorIsoFrom (fun x => Fiber.fiberInclusion) + (hom.hom I) (by intro X; ext; simp [liftIso_id]) + (by intro X Y Z f g; ext; simp [liftIso_comp]) + F (fun x => ⟨x, rfl⟩) (inv.fibMap I) (inv.fibMap_id I) (inv.fibMap_comp I) + (by simp [ι_classifier_comp_forget]) + (by + intro x p + simp only [comp_obj] + apply Subtype.hext HEq.rfl + · simp [Functor.Fiber.functor_obj_fiberInclusion_obj] + · simp [Fiber.fiberInclusion]) + (by + intro x p q f + simp only [inv.fibMap] + apply Fiber.hom_hext + any_goals apply Fiber.hext + all_goals simp [Fiber.functor_obj_fiberInclusion_obj q]) + (by intro x; simp [Fiber.fiberInclusion]) + (by + intro x y f + simp [inv.fibMap]) + (by simp) + (by simp [I.map_liftIso']) + (by + intro x y f p + simp only [inv.fibMap] + apply Fiber.hom_hext + any_goals apply Fiber.hext + any_goals simp + · rw! [map_liftIso', liftObj_comp _ _ _ rfl, liftObj_comp _ _ _ rfl] + simp [liftObj_eqToHom] + · rw! [map_liftIso', liftIso_comp _ _ _ rfl, liftIso_comp _ _ _ rfl] + simp only [liftIso_eqToHom, eqToHom_refl, eqToHom_trans, Category.id_comp, Category.assoc, + IsIso.inv_comp, inv_eqToHom, eqToHom_comp_liftIso, IsIso.inv_hom_id_assoc] + rw! [eqToHom_heq_id_cod] + apply eqToHom_heq_id + rw [liftObj_comp _ _ _ rfl, liftObj_comp _ _ _ rfl] + simp) + +lemma grothendieckClassifierIso.inv_comp_forget : + (grothendieckClassifierIso I).inv ⋙ Groupoidal.forget = F := + rfl + +lemma grothendieckClassifierIso.hom_comp_self : + (grothendieckClassifierIso I).hom ⋙ F = Groupoidal.forget := by + slice_lhs 2 3 => rw[← inv_comp_forget I (F := F)] + simp + +end + +@[simps!] +def iso {A : Type u} [Category.{v} A] {B : Type u₁} [Category.{v₁} B] (F : A ≅≅ B) : + ClovenIsofibration F.hom where + liftObj {b0 b1} f hf x hF := F.inv.obj b1 + liftIso {b0 b1} f hf x hF := eqToHom (by simp [← hF, ← Functor.comp_obj]) ≫ F.inv.map f + isHomLift f hf x hF := IsHomLift.of_fac' _ _ _ hF (by simp [← Functor.comp_obj]) + (by + simp only [map_comp, eqToHom_map, ← comp_map] + rw! (castMode := .all) [F.inv_hom_id]; + simp [← heq_eq_eq] + rfl) + liftIso_IsIso := by + intro X Y f i X' hX' + apply IsIso.comp_isIso + +instance {A : Type u} [Category.{v} A] {B : Type u₁} [Category.{v₁} B] (F : A ≅≅ B) : + IsSplit (iso F) where + liftObj_id h := by simp [← h, ← Functor.comp_obj] + liftIso_id := by simp + liftObj_comp := by simp + liftIso_comp := by simp + +@[simp] +abbrev iso_inv {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : + ClovenIsofibration F.inv := iso (F.symm) + +section + +variable {C : Type u₁} [Groupoid.{v₁,u₁} C] {F : C ⥤ Grpd.{v₂,u₂}} + +def forget.liftObj {X Y: C} (f : X ⟶ Y) + {X' : F.Groupoidal} (hX': Groupoidal.forget.obj X' = X) : F.Groupoidal := + Groupoidal.transport (C := C) (c := Y) X' (eqToHom (by subst hX'; simp) ≫ f) + +def forget.liftIso {X Y: C} (f : X ⟶ Y) {X' : F.Groupoidal} (hX': Groupoidal.forget.obj X' = X) : + X' ⟶ forget.liftObj f hX' := + Groupoidal.toTransport X' (eqToHom (by subst hX'; simp) ≫ f) + +lemma forget.isHomLift {X Y: C} (f : X ⟶ Y) {X' : F.Groupoidal} + (hX': Groupoidal.forget.obj X' = X) : Groupoidal.forget.IsHomLift f (forget.liftIso f hX') := by + apply IsHomLift.of_fac' (ha := hX') (hb := by simp[liftObj]) + simp[liftIso] + +def toTransport_IsIso (x : F.Groupoidal) {c : C} (t : x.base ⟶ c) : + IsIso (Groupoidal.toTransport x t) := + inferInstance + +variable (F) in +@[simps!] +def forget : ClovenIsofibration (Groupoidal.forget (F := F)) where + liftObj f := forget.liftObj f + liftIso f := forget.liftIso f + isHomLift f := forget.isHomLift f + liftIso_IsIso := inferInstance + +instance {X Y: C} (f : X ⟶ Y) [IsIso f] {X' : F.Groupoidal} + (hX': Groupoidal.forget.obj X' = X) : IsIso (forget.liftIso f hX') := by + apply toTransport_IsIso + +def forget.liftObj_id {X: C} {X' : F.Groupoidal} (hX': Groupoidal.forget.obj X' = X) : + forget.liftObj (𝟙 X) hX' = X' := by + simp [liftObj, Groupoidal.transport_eqToHom] + +def forget.liftIso_id {X: C} {X' : F.Groupoidal} (hX': Groupoidal.forget.obj X' = X) : + forget.liftIso (𝟙 X) hX' = eqToHom (by simp [forget.liftObj_id]) := by + dsimp [liftIso] + rw! (castMode :=.all)[Category.comp_id] + simp only [Groupoidal.toTransport_eqToHom, ← heq_eq_eq, eqRec_heq_iff_heq] + congr! + +lemma forget.liftObj_comp {X Y Z: C} (f : X ⟶ Y) (g : Y ⟶ Z) + {X' : F.Groupoidal} (hX' : X'.base = X) + {Y' : F.Groupoidal} (hY' : forget.liftObj f hX' = Y') : + forget.liftObj (f ≫ g) hX' = forget.liftObj g (liftObj_comp_aux (forget F) f hX' Y' hY') := by + simp only [liftObj,Groupoidal.transport_comp] + simp only [Groupoidal.transport, Grothendieck.transport, comp_obj, comp_map] + fapply Grothendieck.ext + · simp + simp only [Grpd.forgetToCat, Cat.of_α, id_eq, comp_obj, eqToHom_refl, comp_map, map_id, + Grpd.id_eq_id, id_obj] + congr! + simp only [← comp_obj,← Grpd.comp_eq_comp,← Functor.map_comp] + rw! [eqToHom_map] + subst hY' + simp [liftObj,Groupoidal.transport] + +lemma forget.liftIso_comp {X Y Z: C} (f : X ⟶ Y) (g : Y ⟶ Z) {X' : F.Groupoidal} + (hX' : X'.base = X) {Y' : F.Groupoidal} (hY' : forget.liftObj f hX' = Y') : + forget.liftIso (f ≫ g) hX' = forget.liftIso f hX' ≫ eqToHom hY' ≫ + forget.liftIso g (liftObj_comp_aux (forget F) f hX' Y' hY') ≫ + eqToHom (by symm; apply forget.liftObj_comp; assumption) := by + subst hX' hY' + simp only [liftIso, eqToHom_refl, Groupoidal.toTransport_comp, Groupoidal.toTransport_id, + Category.assoc, eqToHom_trans, Category.id_comp, eqToHom_trans_assoc] + congr 2 + simp only [liftObj, eqToHom_refl, ← Category.assoc, ← heq_eq_eq, heq_comp_eqToHom_iff, + heq_eqToHom_comp_iff, comp_eqToHom_heq_iff] + congr 1 + rw [Groupoidal.transport_congr ((X'.transport (𝟙 X'.base))) X' (by rw[Groupoidal.transport_id]) + f f (by simp), Groupoidal.transport_congr (X'.transport (𝟙 X'.base ≫ f)) (X'.transport f) _ + ((𝟙 (X'.transport (𝟙 X'.base ≫ f)).base)) (eqToHom (by simp))] + all_goals simp [Groupoidal.transport_id] + +instance : IsSplit (forget F) where + liftObj_id := forget.liftObj_id + liftIso_id := forget.liftIso_id + liftObj_comp _ _ _ _ := by apply forget.liftObj_comp + liftIso_comp _ _ _ _ := by apply forget.liftIso_comp + +end + +def id (A : Type u) [Category.{v} A] : ClovenIsofibration (𝟭 A) := + iso (Functor.Iso.refl _) + +instance (A : Type u) [Category.{v} A] : IsSplit (id A) := + inferInstanceAs <| IsSplit (iso (Functor.Iso.refl _)) + +section + +variable {A B C : Type*} [Category A] [Category B] [Category C] {F : A ⥤ B} + (IF : ClovenIsofibration F) {G : B ⥤ C} (IG : ClovenIsofibration G) + +def comp.liftObj {X Y: C} (f: X ⟶ Y) [IsIso f] {X': A} (hX': (F ⋙ G).obj X' = X) : A := + let f1 := IG.liftIso (X' := F.obj X') f (by simp at hX'; assumption) + IF.liftObj (X' := X') f1 rfl + +lemma comp.obj_liftObj {X Y: C} (f: X ⟶ Y) [IsIso f] {X': A} (hX': (F ⋙ G).obj X' = X) : + (F ⋙ G).obj (liftObj IF IG f hX') = Y := by + simp [liftObj] + +def comp.liftIso {X Y: C} (f: X ⟶ Y) [IsIso f] {X': A} (hX': (F ⋙ G).obj X' = X) : + X' ⟶ comp.liftObj IF IG f hX' := + let f1 := IG.liftIso (X' := F.obj X') f (by simp at hX'; assumption) + IF.liftIso (X' := X') f1 rfl + +lemma comp.isHomLift {X Y: C} (f: X ⟶ Y) [IsIso f] {X': A} (hX': (F ⋙ G).obj X' = X) : + (F ⋙ G).IsHomLift f (comp.liftIso IF IG f hX') := by + apply IsHomLift.of_fac + · let e := ClovenIsofibration.map_liftIso' (F := F) + simp only [comp_obj, liftIso, comp_map, e, eqToHom_refl, Category.id_comp, map_comp, + map_liftIso', eqToHom_map, Category.assoc, eqToHom_trans, eqToHom_trans_assoc] + rw![liftObj] + simp + · assumption + · simp [liftObj,ClovenIsofibration.obj_liftObj] + +/-- `IsMultiplicative` 1/2 -/ +@[simps!] +def comp : ClovenIsofibration (F ⋙ G) where + liftObj := comp.liftObj IF IG + liftIso := comp.liftIso IF IG + isHomLift := comp.isHomLift IF IG + liftIso_IsIso := by + intro X Y f i1 X' hX' + simp [comp.liftIso] + apply liftIso_IsIso + +lemma comp.liftIso_comp_aux {X Y Z : C} (f : X ⟶ Y) [IsIso f] (g : Y ⟶ Z) [IsIso g] {X' : A} + (hX' : (F ⋙ G).obj X' = X) (Y' : A) (hY' : comp.liftObj IF IG f hX' = Y') : + G.obj (F.obj Y') = Y := by + subst hY'; simp [comp.liftObj] + +variable [IsSplit IF] [IsSplit IG] + +lemma comp.liftObj_id {X: C} {X': A} (hX': (F ⋙ G).obj X' = X): + comp.liftObj IF IG (𝟙 X) hX' = X' := by + simp [comp.liftObj,liftIso_id] + +lemma comp.liftIso_id {X : C} {X' : A} (hX' : (F ⋙ G).obj X' = X) : + comp.liftIso IF IG (𝟙 X) hX' = eqToHom (by simp[comp.liftObj_id]) := by + dsimp [comp.liftIso] + rw! (castMode := .all) [IsSplit.liftIso_id] + simp only [liftIso_eqToHom, ← heq_eq_eq, eqRec_heq_iff_heq] + apply HEq.trans (eqToHom_heq_id_dom _ _ _) (eqToHom_heq_id_dom _ _ _).symm + +lemma comp.liftObj_comp {X Y Z : C} (f : X ⟶ Y) [IsIso f] (g : Y ⟶ Z) [IsIso g] {X' : A} + (hX' : (F ⋙ G).obj X' = X) : + comp.liftObj IF IG (f ≫ g) hX' = + comp.liftObj (X' := comp.liftObj IF IG f hX') IF IG g + (by simp only[comp.obj_liftObj]) := by + simp only [liftObj, liftIso_comp, eqToHom_refl, Category.id_comp, IsSplit.liftObj_comp, + liftObj_eqToHom] + congr! + simp + +lemma comp.liftIso_comp {X Y Z : C} (f : X ⟶ Y) [IsIso f] (g : Y ⟶ Z) [IsIso g] {X' : A} + (hX' : (F ⋙ G).obj X' = X) (Y' : A) + (hY' : comp.liftObj IF IG f hX' = Y') : + comp.liftIso IF IG (f ≫ g) hX' = comp.liftIso IF IG f hX' ≫ eqToHom hY' ≫ + comp.liftIso IF IG g (by subst hY';simp[liftObj]) ≫ + eqToHom (by subst hY'; simp[comp.liftObj_comp]) := by + subst hY' + simp only [liftObj, liftIso] + rw! [IsSplit.liftIso_comp (I := IG) f g hX' rfl, eqToHom_refl, Category.id_comp] + simp only [IsSplit.liftIso_comp, eqToHom_refl, liftIso_eqToHom, eqToHom_trans, Category.id_comp, + Category.assoc] + congr 1 + simp only [← heq_eq_eq, heq_comp_eqToHom_iff, comp_eqToHom_heq_iff] + congr! + simp + +instance : IsSplit (comp IF IG) where + liftObj_id := by + intro X X' hX' + apply comp.liftObj_id + liftIso_id := by + intro X X' hX' + apply comp.liftIso_id + liftObj_comp := by + intro X Y Z f i1 g i2 X' hX' Y' hY' + subst hY' + apply comp.liftObj_comp + liftIso_comp := by + intro X Y Z f i1 g i2 X' hX' Y' hY' + apply comp.liftIso_comp + +section isoComp + +@[simps] +def ofEq (F' : A ⥤ B) (hF' : F = F') : ClovenIsofibration F' where + liftObj f hf a ha := IF.liftObj f (by convert ha) + liftIso f hf a ha := IF.liftIso f (by convert ha) + isHomLift f hf a ha := by + subst hF' + apply IF.isHomLift + liftIso_IsIso := by + subst hF' + exact IF.liftIso_IsIso + +instance (F' : A ⥤ B) (hF' : F = F') : (ofEq IF F' hF').IsSplit := by + subst hF' + exact inferInstanceAs IF.IsSplit + +variable {A' : Type u₁} [Category.{v₁} A'] + (i : A' ≅≅ A) (F' : A' ⥤ B) (hF' : F' = i.hom ⋙ F) + +def isoComp : ClovenIsofibration F' := + ofEq (comp (iso ..) IF) F' hF'.symm + +instance : IsSplit (isoComp IF i F' hF') := + inferInstanceAs (ofEq ..).IsSplit + +end isoComp + +end + +def ofIsPullback {A B A' B' : Type u} [Groupoid.{v} A] [Groupoid.{v} B] [Groupoid.{v} A'] + [Groupoid.{v} B'] (top : A' ⥤ A) (F' : A' ⥤ B') (F : A ⥤ B) (bot : B' ⥤ B) + (isPullback : Functor.IsPullback top F' F bot) (IF : ClovenIsofibration F) [IsSplit IF] : + ClovenIsofibration F' := + let i : Functor.Groupoidal IF.classifier ≅≅ A := + Functor.ClovenIsofibration.grothendieckClassifierIso .. + have i_comp_F : i.hom ⋙ F = Groupoidal.forget := by + simp [i, grothendieckClassifierIso.hom_comp_self] + have eq1 : Groupoidal.pre IF.classifier bot ⋙ Groupoidal.forget = Groupoidal.forget ⋙ bot := by + simp [Groupoidal.pre_comp_forget] + have q1 : Functor.IsPullback (Groupoidal.pre IF.classifier bot ⋙ i.hom) + (Groupoidal.forget (F := (bot ⋙ IF.classifier))) F bot := + Functor.IsPullback.Paste.horiz eq1 (by simp [i_comp_F]) + (Functor.IsPullback.ofBotId i_comp_F.symm) + (Groupoidal.pre_isPullback ..) + let j : A' ≅≅ Functor.Groupoidal (F := bot ⋙ IF.classifier) := + Functor.IsPullback.isoIsPullback isPullback q1 + have e : F' = j.hom ⋙ (Groupoidal.forget (F := bot ⋙ IF.classifier)) := + (IsPullback.isoIsPullback.hom_comp_right isPullback q1 (hom := j.hom) (by simp[j])).symm + isoComp (Functor.ClovenIsofibration.forget ..) j _ e + +instance {A B A' B' : Type u} [Groupoid.{v} A] [Groupoid.{v} B] [Groupoid.{v} A'] + [Groupoid.{v} B'] (top : A' ⥤ A) (F' : A' ⥤ B') (F : A ⥤ B) (bot : B' ⥤ B) + (isPullback : Functor.IsPullback top F' F bot) (IF : ClovenIsofibration F) [IsSplit IF] : + IsSplit (ofIsPullback top F' F bot isPullback IF) := by + dsimp [ofIsPullback] + infer_instance + +section pushforward + +open CategoryTheory.Functor.Groupoidal GroupoidModel.FunctorOperation.pi.Over + +variable {C B A : Type u} [Groupoid.{u} C] [Groupoid.{u} B] [Groupoid.{u} A] {F : B ⥤ A} + (IF : ClovenIsofibration F) [IsSplit IF] (G : C ⥤ B) + +def pushforward.strictify : C ⥤ ∫ IF.classifier := + G ⋙ IF.grothendieckClassifierIso.inv + +@[simp] +lemma pushforward.strictify_comp_grothendieckClassifierIso_hom : + strictify IF G ⋙ IF.grothendieckClassifierIso.hom = G := by + simp [strictify, Functor.assoc] + +variable {G} (IG : ClovenIsofibration G) [IsSplit IG] + +def pushforward.strictifyClovenIsofibration : (strictify IF G).ClovenIsofibration := + ClovenIsofibration.comp IG (Functor.ClovenIsofibration.iso_inv ..) + +instance : (pushforward.strictifyClovenIsofibration IF IG).IsSplit := by + simp[pushforward.strictifyClovenIsofibration] + have h: (iso_inv IF.grothendieckClassifierIso).IsSplit := by + apply Functor.ClovenIsofibration.instIsSplitIso + apply CategoryTheory.Functor.ClovenIsofibration.instIsSplitComp + +/-- The object part (a groupoid) of the pushforward along `F`, of `G`, +defined as the Grothendieck construction applied to (unstructured) Pi-type construction +in the HoTTLean groupoid model. -/ +abbrev pushforward := ∫ GroupoidModel.FunctorOperation.pi (IF.classifier) + (pushforward.strictifyClovenIsofibration IF IG).classifier + +/-- `∫ σ.hom ⋙ hF.splitIsofibration.classifier` is the pullback of `F` along `σ`, +`∫ (splitIsofibration_strictify hF hG).classifier` is isomorphic to `G`. +So up to isomorphism this is the hom set bijection we want. -/ +@[simps] +def pushforward.homEquivAux1 {D : Type u} [Groupoid.{u} D] (σ : D ⥤ A) : + {M : D ⥤ pushforward IF IG // M ⋙ Groupoidal.forget = σ} ≃ + {N : ∫ σ ⋙ IF.classifier ⥤ ∫ (strictifyClovenIsofibration IF IG).classifier // + N ⋙ Functor.Groupoidal.forget = pre IF.classifier σ } where + toFun M := ⟨equivFun _ M.1 M.2, equivFun_comp_forget ..⟩ + invFun N := ⟨(equivInv (strictifyClovenIsofibration IF IG).classifier N.1 N.2), + equivInv_comp_forget (strictifyClovenIsofibration IF IG).classifier N.1 N.2⟩ + left_inv _ := by + ext + simp [equivInv_equivFun] + right_inv _ := by + ext + simp [equivFun_equivInv] + +@[simps!] +def pushforward.homEquivAux2 {D : Type u} [Groupoid.{u} D] (σ : D ⥤ A) : + {M : ∫ σ ⋙ IF.classifier ⥤ ∫ (strictifyClovenIsofibration IF IG).classifier // + M ⋙ Functor.Groupoidal.forget = pre IF.classifier σ } ≃ + {N : ∫ σ ⋙ IF.classifier ⥤ C // + N ⋙ G = pre IF.classifier σ ⋙ IF.grothendieckClassifierIso.hom } where + toFun M := ⟨(M.1 ⋙ ((strictifyClovenIsofibration IF IG)).grothendieckClassifierIso.hom), + by + conv => lhs ; rhs ; rw [← strictify_comp_grothendieckClassifierIso_hom IF G] + rw [Functor.assoc] + slice_lhs 2 3 => rw [← Functor.assoc, grothendieckClassifierIso.hom_comp_self] + slice_rhs 1 2 => rw [← M.2] + rw [Functor.assoc] ⟩ + invFun N := ⟨N.1 ⋙ ((strictifyClovenIsofibration IF IG)).grothendieckClassifierIso.inv, + by + dsimp [strictify] + rw [Functor.assoc, grothendieckClassifierIso.inv_comp_forget, ← Functor.assoc, N.2, + Functor.assoc, Iso.hom_inv_id', Functor.comp_id] ⟩ + left_inv := by + simp only [Function.LeftInverse, Subtype.forall, Subtype.mk.injEq] + intro a h + simp[Functor.assoc] + right_inv := by + simp[Function.RightInverse] + intro a + simp[Functor.assoc] + +open GroupoidModel.FunctorOperation.pi in +/-- The universal property of the pushforward, expressed as a (natural) bijection of hom sets. -/ +def pushforward.homEquiv {D : Type u} [Groupoid.{u} D] (σ : D ⥤ A) : + {M : D ⥤ pushforward IF IG // M ⋙ Groupoidal.forget = σ} ≃ + {N : ∫ σ ⋙ IF.classifier ⥤ C // + N ⋙ G = pre IF.classifier σ ⋙ IF.grothendieckClassifierIso.hom} := + calc {M : D ⥤ pushforward IF IG // M ⋙ Groupoidal.forget = σ} + _ ≃ {N : ∫ σ ⋙ IF.classifier ⥤ ∫ (strictifyClovenIsofibration IF IG).classifier // + N ⋙ Functor.Groupoidal.forget = pre IF.classifier σ } := + pushforward.homEquivAux1 .. + _ ≃ {N : ∫ σ ⋙ IF.classifier ⥤ C // + N ⋙ G = pre IF.classifier σ ⋙ IF.grothendieckClassifierIso.hom } := + pushforward.homEquivAux2 .. + +lemma pushforward.homEquiv_apply_coe {D : Type u} [Groupoid.{u} D] (σ : D ⥤ A) + (M : {M : D ⥤ pushforward IF IG // M ⋙ Groupoidal.forget = σ}) : + ((pushforward.homEquiv IF IG σ) M).1 = + equivFun (strictifyClovenIsofibration IF IG).classifier M M.2 ⋙ + (strictifyClovenIsofibration IF IG).grothendieckClassifierIso.hom := by + simp[pushforward.homEquiv] + simp[homEquivAux1] + simp[Trans.trans] + simp[homEquivAux2] + +/-- Naturality in the universal property of the pushforward. -/ +lemma pushforward.homEquiv_comp {D D' : Type u} [Groupoid.{u} D] [Groupoid.{u} D'] + (σ : D ⥤ A) (σ' : D' ⥤ A) (s : D' ⥤ D) (eq : σ' = s ⋙ σ) + (M : D ⥤ pushforward IF IG) (hM : M ⋙ Groupoidal.forget = σ) : + (pushforward.homEquiv IF IG σ' ⟨s ⋙ M, by rw [Functor.assoc, hM, eq]⟩).1 = + Groupoidal.map (eqToHom (by rw [eq, Functor.assoc])) ⋙ + pre _ s ⋙ (pushforward.homEquiv IF IG σ ⟨M, hM⟩).1 := by + subst eq + rw [pushforward.homEquiv_apply_coe, pushforward.homEquiv_apply_coe] + simp [← Functor.assoc, Functor.simpIdComp, equivFun_comp (hF:= hM), Groupoidal.map_id_eq] + +end pushforward + +def toDiscretePUnit + {X : Type*} [Category X] (F : X ⥤ Discrete.{u} PUnit) : Functor.ClovenIsofibration F where + liftObj {y1 y2} g i x e := x + liftIso {y1 y2} g i x e := 𝟙 x + isHomLift {y1 y2} g i x e := by + apply IsHomLift.of_fac _ _ _ + any_goals apply Discrete.ext + any_goals apply PUnit.ext + rfl + liftIso_IsIso {y1 y2} g i x e := CategoryTheory.IsIso.id .. + +instance toDiscretePUnit.IsSplit {X : Type*} [Category X] (F : X ⥤ Discrete.{u} PUnit) : + Functor.ClovenIsofibration.IsSplit (toDiscretePUnit F) where + liftObj_id := by simp[toDiscretePUnit] + liftIso_id := by simp[toDiscretePUnit] + liftObj_comp {y1 y2 y3} f hf g hg x1 hx1 x2 hx2 := by + subst hx2 + simp[toDiscretePUnit] + liftIso_comp {y1 y2 y3} f hf g hg x1 hx1 x2 hx2 := by + subst hx2 + simp[toDiscretePUnit] + +end ClovenIsofibration +end +end Functor +end CategoryTheory + +namespace GroupoidModel + +open CategoryTheory Functor.ClovenIsofibration + +def tpClovenIsofibration : (GroupoidModel.U.{u}.tp).ClovenIsofibration := + let i : U.{u}.Tm ≅≅ Functor.Groupoidal (F := Core.inclusion _ ⋙ AsSmall.down) := + Functor.IsPullback.isoIsPullback IsPullback.isPullbackCoreAsSmall' + (Functor.Groupoidal.isPullback (Core.inclusion _ ⋙ AsSmall.down)) + isoComp (Functor.ClovenIsofibration.forget _) i + _ (Functor.IsPullback.isoIsPullback.hom_comp_right _ _ rfl).symm + +instance : IsSplit tpClovenIsofibration := by + dsimp [tpClovenIsofibration] + infer_instance + +end GroupoidModel diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Basic.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Basic.lean new file mode 100644 index 00000000..e4218ab8 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Basic.lean @@ -0,0 +1,31 @@ +import Mathlib.CategoryTheory.Comma.Basic + + +namespace CategoryTheory + +open Category + +-- declare the `v`'s first; see `CategoryTheory.Category` for an explanation +universe v₁ v₂ v₃ v₄ v₅ v₆ u₁ u₂ u₃ u₄ u₅ u₆ + +variable {A : Type u₁} [Category.{v₁} A] +variable {B : Type u₂} [Category.{v₂} B] +variable {T : Type u₃} [Category.{v₃} T] +variable {A' : Type u₄} [Category.{v₄} A'] +variable {B' : Type u₅} [Category.{v₅} B'] +variable {T' : Type u₆} [Category.{v₆} T'] +variable {L : A ⥤ T} {R : B ⥤ T} + +private lemma Comma.ext {X Y : Comma L R} + (hleft : X.left = Y.left) (hright : X.right = Y.right) + (hhom : X.hom ≫ R.map (eqToHom hright) = L.map (eqToHom hleft) ≫ Y.hom) : + X = Y := by + cases X; cases Y + rw [← heq_eq_eq, eqToHom_map, eqToHom_map, comp_eqToHom_heq_iff, heq_eqToHom_comp_iff] at hhom + congr + +lemma Comma.ext_of_iso {X Y : Comma L R} (e : X ≅ Y) + (obj_left : X.left = Y.left) (obj_right : X.right = Y.right) + (hom_left : e.hom.left = eqToHom obj_left) (hom_right : e.hom.right = eqToHom obj_right) : + X = Y := + Comma.ext obj_left obj_right <| by rw [← hom_left, ← hom_right, e.hom.w] diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Basic.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Basic.lean new file mode 100644 index 00000000..6b2e002d --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Basic.lean @@ -0,0 +1,14 @@ +import Mathlib.CategoryTheory.Comma.Over.Basic +import HoTTLean.ForMathlib.CategoryTheory.Comma.Basic + +namespace CategoryTheory + +universe v₁ v₂ v₃ u₁ u₂ u₃ + +-- morphism levels before object levels. See note [category theory universes]. +variable {T : Type u₁} [Category.{v₁} T] +variable {D : Type u₂} [Category.{v₂} D] + +lemma Over.ext_of_iso {X : T} {U V : Over X} (e : U ≅ V) (obj_left : U.left = V.left) + (hom_left : e.hom.left = eqToHom obj_left) : U = V := + Comma.ext_of_iso e obj_left (by simp) hom_left (by cat_disch) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean new file mode 100644 index 00000000..16f2fcc2 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2025 Joseph Hua. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Joseph Hua +-/ + +import Mathlib.CategoryTheory.Comma.Over.Pullback +import Mathlib.CategoryTheory.Adjunction.PartialAdjoint +import Mathlib.CategoryTheory.Limits.FunctorCategory.Basic + +noncomputable section + +universe v v₂ u u₂ + +namespace CategoryTheory + +open Category Limits Comonad + +variable {C : Type u} [Category.{v} C] (X : C) + +variable {S S' : C} (f : S ⟶ S') [inst_hasPullback : ∀ {W} (h : W ⟶ S'), HasPullback h f] + +/-- `Y` is the pushforward of `X` along `f` when it represents the presheaf +`Hom(pullback f (-), X)`. This expresses the universal property of the right adjoint to +pullback without requiring the existence of the entire adjoint. +See `Mathlib.CategoryTheory.Adjunction.PartialAdjoint`. -/ +abbrev IsPushforward (X : Over S) (Y : Over S') := + ((Over.pullback f).op ⋙ yoneda.obj X).RepresentableBy Y + +/-- An object `X` in the slice over `S` has a pushforward along morphism `f : S ⟶ S'` +when the partial right adjoint of pullback along `f` is well-defined on the object `X`. +This definition could be generalised to not require pullbacks, but such settings are rare. +-/ +abbrev HasPushforward (X : Over S) : Prop := + ((Over.pullback f).op ⋙ yoneda.obj X).IsRepresentable + +/-- Assuming the partial right adjoint of pullback along `f` is well-defined on `X`, +choose the image of `X` under the partial right adjoint. -/ +abbrev pushforward (X : Over S) [HasPushforward f X] : Over S' := + ((Over.pullback f).op ⋙ yoneda.obj X).reprX + +/-- The pushforward of an object satisfies the universal property of the pushforward. -/ +def pushforward.isPushforward (X : Over S) [HasPushforward f X] : + IsPushforward f X (pushforward f X) := + ((Over.pullback f).op ⋙ yoneda.obj X).representableBy + +/-- A morphism `f` has pushforwards (also called exponentiable) when there is a pushforward +along `f` for any map into its domain. -/ +abbrev HasPushforwardsAlong : Prop := ∀ (X : Over S), HasPushforward f X + +-- namespace Over + +-- variable [HasPushforwardsAlong f] + +-- lemma pullback_rightAdjointObjIsDefined_eq_top : +-- (Over.pullback f).rightAdjointObjIsDefined = ⊤ := by aesop_cat + +-- instance : (pullback f).IsLeftAdjoint := +-- Functor.isLeftAdjoint_of_rightAdjointObjIsDefined_eq_top +-- (pullback_rightAdjointObjIsDefined_eq_top f) + +-- /-- The left adjoint of pullback. -/ +-- def pushforward : Over S ⥤ Over S' := +-- (pullback f).rightAdjoint + +-- /-- The pullback-pushforward adjunction. -/ +-- def pullbackPushforwardAdjunction : pullback f ⊣ pushforward f := +-- Adjunction.ofIsLeftAdjoint (pullback f) + +-- end Over + +end CategoryTheory +end diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean new file mode 100644 index 00000000..8b961679 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean @@ -0,0 +1,203 @@ +import Mathlib.CategoryTheory.Comma.Presheaf.Basic +import Mathlib.Tactic.DepRewrite +import HoTTLean.ForMathlib +import HoTTLean.ForMathlib.CategoryTheory.Adjunction.Basic +import HoTTLean.ForMathlib.CategoryTheory.Yoneda + +namespace CategoryTheory + +open Category Opposite + +universe w v u u₁ + +section + +attribute [local simp] CategoryTheory.Yoneda.fullyFaithful_preimage + +namespace costructuredArrowYonedaEquivOver + +variable {C : Type u} [Category.{v} C] {A : C} + +@[simps!] +def functor : CostructuredArrow yoneda (yoneda.obj A) ⥤ Over A where + obj X := Over.mk ((CategoryTheory.Yoneda.fullyFaithful).preimage X.hom) + map {X Y} f := Over.homMk f.left (by + have e : (yoneda.map f.left ≫ Y.hom).app (op X.left) (𝟙 X.left) = + (X.hom ≫ (Functor.fromPUnit (yoneda.obj A)).map f.right).app + (op X.left) (𝟙 X.left) := by simp [f.w] + simp [- CommaMorphism.w] at e + simpa) + +@[simps!] +def inverse : Over A ⥤ CostructuredArrow yoneda (yoneda.obj A) where + obj X := CostructuredArrow.mk (yoneda.map X.hom) + map {X Y} f := CostructuredArrow.homMk f.left + +@[simps!] +def unitIso : 𝟭 (CostructuredArrow yoneda (yoneda.obj A)) ≅ functor ⋙ inverse := + NatIso.ofComponents (fun X => Comma.isoMk (Iso.refl _) (Iso.refl _) + (by cat_disch)) + +@[simps!] +def counitIso : inverse ⋙ functor (A := A) ≅ 𝟭 _ := + NatIso.ofComponents (fun X => Over.isoMk (Iso.refl _)) + +end costructuredArrowYonedaEquivOver + +open costructuredArrowYonedaEquivOver + +variable {C : Type u} [Category.{v} C] {A : C} + +@[simps] +def costructuredArrowYonedaEquivOver : + CostructuredArrow yoneda (yoneda.obj A) ≌ CategoryTheory.Over A where + functor := functor + inverse := inverse + unitIso := unitIso + counitIso := counitIso + +def costructuredArrowYonedaEquivOver.inverseCompToOverIso : + inverse ⋙ CostructuredArrow.toOver yoneda (yoneda.obj A) ≅ Over.post yoneda := + Iso.refl _ + +def overYonedaEquivPresheafOver : + CategoryTheory.Over (yoneda.obj A) ≌ ((CategoryTheory.Over A)ᵒᵖ ⥤ Type v) := + (overEquivPresheafCostructuredArrow (yoneda.obj A)).trans + costructuredArrowYonedaEquivOver.op.congrLeft + +def overYonedaEquivPresheafOver.functorObjMkYonedaIso (B : Over A) : + overYonedaEquivPresheafOver.functor.obj (Over.mk (yoneda.map B.hom)) ≅ yoneda.obj B := + calc overYonedaEquivPresheafOver.functor.obj (Over.mk (yoneda.map B.hom)) + _ ≅ _ := Functor.isoWhiskerLeft inverse.op <| + (CostructuredArrow.toOverCompOverEquivPresheafCostructuredArrow (yoneda.obj A)).app + (.mk (yoneda.map B.hom)) + _ ≅ yoneda.obj B := NatIso.ofComponents (fun X => + costructuredArrowYonedaEquivOver.fullyFaithfulInverse.homEquiv.symm.toIso) + (fun {X Y} f => by + ext a + simp only [Equiv.toIso_hom, types_comp_apply] + erw [Functor.FullyFaithful.homEquiv_symm_apply, Functor.FullyFaithful.homEquiv_symm_apply] + simp) + +def overYonedaEquivPresheafOver.yonedaObjFunctorObjIso (X : Over y(A)) : + y(overYonedaEquivPresheafOver.functor.obj X) ≅ + overYonedaEquivPresheafOver.inverse.op ⋙ yoneda.obj X := + (overYonedaEquivPresheafOver.symm.toAdjunction.representableBy X).toIso + +def overYonedaEquivPresheafOver.postYonedaCompFunctorIso : + Over.post yoneda ⋙ (overYonedaEquivPresheafOver (A := A)).functor ≅ yoneda := + calc _ + _ ≅ (inverse ⋙ CostructuredArrow.toOver yoneda (yoneda.obj A)) ⋙ + (overYonedaEquivPresheafOver (A := A)).functor := + Functor.isoWhiskerRight inverseCompToOverIso _ + _ ≅ ((inverse ⋙ CostructuredArrow.toOver yoneda (yoneda.obj A)) ⋙ + (overEquivPresheafCostructuredArrow y(A)).functor) ⋙ + costructuredArrowYonedaEquivOver.op.congrLeft.functor := + (Functor.associator ..).symm + _ ≅ (inverse ⋙ (CostructuredArrow.toOver yoneda (yoneda.obj A)) ⋙ + (overEquivPresheafCostructuredArrow y(A)).functor) ⋙ + costructuredArrowYonedaEquivOver.op.congrLeft.functor := + Functor.isoWhiskerRight (Functor.associator ..) _ + _ ≅ (inverse ⋙ yoneda) ⋙ costructuredArrowYonedaEquivOver.op.congrLeft.functor := + Functor.isoWhiskerRight (Functor.isoWhiskerLeft _ + (CostructuredArrow.toOverCompOverEquivPresheafCostructuredArrow ..)) _ + _ ≅ inverse ⋙ yoneda ⋙ costructuredArrowYonedaEquivOver.op.congrLeft.functor := + Functor.associator .. + _ ≅ inverse ⋙ functor ⋙ yoneda := + Functor.isoWhiskerLeft _ costructuredArrowYonedaEquivOver.yonedaCompCongrLeftFunctorIso + _ ≅ 𝟭 _ ⋙ yoneda := + (Functor.associator ..).symm ≪≫ Functor.isoWhiskerRight counitIso _ + _ ≅ yoneda := + yoneda.leftUnitor + +def overYonedaEquivPresheafOver.yonedaCompInverseIso : + yoneda ⋙ (overYonedaEquivPresheafOver (A := A)).inverse ≅ Over.post yoneda := + (overYonedaEquivPresheafOver.isoCompInverse postYonedaCompFunctorIso).symm + +end + +section + +variable {C : Type u} [SmallCategory C] {A : C} {D : Type*} [Category D] + +open overYonedaEquivPresheafOver + +/- +noncomputable def Over.yonedaIsoMk {X Y : Over (yoneda.obj A)} + (α : (post yoneda).op ⋙ y(X) ≅ (post yoneda).op ⋙ y(Y)) : + X ≅ Y := + let β (X) : yoneda.op ⋙ y(overYonedaEquivPresheafOver.functor.obj X) ≅ + (Over.post yoneda).op ⋙ yoneda.obj X := + calc yoneda.op ⋙ y(overYonedaEquivPresheafOver.functor.obj X) + _ ≅ yoneda.op ⋙ overYonedaEquivPresheafOver.inverse.op ⋙ yoneda.obj X := + yoneda.op.isoWhiskerLeft (yonedaObjFunctorObjIso X) + _ ≅ (yoneda.op ⋙ overYonedaEquivPresheafOver.inverse.op) ⋙ yoneda.obj X := + (Functor.associator ..).symm + _ ≅ (yoneda ⋙ overYonedaEquivPresheafOver.inverse).op ⋙ yoneda.obj X := + Functor.isoWhiskerRight (Functor.opComp ..).symm _ + _ ≅ (Over.post yoneda).op ⋙ yoneda.obj X := + Functor.isoWhiskerRight (NatIso.op yonedaCompInverseIso.symm) _ + overYonedaEquivPresheafOver.functor.preimageIso + (NatIso.yonedaMk (β X ≪≫ α ≪≫ (β Y).symm)) +-/ + +/-- The natural hom-set bijection as an isomorphism of profunctors +``` + Psh(Over A) (y(-), overYonedaEquivPresheafOver.functor (⋆)) ≅ + Over (y(A)) (yoneda ⋙ inverse (-), ⋆) ≅ + Over (y(A)) (Over.post yoneda (-), ⋆) +``` +-/ +def overYonedaEquivPresheafOver.homIso : overYonedaEquivPresheafOver.functor ⋙ yoneda ⋙ + (Functor.whiskeringLeft (Over A)ᵒᵖ ((Over A)ᵒᵖ ⥤ Type u)ᵒᵖ (Type u)).obj yoneda.op ≅ + yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op := + calc overYonedaEquivPresheafOver.functor ⋙ yoneda ⋙ + (Functor.whiskeringLeft _ _ _).obj yoneda.op + -- `Psh(Over A) (y(-), functor (⋆))` + _ ≅ (overYonedaEquivPresheafOver.functor ⋙ yoneda) ⋙ + (Functor.whiskeringLeft _ _ _).obj yoneda.op := + (Functor.associator ..).symm + -- `Over (y(A)) (yoneda ⋙ inverse (-), ⋆)` + _ ≅ (yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj overYonedaEquivPresheafOver.inverse.op) ⋙ + (Functor.whiskeringLeft _ _ _).obj yoneda.op := + Functor.isoWhiskerRight overYonedaEquivPresheafOver.symm.toAdjunction.homIso.symm _ + _ ≅ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj overYonedaEquivPresheafOver.inverse.op ⋙ + (Functor.whiskeringLeft _ _ _).obj yoneda.op := + Functor.associator .. + _ ≅ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj + (yoneda.op ⋙ overYonedaEquivPresheafOver.inverse.op) := + Functor.isoWhiskerLeft _ (Functor.whiskeringLeftObjCompIso ..).symm + _ ≅ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj + (yoneda ⋙ overYonedaEquivPresheafOver.inverse).op := + Functor.isoWhiskerLeft _ (Functor.mapIso _ (Functor.opComp ..).symm) + -- `Over (y(A)) (Over.post yoneda (-), ⋆)` + _ ≅ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op := + Functor.isoWhiskerLeft _ (Functor.mapIso _ + (NatIso.op overYonedaEquivPresheafOver.yonedaCompInverseIso.symm)) + +/-- To show that `F ≅ G : D ⥤ Over y(A)` +it suffices to show the natural isomorphism of profunctors +`Over (y(A)) (Over.post yoneda (-), F(⋆)) ≅ Over (y(A)) (Over.post yoneda (-), G(⋆))` -/ +def Over.yonedaNatIsoMk {F G : D ⥤ Over (yoneda.obj A)} + (α : F ⋙ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op ≅ + G ⋙ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op) : + F ≅ G := + -- `Psh(Over A) (y(-), F ⋙ functor (⋆)) ≅ Over (y(A)) (Over.post yoneda (-), F(⋆))` + let β (F) : (F ⋙ (overYonedaEquivPresheafOver).functor) ⋙ + yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj yoneda.op ≅ + F ⋙ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op := + (Functor.associator ..).symm ≪≫ Functor.isoWhiskerLeft F overYonedaEquivPresheafOver.homIso + -- to show `F ≅ G : D ⥤ Over (yoneda.obj A)` + (overYonedaEquivPresheafOver.fullyFaithfulFunctor.whiskeringRight _).preimageIso + -- it suffices to compose with the equivalence + -- `overYonedaEquivPresheafOver : Over (y(A)) ≌ Psh (Over A)` and show + -- `F ⋙ overYonedaEquivPresheafOver.functor ≅ G ⋙ overYonedaEquivPresheafOver.functor` + (functorToPresheafIsoMk (β F ≪≫ α ≪≫ (β G).symm)) + -- an isomorphism `F ⋙ functor ≅ G ⋙ functor : Psh C` amounts to + -- an isomorphism `Psh(Over A) (y(-), F ⋙ functor (⋆)) ≅ Psh(Over A) (y(-), G ⋙ functor (⋆))` + -- amounts to + -- an isomorphism `Over (y(A)) (Over.post yoneda (-), F(⋆)) ≅ Over (y(A)) (Over.post yoneda (-), G(⋆))` + +end + +end CategoryTheory diff --git a/HoTTLean/ForMathlib/CategoryTheory/Functor/FullyFaithful.lean b/HoTTLean/ForMathlib/CategoryTheory/Functor/FullyFaithful.lean new file mode 100644 index 00000000..3c415bce --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Functor/FullyFaithful.lean @@ -0,0 +1,16 @@ +import Mathlib.CategoryTheory.Functor.FullyFaithful +import Mathlib.CategoryTheory.Yoneda + +universe v₁ v₂ u₁ u₂ + +namespace CategoryTheory +namespace Functor +namespace FullyFaithful + +variable {C : Type u₁} [Category.{v₁} C] {D : Type u₂} [Category.{v₁} D] + +variable {F : C ⥤ D} (hF : F.FullyFaithful) + +/-- The natural isomorphism of hom-sets `C(-,⋆) ≅ D(F(-),F(⋆))`. -/ +def homIso : yoneda ≅ F ⋙ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj F.op := + NatIso.ofComponents (fun X => NatIso.ofComponents (fun Y => hF.homEquiv.toIso)) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean b/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean index 480b0e40..d49b15e0 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean @@ -480,29 +480,29 @@ def isoIsPullback {P P' X Y Z : Type*} [Category P] [Category P'] · intro A have e : ((h.toChosen ⋙ h'.fromChosen) ⋙ h'.toChosen ⋙ h.fromChosen) = (h.toChosen ⋙ (h'.fromChosen ⋙ h'.toChosen) ⋙ h.fromChosen) := by - simp[comp] + simp [comp] simp only[e,from_to_id,Functor.id_comp,to_from_id] · intro A B t have e : ((h.toChosen ⋙ h'.fromChosen) ⋙ h'.toChosen ⋙ h.fromChosen) = (h.toChosen ⋙ (h'.fromChosen ⋙ h'.toChosen) ⋙ h.fromChosen) := by simp[comp] - rw![e] - simp only[← heq_eq_eq,heq_eqToHom_comp_iff,heq_comp_eqToHom_iff] - rw[from_to_id,Functor.id_comp,to_from_id] + rw! [e] + simp only [← heq_eq_eq,heq_eqToHom_comp_iff,heq_comp_eqToHom_iff] + rw [from_to_id,Functor.id_comp,to_from_id] inv_hom_id := by fapply Functor.ext · intro A have e : ((h'.toChosen ⋙ h.fromChosen) ⋙ h.toChosen ⋙ h'.fromChosen) = (h'.toChosen ⋙ (h.fromChosen ⋙ h.toChosen) ⋙ h'.fromChosen) := by simp[comp] - simp only[e,from_to_id,Functor.id_comp,to_from_id] + simp only [e,from_to_id,Functor.id_comp,to_from_id] · intro A B t have e : ((h'.toChosen ⋙ h.fromChosen) ⋙ h.toChosen ⋙ h'.fromChosen) = (h'.toChosen ⋙ (h.fromChosen ⋙ h.toChosen) ⋙ h'.fromChosen) := by - simp[comp] - rw![e] + simp [comp] + rw! [e] simp only[← heq_eq_eq,heq_eqToHom_comp_iff,heq_comp_eqToHom_iff] - rw[from_to_id,Functor.id_comp,to_from_id] + rw [from_to_id,Functor.id_comp,to_from_id] lemma isoIsPullback.inv_comp_left {P P' X Y Z : Type*} [Category P] [Category P'] [Category X] [Category Y] [Category Z] @@ -510,15 +510,15 @@ lemma isoIsPullback.inv_comp_left {P P' X Y Z : Type*} [Category P] [Category P' {fst' : P' ⥤ X} {snd' : P' ⥤ Y} (h : Functor.IsPullback fst snd f g) (h' : Functor.IsPullback fst' snd' f g): (isoIsPullback h h').inv ⋙ fst = fst' := by - dsimp[isoIsPullback] + dsimp [isoIsPullback] fapply Functor.ext · intro A - simp only[Functor.assoc,h.from_north] - rw[toChosen_north] + simp only [Functor.assoc,h.from_north] + rw [toChosen_north] · intros A B t - simp only[← heq_eq_eq,heq_eqToHom_comp_iff,heq_comp_eqToHom_iff] - rw![Functor.assoc,h.from_north] - rw[toChosen_north] + simp only [← heq_eq_eq,heq_eqToHom_comp_iff,heq_comp_eqToHom_iff] + rw! [Functor.assoc,h.from_north] + rw [toChosen_north] lemma isoIsPullback.hom_comp_left {P P' X Y Z : Type*} [Category P] [Category P'] [Category X] [Category Y] [Category Z] @@ -526,23 +526,23 @@ lemma isoIsPullback.hom_comp_left {P P' X Y Z : Type*} [Category P] [Category P' {fst' : P' ⥤ X} {snd' : P' ⥤ Y} (h : Functor.IsPullback fst snd f g) (h' : Functor.IsPullback fst' snd' f g): (isoIsPullback h h').hom ⋙ fst' = fst := by - dsimp[isoIsPullback] + dsimp [isoIsPullback] fapply Functor.ext · intro A - simp only[Functor.assoc,h'.from_north] - rw[toChosen_north] + simp only [Functor.assoc,h'.from_north] + rw [toChosen_north] · intros A B t - simp only[← heq_eq_eq,heq_eqToHom_comp_iff,heq_comp_eqToHom_iff] - rw![Functor.assoc,h'.from_north] - rw[toChosen_north] + simp only [← heq_eq_eq,heq_eqToHom_comp_iff,heq_comp_eqToHom_iff] + rw! [Functor.assoc,h'.from_north] + rw [toChosen_north] lemma isoIsPullback.hom_comp_left' {P P' X Y Z : Type*} [Category P] [Category P'] [Category X] [Category Y] [Category Z] {fst : P ⥤ X} {snd : P ⥤ Y} {f : X ⥤ Z} {g : Y ⥤ Z} {fst' : P' ⥤ X} {snd' : P' ⥤ Y} (h : Functor.IsPullback fst snd f g) - (h' : Functor.IsPullback fst' snd' f g) {hom } (e: hom = (isoIsPullback h h').hom): + (h' : Functor.IsPullback fst' snd' f g) {hom } (e: hom = (isoIsPullback h h').hom): hom ⋙ fst' = fst := by - rw[e] + rw [e] apply isoIsPullback.hom_comp_left lemma isoIsPullback.hom_comp_right {P P' X Y Z : Type*} [Category P] [Category P'] @@ -553,29 +553,28 @@ lemma isoIsPullback.hom_comp_right {P P' X Y Z : Type*} [Category P] [Category P hom ⋙ snd' = snd := by rw[e] unfold isoIsPullback - simp fapply Functor.ext · intro A - simp only[Functor.assoc,h'.from_west] + simp only [Functor.assoc,h'.from_west] rw[toChosen_west] · intros A B t - simp only[← heq_eq_eq,heq_eqToHom_comp_iff,heq_comp_eqToHom_iff] - rw![Functor.assoc,h'.from_west] - rw[toChosen_west] + simp only [← heq_eq_eq,heq_eqToHom_comp_iff,heq_comp_eqToHom_iff] + rw! [Functor.assoc,h'.from_west] + rw [toChosen_west] -def IsPullbackOfBotId {A A' B : Type*} [Category A] [Category A'] +def ofBotId {A A' B : Type*} [Category A] [Category A'] [Category B] {i : A ≅≅ A'} {F1: A ⥤ B} {F2 : A' ⥤ B} (h' : F1 = i.hom ⋙ F2) : IsPullback i.hom F1 F2 (Functor.id B) := by fapply ofUniversal · aesop · intro C inst Cn Cw h - simp + simp only [Iso.cancel_iso_hom_right, forall_eq', imp_self, implies_true, and_true] have hinv : Cn ⋙ i.inv ⋙ i.hom = Cn ∧ Cn ⋙ i.inv ⋙ F1 = Cw := by aesop_cat exact ⟨ Cn ⋙ i.inv, hinv⟩ · intro C inst Cn Cw h - simp + simp only [Iso.cancel_iso_hom_right, forall_eq', imp_self, implies_true, and_true] have hinv : Cn ⋙ i.inv ⋙ i.hom = Cn ∧ Cn ⋙ i.inv ⋙ F1 = Cw := by aesop_cat exact ⟨ Cn ⋙ i.inv, hinv⟩ diff --git a/HoTTLean/ForMathlib/CategoryTheory/Functor/Iso.lean b/HoTTLean/ForMathlib/CategoryTheory/Functor/Iso.lean index 4cf5eeb2..03a1126f 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Functor/Iso.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Functor/Iso.lean @@ -1,6 +1,8 @@ import Mathlib.CategoryTheory.Functor.Category import Mathlib.CategoryTheory.Category.ULift +universe v u v₁ u₁ v₂ u₂ + namespace CategoryTheory.Functor structure Iso (C D : Type*) [Category C] [Category D] where @@ -321,6 +323,30 @@ def toEquivalence (h : X ≅≅ Y) : X ≌ Y where counitIso := eqToIso h.inv_hom_id functor_unitIso_comp x := by simp [eqToHom_map] +lemma whiskerLeft_inv_hom_heq {C : Type u} [Category.{v} C] {D : Type u₁} + [Category.{v₁} D] {E : Type u₂} [Category.{v₂} E] (F : C ≅≅ D) (G H : D ⥤ E) (η : G ⟶ H) : + (F.inv ⋙ F.hom).whiskerLeft η ≍ η := by + rw [F.inv_hom_id] + aesop_cat + +lemma whiskerLeft_inv_hom {C : Type u} [Category.{v} C] {D : Type u₁} [Category.{v₁} D] + {E : Type u₂} [Category.{v₂} E] (F : C ≅≅ D) (G H : D ⥤ E) (η : G ⟶ H) : + (F.inv ⋙ F.hom).whiskerLeft η = eqToHom (by aesop) ≫ η ≫ eqToHom (by aesop) := by + simpa [← heq_eq_eq] using + whiskerLeft_inv_hom_heq F G H η + +lemma whiskerLeft_hom_inv_heq {C : Type u} [Category.{v} C] {D : Type u₁} + [Category.{v₁} D] {E : Type u₂} [Category.{v₂} E] (F : D ≅≅ C) (G H : D ⥤ E) (η : G ⟶ H) : + (F.hom ⋙ F.inv).whiskerLeft η ≍ η := by + rw [F.hom_inv_id] + aesop_cat + +lemma whiskerLeft_hom_inv {C : Type u} [Category.{v} C] {D : Type u₁} [Category.{v₁} D] + {E : Type u₂} [Category.{v₂} E] (F : D ≅≅ C) (G H : D ⥤ E) (η : G ⟶ H) : + (F.hom ⋙ F.inv).whiskerLeft η = eqToHom (by aesop) ≫ η ≫ eqToHom (by aesop) := by + simpa [← heq_eq_eq] using + whiskerLeft_hom_inv_heq F G H η + end Iso end CategoryTheory.Functor diff --git a/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean b/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean index 9a5023ee..5d3d85cc 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean @@ -203,6 +203,22 @@ lemma Grpd.NatTrans.hext {X X' Y Y' : Grpd.{v,u}} (hX : X = X') (hY : Y = Y') subst hX hY hF hG aesop_cat +lemma Grpd.comp_heq_comp {C C' : Grpd} (hC : C ≍ C') {X Y Z : C} {X' Y' Z' : C'} + (hX : X ≍ X') (hY : Y ≍ Y') (hZ : Z ≍ Z') {f : X ⟶ Y} {f' : X' ⟶ Y'} + {g : Y ⟶ Z} {g' : Y' ⟶ Z'} (hf : f ≍ f') (hg : g ≍ g') : + f ≫ g ≍ f' ≫ g' := by + aesop_cat + +lemma Grpd.inv_heq_of_heq_inv {C C' : Grpd} (hC : C ≍ C') {X Y : C} {X' Y' : C'} + (hX : X ≍ X') (hY : Y ≍ Y') {f : X ⟶ Y} {g : Y' ⟶ X'} (hf : f ≍ inv g) : + inv f ≍ g := by + aesop_cat + +lemma Grpd.inv_heq_inv {C C' : Grpd} (hC : C ≍ C') {X Y : C} {X' Y' : C'} + (hX : X ≍ X') (hY : Y ≍ Y') {f : X ⟶ Y} {f' : X' ⟶ Y'} (hf : f ≍ f') : + inv f ≍ inv f' := by + aesop_cat + end namespace Grpd @@ -224,5 +240,27 @@ def mkIso' {Δ Γ : Type u} [Groupoid.{v} Δ] [Groupoid.{v} Γ] (F : Δ ≅≅ hom_inv_id := by simp inv_hom_id := by simp +open MonoidalCategory + +instance {X : Type} : Groupoid (Codiscrete X) where + inv f := ⟨⟩ + inv_comp := by aesop + comp_inv := by aesop + +def Interval : Grpd := Grpd.of $ AsSmall $ Codiscrete Bool + +def δ0 : 𝟙_ Grpd ⟶ Interval where + obj X := ⟨⟨.false⟩⟩ + map _ := ⟨⟨⟩⟩ + map_id := by aesop + map_comp := by aesop + +def δ1 : 𝟙_ Grpd ⟶ Interval where + obj X := ⟨⟨.true⟩⟩ + map _ := ⟨⟨⟩⟩ + map_id := by aesop + map_comp := by aesop + end Grpd + end CategoryTheory diff --git a/HoTTLean/ForMathlib/CategoryTheory/Limits/Shapes/Pullback/CommSq.lean b/HoTTLean/ForMathlib/CategoryTheory/Limits/Shapes/Pullback/CommSq.lean new file mode 100644 index 00000000..289f5fe1 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Limits/Shapes/Pullback/CommSq.lean @@ -0,0 +1,16 @@ +import Mathlib.CategoryTheory.Limits.Shapes.Pullback.HasPullback +import Mathlib.CategoryTheory.Limits.Shapes.Pullback.CommSq + +noncomputable section + +open CategoryTheory + +universe w v₁ v₂ v u u₂ + +namespace CategoryTheory.Limits + +variable {C : Type u} [Category.{v} C] {W X Y Z : C} + +instance {X : C} : HasPullbacksAlong (𝟙 X) := by + intro W h + exact IsPullback.hasPullback (IsPullback.id_horiz h) diff --git a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean new file mode 100644 index 00000000..7a6210e5 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2022 Andrew Yang. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Andrew Yang, Joël Riou +-/ +import Mathlib.CategoryTheory.MorphismProperty.Limits + +/-! +# Relation of morphism properties with limits + +The following predicates are introduces for morphism properties `P`: +* `IsStableUnderBaseChange`: `P` is stable under base change if in all pullback + squares, the left map satisfies `P` if the right map satisfies it. +* `IsStableUnderCobaseChange`: `P` is stable under cobase change if in all pushout + squares, the right map satisfies `P` if the left map satisfies it. + +We define `P.universally` for the class of morphisms which satisfy `P` after any base change. + +We also introduce properties `IsStableUnderProductsOfShape`, `IsStableUnderLimitsOfShape`, +`IsStableUnderFiniteProducts`, and similar properties for colimits and coproducts. + +-/ + +universe w w' v u + +namespace CategoryTheory + +open Category Limits + +namespace MorphismProperty + +variable {C : Type u} [Category.{v} C] + +section + +variable (P : MorphismProperty C) + +/-- `P.HasPullbacksAlong f` states that for any morphism satifying `P` with the same codomain +as `f`, the pullback of that morphism along `f` exists. -/ +protected class HasPullbacksAlong {X Y : C} (f : X ⟶ Y) : Prop where + hasPullback {W} (g : W ⟶ Y) : P g → HasPullback g f + +instance {X Y : C} (f : X ⟶ Y) [HasPullbacksAlong f] : P.HasPullbacksAlong f where + hasPullback := inferInstance + +variable {P} + +theorem baseChange_map' [IsStableUnderBaseChange P] {S S' X Y : C} (f : S' ⟶ S) + {v₁₂ : X ⟶ S} {v₂₂ : Y ⟶ S} {g : X ⟶ Y} (hv₁₂ : v₁₂ = g ≫ v₂₂) [HasPullback v₁₂ f] + [HasPullback v₂₂ f] (H : P g) : P (pullback.lift (f := v₂₂) (g := f) (pullback.fst v₁₂ f ≫ g) + (pullback.snd v₁₂ f) (by simp [pullback.condition, ← hv₁₂])) := by + subst hv₁₂ + refine of_isPullback (f' := pullback.fst (g ≫ v₂₂) f) + (f := pullback.fst v₂₂ f) ?_ H + refine IsPullback.of_bot ?_ (by simp) (IsPullback.of_hasPullback v₂₂ f) + simpa using IsPullback.of_hasPullback (g ≫ v₂₂) f + +local instance {S X Y : C} {f : X ⟶ S} [HasPullbacksAlong f] {g : Y ⟶ S} : + HasPullback f g := hasPullback_symmetry g f + +instance [P.HasPullbacks] {X Y : C} {f : X ⟶ Y} : P.HasPullbacksAlong f where + hasPullback _ := hasPullback _ + +instance [P.IsStableUnderBaseChange] {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) + [P.HasPullbacksAlong f] [P.HasPullbacksAlong g] : P.HasPullbacksAlong (f ≫ g) where + hasPullback h p := + have : HasPullback h g := HasPullbacksAlong.hasPullback h p + have : HasPullback (pullback.snd h g) f := HasPullbacksAlong.hasPullback (pullback.snd h g) + (P.pullback_snd h g p) + IsPullback.hasPullback (IsPullback.paste_horiz (IsPullback.of_hasPullback + (pullback.snd h g) f) (IsPullback.of_hasPullback h g)) + +/-- A morphism property satisfies `HasObjects` when any map `! : X ⟶ Y` to a terminal +object `Y` satisfies the morphism property. -/ +class HasObjects (P : MorphismProperty C) : Prop where + obj_mem {X Y} (f : X ⟶ Y) : Limits.IsTerminal Y → P f + +end + +end MorphismProperty + +end CategoryTheory diff --git a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean new file mode 100644 index 00000000..657b3320 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean @@ -0,0 +1,495 @@ +/- +Copyright (c) 2024 Christian Merten. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Merten +-/ +import Mathlib.CategoryTheory.MorphismProperty.Comma +import HoTTLean.ForMathlib.CategoryTheory.MorphismProperty.Limits +import HoTTLean.ForMathlib.CategoryTheory.Comma.Over.Pushforward + +/-! +# Adjunction of pushforward and pullback in `P.Over Q X` + +Under suitable assumptions on `P`, `Q` and `f`, +a morphism `f : X ⟶ Y` defines two functors: + +- `Over.map`: post-composition with `f` +- `Over.pullback`: base-change along `f` + +such that `Over.map` is the left adjoint to `Over.pullback`. +-/ + +namespace CategoryTheory.MorphismProperty + +open Limits + +variable {T : Type*} [Category T] (P Q : MorphismProperty T) +variable {X Y Z : T} + +section Map + +lemma Over.forget_preimage {S} {X Y : P.Over ⊤ S} (g : X.toComma ⟶ Y.toComma) : + (Functor.FullyFaithful.ofFullyFaithful (Over.forget P ⊤ S)).preimage g = + Over.homMk g.left := by + simp [Functor.FullyFaithful.ofFullyFaithful] + apply (Over.forget P ⊤ S).map_injective + rw [Functor.map_preimage] + simp + +variable {P} [P.IsStableUnderComposition] [Q.IsMultiplicative] + +/-- If `P` is stable under composition and `f : X ⟶ Y` satisfies `P`, +this is the functor `P.Over Q X ⥤ P.Over Q Y` given by composing with `f`. -/ +@[simps! obj_left obj_hom map_left] +def Over.map {f : X ⟶ Y} (hPf : P f) : P.Over Q X ⥤ P.Over Q Y := + Comma.mapRight _ (Discrete.natTrans fun _ ↦ f) <| fun X ↦ P.comp_mem _ _ X.prop hPf + +lemma Over.map_comp {f : X ⟶ Y} (hf : P f) {g : Y ⟶ Z} (hg : P g) : + map Q (P.comp_mem f g hf hg) = map Q hf ⋙ map Q hg := by + fapply Functor.ext + · simp [map, Comma.mapRight, CategoryTheory.Comma.mapRight, Comma.lift] + · intro U V k + ext + simp + +/-- `Over.map` commutes with composition. -/ +@[simps! hom_app_left inv_app_left] +def Over.mapComp {f : X ⟶ Y} (hf : P f) {g : Y ⟶ Z} (hg : P g) [Q.RespectsIso] : + map Q (P.comp_mem f g hf hg) ≅ map Q hf ⋙ map Q hg := + NatIso.ofComponents (fun X ↦ Over.isoMk (Iso.refl _)) + +end Map + +section Pullback + +/-- A morphism property is `IsStableUnderBaseChangeAlong f` if the base change along `f` of such +a morphism still falls in the class. -/ +class IsStableUnderBaseChangeAlong {X S : T} (f : X ⟶ S) : Prop where + of_isPullback {Y Y' : T} {g : Y ⟶ S} {f' : Y' ⟶ Y} {g' : Y' ⟶ X} + (pb : IsPullback f' g' g f) (hg : P g) : P g' + +instance [P.IsStableUnderBaseChange] {X S : T} (f : X ⟶ S) : P.IsStableUnderBaseChangeAlong f where + of_isPullback := P.of_isPullback + +variable [Q.IsStableUnderBaseChange] [Q.IsMultiplicative] (f : X ⟶ Y) [P.HasPullbacksAlong f] + [P.IsStableUnderBaseChangeAlong f] + +instance (A : P.Over Q Y) : HasPullback A.hom f := + HasPullbacksAlong.hasPullback A.hom A.prop + +instance {X Y Z} (f : X ⟶ Y) (g : Y ⟶ Z) [P.HasPullbacksAlong f] + [P.IsStableUnderBaseChangeAlong g] [P.HasPullbacksAlong g] : P.HasPullbacksAlong (f ≫ g) where + hasPullback p hp := + have := HasPullbacksAlong.hasPullback (f := g) p hp + have right := IsPullback.of_hasPullback p g + have := HasPullbacksAlong.hasPullback (f := f) (pullback.snd p g) + (IsStableUnderBaseChangeAlong.of_isPullback right hp) + (IsPullback.paste_horiz (IsPullback.of_hasPullback (pullback.snd p g) f) right).hasPullback + +instance {X Y Z} (f : X ⟶ Y) (g : Y ⟶ Z) [P.IsStableUnderBaseChangeAlong f] + [P.IsStableUnderBaseChangeAlong g] [P.HasPullbacksAlong g] : + P.IsStableUnderBaseChangeAlong (f ≫ g) where + of_isPullback {_ _ p _ _} pb hp := + have := HasPullbacksAlong.hasPullback (f := g) p hp + have right := IsPullback.of_hasPullback p g + IsStableUnderBaseChangeAlong.of_isPullback (IsPullback.of_right' pb right) + (IsStableUnderBaseChangeAlong.of_isPullback right hp) + +instance {X Y Z} (f : X ⟶ Y) (g : Y ⟶ Z) [P.HasPullbacksAlong f] + [P.IsStableUnderBaseChangeAlong f] [P.HasPullbacksAlong g] [P.IsStableUnderBaseChangeAlong g] + (A : P.Over Q Z) : HasPullback (pullback.snd A.hom g) f := + HasPullbacksAlong.hasPullback (pullback.snd A.hom g) + (IsStableUnderBaseChangeAlong.of_isPullback (IsPullback.of_hasPullback A.hom g) A.prop) + +/-- If `P` and `Q` are stable under base change and pullbacks along `f` exist for morphisms in `P`, +this is the functor `P.Over Q Y ⥤ P.Over Q X` given by base change along `f`. -/ +@[simps! obj_left obj_hom map_left] +noncomputable def Over.pullback : + P.Over Q Y ⥤ P.Over Q X where + obj A := Over.mk Q (Limits.pullback.snd A.hom f) + (IsStableUnderBaseChangeAlong.of_isPullback (IsPullback.of_hasPullback A.hom f) A.prop) + map {A B} g := Over.homMk (pullback.lift (pullback.fst A.hom f ≫ g.left) + (pullback.snd A.hom f) (by simp [pullback.condition])) (by simp) + (baseChange_map' _ _ g.prop_hom_left) + +variable {P} {Q} (f : X ⟶ Y) [P.HasPullbacksAlong f] [P.IsStableUnderBaseChangeAlong f] + (g : Y ⟶ Z) [P.HasPullbacksAlong g] [P.IsStableUnderBaseChangeAlong g] + +/-- `Over.pullback` commutes with composition. -/ +@[simps! hom_app_left inv_app_left] +noncomputable def Over.pullbackComp [Q.RespectsIso] : + Over.pullback P Q (f ≫ g) ≅ + Over.pullback P Q g ⋙ Over.pullback P Q f := + NatIso.ofComponents + (fun X ↦ Over.isoMk ((pullbackLeftPullbackSndIso X.hom g f).symm) (by simp)) + +lemma Over.pullbackComp_left_fst_fst (A : P.Over Q Z) : + ((Over.pullbackComp f g).hom.app A).left ≫ pullback.fst (pullback.snd A.hom g) f ≫ + pullback.fst A.hom g = pullback.fst A.hom (f ≫ g) := by + simp + +variable {f} {g} + +/-- If `f = g`, then base change along `f` is naturally isomorphic to base change along `g`. -/ +@[simps!] +noncomputable def Over.pullbackCongr {g : X ⟶ Y} (h : f = g) : + have : P.HasPullbacksAlong g := by subst h; infer_instance + have : P.IsStableUnderBaseChangeAlong g := by subst h; infer_instance + Over.pullback P Q f ≅ Over.pullback P Q g := + have : P.HasPullbacksAlong g := by subst h; infer_instance + NatIso.ofComponents (fun _ ↦ Over.isoMk (pullback.congrHom rfl h)) + +end Pullback + +section Adjunction + +variable {P Q} [P.IsStableUnderComposition] [Q.IsMultiplicative] [Q.IsStableUnderBaseChange] + +/-- `P.Over.map` is left adjoint to `P.Over.pullback` if `f` satisfies `P` and `Q`. -/ +@[simps!] +noncomputable def Over.mapPullbackAdjHomEquiv (f : X ⟶ Y) [P.HasPullbacksAlong f] + [P.IsStableUnderBaseChangeAlong f] [Q.HasOfPostcompProperty Q] (hPf : P f) (hQf : Q f) + (A : P.Over Q X) (B : P.Over Q Y) : ((map Q hPf).obj A ⟶ B) ≃ (A ⟶ (pullback P Q f).obj B) := + { toFun g := Over.homMk (pullback.lift g.left A.hom <| by simp) (by simp) <| by + apply Q.of_postcomp (W' := Q) + · exact Q.pullback_fst B.hom f hQf + · simpa using g.prop_hom_left + invFun h := Over.homMk (h.left ≫ pullback.fst B.hom f) (by + simp only [map_obj_left, Functor.const_obj_obj, pullback_obj_left, Functor.id_obj, + Category.assoc, pullback.condition, map_obj_hom, ← pullback_obj_hom, Over.w_assoc]) + (Q.comp_mem _ _ h.prop_hom_left (Q.pullback_fst _ _ hQf)) + left_inv := by cat_disch + right_inv h := by + ext + dsimp + ext + · simp + · simpa using h.w.symm } + +/-- `P.Over.map` is left adjoint to `P.Over.pullback` if `f` satisfies `P` and `Q`. -/ +noncomputable def Over.mapPullbackAdj (f : X ⟶ Y) [P.HasPullbacksAlong f] + [P.IsStableUnderBaseChangeAlong f] [Q.HasOfPostcompProperty Q] (hPf : P f) (hQf : Q f) : + Over.map Q hPf ⊣ Over.pullback P Q f := + Adjunction.mkOfHomEquiv + { homEquiv A B := Over.mapPullbackAdjHomEquiv f hPf hQf A B } + +variable (f : X ⟶ Y) [P.HasPullbacksAlong f] [P.IsStableUnderBaseChangeAlong f] + [Q.HasOfPostcompProperty Q] (hPf : P f) (hQf : Q f) + (A : P.Over Q X) (B : P.Over Q Y) + +@[simp] +lemma Over.mapPullbackAdj_homEquiv_apply_left (g : (map Q hPf).obj A ⟶ B) : + ((Over.mapPullbackAdj f hPf hQf).homEquiv A B g).left = + pullback.lift g.left A.hom (by cat_disch) := by + simp [mapPullbackAdj] + +@[simp] +lemma Over.mapPullbackAdj_homEquiv_symm_apply_left (g) : + (((Over.mapPullbackAdj f hPf hQf).homEquiv A B).symm g).left = + g.left ≫ pullback.fst B.hom f := by + simp [mapPullbackAdj] + +@[simp] +lemma Over.mapPullbackAdj_unit_app_left (A) : ((Over.mapPullbackAdj f hPf hQf).unit.app A).left = + pullback.lift (𝟙 A.left) A.hom (by cat_disch) := + rfl + +@[simp] +lemma Over.mapPullbackAdj_counit_app_left (A) : ((Over.mapPullbackAdj f hPf hQf).counit.app A).left = + pullback.fst A.hom f := by + simp [mapPullbackAdj] + +end Adjunction + +/-- Pushforward along a morphism `f` (for which all pullbacks exist) exists relative to `P` +when pushforwards exist along `f` for all morphisms satisfying `P`. -/ +protected class HasPushforwardsAlong {S S' : T} (f : S ⟶ S') [hpb : HasPullbacksAlong f] where + hasPushforward : ∀ {W} (h : W ⟶ S), P h → HasPushforward f (.mk h) + +lemma hasPullbacksAlong_of_hasPullbacks {Q : MorphismProperty T} [Q.HasPullbacks] + {S S' : T} {q : S ⟶ S'} (hq : Q q) : HasPullbacksAlong q := + fun h => have := (Q.hasPullback h hq); hasPullback_symmetry q h + +variable {P Q} in +lemma hasPullbacksAlong_of_hasPullbacks' [Q.HasPullbacks] {S S' : T} {f : S ⟶ S'} (hf : Q f) : + P.HasPullbacksAlong f where + hasPullback g _ := hasPullbacksAlong_of_hasPullbacks hf g + +/-- Morphisms satisfying `P` have pushforwards along morphisms satisfying `Q`. +We require that `[H.HasPullbacks]` so that we can define the universal property of +pushforward along `p` relative to the pullback. +-/ +protected class HasPushforwards [Q.HasPullbacks] : Prop where + hasPushforwardsAlong : ∀ {S S' : T} (q : S ⟶ S') (hq : Q q), + have : HasPullbacksAlong q := hasPullbacksAlong_of_hasPullbacks hq + P.HasPushforwardsAlong q + +/-- Morphisms satisfying `P` are stable under pushforward along morphism `f` +if whenever pushforward along `f` exists it is in `P`. -/ +class IsStableUnderPushforwardsAlong {S S' : T} (q : S ⟶ S') [HasPullbacksAlong q] : Prop where + of_isPushforward {X Y : T} (f : X ⟶ S) (hf : P f) {g : Y ⟶ S'} + (isPushforward : IsPushforward q (.mk f) (.mk g)) : P g + +lemma IsStableUnderPushforwardsAlong.of_respectsIso [P.RespectsIso] {S S' : T} (q : S ⟶ S') + [HasPullbacksAlong q] (g : {X : T} → (f : X ⟶ S) → P f → Over S') + (pg : {X : T} → (f : X ⟶ S) → (pf : P f) → P (g f pf).hom) + (isPushforward : {X : T} → (f : X ⟶ S) → (pf : P f) → IsPushforward q (.mk f) (g f pf)) : + P.IsStableUnderPushforwardsAlong q where + of_isPushforward f pf g' isPushforward' := + have : g' = ((isPushforward f pf).uniqueUpToIso isPushforward').inv.left ≫ (g f pf).hom := + by cat_disch + this ▸ RespectsIso.precomp _ _ _ (pg ..) + +-- lemma IsStableUnderPushforwardsAlong.of_isLeftAdjoint [P.RespectsIso] {S S' : T} (q : S ⟶ S') +-- [HasPullbacksAlong q] [P.IsStableUnderBaseChangeAlong q] +-- [isLeftAdjoint : (Over.pullback P ⊤ q).IsLeftAdjoint] : +-- P.IsStableUnderPushforwardsAlong q where +-- of_isPushforward {X Y} f pf g isPushforward := +-- -- have : ((Over.pullback P ⊤ q).op ⋙ yoneda.obj (Over.mk ⊤ f pf)).RepresentableBy (Over.mk ⊤ g ) := sorry +-- -- have h := isPushforward.uniqueUpToIso +-- let i : CategoryTheory.Over.mk g ≅ +-- ((Over.pullback P ⊤ q).rightAdjoint.obj (Over.mk ⊤ f pf)).toComma := +-- sorry +-- have : g = i.hom.left ≫ ((Over.pullback P ⊤ q).rightAdjoint.obj (Over.mk ⊤ f pf)).hom := +-- sorry +-- this ▸ RespectsIso.precomp _ _ _ (Comma.prop ..) + +/-- Morphisms satisfying `P` are stable under pushforward along morphisms satisfying `Q` +if whenever pushforward along a morphism in `Q` exists it is in `P`. -/ +class IsStableUnderPushforwards [Q.HasPullbacks] : Prop where + of_isPushforward {S S' : T} (q : S ⟶ S') (hq : Q q) : + have : HasPullbacksAlong q := hasPullbacksAlong_of_hasPullbacks hq + IsStableUnderPushforwardsAlong P q + +noncomputable section + +abbrev pushforwardPartial.lift {S S' : T} (q : S ⟶ S') + [HasPullbacksAlong q] [P.HasPushforwardsAlong q] : + P.Over ⊤ S ⥤ (CategoryTheory.Over.pullback q).PartialRightAdjointSource := + ObjectProperty.lift _ (Over.forget P ⊤ S) + (fun X => HasPushforwardsAlong.hasPushforward X.hom X.prop) + +/-- If `P` has pushforwards along `q` then there is a partial left adjoint `P.Over ⊤ S ⥤ Over S'` +of the pullback functor `pullback q : Over S' ⥤ Over S`. +-/ +noncomputable def pushforwardPartial {S S' : T} (q : S ⟶ S') [HasPullbacksAlong q] + [P.HasPushforwardsAlong q] : P.Over ⊤ S ⥤ Over S' := + pushforwardPartial.lift P q ⋙ (CategoryTheory.Over.pullback q).partialRightAdjoint + +/-- When `P` has pushforwards along `Q` and is stable under pushforwards along `Q`, +the pushforward functor along any morphism `q` satisfying `Q` can be defined. -/ +noncomputable def pushforward {S S' : T} (q : S ⟶ S') [HasPullbacksAlong q] + [P.HasPushforwardsAlong q] [P.IsStableUnderPushforwardsAlong q] : + P.Over ⊤ S ⥤ P.Over ⊤ S' := + Comma.lift (pushforwardPartial P q) (fun X => + IsStableUnderPushforwardsAlong.of_isPushforward (q := q) X.hom X.prop + ((have : HasPushforward q X.toComma := HasPushforwardsAlong.hasPushforward _ X.prop + pushforward.isPushforward q (X.toComma)))) + (by simp) (by simp) + +def pushforwardCompForget {S S' : T} (q : S ⟶ S') [HasPullbacksAlong q] + [P.HasPushforwardsAlong q] [P.IsStableUnderPushforwardsAlong q] : + pushforward P q ⋙ Over.forget _ _ _ ≅ pushforwardPartial P q := + Iso.refl _ + +section homEquiv + +variable {P} {S S' : T} {q : S ⟶ S'} [HasPullbacksAlong q] + [P.HasPushforwardsAlong q] [P.IsStableUnderPushforwardsAlong q] + +/-- The pushforward functor is a partial right adjoint to pullback in the sense that +there is a natural bijection of hom-sets `T / S (pullback q X, Y) ≃ T / S' (X, pushforward q Y)`. -/ +def pushforward.homEquiv {X : Over S'} {Y : P.Over ⊤ S} : + (X ⟶ ((pushforward P q).obj Y).toComma) ≃ + ((CategoryTheory.Over.pullback q).obj X ⟶ Y.toComma) := + Functor.partialRightAdjointHomEquiv .. + +@[reassoc] +lemma pushforward.homEquiv_comp {X X' : Over S'} {Y : P.Over ⊤ S} + (f : X' ⟶ ((pushforward P q).obj Y).toComma) (g : X ⟶ X') : + pushforward.homEquiv (g ≫ f) = + (CategoryTheory.Over.pullback q).map g ≫ homEquiv f := + Functor.partialRightAdjointHomEquiv_comp .. + +@[reassoc] +lemma pushforward.homEquiv_map_comp {X : Over S'} {Y Y' : P.Over ⊤ S} + (f : X ⟶ ((pushforward P q).obj Y).toComma) (g : Y ⟶ Y') : + homEquiv (f ≫ Comma.Hom.hom ((P.pushforward q).map g)) = + homEquiv f ≫ Comma.Hom.hom g := + Functor.partialRightAdjointHomEquiv_map_comp .. + +@[reassoc] +lemma pushforward.homEquiv_symm_comp {X : Over S'} {Y Y' : P.Over ⊤ S} + (f : (CategoryTheory.Over.pullback q).obj X ⟶ Y.toComma) (g : Y ⟶ Y') : + homEquiv.symm f ≫ Comma.Hom.hom ((P.pushforward q).map g) = + homEquiv.symm (f ≫ Comma.Hom.hom g) := + Functor.partialRightAdjointHomEquiv_symm_comp .. + +@[reassoc] +lemma pushforward.homEquiv_comp_symm {X X' : Over S'} {Y : P.Over ⊤ S} + (f : (CategoryTheory.Over.pullback q).obj X' ⟶ Y.toComma) (g : X ⟶ X') : + g ≫ homEquiv.symm f = + homEquiv.symm ((CategoryTheory.Over.pullback q).map g ≫ f) := + Functor.partialRightAdjointHomEquiv_comp_symm .. + +def pushforward.homIso : Over.forget P ⊤ S ⋙ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj + (CategoryTheory.Over.pullback q).op ≅ P.pushforward q ⋙ Over.forget P ⊤ S' ⋙ yoneda := + (NatIso.ofComponents + (fun Y => NatIso.ofComponents (fun X => homEquiv.toIso) + (fun {X Y} f => by ext; simp [homEquiv_comp])) + (fun {X Y} f => by ext; simp [homEquiv_map_comp])).symm + +end homEquiv + +section + +open MorphismProperty.Over + +variable {P} [P.IsStableUnderBaseChange] {S S' : T} {f : S ⟶ S'} + [HasPullbacksAlong f] [P.HasPushforwardsAlong f] [P.IsStableUnderPushforwardsAlong f] + +instance : P.HasPullbacksAlong f where + hasPullback := inferInstance + +def pullbackPushforwardAdjunctionHomEquiv (X : P.Over ⊤ S') (Y : P.Over ⊤ S) : + ((Over.pullback P ⊤ f).obj X ⟶ Y) ≃ (X ⟶ (P.pushforward f).obj Y) := + calc ((pullback P ⊤ f).obj X ⟶ Y) + _ ≃ (((pullback P ⊤ f).obj X).toComma ⟶ Y.toComma) := + (Functor.FullyFaithful.ofFullyFaithful (Over.forget P ⊤ S)).homEquiv + _ ≃ (X.toComma ⟶ ((P.pushforward f).obj Y).toComma) := + pushforward.homEquiv.symm + _ ≃ _ := Iso.homCongr (Iso.refl X.toComma) (by exact Iso.refl _) + _ ≃ (X ⟶ (P.pushforward f).obj Y) := + (Functor.FullyFaithful.ofFullyFaithful (Over.forget P ⊤ S')).homEquiv.symm + +@[simp] +lemma pullbackPushforwardAdjunctionHomEquiv_apply {X : P.Over ⊤ S'} {Y : P.Over ⊤ S} + (g : (Over.pullback P ⊤ f).obj X ⟶ Y) : + (pullbackPushforwardAdjunctionHomEquiv X Y g).toCommaMorphism = + pushforward.homEquiv.symm (Comma.Hom.hom g) := by + simp only [pullbackPushforwardAdjunctionHomEquiv, Trans.trans, Comma.forget_obj, + Equiv.trans_apply, Iso.homCongr_apply, Iso.refl_inv, Iso.refl_hom, Category.comp_id, + Category.id_comp] + erw [Functor.FullyFaithful.homEquiv_apply, Functor.FullyFaithful.homEquiv_symm_apply] + simp [Over.forget_preimage] + rfl + +@[simp] +lemma pullbackPushforwardAdjunctionHomEquiv_symm_apply {X : P.Over ⊤ S'} {Y : P.Over ⊤ S} + (g : X ⟶ (P.pushforward f).obj Y) : + ((pullbackPushforwardAdjunctionHomEquiv X Y).symm g).toCommaMorphism = + pushforward.homEquiv (Comma.Hom.hom g) := by + simp only [pullbackPushforwardAdjunctionHomEquiv, Trans.trans, Comma.forget_obj, + Equiv.symm_trans_apply, Equiv.symm_symm, Iso.homCongr_symm, Iso.refl_symm, Iso.homCongr_apply, + Iso.refl_inv, Iso.refl_hom, Category.comp_id, Category.id_comp] + erw [Functor.FullyFaithful.homEquiv_apply, Functor.FullyFaithful.homEquiv_symm_apply] + simp [Over.forget_preimage] + rfl + +variable (P) (f) in +/-- The `pullback ⊣ pushforward` adjunction. -/ +def pullbackPushforwardAdjunction : Over.pullback P ⊤ f ⊣ pushforward P f := + Adjunction.mkOfHomEquiv { + homEquiv X Y := pullbackPushforwardAdjunctionHomEquiv X Y + homEquiv_naturality_left_symm g₁ g₂ := by + ext + simp only [pullback_obj_left, pullbackPushforwardAdjunctionHomEquiv_symm_apply, + Comma.comp_hom, CategoryTheory.Comma.comp_left, pullback_map_left] + rw [pushforward.homEquiv_comp] + simp + homEquiv_naturality_right g₁ g₂ := by + ext + simp only [pullbackPushforwardAdjunctionHomEquiv_apply, Comma.comp_hom, + CategoryTheory.Comma.comp_left] + convert_to _ = ((pushforward.homEquiv.symm (Comma.Hom.hom g₁)) ≫ + (Comma.Hom.hom ((P.pushforward f).map g₂))).left + rw [pushforward.homEquiv_symm_comp] } + +@[simp] +lemma pullbackPushforwardAdjunction_apply {X : P.Over ⊤ S'} {Y : P.Over ⊤ S} + (g : (Over.pullback P ⊤ f).obj X ⟶ Y) : + ((pullbackPushforwardAdjunction P f).homEquiv X Y g).toCommaMorphism = + pushforward.homEquiv.symm (Comma.Hom.hom g) := by + simp [pullbackPushforwardAdjunction, pullbackPushforwardAdjunctionHomEquiv_apply] + +@[simp] +lemma pullbackPushforwardAdjunction_symm_apply {X : P.Over ⊤ S'} {Y : P.Over ⊤ S} + (g : X ⟶ (P.pushforward f).obj Y) : + (((pullbackPushforwardAdjunction P f).homEquiv X Y).symm g).toCommaMorphism = + pushforward.homEquiv (Comma.Hom.hom g) := by + simp [pullbackPushforwardAdjunction, pullbackPushforwardAdjunctionHomEquiv_symm_apply] + +@[simp] +lemma pullbackPushforwardAdjunction_unit_app_toCommaMorphism {X : P.Over ⊤ S'} : + ((pullbackPushforwardAdjunction P f).unit.app X).toCommaMorphism = + pushforward.homEquiv.symm (𝟙 ((Over.pullback P ⊤ f).obj X).toComma) := by + simp [pullbackPushforwardAdjunction, pullbackPushforwardAdjunctionHomEquiv_apply] + +@[simp] +lemma pullbackPushforwardAdjunction_counit_app_toCommaMorphism {Y : P.Over ⊤ S} : + ((pullbackPushforwardAdjunction P f).counit.app Y).toCommaMorphism = + pushforward.homEquiv (𝟙 ((P.pushforward f).obj Y).toComma) := by + simp [pullbackPushforwardAdjunction, pullbackPushforwardAdjunctionHomEquiv_symm_apply] + +instance : (pullback P ⊤ f).IsLeftAdjoint := + Adjunction.isLeftAdjoint (pullbackPushforwardAdjunction P f) + +instance : (pushforward P f).IsRightAdjoint := + Adjunction.isRightAdjoint (pullbackPushforwardAdjunction P f) + +end + +section homEquiv + +variable {P} [P.HasPullbacks] [P.IsStableUnderBaseChange] {S S' : T} (i : S ⟶ S') + +/-- `MorphismProperty.Over.pullback P ⊤ f` is a partial right adjoint to `Over.map f`. -/ +@[simps!] +def pullback.homEquiv {X : Over S} {Y : P.Over ⊤ S'} : + (X ⟶ ((Over.pullback P ⊤ i).obj Y).toComma) ≃ + ((CategoryTheory.Over.map i).obj X ⟶ Y.toComma) where + toFun v := CategoryTheory.Over.homMk (v.left ≫ pullback.fst _ _) <| by + simp only [Category.assoc, pullback.condition, + CategoryTheory.Over.map_obj_hom] + erw [← CategoryTheory.Over.w v] + simp + invFun u := CategoryTheory.Over.homMk (pullback.lift u.left X.hom <| by simp) + left_inv v := by + ext; dsimp; ext + · simp + · simpa using (CategoryTheory.Over.w v).symm + right_inv u := by cat_disch + +lemma pullback.homEquiv_comp {X X' : Over S} {Y : P.Over ⊤ S'} + (f : X' ⟶ ((Over.pullback P ⊤ i).obj Y).toComma) (g : X ⟶ X') : + homEquiv i (g ≫ f) = + (CategoryTheory.Over.map i).map g ≫ homEquiv i f := by + ext; simp + +lemma pullback.homEquiv_map_comp {X : Over S} {Y Y' : P.Over ⊤ S'} + (f : X ⟶ ((Over.pullback P ⊤ i).obj Y).toComma) (g : Y ⟶ Y') : + homEquiv i (f ≫ Comma.Hom.hom ((Over.pullback P ⊤ i).map g)) = + homEquiv i f ≫ Comma.Hom.hom g := by + ext; simp + +lemma pullback.homEquiv_symm_comp {X : Over S} {Y Y' : P.Over ⊤ S'} + (f : (CategoryTheory.Over.map i).obj X ⟶ Y.toComma) (g : Y ⟶ Y') : + (homEquiv i).symm f ≫ Comma.Hom.hom ((Over.pullback P ⊤ i).map g) = + (homEquiv i).symm (f ≫ Comma.Hom.hom g) := by + ext; dsimp; ext + · simp + · simp + +lemma pullback.comp_homEquiv_symm {X X' : Over S} {Y : P.Over ⊤ S'} + (f : (CategoryTheory.Over.map i).obj X' ⟶ Y.toComma) (g : X ⟶ X') : + g ≫ (homEquiv i).symm f = + (homEquiv i).symm ((CategoryTheory.Over.map i).map g ≫ f) := by + ext; dsimp; ext + · simp + · simp + +end homEquiv + +end + +end CategoryTheory.MorphismProperty diff --git a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/WideSubcategory.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/WideSubcategory.lean new file mode 100644 index 00000000..d9792de1 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/WideSubcategory.lean @@ -0,0 +1,152 @@ +/- +Copyright (c) 2024 Sina Hazratpour. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sina Hazratpour, Joseph Hua +-/ +import Mathlib.CategoryTheory.Functor.FullyFaithful +import Mathlib.CategoryTheory.MorphismProperty.Composition + +/-! +# Wide subcategories + +A wide subcategory of a category `C` is a subcategory containing all the objects of `C`. + +## Main declarations + +Given a category `D`, a function `F : C → D` from a type `C` to the objects of `D`, +and a morphism property `P` on `D` which contains identities and is stable under +composition, the type class `InducedWideCategory D F P` is a typeclass +synonym for `C` which comes equipped with a category structure whose morphisms `X ⟶ Y` are the +morphisms in `D` which have the property `P`. + +The instance `WideSubcategory.category` provides a category structure on `WideSubcategory P` +whose objects are the objects of `C` and morphisms are the morphisms in `C` which have the +property `P`. +-/ + +namespace CategoryTheory + +universe v₁ v₂ u₁ u₂ + +namespace MorphismProperty + +section Induced + +variable {C : Type u₁} (D : Type u₂) [Category.{v₁} D] +variable (F : C → D) (P : MorphismProperty D) [P.IsMultiplicative] + +/-- `InducedWideCategory D F P`, where `F : C → D`, is a typeclass synonym for `C`, +which provides a category structure so that the morphisms `X ⟶ Y` are the morphisms +in `D` from `F X` to `F Y` which satisfy a property `P : MorphismProperty D` that is multiplicative. +-/ +@[nolint unusedArguments] +def InducedWideCategory (_F : C → D) (_P : MorphismProperty D) [IsMultiplicative _P] := + C + +variable {D} + +instance InducedWideCategory.hasCoeToSort {α : Sort*} [CoeSort D α] : + CoeSort (InducedWideCategory D F P) α := + ⟨fun c => F c⟩ + +@[simps!] +instance InducedWideCategory.category : + Category (InducedWideCategory D F P) where + Hom X Y := {f : F X ⟶ F Y | P f} + id X := ⟨𝟙 (F X), P.id_mem (F X)⟩ + comp {_ _ _} f g := ⟨f.1 ≫ g.1, P.comp_mem _ _ f.2 g.2⟩ + +/-- The forgetful functor from an induced wide category to the original category. -/ +@[simps] +def wideInducedFunctor : InducedWideCategory D F P ⥤ D where + obj := F + map {_ _} f := f.1 + +/-- The induced functor `wideInducedFunctor F P : InducedWideCategory D F P ⥤ D` +is faithful. -/ +instance InducedWideCategory.faithful : (wideInducedFunctor F P).Faithful where + map_injective {X Y} f g eq := by + cases f + cases g + aesop + +end Induced + +section WideSubcategory + +variable {C : Type u₁} [Category.{v₁} C] +variable (P : MorphismProperty C) [IsMultiplicative P] + +/-- +Structure for wide subcategories. Objects ignore the morphism property. +-/ +@[ext, nolint unusedArguments] +structure WideSubcategory (_P : MorphismProperty C) [IsMultiplicative _P] where + /-- The category of which this is a wide subcategory -/ + obj : C + +instance WideSubcategory.category : Category.{v₁} (WideSubcategory P) := + InducedWideCategory.category WideSubcategory.obj P + +@[simp] +lemma WideSubcategory.id_def (X : WideSubcategory P) : (CategoryStruct.id X).1 = 𝟙 X.obj := rfl + +@[simp] +lemma WideSubcategory.comp_def {X Y Z : WideSubcategory P} (f : X ⟶ Y) (g : Y ⟶ Z) : + (f ≫ g).1 = (f.1 ≫ g.1 : X.obj ⟶ Z.obj) := rfl + +/-- The forgetful functor from a wide subcategory into the original category +("forgetting" the condition). +-/ +def wideSubcategoryInclusion : WideSubcategory P ⥤ C := + wideInducedFunctor WideSubcategory.obj P + +@[simp] +theorem wideSubcategoryInclusion.obj (X) : (wideSubcategoryInclusion P).obj X = X.obj := + rfl + +@[simp] +theorem wideSubcategoryInclusion.map {X Y} {f : X ⟶ Y} : + (wideSubcategoryInclusion P).map f = f.1 := + rfl + +/-- The inclusion of a wide subcategory is faithful. -/ +instance wideSubcategoryInclusion.faithful : (wideSubcategoryInclusion P).Faithful := + inferInstanceAs (wideInducedFunctor WideSubcategory.obj P).Faithful + +lemma WideSubcategory.hom_ext {x y : WideSubcategory P} (f g : x ⟶ y) + (hfg : f.1 = g.1) : f = g := + (wideSubcategoryInclusion P).map_injective (by simpa) + +/-- Construct a functor into a widesubcategory by constructing a functor into +the ambient category, and showing that the images of morphisms satisfy the morphism property.-/ +def lift {D : Type*} [Category D] (F : D ⥤ C) (hF : ∀ {X Y} (f : X ⟶ Y), P (F.map f)) : + D ⥤ P.WideSubcategory where + obj X := ⟨F.obj X⟩ + map f := ⟨F.map f, hF f⟩ + +@[simp] +lemma WideSubcategory.coe_eqToHom {X Y : P.WideSubcategory} (h : X = Y) : + (eqToHom h).1 = eqToHom (by aesop_cat) := by aesop_cat + +lemma WideSubcategory.hext {X X' : P.WideSubcategory} (hX : X.1 ≍ X'.1) : X ≍ X' := by + aesop + +lemma WideSubcategory.hom_hext {X X' Y Y' : P.WideSubcategory} (hX : X.1 ≍ X'.1) + (hY : Y.1 ≍ Y'.1) (f : X ⟶ Y) (f' : X' ⟶ Y') (hf : f.1 ≍ f'.1) : f ≍ f' := by + cases X; cases X'; cases Y; cases Y'; subst hX hY + simp only [Set.mem_setOf_eq, heq_eq_eq] at * + apply hom_ext + assumption + +end WideSubcategory + +end MorphismProperty + +-- @[deprecated (since := "2025-10-30")] +-- alias WideSubcategory := MorphismProperty.WideSubcategory + +-- @[deprecated (since := "2025-10-30")] +-- alias InducedWideSubcategory := MorphismProperty.InducedWideCategory + +end CategoryTheory diff --git a/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean b/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean index 33aa49ce..c732d2a5 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean @@ -2,6 +2,7 @@ import Mathlib.CategoryTheory.NatTrans import Mathlib.CategoryTheory.Functor.TwoSquare import Mathlib.CategoryTheory.Limits.Shapes.Pullback.CommSq import HoTTLean.ForMathlib +import Poly.ForMathlib.CategoryTheory.NatTrans universe w v u v₁ u₁ v₂ u₂ v₃ u₃ @@ -31,7 +32,7 @@ end open Functor -lemma hext {A : Type u} [Category.{v} A] {B: Type u₁} [Groupoid.{v₁} B] +lemma hext {A : Type u} [Category.{v} A] {B : Type u₁} [Category.{v₁} B] {F F' G G' : A ⥤ B} (α : F ⟶ G) (β : F' ⟶ G') (hF : F = F') (hG : G = G') (happ : ∀ x, α.app x ≍ β.app x) : α ≍ β := by @@ -46,3 +47,31 @@ instance {A : Type*} [Category A] {B : Type*} [Groupoid B] : comp_inv := NatTrans.vcomp_inv end CategoryTheory + +namespace CategoryTheory + +universe v' u' v₄ v₅ v₆ v₇ v₈ u₄ u₅ u₆ u₇ u₈ + +variable {J : Type v'} [Category.{u'} J] {C : Type u} [Category.{v} C] +variable {K : Type*} [Category K] {D : Type*} [Category D] + +namespace NatTrans +namespace IsCartesian + +open TwoSquare + +variable {C₁ : Type u₁} {C₂ : Type u₂} {C₃ : Type u₃} {C₄ : Type u₄} + [Category.{v₁} C₁] [Category.{v₂} C₂] [Category.{v₃} C₃] [Category.{v₄} C₄] + {T : C₁ ⥤ C₂} {L : C₁ ⥤ C₃} {R : C₂ ⥤ C₄} {B : C₃ ⥤ C₄} +variable {C₅ : Type u₅} {C₆ : Type u₆} {C₇ : Type u₇} {C₈ : Type u₈} + [Category.{v₅} C₅] [Category.{v₆} C₆] [Category.{v₇} C₇] [Category.{v₈} C₈] + {T' : C₂ ⥤ C₅} {R' : C₅ ⥤ C₆} {B' : C₄ ⥤ C₆} {L' : C₃ ⥤ C₇} {R'' : C₄ ⥤ C₈} {B'' : C₇ ⥤ C₈} + +theorem vCompIsIso {w : TwoSquare T L R B} [IsIso w] {w' : TwoSquare B L' R'' B''} : + IsCartesian w' → IsCartesian (w ≫ᵥ w') := + fun cw' => + (isCartesian_of_isIso _).comp <| + (isCartesian_of_isIso _).comp <| + (isCartesian_of_isIso _).comp <| + (IsCartesian.whiskerLeft cw' _).comp + (isCartesian_of_isIso _) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean new file mode 100644 index 00000000..d0143e19 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -0,0 +1,1392 @@ +import HoTTLean.ForMathlib.CategoryTheory.Clan +import HoTTLean.ForMathlib.CategoryTheory.Comma.Over.Basic + +universe v u v₁ u₁ + +noncomputable section + +namespace CategoryTheory + +open Category Limits MorphismProperty + +variable {C : Type u} [Category.{u} C] + +namespace MorphismProperty + +open NatTrans MorphismProperty.Over in +/-- The counit of the adjunction `mapPullbackAdj` is a pullback square, +since it is the pullback computed by `P.Over.pullback`. -/ +lemma isCartesian_mapPullbackAdj_counit {P : MorphismProperty C} {X Y : C} {f : X ⟶ Y} + [P.IsStableUnderComposition] [P.IsStableUnderBaseChange] + [P.HasPullbacksAlong f] (hPf : P f) : IsCartesian (mapPullbackAdj (Q := ⊤) f hPf trivial).counit := by + intro A B U + apply (MorphismProperty.Over.forget P ⊤ Y).reflect_isPullback + apply (CategoryTheory.Over.forget Y).reflect_isPullback + apply IsPullback.flip + simp only [Functor.comp_obj, Comma.forget_obj, Over.forget_obj, map_obj_left, pullback_obj_left, + Functor.id_obj, mapPullbackAdj, Adjunction.mkOfHomEquiv, Equiv.invFun_as_coe, + Adjunction.mk'_counit, Comma.forget_map, Over.forget_map, + mapPullbackAdjHomEquiv_symm_apply_left, Comma.id_hom, CategoryTheory.Comma.id_left, id_comp, + Functor.comp_map, map_map_left, pullback_map_left, Functor.id_map] + apply IsPullback.of_bot (v₂₁ := (pullback.snd B.hom f)) (h₃₁ := f) (v₂₂ := B.hom) _ _ + (IsPullback.of_hasPullback B.hom f) + · convert IsPullback.of_hasPullback A.hom f <;> simp + · simp + +namespace PolynomialPartialAdjunction + +variable {T : Type u} [Category.{v} T] {R : MorphismProperty T} + [R.HasPullbacks] [R.IsStableUnderBaseChange] + {E I B : T} (i : E ⟶ I) (p : E ⟶ B) + [HasPullbacksAlong p] [R.HasPushforwardsAlong p] + [R.IsStableUnderPushforwardsAlong p] + +/-- The partial right adjoint representing a multivariate polynomial. -/ +abbrev partialRightAdjoint := Over.pullback R ⊤ i ⋙ pushforward R p + +/-- The left adjoint in the partial adjunction. -/ +abbrev leftAdjoint := CategoryTheory.Over.pullback p ⋙ CategoryTheory.Over.map i + +/-- `pullback R ⊤ i ⋙ pushforward R p` is a partial right adjoint to +`CategoryTheory.Over.pullback p.1 ⋙ CategoryTheory.Over.map i` + ``` + pullback i pushforward p + R.Over I ------> R.Over E -----> R.Over B + | | | + | ⊥ | ⊥ | + | | | + V V V + C/I <--------- C/E <------------ C/B + map i pullback p + ``` + +On paper this is written `C/B (X, p⁎ (i* Y)) ≃ C/I (i! (p* X), Y)`. +-/ +def homEquiv {X : Over B} {Y : R.Over ⊤ I} : + (X ⟶ ((partialRightAdjoint i p).obj Y).toComma) ≃ + ((leftAdjoint i p).obj X ⟶ Y.toComma) := + calc (X ⟶ ((R.pushforward p).obj ((Over.pullback R ⊤ i).obj Y)).toComma) + _ ≃ ((CategoryTheory.Over.pullback p).obj X ⟶ ((Over.pullback R ⊤ i).obj Y).toComma) := + pushforward.homEquiv + _ ≃ ((CategoryTheory.Over.map i).obj + ((CategoryTheory.Over.pullback p).obj X) ⟶ Y.toComma) := + pullback.homEquiv _ + +lemma homEquiv_comp {X X' : Over B} {Y : R.Over ⊤ I} + (f : X' ⟶ ((partialRightAdjoint i p).obj Y).toComma) (g : X ⟶ X') : + homEquiv i p (g ≫ f) = + (leftAdjoint i p).map g ≫ homEquiv i p f := by + unfold homEquiv + simp only [Functor.comp_obj, Equiv.trans_def, Equiv.trans_apply] + erw [pushforward.homEquiv_comp, pullback.homEquiv_comp] + rfl + +lemma homEquiv_map_comp {X : Over B} {Y Y' : R.Over ⊤ I} + (f : X ⟶ ((partialRightAdjoint i p).obj Y).toComma) (g : Y ⟶ Y') : + homEquiv i p (f ≫ Comma.Hom.hom ((partialRightAdjoint i p).map g)) = + homEquiv i p f ≫ Comma.Hom.hom g := by + unfold homEquiv + simp only [Functor.comp_obj, Equiv.trans_def, Equiv.trans_apply] + erw [pushforward.homEquiv_map_comp, pullback.homEquiv_map_comp] + rfl + +lemma homEquiv_symm_comp {X : Over B} {Y Y' : R.Over ⊤ I} + (f : (leftAdjoint i p).obj X ⟶ Y.toComma) (g : Y ⟶ Y') : + (homEquiv i p).symm f ≫ Comma.Hom.hom ((partialRightAdjoint i p).map g) = + (homEquiv i p).symm (f ≫ Comma.Hom.hom g) := by + unfold homEquiv + simp + erw [pushforward.homEquiv_symm_comp, pullback.homEquiv_symm_comp] + rfl + +lemma comp_homEquiv_symm {X X' : Over B} {Y : R.Over ⊤ I} + (f : (leftAdjoint i p).obj X' ⟶ Y.toComma) (g : X ⟶ X') : + g ≫ (homEquiv i p).symm f = + (homEquiv i p).symm ((leftAdjoint i p).map g ≫ f) := by + unfold homEquiv + simp + erw [pushforward.homEquiv_comp_symm, pullback.comp_homEquiv_symm] + rfl + +/-- The counit of the partial adjunction is given by evaluating the equivalence of +hom-sets at the identity. +On paper we write this as `counit : i! p* p∗ i* => Over.forget : R.Over ⊤ I ⥤ Over I` +-/ +def counit : + partialRightAdjoint i p ⋙ Over.forget R ⊤ B ⋙ leftAdjoint i p ⟶ Over.forget R ⊤ I where + app _ := homEquiv i p (𝟙 _) + naturality X Y f := by + apply (homEquiv i p).symm.injective + conv => left; erw [← comp_homEquiv_symm] + conv => right; erw [← homEquiv_symm_comp] + simp + +/-- A commutative diagram +``` + I + ↗ ↖ + i / \ i' + / ρ \ + E -------> E' + \ / + p \ / p' + ↘ ↙ + B +``` +induces a natural transformation `partialRightAdjoint i p ⟶ partialRightAdjoint i' p'` +obtained by pasting the following 2-cells +``` + pullback i' pushforward p' +R.Over ⊤ I ----> R.Over ⊤ E' ----> R.Over ⊤ B + ‖ | ‖ + ‖ | ‖ + ‖ ↙ |ρ* ↙ ‖ + ‖ | ‖ + ‖ V ‖ +R.Over ⊤ I ----> R.Over ⊤ E ----> R.Over ⊤ B + pullback i pushforward p +``` +-/ +def partialRightAdjointMap {E' : T} (i' : E' ⟶ I) (p' : E' ⟶ B) + [HasPullbacksAlong p'] [R.HasPushforwardsAlong p'] + [R.IsStableUnderPushforwardsAlong p'] (ρ) + (hi : i = ρ ≫ i') (hρ : p = ρ ≫ p') : + partialRightAdjoint (R := R) i' p' ⟶ partialRightAdjoint i p := + -- let cellLeftIso : Over.pullback R ⊤ i' ⋙ Over.pullback R ⊤ ρ ≅ Over.pullback R ⊤ i := + -- (Over.pullbackComp ρ i').symm ≪≫ eqToIso (by rw [hi]) + let cellLeft : TwoSquare (Over.pullback R ⊤ i') (𝟭 _) + (Over.pullback R ⊤ ρ) (Over.pullback R ⊤ i) := + ((Functor.leftUnitor _) ≪≫ Over.pullbackCongr hi ≪≫ (Over.pullbackComp ρ i')).symm.hom + let cellRight := pushforwardPullbackTwoSquare (R := R) ρ p p' (𝟙 _) (by simp [← hρ]) + Functor.whiskerLeft (partialRightAdjoint i' p') (Over.pullbackId R ⊤ B).inv ≫ + cellLeft.hComp cellRight + +lemma partialRightAdjointMap_obj {E' : T} (i' : E' ⟶ I) (p' : E' ⟶ B) + [HasPullbacksAlong p'] [R.HasPushforwardsAlong p'] + [R.IsStableUnderPushforwardsAlong p'] (ρ) + (hi : i = ρ ≫ i') (hρ : p = ρ ≫ p') (X : R.Over ⊤ I) : + Comma.Hom.hom ((partialRightAdjointMap i p i' p' ρ hi hρ).app X) = sorry := by + simp [partialRightAdjointMap] + -- apply (homEquiv i p).injective + -- simp [Functor.comp_obj, - EmbeddingLike.apply_eq_iff_eq, homEquiv, Trans.trans, + -- partialRightAdjointMap] + -- ext + -- simp only [CategoryTheory.Over.map_obj_left, CategoryTheory.Over.pullback_obj_left, + -- pullback.homEquiv_apply_left] + -- congr 3 + -- ext + -- apply partialRightAdjoint.homEquiv + sorry + +end PolynomialPartialAdjunction + +variable (P : MorphismProperty C) + +namespace Over + +@[simps] +def equivalenceOfHasObjects' (R : MorphismProperty C) [R.HasObjects] + {X : C} (hX : IsTerminal X) : R.Over ⊤ X ≌ Over X where + functor := MorphismProperty.Over.forget _ _ _ + inverse := Comma.lift (𝟭 _) (by intro; apply HasObjects.obj_mem _ hX) (by simp) (by simp) + unitIso := eqToIso rfl + counitIso := eqToIso rfl + functor_unitIso_comp := by simp + +@[simp] +def equivalenceOfHasObjects (R : MorphismProperty C) [R.HasObjects] + {X : C} (hX : IsTerminal X) : R.Over ⊤ X ≌ C := + (equivalenceOfHasObjects' R hX).trans (Over.equivalenceOfIsTerminal hX) + +variable {P : MorphismProperty C} {E B : C} + +@[simps] +def ofMorphismProperty {p : E ⟶ B} (hp : P p) : P.Over ⊤ B where + left := E + right := ⟨⟨⟩⟩ + hom := p + prop := hp + +@[simps] +def homMkTop {p q : P.Over ⊤ B} (left : p.left ⟶ q.left) (hleft : left ≫ q.hom = p.hom) : + p ⟶ q where + left := left + right := eqToHom (by simp) + w := by simp [hleft] + prop_hom_left := trivial + prop_hom_right := trivial + +/-- +Convert an object `p` in `R.Over ⊤ B` to a morphism in `R.Over ⊤ O` by composing with `o`. + p + E -----> B + \ / + \ /o + \ / + VV + O +-/ +@[simp] +def homOfMorphismProperty [P.IsStableUnderComposition] {O} (p : P.Over ⊤ B) {o : B ⟶ O} (ho : P o) : + (map ⊤ ho).obj p ⟶ Over.ofMorphismProperty ho := + Over.homMk p.hom (by simp) + +end Over + +end MorphismProperty + +open MorphismProperty.Over + +/-- `P : MvPoly R H I O` is a the signature for a multivariate polynomial functor, +consisting of the following maps +``` + p + E ---> B + i ↙ ↘ o + I O +``` +We can lazily read this as `∑ b : B, X ^ (E b)`, +for some `X` in the (`P`-restricted) slice over `I`. + +In full detail: +Viewing such an `X` as a series of variables `X_k` indexed by `k ∈ I`, +and `B` as a family of types `B_k` indexed by `j ∈ O` +this can be further viewed as `O`-many `I`-ary polynomials `∑ b : B_j, X_(i b) ^ (E b)` + +To explain the need for two morphism properties, +consider the following two use-cases: +1. `R = ⊤` is all maps and the category has all pullbacks. + `H` is the class of exponentiable maps - it follows from all maps having pullbacks that `H` + also has pullbacks. +2. `R = H` is a π-clan, [see Joyal, def 2.4.1](https://arxiv.org/pdf/1710.10238). + +This will typically be used with the following instances + +- For pullback of `R`-maps along `i`, `p` and `o` we need + `[R.IsStableUnderBaseChange] [R.HasPullbacks]` +- For the left adjoint to pullback for `o` we need `[R.IsStableUnderComposition]` +- For pushforward of `R`-maps along `p` we need + `[R.IsStableUnderPushforward H] [R.HasPushforwards H]` +- For pushforward of `R`-maps along `p` we also assume `[H.HasPullbacks]`. + This is useful - it makes the `R`-restricted pushforward of `R`-maps along `p` + a partial left adjoint to *global* pullback along `p`, + ``` + pushforward p + R.Over E -----> R.Over B + | | + | ⊥ | + | | + V V + C/E <--------- C/B + pullback p + ``` + which is strictly stronger than just having a left adjoint to `R`-restricted pullback + `(pullback : R.Over B ⥤ R.Over E) ⊣ (pushforward : R.Over E ⥤ R.Over B)`. +-/ +structure MvPoly (R : MorphismProperty C) (I O E B : C) where + (i : E ⟶ I) + (hi : R i) + (p : E ⟶ B) + (o : B ⟶ O) + (ho : R o) + +namespace MvPoly + +variable {R : MorphismProperty C} + +instance {B O : C} {i : B ⟶ O} (hi : R i) [R.HasPullbacks] [R.IsStableUnderBaseChange] + [R.IsStableUnderComposition] : (pullback R ⊤ i).IsRightAdjoint := + (mapPullbackAdj (Q := ⊤) i hi ⟨⟩).isRightAdjoint + +variable {I O E B : C} (P : MvPoly R I O E B) [R.HasPullbacks] [R.IsStableUnderBaseChange] + [HasPullbacksAlong P.p] [R.HasPushforwardsAlong P.p] [R.IsStableUnderPushforwardsAlong P.p] + +open PolynomialPartialAdjunction + +/-- (Ignoring the indexing from `i` and `o`) +This is the first projection morphism from `P @ X = ∑ b : B, X ^ (E b)` to `B`, +as an object in the `P`-restricted slice over `B`. -/ +abbrev fstProj (X : R.Over ⊤ I) : R.Over ⊤ B := + (partialRightAdjoint P.i P.p).obj X + +/-- The counit of the adjunction `pullback p ⋙ map i ⊣ pullback i ⋙ pushforward p` evaluated at `X`. +Ignoring the indexing from `i` and `o`, +this can be viewed as the second projection morphism from `P @ X = ∑ b : B, X ^ (E b)` +to `X^ (E b)`. + +``` + X ----------> I + ∧ ∧ + | | + sndProj | i + | | + • ----------> E + | | + | (pb) | + | |p + V fstProj V + P @ X --------> B + ⟍ | + ⟍ |o + ⟍ | + ↘ V + O +``` +-/ +def sndProj (X : R.Over ⊤ I) : + (leftAdjoint P.i P.p).obj (fstProj P X).toComma ⟶ X.toComma := + (counit P.i P.p).app X + +section + +variable {X Y : R.Over ⊤ I} (f : X ⟶ Y) + +@[reassoc (attr := simp)] +lemma map_fstProj : + ((partialRightAdjoint P.i P.p).map f).left ≫ (fstProj P Y).hom = (fstProj P X).hom := by + simp + +lemma sndProj_comp_hom : (sndProj P X).left ≫ X.hom = pullback.snd _ _ ≫ P.i := by + simp [sndProj] + +lemma sndProj_comp : (sndProj P X).left ≫ f.left = + pullback.map _ _ _ _ + ((partialRightAdjoint P.i P.p).map f).left (𝟙 _) (𝟙 _) (by simp) (by simp) ≫ + (sndProj P Y).left := by + have := congr_arg CommaMorphism.left <| (counit P.i P.p).naturality f + simpa [pullback.map] using this.symm + +end + +variable [R.IsStableUnderComposition] +/-- A multivariate polynomial signature +``` + p + E ---> B + i ↙ ↘ o + I O +``` +gives rise to a functor +``` + pushforward p + R.Over ⊤ E ---------> R.Over ⊤ B + pullback i ↗ ⟍ map o + ⟋ ⟍ + ⟋ ↘ + R.Over ⊤ I R.Over ⊤ O +``` +-/ +def functor : R.Over ⊤ I ⥤ R.Over ⊤ O := + pullback R ⊤ P.i ⋙ MorphismProperty.pushforward R P.p ⋙ map ⊤ P.ho + +/-- The action of a univariate polynomial on objects. -/ +def apply : R.Over ⊤ I → R.Over ⊤ O := (functor P).obj + +@[inherit_doc] +infix:90 " @ " => apply + +namespace Equiv + +variable {P} {Γ : Over O} {X : R.Over ⊤ I} + +def fst (pair : Γ ⟶ (P @ X).toComma) : Over B := Over.mk (pair.left ≫ (fstProj P X).hom) + +abbrev sndDom (pair : Γ ⟶ (P @ X).toComma) : Over I := (leftAdjoint P.i P.p).obj (fst pair) + +def snd (pair : Γ ⟶ (P @ X).toComma) : sndDom pair ⟶ X.toComma := + homEquiv P.i P.p (Over.homMk (pair.left)) + +lemma snd_eq (pair : Γ ⟶ (P @ X).toComma) : snd pair = + (leftAdjoint P.i P.p).map (Over.homMk (pair.left)) ≫ sndProj P X := by + erw [Equiv.apply_eq_iff_eq_symm_apply, ← comp_homEquiv_symm] + simp [sndProj, counit] + +def mk (f : Over B) (hf : Γ = (Over.map P.o).obj f) + (s : (leftAdjoint P.i P.p).obj f ⟶ X.toComma) : + Γ ⟶ (P @ X).toComma := + eqToHom hf ≫ (Over.map P.o).map ((homEquiv P.i P.p).symm s) + +@[simp] +lemma fst_mk (f : Over B) (hf : Γ = (Over.map P.o).obj f) + (s : (leftAdjoint P.i P.p).obj f ⟶ X.toComma) : fst (mk f hf s) = f := by + subst hf; simp [fst, mk] + +lemma snd_mk (f : Over B) (hf : Γ = (Over.map P.o).obj f) + (s : (leftAdjoint P.i P.p).obj f ⟶ X.toComma) : snd (mk f hf s) = + eqToHom (by simp) ≫ s := calc snd (mk f hf s) + _ = (leftAdjoint P.i P.p).map (eqToHom (fst_mk f hf s)) ≫ s := by + erw [Equiv.apply_eq_iff_eq_symm_apply, ← comp_homEquiv_symm] + ext + simp [mk] + _ = eqToHom _ ≫ s := by + simp only [eqToHom_map] + +@[simp] +lemma map_fst (pair : Γ ⟶ (P @ X).toComma) : (Over.map P.o).obj (fst pair) = Γ := by + have := pair.w + simp only [Functor.id_obj, Functor.const_obj_obj, Functor.id_map, + CostructuredArrow.right_eq_id, Functor.const_obj_map, comp_id] at this + simp [Over.map, Comma.mapRight, fst] + congr + +@[simp] +lemma mk_fst_snd (pair : Γ ⟶ (P @ X).toComma) : mk (fst pair) (by simp) (snd pair) = pair := by + ext + simp [mk, snd] + +end Equiv + +-- -- NOTE: please leave the commented out subgoals, it makes debugging this easier +-- instance (P : MvPoly R H I O E B) : PreservesLimitsOfShape WalkingCospan +-- (MorphismProperty.Over.pullback R ⊤ P.i ⋙ R.pushforward P.hp ⋙ +-- MorphismProperty.Over.map ⊤ P.ho) := +-- have : (MorphismProperty.Over.pullback R ⊤ P.i).IsRightAdjoint := +-- Adjunction.isRightAdjoint (MorphismProperty.Over.mapPullbackAdj R ⊤ P.i P.hi trivial) +-- -- have : PreservesLimitsOfShape WalkingCospan (MorphismProperty.Over.pullback R ⊤ P.i) := +-- -- inferInstance +-- -- have : PreservesLimitsOfShape WalkingCospan (R.pushforward P.hp) := +-- -- inferInstance +-- -- have : PreservesLimitsOfShape WalkingCospan (MorphismProperty.Over.map ⊤ P.ho) := +-- -- inferInstance +-- inferInstance + +-- instance (P : MvPoly R H I O E B) : +-- Limits.PreservesLimitsOfShape WalkingCospan (MvPoly.functor P) := by +-- dsimp [functor] +-- infer_instance + +/-- A commutative triangle +``` + I + ↗ ↖ +P.i/ \Q.i + / ρ \ + E -------> F + \ / +P.p\ / Q.p + ↘ ↙ + B +``` +induces a natural transformation `Q.functor ⟶ P.functor` when `Q.o = P.o`, +obtained by pasting the following 2-cells +``` + pullback Q.i pushforward Q.p.1 map Q.o.1 +R.Over ⊤ I ----> R.Over ⊤ F ----> R.Over ⊤ B -----> R.Over ⊤ O + ‖ | ‖ ‖ + ‖ | ‖ ‖ + ‖ ↙ |ρ* ↙ ‖ = ‖ + ‖ | ‖ ‖ + ‖ V ‖ ‖ +R.Over ⊤ I ----> R.Over ⊤ E ----> R.Over ⊤ B -----> R.Over ⊤ O + pullback P.i pushforward P.p.1 map P.o +``` +-/ +def verticalNatTrans {F : C} (P : MvPoly R I O E B) (Q : MvPoly R I O F B) + [HasPullbacksAlong P.p] [R.HasPushforwardsAlong P.p] [R.IsStableUnderPushforwardsAlong P.p] + [HasPullbacksAlong Q.p] [R.HasPushforwardsAlong Q.p] [R.IsStableUnderPushforwardsAlong Q.p] + (ρ : E ⟶ F) (hi : P.i = ρ ≫ Q.i) (hp : P.p = ρ ≫ Q.p) (ho : P.o = Q.o) : + Q.functor ⟶ P.functor := + (Functor.associator _ _ _).inv ≫ + ((PolynomialPartialAdjunction.partialRightAdjointMap P.i P.p Q.i Q.p ρ hi hp) ◫ + (NatTrans.mk (fun X => MorphismProperty.Over.homMk (by exact 𝟙 _)))) ≫ + (Functor.associator _ _ _).hom + +lemma verticalNatTrans_hom {F : C} (P : MvPoly R I O E B) (Q : MvPoly R I O F B) + [HasPullbacksAlong P.p] [R.HasPushforwardsAlong P.p] [R.IsStableUnderPushforwardsAlong P.p] + [HasPullbacksAlong Q.p] [R.HasPushforwardsAlong Q.p] [R.IsStableUnderPushforwardsAlong Q.p] + (ρ : E ⟶ F) (hi : P.i = ρ ≫ Q.i) (hp : P.p = ρ ≫ Q.p) (ho : P.o = Q.o) (X) : + ((verticalNatTrans P Q ρ hi hp ho).app X).hom = sorry := by + simp [verticalNatTrans] + -- erw [id_comp] + sorry + +section + +variable {F} (Q : MvPoly R I O F B) [HasPullbacksAlong Q.p] [R.HasPushforwardsAlong Q.p] + [R.IsStableUnderPushforwardsAlong Q.p] + (ρ : E ⟶ F) (hi : P.i = ρ ≫ Q.i) (hp : P.p = ρ ≫ Q.p) (ho : P.o = Q.o) + +def fstVerticalNatTransAppIso {Γ} {X} (pair : Γ ⟶ (Q @ X).toComma) : + Equiv.fst (pair ≫ ((verticalNatTrans P Q ρ hi hp ho).app X).hom) ≅ Equiv.fst pair := + Over.isoMk (Iso.refl _) (by simp [Equiv.fst, verticalNatTrans]; erw [id_comp]) + +lemma fst_verticalNatTrans_app {Γ} {X} (pair : Γ ⟶ (Q @ X).toComma) : + Equiv.fst (pair ≫ ((verticalNatTrans P Q ρ hi hp ho).app X).hom) = Equiv.fst pair := + Over.ext_of_iso (fstVerticalNatTransAppIso P Q ρ hi hp ho pair) rfl rfl + +lemma snd_verticalNatTrans_app {Γ} {X} (pair : Γ ⟶ (Q @ X).toComma) : + Equiv.snd (pair ≫ ((verticalNatTrans P Q ρ hi hp ho).app X).hom) = + Over.homMk (pullback.map _ _ _ _ (fstVerticalNatTransAppIso P Q ρ hi hp ho pair).hom.left + ρ (𝟙 _) (by cat_disch) (by cat_disch)) ≫ Equiv.snd pair := by + simp [Equiv.snd] + -- rw [Over.homMk_comp] + -- rw [homEquiv_comp] + -- rw [comp_homEquiv_symm] + -- rw [Equiv.snd_eq] + -- rw [Equiv.snd_eq] + -- dsimp [sndProj, counit] + -- simp + sorry + +-- lemma mk'_comp_verticalNatTrans_app {Γ : Over O} {X : R.Over ⊤ I} (f : Over B) +-- (hf : Γ = (Over.map Q.o.1).obj f) (s : (leftAdjoint Q.i.1 Q.p).obj f ⟶ X.toComma) : +-- Equiv.mk f hf s ≫ ((verticalNatTrans P Q ρ hi hp ho).app X).hom = +-- Equiv.mk f (sorry) sorry ≫ sorry +-- := +-- sorry + +end + +open TwoSquare + +/-- A cartesian map +``` + P.p + E --------> B + P.i ↙ | | ↘ P.o + I φ| (pb) | δ O + P'.i ↖ v v ↗ P'.o + E' --------> B' + P'.p +``` +induces a natural transformation between their associated functors obtained by pasting the following +2-cells +``` + pullback P'.i pushforward P'.p map P'.o +R.Over I ------ > R.Over E' --------> R.Over B' --------> R.Over O + ‖ | | ‖ + ‖ | | ‖ + ‖ ↗ pullback φ ↗ pullback δ ↗ ‖ + ‖ | | ‖ + ‖ v v ‖ +R.Over I ------ > R.Over E --------> R.Over B --------> R.Over O + pullback P.i pushforward P.p map P.o +``` +-/ +def cartesianNatTrans {E' B' : C} (P : MvPoly R I O E B) (P' : MvPoly R I O E' B') + [HasPullbacksAlong P.p] [R.HasPushforwardsAlong P.p] [R.IsStableUnderPushforwardsAlong P.p] + [HasPullbacksAlong P'.p] [R.HasPushforwardsAlong P'.p] [R.IsStableUnderPushforwardsAlong P'.p] + (δ : B ⟶ B') (φ : E ⟶ E') (hφ : P.i = φ ≫ P'.i) (pb : IsPullback φ P.p P'.p δ) + (hδ : δ ≫ P'.o = P.o) : + P.functor ⟶ P'.functor := + let cellLeft : TwoSquare (𝟭 (R.Over ⊤ I)) (MorphismProperty.Over.pullback R ⊤ P'.i) + (MorphismProperty.Over.pullback R ⊤ P.i) (MorphismProperty.Over.pullback R ⊤ φ) := + (eqToIso (by simp [hφ, Functor.id_comp]) ≪≫ (MorphismProperty.Over.pullbackComp φ P'.i)).hom + let cellMid : TwoSquare (MorphismProperty.Over.pullback R ⊤ φ) + (R.pushforward P'.p) (R.pushforward P.p) (MorphismProperty.Over.pullback R ⊤ δ) := + (pushforwardPullbackIso φ P.p P'.p δ pb).inv + let cellRight : TwoSquare (MorphismProperty.Over.pullback R ⊤ δ) + (MorphismProperty.Over.map ⊤ P'.ho) (MorphismProperty.Over.map ⊤ P.ho) (𝟭 _) := + (pullbackMapTwoSquare R P.o δ (𝟙 _) P'.o P'.ho P.ho (by simp [hδ])) ≫ + Functor.whiskerLeft _ (MorphismProperty.Over.pullbackId R ⊤ O).hom + cellLeft ≫ᵥ cellMid ≫ᵥ cellRight + +-- TODO: This name is not quite correct, because the functor is not cartesian +-- rather, it takes a commutative square in `R.Over I` that is a pullback in the (whole!) +-- over category `Over I` to +-- a commutative square that is a pullback in the over category `Over O` +-- This subtlety can be ignored when `R.Over I = Over I`, like in the π-clan `UvPoly` case. + +-- Here are some relevant facts: +-- 1. partial right adjoints preserve limits in the whole category of diagrams from the subcategory +-- whole limit also lands in the subcategory, +-- hence `pullback i : R.Over I -> R.Over E` and +-- `pushforward p : R.Over E -> R.Over B` both preserve pullbacks in `Over I` +-- that are from `R.Over I`. +-- 2. `map : R.Over E -> R.Over O` also has this pullback preservation property. + +open NatTrans in +theorem isCartesian_cartesianNatTrans {E' B' : C} (P : MvPoly R I O E B) (P' : MvPoly R I O E' B') + [HasPullbacksAlong P.p] [R.HasPushforwardsAlong P.p] [R.IsStableUnderPushforwardsAlong P.p] + [HasPullbacksAlong P'.p] [R.HasPushforwardsAlong P'.p] [R.IsStableUnderPushforwardsAlong P'.p] + (δ : B ⟶ B') (φ : E ⟶ E') (hφ : P.i = φ ≫ P'.i) (pb : IsPullback φ P.p P'.p δ) + (hδ : δ ≫ P'.o = P.o) : + (cartesianNatTrans P P' δ φ hφ pb hδ).IsCartesian := + IsCartesian.vCompIsIso <| + IsCartesian.vCompIsIso <| + IsCartesian.comp + (isCartesian_pullbackMapTwoSquare ..) + (IsCartesian.whiskerLeft (isCartesian_of_isIso _) _) + + -- dsimp [cartesianNatTrans] + -- repeat apply IsCartesian.vComp + -- · apply IsCartesian.comp + -- · apply isCartesian_of_isIso + -- · sorry --apply isCartesian_of_isIso + -- · apply isCartesian_of_isIso + -- · -- apply IsCartesian.whiskerLeft + -- sorry + + -- NOTE: this lemma could be extracted, but `repeat' apply IsCartesian.comp` will unfold past it. + -- have : NatTrans.IsCartesian + -- (pullbackMapTwoSquare R P.o δ (𝟙 _) P'.o.1 P'.o.2 P.ho (by simp [hδ])) := by + -- -- unfold pullbackMapTwoSquare + -- -- simp only [mateEquiv_symm_apply] + -- repeat' apply IsCartesian.comp + -- -- have (i j : R.Over ⊤ B') (f : j ⟶ i) : + -- -- PreservesLimit + -- -- (cospan ((mapPullbackAdj R ⊤ P'.o.fst P'.o.snd trivial).unit.app i) + -- -- ((MorphismProperty.Over.map ⊤ P'.o.2 ⋙ MorphismProperty.Over.pullback R ⊤ P'.o.fst).map f)) + -- -- (MorphismProperty.Over.pullback R ⊤ δ ⋙ MorphismProperty.Over.map ⊤ P.ho) := sorry + -- any_goals apply isCartesian_of_isIso + -- · sorry --refine IsCartesian.whiskerRight _ _ + -- · apply IsCartesian.whiskerLeft + -- apply isCartesian_mapPullbackAdj_counit + + -- repeat' apply IsCartesian.comp + -- any_goals apply isCartesian_of_isIso + -- apply IsCartesian.whiskerLeft + -- repeat' apply IsCartesian.comp + -- any_goals apply isCartesian_of_isIso + -- apply IsCartesian.whiskerLeft + -- repeat' apply IsCartesian.comp + -- any_goals apply isCartesian_of_isIso + -- · sorry -- apply IsCartesian.whiskerRight + -- · apply IsCartesian.whiskerLeft + -- apply isCartesian_mapPullbackAdj_counit + + +end MvPoly + +/-- `P : UvPoly R E B` is the type of signatures for polynomial functors + p + E ---> B + +We read this as `∑ b : B, X ^ (E b)`, +for some `R`-object `X` (meaning the unique map to the terminal object is in `R`). + +This notion of polynomial makes sense when `R` is a π-clan, +[see Joyal, def 2.4.1](https://arxiv.org/pdf/1710.10238). +Therefore it will typically be used with the following instances + +- For pullback of `R`-maps along `p` we need + `[R.IsStableUnderBaseChange] [R.HasPullbacks]` +- For the left adjoint to pullback along `B`, we assume `[R.IsStableUnderComposition]` + and `[R.HasObjects]`, meaning the unique map `B ⟶ ⊤_ C` is in `R`. + For this, we will also assume `[ChosenTerminal C]`. +- For pushforward of `R`-maps along `p` we need + `[R.IsStableUnderPushforward R] [R.HasPushforwards R]` +- For pushforward of `R`-maps along `p` we also assume `[R.HasPullbacks]`. + This is useful - it makes the `R`-restricted pushforward of `R`-maps along `p` + a partial left adjoint to *global* pullback along `p`, + ``` + pushforward p + R.Over E -----> R.Over B + | | + | ⊥ | + | | + V V + C/E <--------- C/B + pullback p + ``` + which is strictly stronger than just having a left adjoint to `R`-restricted pullback + `(pullback : R.Over B ⥤ R.Over E) ⊣ (pushforward : R.Over E ⥤ R.Over B)`. +-/ +structure UvPoly (R : MorphismProperty C) (E B : C) where + (p : E ⟶ B) + (morphismProperty : R p) + +namespace UvPoly + +section + +variable {R : MorphismProperty C} {E B : C} + +variable [ChosenTerminal C] + +open ChosenTerminal + +variable (P : UvPoly R E B) + [R.IsStableUnderComposition] [R.HasPullbacks] [R.IsStableUnderBaseChange] [R.HasObjects] + [HasPullbacksAlong P.p] [R.IsStableUnderPushforwardsAlong P.p] [R.HasPushforwardsAlong P.p] + +instance (P : UvPoly R E B) : HasPullbacksAlong P.p := + hasPullbacksAlong_of_hasPullbacks P.morphismProperty + +instance (P : UvPoly R E B) {Γ : C} (A : Γ ⟶ B) : HasPullback P.p A := + hasPullback_symmetry _ _ + +lemma isTerminal_from (X : C) : R (isTerminal.from X) := + HasObjects.obj_mem _ ChosenTerminal.isTerminal + +@[simp] +abbrev toOverTerminal : C ⥤ R.Over ⊤ (𝟭_ C) := + (equivalenceOfHasObjects R isTerminal).inverse + +@[simp] +abbrev fromOverTerminal : R.Over ⊤ (𝟭_ C) ⥤ C := + (equivalenceOfHasObjects R isTerminal).functor + +@[simps] +def mvPoly : MvPoly R (𝟭_ C) (𝟭_ C) E B where + i := isTerminal.from _ + hi := isTerminal_from _ + p := P.p + o := isTerminal.from _ + ho := isTerminal_from _ + +instance : HasPullbacksAlong P.mvPoly.p := + inferInstanceAs <| HasPullbacksAlong P.p + +instance : R.HasPushforwardsAlong P.mvPoly.p := + inferInstanceAs <| R.HasPushforwardsAlong P.p + +instance : R.IsStableUnderPushforwardsAlong P.mvPoly.p := + inferInstanceAs <| R.IsStableUnderPushforwardsAlong P.p + +def functor : C ⥤ C := + toOverTerminal ⋙ + MvPoly.functor P.mvPoly ⋙ + fromOverTerminal + +/-- The action of a univariate polynomial on objects. -/ +def apply [ChosenTerminal C] : C → C := P.functor.obj + +@[inherit_doc] +infix:90 " @ " => apply + +-- instance [ChosenTerminal C] (P : UvPoly R E B) : +-- Limits.PreservesLimitsOfShape WalkingCospan P.functor := by +-- unfold functor +-- infer_instance + +variable (B) + +/-- The identity polynomial functor in single variable. -/ +@[simps!] +def id (R : MorphismProperty C) [R.ContainsIdentities] (B) : UvPoly R B B := ⟨𝟙 B, R.id_mem _ ⟩ + +@[simps!] +def vcomp [R.IsStableUnderComposition] {A B C} (P : UvPoly R A B) (Q : UvPoly R B C) : + UvPoly R A C := + ⟨ P.p ≫ Q.p, R.comp_mem _ _ P.morphismProperty Q.morphismProperty ⟩ + +/-- With sufficient theory, this lemma can be generalised: the π-clan conditions +`[R.HasPushforwards R] (hP : R P.p) (hQ : R Q.p)` +are unnecessary.-/ +lemma hasPushforwardsAlong_vcomp [R.HasPushforwards R] {A B C} + {P : UvPoly R A B} {Q : UvPoly R B C} (hP : R P.p) (hQ : R Q.p) : + R.HasPushforwardsAlong (vcomp P Q).p := + HasPushforwards.hasPushforwardsAlong _ (R.comp_mem _ _ hP hQ) + +/-- With sufficient theory, this lemma can be generalised: the π-clan conditions +`[R.IsStableUnderPushforwards R] (hP : R P.p) (hQ : R Q.p)` +are unnecessary.-/ +lemma isStableUnderPushforwardsAlong_vcomp [R.IsStableUnderPushforwards R] {A B C} + {P : UvPoly R A B} {Q : UvPoly R B C} (hP : R P.p) (hQ : R Q.p) : + R.IsStableUnderPushforwardsAlong (vcomp P Q).p := + IsStableUnderPushforwards.of_isPushforward _ (R.comp_mem _ _ hP hQ) + +variable {B} + +/-- The fstProjection morphism from `∑ b : B, X ^ (E b)` to `B` again. -/ +def fstProj (X : C) : P @ X ⟶ B := + (P.mvPoly.fstProj (toOverTerminal.obj X)).hom + +@[reassoc (attr := simp)] +lemma map_fstProj {X Y : C} (f : X ⟶ Y) : + P.functor.map f ≫ fstProj P Y = fstProj P X := + P.mvPoly.map_fstProj (toOverTerminal.map f) + +/-- The second projection morphism from `P @ X = ∑ b : B, X ^ (E b)` to `X^ (E b)`. -/ +def sndProj (X : C) : + Limits.pullback (fstProj P X) P.p ⟶ X := + (P.mvPoly.sndProj (toOverTerminal.obj X)).left + +lemma sndProj_comp {X Y : C} (f : X ⟶ Y) : sndProj P X ≫ f = + pullback.map _ _ _ _ (P.functor.map f) (𝟙 _) (𝟙 _) (by simp) (by simp) ≫ sndProj P Y := + P.mvPoly.sndProj_comp (toOverTerminal.map f) + +open TwoSquare + +/-- A commutative triangle +``` + I + ↗ ↖ +P.i/ \Q.i + / ρ \ + E -------> F + \ / +P.p\ / Q.p + ↘ ↙ + B +``` +induces a natural transformation `Q.functor ⟶ P.functor ` obtained by pasting the following 2-cells +``` + Q.mvPoly.functor +C --- ≅ ---> R.Over ⊤ 1 ----> R.Over ⊤ 1 --- ≅ ---> C +‖ ‖ ‖ ‖ +‖ ‖ ‖ ‖ +‖ ‖ ↓ ‖ ‖ +‖ ‖ ‖ ‖ +‖ ‖ ‖ ‖ +C --- ≅ ---> R.Over ⊤ 1 ----> R.Over ⊤ 1 --- ≅ ---> C + P.mvPoly.functor +``` +-/ +def verticalNatTrans {F : C} (Q : UvPoly R F B) (ρ : E ⟶ F) + [R.IsStableUnderPushforwardsAlong Q.p] [R.HasPushforwardsAlong Q.p] + (h : P.p = ρ ≫ Q.p) : Q.functor ⟶ P.functor := + let mv : Q.mvPoly.functor ⟶ P.mvPoly.functor := + MvPoly.verticalNatTrans P.mvPoly Q.mvPoly ρ (isTerminal.hom_ext ..) h (isTerminal.hom_ext ..) + (toOverTerminal).whiskerLeft (Functor.whiskerRight mv fromOverTerminal) + +open TwoSquare + +/-- A cartesian map of polynomials +``` + φ + E --------> E' + | | + P.p | (pb) | P'.p + v v + B --------> B' + δ +``` +induces a natural transformation between their associated functors obtained by pasting the following +2-cells +``` + P'.p +C --- > R.Over E' ----> R.Over B' -----> C +‖ | | ‖ +‖ ↗ | φ* ≅ | δ* ↗ ‖ +‖ v v ‖ +C --- > R.Over E -----> R.Over B -----> C + P.p +``` +-/ +def cartesianNatTrans {E' B' : C} (P' : UvPoly R E' B') + [R.IsStableUnderPushforwardsAlong P'.p] [R.HasPushforwardsAlong P'.p] + (δ : B ⟶ B') (φ : E ⟶ E') (pb : IsPullback φ P.p P'.p δ) : P.functor ⟶ P'.functor := + let mv := P.mvPoly.cartesianNatTrans P'.mvPoly δ φ (isTerminal.hom_ext ..) + pb (isTerminal.hom_ext ..) + (toOverTerminal).whiskerLeft (Functor.whiskerRight mv fromOverTerminal) + +-- TODO: this is cartesian. Unlike with the MvPoly case there is no distinction between +-- `C` and `Over.terminal` and `R.Over terminal`, since `R` has objects. + +open NatTrans in +theorem isCartesian_cartesianNatTrans {D F : C} (Q : UvPoly R F D) + [R.IsStableUnderPushforwardsAlong Q.p] [R.HasPushforwardsAlong Q.p] + (δ : B ⟶ D) (φ : E ⟶ F) (pb : IsPullback φ P.p Q.p δ) : + (cartesianNatTrans P Q δ φ pb).IsCartesian := by + apply IsCartesian.whiskerLeft + apply IsCartesian.whiskerRight + apply MvPoly.isCartesian_cartesianNatTrans + +/-- A morphism from a polynomial `P` to a polynomial `Q` is a pair of morphisms `e : E ⟶ E'` +and `b : B ⟶ B'` such that the diagram +``` + E -- P.p -> B + ^ | + ρ | | + | ψ | + Pb --------> B + | | + φ | | δ + v v + F -- Q.p -> D +``` +is a pullback square. -/ +structure Hom {F D : C} (P : UvPoly R E B) (Q : UvPoly R F D) where + Pb : C + δ : B ⟶ D + φ : Pb ⟶ F + ψ : Pb ⟶ B + ρ : Pb ⟶ E + is_pb : IsPullback ψ φ δ Q.p + w : ρ ≫ P.p = ψ + +namespace Hom + +open IsPullback + +/-- The identity morphism in the category of polynomials. -/ +def id (P : UvPoly R E B) : Hom P P := ⟨E, 𝟙 B, 𝟙 _ , P.p , 𝟙 _, IsPullback.of_id_snd, by simp⟩ + +end Hom + +/-- The domain of the composition of two polynomial signatures. +See `UvPoly.comp`. -/ +def compDom {E' B' : C} (P' : UvPoly R E' B') + [R.IsStableUnderPushforwardsAlong P'.p] [R.HasPushforwardsAlong P'.p] : C := + Limits.pullback (sndProj P B') P'.p + +/-- +The composition of two polynomial signatures. See `UvPoly.comp`. +Note that this is not just composition in the category `C`, +instead it is functor composition in the category `C ⥤ C`, +meaning it satisfies `P.functor ⋙ P'.functor ≅ (comp P P').functor`. + + E' <---- compDom + | | +p' | (pb) | + | | + V V + B' <----- • -------> E + sndProj | | + | (pb) |p + | | + V V + P @ B' -----> B + fstProj +-/ +def comp {E' B' : C} (P' : UvPoly R E' B') + [R.IsStableUnderPushforwardsAlong P'.p] [R.HasPushforwardsAlong P'.p] : + UvPoly R (compDom P P') (P @ B') where + p := Limits.pullback.fst (sndProj P B') P'.p ≫ pullback.fst (fstProj P B') P.p + morphismProperty := R.comp_mem _ _ + (R.of_isPullback (IsPullback.of_hasPullback (sndProj P B') P'.p).flip P'.morphismProperty) + (R.of_isPullback (IsPullback.of_hasPullback (fstProj P B') P.p).flip P.morphismProperty) + +namespace Equiv + +variable {P} {Γ X Y : C} + +/-- Convert the morphism `pair` into a morphism in the over category `Over (𝟭_ C)` -/ +@[simp] +abbrev homMk (pair : Γ ⟶ P @ X) : Over.mk (isTerminal.from Γ) ⟶ + ((toOverTerminal ⋙ MvPoly.functor P.mvPoly).obj X).toComma := + Over.homMk pair (isTerminal.hom_ext ..) + +/-- +A morphism `pair : Γ ⟶ P @ X` is equivalent to a pair of morphisms +`fst : Γ ⟶ B` and `snd : pb ⟶ X` in the following diagram +``` + snd +B <---- pb ------> E + | | + | |p + | | + V V + Γ -------> B + fst +``` +The following API allows users to convert back and forth along this (natural) bijection. +-/ +def fst (pair : Γ ⟶ P @ X) : Γ ⟶ B := + (MvPoly.Equiv.fst (homMk pair)).hom + +lemma fst_eq (pair : Γ ⟶ P @ X) : fst pair = pair ≫ P.fstProj X := by + aesop_cat + +def snd (pair : Γ ⟶ P @ X) : Limits.pullback (fst pair) P.p ⟶ X := + (MvPoly.Equiv.snd (homMk pair)).left + +lemma snd_eq (pair : Γ ⟶ P @ X) : snd pair = + Limits.pullback.map (fst pair) P.p (P.fstProj X) P.p pair (𝟙 E) (𝟙 B) (by simp [fst_eq]) + (by simp) ≫ sndProj P X := by + simpa [Limits.pullback.map] using congrArg CommaMorphism.left (MvPoly.Equiv.snd_eq (homMk pair)) + +def snd' (pair : Γ ⟶ P @ X) {pb f g} (H : IsPullback (P := pb) f g (fst pair) P.p) : pb ⟶ X := + H.isoPullback.hom ≫ snd pair + +theorem snd_eq_snd' (pair : Γ ⟶ P @ X) : snd pair = snd' pair (.of_hasPullback ..) := + by simp [snd'] + +/-- Convert the morphism `x` into a morphism in the over category `Over (𝟭_ C)` -/ +@[simp] +abbrev mkAux (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : + (PolynomialPartialAdjunction.leftAdjoint P.mvPoly.i P.mvPoly.p).obj (Over.mk b) ⟶ + ((toOverTerminal (R := R)).obj X).toComma := + Over.homMk x (isTerminal.hom_ext ..) + +def mk (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : Γ ⟶ P @ X := + (MvPoly.Equiv.mk (P := P.mvPoly) (Γ := Over.mk (isTerminal.from Γ)) + (Over.mk b) (by congr; apply isTerminal.hom_ext) (mkAux b x)).left + +def mk' (b : Γ ⟶ B) {pb f g} (H : IsPullback (P := pb) f g b P.p) (x : pb ⟶ X) : Γ ⟶ P @ X := + mk b (H.isoPullback.inv ≫ x) + +theorem mk_eq_mk' (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : + mk b x = mk' b (.of_hasPullback ..) x := by simp [mk'] + +@[simp] +lemma fst_mk (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : + fst (mk b x) = b := by + simp only [fst, mk, Over.homMk_eta] + rw! (castMode := .all) [MvPoly.Equiv.fst_mk] + simp [← heq_eq_eq]; rfl + +@[simp] +lemma fst_mk' (b : Γ ⟶ B) {pb f g} (H : IsPullback (P := pb) f g b P.p) (x : pb ⟶ X) : + fst (mk' b H x) = b := by + simp [mk'] + +@[simp] +lemma mk'_comp_fstProj (b : Γ ⟶ B) {pb f g} (H : IsPullback (P := pb) f g b P.p) (x : pb ⟶ X) : + mk' b H x ≫ P.fstProj X = b := by + simp [← fst_eq] + +theorem fst_comp_left (pair : Γ ⟶ P @ X) {Δ} (f : Δ ⟶ Γ) : + fst (f ≫ pair) = f ≫ fst pair := by simp [fst_eq] + +theorem fst_comp_right (pair : Γ ⟶ P @ X) (f : X ⟶ Y) : + fst (pair ≫ P.functor.map f) = fst pair := by + simp [fst_eq] + +lemma snd'_eq (pair : Γ ⟶ P @ X) {pb f g} (H : IsPullback (P := pb) f g (fst pair) P.p) : + snd' pair H = pullback.lift (f ≫ pair) g (by simpa using H.w) ≫ sndProj P X := by + rw [snd', snd_eq, ← Category.assoc] + congr 1 + ext <;> simp + +/-- Switch the selected pullback `pb` used in `UvPoly.Equiv.snd'` with a different pullback `pb'`. -/ +lemma snd'_eq_snd' (pair : Γ ⟶ P @ X) {pb f g} (H : IsPullback (P := pb) f g (fst pair) P.p) + {pb' f' g'} (H' : IsPullback (P := pb') f' g' (fst pair) P.p) : + snd' pair H = (H.isoIsPullback _ _ H').hom ≫ snd' pair H' := by + simp [snd'_eq, ← Category.assoc] + congr 2 + ext <;> simp + +@[simp] +lemma snd_mk (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : snd (mk b x) = + eqToHom (by simp) ≫ x := by + have := MvPoly.Equiv.snd_mk (P := P.mvPoly) (Γ := Over.mk (isTerminal.from Γ)) + (Over.mk b) (by congr; apply isTerminal.hom_ext) (mkAux b x) + convert congr_arg CommaMorphism.left this + simp + +@[simp] +lemma snd'_mk' (b : Γ ⟶ B) {pb f g} (H : IsPullback (P := pb) f g b P.p) (x : pb ⟶ X) : + snd' (mk' b H x) (by rwa [fst_mk']) = x := by + simp only [snd', mk', snd_mk] + rw! [fst_mk] + simp + +@[simp] +lemma snd'_mk'' (b : Γ ⟶ B) {pb f g} (H : IsPullback (P := pb) f g b P.p) (x : pb ⟶ X) + {pb' f' g'} (H' : IsPullback (P := pb') f' g' (fst (mk' b H x)) P.p := by exact H) : + snd' (mk' b H x) H' = H.lift f' g' (by rw [fst_mk'] at H'; simp [H'.w]) ≫ x := by + simp only [snd', mk', snd_mk] + rw! [fst_mk] + simp [← Category.assoc] + congr 1 + apply H.hom_ext <;> simp + + +lemma snd_mk_heq (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : + snd (mk b x) ≍ x := by + simp + +theorem snd'_comp_left (pair : Γ ⟶ P @ X) + {pb f g} (H : IsPullback (P := pb) f g (fst pair) P.p) + {Δ} (σ : Δ ⟶ Γ) + {pb' f' g'} (H' : IsPullback (P := pb') f' g' (σ ≫ fst pair) P.p) : + snd' (σ ≫ pair) (by convert H'; rw [fst_comp_left]) = + H.lift (f' ≫ σ) g' (by simp [H'.w]) ≫ snd' pair H := by + simp only [snd'_eq, ← Category.assoc] + congr 2 + ext + · simp + · simp + +theorem snd'_comp_right (pair : Γ ⟶ P @ X) (f : X ⟶ Y) + {pb f1 f2} (H : IsPullback (P := pb) f1 f2 (fst pair) P.p) : + snd' (pair ≫ P.functor.map f) (by rwa [fst_comp_right]) = + snd' pair H ≫ f := by + simp only [snd'_eq, assoc] + conv => right; rw [sndProj_comp, ← Category.assoc] + congr 1 + ext <;> simp + +theorem snd_comp_right (pair : Γ ⟶ P @ X) (f : X ⟶ Y) : snd (pair ≫ P.functor.map f) = + eqToHom (by congr 1; apply fst_comp_right) ≫ snd pair ≫ f := by + simp only [snd_eq, assoc, sndProj_comp] + conv => right; simp only [← Category.assoc] + congr 1 + have : fst (pair ≫ P.functor.map f) = fst pair := by simp [fst_eq] + rw! [this] + ext <;> simp + +@[simp] +lemma mk_fst_snd (pair : Γ ⟶ P @ X) : + mk (fst pair) (snd pair) = pair := by + have := MvPoly.Equiv.mk_fst_snd (P := P.mvPoly) (Γ := Over.mk (isTerminal.from Γ)) (homMk pair) + exact congr_arg CommaMorphism.left this + +@[simp] +lemma mk'_fst_snd' (pair : Γ ⟶ P @ X) + {pb f1 f2} (H : IsPullback (P := pb) f1 f2 (fst pair) P.p) : + mk' (fst pair) H (snd' pair H) = pair := by + simp only [mk', snd'] + simp + +lemma ext' {pair₁ pair₂ : Γ ⟶ P @ X} + {pb f g} (H : IsPullback (P := pb) f g (fst pair₁) P.p) + (h1 : fst pair₁ = fst pair₂) + (h2 : snd' pair₁ H = snd' pair₂ (by rwa [h1] at H)) : + pair₁ = pair₂ := by + rw [← mk'_fst_snd' pair₁ H, ← mk'_fst_snd' pair₂ (by rwa [h1] at H), h2] + rw! [h1] + +/-- Switch the selected pullback `pb` used in `UvPoly.Equiv.mk'` with a different pullback `pb'`. -/ +theorem mk'_eq_mk' (b : Γ ⟶ B) {pb f g} (H : IsPullback (P := pb) f g b P.p) (x : pb ⟶ X) + {pb' f' g'} (H' : IsPullback (P := pb') f' g' b P.p) : + mk' b H x = mk' b H' ((IsPullback.isoIsPullback _ _ H H').inv ≫ x) := by + apply ext' (R := R) (f := f) (g := g) (by convert H; simp) + · have : ∀ h, H'.lift f g h ≫ (IsPullback.isoIsPullback Γ E H H').inv = 𝟙 pb := by + intro ; apply H.hom_ext <;> simp + simp [← Category.assoc, this] + · simp + +lemma mk'_comp_right (b : Γ ⟶ B) {pb f1 f2} (H : IsPullback (P := pb) f1 f2 b P.p) (x : pb ⟶ X) + (f : X ⟶ Y) : mk' b H x ≫ P.functor.map f = mk' b H (x ≫ f) := by + refine .symm <| ext' (by rwa [fst_mk']) (by simp [fst_comp_right]) ?_ + rw [snd'_comp_right (H := by rwa [fst_mk'])]; simp + +lemma mk_comp_right (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) (f : X ⟶ Y) : + mk b x ≫ P.functor.map f = mk b (x ≫ f) := by + simp [mk_eq_mk', mk'_comp_right] + +theorem mk'_comp_left {Δ} + (b : Γ ⟶ B) {pb f g} (H : IsPullback f g b P.p) (x : pb ⟶ X) (σ : Δ ⟶ Γ) + (σb) (eq : σ ≫ b = σb) + {pb' f' g'} (H' : IsPullback (P := pb') f' g' σb P.p) : + σ ≫ UvPoly.Equiv.mk' b H x = UvPoly.Equiv.mk' σb H' + (H.lift (f' ≫ σ) g' (by simp [eq, H'.w]) ≫ x) := by + apply ext' (f := f') (g := g') (H := by convert H'; simp [eq, fst_eq]) + · rw [snd'_comp_left (H := by convert H; rw [fst_mk']) (H' := by convert H'; rw [← eq, fst_mk'])] + simp + · simp [eq, fst_comp_left] + +theorem mk_comp_left {Δ} (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) (σ: Δ ⟶ Γ) : + σ ≫ UvPoly.Equiv.mk b x = + UvPoly.Equiv.mk (σ ≫ b) + (pullback.map _ _ _ _ σ (𝟙 _) (𝟙 _) (by simp) (by simp) ≫ x) := by + simp only [mk_eq_mk'] + rw [mk'_comp_left (H := .of_hasPullback _ _) (H' := .of_hasPullback _ _) (eq := rfl)] + congr 2; ext <;> simp + +lemma mk'_comp_cartesianNatTrans_app {E' B' Γ X : C} {P' : UvPoly R E' B'} + [R.IsStableUnderPushforwardsAlong P'.p] [R.HasPushforwardsAlong P'.p] + (y : Γ ⟶ B) (pb f g) (H : IsPullback (P := pb) f g y P.p) + (x : pb ⟶ X) (e : E ⟶ E') (b : B ⟶ B') + (hp : IsPullback P.p e b P'.p) : + Equiv.mk' y H x ≫ (P.cartesianNatTrans P' b e hp.flip).app X = + Equiv.mk' (y ≫ b) (H.paste_vert hp) x := by + sorry + -- have : fst (Equiv.mk' y H x ≫ (P.cartesianNatTrans P' b e hp.flip).app X) = y ≫ b := by + -- rw [fst_eq, Category.assoc, cartesianNatTrans_fstProj, ← Category.assoc, mk'_comp_fstProj] + -- refine ext' _ _ (this ▸ H.paste_vert hp) (by simpa) ?_ + -- simp; rw [snd'_eq] + -- have := snd'_mk' P X y H x + -- rw [snd'_eq, ← fan_snd_map' _ _ X hp] at this + -- refine .trans ?_ this + -- simp only [← Category.assoc]; congr 1; ext <;> simp + +end Equiv + +namespace compDomEquiv + +variable {Γ E' B' : C} {P} {P' : UvPoly R E' B'} + [R.IsStableUnderPushforwardsAlong P'.p] [R.HasPushforwardsAlong P'.p] + +/- +``` + Γ + | + |triple + V + compDom + |⟍ + | ⟍ + | ⟍ + V ↘ + • -------> E + | | + | (pb) |p + | | + V V +P @ B' -----> B + fstProj +``` +This produces a map `fst : Γ ⟶ E`, +and a map `(triple ≫ P.comp P').p : Γ ⟶ P @ B'`, +which we can further break up using `UvPoly.Equiv.fst` and `UvPoly.Equiv.snd`. +``` + dependent +B <---- pb ------> E + | | + | |p + | | + V V + Γ -------> B + base +``` +-/ +def fst (triple : Γ ⟶ compDom P P') : Γ ⟶ E := + triple ≫ pullback.fst _ _ ≫ pullback.snd _ _ + +@[simp] +abbrev base (triple : Γ ⟶ compDom P P') : Γ ⟶ B := Equiv.fst (triple ≫ (P.comp P').p) + +theorem fst_comp_p (triple : Γ ⟶ compDom P P') : + fst triple ≫ P.p = base triple := by + simp [fst, Equiv.fst_eq, pullback.condition, comp] + +abbrev dependent (triple : Γ ⟶ compDom P P') {pb} (f : pb ⟶ Γ) (g : pb ⟶ E) + (H : IsPullback f g (fst triple ≫ P.p) P.p) : pb ⟶ B' := + Equiv.snd' (triple ≫ (P.comp P').p) (by convert H; simp only [fst_comp_p]) + +def snd (triple : Γ ⟶ compDom P P') : Γ ⟶ E' := + triple ≫ pullback.snd _ _ + +theorem snd_comp_p (triple : Γ ⟶ compDom P P') + {pb} (f : pb ⟶ Γ) (g : pb ⟶ E) (H : IsPullback f g (fst triple ≫ P.p) P.p) : + snd triple ≫ P'.p = + H.lift (𝟙 Γ) (fst triple) (by simp) ≫ dependent triple f g H := + calc (triple ≫ pullback.snd _ _) ≫ P'.p + _ = triple ≫ pullback.fst _ _ ≫ sndProj P B' := by + simp [pullback.condition] + _ = H.lift (𝟙 Γ) (fst triple) (by simp) ≫ dependent triple f g H := by + simp only [← assoc, dependent, comp, Equiv.snd'_eq] + congr 1 + ext <;> simp [fst] + +def mk (b : Γ ⟶ B) (e : Γ ⟶ E) (he : e ≫ P.p = b) + {pb} (f : pb ⟶ Γ) (g : pb ⟶ E) (H : IsPullback f g b P.p) + (b' : pb ⟶ B') (e' : Γ ⟶ E') (he' : e' ≫ P'.p = H.lift (𝟙 Γ) e (by simp [he]) ≫ b') : + Γ ⟶ P.compDom P' := + pullback.lift (pullback.lift (Equiv.mk' b H b') e) e' (by + have : b' = Equiv.snd' (Equiv.mk' b H b') (by convert H; simp) := by rw [Equiv.snd'_mk'] + conv => right; rw [he', this, Equiv.snd'_eq, ← Category.assoc] + congr 1 + ext <;> simp ) + +lemma mk_comp (b : Γ ⟶ B) (e : Γ ⟶ E) (he : e ≫ P.p = b) + {pb} (f : pb ⟶ Γ) (g : pb ⟶ E) (H : IsPullback f g b P.p) + (b' : pb ⟶ B') (e' : Γ ⟶ E') (he' : e' ≫ P'.p = H.lift (𝟙 Γ) e (by simp [he]) ≫ b') : + mk b e he f g H b' e' he' ≫ (P.comp P').p = Equiv.mk' b H b' := by + simp [mk, comp] + +@[simp] +lemma base_mk (b : Γ ⟶ B) (e : Γ ⟶ E) (he : e ≫ P.p = b) + {pb} (f : pb ⟶ Γ) (g : pb ⟶ E) (H : IsPullback f g b P.p) + (b' : pb ⟶ B') (e' : Γ ⟶ E') (he' : e' ≫ P'.p = H.lift (𝟙 Γ) e (by simp [he]) ≫ b') : + base (mk b e he f g H b' e' he') = b := by simp [mk, comp] + +@[simp] +lemma fst_mk (b : Γ ⟶ B) (e : Γ ⟶ E) (he : e ≫ P.p = b) + {pb} (f : pb ⟶ Γ) (g : pb ⟶ E) (H : IsPullback f g b P.p) + (b' : pb ⟶ B') (e' : Γ ⟶ E') (he' : e' ≫ P'.p = H.lift (𝟙 Γ) e (by simp [he]) ≫ b') : + fst (mk b e he f g H b' e' he') = e := by + simp [mk, fst] + +@[simp] +lemma dependent_mk (b : Γ ⟶ B) (e : Γ ⟶ E) (he : e ≫ P.p = b) + {pb} (f : pb ⟶ Γ) (g : pb ⟶ E) (H : IsPullback f g b P.p) + (b' : pb ⟶ B') (e' : Γ ⟶ E') (he' : e' ≫ P'.p = H.lift (𝟙 Γ) e (by simp [he]) ≫ b') + {pb'} (f' : pb' ⟶ Γ) (g' : pb' ⟶ E) + (H' : IsPullback f' g' (fst (mk b e he f g H b' e' he') ≫ P.p) P.p) : + dependent (mk b e he f g H b' e' he') f' g' H' = H.lift f' g' (by simp [← H'.w, he]) ≫ b' := by + simp [mk, dependent, comp] + +@[simp] +lemma snd_mk (b : Γ ⟶ B) (e : Γ ⟶ E) (he : e ≫ P.p = b) + {pb} (f : pb ⟶ Γ) (g : pb ⟶ E) (H : IsPullback f g b P.p) + (b' : pb ⟶ B') (e' : Γ ⟶ E') (he' : e' ≫ P'.p = H.lift (𝟙 Γ) e (by simp [he]) ≫ b') : + snd (mk b e he f g H b' e' he') = e' := by + simp [mk, snd] + +@[simp] +lemma mk_fst_snd (triple : Γ ⟶ compDom P P') {pb} (f : pb ⟶ Γ) (g : pb ⟶ E) + (H : IsPullback f g (base triple) P.p) (b' : pb ⟶ B') + (hbase' : b' = Equiv.snd' (triple ≫ (P.comp P').p) H) : + mk (base triple) (fst triple) (fst_comp_p ..) f g H b' (snd triple) (by + simp only [snd, assoc, ← pullback.condition, base, comp] + simp only [hbase', Equiv.snd'_eq, ← Category.assoc] + congr 1 + ext <;> simp [fst, comp]) = triple := by + apply pullback.hom_ext + · ext + · simp [mk] + conv => right; rw [← Equiv.mk'_fst_snd' + (triple ≫ pullback.fst (P.sndProj B') P'.p ≫ pullback.fst (P.fstProj B') P.p) H] + congr + · simp [mk, fst] + · simp [mk, snd] + +lemma ext (triple triple' : Γ ⟶ compDom P P') + (hfst : fst triple = fst triple') + (hsnd : snd triple = snd triple') + {pb} (f : pb ⟶ Γ) (g : pb ⟶ E) + (H : IsPullback f g (fst triple ≫ P.p) P.p) + (hd : dependent triple f g H = dependent triple' f g (by rwa [← hfst])) : + triple = triple' := by + rw [← mk_fst_snd triple f g (by convert H; simp [fst_comp_p]) (dependent triple f g H) rfl, + ← mk_fst_snd triple' f g (by rwa [← fst_comp_p, ← hfst]) + (dependent triple' f g (by rwa [← hfst])) rfl] + have : base triple = base triple' := by + rw [← fst_comp_p, ← fst_comp_p, hfst] + rw! [hsnd, hd, hfst, this] + +lemma fst_comp {Δ} (σ : Δ ⟶ Γ) (triple : Γ ⟶ compDom P P') : + fst (σ ≫ triple) = σ ≫ fst triple := by + simp [fst] + +lemma snd_comp {Δ} (σ : Δ ⟶ Γ) (triple : Γ ⟶ compDom P P') : + snd (σ ≫ triple) = σ ≫ snd triple := by + simp [snd] + +lemma dependent_comp {Δ} (σ : Δ ⟶ Γ) (triple : Γ ⟶ compDom P P') + {pb'} (f' : pb' ⟶ Γ) (g' : pb' ⟶ E) (H' : IsPullback f' g' (fst triple ≫ P.p) P.p) + {pb} (f : pb ⟶ Δ) (g : pb ⟶ E) (H : IsPullback f g (fst (σ ≫ triple) ≫ P.p) P.p) : + dependent (σ ≫ triple) f g H = H'.lift (f ≫ σ) g (by simp [← H.w, fst_comp]) ≫ + dependent triple f' g' H' := by + simp only [dependent, comp, ← assoc, Equiv.snd'_eq] + congr + ext <;> simp + +lemma comp_mk {Δ} (σ : Δ ⟶ Γ) (b : Γ ⟶ B) (e : Γ ⟶ E) (he : e ≫ P.p = b) + {pb'} (f' : pb' ⟶ Γ) (g' : pb' ⟶ E) (H' : IsPullback f' g' b P.p) + {pb} (f : pb ⟶ Δ) (g : pb ⟶ E) (H : IsPullback f g (σ ≫ b) P.p) + (b' : pb' ⟶ B') (e' : Γ ⟶ E') (he' : e' ≫ P'.p = H'.lift (𝟙 Γ) e (by simp [he]) ≫ b') : + σ ≫ mk b e he f' g' H' b' e' he' = + mk (σ ≫ b) (σ ≫ e) (by simp [he]) f g H (H'.lift (f ≫ σ) g (by simp[← H.w]) ≫ b') (σ ≫ e') + (by simp [he']; simp [← assoc]; congr 1; apply H'.hom_ext <;> simp) := by + simp [mk] + apply pullback.hom_ext + · apply pullback.hom_ext + · simp only [assoc, limit.lift_π, PullbackCone.mk_pt, PullbackCone.mk_π_app] + rw [Equiv.mk'_comp_left] + rfl + · simp + · simp + +end compDomEquiv + +section + +variable {F : C} (Q : UvPoly R F B) + [R.HasPushforwardsAlong Q.p] [R.IsStableUnderPushforwardsAlong Q.p] + (ρ : E ⟶ F) (h : P.p = ρ ≫ Q.p) + +lemma fst_verticalNatTrans_app {Γ : C} (X : C) (pair : Γ ⟶ Q @ X) : + Equiv.fst (pair ≫ (verticalNatTrans P Q ρ h).app X) = Equiv.fst pair := by + dsimp [Equiv.fst] + sorry + +lemma snd'_verticalNatTrans_app {Γ : C} (X : C) (pair : Γ ⟶ Q @ X) {R f g} + (H : IsPullback (P := R) f g (Equiv.fst pair) Q.p) {R' f' g'} + (H' : IsPullback (P := R') f' g' (Equiv.fst pair) P.p) : + Equiv.snd' (pair ≫ (verticalNatTrans P Q ρ h).app X) (by + rw [← fst_verticalNatTrans_app P Q] at H' + exact H') = + (H.lift f' (g' ≫ ρ) (by simp [H'.w, h])) ≫ + Equiv.snd' pair H := + sorry + +lemma mk'_comp_verticalNatTrans_app {Γ : C} (X : C) (b : Γ ⟶ B) {R f g} + (H : IsPullback (P := R) f g b Q.p) (x : R ⟶ X) {R' f' g'} + (H' : IsPullback (P := R') f' g' b P.p) : + Equiv.mk' b H x ≫ (verticalNatTrans P Q ρ h).app X = Equiv.mk' b H' + (H.lift f' (g' ≫ ρ) (by simp [H'.w, h]) ≫ x) := + sorry + +end + +-- instance preservesPullbacks (P : UvPoly R E B) {Pb X Y Z : C} (fst : Pb ⟶ X) (snd : Pb ⟶ Y) +-- (f : X ⟶ Z) (g : Y ⟶ Z) (h: IsPullback fst snd f g) : +-- IsPullback (P.functor.map fst) (P.functor.map snd) (P.functor.map f) (P.functor.map g) := +-- P.functor.map_isPullback h diff --git a/HoTTLean/ForMathlib/CategoryTheory/WeakPullback.lean b/HoTTLean/ForMathlib/CategoryTheory/WeakPullback.lean index 90acf3dd..9b4548f0 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/WeakPullback.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/WeakPullback.lean @@ -20,6 +20,13 @@ variable {C : Type*} [Category C] {P X Y Z : C} {fst : P ⟶ X} {snd : P ⟶ Y} {f : X ⟶ Z} {g : Y ⟶ Z} (wp : WeakPullback fst snd f g) +class IsCoherent : Prop where + comp_left {W W' : C} {σ : W' ⟶ W} + {a : W ⟶ X} {b : W ⟶ Y} (h : a ≫ f = b ≫ g) + {a' : W' ⟶ X} {b' : W' ⟶ Y} + (σ_a : σ ≫ a = a') (σ_b : σ ≫ b = b') : + σ ≫ wp.lift a b h = wp.lift a' b' (by simp [h, ← σ_a, ← σ_b]) + variable {W : C} (a : W ⟶ X) (b : W ⟶ Y) (h : a ≫ f = b ≫ g) @[simp] @@ -28,23 +35,38 @@ lemma lift_fst : wp.lift a b h ≫ fst = a := lift_fst' _ _ _ _ @[simp] lemma lift_snd : wp.lift a b h ≫ snd = b := lift_snd' _ _ _ _ -def coherentLift [HasPullbacks C] : W ⟶ P := +def coherentLift [HasPullback f g] : W ⟶ P := pullback.lift a b h ≫ wp.lift (pullback.fst _ _) (pullback.snd _ _) pullback.condition @[simp] -lemma coherentLift_fst [HasPullbacks C] : wp.coherentLift a b h ≫ fst = a := by +lemma coherentLift_fst [HasPullback f g] : wp.coherentLift a b h ≫ fst = a := by simp [coherentLift] @[simp] -lemma coherentLift_snd [HasPullbacks C] : wp.coherentLift a b h ≫ snd = b := by +lemma coherentLift_snd [HasPullback f g] : wp.coherentLift a b h ≫ snd = b := by simp [coherentLift] -lemma coherentLift_comp_left [HasPullbacks C] {W'} (σ : W' ⟶ W) : +lemma coherentLift_comp_left [HasPullback f g] + {W W' : C} {σ : W' ⟶ W} + {a : W ⟶ X} {b : W ⟶ Y} (h : a ≫ f = b ≫ g) + {a' : W' ⟶ X} {b' : W' ⟶ Y} (σ_a : σ ≫ a = a') (σ_b : σ ≫ b = b') : σ ≫ wp.coherentLift a b h = - wp.coherentLift (σ ≫ a) (σ ≫ b) (by simp [h]) := by + wp.coherentLift a' b' (by simp [h, ← σ_a, ← σ_b]) := by + subst σ_a σ_b simp only [coherentLift, ← Category.assoc] congr 1; ext <;> simp +def coherent [HasPullback f g] : + WeakPullback fst snd f g where + w := wp.w + lift a b h := coherentLift wp a b h + lift_fst' a b h := coherentLift_fst wp a b h + lift_snd' a b h := coherentLift_snd wp a b h + +instance [HasPullback f g] : IsCoherent (coherent wp) where + comp_left h _ _ σ_a σ_b := + coherentLift_comp_left wp h σ_a σ_b + end WeakPullback end CategoryTheory end diff --git a/HoTTLean/ForMathlib/CategoryTheory/Whiskering.lean b/HoTTLean/ForMathlib/CategoryTheory/Whiskering.lean index 9c32f252..3ab29e14 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Whiskering.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Whiskering.lean @@ -77,4 +77,14 @@ lemma id_whiskerRight {A B : Type*} [Category A] [Category B] {H0 H1 : B ⥤ A} (α : H0 ⟶ H1) : whiskerRight α (𝟭 A) = α := rfl +lemma associator_eq {C D E E' : Type*} [Category C] [Category D] [Category E] [Category E'] + (F : C ⥤ D) (G : D ⥤ E) (H : E ⥤ E') : associator F G H = CategoryTheory.Iso.refl _ := + rfl + +@[reassoc] +lemma leftUnitor_hom_comp_rightUnitor_inv + {C : Type u₁} [Category.{v₁, u₁} C] {D : Type u₂} + [Category.{v₂, u₂} D] (F : C ⥤ D) : F.leftUnitor.hom ≫ F.rightUnitor.inv = 𝟙 _ := by + aesop_cat + end CategoryTheory.Functor diff --git a/HoTTLean/ForMathlib/CategoryTheory/Yoneda.lean b/HoTTLean/ForMathlib/CategoryTheory/Yoneda.lean index f95ab0f8..43ed6548 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Yoneda.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Yoneda.lean @@ -1,4 +1,7 @@ import Mathlib.CategoryTheory.Yoneda +import HoTTLean.ForMathlib.CategoryTheory.Adjunction.Basic + +universe v₁ u₁ v₂ u₂ v₃ u₃ /-! Notation for the Yoneda embedding. -/ @@ -27,4 +30,76 @@ def Functor.map.unexpand : Unexpander throw () | _ => throw () +variable {C : Type u₁} [SmallCategory C] {F G : Cᵒᵖ ⥤ Type u₁} + (app : ∀ {X : C}, (yoneda.obj X ⟶ F) → (yoneda.obj X ⟶ G)) + (naturality : ∀ {X Y : C} (f : X ⟶ Y) (α : yoneda.obj Y ⟶ F), + app (yoneda.map f ≫ α) = yoneda.map f ≫ app α) + +variable (F) in + +/-- + A presheaf `F` on a small category `C` is isomorphic to + the hom-presheaf `Hom(y(•),F)`. +-/ +def yonedaIso : yoneda.op ⋙ yoneda.obj F ≅ F := + NatIso.ofComponents (fun _ => Equiv.toIso yonedaEquiv) + (fun f => by ext : 1; dsimp; rw [yonedaEquiv_naturality']) + +/-- Build natural transformations between presheaves on a small category + by defining their action when precomposing by a morphism with + representable domain -/ +def NatTrans.yonedaMk : F ⟶ G := + (yonedaIso F).inv ≫ .mk (fun _ => by exact app) ≫ (yonedaIso G).hom + +@[deprecated (since := "2025-11-20")] alias yonedaIsoMap := NatTrans.yonedaMk + +theorem NatTrans.yonedaMk_app {X : C} (α : yoneda.obj X ⟶ F) : + α ≫ yonedaMk app naturality = app α := by + rw [← yonedaEquiv.apply_eq_iff_eq, yonedaEquiv_comp] + simp [yonedaMk, yonedaIso] + +example : yoneda.op ⋙ y(F) ≅ F := curriedYonedaLemma'.app F + +example {D : Type*} [Category D] (S : D ⥤ Cᵒᵖ ⥤ Type u₁) := + S.isoWhiskerLeft curriedYonedaLemma' + +def NatIso.yonedaMk (α : yoneda.op ⋙ y(F) ≅ yoneda.op ⋙ y(G)) : F ≅ G := + (curriedYonedaLemma'.app F).symm ≪≫ α ≪≫ curriedYonedaLemma'.app G + +def NatIso.yonedaMk' (app : ∀ {X : C}, (yoneda.obj X ⟶ F) ≃ (yoneda.obj X ⟶ G)) + (naturality : ∀ {X Y : C} (f : X ⟶ Y) (α : yoneda.obj Y ⟶ F), + app (yoneda.map f ≫ α) = yoneda.map f ≫ app α) : F ≅ G := + (yonedaIso F).symm ≪≫ NatIso.ofComponents (fun A => by exact Equiv.toIso app) ≪≫ (yonedaIso G) + +/-- To show that `S ≅ T : D ⥤ Psh C` it suffices to prove the bijection + `Psh C (y(c), S d) ≅ Psh C (y(c), T d)`, + natural in both `c : Cᵒᵖ` and `d : D`. -/ +def functorToPresheafIsoMk {D : Type*} [Category D] {S T : D ⥤ Cᵒᵖ ⥤ Type u₁} + (α : S ⋙ yoneda ⋙ (Functor.whiskeringLeft Cᵒᵖ (Cᵒᵖ ⥤ Type u₁)ᵒᵖ (Type u₁)).obj yoneda.op ≅ + T ⋙ yoneda ⋙ (Functor.whiskeringLeft Cᵒᵖ (Cᵒᵖ ⥤ Type u₁)ᵒᵖ (Type u₁)).obj yoneda.op) : + S ≅ T := + (S.isoWhiskerLeft curriedYonedaLemma').symm ≪≫ α ≪≫ T.isoWhiskerLeft curriedYonedaLemma' + +namespace Equivalence + +variable {C : Type u₁} [Category.{v₁} C] {D : Type u₁} [Category.{v₁} D] + +def yonedaCompCongrLeftInverseIso (e : C ≌ D) : yoneda ⋙ (congrLeft e.op).inverse ≅ + e.inverse ⋙ yoneda := + NatIso.ofComponents + (fun _ => NatIso.ofComponents + (fun _ => Equiv.toIso (e.toAdjunction.homEquiv _ _)) + (fun _ => by ext; simp [Adjunction.homEquiv_naturality_left])) + (fun _ => by ext; simp [Adjunction.homEquiv_naturality_right]) + +def yonedaCompCongrLeftFunctorIso (e : C ≌ D) : yoneda ⋙ (congrLeft e.op).functor ≅ + e.functor ⋙ yoneda := + e.symm.yonedaCompCongrLeftInverseIso + +-- #check Functor.FullyFaithful +-- #check Functor.whiskeringRight + + +end Equivalence + end CategoryTheory diff --git a/HoTTLean/ForPoly.lean b/HoTTLean/ForPoly.lean index b9a44a91..9136ab2f 100644 --- a/HoTTLean/ForPoly.lean +++ b/HoTTLean/ForPoly.lean @@ -1,5 +1,6 @@ import Poly.UvPoly.Basic import HoTTLean.ForMathlib +import HoTTLean.ForMathlib.CategoryTheory.Comma.Over.Pushforward open CategoryTheory Limits @@ -75,8 +76,8 @@ open ExponentiableMorphism Functor in theorem ev_naturality {E B E' B' : C} {P : UvPoly E B} {P' : UvPoly E' B'} (e : E ⟶ E') (b : B ⟶ B') (hp : IsPullback P.p e b P'.p) : - let pfwd := pushforward P.p - let p'fwd := pushforward P'.p + let pfwd := ExponentiableMorphism.pushforward P.p + let p'fwd := ExponentiableMorphism.pushforward P'.p let pbk := Over.pullback P.p let ebk := Over.pullback e let bbk := Over.pullback b @@ -157,7 +158,7 @@ open Over ExponentiableMorphism Functor in lemma cartesianNatTrans_fstProj {E B E' B' : C} (P : UvPoly E B) (P' : UvPoly E' B') (e : E ⟶ E') (b : B ⟶ B') (pb : IsPullback P.p e b P'.p) (X : C) : (P.cartesianNatTrans P' b e pb).app X ≫ P'.fstProj X = P.fstProj X ≫ b := by - let m := whiskerRight (Over.starPullbackIsoStar e).inv (pushforward P.p) ≫ + let m := whiskerRight (Over.starPullbackIsoStar e).inv (ExponentiableMorphism.pushforward P.p) ≫ whiskerLeft (Over.star E') (pushforwardPullbackIsoSquare pb.flip).inv simp [cartesianNatTrans, pullbackForgetTwoSquare, Adjunction.id, Over.mapForget] rw [← Category.assoc] @@ -630,5 +631,4 @@ instance preservesPullbacks (P : UvPoly E B) IsPullback (P.functor.map fst) (P.functor.map snd) (P.functor.map f) (P.functor.map g) := P.functor.map_isPullback h - end CategoryTheory.UvPoly diff --git a/HoTTLean/Grothendieck/Groupoidal/Basic.lean b/HoTTLean/Grothendieck/Groupoidal/Basic.lean index f111b388..5103064e 100644 --- a/HoTTLean/Grothendieck/Groupoidal/Basic.lean +++ b/HoTTLean/Grothendieck/Groupoidal/Basic.lean @@ -220,6 +220,34 @@ def toTransport (x : ∫(F)) {c : C} (t : x.base ⟶ c) : x ⟶ x.transport t := (x.toTransport t).fiber = 𝟙 ((F.map t).obj x.fiber) := Grothendieck.toTransport_fiber _ _ +lemma transport_congr (x x' : ∫ F) (e1 : x = x') {c : C} (t : x.base ⟶ c) (t' : x'.base ⟶ c) + (e : t = eqToHom (by simp[e1]) ≫ t') : + transport x t = transport x' t' := by aesop_cat + +lemma transport_id {x : ∫ F} : transport x (𝟙 x.base) = x := by + apply Grothendieck.transport_id + +lemma transport_eqToHom {X: C} {X' : F.Groupoidal} (hX': X'.base = X) : + X'.transport (eqToHom hX') = X' := by + apply Grothendieck.transport_eqToHom + +lemma toTransport_id {X : ∫ F} : + toTransport X (𝟙 X.base) = eqToHom transport_id.symm := by + apply Grothendieck.toTransport_id + +lemma toTransport_eqToHom {X: C} {X' : ∫ F} (hX': forget.obj X' = X): + toTransport X' (eqToHom hX') = eqToHom (by subst hX'; simp [transport_id]) := by + apply Grothendieck.toTransport_eqToHom + +lemma transport_comp (x : ∫ F) {c d : C} (t : x.base ⟶ c) (t' : c ⟶ d): + transport x (t ≫ t') = transport (transport x t) t' := by + apply Grothendieck.transport_comp + +lemma toTransport_comp (x : ∫ F) {c d: C} (t : x.base ⟶ c) (t' : c ⟶ d): + toTransport x (t ≫ t') = + toTransport x t ≫ toTransport (transport x t) t' ≫ eqToHom (transport_comp x t t').symm := by + apply Grothendieck.toTransport_comp + def isoMk {X Y : ∫(F)} (f : X ⟶ Y) : X ≅ Y := by fapply Grothendieck.isoMk · exact (Groupoid.isoEquivHom _ _).2 f.base @@ -678,15 +706,39 @@ lemma pre_map_fiber {x y} (f : x ⟶ y) : ((pre F G).map f).fiber = f.fiber := b @[simp] theorem pre_id : pre F (𝟭 C) = 𝟭 _ := rfl +section + +variable {G H : D ⥤ C} (α : G ≅ H) + /-- An natural isomorphism between functors `G ≅ H` induces a natural isomorphism between the canonical morphism `pre F G` and `pre F H`, up to composition with `∫(G ⋙ F) ⥤ ∫(H ⋙ F)`. -/ -def preNatIso {G H : D ⥤ C} (α : G ≅ H) : +def preNatIso : pre F G ≅ map (whiskerRight α.hom F) ⋙ (pre F H) := Grothendieck.preNatIso _ _ +@[simp] theorem preNatIso_hom_app_base (x) : + ((preNatIso F α).hom.app x).base = α.hom.app x.base := + Grothendieck.preNatIso_hom_app_base .. + +@[simp] theorem preNatIso_hom_app_fiber (x) : + ((preNatIso F α).hom.app x).fiber = 𝟙 _ := + Grothendieck.preNatIso_hom_app_fiber .. + +theorem preNatIso_congr {G H : D ⥤ C} {α β : G ≅ H} (h : α = β) : + preNatIso F α = preNatIso F β ≪≫ eqToIso (by subst h; simp) := by + subst h + simp + +@[simp] theorem preNatIso_eqToIso {G H : D ⥤ C} {h : G = H} : + preNatIso F (eqToIso h) = + eqToIso (by subst h; simp [map_id_eq, Functor.id_comp]) := + Grothendieck.preNatIso_eqToIso .. + +end + /-- Given an equivalence of categories `G`, `preInv _ G` is the (weak) inverse of the `pre _ G.functor`. -/ @@ -717,6 +769,54 @@ theorem pre_comp_forget (α : D ⥤ C) (A : C ⥤ Grpd) : simp · simp +noncomputable section + +variable {F} {x y : ∫ F} (f : x ⟶ y) [IsIso f] + +instance : IsIso f.base := by + refine ⟨ (CategoryTheory.inv f).base , ?_, ?_ ⟩ + · simp [← comp_base] + · simp [← comp_base] + +def invFiber : y.fiber ⟶ (F.map f.base).obj x.fiber := + eqToHom (by simp [← Functor.comp_obj, ← Grpd.comp_eq_comp, ← Functor.map_comp, + ← Groupoidal.comp_base]) ≫ + (F.map f.base).map (CategoryTheory.inv f).fiber + +@[simp] +lemma fiber_comp_invFiber : f.fiber ≫ invFiber f = 𝟙 ((F.map f.base).obj x.fiber) := by + have h := comp_fiber f (CategoryTheory.inv f) + rw! [IsIso.hom_inv_id] at h + have h0 : F.map (CategoryTheory.inv f).base ⋙ F.map f.base = 𝟭 _ := by + simp [← Grpd.comp_eq_comp, ← Functor.map_comp, ← comp_base] + have h1 := Functor.congr_map (F.map f.base) h + simp [← heq_eq_eq, eqToHom_map, ← Functor.comp_map, Functor.congr_hom h0] at h1 + dsimp [invFiber] + rw! [← h1] + simp + +@[simp] +lemma invFiber_comp_fiber : invFiber f ≫ f.fiber = 𝟙 _ := by + have h := comp_fiber (CategoryTheory.inv f) f + rw! [IsIso.inv_hom_id] at h + simp [invFiber] + convert h.symm + · simp + · simp + · simpa using (eqToHom_heq_id_cod _ _ _).symm + +instance : IsIso f.fiber := + ⟨invFiber f , fiber_comp_invFiber f, invFiber_comp_fiber f⟩ + +lemma inv_base : CategoryTheory.inv f.base = (CategoryTheory.inv f).base := by + apply IsIso.inv_eq_of_hom_inv_id + simp [← comp_base] + +lemma inv_fiber : CategoryTheory.inv f.fiber = invFiber f := by + apply IsIso.inv_eq_of_hom_inv_id + simp + +end end section @@ -767,16 +867,6 @@ theorem map_comp_eq {G H : C ⥤ Grpd.{v₂,u₂}} (α : F ⟶ G) (β : G ⟶ H) map (α ≫ β) = map α ⋙ map β := by simp [map, Grothendieck.map_comp_eq] -theorem preNatIso_congr {G H : D ⥤ C} {α β : G ≅ H} (h : α = β) : - preNatIso F α = preNatIso F β ≪≫ eqToIso (by subst h; simp) := - Grothendieck.preNatIso_congr _ h - -@[simp] theorem preNatIso_eqToIso {G H : D ⥤ C} {h : G = H} : - preNatIso F (eqToIso h) = eqToIso (by - subst h - simp [Groupoidal.map_id_eq]) := - Grothendieck.preNatIso_eqToIso _ - theorem preNatIso_comp {G1 G2 G3 : D ⥤ C} (α : G1 ≅ G2) (β : G2 ≅ G3) : preNatIso F (α ≪≫ β) = preNatIso F α ≪≫ Functor.isoWhiskerLeft _ (preNatIso F β) ≪≫ eqToIso (by simp [map_comp_eq, Functor.assoc]) := @@ -902,6 +992,25 @@ lemma pre_congr_functor {Γ Δ : Type*} [Category Γ] [Category Δ] (σ : Δ ⥤ simp only [eqToHom_refl, map_id_eq] exact rfl +lemma fiber_eqToHom_comp_heq {Γ : Type*} [Category Γ] + {F : Γ ⥤ Grpd} {x' x y : ∫ F} (h : x' = x) (f : x ⟶ y) : + (eqToHom h ≫ f).fiber ≍ f.fiber := by + subst h + simp [eqToHom_map] + +lemma fiber_eq_eqToHom_comp_heq {Γ : Type*} [Category Γ] + {F : Γ ⥤ Grpd} {x' x y : ∫ F} (g : x' ⟶ x) (h : x' = x) (hg : g = eqToHom h) + (f : x ⟶ y) : (eqToHom h ≫ f).fiber ≍ f.fiber := by + subst h + simp [eqToHom_map] + +lemma fiber_comp_eqToHom_heq {Γ : Type*} [Category Γ] + {F : Γ ⥤ Grpd} {x y y' : ∫ F} (h : y = y') (f : x ⟶ y) : + (f ≫ eqToHom h).fiber ≍ f.fiber := by + subst h + simp + + end end Groupoidal diff --git a/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean b/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean index 9cd27f1b..20f2df7c 100644 --- a/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean +++ b/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean @@ -108,6 +108,28 @@ theorem toPGrpd_eq_toPGrpd' : toPGrpd A = toPGrpd' A := by def isPullback : Functor.IsPullback (toPGrpd A) forget PGrpd.forgetToGrpd A := cast (by rw [toPGrpd_eq_toPGrpd']) (isPullback' A) +/-- +The left square is a pullback since the right square and outer square are. + ∫(σ ⋙ A) ------------ pre ---------> ∫(A) + | | + | | + forget forget + | | + | | + v v + Δ -------------- σ ---------------> Γ +-/ +def pre_isPullback {C : Type u} [Groupoid.{v, u} C] {D : Type u₁} + [Groupoid.{v₁, u₁} D] (F : C ⥤ Grpd) (G : D ⥤ C) : + Functor.IsPullback (pre F G) (forget (F := G ⋙ F)) (forget (F := F)) G := + Functor.IsPullback.Paste.ofRight + (no := pre F G) (rth := toPGrpd F) (west := forget (F := G ⋙ F)) (sah := forget (F := F)) + (east := PGrpd.forgetToGrpd) (uth := F) + (by simp [Functor.Groupoidal.pre_comp_forget]) + (by simp [Functor.Groupoidal.toPGrpd_forgetToGrpd]) + (by apply Functor.Groupoidal.isPullback) + (by apply Functor.Groupoidal.isPullback) + end section @@ -203,14 +225,6 @@ section variable {C : Type u} [Category.{v} C] {D : Type u₁} [Category.{v₁} D] (F : C ⥤ Grpd) {G H : D ⥤ C} (α : G ≅ H) -@[simp] theorem preNatIso_hom_app_base (x) : - ((preNatIso F α).hom.app x).base = α.hom.app x.base := - Grothendieck.preNatIso_hom_app_base _ _ _ - -@[simp] theorem preNatIso_hom_app_fiber (x) : - ((preNatIso F α).hom.app x).fiber = 𝟙 _ := - Grothendieck.preNatIso_hom_app_fiber _ _ _ - @[simp] theorem map_eqToHom_toPGrpd {Γ : Type*} [Category Γ] (A A' : Γ ⥤ Grpd) (h : A = A'): map (eqToHom h) ⋙ toPGrpd A' = toPGrpd A := by diff --git a/HoTTLean/Groupoids/Id.lean b/HoTTLean/Groupoids/Id.lean index 48f89cbd..7233977c 100644 --- a/HoTTLean/Groupoids/Id.lean +++ b/HoTTLean/Groupoids/Id.lean @@ -1,4 +1,6 @@ import HoTTLean.Groupoids.UnstructuredModel +import HoTTLean.Model.Unstructured.Hurewicz +import HoTTLean.ForMathlib.CategoryTheory.ClovenIsofibration import HoTTLean.ForMathlib.CategoryTheory.RepPullbackCone @@ -6,503 +8,920 @@ universe w v u v₁ u₁ v₂ u₂ noncomputable section -namespace CategoryTheory - -open Functor.Groupoidal - - -def PGrpd.inc (G : Type) [Groupoid G] : G ⥤ PGrpd where - obj x := {base := Grpd.of G,fiber := x} - map f := {base := Functor.id G, fiber := f} - map_comp {X Y Z} f g := by - fapply Functor.Grothendieck.Hom.ext - · simp [Grpd.comp_eq_comp] - · simp [Grpd.forgetToCat] - --- namespace GrothendieckPointedCategories - --- abbrev BPCat := Grothendieck (PCat.forgetToCat) - --- namespace BPCat - --- abbrev forgetToCat : BPCat ⥤ Cat where --- obj x := x.base.base --- map f := f.base.base --- map_comp := by --- intros x y z f g --- exact rfl - --- abbrev FirstPointed : BPCat ⥤ PCat := Grothendieck.forget _ - --- def SecondPointed : BPCat ⥤ PCat where --- obj x := {base := x.base.base, fiber := x.fiber} --- map f := {base := f.base.base, fiber := f.fiber} --- map_comp := by --- intros x y z f g --- exact rfl - --- /- This needs a better name but I cant come up with one now-/ --- theorem Comutes : FirstPointed ⋙ PCat.forgetToCat = SecondPointed ⋙ PCat.forgetToCat := by --- simp[FirstPointed,SecondPointed,PCat.forgetToCat,Functor.comp] +open CategoryTheory +namespace FunctorOperation --- def isPullback : Functor.IsPullback SecondPointed.{u,v} FirstPointed.{u,v} PCat.forgetToCat.{u,v} PCat.forgetToCat.{u,v} --- := @CategoryTheory.Grothendieck.isPullback PCat _ (PCat.forgetToCat) +variable {Γ : Type u} [Groupoid.{v} Γ] {Δ : Type u₂} [Groupoid.{v₂} Δ] (σ : Δ ⥤ Γ) + {A : Γ ⥤ Grpd.{v₁,u₁}} {a0 a1 : Γ ⥤ PGrpd.{v₁,u₁}} + (a0_tp : a0 ⋙ PGrpd.forgetToGrpd = A) (a1_tp : a1 ⋙ PGrpd.forgetToGrpd = A) + +/-- The identity type former takes a (family of) groupoid(s) `A` with two points `a0 a1` +to the (family of) set(s) of isomorphisms +between its two given points `A(a0,a1)`. -/ +def IdObj (x : Γ) : Grpd := + Grpd.of <| Discrete <| PGrpd.objFiber' a0_tp x ⟶ PGrpd.objFiber' a1_tp x + +def IdMap {x y : Γ} (f : x ⟶ y) : IdObj a0_tp a1_tp x ⥤ IdObj a0_tp a1_tp y := + Discrete.functor <| fun g => + ⟨inv (PGrpd.mapFiber' a0_tp f) ≫ (A.map f).map g ≫ PGrpd.mapFiber' a1_tp f⟩ + +lemma IdMap_id (X : Γ) : IdMap a0_tp a1_tp (𝟙 X) = 𝟙 (IdObj a0_tp a1_tp X) := by + apply Discrete.functor_ext + intro g + apply Discrete.ext + simp [IdMap] + +lemma IdMap_comp {X Y Z : Γ} (f1 : X ⟶ Y) (f2 : Y ⟶ Z) : IdMap a0_tp a1_tp (f1 ≫ f2) = + IdMap a0_tp a1_tp f1 ⋙ IdMap a0_tp a1_tp f2 := by + subst a0_tp + apply Discrete.functor_ext + intro g + apply Discrete.ext + simp only [Functor.comp_obj, Functor.Grothendieck.forget_obj, PGrpd.objFiber'_rfl, IdMap, + Functor.comp_map, Functor.Grothendieck.forget_map, PGrpd.mapFiber'_rfl, + Discrete.functor_obj_eq_as, Functor.map_comp, Functor.map_inv, + Category.assoc, IsIso.eq_inv_comp] + simp only [PGrpd.mapFiber, PGrpd.map_comp_fiber, Functor.Grothendieck.forget_obj, + Functor.Grothendieck.forget_map, ← Category.assoc, IsIso.inv_comp, inv_eqToHom, + PGrpd.mapFiber', Functor.comp_obj, Functor.comp_map, PGrpd.objFiber'EqToHom, + PGrpd.mapFiber'EqToHom, Functor.map_comp, eqToHom_map, eqToHom_trans, IsIso.hom_inv_id, + Category.id_comp, Functor.Grothendieck.Hom.comp_base, Grpd.comp_eq_comp, eqToHom_naturality, + Category.comp_id, ← heq_eq_eq] + congr 1 + rw! [Functor.map_comp] + simp only [Functor.Grothendieck.Hom.comp_base, Grpd.comp_eq_comp, Functor.comp_obj, + eqToHom_refl, Functor.comp_map, Category.id_comp, Category.assoc, ← heq_eq_eq] + congr 1 + have h := Functor.congr_hom a1_tp f2 + simp only [Functor.comp_obj, Functor.Grothendieck.forget_obj, Functor.comp_map, + Functor.Grothendieck.forget_map, Grpd.comp_eq_comp] at h + rw! [h] + simp only [← Grpd.comp_eq_comp, Grpd.comp_obj, ← Functor.comp_map, ← heq_eq_eq, + heq_eqToHom_comp_iff, heq_comp_eqToHom_iff, eqToHom_comp_heq_iff] + simp [Grpd.eqToHom_hom] + +@[simps!] +def Id : Γ ⥤ Grpd where + obj := IdObj a0_tp a1_tp + map := IdMap a0_tp a1_tp + map_id := IdMap_id a0_tp a1_tp + map_comp := IdMap_comp a0_tp a1_tp + +lemma Id_comp : Id (A := σ ⋙ A) (a0 := σ ⋙ a0) (a1 := σ ⋙ a1) + (by simp[Functor.assoc, a0_tp]) (by simp[Functor.assoc, a1_tp]) = + σ ⋙ Id a0_tp a1_tp := + rfl --- end BPCat +namespace Path + +open CategoryTheory.Prod + +section + +variable (p : Grpd.Interval × Γ ⥤ PGrpd) + +abbrev ff (x : Γ) : Grpd.Interval × Γ := ⟨⟨⟨.false⟩⟩, x⟩ +abbrev ffm {x y : Γ} (f : x ⟶ y) : ff x ⟶ ff y := ⟨𝟙 _, f⟩ +abbrev tt (x : Γ) : Grpd.Interval × Γ := ⟨⟨⟨.true⟩⟩, x⟩ +abbrev ttm {x y : Γ} (f : x ⟶ y) : tt x ⟶ tt y := ⟨𝟙 _, f⟩ +abbrev ft (x : Γ) : ff x ⟶ tt x := ⟨⟨⟨⟩⟩, 𝟙 x⟩ +abbrev tf (x : Γ) : tt x ⟶ ff x := ⟨⟨⟨⟩⟩, 𝟙 x⟩ + +abbrev unPath0 : Γ ⥤ PGrpd := sectR ⟨⟨.false⟩⟩ _ ⋙ p + +abbrev unPath1 : Γ ⥤ PGrpd := sectR ⟨⟨.true⟩⟩ _ ⋙ p + +variable {p} (p_tp : p ⋙ PGrpd.forgetToGrpd = snd _ _ ⋙ A) + +include p_tp in +@[simp] +lemma unPath0_comp_forgetToGrpd : unPath0 p ⋙ PGrpd.forgetToGrpd = A := by + rw [Functor.assoc, p_tp, ← Functor.assoc, sectR_comp_snd, Functor.id_comp] + +include p_tp in +@[simp] +lemma unPath1_comp_forgetToGrpd : unPath1 p ⋙ PGrpd.forgetToGrpd = A := by + rw [Functor.assoc, p_tp, ← Functor.assoc, sectR_comp_snd, Functor.id_comp] + +lemma objFiber'_unPath0 (x) : PGrpd.objFiber' (unPath0_comp_forgetToGrpd p_tp) x = + PGrpd.objFiber' p_tp (ff x) := by + dsimp [PGrpd.objFiber', PGrpd.objFiber] + +@[simp] +abbrev unPathId : Γ ⥤ Grpd := + Id (A := A) (a0 := unPath0 p) (a1 := unPath1 p) + (unPath0_comp_forgetToGrpd p_tp) (unPath1_comp_forgetToGrpd p_tp) + +@[simps!] +def unPathFibObj (x : Γ) : @IdObj _ _ A (unPath0 p) (unPath1 p) (unPath0_comp_forgetToGrpd p_tp) + (unPath1_comp_forgetToGrpd p_tp) x := + ⟨eqToHom (by simp [objFiber'_unPath0 p_tp]) ≫ PGrpd.mapFiber' p_tp (ft x)⟩ + +lemma unPathFibObj_comp (x : Δ) : unPathFibObj (A := σ ⋙ A) (p := Functor.prod (𝟭 _) σ ⋙ p) + (by simp [Functor.assoc, p_tp]; rfl) x = unPathFibObj p_tp (σ.obj x) := by + apply Discrete.ext + simp only [Functor.comp_obj, unPathFibObj_as, Functor.comp_map, PGrpd.mapFiber', snd_obj, snd_map, + Functor.prod_obj, Functor.id_obj, Functor.Grothendieck.forget_obj, PGrpd.objFiber'EqToHom, + Functor.prod_map, Functor.id_map, PGrpd.mapFiber'EqToHom, Grpd.eqToHom_hom, eqToHom_trans_assoc] + rw! [CategoryTheory.Functor.map_id] + +lemma IdMap_unPath {x y} (f : x ⟶ y) : + ((IdMap (unPath0_comp_forgetToGrpd p_tp) (unPath1_comp_forgetToGrpd p_tp) f).obj + (unPathFibObj p_tp x)).as = (unPathFibObj p_tp y).as := by + dsimp [IdMap] + have comm : ft x ≫ ttm f = ffm f ≫ ft y := by ext; rfl; simp + have h1 := (PGrpd.mapFiber'_comp' p_tp (ft x) (ttm f)).symm + rw! [comm, PGrpd.mapFiber'_comp' p_tp (ffm f) (ft y)] at h1 + simp only [Functor.comp_obj, snd_obj, prod_comp, Functor.comp_map, snd_map, Grpd.map_id_map, + Category.assoc, eqToHom_trans_assoc, ← heq_eq_eq, heq_eqToHom_comp_iff, + eqToHom_comp_heq_iff] at h1 + simp only [PGrpd.mapFiber'_naturality p_tp (sectR ⟨⟨.false⟩⟩ _), sectR_obj, sectR_map, + Functor.map_comp, eqToHom_map, PGrpd.mapFiber'_naturality p_tp (sectR ⟨⟨.true⟩⟩ _), + Category.assoc, IsIso.inv_comp_eq] + rw! [h1] + simp + +def unPathFibMap {x y : Γ} (f : x ⟶ y) : + (IdMap (unPath0_comp_forgetToGrpd p_tp) (unPath1_comp_forgetToGrpd p_tp) f).obj + (unPathFibObj p_tp x) ⟶ unPathFibObj p_tp y := + ⟨⟨IdMap_unPath ..⟩⟩ + +lemma unPathFibMap_id (x : Γ) : unPathFibMap p_tp (𝟙 x) = eqToHom (by simp [IdMap_id]) := by + aesop_cat + +lemma unPathFibMap_comp {x y z : Γ} (f1 : x ⟶ y) (f2 : y ⟶ z) : + unPathFibMap p_tp (f1 ≫ f2) = + eqToHom (by simp only [IdMap_comp]; rfl) ≫ + ((unPathId p_tp).map f2).map (unPathFibMap p_tp f1) ≫ unPathFibMap p_tp f2 := by + aesop_cat + +def unPath : Γ ⥤ PGrpd := + PGrpd.functorTo (unPathId p_tp) (unPathFibObj p_tp) (unPathFibMap p_tp) + (unPathFibMap_id p_tp) (fun f1 f2 => by dsimp only; aesop_cat) + +lemma unPath_comp : unPath (A := σ ⋙ A) (p := Functor.prod (𝟭 _) σ ⋙ p) + (by simp [Functor.assoc, p_tp]; rfl) = σ ⋙ unPath p_tp := by + -- rw [PGrpd.functorTo] + apply PGrpd.Functor.hext + · rfl + · intro x + simp only [unPath, Functor.comp_obj, heq_eq_eq] + -- rw [PGrpd.functorTo_obj_fiber] --FIXME why timeout? + convert_to unPathFibObj (A := σ ⋙ A) (p := Functor.prod (𝟭 _) σ ⋙ p) + (by simp [Functor.assoc, p_tp]; rfl) x = + unPathFibObj (A := A) (p := p) p_tp (σ.obj x) + rw [unPathFibObj_comp] + · intro x y f + simp only [unPath, Functor.comp_map] + -- rw [PGrpd.functorTo_map_fiber] + convert_to unPathFibMap (A := σ ⋙ A) (p := Functor.prod (𝟭 _) σ ⋙ p) + (by simp [Functor.assoc, p_tp]; rfl) f ≍ + unPathFibMap (A := A) (p := p) p_tp (σ.map f) + rw! (castMode := .all) [unPathFibObj_comp _ p_tp] + rw! (castMode := .all) [unPathFibObj_comp _ p_tp] + rfl + +@[simp] +lemma unPath_comp_forgetToGrpd : unPath p_tp ⋙ PGrpd.forgetToGrpd = + Id (a0 := unPath0 p) (a1 := unPath1 p) (unPath0_comp_forgetToGrpd p_tp) + (unPath1_comp_forgetToGrpd p_tp) := + rfl -abbrev BPGrpd := ∫ PGrpd.forgetToGrpd +end + +section + +variable {p : Γ ⥤ PGrpd} + (p_tp : p ⋙ PGrpd.forgetToGrpd = FunctorOperation.Id a0_tp a1_tp) + +def pathFibObj : (x : Grpd.Interval × Γ) → A.obj x.2 +| ⟨⟨⟨.false⟩⟩, x2⟩ => PGrpd.objFiber' a0_tp x2 +| ⟨⟨⟨.true⟩⟩, x2⟩ => PGrpd.objFiber' a1_tp x2 + +def pathFibMap : {x y : Grpd.Interval × Γ} → (f : x ⟶ y) → + ((A.map f.2).obj (pathFibObj a0_tp a1_tp x) ⟶ pathFibObj a0_tp a1_tp y) +| ⟨⟨⟨.false⟩⟩, _⟩, ⟨⟨⟨.false⟩⟩, _⟩, f => PGrpd.mapFiber' a0_tp f.2 +| ⟨⟨⟨.false⟩⟩, _⟩, ⟨⟨⟨.true⟩⟩, y2⟩, f => (PGrpd.mapFiber' a0_tp f.2) ≫ (PGrpd.objFiber' p_tp y2).1 +| ⟨⟨⟨.true⟩⟩, _⟩, ⟨⟨⟨.false⟩⟩, y2⟩, f => + (PGrpd.mapFiber' a1_tp f.2) ≫ inv (PGrpd.objFiber' p_tp y2).1 +| ⟨⟨⟨.true⟩⟩, _⟩, ⟨⟨⟨.true⟩⟩, _⟩, f => PGrpd.mapFiber' a1_tp f.2 + +lemma pathFibMap_id (x : Grpd.Interval × Γ) : pathFibMap a0_tp a1_tp p_tp (𝟙 x) = + eqToHom (by simp) := by + rcases x with ⟨⟨⟨_|_⟩⟩ , x⟩ <;> simp [pathFibMap] + +open PGrpd in +lemma map_objFiber'_mapFiber' {x y} (f : x ⟶ y) : + (A.map f).map (objFiber' p_tp x).as ≫ mapFiber' a1_tp f = + mapFiber' a0_tp f ≫ (objFiber' p_tp y).as := by + simpa using (mapFiber' p_tp f).1.1 + +open PGrpd in +lemma map_objFiber'_mapFiber'_inv_objFiber' {x y} (f : x ⟶ y) : + (A.map f).map (objFiber' p_tp x).as ≫ mapFiber' a1_tp f ≫ inv (objFiber' p_tp y).as = + mapFiber' a0_tp f := by + slice_lhs 1 2 => rw [map_objFiber'_mapFiber'] + simp + +open PGrpd in +lemma mapFiber'_inv_objFiber' {x y} (f : x ⟶ y) : mapFiber' a1_tp f ≫ inv (objFiber' p_tp y).as = + inv ((A.map f).map (objFiber' p_tp x).as) ≫ mapFiber' a0_tp f := by + rw [IsIso.eq_inv_comp] + slice_lhs 1 2 => rw [map_objFiber'_mapFiber'] + simp + +attribute [simp] pathFibMap pathFibObj PGrpd.mapFiber'_comp' Grpd.forgetToCat in +lemma pathFibMap_comp {x y z : Grpd.Interval × Γ} (f : x ⟶ y) (g : y ⟶ z) : + pathFibMap a0_tp a1_tp p_tp (f ≫ g) = + eqToHom (by simp) ≫ (A.map g.2).map (pathFibMap a0_tp a1_tp p_tp f) ≫ + pathFibMap a0_tp a1_tp p_tp g := by + rcases x with ⟨⟨⟨_|_⟩⟩ , x⟩ + · rcases y with ⟨⟨⟨_|_⟩⟩ , y⟩ + · rcases z with ⟨⟨⟨_|_⟩⟩ , z⟩ <;> simp + · rcases z with ⟨⟨⟨_|_⟩⟩ , z⟩ <;> simp [map_objFiber'_mapFiber'_inv_objFiber', + map_objFiber'_mapFiber'] + · rcases y with ⟨⟨⟨_|_⟩⟩ , y⟩ + · rcases z with ⟨⟨⟨_|_⟩⟩ , z⟩ + · simp; simp [mapFiber'_inv_objFiber'] + · simp only [prod_comp, pathFibObj, pathFibMap, PGrpd.mapFiber'_comp', Functor.map_comp, + Functor.map_inv, Category.assoc] + slice_rhs 3 4 => rw [← mapFiber'_inv_objFiber'] + simp + · rcases z with ⟨⟨⟨_|_⟩⟩ , z⟩ <;> simp + +def path : Grpd.Interval × Γ ⥤ PGrpd := + Functor.Grothendieck.functorTo (snd _ _ ⋙ A) (pathFibObj a0_tp a1_tp) + (pathFibMap a0_tp a1_tp p_tp) (pathFibMap_id a0_tp a1_tp p_tp) + (pathFibMap_comp a0_tp a1_tp p_tp) + +@[simp] +lemma path_comp_forgetToGrpd : path a0_tp a1_tp p_tp ⋙ PGrpd.forgetToGrpd = snd _ _ ⋙ A := by + rfl -namespace BPGrpd +@[simp] +lemma sectR_false_comp_path : sectR ⟨⟨.false⟩⟩ _ ⋙ path a0_tp a1_tp p_tp = a0 := by + apply Functor.Grothendieck.FunctorTo.hext + · rw [Functor.assoc, path, Functor.Grothendieck.functorTo_forget, ← Functor.assoc, + sectR_comp_snd, a0_tp, Functor.id_comp] + · intro x + simp [path, PGrpd.objFiber', PGrpd.objFiber, Grpd.eqToHom_obj] + · intro x y f + simp [path, PGrpd.mapFiber', PGrpd.mapFiber'EqToHom, Grpd.eqToHom_hom] + apply HEq.trans (eqToHom_comp_heq _ _) + simp -abbrev fst : BPGrpd ⥤ PGrpd := Functor.Groupoidal.forget +@[simp] +lemma sectR_true_comp_path : sectR ⟨⟨.true⟩⟩ _ ⋙ path a0_tp a1_tp p_tp = a1 := by + apply Functor.Grothendieck.FunctorTo.hext + · rw [Functor.assoc, path, Functor.Grothendieck.functorTo_forget, ← Functor.assoc, + sectR_comp_snd, a1_tp, Functor.id_comp] + · intro x + simp [path, PGrpd.objFiber', PGrpd.objFiber, Grpd.eqToHom_obj] + · intro x y f + simp [path, PGrpd.mapFiber', PGrpd.mapFiber'EqToHom, Grpd.eqToHom_hom] + apply HEq.trans (eqToHom_comp_heq _ _) + simp -abbrev forgetToGrpd : BPGrpd ⥤ Grpd := fst ⋙ PGrpd.forgetToGrpd +lemma unPath0_path : unPath0 (path a0_tp a1_tp p_tp) = a0 := by + apply Functor.Grothendieck.FunctorTo.hext + · simp + · intro x + simpa [path] using PGrpd.objFiber'_heq a0_tp + · intro x y f + simpa [path] using PGrpd.mapFiber'_heq a0_tp f -def snd : BPGrpd ⥤ PGrpd := toPGrpd _ +lemma unPath1_path : unPath1 (path a0_tp a1_tp p_tp) = a1 := by + apply Functor.Grothendieck.FunctorTo.hext + · simp + · intro x + simpa [path] using PGrpd.objFiber'_heq a1_tp + · intro x y f + simpa [path] using PGrpd.mapFiber'_heq a1_tp f + +lemma unPathFibObj_path (x) : unPathFibObj (path_comp_forgetToGrpd a0_tp a1_tp p_tp) x = + PGrpd.objFiber' p_tp x := by + dsimp only [unPathFibObj] + apply Discrete.ext + simp [PGrpd.mapFiber, path] + +lemma mapFiber_path_ft (x) : PGrpd.mapFiber (path a0_tp a1_tp p_tp) (ft x) = + eqToHom (by simp [PGrpd.mapObjFiber, path, PGrpd.objFiber]) ≫ + (PGrpd.objFiber' p_tp x).as := by + dsimp [path, PGrpd.mapFiber] + simp + +lemma unPath_path : unPath (A := A) (path_comp_forgetToGrpd a0_tp a1_tp p_tp) = p := by + apply Functor.Grothendieck.FunctorTo.hext + · rw [unPath_comp_forgetToGrpd, p_tp] + rw! [unPath0_path, unPath1_path] + · intro x + exact heq_of_eq_of_heq (unPathFibObj_path ..) (PGrpd.objFiber'_heq p_tp) + · intro x y f + dsimp only [unPath] + apply heq_of_eq_of_heq (PGrpd.functorTo_map_fiber _ _ _ _ (unPathFibMap_comp _) _) + dsimp only [unPathFibMap] + apply HEq.trans _ (PGrpd.mapFiber'_heq p_tp f) + apply Discrete.Hom.hext + · simp + · simp only [heq_eq_eq] + ext + simp [IdMap_unPath, map_objFiber'_mapFiber', mapFiber_path_ft] + · simp [unPathFibObj_path] + +end + +section + +variable {p : Grpd.Interval × Γ ⥤ PGrpd} (p_tp : p ⋙ PGrpd.forgetToGrpd = snd _ _ ⋙ A) + (δ0_p : unPath0 p = a0) (δ1_p : unPath1 p = a1) + +include δ0_p p_tp in +lemma a0_comp_forgetToGrpd : a0 ⋙ PGrpd.forgetToGrpd = A := by + rw [← δ0_p, unPath0, Functor.assoc, p_tp, ← Functor.assoc, sectR_comp_snd, Functor.id_comp] + +include δ1_p p_tp in +lemma a1_comp_forgetToGrpd : a1 ⋙ PGrpd.forgetToGrpd = A := by + rw [← δ1_p, unPath1, Functor.assoc, p_tp, ← Functor.assoc, sectR_comp_snd, Functor.id_comp] + +lemma obj_ff_fiber (x) : (p.obj (ff x)).fiber ≍ + PGrpd.objFiber' (a0_comp_forgetToGrpd p_tp δ0_p) x := by + symm + convert PGrpd.objFiber'_heq (unPath0_comp_forgetToGrpd p_tp) (x := x) + rw [← δ0_p] + +lemma obj_tt_fiber (x) : (p.obj (tt x)).fiber ≍ + PGrpd.objFiber' (a1_comp_forgetToGrpd p_tp δ1_p) x := by + symm + convert PGrpd.objFiber'_heq (unPath1_comp_forgetToGrpd p_tp) (x := x) + rw [← δ1_p] + +lemma map_ff_fiber {x y : Γ} (f : ff x ⟶ ff y) : (p.map f).fiber ≍ + PGrpd.mapFiber' (a0_comp_forgetToGrpd p_tp δ0_p) f.2 := by + symm + convert PGrpd.mapFiber'_heq p_tp f + · rw! [← obj_ff_fiber p_tp δ0_p x] + rw! [PGrpd.objFiber'_heq p_tp] + · rw! [← obj_ff_fiber p_tp δ0_p y] + rw! [PGrpd.objFiber'_heq p_tp] + · rw! [← δ0_p, unPath0, PGrpd.mapFiber'_naturality p_tp (sectR { down := { as := false } } Γ)] + rw! [PGrpd.mapFiber'_heq p_tp] + rw! [PGrpd.mapFiber'_heq p_tp f] + rfl + +lemma map_tt_fiber {x y : Γ} (f : tt x ⟶ tt y) : (p.map f).fiber ≍ + PGrpd.mapFiber' (a1_comp_forgetToGrpd p_tp δ1_p) f.2 := by + symm + convert PGrpd.mapFiber'_heq p_tp f + · rw! [← obj_tt_fiber p_tp δ1_p x] + rw! [PGrpd.objFiber'_heq p_tp] + · rw! [← obj_tt_fiber p_tp δ1_p y] + rw! [PGrpd.objFiber'_heq p_tp] + · rw! [← δ1_p, unPath1, PGrpd.mapFiber'_naturality p_tp (sectR { down := { as := true } } Γ)] + rw! [PGrpd.mapFiber'_heq p_tp] + rw! [PGrpd.mapFiber'_heq p_tp f] + rfl + +lemma mapFiber'_ffm {x y : Γ} (f : x ⟶ y) : PGrpd.mapFiber' p_tp (ffm f) ≍ + PGrpd.mapFiber' (a0_comp_forgetToGrpd p_tp δ0_p) f := by + rw! [← δ0_p, PGrpd.mapFiber'_naturality p_tp (sectR ..)] + simp + +lemma mapFiber'_ttm {x y : Γ} (f : x ⟶ y) : PGrpd.mapFiber' p_tp (ttm f) ≍ + PGrpd.mapFiber' (a1_comp_forgetToGrpd p_tp δ1_p) f := by + rw! [← δ1_p, PGrpd.mapFiber'_naturality p_tp (sectR ..)] + simp + +@[simp] +lemma objFiber_unPath (x) : PGrpd.objFiber (unPath p_tp) x = unPathFibObj p_tp x := + rfl -/-- The commutative square - BPGrpd ----> PGrpd - | | - | | - | | - | | - V V - PGrpd ----> Grpd --/ -theorem fst_forgetToGrpd : fst ⋙ PGrpd.forgetToGrpd = snd ⋙ PGrpd.forgetToGrpd := by - simp [fst, snd, toPGrpd_forgetToGrpd] +lemma objFiber'_unPath_as (x) : (PGrpd.objFiber' (unPath_comp_forgetToGrpd p_tp) x).as = + eqToHom (by simp [objFiber'_unPath0 p_tp]) ≫ PGrpd.mapFiber' p_tp (ft x) := by + rfl -/- BPGrpd is the pullback of PGrpd.forgetToGrpd with itself -/ -def isPullback : Functor.IsPullback snd.{u,v} fst.{u,v} PGrpd.forgetToGrpd.{u,v} - PGrpd.forgetToGrpd.{u,v} := by - apply @Functor.Groupoidal.isPullback PGrpd _ (PGrpd.forgetToGrpd) +lemma mapFiber_ft (x) : PGrpd.mapFiber p (ft x) ≍ + (PGrpd.objFiber' (unPath_comp_forgetToGrpd p_tp) x).as := by + symm + rw [objFiber'_unPath_as] + simp only [Functor.comp_obj, snd_obj, Functor.comp_map, snd_map, PGrpd.mapFiber', + Grpd.forgetToCat, Functor.Grothendieck.forget_obj, PGrpd.objFiber'EqToHom, + PGrpd.mapFiber'EqToHom, Grpd.eqToHom_hom, eqToHom_trans_assoc, PGrpd.mapFiber] + apply HEq.trans (eqToHom_comp_heq ..) + simp + +include p_tp in +lemma map_ft_base (x) : (p.map (ft x)).base = eqToHom (by + have h0 := Functor.congr_obj p_tp (ff x) + have h1 := Functor.congr_obj p_tp (tt x) + simp at * + rw [h0, h1]) := by + simpa using Functor.congr_hom p_tp (ft x) + +include p_tp in +lemma map_tf_base (x) : (p.map (tf x)).base = eqToHom (by + have h0 := Functor.congr_obj p_tp (ff x) + have h1 := Functor.congr_obj p_tp (tt x) + simp at * + rw [h0, h1]) := by + simpa using Functor.congr_hom p_tp (tf x) + +include p_tp in +lemma inv_mapFiber_tf_heq (y : Γ) : + inv (PGrpd.mapFiber p (tf y)) ≍ PGrpd.mapFiber p (ft y) := by + have : inv (tf y : tt y ⟶ (ff y : Grpd.Interval × Γ)) = ft y := by + apply IsIso.inv_eq_of_hom_inv_id + aesop_cat + rw [← this] + rw [PGrpd.mapFiber_inv] + apply HEq.trans _ (eqToHom_comp_heq ..).symm + rw! [PGrpd.inv_mapFiber_heq] + simp only [Grpd.forgetToCat, Functor.Grothendieck.forget_obj, Functor.comp_obj, Functor.comp_map, + Functor.Grothendieck.forget_map, Cat.of_α, id_eq, cast_heq_iff_heq] + rw! [map_tf_base p_tp, Grpd.eqToHom_hom] + simp only [Grpd.forgetToCat, PGrpd.mapFiber, cast_heq_iff_heq] + rw! (castMode := .all) [Functor.map_inv] + simp + +open PGrpd in +lemma path_map_ft_fiber {x y} (f : ff x ⟶ tt y) : + ((path (a0_comp_forgetToGrpd p_tp δ0_p) (a1_comp_forgetToGrpd p_tp δ1_p) + (p := FunctorOperation.Path.unPath p_tp) + (by rw [unPath_comp_forgetToGrpd]; congr)).map f).fiber ≍ (p.map f).fiber := by + simp only [Grpd.forgetToCat, path, Functor.Grothendieck.functorTo_obj_base, + Functor.comp_obj, snd_obj, Cat.of_α, Functor.Grothendieck.functorTo_map_base, + Functor.comp_map, snd_map, id_eq, Functor.Grothendieck.functorTo_obj_fiber, pathFibObj, + Functor.Grothendieck.functorTo_map_fiber, pathFibMap] + -- have hf : f = ttm f.2 ≫ ft y := by aesop_cat + -- TODO: mwe and report: this should not type check + have hf : f = ffm f.2 ≫ ft y := by aesop_cat + conv => rhs; rw! (castMode := .all) [hf] + simp only [heq_eqRec_iff_heq] + convert_to _ ≍ mapFiber _ _ + erw [mapFiber_comp] + rw! [← mapFiber'_ffm p_tp δ0_p] + apply HEq.trans _ (eqToHom_comp_heq ..).symm + apply Grpd.comp_heq_comp + · erw [Functor.congr_obj p_tp (tt y)] + simp + · have H := Functor.congr_hom p_tp (ffm f.2) + simp only [Grpd.forgetToCat, Functor.comp_obj, Functor.Grothendieck.forget_obj, + Functor.comp_map, Functor.Grothendieck.forget_map, snd_obj, snd_map, + Grpd.comp_eq_comp] at H + erw [Functor.congr_hom p_tp (ft y)] + rw! [← δ0_p, unPath0, objFiber'_naturality (sectR ..) p_tp, objFiber'_heq] + simp [mapObjFiber, Grpd.eqToHom_obj, objFiber, Functor.congr_obj H, + Grpd.eqToHom_obj] + · simp only [Functor.Grothendieck.forget_map] + rw! [← δ0_p, unPath0, objFiber'_naturality (sectR ..) p_tp, objFiber'_heq, + map_ft_base p_tp, Grpd.eqToHom_obj] + simp [objFiber] + · rw! [← δ1_p, unPath1, objFiber'_naturality (sectR ..) p_tp, objFiber'_heq] + simp [objFiber] + · simp only [Functor.comp_obj, snd_obj, Functor.comp_map, snd_map, Grpd.forgetToCat, + Functor.Grothendieck.forget_obj, Functor.Grothendieck.forget_map, cast_heq_iff_heq] + rw! [map_ft_base p_tp, mapFiber'_heq] + simp [Grpd.eqToHom_hom, mapFiber] + · rw! [mapFiber_ft p_tp y] + simp only [Grpd.forgetToCat, Functor.Grothendieck.forget_obj, Functor.Grothendieck.forget_map, + objFiber'_rfl, heq_cast_iff_heq] + apply Discrete.as_heq_as + · congr + · symm; assumption + · symm; assumption + · apply (objFiber'_heq ..).trans + simp [objFiber] + +open PGrpd in +lemma path_map_tf_fiber {x y} (f : tt x ⟶ ff y) : + ((path (a0_comp_forgetToGrpd p_tp δ0_p) (a1_comp_forgetToGrpd p_tp δ1_p) + (p := FunctorOperation.Path.unPath p_tp) + (by rw [unPath_comp_forgetToGrpd]; congr)).map f).fiber ≍ (p.map f).fiber := by + simp only [Grpd.forgetToCat, path, Functor.Grothendieck.functorTo_obj_base, Functor.comp_obj, + snd_obj, Cat.of_α, Functor.Grothendieck.functorTo_map_base, Functor.comp_map, snd_map, id_eq, + Functor.Grothendieck.functorTo_obj_fiber, pathFibObj, Functor.Grothendieck.functorTo_map_fiber, + pathFibMap] + have hf : f = ttm f.2 ≫ tf y := by aesop_cat + conv => rhs; rw! (castMode := .all) [hf] + simp only [heq_eqRec_iff_heq] + convert_to _ ≍ mapFiber _ _ + erw [mapFiber_comp] + rw! [← mapFiber'_ttm p_tp δ1_p f.2] + apply HEq.trans _ (eqToHom_comp_heq ..).symm + have : A.obj y ≍ forgetToGrpd.obj (p.obj (ff y)) := by erw [Functor.congr_obj p_tp (ff y)]; simp + have : objFiber' (a0_comp_forgetToGrpd p_tp δ0_p) y ≍ objFiber p (ff y) := by + rw! [← δ0_p, unPath0, objFiber'_naturality (sectR ..) p_tp, objFiber'_heq] + simp [objFiber] + apply Grpd.comp_heq_comp + · assumption + · have H := Functor.congr_hom p_tp (ttm f.2) + simp only [Grpd.forgetToCat, Functor.comp_obj, Functor.Grothendieck.forget_obj, + Functor.comp_map, Functor.Grothendieck.forget_map, snd_obj, snd_map, + Grpd.comp_eq_comp] at H + erw [Functor.congr_hom p_tp (tf y)] + rw! [← δ1_p, unPath1, objFiber'_naturality (sectR ..) p_tp, objFiber'_heq] + simp [mapObjFiber, Grpd.eqToHom_obj, objFiber, Functor.congr_obj H, + Grpd.eqToHom_obj] + · simp only [Functor.Grothendieck.forget_map] + rw! [← δ1_p, unPath1, objFiber'_naturality (sectR ..) p_tp, objFiber'_heq, + map_tf_base p_tp, Grpd.eqToHom_obj] + simp [objFiber] + · assumption + · simp only [Functor.comp_obj, snd_obj, Functor.comp_map, snd_map, Grpd.forgetToCat, + Functor.Grothendieck.forget_obj, Functor.Grothendieck.forget_map, cast_heq_iff_heq] + rw! [map_tf_base p_tp, mapFiber'_heq] + simp [Grpd.eqToHom_hom, mapFiber] + · apply Grpd.inv_heq_of_heq_inv + · assumption + · assumption + · rw! [← obj_tt_fiber p_tp δ1_p] + simp [mapObjFiber, objFiber, map_tf_base p_tp, Grpd.eqToHom_obj] + · simp [objFiber', Grpd.eqToHom_obj] + apply HEq.trans (b := (unPathFibObj p_tp y).as) + · apply Discrete.as_heq_as + · congr 1 + · rw! [← δ0_p] + simp [unPath0, objFiber_naturality, Grpd.eqToHom_obj, objFiber'] + · rw! [← δ1_p] + simp [unPath1, objFiber_naturality, Grpd.eqToHom_obj, objFiber'] + · simp + · simp + apply HEq.trans (eqToHom_comp_heq ..) + rw! [inv_mapFiber_tf_heq p_tp, mapFiber'_heq] + simp [mapFiber] + +lemma path_unPath : path (a0_comp_forgetToGrpd p_tp δ0_p) (a1_comp_forgetToGrpd p_tp δ1_p) + (p := FunctorOperation.Path.unPath p_tp) (by rw [unPath_comp_forgetToGrpd]; congr) = p := by + apply Functor.Grothendieck.FunctorTo.hext + · simp only [path, Functor.Grothendieck.functorTo_forget, p_tp] + · intro x + rcases x with ⟨⟨⟨_|_⟩⟩ , x⟩ + · simpa [path] using (obj_ff_fiber p_tp δ0_p x).symm + · simpa [path] using (obj_tt_fiber p_tp δ1_p x).symm + · intro x y f + rcases x with ⟨⟨⟨_|_⟩⟩ , x⟩ + · rcases y with ⟨⟨⟨_|_⟩⟩ , y⟩ + · simpa [path] using (map_ff_fiber p_tp δ0_p f).symm + · exact path_map_ft_fiber p_tp δ0_p δ1_p f + · rcases y with ⟨⟨⟨_|_⟩⟩ , y⟩ + · exact path_map_tf_fiber p_tp δ0_p δ1_p f + · simpa [path] using (map_tt_fiber p_tp δ1_p f).symm --- TODO: docstring + why is it called `inc`? -def inc (G : Type) [Groupoid G] : G ⥤ BPGrpd := by - fapply isPullback.lift - . exact PGrpd.inc G - . exact PGrpd.inc G - . simp +end -end BPGrpd +end Path -end CategoryTheory +end FunctorOperation namespace GroupoidModel -open CategoryTheory Functor.Groupoidal - - -namespace FunctorOperation - -section Id - -/- -In this section we build this diagram - -PGrpd-----Refl---->PGrpd - | | - | | - | | -Diag | - | | - | | - v v -BPGrpd----Id----->Grpd - -This is NOT a pullback. - -Instead we use Diag and Refl to define a functor R : PGrpd ⥤ Grothendieck.Groupoidal Id --/ - -/-- The identity type former takes a bipointed groupoid `((A,a0),a1)` to the set of isomorphisms -between its two given points `A(a0,a1)`. -Here `A = x.base.base`, `a0 = x.base.fiber` and `a1 = x.fiber`. -/ -def idObj (x : BPGrpd) : Grpd := Grpd.of (CategoryTheory.Discrete (x.base.fiber ⟶ x.fiber)) - -/-- The identity type former takes a morphism of bipointed groupoids -`((F,f0),f1) : ((A,a0),a1) ⟶ ((B,b0),b1)` -to the function `A(a0,a1) → B(b0,b1)` taking `g : a0 ≅ a1` to `f0⁻¹ ⋙ F g ⋙ f1` where -`f0⁻¹ : b0 ⟶ F a0`, `F g : F a0 ⟶ F a1` and `f1 : F a1 ⟶ b1`. -/ -def idMap {x y : BPGrpd} (f : x ⟶ y) : idObj x ⥤ idObj y := - Discrete.functor (fun g => ⟨ inv f.base.fiber ≫ (f.base.base.map g) ≫ f.fiber ⟩) - -lemma Discrete.functor_ext' {X C : Type*} [Category C] {F G : X → C} (h : ∀ x : X, F x = G x) : - Discrete.functor F = Discrete.functor G := by - have : F = G := by aesop - subst this +open Grpd Model.UnstructuredUniverse + +def cylinder : Cylinder Grpd := .ofCartesianMonoidalCategoryLeft Interval δ0 δ1 + +namespace UId + +variable {Γ Δ : Grpd} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} (a0 a1 : Γ ⟶ U.Tm) + (a0_tp : a0 ≫ U.tp = A) (a1_tp : a1 ≫ U.tp = A) + +include a0_tp in +lemma pt_tp : toCoreAsSmallEquiv a0 ⋙ PGrpd.forgetToGrpd = toCoreAsSmallEquiv A := by + rw [← a0_tp, Grpd.comp_eq_comp, U.tp, toCoreAsSmallEquiv_apply_comp_right] + +def Id : Γ ⟶ U.{v}.Ty := + toCoreAsSmallEquiv.symm (FunctorOperation.Id (A := toCoreAsSmallEquiv A) + (a0 := toCoreAsSmallEquiv a0) (a1 := toCoreAsSmallEquiv a1) + (pt_tp a0 a0_tp) + (pt_tp a1 a1_tp)) + +lemma Id_comp : + UId.Id (A := σ ≫ A) (σ ≫ a0) (σ ≫ a1) (by simp only [Category.assoc, a0_tp, U_Ty]) + (by simp only [Category.assoc, a1_tp, U_Ty]) = σ ≫ UId.Id a0 a1 a0_tp a1_tp := by + dsimp only [U_Ty, comp_eq_comp, Id] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left, ← FunctorOperation.Id_comp] + +section + +variable (p : cylinder.I.obj Γ ⟶ U.Tm) (p_tp : p ≫ U.tp = cylinder.π.app Γ ≫ A) + +def unPath : Γ ⟶ U.{v}.Tm := toCoreAsSmallEquiv.symm <| + FunctorOperation.Path.unPath (A := toCoreAsSmallEquiv A) (p := toCoreAsSmallEquiv p) (by + rw [← toCoreAsSmallEquiv_apply_comp_left] + rw [← toCoreAsSmallEquiv_apply_comp_right, + EmbeddingLike.apply_eq_iff_eq] + exact p_tp) + +lemma unPath_comp : unPath (A := σ ≫ A) (cylinder.I.map σ ≫ p) (by rw [Category.assoc, p_tp, + ← Category.assoc, cylinder.π.naturality, Category.assoc, Functor.id_map]) = + σ ≫ unPath p p_tp := by + dsimp [unPath] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left, ← FunctorOperation.Path.unPath_comp] + +lemma unPath_tp (δ0_p : cylinder.δ0.app Γ ≫ p = a0) (δ1_p : cylinder.δ1.app Γ ≫ p = a1) : + unPath p p_tp ≫ U.tp = UId.Id (A := A) a0 a1 + (by rw [← δ0_p, Category.assoc, p_tp, Cylinder.δ0_π'_app_assoc]) + (by rw [← δ1_p, Category.assoc, p_tp, Cylinder.δ1_π'_app_assoc]) := by + dsimp [unPath, U.tp, Id] + rw [← toCoreAsSmallEquiv_symm_apply_comp_right, FunctorOperation.Path.unPath_comp_forgetToGrpd] + congr 2 + · rw [← δ0_p, Grpd.comp_eq_comp, toCoreAsSmallEquiv_apply_comp_left] + rfl + · rw [← δ1_p, Grpd.comp_eq_comp, toCoreAsSmallEquiv_apply_comp_left] + rfl + +end + +section + +variable (p : Γ ⟶ U.Tm) (p_tp : p ≫ U.tp = UId.Id a0 a1 a0_tp a1_tp) + +def path : cylinder.I.obj Γ ⟶ U.{v}.Tm := + have p_tp' : toCoreAsSmallEquiv p ⋙ PGrpd.forgetToGrpd = + FunctorOperation.Id (pt_tp a0 a0_tp) (pt_tp a1 a1_tp) := by + dsimp [U.tp, Id] at p_tp + rw [← toCoreAsSmallEquiv_apply_comp_right, p_tp, Equiv.apply_symm_apply] + toCoreAsSmallEquiv.symm <| FunctorOperation.Path.path _ _ p_tp' + +lemma path_tp : path a0 a1 a0_tp a1_tp p p_tp ≫ U.tp = cylinder.π.app Γ ≫ A := by + dsimp [path, U.tp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_right, toCoreAsSmallEquiv.symm_apply_eq, + toCoreAsSmallEquiv_apply_comp_left, FunctorOperation.Path.path_comp_forgetToGrpd] rfl -lemma Discrete.functor_eq {X C : Type*} [Category C] {F : Discrete X ⥤ C} : - F = Discrete.functor fun x ↦ F.obj ⟨x⟩ := by - fapply CategoryTheory.Functor.ext - · aesop - · intro x y f - cases x ; rcases f with ⟨⟨h⟩⟩ - cases h - simp - -lemma Discrete.functor_ext {X C : Type*} [Category C] (F G : Discrete X ⥤ C) - (h : ∀ x : X, F.obj ⟨x⟩ = G.obj ⟨x⟩) : - F = G := - calc F - _ = Discrete.functor (fun x => F.obj ⟨x⟩) := Discrete.functor_eq - _ = Discrete.functor (fun x => G.obj ⟨x⟩) := Discrete.functor_ext' h - _ = G := Discrete.functor_eq.symm +lemma δ0_path : cylinder.δ0.app Γ ≫ path a0 a1 a0_tp a1_tp p p_tp = a0 := by + dsimp [path] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left, toCoreAsSmallEquiv.symm_apply_eq] + apply FunctorOperation.Path.sectR_false_comp_path + +lemma δ1_path : cylinder.δ1.app Γ ≫ path a0 a1 a0_tp a1_tp p p_tp = a1 := by + dsimp [path] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left, toCoreAsSmallEquiv.symm_apply_eq] + apply FunctorOperation.Path.sectR_true_comp_path + +lemma unPath_path : unPath (A := A) (path a0 a1 a0_tp a1_tp p p_tp) (path_tp ..) = p := by + dsimp [unPath, path] + rw [toCoreAsSmallEquiv.symm_apply_eq] + rw! (transparency := .default) [toCoreAsSmallEquiv.apply_symm_apply] + apply FunctorOperation.Path.unPath_path + +end + +lemma path_unPath (p : cylinder.I.obj Γ ⟶ U.Tm) (p_tp : p ≫ U.tp = cylinder.π.app Γ ≫ A) + (δ0_p : cylinder.δ0.app Γ ≫ p = a0) (δ1_p : cylinder.δ1.app Γ ≫ p = a1) : + path (A := A) a0 a1 (by simp [← δ0_p, - Grpd.comp_eq_comp, p_tp]) + (by simp [← δ1_p, - Grpd.comp_eq_comp, p_tp]) (unPath p p_tp) + (unPath_tp a0 a1 p p_tp δ0_p δ1_p) = p := by + dsimp [path, unPath] + rw [toCoreAsSmallEquiv.symm_apply_eq] + rw! (transparency := .default) [toCoreAsSmallEquiv.apply_symm_apply] + apply FunctorOperation.Path.path_unPath + · simp [FunctorOperation.Path.unPath0, ← toCoreAsSmallEquiv_apply_comp_left, ← δ0_p] + rfl + · simp [FunctorOperation.Path.unPath1, ← toCoreAsSmallEquiv_apply_comp_left, ← δ1_p] + rfl + +namespace hurewiczUTp + +attribute [local irreducible] tpClovenIsofibration + +variable (σ : Δ ⟶ Γ) (p0 : Γ ⟶ U.{v}.Tm) (p : cylinder.I.obj Γ ⟶ U.Ty) + (p0_tp : p0 ≫ U.tp = cylinder.δ0.app Γ ≫ p) + +@[simp] +def liftObj : Grpd.Interval × Γ → U.{v}.Tm +| ⟨⟨⟨.false⟩⟩, x2⟩ => p0.obj x2 +| ⟨⟨⟨.true⟩⟩, x2⟩ => tpClovenIsofibration.liftObj (p.map (FunctorOperation.Path.ft x2)) + (Functor.congr_obj p0_tp x2) + +@[simp] +abbrev liftMap0 {x2 : Γ} {y : Grpd.Interval × Γ} (f : FunctorOperation.Path.ff x2 ⟶ y) := + tpClovenIsofibration.liftIso (X' := p0.obj x2) (p.map f) (Functor.congr_obj p0_tp x2) + +open FunctorOperation.Path + +@[simp] +def liftMap : {x y : Grpd.Interval × Γ} → (f : x ⟶ y) → + liftObj p0 p p0_tp x ⟶ liftObj p0 p p0_tp y +| ⟨⟨⟨.false⟩⟩, _⟩, ⟨⟨⟨.false⟩⟩, _⟩, f => p0.map f.2 +| ⟨⟨⟨.false⟩⟩, _⟩, ⟨⟨⟨.true⟩⟩, y2⟩, f => p0.map f.2 ≫ liftMap0 p0 p p0_tp (ft y2) +| ⟨⟨⟨.true⟩⟩, x2⟩, ⟨⟨⟨.false⟩⟩, _⟩, f => inv (liftMap0 p0 p p0_tp (ft x2)) ≫ p0.map f.2 +| ⟨⟨⟨.true⟩⟩, x2⟩, ⟨⟨⟨.true⟩⟩, y2⟩, f => inv (liftMap0 p0 p p0_tp (ft x2)) ≫ + p0.map f.2 ≫ liftMap0 p0 p p0_tp (ft y2) + +lemma liftMap_id (x) : liftMap p0 p p0_tp (𝟙 x) = 𝟙 (liftObj p0 p p0_tp x) := by + rcases x with ⟨⟨⟨_|_⟩⟩, _⟩ <;> simp + +lemma liftMap_comp {x y z} (f : x ⟶ y) (g : y ⟶ z) : + liftMap p0 p p0_tp (f ≫ g) = liftMap p0 p p0_tp f ≫ liftMap p0 p p0_tp g := by + rcases x with ⟨⟨⟨_|_⟩⟩, _⟩ + all_goals rcases y with ⟨⟨⟨_|_⟩⟩, _⟩ + all_goals rcases z with ⟨⟨⟨_|_⟩⟩, _⟩ + all_goals simp [liftMap] -lemma Discrete.ext {X : Type*} {x y : Discrete X} (h : x.as = y.as) : x = y := by - cases x; cases h - rfl - -/-- The identity type formation rule, equivalently viewed as a functor. -/ @[simps] -def id : BPGrpd.{u,u} ⥤ Grpd.{u,u} where - obj := idObj - map := idMap - map_id X := by - apply Discrete.functor_ext - intro x - apply Discrete.ext - dsimp only [idMap, Grpd.forgetToCat] - aesop - map_comp {X Y Z} f g := by - apply Discrete.functor_ext - intro a - apply Discrete.ext - dsimp only [idMap, Grpd.forgetToCat] - aesop - -/-- -The diagonal functor into the pullback. -It creates a second copy of the point from the input pointed groupoid. - -This version of `diag` is used for better definitional reduction. --/ -def diag : PGrpd ⥤ BPGrpd where - obj x := objMk x x.fiber - map f := homMk f f.fiber - map_comp {X Y Z} f g:= by - fapply Hom.ext +def lift : cylinder.I.obj Γ ⟶ U.{v}.Tm where + obj := liftObj p0 p p0_tp + map := liftMap p0 p p0_tp + map_id := liftMap_id p0 p p0_tp + map_comp := liftMap_comp p0 p p0_tp + +lemma lift_comp_tp : + hurewiczUTp.lift p0 p p0_tp ≫ U.tp = p := by + fapply CategoryTheory.Functor.ext + · intro x + rcases x with ⟨⟨⟨_|_⟩⟩, x⟩ + · simpa using Functor.congr_obj p0_tp x · simp - · simp [Grpd.forgetToCat] - -/-- -This version of `diag` is used for functor equational reasoning. --/ -def diag' : PGrpd ⥤ BPGrpd := - BPGrpd.isPullback.lift (𝟭 _) (𝟭 _) rfl - -lemma diag_eq_diag' : diag = diag' := - BPGrpd.isPullback.lift_uniq _ _ _ rfl rfl - -def reflObjFiber (x : PGrpd) : Discrete (x.fiber ⟶ x.fiber) := ⟨𝟙 x.fiber⟩ - -def refl : PGrpd ⥤ PGrpd := - PGrpd.functorTo (diag ⋙ id) reflObjFiber (fun f => Discrete.eqToHom (by - simp [idMap, diag, reflObjFiber, Grpd.forgetToCat])) - (by simp) - (by intros; simp [Discrete.eqToHom, eqToHom_map]) - -theorem refl_forgetToGrpd : refl ⋙ PGrpd.forgetToGrpd = diag ⋙ id := rfl - -/- This is the universal lift - Refl -PGrpd ------------> - |----> ∫Id -----> PGrpd - | R | | - | | | - Diag | | forget - | | | - | V V - ---> BPGrpd -----> Grpd - Id --/ -def R : PGrpd ⥤ ∫ id := - (isPullback id).lift refl diag refl_forgetToGrpd - -/- This is the composition - -PGrpd - |----> ∫Id - | R | - | | - Diag | forget - | | - | V - ---> BPGrpd - | - | - | BPGrpd.forgetToGrpd - | - V - Grpd --/ --- TODO : consider removal? --- def K : Grothendieck.Groupoidal Id ⥤ Grpd := Grothendieck.Groupoidal.forget ⋙ BPGrpd.forgetToGrpd - -/- This is the universal lift - Refl -PGrpd ------------> - |----> ∫Id -----> PGrpd - | R | | - | | | - Diag | | forget - | | | - | V V - ---> BPGrpd -----> Grpd - Id --/ -theorem RKForget : R ⋙ forget ⋙ BPGrpd.forgetToGrpd = - PGrpd.forgetToGrpd := by - simp [R,<- Functor.assoc,CategoryTheory.Functor.IsPullback.fac_right,diag] + · intro x y f + rcases x with ⟨⟨⟨_|_⟩⟩, x⟩ + · rcases y with ⟨⟨⟨_|_⟩⟩, y⟩ + · erw [Functor.congr_hom p0_tp f.2] + simp + rfl + · simp only [U_Tm, comp_eq_comp, Functor.comp_obj, lift_obj, liftObj, U_Ty, U_tp, + Functor.comp_map, lift_map, liftMap, liftMap0, Functor.map_comp] + erw [Functor.congr_hom p0_tp f.2] + simp only [U_Tm, comp_eq_comp, Functor.comp_obj, Functor.id_obj, Functor.comp_map, + Category.assoc] + have : f = ffm f.2 ≫ ft y := by aesop + conv => rhs; rw [this] + rw [Functor.map_comp] + rw [Functor.ClovenIsofibration.map_liftIso'] + simp [← Category.assoc] + rfl + · rcases y with ⟨⟨⟨_|_⟩⟩, y⟩ + · simp only [U_Tm, comp_eq_comp, Functor.comp_obj, lift_obj, liftObj, U_Ty, U_tp, + Functor.comp_map, lift_map, liftMap, liftMap0, Functor.map_comp, Functor.map_inv, + IsIso.inv_comp_eq] + erw [Functor.congr_hom p0_tp f.2] + have : f = tf x ≫ ffm f.2 := by aesop + slice_rhs 2 3 => rw [this] + rw [Functor.ClovenIsofibration.map_liftIso', Functor.map_comp] + simp only [U_Tm, comp_eq_comp, Functor.comp_obj, Functor.id_obj, Functor.comp_map, + Category.assoc, eqToHom_trans_assoc, eqToHom_refl, Category.id_comp] + have : ft x ≫ tf x = 𝟙 _ := by aesop + slice_rhs 2 3 => rw [← Functor.map_comp, this, CategoryTheory.Functor.map_id] + rfl + · simp only [U_Tm, comp_eq_comp, Functor.comp_obj, lift_obj, liftObj, U_Ty, U_tp, + Functor.comp_map, lift_map, liftMap, liftMap0, Functor.map_comp, Functor.map_inv, + IsIso.inv_comp_eq] + erw [Functor.congr_hom p0_tp f.2] + rw [Functor.ClovenIsofibration.map_liftIso', Functor.ClovenIsofibration.map_liftIso'] + simp only [U_Tm, comp_eq_comp, Functor.comp_obj, Functor.id_obj, Functor.comp_map, + ← Category.assoc, ← heq_eq_eq, heq_comp_eqToHom_iff, comp_eqToHom_heq_iff] + simp only [Category.assoc, eqToHom_trans, eqToHom_refl, Category.comp_id, + ← Functor.map_comp, heq_eq_eq] + have : ft x ≫ f = ffm f.2 ≫ ft y := by aesop + conv => rhs; rw [this] + rfl + +lemma δ0_comp_lift : cylinder.δ0.app Γ ≫ hurewiczUTp.lift p0 p p0_tp = p0 := by fapply CategoryTheory.Functor.ext - . intro X + · intro x + convert_to (lift p0 p p0_tp).obj ⟨⟨⟨.false⟩⟩, x⟩ = _ simp - . intro X Y f + · intro x y f + convert_to (lift p0 p p0_tp).map (ffm f) = _ simp +@[simp] +lemma I_map_obj_ff (x : Δ) : (cylinder.I.map σ).obj ({ down := { as := false } }, x) = + ({ down := { as := false } }, σ.obj x) := by + rfl + +lemma lift_map_ffm {x y : Δ} (f : x ⟶ y) : (lift p0 p p0_tp).map (ffm (σ.map f)) = + p0.map (σ.map f) := by + simp [liftMap] + +lemma lift_map_ft (x : Δ) : (lift p0 p p0_tp).map (ft (σ.obj x)) = + tpClovenIsofibration.liftIso (p.map (ft (σ.obj x))) + (by simpa using Functor.congr_obj p0_tp (σ.obj x)) := by + simp [liftObj, liftMap] + +lemma lift_map_ft' (x : Δ) : (lift p0 p p0_tp).map (ft (σ.obj x)) = + tpClovenIsofibration.liftIso (p.map (⟨⟨⟨⟩⟩, σ.map (𝟙 _)⟩ : ff (σ.obj x) ⟶ tt (σ.obj x))) + (by simpa using Functor.congr_obj p0_tp (σ.obj x)) ≫ eqToHom (by simp) := by + simp only [U_Tm, lift_obj, liftObj, U_Ty, U_tp, ft, lift_map, liftMap, + CategoryTheory.Functor.map_id, liftMap0, Category.id_comp, ← heq_eq_eq, heq_comp_eqToHom_iff] + rw! (castMode := .all) [← CategoryTheory.Functor.map_id] + rfl --- /- Here I define the path groupoid and how it can be used to create identities --- Note that this is not the same as Id. --- -/ - --- def Path : Type u := ULift.{u} Bool - --- instance : Groupoid.{u,u} Path where --- Hom x y := PUnit --- id := fun _ => PUnit.unit --- comp := by intros; fconstructor --- inv := fun _ => PUnit.unit --- id_comp := by intros; rfl --- comp_id := by intros; rfl --- assoc := by intros; rfl - --- abbrev Paths (G : Type u) [Groupoid.{u,u} G] : Type u := (Path ⥤ G) - --- /- This should be able to be made into a groupoid but I am having trouble with leans instances-/ --- instance (G : Type u) [Groupoid G] : Category.{u,u} (Paths G) := by --- exact Functor.category - --- def Path_Refl (G : Type u) [Groupoid G] : G ⥤ (Paths G) where --- obj x := by --- fconstructor --- fconstructor --- . exact fun _ => x --- . exact fun _ => 𝟙 x --- . exact congrFun rfl --- . simp --- map f := by --- fconstructor --- . intro x --- exact f --- . simp - --- def PreJ (G : Type u) [Groupoid G] : Paths G ⥤ G := by --- fconstructor --- fconstructor --- . intro p --- refine p.obj { down := false } --- . intros X Y f --- refine f.app ?_ --- . exact congrFun rfl --- . simp - --- theorem PreJLift (G : Type u) [Groupoid G] : (Path_Refl G) ⋙ (PreJ G) = 𝟭 G := by --- simp [Path_Refl,PreJ,Functor.comp,Functor.id] - -end Id -end FunctorOperation +lemma lift_map_tf (x : Δ) : (lift p0 p p0_tp).map (tf (σ.obj x)) = + eqToHom (by simp; rfl) ≫ inv (tpClovenIsofibration.liftIso (p.map (ft (σ.obj x))) + (by simpa using Functor.congr_obj p0_tp (σ.obj x))) := by + simp [liftMap] + +lemma lift_map_tf' (x : Δ) : (lift p0 p p0_tp).map (tf (σ.obj x)) = + eqToHom (by simp [ft]; rfl) ≫ + inv (tpClovenIsofibration.liftIso (p.map (⟨⟨⟨⟩⟩, σ.map (𝟙 _)⟩ : ff (σ.obj x) ⟶ tt (σ.obj x))) + (by simpa using Functor.congr_obj p0_tp (σ.obj x))) := by + simp only [U_Tm, lift_obj, liftObj, U_Ty, U_tp, ft, tf, lift_map, liftMap, liftMap0, + CategoryTheory.Functor.map_id, Category.comp_id, ← heq_eq_eq, heq_eqToHom_comp_iff] + rw! (castMode := .all) [← CategoryTheory.Functor.map_id] + rfl --- section Contract --- /- --- At some point I think we will need to contract groupoids along there isomorphisms. In this sections --- I define how to do that. --- -/ - --- variable {C : Type u} [Category C] (a b : C) (f : a ⟶ b) [iso : IsIso f] - --- inductive ContractBase : Type u where --- | inc (x : {x : C // x ≠ a ∧ x ≠ b}) : ContractBase --- | p : ContractBase - --- def ContractHom (x y : ContractBase a b) : Type := match x,y with --- | ContractBase.inc t, ContractBase.inc u => t.val ⟶ u.val --- | ContractBase.inc t, ContractBase.p => t.val ⟶ a --- | ContractBase.p , ContractBase.inc t => b ⟶ t.val --- | ContractBase.p, ContractBase.p => b ⟶ a - --- def ContractHomId (x : ContractBase a b) : ContractHom a b x x := match x with --- | ContractBase.inc t => 𝟙 t.val --- | ContractBase.p => inv f - --- def ContractHomComp {x y z : ContractBase a b} (g : ContractHom a b x y) (h : ContractHom a b y z) : --- ContractHom a b x z := match x,y,z with --- | ContractBase.inc _, ContractBase.inc _, ContractBase.inc _ => g ≫ h --- | ContractBase.inc _, ContractBase.inc _, ContractBase.p => g ≫ h --- | ContractBase.inc _, ContractBase.p, ContractBase.inc _ => g ≫ f ≫ h --- | ContractBase.inc _, ContractBase.p, ContractBase.p => g ≫ f ≫ h --- | ContractBase.p , ContractBase.inc _, ContractBase.inc _ => g ≫ h --- | ContractBase.p , ContractBase.inc _, ContractBase.p => g ≫ h --- | ContractBase.p , ContractBase.p, ContractBase.inc _ => g ≫ f ≫ h --- | ContractBase.p , ContractBase.p, ContractBase.p => g ≫ f ≫ h - --- instance ic (iso : IsIso f) : Category (ContractBase a b) where --- Hom := ContractHom a b --- id := ContractHomId a b f --- comp := ContractHomComp a b f --- id_comp := by --- intros x y g --- cases x <;> cases y <;> simp [ContractHomId, ContractHomComp] --- comp_id := by --- intros x y g --- cases x <;> cases y <;> simp [ContractHomId, ContractHomComp] --- assoc := by --- intros w x y z g h i --- cases w <;> cases x <;> cases y <;> cases z <;> simp [ContractHomId, ContractHomComp] --- end Contract --- section GrpdContract - --- variable {G : Type u} [Groupoid G] - --- def Grpd.Contract (a b : G) : Type u := ContractBase a b - --- instance icc {a b : G} (f : a ⟶ b) : Category (Grpd.Contract a b) := ic a b f (isIso_of_op f) - --- instance {a b : G} (f : a ⟶ b) : Groupoid (Grpd.Contract a b) where --- Hom := ContractHom a b --- id := ContractHomId a b f --- comp := ContractHomComp a b f --- id_comp := by --- intros x y g --- cases x <;> cases y <;> simp [ContractHomId, ContractHomComp] --- comp_id := by --- intros x y g --- cases x <;> cases y <;> simp [ContractHomId, ContractHomComp] --- assoc := by --- intros w x y z g h i --- cases w <;> cases x <;> cases y <;> cases z <;> simp [ContractHomId, ContractHomComp] --- inv {a b} g := by --- cases a <;> cases b --- . dsimp[Quiver.Hom, ContractHom] --- dsimp[ContractHom] at g --- exact inv g --- . dsimp[Quiver.Hom, ContractHom] --- dsimp[ContractHom] at g --- exact inv (g ≫ f) --- . dsimp[Quiver.Hom, ContractHom] --- dsimp[ContractHom] at g --- exact inv (f ≫ g) --- . dsimp[Quiver.Hom, ContractHom] --- dsimp[ContractHom] at g --- exact (inv f) ≫ (inv g) ≫ (inv f) --- inv_comp {a b} g := sorry --- comp_inv := by sorry - --- def CTtoGrpd {a b : G} (f : a ⟶ b) : Grpd := by --- refine @Grpd.of (Grpd.Contract a b) ?_ --- exact instGroupoidContractOfHom f - --- end GrpdContract - --- section ContractMap - --- -- def PJ : Grothendieck.Groupoidal Id ⥤ PGrpd where --- -- obj x := by --- -- rcases x with ⟨base,fiber⟩ --- -- rcases base with ⟨pg,p2⟩ --- -- rcases pg with ⟨base,p1⟩ --- -- simp[Grpd.forgetToCat] at p2 p1 --- -- fconstructor --- -- . refine CTtoGrpd ?_ (G := base) (a := p1) (b := p2) --- -- simp[Grpd.forgetToCat,Id] at fiber --- -- rcases fiber with ⟨f⟩ --- -- simp[Grothendieck.Groupoidal.base,Grothendieck.Groupoidal.fiber] at f --- -- exact f --- -- . simp[Grpd.forgetToCat,CTtoGrpd,Grpd.Contract] --- -- exact ContractBase.p --- -- map {x y} F := by --- -- simp[Quiver.Hom] --- -- rcases F with ⟨base,fiber⟩ --- -- rcases base with ⟨pg,p2⟩ --- -- rcases pg with ⟨base,p1⟩ --- -- simp[Grpd.forgetToCat] at p2 p1 --- -- fconstructor --- -- . fconstructor --- -- fconstructor --- -- . intro x --- -- cases x --- -- rename_i x' --- -- rcases x' with ⟨x',p⟩ --- -- fconstructor --- -- fconstructor --- -- . refine base.obj x' --- -- . simp - --- end ContractMap - -/- -In this section I am trying to move the previous results about groupoids to the -category of contexts --/ - - -#exit -/- -This is the equivelant of Id above --/ - --- TODO tidy up this definition. remove tactic mode + use yonedaCategoryEquiv -def Id' : y(GroupoidModel.U.ext (GroupoidModel.π.{u,u})) ⟶ smallU.Ty.{u,u} := - yonedaCategoryEquiv.symm (sorry) - -- dsimp[GroupoidModel.U.ext,GroupoidModel.U,GroupoidModel.Ctx.ofCategory] - -- refine AsSmall.up.map ?_ - -- dsimp [Quiver.Hom] - -- refine Core.functorToCore ?_ - -- refine ?_ ⋙ AsSmall.up - -- refine ?_ ⋙ Id - -- dsimp [BPGrpd] - -- let F : (GroupoidModel.Ctx.toGrpd.obj GroupoidModel.E) ⥤ PGrpd := by sorry - -- -- dsimp[GroupoidModel.E,GroupoidModel.Ctx.ofCategory] - -- -- refine ?_ ⋙ Core.inclusion PGrpd - -- -- refine Core.map' ?_ - -- -- exact AsSmall.down - -- let h : F ⋙ PGrpd.forgetToGrpd = (GroupoidModel.U.classifier GroupoidModel.π) := by sorry - -- -- exact rfl - -- rw[<-h] - -- exact Grothendieck.Groupoidal.pre PGrpd.forgetToGrpd F - -def Refl' : GroupoidModel.E.{u,u} ⟶ GroupoidModel.E.{u,u} := - AsSmall.up.map (𝟭 (Core (AsSmall PGrpd))) - -/- Lean is gas lighting me -/ -def Diag' : GroupoidModel.E.{v,u} ⟶ GroupoidModel.U.ext (GroupoidModel.π.{v,u}) := by - refine IsPullback.lift (GroupoidModel.IsPullback.SmallU.isPullback_disp_π.{v,u} (GroupoidModel.π.{v,u})) ?_ ?_ ?_ - . refine eqToHom sorry - . refine eqToHom sorry - . simp - - - -namespace smallUId - -def id : Limits.pullback smallU.{v}.tp smallU.{v}.tp ⟶ smallU.{v}.Ty := sorry - -def refl: smallU.{v}.Tm ⟶ smallU.{v}.Tm := sorry - -def comm: Limits.pullback.lift (𝟙 smallU.Tm) (𝟙 smallU.Tm) rfl ≫ id = refl ≫ smallU.tp := sorry - --- TODO: make sure universe levels are most general --- TODO: make namespaces consistent with Sigma file -def smallUIdBase : Universe.IdIntro smallU.{u,u} where - k := y(GroupoidModel.U.ext GroupoidModel.π.{u,u}) - k1 := sorry -- smallU.{u,u}.var GroupoidModel.π.{u,u} - k2 := sorry -- ym(smallU.{u,u}.disp GroupoidModel.π.{u,u}) - isKernelPair := sorry - Id := Id' - refl := sorry - refl_tp := sorry - -end smallUId +lemma lift_comp : lift (σ ≫ p0) (cylinder.I.map σ ≫ p) + (by simp [p0_tp, - Grpd.comp_eq_comp, ← cylinder.δ0.naturality_assoc]) = + cylinder.I.map σ ≫ lift p0 p p0_tp := by + fapply CategoryTheory.Functor.ext + · intro x + rcases x with ⟨⟨⟨_|_⟩⟩, x⟩ + · convert_to _ = (lift p0 p p0_tp).obj (ff (σ.obj x)) + simp + · convert_to _ = (lift p0 p p0_tp).obj (tt (σ.obj x)) + simp only [U_Tm, comp_eq_comp, lift_obj, liftObj, U_Ty, U_tp, Functor.comp_obj, + Functor.comp_map] + congr + conv => rhs; rw [ft, ← CategoryTheory.Functor.map_id] + rfl + · intro x y f + rcases x with ⟨⟨⟨_|_⟩⟩, x⟩ + · rcases y with ⟨⟨⟨_|_⟩⟩, y⟩ + · have : (cylinder.I.map σ).map f = ffm (σ.map f.2) := by aesop + slice_rhs 2 3 => simp only [Grpd.comp_eq_comp, Functor.comp_map, this, lift_map_ffm] + simp + · have : (cylinder.I.map σ).map f = ffm (σ.map f.2) ≫ ft (σ.obj y) := by aesop + slice_rhs 2 3 => simp only [Grpd.comp_eq_comp, Functor.comp_map, this, Functor.map_comp, + lift_map_ffm, lift_map_ft'] + simp [ft] + rfl + · rcases y with ⟨⟨⟨_|_⟩⟩, y⟩ + · have : (cylinder.I.map σ).map f = tf (σ.obj x) ≫ ffm (σ.map f.2) := by aesop + slice_rhs 2 3 => simp only [Grpd.comp_eq_comp, Functor.comp_map, this, Functor.map_comp, + lift_map_ffm, lift_map_tf'] + simp [← heq_eq_eq] + rfl + · have : (cylinder.I.map σ).map f = tf (σ.obj x) ≫ ffm (σ.map f.2) ≫ ft (σ.obj y) := by aesop + slice_rhs 2 3 => simp only [Grpd.comp_eq_comp, Functor.comp_map, this, Functor.map_comp, + lift_map_ffm, lift_map_tf', lift_map_ft'] + simp only [U_Tm, comp_eq_comp, lift_obj, liftObj, U_Ty, U_tp, Functor.comp_obj, ft, + Functor.comp_map, lift_map, liftMap, liftMap0, Category.assoc, eqToHom_trans, + eqToHom_refl, Category.comp_id, eqToHom_trans_assoc, Category.id_comp, IsIso.eq_inv_comp] + erw [IsIso.hom_inv_id_assoc] + rfl + +open Functor.ClovenIsofibration.IsSplit in +lemma isNormal (A : Γ ⟶ U.Ty) (π_A : p = CategoryTheory.Prod.snd _ Γ ≫ A) : + lift p0 p p0_tp = CategoryTheory.Prod.snd _ Γ ≫ p0 := by + have : tpClovenIsofibration.IsSplit := inferInstance -- FIXME + subst π_A + fapply CategoryTheory.Functor.ext + · intro x + rcases x with ⟨⟨⟨_|_⟩⟩, x⟩ + · simp + · simp [ft] + rw [liftObj_id] + · intro x y f + rcases x with ⟨⟨⟨_|_⟩⟩, x⟩ + · rcases y with ⟨⟨⟨_|_⟩⟩, y⟩ + · simp + · simp only [U_Tm, comp_eq_comp, lift_obj, liftObj, U_Ty, U_tp, Functor.comp_obj, + Prod.snd_obj, Functor.comp_map, Prod.snd_map, lift_map, liftMap, liftMap0, + eqToHom_refl, Category.id_comp] + rw! [CategoryTheory.Functor.map_id, liftIso_id] + · rcases y with ⟨⟨⟨_|_⟩⟩, y⟩ + · simp only [U_Tm, comp_eq_comp, lift_obj, liftObj, U_Ty, U_tp, Functor.comp_obj, + Prod.snd_obj, Functor.comp_map, Prod.snd_map, lift_map, liftMap, liftMap0, + eqToHom_refl, Category.comp_id, IsIso.inv_comp_eq] + rw! [CategoryTheory.Functor.map_id, liftIso_id] + simp + · simp + rw! [CategoryTheory.Functor.map_id, liftIso_id] + slice_rhs 1 2 => rw! [CategoryTheory.Functor.map_id, liftIso_id] + simp + +end hurewiczUTp + +end UId + +open UId hurewiczUTp + +def UPath : GroupoidModel.U.{v}.Path cylinder where + Id := Id + Id_comp := Id_comp + unPath := unPath + unPath_comp := unPath_comp + unPath_tp := unPath_tp + path := path + path_tp := path_tp + δ0_path := δ0_path + δ1_path := δ1_path + path_unPath := path_unPath + unPath_path := unPath_path + +def hurewiczUTp : cylinder.Hurewicz U.{v}.tp where + lift := lift + lift_comp_self := lift_comp_tp + δ0_comp_lift := δ0_comp_lift + +instance : hurewiczUTp.IsUniform where + lift_comp := lift_comp + +instance : hurewiczUTp.IsNormal where + isNormal := isNormal + +def UId : GroupoidModel.U.{v,max u (v+1) (v₁+1)}.PolymorphicIdElim UPath.polymorphicIdIntro + GroupoidModel.U.{v₁, max u (v+1) (v₁+1)} := + @UPath.polymorphicIdElim _ _ _ _ hurewiczUTp _ _ _ hurewiczUTp _ _ end GroupoidModel diff --git a/HoTTLean/Groupoids/IsPullback.lean b/HoTTLean/Groupoids/IsPullback.lean index be866c08..171cf8a8 100644 --- a/HoTTLean/Groupoids/IsPullback.lean +++ b/HoTTLean/Groupoids/IsPullback.lean @@ -166,6 +166,20 @@ def isPullbackCoreAsSmall : (AsSmall.down ⋙ PGrpd.forgetToGrpd ⋙ AsSmall.up) (Core.inclusion _) := Core.isPullback_map'_self _ +/-- +coreAsSmall PGrpd ----> PGrpd + | | + | | + | | + V V +coreAsSmall Grpd -----> Grpd +-/ +def isPullbackCoreAsSmall' : + Functor.IsPullback (Core.inclusion _ ⋙ AsSmall.down) + (Ctx.coreAsSmallFunctor PGrpd.forgetToGrpd) + (PGrpd.forgetToGrpd) (Core.inclusion _ ⋙ AsSmall.down) := + Functor.IsPullback.Paste.horiz rfl rfl isPullbackAsSmall isPullbackCoreAsSmall + /-- ∫ toCo...iv A ----> coreAsSmall PGrpd | | diff --git a/HoTTLean/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index 353fd3a8..67209af1 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -1,65 +1,80 @@ import HoTTLean.Groupoids.Sigma import HoTTLean.ForMathlib.CategoryTheory.Whiskering import HoTTLean.ForMathlib.CategoryTheory.NatTrans +import HoTTLean.ForMathlib.CategoryTheory.MorphismProperty.WideSubcategory universe v u v₁ u₁ v₂ u₂ v₃ u₃ noncomputable section --- NOTE temporary section for stuff to be moved elsewhere -section ForOther - -lemma hcongr_fun {α α' : Type u} (hα : α ≍ α') (β : α → Type v) (β' : α' → Type v) (hβ : β ≍ β') - (f : (x : α) → β x) (f' : (x : α') → β' x) (hf : f ≍ f') - {x : α} {x' : α'} (hx : x ≍ x') : f x ≍ f' x' := by - subst hα hβ hf hx - rfl namespace CategoryTheory -lemma Functor.Iso.whiskerLeft_inv_hom_heq {C : Type u} [Category.{v} C] {D : Type u₁} - [Category.{v₁} D] {E : Type u₂} [Category.{v₂} E] (F : C ≅≅ D) (G H : D ⥤ E) (η : G ⟶ H) : - (F.inv ⋙ F.hom).whiskerLeft η ≍ η := by - rw [F.inv_hom_id] - aesop_cat - -lemma Functor.Iso.whiskerLeft_inv_hom {C : Type u} [Category.{v} C] {D : Type u₁} [Category.{v₁} D] - {E : Type u₂} [Category.{v₂} E] (F : C ≅≅ D) (G H : D ⥤ E) (η : G ⟶ H) : - (F.inv ⋙ F.hom).whiskerLeft η = eqToHom (by aesop) ≫ η ≫ eqToHom (by aesop) := by - simpa [← heq_eq_eq] using - Functor.Iso.whiskerLeft_inv_hom_heq F G H η - -lemma Functor.Iso.whiskerLeft_hom_inv_heq {C : Type u} [Category.{v} C] {D : Type u₁} - [Category.{v₁} D] {E : Type u₂} [Category.{v₂} E] (F : D ≅≅ C) (G H : D ⥤ E) (η : G ⟶ H) : - (F.hom ⋙ F.inv).whiskerLeft η ≍ η := by - rw [F.hom_inv_id] - aesop_cat - -lemma Functor.Iso.whiskerLeft_hom_inv {C : Type u} [Category.{v} C] {D : Type u₁} [Category.{v₁} D] - {E : Type u₂} [Category.{v₂} E] (F : D ≅≅ C) (G H : D ⥤ E) (η : G ⟶ H) : - (F.hom ⋙ F.inv).whiskerLeft η = eqToHom (by aesop) ≫ η ≫ eqToHom (by aesop) := by - simpa [← heq_eq_eq] using - Functor.Iso.whiskerLeft_hom_inv_heq F G H η - -lemma Functor.associator_eq {C D E E' : Type*} [Category C] [Category D] [Category E] [Category E'] - (F : C ⥤ D) (G : D ⥤ E) (H : E ⥤ E') : associator F G H = CategoryTheory.Iso.refl _ := - rfl +lemma Pseudofunctor.StrongTrans.ext {C D : Type*} [Bicategory C] [Bicategory D] + {F G : Pseudofunctor C D} (α α' : F ⟶ G) (happ : ∀ x, α.app x = α'.app x) + (hnaturality : ∀ {x y} (f : x ⟶ y), (α.naturality f).hom ≫ eqToHom (by rw [happ]) = + eqToHom (by rw [happ]) ≫ (α'.naturality f).hom) : + α = α' := by + rcases α with ⟨app, naturality⟩ + rcases α' with ⟨app', naturality'⟩ + congr! + · ext + apply happ + · apply fun_hext + · rfl + · apply fun_hext + · rfl + · rfl + · aesop + · aesop section variable {A B : Type*} [Category A] [Category B] (F : B ⥤ A) --- NOTE to follow mathlib convention can use camelCase for definitions, and capitalised first letter when that definition is a Prop or Type -def IsSection (s : A ⥤ B) := s ⋙ F = Functor.id A +def IsSection : ObjectProperty (A ⥤ B) := fun s => s ⋙ F = Functor.id A -abbrev Section := ObjectProperty.FullSubcategory (IsSection F) +def IsOverId : MorphismProperty ((IsSection F).FullSubcategory) := + fun s t α => Functor.whiskerRight α F = eqToHom s.property ≫ 𝟙 (𝟭 A) ≫ eqToHom t.property.symm -instance Section.category : Category (Section F) := - ObjectProperty.FullSubcategory.category (IsSection F) +instance : (IsOverId F).IsMultiplicative where + id_mem := by + intro s + simp only [IsOverId, Category.id_comp, eqToHom_trans, eqToHom_refl] + erw [Functor.whiskerRight_id] + rfl + comp_mem := by + intro s0 s1 s2 α β hα hβ + simp only [IsOverId] + erw [Functor.whiskerRight_comp, hα, hβ] + simp + +abbrev Section := (IsOverId F).WideSubcategory abbrev Section.ι : Section F ⥤ (A ⥤ B) := - ObjectProperty.ι (IsSection F) + MorphismProperty.wideSubcategoryInclusion _ ⋙ ObjectProperty.ι (IsSection F) end +instance {A B : Type*} [Category A] [Groupoid B] (F : B ⥤ A) : + IsGroupoid ((IsSection F).FullSubcategory) := + InducedCategory.isGroupoid (A ⥤ B) (ObjectProperty.ι _).obj + +instance {A B : Type*} [Category A] [Groupoid B] (F : B ⥤ A) : + IsGroupoid (Section F) where + all_isIso {x y} f := { + out := ⟨⟨ CategoryTheory.inv f.1, + by + simp only [IsOverId, Category.id_comp, eqToHom_trans, Set.mem_setOf_eq] + erw [← Functor.inv_whiskerRight] + rw! [f.2] + simp⟩, + by apply MorphismProperty.WideSubcategory.hom_ext; simp, + by apply MorphismProperty.WideSubcategory.hom_ext; simp⟩ + } + +instance Section.groupoid {A B : Type*} [Category A] [Groupoid B] (F : B ⥤ A) : + Groupoid (Section F) := + Groupoid.ofIsGroupoid + namespace ObjectProperty lemma ι_mono {T C : Type u} [Category.{v} C] [Category.{v} T] @@ -77,9 +92,9 @@ lemma ι_mono {T C : Type u} [Category.{v} C] [Category.{v} T] end ObjectProperty -instance {C : Type*} [Groupoid C] (P : ObjectProperty C) : +local instance {G : Type*} [Groupoid G] (P : ObjectProperty G) : Groupoid (P.FullSubcategory) := - InducedCategory.groupoid C (ObjectProperty.ι _).obj + InducedCategory.groupoid G (ObjectProperty.ι _).obj instance Grpd.ι_mono (G : Grpd) (P : ObjectProperty G) : Mono (Grpd.homOf (ObjectProperty.ι P)) := ⟨ fun _ _ e => ObjectProperty.ι_mono _ _ e ⟩ @@ -99,6 +114,15 @@ lemma Grpd.ObjectProperty.FullSubcategory.hext {A A' : Grpd.{v,u}} (hA : A ≍ A subst hA hP hp rfl +lemma Grpd.MorphismProperty.WideSubcategory.hext {A A' : Grpd.{v,u}} (hA : A ≍ A') + (P : MorphismProperty A) (P' : MorphismProperty A') (hP : P ≍ P') + [P.IsMultiplicative] [P'.IsMultiplicative] + (p : P.WideSubcategory) (p' : P'.WideSubcategory) + (hp : p.obj ≍ p'.obj) : p ≍ p' := by + cases p; cases p' + subst hA hP hp + rfl + end CategoryTheory namespace GroupoidModel @@ -107,9 +131,6 @@ open CategoryTheory Opposite Functor.Groupoidal end GroupoidModel -end ForOther - --- NOTE content for this doc starts here namespace GroupoidModel open CategoryTheory Opposite Functor.Groupoidal @@ -144,8 +165,8 @@ def conjugating' {x y : Γ} (f : x ⟶ y) : (A.obj x ⥤ B.obj x) ⥤ (A.obj y ⥤ B.obj y) := whiskeringLeftObjWhiskeringRightObj (A.map (inv f)) (B.map f) -def conjugating {x y : Γ} (f : x ⟶ y) : Grpd.of (A.obj x ⥤ B.obj x) ⟶ - Grpd.of (A.obj y ⥤ B.obj y) := +def conjugating {x y : Γ} (f : x ⟶ y) : (A.obj x ⥤ B.obj x) ⥤ + (A.obj y ⥤ B.obj y) := conjugating' A B f lemma conjugating_obj {x y : Γ} (f : x ⟶ y) (s : A.obj x ⥤ B.obj x) : @@ -153,8 +174,8 @@ lemma conjugating_obj {x y : Γ} (f : x ⟶ y) (s : A.obj x ⥤ B.obj x) : rfl lemma conjugating_map {x y : Γ} (f : x ⟶ y) {s1 s2 : A.obj x ⥤ B.obj x} (h : s1 ⟶ s2) : - (conjugating A B f).map h - = whiskerRight (whiskerLeft (A.map (inv f)) h) (B.map f) := by + (conjugating A B f).map h = + whiskerRight (whiskerLeft (A.map (inv f)) h) (B.map f) := by rfl @[simp] lemma conjugating_id (x : Γ) : conjugating A B (𝟙 x) = 𝟭 _ := by @@ -164,7 +185,7 @@ lemma conjugating_map {x y : Γ} (f : x ⟶ y) {s1 s2 : A.obj x ⥤ B.obj x} (h conjugating A B (f ≫ g) = conjugating A B f ⋙ conjugating A B g := by simp [conjugating] -@[simp] lemma conjugating_naturality_map {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) +@[simp] lemma conjugating_comp_map {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) {x y} (f : x ⟶ y) : conjugating (σ ⋙ A) (σ ⋙ B) f = conjugating A B (σ.map f) := by simp [conjugating] @@ -186,185 +207,395 @@ def conjugatingObjNatTransEquiv' {x y : Γ} (f : x ⟶ y) (S) (T) : rw! (transparency := .default) [Category.id_comp, comp_eqToHom_heq_iff] apply Functor.Iso.whiskerLeft_hom_inv_heq -def conjugatingObjNatTransEquiv {x y : Γ} (f : x ⟶ y) (S) (T) : - (A.map (inv f) ⋙ S ⋙ B.map f ⟶ T) ≃ - (S ⋙ B.map f ⟶ A.map f ⋙ T) := conjugatingObjNatTransEquiv' A B f S T +@[simp] +lemma conjugatingObjNatTransEquiv'_id (x : Γ) (S) (T) (g) : + conjugatingObjNatTransEquiv' A B (𝟙 x) S T g = + eqToHom (by simp) ≫ g ≫ eqToHom (by simp) := by + ext + simp [conjugatingObjNatTransEquiv', Grpd.Functor.iso] + +lemma conjugatingObjNatTransEquiv'_comp {x y z : Γ} (f1 : x ⟶ y) (f2 : y ⟶ z) (S) (T) (g) : + conjugatingObjNatTransEquiv' A B (f1 ≫ f2) S T g = + eqToHom (by simp [Grpd.Functor.iso, ← Grpd.comp_eq_comp]) ≫ + (A.map f1 ⋙ A.map f2).whiskerLeft g ≫ + eqToHom (by simp [Grpd.Functor.iso, ← Grpd.comp_eq_comp]) := by + simp [conjugatingObjNatTransEquiv', Grpd.Functor.iso] + rw! [Functor.map_comp A f1 f2] + simp -def conjugatingObjNatTransEquiv₁ {x y : Γ} (f : x ⟶ y) (S) (T) : - (A.map (inv f) ⋙ S ⋙ B.map f ⟶ T) ≃ - (S ⋙ B.map f ≅ A.map f ⋙ T) := (conjugatingObjNatTransEquiv' A B f S T).trans - (Groupoid.isoEquivHom (S ⋙ B.map f) (A.map f ⋙ T)).symm +lemma whiskerLeft_map_comp {x y z : Γ} (f1 : x ⟶ y) (f2 : y ⟶ z) + (T1 T2 : (A.obj z) ⥤ (B.obj z)) + (g12 : T1 ⟶ T2) : + whiskerLeft (A.map (f1 ≫ f2)) g12 = + eqToHom (by simp) ≫ (A.map f1 ⋙ A.map f2).whiskerLeft g12 ≫ eqToHom (by simp) := by + aesop_cat -end +lemma Functor.id_whiskerLeft {A B C D : Type*} [Category A] [Category B] [Category C] [Category D] + {H0 H1 : C ⥤ D} (α : H0 ⟶ H1) : + whiskerLeft (𝟭 C) α = α := + rfl -section +lemma Functor.comp_whiskerLeft {A B C D : Type*} [Category A] [Category B] [Category C] [Category D] + (F : A ⥤ B) (G : B ⥤ C) {H0 H1 : C ⥤ D} (α : H0 ⟶ H1) : + whiskerLeft (F ⋙ G) α = whiskerLeft F (whiskerLeft G α) := + rfl -variable {Γ : Type u₂} [Category.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} - (B : ∫(A) ⥤ Grpd.{v₁,u₁}) (x : Γ) +lemma Functor.whiskerRight_whiskerLeft {A B C D : Type*} [Category A] [Category B] [Category C] + [Category D] (F : A ⥤ B) (G0 G1 : B ⥤ C) (H : C ⥤ D) (α : G0 ⟶ G1) : + whiskerRight (whiskerLeft F α) H = whiskerLeft F (whiskerRight α H) := by + rfl --- NOTE: domain changed from sigmaObj, since we don't want to view domain as an object in `Grpd` -abbrev sigma.fstAuxObj : ∫ ι A x ⋙ B ⥤ A.obj x := forget +theorem whiskerLeft_twice' {A B C D : Type*} [Category A] [Category B] [Category C] [Category D] + (F : A ⥤ B) (G : B ⥤ C) {H K : C ⥤ D} (α : H ⟶ K) : + whiskerLeft F (whiskerLeft G α) = + whiskerLeft (F ⋙ G) α := + rfl -open sigma +lemma conjugatingObjNatTransEquiv'_comp' {x y z : Γ} (f1 : x ⟶ y) (f2 : y ⟶ z) + (S0 : (A.obj x) ⥤ (B.obj x)) + (S1 : (A.obj y) ⥤ (B.obj y)) + (S2 : (A.obj z) ⥤ (B.obj z)) + (g01 : A.map (CategoryTheory.inv f1) ⋙ S0 ⋙ B.map f1 ⟶ S1) + (g12 : A.map (CategoryTheory.inv f2) ⋙ S1 ⋙ B.map f2 ⟶ S2) + (g02 : A.map (CategoryTheory.inv (f1 ≫ f2)) ⋙ S0 ⋙ B.map (f1 ≫ f2) ⟶ S2) + (h : g02 = eqToHom (by simp [← Grpd.comp_eq_comp]) ≫ + Functor.whiskerRight (Functor.whiskerLeft (A.map (CategoryTheory.inv f2)) g01) (B.map f2) ≫ + eqToHom (by simp [← Grpd.comp_eq_comp]) ≫ g12) : + conjugatingObjNatTransEquiv' A B (f1 ≫ f2) S0 S2 g02 = + eqToHom (by simp [← Grpd.comp_eq_comp, Grpd.Functor.iso]) ≫ + (whiskerRight (conjugatingObjNatTransEquiv' A B f1 S0 S1 g01) (B.map f2)) ≫ + (whiskerLeft (A.map f1) (conjugatingObjNatTransEquiv' A B f2 S1 S2 g12)) ≫ + eqToHom (by simp [← Grpd.comp_eq_comp, Grpd.Functor.iso]) := by + subst h + simp only [Grpd.Functor.iso, Grpd.functorIsoOfIso_hom, mapIso_hom, asIso_hom, + Grpd.functorIsoOfIso_inv, mapIso_inv, asIso_inv, conjugatingObjNatTransEquiv', eqToHom_refl, + Category.id_comp, Equiv.coe_fn_mk, whiskerLeft_comp, whiskerLeft_eqToHom, eqToHom_trans_assoc, + whiskerRight_comp, eqToHom_whiskerRight, whiskerLeft_twice, associator_eq, + CategoryTheory.Iso.refl_inv, CategoryTheory.Iso.refl_hom, Category.comp_id, Category.assoc] at * + erw [Category.id_comp] + rw [whiskerLeft_map_comp, whiskerLeft_map_comp] + simp only [← Category.assoc, eqToHom_trans] + congr 2 + rw [Functor.comp_whiskerLeft, Functor.whiskerRight_whiskerLeft, Functor.whiskerRight_whiskerLeft, + whiskerLeft_twice' (A.map f2)] + simp only [← Grpd.comp_eq_comp] + rw! (castMode := .all) [← Functor.map_comp A f2, IsIso.hom_inv_id, + CategoryTheory.Functor.map_id, Grpd.id_eq_id] + simp only [Functor.id_whiskerLeft, Grpd.comp_eq_comp, Category.assoc, eqToHom_trans, eqToHom_refl, + Category.comp_id, ← heq_eq_eq, heq_eqToHom_comp_iff, heq_comp_eqToHom_iff, + eqToHom_comp_heq_iff] + congr 1 + · simp [← Grpd.comp_eq_comp] + · simp [← Grpd.comp_eq_comp] + · simp -def piObj : Grpd := Grpd.of (Section (fstAuxObj B x)) +def conjugatingObjNatTransEquiv₁ {x y : Γ} (f : x ⟶ y) (S) (T) : + (A.map (inv f) ⋙ S ⋙ B.map f ⟶ T) ≃ + (S ⋙ B.map f ≅ A.map f ⋙ T) := (conjugatingObjNatTransEquiv' A B f S T).trans + (Groupoid.isoEquivHom (S ⋙ B.map f) (A.map f ⋙ T)).symm -lemma piObj.hext {A A' : Γ ⥤ Grpd.{v,u}} (hA : A ≍ A') {B : ∫ A ⥤ Grpd.{v,u}} - {B' : ∫ A' ⥤ Grpd.{v,u}} (hB : B ≍ B') (x : Γ) - (f : piObj B x) (f' : piObj B' x) (hf : f.obj ≍ f'.obj) : f ≍ f' := by - subst hA hB - simp only [heq_eq_eq] at * - unfold piObj Section Grpd.of Bundled.of - ext - rw [hf] +@[simp] +lemma conjugatingObjNatTransEquiv₁_id_inv {x : Γ} (S) (T) + (g : A.map (inv (𝟙 x)) ⋙ S ⋙ B.map (𝟙 x) ⟶ T) : + (conjugatingObjNatTransEquiv₁ A B (𝟙 x) S T g).inv = + eqToHom (by simp) ≫ CategoryTheory.inv g ≫ eqToHom (by simp) := by + dsimp only [conjugatingObjNatTransEquiv₁, Equiv.trans_apply] + erw [conjugatingObjNatTransEquiv'_id] + simp [Groupoid.isoEquivHom] + +lemma conjugatingObjNatTransEquiv₁_comp_inv {x y z : Γ} (f1 : x ⟶ y) (f2 : y ⟶ z) + (S0 : (A.obj x) ⥤ (B.obj x)) + (S1 : (A.obj y) ⥤ (B.obj y)) + (S2 : (A.obj z) ⥤ (B.obj z)) + (g01 : A.map (inv f1) ⋙ S0 ⋙ B.map f1 ⟶ S1) + (g12 : A.map (inv f2) ⋙ S1 ⋙ B.map f2 ⟶ S2) + (g02 : A.map (inv (f1 ≫ f2)) ⋙ S0 ⋙ B.map (f1 ≫ f2) ⟶ S2) + (h : g02 = eqToHom (by simp [← Grpd.comp_eq_comp]) ≫ + Functor.whiskerRight (Functor.whiskerLeft (A.map (CategoryTheory.inv f2)) g01) (B.map f2) ≫ + eqToHom (by simp [← Grpd.comp_eq_comp]) ≫ g12) : + (conjugatingObjNatTransEquiv₁ A B (f1 ≫ f2) S0 S2 g02).inv = + eqToHom (by simp [← Grpd.comp_eq_comp]) ≫ + whiskerLeft (A.map f1) (conjugatingObjNatTransEquiv₁ A B f2 S1 S2 g12).inv ≫ + whiskerRight ((conjugatingObjNatTransEquiv₁ A B f1 S0 S1 g01).inv) (B.map f2) ≫ + eqToHom (by simp [← Grpd.comp_eq_comp]) := by + dsimp [conjugatingObjNatTransEquiv₁] + erw [conjugatingObjNatTransEquiv'_comp' A B f1 f2 S0 S1 S2 g01 g12 g02 h] + simp [Groupoid.isoEquivHom] + rfl end -section -variable {Γ : Type u₂} [Groupoid.{v₂} Γ] (A : Γ ⥤ Grpd.{u₁,u₁}) (B : ∫(A) ⥤ Grpd.{u₁,u₁}) -variable {x y : Γ} (f: x ⟶ y) +namespace Section + +variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {A : Γ ⥤ Grpd.{u₁,u₁}} + {B : Γ ⥤ Grpd.{u₁,u₁}} (φ : B ⟶ A) + +def functorObj (x : Γ) : Grpd.{u₁,u₁} := Grpd.of (Section (φ.app x)) + +def obj_hext {A A' : Grpd.{u₁,u₁}} (hA : A ≍ A') {B B' : Grpd.{u₁,u₁}} (hB : B ≍ B') + {F : A ⟶ B} {F' : A' ⟶ B'} (hF : F ≍ F') (x : Section F) (x' : Section F') + (hx : x.obj.obj ≍ x'.obj.obj) : x ≍ x' := by + aesop + +def hom_hext {A A' : Grpd.{u₁,u₁}} (hA : A ≍ A') {B B' : Grpd.{u₁,u₁}} (hB : B ≍ B') + {F : A ⟶ B} {F' : A' ⟶ B'} (hF : F ≍ F') {x y : Section F} {x' y' : Section F'} + {f : x ⟶ y} {f' : x' ⟶ y'} (hx : x ≍ x') + (hy : y ≍ y') (hf : f.1 ≍ f'.1) : + f ≍ f' := by + subst hA hB hF hx hy + simp at * + apply MorphismProperty.WideSubcategory.hom_ext + apply hf + +def hom_hext' {A A' : Grpd.{u₁,u₁}} (hA : A ≍ A') {B B' : Grpd.{u₁,u₁}} (hB : B ≍ B') + {F : A ⟶ B} {F' : A' ⟶ B'} (hF : F ≍ F') {x y : Section F} {x' y' : Section F'} + {f : x ⟶ y} {f' : x' ⟶ y'} (hx : x ≍ x') + (hy : y ≍ y') (hf : ∀ k k', k ≍ k' → f.1.app k ≍ f'.1.app k') : + f ≍ f' := by + subst hA hB hF hx hy + simp at * + apply MorphismProperty.WideSubcategory.hom_ext + apply NatTrans.ext + ext + apply hf -open sigma +section -/-- -If `s : piObj B x` then the underlying functor is of the form `s : A x ⥤ sigma A B x` -and it is a section of the forgetful functor `sigma A B x ⥤ A x`. -This theorem states that conjugating `A f⁻¹ ⋙ s ⋙ sigma A B f⁻¹ : A y ⥤ sigma A B y` -using some `f : x ⟶ y` produces a section of the forgetful functor `sigma A B y ⥤ A y`. --/ -theorem isSection_conjugating_isSection (s : piObj B x) : IsSection (fstAuxObj B y) - ((Section.ι (fstAuxObj B x) ⋙ conjugating A (sigma A B) f).obj s) := by - simp only [IsSection, Functor.comp_obj, ObjectProperty.ι_obj, - conjugating_obj, Functor.assoc, sigma_map, fstAuxObj] - rw [sigmaMap_forget] - convert_to (Grpd.Functor.iso A f).inv ⋙ (s.obj ⋙ fstAuxObj B x) ⋙ (Grpd.Functor.iso A f).hom = _ - rw [s.property] - simp +variable {x y : Γ} (f : x ⟶ y) /-- The functorial action of `pi` on a morphism `f : x ⟶ y` in `Γ` is given by "conjugation". -Since `piObj B x` is a full subcategory of `sigma A B x ⥤ A x`, +Since `piObj B x` is a subcategory of `sigma A B x ⥤ A x`, we obtain the action `piMap : piObj B x ⥤ piObj B y` as the induced map in the following diagram - the inclusion + +``` Section.ι - piObj B x ⥤ (A x ⥤ sigma A B x) + piObj B x ⥤ (A x ⥤ B x) ⋮ || - ⋮ || conjugating A (sigma A B) f + ⋮ || conjugating A B f VV VV - piObj B y ⥤ (A y ⥤ sigma A B y) + piObj B y ⥤ (A y ⥤ B y) +``` -/ -def piMap : piObj B x ⥤ piObj B y := - ObjectProperty.lift (IsSection (fstAuxObj B y)) - ((Section.ι (fstAuxObj B x) ⋙ conjugating A (sigma A B) f)) - (isSection_conjugating_isSection A B f) +def functorMap : functorObj φ x ⥤ functorObj φ y := + MorphismProperty.lift _ + (ObjectProperty.lift (IsSection (φ.app y)) + ((Section.ι _ ⋙ conjugating A B f)) + (by + intro s + have := s.obj.property + simp only [IsSection, ← Grpd.comp_eq_comp, ← Grpd.id_eq_id, Functor.comp_obj, + MorphismProperty.wideSubcategoryInclusion.obj, ObjectProperty.ι_obj, conjugating_obj, + Functor.map_inv, Category.assoc, NatTrans.naturality] at * + slice_lhs 2 3 => rw [this] + simp [- Grpd.comp_eq_comp, - Grpd.id_eq_id])) + (by + intro s t α + have := α.property + simp only [IsOverId, ← Grpd.comp_eq_comp, Category.id_comp, eqToHom_trans, Set.mem_setOf_eq, + ObjectProperty.lift_obj_obj, Functor.comp_obj, MorphismProperty.wideSubcategoryInclusion.obj, + ObjectProperty.ι_obj, ObjectProperty.lift_map, Functor.comp_map, + MorphismProperty.wideSubcategoryInclusion.map, ObjectProperty.ι_map, conjugating_map, + Functor.whiskerRight_twice, Functor.associator_eq, Iso.refl_hom, Iso.refl_inv] at * + rw [Functor.whiskerRight_whiskerLeft] + conv => left; left; rw! (castMode := .all) [φ.naturality, Grpd.comp_eq_comp] + erw [Functor.comp_whiskerRight, this, Category.comp_id] + simp only [Grpd.comp_eq_comp, Functor.eqToHom_whiskerRight, Functor.whiskerLeft_eqToHom, + ← heq_eq_eq, eqRec_heq_iff_heq] + congr! 1 + · simp only [← Grpd.comp_eq_comp, ← φ.naturality] + rfl + · simp only [← Grpd.comp_eq_comp, ← φ.naturality] + rfl) + +def functor : Γ ⥤ Grpd.{u₁,u₁} where + obj := functorObj φ + map := functorMap φ + map_id _ := by simp only [functorMap, conjugating_id]; rfl + map_comp _ _ := by simp only [functorMap, conjugating_comp]; rfl + +lemma functor_comp {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : + functor (A := σ ⋙ A) (B := σ ⋙ B) (Functor.whiskerLeft σ φ) = + σ ⋙ functor φ := by + fapply CategoryTheory.Functor.ext + · intro x + simp [functor, functorObj] + · intro x y f + simp [functor, functorMap] -lemma piMap_obj_obj (s: piObj B x) : ((piMap A B f).obj s).obj = - (conjugating A (sigma A B) f).obj s.obj := rfl +@[simp] +lemma functor_map_map {s t} (α : s ⟶ t) : (((functor φ).map f).map α).1 = + Functor.whiskerRight (Functor.whiskerLeft (A.map (inv f)) α.1) (B.map f) := by + simp [functor, functorMap, conjugating, MorphismProperty.lift] -lemma piMap_map (s1 s2: piObj B x) (η: s1 ⟶ s2) : - (piMap A B f).map η = (conjugating A (sigma A B) f).map η := - rfl +end -/-- -The square commutes +section - piObj B x ⥤ (A x ⥤ sigma A B x) - ⋮ || -piMap⋮ || conjugating A (sigma A B) f - VV VV - piObj B y ⥤ (A y ⥤ sigma A B y) --/ -lemma piMap_ι : piMap A B f ⋙ Section.ι (fstAuxObj B y) - = Section.ι (fstAuxObj B x) ⋙ conjugating A (sigma A B) f := +variable (app : (x : Γ) → A.obj x ⥤ B.obj x) + (naturality : {x y : Γ} → (f : x ⟶ y) → A.map f ⋙ app y ≅ app x ⋙ B.map f) + (naturality_id : (x : Γ) → (naturality (𝟙 x)).hom = eqToHom (by simp)) + (naturality_comp : {x y z : Γ} → (f : x ⟶ y) → (g : y ⟶ z) → + (naturality (f ≫ g)).hom = eqToHom (by simp [Functor.assoc]) ≫ + Functor.whiskerLeft (A.map f) (naturality g).hom ≫ + eqToHom (Functor.assoc ..) ≫ + Functor.whiskerRight (naturality f).hom (B.map g) + ≫ eqToHom (by simp [Functor.assoc])) + +def strongTrans : (A ⋙ Grpd.forgetToCat).toPseudoFunctor'.StrongTrans + (B ⋙ Grpd.forgetToCat).toPseudoFunctor' where + app x := app x.as + naturality f := naturality f.as + naturality_naturality := by + intro x y f g η + have := LocallyDiscrete.eq_of_hom η + subst this + simp only [Functor.toPseudoFunctor', Functor.comp_obj, Functor.comp_map, LocallyDiscrete.id_as, + LocallyDiscrete.comp_as, pseudofunctorOfIsLocallyDiscrete, Bicategory.whiskerRight, + eqToHom_refl, Bicategory.whiskerLeft] + aesop + naturality_id := by + intro x + simp only [Functor.toPseudoFunctor', Functor.comp_obj, Functor.comp_map, LocallyDiscrete.id_as, + LocallyDiscrete.comp_as, pseudofunctorOfIsLocallyDiscrete, Bicategory.whiskerLeft, + eqToIso.hom, Bicategory.whiskerRight, Bicategory.leftUnitor, Bicategory.rightUnitor] + rw [Functor.eqToHom_whiskerRight, Functor.leftUnitor_hom_comp_rightUnitor_inv, + Functor.whiskerLeft_eqToHom, naturality_id] + simp + conv => right; apply Category.comp_id + naturality_comp := by + intro x y z f g + simp only [Grpd.forgetToCat, Functor.toPseudoFunctor', Functor.comp_obj, Functor.comp_map, + id_eq, LocallyDiscrete.id_as, LocallyDiscrete.comp_as, pseudofunctorOfIsLocallyDiscrete, + naturality_comp, eqToHom_refl, Category.id_comp, Bicategory.whiskerLeft, Cat.of_α, + eqToIso.hom, Category.assoc, Bicategory.whiskerRight, Bicategory.associator, + Functor.associator_eq, Iso.refl_hom, Iso.refl_inv] + rw [Functor.eqToHom_whiskerRight, Functor.whiskerLeft_eqToHom] + erw [Category.id_comp, Category.id_comp, Category.comp_id] + simp + +lemma strongTrans_comp_toStrongTrans'_self_aux (happ : ∀ x, app x ⋙ φ.app x = 𝟭 _) + {x y} (f : x ⟶ y) (a : A.obj x) : + (φ.app y).obj ((A.map f ⋙ app y).obj a) = (φ.app y).obj ((app x ⋙ B.map f).obj a) := by + erw [Functor.congr_obj (φ.naturality f) ((app x).obj a), + Functor.congr_obj (happ y)] + simp only [Functor.id_obj, Grpd.comp_eq_comp, Functor.comp_obj] + erw [Functor.congr_obj (happ x)] + simp + +open CategoryTheory.Pseudofunctor.StrongTrans in +lemma strongTrans_comp_toStrongTrans'_self (happ : ∀ x, app x ⋙ φ.app x = 𝟭 _) + (hnaturality : ∀ {x y} (f : x ⟶ y) (a : A.obj x), + (φ.app y).map ((naturality f).hom.app a) = + eqToHom (strongTrans_comp_toStrongTrans'_self_aux φ app happ f a)) : + (strongTrans app naturality naturality_id naturality_comp) ≫ + (Functor.whiskerRight φ Grpd.forgetToCat).toStrongTrans' = 𝟙 _ := by + fapply Pseudofunctor.StrongTrans.ext + · intro x + simp only [Grpd.forgetToCat, Functor.toPseudoFunctor'_obj, Functor.comp_obj, strongTrans, + comp_app, NatTrans.toStrongTrans'_app, Functor.whiskerRight_app, id_eq, categoryStruct_id_app] + apply happ + · intro x y f + ext a + simp only [Grpd.forgetToCat, Functor.toPseudoFunctor'_obj, Functor.comp_obj, Cat.of_α, + Functor.toPseudoFunctor'_map, Functor.comp_map, id_eq, strongTrans, comp_app, + NatTrans.toStrongTrans'_app, Functor.whiskerRight_app, Cat.comp_obj, categoryStruct_id_app, + Cat.id_obj, categoryStruct_comp_naturality_hom, Bicategory.associator, + NatTrans.toStrongTrans'_naturality, eqToIso.hom, Bicategory.whiskerLeft_eqToHom, + Category.assoc, Cat.comp_app, Functor.associator_inv_app, Cat.whiskerRight_app, + Functor.associator_hom_app, Cat.eqToHom_app, Category.id_comp, eqToHom_trans, + categoryStruct_id_naturality_hom, Bicategory.rightUnitor, Bicategory.leftUnitor, + Functor.rightUnitor_hom_app, Functor.leftUnitor_inv_app, Category.comp_id, ← heq_eq_eq, + comp_eqToHom_heq_iff] + rw! [hnaturality] + apply eqToHom_heq_eqToHom + rfl + +def mapStrongTrans : ∫ A ⥤ ∫ B := + (Functor.Grothendieck.toPseudoFunctor'Iso _).hom ⋙ + Pseudofunctor.Grothendieck.map (strongTrans app naturality naturality_id naturality_comp) ⋙ + (Functor.Grothendieck.toPseudoFunctor'Iso _).inv + +@[simp] +lemma mapStrongTrans_obj_base (x) : + ((mapStrongTrans app naturality naturality_id naturality_comp).obj x).base = x.base := rfl -@[simp] lemma piMap_id (x : Γ) : piMap A B (𝟙 x) = 𝟭 (piObj B x) := by - simp only [piMap, conjugating_id] +@[simp] +lemma mapStrongTrans_obj_fiber (x) : + ((mapStrongTrans app naturality naturality_id naturality_comp).obj x).fiber = + (app x.base).obj x.fiber := rfl -lemma piMap_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : - piMap A B (f ≫ g) = (piMap A B f) ⋙ (piMap A B g) := by - simp only [piMap, conjugating_comp] +@[simp] +lemma mapStrongTrans_map_base {x y} (f : x ⟶ y) : + ((mapStrongTrans app naturality naturality_id naturality_comp).map f).base = f.base := rfl -/-- The formation rule for Π-types for the natural model `smallU` - as operations between functors -/ -@[simps] def pi : Γ ⥤ Grpd.{u₁,u₁} where - obj x := piObj B x - map := piMap A B - map_id := piMap_id A B - map_comp := piMap_comp A B +@[simp] +lemma mapStrongTrans_map_fiber {x y} (f : x ⟶ y) : + ((mapStrongTrans app naturality naturality_id naturality_comp).map f).fiber = + (naturality f.base).inv.app x.fiber ≫ (app y.base).map f.fiber := + rfl + +lemma mapStrongTrans_comp_map_self (happ : ∀ x, app x ⋙ φ.app x = 𝟭 _) + (hnaturality : ∀ {x y} (f : x ⟶ y) (a : A.obj x), + (φ.app y).map ((naturality f).hom.app a) = + eqToHom (strongTrans_comp_toStrongTrans'_self_aux φ app happ f a)) : + mapStrongTrans app naturality naturality_id naturality_comp ⋙ map φ = 𝟭 _ := by + dsimp only [mapStrongTrans, map] + simp only [Functor.Grothendieck.map_eq_pseudofunctor_map, Functor.assoc] + slice_lhs 3 4 => simp only [← Functor.assoc, Functor.Iso.inv_hom_id, Functor.id_comp] + slice_lhs 2 3 => simp only [← Functor.assoc, ← Pseudofunctor.Grothendieck.map_comp_eq] + rw [strongTrans_comp_toStrongTrans'_self φ app naturality naturality_id + naturality_comp happ hnaturality, Pseudofunctor.Grothendieck.map_id_eq] + simp end -section +end Section +section variable {Γ : Type u₂} [Groupoid.{v₂} Γ] (A : Γ ⥤ Grpd.{u₁,u₁}) (B : ∫(A) ⥤ Grpd.{u₁,u₁}) - {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) - -theorem IsSection_eq (x) : sigma.fstAuxObj B (σ.obj x) ≍ sigma.fstAuxObj (pre A σ ⋙ B) x := by - dsimp [sigma.fstAuxObj] - rw [sigma_naturality_aux] +/-- The formation rule for Π-types for the natural model `smallU` +as operations between functors. -lemma piObj_naturality (x): - piObj B (σ.obj x) = piObj (pre A σ ⋙ B) x := by - dsimp [pi, piObj, sigma.fstAuxObj] - rw [sigma_naturality_aux] +The functorial action of `pi` on a morphism `f : x ⟶ y` in `Γ` +is given by "conjugation". +Since `piObj B x` is a subcategory of `sigma A B x ⥤ A x`, +we obtain the action `piMap : piObj B x ⥤ piObj B y` +as the induced map in the following diagram -section +``` + Section.ι + piObj B x ⥤ (A x ⥤ sigma A B x) + ⋮ || + ⋮ || conjugating A (sigma A B) f + VV VV + piObj B y ⥤ (A y ⥤ sigma A B y) +``` +-/ +@[simps!] def pi : Γ ⥤ Grpd.{u₁,u₁} := Section.functor (A := A) + (B := sigma A B) (sigma.fstNatTrans B) -variable (x y : Δ) - -lemma eqToHom_ι_aux : - Grpd.of ((A.obj (σ.obj x)) ⥤ ∫(ι A (σ.obj x) ⋙ B)) - = Grpd.of (A.obj (σ.obj x) ⥤ ∫(ι (σ ⋙ A) x ⋙ pre A σ ⋙ B)) := - by rw [sigma_naturality_aux] - -lemma ObjectProperty.eqToHom_comp_ι {C D : Grpd} (h : C = D) (P : ObjectProperty C) - (Q : ObjectProperty D) (hP : P ≍ Q) : - let h' : Grpd.of P.FullSubcategory = Grpd.of Q.FullSubcategory := by - subst h hP; rfl - eqToHom h' ⋙ (ObjectProperty.ι Q) = (ObjectProperty.ι P) ⋙ eqToHom h := by - subst h hP; rfl - -lemma eqToHom_ι' (x) : - ObjectProperty.ι (IsSection (sigma.fstAuxObj (pre A σ ⋙ B) x)) ≍ - ObjectProperty.ι (IsSection (sigma.fstAuxObj B (σ.obj x))) := by - dsimp [sigma.fstAuxObj] - rw [sigma_naturality_aux] - -lemma eqToHom_ι (x) : - eqToHom (piObj_naturality A B σ x) ≫ - Grpd.homOf (ObjectProperty.ι (IsSection (sigma.fstAuxObj (pre A σ ⋙ B) x))) = - Grpd.homOf (ObjectProperty.ι (IsSection (sigma.fstAuxObj B (σ.obj x)))) ≫ - eqToHom (eqToHom_ι_aux A B σ x) := by - rw [← heq_eq_eq, eqToHom_comp_heq_iff, heq_comp_eqToHom_iff] - apply eqToHom_ι' +lemma pi.obj_hext {A A' : Γ ⥤ Grpd.{u₁,u₁}} (hA : A ≍ A') {B : ∫ A ⥤ Grpd.{u₁,u₁}} + {B' : ∫ A' ⥤ Grpd.{u₁,u₁}} (hB : B ≍ B') (x : Γ) + (f : (pi A B).obj x) (f' : (pi A' B').obj x) (hf : f.obj.obj ≍ f'.obj.obj) : f ≍ f' := by + aesop end section -variable {C : Type u} [Category.{v} C] {D : Type u₁} [Category.{v₁} D] (P Q : ObjectProperty D) - (F : C ⥤ D) (hF : ∀ X, P (F.obj X)) - -theorem FullSubcategory.lift_comp_inclusion_eq : - P.lift F hF ⋙ P.ι = F := - rfl -end +variable {Γ : Type u₂} [Groupoid.{v₂} Γ] (A : Γ ⥤ Grpd.{u₁,u₁}) (B : ∫(A) ⥤ Grpd.{u₁,u₁}) + {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) -lemma conjugating_naturality_sigma {x y} (f : x ⟶ y): +lemma conjugating_comp_sigma {x y} (f : x ⟶ y): conjugating (σ ⋙ A) (sigma (σ ⋙ A) (pre A σ ⋙ B)) f ≍ conjugating A (sigma A B) (σ.map f) := by rw! [← sigma_naturality] - rw [conjugating_naturality_map] - -lemma eqToHom_conjugating {x y} (f : x ⟶ y): - eqToHom (eqToHom_ι_aux A B σ x) ≫ conjugating (σ ⋙ A) (sigma (σ ⋙ A) (pre A σ ⋙ B)) f = - conjugating A (sigma A B) (σ.map f) ≫ eqToHom (eqToHom_ι_aux A B σ y) := by - rw [← heq_eq_eq, eqToHom_comp_heq_iff, heq_comp_eqToHom_iff] - exact conjugating_naturality_sigma A B σ f + rw [conjugating_comp_map] lemma comm_sq_of_comp_mono {C : Type*} [Category C] {X Y Z W X' Y' Z' W' : C} @@ -386,33 +617,20 @@ lemma comm_sq_of_comp_mono {C : Type*} [Category C] _ = h ≫ mW ≫ i' := by simp _ = (h ≫ i) ≫ mZ := by aesop -theorem pi_naturality_map {x y} (f : x ⟶ y) : - Grpd.homOf (piMap A B (σ.map f)) ≫ eqToHom (piObj_naturality A B σ y) - = eqToHom (piObj_naturality A B σ x) ≫ (Grpd.homOf (piMap (σ ⋙ A) (pre A σ ⋙ B) f)) := by - apply comm_sq_of_comp_mono (e := Grpd.ι_mono (Grpd.of (_ ⥤ _)) - (IsSection (sigma.fstAuxObj (pre A σ ⋙ B) y))) - (Grpd.homOf (piMap A B (σ.map f))) - (eqToHom (piObj_naturality A B σ x)) - (eqToHom (piObj_naturality A B σ y)) (Grpd.homOf (piMap (σ ⋙ A) (pre A σ ⋙ B) f)) - (Grpd.homOf (conjugating A (sigma A B) (σ.map f))) - (eqToHom (eqToHom_ι_aux A B σ x)) (eqToHom (eqToHom_ι_aux A B σ y)) - (Grpd.homOf (conjugating (σ ⋙ A) (sigma (σ ⋙ A) (pre A σ ⋙ B)) f)) - (Grpd.homOf (ObjectProperty.ι _)) - (Grpd.homOf (ObjectProperty.ι _)) - (Grpd.homOf (ObjectProperty.ι _)) - (Grpd.homOf (ObjectProperty.ι _)) - · rw [eqToHom_conjugating] - · apply FunctorOperation.FullSubcategory.lift_comp_inclusion_eq - · apply eqToHom_ι - · apply eqToHom_ι - · apply FunctorOperation.FullSubcategory.lift_comp_inclusion_eq - -theorem pi_naturality : σ ⋙ pi A B = pi (σ ⋙ A) (pre A σ ⋙ B) := by - fapply CategoryTheory.Functor.ext - · apply piObj_naturality - · intro x y f - erw [← Category.assoc, ← pi_naturality_map] - simp [- Grpd.comp_eq_comp, - Grpd.id_eq_id] +theorem pi_comp : pi (σ ⋙ A) (pre A σ ⋙ B) = σ ⋙ pi A B := by + dsimp [pi] + rw [← Section.functor_comp] + congr 1 + · symm + apply sigma_naturality + · apply NatTrans.hext + · symm + apply sigma_naturality + · rfl + · intro x + simp only [sigma_obj, Functor.comp_obj, sigma.fstNatTrans, Functor.whiskerLeft_app] + congr 1 + rw [← Functor.assoc, ι_comp_pre] end @@ -424,74 +642,282 @@ variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {A : Γ ⥤ Grpd.{u₁,u₁}} (B (s : Γ ⥤ PGrpd.{u₁,u₁}) (hs : s ⋙ PGrpd.forgetToGrpd = pi A B) {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) +def strongTrans.app (x) : A.obj x ⟶ (sigma A B).obj x := + (PGrpd.objFiber' hs x).obj.obj + +@[simp] +lemma strongTrans.app_obj_base (y) (a) : + ((strongTrans.app B s hs y).obj a).base = a := + Functor.congr_obj (PGrpd.objFiber' hs y).obj.property a + +-- NOTE: no simp lemma for ((strongTrans.app B s hs y).obj a).fiber + +@[simp] +lemma strongTrans.app_map_base (y) {a a'} (f : a ⟶ a') : + ((strongTrans.app B s hs y).map f).base = eqToHom (by simp) ≫ + f ≫ eqToHom (by simp) := by + have := Functor.congr_hom (PGrpd.objFiber' hs y).obj.property f + simp at this + simp [strongTrans.app, this] + +def strongTrans.twoCell {x y : Γ} (g : x ⟶ y) : + A.map (CategoryTheory.inv g) ⋙ strongTrans.app B s hs x ⋙ sigmaMap B g ⟶ + strongTrans.app B s hs y := (PGrpd.mapFiber' hs g).1 + +lemma strongTrans.twoCell_app_base_aux {x y : Γ} (g : x ⟶ y) (a) : + base ((A.map (CategoryTheory.inv g) ⋙ app B s hs x ⋙ sigmaMap B g).obj a) = + base ((app B s hs y).obj a) := by + simp only [Functor.map_inv, sigma_obj, Functor.comp_obj, sigmaMap_obj_base, app_obj_base] + simp [← Functor.comp_obj, ← Grpd.comp_eq_comp] + +@[simp] +lemma strongTrans.twoCell_app_base {x y : Γ} (g : x ⟶ y) (a) : + ((strongTrans.twoCell B s hs g).app a).base = eqToHom (twoCell_app_base_aux ..) := by + have := NatTrans.congr_app (PGrpd.mapFiber' hs g).2 a + simp only [sigma_obj, sigma.fstNatTrans_app, pi_obj_α, Functor.comp_obj, + Functor.Groupoidal.forget_obj, IsOverId, Set.mem_setOf_eq, Functor.whiskerRight_app, forget_map, + Category.id_comp, eqToHom_trans, eqToHom_app] at this + rw [twoCell, this] + +@[simp] +lemma strongTrans.twoCell_id (x) : + twoCell B s hs (𝟙 x) = eqToHom (by simp) := by + simp [twoCell] + rfl + +set_option maxHeartbeats 400000 in +lemma strongTrans.pi_map_map {x y z} (f : x ⟶ y) (g : y ⟶ z) : + (((pi A B).map g).map (PGrpd.mapFiber' hs f)).1 = + Functor.whiskerLeft (A.map (CategoryTheory.inv g)) + (Functor.whiskerRight (twoCell B s hs f) (sigmaMap B g)) := + Section.functor_map_map (A := A) + (B := sigma A B) (sigma.fstNatTrans B) g (PGrpd.mapFiber' hs f) + +set_option maxHeartbeats 300000 in +/-- +``` +A x <----- A y <----- A z + | | | + | => | => | + | conj f | conj g | + V V V +sigma x -> sigma x -> sigma z +``` +-/ +@[simp] +lemma strongTrans.twoCell_comp {x y z} (f : x ⟶ y) (g : y ⟶ z) : + twoCell B s hs (f ≫ g) = eqToHom (by simp [← Grpd.comp_eq_comp, sigmaMap_comp]) ≫ + Functor.whiskerLeft (A.map (CategoryTheory.inv g)) + (Functor.whiskerRight (twoCell B s hs f) (sigmaMap B g)) ≫ + twoCell B s hs g := by + conv => left; simp only [twoCell, sigma_obj, pi_obj_α, Set.mem_setOf_eq, + PGrpd.mapFiber'_comp' hs f g, MorphismProperty.WideSubcategory.comp_def, + MorphismProperty.WideSubcategory.coe_eqToHom, pi_map_map] + rfl + def strongTrans.naturality {x y : Γ} (g : x ⟶ y) : - A.map g ⋙ (PGrpd.objFiber' hs y).obj ≅ (PGrpd.objFiber' hs x).obj ⋙ sigmaMap B g := - let fib : A.map (CategoryTheory.inv g) ⋙ (PGrpd.objFiber' hs x).obj ⋙ (sigma A B).map g ⟶ - (PGrpd.objFiber' hs y).obj := PGrpd.mapFiber' hs g - ((conjugatingObjNatTransEquiv₁ _ _ _ _ _).toFun fib).symm + A.map g ⋙ strongTrans.app B s hs y ≅ strongTrans.app B s hs x ⋙ sigmaMap B g := + ((conjugatingObjNatTransEquiv₁ _ _ _ _ _).toFun (twoCell B s hs g)).symm + +lemma strongTrans.naturality_inv_app {x y} (f : x ⟶ y) (a) : + (strongTrans.naturality B s hs f).inv.app a = + eqToHom (by simp [← Functor.comp_obj]; simp [← Grpd.comp_eq_comp]) ≫ + (twoCell B s hs f).app ((A.map f).obj a) := by + simp only [sigma_obj, Functor.comp_obj, naturality, sigma_map, + conjugatingObjNatTransEquiv₁, Grpd.Functor.iso, Grpd.functorIsoOfIso_inv, Functor.mapIso_inv, + asIso_inv, Grpd.functorIsoOfIso_hom, Functor.mapIso_hom, asIso_hom, + conjugatingObjNatTransEquiv', Groupoid.isoEquivHom, Groupoid.inv_eq_inv, Equiv.toFun_as_coe, + Equiv.trans_apply, Equiv.coe_fn_mk, Equiv.coe_fn_symm_mk, IsIso.inv_comp, + Functor.inv_whiskerLeft, inv_eqToHom, Iso.symm_mk, NatTrans.comp_app, eqToHom_app, + Functor.whiskerLeft_app] -@[simps] -def strongTrans : (A ⋙ Grpd.forgetToCat).toPseudoFunctor'.StrongTrans - (sigma A B ⋙ Grpd.forgetToCat).toPseudoFunctor' where - app x := (PGrpd.objFiber' hs x.as).obj - naturality {x y} g := strongTrans.naturality B s hs g.as - naturality_naturality := sorry - naturality_id := sorry - naturality_comp := sorry +@[simp] +lemma strongTrans.naturality_inv_app_base {x y} (f : x ⟶ y) (a) : + Hom.base ((strongTrans.naturality B s hs f).inv.app a) = eqToHom (by simp) := by + rw [strongTrans.naturality_inv_app, comp_base, base_eqToHom] + simp + +@[simp] +lemma strongTrans.naturality_inv_app_fiber {x y} (f : x ⟶ y) (a) : + ((strongTrans.naturality B s hs f).inv.app a).fiber = + eqToHom (by simp only [← Functor.comp_obj, naturality_inv_app_base, twoCell_app_base, + ← Grpd.comp_eq_comp]; rw! [← Functor.map_comp_assoc, IsIso.hom_inv_id, + CategoryTheory.Functor.map_id, Category.id_comp]) ≫ + Hom.fiber ((twoCell B s hs f).app ((A.map f).obj a)) := by + rw! [strongTrans.naturality_inv_app, comp_fiber, fiber_eqToHom, eqToHom_map] + simp + +@[simp] +lemma strongTrans.naturality_id_hom (x : Γ) : + (strongTrans.naturality B s hs (𝟙 x)).hom = eqToHom (by simp) := by + dsimp [strongTrans.naturality] + erw [conjugatingObjNatTransEquiv₁_id_inv] + simp [sigma_obj, sigma_map, eqToHom_trans, twoCell_id] + +lemma inv_heq_inv {C : Type*} [Category C] {X Y : C} {X' Y' : C} + (hX : X = X') (hY : Y = Y') {f : X ⟶ Y} {f' : X' ⟶ Y'} (hf : f ≍ f') [IsIso f] : + have : IsIso f' := by aesop + inv f ≍ inv f' := by + subst hX hY hf + rfl + +lemma strongTrans.naturality_comp_hom {x y z : Γ} (g1 : x ⟶ y) (g2 : y ⟶ z) : + (strongTrans.naturality B s hs (g1 ≫ g2)).hom = + eqToHom (by simp [Functor.assoc]) ≫ + Functor.whiskerLeft (A.map g1) (strongTrans.naturality B s hs g2).hom ≫ + eqToHom (by simp [Functor.assoc]) ≫ + Functor.whiskerRight (strongTrans.naturality B s hs g1).hom (sigmaMap B g2) ≫ + eqToHom (by simp [Functor.assoc, sigmaMap_comp]) := by + apply (conjugatingObjNatTransEquiv₁_comp_inv A (sigma A B) g1 g2 + (app B s hs x) (app B s hs y) (app B s hs z) + (twoCell B s hs g1) (twoCell B s hs g2) + (twoCell B s hs (g1 ≫ g2)) ?_).trans + · simp [naturality] + · apply (strongTrans.twoCell_comp ..).trans + rw [Functor.whiskerRight_whiskerLeft] + simp only [sigma, eqToHom_refl] + erw [Category.id_comp] + +lemma strongTrans.app_comp_fstNatTrans_app (x : Γ) : + strongTrans.app B s hs x ⋙ (sigma.fstNatTrans B).app x = 𝟭 ↑(A.obj x) := by + simpa [strongTrans.app] using (PGrpd.objFiber' hs x).obj.property + +lemma strongTrans.app_map_naturality_hom_app {x y : Γ} (f : x ⟶ y) (a : (A.obj x)) : + ((sigma.fstNatTrans B).app y).map (((strongTrans.naturality B s hs) f).hom.app a) = + eqToHom (Section.strongTrans_comp_toStrongTrans'_self_aux (sigma.fstNatTrans B) + (app B s hs) (app_comp_fstNatTrans_app B s hs) f a) := by + simp only [sigma_obj, sigma.fstNatTrans, Functor.comp_obj, Functor.Groupoidal.forget_obj, + sigmaMap_obj_base, naturality, sigma_map, conjugatingObjNatTransEquiv₁, Grpd.Functor.iso, + Grpd.functorIsoOfIso_inv, Functor.mapIso_inv, asIso_inv, Grpd.functorIsoOfIso_hom, + Functor.mapIso_hom, asIso_hom, conjugatingObjNatTransEquiv', Groupoid.isoEquivHom, + Groupoid.inv_eq_inv, Equiv.toFun_as_coe, Equiv.trans_apply, Equiv.coe_fn_mk, + Equiv.coe_fn_symm_mk, IsIso.inv_comp, Functor.inv_whiskerLeft, inv_eqToHom, Iso.symm_mk, + NatTrans.comp_app, Functor.whiskerLeft_app, NatIso.isIso_inv_app, eqToHom_app, forget_map] + rw [Functor.Groupoidal.comp_base, Functor.Groupoidal.base_eqToHom, + ← Functor.Groupoidal.inv_base] + have h := NatTrans.congr_app ((PGrpd.mapFiber' hs f)).2 ((A.map f).obj a) + simp only [Set.mem_setOf_eq, IsOverId, sigma.fstNatTrans] at h + simp only [sigma_obj, pi_obj_α, Functor.comp_obj, Functor.Groupoidal.forget_obj, + Functor.whiskerRight_app, forget_map, Category.id_comp, eqToHom_trans, eqToHom_app] at h + simp [twoCell, h] -@[simps!] def mapStrongTrans : ∫ A ⥤ ∫ sigma A B := - Functor.Grothendieck.toPseudoFunctor'Iso.hom _ ⋙ - Pseudofunctor.Grothendieck.map (strongTrans B s hs) ⋙ - Functor.Grothendieck.toPseudoFunctor'Iso.inv _ + Section.mapStrongTrans (strongTrans.app B s hs) (strongTrans.naturality B s hs) + (strongTrans.naturality_id_hom B s hs) (strongTrans.naturality_comp_hom B s hs) + +@[simp] +lemma mapStrongTrans_obj_base (x) : ((mapStrongTrans B s hs).obj x).base = x.base := + rfl + +-- NOTE: `mapStrongTrans_obj_fiber_base` and `mapStrongTrans_obj_fiber_fiber` preferred over this +lemma mapStrongTrans_obj_fiber (x) : ((mapStrongTrans B s hs).obj x).fiber = + (strongTrans.app B s hs x.base).obj x.fiber := + rfl + +@[simp] +lemma mapStrongTrans_obj_fiber_base (x) : ((mapStrongTrans B s hs).obj x).fiber.base = + x.fiber := by + simp [mapStrongTrans] + +@[simp] +lemma mapStrongTrans_obj_fiber_fiber (x) : ((mapStrongTrans B s hs).obj x).fiber.fiber = + ((strongTrans.app B s hs x.base).obj x.fiber).fiber := by + simp [mapStrongTrans] + +@[simp] +lemma mapStrongTrans_map_base {x y} (f : x ⟶ y) : ((mapStrongTrans B s hs).map f).base = + f.base := + rfl + +lemma mapStrongTrans_map_fiber {x y} (f : x ⟶ y) : ((mapStrongTrans B s hs).map f).fiber = + eqToHom (by simp [← Functor.comp_obj]; simp [← Grpd.comp_eq_comp, mapStrongTrans_obj_fiber]) ≫ + (strongTrans.twoCell B s hs f.base).app ((A.map f.base).obj x.fiber) ≫ + (strongTrans.app B s hs y.base).map f.fiber := by + simp [mapStrongTrans, strongTrans.naturality_inv_app] + +@[simp] +lemma mapStrongTrans_map_fiber_base {x y} (f : x ⟶ y) : + ((mapStrongTrans B s hs).map f).fiber.base = + eqToHom (by simp [mapStrongTrans_obj_fiber]) ≫ + f.fiber ≫ eqToHom (by simp [mapStrongTrans_obj_fiber]) := by + rw [mapStrongTrans_map_fiber, comp_base, comp_base, base_eqToHom, strongTrans.twoCell_app_base] + simp /-- Let `Γ` be a category. For any pair of functors `A : Γ ⥤ Grpd` and `B : ∫(A) ⥤ Grpd`, and any "term of pi", meaning a functor `f : Γ ⥤ PGrpd` satisfying `f ⋙ forgetToGrpd = pi A B : Γ ⥤ Grpd`, -there is a "term of `B`" `inversion : Γ ⥤ PGrpd` such that `inversion ⋙ forgetToGrpd = B`. --/ +there is a "term of `B`" `inversion : Γ ⥤ PGrpd` such that `inversion ⋙ forgetToGrpd = B`. -/ @[simps!] def inversion : ∫(A) ⥤ PGrpd := mapStrongTrans B s hs ⋙ (sigma.assoc B).inv ⋙ toPGrpd B -lemma mapStrongTrans_comp_fstAux' : mapStrongTrans B s hs ⋙ sigma.fstAux' B = 𝟭 _ := by - apply Functor.Groupoidal.FunctorTo.hext - · rw [Functor.assoc, sigma.fstAux', Functor.assoc, sigma.assoc_inv_comp_forget_comp_forget, - mapStrongTrans, Functor.assoc, - Functor.assoc, Functor.Groupoidal.forget, - Functor.Grothendieck.toPseudoFunctor'Iso.inv_comp_forget, - Pseudofunctor.Grothendieck.map_comp_forget, Functor.id_comp, - Functor.Grothendieck.toPseudoFunctor'Iso.hom_comp_forget, - Functor.Groupoidal.forget] - · intro x - simp only [sigma.fstAux', Functor.comp_obj, Functor.Groupoidal.forget_obj, - Functor.id_obj, heq_eq_eq] - apply (sigma.assoc_inv_obj_base_fiber B ((mapStrongTrans B s hs).obj x)).trans - simp only [mapStrongTrans_obj_base, mapStrongTrans_obj_fiber] - exact Functor.congr_obj (PGrpd.objFiber' hs x.base).property x.fiber - · sorry +@[simp] +lemma assocHom_app_base_base + {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) + {x y : Γ} (f : x ⟶ y) (a) : + ((sigma.assocHom B f).app a).base.base = f := by + simp [sigma.assocHom, sigma.assocIso, ιNatIso_hom] + +lemma assocHom_app_base_fiber + {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) + {x y : Γ} (f : x ⟶ y) (a) : + ((sigma.assocHom B f).app a).base.fiber = eqToHom (by + simp only [sigma.assocFib.eq_1, Functor.comp_obj, assocHom_app_base_base] + rw! (castMode := .all) [pre_obj_base B (ι A y) ((sigmaMap B f).obj a)] + rw! (castMode := .all) [pre_obj_base B (ι A x) a] + simp) := by + simp only [sigma.assocFib.eq_1, Functor.comp_obj, sigma.assocHom, + sigma.assocIso, eqToHom_refl] + rw! (castMode := .all) [preNatIso_hom_app_base, ιNatIso_hom] + simp + rfl +lemma mapStrongTrans_comp_map_fstNatTrans : + mapStrongTrans B s hs ⋙ map (sigma.fstNatTrans B) = 𝟭 _ := by + convert Section.mapStrongTrans_comp_map_self (sigma.fstNatTrans B) + (strongTrans.app B s hs) (strongTrans.naturality B s hs) + (strongTrans.naturality_id_hom B s hs) (strongTrans.naturality_comp_hom B s hs) _ _ + · apply strongTrans.app_comp_fstNatTrans_app + · intro x y f a + apply strongTrans.app_map_naturality_hom_app + +@[simp] lemma inversion_comp_forgetToGrpd : inversion B s hs ⋙ PGrpd.forgetToGrpd = B := by simp only [inversion, Functor.assoc, toPGrpd_forgetToGrpd] - conv => left; right; rw [← Functor.assoc, ← sigma.fstAux'] - simp [← Functor.assoc, mapStrongTrans_comp_fstAux'] + conv => left; right; rw [← Functor.assoc, ← sigma.map_fstNatTrans_eq] + simp [← Functor.assoc, mapStrongTrans_comp_map_fstNatTrans] + +-- NOTE: this is not as general as the `mapStrongTrans` simp lemmas +lemma mapStrongTrans_map_ι_map_fiber_fiber_heq {x : Γ} {a b : A.obj x} (h : a ⟶ b) : + ((mapStrongTrans B s hs).map ((ι A x).map h)).fiber.fiber ≍ + ((strongTrans.app B s hs x).map h).fiber := by + rw! [mapStrongTrans_map_fiber B s hs] + apply (fiber_eqToHom_comp_heq ..).trans + congr 1 + · simp + · conv => left; right; rw [ι_map_fiber, Functor.map_comp, eqToHom_map] + rw! (castMode := .all) [ι_obj_base] + simp only [mapStrongTrans_obj_base, ι_obj_base, ι_map_base, sigma_obj, ι_obj_fiber, + Functor.comp_obj, strongTrans.twoCell_id, eqToHom_app, eqToHom_trans_assoc] + apply HEq.trans (eqToHom_comp_heq ..) + rfl --- JH: make some API for this? Mixture of Pseudofunctor.Grothendieck --- and Functor.Grothendieck and Functor.Groupoidal is messy. lemma ι_comp_inversion {x} : ι A x ⋙ inversion B s hs = - (PGrpd.objFiber' hs x).obj ⋙ toPGrpd (ι A x ⋙ B) := by + strongTrans.app B s hs x ⋙ toPGrpd (ι A x ⋙ B) := by apply PGrpd.Functor.hext - · simp only [Functor.assoc, inversion_comp_forgetToGrpd, toPGrpd_forgetToGrpd] - rw [← Functor.assoc, (PGrpd.objFiber' hs x).property, Functor.id_comp] + · simp only [Functor.assoc, inversion_comp_forgetToGrpd] + erw [toPGrpd_forgetToGrpd, ← Functor.assoc, strongTrans.app_comp_fstNatTrans_app, + Functor.id_comp] · intro a - rfl -- This is probably bad practice - · intro a b h - simp - have h := sigma.assoc_inv_map_fiber B ((mapStrongTrans B s hs).map ((ι A x).map h)) - rw [← heq_eq_eq, heq_eqToHom_comp_iff] at h - apply h.trans + simp only [Functor.comp_obj, inversion_obj_base, inversion_obj_fiber, ι_obj_base, sigma_obj, + toPGrpd_obj_base, toPGrpd_obj_fiber, heq_eq_eq] + rw! (castMode := .all) [mapStrongTrans_obj_fiber] simp - sorry + · intro a b h + simp only [Functor.comp_obj, inversion_obj_base, Functor.comp_map, inversion_map_base, + inversion_obj_fiber, ι_obj_base, inversion_map_fiber, ι_map_base, sigma_obj, toPGrpd_obj_base, + toPGrpd_map_base, toPGrpd_obj_fiber, toPGrpd_map_fiber, eqToHom_comp_heq_iff] + apply mapStrongTrans_map_ι_map_fiber_fiber_heq end @@ -502,7 +928,7 @@ variable {Γ : Type u₂} [Groupoid.{v₂} Γ] (A : Γ ⥤ Grpd.{u₁,u₁}) (β section variable (x : Γ) -def lamObjFiberObj : Grpd.of (A.obj x ⥤ sigmaObj (β ⋙ PGrpd.forgetToGrpd) x) := +def lamObjFiberObj : A.obj x ⥤ sigmaObj (β ⋙ PGrpd.forgetToGrpd) x := sec (ι A x ⋙ β ⋙ PGrpd.forgetToGrpd) (ι A x ⋙ β) rfl @[simp] lemma lamObjFiberObj_obj_base (a) : ((lamObjFiberObj A β x).obj a).base = a := by @@ -520,14 +946,16 @@ def lamObjFiberObj : Grpd.of (A.obj x ⥤ sigmaObj (β ⋙ PGrpd.forgetToGrpd) x ((lamObjFiberObj A β x).map h).fiber = PGrpd.mapFiber (ι A x ⋙ β) h := by simp [lamObjFiberObj] -def lamObjFiber : piObj (β ⋙ PGrpd.forgetToGrpd) x := - ⟨lamObjFiberObj A β x , rfl⟩ +def lamObjFiber : Grpd.of ((pi _ (β ⋙ PGrpd.forgetToGrpd)).obj x) := + ⟨lamObjFiberObj A β x, rfl⟩ -@[simp] lemma lamObjFiber_obj : (lamObjFiber A β x).obj = lamObjFiberObj A β x := +@[simp] lemma lamObjFiber_obj_obj : (lamObjFiber A β x).obj.obj = lamObjFiberObj A β x := rfl -@[simp] lemma lamObjFiber_obj_obj : (lamObjFiber A β x).obj = lamObjFiberObj A β x := - rfl +lemma lamObjFiber_hext {A' : Γ ⥤ Grpd.{u₁,u₁}} (hA : A ≍ A') {β' : ∫ A' ⥤ PGrpd.{u₁,u₁}} + (hβ : β ≍ β') (x' : Γ) (hx : x ≍ x') : + lamObjFiber A β x ≍ lamObjFiber A' β' x' := by + aesop end @@ -627,22 +1055,6 @@ def lamObjFiberObjCompSigMap : ext a simp [lamObjFiberObjCompSigMap] -/- -lamObjFiberObj A β x ⋙ sigmaMap (β ⋙ PGrpd.forgetToGrpd) (f ≫ g) - -_ ⟶ lamObjFiberObj A β x ⋙ sigmaMap (β ⋙ PGrpd.forgetToGrpd) f ⋙ sigmaMap (β ⋙ PGrpd.forgetToGrpd) g -:= eqToHom ⋯ - -_ ⟶ A.map f ⋙ lamObjFiberObj A β y ⋙ sigmaMap (β ⋙ PGrpd.forgetToGrpd) g -:= whiskerRight (lamObjFiberObjCompSigMap A β f) (sigmaMap (β ⋙ PGrpd.forgetToGrpd) g) - -_ ⟶ A.map f ⋙ A.map g ⋙ lamObjFiberObj A β z -:= whiskerLeft (A.map f) (lamObjFiberObjCompSigMap A β g) - -_ ⟶ A.map (f ≫ g) ⋙ lamObjFiberObj A β z -:= eqToHom ⋯ - --/ lemma lamObjFiberObjCompSigMap_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : lamObjFiberObjCompSigMap A β (f ≫ g) = eqToHom (by rw [sigmaMap_comp]; rfl) @@ -711,18 +1123,35 @@ lemma whiskerLeftInvLamObjObjSigMap_comp {x y z} (f : x ⟶ y) (g : y ⟶ z) : def lamMapFiber : ((pi A (β ⋙ PGrpd.forgetToGrpd)).map f).obj (lamObjFiber A β x) ⟶ lamObjFiber A β y := - whiskerLeftInvLamObjObjSigMap A β f + ⟨whiskerLeftInvLamObjObjSigMap A β f, by + ext + simp only [sigma_obj, sigma.fstNatTrans_app, pi_obj_α, comp_obj, Groupoidal.forget_obj, + lamObjFiber_obj_obj, whiskerLeftInvLamObjObjSigMap, lamObjFiberObjCompSigMap, + whiskerRight_comp, eqToHom_whiskerRight, NatTrans.comp_app, whiskerRight_app, whiskerLeft_app, + forget_map, lamObjFiberObjCompSigMap.app_base, sigmaMap_obj_base, eqToHom_app, eqToHom_refl, + Category.comp_id] + erw [Category.id_comp]⟩ @[simp] lemma lamMapFiber_id (x : Γ) : lamMapFiber A β (𝟙 x) = eqToHom (by simp) := by - simp [lamMapFiber] + apply MorphismProperty.WideSubcategory.hom_ext + simp only [sigma_obj, sigma.fstNatTrans_app, pi_obj_α, Set.mem_setOf_eq, lamMapFiber, + whiskerLeftInvLamObjObjSigMap_id, MorphismProperty.WideSubcategory.coe_eqToHom] rfl lemma lamMapFiber_comp {x y z} (f : x ⟶ y) (g : y ⟶ z) : - lamMapFiber A β (f ≫ g) - = eqToHom (by rw [← Functor.comp_obj]; apply Functor.congr_obj; simp [piMap_comp]) - ≫ ((piMap A (β ⋙ PGrpd.forgetToGrpd)) g).map ((lamMapFiber A β) f) - ≫ lamMapFiber A β g := by - simp [lamMapFiber, piMap, whiskerLeftInvLamObjObjSigMap_comp] + (lamMapFiber A β (f ≫ g)) + = eqToHom (by + rw [← Functor.comp_obj] + apply Functor.congr_obj + rw [← Grpd.comp_eq_comp, Functor.map_comp]) + ≫ (((pi A (β ⋙ PGrpd.forgetToGrpd)).map g).map ((lamMapFiber A β) f)) + ≫ (lamMapFiber A β g) := by + apply MorphismProperty.WideSubcategory.hom_ext + simp only [sigma_obj, pi, Set.mem_setOf_eq, lamMapFiber, whiskerLeftInvLamObjObjSigMap_comp] + rw [MorphismProperty.WideSubcategory.comp_def, + MorphismProperty.WideSubcategory.comp_def, + MorphismProperty.WideSubcategory.coe_eqToHom] + simp rfl def lam : Γ ⥤ PGrpd.{u₁,u₁} := @@ -734,7 +1163,7 @@ def lam : Γ ⥤ PGrpd.{u₁,u₁} := (lamMapFiber_comp A β) @[simp] -lemma lam_obj_base (x) : ((lam A β).obj x).base = piObj (β ⋙ PGrpd.forgetToGrpd) x := rfl +lemma lam_obj_base (x) : ((lam A β).obj x).base = (pi _ (β ⋙ PGrpd.forgetToGrpd)).obj x := rfl @[simp] lemma lam_obj_fib (x) : ((lam A β).obj x).fiber = lamObjFiber A β x := @@ -742,7 +1171,7 @@ lemma lam_obj_fib (x) : ((lam A β).obj x).fiber = lamObjFiber A β x := @[simp] lemma lam_map_base {x y} (f : x ⟶ y) : ((lam A β).map f).base = - piMap A (β ⋙ PGrpd.forgetToGrpd) f := + (pi A (β ⋙ PGrpd.forgetToGrpd)).map f := rfl @[simp] @@ -754,7 +1183,7 @@ lemma lam_comp_forgetToGrpd : lam A β ⋙ PGrpd.forgetToGrpd = pi A (β ⋙ PGr variable {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) -lemma lam_naturality_aux (x) : +lemma lam_comp_aux (x) : ι A (σ.obj x) ⋙ β ⋙ PGrpd.forgetToGrpd = ι (σ ⋙ A) x ⋙ pre A σ ⋙ β ⋙ PGrpd.forgetToGrpd := by simp [← Functor.assoc, ← ι_comp_pre] @@ -763,19 +1192,22 @@ lemma lamObjFiberObj_naturality (x) : simp only [lamObjFiberObj, ← ι_comp_pre, comp_obj, Functor.assoc] congr! -lemma lam_naturality_obj_aux (x) : - Grpd.of (A.obj (σ.obj x) ⥤ sigmaObj (β ⋙ PGrpd.forgetToGrpd) (σ.obj x)) ≍ - Grpd.of (A.obj (σ.obj x) ⥤ sigmaObj ((pre A σ ⋙ β) ⋙ PGrpd.forgetToGrpd) x) := by - rw [sigmaObj_naturality, Functor.assoc] - -theorem lam_naturality_obj (x : Δ) : HEq (lamObjFiber A β (σ.obj x)) - (lamObjFiber (σ ⋙ A) (pre A σ ⋙ β) x) := by - simp only [lamObjFiber] - apply Grpd.ObjectProperty.FullSubcategory.hext (lam_naturality_obj_aux A β σ x) - · simp only [sigma.fstAuxObj, Functor.assoc] - congr! - any_goals simp [lam_naturality_aux] - · apply lamObjFiberObj_naturality +lemma naturality_forget_heq_forget (x) : + @Groupoidal.forget (A.obj (σ.obj x)) _ (ι A (σ.obj x) ⋙ β ⋙ PGrpd.forgetToGrpd) ≍ + @Groupoidal.forget (A.obj (σ.obj x)) _ (ι (σ ⋙ A) x ⋙ (pre A σ ⋙ β) ⋙ PGrpd.forgetToGrpd) := by + congr 1 -- NOTE: this could maybe be avoided by making an hext lemma for Grothendieck.forget + rw [← Functor.assoc, ← ι_comp_pre] + simp [Functor.assoc] + +theorem lamObjFiber_naturality (x : Δ) : lamObjFiber A β (σ.obj x) ≍ + lamObjFiber (σ ⋙ A) (pre A σ ⋙ β) x := by + apply Section.obj_hext + · simp [sigmaObj_naturality, Functor.assoc] + · simp + · simp only [sigma_obj, sigma.fstNatTrans_app, comp_obj] + apply naturality_forget_heq_forget + · simp only [sigma_obj, sigma.fstNatTrans_app, lamObjFiber_obj_obj, comp_obj] + apply lamObjFiberObj_naturality lemma lamObjFiberObjCompSigMap.app_naturality {x y} (f : x ⟶ y) (a) : lamObjFiberObjCompSigMap.app A β (σ.map f) a ≍ @@ -785,7 +1217,7 @@ lemma lamObjFiberObjCompSigMap.app_naturality {x y} (f : x ⟶ y) (a) : any_goals apply Grpd.comp_hcongr any_goals simp only [comp_obj, Functor.comp_map, heq_eq_eq] any_goals apply sigmaObj_naturality - any_goals apply lam_naturality_aux + any_goals apply lam_comp_aux any_goals apply sigmaMap_naturality_heq any_goals apply lamObjFiberObj_naturality any_goals simp [app]; rfl @@ -816,26 +1248,135 @@ lemma whiskerLeftInvLamObjObjSigMap_naturality_heq {x y} (f : x ⟶ y) : · apply sigmaMap_naturality_heq · apply lamObjFiberObjCompSigMap_naturality -lemma lam_naturality_map {x y} (f : x ⟶ y) : +lemma lam_comp_map {x y} (f : x ⟶ y) : lamMapFiber A β (σ.map f) ≍ lamMapFiber (σ ⋙ A) (pre A σ ⋙ β) f := by - apply whiskerLeftInvLamObjObjSigMap_naturality_heq - -theorem lam_naturality : σ ⋙ lam A β = lam (σ ⋙ A) (pre A σ ⋙ β) := by + apply Section.hom_hext + · simp [Functor.assoc, sigmaObj_naturality] + · simp + · simp [Functor.assoc] + apply naturality_forget_heq_forget + · simp only [sigma_obj, sigma.fstNatTrans_app, pi_obj_α, comp_obj, Functor.assoc] + rw [Functor.congr_obj (Functor.congr_hom (pi_comp A (β ⋙ PGrpd.forgetToGrpd) σ) f)] + simp only [pi_obj_α, comp_obj, Functor.comp_map, Grpd.comp_eq_comp, Grpd.eqToHom_obj, + heq_cast_iff_heq, heq_eq_eq] + congr 1 + simp only [← heq_eq_eq, heq_cast_iff_heq] + apply lamObjFiber_naturality + · apply lamObjFiber_naturality + · apply whiskerLeftInvLamObjObjSigMap_naturality_heq + +theorem lam_comp : σ ⋙ lam A β = lam (σ ⋙ A) (pre A σ ⋙ β) := by apply PGrpd.Functor.hext - · apply pi_naturality - · apply lam_naturality_obj - · apply lam_naturality_map + · simp [Functor.assoc, lam_comp_forgetToGrpd, pi_comp] + · apply lamObjFiber_naturality + · apply lam_comp_map + +@[simp] +lemma strongTrans.app_lam_obj_base (x : Γ) (a) : + ((strongTrans.app (β ⋙ PGrpd.forgetToGrpd) (lam A β) + (lam_comp_forgetToGrpd ..) x).obj a).base = a := by + simp + +@[simp] +lemma strongTrans.app_lam_obj_fiber (x) : ((strongTrans.app (β ⋙ PGrpd.forgetToGrpd) (lam A β) + (lam_comp_forgetToGrpd ..) x.base).obj x.fiber).fiber = (β.obj x).fiber := + rfl + +@[simp] +lemma strongTrans.app_lam_map_base {x y : ∫ A} (f : x ⟶ y) : + ((strongTrans.app (β ⋙ PGrpd.forgetToGrpd) (lam A β) + (lam_comp_forgetToGrpd ..) y.base).map f.fiber).base = + f.fiber := + rfl + +@[simp] +lemma strongTrans.app_lam_map_fiber {x y : ∫ A} (f : x ⟶ y) : + ((strongTrans.app (β ⋙ PGrpd.forgetToGrpd) (lam A β) + (lam_comp_forgetToGrpd ..) y.base).map f.fiber).fiber = + PGrpd.mapFiber (ι A y.base ⋙ β) (Hom.fiber f) := by + simp [lam, app, PGrpd.objFiber] + +lemma strongTrans.twoCell_lam_app {x y : ∫ A} (f : x ⟶ y) : + ((strongTrans.twoCell (β ⋙ PGrpd.forgetToGrpd) (lam A β) (lam_comp_forgetToGrpd ..) + (Hom.base f)).app ((A.map (Hom.base f)).obj x.fiber)) = + homMk (eqToHom (by + simp only [Functor.map_inv, sigma_obj, comp_obj, sigmaMap_obj_base, app_obj_base] + simp [← Functor.comp_obj, ← Grpd.comp_eq_comp])) + (eqToHom (by + simp only [comp_obj, Functor.Grothendieck.forget_obj, sigma_obj, sigmaMap_obj_base, + Functor.comp_map, eqToHom_map, Functor.Grothendieck.forget_map, + Functor.Grothendieck.base_eqToHom, sigmaMap_obj_fiber, Grpd.eqToHom_obj, ← heq_eq_eq, + cast_heq_iff_heq] + simp only [← Functor.comp_obj, ← Grpd.comp_eq_comp] + rw! [← Functor.map_comp, IsIso.hom_inv_id, CategoryTheory.Functor.map_id, Category.id_comp] + rfl) ≫ + (β.map ((ιNatTrans (Hom.base f)).app x.fiber)).fiber) := by + simp only [sigma_obj, lam, comp_obj, twoCell, sigma.fstNatTrans_app, pi_obj_α, + PGrpd.objFiber'_rfl, Set.mem_setOf_eq, PGrpd.mapFiber'_rfl, sigmaMap_obj_base, + Functor.Grothendieck.forget_obj, Functor.comp_map, Functor.Grothendieck.forget_map, + sigmaMap_obj_fiber] + convert_to (whiskerLeftInvLamObjObjSigMap A β f.base).app ((A.map f.base).obj x.fiber) = _ + simp only [comp_obj, whiskerLeftInvLamObjObjSigMap, lamObjFiberObjCompSigMap, NatTrans.comp_app, + whiskerLeft_app, lamObjFiberObjCompSigMap.app, sigmaMap_obj_base, + Functor.Grothendieck.forget_obj, Functor.comp_map, Functor.Grothendieck.forget_map, + sigmaMap_obj_fiber, eqToHom_app] + have h : (A.map (CategoryTheory.inv (Hom.base f))).obj ((A.map (Hom.base f)).obj x.fiber) = + x.fiber := by simp [← Functor.comp_obj, ← Grpd.comp_eq_comp] + rw! [h] + simp only [eqToHom_refl, Category.comp_id, ← heq_eq_eq] + congr 1 + +lemma strongTrans.twoCell_lam_app_fiber {x y : ∫ A} (f : x ⟶ y) : + ((strongTrans.twoCell (β ⋙ PGrpd.forgetToGrpd) (lam A β) (lam_comp_forgetToGrpd ..) + (Hom.base f)).app ((A.map (Hom.base f)).obj x.fiber)).fiber = + eqToHom (by + simp only [comp_obj, sigma_obj, sigmaMap_obj_base, Functor.Grothendieck.forget_obj, + twoCell_app_base, Functor.comp_map, eqToHom_map, Functor.Grothendieck.forget_map, + Functor.Grothendieck.base_eqToHom, sigmaMap_obj_fiber] + simp only [← Functor.comp_obj, ← Grpd.comp_eq_comp] + rw! [← Functor.map_comp, IsIso.hom_inv_id, CategoryTheory.Functor.map_id, Category.id_comp] + rfl + ) ≫ (β.map ((ιNatTrans (Hom.base f)).app x.fiber)).fiber := by + rw! [twoCell_lam_app] + simp + +lemma mapStrongTrans_map_lam_map_fiber_fiber_heq {x y} (f : x ⟶ y) : + ((mapStrongTrans (β ⋙ PGrpd.forgetToGrpd) (lam A β) + (lam_comp_forgetToGrpd ..)).map f).fiber.fiber ≍ + (β.map f).fiber := by + rw [mapStrongTrans_map_fiber] + apply (fiber_eqToHom_comp_heq ..).trans + rw [comp_fiber] + rw [strongTrans.twoCell_lam_app_fiber] + slice_lhs 2 3 => rw [Functor.map_comp, eqToHom_map] + rw [strongTrans.app_lam_map_fiber] + simp only [mapStrongTrans_obj_base, comp_obj, Functor.Grothendieck.forget_obj, sigma_obj, + sigmaMap_obj_base, Functor.comp_map, Functor.Grothendieck.forget_map, sigmaMap_obj_fiber, + comp_base, strongTrans.app_lam_map_base, Category.assoc, eqToHom_trans_assoc, + eqToHom_comp_heq_iff] + simp [← Functor.comp_map, PGrpd.mapFiber] + have : f = eqToHom (by apply Functor.Groupoidal.ext <;> simp) ≫ + (ιNatTrans (Hom.base f)).app x.fiber ≫ (ι A y.base).map f.fiber ≫ + eqToHom (by apply Functor.Groupoidal.ext <;> simp) := by + fapply Functor.Groupoidal.Hom.ext + · simp + · simp + have := Functor.congr_map β this + simp [Functor.Grothendieck.Hom.congr this] + rw! [Category.comp_id, CategoryTheory.Functor.map_id] + simp only [Grothendieck.Hom.id_base, Grpd.id_eq_id, id_obj, eqToHom_refl, Functor.id_map, + Category.id_comp, heq_eq_eq] + erw [Category.comp_id] lemma inversion_lam : inversion (β ⋙ PGrpd.forgetToGrpd) (lam A β) (lam_comp_forgetToGrpd ..) = β := by apply PGrpd.Functor.hext · simp [inversion_comp_forgetToGrpd] · intro x - simp [inversion] - sorry + simp [mapStrongTrans_obj_fiber] · intro x y f simp [inversion] - sorry + apply mapStrongTrans_map_lam_map_fiber_fiber_heq end @@ -843,32 +1384,119 @@ section variable (B : ∫ A ⥤ Grpd) (s : Γ ⥤ PGrpd) (hs : s ⋙ PGrpd.forgetToGrpd = pi A B) -lemma lamObjFiberObj_inversion_heq (x) : - lamObjFiberObj A (pi.inversion B s hs) x ≍ (PGrpd.objFiber' hs x).obj := by - dsimp only [lamObjFiberObj] - rw! [pi.inversion_comp_forgetToGrpd B s hs] - simp only [sec_eq_lift, Grpd.forgetToCat.eq_1, heq_eq_eq] +lemma lamObjFiber_obj_obj_inversion_heq (x) : + (lamObjFiber A (inversion B s hs) x).obj.obj ≍ strongTrans.app B s hs x := by + dsimp only [lamObjFiber, lamObjFiberObj] + rw! (castMode := .all) [pi.inversion_comp_forgetToGrpd B s hs] + simp [sec_eq_lift, Grpd.forgetToCat.eq_1, heq_eq_eq] symm apply Functor.IsPullback.lift_uniq · symm apply pi.ι_comp_inversion - · exact (PGrpd.objFiber' hs x).property + · exact (PGrpd.objFiber' hs x).obj.property lemma lamObjFiber_inversion_heq' (x) : lamObjFiber A (pi.inversion B s hs) x ≍ PGrpd.objFiber' hs x := by - dsimp [pi_obj] - apply piObj.hext + apply pi.obj_hext · rfl · simp [pi.inversion_comp_forgetToGrpd] - · apply lamObjFiberObj_inversion_heq + · apply lamObjFiber_obj_obj_inversion_heq lemma lamObjFiber_inversion_heq (x) : - lamObjFiber A (pi.inversion B s hs) x ≍ PGrpd.objFiber s x := - HEq.trans (lamObjFiber_inversion_heq' A B s hs x) (PGrpd.objFiber'_heq hs) + lamObjFiber A (pi.inversion B s hs) x ≍ PGrpd.objFiber s x := by + refine HEq.trans ?_ (PGrpd.objFiber'_heq hs) + apply lamObjFiber_inversion_heq' + +lemma strongTrans.twoCell_app_inversion {x y} (f : x ⟶ y) (a) : + (strongTrans.twoCell B s hs f).app ((A.map f).obj ((A.map (CategoryTheory.inv f)).obj a)) = + eqToHom (by simp only [← Functor.comp_obj]; simp [← Grpd.comp_eq_comp]) ≫ + (strongTrans.twoCell B s hs f).app a ≫ + eqToHom (by simp only [← Functor.comp_obj]; simp [← Grpd.comp_eq_comp]) := by + simp only [twoCell] + have h : ((A.map f).obj ((A.map (CategoryTheory.inv f)).obj a)) = a := by + simp [← Functor.comp_obj, ← Grpd.comp_eq_comp] + apply (NatTrans.congr _ h).trans + simp + +lemma mapStrongTrans_obj_inversion_fiber {x y} (f : x ⟶ y) (a) : + ((mapStrongTrans B s hs).obj ((A.map f ⋙ ι A y).obj ((A.map (CategoryTheory.inv f)).obj a))).fiber = + (strongTrans.app B s hs y).obj a := by + simp only [Functor.comp_obj, mapStrongTrans_obj_base, ι_obj_base, sigma_obj, + mapStrongTrans_obj_fiber, ι_obj_fiber, Functor.map_inv] + simp [← Functor.comp_obj, ← Grpd.comp_eq_comp] + +lemma mapStrongTrans_map_inversion_fiber {x y} (f : x ⟶ y) (a) : + ((mapStrongTrans B s hs).map ((ιNatTrans f).app ((A.map (CategoryTheory.inv f)).obj a))).fiber = + (strongTrans.twoCell B s hs f).app a ≫ + eqToHom (mapStrongTrans_obj_inversion_fiber A B s hs f a).symm := by + have h : (ιNatTrans f).app ((A.map (CategoryTheory.inv f)).obj a) = + homMk f (𝟙 _) := by + fapply Functor.Groupoidal.Hom.ext + · simp + · simp; rfl + rw! (castMode := .all) [h] + simp [mapStrongTrans_map_fiber B s hs, strongTrans.twoCell_app_inversion] + +lemma lamObjFiberObjCompSigMap_app_inversion {x y} (f : x ⟶ y) (a) : + lamObjFiberObjCompSigMap.app A (inversion B s hs) f ((A.map (CategoryTheory.inv f)).obj a) ≍ + (strongTrans.twoCell B s hs f).app a := by + have h := mapStrongTrans_map_inversion_fiber A B s hs f a + simp [← heq_eq_eq] at h + apply HEq.trans _ h + fapply Functor.Groupoidal.Hom.hext' + · simp + · simp only [Functor.map_inv, Functor.comp_obj, mapStrongTrans_obj_base, ι_obj_base, sigma_obj, + mapStrongTrans_map_base, Functor.Groupoidal.ιNatTrans_app_base, sigma_map] + apply Grpd.Functor.hcongr_obj + · rw [inversion_comp_forgetToGrpd] + · rw [inversion_comp_forgetToGrpd] + · rw [inversion_comp_forgetToGrpd] + · rw [Functor.map_inv] + simp only [mapStrongTrans_obj_fiber, ι_obj_base, sigma_obj, ι_obj_fiber] + apply Grpd.Functor.hcongr_obj rfl _ _ HEq.rfl + · simp [inversion_comp_forgetToGrpd] + · apply lamObjFiber_obj_obj_inversion_heq + · simp only [Functor.map_inv, Functor.comp_obj, mapStrongTrans_obj_base, ι_obj_base, + mapStrongTrans_obj_fiber, sigma_obj, ι_obj_fiber] + apply Grpd.Functor.hcongr_obj + · rfl + · simp + · apply lamObjFiber_obj_obj_inversion_heq + · simp + · rw [mapStrongTrans_map_fiber_base] + simp + rfl + · apply (lamObjFiberObjCompSigMap.app_fiber_heq ..).trans + simp [inversion] + +lemma whiskerLeftInvLamObjObjSigMap_inversion_app {x y} (f : x ⟶ y) (a) : + (whiskerLeftInvLamObjObjSigMap A (inversion B s hs) f).app a ≍ + (strongTrans.twoCell B s hs f).app a := by + simp [whiskerLeftInvLamObjObjSigMap, lamObjFiberObjCompSigMap] + have h := Functor.congr_obj (((pi A B).map f).obj (PGrpd.objFiber' hs x)).obj.property a + simp only [sigma_obj, sigma.fstNatTrans_app, pi_obj_α, Functor.comp_obj, + Functor.Groupoidal.forget_obj, Functor.id_obj] at h + exact (comp_eqToHom_heq ..).trans (lamObjFiberObjCompSigMap_app_inversion ..) lemma lamMapFiber_inversion_heq {x y} (f : x ⟶ y) : - lamMapFiber A (pi.inversion B s hs) f ≍ PGrpd.mapFiber s f := - sorry + lamMapFiber A (pi.inversion B s hs) f ≍ PGrpd.mapFiber s f := by + refine HEq.trans ?_ (PGrpd.mapFiber'_heq hs f) + apply Section.hom_hext' + · rw [inversion_comp_forgetToGrpd] + · rfl + · rw [inversion_comp_forgetToGrpd] + · rw! (castMode := .all) [inversion_comp_forgetToGrpd] + congr 1 + rw! [lamObjFiber_inversion_heq, PGrpd.objFiber'_heq] + simp only [pi_obj_α, Functor.Grothendieck.forget_obj, Grpd.coe_of, ← heq_eq_eq, + heq_cast_iff_heq, eqRec_heq_iff_heq, cast_heq_iff_heq] + rfl + · apply lamObjFiber_inversion_heq' + · intro a a' ha + subst ha + simp only [sigma_obj, sigma.fstNatTrans_app, pi_obj_α, Set.mem_setOf_eq, + lamMapFiber] + exact whiskerLeftInvLamObjObjSigMap_inversion_app A B s hs f a lemma lam_inversion : lam A (inversion B s hs) = s := by apply PGrpd.Functor.hext -- TODO: rename to PGrpd.ToFunctor.hext @@ -876,10 +1504,96 @@ lemma lam_inversion : lam A (inversion B s hs) = s := by · apply lamObjFiber_inversion_heq · apply lamMapFiber_inversion_heq +lemma inversion_comp {Δ : Type u} [Groupoid.{v} Δ] {σ : Δ ⥤ Γ} : + inversion (A := σ ⋙ A) (pre _ σ ⋙ B) (σ ⋙ s) (by rw [Functor.assoc, hs, ← pi_comp]) = + pre _ σ ⋙ inversion B s hs := by + rw [← inversion_lam (σ ⋙ A) (pre A σ ⋙ inversion B s hs)] + congr 1 + · simp [Functor.assoc] + · rw [← lam_comp, lam_inversion] + end end +namespace Over + +variable {Γ : Type u} {Δ : Type u} [Groupoid.{v} Γ] [Groupoid.{v} Δ] {σ : Δ ⥤ Γ} + {A : Γ ⥤ Grpd.{u₁,u₁}} (B : ∫ A ⥤ Grpd.{u₁,u₁}) + +/-- lifts of `σ : Δ ⥤ Γ` along `forget : ∫ pi A B ⥤ Γ` +biject (since the Grothendieck construction is a pullback) with +lifts of `pi (σ ⋙ A) (pre A σ ⋙ B) : Δ ⥤ Grpd` along `forgetToGrpd : PGrpd ⥤ Grpd` +biject (via `lam` and `inversion`) with +lifts of `pre A σ ⋙ B : ∫ σ ⋙ A ⥤ Grpd` along `forgetToGrpd : PGrpd ⥤ Grpd` +biject (since the Grothendieck construction is a pullback) with +lifts of `pre A σ : ∫ σ ⋙ A ⥤ ∫ A` along `forget : ∫ B ⥤ ∫ A`. + +The function `equivFun` is the forward direction in this bijection. +The function `equivInv` is the inverse direction in this bijection. +-/ +def equivFun (F : Δ ⥤ ∫ pi A B) (hF : F ⋙ forget = σ) : ∫ σ ⋙ A ⥤ ∫ B := + (isPullback B).lift (inversion (pre A σ ⋙ B) (F ⋙ toPGrpd _) (by + rw [Functor.assoc, toPGrpd_forgetToGrpd, ← Functor.assoc, hF, pi_comp])) + (pre A σ) (inversion_comp_forgetToGrpd ..) + +lemma equivFun_comp_forget (F : Δ ⥤ ∫ pi A B) (hF : F ⋙ forget = σ) : + equivFun B F hF ⋙ forget = pre A σ := by + simp [equivFun, Functor.IsPullback.fac_right] + +@[inherit_doc equivFun] +def equivInv (G : ∫ σ ⋙ A ⥤ ∫ B) (hG : G ⋙ forget = pre A σ) : Δ ⥤ ∫ pi A B := + (isPullback (pi A B)).lift (lam (σ ⋙ A) (G ⋙ toPGrpd _)) σ (by + rw [lam_comp_forgetToGrpd, ← pi_comp, Functor.assoc, + toPGrpd_forgetToGrpd, ← Functor.assoc, hG]) + +lemma equivInv_comp_forget (G : ∫ σ ⋙ A ⥤ ∫ B) (hG : G ⋙ forget = pre A σ) : + equivInv B G hG ⋙ forget = σ := by + simp [equivInv, Functor.IsPullback.fac_right] + +lemma equivInv_equivFun (F : Δ ⥤ ∫ pi A B) (hF : F ⋙ forget = σ) : + equivInv B (equivFun B F hF) (equivFun_comp_forget B F hF) = F := by + simp only [equivFun, equivInv] + apply (isPullback _).hom_ext + · rw [Functor.IsPullback.fac_left, Functor.IsPullback.fac_left, lam_inversion] + · rw! [Functor.IsPullback.fac_right, hF] + +lemma equivFun_equivInv (G : ∫ σ ⋙ A ⥤ ∫ B) (hG : G ⋙ forget = pre A σ) : + equivFun B (equivInv B G hG) (equivInv_comp_forget B G hG) = G := by + simp only [equivFun, equivInv] + apply (isPullback B).hom_ext + · have : pre A σ ⋙ B = (G ⋙ toPGrpd B) ⋙ PGrpd.forgetToGrpd := by + rw [Functor.assoc, toPGrpd_forgetToGrpd, ← Functor.assoc, hG] + rw! [Functor.IsPullback.fac_left, Functor.IsPullback.fac_left, this, inversion_lam] + · rw [Functor.IsPullback.fac_right, hG] + +lemma equivFun_comp {Δ' : Type u} [Groupoid.{v} Δ'] {σ' : Δ' ⥤ Γ} (τ : Δ' ⥤ Δ) (hτ : τ ⋙ σ = σ') + (F : Δ ⥤ ∫ pi A B) (hF : F ⋙ forget = σ) : + equivFun B (τ ⋙ F) (by rw [Functor.assoc, hF, hτ]) = + map (eqToHom (by aesop_cat)) ⋙ pre _ τ ⋙ equivFun B F hF := by + cases hτ + simp only [equivFun, pre_comp, eqToHom_refl, map_id_eq, Cat.of_α, Functor.id_comp] + symm + apply (isPullback B).lift_uniq + · simp only [Functor.assoc, Functor.IsPullback.fac_left] + rw [inversion_comp] + · simp [Functor.assoc, Functor.IsPullback.fac_right] + +lemma equivInv_comp {Δ' : Type u} [Groupoid.{v} Δ'] {σ' : Δ' ⥤ Γ} (τ : Δ' ⥤ Δ) (hτ : τ ⋙ σ = σ') + (G : ∫ σ ⋙ A ⥤ ∫ B) (hG : G ⋙ forget = pre A σ) : + equivInv B (map (eqToHom (Functor.assoc ..)) ⋙ pre _ τ ⋙ G) + (by simp [map_id_eq, Functor.assoc, hG]) = + τ ⋙ equivInv B G hG := by + cases hτ + simp [map_id_eq, equivInv] + symm + apply (isPullback (pi A B)).lift_uniq + · simp only [Functor.assoc, Functor.IsPullback.fac_left] + rw [lam_comp] + · simp [Functor.assoc, Functor.IsPullback.fac_right] + +end Over + end pi end FunctorOperation @@ -899,7 +1613,7 @@ Also known as Beck-Chevalley. -/ lemma Pi_comp {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) (B : U.ext A ⟶ U.{v}.Ty) : Pi (U.substWk σ A σA eq ≫ B) = σ ≫ Pi B := - USig.SigAux_comp pi (by intros; rw [pi_naturality]) σ eq B + USig.SigAux_comp pi (by intros; rw [← pi_comp]) σ eq B def lam {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (b : U.ext A ⟶ U.{v}.Tm) : Γ ⟶ U.{v}.Tm := USig.SigAux pi.lam b @@ -907,7 +1621,7 @@ def lam {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (b : U.ext A ⟶ U.{v}.Tm) : Γ ⟶ U.{ lemma lam_comp {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) (b : U.ext A ⟶ U.{v}.Tm) : lam (U.substWk σ A σA eq ≫ b) = σ ≫ lam b := - USig.SigAux_comp pi.lam (by intros; rw [pi.lam_naturality]) σ eq b + USig.SigAux_comp pi.lam (by intros; rw [pi.lam_comp]) σ eq b lemma lam_tp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) (b : U.ext A ⟶ U.{v}.Tm) (b_tp : b ≫ U.tp = B) : UPi.lam b ≫ U.tp = Pi B := by diff --git a/HoTTLean/Groupoids/Sigma.lean b/HoTTLean/Groupoids/Sigma.lean index 390506b7..a8ee5c47 100644 --- a/HoTTLean/Groupoids/Sigma.lean +++ b/HoTTLean/Groupoids/Sigma.lean @@ -224,6 +224,21 @@ def assocIso {x y : Γ} (f : x ⟶ y) : assocFib B x ≅ sigmaMap B f ⋙ assocFib B y := preNatIso B (ιNatIso A f) +@[simp] +lemma assocIso_hom_app_base_base {x y} (f : x ⟶ y) (p) : + ((assocIso B f).hom.app p).base.base = f := + rfl + +@[simp] +lemma assocIso_hom_app_base_fiber {x y} (f : x ⟶ y) (p) : + ((assocIso B f).hom.app p).base.fiber = 𝟙 _ := + rfl + +@[simp] +lemma assocIso_hom_app_fiber {x y} (f : x ⟶ y) (p) : + ((assocIso B f).hom.app p).fiber = 𝟙 _ := + rfl + @[simp] theorem assocIso_id {x} : assocIso B (𝟙 x) = eqToIso (by simp [sigmaMap_id, Functor.id_comp]) := by simp [assocIso, preNatIso_congr B (ιNatIso_id A x), preNatIso_eqToIso] @@ -236,7 +251,7 @@ theorem assocIso_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : assocIso B (f isoWhiskerLeft_eqToIso, eqToIso_trans, Functor.isoWhiskerLeft_trans, Iso.trans_assoc] rfl -def assocHom {x y : Γ} (f : x ⟶ y) : +abbrev assocHom {x y : Γ} (f : x ⟶ y) : assocFib B x ⟶ sigmaMap B f ⋙ assocFib B y := (assocIso B f).hom @@ -249,17 +264,6 @@ theorem assocHom_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : eqToHom (by simp [sigmaMap_comp, Functor.assoc]) := by simp [assocHom, assocIso_comp] --- deprecated in favor of `assoc` -def assoc' : ∫(sigma A B) ⥤ ∫(B) := - functorFrom (assocFib B) (assocHom B) (by simp) (by simp [assocHom_comp]) - --- lemma assoc_pre {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : --- assoc (pre A σ ⋙ B) ⋙ pre B (pre A σ) = --- (map (eqToHom (sigma_naturality ..).symm) ⋙ pre (sigma A B) σ) ⋙ assoc B := by --- dsimp [assoc] --- rw [functorFrom_comp] --- sorry - section variable {B} @@ -271,7 +275,7 @@ def assocFibObj (x : ∫ B) : sigmaObj B x.base.base := @[simp] theorem assocFibObj_base (x : ∫ B) : (assocFibObj x).base = x.base.fiber := rfl -theorem assocFibMapAux {x y : ∫ B} (f : x ⟶ y) : +theorem assocFibMap_aux {x y : ∫ B} (f : x ⟶ y) : ((ι A y.base.base ⋙ B).map (Hom.fiber (Hom.base f))).obj (fiber ((sigmaMap B (Hom.base (Hom.base f))).obj (assocFibObj x))) = (B.map (Hom.base f)).obj x.fiber := by @@ -283,14 +287,14 @@ theorem assocFibMapAux {x y : ∫ B} (f : x ⟶ y) : def assocFibMap {x y : ∫ B} (f : x ⟶ y) : (sigmaMap B (Hom.base (Hom.base f))).obj (assocFibObj x) ⟶ assocFibObj y := - homMk f.base.fiber (eqToHom (assocFibMapAux ..) ≫ f.fiber) + homMk f.base.fiber (eqToHom (assocFibMap_aux ..) ≫ f.fiber) @[simp↓] theorem assocFibMap_base {x y : ∫ B} (f : x ⟶ y) : (assocFibMap f).base = f.base.fiber := rfl @[simp↓] theorem assocFibMap_fiber {x y : ∫ B} (f : x ⟶ y) : - (assocFibMap f).fiber = eqToHom (assocFibMapAux ..) ≫ f.fiber := by + (assocFibMap f).fiber = eqToHom (assocFibMap_aux ..) ≫ f.fiber := by rfl lemma assocFibMap_id (x : ∫ B) : assocFibMap (𝟙 x) = eqToHom (by simp) := by @@ -406,7 +410,6 @@ lemma assocFibMap_assocHom_app {c c' : Γ} (f : c ⟶ c') (x : sigmaObj B c) : end -@[simps!] def assoc : ∫ B ≅≅ ∫ sigma A B := .symm <| functorIsoFrom (assocFib B) (assocHom B) (by simp) (by simp [assocHom_comp]) (forget ⋙ forget) assocFibObj assocFibMap assocFibMap_id assocFibMap_comp @@ -420,7 +423,7 @@ lemma assoc_hom : (assoc B).hom = Functor.Groupoidal.functorTo (forget ⋙ forge rfl lemma assoc_hom_comp_forget : (assoc B).hom ⋙ forget = forget ⋙ forget := by - simp [assoc_hom] + simp only [assoc_hom] erw [Functor.Groupoidal.functorTo_forget] lemma assoc_inv_comp_forget_comp_forget : (assoc B).inv ⋙ forget ⋙ forget @@ -430,6 +433,77 @@ lemma assoc_inv_comp_forget_comp_forget : (assoc B).inv ⋙ forget ⋙ forget rw [assoc_hom_comp_forget] _ = _ := by simp +@[simp] +lemma assoc_hom_obj_base (x) : ((assoc B).hom.obj x).base = x.base.base := + rfl + +@[simp] +lemma assoc_hom_obj_fiber_base (x) : ((assoc B).hom.obj x).fiber.base = x.base.fiber := + rfl + +@[simp] +lemma assoc_hom_obj_fiber_fiber (x) : ((assoc B).hom.obj x).fiber.fiber = x.fiber := + rfl + +@[simp] +lemma assoc_hom_map_base {x y} (f : x ⟶ y) : ((assoc B).hom.map f).base = f.base.base := + rfl + +@[simp] +lemma assoc_hom_map_fiber_base {x y} (f : x ⟶ y) : ((assoc B).hom.map f).fiber.base = + f.base.fiber := + rfl + +@[simp] +lemma assoc_hom_map_fiber_fiber {x y} (f : x ⟶ y) : ((assoc B).hom.map f).fiber.fiber = + eqToHom (by + simp [assoc_hom] + rw [← Functor.comp_obj, ← Grpd.comp_eq_comp, ← Functor.map_comp] + congr 2 + fapply Hom.ext <;> simp) ≫ f.fiber := + rfl + +@[simp] +lemma assoc_inv_obj_base_base (x) : ((assoc B).inv.obj x).base.base = x.base := + rfl + +@[simp] +lemma assoc_inv_obj_base_fiber (x) : ((assoc B).inv.obj x).base.fiber = x.fiber.base := + rfl + +@[simp] +lemma assoc_inv_obj_fiber (x) : ((assoc B).inv.obj x).fiber = x.fiber.fiber := + rfl + +@[simp] +lemma assoc_inv_map_base_base {x y} (f : x ⟶ y) : ((assoc B).inv.map f).base.base = f.base := by + simp only [assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, assocFib, + functorIsoFrom_hom_map, sigma_map, comp_base, pre_map_base, assocIso_hom_app_base_base, + ι_map_base, ι_obj_base] + erw [Category.comp_id] + rfl + +@[simp] +lemma assoc_inv_map_base_fiber {x y} (f : x ⟶ y) : ((assoc B).inv.map f).base.fiber = + eqToHom (by simp) ≫ f.fiber.base := by + simp only [assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, assocFib, + functorIsoFrom_hom_map, sigma_map, comp_base, assocIso_hom_app_base_base, + Functor.Groupoidal.comp_fiber, assocIso_hom_app_base_fiber, Functor.comp_obj, + CategoryTheory.Functor.map_id, Category.id_comp] + rw! [pre_map_base, ι_map_fiber] + simp + rfl + +@[simp] +lemma assoc_inv_map_fiber {x y} (f : x ⟶ y) : ((assoc B).inv.map f).fiber = + eqToHom (by + simp only [assoc_inv_obj_fiber, sigma_map, + Functor.comp_map, sigmaMap_obj_fiber] + conv => rhs; rw [← Functor.comp_obj, ← Grpd.comp_eq_comp, ← Functor.map_comp] + rfl) ≫ f.fiber.fiber := by + simp [assoc] + rfl + lemma assocFibMap_pre_pre_map {Δ : Type u₃} [Groupoid.{v₃} Δ] {σ : Δ ⥤ Γ} {x y} (f : x ⟶ y) : assocFibMap ((pre B (pre A σ)).map f) ≍ assocFibMap f := by have pre_pre_obj_base_base (x) : ((pre B (pre A σ)).obj x).base.base = σ.obj x.base.base := by @@ -459,7 +533,7 @@ lemma assocFibMap_pre_pre_map {Δ : Type u₃} [Groupoid.{v₃} Δ] {σ : Δ ⥤ rfl · simp -lemma assoc_comp_fiber {Δ : Type u₃} [Groupoid.{v₃} Δ] {σ : Δ ⥤ Γ} {x y} (f : x ⟶ y) : +lemma assoc_comp_fiber {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) {x y} (f : x ⟶ y) : Hom.fiber (((assoc (pre A σ ⋙ B)).hom ⋙ map (eqToHom (sigma_naturality ..).symm) ⋙ pre (sigma A B) σ).map f) ≍ Hom.fiber ((pre B (pre A σ) ⋙ (assoc B).hom).map f) := by simp only [assoc_hom, Functor.comp_obj, sigma_obj, Functor.comp_map, sigma_map, pre_map_fiber, @@ -475,9 +549,9 @@ lemma assoc_comp {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : (sigma.assoc ((pre A σ) ⋙ B)).hom ⋙ map (eqToHom (by simp [sigma_naturality])) ⋙ pre (sigma A B) σ = pre B (pre A σ) ⋙ (sigma.assoc B).hom := by - simp only [assoc_hom] apply FunctorTo.hext - · simp only [Functor.assoc, pre_comp_forget] + · simp only [assoc_hom] + simp only [Functor.assoc, pre_comp_forget] conv => left; right; rw [← Functor.assoc, map_forget] rw [← Functor.assoc _ forget σ] conv => left; left; apply Functor.Groupoidal.functorTo_forget @@ -485,16 +559,20 @@ lemma assoc_comp {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : conv => right; rw [← Functor.assoc, pre_comp_forget] simp only [Functor.assoc, pre_comp_forget] · intro x - simp only [assoc_hom, Functor.comp_obj, sigma_obj, pre_obj_fiber, map_obj_fiber, - Functor.Groupoidal.functorTo_obj_base, Functor.Groupoidal.forget_obj, eqToHom_app, - Functor.Groupoidal.functorTo_obj_fiber, assocFibObj, heq_eq_eq] - rw! (castMode := .all) [pre_obj_base B] - simp only [Grpd.eqToHom_obj, ← heq_eq_eq, cast_heq_iff_heq] - congr 1 - rw! (castMode := .all) [pre_obj_base A] - rw [← Functor.assoc, ι_comp_pre] + simp only [Functor.comp_obj, sigma_obj, pre_obj_fiber, map_obj_fiber, assoc_hom_obj_base, + eqToHom_app, heq_eq_eq] + rw [eqToHom_eq_homOf_map] + apply Functor.Groupoidal.hext + · simp only [Functor.comp_obj, map_obj_base] + rw! (castMode := .all) [assoc_hom_obj_fiber_base, assoc_hom_obj_fiber_base, pre_obj_base] + simp + · simp [- heq_eq_eq] + rw [eqToHom_app, Grpd.eqToHom_obj] + simp + rw! (castMode := .all) [assoc_hom_obj_fiber_fiber, assoc_hom_obj_fiber_fiber, pre_obj_fiber] + · rw [← Functor.assoc, ι_comp_pre A σ x.base.base] · intro x y f - apply assoc_comp_fiber + apply assoc_comp_fiber B σ f lemma assoc_comp' {Δ : Type u₃} [Groupoid.{v₃} Δ] {σ : Δ ⥤ Γ} (Aσ) (eq : Aσ = σ ⋙ A) : (sigma.assoc ((map (eqToHom eq) ⋙ pre A σ) ⋙ B)).hom ⋙ @@ -506,18 +584,50 @@ lemma assoc_comp' {Δ : Type u₃} [Groupoid.{v₃} Δ] {σ : Δ ⥤ Γ} (Aσ) ( section -def fstAux' : ∫(sigma A B) ⥤ ∫(A) := - (assoc B).inv ⋙ forget +-- def fstAux' : ∫(sigma A B) ⥤ ∫(A) := + -- (assoc B).inv ⋙ forget -/-- `fst` projects out the pointed groupoid `(A,a)` appearing in `(A,B,a : A,b : B a)` -/ -def fst : ∫(sigma A B) ⥤ PGrpd := - fstAux' B ⋙ toPGrpd A +-- /-- `fst` projects out the pointed groupoid `(A,a)` appearing in `(A,B,a : A,b : B a)` -/ +-- def fst : ∫(sigma A B) ⥤ PGrpd := +-- fstAux' B ⋙ toPGrpd A + +-- theorem fst_forgetToGrpd : fst B ⋙ PGrpd.forgetToGrpd = forget ⋙ A := by +-- dsimp only [fst, fstAux'] +-- rw [Functor.assoc, (Functor.Groupoidal.isPullback A).comm_sq, +-- ← Functor.assoc] +-- conv => left; left; rw [Functor.assoc, assoc_inv_comp_forget_comp_forget] + +def fstNatTrans : sigma A B ⟶ A where + app x := forget + naturality x y f:= by simp [sigmaMap_forget] + +@[simp] +lemma fstNatTrans_app (x) : (fstNatTrans B).app x = Functor.Groupoidal.forget := + rfl -theorem fst_forgetToGrpd : fst B ⋙ PGrpd.forgetToGrpd = forget ⋙ A := by - dsimp only [fst, fstAux'] - rw [Functor.assoc, (Functor.Groupoidal.isPullback A).comm_sq, - ← Functor.assoc] - conv => left; left; rw [Functor.assoc, assoc_inv_comp_forget_comp_forget] +lemma map_fstNatTrans_eq : map (fstNatTrans B) = (assoc B).inv ⋙ forget := by + apply Functor.Groupoidal.FunctorTo.hext + · simp [Functor.assoc, assoc_inv_comp_forget_comp_forget, map_forget] + · intro x + simp only [fstNatTrans, map_obj_fiber, sigma_obj, Functor.Groupoidal.forget_obj, assoc, + Functor.Iso.symm_inv, Functor.comp_obj, functorIsoFrom_hom_obj, assocFib, heq_eq_eq] + rw! (castMode := .all) [pre_obj_base] + simp + rfl + · intro x y f + simp only [fstNatTrans, map_map_fiber, sigma_obj, Grpd.comp_eq_comp, Functor.comp_obj, + Functor.Groupoidal.forget_obj, sigma_map, sigmaMap_obj_base, eqToHom_refl, forget_map, + Category.id_comp, assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, assocFib, + Functor.comp_map, functorIsoFrom_hom_map, comp_base, Functor.Groupoidal.comp_fiber, + heq_eqToHom_comp_iff] + rw! [pre_map_base] + simp only [ι_map_base, ι_obj_base, assocHom, assocFib, assocIso, ι_map_fiber, ι_obj_fiber] + rw [preNatIso_hom_app_base, ιNatIso_hom, ιNatTrans_app_base] + simp only [Functor.comp_obj, Pi.id_apply, homMk_base, homMk_fiber] + erw [CategoryTheory.Functor.map_id (A.map (𝟙 y.base))] + erw [Category.id_comp] + simp + rfl end end diff --git a/HoTTLean/Groupoids/SplitIsofibration.lean b/HoTTLean/Groupoids/SplitIsofibration.lean new file mode 100644 index 00000000..bdc418a2 --- /dev/null +++ b/HoTTLean/Groupoids/SplitIsofibration.lean @@ -0,0 +1,304 @@ +import HoTTLean.ForMathlib.CategoryTheory.ClovenIsofibration +import HoTTLean.Groupoids.Pi +import HoTTLean.ForMathlib.CategoryTheory.MorphismProperty.Limits +import HoTTLean.ForMathlib.CategoryTheory.MorphismProperty.OverAdjunction + +universe w v u v₁ u₁ v₂ u₂ v₃ u₃ + +noncomputable section + +namespace CategoryTheory + +open Functor.Groupoidal + +namespace Grpd + +def SplitIsofibration : MorphismProperty Grpd := + fun _ _ F => ∃ I : F.ClovenIsofibration, I.IsSplit + +namespace SplitIsofibration + +variable {B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) + +def splitIsofibration : F.ClovenIsofibration := hF.choose + +instance : (splitIsofibration hF).IsSplit := hF.choose_spec + +/-- The Grothendieck construction on the classifier is isomorphic to `E`, +now as objects in `Grpd`. -/ +def grothendieckClassifierIso : Grpd.of (∫ hF.splitIsofibration.classifier) ≅ B := + Grpd.mkIso (Functor.ClovenIsofibration.grothendieckClassifierIso ..) + +/-lemma ι_classifier_comp_forget {x} : ι I.classifier x ⋙ Groupoidal.forget = + Fiber.fiberInclusion ⋙ F + -/ +lemma grothendieckClassifierIso_inv_comp_forget : + hF.grothendieckClassifierIso.inv ⋙ homOf Functor.Groupoidal.forget = F := by + apply Functor.ClovenIsofibration.grothendieckClassifierIso.inv_comp_forget + + +end SplitIsofibration + +instance : SplitIsofibration.IsStableUnderBaseChange.{u,u} where + of_isPullback pb hG := + ⟨ Functor.ClovenIsofibration.ofIsPullback _ _ _ _ + (Grpd.functorIsPullback pb) hG.splitIsofibration, inferInstance ⟩ + +instance : SplitIsofibration.IsMultiplicative where + id_mem _ := ⟨ Functor.ClovenIsofibration.id _, inferInstance ⟩ + comp_mem _ _ hF hG := ⟨ Functor.ClovenIsofibration.comp + hF.splitIsofibration hG.splitIsofibration, inferInstance ⟩ + +instance : SplitIsofibration.RespectsIso := + MorphismProperty.respectsIso_of_isStableUnderComposition (fun X Y F hF => + ⟨ Functor.ClovenIsofibration.iso { + hom := F + inv := have : IsIso F := hF; CategoryTheory.inv F + hom_inv_id := by simp [← Grpd.comp_eq_comp] + inv_hom_id := by simp [← Grpd.comp_eq_comp] }, + inferInstance⟩) + +lemma IsTerminal.SplitIsofibration {X Y : Grpd.{v,v}} (F : X ⟶ Y) (t : Limits.IsTerminal Y) : + SplitIsofibration F := by + let i := t.uniqueUpToIso chosenTerminalIsTerminal + convert_to Grpd.SplitIsofibration ((F ≫ i.hom) ≫ i.inv) + · simp only [Category.assoc, Iso.hom_inv_id, Category.comp_id] + apply MorphismProperty.RespectsIso.postcomp + exact ⟨_, Functor.ClovenIsofibration.toDiscretePUnit.IsSplit ..⟩ + +instance : SplitIsofibration.HasObjects.{v, v} where + obj_mem := Grpd.IsTerminal.SplitIsofibration + +section + +open Functor.ClovenIsofibration + +/-- The object part (a groupoid) of the pushforward along `F`, of `G`, +defined as the Grothendieck construction applied to (unstructured) Pi-type construction +in the HoTTLean groupoid model. -/ +def pushforwardLeft {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} + (hG : SplitIsofibration G) : Grpd := + Grpd.of <| Functor.ClovenIsofibration.pushforward hF.splitIsofibration hG.splitIsofibration + +/-- The morphism part (a functor) of the pushforward along `F`, of `G`. +This is defined as the forgetful functor from the Grothendieck construction. -/ +def pushforwardHom {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} + (hG : SplitIsofibration G) : pushforwardLeft hF hG ⟶ A := + Grpd.homOf Functor.Groupoidal.forget + +/-- The pushforward along `F`, of `G`, as an object in the over category. -/ +abbrev pushforward {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} + (hG : SplitIsofibration G) : Over A := + Over.mk (pushforwardHom hF hG) + +lemma pushforward.hom {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} + (hG : SplitIsofibration G) : (pushforward hF hG).hom = pushforwardHom .. := + rfl + +open Limits in +lemma pullback_isPullback {B A} {F : B ⟶ A} (hF : SplitIsofibration F) (σ : Over A) : + IsPullback (pullback.snd σ.hom F ≫ hF.grothendieckClassifierIso.inv) (pullback.fst σ.hom F) + (homOf Functor.Groupoidal.forget) (homOf σ.hom) := + IsPullback.of_iso (IsPullback.of_hasPullback σ.hom F).flip (Iso.refl _) + (hF.grothendieckClassifierIso ..).symm (Iso.refl _) (Iso.refl _) (by simp) (by simp) + (by simpa using hF.grothendieckClassifierIso_inv_comp_forget.symm ) + (by simp) + +lemma pre_classifier_isPullback {B A} {F : B ⟶ A} (hF : SplitIsofibration F) (σ : Over A) : + IsPullback (homOf (pre hF.splitIsofibration.classifier σ.hom)) + (homOf Functor.Groupoidal.forget) + (homOf Functor.Groupoidal.forget) (homOf σ.hom) := by + have outer_pb := Functor.Groupoidal.isPullback (σ.hom ⋙ hF.splitIsofibration.classifier) + have right_pb := Functor.Groupoidal.isPullback (hF.splitIsofibration.classifier) + have left_pb := Functor.IsPullback.Paste.ofRight' outer_pb.comm_sq outer_pb right_pb.comm_sq + right_pb (pre _ _) (by + apply right_pb.hom_ext + · simp [Functor.IsPullback.fac_left] + · simp [Functor.IsPullback.fac_right, pre_comp_forget]) + exact Grpd.isPullback left_pb + +/-- +∫(σ ⋙ classifier) --> ∫ classifier ≅ B + | | + | | forget ≅ F + | | + V V + Δ -------------> A + σ +The two versions of the pullback are isomorphic. +-/ +def grothendieckIsoPullback {B A} {F : B ⟶ A} (hF : SplitIsofibration F) (σ : Over A) : + Grpd.of (∫ σ.hom ⋙ hF.splitIsofibration.classifier) ≅ Limits.pullback σ.hom F := + (pre_classifier_isPullback hF σ).isoIsPullback _ _ (pullback_isPullback hF σ) + +lemma grothendieckIsoPullback_inv_comp_forget {B A} {F : B ⟶ A} (hF : SplitIsofibration F) + (σ : Over A) : (grothendieckIsoPullback hF σ).inv ⋙ Functor.Groupoidal.forget = + Limits.pullback.fst σ.hom F := by + exact (pre_classifier_isPullback hF σ).isoIsPullback_inv_snd _ _ + (pullback_isPullback hF σ) + +lemma grothendiecIsoPullback_comp_hom_comp_fst {B A} {F : B ⟶ A} (hF : SplitIsofibration F) + (σ : Over A) : (grothendieckIsoPullback hF σ).hom ⋙ Limits.pullback.fst σ.hom F = + Functor.Groupoidal.forget := by + have := (pre_classifier_isPullback hF σ).isoIsPullback_hom_snd _ _ + (pullback_isPullback hF σ) + simp only [Functor.id_obj, Grpd.homOf, ← CategoryTheory.Iso.eq_inv_comp] at this + rw[this,← Grpd.comp_eq_comp,← Category.assoc] + simp[grothendieckIsoPullback] + +lemma grothendiecIsoPullback_comp_hom_comp_snd {B A} {F : B ⟶ A} (hF : SplitIsofibration F) + (σ : Over A) : (grothendieckIsoPullback hF σ).hom ⋙ Limits.pullback.snd σ.hom F = + pre hF.splitIsofibration.classifier σ.hom ⋙ hF.grothendieckClassifierIso.hom := by + have := (pre_classifier_isPullback hF σ).isoIsPullback_hom_fst _ _ + (pullback_isPullback hF σ) + simp only [Functor.id_obj, Grpd.homOf, ← Category.assoc, Iso.comp_inv_eq] at this + assumption + +open GroupoidModel.FunctorOperation.pi Functor in +/-- The universal property of the pushforward, expressed as a (natural) bijection of hom sets. -/ +--@[simps!] +def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} + (hG : SplitIsofibration G) (σ : Over A) : + (σ ⟶ pushforward hF hG) ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := + calc (σ ⟶ pushforward hF hG) + _ ≃ {M : σ.left ⥤ hF.splitIsofibration.pushforward hG.splitIsofibration // + M ⋙ Functor.Groupoidal.forget = σ.hom} := + { toFun M := ⟨M.left, M.w⟩ + invFun M := Over.homMk M.1 M.2 } + _ ≃ {N : ∫ σ.hom ⋙ hF.splitIsofibration.classifier ⥤ C // + N ⋙ G = pre hF.splitIsofibration.classifier σ.hom ⋙ + hF.splitIsofibration.grothendieckClassifierIso.hom} := + pushforward.homEquiv .. + _ ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := + { toFun N := Over.homMk ((grothendieckIsoPullback hF σ).inv ≫ N.1) (by + simp only [Over.pullback_obj_left, Functor.const_obj_obj, Over.mk_left, Functor.id_obj, + grothendieckIsoPullback, comp_eq_comp, coe_of, Over.mk_hom, Functor.assoc, N.2, + Over.pullback_obj_hom] + rw [← Grpd.comp_eq_comp,Iso.inv_comp_eq] + apply (Grpd.grothendiecIsoPullback_comp_hom_comp_snd ..).symm + ) + invFun N := ⟨(grothendieckIsoPullback hF σ).hom ⋙ N.left, by + have e := N.w + simp only [Over.pullback_obj_left, Functor.id_obj, Functor.const_obj_obj, Over.mk_left, + Functor.id_map, Over.mk_hom, comp_eq_comp, Over.pullback_obj_hom, + CostructuredArrow.right_eq_id, Discrete.functor_map_id, id_eq_id, simpCompId] at e + simp only [Functor.id_obj, Functor.const_obj_obj, Functor.assoc, e] + rw [Grpd.grothendiecIsoPullback_comp_hom_comp_snd] + rfl ⟩ + left_inv := by + intro a + simp only [Functor.id_obj, Functor.const_obj_obj, Over.pullback_obj_left, Over.mk_left, + comp_eq_comp, coe_of, Over.homMk_left, ← Functor.assoc] + rw! [← comp_eq_comp] + simp [Iso.hom_inv_id] + right_inv := by + intro a + simp only [Over.pullback_obj_left, Functor.id_obj, Functor.const_obj_obj, Over.mk_left, + comp_eq_comp, coe_of, ← Functor.assoc] + rw! [← comp_eq_comp] -- I do not need this, it attacks the outmost ⋙ first, maybe can use conv to get rid of + rw! [← comp_eq_comp] + simp [Iso.inv_hom_id] } + +lemma pushforwardHomEquiv_left {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} + (hG : SplitIsofibration G) + {X : Over A} (g : X ⟶ pushforward hF hG) : + ((pushforwardHomEquiv hF hG X) g).left = + (grothendieckIsoPullback hF X).inv ⋙ + GroupoidModel.FunctorOperation.pi.Over.equivFun + (pushforward.strictifyClovenIsofibration + hF.splitIsofibration hG.splitIsofibration).classifier g.left + (by have e:= g.w; simp[pushforward,pushforwardHom] at e; assumption) ⋙ + (pushforward.strictifyClovenIsofibration hF.splitIsofibration + hG.splitIsofibration).grothendieckClassifierIso.hom := by + simp only [Over.pullback_obj_left, Over.mk_left, pushforwardHomEquiv, Trans.trans, Functor.id_obj, + Functor.const_obj_obj, comp_eq_comp, coe_of, Equiv.trans_apply, Equiv.coe_fn_mk, + Over.homMk_left,pushforward.homEquiv_apply_coe] + +lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} + (hG : SplitIsofibration G) + {X X' : Over A} (f : X ⟶ X') (g : X' ⟶ pushforward hF hG) : + (pushforwardHomEquiv hF hG X) (f ≫ g) = + (Over.pullback F).map f ≫ (pushforwardHomEquiv hF hG X') g := by + ext + simp only [Over.pullback_obj_left, Over.mk_left, pushforwardHomEquiv_left, Functor.id_obj, + Functor.const_obj_obj, coe_of, Over.comp_left, comp_eq_comp, ← Functor.assoc, + Over.pullback_map_left] + congr 1 + have e1 : f.left ⋙ X'.hom = X.hom := f.w + have e2 : g.left ⋙ Functor.Groupoidal.forget = X'.hom := by + let e0 := g.w + simp[pushforwardHom] at e0 + assumption + rw! [GroupoidModel.FunctorOperation.pi.Over.equivFun_comp + (τ := f.left) (F := g.left) (σ := X'.hom) _ e1 e2] + simp only [Functor.const_obj_obj, Functor.id_obj, ← Functor.assoc] + congr 1 + conv => rhs ; simp[← Grpd.comp_eq_comp]; rw[← Grpd.comp_eq_comp] + simp only [← comp_eq_comp, Functor.const_obj_obj] + rw [CategoryTheory.Iso.eq_comp_inv (α := grothendieckIsoPullback hF X')] + ext + · simp only [Functor.id_obj, Functor.const_obj_obj, coe_of, Functor.assoc, comp_eq_comp, + Limits.limit.lift_π, Limits.PullbackCone.mk_pt, Limits.PullbackCone.mk_π_app] + rw [Grpd.grothendiecIsoPullback_comp_hom_comp_fst] + simp only [← Functor.assoc, Functor.id_obj, Functor.const_obj_obj, pre_comp_forget] + congr + simp only [Functor.assoc, map_forget] + rw [grothendieckIsoPullback_inv_comp_forget] + · simp only [Functor.id_obj, Functor.const_obj_obj, coe_of, Functor.assoc, comp_eq_comp, + Limits.limit.lift_π, Limits.PullbackCone.mk_pt, Limits.PullbackCone.mk_π_app] + rw [Grpd.grothendiecIsoPullback_comp_hom_comp_snd] + conv => lhs; rhs; rhs; rw [← Functor.assoc]; lhs; rw [← pre_comp] + rw [← Grpd.comp_eq_comp,CategoryTheory.Iso.inv_comp_eq (α := grothendieckIsoPullback hF X), + Grpd.comp_eq_comp,Grpd.grothendiecIsoPullback_comp_hom_comp_snd] + simp only [Functor.id_obj, Functor.const_obj_obj, ← Functor.assoc] + congr 1 + simp only [← eqToHom_eq_homOf_map, ← heq_eq_eq] + rw! [← e1] + simp + +def pushforward_isPushforward {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} + (hG : SplitIsofibration G) : IsPushforward F (Over.mk G) (pushforward hF hG) where + homEquiv := pushforwardHomEquiv .. + homEquiv_comp f g := pushforwardHomEquiv_comp hF hG f g + +instance : SplitIsofibration.HasPushforwards SplitIsofibration where + hasPushforwardsAlong _ hF:= { + hasPushforward _ hG := { + has_representation := ⟨pushforward hF hG, ⟨pushforward_isPushforward hF hG⟩⟩ }} + +def isoPushforwardOfIsPushforward {B A} {F : B ⟶ A} (hF : SplitIsofibration F) + (G: Over B) (hG : SplitIsofibration G.hom) (G': Over A) + (h: IsPushforward F G G') : G' ≅ pushforward hF hG := + CategoryTheory.Functor.RepresentableBy.uniqueUpToIso + (F := (Over.pullback F).op ⋙ yoneda.obj G) + (by simp[IsPushforward] at h; assumption) + ({ homEquiv := pushforwardHomEquiv .. + homEquiv_comp f g := by apply pushforwardHomEquiv_comp .. }) + +theorem splitIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) + {G : C ⟶ B} (hG : SplitIsofibration G) : + SplitIsofibration (pushforwardHom hF hG) := + ⟨ Functor.ClovenIsofibration.forget _ , + CategoryTheory.Functor.ClovenIsofibration.instIsSplitGroupoidalForget ⟩ + +-- FIXME. For some reason needed in the proof +-- `SplitIsofibration.IsStableUnderPushforward SplitIsofibration` +instance SplitIsofibration.RespectsIso : SplitIsofibration.RespectsIso := inferInstance + +/-- +1. any pushforward is isomorphic to a chosen pushforward + This is proven in general for pushforwards, + and holds even more generally for partial right adjoint objects: + `(F.op ⋙ yoneda.obj X).IsRepresentable` and + `(F.op ⋙ yoneda.obj Y).IsRepresentable` implies `X ≅ Y`. +2. SplitIsofibrations are stable under isomorphism +3. The chosen pushforward is an splitIsofibration `splitIsofibration_pushforward`. + This is because under the hood, it is a Grothendieck construction. -/ +instance : SplitIsofibration.IsStableUnderPushforward SplitIsofibration where + of_isPushforward F hF G hG P h := by + have p : (Over.mk P) ≅ Grpd.pushforward hF hG := + isoPushforwardOfIsPushforward hF (Over.mk G) hG (Over.mk P) h + convert_to SplitIsofibration ((p.hom).left ≫ pushforwardHom hF hG) + · simpa using (Over.w p.hom).symm + apply (SplitIsofibration.RespectsIso).precomp + apply splitIsofibration_pushforward diff --git a/HoTTLean/Groupoids/UnstructuredModel.lean b/HoTTLean/Groupoids/UnstructuredModel.lean index 39b3520c..c081abf9 100644 --- a/HoTTLean/Groupoids/UnstructuredModel.lean +++ b/HoTTLean/Groupoids/UnstructuredModel.lean @@ -1,7 +1,7 @@ import Mathlib.CategoryTheory.Limits.Preserves.FunctorCategory import Mathlib.CategoryTheory.Category.Cat.Limit -import HoTTLean.Model.Unstructured.UnstructuredUniverse +import HoTTLean.Model.Unstructured.UHom import HoTTLean.Grothendieck.Groupoidal.IsPullback import HoTTLean.Groupoids.IsPullback @@ -98,7 +98,7 @@ namespace U theorem substWk_eq (A : Γ ⟶ U.Ty.{v}) (σA : Δ ⟶ U.Ty.{v}) (eq) : U.substWk σ A σA eq = - map (eqToHom (by subst eq; rfl)) ⋙ pre (toCoreAsSmallEquiv A) σ := by + Grpd.homOf (map (eqToHom (by subst eq; rfl))) ≫ pre (toCoreAsSmallEquiv A) σ := by apply (U.disp_pullback A).hom_ext · rw [substWk_var] simp [var, Grpd.comp_eq_comp] diff --git a/HoTTLean/Model/Structured/Structured1.lean b/HoTTLean/Model/Structured/Structured1.lean new file mode 100644 index 00000000..1c1976a6 --- /dev/null +++ b/HoTTLean/Model/Structured/Structured1.lean @@ -0,0 +1,215 @@ +import Mathlib.CategoryTheory.Limits.Shapes.KernelPair +import HoTTLean.ForMathlib +import HoTTLean.ForMathlib.Tactic.CategoryTheory.FunctorMap +import HoTTLean.ForMathlib.CategoryTheory.RepPullbackCone +import HoTTLean.ForMathlib.CategoryTheory.WeakPullback +import HoTTLean.ForMathlib.CategoryTheory.Polynomial +import HoTTLean.Model.Unstructured.UnstructuredUniverse +import Mathlib.CategoryTheory.Limits.Shapes.BinaryProducts +universe v u + +noncomputable section + +open CategoryTheory Limits Opposite Model.UnstructuredUniverse + +namespace Model + +namespace IdCommon +variable {Ctx : Type u} [Category Ctx] {U0 U1: Model.UnstructuredUniverse Ctx} +{Γ: Ctx} {A: Γ ⟶ U0.Ty} (a: Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) + +def motiveCtx (IdTy: U0.ext A ⟶ U1.Ty) : Ctx := U1.ext IdTy + +def motiveSubst (IdTy: U0.ext A ⟶ U1.Ty) {Δ} (σ : Δ ⟶ Γ) : + motiveCtx (substWk U0 σ A ≫ IdTy) ⟶ motiveCtx IdTy := by + refine substWk _ (substWk _ σ _ _ (by simp)) _ _ ?_ + simp + +def reflSubst (IdTy: U0.ext A ⟶ U1.Ty) (reflTm: Γ ⟶ U1.Tm) + (reflTmTy: reflTm ≫ U1.tp = sec U0 A a (by simp[a_tp]) ≫ IdTy): + Γ ⟶ motiveCtx IdTy := + U1.substCons (sec U0 A a (by simp[a_tp])) IdTy reflTm + (by simp[reflTmTy]) + +@[reassoc (attr := simp)] +lemma reflSubst_comp_motiveSubst + (IdTy: U0.ext A ⟶ U1.Ty) (reflTm: Γ ⟶ U1.Tm) + (reflTmTy: reflTm ≫ U1.tp = sec U0 A a (by simp[a_tp]) ≫ IdTy) + {Δ} (σ : Δ ⟶ Γ) : + reflSubst (A:= σ ≫ A) (σ ≫ a) (by simp[a_tp]) (substWk U0 σ A ≫ IdTy) (σ ≫ reflTm) + (by simp[← comp_sec_assoc _ a_tp, reflTmTy]) ≫ + motiveSubst IdTy σ = + σ ≫ reflSubst a a_tp IdTy reflTm reflTmTy := by + apply (disp_pullback ..).hom_ext <;> simp[reflSubst,motiveSubst, + ← comp_sec _ a_tp ] + +end IdCommon + +namespace UnstructuredId +variable {Ctx : Type u} [Category Ctx] {U0 U1: Model.UnstructuredUniverse Ctx} +{Γ: Ctx} {A: Γ ⟶ U0.Ty} (a: Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) +(i : PolymorphicIdIntro U0 U1) + +def motiveCtx : Ctx := IdCommon.motiveCtx (i.weakenId a a_tp) + +def motiveSubst {Δ} (σ : Δ ⟶ Γ) : + motiveCtx (A:= σ ≫ A) (σ ≫ a) (by simp[a_tp,Category.assoc]) i ⟶ motiveCtx a a_tp i := by + convert + IdCommon.motiveSubst (i.weakenId a a_tp) σ + simp[motiveCtx]; + congr 1 + simp[← i.Id_comp] + + +def reflSubst : Γ ⟶ motiveCtx a a_tp i:= + IdCommon.reflSubst a a_tp (i.weakenId a a_tp) (i.refl a a_tp) + (by simp[← i.Id_comp]) + +--abbrev IdTy := (i.weakenId a a_tp) + +@[reassoc (attr := simp)] +lemma reflSubst_comp_motiveSubst {Δ} (σ : Δ ⟶ Γ) : + reflSubst (A:= σ ≫ A) (σ ≫ a) (by simp[a_tp]) i ≫ motiveSubst a a_tp i σ = + σ ≫ reflSubst (A:= A) a a_tp i := by + simp[reflSubst,motiveSubst] + have e := + IdCommon.reflSubst_comp_motiveSubst a a_tp (i.weakenId a a_tp) (i.refl a a_tp) + (by simp[← i.Id_comp]) σ + convert e <;> simp[←i.Id_comp,←i.refl_comp,a_tp,motiveCtx] + + +structure PolymorphicIdElim (U2 : UnstructuredUniverse Ctx) where + (j : ∀ {Γ} {A : Γ ⟶ U0.Ty} (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) + (C : motiveCtx a a_tp i ⟶ U2.Ty) (c : Γ ⟶ U2.Tm), + (c ≫ U2.tp = (reflSubst a a_tp i) ≫ C) → (motiveCtx a a_tp i ⟶ U2.Tm)) + (comp_j : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} (a : Γ ⟶ U0.Tm) + (a_tp : a ≫ U0.tp = A) (C : motiveCtx a a_tp i ⟶ U2.Ty) (c : Γ ⟶ U2.Tm) + (c_tp : c ≫ U2.tp = (reflSubst a a_tp i) ≫ C), + j (σ ≫ a) (by cat_disch) (motiveSubst a a_tp i σ ≫ C) (σ ≫ c) + (by simp[c_tp]) = + motiveSubst a a_tp i σ ≫ j a a_tp C c c_tp) + (j_tp : ∀ {Γ} {A : Γ ⟶ U0.Ty} (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) + (C : motiveCtx a a_tp i ⟶ U2.Ty) (c : Γ ⟶ U2.Tm) + (c_tp : c ≫ U2.tp = (reflSubst a a_tp i) ≫ C), + j a a_tp C c c_tp ≫ U2.tp = C) + (reflSubst_j : ∀ {Γ} {A : Γ ⟶ U0.Ty} (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) + (C : motiveCtx a a_tp i ⟶ U2.Ty) (c : Γ ⟶ U2.Tm) + (c_tp : c ≫ U2.tp = (reflSubst a a_tp i) ≫ C), + reflSubst a a_tp i ≫ j a a_tp C c c_tp = c) + + +end UnstructuredId + + +namespace StructuredId +variable {Ctx : Type u} [Category Ctx] {U: Model.UnstructuredUniverse Ctx} +{Γ: Ctx} {A: Γ ⟶ U.Ty} (a: Γ ⟶ U.Tm) (a_tp : a ≫ U.tp = A) + +structure IdIntro (M: Model.UnstructuredUniverse Ctx) where + Id : M.ext M.tp ⟶ M.Ty + refl : M.Tm ⟶ M.Tm + refl_tp : refl ≫ M.tp = + ((M.disp_pullback M.tp).lift (𝟙 M.Tm) (𝟙 M.Tm) (by simp)) ≫ Id + +variable (i: IdIntro U) + +def mkId (a0 a1 : Γ ⟶ U.Tm) + (a0_tp_eq_a1_tp : a0 ≫ U.tp = a1 ≫ U.tp) : + Γ ⟶ U.Ty := + (UnstructuredUniverse.disp_pullback _ U.tp).lift a1 a0 (by rw [a0_tp_eq_a1_tp]) ≫ + i.Id + +theorem comp_mkId {Δ : Ctx} (σ : Δ ⟶ Γ) + (a0 a1 : Γ ⟶ U.Tm) (eq : a0 ≫ U.tp = a1 ≫ U.tp) : + σ ≫ mkId i a0 a1 eq = + mkId i (σ ≫ a0) (σ ≫ a1) (by simp [eq]) := by + simp [mkId]; rw [← Category.assoc]; congr 1 + apply (UnstructuredUniverse.disp_pullback _ U.tp).hom_ext <;> simp + + +def mkRefl (a : Γ ⟶ U.Tm) : Γ ⟶ U.Tm := + a ≫ i.refl + +--previously can write i.mkRefl, why I cannot do it here anymore? +theorem comp_mkRefl {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (a : Γ ⟶ U.Tm) : + σ ≫ mkRefl i a = mkRefl i (σ ≫ a) := by + simp [mkRefl] + +def motiveCtx : Ctx := IdCommon.motiveCtx (mkId i (U.disp (a ≫ U.tp) ≫ a) (U.var _) (by simp)) + +abbrev toTmTm : U.ext A ⟶ U.ext U.tp := + U.substCons (U.disp A ≫ a) U.tp (U.var A) (by simp[a_tp]) + +def motiveSubst {Δ} (σ : Δ ⟶ Γ) : + motiveCtx (σ ≫ a) i ⟶ motiveCtx a i := by + convert + IdCommon.motiveSubst (toTmTm a a_tp ≫ i.Id) σ + simp[motiveCtx]; + congr 1 + · simp[a_tp] + · subst a_tp + rw![Category.assoc] + simp[heq_eq_eq,mkId,← Category.assoc] + congr 1 + · subst a_tp + simp[motiveCtx,mkId,substCons] + + + +def reflSubst : Γ ⟶ motiveCtx a i := by + convert + IdCommon.reflSubst a a_tp (toTmTm a a_tp ≫ i.Id) (a ≫ i.refl) + (by simp[i.refl_tp] + simp[← Category.assoc] + congr 1 + apply (U.disp_pullback _).hom_ext <;> simp + ) + subst a_tp + simp[motiveCtx] + congr 1 + + +-- Q: how to make i the first explicit argument and enable writing i.motiveCtx? +--stupid long proof +@[reassoc (attr := simp)] +lemma reflSubst_comp_motiveSubst {Δ} (σ : Δ ⟶ Γ) : + reflSubst (A:= σ ≫ A) (σ ≫ a) (by simp[a_tp]) i ≫ motiveSubst a a_tp i σ = + σ ≫ reflSubst (A:= A) a a_tp i := by + simp[reflSubst,motiveSubst] + have e := + IdCommon.reflSubst_comp_motiveSubst a a_tp (toTmTm a a_tp ≫ i.Id) (a ≫ i.refl) + (by simp[i.refl_tp] + simp[← Category.assoc] + congr 1 + apply (disp_pullback ..).hom_ext <;> simp + ) σ + convert e <;> simp[motiveCtx] + · subst a_tp + congr 1 + · subst a_tp + congr 1 + · simp--this is assoc... + · simp[mkId,← Category.assoc] + congr 1 + · simp + rw![Category.assoc] + simp[heq_eq_eq] + apply (disp_pullback ..).hom_ext <;> simp + · simp[mkId] + rw![a_tp] + simp[substCons] + · subst a_tp + simp[substWk,substCons] + congr! 1 + simp[← Category.assoc] + congr 1 + apply (disp_pullback ..).hom_ext <;> simp + · subst a_tp + simp[mkId,substCons] + + + +end StructuredId + + +end Model diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean new file mode 100644 index 00000000..2bdae3a4 --- /dev/null +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -0,0 +1,1522 @@ +import Mathlib.CategoryTheory.Limits.Shapes.KernelPair +import HoTTLean.ForMathlib +import HoTTLean.ForMathlib.Tactic.CategoryTheory.FunctorMap +import HoTTLean.ForMathlib.CategoryTheory.RepPullbackCone +import HoTTLean.ForMathlib.CategoryTheory.WeakPullback +import HoTTLean.ForMathlib.CategoryTheory.Polynomial +import HoTTLean.Model.Unstructured.UnstructuredUniverse +import Mathlib.CategoryTheory.Limits.Shapes.BinaryProducts +universe v u + +noncomputable section + +open CategoryTheory Limits Opposite + +namespace Model + +/-- A natural model with support for dependent types (and nothing more). +The data is a natural transformation with representable fibers, +stored as a choice of representative for each fiber. -/ +structure StructuredUniverse {Ctx : Type u} [Category Ctx] (R : MorphismProperty Ctx) + extends UnstructuredUniverse Ctx where + morphismProperty : R tp + +namespace StructuredUniverse + +open Model.UnstructuredUniverse + +section + +variable {Ctx : Type u} [Category Ctx] {R : MorphismProperty Ctx} (M : StructuredUniverse R) + [R.HasPullbacks] [R.IsStableUnderBaseChange] + +instance {Γ : Ctx} (A : Γ ⟶ M.Ty) : HasPullback A M.tp := + have := MorphismProperty.HasPullbacks.hasPullback A M.morphismProperty + hasPullback_symmetry _ _ + +lemma disp_mem {Γ : Ctx} (A : Γ ⟶ M.Ty) : R (M.disp A) := + R.of_isPullback (M.disp_pullback A) M.morphismProperty + +@[simps! hom inv] +def pullbackIsoExt {Γ : Ctx} (A : Γ ⟶ M.Ty) : + pullback A M.tp ≅ (M.ext A) := + IsPullback.isoPullback (M.disp_pullback A).flip |>.symm + +/-! ## Pullback of representable natural transformation -/ + +/-- Pull a natural model back along a type. -/ +protected def pullback {Γ : Ctx} (A : Γ ⟶ M.Ty) : StructuredUniverse R where + __ := UnstructuredUniverse.pullback M.toUnstructuredUniverse A + morphismProperty := M.disp_mem A + +/-- + Given the pullback square on the right, + with a natural model structure on `tp : Tm ⟶ Ty` + giving the outer pullback square. + + Γ.A -.-.- var -.-,-> E ------ toTm ------> Tm + | | | + | | | + M.disp π tp + | | | + V V V + Γ ------- A -------> U ------ toTy ------> Ty + + construct a natural model structure on `π : E ⟶ U`, + by pullback pasting. +-/ +def ofIsPullback {U E : Ctx} {π : E ⟶ U} + {toTy : U ⟶ M.Ty} {toTm : E ⟶ M.Tm} + (pb : IsPullback toTm π M.tp toTy) : + StructuredUniverse R where + __ := UnstructuredUniverse.ofIsPullback M.toUnstructuredUniverse pb + morphismProperty := R.of_isPullback pb M.morphismProperty + +/-! ## Polynomial functor on `tp` + +Specializations of results from the `Poly` package to natural models. -/ + +abbrev uvPolyTp : UvPoly R M.Tm M.Ty := ⟨M.tp, M.morphismProperty⟩ + +variable [ChosenTerminal Ctx] [R.HasObjects] [R.IsMultiplicative] + [R.HasPushforwards R] [R.IsStableUnderPushforwards R] + +instance : R.HasPushforwardsAlong M.uvPolyTp.p := + MorphismProperty.HasPushforwards.hasPushforwardsAlong M.tp M.morphismProperty + +instance : R.IsStableUnderPushforwardsAlong M.uvPolyTp.p := + MorphismProperty.IsStableUnderPushforwards.of_isPushforward M.tp M.morphismProperty + +def Ptp : Ctx ⥤ Ctx := M.uvPolyTp.functor + +namespace PtpEquiv + +variable {Γ : Ctx} {X : Ctx} + +/-- +A map `(AB : Γ ⟶ M.Ptp.obj X)` is equivalent to a pair of maps +`A : Γ ⟶ M.Ty` and `B : (M.ext (fst M AB)) ⟶ X`, +thought of as a dependent pair `A : Type` and `B : A ⟶ Type`. +`PtpEquiv.fst` is the `A` in this pair. +-/ +def fst (AB : Γ ⟶ M.Ptp.obj X) : Γ ⟶ M.Ty := + UvPoly.Equiv.fst AB + +/-- +A map `(AB : Γ ⟶ M.Ptp.obj X)` is equivalent to a pair of maps +`A : Γ ⟶ M.Ty` and `B : (M.ext (fst M AB)) ⟶ X`, +thought of as a dependent pair `A : Type` and `B : A ⟶ Type` +`PtpEquiv.snd` is the `B` in this pair. +-/ +def snd (AB : Γ ⟶ M.Ptp.obj X) (A := fst M AB) (eq : fst M AB = A := by rfl) : M.ext A ⟶ X := + UvPoly.Equiv.snd' AB (by rw [← fst, eq]; exact (M.disp_pullback _).flip) + +/-- +A map `(AB : Γ ⟶ M.Ptp.obj X)` is equivalent to a pair of maps +`A : Γ ⟶ M.Ty` and `B : (M.ext (fst M AB)) ⟶ X`, +thought of as a dependent pair `A : Type` and `B : A ⟶ Type` +`PtpEquiv.mk` constructs such a map `AB` from such a pair `A` and `B`. +-/ +def mk (A : Γ ⟶ M.Ty) (B : M.ext A ⟶ X) : Γ ⟶ M.Ptp.obj X := + UvPoly.Equiv.mk' A (M.disp_pullback _).flip B + +@[simp] +lemma fst_mk (A : Γ ⟶ M.Ty) (B : M.ext A ⟶ X) : + fst M (mk M A B) = A := by + simp [fst, mk] + +@[simp] +lemma snd_mk (A : Γ ⟶ M.Ty) (B : M.ext A ⟶ X) : + snd M (mk M A B) _ (fst_mk ..) = B := by + dsimp only [snd, mk] + rw! [UvPoly.Equiv.snd'_mk' (P := M.uvPolyTp)] + +section +variable {Δ : Ctx} {σ : Δ ⟶ Γ} {AB : Γ ⟶ M.Ptp.obj X} + +theorem fst_comp_left (σ : Δ ⟶ Γ) : fst M (σ ≫ AB) = σ ≫ fst M AB := + UvPoly.Equiv.fst_comp_left .. + +@[simp] +theorem fst_comp_right {Y} (σ : X ⟶ Y) : fst M (AB ≫ M.Ptp.map σ) = fst M AB := + UvPoly.Equiv.fst_comp_right .. + +theorem snd_comp_right {Y} (σ : X ⟶ Y) {A} (eq : fst M AB = A) : + snd M (AB ≫ M.Ptp.map σ) _ (by simpa) = snd M AB _ eq ≫ σ := by + simp only [snd, Ptp] + rw [UvPoly.Equiv.snd'_comp_right (P := M.uvPolyTp)] + +theorem snd_comp_left {A} (eqA : fst M AB = A) {σA} (eqσ : σ ≫ A = σA) : + snd M (σ ≫ AB) σA (by simp [fst_comp_left, eqA, eqσ]) = + (M.substWk σ _ _ eqσ) ≫ snd M AB _ eqA := by + have H1 : IsPullback (M.disp A) (M.var A) (UvPoly.Equiv.fst AB) M.tp := by + rw [← fst, eqA]; exact (M.disp_pullback _).flip + have H2 : IsPullback (M.disp σA) (M.var σA) + (σ ≫ UvPoly.Equiv.fst AB) M.tp := by + rw [← fst, eqA, eqσ]; exact (M.disp_pullback _).flip + convert UvPoly.Equiv.snd'_comp_left AB H1 _ H2 + apply H1.hom_ext <;> simp [substWk] + +theorem mk_comp_left {Δ Γ : Ctx} (M : StructuredUniverse R) (σ : Δ ⟶ Γ) + {X : Ctx} (A : Γ ⟶ M.Ty) (σA) (eq : σ ≫ A = σA) (B : (M.ext A) ⟶ X) : + σ ≫ PtpEquiv.mk M A B = PtpEquiv.mk M σA ((M.substWk σ A _ eq) ≫ B) := by + dsimp [PtpEquiv.mk] + have h := UvPoly.Equiv.mk'_comp_left (P := M.uvPolyTp) A (f := M.disp A) (g := M.var A) + (by convert (M.disp_pullback A).flip) B σ σA eq (M.disp_pullback σA).flip + convert h + apply (M.disp_pullback _).hom_ext + · simp + · simp [substWk_disp] + +theorem mk_comp_right {Γ : Ctx} (M : StructuredUniverse R) + {X Y : Ctx} (σ : X ⟶ Y) (A : Γ ⟶ M.Ty) (B : (M.ext A) ⟶ X) : + PtpEquiv.mk M A B ≫ M.Ptp.map σ = PtpEquiv.mk M A (B ≫ σ) := + UvPoly.Equiv.mk'_comp_right .. + +theorem ext {AB AB' : Γ ⟶ M.Ptp.obj X} (A := fst M AB) (eq : fst M AB = A := by rfl) + (h1 : fst M AB = fst M AB') (h2 : snd M AB A eq = snd M AB' A (h1 ▸ eq)) : + AB = AB' := UvPoly.Equiv.ext' _ h1 h2 + +theorem eta (AB : Γ ⟶ M.Ptp.obj X) : mk M (fst M AB) (snd M AB) = AB := + .symm <| ext _ _ rfl (by simp) (by simp) + +end + +end PtpEquiv + +@[reassoc] +theorem PtpEquiv.mk_map {Γ : Ctx} {X Y : Ctx} + (A : Γ ⟶ M.Ty) (x : (M.ext A) ⟶ X) (α : X ⟶ Y) : + mk M A x ≫ M.Ptp.map α = mk M A (x ≫ α) := by + simp [mk, Ptp, UvPoly.Equiv.mk'_comp_right] + +/-! ## Polynomial composition `M.tp ▸ N.tp` -/ + +abbrev compDom (M N : StructuredUniverse R) : Ctx := M.uvPolyTp.compDom N.uvPolyTp + +abbrev compP (M N : StructuredUniverse R) : M.compDom N ⟶ M.uvPolyTp @ N.Ty := + (M.uvPolyTp.comp N.uvPolyTp).p + +namespace compDomEquiv +open UvPoly + +variable {M N : StructuredUniverse R} {Γ Δ : Ctx} (σ : Δ ⟶ Γ) + +/-- Universal property of `compDom`, decomposition (part 1). + +A map `ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +`fst, dependent, snd` such that `fst_tp` and `snd_tp`. The map `fst : Γ ⟶ M.Tm` +is the `(a : A)` in `(a : A) × (b : B a)`. +-/ +abbrev fst (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : Γ ⟶ M.Tm := + UvPoly.compDomEquiv.fst ab + +/-- Computation of `comp` (part 1). + +`fst_tp` is (part 1) of the computation that + (α, B, β, h) + Γ ⟶ compDom + \ | + \ | comp +(α ≫ tp, B) | + \ V + > P_tp Ty +Namely the first projection `α ≫ tp` agrees. +-/ +theorem fst_tp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : + fst ab ≫ M.tp = PtpEquiv.fst M (ab ≫ M.compP N) := + UvPoly.compDomEquiv.fst_comp_p .. + +@[reassoc] +theorem fst_comp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) (σ : Δ ⟶ Γ) : + fst (σ ≫ ab) = σ ≫ fst ab := + UvPoly.compDomEquiv.fst_comp .. + +/-- Universal property of `compDom`, decomposition (part 2). + +A map `ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +`fst, dependent, snd` such that `fst_tp` and `snd_tp`. +The map `dependent : (M.ext (fst N ab ≫ M.tp)) ⟶ M.Ty` +is the `B : A ⟶ Type` in `(a : A) × (b : B a)`. +Here `A` is implicit, derived by the typing of `fst`, or `(a : A)`. +-/ +def dependent (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + (A := fst ab ≫ M.tp) (eq : fst ab ≫ M.tp = A := by rfl) : + (M.ext A) ⟶ N.Ty := + UvPoly.compDomEquiv.dependent ab (M.disp A) (M.var A) <| by + simpa [eq] using (M.disp_pullback A).flip + +lemma dependent_eq (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + (A := fst ab ≫ M.tp) (eq : fst ab ≫ M.tp = A := by rfl) : + dependent ab A eq = PtpEquiv.snd M (ab ≫ M.compP N) A (by simp [← eq, fst_tp]) := by + simp [dependent, UvPoly.compDomEquiv.dependent, PtpEquiv.snd] + +theorem comp_dependent (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + {A} (eq1 : fst ab ≫ M.tp = A) + {σA} (eq2 : σ ≫ A = σA) : + (M.substWk σ _ _ eq2) ≫ dependent ab A eq1 = + dependent (σ ≫ ab) σA (by simp [fst_comp, eq1, eq2]) := by + dsimp [dependent] + rw [UvPoly.compDomEquiv.dependent_comp σ ab (M.disp A) (M.var A) + (by simpa [eq1] using (M.disp_pullback A).flip)] + · congr 1 + simp [substWk, substCons] + apply (M.disp_pullback A).hom_ext <;> simp + +/-- Universal property of `compDom`, decomposition (part 3). + +A map `ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +`fst, dependent, snd` such that `fst_tp` and `snd_tp`. +The map `snd : Γ ⟶ M.Tm` +is the `(b : B a)` in `(a : A) × (b : B a)`. +-/ +abbrev snd (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : Γ ⟶ N.Tm := + UvPoly.compDomEquiv.snd ab + +@[reassoc] +theorem snd_comp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) (σ : Δ ⟶ Γ) : + snd (σ ≫ ab) = σ ≫ snd ab := + UvPoly.compDomEquiv.snd_comp .. + +/-- Universal property of `compDom`, decomposition (part 4). + +A map `ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +`fst, dependent, snd` such that `fst_tp` and `snd_tp`. +The equation `snd_tp` says that the type of `b : B a` agrees with +the expression for `B a` obtained solely from `dependent`, or `B : A ⟶ Type`. +-/ +theorem snd_tp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + {A} (eq : fst ab ≫ M.tp = A := by rfl) : + snd ab ≫ N.tp = (M.sec _ (fst ab) eq) ≫ dependent ab A eq := by + rw [UvPoly.compDomEquiv.snd_comp_p ab (M.disp A) (M.var A) <| by + simpa [eq] using (M.disp_pullback A).flip] + congr 1 + apply (disp_pullback ..).hom_ext + · simp + · simp + +/-- Universal property of `compDom`, constructing a map into `compDom`. -/ +def mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : M.ext A ⟶ N.Ty) (β : Γ ⟶ N.Tm) + (h : β ≫ N.tp = M.sec _ α eq ≫ B) : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp := + UvPoly.compDomEquiv.mk _ α eq (M.disp A) (M.var A) (M.disp_pullback A).flip B β (by + convert h + apply (disp_pullback ..).hom_ext <;> simp) + +@[simp] +theorem fst_mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A := by rfl) (B : (M.ext A) ⟶ N.Ty) + (β : Γ ⟶ N.Tm) (h : β ≫ N.tp = (M.sec _ α eq) ≫ B) : fst (mk α eq B β h) = α := by + simp [mk, fst] + +@[simp] +theorem dependent_mk (α : Γ ⟶ M.Tm) {A A'} (eq : α ≫ M.tp = A) (hA' : A' = A) + (B : M.ext A ⟶ N.Ty) (β : Γ ⟶ N.Tm) + (h : β ≫ N.tp = (M.sec _ α eq) ≫ B) : + dependent (mk α eq B β h) A' (by simp [hA', fst_mk, eq]) = eqToHom (by rw [hA']) ≫ B := by + subst hA' + simp [mk, dependent] + +@[simp] +theorem snd_mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : (M.ext A) ⟶ N.Ty) (β : Γ ⟶ N.Tm) + (h : β ≫ N.tp = (M.sec _ α eq) ≫ B) : snd (mk α eq B β h) = β := by + simp [mk, snd] + +theorem ext {ab₁ ab₂ : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp} + {A} (eq : fst ab₁ ≫ M.tp = A) + (h1 : fst ab₁ = fst ab₂) + (h2 : dependent ab₁ A eq = dependent ab₂ A (h1 ▸ eq)) + (h3 : snd ab₁ = snd ab₂) : ab₁ = ab₂ := by + apply UvPoly.compDomEquiv.ext ab₁ ab₂ h1 h3 (M.disp _) (M.var _) (M.disp_pullback _).flip + dsimp only [dependent] at * + subst eq + rw! [h2] + +theorem comp_mk (α : Γ ⟶ M.Tm) {A} (e1 : α ≫ M.tp = A) (B : (M.ext A) ⟶ N.Ty) + (β : Γ ⟶ N.Tm) (e2 : β ≫ N.tp = (M.sec A α e1) ≫ B) (σ : Δ ⟶ Γ) {σA} (e3 : σ ≫ A = σA) : + σ ≫ mk α e1 B β e2 = + mk (σ ≫ α) (by simp [e1, e3]) + ((M.substWk σ A _ e3) ≫ B) (σ ≫ β) + (by simp [e2]; rw [← Category.assoc, comp_sec]; simp; congr!) := by + dsimp only [mk] + rw [UvPoly.compDomEquiv.comp_mk (P := M.uvPolyTp) (P' := N.uvPolyTp) σ _ α e1 (M.disp _) + (M.var _) (M.disp_pullback _).flip (M.disp _) (M.var _) (M.disp_pullback _).flip] + subst e1 e3 + congr 2 + apply (disp_pullback ..).hom_ext <;> simp [substWk_disp] + +@[reassoc] +lemma mk_comp (α : Γ ⟶ M.Tm) {A} (e1 : α ≫ M.tp = A) (B : (M.ext A) ⟶ N.Ty) + (β : Γ ⟶ N.Tm) (e2 : β ≫ N.tp = (M.sec A α e1) ≫ B) : + mk α e1 B β e2 ≫ M.compP N = PtpEquiv.mk M A B := by + erw [PtpEquiv.mk, UvPoly.compDomEquiv.mk_comp (P := M.uvPolyTp) (P' := N.uvPolyTp)] + +theorem eta (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + {A} (eq : fst ab ≫ M.tp = A) : + mk (fst ab) eq (dependent ab A eq) (snd ab) (snd_tp ab eq) = ab := by + symm; apply ext (eq := eq) <;> simp + +end compDomEquiv + +end + +variable {Ctx : Type u} [Category Ctx] {R : MorphismProperty Ctx} + [R.HasPullbacks] [R.IsStableUnderBaseChange] + [ChosenTerminal Ctx] [R.HasObjects] [R.IsMultiplicative] + [R.HasPushforwards R] [R.IsStableUnderPushforwards R] + +/-! ## Pi types -/ + +/-- The structure on three universes that for +`A : Γ ⟶ U0.Ty` and `B : Γ.A ⟶ U1.Ty` constructs a Π-type `Π_A B : Γ ⟶ U2.Ty`. +-/ +structure PolymorphicPi (U0 U1 U2 : StructuredUniverse R) where + Pi : U0.Ptp.obj U1.Ty ⟶ U2.Ty + lam : U0.Ptp.obj U1.Tm ⟶ U2.Tm + Pi_pullback : IsPullback lam (U0.Ptp.map U1.tp) U2.tp Pi + +set_option linter.dupNamespace false in +/-- A universe `M` has Π-type structure. This is the data of a pullback square +``` + lam +Ptp Tm ------> Tm + | | +Ptp tp |tp + | | + V V +Ptp Ty ------> Ty + Pi +``` +-/ +protected abbrev Pi (U : StructuredUniverse R) := PolymorphicPi U U U + +namespace PolymorphicPi + +variable {U0 U1 U2 : StructuredUniverse R} {Γ : Ctx} + +section +variable (P : PolymorphicPi U0 U1 U2) + +/-- +``` +Γ ⊢₀ A Γ.A ⊢₁ B +----------------- +Γ ⊢₂ ΠA. B +``` -/ +def mkPi {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) : Γ ⟶ U2.Ty := + PtpEquiv.mk U0 A B ≫ P.Pi + +theorem comp_mkPi {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : (Γ) ⟶ U0.Ty) (σA) (eq : (σ) ≫ A = σA) + (B : (U0.ext A) ⟶ U1.Ty) : + (σ) ≫ P.mkPi A B = P.mkPi σA ((U0.substWk σ A _ eq) ≫ B) := by + simp [mkPi, ← Category.assoc, PtpEquiv.mk_comp_left (eq := eq)] + +/-- +``` +Γ ⊢₀ A Γ.A ⊢₁ t : B +------------------------- +Γ ⊢₂ λA. t : ΠA. B +``` -/ +def mkLam {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (t : (U0.ext A) ⟶ U1.Tm) : (Γ) ⟶ U2.Tm := + PtpEquiv.mk U0 A t ≫ P.lam + +@[simp] +theorem mkLam_tp {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (t : (U0.ext A) ⟶ U1.Tm) (t_tp : t ≫ U1.tp = B) : + P.mkLam A t ≫ U2.tp = P.mkPi A B := by + simp [mkLam, mkPi, P.Pi_pullback.w, PtpEquiv.mk_map_assoc, t_tp] + +theorem comp_mkLam {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : (Γ) ⟶ U0.Ty) (σA) (eq : (σ) ≫ A = σA) (t : (U0.ext A) ⟶ U1.Tm) : + (σ) ≫ P.mkLam A t = P.mkLam σA ((U0.substWk σ A _ eq) ≫ t) := by + simp [mkLam, ← Category.assoc, PtpEquiv.mk_comp_left (eq := eq)] + + +/-- +``` +Γ ⊢₀ A Γ ⊢₂ f : ΠA. B +----------------------------- +Γ.A ⊢₁ unlam f : B +``` -/ +def unLam {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + (U0.ext A) ⟶ U1.Tm := by + let total : (Γ) ⟶ U0.Ptp.obj U1.Tm := + P.Pi_pullback.lift f (PtpEquiv.mk U0 A B) f_tp + refine PtpEquiv.snd U0 total _ ?_ + have eq : total ≫ U0.Ptp.map U1.tp = PtpEquiv.mk U0 A B := + (P.Pi_pullback).lift_snd .. + apply_fun PtpEquiv.fst U0 at eq + rw [PtpEquiv.fst_comp_right] at eq + simpa using eq + +@[simp] +theorem unLam_tp {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + P.unLam A B f f_tp ≫ U1.tp = B := by + rw [unLam, ← PtpEquiv.snd_comp_right] + convert PtpEquiv.snd_mk U0 A B using 2; simp + +theorem comp_unLam {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : (Γ) ⟶ U0.Ty) (σA) (eq : (σ) ≫ A = σA) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + (U0.substWk σ A _ eq) ≫ P.unLam A B f f_tp = + P.unLam σA ((U0.substWk σ A _ eq) ≫ B) + ((σ) ≫ f) (by simp [eq, f_tp, comp_mkPi]) := by + simp [unLam] + rw [← PtpEquiv.snd_comp_left] + simp [PtpEquiv.snd, UvPoly.Equiv.snd'_eq]; congr 1 + apply pullback.hom_ext <;> simp; congr 1 + apply (P.Pi_pullback).hom_ext <;> simp + rw [PtpEquiv.mk_comp_left] + +/-- +``` +Γ ⊢₂ f : ΠA. B Γ ⊢₀ a : A +--------------------------------- +Γ ⊢₁ f a : B[id.a] +``` -/ +def mkApp {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) + (a : (Γ) ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) : (Γ) ⟶ U1.Tm := + (U0.sec A a a_tp) ≫ P.unLam A B f f_tp + +@[simp] +theorem mkApp_tp {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) + (a : (Γ) ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) : + P.mkApp A B f f_tp a a_tp ≫ U1.tp = (U0.sec A a a_tp) ≫ B := by + simp [mkApp] + +theorem comp_mkApp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : Γ ⟶ U0.Ty) (σA) (eq : σ ≫ A = σA) (B : (U0.ext A) ⟶ U1.Ty) + (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) + (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) : + σ ≫ P.mkApp A B f f_tp a a_tp = + P.mkApp σA (U0.substWk σ A _ eq ≫ B) + (σ ≫ f) (by simp [f_tp, comp_mkPi (eq := eq)]) + (σ ≫ a) (by simp [a_tp, eq]) := by + unfold mkApp; rw [← Category.assoc, + comp_sec σ a_tp _ eq, Category.assoc, comp_unLam (eq := eq)] + +@[simp] +theorem mkLam_unLam {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + P.mkLam A (P.unLam A B f f_tp) = f := by + let total : Γ ⟶ U0.Ptp.obj U1.Tm := + (P.Pi_pullback).lift f (PtpEquiv.mk U0 A B) f_tp + simp only [mkLam, unLam] + have : PtpEquiv.fst U0 total = A := by + simp only [PtpEquiv.fst, UvPoly.Equiv.fst_eq, total] + rw [← U0.uvPolyTp.map_fstProj U1.tp] + slice_lhs 1 2 => apply (P.Pi_pullback).lift_snd + apply PtpEquiv.fst_mk + slice_lhs 1 1 => equals total => + apply PtpEquiv.ext _ (A := A) (by simp) (by simp [this]) (by simp [total]) + apply (P.Pi_pullback).lift_fst + +@[simp] +theorem unLam_mkLam {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : U0.ext A ⟶ U1.Tm) (t_tp : t ≫ U1.tp = B) + (lam_tp : P.mkLam A t ≫ U2.tp = P.mkPi A B) : + P.unLam A B (P.mkLam A t) lam_tp = t := by + simp [mkLam, unLam] + convert PtpEquiv.snd_mk U0 A t using 2 + apply (P.Pi_pullback).hom_ext <;> simp + rw [PtpEquiv.mk_comp_right, t_tp] + +/-- +``` +Γ ⊢₂ f : ΠA. B +-------------------------------------- +Γ ⊢₂ λA. f[↑] v₀ : ΠA. B +``` +-/ +def etaExpand {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + (Γ) ⟶ U2.Tm := + P.mkLam A <| + P.mkApp + (U0.disp A ≫ A) (U0.substWk .. ≫ B) (U0.disp A ≫ f) + (by simp [f_tp, comp_mkPi]) + (U0.var A) (U0.var_tp A) + +theorem etaExpand_eq {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + P.etaExpand A B f f_tp = f := by + simp [etaExpand] + convert P.mkLam_unLam A B f f_tp using 2 + simp [mkApp]; rw [← comp_unLam (f_tp := f_tp), ← Category.assoc] + conv_rhs => rw [← Category.id_comp (P.unLam ..)] + congr 2 + apply (U0.disp_pullback A).hom_ext <;> simp + +/-- +``` +Γ ⊢₀ A Γ.A ⊢₁ t : B Γ ⊢₀ a : A +-------------------------------- +Γ.A ⊢₁ (λA. t) a ≡ t[a] : B[a] +``` -/ +@[simp] +theorem mkApp_mkLam {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (t : (U0.ext A) ⟶ U1.Tm) (t_tp : t ≫ U1.tp = B) + (lam_tp : P.mkLam A t ≫ U2.tp = P.mkPi A B) + (a : (Γ) ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) : + P.mkApp A B (P.mkLam A t) lam_tp a a_tp = (U0.sec A a a_tp) ≫ t := by + rw [mkApp, unLam_mkLam] + assumption + +def toUnstructured : + UnstructuredUniverse.PolymorphicPi U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse where + Pi := P.mkPi _ + Pi_comp _ _ _ _ _ := (P.comp_mkPi ..).symm + lam _ b _ := P.mkLam _ b + lam_comp σ A σA eq _ b _ := (P.comp_mkLam σ A σA eq b).symm + lam_tp B b b_tp := P.mkLam_tp _ B b b_tp + unLam := P.unLam _ + unLam_tp B f f_tp := P.unLam_tp _ B f f_tp + unLam_lam B b b_tp := P.unLam_mkLam _ B b b_tp _ + lam_unLam B := P.mkLam_unLam _ B + +end + +namespace ofUnstructured + +variable {U0 U1 U2 : StructuredUniverse R} + (P : UnstructuredUniverse.PolymorphicPi U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse) + +def PiApp (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) : Γ ⟶ U2.Ty := + P.Pi (PtpEquiv.snd U0 AB) + +lemma Pi_naturality {Δ Γ} (σ : Δ ⟶ Γ) (AB) : + PiApp P (σ ≫ AB) = σ ≫ PiApp P AB := by + simp only [PiApp, PtpEquiv.fst_comp_left, PtpEquiv.snd_comp_left, ← P.Pi_comp] + rw! [PtpEquiv.fst_comp_left] + +def Pi : U0.uvPolyTp @ U1.Ty ⟶ U2.Ty := + ofYoneda (PiApp P) (Pi_naturality P) + +def lamApp (b : Γ ⟶ U0.uvPolyTp @ U1.Tm) : Γ ⟶ U2.Tm := + P.lam _ (PtpEquiv.snd U0 b) rfl + +lemma lam_naturality {Δ Γ} (σ : Δ ⟶ Γ) (ab) : + lamApp P (σ ≫ ab) = σ ≫ lamApp P ab := by + simp only [lamApp, PtpEquiv.fst_comp_left, PtpEquiv.snd_comp_left, ← P.lam_comp] + rw! [PtpEquiv.fst_comp_left] + simp + +def lam : U0.uvPolyTp @ U1.Tm ⟶ U2.Tm := + ofYoneda (lamApp P) (lam_naturality P) + +lemma lamApp_tp (b : Γ ⟶ U0.uvPolyTp @ U1.Tm) : + lamApp P b ≫ U2.tp = PiApp P (b ≫ U0.Ptp.map U1.tp) := by + simp only [lamApp, PiApp, PtpEquiv.fst_comp_right, PtpEquiv.snd_comp_right] + rw! [P.lam_tp, PtpEquiv.fst_comp_right] + +def lift (f : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (f_tp : f ≫ U2.tp = PiApp P AB) : Γ ⟶ U0.uvPolyTp @ U1.Tm := + PtpEquiv.mk _ (PtpEquiv.fst _ AB) (P.unLam (PtpEquiv.snd _ AB) f f_tp) + +lemma lamApp_lift (f : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (f_tp : f ≫ U2.tp = PiApp P AB) : + lamApp P (lift P f AB f_tp) = f := by + dsimp only [lamApp, lift] + rw! (castMode := .all) [PtpEquiv.fst_mk, PtpEquiv.snd_mk, P.unLam_tp, P.lam_unLam] + +lemma lift_Ptp_map_tp (f : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (f_tp : f ≫ U2.tp = PiApp P AB) : + ofUnstructured.lift P f AB f_tp ≫ U0.Ptp.map U1.tp = AB := by + dsimp [lift] + rw [PtpEquiv.mk_comp_right, P.unLam_tp, PtpEquiv.eta] + +lemma lift_uniq (f : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (f_tp : f ≫ U2.tp = PiApp P AB) (m : Γ ⟶ U0.Ptp.obj U1.Tm) + (hl : lamApp P m = f) (hr : m ≫ U0.Ptp.map U1.tp = AB) : + m = lift P f AB f_tp := by + fapply PtpEquiv.ext _ + · calc PtpEquiv.fst _ m + _ = PtpEquiv.fst _ (m ≫ U0.Ptp.map U1.tp) := by rw [PtpEquiv.fst_comp_right] + _ = _ := by simp [hr, lift] + · subst hl hr + dsimp only [lift, lamApp] + rw! [PtpEquiv.fst_comp_right, PtpEquiv.snd_mk, PtpEquiv.snd_comp_right, P.unLam_lam] + +end ofUnstructured + +def ofUnstructured (P : UnstructuredUniverse.PolymorphicPi U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse) : PolymorphicPi U0 U1 U2 where + Pi := ofUnstructured.Pi P + lam := ofUnstructured.lam P + Pi_pullback := ofYoneda_isPullback _ _ _ _ _ _ (ofUnstructured.lamApp_tp P) + (ofUnstructured.lift P) + (ofUnstructured.lamApp_lift P) + (ofUnstructured.lift_Ptp_map_tp P) + (ofUnstructured.lift_uniq P) + +end PolymorphicPi + +/-! ## Sigma types -/ + +/-- The structure on three universes that for +`A : Γ ⟶ U0.Ty` and `B : Γ.A ⟶ U1.Ty` constructs a Π-type `Σ_A B : Γ ⟶ U2.Ty`. -/ +structure PolymorphicSigma (U0 U1 U2 : StructuredUniverse R) where + Sig : U0.Ptp.obj U1.Ty ⟶ U2.Ty + pair : U0.compDom U1 ⟶ U2.Tm + Sig_pullback : IsPullback pair (U0.compP U1) U2.tp Sig + +/-- A universe `M` has Σ-type structure. This is the data of a pullback square +``` + Sig +compDom ------> Tm + | | + compP |tp + | | + V V +Ptp Ty ------> Ty + pair +``` +-/ +protected abbrev Sigma (U : StructuredUniverse R) := PolymorphicSigma U U U + +namespace PolymorphicSigma + +variable {U0 U1 U2 : StructuredUniverse R} {Γ : Ctx} + +section +variable (S : PolymorphicSigma U0 U1 U2) + +/-- +``` +Γ ⊢₀ A Γ.A ⊢₁ B +----------------- +Γ ⊢₂ ΣA. B +``` -/ +def mkSig {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) : + Γ ⟶ U2.Ty := + PtpEquiv.mk U0 A B ≫ S.Sig + +theorem comp_mkSig {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) : + σ ≫ S.mkSig A B = + S.mkSig (σ ≫ A) ((U0.substWk σ A) ≫ B) := by + simp [mkSig, ← Category.assoc, PtpEquiv.mk_comp_left] + +/-- +``` +Γ ⊢₀ t : A Γ ⊢₁ u : B[t] +-------------------------- +Γ ⊢₂ ⟨t, u⟩ : ΣA. B +``` -/ +def mkPair {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + (Γ) ⟶ U2.Tm := + compDomEquiv.mk t t_tp B u u_tp ≫ S.pair + +theorem comp_mkPair {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + σ ≫ S.mkPair A B t t_tp u u_tp = + S.mkPair (σ ≫ A) ((U0.substWk σ A) ≫ B) + (σ ≫ t) (by simp [t_tp]) + (σ ≫ u) (by simp [u_tp, comp_sec_assoc]) := by + simp only [← Category.assoc, mkPair]; rw [compDomEquiv.comp_mk] + +@[simp] +theorem mkPair_tp {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + S.mkPair A B t t_tp u u_tp ≫ U2.tp = S.mkSig A B := by + simp [mkPair, Category.assoc, S.Sig_pullback.w, mkSig, compDomEquiv.mk_comp_assoc] + +def mkFst {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + Γ ⟶ U0.Tm := + compDomEquiv.fst (S.Sig_pullback.lift p (PtpEquiv.mk _ A B) p_tp) + +@[simp] +theorem mkFst_tp {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + S.mkFst A B p p_tp ≫ U0.tp = A := by + simp [mkFst, compDomEquiv.fst_tp] + +@[simp] +theorem mkFst_mkPair {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + S.mkFst A B (S.mkPair A B t t_tp u u_tp) (by simp) = t := by + simp [mkFst, mkPair] + convert compDomEquiv.fst_mk t t_tp B u u_tp using 2 + apply (S.Sig_pullback).hom_ext <;> simp [compDomEquiv.mk_comp] + +theorem comp_mkFst {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + (σ) ≫ S.mkFst A B p p_tp = + S.mkFst (σ ≫ A) (U0.substWk σ A ≫ B) (σ ≫ p) + (by simp [p_tp, comp_mkSig]) := by + simp [mkFst] + rw [← compDomEquiv.fst_comp]; congr 1 + apply S.Sig_pullback.hom_ext <;> simp [PtpEquiv.mk_comp_left] + +def mkSnd {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + Γ ⟶ U1.Tm := + compDomEquiv.snd (S.Sig_pullback.lift p (PtpEquiv.mk _ A B) p_tp) + +@[simp] +theorem mkSnd_mkPair {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + S.mkSnd A B (S.mkPair A B t t_tp u u_tp) (by simp) = u := by + simp [mkSnd, mkPair] + convert compDomEquiv.snd_mk t t_tp B u u_tp using 2 + apply (S.Sig_pullback).hom_ext <;> simp [compDomEquiv.mk_comp] + +protected theorem dependent_eq {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + compDomEquiv.dependent ((S.Sig_pullback).lift p (PtpEquiv.mk U0 A B) p_tp) A + (by simp [compDomEquiv.fst_tp]) = B := by + convert PtpEquiv.snd_mk U0 A B using 2 + simp only [compDomEquiv.dependent, UvPoly.compDomEquiv.dependent, PtpEquiv.snd_mk] + simp [PtpEquiv.mk] + +@[simp] +theorem mkSnd_tp {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + S.mkSnd A B p p_tp ≫ U1.tp = + (U0.sec A (S.mkFst A B p p_tp) (by simp)) ≫ B := by + generalize_proofs h + simp [mkSnd, compDomEquiv.snd_tp (eq := h), S.dependent_eq]; rfl + +theorem comp_mkSnd {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + σ ≫ S.mkSnd A B p p_tp = + S.mkSnd (σ ≫ A) (U0.substWk σ A ≫ B) (σ ≫ p) + (by simp [p_tp, comp_mkSig]) := by + simp [mkSnd, ← compDomEquiv.snd_comp]; congr 1 + apply (S.Sig_pullback).hom_ext <;> simp + rw [PtpEquiv.mk_comp_left] + +@[simp] +theorem mkPair_mkFst_mkSnd {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + S.mkPair A B + (S.mkFst A B p p_tp) (by simp) + (S.mkSnd A B p p_tp) (by simp) = p := by + simp [mkFst, mkSnd, mkPair] + have := compDomEquiv.eta ((S.Sig_pullback).lift p (PtpEquiv.mk _ A B) p_tp) + (eq := by rw [← mkFst.eq_def, mkFst_tp]) + conv at this => enter [1, 3]; apply S.dependent_eq + simp [this] + +end + +namespace ofUnstructured + +variable {U0 U1 U2 : StructuredUniverse R} + (S : UnstructuredUniverse.PolymorphicSigma U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse) + +def SigApp (AB : Γ ⟶ U0.Ptp.obj U1.Ty) : Γ ⟶ U2.Ty := + S.Sig (PtpEquiv.snd U0 AB) + +lemma Sig_naturality {Δ Γ} (σ : Δ ⟶ Γ) (AB) : + SigApp S (σ ≫ AB) = σ ≫ SigApp S AB := by + simp only [SigApp, PtpEquiv.fst_comp_left, PtpEquiv.snd_comp_left, ← S.Sig_comp] + rw! [PtpEquiv.fst_comp_left] + +def Sig : U0.Ptp.obj U1.Ty ⟶ U2.Ty := + ofYoneda (SigApp S) (Sig_naturality S) + +def pairApp (ab : Γ ⟶ U0.compDom U1) : Γ ⟶ U2.Tm := + S.pair (compDomEquiv.dependent ab) (compDomEquiv.fst ab) + (by rw [compDomEquiv.fst_tp]) (compDomEquiv.snd ab) (by rw [compDomEquiv.snd_tp]) + +lemma pair_naturality {Δ Γ} (σ : Δ ⟶ Γ) (ab) : + pairApp S (σ ≫ ab) = σ ≫ pairApp S ab := by + dsimp [pairApp] + simp only [← S.pair_comp, compDomEquiv.comp_dependent, compDomEquiv.fst_comp, + compDomEquiv.snd_comp] + rw! [compDomEquiv.fst_comp, Category.assoc] + +def pair : U0.compDom U1 ⟶ U2.Tm := + ofYoneda (pairApp S) (pair_naturality S) + +lemma pair_tp (ab : Γ ⟶ U0.compDom U1) : + pairApp S ab ≫ U2.tp = SigApp S (ab ≫ U0.compP U1) := by + dsimp [pairApp, SigApp] + rw! [S.pair_tp, compDomEquiv.dependent_eq, compDomEquiv.fst_tp] + +def lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + Γ ⟶ U0.compDom U1 := + let B := PtpEquiv.snd U0 AB + compDomEquiv.mk (S.fst B ab ab_tp) (S.fst_tp ..) B (S.snd B ab ab_tp) (S.snd_tp ..) + +lemma fst_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + compDomEquiv.fst (lift S ab AB ab_tp) = + S.fst (PtpEquiv.snd U0 AB) ab ab_tp := by + rw [lift, compDomEquiv.fst_mk _ _] + +lemma snd_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + compDomEquiv.snd (lift S ab AB ab_tp) = + S.snd (PtpEquiv.snd U0 AB) ab ab_tp := by + rw [lift, compDomEquiv.snd_mk] + +lemma dependent_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + compDomEquiv.dependent (lift S ab AB ab_tp) (PtpEquiv.fst U0 AB) (by rw [fst_lift, S.fst_tp]) = + PtpEquiv.snd U0 AB (PtpEquiv.fst U0 AB) := by + simp [lift, compDomEquiv.dependent_mk] + +lemma pairApp_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = ofUnstructured.SigApp S AB) : + ofUnstructured.pairApp S (ofUnstructured.lift S ab AB ab_tp) = ab := by + dsimp [pairApp] + rw! [fst_lift, S.fst_tp, fst_lift, snd_lift, dependent_lift] + rw [S.eta] + +lemma lift_compP (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + lift S ab AB ab_tp ≫ U0.compP U1 = AB := by + dsimp [lift] + rw [compDomEquiv.mk_comp, PtpEquiv.eta] + +lemma lift_uniq (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) (m : Γ ⟶ U0.compDom U1) + (hl : pairApp S m = ab) (hr : m ≫ U0.compP U1 = AB) : + m = lift S ab AB ab_tp := by + rw! [← compDomEquiv.eta m] + fapply compDomEquiv.ext (A := PtpEquiv.fst U0 AB) + · rw [compDomEquiv.fst_mk, compDomEquiv.fst_tp, hr] + · rw [fst_lift, compDomEquiv.fst_mk _] + calc compDomEquiv.fst m + _ = S.fst (compDomEquiv.dependent m) (pairApp S m) (S.pair_tp ..) := by + dsimp [pairApp] + rw [S.fst_pair] + S.fst (compDomEquiv.dependent m) (pairApp S m) (S.pair_tp ..) = + S.fst (PtpEquiv.snd U0 AB) ab ab_tp := by + subst hl hr + rw! [compDomEquiv.dependent_eq, compDomEquiv.fst_tp] + · subst hr + rw [compDomEquiv.dependent_mk, dependent_lift, compDomEquiv.dependent_eq] + rw! [compDomEquiv.fst_tp, eqToHom_refl, Category.id_comp, compDomEquiv.fst_tp] + · simp [snd_lift] + calc compDomEquiv.snd m + _ = S.snd (compDomEquiv.dependent m) (pairApp S m) (S.pair_tp ..) := by + dsimp [pairApp] + rw [S.snd_pair] + S.snd (compDomEquiv.dependent m) (pairApp S m) (S.pair_tp ..) = + S.snd (PtpEquiv.snd U0 AB) ab ab_tp := by + subst hl hr + rw! [compDomEquiv.dependent_eq, compDomEquiv.fst_tp] + +end ofUnstructured + +def ofUnstructured {U0 U1 U2 : StructuredUniverse R} + (S : UnstructuredUniverse.PolymorphicSigma U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse) : + PolymorphicSigma U0 U1 U2 where + Sig := ofUnstructured.Sig S + pair := ofUnstructured.pair S + Sig_pullback := ofYoneda_isPullback _ _ _ _ _ _ (ofUnstructured.pair_tp S) + (ofUnstructured.lift S) + (ofUnstructured.pairApp_lift S) + (ofUnstructured.lift_compP S) + (ofUnstructured.lift_uniq S) + +end PolymorphicSigma + +-- def Sigma.mk' +-- (Sig : ∀ {Γ} {A : Γ ⟶ M.Ty}, (M.ext A ⟶ M.Ty) → (Γ ⟶ M.Ty)) +-- (comp_Sig : ∀ {Γ Δ} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) {σA} (eq) (B : M.ext A ⟶ M.Ty), +-- σ ≫ Sig B = Sig (M.substWk σ A σA eq ≫ B)) +-- (assoc : ∀ {Γ} {A : Γ ⟶ M.Ty} (B : M.ext A ⟶ M.Ty), M.ext B ≅ M.ext (Sig B)) +-- (comp_assoc : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ M.Ty} {σA} (eq) (B : M.ext A ⟶ M.Ty), +-- substWk _ (substWk _ σ _ _ eq) _ ≫ (assoc B).hom = +-- (assoc (M.substWk σ A σA eq ≫ B)).hom ≫ M.substWk σ _ _ (comp_Sig ..)) +-- (assoc_disp : ∀ {Γ} {A : Γ ⟶ M.Ty} (B : M.ext A ⟶ M.Ty), +-- (assoc B).hom ≫ M.disp _ = M.disp _ ≫ M.disp _) : +-- M.Sigma := sorry + +section + +variable (U0 U1 U2 : StructuredUniverse R) + +/-- +Used in the definition `IdIntro`, +`diag` is the diagonal substitution into the pullback `U0.ext U0.tp`, +a.k.a the pullback `Tm ×_Ty Tm` or the context `Tm.tp`. + 𝟙 Tm +Tm ---------> + | ↘diag var + | Tm.tp -----> Tm + | | | +𝟙 Tm | | + | disp | tp + V | | + V V + Tm ----------> Ty + tp +-/ +abbrev diag : U0.Tm ⟶ U0.ext U0.tp := + (U0.disp_pullback U0.tp).lift (𝟙 U0.Tm) (𝟙 U0.Tm) (by simp) + +/-- An auxiliary definition for the structure `StructuredUniverse.Id`. +`Universe.IdIntro` consists of the following commutative square + refl +Tm --------> Tm + | | + | | +diag tp + | | + | | + V V + Tm.tp -----> Ty + Id +-/ +structure IdIntro where + Id : U0.ext U0.tp ⟶ U1.Ty + refl : U0.Tm ⟶ U1.Tm + refl_tp : refl ≫ U1.tp = U0.diag ≫ Id + +variable {U0 U1 U2} + +namespace IdIntro + +variable (ii : IdIntro U0 U1) {Γ : Ctx} + +/-- Used in the definition `StructuredUniverse.Id`, +the comparison map `U0.Tm ⟶ U0.ext ii.Id` induced by the +pullback universal property of `U0.ext ii.Id`. + + refl + U0.Tm ---------> + ↘comparison var + | U1.ext ii.Id ------> U1.Tm + | | | +diag | | + | disp U1.tp + | | | + | V V + V U0.ext U0.tp ---> U1.Ty + Id +-/ +def comparison : U0.Tm ⟶ U1.ext ii.Id := + (U1.disp_pullback ii.Id).lift ii.refl U0.diag ii.refl_tp + +@[simp] +lemma comparison_comp_var : comparison ii ≫ U1.var ii.Id = ii.refl := by + simp [comparison] + +@[simp, reassoc] +lemma comparison_comp_diap_comp_var : comparison ii ≫ U1.disp ii.Id ≫ U0.var U0.tp = + 𝟙 _ := by + simp [comparison] + +@[simp, reassoc] +lemma comparison_comp_disp_comp_disp : ii.comparison ≫ U1.disp ii.Id ≫ U0.disp U0.tp = + 𝟙 _ := by + simp [comparison] + +/-- `dispTpUvPoly` promotes the map `U0.disp U0.tp` to a `UvPoly`, +which we can compose with `dispIdUvPoly` to make `iUvPoly`. +Informally thought of as the context extension +`(A : Ty).(a b : A) ->> (A : Ty) (a : A)`. -/ +@[simps] def dispTpUvPoly : UvPoly R (U0.ext U0.tp) U0.Tm := + ⟨U0.disp U0.tp, U0.disp_mem _⟩ + +/-- `dispIdUvPoly` promotes the map `U1.disp ii.Id` to a `UvPoly`, +which we can compose with `dispTpUvPoly` to make `iUvPoly` +Informally thought of as the context extension +`(A : Ty).(a b : A).(p : Id(a,b)) ->> (A : Ty) (a b : A)`. -/ +@[simps] def dispIdUvPoly : UvPoly R (U1.ext ii.Id) (U0.ext U0.tp) := + ⟨U1.disp ii.Id, U1.disp_mem _⟩ + +/-- `(U1.ext ii.Id)` over `Tm` can be informally thought of as the context extension +`(A : Ty).(a b : A).(p : Id(a,b)) ->> (A : Ty) (a : A)`. +This is defined by the composition of (maps informally thought of as) context extensions +`(A : Ty).(a b : A).(p : Id(a,b)) ->> (A : Ty).(a b : A) ->> (A : Ty).(a : A)` +This is the signature for a polynomial functor `iUvPoly` on the presheaf category `Ctx`. +-/ +abbrev iUvPoly : UvPoly R (U1.ext ii.Id) U0.Tm := + (dispIdUvPoly ii).vcomp IdIntro.dispTpUvPoly + +instance : R.IsStableUnderPushforwardsAlong ii.iUvPoly.p := + UvPoly.isStableUnderPushforwardsAlong_vcomp (U1.disp_mem _) (U0.disp_mem _) + +instance : MorphismProperty.HasPushforwardsAlong R ii.iUvPoly.p := + UvPoly.hasPushforwardsAlong_vcomp (U1.disp_mem _) (U0.disp_mem _) + +instance : R.HasPushforwardsAlong (UvPoly.id R U0.Tm).p := + MorphismProperty.HasPushforwards.hasPushforwardsAlong _ (R.id_mem _) + +instance : R.IsStableUnderPushforwardsAlong (UvPoly.id R U0.Tm).p := + MorphismProperty.IsStableUnderPushforwards.of_isPushforward _ (R.id_mem _) + +/-- Consider the comparison map `comparison : Tm ⟶ i` in the slice over `Tm`. +Then the contravariant action `UVPoly.verticalNatTrans` of taking `UvPoly` on a slice +results in a natural transformation `P_iOver ⟶ P_(𝟙 Tm)` +between the polynomial endofunctors `iUvPoly` and `UvPoly.id U0.Tm` respectively. + + comparison + Tm ----> i + \ / + 𝟙\ / `iUvPoly` + V V + Tm +-/ +def verticalNatTrans : ii.iUvPoly.functor ⟶ (UvPoly.id R U0.Tm).functor := + UvPoly.verticalNatTrans (UvPoly.id R U0.Tm) (iUvPoly ii) + (comparison ii) (by simp [iUvPoly]) + +end IdIntro + +open IdIntro + +/-- In the high-tech formulation by Richard Garner and Steve Awodey: +The full structure interpreting the natural model semantics for identity types +requires an `IdIntro`, +(and `IdElimBase` which can be generated by pullback in the presheaf category,) +and that the following commutative square generated by +`IdBaseComparison.verticalNatTrans` is a weak pullback. + +``` + verticalNatTrans.app Tm +iFunctor Tm --------> P_𝟙Tm Tm + | | + | | +iFunctor tp P_𝟙Tm tp + | | + | | + V V +iFunctor Ty --------> P_𝟙Tm Ty + verticalNatTrans.app Ty +``` + +This can be thought of as saying the following. +Fix `A : Ty` and `a : A` - we are working in the slice over `U0.Tm`. +For any context `Γ`, any map `(a, r) : Γ → P_𝟙Tm Tm` +and `(a, C) : Γ ⟶ iFunctor Ty` such that `r ≫ U0.tp = C[x/y, refl_x/p]`, +there is a map `(a,c) : Γ ⟶ iFunctor Tm` such that `c ≫ U0.tp = C` and `c[a/y, refl_a/p] = r`. +Here we are thinking + `Γ (y : A) (p : A) ⊢ C : Ty` + `Γ ⊢ r : C[a/y, refl_a/p]` + `Γ (y : A) (p : A) ⊢ c : Ty` +This witnesses the elimination principle for identity types since +we can take `J (y.p.C;x.r) := c`. +-/ +structure Id (ii : IdIntro U0 U1) (U2 : StructuredUniverse R) where + weakPullback : WeakPullback + ((verticalNatTrans ii).app U2.Tm) + (ii.iUvPoly.functor.map U2.tp) + ((UvPoly.id R U0.Tm).functor.map U2.tp) + ((verticalNatTrans ii).app U2.Ty) + +/-- The additional condition that the weak pullback structure +provided by `Id` is coherent. +We can always replace a weak pullback with a coherent one +(see `coherentId` below), +so this condition is optional, in a sense. -/ +class Id.IsCoherent {ii : IdIntro U0 U1} {U2 : StructuredUniverse R} + (id : Id ii U2) where + isCoherent : WeakPullback.IsCoherent id.weakPullback + +instance {ii : IdIntro U0 U1} {U2 : StructuredUniverse R} : + HasPullback ((UvPoly.id R U0.Tm).functor.map U2.tp) (ii.verticalNatTrans.app U2.Ty) := + sorry + +/-- `coherentId` replaces an identity type structure that has possibly +non-coherent/non-substitution-stable elimination with a new identity type +that has coherent/substitution-stable elimination. -/ +def coherentId {ii : IdIntro U0 U1} (id : Id ii U2) : Id ii U2 where + weakPullback := (id.weakPullback.coherent) + +/-! ## From structured identity types to unstructured identity types -/ + +namespace IdIntro + +variable (ii : IdIntro U0 U1) {Γ : Ctx} + +/-- The substitution `a0.a1 : Γ → Tm.tp`. -/ +abbrev endpts (a0 a1 : Γ ⟶ U0.Tm) (h : a0 ≫ U0.tp = a1 ≫ U0.tp) : Γ ⟶ U0.ext U0.tp := + (U0.disp_pullback U0.tp).lift a1 a0 h.symm + +def toUnstructured : + U0.toUnstructuredUniverse.PolymorphicIdIntro U1.toUnstructuredUniverse where + Id a0 a1 a0_tp a1_tp := + endpts a0 a1 (by simp[a0_tp,a1_tp]) ≫ ii.Id + Id_comp σ A a0 a1 a0_tp a1_tp := by + simp only [← Category.assoc] + congr 1 + apply (U0.disp_pullback U0.tp).hom_ext <;> simp + refl a _ := a ≫ ii.refl + refl_comp σ A a h := by simp + refl_tp a a_tp := by + simp only [Category.assoc, ii.refl_tp] + simp only [← Category.assoc] + congr 1 + apply (U0.disp_pullback U0.tp).hom_ext <;> simp + +variable {Γ : Ctx} {A : Γ ⟶ U0.Ty} {a : Γ ⟶ U0.Tm} (a_tp : a ≫ U0.tp = A) + +end IdIntro + +namespace Id + +variable (ii : IdIntro U0 U1) (id : Id ii U2) + +namespace toUnstructured + +variable {Γ : Ctx} {A : Γ ⟶ U0.Ty} {a : Γ ⟶ U0.Tm} (a_tp : a ≫ U0.tp = A) + +/- The pullback square +``` + Γ --------> Tm + ‖ ‖ + ‖ (pb) ‖ 𝟙_Tm + ‖ ‖ + ‖ ‖ + Γ --------> Tm + a +``` +-/ +lemma idPb (U0 : StructuredUniverse R) (a : Γ ⟶ U0.Tm) : + IsPullback (𝟙 Γ) a a (UvPoly.id R U0.Tm).p := + have : IsIso (UvPoly.id R U0.Tm).p := by simp; infer_instance + IsPullback.of_horiz_isIso (by simp) + +/-- +`toExtTp` is the substitution, +`toExtId` is the substitution, +`toExtTpPb` is the pullback square, +and `toExtIdPb` is the pullback square in the following +``` + Γ ---------- a --------------> Tm + | | + | |disp + | | + V V +Γ.(x:A).(p:Id(a,x)) --- toExtId ----> U1.ext ii.Id + | | + | (toExtIdPb) |disp + | | + V V +Γ.(x:A) ------------- toExtTp ------> U0.ext U0.tp + | | + | (toExtTpPb) |disp + | | + V V + Γ ---------- a --------------> Tm +``` +The pullback `toExtIdPb'` is the vertical pasting of `toExtIdPb` and `toExtTpPb` +-/ +abbrev toExtTp : U0.ext A ⟶ U0.ext U0.tp := + endpts (U0.disp A ≫ a) (U0.var A) (by simp[a_tp]) + +@[inherit_doc toExtTp] +abbrev toExtId : ii.toUnstructured.motiveCtx a a_tp ⟶ U1.ext ii.Id := + (U1.disp_pullback ii.Id).lift (U1.var _) (U1.disp _ ≫ toExtTp a_tp) + (by simp [toUnstructured, toExtTp]) + +@[inherit_doc toExtTp] +lemma toExtTpPb : IsPullback (toExtTp a_tp) (U0.disp _) (U0.disp _) a := + CategoryTheory.IsPullback.of_right (by simpa [a_tp] using U0.disp_pullback _) (by simp) + (U0.disp_pullback _) + +@[inherit_doc toExtTp] +lemma toExtIdPb : IsPullback (toExtId ii a_tp) (U1.disp _) (U1.disp _) (toExtTp a_tp) := + CategoryTheory.IsPullback.of_right (by simpa using U1.disp_pullback _) + (by simp) (U1.disp_pullback ii.Id) + +lemma toExtIdPb' : IsPullback (toExtId ii a_tp) (U1.disp _ ≫ U0.disp A) + (U1.disp _ ≫ U0.disp U0.tp) a := + IsPullback.paste_vert (toExtIdPb ii a_tp) (toExtTpPb a_tp) + +variable (C : ii.toUnstructured.motiveCtx a a_tp ⟶ U2.Ty) (c : Γ ⟶ U2.Tm) + +variable (a) in +/-- +For defining `toIUvPolyTm = (a,j)` into the weak pullback, +we define `toUvPolyIdTm = (a,c)`, `toIUvPolyTy = (a,C)` in the following +``` + (a,c) +Γ -------------------------> + ↘ (a,j) +| verticalNatTrans.app Tm +| P_i Tm --------> P_𝟙Tm Tm +| | | +(a,C) | | +| P_i tp P_𝟙Tm tp +| | | +| | | +| V V +V P_i Ty --------> P_𝟙Tm Ty + verticalNatTrans.app Ty +``` +-/ +abbrev toUvPolyIdTm : Γ ⟶ (UvPoly.id R U0.Tm).functor.obj U2.Tm := + UvPoly.Equiv.mk' a (idPb U0 a) c + +@[inherit_doc toUvPolyIdTm] +abbrev toIUvPolyTy : Γ ⟶ ii.iUvPoly.functor.obj U2.Ty := + UvPoly.Equiv.mk' a (toExtIdPb' ii a_tp).flip C + +variable {ii} {c} (c_tp : c ≫ U2.tp = ii.toUnstructured.reflSubst a a_tp ≫ C) + + +lemma toIUvPolyTm_aux_fst : + UvPoly.Equiv.fst (UvPoly.Equiv.mk' a (idPb U0 a) c ≫ + (UvPoly.id R U0.Tm).functor.map U2.tp) = a := by + simp[UvPoly.Equiv.fst_comp_right] + --Q: how does it figure out the behavior of id-induced poly? --Ah it does not have to + +-- lemma mk'_verticalNatTrans : +-- (UvPoly.Equiv.mk' a ⋯ C ≫ ii.verticalNatTrans.app U2.Ty) = +-- UvPoly.Equiv.mk' a + +lemma toIUvPolyTm_aux: + toUvPolyIdTm a c ≫ (UvPoly.id R U0.Tm).functor.map U2.tp = + toIUvPolyTy ii a_tp C ≫ ii.verticalNatTrans.app U2.Ty := by + fapply CategoryTheory.UvPoly.Equiv.ext' (idPb ..) + · simp[toUvPolyIdTm,] -- why UvPoly.Equiv.fst_mk' not automatic? + convert_to a = UvPoly.Equiv.fst (toIUvPolyTy ii a_tp C ≫ ii.verticalNatTrans.app U2.Ty) + · apply toIUvPolyTm_aux_fst + simp[toIUvPolyTy,verticalNatTrans] + simp[UvPoly.fst_verticalNatTrans_app] + --Q: does verticalNaturalTrans deserve a specific ii-ver? + -- have e: + -- UvPoly.Equiv.mk' a (id ..) c ≫ (UvPoly.id R U0.Tm).functor.map U2.tp = + -- UvPoly.Equiv.mk' a (id ..) C := sorry + + · simp[verticalNatTrans,toIUvPolyTy] + rw[UvPoly.Equiv.snd'_comp_right + (H := by + convert (idPb U0 a) --how do I know it requires indenting like this...? + · simp[UvPoly.Equiv.fst_comp_right] + · simp[])] + -- rw[UvPoly.snd'_verticalNatTrans_app + -- (P := (UvPoly.id R U0.Tm)) (Q := ii.iUvPoly) + -- (H' := by + -- convert (idPb U0 a) + -- · simp[UvPoly.Equiv.fst_comp_right] + -- · simp[]) + -- (ρ := ii.comparison) + -- (h := by simp) + -- (H := by + -- convert (toExtIdPb' ii a_tp)) + + -- ] + simp[UvPoly.snd'_verticalNatTrans_app] + sorry + +-- previously called `toWeakpullback` +@[inherit_doc toUvPolyIdTm] +abbrev toIUvPolyTm : Γ ⟶ ii.iUvPoly.functor.obj U2.Tm := + id.weakPullback.lift (toUvPolyIdTm a c) (toIUvPolyTy ii a_tp C) + (by + have := c_tp -- TODO: remove + apply toIUvPolyTm_aux) + +lemma fst_toIUvPolyTm : UvPoly.Equiv.fst (toIUvPolyTm id a_tp C c_tp) = a := + calc + _ = UvPoly.Equiv.fst (toIUvPolyTm id a_tp C c_tp ≫ ii.iUvPoly.functor.map U2.tp) := by + rw [UvPoly.Equiv.fst_comp_right] + _ = _ := by simp + +def j : ii.toUnstructured.motiveCtx a a_tp ⟶ U2.Tm := + UvPoly.Equiv.snd' (toIUvPolyTm id a_tp C c_tp) + (by convert (toExtIdPb' ii a_tp).flip; apply fst_toIUvPolyTm) + +end toUnstructured + +open toUnstructured + +def toUnstructured [id.IsCoherent] : + UnstructuredUniverse.PolymorphicIdElim (ii.toUnstructured) + U2.toUnstructuredUniverse where + j a a_tp C c c_tp := j id a_tp C c_tp + comp_j σ A a a_tp C c c_tp := by + have e := id.IsCoherent + + sorry -- NOTE: this will need [id.IsCoherent] + j_tp := by + intro Γ A a a_tp C c c_tp + simp[j] + sorry + reflSubst_j := sorry + +end Id + +/-! ## From unstructured identity types to structured identity types -/ + +namespace IdIntro + +variable (ii : PolymorphicIdIntro U0.toUnstructuredUniverse U1.toUnstructuredUniverse) + +namespace ofUnstructured + +def IdApp {Γ} (α : Γ ⟶ U0.ext U0.tp) : Γ ⟶ U1.Ty := + ii.Id (α ≫ U0.disp _) (α ≫ U0.var _) rfl (by simp) + +lemma IdApp_comp {Δ Γ} (σ : Δ ⟶ Γ) (α : Γ ⟶ U0.ext U0.tp) : + IdApp ii (σ ≫ α) = σ ≫ IdApp ii α := by + simp[IdApp,ii.Id_comp] + +def reflApp {Γ} (a : Γ ⟶ U0.Tm) : Γ ⟶ U1.Tm := + ii.refl a rfl + +lemma reflApp_comp {Δ Γ} (σ : Δ ⟶ Γ) (A : Γ ⟶ U0.Tm) : + reflApp ii (σ ≫ A) = σ ≫ reflApp ii A := by + simp[reflApp,← ii.refl_comp] + +lemma reflApp_tp {Γ} (ab : Γ ⟶ U0.Tm) : reflApp ii ab ≫ U1.tp = IdApp ii (ab ≫ U0.diag) := by + simp[reflApp,ii.refl_tp,IdApp] + +end ofUnstructured + +open ofUnstructured + +def ofUnstructured : IdIntro U0 U1 where + Id := ofYoneda (IdApp ii) (IdApp_comp _) + refl := ofYoneda (reflApp ii) (reflApp_comp _) + refl_tp := by apply ofYoneda_comm_sq; simp [reflApp_tp] + +end IdIntro + +namespace Id + +variable {ii : PolymorphicIdIntro U0.toUnstructuredUniverse U1.toUnstructuredUniverse} + (ie : PolymorphicIdElim ii U2.toUnstructuredUniverse) + +namespace ofUnstructured + +variable {Γ : Ctx} (toUvPolyIdTm : Γ ⟶ (UvPoly.id R U0.Tm).functor.obj U2.Tm) + (toIUvPolyTy : Γ ⟶ (IdIntro.ofUnstructured ii).iUvPoly.functor.obj U2.Ty) + (toUvPolyIdTm_uvPolyIdTp : toUvPolyIdTm ≫ (UvPoly.id R U0.Tm).functor.map U2.tp = + toIUvPolyTy ≫ (IdIntro.ofUnstructured ii).verticalNatTrans.app U2.Ty) + +/-- +For defining `lift = (a,j)` into `P_i Tm = (IdIntro.ofUnstructured ii).iUvPoly.functor.obj U2.Tm`, +consider the following diagram +``` + (a,c) +Γ -------------------------> + ↘ (a,j) +| verticalNatTrans.app Tm +| P_i Tm --------> P_𝟙Tm Tm +| | | +(a,C) | | +| P_i tp P_𝟙Tm tp +| | | +| | | +| V V +V P_i Ty --------> P_𝟙Tm Ty + verticalNatTrans.app Ty +``` +In the following lemmas we will have +`toUvPolyIdTm = (a,c)`, `toIUvPolyTy = (a,C)`, +and `endpoint = a : Γ → Tm`. -/ +def endpoint : Γ ⟶ U0.Tm := UvPoly.Equiv.fst toIUvPolyTy + +/-- +`toExtTp` is the substitution, +`toExtId` is the substitution, +`toExtTpPb` is the pullback square, +and `toExtIdPb` is the pullback square in the following +``` + Γ ---------- a --------------> Tm + | | + | |disp + | | + V V +Γ.(x:A).(p:Id(a,x)) --- toExtId ----> U1.ext ii.Id + | | + | (toExtIdPb) |disp + | | + V V +Γ.(x:A) ------------- toExtTp ------> U0.ext U0.tp + | | + | (toExtTpPb) |disp + | | + V V + Γ ---------- a --------------> Tm +``` +The pullback `toExtIdPb'` is the vertical pasting of `toExtIdPb` and `toExtTpPb` +-/ +abbrev toExtTp : U0.ext (endpoint toIUvPolyTy ≫ U0.tp) ⟶ U0.ext U0.tp := + endpts (U0.disp _ ≫ endpoint toIUvPolyTy) (U0.var _) (by simp) + +@[simp] +lemma toExtTp_Id : toExtTp toIUvPolyTy ≫ (ofUnstructured ii).Id = + ii.Id (U0.disp (endpoint toIUvPolyTy ≫ U0.tp) ≫ + endpoint toIUvPolyTy) (U0.var _) rfl (by simp) := by + simp [ofUnstructured, ofUnstructured.IdApp] + +@[inherit_doc toExtTp] +abbrev toExtId : ii.motiveCtx (endpoint toIUvPolyTy) rfl ⟶ U1.ext (ofUnstructured ii).Id := + (U1.disp_pullback _).lift (U1.var _) (U1.disp _ ≫ toExtTp toIUvPolyTy) (by simp) + +@[inherit_doc toExtTp] +lemma toExtTpPb : IsPullback (toExtTp toIUvPolyTy) (U0.disp _) (U0.disp _) (endpoint toIUvPolyTy) := + CategoryTheory.IsPullback.of_right (by simpa using U0.disp_pullback _) (by simp) + (U0.disp_pullback _) + +@[inherit_doc toExtTp] +lemma toExtIdPb : IsPullback (toExtId toIUvPolyTy) (U1.disp _) (U1.disp _) (toExtTp toIUvPolyTy) := + CategoryTheory.IsPullback.of_right (by simpa using U1.disp_pullback _) + (by simp) (U1.disp_pullback (ofUnstructured ii).Id) + +lemma toExtIdPb' : IsPullback (toExtId toIUvPolyTy) (U1.disp _ ≫ U0.disp _) + (U1.disp _ ≫ U0.disp U0.tp) (endpoint toIUvPolyTy) := + IsPullback.paste_vert (toExtIdPb toIUvPolyTy) (toExtTpPb toIUvPolyTy) + +-- TODO: maybe move `toUnstructured.toExtIdPb'` out of its current namespace, +-- since it is general enough to used here +def motive : ii.motiveCtx (endpoint toIUvPolyTy) rfl ⟶ U2.Ty := + UvPoly.Equiv.snd' toIUvPolyTy (toExtIdPb' toIUvPolyTy).flip + +def reflCase : Γ ⟶ U2.Tm := + UvPoly.Equiv.snd' toUvPolyIdTm (toUnstructured.idPb U0 (UvPoly.Equiv.fst toUvPolyIdTm)) + +variable {toIUvPolyTy} {toUvPolyIdTm} + +include toUvPolyIdTm_uvPolyIdTp in -- TODO: remove +lemma reflCase_tp : reflCase toUvPolyIdTm ≫ U2.tp = + ii.reflSubst (endpoint toIUvPolyTy) rfl ≫ motive toIUvPolyTy := + have := toUvPolyIdTm_uvPolyIdTp -- TODO: remove + --also need verticalNatTrans + sorry + +def j : ii.motiveCtx (endpoint toIUvPolyTy) rfl ⟶ U2.Tm := + ie.j (endpoint toIUvPolyTy) rfl (motive toIUvPolyTy) (reflCase toUvPolyIdTm) + (reflCase_tp toUvPolyIdTm_uvPolyIdTp) + +@[inherit_doc endpoint] +def lift : Γ ⟶ (IdIntro.ofUnstructured ii).iUvPoly.functor.obj U2.Tm := + UvPoly.Equiv.mk' (endpoint toIUvPolyTy) + (toExtIdPb' toIUvPolyTy).flip (j ie toUvPolyIdTm_uvPolyIdTp) + +end ofUnstructured + +open ofUnstructured + +def ofUnstructured : Id (IdIntro.ofUnstructured ii) U2 where + weakPullback := + { w := by simp only [NatTrans.naturality] + lift _ _ toUvPolyIdTm_uvPolyIdTp := lift ie toUvPolyIdTm_uvPolyIdTp + lift_fst' := sorry + lift_snd' := sorry } + +instance : (Id.ofUnstructured ie).IsCoherent := sorry + +end Id + +end + +end StructuredUniverse diff --git a/HoTTLean/Model/Structured/StructuredUniverseBackup.lean b/HoTTLean/Model/Structured/StructuredUniverseBackup.lean new file mode 100644 index 00000000..86fb6f81 --- /dev/null +++ b/HoTTLean/Model/Structured/StructuredUniverseBackup.lean @@ -0,0 +1,2212 @@ +import Mathlib.CategoryTheory.Limits.Shapes.KernelPair +import HoTTLean.ForMathlib +import HoTTLean.ForMathlib.Tactic.CategoryTheory.FunctorMap +import HoTTLean.ForMathlib.CategoryTheory.RepPullbackCone +import HoTTLean.ForMathlib.CategoryTheory.WeakPullback +import HoTTLean.ForMathlib.CategoryTheory.Polynomial +import HoTTLean.Model.Unstructured.UnstructuredUniverse +import Mathlib.CategoryTheory.Limits.Shapes.BinaryProducts +universe v u + +noncomputable section + +open CategoryTheory Limits Opposite + +namespace Model + +/-- A natural model with support for dependent types (and nothing more). +The data is a natural transformation with representable fibers, +stored as a choice of representative for each fiber. -/ +structure StructuredUniverse {Ctx : Type u} [Category Ctx] (R : MorphismProperty Ctx) + extends UnstructuredUniverse Ctx where + morphismProperty : R tp + +namespace StructuredUniverse + +open Model.UnstructuredUniverse + +variable {Ctx : Type u} [Category Ctx] {R : MorphismProperty Ctx} (M : StructuredUniverse R) + [R.HasPullbacks] [R.IsStableUnderBaseChange] + +instance {Γ : Ctx} (A : Γ ⟶ M.Ty) : HasPullback A M.tp := + have := MorphismProperty.HasPullbacks.hasPullback A M.morphismProperty + hasPullback_symmetry _ _ + +@[simps! hom inv] +def pullbackIsoExt {Γ : Ctx} (A : Γ ⟶ M.Ty) : + pullback A M.tp ≅ (M.ext A) := + IsPullback.isoPullback (M.disp_pullback A).flip |>.symm + +/-! ## Pullback of representable natural transformation -/ + +/-- Pull a natural model back along a type. -/ +protected def pullback {Γ : Ctx} (A : Γ ⟶ M.Ty) : StructuredUniverse R where + __ := UnstructuredUniverse.pullback M.toUnstructuredUniverse A + morphismProperty := R.of_isPullback (disp_pullback ..) M.morphismProperty + +/-- + Given the pullback square on the right, + with a natural model structure on `tp : Tm ⟶ Ty` + giving the outer pullback square. + + Γ.A -.-.- var -.-,-> E ------ toTm ------> Tm + | | | + | | | + M.disp π tp + | | | + V V V + Γ ------- A -------> U ------ toTy ------> Ty + + construct a natural model structure on `π : E ⟶ U`, + by pullback pasting. +-/ +def ofIsPullback {U E : Ctx} {π : E ⟶ U} + {toTy : U ⟶ M.Ty} {toTm : E ⟶ M.Tm} + (pb : IsPullback toTm π M.tp toTy) : + StructuredUniverse R where + __ := UnstructuredUniverse.ofIsPullback M.toUnstructuredUniverse pb + morphismProperty := R.of_isPullback pb M.morphismProperty + +/-! ## Polynomial functor on `tp` + +Specializations of results from the `Poly` package to natural models. -/ + +abbrev uvPolyTp : UvPoly R M.Tm M.Ty := ⟨M.tp, M.morphismProperty⟩ + +variable [ChosenTerminal Ctx] [R.HasObjects] [R.IsMultiplicative] + [R.HasPushforwards R] [R.IsStableUnderPushforwards R] + +instance : R.HasPushforwardsAlong M.uvPolyTp.p := + MorphismProperty.HasPushforwards.hasPushforwardsAlong M.tp M.morphismProperty + +instance : R.IsStableUnderPushforwardsAlong M.uvPolyTp.p := + MorphismProperty.IsStableUnderPushforwards.of_isPushforward M.tp M.morphismProperty + +def Ptp : Ctx ⥤ Ctx := M.uvPolyTp.functor + +namespace PtpEquiv + +variable {Γ : Ctx} {X : Ctx} + +/-- +A map `(AB : Γ ⟶ M.Ptp.obj X)` is equivalent to a pair of maps +`A : Γ ⟶ M.Ty` and `B : (M.ext (fst M AB)) ⟶ X`, +thought of as a dependent pair `A : Type` and `B : A ⟶ Type`. +`PtpEquiv.fst` is the `A` in this pair. +-/ +def fst (AB : Γ ⟶ M.Ptp.obj X) : Γ ⟶ M.Ty := + UvPoly.Equiv.fst AB + +/-- +A map `(AB : Γ ⟶ M.Ptp.obj X)` is equivalent to a pair of maps +`A : Γ ⟶ M.Ty` and `B : (M.ext (fst M AB)) ⟶ X`, +thought of as a dependent pair `A : Type` and `B : A ⟶ Type` +`PtpEquiv.snd` is the `B` in this pair. +-/ +def snd (AB : Γ ⟶ M.Ptp.obj X) (A := fst M AB) (eq : fst M AB = A := by rfl) : M.ext A ⟶ X := + UvPoly.Equiv.snd' AB (by rw [← fst, eq]; exact (M.disp_pullback _).flip) + +/-- +A map `(AB : Γ ⟶ M.Ptp.obj X)` is equivalent to a pair of maps +`A : Γ ⟶ M.Ty` and `B : (M.ext (fst M AB)) ⟶ X`, +thought of as a dependent pair `A : Type` and `B : A ⟶ Type` +`PtpEquiv.mk` constructs such a map `AB` from such a pair `A` and `B`. +-/ +def mk (A : Γ ⟶ M.Ty) (B : M.ext A ⟶ X) : Γ ⟶ M.Ptp.obj X := + UvPoly.Equiv.mk' A (M.disp_pullback _).flip B + +@[simp] +lemma fst_mk (A : Γ ⟶ M.Ty) (B : M.ext A ⟶ X) : + fst M (mk M A B) = A := by + simp [fst, mk] + +@[simp] +lemma snd_mk (A : Γ ⟶ M.Ty) (B : M.ext A ⟶ X) : + snd M (mk M A B) _ (fst_mk ..) = B := by + dsimp only [snd, mk] + rw! [UvPoly.Equiv.snd'_mk' (P := M.uvPolyTp)] + +section +variable {Δ : Ctx} {σ : Δ ⟶ Γ} {AB : Γ ⟶ M.Ptp.obj X} + +theorem fst_comp_left (σ : Δ ⟶ Γ) : fst M (σ ≫ AB) = σ ≫ fst M AB := + UvPoly.Equiv.fst_comp_left .. + +@[simp] +theorem fst_comp_right {Y} (σ : X ⟶ Y) : fst M (AB ≫ M.Ptp.map σ) = fst M AB := + UvPoly.Equiv.fst_comp_right .. + +theorem snd_comp_right {Y} (σ : X ⟶ Y) {A} (eq : fst M AB = A) : + snd M (AB ≫ M.Ptp.map σ) _ (by simpa) = snd M AB _ eq ≫ σ := by + simp only [snd, Ptp] + rw [UvPoly.Equiv.snd'_comp_right (P := M.uvPolyTp)] + +theorem snd_comp_left {A} (eqA : fst M AB = A) {σA} (eqσ : σ ≫ A = σA) : + snd M (σ ≫ AB) σA (by simp [fst_comp_left, eqA, eqσ]) = + (M.substWk σ _ _ eqσ) ≫ snd M AB _ eqA := by + have H1 : IsPullback (M.disp A) (M.var A) (UvPoly.Equiv.fst AB) M.tp := by + rw [← fst, eqA]; exact (M.disp_pullback _).flip + have H2 : IsPullback (M.disp σA) (M.var σA) + (σ ≫ UvPoly.Equiv.fst AB) M.tp := by + rw [← fst, eqA, eqσ]; exact (M.disp_pullback _).flip + convert UvPoly.Equiv.snd'_comp_left AB H1 _ H2 + apply H1.hom_ext <;> simp [substWk] + +theorem mk_comp_left {Δ Γ : Ctx} (M : StructuredUniverse R) (σ : Δ ⟶ Γ) + {X : Ctx} (A : Γ ⟶ M.Ty) (σA) (eq : σ ≫ A = σA) (B : (M.ext A) ⟶ X) : + σ ≫ PtpEquiv.mk M A B = PtpEquiv.mk M σA ((M.substWk σ A _ eq) ≫ B) := by + dsimp [PtpEquiv.mk] + have h := UvPoly.Equiv.mk'_comp_left (P := M.uvPolyTp) A (f := M.disp A) (g := M.var A) + (by convert (M.disp_pullback A).flip) B σ σA eq (M.disp_pullback σA).flip + convert h + apply (M.disp_pullback _).hom_ext + · simp + · simp [substWk_disp] + +theorem mk_comp_right {Γ : Ctx} (M : StructuredUniverse R) + {X Y : Ctx} (σ : X ⟶ Y) (A : Γ ⟶ M.Ty) (B : (M.ext A) ⟶ X) : + PtpEquiv.mk M A B ≫ M.Ptp.map σ = PtpEquiv.mk M A (B ≫ σ) := + UvPoly.Equiv.mk'_comp_right .. + +theorem ext {AB AB' : Γ ⟶ M.Ptp.obj X} (A := fst M AB) (eq : fst M AB = A := by rfl) + (h1 : fst M AB = fst M AB') (h2 : snd M AB A eq = snd M AB' A (h1 ▸ eq)) : + AB = AB' := UvPoly.Equiv.ext' _ h1 h2 + +theorem eta (AB : Γ ⟶ M.Ptp.obj X) : mk M (fst M AB) (snd M AB) = AB := + .symm <| ext _ _ rfl (by simp) (by simp) + +end + +end PtpEquiv + +@[reassoc] +theorem PtpEquiv.mk_map {Γ : Ctx} {X Y : Ctx} + (A : Γ ⟶ M.Ty) (x : (M.ext A) ⟶ X) (α : X ⟶ Y) : + mk M A x ≫ M.Ptp.map α = mk M A (x ≫ α) := by + simp [mk, Ptp, UvPoly.Equiv.mk'_comp_right] + +/-! ## Polynomial composition `M.tp ▸ N.tp` -/ + +abbrev compDom (M N : StructuredUniverse R) : Ctx := M.uvPolyTp.compDom N.uvPolyTp + +abbrev compP (M N : StructuredUniverse R) : M.compDom N ⟶ M.uvPolyTp @ N.Ty := + (M.uvPolyTp.comp N.uvPolyTp).p + +namespace compDomEquiv +open UvPoly + +variable {M N : StructuredUniverse R} {Γ Δ : Ctx} (σ : Δ ⟶ Γ) + +/-- Universal property of `compDom`, decomposition (part 1). + +A map `ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +`fst, dependent, snd` such that `fst_tp` and `snd_tp`. The map `fst : Γ ⟶ M.Tm` +is the `(a : A)` in `(a : A) × (b : B a)`. +-/ +abbrev fst (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : Γ ⟶ M.Tm := + UvPoly.compDomEquiv.fst ab + +/-- Computation of `comp` (part 1). + +`fst_tp` is (part 1) of the computation that + (α, B, β, h) + Γ ⟶ compDom + \ | + \ | comp +(α ≫ tp, B) | + \ V + > P_tp Ty +Namely the first projection `α ≫ tp` agrees. +-/ +theorem fst_tp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : + fst ab ≫ M.tp = PtpEquiv.fst M (ab ≫ M.compP N) := + UvPoly.compDomEquiv.fst_comp_p .. + +@[reassoc] +theorem fst_comp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) (σ : Δ ⟶ Γ) : + fst (σ ≫ ab) = σ ≫ fst ab := + UvPoly.compDomEquiv.fst_comp .. + +/-- Universal property of `compDom`, decomposition (part 2). + +A map `ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +`fst, dependent, snd` such that `fst_tp` and `snd_tp`. +The map `dependent : (M.ext (fst N ab ≫ M.tp)) ⟶ M.Ty` +is the `B : A ⟶ Type` in `(a : A) × (b : B a)`. +Here `A` is implicit, derived by the typing of `fst`, or `(a : A)`. +-/ +def dependent (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + (A := fst ab ≫ M.tp) (eq : fst ab ≫ M.tp = A := by rfl) : + (M.ext A) ⟶ N.Ty := + UvPoly.compDomEquiv.dependent ab (M.disp A) (M.var A) <| by + simpa [eq] using (M.disp_pullback A).flip + +lemma dependent_eq (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + (A := fst ab ≫ M.tp) (eq : fst ab ≫ M.tp = A := by rfl) : + dependent ab A eq = PtpEquiv.snd M (ab ≫ M.compP N) A (by simp [← eq, fst_tp]) := by + simp [dependent, UvPoly.compDomEquiv.dependent, PtpEquiv.snd] + +theorem comp_dependent (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + {A} (eq1 : fst ab ≫ M.tp = A) + {σA} (eq2 : σ ≫ A = σA) : + (M.substWk σ _ _ eq2) ≫ dependent ab A eq1 = + dependent (σ ≫ ab) σA (by simp [fst_comp, eq1, eq2]) := by + dsimp [dependent] + rw [UvPoly.compDomEquiv.dependent_comp σ ab (M.disp A) (M.var A) + (by simpa [eq1] using (M.disp_pullback A).flip)] + · congr 1 + simp [substWk, substCons] + apply (M.disp_pullback A).hom_ext <;> simp + +/-- Universal property of `compDom`, decomposition (part 3). + +A map `ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +`fst, dependent, snd` such that `fst_tp` and `snd_tp`. +The map `snd : Γ ⟶ M.Tm` +is the `(b : B a)` in `(a : A) × (b : B a)`. +-/ +abbrev snd (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : Γ ⟶ N.Tm := + UvPoly.compDomEquiv.snd ab + +@[reassoc] +theorem snd_comp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) (σ : Δ ⟶ Γ) : + snd (σ ≫ ab) = σ ≫ snd ab := + UvPoly.compDomEquiv.snd_comp .. + +/-- Universal property of `compDom`, decomposition (part 4). + +A map `ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +`fst, dependent, snd` such that `fst_tp` and `snd_tp`. +The equation `snd_tp` says that the type of `b : B a` agrees with +the expression for `B a` obtained solely from `dependent`, or `B : A ⟶ Type`. +-/ +theorem snd_tp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + {A} (eq : fst ab ≫ M.tp = A := by rfl) : + snd ab ≫ N.tp = (M.sec _ (fst ab) eq) ≫ dependent ab A eq := by + rw [UvPoly.compDomEquiv.snd_comp_p ab (M.disp A) (M.var A) <| by + simpa [eq] using (M.disp_pullback A).flip] + congr 1 + apply (disp_pullback ..).hom_ext + · simp + · simp + +/-- Universal property of `compDom`, constructing a map into `compDom`. -/ +def mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : M.ext A ⟶ N.Ty) (β : Γ ⟶ N.Tm) + (h : β ≫ N.tp = M.sec _ α eq ≫ B) : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp := + UvPoly.compDomEquiv.mk _ α eq (M.disp A) (M.var A) (M.disp_pullback A).flip B β (by + convert h + apply (disp_pullback ..).hom_ext <;> simp) + +@[simp] +theorem fst_mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A := by rfl) (B : (M.ext A) ⟶ N.Ty) + (β : Γ ⟶ N.Tm) (h : β ≫ N.tp = (M.sec _ α eq) ≫ B) : fst (mk α eq B β h) = α := by + simp [mk, fst] + +@[simp] +theorem dependent_mk (α : Γ ⟶ M.Tm) {A A'} (eq : α ≫ M.tp = A) (hA' : A' = A) + (B : M.ext A ⟶ N.Ty) (β : Γ ⟶ N.Tm) + (h : β ≫ N.tp = (M.sec _ α eq) ≫ B) : + dependent (mk α eq B β h) A' (by simp [hA', fst_mk, eq]) = eqToHom (by rw [hA']) ≫ B := by + subst hA' + simp [mk, dependent] + +@[simp] +theorem snd_mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : (M.ext A) ⟶ N.Ty) (β : Γ ⟶ N.Tm) + (h : β ≫ N.tp = (M.sec _ α eq) ≫ B) : snd (mk α eq B β h) = β := by + simp [mk, snd] + +theorem ext {ab₁ ab₂ : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp} + {A} (eq : fst ab₁ ≫ M.tp = A) + (h1 : fst ab₁ = fst ab₂) + (h2 : dependent ab₁ A eq = dependent ab₂ A (h1 ▸ eq)) + (h3 : snd ab₁ = snd ab₂) : ab₁ = ab₂ := by + apply UvPoly.compDomEquiv.ext ab₁ ab₂ h1 h3 (M.disp _) (M.var _) (M.disp_pullback _).flip + dsimp only [dependent] at * + subst eq + rw! [h2] + +theorem comp_mk (α : Γ ⟶ M.Tm) {A} (e1 : α ≫ M.tp = A) (B : (M.ext A) ⟶ N.Ty) + (β : Γ ⟶ N.Tm) (e2 : β ≫ N.tp = (M.sec A α e1) ≫ B) (σ : Δ ⟶ Γ) {σA} (e3 : σ ≫ A = σA) : + σ ≫ mk α e1 B β e2 = + mk (σ ≫ α) (by simp [e1, e3]) + ((M.substWk σ A _ e3) ≫ B) (σ ≫ β) + (by simp [e2]; rw [← Category.assoc, comp_sec]; simp; congr!) := by + dsimp only [mk] + rw [UvPoly.compDomEquiv.comp_mk (P := M.uvPolyTp) (P' := N.uvPolyTp) σ _ α e1 (M.disp _) + (M.var _) (M.disp_pullback _).flip (M.disp _) (M.var _) (M.disp_pullback _).flip] + subst e1 e3 + congr 2 + apply (disp_pullback ..).hom_ext <;> simp [substWk_disp] + +@[reassoc] +lemma mk_comp (α : Γ ⟶ M.Tm) {A} (e1 : α ≫ M.tp = A) (B : (M.ext A) ⟶ N.Ty) + (β : Γ ⟶ N.Tm) (e2 : β ≫ N.tp = (M.sec A α e1) ≫ B) : + mk α e1 B β e2 ≫ M.compP N = PtpEquiv.mk M A B := by + erw [PtpEquiv.mk, UvPoly.compDomEquiv.mk_comp (P := M.uvPolyTp) (P' := N.uvPolyTp)] + +theorem eta (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + {A} (eq : fst ab ≫ M.tp = A) : + mk (fst ab) eq (dependent ab A eq) (snd ab) (snd_tp ab eq) = ab := by + symm; apply ext (eq := eq) <;> simp + +end compDomEquiv + +/-! ## Pi types -/ + +/-- The structure on three universes that for +`A : Γ ⟶ U0.Ty` and `B : Γ.A ⟶ U1.Ty` constructs a Π-type `Π_A B : Γ ⟶ U2.Ty`. +-/ +structure PolymorphicPi (U0 U1 U2 : StructuredUniverse R) where + Pi : U0.Ptp.obj U1.Ty ⟶ U2.Ty + lam : U0.Ptp.obj U1.Tm ⟶ U2.Tm + Pi_pullback : IsPullback lam (U0.Ptp.map U1.tp) U2.tp Pi + +set_option linter.dupNamespace false in +/-- A universe `M` has Π-type structure. This is the data of a pullback square +``` + lam +Ptp Tm ------> Tm + | | +Ptp tp |tp + | | + V V +Ptp Ty ------> Ty + Pi +``` +-/ +protected abbrev Pi := PolymorphicPi M M M + +namespace PolymorphicPi + +variable {U0 U1 U2 : StructuredUniverse R} {Γ : Ctx} + +section +variable (P : PolymorphicPi U0 U1 U2) + +/-- +``` +Γ ⊢₀ A Γ.A ⊢₁ B +----------------- +Γ ⊢₂ ΠA. B +``` -/ +def mkPi {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) : Γ ⟶ U2.Ty := + PtpEquiv.mk U0 A B ≫ P.Pi + +theorem comp_mkPi {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : (Γ) ⟶ U0.Ty) (σA) (eq : (σ) ≫ A = σA) + (B : (U0.ext A) ⟶ U1.Ty) : + (σ) ≫ P.mkPi A B = P.mkPi σA ((U0.substWk σ A _ eq) ≫ B) := by + simp [mkPi, ← Category.assoc, PtpEquiv.mk_comp_left (eq := eq)] + +/-- +``` +Γ ⊢₀ A Γ.A ⊢₁ t : B +------------------------- +Γ ⊢₂ λA. t : ΠA. B +``` -/ +def mkLam {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (t : (U0.ext A) ⟶ U1.Tm) : (Γ) ⟶ U2.Tm := + PtpEquiv.mk U0 A t ≫ P.lam + +@[simp] +theorem mkLam_tp {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (t : (U0.ext A) ⟶ U1.Tm) (t_tp : t ≫ U1.tp = B) : + P.mkLam A t ≫ U2.tp = P.mkPi A B := by + simp [mkLam, mkPi, P.Pi_pullback.w, PtpEquiv.mk_map_assoc, t_tp] + +theorem comp_mkLam {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : (Γ) ⟶ U0.Ty) (σA) (eq : (σ) ≫ A = σA) (t : (U0.ext A) ⟶ U1.Tm) : + (σ) ≫ P.mkLam A t = P.mkLam σA ((U0.substWk σ A _ eq) ≫ t) := by + simp [mkLam, ← Category.assoc, PtpEquiv.mk_comp_left (eq := eq)] + + +/-- +``` +Γ ⊢₀ A Γ ⊢₂ f : ΠA. B +----------------------------- +Γ.A ⊢₁ unlam f : B +``` -/ +def unLam {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + (U0.ext A) ⟶ U1.Tm := by + let total : (Γ) ⟶ U0.Ptp.obj U1.Tm := + P.Pi_pullback.lift f (PtpEquiv.mk U0 A B) f_tp + refine PtpEquiv.snd U0 total _ ?_ + have eq : total ≫ U0.Ptp.map U1.tp = PtpEquiv.mk U0 A B := + (P.Pi_pullback).lift_snd .. + apply_fun PtpEquiv.fst U0 at eq + rw [PtpEquiv.fst_comp_right] at eq + simpa using eq + +@[simp] +theorem unLam_tp {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + P.unLam A B f f_tp ≫ U1.tp = B := by + rw [unLam, ← PtpEquiv.snd_comp_right] + convert PtpEquiv.snd_mk U0 A B using 2; simp + +theorem comp_unLam {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : (Γ) ⟶ U0.Ty) (σA) (eq : (σ) ≫ A = σA) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + (U0.substWk σ A _ eq) ≫ P.unLam A B f f_tp = + P.unLam σA ((U0.substWk σ A _ eq) ≫ B) + ((σ) ≫ f) (by simp [eq, f_tp, comp_mkPi]) := by + simp [unLam] + rw [← PtpEquiv.snd_comp_left] + simp [PtpEquiv.snd, UvPoly.Equiv.snd'_eq]; congr 1 + apply pullback.hom_ext <;> simp; congr 1 + apply (P.Pi_pullback).hom_ext <;> simp + rw [PtpEquiv.mk_comp_left] + +/-- +``` +Γ ⊢₂ f : ΠA. B Γ ⊢₀ a : A +--------------------------------- +Γ ⊢₁ f a : B[id.a] +``` -/ +def mkApp {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) + (a : (Γ) ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) : (Γ) ⟶ U1.Tm := + (U0.sec A a a_tp) ≫ P.unLam A B f f_tp + +@[simp] +theorem mkApp_tp {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) + (a : (Γ) ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) : + P.mkApp A B f f_tp a a_tp ≫ U1.tp = (U0.sec A a a_tp) ≫ B := by + simp [mkApp] + +theorem comp_mkApp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : Γ ⟶ U0.Ty) (σA) (eq : σ ≫ A = σA) (B : (U0.ext A) ⟶ U1.Ty) + (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) + (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) : + σ ≫ P.mkApp A B f f_tp a a_tp = + P.mkApp σA (U0.substWk σ A _ eq ≫ B) + (σ ≫ f) (by simp [f_tp, comp_mkPi (eq := eq)]) + (σ ≫ a) (by simp [a_tp, eq]) := by + unfold mkApp; rw [← Category.assoc, + comp_sec σ a_tp _ eq, Category.assoc, comp_unLam (eq := eq)] + +@[simp] +theorem mkLam_unLam {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + P.mkLam A (P.unLam A B f f_tp) = f := by + let total : Γ ⟶ U0.Ptp.obj U1.Tm := + (P.Pi_pullback).lift f (PtpEquiv.mk U0 A B) f_tp + simp only [mkLam, unLam] + have : PtpEquiv.fst U0 total = A := by + simp only [PtpEquiv.fst, UvPoly.Equiv.fst_eq, total] + rw [← U0.uvPolyTp.map_fstProj U1.tp] + slice_lhs 1 2 => apply (P.Pi_pullback).lift_snd + apply PtpEquiv.fst_mk + slice_lhs 1 1 => equals total => + apply PtpEquiv.ext _ (A := A) (by simp) (by simp [this]) (by simp [total]) + apply (P.Pi_pullback).lift_fst + +@[simp] +theorem unLam_mkLam {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : U0.ext A ⟶ U1.Tm) (t_tp : t ≫ U1.tp = B) + (lam_tp : P.mkLam A t ≫ U2.tp = P.mkPi A B) : + P.unLam A B (P.mkLam A t) lam_tp = t := by + simp [mkLam, unLam] + convert PtpEquiv.snd_mk U0 A t using 2 + apply (P.Pi_pullback).hom_ext <;> simp + rw [PtpEquiv.mk_comp_right, t_tp] + +/-- +``` +Γ ⊢₂ f : ΠA. B +-------------------------------------- +Γ ⊢₂ λA. f[↑] v₀ : ΠA. B +``` +-/ +def etaExpand {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + (Γ) ⟶ U2.Tm := + P.mkLam A <| + P.mkApp + (U0.disp A ≫ A) (U0.substWk .. ≫ B) (U0.disp A ≫ f) + (by simp [f_tp, comp_mkPi]) + (U0.var A) (U0.var_tp A) + +theorem etaExpand_eq {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + P.etaExpand A B f f_tp = f := by + simp [etaExpand] + convert P.mkLam_unLam A B f f_tp using 2 + simp [mkApp]; rw [← comp_unLam (f_tp := f_tp), ← Category.assoc] + conv_rhs => rw [← Category.id_comp (P.unLam ..)] + congr 2 + apply (U0.disp_pullback A).hom_ext <;> simp + +/-- +``` +Γ ⊢₀ A Γ.A ⊢₁ t : B Γ ⊢₀ a : A +-------------------------------- +Γ.A ⊢₁ (λA. t) a ≡ t[a] : B[a] +``` -/ +@[simp] +theorem mkApp_mkLam {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (t : (U0.ext A) ⟶ U1.Tm) (t_tp : t ≫ U1.tp = B) + (lam_tp : P.mkLam A t ≫ U2.tp = P.mkPi A B) + (a : (Γ) ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) : + P.mkApp A B (P.mkLam A t) lam_tp a a_tp = (U0.sec A a a_tp) ≫ t := by + rw [mkApp, unLam_mkLam] + assumption + +def toUnstructured : + UnstructuredUniverse.PolymorphicPi U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse where + Pi := P.mkPi _ + Pi_comp _ _ _ _ _ := (P.comp_mkPi ..).symm + lam _ b _ := P.mkLam _ b + lam_comp σ A σA eq _ b _ := (P.comp_mkLam σ A σA eq b).symm + lam_tp B b b_tp := P.mkLam_tp _ B b b_tp + unLam := P.unLam _ + unLam_tp B f f_tp := P.unLam_tp _ B f f_tp + unLam_lam B b b_tp := P.unLam_mkLam _ B b b_tp _ + lam_unLam B := P.mkLam_unLam _ B + +end + +namespace ofUnstructured + +variable {U0 U1 U2 : StructuredUniverse R} + (P : UnstructuredUniverse.PolymorphicPi U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse) + +def PiApp (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) : Γ ⟶ U2.Ty := + P.Pi (PtpEquiv.snd U0 AB) + +lemma Pi_naturality {Δ Γ} (σ : Δ ⟶ Γ) (AB) : + PiApp P (σ ≫ AB) = σ ≫ PiApp P AB := by + simp only [PiApp, PtpEquiv.fst_comp_left, PtpEquiv.snd_comp_left, ← P.Pi_comp] + rw! [PtpEquiv.fst_comp_left] + +def Pi : U0.uvPolyTp @ U1.Ty ⟶ U2.Ty := + ofYoneda (PiApp P) (Pi_naturality P) + +def lamApp (b : Γ ⟶ U0.uvPolyTp @ U1.Tm) : Γ ⟶ U2.Tm := + P.lam _ (PtpEquiv.snd U0 b) rfl + +lemma lam_naturality {Δ Γ} (σ : Δ ⟶ Γ) (ab) : + lamApp P (σ ≫ ab) = σ ≫ lamApp P ab := by + simp only [lamApp, PtpEquiv.fst_comp_left, PtpEquiv.snd_comp_left, ← P.lam_comp] + rw! [PtpEquiv.fst_comp_left] + simp + +def lam : U0.uvPolyTp @ U1.Tm ⟶ U2.Tm := + ofYoneda (lamApp P) (lam_naturality P) + +lemma lamApp_tp (b : Γ ⟶ U0.uvPolyTp @ U1.Tm) : + lamApp P b ≫ U2.tp = PiApp P (b ≫ U0.Ptp.map U1.tp) := by + simp only [lamApp, PiApp, PtpEquiv.fst_comp_right, PtpEquiv.snd_comp_right] + rw! [P.lam_tp, PtpEquiv.fst_comp_right] + +def lift (f : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (f_tp : f ≫ U2.tp = PiApp P AB) : Γ ⟶ U0.uvPolyTp @ U1.Tm := + PtpEquiv.mk _ (PtpEquiv.fst _ AB) (P.unLam (PtpEquiv.snd _ AB) f f_tp) + +lemma lamApp_lift (f : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (f_tp : f ≫ U2.tp = PiApp P AB) : + lamApp P (lift P f AB f_tp) = f := by + dsimp only [lamApp, lift] + rw! (castMode := .all) [PtpEquiv.fst_mk, PtpEquiv.snd_mk, P.unLam_tp, P.lam_unLam] + +lemma lift_Ptp_map_tp (f : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (f_tp : f ≫ U2.tp = PiApp P AB) : + ofUnstructured.lift P f AB f_tp ≫ U0.Ptp.map U1.tp = AB := by + dsimp [lift] + rw [PtpEquiv.mk_comp_right, P.unLam_tp, PtpEquiv.eta] + +lemma lift_uniq (f : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (f_tp : f ≫ U2.tp = PiApp P AB) (m : Γ ⟶ U0.Ptp.obj U1.Tm) + (hl : lamApp P m = f) (hr : m ≫ U0.Ptp.map U1.tp = AB) : + m = lift P f AB f_tp := by + fapply PtpEquiv.ext _ + · calc PtpEquiv.fst _ m + _ = PtpEquiv.fst _ (m ≫ U0.Ptp.map U1.tp) := by rw [PtpEquiv.fst_comp_right] + _ = _ := by simp [hr, lift] + · subst hl hr + dsimp only [lift, lamApp] + rw! [PtpEquiv.fst_comp_right, PtpEquiv.snd_mk, PtpEquiv.snd_comp_right, P.unLam_lam] + +end ofUnstructured + +def ofUnstructured (P : UnstructuredUniverse.PolymorphicPi U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse) : PolymorphicPi U0 U1 U2 where + Pi := ofUnstructured.Pi P + lam := ofUnstructured.lam P + Pi_pullback := ofYoneda_isPullback _ _ _ _ _ _ (ofUnstructured.lamApp_tp P) + (ofUnstructured.lift P) + (ofUnstructured.lamApp_lift P) + (ofUnstructured.lift_Ptp_map_tp P) + (ofUnstructured.lift_uniq P) + +end PolymorphicPi + +/-! ## Sigma types -/ + +/-- The structure on three universes that for +`A : Γ ⟶ U0.Ty` and `B : Γ.A ⟶ U1.Ty` constructs a Π-type `Σ_A B : Γ ⟶ U2.Ty`. -/ +structure PolymorphicSigma (U0 U1 U2 : StructuredUniverse R) where + Sig : U0.Ptp.obj U1.Ty ⟶ U2.Ty + pair : U0.compDom U1 ⟶ U2.Tm + Sig_pullback : IsPullback pair (U0.compP U1) U2.tp Sig + +/-- A universe `M` has Σ-type structure. This is the data of a pullback square +``` + Sig +compDom ------> Tm + | | + compP |tp + | | + V V +Ptp Ty ------> Ty + pair +``` +-/ +protected abbrev Sigma := PolymorphicSigma M M M + +namespace PolymorphicSigma + +variable {U0 U1 U2 : StructuredUniverse R} {Γ : Ctx} + +section +variable (S : PolymorphicSigma U0 U1 U2) + +/-- +``` +Γ ⊢₀ A Γ.A ⊢₁ B +----------------- +Γ ⊢₂ ΣA. B +``` -/ +def mkSig {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) : + Γ ⟶ U2.Ty := + PtpEquiv.mk U0 A B ≫ S.Sig + +theorem comp_mkSig {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) : + σ ≫ S.mkSig A B = + S.mkSig (σ ≫ A) ((U0.substWk σ A) ≫ B) := by + simp [mkSig, ← Category.assoc, PtpEquiv.mk_comp_left] + +/-- +``` +Γ ⊢₀ t : A Γ ⊢₁ u : B[t] +-------------------------- +Γ ⊢₂ ⟨t, u⟩ : ΣA. B +``` -/ +def mkPair {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + (Γ) ⟶ U2.Tm := + compDomEquiv.mk t t_tp B u u_tp ≫ S.pair + +theorem comp_mkPair {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + σ ≫ S.mkPair A B t t_tp u u_tp = + S.mkPair (σ ≫ A) ((U0.substWk σ A) ≫ B) + (σ ≫ t) (by simp [t_tp]) + (σ ≫ u) (by simp [u_tp, comp_sec_assoc]) := by + simp only [← Category.assoc, mkPair]; rw [compDomEquiv.comp_mk] + +@[simp] +theorem mkPair_tp {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + S.mkPair A B t t_tp u u_tp ≫ U2.tp = S.mkSig A B := by + simp [mkPair, Category.assoc, S.Sig_pullback.w, mkSig, compDomEquiv.mk_comp_assoc] + +def mkFst {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + Γ ⟶ U0.Tm := + compDomEquiv.fst (S.Sig_pullback.lift p (PtpEquiv.mk _ A B) p_tp) + +@[simp] +theorem mkFst_tp {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + S.mkFst A B p p_tp ≫ U0.tp = A := by + simp [mkFst, compDomEquiv.fst_tp] + +@[simp] +theorem mkFst_mkPair {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + S.mkFst A B (S.mkPair A B t t_tp u u_tp) (by simp) = t := by + simp [mkFst, mkPair] + convert compDomEquiv.fst_mk t t_tp B u u_tp using 2 + apply (S.Sig_pullback).hom_ext <;> simp [compDomEquiv.mk_comp] + +theorem comp_mkFst {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + (σ) ≫ S.mkFst A B p p_tp = + S.mkFst (σ ≫ A) (U0.substWk σ A ≫ B) (σ ≫ p) + (by simp [p_tp, comp_mkSig]) := by + simp [mkFst] + rw [← compDomEquiv.fst_comp]; congr 1 + apply S.Sig_pullback.hom_ext <;> simp [PtpEquiv.mk_comp_left] + +def mkSnd {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + Γ ⟶ U1.Tm := + compDomEquiv.snd (S.Sig_pullback.lift p (PtpEquiv.mk _ A B) p_tp) + +@[simp] +theorem mkSnd_mkPair {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + S.mkSnd A B (S.mkPair A B t t_tp u u_tp) (by simp) = u := by + simp [mkSnd, mkPair] + convert compDomEquiv.snd_mk t t_tp B u u_tp using 2 + apply (S.Sig_pullback).hom_ext <;> simp [compDomEquiv.mk_comp] + +protected theorem dependent_eq {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + compDomEquiv.dependent ((S.Sig_pullback).lift p (PtpEquiv.mk U0 A B) p_tp) A + (by simp [compDomEquiv.fst_tp]) = B := by + convert PtpEquiv.snd_mk U0 A B using 2 + simp only [compDomEquiv.dependent, UvPoly.compDomEquiv.dependent, PtpEquiv.snd_mk] + simp [PtpEquiv.mk] + +@[simp] +theorem mkSnd_tp {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + S.mkSnd A B p p_tp ≫ U1.tp = + (U0.sec A (S.mkFst A B p p_tp) (by simp)) ≫ B := by + generalize_proofs h + simp [mkSnd, compDomEquiv.snd_tp (eq := h), S.dependent_eq]; rfl + +theorem comp_mkSnd {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + σ ≫ S.mkSnd A B p p_tp = + S.mkSnd (σ ≫ A) (U0.substWk σ A ≫ B) (σ ≫ p) + (by simp [p_tp, comp_mkSig]) := by + simp [mkSnd, ← compDomEquiv.snd_comp]; congr 1 + apply (S.Sig_pullback).hom_ext <;> simp + rw [PtpEquiv.mk_comp_left] + +@[simp] +theorem mkPair_mkFst_mkSnd {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + S.mkPair A B + (S.mkFst A B p p_tp) (by simp) + (S.mkSnd A B p p_tp) (by simp) = p := by + simp [mkFst, mkSnd, mkPair] + have := compDomEquiv.eta ((S.Sig_pullback).lift p (PtpEquiv.mk _ A B) p_tp) + (eq := by rw [← mkFst.eq_def, mkFst_tp]) + conv at this => enter [1, 3]; apply S.dependent_eq + simp [this] + +end + +namespace ofUnstructured + +variable {U0 U1 U2 : StructuredUniverse R} + (S : UnstructuredUniverse.PolymorphicSigma U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse) + +def SigApp (AB : Γ ⟶ U0.Ptp.obj U1.Ty) : Γ ⟶ U2.Ty := + S.Sig (PtpEquiv.snd U0 AB) + +lemma Sig_naturality {Δ Γ} (σ : Δ ⟶ Γ) (AB) : + SigApp S (σ ≫ AB) = σ ≫ SigApp S AB := by + simp only [SigApp, PtpEquiv.fst_comp_left, PtpEquiv.snd_comp_left, ← S.Sig_comp] + rw! [PtpEquiv.fst_comp_left] + +def Sig : U0.Ptp.obj U1.Ty ⟶ U2.Ty := + ofYoneda (SigApp S) (Sig_naturality S) + +def pairApp (ab : Γ ⟶ U0.compDom U1) : Γ ⟶ U2.Tm := + S.pair (compDomEquiv.dependent ab) (compDomEquiv.fst ab) + (by rw [compDomEquiv.fst_tp]) (compDomEquiv.snd ab) (by rw [compDomEquiv.snd_tp]) + +lemma pair_naturality {Δ Γ} (σ : Δ ⟶ Γ) (ab) : + pairApp S (σ ≫ ab) = σ ≫ pairApp S ab := by + dsimp [pairApp] + simp only [← S.pair_comp, compDomEquiv.comp_dependent, compDomEquiv.fst_comp, + compDomEquiv.snd_comp] + rw! [compDomEquiv.fst_comp, Category.assoc] + +def pair : U0.compDom U1 ⟶ U2.Tm := + ofYoneda (pairApp S) (pair_naturality S) + +lemma pair_tp (ab : Γ ⟶ U0.compDom U1) : + pairApp S ab ≫ U2.tp = SigApp S (ab ≫ U0.compP U1) := by + dsimp [pairApp, SigApp] + rw! [S.pair_tp, compDomEquiv.dependent_eq, compDomEquiv.fst_tp] + +def lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + Γ ⟶ U0.compDom U1 := + let B := PtpEquiv.snd U0 AB + compDomEquiv.mk (S.fst B ab ab_tp) (S.fst_tp ..) B (S.snd B ab ab_tp) (S.snd_tp ..) + +lemma fst_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + compDomEquiv.fst (lift S ab AB ab_tp) = + S.fst (PtpEquiv.snd U0 AB) ab ab_tp := by + rw [lift, compDomEquiv.fst_mk _ _] + +lemma snd_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + compDomEquiv.snd (lift S ab AB ab_tp) = + S.snd (PtpEquiv.snd U0 AB) ab ab_tp := by + rw [lift, compDomEquiv.snd_mk] + +lemma dependent_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + compDomEquiv.dependent (lift S ab AB ab_tp) (PtpEquiv.fst U0 AB) (by rw [fst_lift, S.fst_tp]) = + PtpEquiv.snd U0 AB (PtpEquiv.fst U0 AB) := by + simp [lift, compDomEquiv.dependent_mk] + +lemma pairApp_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = ofUnstructured.SigApp S AB) : + ofUnstructured.pairApp S (ofUnstructured.lift S ab AB ab_tp) = ab := by + dsimp [pairApp] + rw! [fst_lift, S.fst_tp, fst_lift, snd_lift, dependent_lift] + rw [S.eta] + +lemma lift_compP (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + lift S ab AB ab_tp ≫ U0.compP U1 = AB := by + dsimp [lift] + rw [compDomEquiv.mk_comp, PtpEquiv.eta] + +lemma lift_uniq (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) (m : Γ ⟶ U0.compDom U1) + (hl : pairApp S m = ab) (hr : m ≫ U0.compP U1 = AB) : + m = lift S ab AB ab_tp := by + rw! [← compDomEquiv.eta m] + fapply compDomEquiv.ext (A := PtpEquiv.fst U0 AB) + · rw [compDomEquiv.fst_mk, compDomEquiv.fst_tp, hr] + · rw [fst_lift, compDomEquiv.fst_mk _] + calc compDomEquiv.fst m + _ = S.fst (compDomEquiv.dependent m) (pairApp S m) (S.pair_tp ..) := by + dsimp [pairApp] + rw [S.fst_pair] + S.fst (compDomEquiv.dependent m) (pairApp S m) (S.pair_tp ..) = + S.fst (PtpEquiv.snd U0 AB) ab ab_tp := by + subst hl hr + rw! [compDomEquiv.dependent_eq, compDomEquiv.fst_tp] + · subst hr + rw [compDomEquiv.dependent_mk, dependent_lift, compDomEquiv.dependent_eq] + rw! [compDomEquiv.fst_tp, eqToHom_refl, Category.id_comp, compDomEquiv.fst_tp] + · simp [snd_lift] + calc compDomEquiv.snd m + _ = S.snd (compDomEquiv.dependent m) (pairApp S m) (S.pair_tp ..) := by + dsimp [pairApp] + rw [S.snd_pair] + S.snd (compDomEquiv.dependent m) (pairApp S m) (S.pair_tp ..) = + S.snd (PtpEquiv.snd U0 AB) ab ab_tp := by + subst hl hr + rw! [compDomEquiv.dependent_eq, compDomEquiv.fst_tp] + +end ofUnstructured + +def ofUnstructured {U0 U1 U2 : StructuredUniverse R} + (S : UnstructuredUniverse.PolymorphicSigma U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse) : + PolymorphicSigma U0 U1 U2 where + Sig := ofUnstructured.Sig S + pair := ofUnstructured.pair S + Sig_pullback := ofYoneda_isPullback _ _ _ _ _ _ (ofUnstructured.pair_tp S) + (ofUnstructured.lift S) + (ofUnstructured.pairApp_lift S) + (ofUnstructured.lift_compP S) + (ofUnstructured.lift_uniq S) + +end PolymorphicSigma + +-- def Sigma.mk' +-- (Sig : ∀ {Γ} {A : Γ ⟶ M.Ty}, (M.ext A ⟶ M.Ty) → (Γ ⟶ M.Ty)) +-- (comp_Sig : ∀ {Γ Δ} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) {σA} (eq) (B : M.ext A ⟶ M.Ty), +-- σ ≫ Sig B = Sig (M.substWk σ A σA eq ≫ B)) +-- (assoc : ∀ {Γ} {A : Γ ⟶ M.Ty} (B : M.ext A ⟶ M.Ty), M.ext B ≅ M.ext (Sig B)) +-- (comp_assoc : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ M.Ty} {σA} (eq) (B : M.ext A ⟶ M.Ty), +-- substWk _ (substWk _ σ _ _ eq) _ ≫ (assoc B).hom = +-- (assoc (M.substWk σ A σA eq ≫ B)).hom ≫ M.substWk σ _ _ (comp_Sig ..)) +-- (assoc_disp : ∀ {Γ} {A : Γ ⟶ M.Ty} (B : M.ext A ⟶ M.Ty), +-- (assoc B).hom ≫ M.disp _ = M.disp _ ≫ M.disp _) : +-- M.Sigma := sorry + +/-- +Universe.IdIntro consists of the following commutative square + refl +M.Tm ------> M.Tm + | | + | | +diag M.tp + | | + | | + V V + k --------> M.Ty + Id + +where `K` (for "Kernel" of `tp`) is a chosen pullback for the square + k1 + k ---------> Tm + | | + | | + k2 | tp + | | + V V +Tm ----------> Ty + tp +and `diag` denotes the diagonal into the pullback `K`. + +We require a choice of pullback because, +although all pullbacks exist in presheaf categories, +when constructing a model it is convenient to know +that `k` is some specific construction on-the-nose. +-/ +structure IdIntro where + Id : M.ext M.tp ⟶ M.Ty + refl : M.Tm ⟶ M.Tm + refl_tp : refl ≫ M.tp = + ((M.disp_pullback M.tp).lift (𝟙 M.Tm) (𝟙 M.Tm) (by simp)) ≫ Id + +namespace IdIntro + +variable {M} (idIntro : IdIntro M) {Γ : Ctx} + +abbrev endpts (a0 a1:Γ ⟶ M.Tm) (h: a0 ≫ M.tp = a1 ≫ M.tp): Γ ⟶ M.ext M.tp := + (M.disp_pullback M.tp).lift a0 a1 h + +def toPolymorphicIdIntro : + M.toUnstructuredUniverse.PolymorphicIdIntro M.toUnstructuredUniverse where + Id a0 a1 a0_tp a1_tp := + --have := idIntro -- TODO: remove + endpts a0 a1 (by simp[a0_tp,a1_tp]) ≫ idIntro.Id + Id_comp σ A a0 a1 a0_tp a1_tp:= by + simp only[←Category.assoc] + congr 1 + apply IsPullback.hom_ext (hP:= (M.disp_pullback M.tp)) + · simp + simp + refl a _ := a ≫ idIntro.refl + refl_comp σ A a h := by simp + refl_tp a a_tp := by + simp[Category.assoc,idIntro.refl_tp] + simp[←Category.assoc] + congr 1 + apply IsPullback.hom_ext (hP:= (M.disp_pullback M.tp)) + · simp + simp + +@[simps] def k2UvPoly : UvPoly R (M.ext M.tp) M.Tm := + ⟨M.disp _, R.of_isPullback (M.disp_pullback M.tp) M.morphismProperty⟩ + +/-- The introduction rule for identity types. +To minimize the number of arguments, we infer the type from the terms. -/ +def mkId (a0 a1 : Γ ⟶ M.Tm) + (a0_tp_eq_a1_tp : a0 ≫ M.tp = a1 ≫ M.tp) : + Γ ⟶ M.Ty := + (UnstructuredUniverse.disp_pullback _ M.tp).lift a1 a0 (by rw [a0_tp_eq_a1_tp]) ≫ + idIntro.Id + +theorem comp_mkId {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (a0 a1 : Γ ⟶ M.Tm) (eq : a0 ≫ M.tp = a1 ≫ M.tp) : + σ ≫ mkId idIntro a0 a1 eq = + mkId idIntro (σ ≫ a0) (σ ≫ a1) (by simp [eq]) := by + simp [mkId]; rw [← Category.assoc]; congr 1 + apply (UnstructuredUniverse.disp_pullback _ M.tp).hom_ext <;> simp + +def mkRefl (a : Γ ⟶ M.Tm) : Γ ⟶ M.Tm := + a ≫ idIntro.refl + +theorem comp_mkRefl {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (a : Γ ⟶ M.Tm) : + σ ≫ idIntro.mkRefl a = idIntro.mkRefl (σ ≫ a) := by + simp [mkRefl] + +@[simp] +theorem mkRefl_tp (a : Γ ⟶ M.Tm) : + idIntro.mkRefl a ≫ M.tp = idIntro.mkId a a rfl := by + simp only [mkRefl, Category.assoc, idIntro.refl_tp, mkId] + rw [← Category.assoc] + congr 1 + apply (UnstructuredUniverse.disp_pullback _ M.tp).hom_ext <;> simp + +/-- The context appearing in the motive for identity elimination `J` + Γ ⊢ A + Γ ⊢ a : A + Γ.(x:A).(h:Id(A,a,x)) ⊢ M + ... +-/ +def motiveCtx (a : Γ ⟶ M.Tm) : Ctx := + M.ext (idIntro.mkId (M.disp (a ≫ M.tp) ≫ a) (M.var _) (by simp)) + +def motiveSubst {Γ Δ} (σ : Δ ⟶ Γ) (a : Γ ⟶ M.Tm) : + motiveCtx idIntro (σ ≫ a) ⟶ motiveCtx idIntro a := by + refine substWk _ (substWk _ σ _ _ (by simp)) _ _ ?_ + simp [comp_mkId] + +/-- The substitution `(a,refl)` appearing in identity elimination `J` + `(a,refl) : Γ ⟶ (Γ.(x:A).(h:Id(A,a,x)))` + so that we can write + `Γ ⊢ r : M(a,refl)` +-/ +def reflSubst (a : Γ ⟶ M.Tm) : Γ ⟶ idIntro.motiveCtx a := + M.substCons (M.substCons (𝟙 Γ) (a ≫ M.tp) a (by simp)) _ (idIntro.mkRefl a) (by + simp only [mkRefl_tp, mkId, ← Category.assoc] + congr 1 + apply (UnstructuredUniverse.disp_pullback _ M.tp).hom_ext <;> simp) + +@[reassoc] +theorem comp_reflSubst' {Γ Δ} (σ : Δ ⟶ Γ) (a : Γ ⟶ M.Tm) : + σ ≫ (idIntro.reflSubst a) = + (idIntro.reflSubst (σ ≫ a)) ≫ (idIntro.motiveSubst σ a) := by + apply (M.disp_pullback _).hom_ext <;> simp [reflSubst, motiveSubst, mkRefl] + apply (M.disp_pullback _).hom_ext <;> simp [substWk] + +@[simp, reassoc] +lemma comp_reflSubst (a : Γ ⟶ M.Tm) {Δ} (σ : Δ ⟶ Γ) : + reflSubst idIntro (σ ≫ a) ≫ idIntro.motiveSubst σ a = σ ≫ reflSubst idIntro a := by + simp [comp_reflSubst'] + +def toK (a : Γ ⟶ M.Tm) : (M.ext (a ≫ M.tp)) ⟶ M.ext M.tp := + (UnstructuredUniverse.disp_pullback _ M.tp).lift (M.var _) ((M.disp _) ≫ a) (by simp) + +lemma toK_comp_k1 (a : Γ ⟶ M.Tm) : IdIntro.toK a ≫ M.var M.tp = M.var _ := by + simp [toK] + +-- why does this not use ii? +lemma ext_a_tp_isPullback (ii : IdIntro M) (a : Γ ⟶ M.Tm) : + IsPullback (IdIntro.toK a) (M.disp _) (M.disp M.tp) a := + IsPullback.of_right' (M.disp_pullback _) (M.disp_pullback M.tp) + + +end IdIntro + +-- Id' is deprecated in favor of UnstructuredUniverse.PolymorphicIdElim + +-- /-- The full structure interpreting the natural model semantics for identity types +-- requires an `IdIntro` and an elimination rule `j` which satisfies a typing rule `j_tp` +-- and a β-rule `reflSubst_j`. +-- There is an equivalent formulation of these extra conditions later in `Id1` +-- that uses the language of polynomial endofunctors. + +-- Note that the universe/model `N` for the motive `C` is different from the universe `M` that the +-- identity type lives in. +-- -/ +/- protected structure Id' (i : IdIntro M) (N : StructuredUniverse R) where + j {Γ} (a : Γ ⟶ M.Tm) (C : IdIntro.motiveCtx _ a ⟶ N.Ty) (r : Γ ⟶ N.Tm) + (r_tp : r ≫ N.tp = (i.reflSubst a) ≫ C) : + i.motiveCtx a ⟶ N.Tm + j_tp {Γ} (a : Γ ⟶ M.Tm) (C : IdIntro.motiveCtx _ a ⟶ N.Ty) (r : Γ ⟶ N.Tm) + (r_tp : r ≫ N.tp = (i.reflSubst a) ≫ C) : j a C r r_tp ≫ N.tp = C + comp_j {Γ Δ} (σ : Δ ⟶ Γ) + (a : Γ ⟶ M.Tm) (C : IdIntro.motiveCtx _ a ⟶ N.Ty) (r : Γ ⟶ N.Tm) + (r_tp : r ≫ N.tp = (i.reflSubst a) ≫ C) : + i.motiveSubst σ _ ≫ j a C r r_tp = + j (σ ≫ a) (i.motiveSubst σ _ ≫ C) (σ ≫ r) (by + simp [r_tp, IdIntro.comp_reflSubst'_assoc]) + reflSubst_j {Γ} (a : Γ ⟶ M.Tm) (C : IdIntro.motiveCtx _ a ⟶ N.Ty) (r : Γ ⟶ N.Tm) + (r_tp : r ≫ N.tp = (i.reflSubst a) ≫ C) : + (i.reflSubst a) ≫ j a C r r_tp = r -/ + +-- namespace PolymorphicIdElim + +-- variable {M} {N : StructuredUniverse R} {ii : M.IdIntro} (i : M.Id' ii N) {Γ : Ctx} (a : Γ ⟶ M.Tm) +-- (C : ii.motiveCtx a ⟶ N.Ty) (r : Γ ⟶ N.Tm) +-- (r_tp : r ≫ N.tp = (ii.reflSubst a) ≫ C) (b : Γ ⟶ M.Tm) (b_tp : b ≫ M.tp = a ≫ M.tp) +-- (h : Γ ⟶ M.Tm) (h_tp : h ≫ M.tp = ii.isKernelPair.lift b a (by aesop) ≫ ii.Id) + +-- def endPtSubst : Γ ⟶ ii.motiveCtx a := +-- M.substCons (M.substCons (𝟙 _) _ b (by aesop)) _ h (by +-- simp only [h_tp, IdIntro.mkId, ← Category.assoc] +-- congr 1 +-- apply ii.isKernelPair.hom_ext +-- · simp +-- · simp) + +-- /-- The elimination rule for identity types, now with the parameters as explicit terms. +-- `Γ ⊢ A` is the type with a term `Γ ⊢ a : A`. +-- `Γ (y : A) (p : Id(A,a,y)) ⊢ C` is the motive for the elimination. +-- `Γ ⊢ b : A` is a second term in `A` and `Γ ⊢ h : Id(A,a,b)` is a path from `a` to `b`. +-- Then `Γ ⊢ mkJ' : C [b/y,h/p]` is a term of the motive with `b` and `h` substituted +-- -/ +-- def mkJ : Γ ⟶ N.Tm := +-- (endPtSubst a b b_tp h h_tp) ≫ i.j a C r r_tp + +-- /-- Typing for elimination rule `J` -/ +-- lemma mkJ_tp : i.mkJ a C r r_tp b b_tp h h_tp ≫ N.tp = (endPtSubst a b b_tp h h_tp) ≫ C := by +-- rw [mkJ, Category.assoc, i.j_tp] + +-- /-- β rule for identity types. Substituting `J` with `refl` gives the user-supplied value `r` -/ +-- lemma mkJ_refl : i.mkJ a C r r_tp a rfl (ii.mkRefl a) (by aesop) = r := +-- calc (endPtSubst a a _ (ii.mkRefl a) _) ≫ i.j a C r r_tp +-- _ = (ii.reflSubst a) ≫ i.j a C r r_tp := rfl +-- _ = r := by rw [i.reflSubst_j] + +-- end Id' + +variable {M} +-- /-- +-- `UniverseBase.IdElimBase` extends the structure `UniverseBase.IdIntro` +-- with a chosen pullback of `Id` +-- i1 +-- i --------> M.Tm +-- | | +-- | | +-- i2 M.tp +-- | | +-- V V +-- k --------> M.Ty +-- Id + +-- Again, we always have a pullback, +-- but when we construct a natural model, +-- this may not be definitionally equal to the pullbacks we construct, +-- for example using context extension. + + + + +-- M.var Id +-- M.ext Id--------> M.Tm +-- | | +-- | | +-- M.disp Id M.tp +-- | | +-- V V +-- M.ext M.tp --------> M.Ty +-- Id + + +-- -/ +-- structure IdElimBase (ii : IdIntro M) where +-- i : Ctx -- TODO: replace i with `M.ext (ii.Id)` and remove this whole definition. +-- i1 : i ⟶ M.Tm -- M.var .. +-- i2 : i ⟶ M.ext M.tp -- M.disp .. +-- i_isPullback : IsPullback i1 i2 M.tp ii.Id + +namespace IdIntro +variable (ii : IdIntro M) --(ie : IdElimBase ii) + +@[simps] def i2UvPoly : UvPoly R (M.ext ii.Id) (M.ext M.tp) := + ⟨M.disp ii.Id, R.of_isPullback (M.disp_pullback _) M.morphismProperty⟩ + +-- /-- The comparison map `M.tm ⟶ i` induced by the pullback universal property of `i`. + +-- refl +-- M.Tm ---------> +-- i1 +-- | i --------> M.Tm +-- | | | +-- diag | | +-- | i2 M.tp +-- | | | +-- | V V +-- V k --------> M.Ty +-- Id +-- -/ +def comparison : M.Tm ⟶ M.ext ii.Id := + (M.disp_pullback ii.Id).lift ii.refl + (IsPullback.lift (M.disp_pullback M.tp) (𝟙 M.Tm) (𝟙 M.Tm) (by simp)) + ii.refl_tp + +@[simp] +lemma comparison_comp_i1 : comparison ii ≫ M.var ii.Id = ii.refl := by + simp [comparison] + +@[simp, reassoc] +lemma comparison_comp_i2_comp_k1 : comparison ii ≫ M.disp ii.Id ≫ M.var M.tp = + 𝟙 _ := by + simp [comparison] + +@[simp, reassoc] +lemma comparison_comp_i2_comp_k2 : ii.comparison ≫ M.disp ii.Id ≫ M.disp M.tp = + 𝟙 _ := by + simp [comparison] + +/-- `i` over `Tm` can be informally thought of as the context extension +`(A : Ty).(a b : A).(p : Id(a,b)) ->> (A : Ty) (a : A)` +which is defined by the composition of (maps informally thought of as) context extensions +`(A : Ty).(a b : A).(p : Id(a,b)) ->> (A : Ty).(a b : A) ->> (A : Ty).(a : A)` +This is the signature for a polynomial functor `iUvPoly` on the presheaf category `Ctx`. +-/ +abbrev iUvPoly : UvPoly R (M.ext ii.Id) M.Tm := + (i2UvPoly ii).vcomp IdIntro.k2UvPoly + +-- lemma iUvPoly_morphismProperty : R (ie.i2 ≫ M.disp M.tp) := by +-- apply R.comp_mem +-- · exact R.of_isPullback ie.i_isPullback M.morphismProperty +-- · exact R.of_isPullback (M.disp_pullback M.tp) M.morphismProperty + +-- instance : R.HasPushforwardsAlong ie.iUvPoly.p := by +-- apply MorphismProperty.HasPushforwards.hasPushforwardsAlong (Q := R) +-- apply iUvPoly_morphismProperty + +-- instance : R.IsStableUnderPushforwardsAlong ie.iUvPoly.p := by +-- apply MorphismProperty.IsStableUnderPushforwards.of_isPushforward (Q := R) +-- apply iUvPoly_morphismProperty + +-- /-- The functor part of the polynomial endofunctor `iOverUvPoly` -/ +--instance : HasPullbacksAlong (iUvPoly (ii:= ii)).p := sorry +--instance : MorphismProperty.IsMultiplicative R := sorry need below +--instance : MorphismProperty.HasObjects R := sorry + + +instance : R.IsStableUnderPushforwardsAlong (iUvPoly (ii:= ii)).p := sorry + +instance : MorphismProperty.HasPushforwardsAlong R (iUvPoly (ii := ii)).p := sorry + +abbrev iFunctor : Ctx ⥤ Ctx := (iUvPoly (ii:= ii)).functor +-- (@iUvPoly _ _ _ _ _ _ ii).functor + +instance : R.HasPushforwardsAlong (UvPoly.id R M.Tm).p := by + apply MorphismProperty.HasPushforwards.hasPushforwardsAlong (Q := R) + apply R.id_mem + +instance : R.IsStableUnderPushforwardsAlong (UvPoly.id R M.Tm).p := by + apply MorphismProperty.IsStableUnderPushforwards.of_isPushforward (Q := R) + apply R.id_mem + +instance : MorphismProperty.IsMultiplicative R := sorry +/-- Consider the comparison map `comparison : Tm ⟶ i` in the slice over `Tm`. +Then the contravariant action `UVPoly.verticalNatTrans` of taking `UvPoly` on a slice +results in a natural transformation `P_iOver ⟶ P_(𝟙 Tm)` +between the polynomial endofunctors `iUvPoly` and `UvPoly.id M.Tm` respectively. + comparison +Tm ----> i + \ / + 𝟙\ /i2 ≫ k2 + VV + Tm +-/ +def verticalNatTrans : iFunctor ii ⟶ (UvPoly.id R M.Tm).functor := + --let f := UvPoly.id R M.Tm + UvPoly.verticalNatTrans (UvPoly.id R M.Tm) (iUvPoly ii) + (comparison ii) (by simp [iUvPoly]) + +section reflCase + +variable (i : IdIntro M) {N : StructuredUniverse R} + +variable {Γ : Ctx} (a : Γ ⟶ M.Tm) (r : Γ ⟶ N.Tm) + +lemma reflCase_aux : IsPullback (𝟙 Γ) a a (UvPoly.id R M.Tm).p := + have : IsIso (UvPoly.id R M.Tm).p := by simp; infer_instance + IsPullback.of_horiz_isIso (by simp) + +/-- The variable `r` witnesses the motive for the case `refl`, +This gives a map `(a,r) : Γ ⟶ P_𝟙Tm Tm ≅ Tm × Tm` where +``` + fst ≫ r +N.Tm <-- Γ --------> Tm + < ‖ ‖ + \ ‖ (pb) ‖ 𝟙_Tm + r \ ‖ ‖ + \ ‖ ‖ + \ Γ --------> Tm + a +``` +-/ +def reflCase : Γ ⟶ (UvPoly.id R M.Tm).functor.obj N.Tm := + UvPoly.Equiv.mk' a (pb := Γ) (f := 𝟙 _) (g := a) (reflCase_aux a) r +-- TODO: consider generalizing +-- TODO: consider showing UvPoly on identity `(P_𝟙_Y X)` is isomorphic to product `Y × X` + +end reflCase + +open IdIntro + +section Equiv + +variable {Γ : Ctx} {X : Ctx} +section +variable (a : Γ ⟶ M.Tm) +/- +In the following lemmas we build the following diagram of pullbacks, +where `pullback` is the pullback of `i₂ ≫ k₂` along `a` given by `HasPullback`. + X + Λ + | + | x + | + (Γ.a≫tp.Id(...)) ------> i ------> Tm + | | | + | | i₂ V + | | Ty + V V + (Γ.a≫tp) ------------> k ------> Tm + | | k₁ | + | |k₂ |tp + | | | + | V V + Γ ----------------> Tm -----> Ty + a tp +-/ + +-- lemma toK_comp_left {Δ} (σ : Δ ⟶ Γ) : IdIntro.toK (σ ≫ a) = +-- (M.substWk σ (a ≫ M.tp) _ (by simp)) ≫ IdIntro.toK a := by +-- dsimp [toK] +-- rw! [Category.assoc] +-- apply (M.disp_pullback M.tp).hom_ext +-- · simp +-- · simp only [IsKernelPair.lift_snd, Category.assoc] +-- slice_rhs 1 2 => rw [substWk_disp] +-- simp + + +/-def toI : (ii.motiveCtx a) ⟶ ie.i := + ie.i_isPullback.lift (M.var _) ((M.disp _) ≫ toK ii a) + (by rw [(M.disp_pullback _).w]; simp [IdIntro.mkId, toK]) + -/ +def toI : (ii.motiveCtx a) ⟶ M.ext ii.Id := + (M.disp_pullback ii.Id).lift (M.var _) ((M.disp _) ≫ toK a) + (by rw [(M.disp_pullback _).w]; simp [IdIntro.mkId, toK]) + +lemma toI_comp_i1 : toI ii a ≫ M.var ii.Id = M.var _ := by simp [toI] + +lemma toI_comp_i2 : toI ii a ≫ M.disp ii.Id = (M.disp _) ≫ toK a := + by simp [toI] + +-- lemma toI_comp_left {Δ} (σ : Δ ⟶ Γ) : toI ie (σ ≫ a) = +-- ii.motiveSubst σ a ≫ toI ie a := by +-- dsimp [toI] +-- apply ie.i_isPullback.hom_ext +-- · simp [motiveSubst] +-- · simp [toK_comp_left, motiveSubst, substWk, substCons] + + +theorem motiveCtx_isPullback : + IsPullback (toI ii a) (M.disp _) (M.disp ii.Id) (toK a) := + IsPullback.of_right' (M.disp_pullback _) (M.disp_pullback _) + +theorem motiveCtx_isPullback' : + IsPullback (toI ii a) ((M.disp (ii.mkId ((M.disp (a ≫ M.tp)) ≫ a) + (M.var (a ≫ M.tp)) (by simp))) ≫ (M.disp (a ≫ M.tp))) (iUvPoly ii).p a := + IsPullback.paste_vert (motiveCtx_isPullback ii a) + (ii.ext_a_tp_isPullback a) + +def equivMk (x : (ii.motiveCtx a) ⟶ X) : Γ ⟶ (iFunctor (ii:= ii)).obj X := + UvPoly.Equiv.mk' a (motiveCtx_isPullback' ii a).flip x + +def equivFst (pair : Γ ⟶ (iFunctor ii).obj X) : + Γ ⟶ M.Tm := + UvPoly.Equiv.fst pair + +lemma equivFst_comp_left (pair : Γ ⟶ (iFunctor ii).obj X) + {Δ} (σ : Δ ⟶ Γ) : + equivFst ii (σ ≫ pair) = σ ≫ equivFst ii pair := by + dsimp [equivFst] + rw [UvPoly.Equiv.fst_comp_left] + +def equivSnd (pair : Γ ⟶ (iFunctor (ii:= ii)).obj X) : + (ii.motiveCtx (equivFst ii pair)) ⟶ X := + UvPoly.Equiv.snd' pair (motiveCtx_isPullback' ii _).flip + +lemma equivSnd_comp_left (pair : Γ ⟶ (iFunctor ii).obj X) + {Δ} (σ : Δ ⟶ Γ) : + equivSnd ii (σ ≫ pair) = + eqToHom (by simp [equivFst_comp_left ii]) ≫ ii.motiveSubst σ _ ≫ equivSnd ii pair := by + sorry + -- dsimp only [equivSnd] + -- let a := ie.equivFst pair + -- have H : IsPullback (ie.toI a) + -- ((M.disp (ii.mkId ((M.disp (a ≫ M.tp)) ≫ a) (M.var (a ≫ M.tp)) _)) ≫ + -- (M.disp (a ≫ M.tp))) ie.iUvPoly.p + -- (UvPoly.Equiv.fst ie.iUvPoly X pair) := (motiveCtx_isPullback' _ _) + -- have H' : IsPullback ((M.disp + -- (ii.mkId ((M.disp (ie.equivFst (σ ≫ pair) ≫ M.tp)) ≫ + -- ie.equivFst (σ ≫ pair)) + -- (M.var (ie.equivFst (σ ≫ pair) ≫ M.tp)) _)) ≫ + -- (M.disp (ie.equivFst (σ ≫ pair) ≫ M.tp))) + -- (ie.toI (ie.equivFst (σ ≫ pair))) + -- (σ ≫ UvPoly.Equiv.fst ie.iUvPoly X pair) + -- ie.iUvPoly.p := + -- (motiveCtx_isPullback' _ _).flip + -- rw [UvPoly.Equiv.snd'_comp_left (H := H.flip) (H' := H')] + -- · congr 1 + -- have h : ie.toI (ie.equivFst (σ ≫ pair)) = + -- (ii.motiveSubst σ (ie.equivFst pair)) ≫ ie.toI a := + -- ie.toI_comp_left a σ + -- apply (IsPullback.flip H).hom_ext + -- · simp only [iUvPoly_p, Category.assoc, IsPullback.lift_fst] + -- simp [motiveSubst, substWk, substCons, a]; rfl + -- · apply ie.i_isPullback.hom_ext + -- · simp [IsPullback.lift_snd, h] + -- · apply ii.isKernelPair.hom_ext + -- · simp [IsPullback.lift_snd, h] + -- · simp only [iUvPoly_p, IsPullback.lift_snd, IdElimBase.toI_comp_i2, ← h, toI_comp_i2] + +-- lemma equivFst_verticalNatTrans_app {Γ : Ctx} {X : Ctx} +-- (pair : Γ ⟶ ie.iFunctor.obj X) : +-- ie.equivFst pair = UvPoly.Equiv.fst (UvPoly.id M.Tm) X +-- (pair ≫ ie.verticalNatTrans.app X) := by +-- dsimp [equivFst, verticalNatTrans] +-- rw [← UvPoly.fst_verticalNatTrans_app] + +-- lemma equivSnd_verticalNatTrans_app {Γ : Ctx} {X : Ctx} +-- (pair : Γ ⟶ ie.iFunctor.obj X) : +-- UvPoly.Equiv.snd' (UvPoly.id M.Tm) X (pair ≫ ie.verticalNatTrans.app X) +-- (R := Γ) (f := 𝟙 _) (g := ie.equivFst pair) (by +-- convert reflCase_aux (ie.equivFst pair) +-- rw [equivFst_verticalNatTrans_app]) = +-- (ii.reflSubst (ie.equivFst pair)) ≫ +-- ie.equivSnd pair := +-- calc _ +-- _ = _ ≫ ie.equivSnd pair := by +-- dsimp [equivSnd, verticalNatTrans] +-- rw [UvPoly.snd'_verticalNatTrans_app (UvPoly.id M.Tm) ie.iUvPoly +-- (ie.comparison) _ _ pair _] +-- apply reflCase_aux (ie.equivFst pair) +-- _ = _ := by +-- congr 1 +-- apply (M.disp_pullback _).hom_ext +-- · conv => lhs; rw [← toI_comp_i1 ie] +-- simp [reflSubst, comparison, mkRefl] +-- · apply (M.disp_pullback _).hom_ext +-- · slice_lhs 3 4 => rw [← ii.toK_comp_k1] +-- slice_lhs 2 3 => rw [← ie.toI_comp_i2] +-- simp [reflSubst] +-- · simp [reflSubst] + +-- lemma equivMk_comp_verticalNatTrans_app {Γ : Ctx} {X : Ctx} (a : Γ ⟶ M.Tm) +-- (x : (ii.motiveCtx a) ⟶ X) : +-- ie.equivMk a x ≫ (ie.verticalNatTrans).app X = +-- UvPoly.Equiv.mk' (UvPoly.id M.Tm) X a (R := Γ) (f := 𝟙 _) (g := a) +-- (reflCase_aux a) ((ii.reflSubst a) ≫ x) := by +-- dsimp only [equivMk, verticalNatTrans] +-- rw [UvPoly.mk'_comp_verticalNatTrans_app (R' := Γ) (f' := 𝟙 _) (g' := a) +-- (H' := reflCase_aux a)] +-- congr 2 +-- apply (M.disp_pullback _).hom_ext +-- · conv => lhs; rw [← toI_comp_i1 ie] +-- simp [reflSubst, comparison, mkRefl] +-- · apply (M.disp_pullback _).hom_ext +-- · slice_lhs 3 4 => rw [← ii.toK_comp_k1] +-- slice_lhs 2 3 => rw [← ie.toI_comp_i2] +-- simp [reflSubst] +-- · simp [reflSubst] + +end + +end Equiv + +end IdIntro + +open IdIntro + +/-- In the high-tech formulation by Richard Garner and Steve Awodey: +The full structure interpreting the natural model semantics for identity types +requires an `IdIntro`, +(and `IdElimBase` which can be generated by pullback in the presheaf category,) +and that the following commutative square generated by +`IdBaseComparison.verticalNatTrans` is a weak pullback. + +``` + verticalNatTrans.app Tm +iFunctor Tm --------> P_𝟙Tm Tm + | | + | | +iFunctor tp P_𝟙Tm tp + | | + | | + V V +iFunctor Ty --------> P_𝟙Tm Ty + verticalNatTrans.app Ty +``` + +This can be thought of as saying the following. +Fix `A : Ty` and `a : A` - we are working in the slice over `M.Tm`. +For any context `Γ`, any map `(a, r) : Γ → P_𝟙Tm Tm` +and `(a, C) : Γ ⟶ iFunctor Ty` such that `r ≫ M.tp = C[x/y, refl_x/p]`, +there is a map `(a,c) : Γ ⟶ iFunctor Tm` such that `c ≫ M.tp = C` and `c[a/y, refl_a/p] = r`. +Here we are thinking + `Γ (y : A) (p : A) ⊢ C : Ty` + `Γ ⊢ r : C[a/y, refl_a/p]` + `Γ (y : A) (p : A) ⊢ c : Ty` +This witnesses the elimination principle for identity types since +we can take `J (y.p.C;x.r) := c`. +-/ +structure Id (ii : IdIntro M) (N : StructuredUniverse R) where + weakPullback : WeakPullback + ((verticalNatTrans ii).app N.Tm) + ((iFunctor (ii:= ii)).map N.tp) + ((UvPoly.id R M.Tm).functor.map N.tp) + ((verticalNatTrans ii).app N.Ty) + +-- TODO fix the proof that `StructuredUniverse.Id` is equivalent to +-- `UnstructuredUniverse.PolymorphicIdElim` + +namespace Id + +variable {N : StructuredUniverse R} {ii : IdIntro M} (i : Id ii N) + +-- variable {Γ Δ : Ctx} (σ : Δ ⟶ Γ) (a : Γ ⟶ M.Tm) +-- (r : Γ ⟶ N.Tm) +-- (r_tp : r ≫ N.tp = (ii.reflSubst a) ≫ C) + +-- open IdIntro + +-- lemma reflCase_aux : IsPullback (𝟙 Γ) a a (UvPoly.id R M.Tm).p := +-- have : IsIso (UvPoly.id R M.Tm).p := by simp; infer_instance +-- IsPullback.of_horiz_isIso (by simp) + + +-- def reflCase : Γ ⟶ (UvPoly.id R M.Tm).functor.obj N.Tm := +-- UvPoly.Equiv.mk' a (pb := Γ) (f := 𝟙 _) (g := a) (reflCase_aux a) r +-- TODO: consider generalizing +-- TODO: consider showing UvPoly on identity `(P_𝟙_Y X)` is isomorphic to product `Y × X` + + +variable (ie) in + +--instance : MorphismProperty.IsMultiplicative R := sorry +--instance : MorphismProperty.IsMultiplicative R := sorry +-- abbrev motive : Γ ⟶ (iFunctor (ii:= ii)).obj N.Ty := +-- equivMk ii a C + +-- lemma motive_comp_left : σ ≫ motive a C = +-- motive (σ ≫ a) ((ii.motiveSubst σ a) ≫ C) := by +-- dsimp [motive, equivMk] +-- rw [UvPoly.Equiv.mk'_comp_left (iUvPoly ) _ a +-- (ie.motiveCtx_isPullback' a).flip C σ _ rfl (ie.motiveCtx_isPullback' _).flip] +-- congr 2 +-- simp only [Functor.map_comp, iUvPoly_p, Category.assoc, motiveSubst, substWk, substCons, +-- Functor.FullyFaithful.map_preimage] +-- apply (M.disp_pullback _).hom_ext <;> simp only [IsPullback.lift_fst, IsPullback.lift_snd] +-- · simp [← toI_comp_i1 ie] +-- · apply (M.disp_pullback _).hom_ext <;> simp +-- · slice_lhs 3 4 => rw [← ii.toK_comp_k1] +-- slice_rhs 2 3 => rw [← ii.toK_comp_k1] +-- slice_lhs 2 3 => rw [← ie.toI_comp_i2] +-- slice_rhs 1 2 => rw [← ie.toI_comp_i2] +-- simp + + +#check Model.UnstructuredUniverse.PolymorphicIdIntro.motiveCtx + +section +variables (M : StructuredUniverse R) (M': StructuredUniverse R) + (N: StructuredUniverse R) (iiM: IdIntro M) {Γ: Ctx} {A:Γ ⟶ M.Ty} (a:Γ ⟶ M.Tm) +(a_tp: a ≫ M.tp = A) (iMN: Id iiM N) (r : Γ ⟶ N.Tm) + +#check toPolymorphicIdIntro + +abbrev toUnstructuredmotiveCtx : Ctx := + UnstructuredUniverse.PolymorphicIdIntro.motiveCtx (A:= A) + (toPolymorphicIdIntro iiM) a (by simp[a_tp]) + +/-def j : (ii.motiveCtx a) ⟶ N.Tm := + eqToHom (by rw[equivFst_lift_eq ]) ≫ equivSnd ii (i.lift a C r r_tp (ii:= ii)) +-/ + +#check Id +instance: HasPullback ((UvPoly.id R M.Tm).functor.map N.tp) + ((verticalNatTrans (M:=M) iiM).app N.Ty) := sorry + +abbrev comparison : pullback ((UvPoly.id R M.Tm).functor.map N.tp) + ((verticalNatTrans iiM).app N.Ty) ⟶ iiM.iFunctor.obj N.Tm:= sorry + +/-def equivSnd (pair : Γ ⟶ (iFunctor (ii:= ii)).obj X) : + (ii.motiveCtx (equivFst ii pair)) ⟶ X := + UvPoly.Equiv.snd' pair (motiveCtx_isPullback' ii _).flip +-/ + +--the pullback of id map is the id map +instance idPb : IsPullback a (𝟙 Γ) (𝟙 M.Tm) a := sorry + +instance idPb': IsPullback a (𝟙 Γ) (UvPoly.id R M.Tm).p a := by + sorry + + +abbrev toTmTm: M.ext A ⟶ M.ext M.tp := (endpts (M.var A) (M.disp A ≫ a) (by simp[a_tp])) +/- + (C : IdIntro.motiveCtx _ a ⟶ N.Ty) (r : Γ ⟶ N.Tm) + (r_tp : r ≫ N.tp = (i.reflSubst a) ≫ C) + + + (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty ) +-/ + + --sorry ≫ comparison M N iiM + +/-M.ext (endpts (M.disp A ≫ a) (M.var A) ⋯ ≫ iiM.Id) = + pullback (UvPoly.Equiv.fst (toWeakpullback M N iiM iMN)) (M.disp iiM.Id ≫ M.disp M.tp)-/ + +/-construct the pullback + +-/ +#check endpts +instance TmTmPb : IsPullback (M.disp M.tp) (M.var M.tp) M.tp M.tp := (M.disp_pullback M.tp).flip + +-- instance GammaATmTmPb : +-- IsPullback (M.disp A) (endpts (M.var A) (M.disp A ≫ a) (by simp[a_tp])) a (M.disp M.tp) := by +-- fapply CategoryTheory.IsPullback.flip +-- fapply CategoryTheory.IsPullback.of_right (t:= (M.disp_pullback M.tp)) +-- (h₁₁:= (endpts (M.var A) (M.disp A ≫ a) (by simp[a_tp]))) (h₂₁ := a) +-- · convert_to +-- IsPullback (M.var A) (M.disp A) M.tp A +-- · rw![← a_tp] +-- simp +-- exact (M.disp_pullback A) +-- simp +instance : HasBinaryProduct M.Tm M.Ty := sorry + +instance prodIdPb : IsPullback (Limits.prod.fst) + (𝟙 (CategoryTheory.Limits.prod M.Tm M.Ty)) (𝟙 M.Tm) (Limits.prod.fst) + := sorry + +instance GammaATmTmPb : + IsPullback (endpts (M.var A) (M.disp A ≫ a) (by simp[a_tp])) (M.disp A) (M.disp M.tp) a := by + fapply CategoryTheory.IsPullback.of_right (t:= (M.disp_pullback M.tp)) + (h₁₁:= (endpts (M.var A) (M.disp A ≫ a) (by simp[a_tp]))) (h₂₁ := a) + · convert_to + IsPullback (M.var A) (M.disp A) M.tp A + · rw![← a_tp] + simp + exact (M.disp_pullback A) + simp + +--abbrev toTmTm: M.ext A ⟶ M.ext M.tp := (endpts (M.var A) (M.disp A ≫ a) (by simp[a_tp])) + +instance TmTmIdPb : IsPullback (M.var iiM.Id) (M.disp iiM.Id) M.tp iiM.Id := + (M.disp_pullback iiM.Id) + +--YX: can we hide the by simp? +--how can we attribute an assumption, say a_tp, to local simp? +instance mtcxPb : IsPullback (X:= M.Tm) (Y:= M.ext A) + (M.var (toTmTm M a (by simp[a_tp]) ≫ iiM.Id)) (M.disp (toTmTm M a (by simp[a_tp]) ≫ iiM.Id)) + M.tp (toTmTm M a (by simp[a_tp]) ≫ iiM.Id) := + (M.disp_pullback (toTmTm M a (by simp[a_tp]) ≫ iiM.Id)) + +--can we specify the parameter as M being implicit, iiM being explicit? +abbrev mtcxToUniversalId : M.ext (Γ:= M.ext A) (toTmTm (Γ := Γ) M a a_tp ≫ iiM.Id) ⟶ M.ext iiM.Id := + (TmTmIdPb M iiM).flip.lift + (W := M.ext (toTmTm (Γ := Γ) M a a_tp ≫ iiM.Id)) + (M.disp (toTmTm M a a_tp ≫ iiM.Id) ≫ toTmTm M a a_tp) + (M.var (toTmTm M a a_tp ≫ iiM.Id)) + (by simp) + --(M.disp (toTmTm M a sorry ≫ iiM.Id) ≫ toTmTm M a sorry) + + +instance mtcxToUniversalIdPb: + IsPullback (mtcxToUniversalId M iiM a a_tp) (M.disp (toTmTm M a a_tp ≫ iiM.Id)) (M.disp iiM.Id) + (endpts (M.var A) (M.disp A ≫ a) (by simp[a_tp])) := by + fapply CategoryTheory.IsPullback.of_right (t:= TmTmIdPb M iiM) + · convert (mtcxPb M iiM a a_tp) + simp + simp + +instance mtcxToTmPb : IsPullback + (mtcxToUniversalId M iiM a a_tp) + (M.disp (toTmTm M a a_tp ≫ iiM.Id) ≫ M.disp A) + (M.disp iiM.Id ≫ M.disp M.tp) + a := IsPullback.paste_vert (mtcxToUniversalIdPb M iiM a a_tp) (GammaATmTmPb M a a_tp) + +abbrev toWeakpullback1 (r : Γ ⟶ N.Tm) : Γ ⟶ (UvPoly.id R M.Tm).functor.obj N.Tm := + UvPoly.Equiv.mk' a (idPb' M a).flip r + +abbrev toWeakpullback2 (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) : + Γ ⟶ iiM.iFunctor.obj N.Ty := + UvPoly.Equiv.mk' a (mtcxToTmPb M iiM a a_tp).flip C +/- +def reflSubst (a : Γ ⟶ M.Tm) : Γ ⟶ idIntro.motiveCtx a := + M.substCons (M.substCons (𝟙 Γ) (a ≫ M.tp) a (by simp)) _ (idIntro.mkRefl a) (by + simp only [mkRefl_tp, mkId, ← Category.assoc] + congr 1 + apply (UnstructuredUniverse.disp_pullback _ M.tp).hom_ext <;> simp) + +-/ +#check IdIntro.refl +abbrev reflSubst: Γ ⟶ M.ext (toTmTm M a a_tp ≫ iiM.Id) := + (M.disp_pullback (toTmTm M a a_tp ≫ iiM.Id)).lift (W:= Γ) + (a ≫ iiM.refl) + ((M.disp_pullback A).lift (W:= Γ) + a (𝟙 _) (by simp[a_tp])) + (by + simp[Category.assoc,iiM.refl_tp] + simp[← Category.assoc] + congr 1 + apply (M.disp_pullback _).hom_ext <;> simp[]) + +--(UvPoly.id R M.Tm).p = iiM.comparison ≫ iiM.iUvPoly.p lemma? +--previously why could you use coherentLift...? +--can certainly compose with the lift to from the pb, but the API there requires Ctx to have all pbs +/- + have h : (UvPoly.id R M.Tm).p = iiM.comparison ≫ iiM.iUvPoly.p := by + simp only [UvPoly.id_p, UvPoly.vcomp_p, i2UvPoly_p, k2UvPoly_p, comparison_comp_i2_comp_k2] +-/ +--instance : HasPullbacks Ctx:=sorry + +variables (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ ⟶ N.Tm) + (r_tp : r ≫ N.tp = reflSubst M iiM a a_tp ≫ C) + +abbrev toWeakpullback : + Γ ⟶ iiM.iFunctor.obj N.Tm := + iMN.weakPullback.coherentLift (W:=Γ) (toWeakpullback1 M N a r) (toWeakpullback2 M N iiM a a_tp C) + (by + dsimp[toWeakpullback1,toWeakpullback2,verticalNatTrans] + have H := mtcxToTmPb M iiM a a_tp + have e:= UvPoly.mk'_comp_verticalNatTrans_app (X:= N.Ty) (P:= UvPoly.id R M.Tm) (Q:= iiM.iUvPoly) + (ρ := iiM.comparison) (h:= by simp) (b:= a) (H:= H.flip) (x:=C) (H':= (idPb M a).flip) + apply UvPoly.Equiv.ext' + (H:= by convert (idPb M a).flip + simp[UvPoly.Equiv.fst_comp_right]) + · rw![UvPoly.Equiv.snd'_comp_right (H := by convert (idPb M a).flip + simp[])] + simp only [UvPoly.Equiv.snd'_mk',r_tp] + rw![e] + simp only [UvPoly.vcomp_p, i2UvPoly_p, k2UvPoly_p, UvPoly.Equiv.snd'_mk'] + congr 1 + fapply (M.disp_pullback _).hom_ext + · simp[] + have e1 : M.var (toTmTm M a a_tp ≫ iiM.Id) = + (mtcxToUniversalId M iiM a a_tp) ≫ M.var iiM.Id := by simp only [IsPullback.lift_snd] + rw[e1] + simp only[←Category.assoc] + simp + simp? + fapply (M.disp_pullback _).hom_ext + · simp + have e2: M.var A = toTmTm M a a_tp ≫ M.var M.tp := by simp + convert_to + a = (H.flip).lift (𝟙 Γ) (a ≫ iiM.comparison) (by simp) ≫ M.disp (toTmTm M a a_tp ≫ iiM.Id) + ≫ toTmTm M a a_tp ≫ M.var M.tp + · simp[← e2] --this convert_to should not be here, what can I do? + · have e3 : M.disp (toTmTm M a a_tp ≫ iiM.Id) ≫ toTmTm M a a_tp = + mtcxToUniversalId M iiM a a_tp ≫ M.disp iiM.Id := by simp + convert_to + a = (H.flip).lift (𝟙 Γ) (a ≫ iiM.comparison) (by simp) ≫ (M.disp (toTmTm M a a_tp ≫ iiM.Id) + ≫ toTmTm M a a_tp ) ≫ M.var M.tp + · simp + · rw[e3] + simp only[← Category.assoc] + simp only [IsPullback.lift_snd, Category.assoc, comparison_comp_i2_comp_k1, + Category.comp_id] + · simp + rw![e]--repeat from 1790-1794 + simp only [UvPoly.vcomp_p, i2UvPoly_p, k2UvPoly_p, UvPoly.Equiv.fst_mk'] + simp only [UvPoly.Equiv.fst_comp_right, UvPoly.Equiv.fst_mk'] + ) +--UvPoly.Equiv.fst_mk' +/- +@[simp] +lemma coherentLift_fst [HasPullback f g] : wp.coherentLift a b h ≫ fst = a := by + simp [coherentLift] + -/ +lemma j_aux : + UvPoly.Equiv.fst (toWeakpullback M N iiM a a_tp iMN C r r_tp) = a := by + have e: UvPoly.Equiv.fst (toWeakpullback M N iiM a a_tp iMN C r r_tp) = + UvPoly.Equiv.fst (toWeakpullback M N iiM a a_tp iMN C r r_tp ≫ + (iFunctor iiM).map N.tp ):= by + rw[UvPoly.Equiv.fst_comp_right] + simp only [e, WeakPullback.coherentLift_snd, UvPoly.Equiv.fst_mk'] + + +--instance mtcxPb : IsPullback (M.disp iiM.Id) (M.var iiM.Id) iiM.Id M.tp +def j : + toUnstructuredmotiveCtx _ iiM a a_tp ⟶ N.Tm := by + have s := UvPoly.Equiv.snd' (R:=R) (P:= iUvPoly iiM) + (toWeakpullback (Γ := Γ) M N iiM a a_tp iMN C r r_tp) + (by convert (mtcxToTmPb M iiM a a_tp).flip + apply j_aux) + convert s + + +--need a lemma for comp of reflsubst +lemma comp_j {Δ} (σ : Δ ⟶ Γ): + j M N iiM (σ ≫ a) (by simp[Category.assoc,a_tp]) iMN + (iiM.toPolymorphicIdIntro.motiveSubst σ a a_tp rfl ≫ C) + (σ ≫ r) (by simp[Category.assoc, r_tp];sorry) = + iiM.toPolymorphicIdIntro.motiveSubst σ a a_tp rfl ≫ + j M N iiM a a_tp iMN C r r_tp := by + + sorry + +/- +def j : (ii.motiveCtx a) ⟶ N.Tm := + eqToHom (by rw[equivFst_lift_eq ]) ≫ equivSnd ii (i.lift a C r r_tp (ii:= ii)) + +/-- Typing for elimination rule `J` -/ +lemma j_tp : j i a C r r_tp ≫ N.tp = C := by + simp only [j, Category.assoc, IdIntro.equivSnd, ← UvPoly.Equiv.snd'_comp_right] + -- FIXME: `transparency := .default` is like `erw` and should be avoided + rw! (transparency := .default) [WeakPullback.coherentLift_snd] + simp only [IdIntro.equivMk] + rw! [equivFst_lift_eq] + simp +-/ +lemma j_tp : j M N iiM a a_tp iMN C r r_tp ≫ N.tp = C := by + dsimp[j]--free from eqToHom compared from the previous version, is that a progress? + simp[← UvPoly.Equiv.snd'_comp_right] + +def toUnstructured : + M.toUnstructuredUniverse.PolymorphicIdElim + iiM.toPolymorphicIdIntro N.toUnstructuredUniverse where + j {Γ A} a a_tp C r r_tp := j M N iiM a a_tp iMN C r r_tp--how can I manage it to just write j? + comp_j := sorry + j_tp := by simp[j_tp] + reflSubst_j := sorry + +end + +-- def toUnstructured : M.toUnstructuredUniverse.PolymorphicIdElim +-- ii.toPolymorphicIdIntro N.toUnstructuredUniverse where +-- j {Γ A} a a_tp C c e := by +-- let w := M.disp_pullback (ii.mkId (M.disp (a ≫ M.tp) ≫ a) (M.var _) (by simp)) + +-- let iso: ii.toPolymorphicIdIntro.motiveCtx a a_tp ⟶ ii.motiveCtx a := by +-- fapply (w.lift (W:= ii.toPolymorphicIdIntro.motiveCtx a a_tp) ) +-- · apply (M.var ((ii.toPolymorphicIdIntro).weakenId a a_tp)) +-- · convert (M.disp ((ii.toPolymorphicIdIntro).weakenId a a_tp)) +-- · simp +-- sorry +-- have f1 : ii.motiveCtx a ⟶ N.Tm := by +-- fapply i.j +-- · sorry +-- · sorry +-- · sorry +-- exact (iso ≫ f1) +-- -- sorry +-- --#check i.j +-- -- sorry --i.j +-- j_tp := sorry -- i.j_tp +-- comp_j := sorry --i.comp_j +-- reflSubst_j := sorry -- i.reflSubst_j + +end Id + +def IdIntro.ofUnstructured + (i : M.toUnstructuredUniverse.PolymorphicIdIntro M.toUnstructuredUniverse) : M.IdIntro := + have := i -- TODO remove + sorry + +namespace Id + +variable {N : StructuredUniverse R} + (ii : M.toUnstructuredUniverse.PolymorphicIdIntro M.toUnstructuredUniverse) + (i : M.Id (IdIntro.ofUnstructured ii) N) +open IdIntro + +--ie |-> (IdIntro.ofUnstructured ii) + +variable {Γ} (ar : (Γ) ⟶ (UvPoly.id R M.Tm).functor.obj N.Tm) + (aC : (Γ) ⟶ (iFunctor ((IdIntro.ofUnstructured ii))).obj N.Ty) + (hrC : ar ≫ (UvPoly.id R M.Tm).functor.map N.tp = + aC ≫ (verticalNatTrans (IdIntro.ofUnstructured ii)).app N.Ty) + + +instance : HasPullbacksAlong ((UvPoly.id R M.Tm).functor.map N.tp) := + +sorry +instance {X} (f: X ⟶ _) : HasPullback ((UvPoly.id R M.Tm).functor.map N.tp) f := by + apply hasPullback_symmetry + + + + +#exit +def lift : Γ ⟶ (iFunctor ii).obj N.Tm := + i.weakPullback.coherentLift (reflCase a r) (motive a C) (by + dsimp only [motive, equivMk, verticalNatTrans, reflCase] + rw [UvPoly.mk'_comp_verticalNatTrans_app (UvPoly.id R M.Tm) (iUvPoly ii) (comparison ii) + _ N.Ty a (motiveCtx_isPullback' ii a).flip C (reflCase_aux a), + UvPoly.Equiv.mk'_comp_right, r_tp, reflSubst] + congr + apply (M.disp_pullback _).hom_ext + · conv => right; rw [← toI_comp_i1] + simp [mkRefl, comparison] + · apply (M.disp_pullback _).hom_ext + · slice_rhs 3 4 => rw [← toK_comp_k1] + slice_rhs 2 3 => rw [← toI_comp_i2] + simp + · simp) + +lemma lift_comp_left {Δ} (σ : Δ ⟶ Γ) : i.lift (σ ≫ a) ((ii.motiveSubst σ a) ≫ C) + (σ ≫ r) (by simp [r_tp, comp_reflSubst'_assoc]) = + σ ≫ i.lift a C r r_tp := by + dsimp [lift] + rw [WeakPullback.coherentLift_comp_left] + sorry + -- congr 1 + -- · dsimp [reflCase] + -- --have e:= UvPoly.Equiv.mk'_comp_left + -- rw [UvPoly.Equiv.mk'_comp_left (σ := σ) (H':=reflCase_aux a)] + -- rw [UvPoly.Equiv.mk'_comp_left (UvPoly.id _ M.Tm) N.Tm a (reflCase_aux a) r σ _ rfl + -- (reflCase_aux (σ ≫ a))] + -- congr 2 + -- apply (reflCase_aux a).hom_ext + -- · simp only [IsPullback.lift_fst] + -- simp + -- · simp + -- · rw [motive_comp_left] + +lemma equivFst_lift_eq : equivFst ii (i.lift a C r r_tp) = a := + calc equivFst ii (i.lift a C r r_tp) + _ = equivFst ii (i.lift a C r r_tp ≫ (iFunctor ii).map N.tp) := by + dsimp [IdIntro.equivFst] + rw [UvPoly.Equiv.fst_comp_right] + _ = _ := by + dsimp [lift, motive, IdIntro.equivFst, IdIntro.equivMk] + rw [WeakPullback.coherentLift_snd, UvPoly.Equiv.fst_mk'] + +/-- The elimination rule for identity types. + `Γ ⊢ A` is the type with a term `Γ ⊢ a : A`. + `Γ (y : A) (h : Id(A,a,y)) ⊢ C` is the motive for the elimination. + Then we obtain a section of the motive + `Γ (y : A) (h : Id(A,a,y)) ⊢ mkJ : A` +-/ +--equivFst_lift_eq +def j : (ii.motiveCtx a) ⟶ N.Tm := + eqToHom (by rw[equivFst_lift_eq ]) ≫ equivSnd ii (i.lift a C r r_tp (ii:= ii)) + +/-- Typing for elimination rule `J` -/ +lemma j_tp : j i a C r r_tp ≫ N.tp = C := by + simp only [j, Category.assoc, IdIntro.equivSnd, ← UvPoly.Equiv.snd'_comp_right] + -- FIXME: `transparency := .default` is like `erw` and should be avoided + rw! (transparency := .default) [WeakPullback.coherentLift_snd] + simp only [IdIntro.equivMk] + rw! [equivFst_lift_eq] + simp + +lemma comp_j : (ii.motiveSubst σ _) ≫ j i a C r r_tp = + j i ((σ) ≫ a) ((ii.motiveSubst σ _) ≫ C) ((σ) ≫ r) (by + simp [r_tp, IdIntro.comp_reflSubst'_assoc]) := by + simp only [j] + conv => rhs; rw! [i.lift_comp_left a C r r_tp] + rw [equivSnd_comp_left] + simp only [← Category.assoc] + congr 1 + simp [← heq_eq_eq] + rw [equivFst_lift_eq] + +/-- β rule for identity types. Substituting `J` with `refl` gives the user-supplied value `r` -/ +lemma reflSubst_j : (ii.reflSubst a) ≫ j i a C r r_tp = r := sorry +-- by +-- have h := ie.equivSnd_verticalNatTrans_app (i.lift a C r r_tp) +-- -- FIXME: `transparency := .default` is like `erw` and should be avoided +-- rw! (transparency := .default) [i.weakPullback.coherentLift_fst] at h +-- unfold reflCase at h +-- rw [UvPoly.Equiv.snd'_eq_snd', UvPoly.Equiv.snd'_mk', ← Iso.eq_inv_comp] at h +-- conv => right; rw [h] +-- simp only [j, ← Category.assoc, UvPoly.Equiv.fst_mk', UvPoly.id_p] +-- congr 1 +-- have pb : IsPullback (𝟙 _) a a (𝟙 _) := IsPullback.of_id_fst +-- have : (IsPullback.isoIsPullback y(Γ) M.Tm pb pb).inv = 𝟙 _ := by +-- apply pb.hom_ext +-- · simp only [IsPullback.isoIsPullback_inv_fst] +-- simp +-- · simp +-- simp only [← heq_eq_eq, comp_eqToHom_heq_iff] +-- rw! [equivFst_lift_eq] +-- simp [this] + +variable (b : (Γ) ⟶ M.Tm) (b_tp : b ≫ M.tp = a ≫ M.tp) + (h : (Γ) ⟶ M.Tm) (h_tp : h ≫ M.tp = (M.disp_pullback _ ).lift b a (by aesop) ≫ ii.Id) + +def endPtSubst : Γ ⟶ ii.motiveCtx a := + M.substCons (M.substCons (𝟙 _) _ b (by aesop)) _ h (by + simp only [h_tp, IdIntro.mkId, ← Category.assoc] + congr 1 + apply (M.disp_pullback _ ).hom_ext + · simp + · simp) + +/-- `Id` is equivalent to `Id` (one half). -/ +def toUnstructured : M.toUnstructuredUniverse.PolymorphicIdElim + ii.toPolymorphicIdIntro N.toUnstructuredUniverse where + j {Γ A} a a_tp C c e := by + let w := M.disp_pullback (ii.mkId (M.disp (a ≫ M.tp) ≫ a) (M.var _) (by simp)) + + let iso: ii.toPolymorphicIdIntro.motiveCtx a a_tp ⟶ ii.motiveCtx a := by + fapply (w.lift (W:= ii.toPolymorphicIdIntro.motiveCtx a a_tp) ) + · apply (M.var ((ii.toPolymorphicIdIntro).weakenId a a_tp)) + · convert (M.disp ((ii.toPolymorphicIdIntro).weakenId a a_tp)) + · simp + sorry + have f1 : ii.motiveCtx a ⟶ N.Tm := by + fapply i.j + · sorry + · sorry + · sorry + exact (iso ≫ f1) + -- sorry + --#check i.j + -- sorry --i.j + j_tp := sorry -- i.j_tp + comp_j := sorry --i.comp_j + reflSubst_j := sorry -- i.reflSubst_j + +end Id + +def IdIntro.ofUnstructured + (i : M.toUnstructuredUniverse.PolymorphicIdIntro M.toUnstructuredUniverse) : M.IdIntro := + have := i -- TODO remove + sorry + +namespace Id + +variable {N : StructuredUniverse R} + (ii : M.toUnstructuredUniverse.PolymorphicIdIntro M.toUnstructuredUniverse) + (i : M.Id (IdIntro.ofUnstructured ii) N) +open IdIntro + +--ie |-> (IdIntro.ofUnstructured ii) + +variable {Γ} (ar : (Γ) ⟶ (UvPoly.id R M.Tm).functor.obj N.Tm) + (aC : (Γ) ⟶ (iFunctor ((IdIntro.ofUnstructured ii))).obj N.Ty) + (hrC : ar ≫ (UvPoly.id R M.Tm).functor.map N.tp = + aC ≫ (verticalNatTrans (IdIntro.ofUnstructured ii)).app N.Ty) + +include hrC in +lemma fst_eq_fst : UvPoly.Equiv.fst ar = (IdIntro.ofUnstructured ii).equivFst aC := + calc _ + _ = UvPoly.Equiv.fst (ar ≫ (UvPoly.id R M.Tm).functor.map N.tp) := by + rw [UvPoly.Equiv.fst_comp_right] + _ = UvPoly.Equiv.fst (aC ≫ (verticalNatTrans (IdIntro.ofUnstructured ii)).app N.Ty) := by + rw [hrC] + _ = _ := by + sorry + --rw [equivFst_verticalNatTrans_app] + +-- abbrev motive1 : (ii.motiveCtx ((IdIntro.ofUnstructured ii).equivFst aC)) ⟶ N.Ty := +-- ie.equivSnd aC + +-- lemma comp_motive {Δ} (σ : Δ ⟶ Γ) : motive ((σ) ≫ aC) = +-- ym(ii.motiveSubst σ (equivFst aC)) ≫ motive aC := by +-- simp only [motive, equivSnd_comp_left ie aC σ] + + +/- +abbrev reflCase : y(Γ) ⟶ N.Tm := UvPoly.Equiv.snd' _ _ ar (Id.reflCase_aux _) + +lemma comp_reflCase {Δ} (σ : Δ ⟶ Γ) : reflCase (ym(σ) ≫ ar) = ym(σ) ≫ reflCase ar := by + simp only [reflCase] + rw [UvPoly.Equiv.snd'_comp_left (UvPoly.id M.Tm) N.Tm ar + (Id.reflCase_aux (UvPoly.Equiv.fst (UvPoly.id M.Tm) N.Tm ar)) ym(σ) + (Id.reflCase_aux _)] + congr 1 + apply (Id.reflCase_aux (UvPoly.Equiv.fst (UvPoly.id M.Tm) N.Tm ar)).hom_ext + · simp only [IsPullback.lift_fst] + simp + · simp + +include hrC in +lemma reflCase_comp_tp : reflCase ar ≫ N.tp = + ym(ii.reflSubst (ie.equivFst aC)) ≫ motive aC := by + dsimp [reflCase, motive] + rw! [← UvPoly.Equiv.snd'_comp_right, hrC] + have H : IsPullback ym(M.disp (ii.mkId + (ym(M.disp (ie.equivFst aC ≫ M.tp)) ≫ ie.equivFst aC) + (M.var (ie.equivFst aC ≫ M.tp)) (by simp)) ≫ + M.disp (ie.equivFst aC ≫ M.tp)) + (ie.toI (ie.equivFst aC)) (UvPoly.Equiv.fst ie.iUvPoly N.Ty aC) ie.iUvPoly.p := by + convert (ie.motiveCtx_isPullback' (ie.equivFst aC)).flip + simp + -- FIXME: `transparency := .default` is like `erw` and should be avoided + rw! (transparency := .default) [UvPoly.snd'_verticalNatTrans_app + (R := y(ii.motiveCtx (ie.equivFst aC))) + (H := H) + (R' := y(Γ)) (f' := 𝟙 _) (g' := UvPoly.Equiv.fst (UvPoly.id M.Tm) N.Tm ar) + (H' := by + rw [fst_eq_fst ar aC hrC] + exact Id.reflCase_aux _)] + simp only [Functor.map_comp, iUvPoly_p, equivSnd] + congr 1 + apply (M.disp_pullback _).hom_ext <;> + simp only [reflSubst, substCons_var, substCons_disp_functor_map, substCons_var] + · simp [← ie.toI_comp_i1 (ie.equivFst aC), fst_eq_fst ar aC hrC, mkRefl] + · apply (M.disp_pullback _).hom_ext + · rw! [fst_eq_fst ar aC hrC] + slice_lhs 3 4 => rw [← ii.toK_comp_k1] + slice_lhs 2 3 => rw [← ie.toI_comp_i2] + simp + · simp +-/ +namespace ofUnstructured +#check ar +def lift : Γ ⟶ (iFunctor (IdIntro.ofUnstructured ii)).obj N.Tm := + equivMk (IdIntro.ofUnstructured ii) (equivFst (IdIntro.ofUnstructured ii) aC) + (by + fapply i.j + · sorry + · have a : Γ ⟶ (UvPoly.id R M.Tm) @ N.Tm := ar + have a1 : Γ ⟶ M.Tm := UvPoly.Equiv.fst a + have a2:= UvPoly.Equiv.snd a + -- (pullback.lift (𝟙 _) a1 ≫ a2) + exact (pullback.lift (𝟙 _) (UvPoly.Equiv.fst a) ≫ UvPoly.Equiv.snd a) + --apply UvPoly.Equiv.fst (E := N.Tm) (B := N.Tm) sorry + · sorry) + + --sorry) + #check i.j + -- (i.j sorry _ sorry sorry) + -- (i.j (equivFst (IdIntro.ofUnstructured ii) aC) + -- (motive aC) + -- (reflCase ar) (reflCase_comp_tp ar aC hrC)) + +-- lemma lift_fst : lift i ar aC hrC ≫ ie.verticalNatTrans.app N.Tm = ar := by +-- dsimp only [lift] +-- rw [equivMk_comp_verticalNatTrans_app] +-- apply UvPoly.Equiv.ext' (UvPoly.id M.Tm) N.Tm (by convert reflCase_aux (ie.equivFst aC); simp) +-- · rw! [i.reflSubst_j] +-- simp [reflCase, fst_eq_fst ar aC hrC] +-- · simp [fst_eq_fst ar aC hrC] + +-- lemma lift_snd : lift i ar aC hrC ≫ ie.iFunctor.map N.tp = aC := by +-- dsimp only [lift, equivMk] +-- rw [UvPoly.Equiv.mk'_comp_right] +-- apply UvPoly.Equiv.ext' ie.iUvPoly N.Ty +-- · rw! [i.j_tp] +-- rw [UvPoly.Equiv.snd'_mk'] +-- simp [motive, equivSnd] +-- · simp only [UvPoly.Equiv.fst_mk', iUvPoly_p] +-- exact (ie.motiveCtx_isPullback' _).flip +-- · simp [equivFst] + +-- lemma comp_lift {Δ} (σ : Δ ⟶ Γ) : ym(σ) ≫ lift i ar aC hrC = +-- lift i (ym(σ) ≫ ar) (ym(σ) ≫ aC) (by simp [hrC]) := by +-- dsimp [lift, equivMk] +-- rw [UvPoly.Equiv.mk'_comp_left ie.iUvPoly N.Tm (ie.equivFst aC) _ +-- (i.j (ie.equivFst aC) (motive aC) (reflCase ar) _) ym(σ) _ rfl +-- (by simp only [iUvPoly_p]; exact (ie.motiveCtx_isPullback' _).flip)] +-- congr 1 +-- have h := i.comp_j σ (ie.equivFst aC) _ _ (reflCase_comp_tp ar aC hrC) +-- rw! (castMode := .all) [← comp_motive, ← comp_reflCase, ← equivFst_comp_left] at h +-- rw [← h] +-- congr 1 +-- simp only [iUvPoly_p, Category.assoc] +-- apply (M.disp_pullback _).hom_ext +-- · simp [toI_comp_left, ← toI_comp_i1 ie] +-- · apply (M.disp_pullback _).hom_ext +-- · slice_rhs 3 4 => rw [← toK_comp_k1 ii] +-- slice_rhs 2 3 => rw [← toI_comp_i2 ie] +-- slice_lhs 3 4 => rw [← toK_comp_k1 ii] +-- slice_lhs 2 3 => rw [← toI_comp_i2 ie] +-- simp [toI_comp_left] +-- · simp [motiveSubst, substWk] + + + +end ofUnstructured +def ofUnstructured (ie : M.toUnstructuredUniverse.PolymorphicIdElim ii N.toUnstructuredUniverse) : + M.Id (IdIntro.ofUnstructured ii) N where + __ := ie + weakPullback := { + w := sorry + lift {Γ}:= sorry + lift_fst' := sorry + lift_snd' := sorry + } + -- RepPullbackCone.WeakPullback.mk + -- ((IdIntro.verticalNatTrans sorry).naturality _).symm + -- (fun s => lift i s.fst sorry s.snd s.condition) + -- sorry + -- sorry + -- sorry + -- (fun s => lift i s.fst sorry s.snd s.condition) + -- (fun s => lift_fst i s.fst s.snd s.condition) + -- (fun s => lift_snd i s.fst s.snd s.condition) + -- (fun s _ σ => comp_lift i s.fst s.snd s.condition σ) + + +end Id + +end StructuredUniverse diff --git a/HoTTLean/Model/Structured/StructuredUniverseBackup2.lean b/HoTTLean/Model/Structured/StructuredUniverseBackup2.lean new file mode 100644 index 00000000..646bc153 --- /dev/null +++ b/HoTTLean/Model/Structured/StructuredUniverseBackup2.lean @@ -0,0 +1,1409 @@ +import Mathlib.CategoryTheory.Limits.Shapes.KernelPair +import HoTTLean.ForMathlib +import HoTTLean.ForMathlib.Tactic.CategoryTheory.FunctorMap +import HoTTLean.ForMathlib.CategoryTheory.RepPullbackCone +import HoTTLean.ForMathlib.CategoryTheory.WeakPullback +import HoTTLean.ForMathlib.CategoryTheory.Polynomial +import HoTTLean.Model.Unstructured.UnstructuredUniverse +import Mathlib.CategoryTheory.Limits.Shapes.BinaryProducts +universe v u + +noncomputable section + +open CategoryTheory Limits Opposite + +namespace Model + +/-- A natural model with support for dependent types (and nothing more). +The data is a natural transformation with representable fibers, +stored as a choice of representative for each fiber. -/ +structure StructuredUniverse {Ctx : Type u} [Category Ctx] (R : MorphismProperty Ctx) + extends UnstructuredUniverse Ctx where + morphismProperty : R tp + +namespace StructuredUniverse + +open Model.UnstructuredUniverse + +section + +variable {Ctx : Type u} [Category Ctx] {R : MorphismProperty Ctx} (M : StructuredUniverse R) + [R.HasPullbacks] [R.IsStableUnderBaseChange] + +instance {Γ : Ctx} (A : Γ ⟶ M.Ty) : HasPullback A M.tp := + have := MorphismProperty.HasPullbacks.hasPullback A M.morphismProperty + hasPullback_symmetry _ _ + +lemma disp_mem {Γ : Ctx} (A : Γ ⟶ M.Ty) : R (M.disp A) := + R.of_isPullback (M.disp_pullback A) M.morphismProperty + +@[simps! hom inv] +def pullbackIsoExt {Γ : Ctx} (A : Γ ⟶ M.Ty) : + pullback A M.tp ≅ (M.ext A) := + IsPullback.isoPullback (M.disp_pullback A).flip |>.symm + +/-! ## Pullback of representable natural transformation -/ + +/-- Pull a natural model back along a type. -/ +protected def pullback {Γ : Ctx} (A : Γ ⟶ M.Ty) : StructuredUniverse R where + __ := UnstructuredUniverse.pullback M.toUnstructuredUniverse A + morphismProperty := M.disp_mem A + +/-- + Given the pullback square on the right, + with a natural model structure on `tp : Tm ⟶ Ty` + giving the outer pullback square. + + Γ.A -.-.- var -.-,-> E ------ toTm ------> Tm + | | | + | | | + M.disp π tp + | | | + V V V + Γ ------- A -------> U ------ toTy ------> Ty + + construct a natural model structure on `π : E ⟶ U`, + by pullback pasting. +-/ +def ofIsPullback {U E : Ctx} {π : E ⟶ U} + {toTy : U ⟶ M.Ty} {toTm : E ⟶ M.Tm} + (pb : IsPullback toTm π M.tp toTy) : + StructuredUniverse R where + __ := UnstructuredUniverse.ofIsPullback M.toUnstructuredUniverse pb + morphismProperty := R.of_isPullback pb M.morphismProperty + +/-! ## Polynomial functor on `tp` + +Specializations of results from the `Poly` package to natural models. -/ + +abbrev uvPolyTp : UvPoly R M.Tm M.Ty := ⟨M.tp, M.morphismProperty⟩ + +variable [ChosenTerminal Ctx] [R.HasObjects] [R.IsMultiplicative] + [R.HasPushforwards R] [R.IsStableUnderPushforwards R] + +instance : R.HasPushforwardsAlong M.uvPolyTp.p := + MorphismProperty.HasPushforwards.hasPushforwardsAlong M.tp M.morphismProperty + +instance : R.IsStableUnderPushforwardsAlong M.uvPolyTp.p := + MorphismProperty.IsStableUnderPushforwards.of_isPushforward M.tp M.morphismProperty + +def Ptp : Ctx ⥤ Ctx := M.uvPolyTp.functor + +namespace PtpEquiv + +variable {Γ : Ctx} {X : Ctx} + +/-- +A map `(AB : Γ ⟶ M.Ptp.obj X)` is equivalent to a pair of maps +`A : Γ ⟶ M.Ty` and `B : (M.ext (fst M AB)) ⟶ X`, +thought of as a dependent pair `A : Type` and `B : A ⟶ Type`. +`PtpEquiv.fst` is the `A` in this pair. +-/ +def fst (AB : Γ ⟶ M.Ptp.obj X) : Γ ⟶ M.Ty := + UvPoly.Equiv.fst AB + +/-- +A map `(AB : Γ ⟶ M.Ptp.obj X)` is equivalent to a pair of maps +`A : Γ ⟶ M.Ty` and `B : (M.ext (fst M AB)) ⟶ X`, +thought of as a dependent pair `A : Type` and `B : A ⟶ Type` +`PtpEquiv.snd` is the `B` in this pair. +-/ +def snd (AB : Γ ⟶ M.Ptp.obj X) (A := fst M AB) (eq : fst M AB = A := by rfl) : M.ext A ⟶ X := + UvPoly.Equiv.snd' AB (by rw [← fst, eq]; exact (M.disp_pullback _).flip) + +/-- +A map `(AB : Γ ⟶ M.Ptp.obj X)` is equivalent to a pair of maps +`A : Γ ⟶ M.Ty` and `B : (M.ext (fst M AB)) ⟶ X`, +thought of as a dependent pair `A : Type` and `B : A ⟶ Type` +`PtpEquiv.mk` constructs such a map `AB` from such a pair `A` and `B`. +-/ +def mk (A : Γ ⟶ M.Ty) (B : M.ext A ⟶ X) : Γ ⟶ M.Ptp.obj X := + UvPoly.Equiv.mk' A (M.disp_pullback _).flip B + +@[simp] +lemma fst_mk (A : Γ ⟶ M.Ty) (B : M.ext A ⟶ X) : + fst M (mk M A B) = A := by + simp [fst, mk] + +@[simp] +lemma snd_mk (A : Γ ⟶ M.Ty) (B : M.ext A ⟶ X) : + snd M (mk M A B) _ (fst_mk ..) = B := by + dsimp only [snd, mk] + rw! [UvPoly.Equiv.snd'_mk' (P := M.uvPolyTp)] + +section +variable {Δ : Ctx} {σ : Δ ⟶ Γ} {AB : Γ ⟶ M.Ptp.obj X} + +theorem fst_comp_left (σ : Δ ⟶ Γ) : fst M (σ ≫ AB) = σ ≫ fst M AB := + UvPoly.Equiv.fst_comp_left .. + +@[simp] +theorem fst_comp_right {Y} (σ : X ⟶ Y) : fst M (AB ≫ M.Ptp.map σ) = fst M AB := + UvPoly.Equiv.fst_comp_right .. + +theorem snd_comp_right {Y} (σ : X ⟶ Y) {A} (eq : fst M AB = A) : + snd M (AB ≫ M.Ptp.map σ) _ (by simpa) = snd M AB _ eq ≫ σ := by + simp only [snd, Ptp] + rw [UvPoly.Equiv.snd'_comp_right (P := M.uvPolyTp)] + +theorem snd_comp_left {A} (eqA : fst M AB = A) {σA} (eqσ : σ ≫ A = σA) : + snd M (σ ≫ AB) σA (by simp [fst_comp_left, eqA, eqσ]) = + (M.substWk σ _ _ eqσ) ≫ snd M AB _ eqA := by + have H1 : IsPullback (M.disp A) (M.var A) (UvPoly.Equiv.fst AB) M.tp := by + rw [← fst, eqA]; exact (M.disp_pullback _).flip + have H2 : IsPullback (M.disp σA) (M.var σA) + (σ ≫ UvPoly.Equiv.fst AB) M.tp := by + rw [← fst, eqA, eqσ]; exact (M.disp_pullback _).flip + convert UvPoly.Equiv.snd'_comp_left AB H1 _ H2 + apply H1.hom_ext <;> simp [substWk] + +theorem mk_comp_left {Δ Γ : Ctx} (M : StructuredUniverse R) (σ : Δ ⟶ Γ) + {X : Ctx} (A : Γ ⟶ M.Ty) (σA) (eq : σ ≫ A = σA) (B : (M.ext A) ⟶ X) : + σ ≫ PtpEquiv.mk M A B = PtpEquiv.mk M σA ((M.substWk σ A _ eq) ≫ B) := by + dsimp [PtpEquiv.mk] + have h := UvPoly.Equiv.mk'_comp_left (P := M.uvPolyTp) A (f := M.disp A) (g := M.var A) + (by convert (M.disp_pullback A).flip) B σ σA eq (M.disp_pullback σA).flip + convert h + apply (M.disp_pullback _).hom_ext + · simp + · simp [substWk_disp] + +theorem mk_comp_right {Γ : Ctx} (M : StructuredUniverse R) + {X Y : Ctx} (σ : X ⟶ Y) (A : Γ ⟶ M.Ty) (B : (M.ext A) ⟶ X) : + PtpEquiv.mk M A B ≫ M.Ptp.map σ = PtpEquiv.mk M A (B ≫ σ) := + UvPoly.Equiv.mk'_comp_right .. + +theorem ext {AB AB' : Γ ⟶ M.Ptp.obj X} (A := fst M AB) (eq : fst M AB = A := by rfl) + (h1 : fst M AB = fst M AB') (h2 : snd M AB A eq = snd M AB' A (h1 ▸ eq)) : + AB = AB' := UvPoly.Equiv.ext' _ h1 h2 + +theorem eta (AB : Γ ⟶ M.Ptp.obj X) : mk M (fst M AB) (snd M AB) = AB := + .symm <| ext _ _ rfl (by simp) (by simp) + +end + +end PtpEquiv + +@[reassoc] +theorem PtpEquiv.mk_map {Γ : Ctx} {X Y : Ctx} + (A : Γ ⟶ M.Ty) (x : (M.ext A) ⟶ X) (α : X ⟶ Y) : + mk M A x ≫ M.Ptp.map α = mk M A (x ≫ α) := by + simp [mk, Ptp, UvPoly.Equiv.mk'_comp_right] + +/-! ## Polynomial composition `M.tp ▸ N.tp` -/ + +abbrev compDom (M N : StructuredUniverse R) : Ctx := M.uvPolyTp.compDom N.uvPolyTp + +abbrev compP (M N : StructuredUniverse R) : M.compDom N ⟶ M.uvPolyTp @ N.Ty := + (M.uvPolyTp.comp N.uvPolyTp).p + +namespace compDomEquiv +open UvPoly + +variable {M N : StructuredUniverse R} {Γ Δ : Ctx} (σ : Δ ⟶ Γ) + +/-- Universal property of `compDom`, decomposition (part 1). + +A map `ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +`fst, dependent, snd` such that `fst_tp` and `snd_tp`. The map `fst : Γ ⟶ M.Tm` +is the `(a : A)` in `(a : A) × (b : B a)`. +-/ +abbrev fst (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : Γ ⟶ M.Tm := + UvPoly.compDomEquiv.fst ab + +/-- Computation of `comp` (part 1). + +`fst_tp` is (part 1) of the computation that + (α, B, β, h) + Γ ⟶ compDom + \ | + \ | comp +(α ≫ tp, B) | + \ V + > P_tp Ty +Namely the first projection `α ≫ tp` agrees. +-/ +theorem fst_tp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : + fst ab ≫ M.tp = PtpEquiv.fst M (ab ≫ M.compP N) := + UvPoly.compDomEquiv.fst_comp_p .. + +@[reassoc] +theorem fst_comp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) (σ : Δ ⟶ Γ) : + fst (σ ≫ ab) = σ ≫ fst ab := + UvPoly.compDomEquiv.fst_comp .. + +/-- Universal property of `compDom`, decomposition (part 2). + +A map `ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +`fst, dependent, snd` such that `fst_tp` and `snd_tp`. +The map `dependent : (M.ext (fst N ab ≫ M.tp)) ⟶ M.Ty` +is the `B : A ⟶ Type` in `(a : A) × (b : B a)`. +Here `A` is implicit, derived by the typing of `fst`, or `(a : A)`. +-/ +def dependent (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + (A := fst ab ≫ M.tp) (eq : fst ab ≫ M.tp = A := by rfl) : + (M.ext A) ⟶ N.Ty := + UvPoly.compDomEquiv.dependent ab (M.disp A) (M.var A) <| by + simpa [eq] using (M.disp_pullback A).flip + +lemma dependent_eq (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + (A := fst ab ≫ M.tp) (eq : fst ab ≫ M.tp = A := by rfl) : + dependent ab A eq = PtpEquiv.snd M (ab ≫ M.compP N) A (by simp [← eq, fst_tp]) := by + simp [dependent, UvPoly.compDomEquiv.dependent, PtpEquiv.snd] + +theorem comp_dependent (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + {A} (eq1 : fst ab ≫ M.tp = A) + {σA} (eq2 : σ ≫ A = σA) : + (M.substWk σ _ _ eq2) ≫ dependent ab A eq1 = + dependent (σ ≫ ab) σA (by simp [fst_comp, eq1, eq2]) := by + dsimp [dependent] + rw [UvPoly.compDomEquiv.dependent_comp σ ab (M.disp A) (M.var A) + (by simpa [eq1] using (M.disp_pullback A).flip)] + · congr 1 + simp [substWk, substCons] + apply (M.disp_pullback A).hom_ext <;> simp + +/-- Universal property of `compDom`, decomposition (part 3). + +A map `ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +`fst, dependent, snd` such that `fst_tp` and `snd_tp`. +The map `snd : Γ ⟶ M.Tm` +is the `(b : B a)` in `(a : A) × (b : B a)`. +-/ +abbrev snd (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : Γ ⟶ N.Tm := + UvPoly.compDomEquiv.snd ab + +@[reassoc] +theorem snd_comp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) (σ : Δ ⟶ Γ) : + snd (σ ≫ ab) = σ ≫ snd ab := + UvPoly.compDomEquiv.snd_comp .. + +/-- Universal property of `compDom`, decomposition (part 4). + +A map `ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +`fst, dependent, snd` such that `fst_tp` and `snd_tp`. +The equation `snd_tp` says that the type of `b : B a` agrees with +the expression for `B a` obtained solely from `dependent`, or `B : A ⟶ Type`. +-/ +theorem snd_tp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + {A} (eq : fst ab ≫ M.tp = A := by rfl) : + snd ab ≫ N.tp = (M.sec _ (fst ab) eq) ≫ dependent ab A eq := by + rw [UvPoly.compDomEquiv.snd_comp_p ab (M.disp A) (M.var A) <| by + simpa [eq] using (M.disp_pullback A).flip] + congr 1 + apply (disp_pullback ..).hom_ext + · simp + · simp + +/-- Universal property of `compDom`, constructing a map into `compDom`. -/ +def mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : M.ext A ⟶ N.Ty) (β : Γ ⟶ N.Tm) + (h : β ≫ N.tp = M.sec _ α eq ≫ B) : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp := + UvPoly.compDomEquiv.mk _ α eq (M.disp A) (M.var A) (M.disp_pullback A).flip B β (by + convert h + apply (disp_pullback ..).hom_ext <;> simp) + +@[simp] +theorem fst_mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A := by rfl) (B : (M.ext A) ⟶ N.Ty) + (β : Γ ⟶ N.Tm) (h : β ≫ N.tp = (M.sec _ α eq) ≫ B) : fst (mk α eq B β h) = α := by + simp [mk, fst] + +@[simp] +theorem dependent_mk (α : Γ ⟶ M.Tm) {A A'} (eq : α ≫ M.tp = A) (hA' : A' = A) + (B : M.ext A ⟶ N.Ty) (β : Γ ⟶ N.Tm) + (h : β ≫ N.tp = (M.sec _ α eq) ≫ B) : + dependent (mk α eq B β h) A' (by simp [hA', fst_mk, eq]) = eqToHom (by rw [hA']) ≫ B := by + subst hA' + simp [mk, dependent] + +@[simp] +theorem snd_mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : (M.ext A) ⟶ N.Ty) (β : Γ ⟶ N.Tm) + (h : β ≫ N.tp = (M.sec _ α eq) ≫ B) : snd (mk α eq B β h) = β := by + simp [mk, snd] + +theorem ext {ab₁ ab₂ : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp} + {A} (eq : fst ab₁ ≫ M.tp = A) + (h1 : fst ab₁ = fst ab₂) + (h2 : dependent ab₁ A eq = dependent ab₂ A (h1 ▸ eq)) + (h3 : snd ab₁ = snd ab₂) : ab₁ = ab₂ := by + apply UvPoly.compDomEquiv.ext ab₁ ab₂ h1 h3 (M.disp _) (M.var _) (M.disp_pullback _).flip + dsimp only [dependent] at * + subst eq + rw! [h2] + +theorem comp_mk (α : Γ ⟶ M.Tm) {A} (e1 : α ≫ M.tp = A) (B : (M.ext A) ⟶ N.Ty) + (β : Γ ⟶ N.Tm) (e2 : β ≫ N.tp = (M.sec A α e1) ≫ B) (σ : Δ ⟶ Γ) {σA} (e3 : σ ≫ A = σA) : + σ ≫ mk α e1 B β e2 = + mk (σ ≫ α) (by simp [e1, e3]) + ((M.substWk σ A _ e3) ≫ B) (σ ≫ β) + (by simp [e2]; rw [← Category.assoc, comp_sec]; simp; congr!) := by + dsimp only [mk] + rw [UvPoly.compDomEquiv.comp_mk (P := M.uvPolyTp) (P' := N.uvPolyTp) σ _ α e1 (M.disp _) + (M.var _) (M.disp_pullback _).flip (M.disp _) (M.var _) (M.disp_pullback _).flip] + subst e1 e3 + congr 2 + apply (disp_pullback ..).hom_ext <;> simp [substWk_disp] + +@[reassoc] +lemma mk_comp (α : Γ ⟶ M.Tm) {A} (e1 : α ≫ M.tp = A) (B : (M.ext A) ⟶ N.Ty) + (β : Γ ⟶ N.Tm) (e2 : β ≫ N.tp = (M.sec A α e1) ≫ B) : + mk α e1 B β e2 ≫ M.compP N = PtpEquiv.mk M A B := by + erw [PtpEquiv.mk, UvPoly.compDomEquiv.mk_comp (P := M.uvPolyTp) (P' := N.uvPolyTp)] + +theorem eta (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) + {A} (eq : fst ab ≫ M.tp = A) : + mk (fst ab) eq (dependent ab A eq) (snd ab) (snd_tp ab eq) = ab := by + symm; apply ext (eq := eq) <;> simp + +end compDomEquiv + +end + +variable {Ctx : Type u} [Category Ctx] {R : MorphismProperty Ctx} + [R.HasPullbacks] [R.IsStableUnderBaseChange] + [ChosenTerminal Ctx] [R.HasObjects] [R.IsMultiplicative] + [R.HasPushforwards R] [R.IsStableUnderPushforwards R] + +/-! ## Pi types -/ + +/-- The structure on three universes that for +`A : Γ ⟶ U0.Ty` and `B : Γ.A ⟶ U1.Ty` constructs a Π-type `Π_A B : Γ ⟶ U2.Ty`. +-/ +structure PolymorphicPi (U0 U1 U2 : StructuredUniverse R) where + Pi : U0.Ptp.obj U1.Ty ⟶ U2.Ty + lam : U0.Ptp.obj U1.Tm ⟶ U2.Tm + Pi_pullback : IsPullback lam (U0.Ptp.map U1.tp) U2.tp Pi + +set_option linter.dupNamespace false in +/-- A universe `M` has Π-type structure. This is the data of a pullback square +``` + lam +Ptp Tm ------> Tm + | | +Ptp tp |tp + | | + V V +Ptp Ty ------> Ty + Pi +``` +-/ +protected abbrev Pi (U : StructuredUniverse R) := PolymorphicPi U U U + +namespace PolymorphicPi + +variable {U0 U1 U2 : StructuredUniverse R} {Γ : Ctx} + +section +variable (P : PolymorphicPi U0 U1 U2) + +/-- +``` +Γ ⊢₀ A Γ.A ⊢₁ B +----------------- +Γ ⊢₂ ΠA. B +``` -/ +def mkPi {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) : Γ ⟶ U2.Ty := + PtpEquiv.mk U0 A B ≫ P.Pi + +theorem comp_mkPi {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : (Γ) ⟶ U0.Ty) (σA) (eq : (σ) ≫ A = σA) + (B : (U0.ext A) ⟶ U1.Ty) : + (σ) ≫ P.mkPi A B = P.mkPi σA ((U0.substWk σ A _ eq) ≫ B) := by + simp [mkPi, ← Category.assoc, PtpEquiv.mk_comp_left (eq := eq)] + +/-- +``` +Γ ⊢₀ A Γ.A ⊢₁ t : B +------------------------- +Γ ⊢₂ λA. t : ΠA. B +``` -/ +def mkLam {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (t : (U0.ext A) ⟶ U1.Tm) : (Γ) ⟶ U2.Tm := + PtpEquiv.mk U0 A t ≫ P.lam + +@[simp] +theorem mkLam_tp {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (t : (U0.ext A) ⟶ U1.Tm) (t_tp : t ≫ U1.tp = B) : + P.mkLam A t ≫ U2.tp = P.mkPi A B := by + simp [mkLam, mkPi, P.Pi_pullback.w, PtpEquiv.mk_map_assoc, t_tp] + +theorem comp_mkLam {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : (Γ) ⟶ U0.Ty) (σA) (eq : (σ) ≫ A = σA) (t : (U0.ext A) ⟶ U1.Tm) : + (σ) ≫ P.mkLam A t = P.mkLam σA ((U0.substWk σ A _ eq) ≫ t) := by + simp [mkLam, ← Category.assoc, PtpEquiv.mk_comp_left (eq := eq)] + + +/-- +``` +Γ ⊢₀ A Γ ⊢₂ f : ΠA. B +----------------------------- +Γ.A ⊢₁ unlam f : B +``` -/ +def unLam {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + (U0.ext A) ⟶ U1.Tm := by + let total : (Γ) ⟶ U0.Ptp.obj U1.Tm := + P.Pi_pullback.lift f (PtpEquiv.mk U0 A B) f_tp + refine PtpEquiv.snd U0 total _ ?_ + have eq : total ≫ U0.Ptp.map U1.tp = PtpEquiv.mk U0 A B := + (P.Pi_pullback).lift_snd .. + apply_fun PtpEquiv.fst U0 at eq + rw [PtpEquiv.fst_comp_right] at eq + simpa using eq + +@[simp] +theorem unLam_tp {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + P.unLam A B f f_tp ≫ U1.tp = B := by + rw [unLam, ← PtpEquiv.snd_comp_right] + convert PtpEquiv.snd_mk U0 A B using 2; simp + +theorem comp_unLam {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : (Γ) ⟶ U0.Ty) (σA) (eq : (σ) ≫ A = σA) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + (U0.substWk σ A _ eq) ≫ P.unLam A B f f_tp = + P.unLam σA ((U0.substWk σ A _ eq) ≫ B) + ((σ) ≫ f) (by simp [eq, f_tp, comp_mkPi]) := by + simp [unLam] + rw [← PtpEquiv.snd_comp_left] + simp [PtpEquiv.snd, UvPoly.Equiv.snd'_eq]; congr 1 + apply pullback.hom_ext <;> simp; congr 1 + apply (P.Pi_pullback).hom_ext <;> simp + rw [PtpEquiv.mk_comp_left] + +/-- +``` +Γ ⊢₂ f : ΠA. B Γ ⊢₀ a : A +--------------------------------- +Γ ⊢₁ f a : B[id.a] +``` -/ +def mkApp {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) + (a : (Γ) ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) : (Γ) ⟶ U1.Tm := + (U0.sec A a a_tp) ≫ P.unLam A B f f_tp + +@[simp] +theorem mkApp_tp {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : (Γ) ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) + (a : (Γ) ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) : + P.mkApp A B f f_tp a a_tp ≫ U1.tp = (U0.sec A a a_tp) ≫ B := by + simp [mkApp] + +theorem comp_mkApp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : Γ ⟶ U0.Ty) (σA) (eq : σ ≫ A = σA) (B : (U0.ext A) ⟶ U1.Ty) + (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) + (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) : + σ ≫ P.mkApp A B f f_tp a a_tp = + P.mkApp σA (U0.substWk σ A _ eq ≫ B) + (σ ≫ f) (by simp [f_tp, comp_mkPi (eq := eq)]) + (σ ≫ a) (by simp [a_tp, eq]) := by + unfold mkApp; rw [← Category.assoc, + comp_sec σ a_tp _ eq, Category.assoc, comp_unLam (eq := eq)] + +@[simp] +theorem mkLam_unLam {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + P.mkLam A (P.unLam A B f f_tp) = f := by + let total : Γ ⟶ U0.Ptp.obj U1.Tm := + (P.Pi_pullback).lift f (PtpEquiv.mk U0 A B) f_tp + simp only [mkLam, unLam] + have : PtpEquiv.fst U0 total = A := by + simp only [PtpEquiv.fst, UvPoly.Equiv.fst_eq, total] + rw [← U0.uvPolyTp.map_fstProj U1.tp] + slice_lhs 1 2 => apply (P.Pi_pullback).lift_snd + apply PtpEquiv.fst_mk + slice_lhs 1 1 => equals total => + apply PtpEquiv.ext _ (A := A) (by simp) (by simp [this]) (by simp [total]) + apply (P.Pi_pullback).lift_fst + +@[simp] +theorem unLam_mkLam {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : U0.ext A ⟶ U1.Tm) (t_tp : t ≫ U1.tp = B) + (lam_tp : P.mkLam A t ≫ U2.tp = P.mkPi A B) : + P.unLam A B (P.mkLam A t) lam_tp = t := by + simp [mkLam, unLam] + convert PtpEquiv.snd_mk U0 A t using 2 + apply (P.Pi_pullback).hom_ext <;> simp + rw [PtpEquiv.mk_comp_right, t_tp] + +/-- +``` +Γ ⊢₂ f : ΠA. B +-------------------------------------- +Γ ⊢₂ λA. f[↑] v₀ : ΠA. B +``` +-/ +def etaExpand {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + (Γ) ⟶ U2.Tm := + P.mkLam A <| + P.mkApp + (U0.disp A ≫ A) (U0.substWk .. ≫ B) (U0.disp A ≫ f) + (by simp [f_tp, comp_mkPi]) + (U0.var A) (U0.var_tp A) + +theorem etaExpand_eq {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.mkPi A B) : + P.etaExpand A B f f_tp = f := by + simp [etaExpand] + convert P.mkLam_unLam A B f f_tp using 2 + simp [mkApp]; rw [← comp_unLam (f_tp := f_tp), ← Category.assoc] + conv_rhs => rw [← Category.id_comp (P.unLam ..)] + congr 2 + apply (U0.disp_pullback A).hom_ext <;> simp + +/-- +``` +Γ ⊢₀ A Γ.A ⊢₁ t : B Γ ⊢₀ a : A +-------------------------------- +Γ.A ⊢₁ (λA. t) a ≡ t[a] : B[a] +``` -/ +@[simp] +theorem mkApp_mkLam {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) + (t : (U0.ext A) ⟶ U1.Tm) (t_tp : t ≫ U1.tp = B) + (lam_tp : P.mkLam A t ≫ U2.tp = P.mkPi A B) + (a : (Γ) ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) : + P.mkApp A B (P.mkLam A t) lam_tp a a_tp = (U0.sec A a a_tp) ≫ t := by + rw [mkApp, unLam_mkLam] + assumption + +def toUnstructured : + UnstructuredUniverse.PolymorphicPi U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse where + Pi := P.mkPi _ + Pi_comp _ _ _ _ _ := (P.comp_mkPi ..).symm + lam _ b _ := P.mkLam _ b + lam_comp σ A σA eq _ b _ := (P.comp_mkLam σ A σA eq b).symm + lam_tp B b b_tp := P.mkLam_tp _ B b b_tp + unLam := P.unLam _ + unLam_tp B f f_tp := P.unLam_tp _ B f f_tp + unLam_lam B b b_tp := P.unLam_mkLam _ B b b_tp _ + lam_unLam B := P.mkLam_unLam _ B + +end + +namespace ofUnstructured + +variable {U0 U1 U2 : StructuredUniverse R} + (P : UnstructuredUniverse.PolymorphicPi U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse) + +def PiApp (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) : Γ ⟶ U2.Ty := + P.Pi (PtpEquiv.snd U0 AB) + +lemma Pi_naturality {Δ Γ} (σ : Δ ⟶ Γ) (AB) : + PiApp P (σ ≫ AB) = σ ≫ PiApp P AB := by + simp only [PiApp, PtpEquiv.fst_comp_left, PtpEquiv.snd_comp_left, ← P.Pi_comp] + rw! [PtpEquiv.fst_comp_left] + +def Pi : U0.uvPolyTp @ U1.Ty ⟶ U2.Ty := + ofYoneda (PiApp P) (Pi_naturality P) + +def lamApp (b : Γ ⟶ U0.uvPolyTp @ U1.Tm) : Γ ⟶ U2.Tm := + P.lam _ (PtpEquiv.snd U0 b) rfl + +lemma lam_naturality {Δ Γ} (σ : Δ ⟶ Γ) (ab) : + lamApp P (σ ≫ ab) = σ ≫ lamApp P ab := by + simp only [lamApp, PtpEquiv.fst_comp_left, PtpEquiv.snd_comp_left, ← P.lam_comp] + rw! [PtpEquiv.fst_comp_left] + simp + +def lam : U0.uvPolyTp @ U1.Tm ⟶ U2.Tm := + ofYoneda (lamApp P) (lam_naturality P) + +lemma lamApp_tp (b : Γ ⟶ U0.uvPolyTp @ U1.Tm) : + lamApp P b ≫ U2.tp = PiApp P (b ≫ U0.Ptp.map U1.tp) := by + simp only [lamApp, PiApp, PtpEquiv.fst_comp_right, PtpEquiv.snd_comp_right] + rw! [P.lam_tp, PtpEquiv.fst_comp_right] + +def lift (f : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (f_tp : f ≫ U2.tp = PiApp P AB) : Γ ⟶ U0.uvPolyTp @ U1.Tm := + PtpEquiv.mk _ (PtpEquiv.fst _ AB) (P.unLam (PtpEquiv.snd _ AB) f f_tp) + +lemma lamApp_lift (f : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (f_tp : f ≫ U2.tp = PiApp P AB) : + lamApp P (lift P f AB f_tp) = f := by + dsimp only [lamApp, lift] + rw! (castMode := .all) [PtpEquiv.fst_mk, PtpEquiv.snd_mk, P.unLam_tp, P.lam_unLam] + +lemma lift_Ptp_map_tp (f : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (f_tp : f ≫ U2.tp = PiApp P AB) : + ofUnstructured.lift P f AB f_tp ≫ U0.Ptp.map U1.tp = AB := by + dsimp [lift] + rw [PtpEquiv.mk_comp_right, P.unLam_tp, PtpEquiv.eta] + +lemma lift_uniq (f : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (f_tp : f ≫ U2.tp = PiApp P AB) (m : Γ ⟶ U0.Ptp.obj U1.Tm) + (hl : lamApp P m = f) (hr : m ≫ U0.Ptp.map U1.tp = AB) : + m = lift P f AB f_tp := by + fapply PtpEquiv.ext _ + · calc PtpEquiv.fst _ m + _ = PtpEquiv.fst _ (m ≫ U0.Ptp.map U1.tp) := by rw [PtpEquiv.fst_comp_right] + _ = _ := by simp [hr, lift] + · subst hl hr + dsimp only [lift, lamApp] + rw! [PtpEquiv.fst_comp_right, PtpEquiv.snd_mk, PtpEquiv.snd_comp_right, P.unLam_lam] + +end ofUnstructured + +def ofUnstructured (P : UnstructuredUniverse.PolymorphicPi U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse) : PolymorphicPi U0 U1 U2 where + Pi := ofUnstructured.Pi P + lam := ofUnstructured.lam P + Pi_pullback := ofYoneda_isPullback _ _ _ _ _ _ (ofUnstructured.lamApp_tp P) + (ofUnstructured.lift P) + (ofUnstructured.lamApp_lift P) + (ofUnstructured.lift_Ptp_map_tp P) + (ofUnstructured.lift_uniq P) + +end PolymorphicPi + +/-! ## Sigma types -/ + +/-- The structure on three universes that for +`A : Γ ⟶ U0.Ty` and `B : Γ.A ⟶ U1.Ty` constructs a Π-type `Σ_A B : Γ ⟶ U2.Ty`. -/ +structure PolymorphicSigma (U0 U1 U2 : StructuredUniverse R) where + Sig : U0.Ptp.obj U1.Ty ⟶ U2.Ty + pair : U0.compDom U1 ⟶ U2.Tm + Sig_pullback : IsPullback pair (U0.compP U1) U2.tp Sig + +/-- A universe `M` has Σ-type structure. This is the data of a pullback square +``` + Sig +compDom ------> Tm + | | + compP |tp + | | + V V +Ptp Ty ------> Ty + pair +``` +-/ +protected abbrev Sigma (U : StructuredUniverse R) := PolymorphicSigma U U U + +namespace PolymorphicSigma + +variable {U0 U1 U2 : StructuredUniverse R} {Γ : Ctx} + +section +variable (S : PolymorphicSigma U0 U1 U2) + +/-- +``` +Γ ⊢₀ A Γ.A ⊢₁ B +----------------- +Γ ⊢₂ ΣA. B +``` -/ +def mkSig {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) : + Γ ⟶ U2.Ty := + PtpEquiv.mk U0 A B ≫ S.Sig + +theorem comp_mkSig {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) : + σ ≫ S.mkSig A B = + S.mkSig (σ ≫ A) ((U0.substWk σ A) ≫ B) := by + simp [mkSig, ← Category.assoc, PtpEquiv.mk_comp_left] + +/-- +``` +Γ ⊢₀ t : A Γ ⊢₁ u : B[t] +-------------------------- +Γ ⊢₂ ⟨t, u⟩ : ΣA. B +``` -/ +def mkPair {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + (Γ) ⟶ U2.Tm := + compDomEquiv.mk t t_tp B u u_tp ≫ S.pair + +theorem comp_mkPair {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + σ ≫ S.mkPair A B t t_tp u u_tp = + S.mkPair (σ ≫ A) ((U0.substWk σ A) ≫ B) + (σ ≫ t) (by simp [t_tp]) + (σ ≫ u) (by simp [u_tp, comp_sec_assoc]) := by + simp only [← Category.assoc, mkPair]; rw [compDomEquiv.comp_mk] + +@[simp] +theorem mkPair_tp {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + S.mkPair A B t t_tp u u_tp ≫ U2.tp = S.mkSig A B := by + simp [mkPair, Category.assoc, S.Sig_pullback.w, mkSig, compDomEquiv.mk_comp_assoc] + +def mkFst {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + Γ ⟶ U0.Tm := + compDomEquiv.fst (S.Sig_pullback.lift p (PtpEquiv.mk _ A B) p_tp) + +@[simp] +theorem mkFst_tp {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + S.mkFst A B p p_tp ≫ U0.tp = A := by + simp [mkFst, compDomEquiv.fst_tp] + +@[simp] +theorem mkFst_mkPair {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + S.mkFst A B (S.mkPair A B t t_tp u u_tp) (by simp) = t := by + simp [mkFst, mkPair] + convert compDomEquiv.fst_mk t t_tp B u u_tp using 2 + apply (S.Sig_pullback).hom_ext <;> simp [compDomEquiv.mk_comp] + +theorem comp_mkFst {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + (σ) ≫ S.mkFst A B p p_tp = + S.mkFst (σ ≫ A) (U0.substWk σ A ≫ B) (σ ≫ p) + (by simp [p_tp, comp_mkSig]) := by + simp [mkFst] + rw [← compDomEquiv.fst_comp]; congr 1 + apply S.Sig_pullback.hom_ext <;> simp [PtpEquiv.mk_comp_left] + +def mkSnd {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + Γ ⟶ U1.Tm := + compDomEquiv.snd (S.Sig_pullback.lift p (PtpEquiv.mk _ A B) p_tp) + +@[simp] +theorem mkSnd_mkPair {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (t : Γ ⟶ U0.Tm) (t_tp : t ≫ U0.tp = A) + (u : Γ ⟶ U1.Tm) (u_tp : u ≫ U1.tp = U0.sec A t t_tp ≫ B) : + S.mkSnd A B (S.mkPair A B t t_tp u u_tp) (by simp) = u := by + simp [mkSnd, mkPair] + convert compDomEquiv.snd_mk t t_tp B u u_tp using 2 + apply (S.Sig_pullback).hom_ext <;> simp [compDomEquiv.mk_comp] + +protected theorem dependent_eq {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + compDomEquiv.dependent ((S.Sig_pullback).lift p (PtpEquiv.mk U0 A B) p_tp) A + (by simp [compDomEquiv.fst_tp]) = B := by + convert PtpEquiv.snd_mk U0 A B using 2 + simp only [compDomEquiv.dependent, UvPoly.compDomEquiv.dependent, PtpEquiv.snd_mk] + simp [PtpEquiv.mk] + +@[simp] +theorem mkSnd_tp {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + S.mkSnd A B p p_tp ≫ U1.tp = + (U0.sec A (S.mkFst A B p p_tp) (by simp)) ≫ B := by + generalize_proofs h + simp [mkSnd, compDomEquiv.snd_tp (eq := h), S.dependent_eq]; rfl + +theorem comp_mkSnd {Δ Γ : Ctx} (σ : Δ ⟶ Γ) + (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + σ ≫ S.mkSnd A B p p_tp = + S.mkSnd (σ ≫ A) (U0.substWk σ A ≫ B) (σ ≫ p) + (by simp [p_tp, comp_mkSig]) := by + simp [mkSnd, ← compDomEquiv.snd_comp]; congr 1 + apply (S.Sig_pullback).hom_ext <;> simp + rw [PtpEquiv.mk_comp_left] + +@[simp] +theorem mkPair_mkFst_mkSnd {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty) + (p : Γ ⟶ U2.Tm) (p_tp : p ≫ U2.tp = S.mkSig A B) : + S.mkPair A B + (S.mkFst A B p p_tp) (by simp) + (S.mkSnd A B p p_tp) (by simp) = p := by + simp [mkFst, mkSnd, mkPair] + have := compDomEquiv.eta ((S.Sig_pullback).lift p (PtpEquiv.mk _ A B) p_tp) + (eq := by rw [← mkFst.eq_def, mkFst_tp]) + conv at this => enter [1, 3]; apply S.dependent_eq + simp [this] + +end + +namespace ofUnstructured + +variable {U0 U1 U2 : StructuredUniverse R} + (S : UnstructuredUniverse.PolymorphicSigma U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse) + +def SigApp (AB : Γ ⟶ U0.Ptp.obj U1.Ty) : Γ ⟶ U2.Ty := + S.Sig (PtpEquiv.snd U0 AB) + +lemma Sig_naturality {Δ Γ} (σ : Δ ⟶ Γ) (AB) : + SigApp S (σ ≫ AB) = σ ≫ SigApp S AB := by + simp only [SigApp, PtpEquiv.fst_comp_left, PtpEquiv.snd_comp_left, ← S.Sig_comp] + rw! [PtpEquiv.fst_comp_left] + +def Sig : U0.Ptp.obj U1.Ty ⟶ U2.Ty := + ofYoneda (SigApp S) (Sig_naturality S) + +def pairApp (ab : Γ ⟶ U0.compDom U1) : Γ ⟶ U2.Tm := + S.pair (compDomEquiv.dependent ab) (compDomEquiv.fst ab) + (by rw [compDomEquiv.fst_tp]) (compDomEquiv.snd ab) (by rw [compDomEquiv.snd_tp]) + +lemma pair_naturality {Δ Γ} (σ : Δ ⟶ Γ) (ab) : + pairApp S (σ ≫ ab) = σ ≫ pairApp S ab := by + dsimp [pairApp] + simp only [← S.pair_comp, compDomEquiv.comp_dependent, compDomEquiv.fst_comp, + compDomEquiv.snd_comp] + rw! [compDomEquiv.fst_comp, Category.assoc] + +def pair : U0.compDom U1 ⟶ U2.Tm := + ofYoneda (pairApp S) (pair_naturality S) + +lemma pair_tp (ab : Γ ⟶ U0.compDom U1) : + pairApp S ab ≫ U2.tp = SigApp S (ab ≫ U0.compP U1) := by + dsimp [pairApp, SigApp] + rw! [S.pair_tp, compDomEquiv.dependent_eq, compDomEquiv.fst_tp] + +def lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + Γ ⟶ U0.compDom U1 := + let B := PtpEquiv.snd U0 AB + compDomEquiv.mk (S.fst B ab ab_tp) (S.fst_tp ..) B (S.snd B ab ab_tp) (S.snd_tp ..) + +lemma fst_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + compDomEquiv.fst (lift S ab AB ab_tp) = + S.fst (PtpEquiv.snd U0 AB) ab ab_tp := by + rw [lift, compDomEquiv.fst_mk _ _] + +lemma snd_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + compDomEquiv.snd (lift S ab AB ab_tp) = + S.snd (PtpEquiv.snd U0 AB) ab ab_tp := by + rw [lift, compDomEquiv.snd_mk] + +lemma dependent_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + compDomEquiv.dependent (lift S ab AB ab_tp) (PtpEquiv.fst U0 AB) (by rw [fst_lift, S.fst_tp]) = + PtpEquiv.snd U0 AB (PtpEquiv.fst U0 AB) := by + simp [lift, compDomEquiv.dependent_mk] + +lemma pairApp_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = ofUnstructured.SigApp S AB) : + ofUnstructured.pairApp S (ofUnstructured.lift S ab AB ab_tp) = ab := by + dsimp [pairApp] + rw! [fst_lift, S.fst_tp, fst_lift, snd_lift, dependent_lift] + rw [S.eta] + +lemma lift_compP (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) : + lift S ab AB ab_tp ≫ U0.compP U1 = AB := by + dsimp [lift] + rw [compDomEquiv.mk_comp, PtpEquiv.eta] + +lemma lift_uniq (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = SigApp S AB) (m : Γ ⟶ U0.compDom U1) + (hl : pairApp S m = ab) (hr : m ≫ U0.compP U1 = AB) : + m = lift S ab AB ab_tp := by + rw! [← compDomEquiv.eta m] + fapply compDomEquiv.ext (A := PtpEquiv.fst U0 AB) + · rw [compDomEquiv.fst_mk, compDomEquiv.fst_tp, hr] + · rw [fst_lift, compDomEquiv.fst_mk _] + calc compDomEquiv.fst m + _ = S.fst (compDomEquiv.dependent m) (pairApp S m) (S.pair_tp ..) := by + dsimp [pairApp] + rw [S.fst_pair] + S.fst (compDomEquiv.dependent m) (pairApp S m) (S.pair_tp ..) = + S.fst (PtpEquiv.snd U0 AB) ab ab_tp := by + subst hl hr + rw! [compDomEquiv.dependent_eq, compDomEquiv.fst_tp] + · subst hr + rw [compDomEquiv.dependent_mk, dependent_lift, compDomEquiv.dependent_eq] + rw! [compDomEquiv.fst_tp, eqToHom_refl, Category.id_comp, compDomEquiv.fst_tp] + · simp [snd_lift] + calc compDomEquiv.snd m + _ = S.snd (compDomEquiv.dependent m) (pairApp S m) (S.pair_tp ..) := by + dsimp [pairApp] + rw [S.snd_pair] + S.snd (compDomEquiv.dependent m) (pairApp S m) (S.pair_tp ..) = + S.snd (PtpEquiv.snd U0 AB) ab ab_tp := by + subst hl hr + rw! [compDomEquiv.dependent_eq, compDomEquiv.fst_tp] + +end ofUnstructured + +def ofUnstructured {U0 U1 U2 : StructuredUniverse R} + (S : UnstructuredUniverse.PolymorphicSigma U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse) : + PolymorphicSigma U0 U1 U2 where + Sig := ofUnstructured.Sig S + pair := ofUnstructured.pair S + Sig_pullback := ofYoneda_isPullback _ _ _ _ _ _ (ofUnstructured.pair_tp S) + (ofUnstructured.lift S) + (ofUnstructured.pairApp_lift S) + (ofUnstructured.lift_compP S) + (ofUnstructured.lift_uniq S) + +end PolymorphicSigma + +-- def Sigma.mk' +-- (Sig : ∀ {Γ} {A : Γ ⟶ M.Ty}, (M.ext A ⟶ M.Ty) → (Γ ⟶ M.Ty)) +-- (comp_Sig : ∀ {Γ Δ} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) {σA} (eq) (B : M.ext A ⟶ M.Ty), +-- σ ≫ Sig B = Sig (M.substWk σ A σA eq ≫ B)) +-- (assoc : ∀ {Γ} {A : Γ ⟶ M.Ty} (B : M.ext A ⟶ M.Ty), M.ext B ≅ M.ext (Sig B)) +-- (comp_assoc : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ M.Ty} {σA} (eq) (B : M.ext A ⟶ M.Ty), +-- substWk _ (substWk _ σ _ _ eq) _ ≫ (assoc B).hom = +-- (assoc (M.substWk σ A σA eq ≫ B)).hom ≫ M.substWk σ _ _ (comp_Sig ..)) +-- (assoc_disp : ∀ {Γ} {A : Γ ⟶ M.Ty} (B : M.ext A ⟶ M.Ty), +-- (assoc B).hom ≫ M.disp _ = M.disp _ ≫ M.disp _) : +-- M.Sigma := sorry + +section + +variable (U0 U1 U2 : StructuredUniverse R) + +/-- +Used in the definition `IdIntro`, +`diag` is the diagonal substitution into the pullback `U0.ext U0.tp`, +a.k.a the pullback `Tm ×_Ty Tm` or the context `Tm.tp`. + 𝟙 Tm +Tm ---------> + | ↘diag var + | Tm.tp -----> Tm + | | | +𝟙 Tm | | + | disp | tp + V | | + V V + Tm ----------> Ty + tp +-/ +abbrev diag : U0.Tm ⟶ U0.ext U0.tp := + (U0.disp_pullback U0.tp).lift (𝟙 U0.Tm) (𝟙 U0.Tm) (by simp) + +/-- An auxiliary definition for the structure `StructuredUniverse.Id`. +`Universe.IdIntro` consists of the following commutative square + refl +Tm --------> Tm + | | + | | +diag tp + | | + | | + V V + Tm.tp -----> Ty + Id +-/ +structure IdIntro where + Id : U0.ext U0.tp ⟶ U1.Ty + refl : U0.Tm ⟶ U1.Tm + refl_tp : refl ≫ U1.tp = U0.diag ≫ Id + +variable {U0 U1 U2} + +namespace IdIntro + +variable (ii : IdIntro U0 U1) {Γ : Ctx} + +/-- Used in the definition `StructuredUniverse.Id`, +the comparison map `U0.Tm ⟶ U0.ext ii.Id` induced by the +pullback universal property of `U0.ext ii.Id`. + + refl + U0.Tm ---------> + ↘comparison var + | U1.ext ii.Id ------> U1.Tm + | | | +diag | | + | disp U1.tp + | | | + | V V + V U0.ext U0.tp ---> U1.Ty + Id +-/ +def comparison : U0.Tm ⟶ U1.ext ii.Id := + (U1.disp_pullback ii.Id).lift ii.refl U0.diag ii.refl_tp + +@[simp] +lemma comparison_comp_var : comparison ii ≫ U1.var ii.Id = ii.refl := by + simp [comparison] + +@[simp, reassoc] +lemma comparison_comp_diap_comp_var : comparison ii ≫ U1.disp ii.Id ≫ U0.var U0.tp = + 𝟙 _ := by + simp [comparison] + +@[simp, reassoc] +lemma comparison_comp_disp_comp_disp : ii.comparison ≫ U1.disp ii.Id ≫ U0.disp U0.tp = + 𝟙 _ := by + simp [comparison] + +/-- `dispTpUvPoly` promotes the map `U0.disp U0.tp` to a `UvPoly`, +which we can compose with `dispIdUvPoly` to make `iUvPoly`. +Informally thought of as the context extension +`(A : Ty).(a b : A) ->> (A : Ty) (a : A)`. -/ +@[simps] def dispTpUvPoly : UvPoly R (U0.ext U0.tp) U0.Tm := + ⟨U0.disp U0.tp, U0.disp_mem _⟩ + +/-- `dispIdUvPoly` promotes the map `U1.disp ii.Id` to a `UvPoly`, +which we can compose with `dispTpUvPoly` to make `iUvPoly` +Informally thought of as the context extension +`(A : Ty).(a b : A).(p : Id(a,b)) ->> (A : Ty) (a b : A)`. -/ +@[simps] def dispIdUvPoly : UvPoly R (U1.ext ii.Id) (U0.ext U0.tp) := + ⟨U1.disp ii.Id, U1.disp_mem _⟩ + +/-- `(U1.ext ii.Id)` over `Tm` can be informally thought of as the context extension +`(A : Ty).(a b : A).(p : Id(a,b)) ->> (A : Ty) (a : A)`. +This is defined by the composition of (maps informally thought of as) context extensions +`(A : Ty).(a b : A).(p : Id(a,b)) ->> (A : Ty).(a b : A) ->> (A : Ty).(a : A)` +This is the signature for a polynomial functor `iUvPoly` on the presheaf category `Ctx`. +-/ +abbrev iUvPoly : UvPoly R (U1.ext ii.Id) U0.Tm := + (dispIdUvPoly ii).vcomp IdIntro.dispTpUvPoly + +instance : R.IsStableUnderPushforwardsAlong ii.iUvPoly.p := + UvPoly.isStableUnderPushforwardsAlong_vcomp (U1.disp_mem _) (U0.disp_mem _) + +instance : MorphismProperty.HasPushforwardsAlong R ii.iUvPoly.p := + UvPoly.hasPushforwardsAlong_vcomp (U1.disp_mem _) (U0.disp_mem _) + +instance : R.HasPushforwardsAlong (UvPoly.id R U0.Tm).p := + MorphismProperty.HasPushforwards.hasPushforwardsAlong _ (R.id_mem _) + +instance : R.IsStableUnderPushforwardsAlong (UvPoly.id R U0.Tm).p := + MorphismProperty.IsStableUnderPushforwards.of_isPushforward _ (R.id_mem _) + +/-- Consider the comparison map `comparison : Tm ⟶ i` in the slice over `Tm`. +Then the contravariant action `UVPoly.verticalNatTrans` of taking `UvPoly` on a slice +results in a natural transformation `P_iOver ⟶ P_(𝟙 Tm)` +between the polynomial endofunctors `iUvPoly` and `UvPoly.id U0.Tm` respectively. + + comparison + Tm ----> i + \ / + 𝟙\ / `iUvPoly` + V V + Tm +-/ +def verticalNatTrans : ii.iUvPoly.functor ⟶ (UvPoly.id R U0.Tm).functor := + UvPoly.verticalNatTrans (UvPoly.id R U0.Tm) (iUvPoly ii) + (comparison ii) (by simp [iUvPoly]) + +end IdIntro + +open IdIntro + +/-- In the high-tech formulation by Richard Garner and Steve Awodey: +The full structure interpreting the natural model semantics for identity types +requires an `IdIntro`, +(and `IdElimBase` which can be generated by pullback in the presheaf category,) +and that the following commutative square generated by +`IdBaseComparison.verticalNatTrans` is a weak pullback. + +``` + verticalNatTrans.app Tm +iFunctor Tm --------> P_𝟙Tm Tm + | | + | | +iFunctor tp P_𝟙Tm tp + | | + | | + V V +iFunctor Ty --------> P_𝟙Tm Ty + verticalNatTrans.app Ty +``` + +This can be thought of as saying the following. +Fix `A : Ty` and `a : A` - we are working in the slice over `U0.Tm`. +For any context `Γ`, any map `(a, r) : Γ → P_𝟙Tm Tm` +and `(a, C) : Γ ⟶ iFunctor Ty` such that `r ≫ U0.tp = C[x/y, refl_x/p]`, +there is a map `(a,c) : Γ ⟶ iFunctor Tm` such that `c ≫ U0.tp = C` and `c[a/y, refl_a/p] = r`. +Here we are thinking + `Γ (y : A) (p : A) ⊢ C : Ty` + `Γ ⊢ r : C[a/y, refl_a/p]` + `Γ (y : A) (p : A) ⊢ c : Ty` +This witnesses the elimination principle for identity types since +we can take `J (y.p.C;x.r) := c`. +-/ +structure Id (ii : IdIntro U0 U1) (U2 : StructuredUniverse R) where + weakPullback : WeakPullback + ((verticalNatTrans ii).app U2.Tm) + (ii.iUvPoly.functor.map U2.tp) + ((UvPoly.id R U0.Tm).functor.map U2.tp) + ((verticalNatTrans ii).app U2.Ty) + +/-- The additional condition that the weak pullback structure +provided by `Id` is coherent. +We can always replace a weak pullback with a coherent one +(see `coherentId` below), +so this condition is optional, in a sense. -/ +class Id.IsCoherent {ii : IdIntro U0 U1} {U2 : StructuredUniverse R} + (id : Id ii U2) where + isCoherent : WeakPullback.IsCoherent id.weakPullback + +instance {ii : IdIntro U0 U1} {U2 : StructuredUniverse R} : + HasPullback ((UvPoly.id R U0.Tm).functor.map U2.tp) (ii.verticalNatTrans.app U2.Ty) := + sorry + +/-- `coherentId` replaces an identity type structure that has possibly +non-coherent/non-substitution-stable elimination with a new identity type +that has coherent/substitution-stable elimination. -/ +def coherentId {ii : IdIntro U0 U1} (id : Id ii U2) : Id ii U2 where + weakPullback := (id.weakPullback.coherent) + +/-! ## From structured identity types to unstructured identity types -/ + +namespace IdIntro + +variable (ii : IdIntro U0 U1) {Γ : Ctx} + +/-- The substitution `a0.a1 : Γ → Tm.tp`. -/ +abbrev endpts (a0 a1 : Γ ⟶ U0.Tm) (h : a0 ≫ U0.tp = a1 ≫ U0.tp) : Γ ⟶ U0.ext U0.tp := + (U0.disp_pullback U0.tp).lift a1 a0 h.symm + +def toUnstructured : + U0.toUnstructuredUniverse.PolymorphicIdIntro U1.toUnstructuredUniverse where + Id a0 a1 a0_tp a1_tp := + endpts a0 a1 (by simp[a0_tp,a1_tp]) ≫ ii.Id + Id_comp σ A a0 a1 a0_tp a1_tp := by + simp only [← Category.assoc] + congr 1 + apply (U0.disp_pullback U0.tp).hom_ext <;> simp + refl a _ := a ≫ ii.refl + refl_comp σ A a h := by simp + refl_tp a a_tp := by + simp only [Category.assoc, ii.refl_tp] + simp only [← Category.assoc] + congr 1 + apply (U0.disp_pullback U0.tp).hom_ext <;> simp + +variable {Γ : Ctx} {A : Γ ⟶ U0.Ty} {a : Γ ⟶ U0.Tm} (a_tp : a ≫ U0.tp = A) + +end IdIntro + +namespace Id + +variable (ii : IdIntro U0 U1) (id : Id ii U2) + +namespace toUnstructured + +variable {Γ : Ctx} {A : Γ ⟶ U0.Ty} {a : Γ ⟶ U0.Tm} (a_tp : a ≫ U0.tp = A) + +/- The pullback square +``` + Γ --------> Tm + ‖ ‖ + ‖ (pb) ‖ 𝟙_Tm + ‖ ‖ + ‖ ‖ + Γ --------> Tm + a +``` +-/ +lemma idPb (U0 : StructuredUniverse R) (a : Γ ⟶ U0.Tm) : + IsPullback (𝟙 Γ) a a (UvPoly.id R U0.Tm).p := + have : IsIso (UvPoly.id R U0.Tm).p := by simp; infer_instance + IsPullback.of_horiz_isIso (by simp) + +/-- +`toExtTp` is the substitution, +`toExtId` is the substitution, +`toExtTpPb` is the pullback square, +and `toExtIdPb` is the pullback square in the following +``` + Γ ---------- a --------------> Tm + | | + | |disp + | | + V V +Γ.(x:A).(p:Id(a,x)) --- toExtId ----> U1.ext ii.Id + | | + | (toExtIdPb) |disp + | | + V V +Γ.(x:A) ------------- toExtTp ------> U0.ext U0.tp + | | + | (toExtTpPb) |disp + | | + V V + Γ ---------- a --------------> Tm +``` +The pullback `toExtIdPb'` is the vertical pasting of `toExtIdPb` and `toExtTpPb` +-/ +abbrev toExtTp : U0.ext A ⟶ U0.ext U0.tp := + endpts (U0.disp A ≫ a) (U0.var A) (by simp[a_tp]) + +@[inherit_doc toExtTp] +abbrev toExtId : ii.toUnstructured.motiveCtx a a_tp ⟶ U1.ext ii.Id := + (U1.disp_pullback ii.Id).lift (U1.var _) (U1.disp _ ≫ toExtTp a_tp) + (by simp [toUnstructured, toExtTp]) + +@[inherit_doc toExtTp] +lemma toExtTpPb : IsPullback (toExtTp a_tp) (U0.disp _) (U0.disp _) a := + CategoryTheory.IsPullback.of_right (by simpa [a_tp] using U0.disp_pullback _) (by simp) + (U0.disp_pullback _) + +@[inherit_doc toExtTp] +lemma toExtIdPb : IsPullback (toExtId ii a_tp) (U1.disp _) (U1.disp _) (toExtTp a_tp) := + CategoryTheory.IsPullback.of_right (by simpa using U1.disp_pullback _) + (by simp) (U1.disp_pullback ii.Id) + +lemma toExtIdPb' : IsPullback (toExtId ii a_tp) (U1.disp _ ≫ U0.disp A) + (U1.disp _ ≫ U0.disp U0.tp) a := + IsPullback.paste_vert (toExtIdPb ii a_tp) (toExtTpPb a_tp) + +variable (C : ii.toUnstructured.motiveCtx a a_tp ⟶ U2.Ty) (c : Γ ⟶ U2.Tm) + +variable (a) in +/-- +For defining `toIUvPolyTm = (a,j)` into the weak pullback, +we define `toUvPolyIdTm = (a,c)`, `toIUvPolyTy = (a,C)` in the following +``` + (a,c) +Γ -------------------------> + ↘ (a,j) +| verticalNatTrans.app Tm +| P_i Tm --------> P_𝟙Tm Tm +| | | +(a,C) | | +| P_i tp P_𝟙Tm tp +| | | +| | | +| V V +V P_i Ty --------> P_𝟙Tm Ty + verticalNatTrans.app Ty +``` +-/ +abbrev toUvPolyIdTm : Γ ⟶ (UvPoly.id R U0.Tm).functor.obj U2.Tm := + UvPoly.Equiv.mk' a (idPb U0 a) c + +@[inherit_doc toUvPolyIdTm] +abbrev toIUvPolyTy : Γ ⟶ ii.iUvPoly.functor.obj U2.Ty := + UvPoly.Equiv.mk' a (toExtIdPb' ii a_tp).flip C + +variable {ii} {c} (c_tp : c ≫ U2.tp = ii.toUnstructured.reflSubst a a_tp ≫ C) + +-- previously called `toWeakpullback` +@[inherit_doc toUvPolyIdTm] +abbrev toIUvPolyTm : Γ ⟶ ii.iUvPoly.functor.obj U2.Tm := + id.weakPullback.lift (toUvPolyIdTm a c) (toIUvPolyTy ii a_tp C) + (by + have := c_tp -- TODO: remove + sorry) + +lemma fst_toIUvPolyTm : UvPoly.Equiv.fst (toIUvPolyTm id a_tp C c_tp) = a := + calc + _ = UvPoly.Equiv.fst (toIUvPolyTm id a_tp C c_tp ≫ ii.iUvPoly.functor.map U2.tp) := by + rw [UvPoly.Equiv.fst_comp_right] + _ = _ := by simp + +def j : ii.toUnstructured.motiveCtx a a_tp ⟶ U2.Tm := + UvPoly.Equiv.snd' (toIUvPolyTm id a_tp C c_tp) + (by convert (toExtIdPb' ii a_tp).flip; apply fst_toIUvPolyTm) + +end toUnstructured + +open toUnstructured + +def toUnstructured [id.IsCoherent] : + UnstructuredUniverse.PolymorphicIdElim (ii.toUnstructured) + U2.toUnstructuredUniverse where + j a a_tp C c c_tp := j id a_tp C c_tp + comp_j σ A a a_tp C c c_tp := sorry -- NOTE: this will need [id.IsCoherent] + j_tp := sorry + reflSubst_j := sorry + +end Id + +/-! ## From unstructured identity types to structured identity types -/ + +namespace IdIntro + +variable (ii : PolymorphicIdIntro U0.toUnstructuredUniverse U1.toUnstructuredUniverse) + +namespace ofUnstructured + +def IdApp {Γ} (α : Γ ⟶ U0.ext U0.tp) : Γ ⟶ U1.Ty := + ii.Id (α ≫ U0.disp _) (α ≫ U0.var _) rfl (by simp) + +lemma IdApp_comp {Δ Γ} (σ : Δ ⟶ Γ) (α : Γ ⟶ U0.ext U0.tp) : + IdApp ii (σ ≫ α) = σ ≫ IdApp ii α := + sorry + +def reflApp {Γ} (a : Γ ⟶ U0.Tm) : Γ ⟶ U1.Tm := + ii.refl a rfl + +lemma reflApp_comp {Δ Γ} (σ : Δ ⟶ Γ) (A : Γ ⟶ U0.Tm) : + reflApp ii (σ ≫ A) = σ ≫ reflApp ii A := + sorry + +lemma reflApp_tp {Γ} (ab : Γ ⟶ U0.Tm) : reflApp ii ab ≫ U1.tp = IdApp ii (ab ≫ U0.diag) := + sorry + +end ofUnstructured + +open ofUnstructured + +def ofUnstructured : IdIntro U0 U1 where + Id := ofYoneda (IdApp ii) (IdApp_comp _) + refl := ofYoneda (reflApp ii) (reflApp_comp _) + refl_tp := by apply ofYoneda_comm_sq; simp [reflApp_tp] + +end IdIntro + +namespace Id + +variable {ii : PolymorphicIdIntro U0.toUnstructuredUniverse U1.toUnstructuredUniverse} + (ie : PolymorphicIdElim ii U2.toUnstructuredUniverse) + +namespace ofUnstructured + +variable {Γ : Ctx} (toUvPolyIdTm : Γ ⟶ (UvPoly.id R U0.Tm).functor.obj U2.Tm) + (toIUvPolyTy : Γ ⟶ (IdIntro.ofUnstructured ii).iUvPoly.functor.obj U2.Ty) + (toUvPolyIdTm_uvPolyIdTp : toUvPolyIdTm ≫ (UvPoly.id R U0.Tm).functor.map U2.tp = + toIUvPolyTy ≫ (IdIntro.ofUnstructured ii).verticalNatTrans.app U2.Ty) + +/-- +For defining `lift = (a,j)` into `P_i Tm = (IdIntro.ofUnstructured ii).iUvPoly.functor.obj U2.Tm`, +consider the following diagram +``` + (a,c) +Γ -------------------------> + ↘ (a,j) +| verticalNatTrans.app Tm +| P_i Tm --------> P_𝟙Tm Tm +| | | +(a,C) | | +| P_i tp P_𝟙Tm tp +| | | +| | | +| V V +V P_i Ty --------> P_𝟙Tm Ty + verticalNatTrans.app Ty +``` +In the following lemmas we will have +`toUvPolyIdTm = (a,c)`, `toIUvPolyTy = (a,C)`, +and `endpoint = a : Γ → Tm`. -/ +def endpoint : Γ ⟶ U0.Tm := UvPoly.Equiv.fst toIUvPolyTy + +-- TODO: maybe move `toUnstructured.toExtIdPb'` out of its current namespace, +-- since it is general enough to used here +def motive : ii.motiveCtx (endpoint toIUvPolyTy) rfl ⟶ U2.Ty := + UvPoly.Equiv.snd' toIUvPolyTy + (toUnstructured.toExtIdPb' (IdIntro.ofUnstructured ii) rfl).flip + +-- def reflCase : Γ ⟶ + +def j : (ofUnstructured ii).toUnstructured.motiveCtx (endpoint toIUvPolyTy) rfl ⟶ U2.Tm := + ie.j (endpoint toIUvPolyTy) rfl (motive toIUvPolyTy) + +@[inherit_doc endpoint] +def lift : Γ ⟶ (IdIntro.ofUnstructured ii).iUvPoly.functor.obj U2.Tm := + UvPoly.Equiv.mk' (endpoint toIUvPolyTy) + (toUnstructured.toExtIdPb' (IdIntro.ofUnstructured ii) rfl).flip (j toIUvPolyTy) + +end ofUnstructured + +open ofUnstructured + +def ofUnstructured : Id (IdIntro.ofUnstructured ii) U2 where + weakPullback := + have := ie -- TODO: remove + { w := by simp only [NatTrans.naturality] + lift toUvPolyIdTm toIUvPolyTy _ := lift toIUvPolyTy + lift_fst' := sorry + lift_snd' := sorry } + +instance : (Id.ofUnstructured ie).IsCoherent := sorry + +end Id + +end + +end StructuredUniverse diff --git a/HoTTLean/Model/Unstructured/Hurewicz.lean b/HoTTLean/Model/Unstructured/Hurewicz.lean index 7f9d09e7..e3870c8c 100644 --- a/HoTTLean/Model/Unstructured/Hurewicz.lean +++ b/HoTTLean/Model/Unstructured/Hurewicz.lean @@ -92,7 +92,48 @@ lemma symm_π_π'_app (X) : cyl.symm.app X ≫ cyl.π.app (cyl.I.obj X) ≫ cyl. cyl.π.app (cyl.I.obj X) ≫ cyl.π.app X := NatTrans.congr_app (cyl.symm_π_π) X -/-- A Hurewicz cleavage (just called `Hurewicz`) on `f` consists of a diagonal filler +attribute [local instance] BraidedCategory.ofCartesianMonoidalCategory in +open MonoidalCategory CartesianMonoidalCategory in +def ofCartesianMonoidalCategoryLeft [CartesianMonoidalCategory Ctx] (Interval : Ctx) + (δ0 δ1 : 𝟙_ Ctx ⟶ Interval) : Cylinder Ctx where + I := tensorLeft Interval + δ0 := (leftUnitorNatIso _).inv ≫ (tensoringLeft _).map δ0 + δ1 := (leftUnitorNatIso _).inv ≫ (tensoringLeft _).map δ1 + π := (tensoringLeft _).map (toUnit _) ≫ (leftUnitorNatIso _).hom + δ0_π := by simp [← Functor.map_comp_assoc] + δ1_π := by simp [← Functor.map_comp_assoc] + symm := (tensorLeftTensor _ _).inv ≫ (tensoringLeft _).map (β_ _ _).hom ≫ + (tensorLeftTensor _ _).hom + symm_symm := by simp [← Functor.map_comp_assoc] + whiskerLeft_I_δ0_symm := by + ext + simp only [Functor.comp_obj, curriedTensor_obj_obj, Functor.id_obj, Functor.whiskerLeft_comp, + Category.assoc, NatTrans.comp_app, Functor.whiskerLeft_app, leftUnitorNatIso_inv_app, + leftUnitor_tensor_inv, curriedTensor_map_app, whiskerRight_tensor, tensorLeftTensor_inv_app, + tensorLeftTensor_hom_app, Iso.hom_inv_id_assoc, ← comp_whiskerRight_assoc, + BraidedCategory.braiding_naturality_left, leftUnitor_inv_braiding_assoc ] + simp + whiskerLeft_I_δ1_symm := by + ext + simp only [Functor.comp_obj, curriedTensor_obj_obj, Functor.id_obj, Functor.whiskerLeft_comp, + Category.assoc, NatTrans.comp_app, Functor.whiskerLeft_app, leftUnitorNatIso_inv_app, + leftUnitor_tensor_inv, curriedTensor_map_app, whiskerRight_tensor, tensorLeftTensor_inv_app, + tensorLeftTensor_hom_app, Iso.hom_inv_id_assoc, ← comp_whiskerRight_assoc, + BraidedCategory.braiding_naturality_left, leftUnitor_inv_braiding_assoc, ] + simp + symm_π_π := by + ext + simp only [Functor.comp_obj, curriedTensor_obj_obj, Functor.id_obj, Functor.whiskerLeft_comp, + Category.assoc, NatTrans.comp_app, tensorLeftTensor_inv_app, curriedTensor_map_app, + tensorLeftTensor_hom_app, Functor.whiskerLeft_app, whiskerRight_tensor, + leftUnitorNatIso_hom_app, Iso.hom_inv_id_assoc, Iso.cancel_iso_inv_left] + have h0 (x) : 𝟙_ Ctx ◁ toUnit Interval ▷ x = 𝟙 _ ⊗ₘ toUnit Interval ⊗ₘ 𝟙 x := by simp + have h1 (x) : (𝟙_ Ctx ◁ toUnit Interval) ▷ x = (𝟙 _ ⊗ₘ toUnit Interval) ⊗ₘ 𝟙 x := by simp + have h2 : λ_ (𝟙_ Ctx) = ρ_ (𝟙_ Ctx) := by aesop_cat + rw [← leftUnitor_naturality_assoc, h0, ← associator_naturality_assoc, ← h1] + simp [← comp_whiskerRight_assoc, h2] + +/-- A Hurewicz cleavage (just called `Hurewicz`) of `f` consists of a diagonal filler `lift` for every commutative square of the form ``` y @@ -700,8 +741,8 @@ lemma reflSubst_comp_substConnection [hrwcz0.IsUniform] [hrwcz0.IsNormal] : end connection def polymorphicIdElim (hrwcz0 : Hurewicz cyl U0.tp) [hrwcz0.IsUniform] [hrwcz0.IsNormal] - (U1 : UnstructuredUniverse Ctx) (hrwcz1 : Hurewicz cyl U1.tp) [Hurewicz.IsUniform hrwcz1] - [Hurewicz.IsNormal hrwcz1] : PolymorphicIdElim (polymorphicIdIntro P0) U1 where + (U1 : UnstructuredUniverse Ctx) (hrwcz1 : Hurewicz cyl U1.tp) [Hurewicz.IsUniform hrwcz1] + [Hurewicz.IsNormal hrwcz1] : PolymorphicIdElim (polymorphicIdIntro P0) U1 where j a a_tp C c c_tp := cyl.δ1.app _ ≫ hrwcz1.lift (disp .. ≫ disp .. ≫ c) (substConnection P0 hrwcz0 a a_tp ≫ C) (by rw [δ0_substConnection_assoc]; simp [c_tp]) -- FIXME simp failed comp_j σ A a a_tp C c c_tp := by @@ -715,7 +756,8 @@ def polymorphicIdElim (hrwcz0 : Hurewicz cyl U0.tp) [hrwcz0.IsUniform] [hrwcz0.I erw [δ1_substConnection_assoc] -- FIXME simp, rw failed reflSubst_j {Γ A} a a_tp C c c_tp := calc _ _ = cyl.δ1.app Γ ≫ cyl.I.map (reflSubst _ a a_tp) ≫ - hrwcz1.lift (U0.disp (weakenId _ a a_tp) ≫ U0.disp A ≫ c) (P0.substConnection hrwcz0 a a_tp ≫ C) _ := by + hrwcz1.lift (U0.disp (weakenId _ a a_tp) ≫ U0.disp A ≫ c) + (P0.substConnection hrwcz0 a a_tp ≫ C) _ := by rw [← δ1_naturality_assoc] _ = cyl.δ1.app Γ ≫ hrwcz1.lift diff --git a/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean b/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean index a7fa0d21..ca978f7e 100644 --- a/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean +++ b/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean @@ -193,6 +193,8 @@ lemma var_comp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) : M.var (σ ≫ def sec {Γ : Ctx} (A : Γ ⟶ M.Ty) (a : Γ ⟶ M.Tm) (a_tp : a ≫ M.tp = A) : Γ ⟶ M.ext A := M.substCons (𝟙 Γ) A a (by simp [a_tp]) +variable {M} + @[reassoc (attr := simp)] theorem sec_disp {Γ : Ctx} (A : Γ ⟶ M.Ty) (a : Γ ⟶ M.Tm) (a_tp : a ≫ M.tp = A) : M.sec A a a_tp ≫ M.disp A = 𝟙 _ := by @@ -203,12 +205,22 @@ theorem sec_var {Γ : Ctx} (A : Γ ⟶ M.Ty) (a : Γ ⟶ M.Tm) (a_tp : a ≫ M.t M.sec A a a_tp ≫ M.var A = a := by simp [sec] +/- + σ + Δ ------------> Γ + | | +sec (σ ≫ a) | sec a + | | + V V + Δ.(σ ≫ A) ----> Γ.A + σ.a +-/ @[reassoc] -theorem comp_sec {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (σA) (eq : σ ≫ A = σA) - (a : Γ ⟶ M.Tm) (a_tp : a ≫ M.tp = A) : - σ ≫ M.sec A a a_tp = M.sec σA (σ ≫ a) (by simp [eq, a_tp]) ≫ M.substWk σ A _ eq := by - apply (M.disp_pullback _).hom_ext <;> - simp [sec, substWk] +theorem comp_sec {Δ Γ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ M.Ty} {a : Γ ⟶ M.Tm} (a_tp : a ≫ M.tp = A) + (σA := σ ≫ A) (eq : σ ≫ A = σA := by rfl) + (σa := σ ≫ a) (eq' : σ ≫ a = σa := by rfl) : + σ ≫ M.sec A a a_tp = M.sec σA σa (by simp [eq, a_tp, ← eq']) ≫ M.substWk σ A _ eq := by + apply (M.disp_pullback _).hom_ext <;> simp [sec, substWk, eq'] @[reassoc (attr := simp)] theorem sec_apply_comp_var {Γ : Ctx} (A : Γ ⟶ M.Ty) @@ -216,6 +228,10 @@ theorem sec_apply_comp_var {Γ : Ctx} (A : Γ ⟶ M.Ty) M.sec A (s ≫ M.var A) (by rw [Category.assoc, var_tp, ← Category.assoc, s_tp]; simp) = s := by apply substCons_apply_comp_var _ _ _ _ s_tp +-- lemma sec_substWk {Δ Γ : Ctx} (A : Γ ⟶ M.Ty) (a : Γ ⟶ M.Tm) (a_tp : a ≫ M.tp = A) (σ : Δ ⟶ Γ) : +-- M.sec (σ ≫ A) (σ ≫ a) (by simp[a_tp]) ≫ M.substWk σ A (σ ≫ A) rfl = σ ≫ M.sec A a a_tp := by +-- simp[substWk,sec] + structure PolymorphicSigma (U0 U1 U2 : UnstructuredUniverse Ctx) where (Sig : ∀ {Γ} {A : Γ ⟶ U0.Ty}, (U0.ext A ⟶ U1.Ty) → (Γ ⟶ U2.Ty)) (Sig_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) (A : Γ ⟶ U0.Ty) {σA} (eq) (B : U0.ext A ⟶ U1.Ty), @@ -299,15 +315,15 @@ def mk' (Sig : ∀ {Γ} {A : Γ ⟶ U0.Ty}, (U0.ext A ⟶ U1.Ty) → (Γ ⟶ U2. · simp [← assoc_disp] fst_pair B a a_tp b b_tp := by simp only [← Category.assoc] - rw [sec_apply_comp_var _ _ _ (by simp [assoc_disp])] + rw [sec_apply_comp_var _ _ (by simp [assoc_disp])] simp snd_pair B a a_tp b b_tp := by simp only [← Category.assoc] - rw [sec_apply_comp_var _ _ _ (by simp [assoc_disp])] + rw [sec_apply_comp_var _ _ (by simp [assoc_disp])] simp eta B s s_tp := by simp only [← Category.assoc] - rw! [sec_apply_comp_var _ _ _ (by simp [← assoc_disp])] + rw! [sec_apply_comp_var _ _ (by simp [← assoc_disp])] rw [U1.substCons_apply_comp_var _ _ _ (by simp)] simp @@ -396,6 +412,10 @@ lemma weakenId_comp : i.weakenId (A := σ ≫ A) (σ ≫ a) (by simp [a_tp]) = U0.substWk σ A ≫ i.weakenId a a_tp := by simp [← Id_comp] +lemma refl_tp_eq_sec_weakenId : + i.refl a a_tp ≫ U1.tp = U0.sec A a a_tp ≫ i.weakenId a a_tp := by + simp[← i.Id_comp] + /-- Given `Γ ⊢ a : A` this is the context `Γ.(x : A).(h:Id(a,x))` -/ @[simp] abbrev motiveCtx : Ctx := diff --git a/HoTTLean/Pointed/Basic.lean b/HoTTLean/Pointed/Basic.lean index c4dbb276..b41f69d6 100644 --- a/HoTTLean/Pointed/Basic.lean +++ b/HoTTLean/Pointed/Basic.lean @@ -113,11 +113,14 @@ def mapFiber {x y : Γ} (f : x ⟶ y) : -- formerly `mapPoint_comp` theorem mapFiber_comp {x y z} (f : x ⟶ y) (g : y ⟶ z) : - mapFiber α (f ≫ g) - = eqToHom (by simp [mapObjFiber, objFiber]) + mapFiber α (f ≫ g) = eqToHom (by simp [mapObjFiber, objFiber]) ≫ (α.map g)⟱.map (mapFiber α f) ≫ mapFiber α g := by simp [mapFiber] +theorem mapFiber_inv {x y} (f : x ⟶ y) [IsIso f] : + mapFiber α (inv f) = eqToHom (Functor.map_inv α f ▸ rfl) ≫ (inv (α.map f)).fiber := by + simp [mapFiber, Functor.Grothendieck.Hom.congr (Functor.map_inv α f)] + end theorem eqToHom_base_map {x y : PCat} (eq : x = y) {a b} (f : a ⟶ b) : @@ -342,6 +345,23 @@ theorem mapFiber'_comp_aux1 {x y z} (f : x ⟶ y) (g : y ⟶ z) : subst h simp [objFiber] +theorem mapFiber'_naturality {Δ : Type*} [Category Δ] (σ : Δ ⥤ Γ) {x y} (f : x ⟶ y) : + @mapFiber' _ _ (σ ⋙ A) (σ ⋙ α) (by rw [Functor.assoc, h]) _ _ f + = mapFiber' h (σ.map f) := by + simp [mapFiber', mapFiber'EqToHom] + +@[simp] theorem mapFiber'_rfl {x y : Γ} (f : x ⟶ y) : mapFiber' rfl f = mapFiber α f := by + simp [mapFiber', mapFiber, mapFiber'EqToHom] + +theorem mapFiber'_comp' + {A : Γ ⥤ Grpd.{v₁,u₁}} {α : Γ ⥤ PGrpd.{v₁,u₁}} (h : α ⋙ PGrpd.forgetToGrpd = A) + {x y z} (f : x ⟶ y) + (g : y ⟶ z) : mapFiber' h (f ≫ g) + = eqToHom (by simp) ≫ (A.map g).map (mapFiber' h f) ≫ mapFiber' h g := by + subst h + simp [mapFiber] + +-- TODO: remove and replace with `mapFiber'_comp'` theorem mapFiber'_comp {x y z} (f : x ⟶ y) (g : y ⟶ z) : mapFiber' h (f ≫ g) = eqToHom (by rw [mapFiber'_comp_aux1 h f g]; simp [forgetToCat]) ≫ @@ -349,13 +369,16 @@ theorem mapFiber'_comp {x y z} (f : x ⟶ y) ≫ (eqToHom (mapFiber'_comp_aux0 h)).map (α.map g).fiber := by simp [mapFiber', eqToHom_map, mapFiber'EqToHom] -theorem mapFiber'_naturality {Δ : Type*} [Category Δ] (σ : Δ ⥤ Γ) {x y} (f : x ⟶ y) : - @mapFiber' _ _ (σ ⋙ A) (σ ⋙ α) (by rw [Functor.assoc, h]) _ _ f - = mapFiber' h (σ.map f) := by - simp [mapFiber', mapFiber'EqToHom] +theorem mapFiber_inv {x y} (f : x ⟶ y) [IsIso f] : + mapFiber α (inv f) = eqToHom (Functor.map_inv α f ▸ rfl) ≫ (inv (α.map f)).fiber := by + simp [mapFiber, Functor.Grothendieck.Hom.congr (Functor.map_inv α f)] -@[simp] theorem mapFiber'_rfl {x y : Γ} (f : x ⟶ y) : mapFiber' rfl f = mapFiber α f := by - simp [mapFiber', mapFiber, mapFiber'EqToHom] +theorem inv_mapFiber_heq {x y} (f : x ⟶ y) [IsIso f] : + inv (mapFiber α f) ≍ ((α ⋙ forgetToGrpd).map f).map (mapFiber α (inv f)) := by + rw [mapFiber_inv] + simp [eqToHom_map, mapFiber] + rw [Functor.Grothendieck.inv_fiber, Functor.Grothendieck.invFiber] + simp [Grpd.forgetToCat] end @@ -416,8 +439,13 @@ end end -end +theorem congr {X Y : PGrpd} {f g : X ⟶ Y} (h : f = g) : + f.fiber = eqToHom (by subst h; rfl) ≫ g.fiber := by + subst h + dsimp + simp +end end PGrpd end CategoryTheory diff --git a/lake-manifest.json b/lake-manifest.json index 930c29a9..49a6fda3 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -11,11 +11,11 @@ "inputRev": null, "inherited": false, "configFile": "lakefile.lean"}, - {"url": "https://github.com/sinhp/Poly", + {"url": "https://github.com/Jlh18/Poly.git", "type": "git", "subDir": null, "scope": "", - "rev": "aedee22f07d681d845bcbe4a1fb9aa10f95c9977", + "rev": "e662604d050f054deb14c8849c0c5c644058b7b7", "name": "Poly", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -25,7 +25,7 @@ "type": "git", "subDir": null, "scope": "", - "rev": "32bd6c7c8ca4a4be1c71bc04df0c9cf929d04818", + "rev": "a79df06b3d23fb6a3c42fb65a949009dc241862d", "name": "mathlib", "manifestFile": "lake-manifest.json", "inputRev": null, @@ -75,7 +75,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "1fa48c6a63b4c4cda28be61e1037192776e77ac0", + "rev": "ca519018e8bdc34d7bb4ecf0c8d39634a8c15300", "name": "aesop", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -95,7 +95,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "c44068fa1b40041e6df42bd67639b690eb2764ca", + "rev": "5a4e38939564f38cef2c55051ea24567df6030ad", "name": "batteries", "manifestFile": "lake-manifest.json", "inputRev": "main", diff --git a/lakefile.lean b/lakefile.lean index 2807a875..067b7178 100644 --- a/lakefile.lean +++ b/lakefile.lean @@ -1,7 +1,7 @@ import Lake open Lake DSL -require Poly from git "https://github.com/sinhp/Poly" @ "master" +require Poly from git "https://github.com/Jlh18/Poly.git" @ "master" require checkdecls from git "https://github.com/PatrickMassot/checkdecls.git"