From c041a29bfc94c820ebd44a3280aa73a1754c8976 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Tue, 28 Oct 2025 10:24:55 -0400 Subject: [PATCH 01/95] feat: UId --- HoTTLean/ForMathlib.lean | 69 + .../Bicategory/Grothendieck.lean | 90 +- .../CategoryTheory/ClovenIsofibration.lean | 692 +++++++++ HoTTLean/ForMathlib/CategoryTheory/Grpd.lean | 38 + HoTTLean/Grothendieck/Groupoidal/Basic.lean | 28 + HoTTLean/Groupoids/Id.lean | 1365 +++++++++++------ HoTTLean/Groupoids/IsPullback.lean | 14 + HoTTLean/Model/Unstructured/Hurewicz.lean | 50 +- HoTTLean/Pointed/Basic.lean | 46 +- 9 files changed, 1906 insertions(+), 486 deletions(-) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean diff --git a/HoTTLean/ForMathlib.lean b/HoTTLean/ForMathlib.lean index cea2bcc2..b8016dd5 100644 --- a/HoTTLean/ForMathlib.lean +++ b/HoTTLean/ForMathlib.lean @@ -583,4 +583,73 @@ 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.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 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 + end CategoryTheory + +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/Bicategory/Grothendieck.lean b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean index fd2adab7..b8c7f928 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. -/ @@ -1146,7 +1183,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 +1192,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 +1427,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/ClovenIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean new file mode 100644 index 00000000..d4ce2ad3 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean @@ -0,0 +1,692 @@ +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 IsPullback + +def isoIsPullback {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) : + P ≅≅ P' := sorry + +lemma isoIsPullback.invCompFst {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): + (isoIsPullback h h').inv ⋙ fst = fst' := sorry + +lemma isoIsPullback.homCompLeft {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): + (isoIsPullback h h').hom ⋙ fst' = fst := sorry + + lemma isoIsPullback.homCompLeft' {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): + hom ⋙ fst' = fst := sorry + + lemma isoIsPullback.homCompRight' {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): + hom ⋙ snd' = snd := sorry + + def IsPullback.botDegenerate {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) := sorry + +end IsPullback + +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 := by + exact 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 B : Type u} [Category.{v} A] [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 B : Type u} [Category.{v} A] [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 + +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 u} [Category.{v} A] [Category.{v} B] [Category.{v} 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 + +variable {A A' B : Type u} [Category.{v} A] [Category.{v} A'] + [Category.{v} B] (i : A' ≅≅ A) {F : A ⥤ B} (IF: ClovenIsofibration F) + (F' : A' ⥤ B) (hF' : F' = i.hom ⋙ F) + +def isoComp : ClovenIsofibration F' := + let := i -- TODO: remove once defined + let := IF -- TODO: remove once defined + let := hF' -- TODO: remove once defined + sorry + +instance [IsSplit IF] : IsSplit (isoComp i IF F' hF') := sorry + +end isoComp + +end + +-- this has been proven in the `clans` branch. +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 := sorry + -- Functor.IsPullback.Paste.horiz eq1 (by simp [i_comp_F]) + -- (IsPullback.IsPullback.botDegenerate i_comp_F.symm) + -- (Groupoidal.compGrothendieck.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.homCompRight' isPullback q1 (hom := j.hom) (by simp[j])).symm + isoComp j (Functor.ClovenIsofibration.forget ..) _ 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 + +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 i (Functor.ClovenIsofibration.forget _) + _ (Functor.IsPullback.isoIsPullback.homCompRight' _ _ rfl).symm + +instance : IsSplit tpClovenIsofibration := by + dsimp [tpClovenIsofibration] + infer_instance + +end GroupoidModel 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/Grothendieck/Groupoidal/Basic.lean b/HoTTLean/Grothendieck/Groupoidal/Basic.lean index f111b388..9ab146fa 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 diff --git a/HoTTLean/Groupoids/Id.lean b/HoTTLean/Groupoids/Id.lean index 48f89cbd..1e69204d 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,924 @@ 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 + +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 [liftMap] + +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 + +-- @[simp] +-- lemma I_map_obj_tt (x) : (cylinder.I.map σ).obj (tt x) = tt (σ.obj x) := by +-- rfl + +-- lemma map_map_ft (y) : ((cylinder.I.map σ).map (ft y)) = (ft (σ.obj y)) := by +-- simp [ft, ← CategoryTheory.Functor.map_id] +-- 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 + +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 + +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)) = + inv (tpClovenIsofibration.liftIso (p.map (ft (σ.obj x))) + (by simpa using Functor.congr_obj p0_tp (σ.obj x))) := by + simp + +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 [ft] + 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/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/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 From c9c6337a0bd9111a654ebac9cad34ac3690c5d91 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Tue, 28 Oct 2025 22:47:11 -0400 Subject: [PATCH 02/95] feat: StrongTrans.naturality lemmas --- HoTTLean/Groupoids/Pi.lean | 280 ++++++++++++++++++++++++++++++++++++- 1 file changed, 274 insertions(+), 6 deletions(-) diff --git a/HoTTLean/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index 353fd3a8..ff14c7e7 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -186,15 +186,148 @@ 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'_apply {x y : Γ} (f : x ⟶ y) (S) (T) (g) : +-- conjugatingObjNatTransEquiv' A B f S T g = +-- eqToHom (by simp) ≫ g ≫ eqToHom (by simp) := by +-- ext +-- simp [conjugatingObjNatTransEquiv', Grpd.Functor.iso] + +@[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 + +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 + +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 + +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 + +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 + +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 + +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 [conjugatingObjNatTransEquiv', Grpd.Functor.iso, Functor.associator_eq] at * + erw [Category.id_comp] + rw [whiskerLeft_map_comp] + rw [whiskerLeft_map_comp] + simp [← Category.assoc] + congr 2 + rw [Functor.comp_whiskerLeft, Functor.whiskerRight_whiskerLeft, Functor.whiskerRight_whiskerLeft] + rw [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] + simp [← heq_eq_eq] + congr 1 + · simp [← Grpd.comp_eq_comp] + · simp [← Grpd.comp_eq_comp] + · 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 +@[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 + +-- lemma conjugatingObjNatTransEquiv₁_comp_inv {x y z : Γ} (f1 : x ⟶ y) (f2 : y ⟶ z) (S) (T) +-- (g : A.map (inv (f1 ≫ f2)) ⋙ S ⋙ B.map (f1 ≫ f2) ⟶ T) : +-- (conjugatingObjNatTransEquiv₁ A B (f1 ≫ f2) S T g).inv = +-- eqToHom (by simp [Functor.assoc]) ≫ +-- (A.map f1 ⋙ A.map f2).whiskerLeft (CategoryTheory.inv g) ≫ +-- eqToHom (by simp [← Grpd.comp_eq_comp]) +-- := by +-- simp only [conjugatingObjNatTransEquiv₁, Groupoid.isoEquivHom, Groupoid.inv_eq_inv, +-- Equiv.trans_apply, Equiv.coe_fn_symm_mk] +-- erw [conjugatingObjNatTransEquiv'_comp] +-- simp [IsIso.inv_comp, inv_eqToHom, inv_whiskerLeft, Category.assoc] + +-- lemma conjugatingObjNatTransEquiv₁_comp_inv {x y z : Γ} (f1 : x ⟶ y) (f2 : y ⟶ z) (S) (T) +-- (g : A.map (inv (f1 ≫ f2)) ⋙ S ⋙ B.map (f1 ≫ f2) ⟶ T) : +-- (conjugatingObjNatTransEquiv₁ A B (f1 ≫ f2) S T g).inv = +-- eqToHom (by simp [Functor.assoc]) ≫ +-- whiskerLeft (A.map f1) (whiskerLeft (A.map f2) (CategoryTheory.inv g)) ≫ +-- eqToHom (by simp [← Grpd.comp_eq_comp]) +-- := by +-- dsimp only [conjugatingObjNatTransEquiv₁, Equiv.trans_apply] +-- simp only [Groupoid.isoEquivHom, Groupoid.inv_eq_inv, Equiv.coe_fn_symm_mk] +-- erw [conjugatingObjNatTransEquiv'_comp] +-- simp only [IsIso.inv_comp, inv_eqToHom, inv_whiskerLeft, Category.assoc] end section @@ -430,14 +563,149 @@ def strongTrans.naturality {x y : Γ} (g : x ⟶ y) : (PGrpd.objFiber' hs y).obj := PGrpd.mapFiber' hs g ((conjugatingObjNatTransEquiv₁ _ _ _ _ _).toFun fib).symm +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 + +lemma eqToHom_heq_id {C : Type*} [Category C] (x y z : C) (h : x = y) + (hz : z = x) : eqToHom h ≍ 𝟙 z := by cat_disch + +@[reassoc] +lemma _root_.CategoryTheory.Functor.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 + +theorem _root_.CategoryTheory.PGrpd.mapFiber'_comp' + {A : Γ ⥤ Grpd.{v₁,u₁}} {α : Γ ⥤ PGrpd.{v₁,u₁}} (h : α ⋙ PGrpd.forgetToGrpd = A) + {x y z} (f : x ⟶ y) + (g : y ⟶ z) : PGrpd.mapFiber' h (f ≫ g) + = eqToHom (by simp) ≫ (A.map g).map (PGrpd.mapFiber' h f) ≫ PGrpd.mapFiber' h g := by + subst h + simp [PGrpd.mapFiber] + +@[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 only [sigma_obj, sigma_map, PGrpd.mapFiber'_id, pi_obj, pi_map, eqToHom_comp_iff, + eqToHom_trans, IsIso.inv_comp_eq] + simp only [← heq_eq_eq, heq_comp_eqToHom_iff] + apply eqToHom_heq_eqToHom + · simp + · simp + +-- 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') [IsIso f] : +-- have : IsIso f' := by aesop +-- inv f ≍ inv f' := by +-- subst hC hX hY hf +-- rfl + +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 + +@[reassoc] +lemma strongTrans.naturality_comp_hom_aux {x y} (g : x ⟶ y) : + A.map g ≫ ((piMap A B g).obj (PGrpd.objFiber' hs x)).obj = + (PGrpd.objFiber' hs x).obj ⋙ sigmaMap B g := by + simp [piMap, conjugating, ← Grpd.comp_eq_comp] + +-- 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) ≫ +-- CategoryTheory.inv +-- ((A.map g1 ⋙ A.map g2).whiskerLeft ((piMap A B g2).map (PGrpd.mapFiber' hs g1) ≫ +-- PGrpd.mapFiber' hs g2)) ≫ +-- eqToHom (by +-- simp only [← Grpd.comp_eq_comp, ← Functor.map_comp, pi_obj, pi_map, ObjectProperty.ι_obj] +-- simp only [← Functor.comp_obj, ← piMap_comp] +-- apply strongTrans.naturality_comp_hom_aux) := by +-- simp only [naturality, sigma_obj, sigma_map, Equiv.toFun_as_coe, Iso.symm_hom, +-- ObjectProperty.ι_obj, pi_obj, pi_map, PGrpd.mapFiber'_comp'] +-- erw [conjugatingObjNatTransEquiv₁_comp_inv] +-- simp only [← heq_eq_eq, heq_eqToHom_comp_iff, eqToHom_comp_heq_iff, +-- comp_eqToHom_heq_iff] +-- simp only [← Category.assoc, heq_comp_eqToHom_iff] +-- simp only [← Functor.inv_whiskerLeft] +-- congr! 2 +-- · rw [← Functor.comp_obj, ← piMap_comp] +-- simp only [piMap_obj_obj] +-- rfl +-- · rw [← Functor.comp_obj, ← piMap_comp] +-- simp only [piMap_obj_obj] +-- rfl +-- · simp only [Category.assoc] +-- apply HEq.trans (eqToHom_comp_heq ..) +-- rfl + +set_option maxHeartbeats 400000 +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 ≫ + Functor.whiskerRight (strongTrans.naturality B s hs g1).hom (sigmaMap B g2) + ≫ eqToHom (by simp [Functor.assoc, sigmaMap_comp]) := by + simp only [naturality, sigma_obj, sigma_map, Equiv.toFun_as_coe, Iso.symm_hom] + refine conjugatingObjNatTransEquiv₁_comp_inv A (sigma A B) g1 g2 + (PGrpd.objFiber' hs x).obj (PGrpd.objFiber' hs y).obj (PGrpd.objFiber' hs z).obj + (PGrpd.mapFiber' hs g1) (PGrpd.mapFiber' hs g2) + (PGrpd.mapFiber' hs (g1 ≫ g2)) ?_ + simp [PGrpd.mapFiber'_comp', piMap, conjugating] + rfl + + -- rw [strongTrans.naturality_comp_hom'] + -- simp only [sigma_obj, sigma_map, conjugatingObjNatTransEquiv₁, Groupoid.isoEquivHom, + -- Groupoid.inv_eq_inv, Equiv.trans_apply, Equiv.coe_fn_symm_mk] + -- simp only [← Functor.inv_whiskerLeft, ← CategoryTheory.Functor.inv_whiskerRight, + -- ← IsIso.inv_comp_assoc] + -- simp only [← heq_eq_eq, heq_eqToHom_comp_iff, eqToHom_comp_heq_iff, + -- comp_eqToHom_heq_iff, heq_comp_eqToHom_iff] + -- congr! 2 + -- · simp [← Grpd.comp_eq_comp, sigmaMap_comp, Functor.assoc] + -- simp + -- · have h := conjugatingObjNatTransEquiv'_comp A (sigma A B) g1 g2 + -- (PGrpd.objFiber' hs x).obj (PGrpd.objFiber' hs z).obj (PGrpd.mapFiber' hs (g1 ≫ g2)) + -- simp [conjugatingObjNatTransEquiv', Grpd.Functor.iso, ← heq_eq_eq] at h + +set_option maxHeartbeats 400000 @[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 + naturality_naturality := by + intro x y f g η + have : f = g := LocallyDiscrete.eq_of_hom η + subst this + simp [Functor.toPseudoFunctor', pseudofunctorOfIsLocallyDiscrete] + naturality_id := by + intro x + simp only [Functor.toPseudoFunctor'_obj, Functor.comp_obj, sigma_obj, + Functor.toPseudoFunctor'_map, LocallyDiscrete.id_as, Functor.comp_map, sigma_map, + strongTrans.naturality_id_hom, Functor.toPseudoFunctor'_mapId, eqToIso.hom, + Bicategory.whiskerLeft_eqToHom, eqToHom_trans, Bicategory.eqToHom_whiskerRight, + Bicategory.leftUnitor, Bicategory.rightUnitor, + Functor.leftUnitor_hom_comp_rightUnitor_inv (PGrpd.objFiber' hs x.as).obj, + Functor.simpIdComp, ← heq_eq_eq, heq_eqToHom_comp_iff] + apply eqToHom_heq_id + simp [Grpd.forgetToCat, Cat.comp_eq_comp] + naturality_comp := by + intro x y z g1 g2 + simp only [Functor.toPseudoFunctor'_obj, Functor.comp_obj, sigma_obj, + Functor.toPseudoFunctor'_map, LocallyDiscrete.comp_as, Functor.comp_map, sigma_map, + Bicategory.whiskerLeft, Functor.toPseudoFunctor'_mapComp, eqToIso.hom, + Bicategory.whiskerRight, Bicategory.associator, Functor.associator_eq, Iso.refl_hom, + Iso.refl_inv] + rw [Functor.whiskerLeft_eqToHom, Functor.eqToHom_whiskerRight, + strongTrans.naturality_comp_hom] + simp only [← Grpd.comp_eq_comp, Category.assoc] + erw [Category.id_comp, Category.id_comp, Category.comp_id] + simp only [Grpd.forgetToCat, id_eq, Cat.of_α, eqToHom_trans, eqToHom_refl, Category.comp_id] @[simps!] def mapStrongTrans : ∫ A ⥤ ∫ sigma A B := From d44df5fe5cc9bcfcdbec13b023a825ce913e2986 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 30 Oct 2025 09:22:31 -0400 Subject: [PATCH 03/95] . --- HoTTLean/Grothendieck/Groupoidal/Basic.lean | 36 +- .../Grothendieck/Groupoidal/IsPullback.lean | 8 - HoTTLean/Groupoids/Pi copy.lean | 1355 +++++++++++++++++ HoTTLean/Groupoids/Pi.lean | 185 ++- 4 files changed, 1551 insertions(+), 33 deletions(-) create mode 100644 HoTTLean/Groupoids/Pi copy.lean diff --git a/HoTTLean/Grothendieck/Groupoidal/Basic.lean b/HoTTLean/Grothendieck/Groupoidal/Basic.lean index f111b388..b7a9e32d 100644 --- a/HoTTLean/Grothendieck/Groupoidal/Basic.lean +++ b/HoTTLean/Grothendieck/Groupoidal/Basic.lean @@ -678,15 +678,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`. -/ @@ -767,16 +791,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]) := diff --git a/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean b/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean index 9cd27f1b..01e0d4f5 100644 --- a/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean +++ b/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean @@ -203,14 +203,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/Pi copy.lean b/HoTTLean/Groupoids/Pi copy.lean new file mode 100644 index 00000000..18aebe6d --- /dev/null +++ b/HoTTLean/Groupoids/Pi copy.lean @@ -0,0 +1,1355 @@ +import HoTTLean.Groupoids.Sigma +import HoTTLean.ForMathlib.CategoryTheory.Whiskering +import HoTTLean.ForMathlib.CategoryTheory.NatTrans + +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 + +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 + +abbrev Section := ObjectProperty.FullSubcategory (IsSection F) + +instance Section.category : Category (Section F) := + ObjectProperty.FullSubcategory.category (IsSection F) + +abbrev Section.ι : Section F ⥤ (A ⥤ B) := + ObjectProperty.ι (IsSection F) + +end + +namespace ObjectProperty + +lemma ι_mono {T C : Type u} [Category.{v} C] [Category.{v} T] + {Z : C → Prop} (f g : T ⥤ FullSubcategory Z) + (e : f ⋙ ι Z = g ⋙ ι Z) : f = g := by + apply CategoryTheory.Functor.ext_of_iso _ _ _ + · exact Functor.fullyFaithfulCancelRight (ι Z) (eqToIso e) + · intro X + ext + exact Functor.congr_obj e X + · intro X + simp only [Functor.fullyFaithfulCancelRight_hom_app, Functor.preimage, ι_obj, ι_map, + eqToIso.hom, eqToHom_app, Functor.comp_obj, Classical.choose_eq] + rfl + +end ObjectProperty + +instance {C : Type*} [Groupoid C] (P : ObjectProperty C) : + Groupoid (P.FullSubcategory) := + InducedCategory.groupoid C (ObjectProperty.ι _).obj + +instance Grpd.ι_mono (G : Grpd) (P : ObjectProperty G) : Mono (Grpd.homOf (ObjectProperty.ι P)) := + ⟨ fun _ _ e => ObjectProperty.ι_mono _ _ e ⟩ + +lemma Grpd.ObjectProperty.FullSubcategory.congr {A A' : Grpd.{v,u}} (hA : A ≍ A') + (P : ObjectProperty A) (P' : ObjectProperty A') (hP : P ≍ P') + (a : A) (a' : A') (ha : a ≍ a') (ha : P a) (ha' : P' a') : + (⟨ a, ha ⟩ : P.FullSubcategory) ≍ (⟨ a', ha' ⟩ : P'.FullSubcategory) := by + subst hA ha hP + rfl + +lemma Grpd.ObjectProperty.FullSubcategory.hext {A A' : Grpd.{v,u}} (hA : A ≍ A') + (P : ObjectProperty A) (P' : ObjectProperty A') (hP : P ≍ P') + (p : P.FullSubcategory) (p' : P'.FullSubcategory) + (hp : p.obj ≍ p'.obj) : p ≍ p' := by + cases p; cases p' + subst hA hP hp + rfl + +end CategoryTheory + +namespace GroupoidModel + +open CategoryTheory Opposite Functor.Groupoidal + +end GroupoidModel + +end ForOther + +-- NOTE content for this doc starts here +namespace GroupoidModel + +open CategoryTheory Opposite Functor.Groupoidal + +attribute [local simp] eqToHom_map Grpd.id_eq_id Grpd.comp_eq_comp Functor.id_comp Functor.comp_id + +namespace FunctorOperation +section + +open CategoryTheory.Functor + +variable {Γ : Type u₂} [Groupoid.{v₂} Γ] (A B : Γ ⥤ Grpd.{v₁,u₁}) + +/-- +The functor that, on objects `G : A.obj x ⥤ B.obj x` acts by +creating the map on the right, +by taking the inverse of `f : x ⟶ y` in the groupoid + A f + A x --------> A y + | . + | | + | . +G | | conjugating A B f G + | . + V V + B x --------> B y + B f +-/ + +@[simp] +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) := + conjugating' A B f + +lemma conjugating_obj {x y : Γ} (f : x ⟶ y) (s : A.obj x ⥤ B.obj x) : + (conjugating A B f).obj s = A.map (inv f) ⋙ s ⋙ B.map f := by + 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 + rfl + +@[simp] lemma conjugating_id (x : Γ) : conjugating A B (𝟙 x) = 𝟭 _ := by + simp [conjugating] + +@[simp] lemma conjugating_comp (x y z : Γ) (f : x ⟶ y) (g : y ⟶ z) : + 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₃} Δ] (σ : Δ ⥤ Γ) + {x y} (f : x ⟶ y) : conjugating (σ ⋙ A) (σ ⋙ B) f = conjugating A B (σ.map f) := by + simp [conjugating] + +def conjugatingObjNatTransEquiv' {x y : Γ} (f : x ⟶ y) (S) (T) : + ((Grpd.Functor.iso A f).inv ⋙ S ⋙ (Grpd.Functor.iso B f).hom ⟶ T) ≃ + (S ⋙ (Grpd.Functor.iso B f).hom ⟶ (Grpd.Functor.iso A f).hom ⋙ T) where + toFun η := eqToHom (by simp) ≫ whiskerLeft (Grpd.Functor.iso A f).hom η + invFun η := whiskerLeft (Grpd.Functor.iso A f).inv η ≫ eqToHom (by simp) + left_inv η := by + simp only [whiskerLeft_comp, whiskerLeft_eqToHom, whiskerLeft_twice, associator_eq, + CategoryTheory.Iso.refl_inv, CategoryTheory.Iso.refl_hom, Category.comp_id, Category.assoc, + ← heq_eq_eq, eqToHom_comp_heq_iff] + rw! (transparency := .default) [Category.id_comp, comp_eqToHom_heq_iff] + apply Functor.Iso.whiskerLeft_inv_hom_heq + right_inv η := by + simp only [whiskerLeft_comp, whiskerLeft_twice, associator_eq, CategoryTheory.Iso.refl_inv, + CategoryTheory.Iso.refl_hom, Category.comp_id, whiskerLeft_eqToHom, Category.assoc, ← + heq_eq_eq, eqToHom_comp_heq_iff] + rw! (transparency := .default) [Category.id_comp, comp_eqToHom_heq_iff] + apply Functor.Iso.whiskerLeft_hom_inv_heq + +-- @[simp] +-- lemma conjugatingObjNatTransEquiv'_apply {x y : Γ} (f : x ⟶ y) (S) (T) (g) : +-- conjugatingObjNatTransEquiv' A B f S T g = +-- eqToHom (by simp) ≫ g ≫ eqToHom (by simp) := by +-- ext +-- simp [conjugatingObjNatTransEquiv', Grpd.Functor.iso] + +@[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 + +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 + +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 + +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 + +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 + +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 + +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 [conjugatingObjNatTransEquiv', Grpd.Functor.iso, Functor.associator_eq] at * + erw [Category.id_comp] + rw [whiskerLeft_map_comp] + rw [whiskerLeft_map_comp] + simp [← Category.assoc] + congr 2 + rw [Functor.comp_whiskerLeft, Functor.whiskerRight_whiskerLeft, Functor.whiskerRight_whiskerLeft] + rw [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] + simp [← heq_eq_eq] + congr 1 + · simp [← Grpd.comp_eq_comp] + · simp [← Grpd.comp_eq_comp] + · 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 + +@[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 + +-- lemma conjugatingObjNatTransEquiv₁_comp_inv {x y z : Γ} (f1 : x ⟶ y) (f2 : y ⟶ z) (S) (T) +-- (g : A.map (inv (f1 ≫ f2)) ⋙ S ⋙ B.map (f1 ≫ f2) ⟶ T) : +-- (conjugatingObjNatTransEquiv₁ A B (f1 ≫ f2) S T g).inv = +-- eqToHom (by simp [Functor.assoc]) ≫ +-- (A.map f1 ⋙ A.map f2).whiskerLeft (CategoryTheory.inv g) ≫ +-- eqToHom (by simp [← Grpd.comp_eq_comp]) +-- := by +-- simp only [conjugatingObjNatTransEquiv₁, Groupoid.isoEquivHom, Groupoid.inv_eq_inv, +-- Equiv.trans_apply, Equiv.coe_fn_symm_mk] +-- erw [conjugatingObjNatTransEquiv'_comp] +-- simp [IsIso.inv_comp, inv_eqToHom, inv_whiskerLeft, Category.assoc] + +-- lemma conjugatingObjNatTransEquiv₁_comp_inv {x y z : Γ} (f1 : x ⟶ y) (f2 : y ⟶ z) (S) (T) +-- (g : A.map (inv (f1 ≫ f2)) ⋙ S ⋙ B.map (f1 ≫ f2) ⟶ T) : +-- (conjugatingObjNatTransEquiv₁ A B (f1 ≫ f2) S T g).inv = +-- eqToHom (by simp [Functor.assoc]) ≫ +-- whiskerLeft (A.map f1) (whiskerLeft (A.map f2) (CategoryTheory.inv g)) ≫ +-- eqToHom (by simp [← Grpd.comp_eq_comp]) +-- := by +-- dsimp only [conjugatingObjNatTransEquiv₁, Equiv.trans_apply] +-- simp only [Groupoid.isoEquivHom, Groupoid.inv_eq_inv, Equiv.coe_fn_symm_mk] +-- erw [conjugatingObjNatTransEquiv'_comp] +-- simp only [IsIso.inv_comp, inv_eqToHom, inv_whiskerLeft, Category.assoc] +end + +section + +variable {Γ : Type u₂} [Category.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} + (B : ∫(A) ⥤ Grpd.{v₁,u₁}) (x : Γ) + +-- 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 + +open sigma + +def piObj : Grpd := Grpd.of (Section (fstAuxObj B x)) + +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] + +end + +section +variable {Γ : Type u₂} [Groupoid.{v₂} Γ] (A : Γ ⥤ Grpd.{u₁,u₁}) (B : ∫(A) ⥤ Grpd.{u₁,u₁}) +variable {x y : Γ} (f: x ⟶ y) + +open sigma + +/-- +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 + +/-- 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`, +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) + ⋮ || + ⋮ || conjugating A (sigma A B) f + VV VV + piObj B y ⥤ (A y ⥤ sigma A 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) + +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 + +lemma piMap_map (s1 s2: piObj B x) (η: s1 ⟶ s2) : + (piMap A B f).map η = (conjugating A (sigma A B) f).map η := + rfl + +/-- +The square commutes + + 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 := + rfl + +@[simp] lemma piMap_id (x : Γ) : piMap A B (𝟙 x) = 𝟭 (piObj B x) := by + simp only [piMap, conjugating_id] + 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] + 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 + +end + +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] + +lemma piObj_naturality (x): + piObj B (σ.obj x) = piObj (pre A σ ⋙ B) x := by + dsimp [pi, piObj, sigma.fstAuxObj] + rw [sigma_naturality_aux] + +section + +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_ι' + +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 + +lemma conjugating_naturality_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 + +lemma comm_sq_of_comp_mono {C : Type*} [Category C] + {X Y Z W X' Y' Z' W' : C} + (f : X ⟶ Y) (h : X ⟶ W) (g : Y ⟶ Z) (i : W ⟶ Z) + (f' : X' ⟶ Y') (h' : X' ⟶ W') (g' : Y' ⟶ Z') (i' : W' ⟶ Z') + (mX : X ⟶ X') (mY : Y ⟶ Y') (mW : W ⟶ W') (mZ : Z ⟶ Z') + (hbot : f' ≫ g' = h' ≫ i') + (hf : f ≫ mY = mX ≫ f') + (hh : h ≫ mW = mX ≫ h') + (hg : g ≫ mZ = mY ≫ g') + (hi : i ≫ mZ = mW ≫ i') + [e : Mono mZ] + : f ≫ g = h ≫ i := by + apply e.right_cancellation + calc (f ≫ g) ≫ mZ + _ = f ≫ mY ≫ g' := by aesop + _ = (f ≫ mY) ≫ g' := by simp + _ = (h ≫ mW) ≫ i' := by aesop + _ = 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] + +end + +namespace pi + +section + +variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {A : Γ ⥤ Grpd.{u₁,u₁}} (B : ∫(A) ⥤ Grpd.{u₁,u₁}) + (s : Γ ⥤ PGrpd.{u₁,u₁}) (hs : s ⋙ PGrpd.forgetToGrpd = pi A B) + {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) + +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 + +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 + +lemma eqToHom_heq_id {C : Type*} [Category C] (x y z : C) (h : x = y) + (hz : z = x) : eqToHom h ≍ 𝟙 z := by cat_disch + +@[reassoc] +lemma _root_.CategoryTheory.Functor.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 + +theorem _root_.CategoryTheory.PGrpd.mapFiber'_comp' + {A : Γ ⥤ Grpd.{v₁,u₁}} {α : Γ ⥤ PGrpd.{v₁,u₁}} (h : α ⋙ PGrpd.forgetToGrpd = A) + {x y z} (f : x ⟶ y) + (g : y ⟶ z) : PGrpd.mapFiber' h (f ≫ g) + = eqToHom (by simp) ≫ (A.map g).map (PGrpd.mapFiber' h f) ≫ PGrpd.mapFiber' h g := by + subst h + simp [PGrpd.mapFiber] + +@[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 only [sigma_obj, sigma_map, PGrpd.mapFiber'_id, pi_obj, pi_map, eqToHom_comp_iff, + eqToHom_trans, IsIso.inv_comp_eq] + simp only [← heq_eq_eq, heq_comp_eqToHom_iff] + apply eqToHom_heq_eqToHom + · simp + · simp + +-- 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') [IsIso f] : +-- have : IsIso f' := by aesop +-- inv f ≍ inv f' := by +-- subst hC hX hY hf +-- rfl + +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 + +@[reassoc] +lemma strongTrans.naturality_comp_hom_aux {x y} (g : x ⟶ y) : + A.map g ≫ ((piMap A B g).obj (PGrpd.objFiber' hs x)).obj = + (PGrpd.objFiber' hs x).obj ⋙ sigmaMap B g := by + simp [piMap, conjugating, ← Grpd.comp_eq_comp] + +-- 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) ≫ +-- CategoryTheory.inv +-- ((A.map g1 ⋙ A.map g2).whiskerLeft ((piMap A B g2).map (PGrpd.mapFiber' hs g1) ≫ +-- PGrpd.mapFiber' hs g2)) ≫ +-- eqToHom (by +-- simp only [← Grpd.comp_eq_comp, ← Functor.map_comp, pi_obj, pi_map, ObjectProperty.ι_obj] +-- simp only [← Functor.comp_obj, ← piMap_comp] +-- apply strongTrans.naturality_comp_hom_aux) := by +-- simp only [naturality, sigma_obj, sigma_map, Equiv.toFun_as_coe, Iso.symm_hom, +-- ObjectProperty.ι_obj, pi_obj, pi_map, PGrpd.mapFiber'_comp'] +-- erw [conjugatingObjNatTransEquiv₁_comp_inv] +-- simp only [← heq_eq_eq, heq_eqToHom_comp_iff, eqToHom_comp_heq_iff, +-- comp_eqToHom_heq_iff] +-- simp only [← Category.assoc, heq_comp_eqToHom_iff] +-- simp only [← Functor.inv_whiskerLeft] +-- congr! 2 +-- · rw [← Functor.comp_obj, ← piMap_comp] +-- simp only [piMap_obj_obj] +-- rfl +-- · rw [← Functor.comp_obj, ← piMap_comp] +-- simp only [piMap_obj_obj] +-- rfl +-- · simp only [Category.assoc] +-- apply HEq.trans (eqToHom_comp_heq ..) +-- rfl + +set_option maxHeartbeats 400000 +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 ≫ + Functor.whiskerRight (strongTrans.naturality B s hs g1).hom (sigmaMap B g2) + ≫ eqToHom (by simp [Functor.assoc, sigmaMap_comp]) := by + simp only [naturality, sigma_obj, sigma_map, Equiv.toFun_as_coe, Iso.symm_hom] + refine conjugatingObjNatTransEquiv₁_comp_inv A (sigma A B) g1 g2 + (PGrpd.objFiber' hs x).obj (PGrpd.objFiber' hs y).obj (PGrpd.objFiber' hs z).obj + (PGrpd.mapFiber' hs g1) (PGrpd.mapFiber' hs g2) + (PGrpd.mapFiber' hs (g1 ≫ g2)) ?_ + simp [PGrpd.mapFiber'_comp', piMap, conjugating] + rfl + + -- rw [strongTrans.naturality_comp_hom'] + -- simp only [sigma_obj, sigma_map, conjugatingObjNatTransEquiv₁, Groupoid.isoEquivHom, + -- Groupoid.inv_eq_inv, Equiv.trans_apply, Equiv.coe_fn_symm_mk] + -- simp only [← Functor.inv_whiskerLeft, ← CategoryTheory.Functor.inv_whiskerRight, + -- ← IsIso.inv_comp_assoc] + -- simp only [← heq_eq_eq, heq_eqToHom_comp_iff, eqToHom_comp_heq_iff, + -- comp_eqToHom_heq_iff, heq_comp_eqToHom_iff] + -- congr! 2 + -- · simp [← Grpd.comp_eq_comp, sigmaMap_comp, Functor.assoc] + -- simp + -- · have h := conjugatingObjNatTransEquiv'_comp A (sigma A B) g1 g2 + -- (PGrpd.objFiber' hs x).obj (PGrpd.objFiber' hs z).obj (PGrpd.mapFiber' hs (g1 ≫ g2)) + -- simp [conjugatingObjNatTransEquiv', Grpd.Functor.iso, ← heq_eq_eq] at h + +set_option maxHeartbeats 400000 +@[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 := by + intro x y f g η + have : f = g := LocallyDiscrete.eq_of_hom η + subst this + simp [Functor.toPseudoFunctor', pseudofunctorOfIsLocallyDiscrete] + naturality_id := by + intro x + simp only [Functor.toPseudoFunctor'_obj, Functor.comp_obj, sigma_obj, + Functor.toPseudoFunctor'_map, LocallyDiscrete.id_as, Functor.comp_map, sigma_map, + strongTrans.naturality_id_hom, Functor.toPseudoFunctor'_mapId, eqToIso.hom, + Bicategory.whiskerLeft_eqToHom, eqToHom_trans, Bicategory.eqToHom_whiskerRight, + Bicategory.leftUnitor, Bicategory.rightUnitor, + Functor.leftUnitor_hom_comp_rightUnitor_inv (PGrpd.objFiber' hs x.as).obj, + Functor.simpIdComp, ← heq_eq_eq, heq_eqToHom_comp_iff] + apply eqToHom_heq_id + simp [Grpd.forgetToCat, Cat.comp_eq_comp] + naturality_comp := by + intro x y z g1 g2 + simp only [Functor.toPseudoFunctor'_obj, Functor.comp_obj, sigma_obj, + Functor.toPseudoFunctor'_map, LocallyDiscrete.comp_as, Functor.comp_map, sigma_map, + Bicategory.whiskerLeft, Functor.toPseudoFunctor'_mapComp, eqToIso.hom, + Bicategory.whiskerRight, Bicategory.associator, Functor.associator_eq, Iso.refl_hom, + Iso.refl_inv] + rw [Functor.whiskerLeft_eqToHom, Functor.eqToHom_whiskerRight, + strongTrans.naturality_comp_hom] + simp only [← Grpd.comp_eq_comp, Category.assoc] + erw [Category.id_comp, Category.id_comp, Category.comp_id] + simp only [Grpd.forgetToCat, id_eq, Cat.of_α, eqToHom_trans, eqToHom_refl, Category.comp_id] + +def mapStrongTrans : ∫ A ⥤ ∫ sigma A B := + Functor.Grothendieck.toPseudoFunctor'Iso.hom _ ⋙ + Pseudofunctor.Grothendieck.map (strongTrans B s hs) ⋙ + Functor.Grothendieck.toPseudoFunctor'Iso.inv _ + +@[simp] +lemma mapStrongTrans_obj_base (x) : ((mapStrongTrans B s hs).obj x).base = x.base := + rfl + +@[simp] +lemma mapStrongTrans_obj_fiber (x) : ((mapStrongTrans B s hs).obj x).fiber = + (PGrpd.objFiber' hs x.base).obj.obj x.fiber := + rfl + +@[simp] +lemma mapStrongTrans_map_base {x y} (f : x ⟶ y) : ((mapStrongTrans B s hs).map f).base = + f.base := + rfl + +@[simp] +lemma mapStrongTrans_map_fiber {x y} (f : x ⟶ y) : ((mapStrongTrans B s hs).map f).fiber = + eqToHom (by + simp only [mapStrongTrans_obj_base, sigma_obj, mapStrongTrans_map_base, sigma_map, + mapStrongTrans_obj_fiber, pi_obj, pi_map, piMap, ObjectProperty.ι_obj, + ObjectProperty.lift_obj_obj, Functor.comp_obj, conjugating_obj, Functor.map_inv] + simp [← Functor.comp_obj, ← Grpd.comp_eq_comp]) ≫ + (PGrpd.mapFiber' hs f.base).app ((A.map f.base).obj x.fiber) ≫ + (PGrpd.objFiber' hs y.base).obj.map f.fiber := by + simp only [mapStrongTrans, Functor.Grothendieck.toPseudoFunctor'Iso.inv, Functor.comp_obj, + Pseudofunctor.Grothendieck.map_obj_base, Functor.Grothendieck.toPseudoFunctor'Iso.hom_obj_base, + Pseudofunctor.Grothendieck.map_obj_fiber, Functor.toPseudoFunctor'_obj, sigma_obj, + strongTrans_app, Functor.Grothendieck.toPseudoFunctor'Iso.hom_obj_fiber, Functor.comp_map, + Pseudofunctor.Grothendieck.map_map_base, Functor.Grothendieck.toPseudoFunctor'Iso.hom_map_base, + Pseudofunctor.Grothendieck.map_map_fiber, Functor.toPseudoFunctor'_map, Quiver.Hom.toLoc_as, + sigma_map, strongTrans_naturality, strongTrans.naturality, conjugatingObjNatTransEquiv₁, + Grpd.Functor.iso, Grpd.functorIsoOfIso_inv, Functor.mapIso_inv, asIso_inv, + Grpd.functorIsoOfIso_hom, Functor.mapIso_hom, asIso_hom, conjugatingObjNatTransEquiv', + Groupoid.isoEquivHom, Equiv.toFun_as_coe, Equiv.trans_apply, Equiv.coe_fn_mk, + Equiv.coe_fn_symm_mk, Iso.symm_mk, NatTrans.comp_app, Cat.comp_obj, Functor.whiskerLeft_app, + Functor.Grothendieck.toPseudoFunctor'Iso.hom_map_fiber, Hom.fiber, + Functor.Grothendieck.Hom.mk_fiber, eqToHom_app, Category.assoc] + rfl + +/-- 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`. +-/ +@[simps!] +def inversion : ∫(A) ⥤ PGrpd := mapStrongTrans B s hs ⋙ (sigma.assoc B).inv ⋙ toPGrpd B + +@[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 _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_obj_base_base' + {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) + (x : ∫ sigma A B) : + ((sigma.assoc B).inv.obj x).base.base = x.base := by + simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, + sigma.assocFib.eq_1] + rw! (castMode := .all) [pre_obj_base] + simp + rfl + +lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_obj_base_fiber' + {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) + (x : ∫ sigma A B) : + ((sigma.assoc B).inv.obj x).base.fiber = x.fiber.base := by + simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, + sigma.assocFib.eq_1] + rw! (castMode := .all) [pre_obj_base] + simp + rfl + +lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_map_base_base' + {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) + {X Y : ∫ sigma A B} (f : X ⟶ Y) : + ((sigma.assoc B).inv.map f).base.base = f.base := by + simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, + sigma.assocFib.eq_1, functorIsoFrom_hom_map, sigma_map, comp_base, pre_map_base, + assocHom_app_base_base, ι_map_base, ι_obj_base] + erw [Category.comp_id] + simp [Hom.base] + +-- TODO replace simps! with this +lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_map_base_fiber' + {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) + {X Y : ∫ sigma A B} (f : X ⟶ Y) : + ((sigma.assoc B).inv.map f).base.fiber = eqToHom (by + simp + rw! [sigma.assoc_inv_map_base_base', sigma.assoc_inv_obj_base_fiber']) ≫ + f.fiber.base := by + simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, + sigma.assocFib.eq_1, functorIsoFrom_hom_map, sigma_map, comp_base, comp_fiber, + sigmaMap_obj_base] + rw! [pre_map_base, ι_map_fiber] + simp only [ι_map_base, ι_obj_base, ι_obj_fiber] + erw [Grpd.map_id_map, assocHom_app_base_fiber] + simp only [sigma.assocFib.eq_1, Functor.comp_obj, eqToHom_refl, Category.id_comp, eqToHom_trans] + erw [Category.id_comp] + simp + rfl + +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_fiber] + exact Functor.congr_obj (PGrpd.objFiber' hs x.base).property x.fiber + · intro x y f + simp [sigma.fstAux'] + rw [sigma.assoc_inv_map_base_fiber'] + have h := Functor.congr_hom (PGrpd.objFiber' hs y.base).property f.fiber + dsimp [IsSection, sigma.fstAuxObj] at h + simp [h] + simp [← Category.assoc] + -- rw! [PGrpd.mapFiber'_heq] + -- rw [← comp_base] + -- erw [mapStrongTrans_map_fiber_base] + -- apply heq_of_eq_of_heq (sigma.assoc_inv_map_base_fiber ..) + -- simp [Grpd.forgetToCat] + -- have h := pre_map_base B (ι A y.base) ((mapStrongTrans B s hs).map f).fiber + -- erw [h] + -- erw [sigma.assoc_inv_map_base_fiber] + -- #check pre_map_base + -- #check mapStrongTrans_map_fiber_base + sorry + +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'] + +-- 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 + apply PGrpd.Functor.hext + · simp only [Functor.assoc, inversion_comp_forgetToGrpd, toPGrpd_forgetToGrpd] + rw [← Functor.assoc, (PGrpd.objFiber' hs x).property, 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 + sorry + +end + +section + +variable {Γ : Type u₂} [Groupoid.{v₂} Γ] (A : Γ ⥤ Grpd.{u₁,u₁}) (β : ∫(A) ⥤ PGrpd.{u₁,u₁}) + +section +variable (x : Γ) + +def lamObjFiberObj : Grpd.of (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 + simp [lamObjFiberObj] + +@[simp] lemma lamObjFiberObj_obj_fiber (a) : ((lamObjFiberObj A β x).obj a).fiber + = PGrpd.objFiber (ι A x ⋙ β) a := by + simp [lamObjFiberObj] + +@[simp] lemma lamObjFiberObj_map_base {a a'} (h: a ⟶ a'): + ((lamObjFiberObj A β x).map h).base = h := by + simp [lamObjFiberObj] + +@[simp] lemma lamObjFiberObj_map_fiber {a a'} (h: a ⟶ a'): + ((lamObjFiberObj A β x).map h).fiber = PGrpd.mapFiber (ι A x ⋙ β) h := by + simp [lamObjFiberObj] + +def lamObjFiber : piObj (β ⋙ PGrpd.forgetToGrpd) x := + ⟨lamObjFiberObj A β x , rfl⟩ + +@[simp] lemma lamObjFiber_obj : (lamObjFiber A β x).obj = lamObjFiberObj A β x := + rfl + +@[simp] lemma lamObjFiber_obj_obj : (lamObjFiber A β x).obj = lamObjFiberObj A β x := + rfl + +end + +section +variable {x y : Γ} (f : x ⟶ y) + +open CategoryTheory.Functor + +def lamObjFiberObjCompSigMap.app (a : A.obj x) : + (lamObjFiberObj A β x ⋙ sigmaMap (β ⋙ PGrpd.forgetToGrpd) f).obj a ⟶ + (A.map f ⋙ lamObjFiberObj A β y).obj a := + homMk (𝟙 _) (eqToHom (by simp; rfl) ≫ (β.map ((ιNatTrans f).app a)).fiber) + +@[simp] lemma lamObjFiberObjCompSigMap.app_base (a : A.obj x) : (app A β f a).base = 𝟙 _ := by + simp [app] + +lemma lamObjFiberObjCompSigMap.app_fiber_eq (a : A.obj x) : (app A β f a).fiber = + eqToHom (by simp; rfl) ≫ (β.map ((ιNatTrans f).app a)).fiber := by + simp [app] + +lemma lamObjFiberObjCompSigMap.app_fiber_heq (a : A.obj x) : (app A β f a).fiber ≍ + (β.map ((ιNatTrans f).app a)).fiber := by + simp [app] + +lemma lamObjFiberObjCompSigMap.naturality {x y : Γ} (f : x ⟶ y) {a1 a2 : A.obj x} (h : a1 ⟶ a2) : + (lamObjFiberObj A β x ⋙ sigmaMap (β ⋙ PGrpd.forgetToGrpd) f).map h + ≫ lamObjFiberObjCompSigMap.app A β f a2 = + lamObjFiberObjCompSigMap.app A β f a1 + ≫ (A.map f ⋙ lamObjFiberObj A β y).map h := by + apply Hom.hext + · simp [sigmaObj] + · have β_ιNatTrans_naturality : β.map ((ι A x).map h) ≫ β.map ((ιNatTrans f).app a2) + = β.map ((ιNatTrans f).app a1) ≫ β.map ((A.map f ⋙ ι A y).map h) := by + simp [← Functor.map_comp, (ιNatTrans f).naturality h] + have h_naturality : (β.map ((ιNatTrans f).app a2)).base.map (β.map ((ι A x).map h)).fiber + ≫ (β.map ((ιNatTrans f).app a2)).fiber ≍ + (β.map ((ι A y).map ((A.map f).map h))).base.map (β.map ((ιNatTrans f).app a1)).fiber + ≫ (β.map ((ι A y).map ((A.map f).map h))).fiber := by + simpa [← heq_eq_eq] using Grothendieck.Hom.congr β_ιNatTrans_naturality + simp only [Grpd.forgetToCat.eq_1, sigmaObj, Grpd.coe_of, comp_obj, sigmaMap_obj_base, + Functor.comp_map, comp_base, sigmaMap_map_base, sigmaMap_obj_fiber, comp_fiber, + sigmaMap_map_fiber, lamObjFiberObj_map_fiber, map_comp, eqToHom_map, app_fiber_eq, Cat.of_α, + id_eq, Category.assoc, eqToHom_trans_assoc, heq_eqToHom_comp_iff, eqToHom_comp_heq_iff] + rw [← Category.assoc] + apply HEq.trans _ h_naturality + apply heq_comp _ rfl rfl _ HEq.rfl + · aesop_cat + · simp only [← Functor.comp_map, ← Grpd.comp_eq_comp, comp_eqToHom_heq_iff] + congr 3 + aesop_cat + +@[simp] lemma lamObjFiberObjCompSigMap.app_id (a) : lamObjFiberObjCompSigMap.app A β (𝟙 x) a + = eqToHom (by simp) := by + apply Hom.hext + · rw [base_eqToHom] + simp + · simp [app] + rw! (castMode := .all) [ιNatTrans_id_app, fiber_eqToHom] + simp [Grothendieck.Hom.congr (eqToHom_map β _), Functor.Grothendieck.fiber_eqToHom, + eqToHom_trans] + apply (eqToHom_heq_id_cod _ _ _).trans (eqToHom_heq_id_cod _ _ _).symm + +lemma lamObjFiberObjCompSigMap.app_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) (a) : + app A β (f ≫ g) a + = eqToHom (by simp) + ≫ (sigmaMap (β ⋙ PGrpd.forgetToGrpd) g).map (app A β f a) + ≫ app A β g ((A.map f).obj a) ≫ eqToHom (by simp) := by + fapply Hom.hext + · simp only [Grpd.forgetToCat.eq_1, sigmaObj, Grpd.coe_of, comp_obj, sigmaMap_obj_base, app_base, + comp_base, base_eqToHom, sigmaMap_map_base, map_id, lamObjFiberObj_obj_base, map_comp, + Grpd.comp_eq_comp, eqToHom_naturality, Category.comp_id, eqToHom_trans, eqToHom_refl] + · have : (β.map ((ιNatTrans (f ≫ g)).app a)) = β.map ((ιNatTrans f).app a) + ≫ β.map ((ιNatTrans g).app ((A.map f).obj a)) + ≫ eqToHom (by simp) := by + simp [ιNatTrans_comp_app] + simp only [Grpd.forgetToCat.eq_1, sigmaObj, Grpd.coe_of, comp_obj, sigmaMap_obj_base, app, + Functor.comp_map, PGrpd.forgetToGrpd_map, sigmaMap_obj_fiber, Cat.of_α, id_eq, homMk_base, + homMk_fiber, Grothendieck.Hom.congr this, Grothendieck.Hom.comp_base, Grpd.comp_eq_comp, + Grothendieck.Hom.comp_fiber, eqToHom_refl, Functor.Grothendieck.fiber_eqToHom, + Category.id_comp, eqToHom_trans_assoc, comp_base, sigmaMap_map_base, comp_fiber, + fiber_eqToHom, eqToHom_map, sigmaMap_map_fiber, map_comp, Category.assoc, + heq_eqToHom_comp_iff, eqToHom_comp_heq_iff] + have : ((ιNatTrans g).app ((A.map f).obj a)) = homMk g (𝟙 _) := by + apply Hom.ext _ _ (by simp) (by aesop_cat) + rw! (castMode := .all) [Category.id_comp, base_eqToHom, eqToHom_map, eqToHom_map, + Functor.Grothendieck.base_eqToHom, ιNatTrans_app_base, this] + aesop_cat + +def lamObjFiberObjCompSigMap : + lamObjFiberObj A β x ⋙ sigmaMap (β ⋙ PGrpd.forgetToGrpd) f ⟶ + A.map f ⋙ lamObjFiberObj A β y where + app := lamObjFiberObjCompSigMap.app A β f + naturality _ _ h := lamObjFiberObjCompSigMap.naturality A β f h + +@[simp] lemma lamObjFiberObjCompSigMap_id (x : Γ) : lamObjFiberObjCompSigMap A β (𝟙 x) = + eqToHom (by simp [sigmaMap_id]) := by + 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) + ≫ whiskerRight (lamObjFiberObjCompSigMap A β f) (sigmaMap (β ⋙ PGrpd.forgetToGrpd) g) + ≫ whiskerLeft (A.map f) (lamObjFiberObjCompSigMap A β g) + ≫ eqToHom (by rw [Functor.map_comp, Grpd.comp_eq_comp, Functor.assoc]) := by + ext a + simp [lamObjFiberObjCompSigMap, lamObjFiberObjCompSigMap.app_comp] + +def whiskerLeftInvLamObjObjSigMap : + A.map (CategoryTheory.inv f) ⋙ lamObjFiberObj A β x ⋙ sigmaMap (β ⋙ PGrpd.forgetToGrpd) f ⟶ + lamObjFiberObj A β y := + whiskerLeft (A.map (CategoryTheory.inv f)) (lamObjFiberObjCompSigMap A β f) + ≫ eqToHom (by simp [← Grpd.comp_eq_comp]) + +@[simp] lemma whiskerLeftInvLamObjObjSigMap_id (x : Γ) : + whiskerLeftInvLamObjObjSigMap A β (𝟙 x) = eqToHom (by simp [sigmaMap_id]) := by + simp [whiskerLeftInvLamObjObjSigMap] + +attribute [local simp] Functor.assoc in +lemma whiskerLeftInvLamObjObjSimgaMap_comp_aux {A A' B B' C C' : Type*} + [Category A] [Category A'] [Category B] [Category B'] [Category C] [Category C'] + (F : Functor.Iso A B) (G : Functor.Iso B C) (lamA : A ⥤ A') (lamB : B ⥤ B') (lamC : C ⥤ C') + (F' : A' ⥤ B') (G' : B' ⥤ C') + (lamF : lamA ⋙ F' ⟶ F.hom ⋙ lamB) (lamG : lamB ⋙ G' ⟶ G.hom ⋙ lamC) + (H1 : A ⥤ C') (e1 : H1 = _) (H2 : A ⥤ C') (e2 : F.hom ⋙ G.hom ⋙ lamC = H2) : + whiskerLeft (G.inv ⋙ F.inv) + (eqToHom e1 ≫ whiskerRight lamF G' ≫ whiskerLeft F.hom lamG ≫ eqToHom e2) = + eqToHom (by aesop) ≫ + whiskerRight (whiskerLeft G.inv (whiskerLeft F.inv lamF ≫ eqToHom (by simp))) G' ≫ + whiskerLeft G.inv lamG ≫ + eqToHom (by aesop) := + calc _ + _ = eqToHom (by aesop) ≫ + (G.inv ⋙ F.inv).whiskerLeft (whiskerRight lamF G') ≫ + (G.inv ⋙ F.inv ⋙ F.hom).whiskerLeft lamG ≫ + eqToHom (by aesop) := by aesop + _ = (eqToHom (by aesop)) ≫ + whiskerLeft (G.inv ⋙ F.inv) (whiskerRight lamF G') ≫ + eqToHom (by simp) ≫ + whiskerLeft G.inv lamG ≫ + eqToHom (by aesop) := by + congr 2 + simp only [Functor.assoc, ← heq_eq_eq, heq_eqToHom_comp_iff, heq_comp_eqToHom_iff, + comp_eqToHom_heq_iff] + rw! (castMode := .all) [F.inv_hom_id, Functor.comp_id] + simp + _ = eqToHom (by aesop) ≫ + whiskerRight (whiskerLeft G.inv (whiskerLeft F.inv lamF ≫ eqToHom (by simp))) G' ≫ + whiskerLeft G.inv lamG ≫ + eqToHom (by aesop) := by aesop_cat + +lemma whiskerLeftInvLamObjObjSigMap_comp {x y z} (f : x ⟶ y) (g : y ⟶ z) : + whiskerLeftInvLamObjObjSigMap A β (f ≫ g) + = eqToHom (by simp [Functor.assoc, sigmaMap_comp]) + ≫ whiskerRight (whiskerLeft (A.map (CategoryTheory.inv g)) + (whiskerLeftInvLamObjObjSigMap A β f)) (sigmaMap (β ⋙ PGrpd.forgetToGrpd) g) + ≫ whiskerLeftInvLamObjObjSigMap A β g := by + simp only [whiskerLeftInvLamObjObjSigMap, lamObjFiberObjCompSigMap_comp] + have hAfg : A.map (CategoryTheory.inv (f ≫ g)) = (Grpd.Functor.iso A g).inv ≫ + (Grpd.Functor.iso A f).inv := by simp [Grpd.Functor.iso] + rw! (castMode := .all) [hAfg] + erw [whiskerLeftInvLamObjObjSimgaMap_comp_aux (Grpd.Functor.iso A f) (Grpd.Functor.iso A g) + _ _ _ (sigmaMap (β ⋙ PGrpd.forgetToGrpd) f) (sigmaMap (β ⋙ PGrpd.forgetToGrpd) g)] + simp only [Category.assoc, eqToHom_trans, Grpd.Functor.iso_hom, Grpd.Functor.iso_inv] + +def lamMapFiber : + ((pi A (β ⋙ PGrpd.forgetToGrpd)).map f).obj (lamObjFiber A β x) ⟶ lamObjFiber A β y := + whiskerLeftInvLamObjObjSigMap A β f + +@[simp] lemma lamMapFiber_id (x : Γ) : lamMapFiber A β (𝟙 x) = eqToHom (by simp) := by + simp [lamMapFiber] + 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] + rfl + +def lam : Γ ⥤ PGrpd.{u₁,u₁} := + PGrpd.functorTo + (pi A (β ⋙ PGrpd.forgetToGrpd)) + (lamObjFiber A β) + (lamMapFiber A β) + (lamMapFiber_id A β) + (lamMapFiber_comp A β) + +@[simp] +lemma lam_obj_base (x) : ((lam A β).obj x).base = piObj (β ⋙ PGrpd.forgetToGrpd) x := rfl + +@[simp] +lemma lam_obj_fib (x) : ((lam A β).obj x).fiber = lamObjFiber A β x := + rfl + +@[simp] +lemma lam_map_base {x y} (f : x ⟶ y) : ((lam A β).map f).base = + piMap A (β ⋙ PGrpd.forgetToGrpd) f := + rfl + +@[simp] +lemma lam_map_fib {x y} (f : x ⟶ y) : ((lam A β).map f).fiber = lamMapFiber A β f := + rfl + +lemma lam_comp_forgetToGrpd : lam A β ⋙ PGrpd.forgetToGrpd = pi A (β ⋙ PGrpd.forgetToGrpd) := + rfl + +variable {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) + +lemma lam_naturality_aux (x) : + ι A (σ.obj x) ⋙ β ⋙ PGrpd.forgetToGrpd = ι (σ ⋙ A) x ⋙ pre A σ ⋙ β ⋙ PGrpd.forgetToGrpd := by + simp [← Functor.assoc, ← ι_comp_pre] + +lemma lamObjFiberObj_naturality (x) : + lamObjFiberObj A β (σ.obj x) ≍ lamObjFiberObj (σ ⋙ A) (pre A σ ⋙ β) x := by + 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 lamObjFiberObjCompSigMap.app_naturality {x y} (f : x ⟶ y) (a) : + lamObjFiberObjCompSigMap.app A β (σ.map f) a ≍ + lamObjFiberObjCompSigMap.app (σ ⋙ A) (pre A σ ⋙ β) f a := by + apply Hom.hext' + any_goals apply Grpd.Functor.hcongr_obj + 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 sigmaMap_naturality_heq + any_goals apply lamObjFiberObj_naturality + any_goals simp [app]; rfl + +lemma lamObjFiberObjCompSigMap_naturality {x y} (f : x ⟶ y) : + lamObjFiberObjCompSigMap A β (σ.map f) ≍ + lamObjFiberObjCompSigMap (σ ⋙ A) (pre A σ ⋙ β) f := by + apply Grpd.NatTrans.hext + any_goals apply Grpd.comp_hcongr + any_goals simp only [comp_obj, Functor.comp_map, heq_eq_eq, eqToHom_refl] + any_goals apply sigmaObj_naturality + any_goals apply lamObjFiberObj_naturality + · apply sigmaMap_naturality_heq + · apply lamObjFiberObjCompSigMap.app_naturality + +lemma whiskerLeftInvLamObjObjSigMap_naturality_heq {x y} (f : x ⟶ y) : + whiskerLeftInvLamObjObjSigMap A β (σ.map f) ≍ + whiskerLeftInvLamObjObjSigMap (σ ⋙ A) (pre A σ ⋙ β) f := by + simp only [whiskerLeftInvLamObjObjSigMap, Functor.comp_map] + apply HEq.trans (comp_eqToHom_heq _ _) + apply HEq.trans _ (comp_eqToHom_heq _ _).symm + rw [Functor.map_inv, Functor.map_inv, Functor.map_inv] + apply Grpd.whiskerLeft_hcongr_right + any_goals apply Grpd.comp_hcongr + any_goals simp only [comp_obj, heq_eq_eq] + any_goals apply sigmaObj_naturality + any_goals apply lamObjFiberObj_naturality + · apply sigmaMap_naturality_heq + · apply lamObjFiberObjCompSigMap_naturality + +lemma lam_naturality_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 PGrpd.Functor.hext + · apply pi_naturality + · apply lam_naturality_obj + · apply lam_naturality_map + +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 + · intro x y f + simp [inversion] + sorry + +end + +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] + symm + apply Functor.IsPullback.lift_uniq + · symm + apply pi.ι_comp_inversion + · exact (PGrpd.objFiber' hs x).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 + · rfl + · simp [pi.inversion_comp_forgetToGrpd] + · apply lamObjFiberObj_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) + +lemma lamMapFiber_inversion_heq {x y} (f : x ⟶ y) : + lamMapFiber A (pi.inversion B s hs) f ≍ PGrpd.mapFiber s f := + sorry + +lemma lam_inversion : lam A (inversion B s hs) = s := by + apply PGrpd.Functor.hext -- TODO: rename to PGrpd.ToFunctor.hext + · rw [lam_comp_forgetToGrpd, inversion_comp_forgetToGrpd, hs] + · apply lamObjFiber_inversion_heq + · apply lamMapFiber_inversion_heq + +end + +end + +end pi + +end FunctorOperation + +section +variable {Γ : Ctx} + +open FunctorOperation + +namespace UPi + +def Pi {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) : Γ ⟶ U.{v}.Ty := + USig.SigAux pi B + +/-- Naturality for the formation rule for Π-types. +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 + +def lam {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (b : U.ext A ⟶ U.{v}.Tm) : Γ ⟶ U.{v}.Tm := + USig.SigAux pi.lam b + +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 + +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 + subst b_tp + dsimp [lam, Pi, U.tp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_right] + rfl + +def unLam {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) (f : Γ ⟶ U.Tm) + (f_tp : f ≫ U.tp = UPi.Pi B) : U.ext A ⟶ U.{v}.Tm := + toCoreAsSmallEquiv.symm <| pi.inversion (toCoreAsSmallEquiv B) (toCoreAsSmallEquiv f) (by + simp [U.tp] at f_tp + rw [← toCoreAsSmallEquiv_apply_comp_right, f_tp] + simp [Pi]) + +lemma unLam_tp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) (f : Γ ⟶ U.Tm) + (f_tp : f ≫ U.tp = UPi.Pi B) : UPi.unLam B f f_tp ≫ U.tp = B := by + dsimp [unLam, U.tp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_right, toCoreAsSmallEquiv.symm_apply_eq, + pi.inversion_comp_forgetToGrpd] + rfl + +lemma unLam_lam {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) (b : U.ext A ⟶ U.Tm) + (b_tp : b ≫ U.tp = B) : UPi.unLam B (UPi.lam b) (lam_tp _ _ b_tp) = b := by + subst b_tp + simp only [unLam, lam, toCoreAsSmallEquiv.symm_apply_eq, U.tp, Grpd.comp_eq_comp, + Equiv.apply_symm_apply] + rw! [toCoreAsSmallEquiv_apply_comp_right] + rw [pi.inversion_lam (toCoreAsSmallEquiv A) (toCoreAsSmallEquiv b)] + rfl + +lemma lam_unLam {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) (f : Γ ⟶ U.Tm) + (f_tp : f ≫ U.tp = UPi.Pi B) : UPi.lam (UPi.unLam B f f_tp) = f := by + simp [lam, unLam, toCoreAsSmallEquiv.symm_apply_eq] + erw [toCoreAsSmallEquiv.apply_symm_apply] + rw [pi.lam_inversion] + +end UPi + +def UPi : Model.UnstructuredUniverse.PolymorphicPi U.{v} U.{v} U.{v} where + Pi := UPi.Pi + Pi_comp := UPi.Pi_comp + lam _ b _ := UPi.lam b + lam_comp _ _ _ _ _ _ _ := UPi.lam_comp .. + lam_tp := UPi.lam_tp + unLam := UPi.unLam + unLam_tp := UPi.unLam_tp + unLam_lam := UPi.unLam_lam + lam_unLam := UPi.lam_unLam + +end + +end GroupoidModel diff --git a/HoTTLean/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index ff14c7e7..fca29ee5 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -47,19 +47,56 @@ lemma Functor.associator_eq {C D E E' : Type*} [Category C] [Category D] [Catego 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 + +def IsOverId : MorphismProperty ((IsSection F).FullSubcategory) := + fun s t α => Functor.whiskerRight α F = eqToHom s.property ≫ 𝟙 (𝟭 A) ≫ eqToHom t.property.symm + +instance : (IsOverId F).IsMultiplicative where + id_mem := sorry + comp_mem := sorry + +abbrev Section := WideSubcategory (IsOverId F) -abbrev Section := ObjectProperty.FullSubcategory (IsSection F) -instance Section.category : Category (Section F) := - ObjectProperty.FullSubcategory.category (IsSection F) abbrev Section.ι : Section F ⥤ (A ⥤ B) := - ObjectProperty.ι (IsSection F) + wideSubcategoryInclusion _ ⋙ ObjectProperty.ι (IsSection F) end +-- def WideSubcategory.groupoid {G : Type*} [Category G] [IsGroupoid G] (P : MorphismProperty G) +-- [P.IsMultiplicative] : Groupoid (WideSubcategory P) := +-- sorry + +-- instance {C : Type*} [Category C] [IsGroupoid C] (P : ObjectProperty C) : +-- IsGroupoid (P.FullSubcategory) := +-- InducedCategory.isGroupoid C (ObjectProperty.ι _).obj + +-- instance {A B : Type*} [Category A] [IsGroupoid A] [Category B] (F : B ⥤ A) : +-- IsGroupoid (A ⥤ B) := sorry + +-- instance {A B : Type*} [Category A] [Category B] [IsGroupoid B] (F : B ⥤ A) : +-- IsGroupoid (IsSection F).FullSubcategory := +-- sorry + -- InducedCategory.isGroupoid _ (ObjectProperty.ι _).obj + +instance {C : Type*} [Groupoid C] (P : ObjectProperty C) : + Groupoid (P.FullSubcategory) := + InducedCategory.groupoid C (ObjectProperty.ι _).obj + +instance {A B : Type*} [Category A] [Category B] [Groupoid B] (F : B ⥤ A) : + IsGroupoid (Section F) where + all_isIso {x y} f := { + out := ⟨⟨ + have : IsGroupoid (A ⥤ B) := sorry + have h := x.1 + have : IsIso f.1 := sorry + CategoryTheory.inv f.1, + sorry⟩, sorry⟩ + } + -- exact WideSubcategory.groupoid (G := (IsSection F).FullSubcategory) (IsOverId F) + namespace ObjectProperty lemma ι_mono {T C : Type u} [Category.{v} C] [Category.{v} T] @@ -77,10 +114,6 @@ lemma ι_mono {T C : Type u} [Category.{v} C] [Category.{v} T] end ObjectProperty -instance {C : Type*} [Groupoid C] (P : ObjectProperty C) : - Groupoid (P.FullSubcategory) := - InducedCategory.groupoid C (ObjectProperty.ι _).obj - instance Grpd.ι_mono (G : Grpd) (P : ObjectProperty G) : Mono (Grpd.homOf (ObjectProperty.ι P)) := ⟨ fun _ _ e => ObjectProperty.ι_mono _ _ e ⟩ @@ -707,12 +740,49 @@ def strongTrans : (A ⋙ Grpd.forgetToCat).toPseudoFunctor'.StrongTrans erw [Category.id_comp, Category.id_comp, Category.comp_id] simp only [Grpd.forgetToCat, id_eq, Cat.of_α, eqToHom_trans, eqToHom_refl, Category.comp_id] -@[simps!] def mapStrongTrans : ∫ A ⥤ ∫ sigma A B := Functor.Grothendieck.toPseudoFunctor'Iso.hom _ ⋙ Pseudofunctor.Grothendieck.map (strongTrans B s hs) ⋙ Functor.Grothendieck.toPseudoFunctor'Iso.inv _ +@[simp] +lemma mapStrongTrans_obj_base (x) : ((mapStrongTrans B s hs).obj x).base = x.base := + rfl + +@[simp] +lemma mapStrongTrans_obj_fiber (x) : ((mapStrongTrans B s hs).obj x).fiber = + (PGrpd.objFiber' hs x.base).obj.obj x.fiber := + rfl + +@[simp] +lemma mapStrongTrans_map_base {x y} (f : x ⟶ y) : ((mapStrongTrans B s hs).map f).base = + f.base := + rfl + +@[simp] +lemma mapStrongTrans_map_fiber {x y} (f : x ⟶ y) : ((mapStrongTrans B s hs).map f).fiber = + eqToHom (by + simp only [mapStrongTrans_obj_base, sigma_obj, mapStrongTrans_map_base, sigma_map, + mapStrongTrans_obj_fiber, pi_obj, pi_map, piMap, ObjectProperty.ι_obj, + ObjectProperty.lift_obj_obj, Functor.comp_obj, conjugating_obj, Functor.map_inv] + simp [← Functor.comp_obj, ← Grpd.comp_eq_comp]) ≫ + (PGrpd.mapFiber' hs f.base).app ((A.map f.base).obj x.fiber) ≫ + (PGrpd.objFiber' hs y.base).obj.map f.fiber := by + simp only [mapStrongTrans, Functor.Grothendieck.toPseudoFunctor'Iso.inv, Functor.comp_obj, + Pseudofunctor.Grothendieck.map_obj_base, Functor.Grothendieck.toPseudoFunctor'Iso.hom_obj_base, + Pseudofunctor.Grothendieck.map_obj_fiber, Functor.toPseudoFunctor'_obj, sigma_obj, + strongTrans_app, Functor.Grothendieck.toPseudoFunctor'Iso.hom_obj_fiber, Functor.comp_map, + Pseudofunctor.Grothendieck.map_map_base, Functor.Grothendieck.toPseudoFunctor'Iso.hom_map_base, + Pseudofunctor.Grothendieck.map_map_fiber, Functor.toPseudoFunctor'_map, Quiver.Hom.toLoc_as, + sigma_map, strongTrans_naturality, strongTrans.naturality, conjugatingObjNatTransEquiv₁, + Grpd.Functor.iso, Grpd.functorIsoOfIso_inv, Functor.mapIso_inv, asIso_inv, + Grpd.functorIsoOfIso_hom, Functor.mapIso_hom, asIso_hom, conjugatingObjNatTransEquiv', + Groupoid.isoEquivHom, Equiv.toFun_as_coe, Equiv.trans_apply, Equiv.coe_fn_mk, + Equiv.coe_fn_symm_mk, Iso.symm_mk, NatTrans.comp_app, Cat.comp_obj, Functor.whiskerLeft_app, + Functor.Grothendieck.toPseudoFunctor'Iso.hom_map_fiber, Hom.fiber, + Functor.Grothendieck.Hom.mk_fiber, eqToHom_app, Category.assoc] + rfl + /-- 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` @@ -722,6 +792,76 @@ there is a "term of `B`" `inversion : Γ ⥤ PGrpd` such that `inversion ⋙ for @[simps!] def inversion : ∫(A) ⥤ PGrpd := mapStrongTrans B s hs ⋙ (sigma.assoc B).inv ⋙ toPGrpd B +@[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 _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_obj_base_base' + {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) + (x : ∫ sigma A B) : + ((sigma.assoc B).inv.obj x).base.base = x.base := by + simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, + sigma.assocFib.eq_1] + rw! (castMode := .all) [pre_obj_base] + simp + rfl + +lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_obj_base_fiber' + {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) + (x : ∫ sigma A B) : + ((sigma.assoc B).inv.obj x).base.fiber = x.fiber.base := by + simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, + sigma.assocFib.eq_1] + rw! (castMode := .all) [pre_obj_base] + simp + rfl + +lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_map_base_base' + {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) + {X Y : ∫ sigma A B} (f : X ⟶ Y) : + ((sigma.assoc B).inv.map f).base.base = f.base := by + simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, + sigma.assocFib.eq_1, functorIsoFrom_hom_map, sigma_map, comp_base, pre_map_base, + assocHom_app_base_base, ι_map_base, ι_obj_base] + erw [Category.comp_id] + simp [Hom.base] + +-- TODO replace simps! with this +lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_map_base_fiber' + {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) + {X Y : ∫ sigma A B} (f : X ⟶ Y) : + ((sigma.assoc B).inv.map f).base.fiber = eqToHom (by + simp + rw! [sigma.assoc_inv_map_base_base', sigma.assoc_inv_obj_base_fiber']) ≫ + f.fiber.base := by + simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, + sigma.assocFib.eq_1, functorIsoFrom_hom_map, sigma_map, comp_base, comp_fiber, + sigmaMap_obj_base] + rw! [pre_map_base, ι_map_fiber] + simp only [ι_map_base, ι_obj_base, ι_obj_fiber] + erw [Grpd.map_id_map, assocHom_app_base_fiber] + simp only [sigma.assocFib.eq_1, Functor.comp_obj, eqToHom_refl, Category.id_comp, eqToHom_trans] + erw [Category.id_comp] + simp + rfl + 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, @@ -734,10 +874,27 @@ lemma mapStrongTrans_comp_fstAux' : mapStrongTrans B s hs ⋙ sigma.fstAux' B = · 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] + apply (sigma.assoc_inv_obj_base_fiber' B ((mapStrongTrans B s hs).obj x)).trans + simp only [mapStrongTrans_obj_fiber] exact Functor.congr_obj (PGrpd.objFiber' hs x.base).property x.fiber - · sorry + · intro x y f + simp [sigma.fstAux'] + rw [sigma.assoc_inv_map_base_fiber'] + have h := Functor.congr_hom (PGrpd.objFiber' hs y.base).property f.fiber + dsimp [IsSection, sigma.fstAuxObj] at h + simp [h] + simp [← Category.assoc] + -- rw! [PGrpd.mapFiber'_heq] + -- rw [← comp_base] + -- erw [mapStrongTrans_map_fiber_base] + -- apply heq_of_eq_of_heq (sigma.assoc_inv_map_base_fiber ..) + -- simp [Grpd.forgetToCat] + -- have h := pre_map_base B (ι A y.base) ((mapStrongTrans B s hs).map f).fiber + -- erw [h] + -- erw [sigma.assoc_inv_map_base_fiber] + -- #check pre_map_base + -- #check mapStrongTrans_map_fiber_base + sorry lemma inversion_comp_forgetToGrpd : inversion B s hs ⋙ PGrpd.forgetToGrpd = B := by simp only [inversion, Functor.assoc, toPGrpd_forgetToGrpd] From d5ce49a339b15cbe3583063eb1083f6d6b9087c0 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 30 Oct 2025 23:57:18 -0400 Subject: [PATCH 04/95] no errors --- .../Bicategory/Grothendieck.lean | 57 + .../MorphismProperty/WideSubcategory.lean | 152 +++ .../ForMathlib/CategoryTheory/NatTrans.lean | 2 +- HoTTLean/Grothendieck/Groupoidal/Basic.lean | 48 + HoTTLean/Groupoids/Pi.lean | 1058 +++++++++++------ HoTTLean/Groupoids/Sigma.lean | 52 +- 6 files changed, 993 insertions(+), 376 deletions(-) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/WideSubcategory.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean index fd2adab7..d4e58b42 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean @@ -851,6 +851,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 @@ -1390,6 +1398,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/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..aee6e9a4 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean @@ -31,7 +31,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 diff --git a/HoTTLean/Grothendieck/Groupoidal/Basic.lean b/HoTTLean/Grothendieck/Groupoidal/Basic.lean index b7a9e32d..5538f7ed 100644 --- a/HoTTLean/Grothendieck/Groupoidal/Basic.lean +++ b/HoTTLean/Grothendieck/Groupoidal/Basic.lean @@ -741,6 +741,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 diff --git a/HoTTLean/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index fca29ee5..d4507072 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -1,6 +1,7 @@ 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₃ @@ -14,8 +15,29 @@ lemma hcongr_fun {α α' : Type u} (hα : α ≍ α') (β : α → Type v) (β' 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 + namespace CategoryTheory +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 + +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 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 @@ -44,6 +66,39 @@ lemma Functor.associator_eq {C D E E' : Type*} [Category C] [Category D] [Catego (F : C ⥤ D) (G : D ⥤ E) (H : E ⥤ E') : associator F G H = CategoryTheory.Iso.refl _ := rfl +@[reassoc] +lemma _root_.CategoryTheory.Functor.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 + +theorem _root_.CategoryTheory.PGrpd.mapFiber'_comp' + {Γ : Type u₂} [Category.{v₂} Γ] + {A : Γ ⥤ Grpd.{v₁,u₁}} {α : Γ ⥤ PGrpd.{v₁,u₁}} (h : α ⋙ PGrpd.forgetToGrpd = A) + {x y z} (f : x ⟶ y) + (g : y ⟶ z) : PGrpd.mapFiber' h (f ≫ g) + = eqToHom (by simp) ≫ (A.map g).map (PGrpd.mapFiber' h f) ≫ PGrpd.mapFiber' h g := by + subst h + simp [PGrpd.mapFiber] + +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) @@ -53,49 +108,44 @@ def IsOverId : MorphismProperty ((IsSection F).FullSubcategory) := fun s t α => Functor.whiskerRight α F = eqToHom s.property ≫ 𝟙 (𝟭 A) ≫ eqToHom t.property.symm instance : (IsOverId F).IsMultiplicative where - id_mem := sorry - comp_mem := sorry - -abbrev Section := WideSubcategory (IsOverId F) - + 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) := - wideSubcategoryInclusion _ ⋙ ObjectProperty.ι (IsSection F) + MorphismProperty.wideSubcategoryInclusion _ ⋙ ObjectProperty.ι (IsSection F) end --- def WideSubcategory.groupoid {G : Type*} [Category G] [IsGroupoid G] (P : MorphismProperty G) --- [P.IsMultiplicative] : Groupoid (WideSubcategory P) := --- sorry - --- instance {C : Type*} [Category C] [IsGroupoid C] (P : ObjectProperty C) : --- IsGroupoid (P.FullSubcategory) := --- InducedCategory.isGroupoid C (ObjectProperty.ι _).obj - --- instance {A B : Type*} [Category A] [IsGroupoid A] [Category B] (F : B ⥤ A) : --- IsGroupoid (A ⥤ B) := sorry - --- instance {A B : Type*} [Category A] [Category B] [IsGroupoid B] (F : B ⥤ A) : --- IsGroupoid (IsSection F).FullSubcategory := --- sorry - -- InducedCategory.isGroupoid _ (ObjectProperty.ι _).obj +instance {A B : Type*} [Category A] [Groupoid B] (F : B ⥤ A) : + IsGroupoid ((IsSection F).FullSubcategory) := + InducedCategory.isGroupoid (A ⥤ B) (ObjectProperty.ι _).obj -instance {C : Type*} [Groupoid C] (P : ObjectProperty C) : - Groupoid (P.FullSubcategory) := - InducedCategory.groupoid C (ObjectProperty.ι _).obj - -instance {A B : Type*} [Category A] [Category B] [Groupoid B] (F : B ⥤ A) : +instance {A B : Type*} [Category A] [Groupoid B] (F : B ⥤ A) : IsGroupoid (Section F) where all_isIso {x y} f := { - out := ⟨⟨ - have : IsGroupoid (A ⥤ B) := sorry - have h := x.1 - have : IsIso f.1 := sorry - CategoryTheory.inv f.1, - sorry⟩, sorry⟩ + 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⟩ } - -- exact WideSubcategory.groupoid (G := (IsSection F).FullSubcategory) (IsOverId F) + +instance Section.groupoid {A B : Type*} [Category A] [Groupoid B] (F : B ⥤ A) : + Groupoid (Section F) := + Groupoid.ofIsGroupoid namespace ObjectProperty @@ -114,6 +164,10 @@ lemma ι_mono {T C : Type u} [Category.{v} C] [Category.{v} T] end ObjectProperty +local instance {G : Type*} [Groupoid G] (P : ObjectProperty G) : + Groupoid (P.FullSubcategory) := + InducedCategory.groupoid G (ObjectProperty.ι _).obj + instance Grpd.ι_mono (G : Grpd) (P : ObjectProperty G) : Mono (Grpd.homOf (ObjectProperty.ι P)) := ⟨ fun _ _ e => ObjectProperty.ι_mono _ _ e ⟩ @@ -132,6 +186,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 @@ -177,8 +240,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) : @@ -186,8 +249,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 @@ -286,19 +349,23 @@ lemma conjugatingObjNatTransEquiv'_comp' {x y z : Γ} (f1 : x ⟶ y) (f2 : y ⟶ (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 [conjugatingObjNatTransEquiv', Grpd.Functor.iso, Functor.associator_eq] at * + 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] - rw [whiskerLeft_map_comp] - simp [← Category.assoc] + 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] - rw [whiskerLeft_twice' (A.map f2)] + 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] - simp [← heq_eq_eq] + 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] @@ -363,104 +430,314 @@ lemma conjugatingObjNatTransEquiv₁_comp_inv {x y z : Γ} (f1 : x ⟶ y) (f2 : -- simp only [IsIso.inv_comp, inv_eqToHom, inv_whiskerLeft, Category.assoc] end -section - -variable {Γ : Type u₂} [Category.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} - (B : ∫(A) ⥤ Grpd.{v₁,u₁}) (x : Γ) - --- 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 - -open sigma +namespace Section -def piObj : Grpd := Grpd.of (Section (fstAuxObj B x)) +variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {A : Γ ⥤ Grpd.{u₁,u₁}} + {B : Γ ⥤ Grpd.{u₁,u₁}} (φ : B ⟶ A) -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] - -end +def functorObj (x : Γ) : Grpd.{u₁,u₁} := Grpd.of (Section (φ.app x)) section -variable {Γ : Type u₂} [Groupoid.{v₂} Γ] (A : Γ ⥤ Grpd.{u₁,u₁}) (B : ∫(A) ⥤ Grpd.{u₁,u₁}) -variable {x y : Γ} (f: x ⟶ y) - -open sigma -/-- -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 := - rfl +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])) -@[simp] lemma piMap_id (x : Γ) : piMap A B (𝟙 x) = 𝟭 (piObj B x) := by - simp only [piMap, conjugating_id] - rfl +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 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] - rfl +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 + +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 + -- fapply CategoryTheory.Functor.ext + -- · intro x + -- fapply Functor.Grothendieck.ext + -- · simp [mapStrongTrans, Functor.Grothendieck.toPseudoFunctor'Iso, + -- map, strongTrans] + -- · simpa [Grpd.forgetToCat, mapStrongTrans, map, strongTrans, + -- Functor.Grothendieck.toPseudoFunctor'Iso] using Functor.congr_obj (happ x.base) _ + -- · intro x y f + -- fapply Functor.Grothendieck.Hom.ext + -- · simp only [Grpd.forgetToCat, mapStrongTrans, Functor.Grothendieck.toPseudoFunctor'Iso, + -- strongTrans, map, Functor.comp_obj, Functor.Grothendieck.map_obj_base, + -- Functor.Grothendieck.toPseudoFunctor'Iso.inv_obj_base, + -- Pseudofunctor.Grothendieck.map_obj_base, + -- Functor.Grothendieck.toPseudoFunctor'Iso.hom_obj_base, Functor.comp_map, + -- Functor.Grothendieck.map_map_base, Functor.Grothendieck.toPseudoFunctor'Iso.inv_map_base, + -- Pseudofunctor.Grothendieck.map_map_base, + -- Functor.Grothendieck.toPseudoFunctor'Iso.hom_map_base, Functor.id_obj, Functor.id_map] + -- rw [Functor.Grothendieck.Hom.comp_base, Functor.Grothendieck.Hom.comp_base, + -- Functor.Grothendieck.base_eqToHom, Functor.Grothendieck.base_eqToHom] + -- simp + -- · simp [Grpd.forgetToCat, mapStrongTrans, map, strongTrans, + -- Functor.Grothendieck.toPseudoFunctor'Iso] + -- rw [Functor.Grothendieck.Hom.comp_fiber, Functor.Grothendieck.Hom.comp_fiber] + -- simp + -- rw [Functor.Grothendieck.fiber_eqToHom] + -- rw [Functor.Grothendieck.fiber_eqToHom] + -- slice_rhs 2 2 => rw [eqToHom_map] + -- simp [← heq_eq_eq] + -- conv => right; rw! (castMode := .all) [Functor.Grothendieck.base_eqToHom, + -- eqToHom_map A] + -- simp [← Functor.comp_map] + -- erw [Functor.congr_hom (happ y.base) f.fiber] + -- simp + -- sorry + +end + +end Section + +section +variable {Γ : Type u₂} [Groupoid.{v₂} Γ] (A : Γ ⥤ Grpd.{u₁,u₁}) (B : ∫(A) ⥤ Grpd.{u₁,u₁}) +-- variable {x y : Γ} (f : x ⟶ y) + +-- open sigma + +-- /-- +-- 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 (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.obj ⋙ fstAuxObj B x) ⋙ +-- (Grpd.Functor.iso A f).hom = _ +-- rw [s.obj.property] +-- simp + +-- theorem isOverId_conjugating {s t : piObj B x} (α : s ⟶ t) : +-- IsOverId (fstAuxObj B y) ((conjugating A (sigma A B) f).map (↑α : s.obj ⟶ t.obj)) := sorry + +-- /-- 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.ι +-- 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) +-- ``` +-- -/ +-- def piMap : piObj B x ⥤ piObj B y := +-- MorphismProperty.lift _ +-- (ObjectProperty.lift (IsSection (fstAuxObj B y)) +-- ((Section.ι (fstAuxObj B x) ⋙ conjugating A (sigma A B) f)) +-- (isSection_conjugating A B f)) +-- (by +-- intro s t α +-- simp [IsOverId, conjugating, Functor.associator_eq] +-- erw [Category.comp_id] +-- have h := α.2 +-- simp only [Set.mem_setOf_eq, IsOverId] at h +-- rw [Functor.comp_whiskerRight] +-- sorry) + +-- 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 + +-- lemma piMap_map (s1 s2: piObj B x) (η: s1 ⟶ s2) : +-- (piMap A B f).map η = (conjugating A (sigma A B) f).map η := +-- rfl + +-- /-- +-- The square commutes + +-- 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 := +-- rfl + +-- @[simp] lemma piMap_id (x : Γ) : piMap A B (𝟙 x) = 𝟭 (piObj B x) := by +-- simp only [piMap, conjugating_id] +-- 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] +-- 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 +@[simps!] def pi : Γ ⥤ Grpd.{u₁,u₁} := Section.functor (A := A) + (B := sigma A B) (sigma.fstNatTrans B) + +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 @@ -469,14 +746,14 @@ 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] +-- theorem IsSection_eq (x) : sigma.fstAuxObj B (σ.obj x) ≍ sigma.fstAuxObj (pre A σ ⋙ B) x := by +-- dsimp [sigma.fstAuxObj] +-- rw [sigma_naturality_aux] -lemma piObj_naturality (x): - piObj B (σ.obj x) = piObj (pre A σ ⋙ B) x := by - dsimp [pi, piObj, sigma.fstAuxObj] - rw [sigma_naturality_aux] +-- lemma piObj_naturality (x): +-- piObj B (σ.obj x) = piObj (pre A σ ⋙ B) x := by +-- dsimp [pi, piObj, sigma.fstAuxObj] +-- rw [sigma_naturality_aux] section @@ -487,36 +764,26 @@ lemma eqToHom_ι_aux : = 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_ι' - -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 +-- 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_ι' end @@ -526,11 +793,11 @@ lemma conjugating_naturality_sigma {x y} (f : x ⟶ y): 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 +-- 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 lemma comm_sq_of_comp_mono {C : Type*} [Category C] {X Y Z W X' Y' Z' W' : C} @@ -552,33 +819,41 @@ 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_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 ObjectProperty.lift_comp_inclusion_eq +-- · apply eqToHom_ι +-- · apply eqToHom_ι +-- · apply ObjectProperty.lift_comp_inclusion_eq + +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 @@ -590,43 +865,59 @@ 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.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 +def strongTrans.app (x) : A.obj x ⟶ (sigma A B).obj x := + (PGrpd.objFiber' hs x).obj.obj -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 +def strongTrans.conjugate {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 eqToHom_heq_id {C : Type*} [Category C] (x y z : C) (h : x = y) - (hz : z = x) : eqToHom h ≍ 𝟙 z := by cat_disch +@[simp] +lemma strongTrans.conjugate_id (x) : + conjugate B s hs (𝟙 x) = eqToHom (by simp) := by + simp [conjugate] + rfl -@[reassoc] -lemma _root_.CategoryTheory.Functor.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 +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 (conjugate 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) -theorem _root_.CategoryTheory.PGrpd.mapFiber'_comp' - {A : Γ ⥤ Grpd.{v₁,u₁}} {α : Γ ⥤ PGrpd.{v₁,u₁}} (h : α ⋙ PGrpd.forgetToGrpd = A) - {x y z} (f : x ⟶ y) - (g : y ⟶ z) : PGrpd.mapFiber' h (f ≫ g) - = eqToHom (by simp) ≫ (A.map g).map (PGrpd.mapFiber' h f) ≫ PGrpd.mapFiber' h g := by - subst h - simp [PGrpd.mapFiber] +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.conjugate_comp {x y z} (f : x ⟶ y) (g : y ⟶ z) : + conjugate B s hs (f ≫ g) = eqToHom (by simp [← Grpd.comp_eq_comp, sigmaMap_comp]) ≫ + Functor.whiskerLeft (A.map (CategoryTheory.inv g)) + (Functor.whiskerRight (conjugate B s hs f) (sigmaMap B g)) ≫ + conjugate B s hs g := by + conv => left; simp only [conjugate, sigma_obj, pi_obj_α, Set.mem_setOf_eq, + PGrpd.mapFiber'_comp' hs f g, MorphismProperty.WideSubcategory.comp_def, + MorphismProperty.coe_eqToHom, pi_map_map] + rfl + +def strongTrans.naturality {x y : Γ} (g : x ⟶ y) : + A.map g ⋙ strongTrans.app B s hs y ≅ strongTrans.app B s hs x ⋙ sigmaMap B g := + ((conjugatingObjNatTransEquiv₁ _ _ _ _ _).toFun (conjugate B s hs g)).symm @[simp] -lemma strongTrans.naturality_id_hom {x : Γ} : +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 only [sigma_obj, sigma_map, PGrpd.mapFiber'_id, pi_obj, pi_map, eqToHom_comp_iff, - eqToHom_trans, IsIso.inv_comp_eq] - simp only [← heq_eq_eq, heq_comp_eqToHom_iff] - apply eqToHom_heq_eqToHom - · simp - · simp + simp [sigma_obj, sigma_map, eqToHom_trans, conjugate_id] -- 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') [IsIso f] : @@ -642,11 +933,12 @@ lemma inv_heq_inv {C : Type*} [Category C] {X Y : C} {X' Y' : C} subst hX hY hf rfl -@[reassoc] -lemma strongTrans.naturality_comp_hom_aux {x y} (g : x ⟶ y) : - A.map g ≫ ((piMap A B g).obj (PGrpd.objFiber' hs x)).obj = - (PGrpd.objFiber' hs x).obj ⋙ sigmaMap B g := by - simp [piMap, conjugating, ← Grpd.comp_eq_comp] +-- @[reassoc] +-- lemma strongTrans.naturality_comp_hom_aux {x y} (g : x ⟶ y) : +-- A.map g ≫ (((pi A B).map g).obj (PGrpd.objFiber' hs x)).obj.obj = +-- (PGrpd.objFiber' hs x).obj.obj ⋙ sigmaMap B g := by +-- simp [pi, conjugating, ← Grpd.comp_eq_comp] +-- sorry -- lemma strongTrans.naturality_comp_hom' {x y z : Γ} (g1 : x ⟶ y) (g2 : y ⟶ z) : -- (strongTrans.naturality B s hs (g1 ≫ g2)).hom = @@ -676,20 +968,45 @@ lemma strongTrans.naturality_comp_hom_aux {x y} (g : x ⟶ y) : -- apply HEq.trans (eqToHom_comp_heq ..) -- rfl -set_option maxHeartbeats 400000 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 ≫ - Functor.whiskerRight (strongTrans.naturality B s hs g1).hom (sigmaMap B g2) - ≫ eqToHom (by simp [Functor.assoc, sigmaMap_comp]) := by - simp only [naturality, sigma_obj, sigma_map, Equiv.toFun_as_coe, Iso.symm_hom] - refine conjugatingObjNatTransEquiv₁_comp_inv A (sigma A B) g1 g2 - (PGrpd.objFiber' hs x).obj (PGrpd.objFiber' hs y).obj (PGrpd.objFiber' hs z).obj - (PGrpd.mapFiber' hs g1) (PGrpd.mapFiber' hs g2) - (PGrpd.mapFiber' hs (g1 ≫ g2)) ?_ - simp [PGrpd.mapFiber'_comp', piMap, conjugating] - rfl + 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) + (conjugate B s hs g1) (conjugate B s hs g2) + (conjugate B s hs (g1 ≫ g2)) ?_).trans + · simp [naturality] + · apply (strongTrans.conjugate_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 [conjugate, h] -- rw [strongTrans.naturality_comp_hom'] -- simp only [sigma_obj, sigma_map, conjugatingObjNatTransEquiv₁, Groupoid.isoEquivHom, @@ -705,45 +1022,45 @@ lemma strongTrans.naturality_comp_hom {x y z : Γ} (g1 : x ⟶ y) (g2 : y ⟶ z) -- (PGrpd.objFiber' hs x).obj (PGrpd.objFiber' hs z).obj (PGrpd.mapFiber' hs (g1 ≫ g2)) -- simp [conjugatingObjNatTransEquiv', Grpd.Functor.iso, ← heq_eq_eq] at h -set_option maxHeartbeats 400000 -@[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 := by - intro x y f g η - have : f = g := LocallyDiscrete.eq_of_hom η - subst this - simp [Functor.toPseudoFunctor', pseudofunctorOfIsLocallyDiscrete] - naturality_id := by - intro x - simp only [Functor.toPseudoFunctor'_obj, Functor.comp_obj, sigma_obj, - Functor.toPseudoFunctor'_map, LocallyDiscrete.id_as, Functor.comp_map, sigma_map, - strongTrans.naturality_id_hom, Functor.toPseudoFunctor'_mapId, eqToIso.hom, - Bicategory.whiskerLeft_eqToHom, eqToHom_trans, Bicategory.eqToHom_whiskerRight, - Bicategory.leftUnitor, Bicategory.rightUnitor, - Functor.leftUnitor_hom_comp_rightUnitor_inv (PGrpd.objFiber' hs x.as).obj, - Functor.simpIdComp, ← heq_eq_eq, heq_eqToHom_comp_iff] - apply eqToHom_heq_id - simp [Grpd.forgetToCat, Cat.comp_eq_comp] - naturality_comp := by - intro x y z g1 g2 - simp only [Functor.toPseudoFunctor'_obj, Functor.comp_obj, sigma_obj, - Functor.toPseudoFunctor'_map, LocallyDiscrete.comp_as, Functor.comp_map, sigma_map, - Bicategory.whiskerLeft, Functor.toPseudoFunctor'_mapComp, eqToIso.hom, - Bicategory.whiskerRight, Bicategory.associator, Functor.associator_eq, Iso.refl_hom, - Iso.refl_inv] - rw [Functor.whiskerLeft_eqToHom, Functor.eqToHom_whiskerRight, - strongTrans.naturality_comp_hom] - simp only [← Grpd.comp_eq_comp, Category.assoc] - erw [Category.id_comp, Category.id_comp, Category.comp_id] - simp only [Grpd.forgetToCat, id_eq, Cat.of_α, eqToHom_trans, eqToHom_refl, Category.comp_id] +-- set_option maxHeartbeats 500000 +-- @[simps] +-- def strongTrans : (A ⋙ Grpd.forgetToCat).toPseudoFunctor'.StrongTrans +-- (sigma A B ⋙ Grpd.forgetToCat).toPseudoFunctor' := where + -- app x := strongTrans.app B s hs x.as + -- naturality {x y} g := strongTrans.naturality B s hs g.as + -- naturality_naturality := by sorry + -- -- intro x y f g η + -- -- have : f = g := LocallyDiscrete.eq_of_hom η + -- -- subst this + -- -- simp [Functor.toPseudoFunctor', pseudofunctorOfIsLocallyDiscrete] + -- naturality_id := by sorry + -- -- intro x + -- -- simp only [Functor.toPseudoFunctor'_obj, Functor.comp_obj, sigma_obj, + -- -- Functor.toPseudoFunctor'_map, LocallyDiscrete.id_as, Functor.comp_map, sigma_map, + -- -- strongTrans.naturality_id_hom, Functor.toPseudoFunctor'_mapId, eqToIso.hom, + -- -- Bicategory.whiskerLeft_eqToHom, eqToHom_trans, Bicategory.eqToHom_whiskerRight, + -- -- Bicategory.leftUnitor, Bicategory.rightUnitor, + -- -- Functor.leftUnitor_hom_comp_rightUnitor_inv (PGrpd.objFiber' hs x.as).obj.obj, + -- -- Functor.simpIdComp, ← heq_eq_eq, heq_eqToHom_comp_iff] + -- -- apply eqToHom_heq_id + -- -- simp [Grpd.forgetToCat, Cat.comp_eq_comp] + -- naturality_comp := by sorry + -- -- intro x y z g1 g2 + -- -- simp only [Functor.toPseudoFunctor'_obj, Functor.comp_obj, sigma_obj, + -- -- Functor.toPseudoFunctor'_map, LocallyDiscrete.comp_as, Functor.comp_map, sigma_map, + -- -- Bicategory.whiskerLeft, Functor.toPseudoFunctor'_mapComp, eqToIso.hom, + -- -- Bicategory.whiskerRight, Bicategory.associator, Functor.associator_eq, Iso.refl_hom, + -- -- Iso.refl_inv] + -- -- rw [Functor.whiskerLeft_eqToHom, Functor.eqToHom_whiskerRight, + -- -- strongTrans.naturality_comp_hom] + -- -- simp only [← Grpd.comp_eq_comp, Category.assoc] + -- -- erw [Category.id_comp, Category.id_comp, Category.comp_id] + -- -- simp only [Grpd.forgetToCat, id_eq, sigma_obj, Grpd.comp_eq_comp, Cat.of_α, eqToHom_trans, + -- -- eqToHom_refl, Category.comp_id] 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 := @@ -751,7 +1068,7 @@ lemma mapStrongTrans_obj_base (x) : ((mapStrongTrans B s hs).obj x).base = x.bas @[simp] lemma mapStrongTrans_obj_fiber (x) : ((mapStrongTrans B s hs).obj x).fiber = - (PGrpd.objFiber' hs x.base).obj.obj x.fiber := + (PGrpd.objFiber' hs x.base).obj.obj.obj x.fiber := rfl @[simp] @@ -761,27 +1078,24 @@ lemma mapStrongTrans_map_base {x y} (f : x ⟶ y) : ((mapStrongTrans B s hs).map @[simp] lemma mapStrongTrans_map_fiber {x y} (f : x ⟶ y) : ((mapStrongTrans B s hs).map f).fiber = - eqToHom (by - simp only [mapStrongTrans_obj_base, sigma_obj, mapStrongTrans_map_base, sigma_map, - mapStrongTrans_obj_fiber, pi_obj, pi_map, piMap, ObjectProperty.ι_obj, - ObjectProperty.lift_obj_obj, Functor.comp_obj, conjugating_obj, Functor.map_inv] - simp [← Functor.comp_obj, ← Grpd.comp_eq_comp]) ≫ - (PGrpd.mapFiber' hs f.base).app ((A.map f.base).obj x.fiber) ≫ - (PGrpd.objFiber' hs y.base).obj.map f.fiber := by - simp only [mapStrongTrans, Functor.Grothendieck.toPseudoFunctor'Iso.inv, Functor.comp_obj, - Pseudofunctor.Grothendieck.map_obj_base, Functor.Grothendieck.toPseudoFunctor'Iso.hom_obj_base, - Pseudofunctor.Grothendieck.map_obj_fiber, Functor.toPseudoFunctor'_obj, sigma_obj, - strongTrans_app, Functor.Grothendieck.toPseudoFunctor'Iso.hom_obj_fiber, Functor.comp_map, - Pseudofunctor.Grothendieck.map_map_base, Functor.Grothendieck.toPseudoFunctor'Iso.hom_map_base, - Pseudofunctor.Grothendieck.map_map_fiber, Functor.toPseudoFunctor'_map, Quiver.Hom.toLoc_as, - sigma_map, strongTrans_naturality, strongTrans.naturality, conjugatingObjNatTransEquiv₁, - Grpd.Functor.iso, Grpd.functorIsoOfIso_inv, Functor.mapIso_inv, asIso_inv, - Grpd.functorIsoOfIso_hom, Functor.mapIso_hom, asIso_hom, conjugatingObjNatTransEquiv', - Groupoid.isoEquivHom, Equiv.toFun_as_coe, Equiv.trans_apply, Equiv.coe_fn_mk, - Equiv.coe_fn_symm_mk, Iso.symm_mk, NatTrans.comp_app, Cat.comp_obj, Functor.whiskerLeft_app, - Functor.Grothendieck.toPseudoFunctor'Iso.hom_map_fiber, Hom.fiber, - Functor.Grothendieck.Hom.mk_fiber, eqToHom_app, Category.assoc] - rfl + eqToHom (sorry) ≫ + (PGrpd.mapFiber' hs f.base).1.app ((A.map f.base).obj x.fiber) ≫ + (PGrpd.objFiber' hs y.base).obj.obj.map f.fiber := by + -- simp only [mapStrongTrans, Functor.Grothendieck.toPseudoFunctor'Iso.inv, Functor.comp_obj, + -- Pseudofunctor.Grothendieck.map_obj_base, Functor.Grothendieck.toPseudoFunctor'Iso.hom_obj_base, + -- Pseudofunctor.Grothendieck.map_obj_fiber, Functor.toPseudoFunctor'_obj, sigma_obj, + -- strongTrans_app, Functor.Grothendieck.toPseudoFunctor'Iso.hom_obj_fiber, Functor.comp_map, + -- Pseudofunctor.Grothendieck.map_map_base, Functor.Grothendieck.toPseudoFunctor'Iso.hom_map_base, + -- Pseudofunctor.Grothendieck.map_map_fiber, Functor.toPseudoFunctor'_map, Quiver.Hom.toLoc_as, + -- sigma_map, strongTrans_naturality, strongTrans.naturality, conjugatingObjNatTransEquiv₁, + -- Grpd.Functor.iso, Grpd.functorIsoOfIso_inv, Functor.mapIso_inv, asIso_inv, + -- Grpd.functorIsoOfIso_hom, Functor.mapIso_hom, asIso_hom, conjugatingObjNatTransEquiv', + -- Groupoid.isoEquivHom, Equiv.toFun_as_coe, Equiv.trans_apply, Equiv.coe_fn_mk, + -- Equiv.coe_fn_symm_mk, Iso.symm_mk, NatTrans.comp_app, Cat.comp_obj, Functor.whiskerLeft_app, + -- Functor.Grothendieck.toPseudoFunctor'Iso.hom_map_fiber, Hom.fiber, + -- Functor.Grothendieck.Hom.mk_fiber, eqToHom_app, Category.assoc] + sorry + -- rfl /-- Let `Γ` be a category. For any pair of functors `A : Γ ⥤ Grpd` and `B : ∫(A) ⥤ Grpd`, @@ -862,52 +1176,61 @@ lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_map_base_fiber' simp rfl -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_fiber] - exact Functor.congr_obj (PGrpd.objFiber' hs x.base).property x.fiber - · intro x y f - simp [sigma.fstAux'] - rw [sigma.assoc_inv_map_base_fiber'] - have h := Functor.congr_hom (PGrpd.objFiber' hs y.base).property f.fiber - dsimp [IsSection, sigma.fstAuxObj] at h - simp [h] - simp [← Category.assoc] - -- rw! [PGrpd.mapFiber'_heq] - -- rw [← comp_base] - -- erw [mapStrongTrans_map_fiber_base] - -- apply heq_of_eq_of_heq (sigma.assoc_inv_map_base_fiber ..) - -- simp [Grpd.forgetToCat] - -- have h := pre_map_base B (ι A y.base) ((mapStrongTrans B s hs).map f).fiber - -- erw [h] - -- erw [sigma.assoc_inv_map_base_fiber] - -- #check pre_map_base - -- #check mapStrongTrans_map_fiber_base - sorry +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 + + -- 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_fiber] + -- exact Functor.congr_obj (PGrpd.objFiber' hs x.base).property x.fiber + -- · intro x y f + -- simp [sigma.fstAux'] + -- rw [sigma.assoc_inv_map_base_fiber'] + -- have h := Functor.congr_hom (PGrpd.objFiber' hs y.base).property f.fiber + -- dsimp [IsSection, sigma.fstAuxObj] at h + -- simp [h] + -- simp [← Category.assoc] + -- -- rw! [PGrpd.mapFiber'_heq] + -- -- rw [← comp_base] + -- -- erw [mapStrongTrans_map_fiber_base] + -- -- apply heq_of_eq_of_heq (sigma.assoc_inv_map_base_fiber ..) + -- -- simp [Grpd.forgetToCat] + -- -- have h := pre_map_base B (ι A y.base) ((mapStrongTrans B s hs).map f).fiber + -- -- erw [h] + -- -- erw [sigma.assoc_inv_map_base_fiber] + -- -- #check pre_map_base + -- -- #check mapStrongTrans_map_fiber_base + -- sorry 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] --- JH: make some API for this? Mixture of Pseudofunctor.Grothendieck --- and Functor.Grothendieck and Functor.Groupoidal is messy. +-- -- 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 + (PGrpd.objFiber' hs x).obj.obj ⋙ 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] + -- rw [← Functor.assoc, (PGrpd.objFiber' hs x).property, Functor.id_comp] + sorry · intro a rfl -- This is probably bad practice · intro a b h @@ -945,13 +1268,10 @@ 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 := +def lamObjFiber : Grpd.of ((pi _ (β ⋙ PGrpd.forgetToGrpd)).obj x) := ⟨lamObjFiberObj A β x , rfl⟩ -@[simp] lemma lamObjFiber_obj : (lamObjFiber A β x).obj = lamObjFiberObj A β x := - rfl - -@[simp] lemma lamObjFiber_obj_obj : (lamObjFiber A β x).obj = lamObjFiberObj A β x := +@[simp] lemma lamObjFiber_obj_obj : (lamObjFiber A β x).obj.obj = lamObjFiberObj A β x := rfl end @@ -1136,18 +1456,25 @@ 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, sorry⟩ @[simp] lemma lamMapFiber_id (x : Γ) : lamMapFiber A β (𝟙 x) = eqToHom (by simp) := by simp [lamMapFiber] + apply MorphismProperty.WideSubcategory.hom_ext + simp 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; sorry) + ≫ (((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₁} := @@ -1159,7 +1486,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 := @@ -1167,7 +1494,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] @@ -1193,14 +1520,18 @@ lemma lam_naturality_obj_aux (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 +theorem lam_naturality_obj (x : Δ) : lamObjFiber A β (σ.obj x) ≍ + lamObjFiber (σ ⋙ A) (pre A σ ⋙ β) x := by + + -- apply Grpd.MorphismProperty.WideSubcategory.hext + -- simp only [lamObjFiber] + sorry + -- apply Grpd.MorphismProperty.WideSubcategory.hext + -- 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 lamObjFiberObjCompSigMap.app_naturality {x y} (f : x ⟶ y) (a) : lamObjFiberObjCompSigMap.app A β (σ.map f) a ≍ @@ -1243,11 +1574,12 @@ lemma whiskerLeftInvLamObjObjSigMap_naturality_heq {x y} (f : x ⟶ y) : lemma lam_naturality_map {x y} (f : x ⟶ y) : lamMapFiber A β (σ.map f) ≍ lamMapFiber (σ ⋙ A) (pre A σ ⋙ β) f := by - apply whiskerLeftInvLamObjObjSigMap_naturality_heq + -- apply whiskerLeftInvLamObjObjSigMap_naturality_heq + sorry theorem lam_naturality : σ ⋙ lam A β = lam (σ ⋙ A) (pre A σ ⋙ β) := by apply PGrpd.Functor.hext - · apply pi_naturality + · simp [Functor.assoc, lam_comp_forgetToGrpd, pi_comp] · apply lam_naturality_obj · apply lam_naturality_map @@ -1268,24 +1600,24 @@ 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 ≍ (PGrpd.objFiber' hs x).obj.obj := 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 + -- dsimp [pi_obj] + 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 := @@ -1324,7 +1656,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 diff --git a/HoTTLean/Groupoids/Sigma.lean b/HoTTLean/Groupoids/Sigma.lean index 390506b7..148466f4 100644 --- a/HoTTLean/Groupoids/Sigma.lean +++ b/HoTTLean/Groupoids/Sigma.lean @@ -506,18 +506,46 @@ lemma assoc_comp' {Δ : Type u₃} [Groupoid.{v₃} Δ] {σ : Δ ⥤ Γ} (Aσ) ( section -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 - -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 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 + +-- 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] + +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 From 32dd5c63b1fda5f44702e8954d4168babe0286b6 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 31 Oct 2025 10:59:08 -0400 Subject: [PATCH 05/95] . --- HoTTLean/Groupoids/Pi.lean | 255 ++++++++++++++++++++++++---------- HoTTLean/Groupoids/Sigma.lean | 140 +++++++++++++++---- 2 files changed, 296 insertions(+), 99 deletions(-) diff --git a/HoTTLean/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index d4507072..4cdf2ad6 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -595,6 +595,28 @@ def mapStrongTrans : ∫ A ⥤ ∫ B := 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 mapStrongTrans_obj_fiber (x) : + ((mapStrongTrans app naturality naturality_id naturality_comp).obj x).fiber = + (app x.base).obj x.fiber := + rfl + +@[simp] +lemma mapStrongTrans_map_base {x y} (f : x ⟶ y) : + ((mapStrongTrans app naturality naturality_id naturality_comp).map f).base = f.base := + rfl + +@[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) = @@ -868,21 +890,53 @@ variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {A : Γ ⥤ Grpd.{u₁,u₁}} (B def strongTrans.app (x) : A.obj x ⟶ (sigma A B).obj x := (PGrpd.objFiber' hs x).obj.obj -def strongTrans.conjugate {x y : Γ} (g : x ⟶ y) : +@[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: simp should just end at ((strongTrans.app B s hs y).obj a).fiber +-- @[simp] +-- lemma strongTrans.app_obj_fiber (y) (a) : +-- ((strongTrans.app B s hs y).obj a).fiber = sorry := by +-- simp [app] +-- sorry + -- Functor.congr_obj (PGrpd.objFiber' hs y).obj.property a + +@[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 @[simp] -lemma strongTrans.conjugate_id (x) : - conjugate B s hs (𝟙 x) = eqToHom (by simp) := by - simp [conjugate] +lemma strongTrans.twoCell_app_base {x y : Γ} (g : x ⟶ y) (a) : + ((strongTrans.twoCell B s hs g).app a).base = eqToHom (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]) := 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 (conjugate B s hs f) (sigmaMap B 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) @@ -898,26 +952,39 @@ sigma x -> sigma x -> sigma z ``` -/ @[simp] -lemma strongTrans.conjugate_comp {x y z} (f : x ⟶ y) (g : y ⟶ z) : - conjugate B s hs (f ≫ g) = eqToHom (by simp [← Grpd.comp_eq_comp, sigmaMap_comp]) ≫ +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 (conjugate B s hs f) (sigmaMap B g)) ≫ - conjugate B s hs g := by - conv => left; simp only [conjugate, sigma_obj, pi_obj_α, Set.mem_setOf_eq, + (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.coe_eqToHom, pi_map_map] + MorphismProperty.WideSubcategory.coe_eqToHom, pi_map_map] rfl def strongTrans.naturality {x y : Γ} (g : x ⟶ y) : A.map g ⋙ strongTrans.app B s hs y ≅ strongTrans.app B s hs x ⋙ sigmaMap B g := - ((conjugatingObjNatTransEquiv₁ _ _ _ _ _).toFun (conjugate B s hs g)).symm + ((conjugatingObjNatTransEquiv₁ _ _ _ _ _).toFun (twoCell B s hs g)).symm + +@[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 + simp only [sigma_obj, Functor.comp_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, eqToHom_app, + Functor.whiskerLeft_app] + rw [comp_base, base_eqToHom] + 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, conjugate_id] + simp [sigma_obj, sigma_map, eqToHom_trans, twoCell_id] -- 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') [IsIso f] : @@ -977,10 +1044,10 @@ lemma strongTrans.naturality_comp_hom {x y z : Γ} (g1 : x ⟶ y) (g2 : y ⟶ z) 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) - (conjugate B s hs g1) (conjugate B s hs g2) - (conjugate B s hs (g1 ≫ g2)) ?_).trans + (twoCell B s hs g1) (twoCell B s hs g2) + (twoCell B s hs (g1 ≫ g2)) ?_).trans · simp [naturality] - · apply (strongTrans.conjugate_comp ..).trans + · apply (strongTrans.twoCell_comp ..).trans rw [Functor.whiskerRight_whiskerLeft] simp only [sigma, eqToHom_refl] erw [Category.id_comp] @@ -1006,7 +1073,7 @@ lemma strongTrans.app_map_naturality_hom_app {x y : Γ} (f : x ⟶ y) (a : (A.ob 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 [conjugate, h] + simp [twoCell, h] -- rw [strongTrans.naturality_comp_hom'] -- simp only [sigma_obj, sigma_map, conjugatingObjNatTransEquiv₁, Groupoid.isoEquivHom, @@ -1066,17 +1133,46 @@ def mapStrongTrans : ∫ A ⥤ ∫ sigma A B := lemma mapStrongTrans_obj_base (x) : ((mapStrongTrans B s hs).obj x).base = x.base := rfl -@[simp] +-- 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 = - (PGrpd.objFiber' hs x.base).obj.obj.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 @[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 + simp only [mapStrongTrans, Section.mapStrongTrans_obj_base, sigma_obj, + Section.mapStrongTrans_map_base, sigma_map, Section.mapStrongTrans_obj_fiber, sigmaMap_obj_base, + Section.mapStrongTrans_map_fiber, Functor.comp_obj] + rw [comp_base] + simp + +lemma mapStrongTrans_map_fiber_fiber {x y} (f : x ⟶ y) : + ((mapStrongTrans B s hs).map f).fiber.fiber = + sorry := by + simp [mapStrongTrans] + rw [comp_fiber] + simp + sorry + +-- @[simp] -- TODO remove in favour of fiber_fiber lemma mapStrongTrans_map_fiber {x y} (f : x ⟶ y) : ((mapStrongTrans B s hs).map f).fiber = eqToHom (sorry) ≫ (PGrpd.mapFiber' hs f.base).1.app ((A.map f.base).obj x.fiber) ≫ @@ -1127,54 +1223,54 @@ lemma assocHom_app_base_fiber simp rfl -lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_obj_base_base' - {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) - (x : ∫ sigma A B) : - ((sigma.assoc B).inv.obj x).base.base = x.base := by - simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, - sigma.assocFib.eq_1] - rw! (castMode := .all) [pre_obj_base] - simp - rfl +-- lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_obj_base_base' +-- {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) +-- (x : ∫ sigma A B) : +-- ((sigma.assoc B).inv.obj x).base.base = x.base := by +-- simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, +-- sigma.assocFib.eq_1] +-- rw! (castMode := .all) [pre_obj_base] +-- simp +-- rfl -lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_obj_base_fiber' - {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) - (x : ∫ sigma A B) : - ((sigma.assoc B).inv.obj x).base.fiber = x.fiber.base := by - simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, - sigma.assocFib.eq_1] - rw! (castMode := .all) [pre_obj_base] - simp - rfl +-- lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_obj_base_fiber' +-- {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) +-- (x : ∫ sigma A B) : +-- ((sigma.assoc B).inv.obj x).base.fiber = x.fiber.base := by +-- simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, +-- sigma.assocFib.eq_1] +-- rw! (castMode := .all) [pre_obj_base] +-- simp +-- rfl -lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_map_base_base' - {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) - {X Y : ∫ sigma A B} (f : X ⟶ Y) : - ((sigma.assoc B).inv.map f).base.base = f.base := by - simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, - sigma.assocFib.eq_1, functorIsoFrom_hom_map, sigma_map, comp_base, pre_map_base, - assocHom_app_base_base, ι_map_base, ι_obj_base] - erw [Category.comp_id] - simp [Hom.base] - --- TODO replace simps! with this -lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_map_base_fiber' - {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) - {X Y : ∫ sigma A B} (f : X ⟶ Y) : - ((sigma.assoc B).inv.map f).base.fiber = eqToHom (by - simp - rw! [sigma.assoc_inv_map_base_base', sigma.assoc_inv_obj_base_fiber']) ≫ - f.fiber.base := by - simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, - sigma.assocFib.eq_1, functorIsoFrom_hom_map, sigma_map, comp_base, comp_fiber, - sigmaMap_obj_base] - rw! [pre_map_base, ι_map_fiber] - simp only [ι_map_base, ι_obj_base, ι_obj_fiber] - erw [Grpd.map_id_map, assocHom_app_base_fiber] - simp only [sigma.assocFib.eq_1, Functor.comp_obj, eqToHom_refl, Category.id_comp, eqToHom_trans] - erw [Category.id_comp] - simp - rfl +-- lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_map_base_base' +-- {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) +-- {X Y : ∫ sigma A B} (f : X ⟶ Y) : +-- ((sigma.assoc B).inv.map f).base.base = f.base := by +-- simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, +-- sigma.assocFib.eq_1, functorIsoFrom_hom_map, sigma_map, comp_base, pre_map_base, +-- assocHom_app_base_base, ι_map_base, ι_obj_base] +-- erw [Category.comp_id] +-- simp [Hom.base] + +-- -- TODO replace simps! with this +-- lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_map_base_fiber' +-- {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) +-- {X Y : ∫ sigma A B} (f : X ⟶ Y) : +-- ((sigma.assoc B).inv.map f).base.fiber = eqToHom (by +-- simp +-- rw! [sigma.assoc_inv_map_base_base, sigma.assoc_inv_obj_base_fiber']) ≫ +-- f.fiber.base := by +-- simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, +-- sigma.assocFib.eq_1, functorIsoFrom_hom_map, sigma_map, comp_base, comp_fiber, +-- sigmaMap_obj_base] +-- rw! [pre_map_base, ι_map_fiber] +-- simp only [ι_map_base, ι_obj_base, ι_obj_fiber] +-- erw [Grpd.map_id_map, assocHom_app_base_fiber] +-- simp only [sigma.assocFib.eq_1, Functor.comp_obj, eqToHom_refl, Category.id_comp, eqToHom_trans] +-- erw [Category.id_comp] +-- simp +-- rfl lemma mapStrongTrans_comp_map_fstNatTrans : mapStrongTrans B s hs ⋙ map (sigma.fstNatTrans B) = 𝟭 _ := by @@ -1228,16 +1324,18 @@ lemma inversion_comp_forgetToGrpd : inversion B s hs ⋙ PGrpd.forgetToGrpd = B lemma ι_comp_inversion {x} : ι A x ⋙ inversion B s hs = (PGrpd.objFiber' hs x).obj.obj ⋙ toPGrpd (ι A x ⋙ B) := by apply PGrpd.Functor.hext - · simp only [Functor.assoc, inversion_comp_forgetToGrpd, toPGrpd_forgetToGrpd] + · simp only [Functor.assoc, inversion_comp_forgetToGrpd] -- rw [← Functor.assoc, (PGrpd.objFiber' hs x).property, Functor.id_comp] sorry · 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 + -- 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 + rw [mapStrongTrans_map_fiber] simp sorry @@ -1583,15 +1681,32 @@ theorem lam_naturality : σ ⋙ lam A β = lam (σ ⋙ A) (pre A σ ⋙ β) := b · apply lam_naturality_obj · apply lam_naturality_map +lemma objFiber_lam_obj_obj_obj {x y : ∫ A} (f : x ⟶ y) : + ((PGrpd.objFiber (lam A β) y.base).obj.obj.map (Hom.fiber f)).fiber = sorry := + sorry + lemma inversion_lam : inversion (β ⋙ PGrpd.forgetToGrpd) (lam A β) (lam_comp_forgetToGrpd ..) = β := by apply PGrpd.Functor.hext · simp [inversion_comp_forgetToGrpd] · intro x - simp [inversion] + simp only [inversion, comp_obj, toPGrpd_obj_base, Functor.Grothendieck.forget_obj, + toPGrpd_obj_fiber, sigma.assoc_inv_obj_fiber, mapStrongTrans_obj_base, + mapStrongTrans_obj_fiber, sigma_obj, sigma.fstNatTrans_app, PGrpd.objFiber'_rfl, heq_eq_eq] sorry + -- simp only [inversion, comp_obj, toPGrpd_obj_base, Functor.Grothendieck.forget_obj, + -- toPGrpd_obj_fiber, sigma.assoc_inv_obj_fiber, mapStrongTrans_obj_base, + -- mapStrongTrans_obj_fiber, sigma_obj, sigma.fstNatTrans_app, PGrpd.objFiber'_rfl, heq_eq_eq] + -- rfl · intro x y f simp [inversion] + rw [mapStrongTrans_map_fiber] + simp + rw [comp_fiber] + rw [fiber_eqToHom] + simp + rw [comp_fiber] + simp sorry end diff --git a/HoTTLean/Groupoids/Sigma.lean b/HoTTLean/Groupoids/Sigma.lean index 148466f4..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 ⋙ @@ -523,6 +601,10 @@ 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 + 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] From 58b148f7a2760054e273108b2b7d4fe165e76e02 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 31 Oct 2025 22:45:18 -0400 Subject: [PATCH 06/95] two sorrys left --- HoTTLean/Groupoids/Pi.lean | 515 +++++++++++++++++++++++++++++-------- 1 file changed, 414 insertions(+), 101 deletions(-) diff --git a/HoTTLean/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index 4cdf2ad6..4348cd21 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -437,6 +437,33 @@ variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {A : Γ ⥤ Grpd.{u₁,u₁}} 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 + section variable {x y : Γ} (f : x ⟶ y) @@ -966,17 +993,32 @@ def strongTrans.naturality {x y : Γ} (g : x ⟶ y) : 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 -@[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 - simp only [sigma_obj, Functor.comp_obj, sigmaMap_obj_base, naturality, sigma_map, +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] - rw [comp_base, base_eqToHom] + +@[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] @@ -1089,7 +1131,7 @@ lemma strongTrans.app_map_naturality_hom_app {x y : Γ} (f : x ⟶ y) (a : (A.ob -- (PGrpd.objFiber' hs x).obj (PGrpd.objFiber' hs z).obj (PGrpd.mapFiber' hs (g1 ≫ g2)) -- simp [conjugatingObjNatTransEquiv', Grpd.Functor.iso, ← heq_eq_eq] at h --- set_option maxHeartbeats 500000 +-- set_option maxHeartbeats 5000 -- @[simps] -- def strongTrans : (A ⋙ Grpd.forgetToCat).toPseudoFunctor'.StrongTrans -- (sigma A B ⋙ Grpd.forgetToCat).toPseudoFunctor' := where @@ -1153,45 +1195,19 @@ lemma mapStrongTrans_map_base {x y} (f : x ⟶ y) : ((mapStrongTrans B s hs).map 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 - simp only [mapStrongTrans, Section.mapStrongTrans_obj_base, sigma_obj, - Section.mapStrongTrans_map_base, sigma_map, Section.mapStrongTrans_obj_fiber, sigmaMap_obj_base, - Section.mapStrongTrans_map_fiber, Functor.comp_obj] - rw [comp_base] - simp - -lemma mapStrongTrans_map_fiber_fiber {x y} (f : x ⟶ y) : - ((mapStrongTrans B s hs).map f).fiber.fiber = - sorry := by - simp [mapStrongTrans] - rw [comp_fiber] + rw [mapStrongTrans_map_fiber, comp_base, comp_base, base_eqToHom, strongTrans.twoCell_app_base] simp - sorry - --- @[simp] -- TODO remove in favour of fiber_fiber -lemma mapStrongTrans_map_fiber {x y} (f : x ⟶ y) : ((mapStrongTrans B s hs).map f).fiber = - eqToHom (sorry) ≫ - (PGrpd.mapFiber' hs f.base).1.app ((A.map f.base).obj x.fiber) ≫ - (PGrpd.objFiber' hs y.base).obj.obj.map f.fiber := by - -- simp only [mapStrongTrans, Functor.Grothendieck.toPseudoFunctor'Iso.inv, Functor.comp_obj, - -- Pseudofunctor.Grothendieck.map_obj_base, Functor.Grothendieck.toPseudoFunctor'Iso.hom_obj_base, - -- Pseudofunctor.Grothendieck.map_obj_fiber, Functor.toPseudoFunctor'_obj, sigma_obj, - -- strongTrans_app, Functor.Grothendieck.toPseudoFunctor'Iso.hom_obj_fiber, Functor.comp_map, - -- Pseudofunctor.Grothendieck.map_map_base, Functor.Grothendieck.toPseudoFunctor'Iso.hom_map_base, - -- Pseudofunctor.Grothendieck.map_map_fiber, Functor.toPseudoFunctor'_map, Quiver.Hom.toLoc_as, - -- sigma_map, strongTrans_naturality, strongTrans.naturality, conjugatingObjNatTransEquiv₁, - -- Grpd.Functor.iso, Grpd.functorIsoOfIso_inv, Functor.mapIso_inv, asIso_inv, - -- Grpd.functorIsoOfIso_hom, Functor.mapIso_hom, asIso_hom, conjugatingObjNatTransEquiv', - -- Groupoid.isoEquivHom, Equiv.toFun_as_coe, Equiv.trans_apply, Equiv.coe_fn_mk, - -- Equiv.coe_fn_symm_mk, Iso.symm_mk, NatTrans.comp_app, Cat.comp_obj, Functor.whiskerLeft_app, - -- Functor.Grothendieck.toPseudoFunctor'Iso.hom_map_fiber, Hom.fiber, - -- Functor.Grothendieck.Hom.mk_fiber, eqToHom_app, Category.assoc] - sorry - -- rfl /-- Let `Γ` be a category. For any pair of functors `A : Γ ⥤ Grpd` and `B : ∫(A) ⥤ Grpd`, @@ -1314,30 +1330,82 @@ lemma mapStrongTrans_comp_map_fstNatTrans : -- -- #check mapStrongTrans_map_fiber_base -- sorry +@[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.map_fstNatTrans_eq] simp [← Functor.assoc, mapStrongTrans_comp_map_fstNatTrans] --- -- JH: make some API for this? Mixture of Pseudofunctor.Grothendieck --- -- and Functor.Grothendieck and Functor.Groupoidal is messy. +lemma fiber_eqToHom_comp_heq {x' x y : ∫ A} (h : x' = x) (f : x ⟶ y) : + (eqToHom h ≫ f).fiber ≍ f.fiber := by + subst h + simp + +lemma fiber_eq_eqToHom_comp_heq {x' x y : ∫ A} (g : x' ⟶ x) (h : x' = x) (hg : g = eqToHom h) + (f : x ⟶ y) : (eqToHom h ≫ f).fiber ≍ f.fiber := by + subst h + simp + +-- Hom.fiber (Hom.fiber ((mapStrongTrans B s hs).map ((ι A x).map h))) ≍ Hom.fiber ((strongTrans.app B s hs x).map h) +-- 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 + apply HEq.trans (eqToHom_comp_heq ..) + rfl + + -- simp? [mapStrongTrans] + -- rw [comp_fiber] + -- apply HEq.trans (eqToHom_comp_heq ..) + -- conv => left; left; right; rw [fiber_eqToHom] + -- conv => left; left; rw [eqToHom_map] + -- apply HEq.trans (eqToHom_comp_heq ..) + -- congr 1 + -- · simp + -- · conv => left; right; rw [ι_map_fiber, Functor.map_comp, eqToHom_map] + -- rw! (castMode := .all) [ι_obj_base] + -- simp + -- apply HEq.trans (eqToHom_comp_heq ..) + -- rfl + + -- , fiber_eqToHom, eqToHom_map, ι_map_fiber, Functor.map_comp, eqToHom_map, + -- ι_obj_fiber] + -- comp_fiber + -- slice_lhs 4 4 => rw! [← Functor.comp_map] + -- simp + -- , strongTrans.twoCell_app_base + -- simp + + -- simp [- Functor.comp_map] + -- have H := Functor.congr_map (ι A y.base ⋙ B) (strongTrans.app_map_base B s hs y.base f.fiber) + -- rw [Functor.map_comp, eqToHom_map, Functor.map_comp, eqToHom_map, Grpd.comp_eq_comp, + -- Grpd.comp_eq_comp] at H + -- rw [Functor.congr_hom H] + -- simp [← heq_eq_eq, Grpd.eqToHom_hom] + lemma ι_comp_inversion {x} : ι A x ⋙ inversion B s hs = - (PGrpd.objFiber' hs x).obj.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] - -- rw [← Functor.assoc, (PGrpd.objFiber' hs x).property, Functor.id_comp] - sorry + 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 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 - -- 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 - rw [mapStrongTrans_map_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 @@ -1348,7 +1416,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 @@ -1367,11 +1435,16 @@ def lamObjFiberObj : Grpd.of (A.obj x ⥤ sigmaObj (β ⋙ PGrpd.forgetToGrpd) x simp [lamObjFiberObj] def lamObjFiber : Grpd.of ((pi _ (β ⋙ PGrpd.forgetToGrpd)).obj x) := - ⟨lamObjFiberObj A β x , rfl⟩ + ⟨lamObjFiberObj A β x, rfl⟩ @[simp] lemma lamObjFiber_obj_obj : (lamObjFiber A β x).obj.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 section @@ -1554,17 +1627,27 @@ 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, sorry⟩ + ⟨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 + 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; sorry) + = 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 @@ -1613,23 +1696,27 @@ 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] +-- 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 : Δ) : lamObjFiber A β (σ.obj x) ≍ - lamObjFiber (σ ⋙ A) (pre A σ ⋙ β) x := by +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] - -- apply Grpd.MorphismProperty.WideSubcategory.hext - -- simp only [lamObjFiber] - sorry - -- apply Grpd.MorphismProperty.WideSubcategory.hext - -- 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 +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 ≍ @@ -1672,42 +1759,196 @@ lemma whiskerLeftInvLamObjObjSigMap_naturality_heq {x y} (f : x ⟶ y) : lemma lam_naturality_map {x y} (f : x ⟶ y) : lamMapFiber A β (σ.map f) ≍ lamMapFiber (σ ⋙ A) (pre A σ ⋙ β) f := by + apply Section.hom_hext + -- all_goals simp [Functor.assoc, sigmaObj_naturality] -- apply whiskerLeftInvLamObjObjSigMap_naturality_heq - sorry + · 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_naturality : σ ⋙ lam A β = lam (σ ⋙ A) (pre A σ ⋙ β) := by apply PGrpd.Functor.hext · simp [Functor.assoc, lam_comp_forgetToGrpd, pi_comp] - · apply lam_naturality_obj + · apply lamObjFiber_naturality · apply lam_naturality_map -lemma objFiber_lam_obj_obj_obj {x y : ∫ A} (f : x ⟶ y) : - ((PGrpd.objFiber (lam A β) y.base).obj.obj.map (Hom.fiber f)).fiber = sorry := - sorry +@[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 objFiber_lam_obj_obj_obj {x y : ∫ A} (f : x ⟶ y) : +-- ((PGrpd.objFiber (lam A β) y.base).obj.obj.map (Hom.fiber f)).fiber = sorry := +-- sorry + +-- lemma lskdfjalskdjf {x y : ∫ A} (f : x ⟶ y) : +-- (β.map f).fiber = sorry ≫ PGrpd.mapFiber (ι A y.base ⋙ β) (Hom.fiber f) := by +-- sorry + +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 [twoCell, lam] + convert_to (whiskerLeftInvLamObjObjSigMap A β f.base).app ((A.map f.base).obj x.fiber) = _ + simp [whiskerLeftInvLamObjObjSigMap, lamObjFiberObjCompSigMap, lamObjFiberObjCompSigMap.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 + + -- 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] + -- simp [strongTrans.twoCell, lam, PGrpd.mapFiber', PGrpd.mapFiber'EqToHom, + -- lamMapFiber] + -- erw [NatTrans.comp_app, NatTrans.id_app, Category.id_comp] + -- simp [whiskerLeftInvLamObjObjSigMap, lamObjFiberObjCompSigMap] + -- erw [eqToHom_app] + -- rw [comp_fiber, fiber_eqToHom, lamObjFiberObjCompSigMap.app_fiber_eq] + -- simp only [Functor.map_comp, eqToHom_map] + -- rw! [base_eqToHom, eqToHom_map] + -- simp only [comp_obj, Functor.Grothendieck.forget_obj, sigmaMap_obj_base, comp_base, + -- Functor.comp_map, Functor.Grothendieck.forget_map, sigmaMap_obj_fiber, Category.assoc, + -- eqToHom_trans_assoc] + + -- erw [eqToHom_refl] + -- rw! (castMode := .all) [h] + -- rw! (castMode := .all) [← Functor.comp_obj (A.map (CategoryTheory.inv (Hom.base f)))] + -- erw [ιNatTrans_app_fiber] + -- simp + -- simp + -- sorry + +-- lemma ualskfalksdjf {x y} (f : x ⟶ y) : ((ι A y.base ⋙ β).map (Hom.fiber f)).base.map +-- (β.map ((ιNatTrans (Hom.base f)).app x.fiber)).fiber ≫ +-- ((ι A y.base ⋙ β).map (Hom.fiber f)).fiber ≍ +-- (β.map f).fiber := by +-- 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 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] + -- simp [PGrpd.mapFiber] + -- simp [strongTrans.twoCell_app] + -- rw [comp_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_fiber, eqToHom_comp_heq_iff] + + -- apply (fiber_eq_eqToHom_comp_heq ..).trans + -- simp [strongTrans.twoCell, strongTrans.app] + -- rw [comp_fiber] + -- · sorry lemma inversion_lam : inversion (β ⋙ PGrpd.forgetToGrpd) (lam A β) (lam_comp_forgetToGrpd ..) = β := by apply PGrpd.Functor.hext · simp [inversion_comp_forgetToGrpd] · intro x - simp only [inversion, comp_obj, toPGrpd_obj_base, Functor.Grothendieck.forget_obj, - toPGrpd_obj_fiber, sigma.assoc_inv_obj_fiber, mapStrongTrans_obj_base, - mapStrongTrans_obj_fiber, sigma_obj, sigma.fstNatTrans_app, PGrpd.objFiber'_rfl, heq_eq_eq] - sorry - -- simp only [inversion, comp_obj, toPGrpd_obj_base, Functor.Grothendieck.forget_obj, - -- toPGrpd_obj_fiber, sigma.assoc_inv_obj_fiber, mapStrongTrans_obj_base, - -- mapStrongTrans_obj_fiber, sigma_obj, sigma.fstNatTrans_app, PGrpd.objFiber'_rfl, heq_eq_eq] - -- rfl + simp [mapStrongTrans_obj_fiber] · intro x y f simp [inversion] - rw [mapStrongTrans_map_fiber] - simp - rw [comp_fiber] - rw [fiber_eqToHom] - simp - rw [comp_fiber] - simp - sorry + apply mapStrongTrans_map_lam_map_fiber_fiber_heq + -- rw [mapStrongTrans_map_fiber] + -- simp + -- rw [comp_fiber] + -- rw [fiber_eqToHom] + -- simp + -- rw [comp_fiber] + -- simp + -- sorry end @@ -1716,7 +1957,7 @@ section variable (B : ∫ A ⥤ Grpd) (s : Γ ⥤ PGrpd) (hs : s ⋙ PGrpd.forgetToGrpd = pi A B) lemma lamObjFiber_obj_obj_inversion_heq (x) : - (lamObjFiber A (inversion B s hs) x).obj.obj ≍ (PGrpd.objFiber' hs x).obj.obj := by + (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] @@ -1728,19 +1969,91 @@ lemma lamObjFiber_obj_obj_inversion_heq (x) : lemma lamObjFiber_inversion_heq' (x) : lamObjFiber A (pi.inversion B s hs) x ≍ PGrpd.objFiber' hs x := by - -- dsimp [pi_obj] apply pi.obj_hext · rfl · simp [pi.inversion_comp_forgetToGrpd] · 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' + +-- #check Grpd.Functor.hcongr_obj +-- lemma Grpd.Functor.hcongr_obj (A B : ) + +lemma whiskerLeftInvLamObjObjSigMap_inversion_app {x y} (f : x ⟶ y) (a) : + (whiskerLeftInvLamObjObjSigMap A (inversion B s hs) f).app a ≍ + (PGrpd.mapFiber' hs f).1.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 + fapply Functor.Groupoidal.Hom.hext' + · rw [inversion_comp_forgetToGrpd] + · apply Functor.Groupoidal.hext' + · rw [inversion_comp_forgetToGrpd] + · simp [h] + simp [← Functor.comp_obj, ← Grpd.comp_eq_comp] + · simp + sorry + · rw [← lamObjFiber_obj_obj] + apply Grpd.Functor.hcongr_obj rfl _ _ HEq.rfl + · simp + · apply lamObjFiber_obj_obj_inversion_heq + · rw [comp_base] + conv => lhs; rhs; rw [base_eqToHom] + simp only [sigmaMap_obj_base, lamObjFiberObjCompSigMap.app_base, Functor.comp_obj, + Category.id_comp] + have := NatTrans.congr_app (PGrpd.mapFiber' hs f).property a + simp only [sigma_obj, sigma.fstNatTrans, pi_obj_α, Functor.comp_obj, + Functor.Groupoidal.forget_obj, Set.mem_setOf_eq, Functor.whiskerRight_app, forget_map, + Category.id_comp, eqToHom_trans, eqToHom_app] at this + simp only [this] + apply eqToHom_heq_eqToHom + simp only [Functor.map_inv, ← Functor.comp_obj, ← Grpd.comp_eq_comp, IsIso.inv_hom_id, + Grpd.id_eq_id, Functor.id_obj, lamObjFiberObj_obj_base] + exact h.symm + · sorry + -- · rw [comp_base] + -- simp only [sigmaMap_obj_base, lamObjFiberObjCompSigMap.app_base, Functor.comp_obj, + -- Category.id_comp, homMk_base] + -- rw [base_eqToHom] + -- · rw [comp_fiber] + -- sorry + +-- lemma lamMapObjFiblskdfj {x y} (f : x ⟶ y) : (lamMapFiber A (inversion B s hs) f).1 = +-- sorry := by +-- -- simp only [sigma_obj, sigma.fstNatTrans_app, pi_obj_α, Set.mem_setOf_eq, +-- -- lamMapFiber, whiskerLeftInvLamObjObjSigMap] +-- sorry + +-- lemma lamMapObjFiber_inversion_app {x y} (f : x ⟶ y) (a) : +-- (lamMapFiber A (inversion B s hs) f).1.app a ≍ +-- (PGrpd.mapFiber' hs f).1.app a := by +-- 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 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 From 2694ddf14db55c43b91a65a8f6424a516814b579 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 31 Oct 2025 23:06:27 -0400 Subject: [PATCH 07/95] chore: tidy up pi file --- HoTTLean/ForMathlib.lean | 28 + .../CategoryTheory/Functor/Iso.lean | 26 + .../ForMathlib/CategoryTheory/Whiskering.lean | 10 + HoTTLean/Groupoids/Pi.lean | 623 +----------------- 4 files changed, 86 insertions(+), 601 deletions(-) diff --git a/HoTTLean/ForMathlib.lean b/HoTTLean/ForMathlib.lean index cea2bcc2..02313809 100644 --- a/HoTTLean/ForMathlib.lean +++ b/HoTTLean/ForMathlib.lean @@ -583,4 +583,32 @@ theorem comp_heq_of_heq_id {A B : Type u} {C : Type*} [Category.{v} A] [Category end Functor +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 + +lemma eqToHom_heq_id {C : Type*} [Category C] (x y z : C) (h : x = y) + (hz : z = x) : eqToHom h ≍ 𝟙 z := by cat_disch + + 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 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/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/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index 4348cd21..21c71992 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -6,73 +6,10 @@ 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 - -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 namespace CategoryTheory -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 - -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 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 - -@[reassoc] -lemma _root_.CategoryTheory.Functor.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 - -theorem _root_.CategoryTheory.PGrpd.mapFiber'_comp' +theorem PGrpd.mapFiber'_comp' {Γ : Type u₂} [Category.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} {α : Γ ⥤ PGrpd.{v₁,u₁}} (h : α ⋙ PGrpd.forgetToGrpd = A) {x y z} (f : x ⟶ y) @@ -203,9 +140,6 @@ open CategoryTheory Opposite Functor.Groupoidal end GroupoidModel -end ForOther - --- NOTE content for this doc starts here namespace GroupoidModel open CategoryTheory Opposite Functor.Groupoidal @@ -282,13 +216,6 @@ 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 --- @[simp] --- lemma conjugatingObjNatTransEquiv'_apply {x y : Γ} (f : x ⟶ y) (S) (T) (g) : --- conjugatingObjNatTransEquiv' A B f S T g = --- eqToHom (by simp) ≫ g ≫ eqToHom (by simp) := by --- ext --- simp [conjugatingObjNatTransEquiv', Grpd.Functor.iso] - @[simp] lemma conjugatingObjNatTransEquiv'_id (x : Γ) (S) (T) (g) : conjugatingObjNatTransEquiv' A B (𝟙 x) S T g = @@ -405,29 +332,6 @@ lemma conjugatingObjNatTransEquiv₁_comp_inv {x y z : Γ} (f1 : x ⟶ y) (f2 : simp [Groupoid.isoEquivHom] rfl --- lemma conjugatingObjNatTransEquiv₁_comp_inv {x y z : Γ} (f1 : x ⟶ y) (f2 : y ⟶ z) (S) (T) --- (g : A.map (inv (f1 ≫ f2)) ⋙ S ⋙ B.map (f1 ≫ f2) ⟶ T) : --- (conjugatingObjNatTransEquiv₁ A B (f1 ≫ f2) S T g).inv = --- eqToHom (by simp [Functor.assoc]) ≫ --- (A.map f1 ⋙ A.map f2).whiskerLeft (CategoryTheory.inv g) ≫ --- eqToHom (by simp [← Grpd.comp_eq_comp]) --- := by --- simp only [conjugatingObjNatTransEquiv₁, Groupoid.isoEquivHom, Groupoid.inv_eq_inv, --- Equiv.trans_apply, Equiv.coe_fn_symm_mk] --- erw [conjugatingObjNatTransEquiv'_comp] --- simp [IsIso.inv_comp, inv_eqToHom, inv_whiskerLeft, Category.assoc] - --- lemma conjugatingObjNatTransEquiv₁_comp_inv {x y z : Γ} (f1 : x ⟶ y) (f2 : y ⟶ z) (S) (T) --- (g : A.map (inv (f1 ≫ f2)) ⋙ S ⋙ B.map (f1 ≫ f2) ⟶ T) : --- (conjugatingObjNatTransEquiv₁ A B (f1 ≫ f2) S T g).inv = --- eqToHom (by simp [Functor.assoc]) ≫ --- whiskerLeft (A.map f1) (whiskerLeft (A.map f2) (CategoryTheory.inv g)) ≫ --- eqToHom (by simp [← Grpd.comp_eq_comp]) --- := by --- dsimp only [conjugatingObjNatTransEquiv₁, Equiv.trans_apply] --- simp only [Groupoid.isoEquivHom, Groupoid.inv_eq_inv, Equiv.coe_fn_symm_mk] --- erw [conjugatingObjNatTransEquiv'_comp] --- simp only [IsIso.inv_comp, inv_eqToHom, inv_whiskerLeft, Category.assoc] end namespace Section @@ -656,40 +560,6 @@ lemma mapStrongTrans_comp_map_self (happ : ∀ x, app x ⋙ φ.app x = 𝟭 _) rw [strongTrans_comp_toStrongTrans'_self φ app naturality naturality_id naturality_comp happ hnaturality, Pseudofunctor.Grothendieck.map_id_eq] simp - -- fapply CategoryTheory.Functor.ext - -- · intro x - -- fapply Functor.Grothendieck.ext - -- · simp [mapStrongTrans, Functor.Grothendieck.toPseudoFunctor'Iso, - -- map, strongTrans] - -- · simpa [Grpd.forgetToCat, mapStrongTrans, map, strongTrans, - -- Functor.Grothendieck.toPseudoFunctor'Iso] using Functor.congr_obj (happ x.base) _ - -- · intro x y f - -- fapply Functor.Grothendieck.Hom.ext - -- · simp only [Grpd.forgetToCat, mapStrongTrans, Functor.Grothendieck.toPseudoFunctor'Iso, - -- strongTrans, map, Functor.comp_obj, Functor.Grothendieck.map_obj_base, - -- Functor.Grothendieck.toPseudoFunctor'Iso.inv_obj_base, - -- Pseudofunctor.Grothendieck.map_obj_base, - -- Functor.Grothendieck.toPseudoFunctor'Iso.hom_obj_base, Functor.comp_map, - -- Functor.Grothendieck.map_map_base, Functor.Grothendieck.toPseudoFunctor'Iso.inv_map_base, - -- Pseudofunctor.Grothendieck.map_map_base, - -- Functor.Grothendieck.toPseudoFunctor'Iso.hom_map_base, Functor.id_obj, Functor.id_map] - -- rw [Functor.Grothendieck.Hom.comp_base, Functor.Grothendieck.Hom.comp_base, - -- Functor.Grothendieck.base_eqToHom, Functor.Grothendieck.base_eqToHom] - -- simp - -- · simp [Grpd.forgetToCat, mapStrongTrans, map, strongTrans, - -- Functor.Grothendieck.toPseudoFunctor'Iso] - -- rw [Functor.Grothendieck.Hom.comp_fiber, Functor.Grothendieck.Hom.comp_fiber] - -- simp - -- rw [Functor.Grothendieck.fiber_eqToHom] - -- rw [Functor.Grothendieck.fiber_eqToHom] - -- slice_rhs 2 2 => rw [eqToHom_map] - -- simp [← heq_eq_eq] - -- conv => right; rw! (castMode := .all) [Functor.Grothendieck.base_eqToHom, - -- eqToHom_map A] - -- simp [← Functor.comp_map] - -- erw [Functor.congr_hom (happ y.base) f.fiber] - -- simp - -- sorry end @@ -697,89 +567,24 @@ end Section section variable {Γ : Type u₂} [Groupoid.{v₂} Γ] (A : Γ ⥤ Grpd.{u₁,u₁}) (B : ∫(A) ⥤ Grpd.{u₁,u₁}) --- variable {x y : Γ} (f : x ⟶ y) - --- open sigma - --- /-- --- 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 (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.obj ⋙ fstAuxObj B x) ⋙ --- (Grpd.Functor.iso A f).hom = _ --- rw [s.obj.property] --- simp - --- theorem isOverId_conjugating {s t : piObj B x} (α : s ⟶ t) : --- IsOverId (fstAuxObj B y) ((conjugating A (sigma A B) f).map (↑α : s.obj ⟶ t.obj)) := sorry - --- /-- 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.ι --- 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) --- ``` --- -/ --- def piMap : piObj B x ⥤ piObj B y := --- MorphismProperty.lift _ --- (ObjectProperty.lift (IsSection (fstAuxObj B y)) --- ((Section.ι (fstAuxObj B x) ⋙ conjugating A (sigma A B) f)) --- (isSection_conjugating A B f)) --- (by --- intro s t α --- simp [IsOverId, conjugating, Functor.associator_eq] --- erw [Category.comp_id] --- have h := α.2 --- simp only [Set.mem_setOf_eq, IsOverId] at h --- rw [Functor.comp_whiskerRight] --- sorry) - --- 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 - --- lemma piMap_map (s1 s2: piObj B x) (η: s1 ⟶ s2) : --- (piMap A B f).map η = (conjugating A (sigma A B) f).map η := --- rfl - --- /-- --- The square commutes - --- 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 := --- rfl - --- @[simp] lemma piMap_id (x : Γ) : piMap A B (𝟙 x) = 𝟭 (piObj B x) := by --- simp only [piMap, conjugating_id] --- 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] --- rfl - /-- The formation rule for Π-types for the natural model `smallU` - as operations between functors -/ +as operations between functors. + +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.ι + 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) @@ -795,59 +600,12 @@ 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] - --- lemma piObj_naturality (x): --- piObj B (σ.obj x) = piObj (pre A σ ⋙ B) x := by --- dsimp [pi, piObj, sigma.fstAuxObj] --- rw [sigma_naturality_aux] - -section - -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_ι' - -end - lemma conjugating_naturality_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 - lemma comm_sq_of_comp_mono {C : Type*} [Category C] {X Y Z W X' Y' Z' W' : C} (f : X ⟶ Y) (h : X ⟶ W) (g : Y ⟶ Z) (i : W ⟶ Z) @@ -868,27 +626,6 @@ 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 ObjectProperty.lift_comp_inclusion_eq --- · apply eqToHom_ι --- · apply eqToHom_ι --- · apply ObjectProperty.lift_comp_inclusion_eq - theorem pi_comp : pi (σ ⋙ A) (pre A σ ⋙ B) = σ ⋙ pi A B := by dsimp [pi] rw [← Section.functor_comp] @@ -922,13 +659,7 @@ 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: simp should just end at ((strongTrans.app B s hs y).obj a).fiber --- @[simp] --- lemma strongTrans.app_obj_fiber (y) (a) : --- ((strongTrans.app B s hs y).obj a).fiber = sorry := by --- simp [app] --- sorry - -- 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') : @@ -1028,13 +759,6 @@ lemma strongTrans.naturality_id_hom (x : Γ) : erw [conjugatingObjNatTransEquiv₁_id_inv] simp [sigma_obj, sigma_map, eqToHom_trans, twoCell_id] --- 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') [IsIso f] : --- have : IsIso f' := by aesop --- inv f ≍ inv f' := by --- subst hC hX hY hf --- rfl - 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 @@ -1042,41 +766,6 @@ lemma inv_heq_inv {C : Type*} [Category C] {X Y : C} {X' Y' : C} subst hX hY hf rfl --- @[reassoc] --- lemma strongTrans.naturality_comp_hom_aux {x y} (g : x ⟶ y) : --- A.map g ≫ (((pi A B).map g).obj (PGrpd.objFiber' hs x)).obj.obj = --- (PGrpd.objFiber' hs x).obj.obj ⋙ sigmaMap B g := by --- simp [pi, conjugating, ← Grpd.comp_eq_comp] --- sorry - --- 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) ≫ --- CategoryTheory.inv --- ((A.map g1 ⋙ A.map g2).whiskerLeft ((piMap A B g2).map (PGrpd.mapFiber' hs g1) ≫ --- PGrpd.mapFiber' hs g2)) ≫ --- eqToHom (by --- simp only [← Grpd.comp_eq_comp, ← Functor.map_comp, pi_obj, pi_map, ObjectProperty.ι_obj] --- simp only [← Functor.comp_obj, ← piMap_comp] --- apply strongTrans.naturality_comp_hom_aux) := by --- simp only [naturality, sigma_obj, sigma_map, Equiv.toFun_as_coe, Iso.symm_hom, --- ObjectProperty.ι_obj, pi_obj, pi_map, PGrpd.mapFiber'_comp'] --- erw [conjugatingObjNatTransEquiv₁_comp_inv] --- simp only [← heq_eq_eq, heq_eqToHom_comp_iff, eqToHom_comp_heq_iff, --- comp_eqToHom_heq_iff] --- simp only [← Category.assoc, heq_comp_eqToHom_iff] --- simp only [← Functor.inv_whiskerLeft] --- congr! 2 --- · rw [← Functor.comp_obj, ← piMap_comp] --- simp only [piMap_obj_obj] --- rfl --- · rw [← Functor.comp_obj, ← piMap_comp] --- simp only [piMap_obj_obj] --- rfl --- · simp only [Category.assoc] --- apply HEq.trans (eqToHom_comp_heq ..) --- 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]) ≫ @@ -1117,56 +806,6 @@ lemma strongTrans.app_map_naturality_hom_app {x y : Γ} (f : x ⟶ y) (a : (A.ob Functor.whiskerRight_app, forget_map, Category.id_comp, eqToHom_trans, eqToHom_app] at h simp [twoCell, h] - -- rw [strongTrans.naturality_comp_hom'] - -- simp only [sigma_obj, sigma_map, conjugatingObjNatTransEquiv₁, Groupoid.isoEquivHom, - -- Groupoid.inv_eq_inv, Equiv.trans_apply, Equiv.coe_fn_symm_mk] - -- simp only [← Functor.inv_whiskerLeft, ← CategoryTheory.Functor.inv_whiskerRight, - -- ← IsIso.inv_comp_assoc] - -- simp only [← heq_eq_eq, heq_eqToHom_comp_iff, eqToHom_comp_heq_iff, - -- comp_eqToHom_heq_iff, heq_comp_eqToHom_iff] - -- congr! 2 - -- · simp [← Grpd.comp_eq_comp, sigmaMap_comp, Functor.assoc] - -- simp - -- · have h := conjugatingObjNatTransEquiv'_comp A (sigma A B) g1 g2 - -- (PGrpd.objFiber' hs x).obj (PGrpd.objFiber' hs z).obj (PGrpd.mapFiber' hs (g1 ≫ g2)) - -- simp [conjugatingObjNatTransEquiv', Grpd.Functor.iso, ← heq_eq_eq] at h - --- set_option maxHeartbeats 5000 --- @[simps] --- def strongTrans : (A ⋙ Grpd.forgetToCat).toPseudoFunctor'.StrongTrans --- (sigma A B ⋙ Grpd.forgetToCat).toPseudoFunctor' := where - -- app x := strongTrans.app B s hs x.as - -- naturality {x y} g := strongTrans.naturality B s hs g.as - -- naturality_naturality := by sorry - -- -- intro x y f g η - -- -- have : f = g := LocallyDiscrete.eq_of_hom η - -- -- subst this - -- -- simp [Functor.toPseudoFunctor', pseudofunctorOfIsLocallyDiscrete] - -- naturality_id := by sorry - -- -- intro x - -- -- simp only [Functor.toPseudoFunctor'_obj, Functor.comp_obj, sigma_obj, - -- -- Functor.toPseudoFunctor'_map, LocallyDiscrete.id_as, Functor.comp_map, sigma_map, - -- -- strongTrans.naturality_id_hom, Functor.toPseudoFunctor'_mapId, eqToIso.hom, - -- -- Bicategory.whiskerLeft_eqToHom, eqToHom_trans, Bicategory.eqToHom_whiskerRight, - -- -- Bicategory.leftUnitor, Bicategory.rightUnitor, - -- -- Functor.leftUnitor_hom_comp_rightUnitor_inv (PGrpd.objFiber' hs x.as).obj.obj, - -- -- Functor.simpIdComp, ← heq_eq_eq, heq_eqToHom_comp_iff] - -- -- apply eqToHom_heq_id - -- -- simp [Grpd.forgetToCat, Cat.comp_eq_comp] - -- naturality_comp := by sorry - -- -- intro x y z g1 g2 - -- -- simp only [Functor.toPseudoFunctor'_obj, Functor.comp_obj, sigma_obj, - -- -- Functor.toPseudoFunctor'_map, LocallyDiscrete.comp_as, Functor.comp_map, sigma_map, - -- -- Bicategory.whiskerLeft, Functor.toPseudoFunctor'_mapComp, eqToIso.hom, - -- -- Bicategory.whiskerRight, Bicategory.associator, Functor.associator_eq, Iso.refl_hom, - -- -- Iso.refl_inv] - -- -- rw [Functor.whiskerLeft_eqToHom, Functor.eqToHom_whiskerRight, - -- -- strongTrans.naturality_comp_hom] - -- -- simp only [← Grpd.comp_eq_comp, Category.assoc] - -- -- erw [Category.id_comp, Category.id_comp, Category.comp_id] - -- -- simp only [Grpd.forgetToCat, id_eq, sigma_obj, Grpd.comp_eq_comp, Cat.of_α, eqToHom_trans, - -- -- eqToHom_refl, Category.comp_id] - def mapStrongTrans : ∫ A ⥤ ∫ sigma A B := 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) @@ -1213,8 +852,7 @@ lemma mapStrongTrans_map_fiber_base {x y} (f : x ⟶ y) : 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 @@ -1239,55 +877,6 @@ lemma assocHom_app_base_fiber simp rfl --- lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_obj_base_base' --- {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) --- (x : ∫ sigma A B) : --- ((sigma.assoc B).inv.obj x).base.base = x.base := by --- simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, --- sigma.assocFib.eq_1] --- rw! (castMode := .all) [pre_obj_base] --- simp --- rfl - --- lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_obj_base_fiber' --- {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) --- (x : ∫ sigma A B) : --- ((sigma.assoc B).inv.obj x).base.fiber = x.fiber.base := by --- simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, --- sigma.assocFib.eq_1] --- rw! (castMode := .all) [pre_obj_base] --- simp --- rfl - --- lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_map_base_base' --- {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) --- {X Y : ∫ sigma A B} (f : X ⟶ Y) : --- ((sigma.assoc B).inv.map f).base.base = f.base := by --- simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, --- sigma.assocFib.eq_1, functorIsoFrom_hom_map, sigma_map, comp_base, pre_map_base, --- assocHom_app_base_base, ι_map_base, ι_obj_base] --- erw [Category.comp_id] --- simp [Hom.base] - --- -- TODO replace simps! with this --- lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_map_base_fiber' --- {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) --- {X Y : ∫ sigma A B} (f : X ⟶ Y) : --- ((sigma.assoc B).inv.map f).base.fiber = eqToHom (by --- simp --- rw! [sigma.assoc_inv_map_base_base, sigma.assoc_inv_obj_base_fiber']) ≫ --- f.fiber.base := by --- simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, --- sigma.assocFib.eq_1, functorIsoFrom_hom_map, sigma_map, comp_base, comp_fiber, --- sigmaMap_obj_base] --- rw! [pre_map_base, ι_map_fiber] --- simp only [ι_map_base, ι_obj_base, ι_obj_fiber] --- erw [Grpd.map_id_map, assocHom_app_base_fiber] --- simp only [sigma.assocFib.eq_1, Functor.comp_obj, eqToHom_refl, Category.id_comp, eqToHom_trans] --- erw [Category.id_comp] --- 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) @@ -1297,39 +886,6 @@ lemma mapStrongTrans_comp_map_fstNatTrans : · intro x y f a apply strongTrans.app_map_naturality_hom_app - -- 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_fiber] - -- exact Functor.congr_obj (PGrpd.objFiber' hs x.base).property x.fiber - -- · intro x y f - -- simp [sigma.fstAux'] - -- rw [sigma.assoc_inv_map_base_fiber'] - -- have h := Functor.congr_hom (PGrpd.objFiber' hs y.base).property f.fiber - -- dsimp [IsSection, sigma.fstAuxObj] at h - -- simp [h] - -- simp [← Category.assoc] - -- -- rw! [PGrpd.mapFiber'_heq] - -- -- rw [← comp_base] - -- -- erw [mapStrongTrans_map_fiber_base] - -- -- apply heq_of_eq_of_heq (sigma.assoc_inv_map_base_fiber ..) - -- -- simp [Grpd.forgetToCat] - -- -- have h := pre_map_base B (ι A y.base) ((mapStrongTrans B s hs).map f).fiber - -- -- erw [h] - -- -- erw [sigma.assoc_inv_map_base_fiber] - -- -- #check pre_map_base - -- -- #check mapStrongTrans_map_fiber_base - -- sorry - @[simp] lemma inversion_comp_forgetToGrpd : inversion B s hs ⋙ PGrpd.forgetToGrpd = B := by simp only [inversion, Functor.assoc, toPGrpd_forgetToGrpd] @@ -1346,7 +902,6 @@ lemma fiber_eq_eqToHom_comp_heq {x' x y : ∫ A} (g : x' ⟶ x) (h : x' = x) (hg subst h simp --- Hom.fiber (Hom.fiber ((mapStrongTrans B s hs).map ((ι A x).map h))) ≍ Hom.fiber ((strongTrans.app B s hs x).map h) -- 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 ≍ @@ -1357,39 +912,11 @@ lemma mapStrongTrans_map_ι_map_fiber_fiber_heq {x : Γ} {a b : A.obj x} (h : a · simp · conv => left; right; rw [ι_map_fiber, Functor.map_comp, eqToHom_map] rw! (castMode := .all) [ι_obj_base] - simp + 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 - -- simp? [mapStrongTrans] - -- rw [comp_fiber] - -- apply HEq.trans (eqToHom_comp_heq ..) - -- conv => left; left; right; rw [fiber_eqToHom] - -- conv => left; left; rw [eqToHom_map] - -- apply HEq.trans (eqToHom_comp_heq ..) - -- congr 1 - -- · simp - -- · conv => left; right; rw [ι_map_fiber, Functor.map_comp, eqToHom_map] - -- rw! (castMode := .all) [ι_obj_base] - -- simp - -- apply HEq.trans (eqToHom_comp_heq ..) - -- rfl - - -- , fiber_eqToHom, eqToHom_map, ι_map_fiber, Functor.map_comp, eqToHom_map, - -- ι_obj_fiber] - -- comp_fiber - -- slice_lhs 4 4 => rw! [← Functor.comp_map] - -- simp - -- , strongTrans.twoCell_app_base - -- simp - - -- simp [- Functor.comp_map] - -- have H := Functor.congr_map (ι A y.base ⋙ B) (strongTrans.app_map_base B s hs y.base f.fiber) - -- rw [Functor.map_comp, eqToHom_map, Functor.map_comp, eqToHom_map, Grpd.comp_eq_comp, - -- Grpd.comp_eq_comp] at H - -- rw [Functor.congr_hom H] - -- simp [← heq_eq_eq, Grpd.eqToHom_hom] - lemma ι_comp_inversion {x} : ι A x ⋙ inversion B s hs = strongTrans.app B s hs x ⋙ toPGrpd (ι A x ⋙ B) := by apply PGrpd.Functor.hext @@ -1543,22 +1070,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) @@ -1696,11 +1207,6 @@ 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] - 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 @@ -1760,8 +1266,6 @@ lemma whiskerLeftInvLamObjObjSigMap_naturality_heq {x y} (f : x ⟶ y) : lemma lam_naturality_map {x y} (f : x ⟶ y) : lamMapFiber A β (σ.map f) ≍ lamMapFiber (σ ⋙ A) (pre A σ ⋙ β) f := by apply Section.hom_hext - -- all_goals simp [Functor.assoc, sigmaObj_naturality] - -- apply whiskerLeftInvLamObjObjSigMap_naturality_heq · simp [Functor.assoc, sigmaObj_naturality] · simp · simp [Functor.assoc] @@ -1807,14 +1311,6 @@ lemma strongTrans.app_lam_map_fiber {x y : ∫ A} (f : x ⟶ y) : PGrpd.mapFiber (ι A y.base ⋙ β) (Hom.fiber f) := by simp [lam, app, PGrpd.objFiber] --- lemma objFiber_lam_obj_obj_obj {x y : ∫ A} (f : x ⟶ y) : --- ((PGrpd.objFiber (lam A β) y.base).obj.obj.map (Hom.fiber f)).fiber = sorry := --- sorry - --- lemma lskdfjalskdjf {x y : ∫ A} (f : x ⟶ y) : --- (β.map f).fiber = sorry ≫ PGrpd.mapFiber (ι A y.base ⋙ β) (Hom.fiber f) := by --- sorry - 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)) = @@ -1853,46 +1349,6 @@ lemma strongTrans.twoCell_lam_app_fiber {x y : ∫ A} (f : x ⟶ y) : rw! [twoCell_lam_app] simp - -- 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] - -- simp [strongTrans.twoCell, lam, PGrpd.mapFiber', PGrpd.mapFiber'EqToHom, - -- lamMapFiber] - -- erw [NatTrans.comp_app, NatTrans.id_app, Category.id_comp] - -- simp [whiskerLeftInvLamObjObjSigMap, lamObjFiberObjCompSigMap] - -- erw [eqToHom_app] - -- rw [comp_fiber, fiber_eqToHom, lamObjFiberObjCompSigMap.app_fiber_eq] - -- simp only [Functor.map_comp, eqToHom_map] - -- rw! [base_eqToHom, eqToHom_map] - -- simp only [comp_obj, Functor.Grothendieck.forget_obj, sigmaMap_obj_base, comp_base, - -- Functor.comp_map, Functor.Grothendieck.forget_map, sigmaMap_obj_fiber, Category.assoc, - -- eqToHom_trans_assoc] - - -- erw [eqToHom_refl] - -- rw! (castMode := .all) [h] - -- rw! (castMode := .all) [← Functor.comp_obj (A.map (CategoryTheory.inv (Hom.base f)))] - -- erw [ιNatTrans_app_fiber] - -- simp - -- simp - -- sorry - --- lemma ualskfalksdjf {x y} (f : x ⟶ y) : ((ι A y.base ⋙ β).map (Hom.fiber f)).base.map --- (β.map ((ιNatTrans (Hom.base f)).app x.fiber)).fiber ≫ --- ((ι A y.base ⋙ β).map (Hom.fiber f)).fiber ≍ --- (β.map f).fiber := by --- 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 mapStrongTrans_map_lam_map_fiber_fiber_heq {x y} (f : x ⟶ y) : ((mapStrongTrans (β ⋙ PGrpd.forgetToGrpd) (lam A β) (lam_comp_forgetToGrpd ..)).map f).fiber.fiber ≍ @@ -1920,17 +1376,6 @@ lemma mapStrongTrans_map_lam_map_fiber_fiber_heq {x y} (f : x ⟶ y) : 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] - -- simp [PGrpd.mapFiber] - -- simp [strongTrans.twoCell_app] - -- rw [comp_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_fiber, eqToHom_comp_heq_iff] - - -- apply (fiber_eq_eqToHom_comp_heq ..).trans - -- simp [strongTrans.twoCell, strongTrans.app] - -- rw [comp_fiber] - -- · sorry lemma inversion_lam : inversion (β ⋙ PGrpd.forgetToGrpd) (lam A β) (lam_comp_forgetToGrpd ..) = β := by @@ -1941,14 +1386,6 @@ lemma inversion_lam : inversion (β ⋙ PGrpd.forgetToGrpd) (lam A β) · intro x y f simp [inversion] apply mapStrongTrans_map_lam_map_fiber_fiber_heq - -- rw [mapStrongTrans_map_fiber] - -- simp - -- rw [comp_fiber] - -- rw [fiber_eqToHom] - -- simp - -- rw [comp_fiber] - -- simp - -- sorry end @@ -1979,9 +1416,6 @@ lemma lamObjFiber_inversion_heq (x) : refine HEq.trans ?_ (PGrpd.objFiber'_heq hs) apply lamObjFiber_inversion_heq' --- #check Grpd.Functor.hcongr_obj --- lemma Grpd.Functor.hcongr_obj (A B : ) - lemma whiskerLeftInvLamObjObjSigMap_inversion_app {x y} (f : x ⟶ y) (a) : (whiskerLeftInvLamObjObjSigMap A (inversion B s hs) f).app a ≍ (PGrpd.mapFiber' hs f).1.app a := by @@ -2022,19 +1456,6 @@ lemma whiskerLeftInvLamObjObjSigMap_inversion_app {x y} (f : x ⟶ y) (a) : -- · rw [comp_fiber] -- sorry --- lemma lamMapObjFiblskdfj {x y} (f : x ⟶ y) : (lamMapFiber A (inversion B s hs) f).1 = --- sorry := by --- -- simp only [sigma_obj, sigma.fstNatTrans_app, pi_obj_α, Set.mem_setOf_eq, --- -- lamMapFiber, whiskerLeftInvLamObjObjSigMap] --- sorry - --- lemma lamMapObjFiber_inversion_app {x y} (f : x ⟶ y) (a) : --- (lamMapFiber A (inversion B s hs) f).1.app a ≍ --- (PGrpd.mapFiber' hs f).1.app a := by --- 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 lamMapFiber_inversion_heq {x y} (f : x ⟶ y) : lamMapFiber A (pi.inversion B s hs) f ≍ PGrpd.mapFiber s f := by refine HEq.trans ?_ (PGrpd.mapFiber'_heq hs f) From 1ec980c0ea5c385290f0c3ca42441392082976c4 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sat, 1 Nov 2025 11:20:46 -0400 Subject: [PATCH 08/95] pi file sorry free --- HoTTLean/ForMathlib.lean | 1 - HoTTLean/Grothendieck/Groupoidal/Basic.lean | 19 +++ HoTTLean/Groupoids/Pi.lean | 127 ++++++++++++-------- 3 files changed, 98 insertions(+), 49 deletions(-) diff --git a/HoTTLean/ForMathlib.lean b/HoTTLean/ForMathlib.lean index 02313809..4a518692 100644 --- a/HoTTLean/ForMathlib.lean +++ b/HoTTLean/ForMathlib.lean @@ -599,7 +599,6 @@ lemma eqToHom_heq_eqToHom {C : Type*} [Category C] (x y x' y' : C) (hx : x = x') lemma eqToHom_heq_id {C : Type*} [Category C] (x y z : C) (h : x = y) (hz : z = x) : eqToHom h ≍ 𝟙 z := by cat_disch - end CategoryTheory lemma hcongr_fun {α α' : Type u} (hα : α ≍ α') (β : α → Type v) (β' : α' → Type v) (hβ : β ≍ β') diff --git a/HoTTLean/Grothendieck/Groupoidal/Basic.lean b/HoTTLean/Grothendieck/Groupoidal/Basic.lean index 5538f7ed..b8105a97 100644 --- a/HoTTLean/Grothendieck/Groupoidal/Basic.lean +++ b/HoTTLean/Grothendieck/Groupoidal/Basic.lean @@ -964,6 +964,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/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index 21c71992..665c82c5 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -673,11 +673,15 @@ 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 (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]) := by + ((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, @@ -892,16 +896,6 @@ lemma inversion_comp_forgetToGrpd : inversion B s hs ⋙ PGrpd.forgetToGrpd = B conv => left; right; rw [← Functor.assoc, ← sigma.map_fstNatTrans_eq] simp [← Functor.assoc, mapStrongTrans_comp_map_fstNatTrans] -lemma fiber_eqToHom_comp_heq {x' x y : ∫ A} (h : x' = x) (f : x ⟶ y) : - (eqToHom h ≫ f).fiber ≍ f.fiber := by - subst h - simp - -lemma fiber_eq_eqToHom_comp_heq {x' x y : ∫ A} (g : x' ⟶ x) (h : x' = x) (hg : g = eqToHom h) - (f : x ⟶ y) : (eqToHom h ≫ f).fiber ≍ f.fiber := by - subst h - simp - -- 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 ≍ @@ -1326,9 +1320,15 @@ lemma strongTrans.twoCell_lam_app {x y : ∫ A} (f : x ⟶ y) : 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 [twoCell, lam] + 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 [whiskerLeftInvLamObjObjSigMap, lamObjFiberObjCompSigMap, lamObjFiberObjCompSigMap.app] + 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] @@ -1416,45 +1416,76 @@ lemma lamObjFiber_inversion_heq (x) : 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 ≍ - (PGrpd.mapFiber' hs f).1.app a := by + (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 - fapply Functor.Groupoidal.Hom.hext' - · rw [inversion_comp_forgetToGrpd] - · apply Functor.Groupoidal.hext' - · rw [inversion_comp_forgetToGrpd] - · simp [h] - simp [← Functor.comp_obj, ← Grpd.comp_eq_comp] - · simp - sorry - · rw [← lamObjFiber_obj_obj] - apply Grpd.Functor.hcongr_obj rfl _ _ HEq.rfl - · simp - · apply lamObjFiber_obj_obj_inversion_heq - · rw [comp_base] - conv => lhs; rhs; rw [base_eqToHom] - simp only [sigmaMap_obj_base, lamObjFiberObjCompSigMap.app_base, Functor.comp_obj, - Category.id_comp] - have := NatTrans.congr_app (PGrpd.mapFiber' hs f).property a - simp only [sigma_obj, sigma.fstNatTrans, pi_obj_α, Functor.comp_obj, - Functor.Groupoidal.forget_obj, Set.mem_setOf_eq, Functor.whiskerRight_app, forget_map, - Category.id_comp, eqToHom_trans, eqToHom_app] at this - simp only [this] - apply eqToHom_heq_eqToHom - simp only [Functor.map_inv, ← Functor.comp_obj, ← Grpd.comp_eq_comp, IsIso.inv_hom_id, - Grpd.id_eq_id, Functor.id_obj, lamObjFiberObj_obj_base] - exact h.symm - · sorry - -- · rw [comp_base] - -- simp only [sigmaMap_obj_base, lamObjFiberObjCompSigMap.app_base, Functor.comp_obj, - -- Category.id_comp, homMk_base] - -- rw [base_eqToHom] - -- · rw [comp_fiber] - -- sorry + 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 := by From e54b4333923b10fc4fa1d0aac6a11a619e8f96ad Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sat, 1 Nov 2025 14:59:50 -0400 Subject: [PATCH 09/95] feat: pi.Over.equivFun --- HoTTLean/Groupoids/Pi.lean | 104 +++++++++++++++++++++++++++++++++---- 1 file changed, 95 insertions(+), 9 deletions(-) diff --git a/HoTTLean/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index df5e4396..67209af1 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -185,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] @@ -591,11 +591,11 @@ section 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] + rw [conjugating_comp_map] lemma comm_sq_of_comp_mono {C : Type*} [Category C] {X Y Z W X' Y' Z' W' : C} @@ -1183,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] @@ -1217,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 @@ -1248,7 +1248,7 @@ 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 Section.hom_hext · simp [Functor.assoc, sigmaObj_naturality] @@ -1265,11 +1265,11 @@ lemma lam_naturality_map {x y} (f : x ⟶ y) : · apply lamObjFiber_naturality · apply whiskerLeftInvLamObjObjSigMap_naturality_heq -theorem lam_naturality : σ ⋙ lam A β = lam (σ ⋙ A) (pre A σ ⋙ β) := by +theorem lam_comp : σ ⋙ lam A β = lam (σ ⋙ A) (pre A σ ⋙ β) := by apply PGrpd.Functor.hext · simp [Functor.assoc, lam_comp_forgetToGrpd, pi_comp] · apply lamObjFiber_naturality - · apply lam_naturality_map + · apply lam_comp_map @[simp] lemma strongTrans.app_lam_obj_base (x : Γ) (a) : @@ -1504,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 @@ -1535,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 From de8b751ab1772ebff8d2e5fd2bf9571a823f3f7e Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sat, 1 Nov 2025 15:29:23 -0400 Subject: [PATCH 10/95] merge clans proofs --- .../CategoryTheory/ClovenIsofibration.lean | 50 ++++++++++++------- .../CategoryTheory/Functor/IsPullback.lean | 2 +- .../Grothendieck/Groupoidal/IsPullback.lean | 22 ++++++++ 3 files changed, 54 insertions(+), 20 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean index b10dd0d3..e49161de 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean @@ -20,8 +20,8 @@ variable {p : 𝒳 ⥤ 𝒮} {S : 𝒮} @[simp] lemma functor_obj_fiberInclusion_obj (a : Fiber p S) : - p.obj (Fiber.fiberInclusion.obj a) = S := by - exact a.2 + p.obj (Fiber.fiberInclusion.obj a) = S := + a.2 lemma functor_map_fiberInclusion_map {a b : Fiber p S} (f : a ⟶ b) : @@ -368,7 +368,7 @@ lemma grothendieckClassifierIso.hom_comp_self : end @[simps!] -def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : +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 @@ -382,7 +382,7 @@ def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : intro X Y f i X' hX' apply IsIso.comp_isIso -instance {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : IsSplit (iso F) where +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 @@ -481,7 +481,7 @@ instance (A : Type u) [Category.{v} A] : IsSplit (id A) := section -variable {A B C : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} C] {F : A ⥤ B} +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 := @@ -580,23 +580,35 @@ instance : IsSplit (comp IF IG) where section isoComp -variable {A A' B : Type u} [Category.{v} A] [Category.{v} A'] - [Category.{v} B] (i : A' ≅≅ A) {F : A ⥤ B} (IF: ClovenIsofibration F) - (F' : A' ⥤ B) (hF' : F' = i.hom ⋙ F) +@[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) + +@[simps!] def isoComp : ClovenIsofibration F' := - let := i -- TODO: remove once defined - let := IF -- TODO: remove once defined - let := hF' -- TODO: remove once defined - sorry + ofEq (comp (iso ..) IF) F' hF'.symm -instance [IsSplit IF] : IsSplit (isoComp i IF F' hF') := sorry +instance : IsSplit (isoComp IF i F' hF') := + inferInstanceAs (ofEq ..).IsSplit end isoComp end --- this has been proven in the `clans` branch. 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] : @@ -608,10 +620,10 @@ def ofIsPullback {A B A' B' : Type u} [Groupoid.{v} A] [Groupoid.{v} B] [Groupoi 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 := sorry - -- Functor.IsPullback.Paste.horiz eq1 (by simp [i_comp_F]) - -- (IsPullback.IsPullback.botDegenerate i_comp_F.symm) - -- (Groupoidal.compGrothendieck.isPullback ..) + (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)) := @@ -638,7 +650,7 @@ 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 i (Functor.ClovenIsofibration.forget _) + isoComp (Functor.ClovenIsofibration.forget _) i _ (Functor.IsPullback.isoIsPullback.hom_comp_right _ _ rfl).symm instance : IsSplit tpClovenIsofibration := by diff --git a/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean b/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean index 4f416541..d49b15e0 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean @@ -562,7 +562,7 @@ lemma isoIsPullback.hom_comp_right {P P' X Y Z : Type*} [Category P] [Category P 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 diff --git a/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean b/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean index 01e0d4f5..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 From 67c57593bc80ae0e7618584b546e8dff4aa6cd36 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sat, 1 Nov 2025 15:38:09 -0400 Subject: [PATCH 11/95] fix: build failure --- HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean index e49161de..3705bb56 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean @@ -628,7 +628,7 @@ def ofIsPullback {A B A' B' : Type u} [Groupoid.{v} A] [Groupoid.{v} B] [Groupoi 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 j (Functor.ClovenIsofibration.forget ..) _ e + 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) From 4a0ab48cd45c4fb85fb16ae9cba0fa40b9b0e349 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sat, 1 Nov 2025 16:36:04 -0400 Subject: [PATCH 12/95] fix: add local irreducible attr --- .../CategoryTheory/ClovenIsofibration.lean | 1 - HoTTLean/Groupoids/Id.lean | 26 ++++++++----------- 2 files changed, 11 insertions(+), 16 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean index 3705bb56..99fa2019 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean @@ -598,7 +598,6 @@ instance (F' : A ⥤ B) (hF' : F = F') : (ofEq IF F' hF').IsSplit := by variable {A' : Type u₁} [Category.{v₁} A'] (i : A' ≅≅ A) (F' : A' ⥤ B) (hF' : F' = i.hom ⋙ F) -@[simps!] def isoComp : ClovenIsofibration F' := ofEq (comp (iso ..) IF) F' hF'.symm diff --git a/HoTTLean/Groupoids/Id.lean b/HoTTLean/Groupoids/Id.lean index 1e69204d..7233977c 100644 --- a/HoTTLean/Groupoids/Id.lean +++ b/HoTTLean/Groupoids/Id.lean @@ -682,6 +682,8 @@ lemma path_unPath (p : cylinder.I.obj Γ ⟶ U.Tm) (p_tp : p ≫ U.tp = cylinder 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) @@ -707,7 +709,7 @@ def liftMap : {x y : Grpd.Interval × Γ} → (f : x ⟶ y) → 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 [liftMap] + 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 @@ -787,22 +789,14 @@ lemma I_map_obj_ff (x : Δ) : (cylinder.I.map σ).obj ({ down := { as := false } ({ down := { as := false } }, σ.obj x) := by rfl --- @[simp] --- lemma I_map_obj_tt (x) : (cylinder.I.map σ).obj (tt x) = tt (σ.obj x) := by --- rfl - --- lemma map_map_ft (y) : ((cylinder.I.map σ).map (ft y)) = (ft (σ.obj y)) := by --- simp [ft, ← CategoryTheory.Functor.map_id] --- 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 + 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 + 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))) @@ -813,9 +807,9 @@ lemma lift_map_ft' (x : Δ) : (lift p0 p p0_tp).map (ft (σ.obj x)) = rfl lemma lift_map_tf (x : Δ) : (lift p0 p p0_tp).map (tf (σ.obj x)) = - inv (tpClovenIsofibration.liftIso (p.map (ft (σ.obj x))) - (by simpa using Functor.congr_obj p0_tp (σ.obj x))) := by - simp + 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) ≫ @@ -860,7 +854,9 @@ lemma lift_comp : lift (σ ≫ p0) (cylinder.I.map σ ≫ p) · 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 [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 From 766ae081bc34d20b18532e1af795892c879faa74 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sat, 1 Nov 2025 16:54:16 -0400 Subject: [PATCH 13/95] feat: pushforward --- .../CategoryTheory/ClovenIsofibration.lean | 120 +++++++++++++++++- 1 file changed, 119 insertions(+), 1 deletion(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean index 99fa2019..806ac504 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean @@ -382,12 +382,17 @@ def iso {A : Type u} [Category.{v} A] {B : Type u₁} [Category.{v₁} B] (F : A 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 +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₂}} @@ -636,6 +641,119 @@ instance {A B A' B' : Type u} [Groupoid.{v} A] [Groupoid.{v} B] [Groupoid.{v} A' 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 end ClovenIsofibration end end Functor From 21acc29cfebf4b8e7112238841148ebe458774bb Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sat, 1 Nov 2025 16:54:51 -0400 Subject: [PATCH 14/95] chore: delete file copy --- HoTTLean/Groupoids/Pi copy.lean | 1355 ------------------------------- 1 file changed, 1355 deletions(-) delete mode 100644 HoTTLean/Groupoids/Pi copy.lean diff --git a/HoTTLean/Groupoids/Pi copy.lean b/HoTTLean/Groupoids/Pi copy.lean deleted file mode 100644 index 18aebe6d..00000000 --- a/HoTTLean/Groupoids/Pi copy.lean +++ /dev/null @@ -1,1355 +0,0 @@ -import HoTTLean.Groupoids.Sigma -import HoTTLean.ForMathlib.CategoryTheory.Whiskering -import HoTTLean.ForMathlib.CategoryTheory.NatTrans - -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 - -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 - -abbrev Section := ObjectProperty.FullSubcategory (IsSection F) - -instance Section.category : Category (Section F) := - ObjectProperty.FullSubcategory.category (IsSection F) - -abbrev Section.ι : Section F ⥤ (A ⥤ B) := - ObjectProperty.ι (IsSection F) - -end - -namespace ObjectProperty - -lemma ι_mono {T C : Type u} [Category.{v} C] [Category.{v} T] - {Z : C → Prop} (f g : T ⥤ FullSubcategory Z) - (e : f ⋙ ι Z = g ⋙ ι Z) : f = g := by - apply CategoryTheory.Functor.ext_of_iso _ _ _ - · exact Functor.fullyFaithfulCancelRight (ι Z) (eqToIso e) - · intro X - ext - exact Functor.congr_obj e X - · intro X - simp only [Functor.fullyFaithfulCancelRight_hom_app, Functor.preimage, ι_obj, ι_map, - eqToIso.hom, eqToHom_app, Functor.comp_obj, Classical.choose_eq] - rfl - -end ObjectProperty - -instance {C : Type*} [Groupoid C] (P : ObjectProperty C) : - Groupoid (P.FullSubcategory) := - InducedCategory.groupoid C (ObjectProperty.ι _).obj - -instance Grpd.ι_mono (G : Grpd) (P : ObjectProperty G) : Mono (Grpd.homOf (ObjectProperty.ι P)) := - ⟨ fun _ _ e => ObjectProperty.ι_mono _ _ e ⟩ - -lemma Grpd.ObjectProperty.FullSubcategory.congr {A A' : Grpd.{v,u}} (hA : A ≍ A') - (P : ObjectProperty A) (P' : ObjectProperty A') (hP : P ≍ P') - (a : A) (a' : A') (ha : a ≍ a') (ha : P a) (ha' : P' a') : - (⟨ a, ha ⟩ : P.FullSubcategory) ≍ (⟨ a', ha' ⟩ : P'.FullSubcategory) := by - subst hA ha hP - rfl - -lemma Grpd.ObjectProperty.FullSubcategory.hext {A A' : Grpd.{v,u}} (hA : A ≍ A') - (P : ObjectProperty A) (P' : ObjectProperty A') (hP : P ≍ P') - (p : P.FullSubcategory) (p' : P'.FullSubcategory) - (hp : p.obj ≍ p'.obj) : p ≍ p' := by - cases p; cases p' - subst hA hP hp - rfl - -end CategoryTheory - -namespace GroupoidModel - -open CategoryTheory Opposite Functor.Groupoidal - -end GroupoidModel - -end ForOther - --- NOTE content for this doc starts here -namespace GroupoidModel - -open CategoryTheory Opposite Functor.Groupoidal - -attribute [local simp] eqToHom_map Grpd.id_eq_id Grpd.comp_eq_comp Functor.id_comp Functor.comp_id - -namespace FunctorOperation -section - -open CategoryTheory.Functor - -variable {Γ : Type u₂} [Groupoid.{v₂} Γ] (A B : Γ ⥤ Grpd.{v₁,u₁}) - -/-- -The functor that, on objects `G : A.obj x ⥤ B.obj x` acts by -creating the map on the right, -by taking the inverse of `f : x ⟶ y` in the groupoid - A f - A x --------> A y - | . - | | - | . -G | | conjugating A B f G - | . - V V - B x --------> B y - B f --/ - -@[simp] -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) := - conjugating' A B f - -lemma conjugating_obj {x y : Γ} (f : x ⟶ y) (s : A.obj x ⥤ B.obj x) : - (conjugating A B f).obj s = A.map (inv f) ⋙ s ⋙ B.map f := by - 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 - rfl - -@[simp] lemma conjugating_id (x : Γ) : conjugating A B (𝟙 x) = 𝟭 _ := by - simp [conjugating] - -@[simp] lemma conjugating_comp (x y z : Γ) (f : x ⟶ y) (g : y ⟶ z) : - 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₃} Δ] (σ : Δ ⥤ Γ) - {x y} (f : x ⟶ y) : conjugating (σ ⋙ A) (σ ⋙ B) f = conjugating A B (σ.map f) := by - simp [conjugating] - -def conjugatingObjNatTransEquiv' {x y : Γ} (f : x ⟶ y) (S) (T) : - ((Grpd.Functor.iso A f).inv ⋙ S ⋙ (Grpd.Functor.iso B f).hom ⟶ T) ≃ - (S ⋙ (Grpd.Functor.iso B f).hom ⟶ (Grpd.Functor.iso A f).hom ⋙ T) where - toFun η := eqToHom (by simp) ≫ whiskerLeft (Grpd.Functor.iso A f).hom η - invFun η := whiskerLeft (Grpd.Functor.iso A f).inv η ≫ eqToHom (by simp) - left_inv η := by - simp only [whiskerLeft_comp, whiskerLeft_eqToHom, whiskerLeft_twice, associator_eq, - CategoryTheory.Iso.refl_inv, CategoryTheory.Iso.refl_hom, Category.comp_id, Category.assoc, - ← heq_eq_eq, eqToHom_comp_heq_iff] - rw! (transparency := .default) [Category.id_comp, comp_eqToHom_heq_iff] - apply Functor.Iso.whiskerLeft_inv_hom_heq - right_inv η := by - simp only [whiskerLeft_comp, whiskerLeft_twice, associator_eq, CategoryTheory.Iso.refl_inv, - CategoryTheory.Iso.refl_hom, Category.comp_id, whiskerLeft_eqToHom, Category.assoc, ← - heq_eq_eq, eqToHom_comp_heq_iff] - rw! (transparency := .default) [Category.id_comp, comp_eqToHom_heq_iff] - apply Functor.Iso.whiskerLeft_hom_inv_heq - --- @[simp] --- lemma conjugatingObjNatTransEquiv'_apply {x y : Γ} (f : x ⟶ y) (S) (T) (g) : --- conjugatingObjNatTransEquiv' A B f S T g = --- eqToHom (by simp) ≫ g ≫ eqToHom (by simp) := by --- ext --- simp [conjugatingObjNatTransEquiv', Grpd.Functor.iso] - -@[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 - -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 - -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 - -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 - -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 - -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 - -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 [conjugatingObjNatTransEquiv', Grpd.Functor.iso, Functor.associator_eq] at * - erw [Category.id_comp] - rw [whiskerLeft_map_comp] - rw [whiskerLeft_map_comp] - simp [← Category.assoc] - congr 2 - rw [Functor.comp_whiskerLeft, Functor.whiskerRight_whiskerLeft, Functor.whiskerRight_whiskerLeft] - rw [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] - simp [← heq_eq_eq] - congr 1 - · simp [← Grpd.comp_eq_comp] - · simp [← Grpd.comp_eq_comp] - · 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 - -@[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 - --- lemma conjugatingObjNatTransEquiv₁_comp_inv {x y z : Γ} (f1 : x ⟶ y) (f2 : y ⟶ z) (S) (T) --- (g : A.map (inv (f1 ≫ f2)) ⋙ S ⋙ B.map (f1 ≫ f2) ⟶ T) : --- (conjugatingObjNatTransEquiv₁ A B (f1 ≫ f2) S T g).inv = --- eqToHom (by simp [Functor.assoc]) ≫ --- (A.map f1 ⋙ A.map f2).whiskerLeft (CategoryTheory.inv g) ≫ --- eqToHom (by simp [← Grpd.comp_eq_comp]) --- := by --- simp only [conjugatingObjNatTransEquiv₁, Groupoid.isoEquivHom, Groupoid.inv_eq_inv, --- Equiv.trans_apply, Equiv.coe_fn_symm_mk] --- erw [conjugatingObjNatTransEquiv'_comp] --- simp [IsIso.inv_comp, inv_eqToHom, inv_whiskerLeft, Category.assoc] - --- lemma conjugatingObjNatTransEquiv₁_comp_inv {x y z : Γ} (f1 : x ⟶ y) (f2 : y ⟶ z) (S) (T) --- (g : A.map (inv (f1 ≫ f2)) ⋙ S ⋙ B.map (f1 ≫ f2) ⟶ T) : --- (conjugatingObjNatTransEquiv₁ A B (f1 ≫ f2) S T g).inv = --- eqToHom (by simp [Functor.assoc]) ≫ --- whiskerLeft (A.map f1) (whiskerLeft (A.map f2) (CategoryTheory.inv g)) ≫ --- eqToHom (by simp [← Grpd.comp_eq_comp]) --- := by --- dsimp only [conjugatingObjNatTransEquiv₁, Equiv.trans_apply] --- simp only [Groupoid.isoEquivHom, Groupoid.inv_eq_inv, Equiv.coe_fn_symm_mk] --- erw [conjugatingObjNatTransEquiv'_comp] --- simp only [IsIso.inv_comp, inv_eqToHom, inv_whiskerLeft, Category.assoc] -end - -section - -variable {Γ : Type u₂} [Category.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} - (B : ∫(A) ⥤ Grpd.{v₁,u₁}) (x : Γ) - --- 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 - -open sigma - -def piObj : Grpd := Grpd.of (Section (fstAuxObj B x)) - -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] - -end - -section -variable {Γ : Type u₂} [Groupoid.{v₂} Γ] (A : Γ ⥤ Grpd.{u₁,u₁}) (B : ∫(A) ⥤ Grpd.{u₁,u₁}) -variable {x y : Γ} (f: x ⟶ y) - -open sigma - -/-- -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 - -/-- 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`, -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) - ⋮ || - ⋮ || conjugating A (sigma A B) f - VV VV - piObj B y ⥤ (A y ⥤ sigma A 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) - -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 - -lemma piMap_map (s1 s2: piObj B x) (η: s1 ⟶ s2) : - (piMap A B f).map η = (conjugating A (sigma A B) f).map η := - rfl - -/-- -The square commutes - - 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 := - rfl - -@[simp] lemma piMap_id (x : Γ) : piMap A B (𝟙 x) = 𝟭 (piObj B x) := by - simp only [piMap, conjugating_id] - 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] - 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 - -end - -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] - -lemma piObj_naturality (x): - piObj B (σ.obj x) = piObj (pre A σ ⋙ B) x := by - dsimp [pi, piObj, sigma.fstAuxObj] - rw [sigma_naturality_aux] - -section - -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_ι' - -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 - -lemma conjugating_naturality_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 - -lemma comm_sq_of_comp_mono {C : Type*} [Category C] - {X Y Z W X' Y' Z' W' : C} - (f : X ⟶ Y) (h : X ⟶ W) (g : Y ⟶ Z) (i : W ⟶ Z) - (f' : X' ⟶ Y') (h' : X' ⟶ W') (g' : Y' ⟶ Z') (i' : W' ⟶ Z') - (mX : X ⟶ X') (mY : Y ⟶ Y') (mW : W ⟶ W') (mZ : Z ⟶ Z') - (hbot : f' ≫ g' = h' ≫ i') - (hf : f ≫ mY = mX ≫ f') - (hh : h ≫ mW = mX ≫ h') - (hg : g ≫ mZ = mY ≫ g') - (hi : i ≫ mZ = mW ≫ i') - [e : Mono mZ] - : f ≫ g = h ≫ i := by - apply e.right_cancellation - calc (f ≫ g) ≫ mZ - _ = f ≫ mY ≫ g' := by aesop - _ = (f ≫ mY) ≫ g' := by simp - _ = (h ≫ mW) ≫ i' := by aesop - _ = 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] - -end - -namespace pi - -section - -variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {A : Γ ⥤ Grpd.{u₁,u₁}} (B : ∫(A) ⥤ Grpd.{u₁,u₁}) - (s : Γ ⥤ PGrpd.{u₁,u₁}) (hs : s ⋙ PGrpd.forgetToGrpd = pi A B) - {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) - -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 - -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 - -lemma eqToHom_heq_id {C : Type*} [Category C] (x y z : C) (h : x = y) - (hz : z = x) : eqToHom h ≍ 𝟙 z := by cat_disch - -@[reassoc] -lemma _root_.CategoryTheory.Functor.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 - -theorem _root_.CategoryTheory.PGrpd.mapFiber'_comp' - {A : Γ ⥤ Grpd.{v₁,u₁}} {α : Γ ⥤ PGrpd.{v₁,u₁}} (h : α ⋙ PGrpd.forgetToGrpd = A) - {x y z} (f : x ⟶ y) - (g : y ⟶ z) : PGrpd.mapFiber' h (f ≫ g) - = eqToHom (by simp) ≫ (A.map g).map (PGrpd.mapFiber' h f) ≫ PGrpd.mapFiber' h g := by - subst h - simp [PGrpd.mapFiber] - -@[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 only [sigma_obj, sigma_map, PGrpd.mapFiber'_id, pi_obj, pi_map, eqToHom_comp_iff, - eqToHom_trans, IsIso.inv_comp_eq] - simp only [← heq_eq_eq, heq_comp_eqToHom_iff] - apply eqToHom_heq_eqToHom - · simp - · simp - --- 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') [IsIso f] : --- have : IsIso f' := by aesop --- inv f ≍ inv f' := by --- subst hC hX hY hf --- rfl - -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 - -@[reassoc] -lemma strongTrans.naturality_comp_hom_aux {x y} (g : x ⟶ y) : - A.map g ≫ ((piMap A B g).obj (PGrpd.objFiber' hs x)).obj = - (PGrpd.objFiber' hs x).obj ⋙ sigmaMap B g := by - simp [piMap, conjugating, ← Grpd.comp_eq_comp] - --- 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) ≫ --- CategoryTheory.inv --- ((A.map g1 ⋙ A.map g2).whiskerLeft ((piMap A B g2).map (PGrpd.mapFiber' hs g1) ≫ --- PGrpd.mapFiber' hs g2)) ≫ --- eqToHom (by --- simp only [← Grpd.comp_eq_comp, ← Functor.map_comp, pi_obj, pi_map, ObjectProperty.ι_obj] --- simp only [← Functor.comp_obj, ← piMap_comp] --- apply strongTrans.naturality_comp_hom_aux) := by --- simp only [naturality, sigma_obj, sigma_map, Equiv.toFun_as_coe, Iso.symm_hom, --- ObjectProperty.ι_obj, pi_obj, pi_map, PGrpd.mapFiber'_comp'] --- erw [conjugatingObjNatTransEquiv₁_comp_inv] --- simp only [← heq_eq_eq, heq_eqToHom_comp_iff, eqToHom_comp_heq_iff, --- comp_eqToHom_heq_iff] --- simp only [← Category.assoc, heq_comp_eqToHom_iff] --- simp only [← Functor.inv_whiskerLeft] --- congr! 2 --- · rw [← Functor.comp_obj, ← piMap_comp] --- simp only [piMap_obj_obj] --- rfl --- · rw [← Functor.comp_obj, ← piMap_comp] --- simp only [piMap_obj_obj] --- rfl --- · simp only [Category.assoc] --- apply HEq.trans (eqToHom_comp_heq ..) --- rfl - -set_option maxHeartbeats 400000 -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 ≫ - Functor.whiskerRight (strongTrans.naturality B s hs g1).hom (sigmaMap B g2) - ≫ eqToHom (by simp [Functor.assoc, sigmaMap_comp]) := by - simp only [naturality, sigma_obj, sigma_map, Equiv.toFun_as_coe, Iso.symm_hom] - refine conjugatingObjNatTransEquiv₁_comp_inv A (sigma A B) g1 g2 - (PGrpd.objFiber' hs x).obj (PGrpd.objFiber' hs y).obj (PGrpd.objFiber' hs z).obj - (PGrpd.mapFiber' hs g1) (PGrpd.mapFiber' hs g2) - (PGrpd.mapFiber' hs (g1 ≫ g2)) ?_ - simp [PGrpd.mapFiber'_comp', piMap, conjugating] - rfl - - -- rw [strongTrans.naturality_comp_hom'] - -- simp only [sigma_obj, sigma_map, conjugatingObjNatTransEquiv₁, Groupoid.isoEquivHom, - -- Groupoid.inv_eq_inv, Equiv.trans_apply, Equiv.coe_fn_symm_mk] - -- simp only [← Functor.inv_whiskerLeft, ← CategoryTheory.Functor.inv_whiskerRight, - -- ← IsIso.inv_comp_assoc] - -- simp only [← heq_eq_eq, heq_eqToHom_comp_iff, eqToHom_comp_heq_iff, - -- comp_eqToHom_heq_iff, heq_comp_eqToHom_iff] - -- congr! 2 - -- · simp [← Grpd.comp_eq_comp, sigmaMap_comp, Functor.assoc] - -- simp - -- · have h := conjugatingObjNatTransEquiv'_comp A (sigma A B) g1 g2 - -- (PGrpd.objFiber' hs x).obj (PGrpd.objFiber' hs z).obj (PGrpd.mapFiber' hs (g1 ≫ g2)) - -- simp [conjugatingObjNatTransEquiv', Grpd.Functor.iso, ← heq_eq_eq] at h - -set_option maxHeartbeats 400000 -@[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 := by - intro x y f g η - have : f = g := LocallyDiscrete.eq_of_hom η - subst this - simp [Functor.toPseudoFunctor', pseudofunctorOfIsLocallyDiscrete] - naturality_id := by - intro x - simp only [Functor.toPseudoFunctor'_obj, Functor.comp_obj, sigma_obj, - Functor.toPseudoFunctor'_map, LocallyDiscrete.id_as, Functor.comp_map, sigma_map, - strongTrans.naturality_id_hom, Functor.toPseudoFunctor'_mapId, eqToIso.hom, - Bicategory.whiskerLeft_eqToHom, eqToHom_trans, Bicategory.eqToHom_whiskerRight, - Bicategory.leftUnitor, Bicategory.rightUnitor, - Functor.leftUnitor_hom_comp_rightUnitor_inv (PGrpd.objFiber' hs x.as).obj, - Functor.simpIdComp, ← heq_eq_eq, heq_eqToHom_comp_iff] - apply eqToHom_heq_id - simp [Grpd.forgetToCat, Cat.comp_eq_comp] - naturality_comp := by - intro x y z g1 g2 - simp only [Functor.toPseudoFunctor'_obj, Functor.comp_obj, sigma_obj, - Functor.toPseudoFunctor'_map, LocallyDiscrete.comp_as, Functor.comp_map, sigma_map, - Bicategory.whiskerLeft, Functor.toPseudoFunctor'_mapComp, eqToIso.hom, - Bicategory.whiskerRight, Bicategory.associator, Functor.associator_eq, Iso.refl_hom, - Iso.refl_inv] - rw [Functor.whiskerLeft_eqToHom, Functor.eqToHom_whiskerRight, - strongTrans.naturality_comp_hom] - simp only [← Grpd.comp_eq_comp, Category.assoc] - erw [Category.id_comp, Category.id_comp, Category.comp_id] - simp only [Grpd.forgetToCat, id_eq, Cat.of_α, eqToHom_trans, eqToHom_refl, Category.comp_id] - -def mapStrongTrans : ∫ A ⥤ ∫ sigma A B := - Functor.Grothendieck.toPseudoFunctor'Iso.hom _ ⋙ - Pseudofunctor.Grothendieck.map (strongTrans B s hs) ⋙ - Functor.Grothendieck.toPseudoFunctor'Iso.inv _ - -@[simp] -lemma mapStrongTrans_obj_base (x) : ((mapStrongTrans B s hs).obj x).base = x.base := - rfl - -@[simp] -lemma mapStrongTrans_obj_fiber (x) : ((mapStrongTrans B s hs).obj x).fiber = - (PGrpd.objFiber' hs x.base).obj.obj x.fiber := - rfl - -@[simp] -lemma mapStrongTrans_map_base {x y} (f : x ⟶ y) : ((mapStrongTrans B s hs).map f).base = - f.base := - rfl - -@[simp] -lemma mapStrongTrans_map_fiber {x y} (f : x ⟶ y) : ((mapStrongTrans B s hs).map f).fiber = - eqToHom (by - simp only [mapStrongTrans_obj_base, sigma_obj, mapStrongTrans_map_base, sigma_map, - mapStrongTrans_obj_fiber, pi_obj, pi_map, piMap, ObjectProperty.ι_obj, - ObjectProperty.lift_obj_obj, Functor.comp_obj, conjugating_obj, Functor.map_inv] - simp [← Functor.comp_obj, ← Grpd.comp_eq_comp]) ≫ - (PGrpd.mapFiber' hs f.base).app ((A.map f.base).obj x.fiber) ≫ - (PGrpd.objFiber' hs y.base).obj.map f.fiber := by - simp only [mapStrongTrans, Functor.Grothendieck.toPseudoFunctor'Iso.inv, Functor.comp_obj, - Pseudofunctor.Grothendieck.map_obj_base, Functor.Grothendieck.toPseudoFunctor'Iso.hom_obj_base, - Pseudofunctor.Grothendieck.map_obj_fiber, Functor.toPseudoFunctor'_obj, sigma_obj, - strongTrans_app, Functor.Grothendieck.toPseudoFunctor'Iso.hom_obj_fiber, Functor.comp_map, - Pseudofunctor.Grothendieck.map_map_base, Functor.Grothendieck.toPseudoFunctor'Iso.hom_map_base, - Pseudofunctor.Grothendieck.map_map_fiber, Functor.toPseudoFunctor'_map, Quiver.Hom.toLoc_as, - sigma_map, strongTrans_naturality, strongTrans.naturality, conjugatingObjNatTransEquiv₁, - Grpd.Functor.iso, Grpd.functorIsoOfIso_inv, Functor.mapIso_inv, asIso_inv, - Grpd.functorIsoOfIso_hom, Functor.mapIso_hom, asIso_hom, conjugatingObjNatTransEquiv', - Groupoid.isoEquivHom, Equiv.toFun_as_coe, Equiv.trans_apply, Equiv.coe_fn_mk, - Equiv.coe_fn_symm_mk, Iso.symm_mk, NatTrans.comp_app, Cat.comp_obj, Functor.whiskerLeft_app, - Functor.Grothendieck.toPseudoFunctor'Iso.hom_map_fiber, Hom.fiber, - Functor.Grothendieck.Hom.mk_fiber, eqToHom_app, Category.assoc] - rfl - -/-- 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`. --/ -@[simps!] -def inversion : ∫(A) ⥤ PGrpd := mapStrongTrans B s hs ⋙ (sigma.assoc B).inv ⋙ toPGrpd B - -@[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 _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_obj_base_base' - {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) - (x : ∫ sigma A B) : - ((sigma.assoc B).inv.obj x).base.base = x.base := by - simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, - sigma.assocFib.eq_1] - rw! (castMode := .all) [pre_obj_base] - simp - rfl - -lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_obj_base_fiber' - {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) - (x : ∫ sigma A B) : - ((sigma.assoc B).inv.obj x).base.fiber = x.fiber.base := by - simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, - sigma.assocFib.eq_1] - rw! (castMode := .all) [pre_obj_base] - simp - rfl - -lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_map_base_base' - {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) - {X Y : ∫ sigma A B} (f : X ⟶ Y) : - ((sigma.assoc B).inv.map f).base.base = f.base := by - simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, - sigma.assocFib.eq_1, functorIsoFrom_hom_map, sigma_map, comp_base, pre_map_base, - assocHom_app_base_base, ι_map_base, ι_obj_base] - erw [Category.comp_id] - simp [Hom.base] - --- TODO replace simps! with this -lemma _root_.GroupoidModel.FunctorOperation.sigma.assoc_inv_map_base_fiber' - {Γ : Type u₂} [Groupoid Γ] {A : Γ ⥤ Grpd} (B : ∫ A ⥤ Grpd) - {X Y : ∫ sigma A B} (f : X ⟶ Y) : - ((sigma.assoc B).inv.map f).base.fiber = eqToHom (by - simp - rw! [sigma.assoc_inv_map_base_base', sigma.assoc_inv_obj_base_fiber']) ≫ - f.fiber.base := by - simp only [sigma.assoc, Functor.Iso.symm_inv, functorIsoFrom_hom_obj, sigma_obj, - sigma.assocFib.eq_1, functorIsoFrom_hom_map, sigma_map, comp_base, comp_fiber, - sigmaMap_obj_base] - rw! [pre_map_base, ι_map_fiber] - simp only [ι_map_base, ι_obj_base, ι_obj_fiber] - erw [Grpd.map_id_map, assocHom_app_base_fiber] - simp only [sigma.assocFib.eq_1, Functor.comp_obj, eqToHom_refl, Category.id_comp, eqToHom_trans] - erw [Category.id_comp] - simp - rfl - -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_fiber] - exact Functor.congr_obj (PGrpd.objFiber' hs x.base).property x.fiber - · intro x y f - simp [sigma.fstAux'] - rw [sigma.assoc_inv_map_base_fiber'] - have h := Functor.congr_hom (PGrpd.objFiber' hs y.base).property f.fiber - dsimp [IsSection, sigma.fstAuxObj] at h - simp [h] - simp [← Category.assoc] - -- rw! [PGrpd.mapFiber'_heq] - -- rw [← comp_base] - -- erw [mapStrongTrans_map_fiber_base] - -- apply heq_of_eq_of_heq (sigma.assoc_inv_map_base_fiber ..) - -- simp [Grpd.forgetToCat] - -- have h := pre_map_base B (ι A y.base) ((mapStrongTrans B s hs).map f).fiber - -- erw [h] - -- erw [sigma.assoc_inv_map_base_fiber] - -- #check pre_map_base - -- #check mapStrongTrans_map_fiber_base - sorry - -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'] - --- 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 - apply PGrpd.Functor.hext - · simp only [Functor.assoc, inversion_comp_forgetToGrpd, toPGrpd_forgetToGrpd] - rw [← Functor.assoc, (PGrpd.objFiber' hs x).property, 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 - sorry - -end - -section - -variable {Γ : Type u₂} [Groupoid.{v₂} Γ] (A : Γ ⥤ Grpd.{u₁,u₁}) (β : ∫(A) ⥤ PGrpd.{u₁,u₁}) - -section -variable (x : Γ) - -def lamObjFiberObj : Grpd.of (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 - simp [lamObjFiberObj] - -@[simp] lemma lamObjFiberObj_obj_fiber (a) : ((lamObjFiberObj A β x).obj a).fiber - = PGrpd.objFiber (ι A x ⋙ β) a := by - simp [lamObjFiberObj] - -@[simp] lemma lamObjFiberObj_map_base {a a'} (h: a ⟶ a'): - ((lamObjFiberObj A β x).map h).base = h := by - simp [lamObjFiberObj] - -@[simp] lemma lamObjFiberObj_map_fiber {a a'} (h: a ⟶ a'): - ((lamObjFiberObj A β x).map h).fiber = PGrpd.mapFiber (ι A x ⋙ β) h := by - simp [lamObjFiberObj] - -def lamObjFiber : piObj (β ⋙ PGrpd.forgetToGrpd) x := - ⟨lamObjFiberObj A β x , rfl⟩ - -@[simp] lemma lamObjFiber_obj : (lamObjFiber A β x).obj = lamObjFiberObj A β x := - rfl - -@[simp] lemma lamObjFiber_obj_obj : (lamObjFiber A β x).obj = lamObjFiberObj A β x := - rfl - -end - -section -variable {x y : Γ} (f : x ⟶ y) - -open CategoryTheory.Functor - -def lamObjFiberObjCompSigMap.app (a : A.obj x) : - (lamObjFiberObj A β x ⋙ sigmaMap (β ⋙ PGrpd.forgetToGrpd) f).obj a ⟶ - (A.map f ⋙ lamObjFiberObj A β y).obj a := - homMk (𝟙 _) (eqToHom (by simp; rfl) ≫ (β.map ((ιNatTrans f).app a)).fiber) - -@[simp] lemma lamObjFiberObjCompSigMap.app_base (a : A.obj x) : (app A β f a).base = 𝟙 _ := by - simp [app] - -lemma lamObjFiberObjCompSigMap.app_fiber_eq (a : A.obj x) : (app A β f a).fiber = - eqToHom (by simp; rfl) ≫ (β.map ((ιNatTrans f).app a)).fiber := by - simp [app] - -lemma lamObjFiberObjCompSigMap.app_fiber_heq (a : A.obj x) : (app A β f a).fiber ≍ - (β.map ((ιNatTrans f).app a)).fiber := by - simp [app] - -lemma lamObjFiberObjCompSigMap.naturality {x y : Γ} (f : x ⟶ y) {a1 a2 : A.obj x} (h : a1 ⟶ a2) : - (lamObjFiberObj A β x ⋙ sigmaMap (β ⋙ PGrpd.forgetToGrpd) f).map h - ≫ lamObjFiberObjCompSigMap.app A β f a2 = - lamObjFiberObjCompSigMap.app A β f a1 - ≫ (A.map f ⋙ lamObjFiberObj A β y).map h := by - apply Hom.hext - · simp [sigmaObj] - · have β_ιNatTrans_naturality : β.map ((ι A x).map h) ≫ β.map ((ιNatTrans f).app a2) - = β.map ((ιNatTrans f).app a1) ≫ β.map ((A.map f ⋙ ι A y).map h) := by - simp [← Functor.map_comp, (ιNatTrans f).naturality h] - have h_naturality : (β.map ((ιNatTrans f).app a2)).base.map (β.map ((ι A x).map h)).fiber - ≫ (β.map ((ιNatTrans f).app a2)).fiber ≍ - (β.map ((ι A y).map ((A.map f).map h))).base.map (β.map ((ιNatTrans f).app a1)).fiber - ≫ (β.map ((ι A y).map ((A.map f).map h))).fiber := by - simpa [← heq_eq_eq] using Grothendieck.Hom.congr β_ιNatTrans_naturality - simp only [Grpd.forgetToCat.eq_1, sigmaObj, Grpd.coe_of, comp_obj, sigmaMap_obj_base, - Functor.comp_map, comp_base, sigmaMap_map_base, sigmaMap_obj_fiber, comp_fiber, - sigmaMap_map_fiber, lamObjFiberObj_map_fiber, map_comp, eqToHom_map, app_fiber_eq, Cat.of_α, - id_eq, Category.assoc, eqToHom_trans_assoc, heq_eqToHom_comp_iff, eqToHom_comp_heq_iff] - rw [← Category.assoc] - apply HEq.trans _ h_naturality - apply heq_comp _ rfl rfl _ HEq.rfl - · aesop_cat - · simp only [← Functor.comp_map, ← Grpd.comp_eq_comp, comp_eqToHom_heq_iff] - congr 3 - aesop_cat - -@[simp] lemma lamObjFiberObjCompSigMap.app_id (a) : lamObjFiberObjCompSigMap.app A β (𝟙 x) a - = eqToHom (by simp) := by - apply Hom.hext - · rw [base_eqToHom] - simp - · simp [app] - rw! (castMode := .all) [ιNatTrans_id_app, fiber_eqToHom] - simp [Grothendieck.Hom.congr (eqToHom_map β _), Functor.Grothendieck.fiber_eqToHom, - eqToHom_trans] - apply (eqToHom_heq_id_cod _ _ _).trans (eqToHom_heq_id_cod _ _ _).symm - -lemma lamObjFiberObjCompSigMap.app_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) (a) : - app A β (f ≫ g) a - = eqToHom (by simp) - ≫ (sigmaMap (β ⋙ PGrpd.forgetToGrpd) g).map (app A β f a) - ≫ app A β g ((A.map f).obj a) ≫ eqToHom (by simp) := by - fapply Hom.hext - · simp only [Grpd.forgetToCat.eq_1, sigmaObj, Grpd.coe_of, comp_obj, sigmaMap_obj_base, app_base, - comp_base, base_eqToHom, sigmaMap_map_base, map_id, lamObjFiberObj_obj_base, map_comp, - Grpd.comp_eq_comp, eqToHom_naturality, Category.comp_id, eqToHom_trans, eqToHom_refl] - · have : (β.map ((ιNatTrans (f ≫ g)).app a)) = β.map ((ιNatTrans f).app a) - ≫ β.map ((ιNatTrans g).app ((A.map f).obj a)) - ≫ eqToHom (by simp) := by - simp [ιNatTrans_comp_app] - simp only [Grpd.forgetToCat.eq_1, sigmaObj, Grpd.coe_of, comp_obj, sigmaMap_obj_base, app, - Functor.comp_map, PGrpd.forgetToGrpd_map, sigmaMap_obj_fiber, Cat.of_α, id_eq, homMk_base, - homMk_fiber, Grothendieck.Hom.congr this, Grothendieck.Hom.comp_base, Grpd.comp_eq_comp, - Grothendieck.Hom.comp_fiber, eqToHom_refl, Functor.Grothendieck.fiber_eqToHom, - Category.id_comp, eqToHom_trans_assoc, comp_base, sigmaMap_map_base, comp_fiber, - fiber_eqToHom, eqToHom_map, sigmaMap_map_fiber, map_comp, Category.assoc, - heq_eqToHom_comp_iff, eqToHom_comp_heq_iff] - have : ((ιNatTrans g).app ((A.map f).obj a)) = homMk g (𝟙 _) := by - apply Hom.ext _ _ (by simp) (by aesop_cat) - rw! (castMode := .all) [Category.id_comp, base_eqToHom, eqToHom_map, eqToHom_map, - Functor.Grothendieck.base_eqToHom, ιNatTrans_app_base, this] - aesop_cat - -def lamObjFiberObjCompSigMap : - lamObjFiberObj A β x ⋙ sigmaMap (β ⋙ PGrpd.forgetToGrpd) f ⟶ - A.map f ⋙ lamObjFiberObj A β y where - app := lamObjFiberObjCompSigMap.app A β f - naturality _ _ h := lamObjFiberObjCompSigMap.naturality A β f h - -@[simp] lemma lamObjFiberObjCompSigMap_id (x : Γ) : lamObjFiberObjCompSigMap A β (𝟙 x) = - eqToHom (by simp [sigmaMap_id]) := by - 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) - ≫ whiskerRight (lamObjFiberObjCompSigMap A β f) (sigmaMap (β ⋙ PGrpd.forgetToGrpd) g) - ≫ whiskerLeft (A.map f) (lamObjFiberObjCompSigMap A β g) - ≫ eqToHom (by rw [Functor.map_comp, Grpd.comp_eq_comp, Functor.assoc]) := by - ext a - simp [lamObjFiberObjCompSigMap, lamObjFiberObjCompSigMap.app_comp] - -def whiskerLeftInvLamObjObjSigMap : - A.map (CategoryTheory.inv f) ⋙ lamObjFiberObj A β x ⋙ sigmaMap (β ⋙ PGrpd.forgetToGrpd) f ⟶ - lamObjFiberObj A β y := - whiskerLeft (A.map (CategoryTheory.inv f)) (lamObjFiberObjCompSigMap A β f) - ≫ eqToHom (by simp [← Grpd.comp_eq_comp]) - -@[simp] lemma whiskerLeftInvLamObjObjSigMap_id (x : Γ) : - whiskerLeftInvLamObjObjSigMap A β (𝟙 x) = eqToHom (by simp [sigmaMap_id]) := by - simp [whiskerLeftInvLamObjObjSigMap] - -attribute [local simp] Functor.assoc in -lemma whiskerLeftInvLamObjObjSimgaMap_comp_aux {A A' B B' C C' : Type*} - [Category A] [Category A'] [Category B] [Category B'] [Category C] [Category C'] - (F : Functor.Iso A B) (G : Functor.Iso B C) (lamA : A ⥤ A') (lamB : B ⥤ B') (lamC : C ⥤ C') - (F' : A' ⥤ B') (G' : B' ⥤ C') - (lamF : lamA ⋙ F' ⟶ F.hom ⋙ lamB) (lamG : lamB ⋙ G' ⟶ G.hom ⋙ lamC) - (H1 : A ⥤ C') (e1 : H1 = _) (H2 : A ⥤ C') (e2 : F.hom ⋙ G.hom ⋙ lamC = H2) : - whiskerLeft (G.inv ⋙ F.inv) - (eqToHom e1 ≫ whiskerRight lamF G' ≫ whiskerLeft F.hom lamG ≫ eqToHom e2) = - eqToHom (by aesop) ≫ - whiskerRight (whiskerLeft G.inv (whiskerLeft F.inv lamF ≫ eqToHom (by simp))) G' ≫ - whiskerLeft G.inv lamG ≫ - eqToHom (by aesop) := - calc _ - _ = eqToHom (by aesop) ≫ - (G.inv ⋙ F.inv).whiskerLeft (whiskerRight lamF G') ≫ - (G.inv ⋙ F.inv ⋙ F.hom).whiskerLeft lamG ≫ - eqToHom (by aesop) := by aesop - _ = (eqToHom (by aesop)) ≫ - whiskerLeft (G.inv ⋙ F.inv) (whiskerRight lamF G') ≫ - eqToHom (by simp) ≫ - whiskerLeft G.inv lamG ≫ - eqToHom (by aesop) := by - congr 2 - simp only [Functor.assoc, ← heq_eq_eq, heq_eqToHom_comp_iff, heq_comp_eqToHom_iff, - comp_eqToHom_heq_iff] - rw! (castMode := .all) [F.inv_hom_id, Functor.comp_id] - simp - _ = eqToHom (by aesop) ≫ - whiskerRight (whiskerLeft G.inv (whiskerLeft F.inv lamF ≫ eqToHom (by simp))) G' ≫ - whiskerLeft G.inv lamG ≫ - eqToHom (by aesop) := by aesop_cat - -lemma whiskerLeftInvLamObjObjSigMap_comp {x y z} (f : x ⟶ y) (g : y ⟶ z) : - whiskerLeftInvLamObjObjSigMap A β (f ≫ g) - = eqToHom (by simp [Functor.assoc, sigmaMap_comp]) - ≫ whiskerRight (whiskerLeft (A.map (CategoryTheory.inv g)) - (whiskerLeftInvLamObjObjSigMap A β f)) (sigmaMap (β ⋙ PGrpd.forgetToGrpd) g) - ≫ whiskerLeftInvLamObjObjSigMap A β g := by - simp only [whiskerLeftInvLamObjObjSigMap, lamObjFiberObjCompSigMap_comp] - have hAfg : A.map (CategoryTheory.inv (f ≫ g)) = (Grpd.Functor.iso A g).inv ≫ - (Grpd.Functor.iso A f).inv := by simp [Grpd.Functor.iso] - rw! (castMode := .all) [hAfg] - erw [whiskerLeftInvLamObjObjSimgaMap_comp_aux (Grpd.Functor.iso A f) (Grpd.Functor.iso A g) - _ _ _ (sigmaMap (β ⋙ PGrpd.forgetToGrpd) f) (sigmaMap (β ⋙ PGrpd.forgetToGrpd) g)] - simp only [Category.assoc, eqToHom_trans, Grpd.Functor.iso_hom, Grpd.Functor.iso_inv] - -def lamMapFiber : - ((pi A (β ⋙ PGrpd.forgetToGrpd)).map f).obj (lamObjFiber A β x) ⟶ lamObjFiber A β y := - whiskerLeftInvLamObjObjSigMap A β f - -@[simp] lemma lamMapFiber_id (x : Γ) : lamMapFiber A β (𝟙 x) = eqToHom (by simp) := by - simp [lamMapFiber] - 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] - rfl - -def lam : Γ ⥤ PGrpd.{u₁,u₁} := - PGrpd.functorTo - (pi A (β ⋙ PGrpd.forgetToGrpd)) - (lamObjFiber A β) - (lamMapFiber A β) - (lamMapFiber_id A β) - (lamMapFiber_comp A β) - -@[simp] -lemma lam_obj_base (x) : ((lam A β).obj x).base = piObj (β ⋙ PGrpd.forgetToGrpd) x := rfl - -@[simp] -lemma lam_obj_fib (x) : ((lam A β).obj x).fiber = lamObjFiber A β x := - rfl - -@[simp] -lemma lam_map_base {x y} (f : x ⟶ y) : ((lam A β).map f).base = - piMap A (β ⋙ PGrpd.forgetToGrpd) f := - rfl - -@[simp] -lemma lam_map_fib {x y} (f : x ⟶ y) : ((lam A β).map f).fiber = lamMapFiber A β f := - rfl - -lemma lam_comp_forgetToGrpd : lam A β ⋙ PGrpd.forgetToGrpd = pi A (β ⋙ PGrpd.forgetToGrpd) := - rfl - -variable {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) - -lemma lam_naturality_aux (x) : - ι A (σ.obj x) ⋙ β ⋙ PGrpd.forgetToGrpd = ι (σ ⋙ A) x ⋙ pre A σ ⋙ β ⋙ PGrpd.forgetToGrpd := by - simp [← Functor.assoc, ← ι_comp_pre] - -lemma lamObjFiberObj_naturality (x) : - lamObjFiberObj A β (σ.obj x) ≍ lamObjFiberObj (σ ⋙ A) (pre A σ ⋙ β) x := by - 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 lamObjFiberObjCompSigMap.app_naturality {x y} (f : x ⟶ y) (a) : - lamObjFiberObjCompSigMap.app A β (σ.map f) a ≍ - lamObjFiberObjCompSigMap.app (σ ⋙ A) (pre A σ ⋙ β) f a := by - apply Hom.hext' - any_goals apply Grpd.Functor.hcongr_obj - 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 sigmaMap_naturality_heq - any_goals apply lamObjFiberObj_naturality - any_goals simp [app]; rfl - -lemma lamObjFiberObjCompSigMap_naturality {x y} (f : x ⟶ y) : - lamObjFiberObjCompSigMap A β (σ.map f) ≍ - lamObjFiberObjCompSigMap (σ ⋙ A) (pre A σ ⋙ β) f := by - apply Grpd.NatTrans.hext - any_goals apply Grpd.comp_hcongr - any_goals simp only [comp_obj, Functor.comp_map, heq_eq_eq, eqToHom_refl] - any_goals apply sigmaObj_naturality - any_goals apply lamObjFiberObj_naturality - · apply sigmaMap_naturality_heq - · apply lamObjFiberObjCompSigMap.app_naturality - -lemma whiskerLeftInvLamObjObjSigMap_naturality_heq {x y} (f : x ⟶ y) : - whiskerLeftInvLamObjObjSigMap A β (σ.map f) ≍ - whiskerLeftInvLamObjObjSigMap (σ ⋙ A) (pre A σ ⋙ β) f := by - simp only [whiskerLeftInvLamObjObjSigMap, Functor.comp_map] - apply HEq.trans (comp_eqToHom_heq _ _) - apply HEq.trans _ (comp_eqToHom_heq _ _).symm - rw [Functor.map_inv, Functor.map_inv, Functor.map_inv] - apply Grpd.whiskerLeft_hcongr_right - any_goals apply Grpd.comp_hcongr - any_goals simp only [comp_obj, heq_eq_eq] - any_goals apply sigmaObj_naturality - any_goals apply lamObjFiberObj_naturality - · apply sigmaMap_naturality_heq - · apply lamObjFiberObjCompSigMap_naturality - -lemma lam_naturality_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 PGrpd.Functor.hext - · apply pi_naturality - · apply lam_naturality_obj - · apply lam_naturality_map - -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 - · intro x y f - simp [inversion] - sorry - -end - -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] - symm - apply Functor.IsPullback.lift_uniq - · symm - apply pi.ι_comp_inversion - · exact (PGrpd.objFiber' hs x).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 - · rfl - · simp [pi.inversion_comp_forgetToGrpd] - · apply lamObjFiberObj_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) - -lemma lamMapFiber_inversion_heq {x y} (f : x ⟶ y) : - lamMapFiber A (pi.inversion B s hs) f ≍ PGrpd.mapFiber s f := - sorry - -lemma lam_inversion : lam A (inversion B s hs) = s := by - apply PGrpd.Functor.hext -- TODO: rename to PGrpd.ToFunctor.hext - · rw [lam_comp_forgetToGrpd, inversion_comp_forgetToGrpd, hs] - · apply lamObjFiber_inversion_heq - · apply lamMapFiber_inversion_heq - -end - -end - -end pi - -end FunctorOperation - -section -variable {Γ : Ctx} - -open FunctorOperation - -namespace UPi - -def Pi {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) : Γ ⟶ U.{v}.Ty := - USig.SigAux pi B - -/-- Naturality for the formation rule for Π-types. -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 - -def lam {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (b : U.ext A ⟶ U.{v}.Tm) : Γ ⟶ U.{v}.Tm := - USig.SigAux pi.lam b - -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 - -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 - subst b_tp - dsimp [lam, Pi, U.tp] - rw [← toCoreAsSmallEquiv_symm_apply_comp_right] - rfl - -def unLam {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) (f : Γ ⟶ U.Tm) - (f_tp : f ≫ U.tp = UPi.Pi B) : U.ext A ⟶ U.{v}.Tm := - toCoreAsSmallEquiv.symm <| pi.inversion (toCoreAsSmallEquiv B) (toCoreAsSmallEquiv f) (by - simp [U.tp] at f_tp - rw [← toCoreAsSmallEquiv_apply_comp_right, f_tp] - simp [Pi]) - -lemma unLam_tp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) (f : Γ ⟶ U.Tm) - (f_tp : f ≫ U.tp = UPi.Pi B) : UPi.unLam B f f_tp ≫ U.tp = B := by - dsimp [unLam, U.tp] - rw [← toCoreAsSmallEquiv_symm_apply_comp_right, toCoreAsSmallEquiv.symm_apply_eq, - pi.inversion_comp_forgetToGrpd] - rfl - -lemma unLam_lam {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) (b : U.ext A ⟶ U.Tm) - (b_tp : b ≫ U.tp = B) : UPi.unLam B (UPi.lam b) (lam_tp _ _ b_tp) = b := by - subst b_tp - simp only [unLam, lam, toCoreAsSmallEquiv.symm_apply_eq, U.tp, Grpd.comp_eq_comp, - Equiv.apply_symm_apply] - rw! [toCoreAsSmallEquiv_apply_comp_right] - rw [pi.inversion_lam (toCoreAsSmallEquiv A) (toCoreAsSmallEquiv b)] - rfl - -lemma lam_unLam {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) (f : Γ ⟶ U.Tm) - (f_tp : f ≫ U.tp = UPi.Pi B) : UPi.lam (UPi.unLam B f f_tp) = f := by - simp [lam, unLam, toCoreAsSmallEquiv.symm_apply_eq] - erw [toCoreAsSmallEquiv.apply_symm_apply] - rw [pi.lam_inversion] - -end UPi - -def UPi : Model.UnstructuredUniverse.PolymorphicPi U.{v} U.{v} U.{v} where - Pi := UPi.Pi - Pi_comp := UPi.Pi_comp - lam _ b _ := UPi.lam b - lam_comp _ _ _ _ _ _ _ := UPi.lam_comp .. - lam_tp := UPi.lam_tp - unLam := UPi.unLam - unLam_tp := UPi.unLam_tp - unLam_lam := UPi.unLam_lam - lam_unLam := UPi.lam_unLam - -end - -end GroupoidModel From cfdc2259a40dfe26bafa70af14f6382f0428de69 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sat, 1 Nov 2025 17:59:38 -0400 Subject: [PATCH 15/95] need MorphismProperty.HasPullbacksAlong --- .../Comma/Over/Pushforward.lean | 73 + .../Limits/Shapes/Pullback/CommSq.lean | 16 + .../MorphismProperty/Limits.lean | 91 + .../MorphismProperty/OverAdjunction.lean | 373 +++++ .../ForMathlib/CategoryTheory/Polynomial.lean | 1487 +++++++++++++++++ 5 files changed, 2040 insertions(+) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Limits/Shapes/Pullback/CommSq.lean create mode 100644 HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean create mode 100644 HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean new file mode 100644 index 00000000..6e5528eb --- /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 + +noncomputable section + +universe v v₂ u u₂ + +namespace CategoryTheory + +open Category Limits Comonad + +variable {C : Type u} [Category.{v} C] (X : C) +variable {D : Type u₂} [Category.{v₂} D] + +variable {S S' : C} (f : S ⟶ S') [∀ {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 HasPushforwards : Prop := ∀ (X : Over S), HasPushforward f X + +namespace Over + +variable [HasPushforwards 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/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..8b5b657c --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean @@ -0,0 +1,91 @@ +import Mathlib.CategoryTheory.MorphismProperty.Limits + +universe w w' v u + +namespace CategoryTheory + +open Category Limits + +namespace MorphismProperty + +variable {C : Type u} [Category.{v} C] + +section + +variable (P : MorphismProperty C) + +notation E " ⟶("P") " B => (p : E ⟶ B) ×' P p + +/-- `P.HasPullback f` means that all morphisms satisfying morphism property `P` +have pullbacks along `f`. -/ +protected class HasPullback {X Y : C} (f : X ⟶ Y) : Prop where + hasPullback {W} (g : W ⟶ Y) : P g → HasPullback g f := by infer_instance + +variable {P} in +/-- Bundling `g : W ⟶ Y` and `P g` into `g : W ⟶(P) Y` allows for typeclass inference +involving the proposition `P g`. -/ +lemma hasPullback' {X Y : C} {f : X ⟶ Y} + (h : ∀ {W} (g : W ⟶(P) Y), HasPullback g.1 f) : P.HasPullback f where + hasPullback g hg := h ⟨g, hg⟩ + +instance {X Y : C} (f : X ⟶ Y) [P.HasPullback f] {W : C} (g : W ⟶(P) Y) : HasPullback g.1 f := + HasPullback.hasPullback g.1 g.2 + +instance {X Y : C} (f : X ⟶ Y) [∀ {W : C} (h : W ⟶(P) Y), HasPullback h.1 f] : + P.HasPullback f := hasPullback' inferInstance + +instance [P.IsStableUnderBaseChange] {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) + [P.HasPullback f] [P.HasPullback g] : P.HasPullback (f ≫ g) := + hasPullback' <| fun h => + have {W : C} (h : W ⟶(P) Y) : HasPullback h.1 f := inferInstance + IsPullback.hasPullback + (IsPullback.paste_horiz (IsPullback.of_hasPullback + (⟨ (pullback.snd h.1 g) , of_isPullback (IsPullback.of_hasPullback h.1 g) h.2 ⟩ + : (pullback h.1 g) ⟶(P) Y).1 f) + (IsPullback.of_hasPullback h.1 g)) + +instance (priority := 900) [IsStableUnderBaseChange P] : RespectsIso P := by + apply RespectsIso.of_respects_arrow_iso + intro f g e hf + refine MorphismProperty.of_isPullback (IsPullback.of_horiz_isIso (CommSq.mk e.inv.w)) hf + +instance [P.IsStableUnderBaseChange] {X Y Z} + (f : X ⟶ Y) (g : Y ⟶ Z) [P.HasPullback f] [P.HasPullback g] {W} (h : W ⟶(P) Z) : + HasPullback (pullback.snd h.1 g) f := + let p : pullback h.1 g ⟶(P) Y := ⟨pullback.snd h.1 g, pullback_snd _ _ h.2⟩ + have {W} (h : W ⟶(P) Y) : HasPullback h.1 f := inferInstance + inferInstanceAs (HasPullback p.1 f) + +theorem pullback_map' + [IsStableUnderBaseChange P] [P.IsStableUnderComposition] {S X X' Y Y' : C} + {f : X ⟶ S} {g : Y ⟶ S} [∀ {W} (h : W ⟶ S), HasPullback f h] + {f' : X' ⟶ S} {g' : Y' ⟶ S} [∀ {W} (h : W ⟶ S), HasPullback h g'] + {i₁ : X ⟶ X'} {i₂ : Y ⟶ Y'} (h₁ : P i₁) (h₂ : P i₂) + (e₁ : f = i₁ ≫ f') (e₂ : g = i₂ ≫ g') : + P (pullback.map f g f' g' i₁ i₂ (𝟙 _) ((Category.comp_id _).trans e₁) + ((Category.comp_id _).trans e₂)) := by + have inst {W} (h : W ⟶ _): HasPullback h f := hasPullback_symmetry _ _ + have inst {W} (h : W ⟶ _): HasPullback (Over.mk f).hom h := inferInstanceAs (HasPullback f h) + have inst {W} (h : W ⟶ _): HasPullback h (Over.mk f).hom := hasPullback_symmetry _ _ + have : + pullback.map f g f' g' i₁ i₂ (𝟙 _) ((Category.comp_id _).trans e₁) + ((Category.comp_id _).trans e₂) = + ((pullbackSymmetry _ _).hom ≫ + ((Over.pullback _).map (Over.homMk _ e₂.symm : Over.mk g ⟶ Over.mk g')).left) ≫ + (pullbackSymmetry _ _).hom ≫ + ((Over.pullback g').map (Over.homMk _ e₁.symm : Over.mk f ⟶ Over.mk f')).left := by + ext <;> simp + rw [this] + apply P.comp_mem <;> rw [P.cancel_left_of_respectsIso] + · simpa [pullback.map] using baseChange_map _ (Over.homMk _ e₂.symm : Over.mk g ⟶ Over.mk g') h₂ + · simpa [pullback.map] using baseChange_map _ (Over.homMk _ e₁.symm : Over.mk f ⟶ Over.mk f') h₁ + +end + +/-- A morphism property satisfies `ContainsObjects` 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 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..6e9a87e9 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean @@ -0,0 +1,373 @@ +/- +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 Mathlib.CategoryTheory.Comma.Over.Pullback +import Mathlib.CategoryTheory.MorphismProperty.Limits +import HoTTLean.ForMathlib.CategoryTheory.MorphismProperty.Limits + +/-! +# 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`. +We say that `P` is *stable* under pushforward if `Over.pullback` +also is a left adjoint. +We say that `P` is *closed* under pushforward if `Over.pullback` +also is a left adjoint for any `f` satisfying `P`. + +-/ + +namespace CategoryTheory.MorphismProperty + +open Limits + +variable {T : Type*} [Category T] (P Q : MorphismProperty T) [Q.IsMultiplicative] +variable {X Y Z : T} (f : X ⟶ Y) + +section Map + +variable {P} [P.IsStableUnderComposition] (hPf : P f) + +variable {f} + +/-- 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 : 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 {X Y Z : T} {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 {X Y Z : T} {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 + +variable [P.HasPullback f] [P.IsStableUnderBaseChange] [Q.IsStableUnderBaseChange] + +variable {P Q} in +@[simps] +def Over.morphismProperty (f : P.Over Q X) : f.left ⟶(P) X := ⟨ f.hom , f.prop ⟩ + +instance (A : P.Over Q Y) : HasPullback A.hom f := + inferInstanceAs (HasPullback (A.morphismProperty).1 f) + +/-- If `P` and `Q` are stable under base change and pullbacks exist in `T`, +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.morphismProperty.1 f) + (baseChange_obj f A.toComma A.prop) + map {A B} g := Over.homMk (pullback.map _ f _ f g.left (𝟙 _) (𝟙 _) (by simp) (by simp)) + (by simp) (baseChange_map f ⟨g.left, g.right, _⟩ g.prop_hom_left) + +variable {P} {Q} + +instance [P.IsStableUnderBaseChange] {X Y Z} + (f : X ⟶ Y) (g : Y ⟶ Z) [P.HasPullback f] [P.HasPullback g] (A : P.Over Q Z) : + HasPullback (pullback.snd A.hom g) f := + inferInstanceAs <| HasPullback (pullback.snd A.morphismProperty.1 g) f + +lemma Over.hom_pullback_map [∀ {W : T} (h : W ⟶ Y), HasPullback h f] {A B} (g : A ⟶ B) : + Comma.Hom.hom ((Over.pullback P Q f).map g) = + (CategoryTheory.Over.pullback f).map (Comma.Hom.hom g) := by + simp [Over.pullback, CategoryTheory.Over.pullback, pullback.map] + +/-- `Over.pullback` commutes with composition. -/ +@[simps! hom_app_left inv_app_left] +noncomputable def Over.pullbackComp (g : Y ⟶ Z) [P.HasPullback g] + [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 (g : Y ⟶ Z) [P.HasPullback g] + [Q.RespectsIso] (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} +/-- If `f = g`, then base change along `f` is naturally isomorphic to base change along `g`. -/ +noncomputable def Over.pullbackCongr {g : X ⟶ Y} (h : f = g) : + have : P.HasPullback g := by subst h; infer_instance + Over.pullback P Q f ≅ Over.pullback P Q g := + NatIso.ofComponents (fun X ↦ eqToIso (by simp [h])) + +@[reassoc (attr := simp)] +lemma Over.pullbackCongr_hom_app_left_fst {g : X ⟶ Y} (h : f = g) (A : P.Over Q Y) : + have : P.HasPullback g := by subst h; infer_instance + ((Over.pullbackCongr h).hom.app A).left ≫ pullback.fst A.hom g = + pullback.fst A.hom f := by + subst h + simp [pullbackCongr] + +end Pullback + +section Adjunction + +variable [P.IsStableUnderComposition] [P.IsStableUnderBaseChange] + [Q.IsStableUnderBaseChange] [P.HasPullback f] + +/-- `P.Over.map` is left adjoint to `P.Over.pullback` if `f` satisfies `P`. -/ +noncomputable def Over.mapPullbackAdj [Q.HasOfPostcompProperty Q] (hPf : P f) (hQf : Q f) : + Over.map Q hPf ⊣ Over.pullback P Q f := + Adjunction.mkOfHomEquiv + { homEquiv := fun A B ↦ + { toFun := fun 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 := fun 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 := fun h ↦ by + ext + dsimp + ext + · simp + · simpa using h.w.symm } } + +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 abbrev HasPushforward (P : MorphismProperty T) {S S' : T} (f : S ⟶ S') + [∀ {W} (h : W ⟶ S'), HasPullback h f] : Prop := + ∀ {W} (h : W ⟶(P) S), HasPushforward f (.mk h.1) + +/-- 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 abbrev HasPushforwards (P : MorphismProperty T) + (Q : MorphismProperty T) [Q.HasPullbacks] : Prop := + ∀ {S S' : T} (q : S ⟶(Q) S'), P.HasPushforward q.1 + +/-- 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 IsStableUnderPushforward (P : MorphismProperty T) + (Q : MorphismProperty T) [Q.HasPullbacks] : Prop where + of_isPushforward {S S' X Y : T} (q : S ⟶(Q) S') (f : X ⟶(P) S) (g : Y ⟶ S') + (isPushforward : IsPushforward q.1 (.mk f.1) (.mk g)) : P g + +noncomputable section + +/-- 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 (P : MorphismProperty T) + {S S' : T} (q : S ⟶ S') [∀ {W} (h : W ⟶ S'), HasPullback h q] [P.HasPushforward q] : + P.Over ⊤ S ⥤ Over S' := by + refine Functor.PartialRightAdjointSource.lift (Over.forget P ⊤ S) ?_ ⋙ + (CategoryTheory.Over.pullback q).partialRightAdjoint + intro X + let X' : _ ⟶(P) S := ⟨ X.hom , X.prop ⟩ + convert_to ((CategoryTheory.Over.pullback q).op ⋙ + yoneda.obj (CategoryTheory.Over.mk X'.fst)).IsRepresentable + infer_instance + +-- section homEquiv + +-- variable {P} {S S' : T} (q : S ⟶ S') +-- [∀ {W} (h : W ⟶ S'), HasPullback h q] [P.HasPushforward q] {X : Over S'} {Y : P.Over ⊤ S} + +-- /-- 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)`. -/ +-- abbrev pushforwardPartial.homEquiv : +-- (X ⟶ (pushforwardPartial P q).obj Y) ≃ +-- ((CategoryTheory.Over.pullback q).obj X ⟶ Y.toComma) := +-- Functor.partialRightAdjointHomEquiv _ + +-- lemma pushforwardPartial.homEquiv_comp {S S' : T} (q : S ⟶ S') +-- [∀ {W} (h : W ⟶ S'), HasPullback h q] [P.HasPushforward q] {X X' : Over S'} {Y : P.Over ⊤ S} +-- (f : X' ⟶ (pushforwardPartial P q).obj Y) (g : X ⟶ X') : +-- pushforwardPartial.homEquiv q (g ≫ f) = +-- (CategoryTheory.Over.pullback q).map g ≫ pushforwardPartial.homEquiv q f := +-- Functor.partialRightAdjointHomEquiv_comp .. + +-- lemma pushforwardPartial.homEquiv_map_comp {S S' : T} (q : S ⟶ S') +-- [∀ {W} (h : W ⟶ S'), HasPullback h q] [P.HasPushforward q] {X : Over S'} {Y Y' : P.Over ⊤ S} +-- (f : X ⟶ (pushforwardPartial P q).obj Y) (g : Y ⟶ Y') : +-- pushforwardPartial.homEquiv q (f ≫ (P.pushforwardPartial q).map g) = +-- pushforwardPartial.homEquiv q f ≫ g.toCommaMorphism := +-- Functor.partialRightAdjointHomEquiv_map_comp .. + +-- end homEquiv + +/-- 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 {Q : MorphismProperty T} [Q.HasPullbacks] [P.HasPushforwards Q] + [P.IsStableUnderPushforward Q] {S S' : T} (q : S ⟶(Q) S') : P.Over ⊤ S ⥤ P.Over ⊤ S' := + Comma.lift (pushforwardPartial P q.1) (fun X => + let X' : _ ⟶(P) S := ⟨ X.hom , X.prop ⟩ + IsStableUnderPushforward.of_isPushforward q X' _ + (pushforward.isPushforward q.fst (CategoryTheory.Over.mk X'.fst))) + (by simp) (by simp) + +section homEquiv + +variable {P} {Q : MorphismProperty T} [Q.HasPullbacks] [P.HasPushforwards Q] + [P.IsStableUnderPushforward Q] {S S' : T} (q : S ⟶(Q) S') + +/-- 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.1).obj X ⟶ Y.toComma) := + (Functor.partialRightAdjointHomEquiv ..) + +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 q (g ≫ f) = + (CategoryTheory.Over.pullback q.fst).map g ≫ homEquiv q f := + Functor.partialRightAdjointHomEquiv_comp .. + +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 q (f ≫ Comma.Hom.hom ((P.pushforward q).map g)) = + homEquiv q f ≫ Comma.Hom.hom g := + Functor.partialRightAdjointHomEquiv_map_comp .. + +lemma pushforward.homEquiv_symm_comp {X : Over S'} {Y Y' : P.Over ⊤ S} + (f : (CategoryTheory.Over.pullback q.1).obj X ⟶ Y.toComma) (g : Y ⟶ Y') : + (homEquiv q).symm f ≫ Comma.Hom.hom ((P.pushforward q).map g) = + (homEquiv q).symm (f ≫ Comma.Hom.hom g) := + Functor.partialRightAdjointHomEquiv_symm_comp .. + +lemma pushforward.homEquiv_comp_symm {X X' : Over S'} {Y : P.Over ⊤ S} + (f : (CategoryTheory.Over.pullback q.1).obj X' ⟶ Y.toComma) (g : X ⟶ X') : + g ≫ (homEquiv q).symm f = + (homEquiv q).symm ((CategoryTheory.Over.pullback q.fst).map g ≫ f) := + Functor.partialRightAdjointHomEquiv_comp_symm .. + +end homEquiv + +section + +open MorphismProperty.Over + +variable [P.IsStableUnderBaseChange] {S S' : T} (f : S ⟶(Q) S') + [Q.HasPullbacks] [P.HasPushforwards Q] [P.IsStableUnderPushforward Q] + +/-- The `pullback ⊣ pushforward` adjunction. -/ +def pullbackPushforwardAdjunction : pullback P ⊤ f.1 ⊣ pushforward P f := + Adjunction.mkOfHomEquiv { + homEquiv X Y := + calc ((pullback P ⊤ f.1).obj X ⟶ Y) + _ ≃ (((Over.pullback P ⊤ f.fst).obj X).toComma ⟶ Y.toComma) := + (Functor.FullyFaithful.ofFullyFaithful (Over.forget P ⊤ S)).homEquiv + _ ≃ (X.toComma ⟶ ((P.pushforward f).obj Y).toComma) := + (pushforward.homEquiv f).symm + _ ≃ _ := Equiv.cast (by dsimp) -- why? + _ ≃ (X ⟶ (P.pushforward f).obj Y) := + (Functor.FullyFaithful.ofFullyFaithful (Over.forget P ⊤ S')).homEquiv.symm + homEquiv_naturality_left_symm g f := by + simp only [Equiv.trans_def, Equiv.cast_refl, Equiv.trans_refl, + Equiv.symm_trans_apply, Equiv.symm_symm] + erw [Functor.FullyFaithful.homEquiv_apply, Functor.FullyFaithful.homEquiv_symm_apply, + Functor.FullyFaithful.homEquiv_apply, Functor.FullyFaithful.homEquiv_symm_apply, + Functor.map_comp, pushforward.homEquiv_comp] + apply Functor.FullyFaithful.map_injective + (Functor.FullyFaithful.ofFullyFaithful (Over.forget P ⊤ S)) + simp only [Functor.FullyFaithful.map_preimage, Functor.map_comp] + simp only [Comma.forget_obj, Comma.forget_map, hom_pullback_map] + congr 1 + homEquiv_naturality_right f g := by + simp only [Comma.forget_obj, Equiv.trans_def, Equiv.cast_refl, Equiv.trans_refl, + Equiv.trans_apply] + erw [Functor.FullyFaithful.homEquiv_symm_apply, Functor.FullyFaithful.homEquiv_symm_apply, + Functor.FullyFaithful.homEquiv_apply, Functor.FullyFaithful.homEquiv_apply] + apply Functor.FullyFaithful.map_injective + (Functor.FullyFaithful.ofFullyFaithful (Over.forget P ⊤ S')) + simp only [Functor.FullyFaithful.map_preimage, Functor.map_comp] + erw [pushforward.homEquiv_symm_comp] + rfl + } + +instance : (pullback P ⊤ f.1).IsLeftAdjoint := + Adjunction.isLeftAdjoint (pullbackPushforwardAdjunction P Q f) + +instance : (pushforward P f).IsRightAdjoint := + Adjunction.isRightAdjoint (pullbackPushforwardAdjunction P Q 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 [Over.morphismProperty_fst, 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.homEquiv_comp_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/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean new file mode 100644 index 00000000..1cccb853 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -0,0 +1,1487 @@ +/- +Copyright (c) 2025 Joseph Hua. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Joseph Hua, Sina Hazratpour, Emily Riehl +-/ + +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 + +universe v u v₁ u₁ + +noncomputable section + +namespace CategoryTheory + +open Category Limits MorphismProperty + +variable {C : Type u} [Category.{v} C] + +namespace MorphismProperty + +instance : (⊤ : MorphismProperty C).HasOfPostcompProperty ⊤ where + of_postcomp := by simp + +instance (P : MorphismProperty C) {X} : P.HasPullback (𝟙 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])) + +/-- 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.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) + [R.HasPullback h] [R.HasPullback f] [R.HasPullback g] [R.HasPullback k] + (sq : f ≫ k = h ≫ g) : + TwoSquare (MorphismProperty.Over.pullback R ⊤ f) + (MorphismProperty.Over.map ⊤ rk) (MorphismProperty.Over.map ⊤ rh) + (MorphismProperty.Over.pullback R ⊤ g) := + (mateEquiv (MorphismProperty.Over.mapPullbackAdj R ⊤ k rk trivial) + (MorphismProperty.Over.mapPullbackAdj R ⊤ h rh trivial)).symm <| + ((MorphismProperty.Over.pullbackComp _ _).inv ≫ + eqToHom (by rw! [sq]) ≫ + (MorphismProperty.Over.pullbackComp _ _).hom) + +/-- +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 +``` +TODO: in what generality does this theorem hold? +NOTE: we know it holds when `R` is a 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 = ⊤`. +-/ +theorem pullbackMapTwoSquare_isIso {T : Type u} [Category.{v} T] (R : MorphismProperty T) + [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) + [R.HasPullback h] [R.HasPullback f] [R.HasPullback g] [R.HasPullback k] + (pb : IsPullback f h k g) : + NatTrans.IsCartesian <| pullbackMapTwoSquare R h f g k rk rh pb.w := + sorry + +/-- 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] {Q : MorphismProperty T} [Q.HasPullbacks] + [R.HasPushforwards Q] [R.IsStableUnderPushforward Q] {X Y Z W : T} + (h : X ⟶ Z) (f : X ⟶(Q) Y) (g : Z ⟶(Q) W) (k : Y ⟶ W) (sq : h ≫ g.1 = f.1 ≫ k) : + TwoSquare (pushforward (P := R) g) (Over.pullback R ⊤ h) (Over.pullback R ⊤ k) + (pushforward (P := R) f) := + let pullbackTwoSquare : TwoSquare (Over.pullback R ⊤ k) (Over.pullback R ⊤ g.fst) + (Over.pullback R ⊤ f.fst) (Over.pullback R ⊤ h) := + ((Over.pullbackComp _ _).inv ≫ + eqToHom (by rw! [sq]) ≫ + (Over.pullbackComp _ _).hom) + mateEquiv (pullbackPushforwardAdjunction R Q g) + (pullbackPushforwardAdjunction R Q f) + pullbackTwoSquare + +/-- +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.{v} T] (R : MorphismProperty T) + [R.HasPullbacks] [R.IsStableUnderBaseChange] {Q : MorphismProperty T} [Q.HasPullbacks] + [R.HasPushforwards Q] [R.IsStableUnderPushforward Q] + {X Y Z W : T} (h : X ⟶ Z) (f : X ⟶(Q) Y) (g : Z ⟶(Q) W) (k : Y ⟶ W) + (pb : IsPullback h f.1 g.1 k) : IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := + sorry + +/- +Copyright (c) 2025 Wojciech Nawrocki. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Wojciech Nawrocki +-/ + +theorem _root_.CategoryTheory.Functor.reflect_commSq + {C D : Type*} [Category C] [Category D] + (F : C ⥤ D) [Functor.Faithful F] + {X Y Z W : C} {f : X ⟶ Y} {g : X ⟶ Z} {h : Y ⟶ W} {i : Z ⟶ W} : + CommSq (F.map f) (F.map g) (F.map h) (F.map i) → + CommSq f g h i := by + intro cs + constructor + apply Functor.map_injective F + simpa [← Functor.map_comp] using cs.w + +theorem _root_.CategoryTheory.Functor.reflect_isPullback + {C D : Type*} [Category C] [Category D] (F : C ⥤ D) + {X Y Z W : C} (f : X ⟶ Y) (g : X ⟶ Z) (h : Y ⟶ W) (i : Z ⟶ W) + [rl : ReflectsLimit (cospan h i) F] [Functor.Faithful F] : + IsPullback (F.map f) (F.map g) (F.map h) (F.map i) → + IsPullback f g h i := by + intro pb + have sq := F.reflect_commSq pb.toCommSq + apply IsPullback.mk sq + apply rl.reflects + let i := cospanCompIso F h i + apply IsLimit.equivOfNatIsoOfIso i.symm pb.cone _ _ pb.isLimit + let j : + ((Cones.postcompose i.symm.hom).obj pb.cone).pt ≅ + (F.mapCone <| PullbackCone.mk f g sq.w).pt := + Iso.refl _ + apply WalkingCospan.ext j <;> simp +zetaDelta + +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.HasPullback f] (hPf : P f) : IsCartesian (mapPullbackAdj P ⊤ 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, morphismProperty_fst, + Functor.const_obj_obj, map_obj_hom, Equiv.coe_fn_mk, Comma.id_hom, CategoryTheory.Comma.id_left, + id_comp, Adjunction.mk'_counit, Comma.forget_map, homMk_hom, Over.forget_map, Over.homMk_left, + 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] + {Q : MorphismProperty T} [Q.HasPullbacks] [R.HasPushforwards Q] + [R.IsStableUnderPushforward Q] + {E I B : T} (i : E ⟶ I) (p : E ⟶(Q) B) + +/-- 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.1 ⋙ 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.1).obj X ⟶ ((Over.pullback R ⊤ i).obj Y).toComma) := + pushforward.homEquiv .. + _ ≃ ((CategoryTheory.Over.map i).obj + ((CategoryTheory.Over.pullback p.fst).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 homEquiv_comp_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.homEquiv_comp_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 [← homEquiv_comp_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' ⟶(Q) B) (ρ) + (hi : i = ρ ≫ i') (hp : p.1 = ρ ≫ p'.1) : + 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) := + ((Over.pullbackComp ρ i').symm ≪≫ eqToIso (by simp [hi, Functor.id_comp])).hom + let cellRight := pushforwardPullbackTwoSquare (R := R) (Q := Q) ρ p p' (𝟙 _) (by simp [← hp]) + Functor.whiskerLeft (partialRightAdjoint i' p') (Over.pullbackId R ⊤ B).inv ≫ + cellLeft.hComp cellRight + +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 ⟶(P) B) : P.Over ⊤ B where + left := E + right := ⟨⟨⟩⟩ + hom := p.1 + prop := p.2 + +@[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 ⟶(P) O) : + (map ⊤ o.2).obj p ⟶ Over.ofMorphismProperty o := + 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) (H : MorphismProperty C) (I O E B : C) where + (i : E ⟶(R) I) + (p : E ⟶(H) B) + (o : B ⟶(R) O) + +namespace MvPoly + +variable {R : MorphismProperty C} {H : MorphismProperty C} + +instance {B O : C} (i : B ⟶(R) O) [R.HasPullbacks] [R.IsStableUnderBaseChange] + [R.IsStableUnderComposition] : (pullback R ⊤ i.1).IsRightAdjoint := + (mapPullbackAdj R ⊤ i.1 i.2 ⟨⟩).isRightAdjoint + +instance [R.IsStableUnderComposition] {X Y} (f : X ⟶ Y) (hf : R f) : + Limits.PreservesLimitsOfShape WalkingCospan (MorphismProperty.Over.map ⊤ hf) := + sorry + +variable {I O E B : C} (P : MvPoly R H I O E B) [R.HasPullbacks] [R.IsStableUnderBaseChange] + [H.HasPullbacks] [R.HasPushforwards H] + [R.IsStableUnderPushforward H] + +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 (P : MvPoly R H I O E B) (X : R.Over ⊤ I) : R.Over ⊤ B := + (partialRightAdjoint P.i.1 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 (P : MvPoly R H I O E B) (X : R.Over ⊤ I) : + (leftAdjoint P.i.1 P.p).obj (fstProj P X).toComma ⟶ X.toComma := + (counit P.i.1 P.p).app X + +section + +variable (P : MvPoly R H I O E B) {X Y : R.Over ⊤ I} (f : X ⟶ Y) + +@[reassoc (attr := simp)] +lemma map_fstProj : + ((partialRightAdjoint P.i.1 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.1 := by + simp [sndProj] + +lemma sndProj_comp : (sndProj P X).left ≫ f.left = + pullback.map _ _ _ _ + ((partialRightAdjoint P.i.1 P.p).map f).left (𝟙 _) (𝟙 _) (by simp) (by simp) ≫ + (sndProj P Y).left := by + have := congr_arg CommaMorphism.left <| (counit P.i.1 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.1 ⋙ MorphismProperty.pushforward R P.p ⋙ map ⊤ P.o.2 + +/-- The action of a univariate polynomial on objects. -/ +def apply (P : MvPoly R H I O E B) : R.Over ⊤ I → R.Over ⊤ O := (functor P).obj + +@[inherit_doc] +infix:90 " @ " => apply + +namespace Equiv + +variable {P : MvPoly R H I O E B} {Γ : 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.1 P.p).obj (fst pair) + +def snd (pair : Γ ⟶ (P @ X).toComma) : sndDom pair ⟶ X.toComma := + homEquiv P.i.1 P.p (Over.homMk (pair.left)) + +lemma snd_eq (pair : Γ ⟶ (P @ X).toComma) : snd pair = + (leftAdjoint P.i.1 P.p).map (Over.homMk (pair.left)) ≫ sndProj P X := by + erw [Equiv.apply_eq_iff_eq_symm_apply, ← homEquiv_comp_symm] + simp [sndProj, counit] + +def mk (f : Over B) (hf : Γ = (Over.map P.o.1).obj f) + (s : (leftAdjoint P.i.1 P.p).obj f ⟶ X.toComma) : + Γ ⟶ (P @ X).toComma := + eqToHom hf ≫ (Over.map P.o.fst).map ((homEquiv P.i.1 P.p).symm s) + +@[simp] +lemma fst_mk (f : Over B) (hf : Γ = (Over.map P.o.1).obj f) + (s : (leftAdjoint P.i.1 P.p).obj f ⟶ X.toComma) : fst (mk f hf s) = f := by + subst hf; simp [fst, mk]; rfl + +lemma snd_mk (f : Over B) (hf : Γ = (Over.map P.o.1).obj f) + (s : (leftAdjoint P.i.1 P.p).obj f ⟶ X.toComma) : snd (mk f hf s) = + eqToHom (by simp) ≫ s := calc snd (mk f hf s) + _ = (leftAdjoint P.i.1 P.p).map (eqToHom (fst_mk f hf s)) ≫ s := by + erw [Equiv.apply_eq_iff_eq_symm_apply, ← homEquiv_comp_symm] + ext + simp [mk] + _ = eqToHom _ ≫ s := by + simp only [eqToHom_map] + +@[simp] +lemma map_fst (pair : Γ ⟶ (P @ X).toComma) : (Over.map P.o.fst).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 eta (pair : Γ ⟶ (P @ X).toComma) : mk (fst pair) (by simp) (snd pair) = pair := by + ext + simp [mk, snd] + +end Equiv + +instance (X Y) (δ : X ⟶ Y) (rδ : R δ) : (MorphismProperty.Over.pullback R ⊤ δ).IsRightAdjoint := + Adjunction.isRightAdjoint (MorphismProperty.Over.mapPullbackAdj R ⊤ δ rδ trivial) + +-- (MorphismProperty.Over.pullback R ⊤ δ ⋙ MorphismProperty.Over.map ⊤ ⋯) +instance (P : MvPoly R H I O E B) : PreservesLimitsOfShape WalkingCospan + (MorphismProperty.Over.pullback R ⊤ P.i.fst ⋙ R.pushforward P.p ⋙ + MorphismProperty.Over.map ⊤ P.o.2) := + 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.1 +``` +-/ +def verticalNatTrans {F : C} (P : MvPoly R H I O E B) (Q : MvPoly R H I O F B) (ρ : E ⟶ F) + (hi : P.i.1 = ρ ≫ Q.i.1) (hp : P.p.1 = ρ ≫ Q.p.1) (ho : P.o.1 = Q.o.1) : + Q.functor ⟶ P.functor := + (Functor.associator _ _ _).inv ≫ + ((PolynomialPartialAdjunction.partialRightAdjointMap P.i.1 P.p Q.i.1 Q.p ρ hi hp) ◫ + (eqToHom (by rw! [ho]))) ≫ + (Functor.associator _ _ _).hom + +section + +variable {F} (Q : MvPoly R H I O F B) (ρ : E ⟶ F) (hi : P.i.1 = ρ ≫ Q.i.1) + (hp : P.p.1 = ρ ≫ Q.p.1) (ho : P.o.1 = Q.o.1) + +lemma fst_verticalNatTrans_app {Γ} {X} (pair : Γ ⟶ (Q @ X).toComma) : + Equiv.fst (pair ≫ ((verticalNatTrans P Q ρ hi hp ho).app X).hom) = Equiv.fst pair := by + -- simp [verticalNatTrans, partialRightAdjointMap] + -- erw [Category.id_comp] + -- dsimp [Equiv.fst] + -- congr 1 + sorry + +-- lemma snd'_verticalNatTrans_app {Γ} {X} (pair : Γ ⟶ (Q @ X).toComma) : +-- Equiv.snd (pair ≫ ((verticalNatTrans P Q ρ hi hp ho).app X).hom) = +-- --(H.lift f' (g' ≫ ρ) (by simp [H'.w, h])) ≫ +-- sorry ≫ Equiv.snd pair := by +-- 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 H I O E B) (P' : MvPoly R H I O E' B') + (δ : B ⟶ B') (φ : E ⟶ E') (hφ : P.i.1 = φ ≫ P'.i.1) (pb : IsPullback φ P.p.1 P'.p.1 δ) + (hδ : δ ≫ P'.o.1 = P.o.1) : + P.functor ⟶ P'.functor := + let cellLeft : TwoSquare (𝟭 (R.Over ⊤ I)) (MorphismProperty.Over.pullback R ⊤ P'.i.1) + (MorphismProperty.Over.pullback R ⊤ P.i.1) (MorphismProperty.Over.pullback R ⊤ φ) := + (eqToIso (by simp [hφ, Functor.id_comp]) ≪≫ (MorphismProperty.Over.pullbackComp φ P'.i.1)).hom + have : IsIso (pushforwardPullbackTwoSquare (R := R) φ P.p P'.p δ pb.w) := + pushforwardPullbackTwoSquare_isIso R φ P.p P'.p δ pb + let cellMid : TwoSquare (MorphismProperty.Over.pullback R ⊤ φ) + (R.pushforward P'.p) (R.pushforward P.p) (MorphismProperty.Over.pullback R ⊤ δ) := + CategoryTheory.inv (pushforwardPullbackTwoSquare φ P.p P'.p δ pb.w) + let cellRight : TwoSquare (MorphismProperty.Over.pullback R ⊤ δ) + (MorphismProperty.Over.map ⊤ P'.o.2) (MorphismProperty.Over.map ⊤ P.o.2) (𝟭 _) := + (pullbackMapTwoSquare R P.o.1 δ (𝟙 _) P'.o.1 P'.o.2 P.o.2 (by simp [hδ])) ≫ + Functor.whiskerLeft _ (MorphismProperty.Over.pullbackId R ⊤ O).hom + cellLeft ≫ᵥ cellMid ≫ᵥ cellRight + +open NatTrans in +theorem isCartesian_cartesianNatTrans {E' B' : C} (P : MvPoly R H I O E B) (P' : MvPoly R H I O E' B') + (δ : B ⟶ B') (φ : E ⟶ E') (hφ : P.i.1 = φ ≫ P'.i.1) (pb : IsPullback φ P.p.1 P'.p.1 δ) + (hδ : δ ≫ P'.o.1 = P.o.1) : + (cartesianNatTrans P P' δ φ hφ pb hδ).IsCartesian := by + dsimp [cartesianNatTrans] + -- NOTE: this lemma could be extracted, but `repeat' apply IsCartesian.comp` will unfold past it. + -- have : NatTrans.IsCartesian + -- (pullbackMapTwoSquare R P.o.1 δ (𝟙 _) P'.o.1 P'.o.2 P.o.2 (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.o.2) := 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 [R.IsStableUnderComposition] [R.HasPullbacks] [R.IsStableUnderBaseChange] [R.HasObjects] + [R.IsStableUnderPushforward R] [R.HasPushforwards R] + +abbrev morphismProperty' (P : UvPoly R E B) : E ⟶(R) B := ⟨ P.p, P.morphismProperty ⟩ + +instance (P : UvPoly R E B) {Γ : C} (A : Γ ⟶ B) : HasPullback A P.p := by + convert_to HasPullback A (morphismProperty' P).1 + apply MorphismProperty.instHasPullbackFstHomOfHasPullbacks + +instance (P : UvPoly R E B) {Γ : C} (A : Γ ⟶ B) : HasPullback P.p A := + hasPullback_symmetry _ _ + +def object (X : C) : X ⟶(R) (𝟭_ C) := + ⟨ 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 (P : UvPoly R E B) : MvPoly R R (𝟭_ C) (𝟭_ C) E B where + i := object E + p := morphismProperty' P + o := object B + +def functor (P : UvPoly R E B) : C ⥤ C := + toOverTerminal ⋙ + MvPoly.functor P.mvPoly ⋙ + fromOverTerminal + +/-- The action of a univariate polynomial on objects. -/ +def apply [ChosenTerminal C] (P : UvPoly R E B) : 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 ⟩ + +variable {B} + +/-- The fstProjection morphism from `∑ b : B, X ^ (E b)` to `B` again. -/ +def fstProj (P : UvPoly R E B) (X : C) : P @ X ⟶ B := + (P.mvPoly.fstProj (toOverTerminal.obj X)).hom + +@[reassoc (attr := simp)] +lemma map_fstProj (P : UvPoly R E B) {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 (P : UvPoly R E B) (X : C) : + Limits.pullback (fstProj P X) P.p ⟶ X := + (P.mvPoly.sndProj (toOverTerminal.obj X)).left + +lemma sndProj_comp (P : UvPoly R E B) {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} (P : UvPoly R E B) (Q : UvPoly R F B) (ρ : E ⟶ F) + (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 --- > C/E' ----> C/B' -----> C +‖ | | ‖ +‖ ↗ | φ* ≅ | δ* ↗ ‖ +‖ v v ‖ +C --- > C/E -----> C/B -----> C + P.p +``` +-/ +def cartesianNatTrans {E' B' : C} (P : UvPoly R E B) (P' : UvPoly R E' B') + (δ : 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) + +open NatTrans in +theorem isCartesian_cartesianNatTrans {D F : C} (P : UvPoly R E B) (Q : UvPoly R F D) + (δ : 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 E' B' : C} (P : UvPoly R E B) (P' : UvPoly R E' B') : 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 E' B' : C} (P : UvPoly R E B) (P' : UvPoly R E' B') : + 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 : UvPoly R E B} {Γ 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.fst 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 eta (pair : Γ ⟶ P @ X) : + mk (fst pair) (snd pair) = pair := by + have := MvPoly.Equiv.eta (P := P.mvPoly) (Γ := Over.mk (isTerminal.from Γ)) (homMk pair) + exact congr_arg CommaMorphism.left this + +@[simp] +lemma eta' (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 [← eta' pair₁ H, ← eta' 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'} + (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 E' B' : C} {P : UvPoly R E B} {P' : UvPoly R E' B'} + +/- +``` + Γ + | + |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 eta (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.eta' + (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 [← eta triple f g (by convert H; simp [fst_comp_p]) (dependent triple f g H) rfl, + ← eta 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 {E B F : C} (P : UvPoly R E B) (Q : UvPoly R F B) (ρ : 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] 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 From 80cd27c0a1cba2965c882cc0aee109a2ab19a9a8 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Mon, 3 Nov 2025 19:30:29 -0500 Subject: [PATCH 16/95] splitIsofibration --- HoTTLean/ForMathlib.lean | 8 - .../Comma/Over/Pushforward.lean | 2 +- .../MorphismProperty/Limits.lean | 895 +++++++++++++++++- .../MorphismProperty/OverAdjunction.lean | 254 +++-- .../ForMathlib/CategoryTheory/Polynomial.lean | 253 ++--- HoTTLean/Groupoids/SplitIsofibration.lean | 260 +++++ lake-manifest.json | 10 +- lakefile.lean | 2 +- 8 files changed, 1367 insertions(+), 317 deletions(-) create mode 100644 HoTTLean/Groupoids/SplitIsofibration.lean diff --git a/HoTTLean/ForMathlib.lean b/HoTTLean/ForMathlib.lean index 0d1cd8c9..891acc25 100644 --- a/HoTTLean/ForMathlib.lean +++ b/HoTTLean/ForMathlib.lean @@ -624,14 +624,6 @@ lemma Discrete.functor_eq {X C : Type*} [Category C] {F : Discrete X ⥤ C} : 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 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 diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean index 6e5528eb..0f232f58 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean @@ -18,7 +18,7 @@ open Category Limits Comonad variable {C : Type u} [Category.{v} C] (X : C) variable {D : Type u₂} [Category.{v₂} D] -variable {S S' : C} (f : S ⟶ S') [∀ {W} (h : W ⟶ S'), HasPullback h f] +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 diff --git a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean index 8b5b657c..f0bb1b70 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean @@ -1,4 +1,29 @@ -import Mathlib.CategoryTheory.MorphismProperty.Limits +/- +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.Limits.Final +import Mathlib.CategoryTheory.Limits.Connected +import Mathlib.CategoryTheory.Filtered.Connected +import Mathlib.CategoryTheory.Limits.Shapes.Diagonal +import Mathlib.CategoryTheory.MorphismProperty.Composition + +/-! +# 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 @@ -14,61 +39,196 @@ section variable (P : MorphismProperty C) -notation E " ⟶("P") " B => (p : E ⟶ B) ×' P p +/-- Given a class of morphisms `P`, this is the class of pullbacks +of morphisms in `P`. -/ +def pullbacks : MorphismProperty C := fun A B q ↦ + ∃ (X Y : C) (p : X ⟶ Y) (f : A ⟶ X) (g : B ⟶ Y) (_ : P p), + IsPullback f q p g + +lemma pullbacks_mk {A B X Y : C} {f : A ⟶ X} {q : A ⟶ B} {p : X ⟶ Y} {g : B ⟶ Y} + (sq : IsPullback f q p g) (hp : P p) : + P.pullbacks q := + ⟨_, _, _, _, _, hp, sq⟩ + +lemma le_pullbacks : P ≤ P.pullbacks := by + intro A B q hq + exact P.pullbacks_mk IsPullback.of_id_fst hq + +lemma pullbacks_monotone : Monotone (pullbacks (C := C)) := by + rintro _ _ h _ _ _ ⟨_, _, _, _, _, hp, sq⟩ + exact ⟨_, _, _, _, _, h _ hp, sq⟩ + +/-- Given a class of morphisms `P`, this is the class of pushouts +of morphisms in `P`. -/ +def pushouts : MorphismProperty C := fun X Y q ↦ + ∃ (A B : C) (p : A ⟶ B) (f : A ⟶ X) (g : B ⟶ Y) (_ : P p), + IsPushout f p q g + +lemma pushouts_mk {A B X Y : C} {f : A ⟶ X} {q : A ⟶ B} {p : X ⟶ Y} {g : B ⟶ Y} + (sq : IsPushout f q p g) (hq : P q) : + P.pushouts p := + ⟨_, _, _, _, _, hq, sq⟩ + +lemma le_pushouts : P ≤ P.pushouts := by + intro X Y p hp + exact P.pushouts_mk IsPushout.of_id_fst hp + +lemma pushouts_monotone : Monotone (pushouts (C := C)) := by + rintro _ _ h _ _ _ ⟨_, _, _, _, _, hp, sq⟩ + exact ⟨_, _, _, _, _, h _ hp, sq⟩ + +instance : P.pushouts.RespectsIso := + RespectsIso.of_respects_arrow_iso _ (by + rintro q q' e ⟨A, B, p, f, g, hp, h⟩ + exact ⟨A, B, p, f ≫ e.hom.left, g ≫ e.hom.right, hp, + IsPushout.paste_horiz h (IsPushout.of_horiz_isIso ⟨e.hom.w⟩)⟩) + +instance : P.pullbacks.RespectsIso := + RespectsIso.of_respects_arrow_iso _ (by + rintro q q' e ⟨X, Y, p, f, g, hp, h⟩ + exact ⟨X, Y, p, e.inv.left ≫ f, e.inv.right ≫ g, hp, + IsPullback.paste_horiz (IsPullback.of_horiz_isIso ⟨e.inv.w⟩) h⟩) + +/-- If `P : MorphismProperty C` is such that any object in `C` maps to the +target of some morphism in `P`, then `P.pushouts` contains the isomorphisms. -/ +lemma isomorphisms_le_pushouts + (h : ∀ (X : C), ∃ (A B : C) (p : A ⟶ B) (_ : P p) (_ : B ⟶ X), IsIso p) : + isomorphisms C ≤ P.pushouts := by + intro X Y f (_ : IsIso f) + obtain ⟨A, B, p, hp, g, _⟩ := h X + exact ⟨A, B, p, p ≫ g, g ≫ f, hp, (IsPushout.of_id_snd (f := p ≫ g)).of_iso + (Iso.refl _) (Iso.refl _) (asIso p) (asIso f) (by simp) (by simp) (by simp) (by simp)⟩ + +/-- A morphism property is `IsStableUnderBaseChange` if the base change of such a morphism +still falls in the class. -/ +class IsStableUnderBaseChange : Prop where + of_isPullback {X Y Y' S : C} {f : X ⟶ S} {g : Y ⟶ S} {f' : Y' ⟶ Y} {g' : Y' ⟶ X} + (sq : IsPullback f' g' g f) (hg : P g) : P g' + +instance : P.pullbacks.IsStableUnderBaseChange where + of_isPullback := by + rintro _ _ _ _ _ _ _ _ h ⟨_, _, _, _, _, hp, hq⟩ + exact P.pullbacks_mk (h.paste_horiz hq) hp + +/-- A morphism property is `IsStableUnderCobaseChange` if the cobase change of such a morphism +still falls in the class. -/ +class IsStableUnderCobaseChange : Prop where + of_isPushout {A A' B B' : C} {f : A ⟶ A'} {g : A ⟶ B} {f' : B ⟶ B'} {g' : A' ⟶ B'} + (sq : IsPushout g f f' g') (hf : P f) : P f' + +instance : P.pushouts.IsStableUnderCobaseChange where + of_isPushout := by + rintro _ _ _ _ _ _ _ _ h ⟨_, _, _, _, _, hp, hq⟩ + exact P.pushouts_mk (hq.paste_horiz h) hp -/-- `P.HasPullback f` means that all morphisms satisfying morphism property `P` -have pullbacks along `f`. -/ -protected class HasPullback {X Y : C} (f : X ⟶ Y) : Prop where - hasPullback {W} (g : W ⟶ Y) : P g → HasPullback g f := by infer_instance +/-- `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 variable {P} in -/-- Bundling `g : W ⟶ Y` and `P g` into `g : W ⟶(P) Y` allows for typeclass inference -involving the proposition `P g`. -/ -lemma hasPullback' {X Y : C} {f : X ⟶ Y} - (h : ∀ {W} (g : W ⟶(P) Y), HasPullback g.1 f) : P.HasPullback f where - hasPullback g hg := h ⟨g, hg⟩ +lemma of_isPullback [P.IsStableUnderBaseChange] + {X Y Y' S : C} {f : X ⟶ S} {g : Y ⟶ S} {f' : Y' ⟶ Y} {g' : Y' ⟶ X} + (sq : IsPullback f' g' g f) (hg : P g) : P g' := + IsStableUnderBaseChange.of_isPullback sq hg -instance {X Y : C} (f : X ⟶ Y) [P.HasPullback f] {W : C} (g : W ⟶(P) Y) : HasPullback g.1 f := - HasPullback.hasPullback g.1 g.2 +lemma isStableUnderBaseChange_iff_pullbacks_le : + P.IsStableUnderBaseChange ↔ P.pullbacks ≤ P := by + constructor + · intro h _ _ _ ⟨_, _, _, _, _, h₁, h₂⟩ + exact of_isPullback h₂ h₁ + · intro h + constructor + intro _ _ _ _ _ _ _ _ h₁ h₂ + exact h _ ⟨_, _, _, _, _, h₂, h₁⟩ -instance {X Y : C} (f : X ⟶ Y) [∀ {W : C} (h : W ⟶(P) Y), HasPullback h.1 f] : - P.HasPullback f := hasPullback' inferInstance +lemma pullbacks_le [P.IsStableUnderBaseChange] : P.pullbacks ≤ P := by + rwa [← isStableUnderBaseChange_iff_pullbacks_le] -instance [P.IsStableUnderBaseChange] {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) - [P.HasPullback f] [P.HasPullback g] : P.HasPullback (f ≫ g) := - hasPullback' <| fun h => - have {W : C} (h : W ⟶(P) Y) : HasPullback h.1 f := inferInstance - IsPullback.hasPullback - (IsPullback.paste_horiz (IsPullback.of_hasPullback - (⟨ (pullback.snd h.1 g) , of_isPullback (IsPullback.of_hasPullback h.1 g) h.2 ⟩ - : (pullback h.1 g) ⟶(P) Y).1 f) - (IsPullback.of_hasPullback h.1 g)) - -instance (priority := 900) [IsStableUnderBaseChange P] : RespectsIso P := by +variable {P} in +/-- Alternative constructor for `IsStableUnderBaseChange`. -/ +theorem IsStableUnderBaseChange.mk' [RespectsIso P] + (hP₂ : ∀ (X Y S : C) (f : X ⟶ S) (g : Y ⟶ S) [HasPullback f g] (_ : P g), + P (pullback.fst f g)) : + IsStableUnderBaseChange P where + of_isPullback {X Y Y' S f g f' g'} sq hg := by + haveI : HasPullback f g := sq.flip.hasPullback + let e := sq.flip.isoPullback + rw [← P.cancel_left_of_respectsIso e.inv, sq.flip.isoPullback_inv_fst] + exact hP₂ _ _ _ f g hg + +variable (C) + +instance IsStableUnderBaseChange.isomorphisms : + (isomorphisms C).IsStableUnderBaseChange where + of_isPullback {_ _ _ _ f g _ _} h hg := + have : IsIso g := hg + have := hasPullback_of_left_iso g f + h.isoPullback_hom_snd ▸ inferInstanceAs (IsIso _) + +instance IsStableUnderBaseChange.monomorphisms : + (monomorphisms C).IsStableUnderBaseChange where + of_isPullback {X Y Y' S f g f' g'} h hg := by + have : Mono g := hg + constructor + intro Z f₁ f₂ h₁₂ + apply PullbackCone.IsLimit.hom_ext h.isLimit + · rw [← cancel_mono g] + dsimp + simp only [Category.assoc, h.w, reassoc_of% h₁₂] + · exact h₁₂ + +variable {C P} + +instance (priority := 900) IsStableUnderBaseChange.respectsIso + [IsStableUnderBaseChange P] : RespectsIso P := by apply RespectsIso.of_respects_arrow_iso - intro f g e hf - refine MorphismProperty.of_isPullback (IsPullback.of_horiz_isIso (CommSq.mk e.inv.w)) hf - -instance [P.IsStableUnderBaseChange] {X Y Z} - (f : X ⟶ Y) (g : Y ⟶ Z) [P.HasPullback f] [P.HasPullback g] {W} (h : W ⟶(P) Z) : - HasPullback (pullback.snd h.1 g) f := - let p : pullback h.1 g ⟶(P) Y := ⟨pullback.snd h.1 g, pullback_snd _ _ h.2⟩ - have {W} (h : W ⟶(P) Y) : HasPullback h.1 f := inferInstance - inferInstanceAs (HasPullback p.1 f) - -theorem pullback_map' - [IsStableUnderBaseChange P] [P.IsStableUnderComposition] {S X X' Y Y' : C} - {f : X ⟶ S} {g : Y ⟶ S} [∀ {W} (h : W ⟶ S), HasPullback f h] - {f' : X' ⟶ S} {g' : Y' ⟶ S} [∀ {W} (h : W ⟶ S), HasPullback h g'] - {i₁ : X ⟶ X'} {i₂ : Y ⟶ Y'} (h₁ : P i₁) (h₂ : P i₂) + intro f g e + exact of_isPullback (IsPullback.of_horiz_isIso (CommSq.mk e.inv.w)) + +theorem pullback_fst [IsStableUnderBaseChange P] + {X Y S : C} (f : X ⟶ S) (g : Y ⟶ S) [HasPullback f g] (H : P g) : + P (pullback.fst f g) := + of_isPullback (IsPullback.of_hasPullback f g).flip H + +theorem pullback_snd [IsStableUnderBaseChange P] + {X Y S : C} (f : X ⟶ S) (g : Y ⟶ S) [HasPullback f g] (H : P f) : + P (pullback.snd f g) := + of_isPullback (IsPullback.of_hasPullback f g) H + +theorem baseChange_obj [IsStableUnderBaseChange P] {S S' : C} (f : S' ⟶ S) + [HasPullbacksAlong f] (X : Over S) (H : P X.hom) : + P ((Over.pullback f).obj X).hom := + pullback_snd X.hom f H + +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 + +theorem baseChange_map [IsStableUnderBaseChange P] {S S' : C} (f : S' ⟶ S) + [HasPullbacksAlong f] {X Y : Over S} (g : X ⟶ Y) (H : P g.left) : + P ((Over.pullback f).map g).left := by + dsimp only [Over.pullback_obj_left, Over.pullback_map_left] + convert baseChange_map' f (g.w.symm) H <;> simp + +local instance {S X Y : C} {f : X ⟶ S} [HasPullbacksAlong f] {g : Y ⟶ S} : + HasPullback f g := hasPullback_symmetry g f + +theorem pullback_map + [IsStableUnderBaseChange P] [P.IsStableUnderComposition] {S X X' Y Y' : C} {f : X ⟶ S} + [HasPullbacksAlong f] {g : Y ⟶ S} {f' : X' ⟶ S} {g' : Y' ⟶ S} {i₁ : X ⟶ X'} + [HasPullbacksAlong g'] {i₂ : Y ⟶ Y'} (h₁ : P i₁) (h₂ : P i₂) (e₁ : f = i₁ ≫ f') (e₂ : g = i₂ ≫ g') : P (pullback.map f g f' g' i₁ i₂ (𝟙 _) ((Category.comp_id _).trans e₁) ((Category.comp_id _).trans e₂)) := by - have inst {W} (h : W ⟶ _): HasPullback h f := hasPullback_symmetry _ _ - have inst {W} (h : W ⟶ _): HasPullback (Over.mk f).hom h := inferInstanceAs (HasPullback f h) - have inst {W} (h : W ⟶ _): HasPullback h (Over.mk f).hom := hasPullback_symmetry _ _ - have : - pullback.map f g f' g' i₁ i₂ (𝟙 _) ((Category.comp_id _).trans e₁) + have : HasPullbacksAlong (Over.mk f).hom := by aesop_cat + have : pullback.map f g f' g' i₁ i₂ (𝟙 _) ((Category.comp_id _).trans e₁) ((Category.comp_id _).trans e₂) = ((pullbackSymmetry _ _).hom ≫ ((Over.pullback _).map (Over.homMk _ e₂.symm : Over.mk g ⟶ Over.mk g')).left) ≫ @@ -77,15 +237,654 @@ theorem pullback_map' ext <;> simp rw [this] apply P.comp_mem <;> rw [P.cancel_left_of_respectsIso] - · simpa [pullback.map] using baseChange_map _ (Over.homMk _ e₂.symm : Over.mk g ⟶ Over.mk g') h₂ - · simpa [pullback.map] using baseChange_map _ (Over.homMk _ e₁.symm : Over.mk f ⟶ Over.mk f') h₁ + exacts [baseChange_map _ (Over.homMk _ e₂.symm : Over.mk g ⟶ Over.mk g') h₂, + baseChange_map _ (Over.homMk _ e₁.symm : Over.mk f ⟶ Over.mk f') h₁] + +instance IsStableUnderBaseChange.hasOfPostcompProperty_monomorphisms + [P.IsStableUnderBaseChange] : P.HasOfPostcompProperty (MorphismProperty.monomorphisms C) where + of_postcomp {X Y Z} f g (hg : Mono g) hcomp := by + have : f = (asIso (pullback.fst (f ≫ g) g)).inv ≫ pullback.snd (f ≫ g) g := by + simp [← cancel_mono g, pullback.condition] + rw [this, cancel_left_of_respectsIso (P := P)] + exact P.pullback_snd _ _ hcomp + +lemma of_isPushout [P.IsStableUnderCobaseChange] + {A A' B B' : C} {f : A ⟶ A'} {g : A ⟶ B} {f' : B ⟶ B'} {g' : A' ⟶ B'} + (sq : IsPushout g f f' g') (hf : P f) : P f' := + IsStableUnderCobaseChange.of_isPushout sq hf + +lemma isStableUnderCobaseChange_iff_pushouts_le : + P.IsStableUnderCobaseChange ↔ P.pushouts ≤ P := by + constructor + · intro h _ _ _ ⟨_, _, _, _, _, h₁, h₂⟩ + exact of_isPushout h₂ h₁ + · intro h + constructor + intro _ _ _ _ _ _ _ _ h₁ h₂ + exact h _ ⟨_, _, _, _, _, h₂, h₁⟩ + +lemma pushouts_le [P.IsStableUnderCobaseChange] : P.pushouts ≤ P := by + rwa [← isStableUnderCobaseChange_iff_pushouts_le] + +@[simp] +lemma pushouts_le_iff {P Q : MorphismProperty C} [Q.IsStableUnderCobaseChange] : + P.pushouts ≤ Q ↔ P ≤ Q := by + constructor + · exact le_trans P.le_pushouts + · intro h + exact le_trans (pushouts_monotone h) pushouts_le + +/-- An alternative constructor for `IsStableUnderCobaseChange`. -/ +theorem IsStableUnderCobaseChange.mk' [RespectsIso P] + (hP₂ : ∀ (A B A' : C) (f : A ⟶ A') (g : A ⟶ B) [HasPushout f g] (_ : P f), + P (pushout.inr f g)) : + IsStableUnderCobaseChange P where + of_isPushout {A A' B B' f g f' g'} sq hf := by + haveI : HasPushout f g := sq.flip.hasPushout + let e := sq.flip.isoPushout + rw [← P.cancel_right_of_respectsIso _ e.hom, sq.flip.inr_isoPushout_hom] + exact hP₂ _ _ _ f g hf + +instance IsStableUnderCobaseChange.isomorphisms : + (isomorphisms C).IsStableUnderCobaseChange where + of_isPushout {_ _ _ _ f g _ _} h (_ : IsIso f) := + have := hasPushout_of_right_iso g f + h.inl_isoPushout_inv ▸ inferInstanceAs (IsIso _) + +variable (C) in +instance IsStableUnderCobaseChange.epimorphisms : + (epimorphisms C).IsStableUnderCobaseChange where + of_isPushout {X Y Y' S f g f' g'} h hf := by + have : Epi f := hf + constructor + intro Z f₁ f₂ h₁₂ + apply PushoutCocone.IsColimit.hom_ext h.isColimit + · exact h₁₂ + · rw [← cancel_epi f] + dsimp + simp only [← reassoc_of% h.w, h₁₂] + +instance IsStableUnderCobaseChange.respectsIso + [IsStableUnderCobaseChange P] : RespectsIso P := + RespectsIso.of_respects_arrow_iso _ fun _ _ e ↦ + of_isPushout (IsPushout.of_horiz_isIso (CommSq.mk e.hom.w)) + +theorem pushout_inl [IsStableUnderCobaseChange P] + {A B A' : C} (f : A ⟶ A') (g : A ⟶ B) [HasPushout f g] (H : P g) : + P (pushout.inl f g) := + of_isPushout (IsPushout.of_hasPushout f g) H + +theorem pushout_inr [IsStableUnderCobaseChange P] + {A B A' : C} (f : A ⟶ A') (g : A ⟶ B) [HasPushout f g] (H : P f) : P (pushout.inr f g) := + of_isPushout (IsPushout.of_hasPushout f g).flip H + +instance IsStableUnderCobaseChange.hasOfPrecompProperty_epimorphisms + [P.IsStableUnderCobaseChange] : P.HasOfPrecompProperty (MorphismProperty.epimorphisms C) where + of_precomp {X Y Z} f g (hf : Epi f) hcomp := by + have : g = pushout.inr (f ≫ g) f ≫ (asIso (pushout.inl (f ≫ g) f)).inv := by + rw [asIso_inv, IsIso.eq_comp_inv, ← cancel_epi f, ← pushout.condition, assoc] + rw [this, cancel_right_of_respectsIso (P := P)] + exact P.pushout_inr _ _ hcomp + +instance IsStableUnderCobaseChange.op [IsStableUnderCobaseChange P] : + IsStableUnderBaseChange P.op where + of_isPullback sq hg := P.of_isPushout sq.unop hg + +instance IsStableUnderCobaseChange.unop {P : MorphismProperty Cᵒᵖ} [IsStableUnderCobaseChange P] : + IsStableUnderBaseChange P.unop where + of_isPullback sq hg := P.of_isPushout sq.op hg + +instance IsStableUnderBaseChange.op [IsStableUnderBaseChange P] : + IsStableUnderCobaseChange P.op where + of_isPushout sq hf := P.of_isPullback sq.unop hf + +instance IsStableUnderBaseChange.unop {P : MorphismProperty Cᵒᵖ} [IsStableUnderBaseChange P] : + IsStableUnderCobaseChange P.unop where + of_isPushout sq hf := P.of_isPullback sq.op hf + +instance IsStableUnderBaseChange.inf {P Q : MorphismProperty C} [IsStableUnderBaseChange P] + [IsStableUnderBaseChange Q] : + IsStableUnderBaseChange (P ⊓ Q) where + of_isPullback hp hg := ⟨of_isPullback hp hg.left, of_isPullback hp hg.right⟩ + +instance IsStableUnderCobaseChange.inf {P Q : MorphismProperty C} [IsStableUnderCobaseChange P] + [IsStableUnderCobaseChange Q] : + IsStableUnderCobaseChange (P ⊓ Q) where + of_isPushout hp hg := ⟨of_isPushout hp hg.left, of_isPushout hp hg.right⟩ + +instance : (⊤ : MorphismProperty C).IsStableUnderBaseChange where + of_isPullback _ _ := trivial + +instance : (⊤ : MorphismProperty C).IsStableUnderCobaseChange where + of_isPushout _ _ := trivial end +section LimitsOfShape + +variable (W : MorphismProperty C) (J : Type*) [Category J] + +/-- The class of morphisms in `C` that are limits of shape `J` of +natural transformations involving morphisms in `W`. -/ +inductive limitsOfShape : MorphismProperty C + | mk (X₁ X₂ : J ⥤ C) (c₁ : Cone X₁) (c₂ : Cone X₂) + (_ : IsLimit c₁) (h₂ : IsLimit c₂) (f : X₁ ⟶ X₂) (_ : W.functorCategory J f) : + limitsOfShape (h₂.lift (Cone.mk _ (c₁.π ≫ f))) + +variable {W J} in +lemma limitsOfShape.mk' (X₁ X₂ : J ⥤ C) (c₁ : Cone X₁) (c₂ : Cone X₂) + (h₁ : IsLimit c₁) (h₂ : IsLimit c₂) (f : X₁ ⟶ X₂) (hf : W.functorCategory J f) + (φ : c₁.pt ⟶ c₂.pt) (hφ : ∀ j, φ ≫ c₂.π.app j = c₁.π.app j ≫ f.app j) : + W.limitsOfShape J φ := by + obtain rfl : φ = h₂.lift (Cone.mk _ (c₁.π ≫ f)) := h₂.hom_ext (fun j ↦ by simp [hφ]) + exact ⟨_, _, _, _, h₁, _, _, hf⟩ + +lemma limitsOfShape_monotone {W₁ W₂ : MorphismProperty C} (h : W₁ ≤ W₂) + (J : Type*) [Category J] : + W₁.limitsOfShape J ≤ W₂.limitsOfShape J := by + rintro _ _ _ ⟨_, _, _, _, h₁, _, f, hf⟩ + exact ⟨_, _, _, _, h₁, _, f, fun j ↦ h _ (hf j)⟩ + +instance : (W.limitsOfShape J).RespectsIso := + RespectsIso.of_respects_arrow_iso _ (by + rintro ⟨_, _, f⟩ ⟨Y₁, Y₂, g⟩ e ⟨X₁, X₂, c₁, c₂, h₁, h₂, f, hf⟩ + let e₁ := Arrow.leftFunc.mapIso e + let e₂ := Arrow.rightFunc.mapIso e + have fac : g ≫ e₂.inv = e₁.inv ≫ h₂.lift (Cone.mk _ (c₁.π ≫ f)) := + e.inv.w.symm + let c₁' : Cone X₁ := { pt := Y₁, π := (Functor.const _).map e₁.inv ≫ c₁.π } + let c₂' : Cone X₂ := { pt := Y₂, π := (Functor.const _).map e₂.inv ≫ c₂.π } + have h₁' : IsLimit c₁' := IsLimit.ofIsoLimit h₁ (Cones.ext e₁) + have h₂' : IsLimit c₂' := IsLimit.ofIsoLimit h₂ (Cones.ext e₂) + obtain hg : h₂'.lift (Cone.mk _ (c₁'.π ≫ f)) = g := + h₂'.hom_ext (fun j ↦ by + rw [h₂'.fac] + simp [reassoc_of% fac, c₁', c₂']) + rw [← hg] + exact ⟨_, _, _, _, h₁', _, _, hf⟩) + +variable {W J} in +lemma limitsOfShape_limMap {X Y : J ⥤ C} + (f : X ⟶ Y) [HasLimit X] [HasLimit Y] (hf : W.functorCategory _ f) : + W.limitsOfShape J (limMap f) := + ⟨_, _, _, _, limit.isLimit X, _, _, hf⟩ + +/-- The property that a morphism property `W` is stable under limits +indexed by a category `J`. -/ +class IsStableUnderLimitsOfShape : Prop where + condition (X₁ X₂ : J ⥤ C) (c₁ : Cone X₁) (c₂ : Cone X₂) + (_ : IsLimit c₁) (h₂ : IsLimit c₂) (f : X₁ ⟶ X₂) (_ : W.functorCategory J f) + (φ : c₁.pt ⟶ c₂.pt) (hφ : ∀ j, φ ≫ c₂.π.app j = c₁.π.app j ≫ f.app j) : W φ + +lemma isStableUnderLimitsOfShape_iff_limitsOfShape_le : + W.IsStableUnderLimitsOfShape J ↔ W.limitsOfShape J ≤ W := by + constructor + · rintro h _ _ _ ⟨_, _, _, _, h₁, h₂, f, hf⟩ + exact h.condition _ _ _ _ h₁ h₂ f hf _ (by simp) + · rintro h + constructor + intro X₁ X₂ c₁ c₂ h₁ h₂ f hf φ hφ + exact h _ (limitsOfShape.mk' X₁ X₂ c₁ c₂ h₁ h₂ f hf φ hφ) + +variable {W J} + +lemma limitsOfShape_le [W.IsStableUnderLimitsOfShape J] : + W.limitsOfShape J ≤ W := by + rwa [← isStableUnderLimitsOfShape_iff_limitsOfShape_le] + +protected lemma limMap [W.IsStableUnderLimitsOfShape J] {X Y : J ⥤ C} + (f : X ⟶ Y) [HasLimit X] [HasLimit Y] (hf : W.functorCategory _ f) : + W (limMap f) := + limitsOfShape_le _ (limitsOfShape_limMap _ hf) + +@[deprecated (since := "2025-05-11")] alias IsStableUnderLimitsOfShape.limitsOfShape_le := + limitsOfShape_le + +@[deprecated (since := "2025-05-11")] alias IsStableUnderLimitsOfShape.limMap := + MorphismProperty.limMap + +end LimitsOfShape + +section ColimitsOfShape + +variable (W : MorphismProperty C) (J : Type*) [Category J] + +/-- The class of morphisms in `C` that are colimits of shape `J` of +natural transformations involving morphisms in `W`. -/ +inductive colimitsOfShape : MorphismProperty C + | mk (X₁ X₂ : J ⥤ C) (c₁ : Cocone X₁) (c₂ : Cocone X₂) + (h₁ : IsColimit c₁) (h₂ : IsColimit c₂) (f : X₁ ⟶ X₂) (_ : W.functorCategory J f) : + colimitsOfShape (h₁.desc (Cocone.mk _ (f ≫ c₂.ι))) + +variable {W J} in +lemma colimitsOfShape.mk' (X₁ X₂ : J ⥤ C) (c₁ : Cocone X₁) (c₂ : Cocone X₂) + (h₁ : IsColimit c₁) (h₂ : IsColimit c₂) (f : X₁ ⟶ X₂) (hf : W.functorCategory J f) + (φ : c₁.pt ⟶ c₂.pt) (hφ : ∀ j, c₁.ι.app j ≫ φ = f.app j ≫ c₂.ι.app j) : + W.colimitsOfShape J φ := by + obtain rfl : φ = h₁.desc (Cocone.mk _ (f ≫ c₂.ι)) := h₁.hom_ext (fun j ↦ by simp [hφ]) + exact ⟨_, _, _, _, _, h₂, _, hf⟩ + +lemma colimitsOfShape_monotone {W₁ W₂ : MorphismProperty C} (h : W₁ ≤ W₂) + (J : Type*) [Category J] : + W₁.colimitsOfShape J ≤ W₂.colimitsOfShape J := by + rintro _ _ _ ⟨_, _, _, _, _, h₂, f, hf⟩ + exact ⟨_, _, _, _, _, h₂, f, fun j ↦ h _ (hf j)⟩ + +variable {J} in +lemma colimitsOfShape_le_of_final {J' : Type*} [Category J'] (F : J ⥤ J') [F.Final] : + W.colimitsOfShape J' ≤ W.colimitsOfShape J := by + intro _ _ _ ⟨X₁, X₂, c₁, c₂, h₁, h₂, f, hf⟩ + have h₁' : IsColimit (c₁.whisker F) := (Functor.Final.isColimitWhiskerEquiv F c₁).symm h₁ + have h₂' : IsColimit (c₂.whisker F) := (Functor.Final.isColimitWhiskerEquiv F c₂).symm h₂ + have : h₁.desc (Cocone.mk c₂.pt (f ≫ c₂.ι)) = + h₁'.desc (Cocone.mk c₂.pt (Functor.whiskerLeft _ f ≫ (c₂.whisker F).ι)) := + h₁'.hom_ext (fun j ↦ by + have := h₁'.fac (Cocone.mk c₂.pt (Functor.whiskerLeft F f ≫ Functor.whiskerLeft F c₂.ι)) j + dsimp at this ⊢ + simp [this]) + rw [this] + exact ⟨_, _, _, _, h₁', h₂', _, fun _ ↦ hf _⟩ + +variable {J} in +lemma colimitsOfShape_eq_of_equivalence {J' : Type*} [Category J'] (e : J ≌ J') : + W.colimitsOfShape J = W.colimitsOfShape J' := + le_antisymm (W.colimitsOfShape_le_of_final e.inverse) + (W.colimitsOfShape_le_of_final e.functor) + +instance : (W.colimitsOfShape J).RespectsIso := + RespectsIso.of_respects_arrow_iso _ (by + rintro ⟨_, _, f⟩ ⟨Y₁, Y₂, g⟩ e ⟨X₁, X₂, c₁, c₂, h₁, h₂, f, hf⟩ + let e₁ := Arrow.leftFunc.mapIso e + let e₂ := Arrow.rightFunc.mapIso e + have fac : e₁.hom ≫ g = h₁.desc (Cocone.mk _ (f ≫ c₂.ι)) ≫ e₂.hom := e.hom.w + let c₁' : Cocone X₁ := { pt := Y₁, ι := c₁.ι ≫ (Functor.const _).map e₁.hom} + let c₂' : Cocone X₂ := { pt := Y₂, ι := c₂.ι ≫ (Functor.const _).map e₂.hom} + have h₁' : IsColimit c₁' := IsColimit.ofIsoColimit h₁ (Cocones.ext e₁) + have h₂' : IsColimit c₂' := IsColimit.ofIsoColimit h₂ (Cocones.ext e₂) + obtain hg : h₁'.desc (Cocone.mk _ (f ≫ c₂'.ι)) = g := + h₁'.hom_ext (fun j ↦ by + rw [h₁'.fac] + simp [fac, c₁', c₂']) + rw [← hg] + exact ⟨_, _, _, _, _, h₂', _, hf⟩) + +variable {W J} in +lemma colimitsOfShape_colimMap {X Y : J ⥤ C} + (f : X ⟶ Y) [HasColimit X] [HasColimit Y] (hf : W.functorCategory _ f) : + W.colimitsOfShape J (colimMap f) := + ⟨_, _, _, _, _, colimit.isColimit Y, _, hf⟩ + +attribute [local instance] IsCofiltered.isConnected in +variable {W} in +lemma colimitsOfShape.of_isColimit + {J : Type*} [Preorder J] [OrderBot J] {F : J ⥤ C} + {c : Cocone F} (hc : IsColimit c) (h : ∀ (j : J), W (F.map (homOfLE bot_le : ⊥ ⟶ j))) : + W.colimitsOfShape J (c.ι.app ⊥) := + .mk' _ _ _ _ (isColimitConstCocone J (F.obj ⊥)) hc + { app k := F.map (homOfLE bot_le) + naturality _ _ _ := by + dsimp + rw [Category.id_comp, ← Functor.map_comp] + rfl} h _ (by simp) + +/-- The property that a morphism property `W` is stable under colimits +indexed by a category `J`. -/ +class IsStableUnderColimitsOfShape : Prop where + condition (X₁ X₂ : J ⥤ C) (c₁ : Cocone X₁) (c₂ : Cocone X₂) + (h₁ : IsColimit c₁) (h₁ : IsColimit c₂) (f : X₁ ⟶ X₂) (_ : W.functorCategory J f) + (φ : c₁.pt ⟶ c₂.pt) (hφ : ∀ j, c₁.ι.app j ≫ φ = f.app j ≫ c₂.ι.app j) : W φ + +lemma isStableUnderColimitsOfShape_iff_colimitsOfShape_le : + W.IsStableUnderColimitsOfShape J ↔ W.colimitsOfShape J ≤ W := by + constructor + · rintro h _ _ _ ⟨_, _, _, _, h₁, h₂, f, hf⟩ + exact h.condition _ _ _ _ h₁ h₂ f hf _ (by simp) + · rintro h + constructor + intro X₁ X₂ c₁ c₂ h₁ h₂ f hf φ hφ + exact h _ (colimitsOfShape.mk' X₁ X₂ c₁ c₂ h₁ h₂ f hf φ hφ) + +variable {W J} + +lemma colimitsOfShape_le [W.IsStableUnderColimitsOfShape J] : + W.colimitsOfShape J ≤ W := by + rwa [← isStableUnderColimitsOfShape_iff_colimitsOfShape_le] + +protected lemma colimMap [W.IsStableUnderColimitsOfShape J] {X Y : J ⥤ C} + (f : X ⟶ Y) [HasColimit X] [HasColimit Y] (hf : W.functorCategory _ f) : + W (colimMap f) := + colimitsOfShape_le _ (colimitsOfShape_colimMap _ hf) + +@[deprecated (since := "2025-05-11")] alias IsStableUnderColimitsOfShape.colimMap := + MorphismProperty.colimMap + +@[deprecated (since := "2025-05-11")] alias IsStableUnderColimitsOfShape.colimitsOfShape_le := + colimitsOfShape_le + +variable (C J) in +instance IsStableUnderColimitsOfShape.isomorphisms : + (isomorphisms C).IsStableUnderColimitsOfShape J where + condition F₁ F₂ c₁ c₂ h₁ h₂ f (_ : ∀ j, IsIso (f.app j)) φ hφ := by + have := NatIso.isIso_of_isIso_app f + exact ⟨h₂.desc (Cocone.mk _ (inv f ≫ c₁.ι)), + h₁.hom_ext (fun j ↦ by simp [reassoc_of% (hφ j)]), + h₂.hom_ext (by simp [hφ])⟩ + +end ColimitsOfShape + +/-- The condition that a property of morphisms is stable by filtered colimits. -/ +@[pp_with_univ] +class IsStableUnderFilteredColimits (W : MorphismProperty C) : Prop where + isStableUnderColimitsOfShape (J : Type w') [Category.{w} J] [IsFiltered J] : + W.IsStableUnderColimitsOfShape J := by infer_instance + +attribute [instance] IsStableUnderFilteredColimits.isStableUnderColimitsOfShape + +instance : IsStableUnderFilteredColimits.{w, w'} (isomorphisms C) where + +section Coproducts + +variable (W : MorphismProperty C) + +/-- Given `W : MorphismProperty C`, this is class of morphisms that are +isomorphic to a coproduct of a family (indexed by some `J : Type w`) of maps in `W`. -/ +@[pp_with_univ] +def coproducts : MorphismProperty C := ⨆ (J : Type w), W.colimitsOfShape (Discrete J) + +lemma colimitsOfShape_le_coproducts (J : Type w) : + W.colimitsOfShape (Discrete J) ≤ coproducts.{w} W := + le_iSup (f := fun (J : Type w) ↦ W.colimitsOfShape (Discrete J)) J + +lemma coproducts_iff {X Y : C} (f : X ⟶ Y) : + coproducts.{w} W f ↔ ∃ (J : Type w), W.colimitsOfShape (Discrete J) f := by + simp only [coproducts, iSup_iff] + +lemma coproducts_of_small {X Y : C} (f : X ⟶ Y) {J : Type w'} + (hf : W.colimitsOfShape (Discrete J) f) [Small.{w} J] : + coproducts.{w} W f := by + rw [coproducts_iff] + refine ⟨Shrink J, ?_⟩ + rwa [← W.colimitsOfShape_eq_of_equivalence (Discrete.equivalence (equivShrink.{w} J))] + +lemma le_colimitsOfShape_punit : W ≤ W.colimitsOfShape (Discrete PUnit.{w + 1}) := by + intro X₁ X₂ f hf + have h := initialIsInitial (C := Discrete (PUnit.{w + 1})) + let c₁ := coconeOfDiagramInitial (F := Discrete.functor (fun _ ↦ X₁)) h + let c₂ := coconeOfDiagramInitial (F := Discrete.functor (fun _ ↦ X₂)) h + have hc₁ : IsColimit c₁ := colimitOfDiagramInitial h _ + have hc₂ : IsColimit c₂ := colimitOfDiagramInitial h _ + have : hc₁.desc (Cocone.mk _ (Discrete.natTrans (fun _ ↦ by exact f) ≫ c₂.ι)) = f := + hc₁.hom_ext (fun x ↦ by + obtain rfl : x = ⊥_ _ := by ext + rw [IsColimit.fac] + simp [c₁, c₂]) + rw [← this] + exact ⟨_, _, _, _, _, hc₂, _, fun _ ↦ hf⟩ + +lemma le_coproducts : W ≤ coproducts.{w} W := + (le_colimitsOfShape_punit.{w} W).trans + (colimitsOfShape_le_coproducts W PUnit.{w + 1}) + +lemma coproducts_monotone : Monotone (coproducts.{w} (C := C)) := by + rintro W₁ W₂ h X Y f hf + rw [coproducts_iff] at hf + obtain ⟨J, hf⟩ := hf + exact W₂.colimitsOfShape_le_coproducts J _ + (colimitsOfShape_monotone h _ _ hf) + +end Coproducts + +section Products + +variable (W : MorphismProperty C) + +/-- The property that a morphism property `W` is stable under products indexed by a type `J`. -/ +abbrev IsStableUnderProductsOfShape (J : Type*) := W.IsStableUnderLimitsOfShape (Discrete J) + +/-- The property that a morphism property `W` is stable under coproducts indexed by a type `J`. -/ +abbrev IsStableUnderCoproductsOfShape (J : Type*) := W.IsStableUnderColimitsOfShape (Discrete J) + +lemma IsStableUnderProductsOfShape.mk (J : Type*) [W.RespectsIso] + (hW : ∀ (X₁ X₂ : J → C) [HasProduct X₁] [HasProduct X₂] + (f : ∀ j, X₁ j ⟶ X₂ j) (_ : ∀ (j : J), W (f j)), + W (Limits.Pi.map f)) : W.IsStableUnderProductsOfShape J where + condition X₁ X₂ c₁ c₂ hc₁ hc₂ f hf α hα := by + let φ := fun j => f.app (Discrete.mk j) + have : HasLimit X₁ := ⟨c₁, hc₁⟩ + have : HasLimit X₂ := ⟨c₂, hc₂⟩ + have : HasProduct fun j ↦ X₁.obj (Discrete.mk j) := + hasLimit_of_iso (Discrete.natIso (fun j ↦ Iso.refl (X₁.obj j))) + have : HasProduct fun j ↦ X₂.obj (Discrete.mk j) := + hasLimit_of_iso (Discrete.natIso (fun j ↦ Iso.refl (X₂.obj j))) + have hf' := hW _ _ φ (fun j => hf (Discrete.mk j)) + refine (W.arrow_mk_iso_iff ?_).2 hf' + refine Arrow.isoMk + (IsLimit.conePointUniqueUpToIso hc₁ (limit.isLimit X₁) ≪≫ (Pi.isoLimit X₁).symm) + (IsLimit.conePointUniqueUpToIso hc₂ (limit.isLimit X₂) ≪≫ (Pi.isoLimit _).symm) ?_ + apply limit.hom_ext + rintro ⟨j⟩ + simp [φ, hα] + +lemma IsStableUnderCoproductsOfShape.mk (J : Type*) [W.RespectsIso] + (hW : ∀ (X₁ X₂ : J → C) [HasCoproduct X₁] [HasCoproduct X₂] + (f : ∀ j, X₁ j ⟶ X₂ j) (_ : ∀ (j : J), W (f j)), + W (Limits.Sigma.map f)) : W.IsStableUnderCoproductsOfShape J where + condition X₁ X₂ c₁ c₂ hc₁ hc₂ f hf α hα := by + let φ := fun j => f.app (Discrete.mk j) + have : HasColimit X₁ := ⟨c₁, hc₁⟩ + have : HasColimit X₂ := ⟨c₂, hc₂⟩ + have : HasCoproduct fun j ↦ X₁.obj (Discrete.mk j) := + hasColimit_of_iso (Discrete.natIso (fun j ↦ Iso.refl (X₁.obj j))) + have : HasCoproduct fun j ↦ X₂.obj (Discrete.mk j) := + hasColimit_of_iso (Discrete.natIso (fun j ↦ Iso.refl (X₂.obj j))) + have hf' := hW _ _ φ (fun j => hf (Discrete.mk j)) + refine (W.arrow_mk_iso_iff ?_).1 hf' + refine Arrow.isoMk + ((Sigma.isoColimit _) ≪≫ IsColimit.coconePointUniqueUpToIso (colimit.isColimit X₁) hc₁) + ((Sigma.isoColimit _) ≪≫ IsColimit.coconePointUniqueUpToIso (colimit.isColimit X₂) hc₂) ?_ + apply colimit.hom_ext + rintro ⟨j⟩ + simp [φ, hα] + +/-- The condition that a property of morphisms is stable by finite products. -/ +class IsStableUnderFiniteProducts : Prop where + isStableUnderProductsOfShape (J : Type) [Finite J] : W.IsStableUnderProductsOfShape J + +attribute [instance] IsStableUnderFiniteProducts.isStableUnderProductsOfShape + +/-- The condition that a property of morphisms is stable by finite coproducts. -/ +class IsStableUnderFiniteCoproducts : Prop where + isStableUnderCoproductsOfShape (J : Type) [Finite J] : W.IsStableUnderCoproductsOfShape J + +attribute [instance] IsStableUnderFiniteCoproducts.isStableUnderCoproductsOfShape + +@[deprecated "This is now an instance." (since := "2025-05-11")] +alias isStableUnderProductsOfShape_of_isStableUnderFiniteProducts := + IsStableUnderFiniteProducts.isStableUnderProductsOfShape + +@[deprecated "This is now an instance." (since := "2025-05-11")] +alias isStableUnderCoproductsOfShape_of_isStableUnderFiniteCoproducts := + IsStableUnderFiniteCoproducts.isStableUnderCoproductsOfShape + +/-- The condition that a property of morphisms is stable by coproducts. -/ +@[pp_with_univ] +class IsStableUnderCoproducts : Prop where + isStableUnderCoproductsOfShape (J : Type w) : W.IsStableUnderCoproductsOfShape J := by + infer_instance + +attribute [instance] IsStableUnderCoproducts.isStableUnderCoproductsOfShape + +lemma coproducts_le [IsStableUnderCoproducts.{w} W] : + coproducts.{w} W ≤ W := by + intro X Y f hf + rw [coproducts_iff] at hf + obtain ⟨J, hf⟩ := hf + exact colimitsOfShape_le _ hf + +@[simp] +lemma coproducts_eq_self [IsStableUnderCoproducts.{w} W] : + coproducts.{w} W = W := + le_antisymm W.coproducts_le W.le_coproducts + +@[simp] +lemma coproducts_le_iff {P Q : MorphismProperty C} [IsStableUnderCoproducts.{w} Q] : + coproducts.{w} P ≤ Q ↔ P ≤ Q := by + constructor + · exact le_trans P.le_coproducts + · intro h + exact le_trans (coproducts_monotone h) Q.coproducts_le + +end Products + +section Diagonal + +variable [HasPullbacks C] {P : MorphismProperty C} + +/-- For `P : MorphismProperty C`, `P.diagonal` is a morphism property that holds for `f : X ⟶ Y` +whenever `P` holds for `X ⟶ Y xₓ Y`. -/ +def diagonal (P : MorphismProperty C) : MorphismProperty C := fun _ _ f => P (pullback.diagonal f) + +theorem diagonal_iff {X Y : C} {f : X ⟶ Y} : P.diagonal f ↔ P (pullback.diagonal f) := + Iff.rfl + +instance RespectsIso.diagonal [P.RespectsIso] : P.diagonal.RespectsIso := by + apply RespectsIso.mk + · introv H + rwa [diagonal_iff, pullback.diagonal_comp, P.cancel_left_of_respectsIso, + P.cancel_left_of_respectsIso, ← P.cancel_right_of_respectsIso _ + (pullback.map (e.hom ≫ f) (e.hom ≫ f) f f e.hom e.hom (𝟙 Z) (by simp) (by simp)), + ← pullback.condition, P.cancel_left_of_respectsIso] + · introv H + delta diagonal + rwa [pullback.diagonal_comp, P.cancel_right_of_respectsIso] + +instance diagonal_isStableUnderComposition [P.IsStableUnderComposition] [RespectsIso P] + [IsStableUnderBaseChange P] : P.diagonal.IsStableUnderComposition where + comp_mem _ _ h₁ h₂ := by + rw [diagonal_iff, pullback.diagonal_comp] + exact P.comp_mem _ _ h₁ + (by simpa only [cancel_left_of_respectsIso] using P.pullback_snd _ _ h₂) + +instance IsStableUnderBaseChange.diagonal [IsStableUnderBaseChange P] [P.RespectsIso] : + P.diagonal.IsStableUnderBaseChange := + IsStableUnderBaseChange.mk' + (by + introv h + rw [diagonal_iff, diagonal_pullback_fst, P.cancel_left_of_respectsIso, + P.cancel_right_of_respectsIso] + exact P.baseChange_map f _ (by simpa)) + +lemma diagonal_isomorphisms : (isomorphisms C).diagonal = monomorphisms C := + ext _ _ fun _ _ _ ↦ pullback.isIso_diagonal_iff _ + +/-- If `P` is multiplicative and stable under base change, having the of-postcomp property +w.r.t. `Q` is equivalent to `Q` implying `P` on the diagonal. -/ +lemma hasOfPostcompProperty_iff_le_diagonal [P.IsStableUnderBaseChange] + [P.IsMultiplicative] {Q : MorphismProperty C} [Q.IsStableUnderBaseChange] : + P.HasOfPostcompProperty Q ↔ Q ≤ P.diagonal := by + refine ⟨fun hP X Y f hf ↦ ?_, fun hP ↦ ⟨fun {Y X S} g f hf hcomp ↦ ?_⟩⟩ + · exact hP.of_postcomp _ _ (Q.pullback_fst _ _ hf) (by simpa using P.id_mem X) + · set gr : Y ⟶ pullback (g ≫ f) f := pullback.lift (𝟙 Y) g (by simp) + have : g = gr ≫ pullback.snd _ _ := by simp [gr] + rw [this] + apply P.comp_mem + · exact P.of_isPullback (pullback_lift_diagonal_isPullback g f) (hP _ hf) + · exact P.pullback_snd _ _ hcomp + +end Diagonal + +section Universally + +/-- `P.universally` holds for a morphism `f : X ⟶ Y` iff `P` holds for all `X ×[Y] Y' ⟶ Y'`. -/ +def universally (P : MorphismProperty C) : MorphismProperty C := fun X Y f => + ∀ ⦃X' Y' : C⦄ (i₁ : X' ⟶ X) (i₂ : Y' ⟶ Y) (f' : X' ⟶ Y') (_ : IsPullback f' i₁ i₂ f), P f' + +instance universally_respectsIso (P : MorphismProperty C) : P.universally.RespectsIso := by + apply RespectsIso.mk + · intro X Y Z e f hf X' Z' i₁ i₂ f' H + have : IsPullback (𝟙 _) (i₁ ≫ e.hom) i₁ e.inv := + IsPullback.of_horiz_isIso + ⟨by rw [Category.id_comp, Category.assoc, e.hom_inv_id, Category.comp_id]⟩ + exact hf _ _ _ + (by simpa only [Iso.inv_hom_id_assoc, Category.id_comp] using this.paste_horiz H) + · intro X Y Z e f hf X' Z' i₁ i₂ f' H + have : IsPullback (𝟙 _) i₂ (i₂ ≫ e.inv) e.inv := + IsPullback.of_horiz_isIso ⟨Category.id_comp _⟩ + exact hf _ _ _ (by simpa only [Category.assoc, Iso.hom_inv_id, + Category.comp_id, Category.comp_id] using H.paste_horiz this) + +instance universally_isStableUnderBaseChange (P : MorphismProperty C) : + P.universally.IsStableUnderBaseChange where + of_isPullback H h₁ _ _ _ _ _ H' := h₁ _ _ _ (H'.paste_vert H.flip) + +instance IsStableUnderComposition.universally [HasPullbacks C] (P : MorphismProperty C) + [hP : P.IsStableUnderComposition] : P.universally.IsStableUnderComposition where + comp_mem {X Y Z} f g hf hg X' Z' i₁ i₂ f' H := by + have := pullback.lift_fst _ _ (H.w.trans (Category.assoc _ _ _).symm) + rw [← this] at H ⊢ + apply P.comp_mem _ _ _ (hg _ _ _ <| IsPullback.of_hasPullback _ _) + exact hf _ _ _ (H.of_right (pullback.lift_snd _ _ _) (IsPullback.of_hasPullback i₂ g)) + +theorem universally_le (P : MorphismProperty C) : P.universally ≤ P := by + intro X Y f hf + exact hf (𝟙 _) (𝟙 _) _ (IsPullback.of_vert_isIso ⟨by rw [Category.comp_id, Category.id_comp]⟩) + +theorem universally_inf (P Q : MorphismProperty C) : + (P ⊓ Q).universally = P.universally ⊓ Q.universally := by + ext X Y f + change _ ↔ _ ∧ _ + simp_rw [universally, ← forall_and] + rfl + +theorem universally_eq_iff {P : MorphismProperty C} : + P.universally = P ↔ P.IsStableUnderBaseChange := + ⟨(· ▸ P.universally_isStableUnderBaseChange), + fun hP ↦ P.universally_le.antisymm fun _ _ _ hf _ _ _ _ _ H => hP.of_isPullback H.flip hf⟩ + +theorem IsStableUnderBaseChange.universally_eq {P : MorphismProperty C} + [hP : P.IsStableUnderBaseChange] : P.universally = P := universally_eq_iff.mpr hP + +theorem universally_mono : Monotone (universally : MorphismProperty C → MorphismProperty C) := + fun _ _ h _ _ _ h₁ _ _ _ _ _ H => h _ (h₁ _ _ _ H) + +lemma universally_mk' (P : MorphismProperty C) [P.RespectsIso] {X Y : C} (g : X ⟶ Y) + (H : ∀ {T : C} (f : T ⟶ Y) [HasPullback f g], P (pullback.fst f g)) : + universally P g := by + introv X' h + have := h.hasPullback + rw [← h.isoPullback_hom_fst, P.cancel_left_of_respectsIso] + exact H .. + +end Universally + +variable (P : MorphismProperty C) + +/-- `P` has pullbacks if for every `f` satisfying `P`, pullbacks of arbitrary morphisms along `f` +exist. -/ +protected class HasPullbacks : Prop where + hasPullback {X Y S : C} {f : X ⟶ S} (g : Y ⟶ S) : P f → HasPullback f g := by infer_instance + +instance [HasPullbacks C] : P.HasPullbacks where + +alias hasPullback := HasPullbacks.hasPullback + +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 `ContainsObjects` 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 MorphismProperty + end CategoryTheory diff --git a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean index 6e9a87e9..26430a3f 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean @@ -4,9 +4,8 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Christian Merten -/ import Mathlib.CategoryTheory.MorphismProperty.Comma -import Mathlib.CategoryTheory.Comma.Over.Pullback -import Mathlib.CategoryTheory.MorphismProperty.Limits import HoTTLean.ForMathlib.CategoryTheory.MorphismProperty.Limits +import HoTTLean.ForMathlib.CategoryTheory.Comma.Over.Pushforward /-! # Adjunction of pushforward and pullback in `P.Over Q X` @@ -18,33 +17,26 @@ a morphism `f : X ⟶ Y` defines two functors: - `Over.pullback`: base-change along `f` such that `Over.map` is the left adjoint to `Over.pullback`. -We say that `P` is *stable* under pushforward if `Over.pullback` -also is a left adjoint. -We say that `P` is *closed* under pushforward if `Over.pullback` -also is a left adjoint for any `f` satisfying `P`. - -/ namespace CategoryTheory.MorphismProperty open Limits -variable {T : Type*} [Category T] (P Q : MorphismProperty T) [Q.IsMultiplicative] -variable {X Y Z : T} (f : X ⟶ Y) +variable {T : Type*} [Category T] (P Q : MorphismProperty T) +variable {X Y Z : T} section Map -variable {P} [P.IsStableUnderComposition] (hPf : P f) - -variable {f} +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 : P.Over Q X ⥤ P.Over Q Y := +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 {X Y Z : T} {f : X ⟶ Y} (hf : P f) {g : Y ⟶ Z} (hg : P g) : +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] @@ -54,7 +46,7 @@ lemma Over.map_comp {X Y Z : T} {f : X ⟶ Y} (hf : P f) {g : Y ⟶ Z} (hg : P g /-- `Over.map` commutes with composition. -/ @[simps! hom_app_left inv_app_left] -def Over.mapComp {X Y Z : T} {f : X ⟶ Y} (hf : P f) {g : Y ⟶ Z} (hg : P g) [Q.RespectsIso] : +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 _)) @@ -62,62 +54,54 @@ end Map section Pullback -variable [P.HasPullback f] [P.IsStableUnderBaseChange] [Q.IsStableUnderBaseChange] +variable [P.IsStableUnderBaseChange] [Q.IsStableUnderBaseChange] [Q.IsMultiplicative] -variable {P Q} in -@[simps] -def Over.morphismProperty (f : P.Over Q X) : f.left ⟶(P) X := ⟨ f.hom , f.prop ⟩ +instance (f : X ⟶ Y) [P.HasPullbacksAlong f] (A : P.Over Q Y) : HasPullback A.hom f := + HasPullbacksAlong.hasPullback A.hom A.prop -instance (A : P.Over Q Y) : HasPullback A.hom f := - inferInstanceAs (HasPullback (A.morphismProperty).1 f) +instance [P.IsStableUnderBaseChange] {X Y Z} (f : X ⟶ Y) (g : Y ⟶ Z) [P.HasPullbacksAlong f] + [P.HasPullbacksAlong g] (A : P.Over Q Z) : HasPullback (pullback.snd A.hom g) f := + HasPullbacksAlong.hasPullback (pullback.snd A.hom g) + (P.of_isPullback (IsPullback.of_hasPullback A.hom g) A.prop) -/-- If `P` and `Q` are stable under base change and pullbacks exist in `T`, +/-- 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.morphismProperty.1 f) - (baseChange_obj f A.toComma A.prop) - map {A B} g := Over.homMk (pullback.map _ f _ f g.left (𝟙 _) (𝟙 _) (by simp) (by simp)) - (by simp) (baseChange_map f ⟨g.left, g.right, _⟩ g.prop_hom_left) +noncomputable def Over.pullback (f : X ⟶ Y) [P.HasPullbacksAlong f] : + P.Over Q Y ⥤ P.Over Q X where + obj A := Over.mk Q (Limits.pullback.snd A.hom f) + (pullback_snd 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} -instance [P.IsStableUnderBaseChange] {X Y Z} - (f : X ⟶ Y) (g : Y ⟶ Z) [P.HasPullback f] [P.HasPullback g] (A : P.Over Q Z) : - HasPullback (pullback.snd A.hom g) f := - inferInstanceAs <| HasPullback (pullback.snd A.morphismProperty.1 g) f - -lemma Over.hom_pullback_map [∀ {W : T} (h : W ⟶ Y), HasPullback h f] {A B} (g : A ⟶ B) : - Comma.Hom.hom ((Over.pullback P Q f).map g) = - (CategoryTheory.Over.pullback f).map (Comma.Hom.hom g) := by - simp [Over.pullback, CategoryTheory.Over.pullback, pullback.map] - /-- `Over.pullback` commutes with composition. -/ @[simps! hom_app_left inv_app_left] -noncomputable def Over.pullbackComp (g : Y ⟶ Z) [P.HasPullback g] - [Q.RespectsIso] : Over.pullback P Q (f ≫ g) ≅ Over.pullback P Q g ⋙ Over.pullback P Q f := +noncomputable def Over.pullbackComp (f : X ⟶ Y) [P.HasPullbacksAlong f] (g : Y ⟶ Z) + [P.HasPullbacksAlong g] [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)) + (fun X ↦ Over.isoMk ((pullbackLeftPullbackSndIso X.hom g f).symm) (by simp)) -lemma Over.pullbackComp_left_fst_fst (g : Y ⟶ Z) [P.HasPullback g] - [Q.RespectsIso] (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 +lemma Over.pullbackComp_left_fst_fst (f : X ⟶ Y) [P.HasPullbacksAlong f] (g : Y ⟶ Z) + [P.HasPullbacksAlong g] [Q.RespectsIso] (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} /-- If `f = g`, then base change along `f` is naturally isomorphic to base change along `g`. -/ -noncomputable def Over.pullbackCongr {g : X ⟶ Y} (h : f = g) : - have : P.HasPullback g := by subst h; infer_instance +noncomputable def Over.pullbackCongr {f : X ⟶ Y} [P.HasPullbacksAlong f] {g : X ⟶ Y} (h : f = g) : + have : P.HasPullbacksAlong g := by subst h; infer_instance Over.pullback P Q f ≅ Over.pullback P Q g := NatIso.ofComponents (fun X ↦ eqToIso (by simp [h])) @[reassoc (attr := simp)] -lemma Over.pullbackCongr_hom_app_left_fst {g : X ⟶ Y} (h : f = g) (A : P.Over Q Y) : - have : P.HasPullback g := by subst h; infer_instance - ((Over.pullbackCongr h).hom.app A).left ≫ pullback.fst A.hom g = - pullback.fst A.hom f := by +lemma Over.pullbackCongr_hom_app_left_fst {f : X ⟶ Y} [P.HasPullbacksAlong f] {g : X ⟶ Y} + (h : f = g) (A : P.Over Q Y) : + have : P.HasPullbacksAlong g := by subst h; infer_instance + ((Over.pullbackCongr h).hom.app A).left ≫ pullback.fst A.hom g = pullback.fst A.hom f := by subst h simp [pullbackCongr] @@ -126,10 +110,11 @@ end Pullback section Adjunction variable [P.IsStableUnderComposition] [P.IsStableUnderBaseChange] - [Q.IsStableUnderBaseChange] [P.HasPullback f] + [Q.IsMultiplicative] [Q.IsStableUnderBaseChange] -/-- `P.Over.map` is left adjoint to `P.Over.pullback` if `f` satisfies `P`. -/ -noncomputable def Over.mapPullbackAdj [Q.HasOfPostcompProperty Q] (hPf : P f) (hQf : Q f) : +/-- `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] + [Q.HasOfPostcompProperty Q] (hPf : P f) (hQf : Q f) : Over.map Q hPf ⊣ Over.pullback P Q f := Adjunction.mkOfHomEquiv { homEquiv := fun A B ↦ @@ -155,114 +140,106 @@ 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 abbrev HasPushforward (P : MorphismProperty T) {S S' : T} (f : S ⟶ S') - [∀ {W} (h : W ⟶ S'), HasPullback h f] : Prop := - ∀ {W} (h : W ⟶(P) S), HasPushforward f (.mk h.1) +protected class HasPushforwardsAlong {S S' : T} {f : S ⟶ S'} + (hpb : HasPullbacksAlong f) : Prop 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 abbrev HasPushforwards (P : MorphismProperty T) - (Q : MorphismProperty T) [Q.HasPullbacks] : Prop := - ∀ {S S' : T} (q : S ⟶(Q) S'), P.HasPushforward q.1 +protected class HasPushforwards [Q.HasPullbacks] : Prop where + hasPushforwardsAlong : ∀ {S S' : T} (q : S ⟶ S') (hq : Q q), + P.HasPushforwardsAlong (hasPullbacksAlong_of_hasPullbacks hq) + +variable {P Q} in +lemma HasPushforwards.hasPushforward [Q.HasPullbacks] [P.HasPushforwards Q] + {S S' W : T} {f : S ⟶ S'} (hf : Q f) {g : W ⟶ S} (hg : P g) : + @HasPushforward _ _ _ _ f (fun h => hasPullbacksAlong_of_hasPullbacks hf h) (.mk g) := + (HasPushforwards.hasPushforwardsAlong f hf).hasPushforward g hg /-- 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 IsStableUnderPushforward (P : MorphismProperty T) - (Q : MorphismProperty T) [Q.HasPullbacks] : Prop where - of_isPushforward {S S' X Y : T} (q : S ⟶(Q) S') (f : X ⟶(P) S) (g : Y ⟶ S') - (isPushforward : IsPushforward q.1 (.mk f.1) (.mk g)) : P g +class IsStableUnderPushforward [Q.HasPullbacks] : Prop where + of_isPushforward {S S' X Y : T} (q : S ⟶ S') (hq : Q q) (f : X ⟶ S) (hf : P f) {g : Y ⟶ S'} + (isPushforward : IsPushforward (inst_hasPullback := hasPullbacksAlong_of_hasPullbacks hq) + q (.mk f) (.mk g)) : P g noncomputable section /-- 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 (P : MorphismProperty T) - {S S' : T} (q : S ⟶ S') [∀ {W} (h : W ⟶ S'), HasPullback h q] [P.HasPushforward q] : - P.Over ⊤ S ⥤ Over S' := by - refine Functor.PartialRightAdjointSource.lift (Over.forget P ⊤ S) ?_ ⋙ +noncomputable def pushforwardPartial {S S' : T} (q : S ⟶ S') + (hpb : HasPullbacksAlong q) + (hpf : P.HasPushforwardsAlong hpb) : + P.Over ⊤ S ⥤ Over S' := + ObjectProperty.lift _ (Over.forget P ⊤ S) + (fun X => HasPushforwardsAlong.hasPushforward X.hom X.prop) ⋙ (CategoryTheory.Over.pullback q).partialRightAdjoint - intro X - let X' : _ ⟶(P) S := ⟨ X.hom , X.prop ⟩ - convert_to ((CategoryTheory.Over.pullback q).op ⋙ - yoneda.obj (CategoryTheory.Over.mk X'.fst)).IsRepresentable - infer_instance - --- section homEquiv - --- variable {P} {S S' : T} (q : S ⟶ S') --- [∀ {W} (h : W ⟶ S'), HasPullback h q] [P.HasPushforward q] {X : Over S'} {Y : P.Over ⊤ S} - --- /-- 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)`. -/ --- abbrev pushforwardPartial.homEquiv : --- (X ⟶ (pushforwardPartial P q).obj Y) ≃ --- ((CategoryTheory.Over.pullback q).obj X ⟶ Y.toComma) := --- Functor.partialRightAdjointHomEquiv _ - --- lemma pushforwardPartial.homEquiv_comp {S S' : T} (q : S ⟶ S') --- [∀ {W} (h : W ⟶ S'), HasPullback h q] [P.HasPushforward q] {X X' : Over S'} {Y : P.Over ⊤ S} --- (f : X' ⟶ (pushforwardPartial P q).obj Y) (g : X ⟶ X') : --- pushforwardPartial.homEquiv q (g ≫ f) = --- (CategoryTheory.Over.pullback q).map g ≫ pushforwardPartial.homEquiv q f := --- Functor.partialRightAdjointHomEquiv_comp .. - --- lemma pushforwardPartial.homEquiv_map_comp {S S' : T} (q : S ⟶ S') --- [∀ {W} (h : W ⟶ S'), HasPullback h q] [P.HasPushforward q] {X : Over S'} {Y Y' : P.Over ⊤ S} --- (f : X ⟶ (pushforwardPartial P q).obj Y) (g : Y ⟶ Y') : --- pushforwardPartial.homEquiv q (f ≫ (P.pushforwardPartial q).map g) = --- pushforwardPartial.homEquiv q f ≫ g.toCommaMorphism := --- Functor.partialRightAdjointHomEquiv_map_comp .. - --- end homEquiv /-- 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 {Q : MorphismProperty T} [Q.HasPullbacks] [P.HasPushforwards Q] - [P.IsStableUnderPushforward Q] {S S' : T} (q : S ⟶(Q) S') : P.Over ⊤ S ⥤ P.Over ⊤ S' := - Comma.lift (pushforwardPartial P q.1) (fun X => - let X' : _ ⟶(P) S := ⟨ X.hom , X.prop ⟩ - IsStableUnderPushforward.of_isPushforward q X' _ - (pushforward.isPushforward q.fst (CategoryTheory.Over.mk X'.fst))) + [P.IsStableUnderPushforward Q] {S S' : T} {q : S ⟶ S'} (hq : Q q) : + P.Over ⊤ S ⥤ P.Over ⊤ S' := + Comma.lift (pushforwardPartial P q (hasPullbacksAlong_of_hasPullbacks hq) + (HasPushforwards.hasPushforwardsAlong q hq) + ) (fun X => IsStableUnderPushforward.of_isPushforward q hq X.hom X.prop + ((have : HasPullbacksAlong q := hasPullbacksAlong_of_hasPullbacks hq + have : HasPushforward q X.toComma := HasPushforwards.hasPushforward hq X.prop + pushforward.isPushforward q (X.toComma)))) (by simp) (by simp) section homEquiv +open Over + variable {P} {Q : MorphismProperty T} [Q.HasPullbacks] [P.HasPushforwards Q] - [P.IsStableUnderPushforward Q] {S S' : T} (q : S ⟶(Q) S') + [P.IsStableUnderPushforward Q] {S S' : T} {q : S ⟶ S'} (hq : Q q) + +@[simp] +abbrev Over.pullback' := @CategoryTheory.Over.pullback _ _ _ _ q (hasPullbacksAlong_of_hasPullbacks hq) /-- 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.1).obj X ⟶ Y.toComma) := + (X ⟶ ((pushforward P hq).obj Y).toComma) ≃ + ((pullback' hq).obj X ⟶ + Y.toComma) := (Functor.partialRightAdjointHomEquiv ..) 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 q (g ≫ f) = - (CategoryTheory.Over.pullback q.fst).map g ≫ homEquiv q f := + (f : X' ⟶ ((pushforward P hq).obj Y).toComma) (g : X ⟶ X') : + pushforward.homEquiv hq (g ≫ f) = + (pullback' hq).map g ≫ homEquiv hq f := Functor.partialRightAdjointHomEquiv_comp .. 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 q (f ≫ Comma.Hom.hom ((P.pushforward q).map g)) = - homEquiv q f ≫ Comma.Hom.hom g := + (f : X ⟶ ((pushforward P hq).obj Y).toComma) (g : Y ⟶ Y') : + homEquiv hq (f ≫ Comma.Hom.hom ((P.pushforward hq).map g)) = + homEquiv hq f ≫ Comma.Hom.hom g := Functor.partialRightAdjointHomEquiv_map_comp .. lemma pushforward.homEquiv_symm_comp {X : Over S'} {Y Y' : P.Over ⊤ S} - (f : (CategoryTheory.Over.pullback q.1).obj X ⟶ Y.toComma) (g : Y ⟶ Y') : - (homEquiv q).symm f ≫ Comma.Hom.hom ((P.pushforward q).map g) = - (homEquiv q).symm (f ≫ Comma.Hom.hom g) := + (f : (pullback' hq).obj X ⟶ Y.toComma) (g : Y ⟶ Y') : + (homEquiv hq).symm f ≫ Comma.Hom.hom ((P.pushforward hq).map g) = + (homEquiv hq).symm (f ≫ Comma.Hom.hom g) := Functor.partialRightAdjointHomEquiv_symm_comp .. lemma pushforward.homEquiv_comp_symm {X X' : Over S'} {Y : P.Over ⊤ S} - (f : (CategoryTheory.Over.pullback q.1).obj X' ⟶ Y.toComma) (g : X ⟶ X') : - g ≫ (homEquiv q).symm f = - (homEquiv q).symm ((CategoryTheory.Over.pullback q.fst).map g ≫ f) := + (f : (pullback' hq).obj X' ⟶ Y.toComma) (g : X ⟶ X') : + g ≫ (homEquiv hq).symm f = + (homEquiv hq).symm ((pullback' hq).map g ≫ f) := Functor.partialRightAdjointHomEquiv_comp_symm .. end homEquiv @@ -271,20 +248,25 @@ section open MorphismProperty.Over -variable [P.IsStableUnderBaseChange] {S S' : T} (f : S ⟶(Q) S') +variable {Q} [P.IsStableUnderBaseChange] {S S' : T} {f : S ⟶ S'} (hf : Q f) [Q.HasPullbacks] [P.HasPushforwards Q] [P.IsStableUnderPushforward Q] +@[simp] +abbrev Over.pullback'' := @Over.pullback _ _ P ⊤ _ _ _ _ _ f + (hasPullbacksAlong_of_hasPullbacks' hf) + /-- The `pullback ⊣ pushforward` adjunction. -/ -def pullbackPushforwardAdjunction : pullback P ⊤ f.1 ⊣ pushforward P f := +def pullbackPushforwardAdjunction : @Over.pullback _ _ P ⊤ _ _ _ _ _ f + (hasPullbacksAlong_of_hasPullbacks' hf) ⊣ pushforward P hf := Adjunction.mkOfHomEquiv { homEquiv X Y := - calc ((pullback P ⊤ f.1).obj X ⟶ Y) - _ ≃ (((Over.pullback P ⊤ f.fst).obj X).toComma ⟶ Y.toComma) := + calc ((pullback'' P hf).obj X ⟶ Y) + _ ≃ (((pullback'' P hf).obj X).toComma ⟶ Y.toComma) := (Functor.FullyFaithful.ofFullyFaithful (Over.forget P ⊤ S)).homEquiv - _ ≃ (X.toComma ⟶ ((P.pushforward f).obj Y).toComma) := - (pushforward.homEquiv f).symm + _ ≃ (X.toComma ⟶ ((P.pushforward hf).obj Y).toComma) := + (pushforward.homEquiv hf).symm _ ≃ _ := Equiv.cast (by dsimp) -- why? - _ ≃ (X ⟶ (P.pushforward f).obj Y) := + _ ≃ (X ⟶ (P.pushforward hf).obj Y) := (Functor.FullyFaithful.ofFullyFaithful (Over.forget P ⊤ S')).homEquiv.symm homEquiv_naturality_left_symm g f := by simp only [Equiv.trans_def, Equiv.cast_refl, Equiv.trans_refl, @@ -295,7 +277,7 @@ def pullbackPushforwardAdjunction : pullback P ⊤ f.1 ⊣ pushforward P f := apply Functor.FullyFaithful.map_injective (Functor.FullyFaithful.ofFullyFaithful (Over.forget P ⊤ S)) simp only [Functor.FullyFaithful.map_preimage, Functor.map_comp] - simp only [Comma.forget_obj, Comma.forget_map, hom_pullback_map] + simp only [Comma.forget_obj, Comma.forget_map] congr 1 homEquiv_naturality_right f g := by simp only [Comma.forget_obj, Equiv.trans_def, Equiv.cast_refl, Equiv.trans_refl, @@ -309,11 +291,11 @@ def pullbackPushforwardAdjunction : pullback P ⊤ f.1 ⊣ pushforward P f := rfl } -instance : (pullback P ⊤ f.1).IsLeftAdjoint := - Adjunction.isLeftAdjoint (pullbackPushforwardAdjunction P Q f) +instance : (pullback'' P hf).IsLeftAdjoint := + Adjunction.isLeftAdjoint (pullbackPushforwardAdjunction P hf) -instance : (pushforward P f).IsRightAdjoint := - Adjunction.isRightAdjoint (pullbackPushforwardAdjunction P Q f) +instance : (pushforward P hf).IsRightAdjoint := + Adjunction.isRightAdjoint (pullbackPushforwardAdjunction P hf) end @@ -327,7 +309,7 @@ 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 [Over.morphismProperty_fst, Category.assoc, pullback.condition, + simp only [Category.assoc, pullback.condition, CategoryTheory.Over.map_obj_hom] erw [← CategoryTheory.Over.w v] simp diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index 1cccb853..e1e0e96c 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -12,6 +12,8 @@ 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.NatTrans universe v u v₁ u₁ @@ -28,7 +30,7 @@ namespace MorphismProperty instance : (⊤ : MorphismProperty C).HasOfPostcompProperty ⊤ where of_postcomp := by simp -instance (P : MorphismProperty C) {X} : P.HasPullback (𝟙 X) where +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 @@ -69,11 +71,11 @@ def pullbackMapTwoSquare {T : Type u} [Category.{v} T] (R : MorphismProperty T) [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) - [R.HasPullback h] [R.HasPullback f] [R.HasPullback g] [R.HasPullback k] + [R.HasPullbacksAlong h] [R.HasPullbacksAlong f] [R.HasPullbacksAlong g] [R.HasPullbacksAlong k] (sq : f ≫ k = h ≫ g) : - TwoSquare (MorphismProperty.Over.pullback R ⊤ f) - (MorphismProperty.Over.map ⊤ rk) (MorphismProperty.Over.map ⊤ rh) - (MorphismProperty.Over.pullback R ⊤ g) := + TwoSquare (MorphismProperty.Over.pullback R ⊤ f) (MorphismProperty.Over.map ⊤ rk) + (MorphismProperty.Over.map ⊤ rh) + (MorphismProperty.Over.pullback R ⊤ g) := (mateEquiv (MorphismProperty.Over.mapPullbackAdj R ⊤ k rk trivial) (MorphismProperty.Over.mapPullbackAdj R ⊤ h rh trivial)).symm <| ((MorphismProperty.Over.pullbackComp _ _).inv ≫ @@ -111,7 +113,7 @@ theorem pullbackMapTwoSquare_isIso {T : Type u} [Category.{v} T] (R : MorphismPr [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) - [R.HasPullback h] [R.HasPullback f] [R.HasPullback g] [R.HasPullback k] + [R.HasPullbacksAlong h] [R.HasPullbacksAlong f] [R.HasPullbacksAlong g] [R.HasPullbacksAlong k] (pb : IsPullback f h k g) : NatTrans.IsCartesian <| pullbackMapTwoSquare R h f g k rk rh pb.w := sorry @@ -140,16 +142,17 @@ It is the mate of the square of pullback functors def pushforwardPullbackTwoSquare {T : Type u} [Category.{v} T] {R : MorphismProperty T} [R.HasPullbacks] [R.IsStableUnderBaseChange] {Q : MorphismProperty T} [Q.HasPullbacks] [R.HasPushforwards Q] [R.IsStableUnderPushforward Q] {X Y Z W : T} - (h : X ⟶ Z) (f : X ⟶(Q) Y) (g : Z ⟶(Q) W) (k : Y ⟶ W) (sq : h ≫ g.1 = f.1 ≫ k) : - TwoSquare (pushforward (P := R) g) (Over.pullback R ⊤ h) (Over.pullback R ⊤ k) - (pushforward (P := R) f) := - let pullbackTwoSquare : TwoSquare (Over.pullback R ⊤ k) (Over.pullback R ⊤ g.fst) - (Over.pullback R ⊤ f.fst) (Over.pullback R ⊤ h) := + (h : X ⟶ Z) {f : X ⟶ Y} {g : Z ⟶ W} (k : Y ⟶ W) (sq : h ≫ g = f ≫ k) + (hf : Q f) (hg : Q g) : + TwoSquare (pushforward (P := R) hg) (Over.pullback R ⊤ h) (Over.pullback R ⊤ k) + (pushforward (P := R) hf) := + let pullbackTwoSquare : TwoSquare (Over.pullback R ⊤ k) (Over.pullback R ⊤ g) + (Over.pullback R ⊤ f) (Over.pullback R ⊤ h) := ((Over.pullbackComp _ _).inv ≫ eqToHom (by rw! [sq]) ≫ (Over.pullbackComp _ _).hom) - mateEquiv (pullbackPushforwardAdjunction R Q g) - (pullbackPushforwardAdjunction R Q f) + mateEquiv (pullbackPushforwardAdjunction R hg) + (pullbackPushforwardAdjunction R hf) pullbackTwoSquare /-- @@ -178,8 +181,9 @@ NOTE: we also know it holds in a category with pullbacks with `R = ⊤` and `Q = theorem pushforwardPullbackTwoSquare_isIso {T : Type u} [Category.{v} T] (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] {Q : MorphismProperty T} [Q.HasPullbacks] [R.HasPushforwards Q] [R.IsStableUnderPushforward Q] - {X Y Z W : T} (h : X ⟶ Z) (f : X ⟶(Q) Y) (g : Z ⟶(Q) W) (k : Y ⟶ W) - (pb : IsPullback h f.1 g.1 k) : IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := + {X Y Z W : T} (h : X ⟶ Z) {f : X ⟶ Y} {g : Z ⟶ W} (k : Y ⟶ W) (sq : h ≫ g = f ≫ k) + (hf : Q f) (hg : Q g) (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := R) h k pb.w hf hg) := sorry /- @@ -222,13 +226,13 @@ open NatTrans MorphismProperty.Over in 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.HasPullback f] (hPf : P f) : IsCartesian (mapPullbackAdj P ⊤ f hPf trivial).counit := by + [P.HasPullbacksAlong f] (hPf : P f) : IsCartesian (mapPullbackAdj P ⊤ 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, morphismProperty_fst, + Functor.id_obj, mapPullbackAdj, Adjunction.mkOfHomEquiv, Functor.const_obj_obj, map_obj_hom, Equiv.coe_fn_mk, Comma.id_hom, CategoryTheory.Comma.id_left, id_comp, Adjunction.mk'_counit, Comma.forget_map, homMk_hom, Over.forget_map, Over.homMk_left, Functor.comp_map, map_map_left, pullback_map_left, Functor.id_map] @@ -243,13 +247,15 @@ variable {T : Type u} [Category.{v} T] {R : MorphismProperty T} [R.HasPullbacks] [R.IsStableUnderBaseChange] {Q : MorphismProperty T} [Q.HasPullbacks] [R.HasPushforwards Q] [R.IsStableUnderPushforward Q] - {E I B : T} (i : E ⟶ I) (p : E ⟶(Q) B) + {E I B : T} (i : E ⟶ I) {p : E ⟶ B} (hp : Q p) + +abbrev pullback := @CategoryTheory.Over.pullback _ _ _ _ p (hasPullbacksAlong_of_hasPullbacks hp) /-- The partial right adjoint representing a multivariate polynomial. -/ -abbrev partialRightAdjoint := Over.pullback R ⊤ i ⋙ pushforward R p +abbrev partialRightAdjoint := Over.pullback R ⊤ i ⋙ pushforward R hp /-- The left adjoint in the partial adjunction. -/ -abbrev leftAdjoint := CategoryTheory.Over.pullback p.1 ⋙ CategoryTheory.Over.map i +abbrev leftAdjoint := pullback hp ⋙ 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` @@ -267,46 +273,46 @@ abbrev leftAdjoint := CategoryTheory.Over.pullback p.1 ⋙ CategoryTheory.Over.m 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.1).obj X ⟶ ((Over.pullback R ⊤ i).obj Y).toComma) := - pushforward.homEquiv .. + (X ⟶ ((partialRightAdjoint i hp).obj Y).toComma) ≃ + ((leftAdjoint i hp).obj X ⟶ Y.toComma) := + calc (X ⟶ ((R.pushforward hp).obj ((Over.pullback R ⊤ i).obj Y)).toComma) + _ ≃ ((pullback hp).obj X ⟶ ((Over.pullback R ⊤ i).obj Y).toComma) := + pushforward.homEquiv _ _ ≃ ((CategoryTheory.Over.map i).obj - ((CategoryTheory.Over.pullback p.fst).obj X) ⟶ Y.toComma) := - pullback.homEquiv .. + ((pullback hp).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 + (f : X' ⟶ ((partialRightAdjoint i hp).obj Y).toComma) (g : X ⟶ X') : + homEquiv i hp (g ≫ f) = + (leftAdjoint i hp).map g ≫ homEquiv i hp 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 + (f : X ⟶ ((partialRightAdjoint i hp).obj Y).toComma) (g : Y ⟶ Y') : + homEquiv i hp (f ≫ Comma.Hom.hom ((partialRightAdjoint i hp).map g)) = + homEquiv i hp 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 + (f : (leftAdjoint i hp).obj X ⟶ Y.toComma) (g : Y ⟶ Y') : + (homEquiv i hp).symm f ≫ Comma.Hom.hom ((partialRightAdjoint i hp).map g) = + (homEquiv i hp).symm (f ≫ Comma.Hom.hom g) := by unfold homEquiv simp erw [pushforward.homEquiv_symm_comp, pullback.homEquiv_symm_comp] rfl lemma homEquiv_comp_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 + (f : (leftAdjoint i hp).obj X' ⟶ Y.toComma) (g : X ⟶ X') : + g ≫ (homEquiv i hp).symm f = + (homEquiv i hp).symm ((leftAdjoint i hp).map g ≫ f) := by unfold homEquiv simp erw [pushforward.homEquiv_comp_symm, pullback.homEquiv_comp_symm] @@ -317,10 +323,10 @@ 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 (𝟙 _) + partialRightAdjoint i hp ⋙ Over.forget R ⊤ B ⋙ leftAdjoint i hp ⟶ Over.forget R ⊤ I where + app _ := homEquiv i hp (𝟙 _) naturality X Y f := by - apply (homEquiv i p).symm.injective + apply (homEquiv i hp).symm.injective conv => left; erw [← homEquiv_comp_symm] conv => right; erw [← homEquiv_symm_comp] simp @@ -351,15 +357,15 @@ R.Over ⊤ I ----> R.Over ⊤ E ----> R.Over ⊤ B pullback i pushforward p ``` -/ -def partialRightAdjointMap {E' : T} (i' : E' ⟶ I) (p' : E' ⟶(Q) B) (ρ) - (hi : i = ρ ≫ i') (hp : p.1 = ρ ≫ p'.1) : - partialRightAdjoint (R := R) i' p' ⟶ partialRightAdjoint i p := +def partialRightAdjointMap {E' : T} (i' : E' ⟶ I) {p' : E' ⟶ B} (hp' : Q p') (ρ) + (hi : i = ρ ≫ i') (hρ : p = ρ ≫ p') : + partialRightAdjoint (R := R) i' hp' ⟶ partialRightAdjoint i hp := 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) := ((Over.pullbackComp ρ i').symm ≪≫ eqToIso (by simp [hi, Functor.id_comp])).hom - let cellRight := pushforwardPullbackTwoSquare (R := R) (Q := Q) ρ p p' (𝟙 _) (by simp [← hp]) - Functor.whiskerLeft (partialRightAdjoint i' p') (Over.pullbackId R ⊤ B).inv ≫ + let cellRight := pushforwardPullbackTwoSquare (R := R) (Q := Q) ρ (𝟙 _) (by simp [← hρ]) hp hp' + Functor.whiskerLeft (partialRightAdjoint i' hp') (Over.pullbackId R ⊤ B).inv ≫ cellLeft.hComp cellRight end PolynomialPartialAdjunction @@ -385,11 +391,11 @@ def equivalenceOfHasObjects (R : MorphismProperty C) [R.HasObjects] variable {P : MorphismProperty C} {E B : C} @[simps] -def ofMorphismProperty (p : E ⟶(P) B) : P.Over ⊤ B where +def ofMorphismProperty {p : E ⟶ B} (hp : P p) : P.Over ⊤ B where left := E right := ⟨⟨⟩⟩ - hom := p.1 - prop := p.2 + hom := p + prop := hp @[simps] def homMkTop {p q : P.Over ⊤ B} (left : p.left ⟶ q.left) (hleft : left ≫ q.hom = p.hom) : @@ -411,8 +417,8 @@ Convert an object `p` in `R.Over ⊤ B` to a morphism in `R.Over ⊤ O` by compo O -/ @[simp] -def homOfMorphismProperty [P.IsStableUnderComposition] {O} (p : P.Over ⊤ B) (o : B ⟶(P) O) : - (map ⊤ o.2).obj p ⟶ Over.ofMorphismProperty o := +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 @@ -468,25 +474,27 @@ This will typically be used with the following instances `(pullback : R.Over B ⥤ R.Over E) ⊣ (pushforward : R.Over E ⥤ R.Over B)`. -/ structure MvPoly (R : MorphismProperty C) (H : MorphismProperty C) (I O E B : C) where - (i : E ⟶(R) I) - (p : E ⟶(H) B) - (o : B ⟶(R) O) + (i : E ⟶ I) + (hi : R i) + (p : E ⟶ B) + (hp : H p) + (o : B ⟶ O) + (ho : R o) namespace MvPoly variable {R : MorphismProperty C} {H : MorphismProperty C} -instance {B O : C} (i : B ⟶(R) O) [R.HasPullbacks] [R.IsStableUnderBaseChange] - [R.IsStableUnderComposition] : (pullback R ⊤ i.1).IsRightAdjoint := - (mapPullbackAdj R ⊤ i.1 i.2 ⟨⟩).isRightAdjoint +instance {B O : C} {i : B ⟶ O} (hi : R i) [R.HasPullbacks] [R.IsStableUnderBaseChange] + [R.IsStableUnderComposition] : (pullback R ⊤ i).IsRightAdjoint := + (mapPullbackAdj R ⊤ i hi ⟨⟩).isRightAdjoint -instance [R.IsStableUnderComposition] {X Y} (f : X ⟶ Y) (hf : R f) : +instance [R.IsStableUnderComposition] {X Y} {f : X ⟶ Y} (hf : R f) : Limits.PreservesLimitsOfShape WalkingCospan (MorphismProperty.Over.map ⊤ hf) := sorry variable {I O E B : C} (P : MvPoly R H I O E B) [R.HasPullbacks] [R.IsStableUnderBaseChange] - [H.HasPullbacks] [R.HasPushforwards H] - [R.IsStableUnderPushforward H] + [H.HasPullbacks] [R.HasPushforwards H] [R.IsStableUnderPushforward H] open PolynomialPartialAdjunction @@ -494,7 +502,7 @@ open PolynomialPartialAdjunction 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 (P : MvPoly R H I O E B) (X : R.Over ⊤ I) : R.Over ⊤ B := - (partialRightAdjoint P.i.1 P.p).obj X + (partialRightAdjoint P.i P.hp).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`, @@ -521,8 +529,8 @@ to `X^ (E b)`. ``` -/ def sndProj (P : MvPoly R H I O E B) (X : R.Over ⊤ I) : - (leftAdjoint P.i.1 P.p).obj (fstProj P X).toComma ⟶ X.toComma := - (counit P.i.1 P.p).app X + (leftAdjoint P.i P.hp).obj (fstProj P X).toComma ⟶ X.toComma := + (counit P.i P.hp).app X section @@ -530,17 +538,17 @@ variable (P : MvPoly R H I O E B) {X Y : R.Over ⊤ I} (f : X ⟶ Y) @[reassoc (attr := simp)] lemma map_fstProj : - ((partialRightAdjoint P.i.1 P.p).map f).left ≫ (fstProj P Y).hom = (fstProj P X).hom := by + ((partialRightAdjoint P.i P.hp).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.1 := by +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.1 P.p).map f).left (𝟙 _) (𝟙 _) (by simp) (by simp) ≫ + ((partialRightAdjoint P.i P.hp).map f).left (𝟙 _) (𝟙 _) (by simp) (by simp) ≫ (sndProj P Y).left := by - have := congr_arg CommaMorphism.left <| (counit P.i.1 P.p).naturality f + have := congr_arg CommaMorphism.left <| (counit P.i P.hp).naturality f simpa [pullback.map] using this.symm end @@ -564,7 +572,7 @@ gives rise to a functor ``` -/ def functor : R.Over ⊤ I ⥤ R.Over ⊤ O := - pullback R ⊤ P.i.1 ⋙ MorphismProperty.pushforward R P.p ⋙ map ⊤ P.o.2 + pullback R ⊤ P.i ⋙ MorphismProperty.pushforward R P.hp ⋙ map ⊤ P.ho /-- The action of a univariate polynomial on objects. -/ def apply (P : MvPoly R H I O E B) : R.Over ⊤ I → R.Over ⊤ O := (functor P).obj @@ -578,30 +586,30 @@ variable {P : MvPoly R H I O E B} {Γ : 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.1 P.p).obj (fst pair) +abbrev sndDom (pair : Γ ⟶ (P @ X).toComma) : Over I := (leftAdjoint P.i P.hp).obj (fst pair) def snd (pair : Γ ⟶ (P @ X).toComma) : sndDom pair ⟶ X.toComma := - homEquiv P.i.1 P.p (Over.homMk (pair.left)) + homEquiv P.i P.hp (Over.homMk (pair.left)) lemma snd_eq (pair : Γ ⟶ (P @ X).toComma) : snd pair = - (leftAdjoint P.i.1 P.p).map (Over.homMk (pair.left)) ≫ sndProj P X := by + (leftAdjoint P.i P.hp).map (Over.homMk (pair.left)) ≫ sndProj P X := by erw [Equiv.apply_eq_iff_eq_symm_apply, ← homEquiv_comp_symm] simp [sndProj, counit] -def mk (f : Over B) (hf : Γ = (Over.map P.o.1).obj f) - (s : (leftAdjoint P.i.1 P.p).obj f ⟶ X.toComma) : +def mk (f : Over B) (hf : Γ = (Over.map P.o).obj f) + (s : (leftAdjoint P.i P.hp).obj f ⟶ X.toComma) : Γ ⟶ (P @ X).toComma := - eqToHom hf ≫ (Over.map P.o.fst).map ((homEquiv P.i.1 P.p).symm s) + eqToHom hf ≫ (Over.map P.o).map ((homEquiv P.i P.hp).symm s) @[simp] -lemma fst_mk (f : Over B) (hf : Γ = (Over.map P.o.1).obj f) - (s : (leftAdjoint P.i.1 P.p).obj f ⟶ X.toComma) : fst (mk f hf s) = f := by +lemma fst_mk (f : Over B) (hf : Γ = (Over.map P.o).obj f) + (s : (leftAdjoint P.i P.hp).obj f ⟶ X.toComma) : fst (mk f hf s) = f := by subst hf; simp [fst, mk]; rfl -lemma snd_mk (f : Over B) (hf : Γ = (Over.map P.o.1).obj f) - (s : (leftAdjoint P.i.1 P.p).obj f ⟶ X.toComma) : snd (mk f hf s) = +lemma snd_mk (f : Over B) (hf : Γ = (Over.map P.o).obj f) + (s : (leftAdjoint P.i P.hp).obj f ⟶ X.toComma) : snd (mk f hf s) = eqToHom (by simp) ≫ s := calc snd (mk f hf s) - _ = (leftAdjoint P.i.1 P.p).map (eqToHom (fst_mk f hf s)) ≫ s := by + _ = (leftAdjoint P.i P.hp).map (eqToHom (fst_mk f hf s)) ≫ s := by erw [Equiv.apply_eq_iff_eq_symm_apply, ← homEquiv_comp_symm] ext simp [mk] @@ -609,7 +617,7 @@ lemma snd_mk (f : Over B) (hf : Γ = (Over.map P.o.1).obj f) simp only [eqToHom_map] @[simp] -lemma map_fst (pair : Γ ⟶ (P @ X).toComma) : (Over.map P.o.fst).obj (fst pair) = Γ := by +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 @@ -623,13 +631,18 @@ lemma eta (pair : Γ ⟶ (P @ X).toComma) : mk (fst pair) (by simp) (snd pair) = end Equiv -instance (X Y) (δ : X ⟶ Y) (rδ : R δ) : (MorphismProperty.Over.pullback R ⊤ δ).IsRightAdjoint := - Adjunction.isRightAdjoint (MorphismProperty.Over.mapPullbackAdj R ⊤ δ rδ trivial) - --- (MorphismProperty.Over.pullback R ⊤ δ ⋙ MorphismProperty.Over.map ⊤ ⋯) +-- 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.fst ⋙ R.pushforward P.p ⋙ - MorphismProperty.Over.map ⊤ P.o.2) := + (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) : @@ -660,21 +673,21 @@ 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.1 + pullback P.i pushforward P.p.1 map P.o ``` -/ def verticalNatTrans {F : C} (P : MvPoly R H I O E B) (Q : MvPoly R H I O F B) (ρ : E ⟶ F) - (hi : P.i.1 = ρ ≫ Q.i.1) (hp : P.p.1 = ρ ≫ Q.p.1) (ho : P.o.1 = Q.o.1) : + (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.1 P.p Q.i.1 Q.p ρ hi hp) ◫ + ((PolynomialPartialAdjunction.partialRightAdjointMap P.i P.hp Q.i Q.hp ρ hi hp) ◫ (eqToHom (by rw! [ho]))) ≫ (Functor.associator _ _ _).hom section -variable {F} (Q : MvPoly R H I O F B) (ρ : E ⟶ F) (hi : P.i.1 = ρ ≫ Q.i.1) - (hp : P.p.1 = ρ ≫ Q.p.1) (ho : P.o.1 = Q.o.1) +variable {F} (Q : MvPoly R H I O F B) (ρ : E ⟶ F) (hi : P.i = ρ ≫ Q.i) + (hp : P.p = ρ ≫ Q.p) (ho : P.o = Q.o) lemma fst_verticalNatTrans_app {Γ} {X} (pair : Γ ⟶ (Q @ X).toComma) : Equiv.fst (pair ≫ ((verticalNatTrans P Q ρ hi hp ho).app X).hom) = Equiv.fst pair := by @@ -726,32 +739,32 @@ R.Over I ------ > R.Over E --------> R.Over B --------> R.Over O ``` -/ def cartesianNatTrans {E' B' : C} (P : MvPoly R H I O E B) (P' : MvPoly R H I O E' B') - (δ : B ⟶ B') (φ : E ⟶ E') (hφ : P.i.1 = φ ≫ P'.i.1) (pb : IsPullback φ P.p.1 P'.p.1 δ) - (hδ : δ ≫ P'.o.1 = P.o.1) : + (δ : 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.1) - (MorphismProperty.Over.pullback R ⊤ P.i.1) (MorphismProperty.Over.pullback R ⊤ φ) := - (eqToIso (by simp [hφ, Functor.id_comp]) ≪≫ (MorphismProperty.Over.pullbackComp φ P'.i.1)).hom - have : IsIso (pushforwardPullbackTwoSquare (R := R) φ P.p P'.p δ pb.w) := - pushforwardPullbackTwoSquare_isIso R φ P.p P'.p δ pb + 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 + have : IsIso (pushforwardPullbackTwoSquare (R := R) φ δ pb.w P.hp P'.hp) := + pushforwardPullbackTwoSquare_isIso R φ δ pb.w P.hp P'.hp pb let cellMid : TwoSquare (MorphismProperty.Over.pullback R ⊤ φ) - (R.pushforward P'.p) (R.pushforward P.p) (MorphismProperty.Over.pullback R ⊤ δ) := - CategoryTheory.inv (pushforwardPullbackTwoSquare φ P.p P'.p δ pb.w) + (R.pushforward P'.hp) (R.pushforward P.hp) (MorphismProperty.Over.pullback R ⊤ δ) := + CategoryTheory.inv (pushforwardPullbackTwoSquare φ δ pb.w P.hp P'.hp) let cellRight : TwoSquare (MorphismProperty.Over.pullback R ⊤ δ) - (MorphismProperty.Over.map ⊤ P'.o.2) (MorphismProperty.Over.map ⊤ P.o.2) (𝟭 _) := - (pullbackMapTwoSquare R P.o.1 δ (𝟙 _) P'.o.1 P'.o.2 P.o.2 (by simp [hδ])) ≫ + (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 open NatTrans in theorem isCartesian_cartesianNatTrans {E' B' : C} (P : MvPoly R H I O E B) (P' : MvPoly R H I O E' B') - (δ : B ⟶ B') (φ : E ⟶ E') (hφ : P.i.1 = φ ≫ P'.i.1) (pb : IsPullback φ P.p.1 P'.p.1 δ) - (hδ : δ ≫ P'.o.1 = P.o.1) : + (δ : 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 := by dsimp [cartesianNatTrans] -- NOTE: this lemma could be extracted, but `repeat' apply IsCartesian.comp` will unfold past it. -- have : NatTrans.IsCartesian - -- (pullbackMapTwoSquare R P.o.1 δ (𝟙 _) P'.o.1 P'.o.2 P.o.2 (by simp [hδ])) := by + -- (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 @@ -759,7 +772,7 @@ theorem isCartesian_cartesianNatTrans {E' B' : C} (P : MvPoly R H I O E B) (P' : -- -- 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.o.2) := sorry + -- -- (MorphismProperty.Over.pullback R ⊤ δ ⋙ MorphismProperty.Over.map ⊤ P.ho) := sorry -- any_goals apply isCartesian_of_isIso -- · sorry --refine IsCartesian.whiskerRight _ _ -- · apply IsCartesian.whiskerLeft @@ -829,17 +842,19 @@ open ChosenTerminal variable [R.IsStableUnderComposition] [R.HasPullbacks] [R.IsStableUnderBaseChange] [R.HasObjects] [R.IsStableUnderPushforward R] [R.HasPushforwards R] -abbrev morphismProperty' (P : UvPoly R E B) : E ⟶(R) B := ⟨ P.p, P.morphismProperty ⟩ +-- abbrev morphismProperty' (P : UvPoly R E B) : E ⟶(R) B := ⟨ P.p, P.morphismProperty ⟩ -instance (P : UvPoly R E B) {Γ : C} (A : Γ ⟶ B) : HasPullback A P.p := by - convert_to HasPullback A (morphismProperty' P).1 - apply MorphismProperty.instHasPullbackFstHomOfHasPullbacks +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 _ _ -def object (X : C) : X ⟶(R) (𝟭_ C) := - ⟨ isTerminal.from X, HasObjects.obj_mem _ ChosenTerminal.isTerminal⟩ +lemma isTerminal_from (X : C) : R (isTerminal.from X) := + HasObjects.obj_mem _ ChosenTerminal.isTerminal + +-- def object (X : C) : X ⟶(R) (𝟭_ C) := +-- ⟨ isTerminal.from X, HasObjects.obj_mem _ ChosenTerminal.isTerminal⟩ @[simp] abbrev toOverTerminal : C ⥤ R.Over ⊤ (𝟭_ C) := @@ -851,9 +866,12 @@ abbrev fromOverTerminal : R.Over ⊤ (𝟭_ C) ⥤ C := @[simps] def mvPoly (P : UvPoly R E B) : MvPoly R R (𝟭_ C) (𝟭_ C) E B where - i := object E - p := morphismProperty' P - o := object B + i := isTerminal.from _ + hi := isTerminal_from _ + p := P.p + hp := P.morphismProperty + o := isTerminal.from _ + ho := isTerminal_from _ def functor (P : UvPoly R E B) : C ⥤ C := toOverTerminal ⋙ @@ -1085,7 +1103,7 @@ theorem snd_eq_snd' (pair : Γ ⟶ P @ X) : snd pair = snd' pair (.of_hasPullbac /-- 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.fst P.mvPoly.p).obj (Over.mk b) ⟶ + (PolynomialPartialAdjunction.leftAdjoint P.mvPoly.i P.mvPoly.hp).obj (Over.mk b) ⟶ ((toOverTerminal (R := R)).obj X).toComma := Over.homMk x (isTerminal.hom_ext ..) @@ -1480,7 +1498,6 @@ lemma mk'_comp_verticalNatTrans_app {Γ : C} (X : C) (b : Γ ⟶ B) {R f g} 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) := diff --git a/HoTTLean/Groupoids/SplitIsofibration.lean b/HoTTLean/Groupoids/SplitIsofibration.lean new file mode 100644 index 00000000..9fc3e565 --- /dev/null +++ b/HoTTLean/Groupoids/SplitIsofibration.lean @@ -0,0 +1,260 @@ +import HoTTLean.ForMathlib.CategoryTheory.ClovenIsofibration +import HoTTLean.Groupoids.Pi + +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⟩) + +-- instance : SplitIsofibration.HasObjects where +-- obj_mem {X Y} F G := sorry + +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_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[← 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] + } + +/-- Naturality in the universal property of the pushforward. -/ +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[pushforwardHomEquiv] + sorry + +#exit +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 := + fun F _ G => { + has_representation := ⟨pushforward F.2 G.2, ⟨pushforward_isPushforward F.2 G.2⟩⟩ } + +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 .. + } ) + +-- This should follow from `Groupoidal.forget` being an splitIsofibration. +-- (If we manage to directly define the pushforward +-- as a grothendieck construction) +theorem splitIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) + {G : C ⟶ B} (hG : SplitIsofibration G) : + SplitIsofibration (pushforwardHom hF hG) := by + unfold Grpd.pushforwardHom homOf --SplitIsofibration + exact ⟨ Functor.ClovenIsofibration.forget _ , + CategoryTheory.Functor.ClovenIsofibration.instIsSplitGroupoidalForget + ⟩ + + ---simp[Grpd.pushforwardHom,SplitIsofibration,homOf] + --apply (Functor.ClovenIsofibration.IsSplit ) + + +-- FIXME. For some reason needed in the proof +-- `SplitIsofibration.IsStableUnderPushforward SplitIsofibration` +instance SplitIsofibration.RespectsIso : SplitIsofibration.RespectsIso := inferInstance + +/- TODO: following instance can be proven like so + 1. any pushforward is isomorphic to a chosen pushforward + This should be proven in general for pushforwards, + and 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 (this is in mathlib, for any `rlp`) + `MorphismProperty.rlp_isMultiplicative` + `MorphismProperty.respectsIso_of_isStableUnderComposition` + 3. The chosen pushforward is an splitIsofibration `splitIsofibration_pushforward` -/ + +instance : SplitIsofibration.IsStableUnderPushforward SplitIsofibration where + of_isPushforward F G P := by + intro h + have p : (Over.mk P) ≅ Grpd.pushforward (F.snd) (G.snd) := + isoPushforwardOfIsPushforward F.snd (Over.mk G.fst) G.snd (Over.mk P) h + have i1 : SplitIsofibration (pushforwardHom (F.snd) (G.snd)) := by + apply splitIsofibration_pushforward + have e : P = (p.hom).left ≫ (pushforwardHom (F.snd) (G.snd)) := by + have ee := Over.w p.hom + simp at ee + simp [ee] + simp only[e] + apply (SplitIsofibration.RespectsIso).precomp + assumption 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" From 681b1f0f1497eea2aadcbbceec3a11d06a959579 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Mon, 3 Nov 2025 19:46:22 -0500 Subject: [PATCH 17/95] feat: pushforward of split isofibrations --- .../MorphismProperty/Limits.lean | 819 +----------------- HoTTLean/Groupoids/SplitIsofibration.lean | 89 +- 2 files changed, 41 insertions(+), 867 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean index f0bb1b70..5852bfd8 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean @@ -3,11 +3,7 @@ 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.Limits.Final -import Mathlib.CategoryTheory.Limits.Connected -import Mathlib.CategoryTheory.Filtered.Connected -import Mathlib.CategoryTheory.Limits.Shapes.Diagonal -import Mathlib.CategoryTheory.MorphismProperty.Composition +import Mathlib.CategoryTheory.MorphismProperty.Limits /-! # Relation of morphism properties with limits @@ -39,167 +35,12 @@ section variable (P : MorphismProperty C) -/-- Given a class of morphisms `P`, this is the class of pullbacks -of morphisms in `P`. -/ -def pullbacks : MorphismProperty C := fun A B q ↦ - ∃ (X Y : C) (p : X ⟶ Y) (f : A ⟶ X) (g : B ⟶ Y) (_ : P p), - IsPullback f q p g - -lemma pullbacks_mk {A B X Y : C} {f : A ⟶ X} {q : A ⟶ B} {p : X ⟶ Y} {g : B ⟶ Y} - (sq : IsPullback f q p g) (hp : P p) : - P.pullbacks q := - ⟨_, _, _, _, _, hp, sq⟩ - -lemma le_pullbacks : P ≤ P.pullbacks := by - intro A B q hq - exact P.pullbacks_mk IsPullback.of_id_fst hq - -lemma pullbacks_monotone : Monotone (pullbacks (C := C)) := by - rintro _ _ h _ _ _ ⟨_, _, _, _, _, hp, sq⟩ - exact ⟨_, _, _, _, _, h _ hp, sq⟩ - -/-- Given a class of morphisms `P`, this is the class of pushouts -of morphisms in `P`. -/ -def pushouts : MorphismProperty C := fun X Y q ↦ - ∃ (A B : C) (p : A ⟶ B) (f : A ⟶ X) (g : B ⟶ Y) (_ : P p), - IsPushout f p q g - -lemma pushouts_mk {A B X Y : C} {f : A ⟶ X} {q : A ⟶ B} {p : X ⟶ Y} {g : B ⟶ Y} - (sq : IsPushout f q p g) (hq : P q) : - P.pushouts p := - ⟨_, _, _, _, _, hq, sq⟩ - -lemma le_pushouts : P ≤ P.pushouts := by - intro X Y p hp - exact P.pushouts_mk IsPushout.of_id_fst hp - -lemma pushouts_monotone : Monotone (pushouts (C := C)) := by - rintro _ _ h _ _ _ ⟨_, _, _, _, _, hp, sq⟩ - exact ⟨_, _, _, _, _, h _ hp, sq⟩ - -instance : P.pushouts.RespectsIso := - RespectsIso.of_respects_arrow_iso _ (by - rintro q q' e ⟨A, B, p, f, g, hp, h⟩ - exact ⟨A, B, p, f ≫ e.hom.left, g ≫ e.hom.right, hp, - IsPushout.paste_horiz h (IsPushout.of_horiz_isIso ⟨e.hom.w⟩)⟩) - -instance : P.pullbacks.RespectsIso := - RespectsIso.of_respects_arrow_iso _ (by - rintro q q' e ⟨X, Y, p, f, g, hp, h⟩ - exact ⟨X, Y, p, e.inv.left ≫ f, e.inv.right ≫ g, hp, - IsPullback.paste_horiz (IsPullback.of_horiz_isIso ⟨e.inv.w⟩) h⟩) - -/-- If `P : MorphismProperty C` is such that any object in `C` maps to the -target of some morphism in `P`, then `P.pushouts` contains the isomorphisms. -/ -lemma isomorphisms_le_pushouts - (h : ∀ (X : C), ∃ (A B : C) (p : A ⟶ B) (_ : P p) (_ : B ⟶ X), IsIso p) : - isomorphisms C ≤ P.pushouts := by - intro X Y f (_ : IsIso f) - obtain ⟨A, B, p, hp, g, _⟩ := h X - exact ⟨A, B, p, p ≫ g, g ≫ f, hp, (IsPushout.of_id_snd (f := p ≫ g)).of_iso - (Iso.refl _) (Iso.refl _) (asIso p) (asIso f) (by simp) (by simp) (by simp) (by simp)⟩ - -/-- A morphism property is `IsStableUnderBaseChange` if the base change of such a morphism -still falls in the class. -/ -class IsStableUnderBaseChange : Prop where - of_isPullback {X Y Y' S : C} {f : X ⟶ S} {g : Y ⟶ S} {f' : Y' ⟶ Y} {g' : Y' ⟶ X} - (sq : IsPullback f' g' g f) (hg : P g) : P g' - -instance : P.pullbacks.IsStableUnderBaseChange where - of_isPullback := by - rintro _ _ _ _ _ _ _ _ h ⟨_, _, _, _, _, hp, hq⟩ - exact P.pullbacks_mk (h.paste_horiz hq) hp - -/-- A morphism property is `IsStableUnderCobaseChange` if the cobase change of such a morphism -still falls in the class. -/ -class IsStableUnderCobaseChange : Prop where - of_isPushout {A A' B B' : C} {f : A ⟶ A'} {g : A ⟶ B} {f' : B ⟶ B'} {g' : A' ⟶ B'} - (sq : IsPushout g f f' g') (hf : P f) : P f' - -instance : P.pushouts.IsStableUnderCobaseChange where - of_isPushout := by - rintro _ _ _ _ _ _ _ _ h ⟨_, _, _, _, _, hp, hq⟩ - exact P.pushouts_mk (hq.paste_horiz h) hp - /-- `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 -variable {P} in -lemma of_isPullback [P.IsStableUnderBaseChange] - {X Y Y' S : C} {f : X ⟶ S} {g : Y ⟶ S} {f' : Y' ⟶ Y} {g' : Y' ⟶ X} - (sq : IsPullback f' g' g f) (hg : P g) : P g' := - IsStableUnderBaseChange.of_isPullback sq hg - -lemma isStableUnderBaseChange_iff_pullbacks_le : - P.IsStableUnderBaseChange ↔ P.pullbacks ≤ P := by - constructor - · intro h _ _ _ ⟨_, _, _, _, _, h₁, h₂⟩ - exact of_isPullback h₂ h₁ - · intro h - constructor - intro _ _ _ _ _ _ _ _ h₁ h₂ - exact h _ ⟨_, _, _, _, _, h₂, h₁⟩ - -lemma pullbacks_le [P.IsStableUnderBaseChange] : P.pullbacks ≤ P := by - rwa [← isStableUnderBaseChange_iff_pullbacks_le] - -variable {P} in -/-- Alternative constructor for `IsStableUnderBaseChange`. -/ -theorem IsStableUnderBaseChange.mk' [RespectsIso P] - (hP₂ : ∀ (X Y S : C) (f : X ⟶ S) (g : Y ⟶ S) [HasPullback f g] (_ : P g), - P (pullback.fst f g)) : - IsStableUnderBaseChange P where - of_isPullback {X Y Y' S f g f' g'} sq hg := by - haveI : HasPullback f g := sq.flip.hasPullback - let e := sq.flip.isoPullback - rw [← P.cancel_left_of_respectsIso e.inv, sq.flip.isoPullback_inv_fst] - exact hP₂ _ _ _ f g hg - -variable (C) - -instance IsStableUnderBaseChange.isomorphisms : - (isomorphisms C).IsStableUnderBaseChange where - of_isPullback {_ _ _ _ f g _ _} h hg := - have : IsIso g := hg - have := hasPullback_of_left_iso g f - h.isoPullback_hom_snd ▸ inferInstanceAs (IsIso _) - -instance IsStableUnderBaseChange.monomorphisms : - (monomorphisms C).IsStableUnderBaseChange where - of_isPullback {X Y Y' S f g f' g'} h hg := by - have : Mono g := hg - constructor - intro Z f₁ f₂ h₁₂ - apply PullbackCone.IsLimit.hom_ext h.isLimit - · rw [← cancel_mono g] - dsimp - simp only [Category.assoc, h.w, reassoc_of% h₁₂] - · exact h₁₂ - -variable {C P} - -instance (priority := 900) IsStableUnderBaseChange.respectsIso - [IsStableUnderBaseChange P] : RespectsIso P := by - apply RespectsIso.of_respects_arrow_iso - intro f g e - exact of_isPullback (IsPullback.of_horiz_isIso (CommSq.mk e.inv.w)) - -theorem pullback_fst [IsStableUnderBaseChange P] - {X Y S : C} (f : X ⟶ S) (g : Y ⟶ S) [HasPullback f g] (H : P g) : - P (pullback.fst f g) := - of_isPullback (IsPullback.of_hasPullback f g).flip H - -theorem pullback_snd [IsStableUnderBaseChange P] - {X Y S : C} (f : X ⟶ S) (g : Y ⟶ S) [HasPullback f g] (H : P f) : - P (pullback.snd f g) := - of_isPullback (IsPullback.of_hasPullback f g) H - -theorem baseChange_obj [IsStableUnderBaseChange P] {S S' : C} (f : S' ⟶ S) - [HasPullbacksAlong f] (X : Over S) (H : P X.hom) : - P ((Over.pullback f).obj X).hom := - pullback_snd X.hom f H +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] @@ -211,663 +52,9 @@ theorem baseChange_map' [IsStableUnderBaseChange P] {S S' X Y : C} (f : S' ⟶ S refine IsPullback.of_bot ?_ (by simp) (IsPullback.of_hasPullback v₂₂ f) simpa using IsPullback.of_hasPullback (g ≫ v₂₂) f -theorem baseChange_map [IsStableUnderBaseChange P] {S S' : C} (f : S' ⟶ S) - [HasPullbacksAlong f] {X Y : Over S} (g : X ⟶ Y) (H : P g.left) : - P ((Over.pullback f).map g).left := by - dsimp only [Over.pullback_obj_left, Over.pullback_map_left] - convert baseChange_map' f (g.w.symm) H <;> simp - local instance {S X Y : C} {f : X ⟶ S} [HasPullbacksAlong f] {g : Y ⟶ S} : HasPullback f g := hasPullback_symmetry g f -theorem pullback_map - [IsStableUnderBaseChange P] [P.IsStableUnderComposition] {S X X' Y Y' : C} {f : X ⟶ S} - [HasPullbacksAlong f] {g : Y ⟶ S} {f' : X' ⟶ S} {g' : Y' ⟶ S} {i₁ : X ⟶ X'} - [HasPullbacksAlong g'] {i₂ : Y ⟶ Y'} (h₁ : P i₁) (h₂ : P i₂) - (e₁ : f = i₁ ≫ f') (e₂ : g = i₂ ≫ g') : - P (pullback.map f g f' g' i₁ i₂ (𝟙 _) ((Category.comp_id _).trans e₁) - ((Category.comp_id _).trans e₂)) := by - have : HasPullbacksAlong (Over.mk f).hom := by aesop_cat - have : pullback.map f g f' g' i₁ i₂ (𝟙 _) ((Category.comp_id _).trans e₁) - ((Category.comp_id _).trans e₂) = - ((pullbackSymmetry _ _).hom ≫ - ((Over.pullback _).map (Over.homMk _ e₂.symm : Over.mk g ⟶ Over.mk g')).left) ≫ - (pullbackSymmetry _ _).hom ≫ - ((Over.pullback g').map (Over.homMk _ e₁.symm : Over.mk f ⟶ Over.mk f')).left := by - ext <;> simp - rw [this] - apply P.comp_mem <;> rw [P.cancel_left_of_respectsIso] - exacts [baseChange_map _ (Over.homMk _ e₂.symm : Over.mk g ⟶ Over.mk g') h₂, - baseChange_map _ (Over.homMk _ e₁.symm : Over.mk f ⟶ Over.mk f') h₁] - -instance IsStableUnderBaseChange.hasOfPostcompProperty_monomorphisms - [P.IsStableUnderBaseChange] : P.HasOfPostcompProperty (MorphismProperty.monomorphisms C) where - of_postcomp {X Y Z} f g (hg : Mono g) hcomp := by - have : f = (asIso (pullback.fst (f ≫ g) g)).inv ≫ pullback.snd (f ≫ g) g := by - simp [← cancel_mono g, pullback.condition] - rw [this, cancel_left_of_respectsIso (P := P)] - exact P.pullback_snd _ _ hcomp - -lemma of_isPushout [P.IsStableUnderCobaseChange] - {A A' B B' : C} {f : A ⟶ A'} {g : A ⟶ B} {f' : B ⟶ B'} {g' : A' ⟶ B'} - (sq : IsPushout g f f' g') (hf : P f) : P f' := - IsStableUnderCobaseChange.of_isPushout sq hf - -lemma isStableUnderCobaseChange_iff_pushouts_le : - P.IsStableUnderCobaseChange ↔ P.pushouts ≤ P := by - constructor - · intro h _ _ _ ⟨_, _, _, _, _, h₁, h₂⟩ - exact of_isPushout h₂ h₁ - · intro h - constructor - intro _ _ _ _ _ _ _ _ h₁ h₂ - exact h _ ⟨_, _, _, _, _, h₂, h₁⟩ - -lemma pushouts_le [P.IsStableUnderCobaseChange] : P.pushouts ≤ P := by - rwa [← isStableUnderCobaseChange_iff_pushouts_le] - -@[simp] -lemma pushouts_le_iff {P Q : MorphismProperty C} [Q.IsStableUnderCobaseChange] : - P.pushouts ≤ Q ↔ P ≤ Q := by - constructor - · exact le_trans P.le_pushouts - · intro h - exact le_trans (pushouts_monotone h) pushouts_le - -/-- An alternative constructor for `IsStableUnderCobaseChange`. -/ -theorem IsStableUnderCobaseChange.mk' [RespectsIso P] - (hP₂ : ∀ (A B A' : C) (f : A ⟶ A') (g : A ⟶ B) [HasPushout f g] (_ : P f), - P (pushout.inr f g)) : - IsStableUnderCobaseChange P where - of_isPushout {A A' B B' f g f' g'} sq hf := by - haveI : HasPushout f g := sq.flip.hasPushout - let e := sq.flip.isoPushout - rw [← P.cancel_right_of_respectsIso _ e.hom, sq.flip.inr_isoPushout_hom] - exact hP₂ _ _ _ f g hf - -instance IsStableUnderCobaseChange.isomorphisms : - (isomorphisms C).IsStableUnderCobaseChange where - of_isPushout {_ _ _ _ f g _ _} h (_ : IsIso f) := - have := hasPushout_of_right_iso g f - h.inl_isoPushout_inv ▸ inferInstanceAs (IsIso _) - -variable (C) in -instance IsStableUnderCobaseChange.epimorphisms : - (epimorphisms C).IsStableUnderCobaseChange where - of_isPushout {X Y Y' S f g f' g'} h hf := by - have : Epi f := hf - constructor - intro Z f₁ f₂ h₁₂ - apply PushoutCocone.IsColimit.hom_ext h.isColimit - · exact h₁₂ - · rw [← cancel_epi f] - dsimp - simp only [← reassoc_of% h.w, h₁₂] - -instance IsStableUnderCobaseChange.respectsIso - [IsStableUnderCobaseChange P] : RespectsIso P := - RespectsIso.of_respects_arrow_iso _ fun _ _ e ↦ - of_isPushout (IsPushout.of_horiz_isIso (CommSq.mk e.hom.w)) - -theorem pushout_inl [IsStableUnderCobaseChange P] - {A B A' : C} (f : A ⟶ A') (g : A ⟶ B) [HasPushout f g] (H : P g) : - P (pushout.inl f g) := - of_isPushout (IsPushout.of_hasPushout f g) H - -theorem pushout_inr [IsStableUnderCobaseChange P] - {A B A' : C} (f : A ⟶ A') (g : A ⟶ B) [HasPushout f g] (H : P f) : P (pushout.inr f g) := - of_isPushout (IsPushout.of_hasPushout f g).flip H - -instance IsStableUnderCobaseChange.hasOfPrecompProperty_epimorphisms - [P.IsStableUnderCobaseChange] : P.HasOfPrecompProperty (MorphismProperty.epimorphisms C) where - of_precomp {X Y Z} f g (hf : Epi f) hcomp := by - have : g = pushout.inr (f ≫ g) f ≫ (asIso (pushout.inl (f ≫ g) f)).inv := by - rw [asIso_inv, IsIso.eq_comp_inv, ← cancel_epi f, ← pushout.condition, assoc] - rw [this, cancel_right_of_respectsIso (P := P)] - exact P.pushout_inr _ _ hcomp - -instance IsStableUnderCobaseChange.op [IsStableUnderCobaseChange P] : - IsStableUnderBaseChange P.op where - of_isPullback sq hg := P.of_isPushout sq.unop hg - -instance IsStableUnderCobaseChange.unop {P : MorphismProperty Cᵒᵖ} [IsStableUnderCobaseChange P] : - IsStableUnderBaseChange P.unop where - of_isPullback sq hg := P.of_isPushout sq.op hg - -instance IsStableUnderBaseChange.op [IsStableUnderBaseChange P] : - IsStableUnderCobaseChange P.op where - of_isPushout sq hf := P.of_isPullback sq.unop hf - -instance IsStableUnderBaseChange.unop {P : MorphismProperty Cᵒᵖ} [IsStableUnderBaseChange P] : - IsStableUnderCobaseChange P.unop where - of_isPushout sq hf := P.of_isPullback sq.op hf - -instance IsStableUnderBaseChange.inf {P Q : MorphismProperty C} [IsStableUnderBaseChange P] - [IsStableUnderBaseChange Q] : - IsStableUnderBaseChange (P ⊓ Q) where - of_isPullback hp hg := ⟨of_isPullback hp hg.left, of_isPullback hp hg.right⟩ - -instance IsStableUnderCobaseChange.inf {P Q : MorphismProperty C} [IsStableUnderCobaseChange P] - [IsStableUnderCobaseChange Q] : - IsStableUnderCobaseChange (P ⊓ Q) where - of_isPushout hp hg := ⟨of_isPushout hp hg.left, of_isPushout hp hg.right⟩ - -instance : (⊤ : MorphismProperty C).IsStableUnderBaseChange where - of_isPullback _ _ := trivial - -instance : (⊤ : MorphismProperty C).IsStableUnderCobaseChange where - of_isPushout _ _ := trivial - -end - -section LimitsOfShape - -variable (W : MorphismProperty C) (J : Type*) [Category J] - -/-- The class of morphisms in `C` that are limits of shape `J` of -natural transformations involving morphisms in `W`. -/ -inductive limitsOfShape : MorphismProperty C - | mk (X₁ X₂ : J ⥤ C) (c₁ : Cone X₁) (c₂ : Cone X₂) - (_ : IsLimit c₁) (h₂ : IsLimit c₂) (f : X₁ ⟶ X₂) (_ : W.functorCategory J f) : - limitsOfShape (h₂.lift (Cone.mk _ (c₁.π ≫ f))) - -variable {W J} in -lemma limitsOfShape.mk' (X₁ X₂ : J ⥤ C) (c₁ : Cone X₁) (c₂ : Cone X₂) - (h₁ : IsLimit c₁) (h₂ : IsLimit c₂) (f : X₁ ⟶ X₂) (hf : W.functorCategory J f) - (φ : c₁.pt ⟶ c₂.pt) (hφ : ∀ j, φ ≫ c₂.π.app j = c₁.π.app j ≫ f.app j) : - W.limitsOfShape J φ := by - obtain rfl : φ = h₂.lift (Cone.mk _ (c₁.π ≫ f)) := h₂.hom_ext (fun j ↦ by simp [hφ]) - exact ⟨_, _, _, _, h₁, _, _, hf⟩ - -lemma limitsOfShape_monotone {W₁ W₂ : MorphismProperty C} (h : W₁ ≤ W₂) - (J : Type*) [Category J] : - W₁.limitsOfShape J ≤ W₂.limitsOfShape J := by - rintro _ _ _ ⟨_, _, _, _, h₁, _, f, hf⟩ - exact ⟨_, _, _, _, h₁, _, f, fun j ↦ h _ (hf j)⟩ - -instance : (W.limitsOfShape J).RespectsIso := - RespectsIso.of_respects_arrow_iso _ (by - rintro ⟨_, _, f⟩ ⟨Y₁, Y₂, g⟩ e ⟨X₁, X₂, c₁, c₂, h₁, h₂, f, hf⟩ - let e₁ := Arrow.leftFunc.mapIso e - let e₂ := Arrow.rightFunc.mapIso e - have fac : g ≫ e₂.inv = e₁.inv ≫ h₂.lift (Cone.mk _ (c₁.π ≫ f)) := - e.inv.w.symm - let c₁' : Cone X₁ := { pt := Y₁, π := (Functor.const _).map e₁.inv ≫ c₁.π } - let c₂' : Cone X₂ := { pt := Y₂, π := (Functor.const _).map e₂.inv ≫ c₂.π } - have h₁' : IsLimit c₁' := IsLimit.ofIsoLimit h₁ (Cones.ext e₁) - have h₂' : IsLimit c₂' := IsLimit.ofIsoLimit h₂ (Cones.ext e₂) - obtain hg : h₂'.lift (Cone.mk _ (c₁'.π ≫ f)) = g := - h₂'.hom_ext (fun j ↦ by - rw [h₂'.fac] - simp [reassoc_of% fac, c₁', c₂']) - rw [← hg] - exact ⟨_, _, _, _, h₁', _, _, hf⟩) - -variable {W J} in -lemma limitsOfShape_limMap {X Y : J ⥤ C} - (f : X ⟶ Y) [HasLimit X] [HasLimit Y] (hf : W.functorCategory _ f) : - W.limitsOfShape J (limMap f) := - ⟨_, _, _, _, limit.isLimit X, _, _, hf⟩ - -/-- The property that a morphism property `W` is stable under limits -indexed by a category `J`. -/ -class IsStableUnderLimitsOfShape : Prop where - condition (X₁ X₂ : J ⥤ C) (c₁ : Cone X₁) (c₂ : Cone X₂) - (_ : IsLimit c₁) (h₂ : IsLimit c₂) (f : X₁ ⟶ X₂) (_ : W.functorCategory J f) - (φ : c₁.pt ⟶ c₂.pt) (hφ : ∀ j, φ ≫ c₂.π.app j = c₁.π.app j ≫ f.app j) : W φ - -lemma isStableUnderLimitsOfShape_iff_limitsOfShape_le : - W.IsStableUnderLimitsOfShape J ↔ W.limitsOfShape J ≤ W := by - constructor - · rintro h _ _ _ ⟨_, _, _, _, h₁, h₂, f, hf⟩ - exact h.condition _ _ _ _ h₁ h₂ f hf _ (by simp) - · rintro h - constructor - intro X₁ X₂ c₁ c₂ h₁ h₂ f hf φ hφ - exact h _ (limitsOfShape.mk' X₁ X₂ c₁ c₂ h₁ h₂ f hf φ hφ) - -variable {W J} - -lemma limitsOfShape_le [W.IsStableUnderLimitsOfShape J] : - W.limitsOfShape J ≤ W := by - rwa [← isStableUnderLimitsOfShape_iff_limitsOfShape_le] - -protected lemma limMap [W.IsStableUnderLimitsOfShape J] {X Y : J ⥤ C} - (f : X ⟶ Y) [HasLimit X] [HasLimit Y] (hf : W.functorCategory _ f) : - W (limMap f) := - limitsOfShape_le _ (limitsOfShape_limMap _ hf) - -@[deprecated (since := "2025-05-11")] alias IsStableUnderLimitsOfShape.limitsOfShape_le := - limitsOfShape_le - -@[deprecated (since := "2025-05-11")] alias IsStableUnderLimitsOfShape.limMap := - MorphismProperty.limMap - -end LimitsOfShape - -section ColimitsOfShape - -variable (W : MorphismProperty C) (J : Type*) [Category J] - -/-- The class of morphisms in `C` that are colimits of shape `J` of -natural transformations involving morphisms in `W`. -/ -inductive colimitsOfShape : MorphismProperty C - | mk (X₁ X₂ : J ⥤ C) (c₁ : Cocone X₁) (c₂ : Cocone X₂) - (h₁ : IsColimit c₁) (h₂ : IsColimit c₂) (f : X₁ ⟶ X₂) (_ : W.functorCategory J f) : - colimitsOfShape (h₁.desc (Cocone.mk _ (f ≫ c₂.ι))) - -variable {W J} in -lemma colimitsOfShape.mk' (X₁ X₂ : J ⥤ C) (c₁ : Cocone X₁) (c₂ : Cocone X₂) - (h₁ : IsColimit c₁) (h₂ : IsColimit c₂) (f : X₁ ⟶ X₂) (hf : W.functorCategory J f) - (φ : c₁.pt ⟶ c₂.pt) (hφ : ∀ j, c₁.ι.app j ≫ φ = f.app j ≫ c₂.ι.app j) : - W.colimitsOfShape J φ := by - obtain rfl : φ = h₁.desc (Cocone.mk _ (f ≫ c₂.ι)) := h₁.hom_ext (fun j ↦ by simp [hφ]) - exact ⟨_, _, _, _, _, h₂, _, hf⟩ - -lemma colimitsOfShape_monotone {W₁ W₂ : MorphismProperty C} (h : W₁ ≤ W₂) - (J : Type*) [Category J] : - W₁.colimitsOfShape J ≤ W₂.colimitsOfShape J := by - rintro _ _ _ ⟨_, _, _, _, _, h₂, f, hf⟩ - exact ⟨_, _, _, _, _, h₂, f, fun j ↦ h _ (hf j)⟩ - -variable {J} in -lemma colimitsOfShape_le_of_final {J' : Type*} [Category J'] (F : J ⥤ J') [F.Final] : - W.colimitsOfShape J' ≤ W.colimitsOfShape J := by - intro _ _ _ ⟨X₁, X₂, c₁, c₂, h₁, h₂, f, hf⟩ - have h₁' : IsColimit (c₁.whisker F) := (Functor.Final.isColimitWhiskerEquiv F c₁).symm h₁ - have h₂' : IsColimit (c₂.whisker F) := (Functor.Final.isColimitWhiskerEquiv F c₂).symm h₂ - have : h₁.desc (Cocone.mk c₂.pt (f ≫ c₂.ι)) = - h₁'.desc (Cocone.mk c₂.pt (Functor.whiskerLeft _ f ≫ (c₂.whisker F).ι)) := - h₁'.hom_ext (fun j ↦ by - have := h₁'.fac (Cocone.mk c₂.pt (Functor.whiskerLeft F f ≫ Functor.whiskerLeft F c₂.ι)) j - dsimp at this ⊢ - simp [this]) - rw [this] - exact ⟨_, _, _, _, h₁', h₂', _, fun _ ↦ hf _⟩ - -variable {J} in -lemma colimitsOfShape_eq_of_equivalence {J' : Type*} [Category J'] (e : J ≌ J') : - W.colimitsOfShape J = W.colimitsOfShape J' := - le_antisymm (W.colimitsOfShape_le_of_final e.inverse) - (W.colimitsOfShape_le_of_final e.functor) - -instance : (W.colimitsOfShape J).RespectsIso := - RespectsIso.of_respects_arrow_iso _ (by - rintro ⟨_, _, f⟩ ⟨Y₁, Y₂, g⟩ e ⟨X₁, X₂, c₁, c₂, h₁, h₂, f, hf⟩ - let e₁ := Arrow.leftFunc.mapIso e - let e₂ := Arrow.rightFunc.mapIso e - have fac : e₁.hom ≫ g = h₁.desc (Cocone.mk _ (f ≫ c₂.ι)) ≫ e₂.hom := e.hom.w - let c₁' : Cocone X₁ := { pt := Y₁, ι := c₁.ι ≫ (Functor.const _).map e₁.hom} - let c₂' : Cocone X₂ := { pt := Y₂, ι := c₂.ι ≫ (Functor.const _).map e₂.hom} - have h₁' : IsColimit c₁' := IsColimit.ofIsoColimit h₁ (Cocones.ext e₁) - have h₂' : IsColimit c₂' := IsColimit.ofIsoColimit h₂ (Cocones.ext e₂) - obtain hg : h₁'.desc (Cocone.mk _ (f ≫ c₂'.ι)) = g := - h₁'.hom_ext (fun j ↦ by - rw [h₁'.fac] - simp [fac, c₁', c₂']) - rw [← hg] - exact ⟨_, _, _, _, _, h₂', _, hf⟩) - -variable {W J} in -lemma colimitsOfShape_colimMap {X Y : J ⥤ C} - (f : X ⟶ Y) [HasColimit X] [HasColimit Y] (hf : W.functorCategory _ f) : - W.colimitsOfShape J (colimMap f) := - ⟨_, _, _, _, _, colimit.isColimit Y, _, hf⟩ - -attribute [local instance] IsCofiltered.isConnected in -variable {W} in -lemma colimitsOfShape.of_isColimit - {J : Type*} [Preorder J] [OrderBot J] {F : J ⥤ C} - {c : Cocone F} (hc : IsColimit c) (h : ∀ (j : J), W (F.map (homOfLE bot_le : ⊥ ⟶ j))) : - W.colimitsOfShape J (c.ι.app ⊥) := - .mk' _ _ _ _ (isColimitConstCocone J (F.obj ⊥)) hc - { app k := F.map (homOfLE bot_le) - naturality _ _ _ := by - dsimp - rw [Category.id_comp, ← Functor.map_comp] - rfl} h _ (by simp) - -/-- The property that a morphism property `W` is stable under colimits -indexed by a category `J`. -/ -class IsStableUnderColimitsOfShape : Prop where - condition (X₁ X₂ : J ⥤ C) (c₁ : Cocone X₁) (c₂ : Cocone X₂) - (h₁ : IsColimit c₁) (h₁ : IsColimit c₂) (f : X₁ ⟶ X₂) (_ : W.functorCategory J f) - (φ : c₁.pt ⟶ c₂.pt) (hφ : ∀ j, c₁.ι.app j ≫ φ = f.app j ≫ c₂.ι.app j) : W φ - -lemma isStableUnderColimitsOfShape_iff_colimitsOfShape_le : - W.IsStableUnderColimitsOfShape J ↔ W.colimitsOfShape J ≤ W := by - constructor - · rintro h _ _ _ ⟨_, _, _, _, h₁, h₂, f, hf⟩ - exact h.condition _ _ _ _ h₁ h₂ f hf _ (by simp) - · rintro h - constructor - intro X₁ X₂ c₁ c₂ h₁ h₂ f hf φ hφ - exact h _ (colimitsOfShape.mk' X₁ X₂ c₁ c₂ h₁ h₂ f hf φ hφ) - -variable {W J} - -lemma colimitsOfShape_le [W.IsStableUnderColimitsOfShape J] : - W.colimitsOfShape J ≤ W := by - rwa [← isStableUnderColimitsOfShape_iff_colimitsOfShape_le] - -protected lemma colimMap [W.IsStableUnderColimitsOfShape J] {X Y : J ⥤ C} - (f : X ⟶ Y) [HasColimit X] [HasColimit Y] (hf : W.functorCategory _ f) : - W (colimMap f) := - colimitsOfShape_le _ (colimitsOfShape_colimMap _ hf) - -@[deprecated (since := "2025-05-11")] alias IsStableUnderColimitsOfShape.colimMap := - MorphismProperty.colimMap - -@[deprecated (since := "2025-05-11")] alias IsStableUnderColimitsOfShape.colimitsOfShape_le := - colimitsOfShape_le - -variable (C J) in -instance IsStableUnderColimitsOfShape.isomorphisms : - (isomorphisms C).IsStableUnderColimitsOfShape J where - condition F₁ F₂ c₁ c₂ h₁ h₂ f (_ : ∀ j, IsIso (f.app j)) φ hφ := by - have := NatIso.isIso_of_isIso_app f - exact ⟨h₂.desc (Cocone.mk _ (inv f ≫ c₁.ι)), - h₁.hom_ext (fun j ↦ by simp [reassoc_of% (hφ j)]), - h₂.hom_ext (by simp [hφ])⟩ - -end ColimitsOfShape - -/-- The condition that a property of morphisms is stable by filtered colimits. -/ -@[pp_with_univ] -class IsStableUnderFilteredColimits (W : MorphismProperty C) : Prop where - isStableUnderColimitsOfShape (J : Type w') [Category.{w} J] [IsFiltered J] : - W.IsStableUnderColimitsOfShape J := by infer_instance - -attribute [instance] IsStableUnderFilteredColimits.isStableUnderColimitsOfShape - -instance : IsStableUnderFilteredColimits.{w, w'} (isomorphisms C) where - -section Coproducts - -variable (W : MorphismProperty C) - -/-- Given `W : MorphismProperty C`, this is class of morphisms that are -isomorphic to a coproduct of a family (indexed by some `J : Type w`) of maps in `W`. -/ -@[pp_with_univ] -def coproducts : MorphismProperty C := ⨆ (J : Type w), W.colimitsOfShape (Discrete J) - -lemma colimitsOfShape_le_coproducts (J : Type w) : - W.colimitsOfShape (Discrete J) ≤ coproducts.{w} W := - le_iSup (f := fun (J : Type w) ↦ W.colimitsOfShape (Discrete J)) J - -lemma coproducts_iff {X Y : C} (f : X ⟶ Y) : - coproducts.{w} W f ↔ ∃ (J : Type w), W.colimitsOfShape (Discrete J) f := by - simp only [coproducts, iSup_iff] - -lemma coproducts_of_small {X Y : C} (f : X ⟶ Y) {J : Type w'} - (hf : W.colimitsOfShape (Discrete J) f) [Small.{w} J] : - coproducts.{w} W f := by - rw [coproducts_iff] - refine ⟨Shrink J, ?_⟩ - rwa [← W.colimitsOfShape_eq_of_equivalence (Discrete.equivalence (equivShrink.{w} J))] - -lemma le_colimitsOfShape_punit : W ≤ W.colimitsOfShape (Discrete PUnit.{w + 1}) := by - intro X₁ X₂ f hf - have h := initialIsInitial (C := Discrete (PUnit.{w + 1})) - let c₁ := coconeOfDiagramInitial (F := Discrete.functor (fun _ ↦ X₁)) h - let c₂ := coconeOfDiagramInitial (F := Discrete.functor (fun _ ↦ X₂)) h - have hc₁ : IsColimit c₁ := colimitOfDiagramInitial h _ - have hc₂ : IsColimit c₂ := colimitOfDiagramInitial h _ - have : hc₁.desc (Cocone.mk _ (Discrete.natTrans (fun _ ↦ by exact f) ≫ c₂.ι)) = f := - hc₁.hom_ext (fun x ↦ by - obtain rfl : x = ⊥_ _ := by ext - rw [IsColimit.fac] - simp [c₁, c₂]) - rw [← this] - exact ⟨_, _, _, _, _, hc₂, _, fun _ ↦ hf⟩ - -lemma le_coproducts : W ≤ coproducts.{w} W := - (le_colimitsOfShape_punit.{w} W).trans - (colimitsOfShape_le_coproducts W PUnit.{w + 1}) - -lemma coproducts_monotone : Monotone (coproducts.{w} (C := C)) := by - rintro W₁ W₂ h X Y f hf - rw [coproducts_iff] at hf - obtain ⟨J, hf⟩ := hf - exact W₂.colimitsOfShape_le_coproducts J _ - (colimitsOfShape_monotone h _ _ hf) - -end Coproducts - -section Products - -variable (W : MorphismProperty C) - -/-- The property that a morphism property `W` is stable under products indexed by a type `J`. -/ -abbrev IsStableUnderProductsOfShape (J : Type*) := W.IsStableUnderLimitsOfShape (Discrete J) - -/-- The property that a morphism property `W` is stable under coproducts indexed by a type `J`. -/ -abbrev IsStableUnderCoproductsOfShape (J : Type*) := W.IsStableUnderColimitsOfShape (Discrete J) - -lemma IsStableUnderProductsOfShape.mk (J : Type*) [W.RespectsIso] - (hW : ∀ (X₁ X₂ : J → C) [HasProduct X₁] [HasProduct X₂] - (f : ∀ j, X₁ j ⟶ X₂ j) (_ : ∀ (j : J), W (f j)), - W (Limits.Pi.map f)) : W.IsStableUnderProductsOfShape J where - condition X₁ X₂ c₁ c₂ hc₁ hc₂ f hf α hα := by - let φ := fun j => f.app (Discrete.mk j) - have : HasLimit X₁ := ⟨c₁, hc₁⟩ - have : HasLimit X₂ := ⟨c₂, hc₂⟩ - have : HasProduct fun j ↦ X₁.obj (Discrete.mk j) := - hasLimit_of_iso (Discrete.natIso (fun j ↦ Iso.refl (X₁.obj j))) - have : HasProduct fun j ↦ X₂.obj (Discrete.mk j) := - hasLimit_of_iso (Discrete.natIso (fun j ↦ Iso.refl (X₂.obj j))) - have hf' := hW _ _ φ (fun j => hf (Discrete.mk j)) - refine (W.arrow_mk_iso_iff ?_).2 hf' - refine Arrow.isoMk - (IsLimit.conePointUniqueUpToIso hc₁ (limit.isLimit X₁) ≪≫ (Pi.isoLimit X₁).symm) - (IsLimit.conePointUniqueUpToIso hc₂ (limit.isLimit X₂) ≪≫ (Pi.isoLimit _).symm) ?_ - apply limit.hom_ext - rintro ⟨j⟩ - simp [φ, hα] - -lemma IsStableUnderCoproductsOfShape.mk (J : Type*) [W.RespectsIso] - (hW : ∀ (X₁ X₂ : J → C) [HasCoproduct X₁] [HasCoproduct X₂] - (f : ∀ j, X₁ j ⟶ X₂ j) (_ : ∀ (j : J), W (f j)), - W (Limits.Sigma.map f)) : W.IsStableUnderCoproductsOfShape J where - condition X₁ X₂ c₁ c₂ hc₁ hc₂ f hf α hα := by - let φ := fun j => f.app (Discrete.mk j) - have : HasColimit X₁ := ⟨c₁, hc₁⟩ - have : HasColimit X₂ := ⟨c₂, hc₂⟩ - have : HasCoproduct fun j ↦ X₁.obj (Discrete.mk j) := - hasColimit_of_iso (Discrete.natIso (fun j ↦ Iso.refl (X₁.obj j))) - have : HasCoproduct fun j ↦ X₂.obj (Discrete.mk j) := - hasColimit_of_iso (Discrete.natIso (fun j ↦ Iso.refl (X₂.obj j))) - have hf' := hW _ _ φ (fun j => hf (Discrete.mk j)) - refine (W.arrow_mk_iso_iff ?_).1 hf' - refine Arrow.isoMk - ((Sigma.isoColimit _) ≪≫ IsColimit.coconePointUniqueUpToIso (colimit.isColimit X₁) hc₁) - ((Sigma.isoColimit _) ≪≫ IsColimit.coconePointUniqueUpToIso (colimit.isColimit X₂) hc₂) ?_ - apply colimit.hom_ext - rintro ⟨j⟩ - simp [φ, hα] - -/-- The condition that a property of morphisms is stable by finite products. -/ -class IsStableUnderFiniteProducts : Prop where - isStableUnderProductsOfShape (J : Type) [Finite J] : W.IsStableUnderProductsOfShape J - -attribute [instance] IsStableUnderFiniteProducts.isStableUnderProductsOfShape - -/-- The condition that a property of morphisms is stable by finite coproducts. -/ -class IsStableUnderFiniteCoproducts : Prop where - isStableUnderCoproductsOfShape (J : Type) [Finite J] : W.IsStableUnderCoproductsOfShape J - -attribute [instance] IsStableUnderFiniteCoproducts.isStableUnderCoproductsOfShape - -@[deprecated "This is now an instance." (since := "2025-05-11")] -alias isStableUnderProductsOfShape_of_isStableUnderFiniteProducts := - IsStableUnderFiniteProducts.isStableUnderProductsOfShape - -@[deprecated "This is now an instance." (since := "2025-05-11")] -alias isStableUnderCoproductsOfShape_of_isStableUnderFiniteCoproducts := - IsStableUnderFiniteCoproducts.isStableUnderCoproductsOfShape - -/-- The condition that a property of morphisms is stable by coproducts. -/ -@[pp_with_univ] -class IsStableUnderCoproducts : Prop where - isStableUnderCoproductsOfShape (J : Type w) : W.IsStableUnderCoproductsOfShape J := by - infer_instance - -attribute [instance] IsStableUnderCoproducts.isStableUnderCoproductsOfShape - -lemma coproducts_le [IsStableUnderCoproducts.{w} W] : - coproducts.{w} W ≤ W := by - intro X Y f hf - rw [coproducts_iff] at hf - obtain ⟨J, hf⟩ := hf - exact colimitsOfShape_le _ hf - -@[simp] -lemma coproducts_eq_self [IsStableUnderCoproducts.{w} W] : - coproducts.{w} W = W := - le_antisymm W.coproducts_le W.le_coproducts - -@[simp] -lemma coproducts_le_iff {P Q : MorphismProperty C} [IsStableUnderCoproducts.{w} Q] : - coproducts.{w} P ≤ Q ↔ P ≤ Q := by - constructor - · exact le_trans P.le_coproducts - · intro h - exact le_trans (coproducts_monotone h) Q.coproducts_le - -end Products - -section Diagonal - -variable [HasPullbacks C] {P : MorphismProperty C} - -/-- For `P : MorphismProperty C`, `P.diagonal` is a morphism property that holds for `f : X ⟶ Y` -whenever `P` holds for `X ⟶ Y xₓ Y`. -/ -def diagonal (P : MorphismProperty C) : MorphismProperty C := fun _ _ f => P (pullback.diagonal f) - -theorem diagonal_iff {X Y : C} {f : X ⟶ Y} : P.diagonal f ↔ P (pullback.diagonal f) := - Iff.rfl - -instance RespectsIso.diagonal [P.RespectsIso] : P.diagonal.RespectsIso := by - apply RespectsIso.mk - · introv H - rwa [diagonal_iff, pullback.diagonal_comp, P.cancel_left_of_respectsIso, - P.cancel_left_of_respectsIso, ← P.cancel_right_of_respectsIso _ - (pullback.map (e.hom ≫ f) (e.hom ≫ f) f f e.hom e.hom (𝟙 Z) (by simp) (by simp)), - ← pullback.condition, P.cancel_left_of_respectsIso] - · introv H - delta diagonal - rwa [pullback.diagonal_comp, P.cancel_right_of_respectsIso] - -instance diagonal_isStableUnderComposition [P.IsStableUnderComposition] [RespectsIso P] - [IsStableUnderBaseChange P] : P.diagonal.IsStableUnderComposition where - comp_mem _ _ h₁ h₂ := by - rw [diagonal_iff, pullback.diagonal_comp] - exact P.comp_mem _ _ h₁ - (by simpa only [cancel_left_of_respectsIso] using P.pullback_snd _ _ h₂) - -instance IsStableUnderBaseChange.diagonal [IsStableUnderBaseChange P] [P.RespectsIso] : - P.diagonal.IsStableUnderBaseChange := - IsStableUnderBaseChange.mk' - (by - introv h - rw [diagonal_iff, diagonal_pullback_fst, P.cancel_left_of_respectsIso, - P.cancel_right_of_respectsIso] - exact P.baseChange_map f _ (by simpa)) - -lemma diagonal_isomorphisms : (isomorphisms C).diagonal = monomorphisms C := - ext _ _ fun _ _ _ ↦ pullback.isIso_diagonal_iff _ - -/-- If `P` is multiplicative and stable under base change, having the of-postcomp property -w.r.t. `Q` is equivalent to `Q` implying `P` on the diagonal. -/ -lemma hasOfPostcompProperty_iff_le_diagonal [P.IsStableUnderBaseChange] - [P.IsMultiplicative] {Q : MorphismProperty C} [Q.IsStableUnderBaseChange] : - P.HasOfPostcompProperty Q ↔ Q ≤ P.diagonal := by - refine ⟨fun hP X Y f hf ↦ ?_, fun hP ↦ ⟨fun {Y X S} g f hf hcomp ↦ ?_⟩⟩ - · exact hP.of_postcomp _ _ (Q.pullback_fst _ _ hf) (by simpa using P.id_mem X) - · set gr : Y ⟶ pullback (g ≫ f) f := pullback.lift (𝟙 Y) g (by simp) - have : g = gr ≫ pullback.snd _ _ := by simp [gr] - rw [this] - apply P.comp_mem - · exact P.of_isPullback (pullback_lift_diagonal_isPullback g f) (hP _ hf) - · exact P.pullback_snd _ _ hcomp - -end Diagonal - -section Universally - -/-- `P.universally` holds for a morphism `f : X ⟶ Y` iff `P` holds for all `X ×[Y] Y' ⟶ Y'`. -/ -def universally (P : MorphismProperty C) : MorphismProperty C := fun X Y f => - ∀ ⦃X' Y' : C⦄ (i₁ : X' ⟶ X) (i₂ : Y' ⟶ Y) (f' : X' ⟶ Y') (_ : IsPullback f' i₁ i₂ f), P f' - -instance universally_respectsIso (P : MorphismProperty C) : P.universally.RespectsIso := by - apply RespectsIso.mk - · intro X Y Z e f hf X' Z' i₁ i₂ f' H - have : IsPullback (𝟙 _) (i₁ ≫ e.hom) i₁ e.inv := - IsPullback.of_horiz_isIso - ⟨by rw [Category.id_comp, Category.assoc, e.hom_inv_id, Category.comp_id]⟩ - exact hf _ _ _ - (by simpa only [Iso.inv_hom_id_assoc, Category.id_comp] using this.paste_horiz H) - · intro X Y Z e f hf X' Z' i₁ i₂ f' H - have : IsPullback (𝟙 _) i₂ (i₂ ≫ e.inv) e.inv := - IsPullback.of_horiz_isIso ⟨Category.id_comp _⟩ - exact hf _ _ _ (by simpa only [Category.assoc, Iso.hom_inv_id, - Category.comp_id, Category.comp_id] using H.paste_horiz this) - -instance universally_isStableUnderBaseChange (P : MorphismProperty C) : - P.universally.IsStableUnderBaseChange where - of_isPullback H h₁ _ _ _ _ _ H' := h₁ _ _ _ (H'.paste_vert H.flip) - -instance IsStableUnderComposition.universally [HasPullbacks C] (P : MorphismProperty C) - [hP : P.IsStableUnderComposition] : P.universally.IsStableUnderComposition where - comp_mem {X Y Z} f g hf hg X' Z' i₁ i₂ f' H := by - have := pullback.lift_fst _ _ (H.w.trans (Category.assoc _ _ _).symm) - rw [← this] at H ⊢ - apply P.comp_mem _ _ _ (hg _ _ _ <| IsPullback.of_hasPullback _ _) - exact hf _ _ _ (H.of_right (pullback.lift_snd _ _ _) (IsPullback.of_hasPullback i₂ g)) - -theorem universally_le (P : MorphismProperty C) : P.universally ≤ P := by - intro X Y f hf - exact hf (𝟙 _) (𝟙 _) _ (IsPullback.of_vert_isIso ⟨by rw [Category.comp_id, Category.id_comp]⟩) - -theorem universally_inf (P Q : MorphismProperty C) : - (P ⊓ Q).universally = P.universally ⊓ Q.universally := by - ext X Y f - change _ ↔ _ ∧ _ - simp_rw [universally, ← forall_and] - rfl - -theorem universally_eq_iff {P : MorphismProperty C} : - P.universally = P ↔ P.IsStableUnderBaseChange := - ⟨(· ▸ P.universally_isStableUnderBaseChange), - fun hP ↦ P.universally_le.antisymm fun _ _ _ hf _ _ _ _ _ H => hP.of_isPullback H.flip hf⟩ - -theorem IsStableUnderBaseChange.universally_eq {P : MorphismProperty C} - [hP : P.IsStableUnderBaseChange] : P.universally = P := universally_eq_iff.mpr hP - -theorem universally_mono : Monotone (universally : MorphismProperty C → MorphismProperty C) := - fun _ _ h _ _ _ h₁ _ _ _ _ _ H => h _ (h₁ _ _ _ H) - -lemma universally_mk' (P : MorphismProperty C) [P.RespectsIso] {X Y : C} (g : X ⟶ Y) - (H : ∀ {T : C} (f : T ⟶ Y) [HasPullback f g], P (pullback.fst f g)) : - universally P g := by - introv X' h - have := h.hasPullback - rw [← h.isoPullback_hom_fst, P.cancel_left_of_respectsIso] - exact H .. - -end Universally - -variable (P : MorphismProperty C) - -/-- `P` has pullbacks if for every `f` satisfying `P`, pullbacks of arbitrary morphisms along `f` -exist. -/ -protected class HasPullbacks : Prop where - hasPullback {X Y S : C} {f : X ⟶ S} (g : Y ⟶ S) : P f → HasPullback f g := by infer_instance - -instance [HasPullbacks C] : P.HasPullbacks where - -alias hasPullback := HasPullbacks.hasPullback - instance [P.HasPullbacks] {X Y : C} {f : X ⟶ Y} : P.HasPullbacksAlong f where hasPullback _ := hasPullback _ @@ -885,6 +72,8 @@ 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/Groupoids/SplitIsofibration.lean b/HoTTLean/Groupoids/SplitIsofibration.lean index 9fc3e565..848a4eef 100644 --- a/HoTTLean/Groupoids/SplitIsofibration.lean +++ b/HoTTLean/Groupoids/SplitIsofibration.lean @@ -1,5 +1,6 @@ import HoTTLean.ForMathlib.CategoryTheory.ClovenIsofibration import HoTTLean.Groupoids.Pi +import HoTTLean.ForMathlib.CategoryTheory.MorphismProperty.OverAdjunction universe w v u v₁ u₁ v₂ u₂ v₃ u₃ @@ -56,8 +57,8 @@ instance : SplitIsofibration.RespectsIso := inv_hom_id := by simp [← Grpd.comp_eq_comp] }, inferInstance⟩) --- instance : SplitIsofibration.HasObjects where --- obj_mem {X Y} F G := sorry +instance : SplitIsofibration.HasObjects where + obj_mem {X Y} F G := sorry section @@ -156,18 +157,17 @@ def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C 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] + 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 - ⟩ + have := 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 this + simp only [Functor.id_obj, Functor.const_obj_obj, Functor.assoc, this] + 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, @@ -192,15 +192,14 @@ lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) simp[pushforwardHomEquiv] sorry -#exit 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 := - fun F _ G => { - has_representation := ⟨pushforward F.2 G.2, ⟨pushforward_isPushforward F.2 G.2⟩⟩ } +instance : SplitIsofibration.HasPushforwards SplitIsofibration where + hasPushforwardsAlong _ hF := { hasPushforward _ hG := + ⟨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) @@ -208,53 +207,39 @@ def isoPushforwardOfIsPushforward {B A} {F : B ⟶ A} (hF : SplitIsofibration F 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 .. - } ) - --- This should follow from `Groupoidal.forget` being an splitIsofibration. --- (If we manage to directly define the pushforward --- as a grothendieck construction) + ({ 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) := by - unfold Grpd.pushforwardHom homOf --SplitIsofibration + unfold Grpd.pushforwardHom homOf exact ⟨ Functor.ClovenIsofibration.forget _ , - CategoryTheory.Functor.ClovenIsofibration.instIsSplitGroupoidalForget - ⟩ - - ---simp[Grpd.pushforwardHom,SplitIsofibration,homOf] - --apply (Functor.ClovenIsofibration.IsSplit ) - + CategoryTheory.Functor.ClovenIsofibration.instIsSplitGroupoidalForget ⟩ -- FIXME. For some reason needed in the proof -- `SplitIsofibration.IsStableUnderPushforward SplitIsofibration` instance SplitIsofibration.RespectsIso : SplitIsofibration.RespectsIso := inferInstance -/- TODO: following instance can be proven like so - 1. any pushforward is isomorphic to a chosen pushforward - This should be proven in general for pushforwards, - and 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 (this is in mathlib, for any `rlp`) - `MorphismProperty.rlp_isMultiplicative` - `MorphismProperty.respectsIso_of_isStableUnderComposition` - 3. The chosen pushforward is an splitIsofibration `splitIsofibration_pushforward` -/ - +/-- +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 G P := by - intro h - have p : (Over.mk P) ≅ Grpd.pushforward (F.snd) (G.snd) := - isoPushforwardOfIsPushforward F.snd (Over.mk G.fst) G.snd (Over.mk P) h - have i1 : SplitIsofibration (pushforwardHom (F.snd) (G.snd)) := by - apply splitIsofibration_pushforward - have e : P = (p.hom).left ≫ (pushforwardHom (F.snd) (G.snd)) := by - have ee := Over.w p.hom - simp at ee - simp [ee] + of_isPushforward F hF G hG P hP := by + have p : (Over.mk P) ≅ Grpd.pushforward (hF) (hG) := + isoPushforwardOfIsPushforward hF (Over.mk G) hG (Over.mk P) hP + have i1 : SplitIsofibration (pushforwardHom (hF) (hG)) := by + apply splitIsofibration_pushforward + have e : P = (p.hom).left ≫ (pushforwardHom (hF) (hG)) := by + have ee := Over.w p.hom + simp at ee + simp [ee] simp only[e] apply (SplitIsofibration.RespectsIso).precomp assumption From 9f483354be6e9337c6f20703edaecea3e7a8f61f Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 9 Nov 2025 14:09:45 -0500 Subject: [PATCH 18/95] trying to move clans |-> clans1 --- .../CategoryTheory/ClovenIsofibration.lean | 49 + .../CategoryTheory/SplitIsofibration.lean | 864 ++++++++++++++++++ HoTTLean/Groupoids/SplitIsofibration.lean | 183 +++- HoTTLean/Groupoids/UnstructuredModel.lean | 4 +- HoTTLean/Model/Unstructured/UHom.lean | 2 +- .../Model/Unstructured/UnstructuredModel.lean | 364 ++++++++ 6 files changed, 1426 insertions(+), 40 deletions(-) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean create mode 100644 HoTTLean/Model/Unstructured/UnstructuredModel.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean index 806ac504..7c48544d 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean @@ -754,6 +754,37 @@ lemma pushforward.homEquiv_comp {D D' : Type u} [Groupoid.{u} D] [Groupoid.{u} D simp [← Functor.assoc, Functor.simpIdComp, equivFun_comp (hF:= hM), Groupoidal.map_id_eq] end pushforward + +@[simp] +lemma discrete_pUnit_ext (x y: Discrete.{u} PUnit): x = y := by + cases x + cases y + simp + + +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_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 @@ -774,4 +805,22 @@ instance : IsSplit tpClovenIsofibration := by dsimp [tpClovenIsofibration] infer_instance + +@[simp] +lemma discrete_pUnit_ext (x y: Discrete.{u} PUnit): x = y := by + cases x + cases y + simp + + +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_pUnit_ext + rfl + liftIso_IsIso {y1 y2} g i x e := CategoryTheory.IsIso.id .. + end GroupoidModel diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean new file mode 100644 index 00000000..770bbf93 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -0,0 +1,864 @@ +import Mathlib.CategoryTheory.MorphismProperty.OverAdjunction +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 + +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 _root_.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] + +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 := by + exact 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 B : Type u} [Category.{v} A] [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 + + +def iso_inv {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : + ClovenIsofibration F.inv := iso (F.symm) + +instance {A B : Type u} [Category.{v} A] [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 + +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 u} [Category.{v} A] [Category.{v} B] [Category.{v} 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) + +@[simps!] +def isoComp : ClovenIsofibration F' := + ofEq (comp (iso ..) IF) F' hF'.symm + +-- by +-- subst hF' +-- apply comp (iso ..) IF + + -- let := i -- TODO: remove once defined + -- let := IF -- TODO: remove once defined + -- let := hF' -- TODO: remove once defined + -- sorry + +-- def isoComp : ClovenIsofibration F' := +-- let := i -- TODO: remove once defined +-- let := IF -- TODO: remove once defined +-- let := hF' -- TODO: remove once defined +-- sorry +-- #check eqToHom +instance : IsSplit (isoComp IF i F' hF') := + inferInstanceAs (ofEq ..).IsSplit + --rw![congrArg_cast_hom_right] + +end isoComp + +end + +-- def toTerminal {A : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} A'] +-- [Category.{v} B'] (top : A' ⥤ A) (F' : A' ⥤ B') (F : A ⥤ B) (bot : B' ⥤ B) +-- (isPullback : Functor.IsPullback top F' F bot) (IF : SplitIsofibration F) : +-- SplitIsofibration F' where +-- liftObj := sorry +-- liftIso := sorry +-- isHomLift := sorry +-- liftObj_id := sorry +-- liftIso_id := sorry +-- liftObj_comp := sorry +-- liftIsoComp := sorry + +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]) + (IsPullback.IsPullback.botDegenerate i_comp_F.symm) + (Groupoidal.compGrothendieck.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.homCompRight' isPullback q1 (hom := j.hom) (by simp[j])).symm + isoComp (i:=j) (Functor.ClovenIsofibration.forget ..) _ 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 + +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] +#check (ClovenIsofibration.pushforward.strictify IF G) +def pushforward.strictifyClovenIsofibration : (strictify IF G).ClovenIsofibration := + ClovenIsofibration.comp IG (Functor.ClovenIsofibration.iso_inv ..) + + +-- def pushforward.strictifyClovenIsofibration : (strictify IF G).ClovenIsofibration := +-- let := IG -- TODO: remove +-- sorry + +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. -/ +@[simps?] +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] + rw[pushforward.homEquiv_apply_coe] + simp only [← Functor.assoc, eqToHom_refl, Iso.cancel_iso_hom_right,map_id_eq, Cat.of_α, + Functor.simpIdComp] + rw[GroupoidModel.FunctorOperation.pi.equivFun_comp + (τ := s) (F := M) (σ' := s ⋙ σ) (σ := σ) (hF:= hM) (hτ := rfl)] + simp[Groupoidal.map_id_eq] + + + +end pushforward +@[simp] +lemma discrete_pUnit_ext (x y: Discrete.{u} PUnit): x = y := by + cases x + cases y + simp + + +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_pUnit_ext + rfl + liftIso_IsIso {y1 y2} g i x e := CategoryTheory.IsIso.id .. + + +/- + + +instance toTerminal.IsSplit {X Y : Grpd} (F : X ⟶ Y) (t : Limits.IsTerminal Y) : + Functor.ClovenIsofibration.IsSplit (IsTerminal.ClovenIsofibration F t) where + liftObj_id {y x} hX' := by simp[IsTerminal.ClovenIsofibration] + liftIso_id {y x} hX' := by simp[IsTerminal.ClovenIsofibration] + liftObj_comp {y1 y2 y3} f hf g hg x1 hx1 x2 hx2 := by + subst hx2 + simp only [IsTerminal.ClovenIsofibration] + liftIso_comp {y1 y2 y3} f hf g hg x1 hx1 x2 hx2 := by + subst hx2 + simp only [IsTerminal.ClovenIsofibration, eqToHom_refl, Category.comp_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 diff --git a/HoTTLean/Groupoids/SplitIsofibration.lean b/HoTTLean/Groupoids/SplitIsofibration.lean index 848a4eef..d781a6a5 100644 --- a/HoTTLean/Groupoids/SplitIsofibration.lean +++ b/HoTTLean/Groupoids/SplitIsofibration.lean @@ -1,5 +1,6 @@ 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₃ @@ -15,6 +16,9 @@ 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) @@ -57,8 +61,23 @@ instance : SplitIsofibration.RespectsIso := inv_hom_id := by simp [← Grpd.comp_eq_comp] }, inferInstance⟩) -instance : SplitIsofibration.HasObjects where - obj_mem {X Y} F G := sorry +def IsTerminal.SplitIsofibration {X Y : Grpd.{v,v}} (F : X ⟶ Y) (t : Limits.IsTerminal Y) : + SplitIsofibration F + := by + have i := @Limits.IsTerminal.uniqueUpToIso Grpd.{v,v} _ Y chosenTerminal.{v} t chosenTerminalIsTerminal + have e : F = F ≫ i.hom ≫ i.inv := by simp[] + rw[e] + simp only[← Category.assoc] + apply MorphismProperty.RespectsIso.postcomp (P:= CategoryTheory.Grpd.SplitIsofibration) + exact ⟨Functor.ClovenIsofibration.toDiscretePUnit .., Functor.ClovenIsofibration.toDiscretePUnit.IsSplit ..⟩ + + + +instance : SplitIsofibration.HasObjects.{v, v} where + obj_mem {X Y} F G := by + exact (Grpd.IsTerminal.SplitIsofibration F G) + + section @@ -128,6 +147,18 @@ lemma grothendieckIsoPullback_inv_comp_forget {B A} {F : B ⟶ A} (hF : SplitIso 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, ← Category.assoc, ← 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 @@ -157,17 +188,18 @@ def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C 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] + 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 := 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 this - simp only [Functor.id_obj, Functor.const_obj_obj, Functor.assoc, this] - rw [Grpd.grothendiecIsoPullback_comp_hom_comp_snd] - rfl ⟩ + 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, @@ -182,15 +214,74 @@ def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C simp[Iso.inv_hom_id] } -/-- Naturality in the universal property of the pushforward. -/ +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[pushforwardHomEquiv] - sorry + 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, -pre_comp] + congr 1 + simp only [← eqToHom_eq_homOf_map, ← heq_eq_eq] + rw![← Grpd.comp_eq_comp] + conv => lhs ; rw![← Grpd.comp_eq_comp]; rw![← Grpd.comp_eq_comp];rw![← Grpd.comp_eq_comp] + -- proof1: + rw! [← e1] + simp + + -- proof2: + -- obtain ⟨ fl, fr, fw ⟩ := f + -- obtain ⟨ Xl, Xr, Xhom ⟩ := X + -- simp at e1 fl fr fw + -- subst fw + -- 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 @@ -198,8 +289,12 @@ def pushforward_isPushforward {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) homEquiv_comp f g := pushforwardHomEquiv_comp hF hG f g instance : SplitIsofibration.HasPushforwards SplitIsofibration where - hasPushforwardsAlong _ hF := { hasPushforward _ hG := - ⟨pushforward hF hG, ⟨pushforward_isPushforward hF hG⟩⟩ } + hasPushforwardsAlong {B A} F hF:= { + hasPushforward {C} G 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) @@ -207,39 +302,53 @@ def isoPushforwardOfIsPushforward {B A} {F : B ⟶ A} (hF : SplitIsofibration F 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 .. } ) - + ({ + homEquiv := pushforwardHomEquiv .. + homEquiv_comp f g := by apply pushforwardHomEquiv_comp .. + } ) + +-- This should follow from `Groupoidal.forget` being an splitIsofibration. +-- (If we manage to directly define the pushforward +-- as a grothendieck construction) theorem splitIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} (hG : SplitIsofibration G) : SplitIsofibration (pushforwardHom hF hG) := by - unfold Grpd.pushforwardHom homOf + unfold Grpd.pushforwardHom homOf --SplitIsofibration exact ⟨ Functor.ClovenIsofibration.forget _ , - CategoryTheory.Functor.ClovenIsofibration.instIsSplitGroupoidalForget ⟩ + CategoryTheory.Functor.ClovenIsofibration.instIsSplitGroupoidalForget + ⟩ + + ---simp[Grpd.pushforwardHom,SplitIsofibration,homOf] + --apply (Functor.ClovenIsofibration.IsSplit ) + -- 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. -/ +/- TODO: following instance can be proven like so + 1. any pushforward is isomorphic to a chosen pushforward + This should be proven in general for pushforwards, + and 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 (this is in mathlib, for any `rlp`) + `MorphismProperty.rlp_isMultiplicative` + `MorphismProperty.respectsIso_of_isStableUnderComposition` + 3. The chosen pushforward is an splitIsofibration `splitIsofibration_pushforward` -/ + +#check IsPushforward instance : SplitIsofibration.IsStableUnderPushforward SplitIsofibration where - of_isPushforward F hF G hG P hP := by - have p : (Over.mk P) ≅ Grpd.pushforward (hF) (hG) := - isoPushforwardOfIsPushforward hF (Over.mk G) hG (Over.mk P) hP - have i1 : SplitIsofibration (pushforwardHom (hF) (hG)) := by + of_isPushforward {B A C Pd} 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 + have i1 : SplitIsofibration (pushforwardHom hF hG) := by apply splitIsofibration_pushforward - have e : P = (p.hom).left ≫ (pushforwardHom (hF) (hG)) := by + have e : P = (p.hom).left ≫ (pushforwardHom hF hG) := by have ee := Over.w p.hom simp at ee simp [ee] - simp only[e] - apply (SplitIsofibration.RespectsIso).precomp - assumption + simp only[e] + apply (SplitIsofibration.RespectsIso).precomp + assumption 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/Unstructured/UHom.lean b/HoTTLean/Model/Unstructured/UHom.lean index 6e7b6973..427c9dc3 100644 --- a/HoTTLean/Model/Unstructured/UHom.lean +++ b/HoTTLean/Model/Unstructured/UHom.lean @@ -1,6 +1,6 @@ import Mathlib.CategoryTheory.Limits.Shapes.StrictInitial import HoTTLean.ForMathlib -import HoTTLean.Model.Unstructured.UnstructuredUniverse +import HoTTLean.Model.Unstructured.UnstructuredModel /-! Morphisms of unstructured models, and Russell-universe embeddings. -/ diff --git a/HoTTLean/Model/Unstructured/UnstructuredModel.lean b/HoTTLean/Model/Unstructured/UnstructuredModel.lean new file mode 100644 index 00000000..65f94a7d --- /dev/null +++ b/HoTTLean/Model/Unstructured/UnstructuredModel.lean @@ -0,0 +1,364 @@ +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 Mathlib.Tactic.DepRewrite + +universe u v + +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 UnstructuredUniverse (Ctx : Type u) [Category Ctx] where + Tm : Ctx + Ty : Ctx + tp : Tm ⟶ Ty + ext {Γ : Ctx} (A : Γ ⟶ Ty) : Ctx + disp {Γ : Ctx} (A : Γ ⟶ Ty) : ext A ⟶ Γ + var {Γ : Ctx} (A : Γ ⟶ Ty) : ext A ⟶ Tm + disp_pullback {Γ : Ctx} (A : Γ ⟶ Ty) : + IsPullback (var A) (disp A) tp A + +namespace UnstructuredUniverse + +variable {Ctx : Type u} [Category Ctx] (M : UnstructuredUniverse Ctx) + +@[reassoc (attr := simp)] +theorem var_tp {Γ : Ctx} (A : Γ ⟶ M.Ty) : M.var A ≫ M.tp = (M.disp A) ≫ A := by + simp [(M.disp_pullback A).w] + +/-! ## Pullback of representable natural transformation -/ + +/-- Pull a natural model back along a type. -/ +protected def pullback {Γ : Ctx} (A : Γ ⟶ M.Ty) : UnstructuredUniverse Ctx where + Tm := M.ext A + Ty := Γ + tp := M.disp A + ext := fun B => M.ext (B ≫ A) + disp := fun B => M.disp (B ≫ A) + var := fun B => (M.disp_pullback A).lift (M.var (B ≫ A)) + (M.disp (B ≫ A) ≫ B) (by simp [(M.disp_pullback (B ≫ A)).w]) + disp_pullback := fun B => + IsPullback.of_right' (M.disp_pullback (B ≫ A)) (M.disp_pullback 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) : + UnstructuredUniverse Ctx where + Ty := U + Tm := E + tp := π + ext A := M.ext (A ≫ toTy) + disp A := M.disp (A ≫ toTy) + var A := pb.lift (M.var (A ≫ toTy)) (M.disp (A ≫ toTy) ≫ A) + (by simp [(M.disp_pullback (A ≫ toTy)).w]) + disp_pullback A := IsPullback.of_right' (M.disp_pullback (A ≫ toTy)) pb + +/-! ## Substitutions -/ + +/-- +``` +Δ ⊢ σ : Γ Γ ⊢ A type Δ ⊢ t : A[σ] +----------------------------------- +Δ ⊢ σ.t : Γ.A +``` + ------ Δ ------ t --------¬ + | ↓ substCons ↓ + | M.ext A ---var A---> M.Tm + | | | + σ | | + | disp A M.tp + | | | + | V V + ---> Γ ------ A -----> M.Ty +-/ +def substCons {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) + (t : Δ ⟶ M.Tm) (t_tp : t ≫ M.tp = σ ≫ A) : + Δ ⟶ M.ext A := + (M.disp_pullback A).lift t σ t_tp + +@[reassoc (attr := simp)] +theorem substCons_disp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (t : Δ ⟶ M.Tm) + (tTp : t ≫ M.tp = σ ≫ A) : + M.substCons σ A t tTp ≫ M.disp A = σ := by + simp [substCons] + +@[reassoc (attr := simp)] +theorem substCons_var {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (t : Δ ⟶ M.Tm) + (aTp : t ≫ M.tp = σ ≫ A) : + M.substCons σ A t aTp ≫ M.var A = t := by + simp [substCons] + +@[simp] +theorem comp_substCons {Θ Δ Γ : Ctx} (τ : Θ ⟶ Δ) (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (t : Δ ⟶ M.Tm) + (aTp : t ≫ M.tp = σ ≫ A) : + τ ≫ M.substCons σ A t aTp = M.substCons (τ ≫ σ) A (τ ≫ t) (by simp [*]) := by + apply (M.disp_pullback A).hom_ext + · simp + · simp + +@[reassoc (attr := simp)] +theorem substCons_apply_comp_var {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (s : Δ ⟶ M.ext A) + (s_tp : s ≫ M.disp A = σ) : + M.substCons σ A (s ≫ M.var A) (by rw [Category.assoc, var_tp, ← Category.assoc, s_tp]) = + s := by + apply (disp_pullback ..).hom_ext <;> simp [s_tp] + +/-- +``` +Δ ⊢ σ : Γ.A +------------ +Δ ⊢ ↑∘σ : Γ +``` +-/ +def substFst {Δ Γ : Ctx} {A : Γ ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : Δ ⟶ Γ := + σ ≫ M.disp A + +/-- +``` +Δ ⊢ σ : Γ.A +------------------- +Δ ⊢ v₀[σ] : A[↑∘σ] +``` +-/ +def substSnd {Δ Γ : Ctx} {A : Γ ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : Δ ⟶ M.Tm := + σ ≫ M.var A + +theorem substSnd_tp {Δ Γ : Ctx} {A : Γ ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : + M.substSnd σ ≫ M.tp = (M.substFst σ) ≫ A := by + simp [substSnd, substFst] + +/-- +Weaken a substitution. +``` +Δ ⊢ σ : Γ Γ ⊢ A type A' = A[σ] +------------------------------------ +Δ.A' ⊢ ↑≫σ : Γ Δ.A' ⊢ v₀ : A[↑≫σ] +------------------------------------ +Δ.A' ⊢ (↑≫σ).v₀ : Γ.A +``` +-/ +def substWk {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) + (A' := σ ≫ A) (eq : σ ≫ A = A' := by rfl) : M.ext A' ⟶ M.ext A := + M.substCons (M.disp _ ≫ σ) A (M.var _) (by simp [eq]) + +@[reassoc] +theorem substWk_disp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (A' eq) : + M.substWk σ A A' eq ≫ M.disp A = M.disp A' ≫ σ := by + simp [substWk] + +@[reassoc (attr := simp)] +theorem substWk_var {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (A' eq) : + M.substWk σ A A' eq ≫ M.var A = M.var A' := by + simp [substWk] + +/-- `sec` is the section of `disp A` corresponding to `a`. + + ===== Γ ------ a --------¬ + ‖ ↓ sec V + ‖ M.ext A -----------> M.Tm + ‖ | | + ‖ | | + ‖ disp A M.tp + ‖ | | + ‖ V V + ===== Γ ------ A -----> M.Ty -/ +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]) + +@[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 + simp [sec] + +@[reassoc (attr := simp)] +theorem sec_var {Γ : Ctx} (A : Γ ⟶ M.Ty) (a : Γ ⟶ M.Tm) (a_tp : a ≫ M.tp = A) : + M.sec A a a_tp ≫ M.var A = a := by + simp [sec] + +@[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] + +@[reassoc (attr := simp)] +theorem sec_apply_comp_var {Γ : Ctx} (A : Γ ⟶ M.Ty) + (s : Γ ⟶ M.ext A) (s_tp : s ≫ M.disp A = 𝟙 _) : + 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 + +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), + Sig (U0.substWk σ A σA eq ≫ B) = σ ≫ Sig B) + (pair : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (a : Γ ⟶ U0.Tm) + (a_tp : a ≫ U0.tp = A) (b : Γ ⟶ U1.Tm), b ≫ U1.tp = U0.sec A a a_tp ≫ B → + (Γ ⟶ U2.Tm)) + (pair_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) (B : U0.ext A ⟶ U1.Ty) + (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) (b : Γ ⟶ U1.Tm) + (b_tp : b ≫ U1.tp = U0.sec A a a_tp ≫ B), + pair (U0.substWk σ A σA eq ≫ B) (σ ≫ a) (by cat_disch) (σ ≫ b) + (by simp [b_tp, comp_sec_assoc, eq]) = + σ ≫ pair B a a_tp b b_tp) + (pair_tp : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) + (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) (b : Γ ⟶ U1.Tm) + (b_tp : b ≫ U1.tp = U0.sec A a a_tp ≫ B), + pair B a a_tp b b_tp ≫ U2.tp = Sig B) + (fst : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (s : Γ ⟶ U2.Tm), + s ≫ U2.tp = Sig B → (Γ ⟶ U0.Tm)) + (fst_tp : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (s : Γ ⟶ U2.Tm) + (s_tp : s ≫ U2.tp = Sig B), fst B s s_tp ≫ U0.tp = A) + (snd : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (s : Γ ⟶ U2.Tm), + s ≫ U2.tp = Sig B → (Γ ⟶ U1.Tm)) + (snd_tp : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (s : Γ ⟶ U2.Tm) + (s_tp : s ≫ U2.tp = Sig B), snd B s s_tp ≫ U1.tp = U0.sec A (fst B s s_tp) (fst_tp ..) ≫ B) + (fst_pair : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) + (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) (b : Γ ⟶ U1.Tm) + (b_tp : b ≫ U1.tp = U0.sec A a a_tp ≫ B), fst B (pair B a a_tp b b_tp) (pair_tp ..) = a) + (snd_pair : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) + (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) (b : Γ ⟶ U1.Tm) + (b_tp : b ≫ U1.tp = U0.sec A a a_tp ≫ B), snd B (pair B a a_tp b b_tp) (pair_tp ..) = b) + (eta : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (s : Γ ⟶ U2.Tm) + (s_tp : s ≫ U2.tp = Sig B), pair B (fst B s s_tp) (fst_tp ..) (snd B s s_tp) (snd_tp ..) = s) + +namespace PolymorphicSigma + +variable {U0 U1 U2 : UnstructuredUniverse Ctx} + +def mk' (Sig : ∀ {Γ} {A : Γ ⟶ U0.Ty}, (U0.ext A ⟶ U1.Ty) → (Γ ⟶ U2.Ty)) + (Sig_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) (A : Γ ⟶ U0.Ty) {σA} (eq) (B : U0.ext A ⟶ U1.Ty), + Sig (U0.substWk σ A σA eq ≫ B) = σ ≫ Sig B) + (assoc : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty), U1.ext B ≅ U2.ext (Sig B)) + (assoc_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) (B : U0.ext A ⟶ U1.Ty), + (assoc (substWk U0 σ A σA eq ≫ B)).hom ≫ substWk U2 σ _ _ (Sig_comp ..).symm = + substWk _ (substWk _ σ _ _ eq) _ ≫ (assoc B).hom ) + (assoc_disp : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty), + (assoc B).hom ≫ disp .. = disp .. ≫ disp ..) : + PolymorphicSigma U0 U1 U2 where + Sig := Sig + Sig_comp := Sig_comp + pair B a a_tp b b_tp := U1.substCons (U0.sec _ a a_tp) B b (by simp [b_tp]) ≫ + (assoc B).hom ≫ var .. + pair_comp σ A σA eq B a a_tp b b_tp := by + have : σ ≫ U1.substCons (U0.sec A a a_tp) B b b_tp = + U1.substCons (U0.sec (σA) (σ ≫ a) (by simp [eq, a_tp])) (substWk U0 σ A σA eq ≫ B) + (σ ≫ b) (by simp [b_tp, comp_sec_assoc, eq]) ≫ substWk U1 (substWk U0 σ A σA eq) B := by + apply (disp_pullback ..).hom_ext + · simp + · apply (disp_pullback ..).hom_ext + · simp [substWk_disp_assoc] + · simp [substWk_disp] + slice_rhs 1 2 => rw [this] + slice_rhs 2 3 => rw [← assoc_comp] + simp + pair_tp B a a_tp b b_tp := by + slice_lhs 3 4 => rw [var_tp] + slice_lhs 2 3 => rw [assoc_disp] + simp + fst B s s_tp := U2.sec _ s s_tp ≫ (assoc _).inv ≫ disp .. ≫ var .. + fst_tp B s s_tp := by + slice_lhs 4 5 => rw [var_tp] + slice_lhs 3 4 => rw [← assoc_disp] + simp + snd B s s_tp := U2.sec _ s s_tp ≫ (assoc _).inv ≫ var .. + snd_tp B s s_tp := by + slice_lhs 3 4 => rw [var_tp] + simp only [← Category.assoc] + congr 2 + apply (disp_pullback ..).hom_ext + · simp + · 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])] + simp + snd_pair B a a_tp b b_tp := by + simp only [← Category.assoc] + 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 [U1.substCons_apply_comp_var _ _ _ (by simp)] + simp + +variable (S : PolymorphicSigma U0 U1 U2) + +lemma fst_comp {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} + (s : Γ ⟶ U2.Tm) (s_tp : s ≫ U2.tp = S.Sig B) : + S.fst (U0.substWk σ A σA eq ≫ B) (σ ≫ s) (by simp [s_tp, S.Sig_comp]) = + σ ≫ S.fst B s s_tp := by + rw! [(S.eta B s (by simp [s_tp])).symm, ← S.pair_comp, S.fst_pair, S.fst_pair] + +lemma snd_comp {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} + (s : Γ ⟶ U2.Tm) (s_tp : s ≫ U2.tp = S.Sig B) : + S.snd (U0.substWk σ A σA eq ≫ B) (σ ≫ s) (by simp [s_tp, S.Sig_comp]) = + σ ≫ S.snd B s s_tp := by + rw! [(S.eta B s (by simp [s_tp])).symm, ← S.pair_comp, S.snd_pair, S.snd_pair] + +end PolymorphicSigma + +structure PolymorphicPi (U0 U1 U2 : UnstructuredUniverse Ctx) where + (Pi : ∀ {Γ} {A : Γ ⟶ U0.Ty}, (U0.ext A ⟶ U1.Ty) → (Γ ⟶ U2.Ty)) + (Pi_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) (A : Γ ⟶ U0.Ty) {σA} (eq) (B : U0.ext A ⟶ U1.Ty), + Pi (U0.substWk σ A σA eq ≫ B) = σ ≫ Pi B) + (lam : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) + (b : U0.ext A ⟶ U1.Tm), b ≫ U1.tp = B → (Γ ⟶ U2.Tm)) + (lam_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) (B : U0.ext A ⟶ U1.Ty) + (b : U0.ext A ⟶ U1.Tm) (b_tp : b ≫ U1.tp = B), + lam (U0.substWk σ A σA eq ≫ B) (U0.substWk σ A σA eq ≫ b) (by cat_disch) = + σ ≫ lam B b b_tp) + (lam_tp : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) + (b : U0.ext A ⟶ U1.Tm) (b_tp : b ≫ U1.tp = B), + lam B b b_tp ≫ U2.tp = Pi B) + (unLam : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (f : Γ ⟶ U2.Tm), + f ≫ U2.tp = Pi B → (U0.ext A ⟶ U1.Tm)) + (unLam_tp : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (f : Γ ⟶ U2.Tm) + (f_tp : f ≫ U2.tp = Pi B), unLam B f f_tp ≫ U1.tp = B) + (unLam_lam : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) + (b : U0.ext A ⟶ U1.Tm) (b_tp : b ≫ U1.tp = B), unLam B (lam B b b_tp) (lam_tp ..) = b) + (lam_unLam : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (f : Γ ⟶ U2.Tm) + (f_tp : f ≫ U2.tp = Pi B), lam B (unLam B f f_tp) (unLam_tp ..) = f) + +namespace PolymorphicPi + +variable {U0 U1 U2 : UnstructuredUniverse Ctx} (P : PolymorphicPi U0 U1 U2) + +lemma unLam_comp {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} + (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.Pi B) : + P.unLam (U0.substWk σ A σA eq ≫ B) (σ ≫ f) (by simp [f_tp, P.Pi_comp]) = + U0.substWk σ A σA eq ≫ P.unLam B f f_tp := by + rw [← P.unLam_lam (U0.substWk σ A σA eq ≫ B) (U0.substWk σ A σA eq ≫ P.unLam B f f_tp)] + · rw! [P.lam_comp σ eq B, P.lam_unLam] + · rw [Category.assoc, P.unLam_tp] + +end PolymorphicPi + +end UnstructuredUniverse + +end Model From 47034e135f667b796d1adebb68a3433fe12d8d2b Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 9 Nov 2025 14:40:45 -0500 Subject: [PATCH 19/95] delete old SplitIso --- .../CategoryTheory/SplitIsofibration.lean | 864 ------------------ 1 file changed, 864 deletions(-) delete mode 100644 HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean deleted file mode 100644 index 770bbf93..00000000 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ /dev/null @@ -1,864 +0,0 @@ -import Mathlib.CategoryTheory.MorphismProperty.OverAdjunction -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 - -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 _root_.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] - -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 := by - exact 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 B : Type u} [Category.{v} A] [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 - - -def iso_inv {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : - ClovenIsofibration F.inv := iso (F.symm) - -instance {A B : Type u} [Category.{v} A] [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 - -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 u} [Category.{v} A] [Category.{v} B] [Category.{v} 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) - -@[simps!] -def isoComp : ClovenIsofibration F' := - ofEq (comp (iso ..) IF) F' hF'.symm - --- by --- subst hF' --- apply comp (iso ..) IF - - -- let := i -- TODO: remove once defined - -- let := IF -- TODO: remove once defined - -- let := hF' -- TODO: remove once defined - -- sorry - --- def isoComp : ClovenIsofibration F' := --- let := i -- TODO: remove once defined --- let := IF -- TODO: remove once defined --- let := hF' -- TODO: remove once defined --- sorry --- #check eqToHom -instance : IsSplit (isoComp IF i F' hF') := - inferInstanceAs (ofEq ..).IsSplit - --rw![congrArg_cast_hom_right] - -end isoComp - -end - --- def toTerminal {A : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} A'] --- [Category.{v} B'] (top : A' ⥤ A) (F' : A' ⥤ B') (F : A ⥤ B) (bot : B' ⥤ B) --- (isPullback : Functor.IsPullback top F' F bot) (IF : SplitIsofibration F) : --- SplitIsofibration F' where --- liftObj := sorry --- liftIso := sorry --- isHomLift := sorry --- liftObj_id := sorry --- liftIso_id := sorry --- liftObj_comp := sorry --- liftIsoComp := sorry - -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]) - (IsPullback.IsPullback.botDegenerate i_comp_F.symm) - (Groupoidal.compGrothendieck.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.homCompRight' isPullback q1 (hom := j.hom) (by simp[j])).symm - isoComp (i:=j) (Functor.ClovenIsofibration.forget ..) _ 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 - -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] -#check (ClovenIsofibration.pushforward.strictify IF G) -def pushforward.strictifyClovenIsofibration : (strictify IF G).ClovenIsofibration := - ClovenIsofibration.comp IG (Functor.ClovenIsofibration.iso_inv ..) - - --- def pushforward.strictifyClovenIsofibration : (strictify IF G).ClovenIsofibration := --- let := IG -- TODO: remove --- sorry - -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. -/ -@[simps?] -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] - rw[pushforward.homEquiv_apply_coe] - simp only [← Functor.assoc, eqToHom_refl, Iso.cancel_iso_hom_right,map_id_eq, Cat.of_α, - Functor.simpIdComp] - rw[GroupoidModel.FunctorOperation.pi.equivFun_comp - (τ := s) (F := M) (σ' := s ⋙ σ) (σ := σ) (hF:= hM) (hτ := rfl)] - simp[Groupoidal.map_id_eq] - - - -end pushforward -@[simp] -lemma discrete_pUnit_ext (x y: Discrete.{u} PUnit): x = y := by - cases x - cases y - simp - - -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_pUnit_ext - rfl - liftIso_IsIso {y1 y2} g i x e := CategoryTheory.IsIso.id .. - - -/- - - -instance toTerminal.IsSplit {X Y : Grpd} (F : X ⟶ Y) (t : Limits.IsTerminal Y) : - Functor.ClovenIsofibration.IsSplit (IsTerminal.ClovenIsofibration F t) where - liftObj_id {y x} hX' := by simp[IsTerminal.ClovenIsofibration] - liftIso_id {y x} hX' := by simp[IsTerminal.ClovenIsofibration] - liftObj_comp {y1 y2 y3} f hf g hg x1 hx1 x2 hx2 := by - subst hx2 - simp only [IsTerminal.ClovenIsofibration] - liftIso_comp {y1 y2 y3} f hf g hg x1 hx1 x2 hx2 := by - subst hx2 - simp only [IsTerminal.ClovenIsofibration, eqToHom_refl, Category.comp_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 From 06170cb3ad878760a48f19c3377374ac600ec854 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sun, 9 Nov 2025 16:05:40 -0500 Subject: [PATCH 20/95] style: --- .../CategoryTheory/ClovenIsofibration.lean | 32 +- HoTTLean/Groupoids/SplitIsofibration.lean | 174 +++------ HoTTLean/Model/Unstructured/UHom.lean | 2 +- .../Model/Unstructured/UnstructuredModel.lean | 364 ------------------ 4 files changed, 66 insertions(+), 506 deletions(-) delete mode 100644 HoTTLean/Model/Unstructured/UnstructuredModel.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean index 7c48544d..5155a053 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/ClovenIsofibration.lean @@ -755,25 +755,18 @@ lemma pushforward.homEquiv_comp {D D' : Type u} [Groupoid.{u} D] [Groupoid.{u} D end pushforward -@[simp] -lemma discrete_pUnit_ext (x y: Discrete.{u} PUnit): x = y := by - cases x - cases y - simp - - 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_pUnit_ext + 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) : +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] @@ -784,7 +777,6 @@ instance toDiscretePUnit.IsSplit {X : Type*} [Category X] (F : X ⥤ Discrete subst hx2 simp[toDiscretePUnit] - end ClovenIsofibration end end Functor @@ -805,22 +797,4 @@ instance : IsSplit tpClovenIsofibration := by dsimp [tpClovenIsofibration] infer_instance - -@[simp] -lemma discrete_pUnit_ext (x y: Discrete.{u} PUnit): x = y := by - cases x - cases y - simp - - -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_pUnit_ext - rfl - liftIso_IsIso {y1 y2} g i x e := CategoryTheory.IsIso.id .. - end GroupoidModel diff --git a/HoTTLean/Groupoids/SplitIsofibration.lean b/HoTTLean/Groupoids/SplitIsofibration.lean index d781a6a5..bdc418a2 100644 --- a/HoTTLean/Groupoids/SplitIsofibration.lean +++ b/HoTTLean/Groupoids/SplitIsofibration.lean @@ -16,9 +16,6 @@ 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) @@ -61,23 +58,16 @@ instance : SplitIsofibration.RespectsIso := inv_hom_id := by simp [← Grpd.comp_eq_comp] }, inferInstance⟩) -def IsTerminal.SplitIsofibration {X Y : Grpd.{v,v}} (F : X ⟶ Y) (t : Limits.IsTerminal Y) : - SplitIsofibration F - := by - have i := @Limits.IsTerminal.uniqueUpToIso Grpd.{v,v} _ Y chosenTerminal.{v} t chosenTerminalIsTerminal - have e : F = F ≫ i.hom ≫ i.inv := by simp[] - rw[e] - simp only[← Category.assoc] - apply MorphismProperty.RespectsIso.postcomp (P:= CategoryTheory.Grpd.SplitIsofibration) - exact ⟨Functor.ClovenIsofibration.toDiscretePUnit .., Functor.ClovenIsofibration.toDiscretePUnit.IsSplit ..⟩ - - +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 {X Y} F G := by - exact (Grpd.IsTerminal.SplitIsofibration F G) - - + obj_mem := Grpd.IsTerminal.SplitIsofibration section @@ -147,18 +137,15 @@ lemma grothendieckIsoPullback_inv_comp_forget {B A} {F : B ⟶ A} (hF : SplitIso 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, ← Category.assoc, ← CategoryTheory.Iso.eq_inv_comp] at this + 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 @@ -167,7 +154,6 @@ lemma grothendiecIsoPullback_comp_hom_comp_snd {B A} {F : B ⟶ A} (hF : SplitIs 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!] @@ -188,31 +174,30 @@ def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C 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] + 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 - ⟩ + 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] + 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[← 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] - } + 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) @@ -224,8 +209,7 @@ lemma pushforwardHomEquiv_left {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) 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 + 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] @@ -240,61 +224,47 @@ lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) 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 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 + 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')] + 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] + 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] + 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] + 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), + 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, -pre_comp] + simp only [Functor.id_obj, Functor.const_obj_obj, ← Functor.assoc] congr 1 simp only [← eqToHom_eq_homOf_map, ← heq_eq_eq] - rw![← Grpd.comp_eq_comp] - conv => lhs ; rw![← Grpd.comp_eq_comp]; rw![← Grpd.comp_eq_comp];rw![← Grpd.comp_eq_comp] - -- proof1: rw! [← e1] simp - -- proof2: - -- obtain ⟨ fl, fr, fw ⟩ := f - -- obtain ⟨ Xl, Xr, Xhom ⟩ := X - -- simp at e1 fl fr fw - -- subst fw - -- 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 {B A} F hF:= { - hasPushforward {C} G hG := { - has_representation := ⟨pushforward hF hG, ⟨pushforward_isPushforward hF hG⟩⟩ - } - } - + 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) @@ -302,53 +272,33 @@ def isoPushforwardOfIsPushforward {B A} {F : B ⟶ A} (hF : SplitIsofibration F 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 .. - } ) - --- This should follow from `Groupoidal.forget` being an splitIsofibration. --- (If we manage to directly define the pushforward --- as a grothendieck construction) + ({ 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) := by - unfold Grpd.pushforwardHom homOf --SplitIsofibration - exact ⟨ Functor.ClovenIsofibration.forget _ , - CategoryTheory.Functor.ClovenIsofibration.instIsSplitGroupoidalForget - ⟩ - - ---simp[Grpd.pushforwardHom,SplitIsofibration,homOf] - --apply (Functor.ClovenIsofibration.IsSplit ) - + 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 -/- TODO: following instance can be proven like so - 1. any pushforward is isomorphic to a chosen pushforward - This should be proven in general for pushforwards, - and 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 (this is in mathlib, for any `rlp`) - `MorphismProperty.rlp_isMultiplicative` - `MorphismProperty.respectsIso_of_isStableUnderComposition` - 3. The chosen pushforward is an splitIsofibration `splitIsofibration_pushforward` -/ - -#check IsPushforward +/-- +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 {B A C Pd} F hF G hG P h := by - have p : (Over.mk P) ≅ Grpd.pushforward hF hG := + 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 - have i1 : SplitIsofibration (pushforwardHom hF hG) := by - apply splitIsofibration_pushforward - have e : P = (p.hom).left ≫ (pushforwardHom hF hG) := by - have ee := Over.w p.hom - simp at ee - simp [ee] - simp only[e] - apply (SplitIsofibration.RespectsIso).precomp - assumption + 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/Model/Unstructured/UHom.lean b/HoTTLean/Model/Unstructured/UHom.lean index 427c9dc3..6e7b6973 100644 --- a/HoTTLean/Model/Unstructured/UHom.lean +++ b/HoTTLean/Model/Unstructured/UHom.lean @@ -1,6 +1,6 @@ import Mathlib.CategoryTheory.Limits.Shapes.StrictInitial import HoTTLean.ForMathlib -import HoTTLean.Model.Unstructured.UnstructuredModel +import HoTTLean.Model.Unstructured.UnstructuredUniverse /-! Morphisms of unstructured models, and Russell-universe embeddings. -/ diff --git a/HoTTLean/Model/Unstructured/UnstructuredModel.lean b/HoTTLean/Model/Unstructured/UnstructuredModel.lean deleted file mode 100644 index 65f94a7d..00000000 --- a/HoTTLean/Model/Unstructured/UnstructuredModel.lean +++ /dev/null @@ -1,364 +0,0 @@ -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 Mathlib.Tactic.DepRewrite - -universe u v - -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 UnstructuredUniverse (Ctx : Type u) [Category Ctx] where - Tm : Ctx - Ty : Ctx - tp : Tm ⟶ Ty - ext {Γ : Ctx} (A : Γ ⟶ Ty) : Ctx - disp {Γ : Ctx} (A : Γ ⟶ Ty) : ext A ⟶ Γ - var {Γ : Ctx} (A : Γ ⟶ Ty) : ext A ⟶ Tm - disp_pullback {Γ : Ctx} (A : Γ ⟶ Ty) : - IsPullback (var A) (disp A) tp A - -namespace UnstructuredUniverse - -variable {Ctx : Type u} [Category Ctx] (M : UnstructuredUniverse Ctx) - -@[reassoc (attr := simp)] -theorem var_tp {Γ : Ctx} (A : Γ ⟶ M.Ty) : M.var A ≫ M.tp = (M.disp A) ≫ A := by - simp [(M.disp_pullback A).w] - -/-! ## Pullback of representable natural transformation -/ - -/-- Pull a natural model back along a type. -/ -protected def pullback {Γ : Ctx} (A : Γ ⟶ M.Ty) : UnstructuredUniverse Ctx where - Tm := M.ext A - Ty := Γ - tp := M.disp A - ext := fun B => M.ext (B ≫ A) - disp := fun B => M.disp (B ≫ A) - var := fun B => (M.disp_pullback A).lift (M.var (B ≫ A)) - (M.disp (B ≫ A) ≫ B) (by simp [(M.disp_pullback (B ≫ A)).w]) - disp_pullback := fun B => - IsPullback.of_right' (M.disp_pullback (B ≫ A)) (M.disp_pullback 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) : - UnstructuredUniverse Ctx where - Ty := U - Tm := E - tp := π - ext A := M.ext (A ≫ toTy) - disp A := M.disp (A ≫ toTy) - var A := pb.lift (M.var (A ≫ toTy)) (M.disp (A ≫ toTy) ≫ A) - (by simp [(M.disp_pullback (A ≫ toTy)).w]) - disp_pullback A := IsPullback.of_right' (M.disp_pullback (A ≫ toTy)) pb - -/-! ## Substitutions -/ - -/-- -``` -Δ ⊢ σ : Γ Γ ⊢ A type Δ ⊢ t : A[σ] ------------------------------------ -Δ ⊢ σ.t : Γ.A -``` - ------ Δ ------ t --------¬ - | ↓ substCons ↓ - | M.ext A ---var A---> M.Tm - | | | - σ | | - | disp A M.tp - | | | - | V V - ---> Γ ------ A -----> M.Ty --/ -def substCons {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) - (t : Δ ⟶ M.Tm) (t_tp : t ≫ M.tp = σ ≫ A) : - Δ ⟶ M.ext A := - (M.disp_pullback A).lift t σ t_tp - -@[reassoc (attr := simp)] -theorem substCons_disp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (t : Δ ⟶ M.Tm) - (tTp : t ≫ M.tp = σ ≫ A) : - M.substCons σ A t tTp ≫ M.disp A = σ := by - simp [substCons] - -@[reassoc (attr := simp)] -theorem substCons_var {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (t : Δ ⟶ M.Tm) - (aTp : t ≫ M.tp = σ ≫ A) : - M.substCons σ A t aTp ≫ M.var A = t := by - simp [substCons] - -@[simp] -theorem comp_substCons {Θ Δ Γ : Ctx} (τ : Θ ⟶ Δ) (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (t : Δ ⟶ M.Tm) - (aTp : t ≫ M.tp = σ ≫ A) : - τ ≫ M.substCons σ A t aTp = M.substCons (τ ≫ σ) A (τ ≫ t) (by simp [*]) := by - apply (M.disp_pullback A).hom_ext - · simp - · simp - -@[reassoc (attr := simp)] -theorem substCons_apply_comp_var {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (s : Δ ⟶ M.ext A) - (s_tp : s ≫ M.disp A = σ) : - M.substCons σ A (s ≫ M.var A) (by rw [Category.assoc, var_tp, ← Category.assoc, s_tp]) = - s := by - apply (disp_pullback ..).hom_ext <;> simp [s_tp] - -/-- -``` -Δ ⊢ σ : Γ.A ------------- -Δ ⊢ ↑∘σ : Γ -``` --/ -def substFst {Δ Γ : Ctx} {A : Γ ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : Δ ⟶ Γ := - σ ≫ M.disp A - -/-- -``` -Δ ⊢ σ : Γ.A -------------------- -Δ ⊢ v₀[σ] : A[↑∘σ] -``` --/ -def substSnd {Δ Γ : Ctx} {A : Γ ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : Δ ⟶ M.Tm := - σ ≫ M.var A - -theorem substSnd_tp {Δ Γ : Ctx} {A : Γ ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : - M.substSnd σ ≫ M.tp = (M.substFst σ) ≫ A := by - simp [substSnd, substFst] - -/-- -Weaken a substitution. -``` -Δ ⊢ σ : Γ Γ ⊢ A type A' = A[σ] ------------------------------------- -Δ.A' ⊢ ↑≫σ : Γ Δ.A' ⊢ v₀ : A[↑≫σ] ------------------------------------- -Δ.A' ⊢ (↑≫σ).v₀ : Γ.A -``` --/ -def substWk {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) - (A' := σ ≫ A) (eq : σ ≫ A = A' := by rfl) : M.ext A' ⟶ M.ext A := - M.substCons (M.disp _ ≫ σ) A (M.var _) (by simp [eq]) - -@[reassoc] -theorem substWk_disp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (A' eq) : - M.substWk σ A A' eq ≫ M.disp A = M.disp A' ≫ σ := by - simp [substWk] - -@[reassoc (attr := simp)] -theorem substWk_var {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (A' eq) : - M.substWk σ A A' eq ≫ M.var A = M.var A' := by - simp [substWk] - -/-- `sec` is the section of `disp A` corresponding to `a`. - - ===== Γ ------ a --------¬ - ‖ ↓ sec V - ‖ M.ext A -----------> M.Tm - ‖ | | - ‖ | | - ‖ disp A M.tp - ‖ | | - ‖ V V - ===== Γ ------ A -----> M.Ty -/ -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]) - -@[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 - simp [sec] - -@[reassoc (attr := simp)] -theorem sec_var {Γ : Ctx} (A : Γ ⟶ M.Ty) (a : Γ ⟶ M.Tm) (a_tp : a ≫ M.tp = A) : - M.sec A a a_tp ≫ M.var A = a := by - simp [sec] - -@[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] - -@[reassoc (attr := simp)] -theorem sec_apply_comp_var {Γ : Ctx} (A : Γ ⟶ M.Ty) - (s : Γ ⟶ M.ext A) (s_tp : s ≫ M.disp A = 𝟙 _) : - 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 - -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), - Sig (U0.substWk σ A σA eq ≫ B) = σ ≫ Sig B) - (pair : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (a : Γ ⟶ U0.Tm) - (a_tp : a ≫ U0.tp = A) (b : Γ ⟶ U1.Tm), b ≫ U1.tp = U0.sec A a a_tp ≫ B → - (Γ ⟶ U2.Tm)) - (pair_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) (B : U0.ext A ⟶ U1.Ty) - (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) (b : Γ ⟶ U1.Tm) - (b_tp : b ≫ U1.tp = U0.sec A a a_tp ≫ B), - pair (U0.substWk σ A σA eq ≫ B) (σ ≫ a) (by cat_disch) (σ ≫ b) - (by simp [b_tp, comp_sec_assoc, eq]) = - σ ≫ pair B a a_tp b b_tp) - (pair_tp : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) - (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) (b : Γ ⟶ U1.Tm) - (b_tp : b ≫ U1.tp = U0.sec A a a_tp ≫ B), - pair B a a_tp b b_tp ≫ U2.tp = Sig B) - (fst : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (s : Γ ⟶ U2.Tm), - s ≫ U2.tp = Sig B → (Γ ⟶ U0.Tm)) - (fst_tp : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (s : Γ ⟶ U2.Tm) - (s_tp : s ≫ U2.tp = Sig B), fst B s s_tp ≫ U0.tp = A) - (snd : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (s : Γ ⟶ U2.Tm), - s ≫ U2.tp = Sig B → (Γ ⟶ U1.Tm)) - (snd_tp : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (s : Γ ⟶ U2.Tm) - (s_tp : s ≫ U2.tp = Sig B), snd B s s_tp ≫ U1.tp = U0.sec A (fst B s s_tp) (fst_tp ..) ≫ B) - (fst_pair : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) - (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) (b : Γ ⟶ U1.Tm) - (b_tp : b ≫ U1.tp = U0.sec A a a_tp ≫ B), fst B (pair B a a_tp b b_tp) (pair_tp ..) = a) - (snd_pair : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) - (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) (b : Γ ⟶ U1.Tm) - (b_tp : b ≫ U1.tp = U0.sec A a a_tp ≫ B), snd B (pair B a a_tp b b_tp) (pair_tp ..) = b) - (eta : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (s : Γ ⟶ U2.Tm) - (s_tp : s ≫ U2.tp = Sig B), pair B (fst B s s_tp) (fst_tp ..) (snd B s s_tp) (snd_tp ..) = s) - -namespace PolymorphicSigma - -variable {U0 U1 U2 : UnstructuredUniverse Ctx} - -def mk' (Sig : ∀ {Γ} {A : Γ ⟶ U0.Ty}, (U0.ext A ⟶ U1.Ty) → (Γ ⟶ U2.Ty)) - (Sig_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) (A : Γ ⟶ U0.Ty) {σA} (eq) (B : U0.ext A ⟶ U1.Ty), - Sig (U0.substWk σ A σA eq ≫ B) = σ ≫ Sig B) - (assoc : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty), U1.ext B ≅ U2.ext (Sig B)) - (assoc_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) (B : U0.ext A ⟶ U1.Ty), - (assoc (substWk U0 σ A σA eq ≫ B)).hom ≫ substWk U2 σ _ _ (Sig_comp ..).symm = - substWk _ (substWk _ σ _ _ eq) _ ≫ (assoc B).hom ) - (assoc_disp : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty), - (assoc B).hom ≫ disp .. = disp .. ≫ disp ..) : - PolymorphicSigma U0 U1 U2 where - Sig := Sig - Sig_comp := Sig_comp - pair B a a_tp b b_tp := U1.substCons (U0.sec _ a a_tp) B b (by simp [b_tp]) ≫ - (assoc B).hom ≫ var .. - pair_comp σ A σA eq B a a_tp b b_tp := by - have : σ ≫ U1.substCons (U0.sec A a a_tp) B b b_tp = - U1.substCons (U0.sec (σA) (σ ≫ a) (by simp [eq, a_tp])) (substWk U0 σ A σA eq ≫ B) - (σ ≫ b) (by simp [b_tp, comp_sec_assoc, eq]) ≫ substWk U1 (substWk U0 σ A σA eq) B := by - apply (disp_pullback ..).hom_ext - · simp - · apply (disp_pullback ..).hom_ext - · simp [substWk_disp_assoc] - · simp [substWk_disp] - slice_rhs 1 2 => rw [this] - slice_rhs 2 3 => rw [← assoc_comp] - simp - pair_tp B a a_tp b b_tp := by - slice_lhs 3 4 => rw [var_tp] - slice_lhs 2 3 => rw [assoc_disp] - simp - fst B s s_tp := U2.sec _ s s_tp ≫ (assoc _).inv ≫ disp .. ≫ var .. - fst_tp B s s_tp := by - slice_lhs 4 5 => rw [var_tp] - slice_lhs 3 4 => rw [← assoc_disp] - simp - snd B s s_tp := U2.sec _ s s_tp ≫ (assoc _).inv ≫ var .. - snd_tp B s s_tp := by - slice_lhs 3 4 => rw [var_tp] - simp only [← Category.assoc] - congr 2 - apply (disp_pullback ..).hom_ext - · simp - · 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])] - simp - snd_pair B a a_tp b b_tp := by - simp only [← Category.assoc] - 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 [U1.substCons_apply_comp_var _ _ _ (by simp)] - simp - -variable (S : PolymorphicSigma U0 U1 U2) - -lemma fst_comp {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} - (s : Γ ⟶ U2.Tm) (s_tp : s ≫ U2.tp = S.Sig B) : - S.fst (U0.substWk σ A σA eq ≫ B) (σ ≫ s) (by simp [s_tp, S.Sig_comp]) = - σ ≫ S.fst B s s_tp := by - rw! [(S.eta B s (by simp [s_tp])).symm, ← S.pair_comp, S.fst_pair, S.fst_pair] - -lemma snd_comp {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} - (s : Γ ⟶ U2.Tm) (s_tp : s ≫ U2.tp = S.Sig B) : - S.snd (U0.substWk σ A σA eq ≫ B) (σ ≫ s) (by simp [s_tp, S.Sig_comp]) = - σ ≫ S.snd B s s_tp := by - rw! [(S.eta B s (by simp [s_tp])).symm, ← S.pair_comp, S.snd_pair, S.snd_pair] - -end PolymorphicSigma - -structure PolymorphicPi (U0 U1 U2 : UnstructuredUniverse Ctx) where - (Pi : ∀ {Γ} {A : Γ ⟶ U0.Ty}, (U0.ext A ⟶ U1.Ty) → (Γ ⟶ U2.Ty)) - (Pi_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) (A : Γ ⟶ U0.Ty) {σA} (eq) (B : U0.ext A ⟶ U1.Ty), - Pi (U0.substWk σ A σA eq ≫ B) = σ ≫ Pi B) - (lam : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) - (b : U0.ext A ⟶ U1.Tm), b ≫ U1.tp = B → (Γ ⟶ U2.Tm)) - (lam_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) (B : U0.ext A ⟶ U1.Ty) - (b : U0.ext A ⟶ U1.Tm) (b_tp : b ≫ U1.tp = B), - lam (U0.substWk σ A σA eq ≫ B) (U0.substWk σ A σA eq ≫ b) (by cat_disch) = - σ ≫ lam B b b_tp) - (lam_tp : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) - (b : U0.ext A ⟶ U1.Tm) (b_tp : b ≫ U1.tp = B), - lam B b b_tp ≫ U2.tp = Pi B) - (unLam : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (f : Γ ⟶ U2.Tm), - f ≫ U2.tp = Pi B → (U0.ext A ⟶ U1.Tm)) - (unLam_tp : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (f : Γ ⟶ U2.Tm) - (f_tp : f ≫ U2.tp = Pi B), unLam B f f_tp ≫ U1.tp = B) - (unLam_lam : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) - (b : U0.ext A ⟶ U1.Tm) (b_tp : b ≫ U1.tp = B), unLam B (lam B b b_tp) (lam_tp ..) = b) - (lam_unLam : ∀ {Γ} {A : Γ ⟶ U0.Ty} (B : U0.ext A ⟶ U1.Ty) (f : Γ ⟶ U2.Tm) - (f_tp : f ≫ U2.tp = Pi B), lam B (unLam B f f_tp) (unLam_tp ..) = f) - -namespace PolymorphicPi - -variable {U0 U1 U2 : UnstructuredUniverse Ctx} (P : PolymorphicPi U0 U1 U2) - -lemma unLam_comp {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} - (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = P.Pi B) : - P.unLam (U0.substWk σ A σA eq ≫ B) (σ ≫ f) (by simp [f_tp, P.Pi_comp]) = - U0.substWk σ A σA eq ≫ P.unLam B f f_tp := by - rw [← P.unLam_lam (U0.substWk σ A σA eq ≫ B) (U0.substWk σ A σA eq ≫ P.unLam B f f_tp)] - · rw! [P.lam_comp σ eq B, P.lam_unLam] - · rw [Category.assoc, P.unLam_tp] - -end PolymorphicPi - -end UnstructuredUniverse - -end Model From f5f6d782c9622a07f5156adc6e61ad87093a4b7b Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sun, 9 Nov 2025 16:25:18 -0500 Subject: [PATCH 21/95] feat: StructuredModel --- .../Model/Structured/StructuredUniverse.lean | 1761 +++++++++++++++++ 1 file changed, 1761 insertions(+) create mode 100644 HoTTLean/Model/Structured/StructuredUniverse.lean diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean new file mode 100644 index 00000000..ba47f111 --- /dev/null +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -0,0 +1,1761 @@ +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 + +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.IsStableUnderPushforward R] + +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'] + +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] + +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 σ _ α 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] + +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 (eq := 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 + k : Ctx + k1 : k ⟶ M.Tm + k2 : k ⟶ M.Tm + isKernelPair : IsKernelPair M.tp k1 k2 + Id : k ⟶ M.Ty + refl : M.Tm ⟶ M.Tm + refl_tp : refl ≫ M.tp = + (IsPullback.lift isKernelPair (𝟙 M.Tm) (𝟙 M.Tm) (by simp)) ≫ Id + +namespace IdIntro + +variable {M} (idIntro : IdIntro M) {Γ : Ctx} + +@[simps] def k2UvPoly : UvPoly R idIntro.k M.Tm := + ⟨idIntro.k2, R.of_isPullback idIntro.isKernelPair 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 := + idIntro.isKernelPair.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 idIntro.isKernelPair.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 idIntro.isKernelPair.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 idIntro.isKernelPair.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 (ii : IdIntro M) (a : Γ ⟶ M.Tm) : (M.ext (a ≫ M.tp)) ⟶ ii.k := + ii.isKernelPair.lift (M.var _) ((M.disp _) ≫ a) (by simp) + +lemma toK_comp_k1 (ii : IdIntro M) (a : Γ ⟶ M.Tm) : ii.toK a ≫ ii.k1 = M.var _ := by + simp [toK] + +lemma ext_a_tp_isPullback (ii : IdIntro M) (a : Γ ⟶ M.Tm) : + IsPullback (ii.toK a) (M.disp _) ii.k2 a := + IsPullback.of_right' (M.disp_pullback _) ii.isKernelPair + +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 Id' + +-- 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. +-/ +structure IdElimBase (ii : IdIntro M) where + i : Ctx + i1 : i ⟶ M.Tm + i2 : i ⟶ ii.k + i_isPullback : IsPullback i1 i2 M.tp ii.Id + +namespace IdElimBase +variable {ii : IdIntro M} (ie : IdElimBase ii) + +@[simps] def i2UvPoly : UvPoly R ie.i ii.k := + ⟨ie.i2, R.of_isPullback ie.i_isPullback 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 ⟶ ie.i := + ie.i_isPullback.lift ii.refl + (IsPullback.lift ii.isKernelPair (𝟙 M.Tm) (𝟙 M.Tm) (by simp)) + ii.refl_tp + +@[simp] +lemma comparison_comp_i1 : ie.comparison ≫ ie.i1 = ii.refl := by + simp [comparison] + +@[simp, reassoc] +lemma comparison_comp_i2_comp_k1 : ie.comparison ≫ ie.i2 ≫ ii.k1 = + 𝟙 _ := by + simp [comparison] + +@[simp, reassoc] +lemma comparison_comp_i2_comp_k2 : ie.comparison ≫ ie.i2 ≫ ii.k2 = + 𝟙 _ := 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 ie.i M.Tm := + ie.i2UvPoly.vcomp ii.k2UvPoly + +/-- The functor part of the polynomial endofunctor `iOverUvPoly` -/ +abbrev iFunctor : Ctx ⥤ Ctx := ie.iUvPoly.functor + +/-- 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 : ie.iFunctor ⟶ (UvPoly.id R M.Tm).functor := + UvPoly.verticalNatTrans (UvPoly.id R M.Tm) ie.iUvPoly + ie.comparison (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 IdElimBase 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 {Δ} (σ : Δ ⟶ Γ) : ii.toK (σ ≫ a) = + (M.substWk σ (a ≫ M.tp) _ (by simp)) ≫ ii.toK a := by + dsimp [toK] + rw! [Category.assoc] + apply ii.isKernelPair.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]) + +lemma toI_comp_i1 : ie.toI a ≫ ie.i1 = M.var _ := by simp [toI] + +lemma toI_comp_i2 : ie.toI a ≫ ie.i2 = (M.disp _) ≫ ii.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 (ie.toI a) (M.disp _) ie.i2 (toK ii a) := + IsPullback.of_right' (M.disp_pullback _) ie.i_isPullback + +theorem motiveCtx_isPullback' : + IsPullback (ie.toI a) ((M.disp (ii.mkId ((M.disp (a ≫ M.tp)) ≫ a) + (M.var (a ≫ M.tp)) (by simp))) ≫ (M.disp (a ≫ M.tp))) (iUvPoly ie).p a := + IsPullback.paste_vert (ie.motiveCtx_isPullback a) + (ii.ext_a_tp_isPullback a) + +def equivMk (x : (ii.motiveCtx a) ⟶ X) : Γ ⟶ ie.iFunctor.obj X := + UvPoly.Equiv.mk' a (ie.motiveCtx_isPullback' a).flip x + +def equivFst (pair : Γ ⟶ ie.iFunctor.obj X) : + Γ ⟶ M.Tm := + UvPoly.Equiv.fst pair + +lemma equivFst_comp_left (pair : Γ ⟶ ie.iFunctor.obj X) + {Δ} (σ : Δ ⟶ Γ) : + ie.equivFst (σ ≫ pair) = σ ≫ ie.equivFst pair := by + dsimp [equivFst] + rw [UvPoly.Equiv.fst_comp_left] + +def equivSnd (pair : Γ ⟶ ie.iFunctor.obj X) : + (ii.motiveCtx (equivFst ie pair)) ⟶ X := + UvPoly.Equiv.snd' pair (ie.motiveCtx_isPullback' _).flip + +lemma equivSnd_comp_left (pair : Γ ⟶ ie.iFunctor.obj X) + {Δ} (σ : Δ ⟶ Γ) : + ie.equivSnd (σ ≫ pair) = + eqToHom (by simp [equivFst_comp_left]) ≫ ii.motiveSubst σ _ ≫ ie.equivSnd 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 IdElimBase + +/-- 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} (ie : IdElimBase ii) (N : StructuredUniverse R) where + weakPullback : WeakPullback + (ie.verticalNatTrans.app N.Tm) + (ie.iFunctor.map N.tp) + ((UvPoly.id R M.Tm).functor.map N.tp) + (ie.verticalNatTrans.app N.Ty) + +-- TODO fix the proof that `StructuredUniverse.Id` is equivalent to +-- `UnstructuredUniverse.PolymorphicIdElim` + +namespace Id + +variable {N : StructuredUniverse R} {ii : IdIntro M} {ie : IdElimBase ii} (i : Id ie N) + +variable {Γ Δ : Ctx} (σ : Δ ⟶ Γ) (a : Γ ⟶ M.Tm) + (C : (ii.motiveCtx a) ⟶ N.Ty) (r : Γ ⟶ N.Tm) + (r_tp : r ≫ N.tp = (ii.reflSubst a) ≫ C) + +open IdElimBase 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) + +/-- The variable `r` witnesses the motive for the case `refl`, +This gives a map `(a,r) : Γ ⟶ P_𝟙Tm Tm ≅ Tm × Tm` where +``` + fst ≫ r +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` + +#exit +variable (ie) in +/-- The variable `C` is the motive for elimination, +This gives a map `(a, C) : Γ ⟶ iFunctor Ty` +``` + C +Ty <-- y(motiveCtx) ----> i + | | + | | i2 ≫ k2 + | | + V V + Γ --------> Tm + a +``` +-/ +abbrev motive : Γ ⟶ ie.iFunctor.obj N.Ty := + ie.equivMk a C + +lemma motive_comp_left : σ ≫ motive ie a C = + motive ie (σ ≫ a) ((ii.motiveSubst σ a) ≫ C) := by + dsimp [motive, equivMk] + rw [UvPoly.Equiv.mk'_comp_left (iUvPoly ie) _ 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 + +def lift : Γ ⟶ ie.iFunctor.obj N.Tm := + i.weakPullback.coherentLift (reflCase a r) (motive ie a C) (by + dsimp only [motive, equivMk, verticalNatTrans, reflCase] + rw [UvPoly.mk'_comp_verticalNatTrans_app (UvPoly.id M.Tm) ie.iUvPoly ie.comparison + _ N.Ty a (ie.motiveCtx_isPullback' 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 ie] + simp [mkRefl, comparison] + · apply (M.disp_pullback _).hom_ext + · slice_rhs 3 4 => rw [← ii.toK_comp_k1] + slice_rhs 2 3 => rw [← ie.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] + congr 1 + · dsimp [reflCase] + 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 : ie.equivFst (i.lift a C r r_tp) = a := + calc ie.equivFst (i.lift a C r r_tp) + _ = ie.equivFst (i.lift a C r r_tp ≫ ie.iFunctor.map N.tp) := by + dsimp [IdElimBase.equivFst] + rw [UvPoly.Equiv.fst_comp_right] + _ = _ := by + dsimp [lift, motive, IdElimBase.equivFst, IdElimBase.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` +-/ +def j : y(ii.motiveCtx a) ⟶ N.Tm := + eqToHom (by rw [equivFst_lift_eq]) ≫ ie.equivSnd (i.lift a C r r_tp) + +/-- Typing for elimination rule `J` -/ +lemma j_tp : j i a C r r_tp ≫ N.tp = C := by + simp only [j, Category.assoc, IdElimBase.equivSnd, ← UvPoly.Equiv.snd'_comp_right] + -- FIXME: `transparency := .default` is like `erw` and should be avoided + rw! (transparency := .default) [WeakPullback.coherentLift_snd] + simp only [IdElimBase.equivMk] + rw! [equivFst_lift_eq] + simp + +lemma comp_j : ym(ii.motiveSubst σ _) ≫ j i a C r r_tp = + j i (ym(σ) ≫ a) (ym(ii.motiveSubst σ _) ≫ C) (ym(σ) ≫ 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 [ie.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 : ym(ii.reflSubst a) ≫ j i a C r r_tp = r := 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 : y(Γ) ⟶ M.Tm) (b_tp : b ≫ M.tp = a ≫ M.tp) + (h : y(Γ) ⟶ 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) + +/-- `Id` is equivalent to `Id` (one half). -/ +def toId' : M.Id' ii N where + j := i.j + j_tp := i.j_tp + comp_j := i.comp_j + reflSubst_j := i.reflSubst_j + +end Id + +namespace Id' + +variable {ii : IdIntro M} {ie : IdElimBase ii} {N : Universe Ctx} (i : M.Id' ii N) + +open IdIntro IdElimBase + +variable {Γ} (ar : y(Γ) ⟶ (UvPoly.id M.Tm).functor.obj N.Tm) + (aC : y(Γ) ⟶ ie.iFunctor.obj N.Ty) + (hrC : ar ≫ (UvPoly.id M.Tm).functor.map N.tp = + aC ≫ (verticalNatTrans ie).app N.Ty) + +include hrC in +lemma fst_eq_fst : UvPoly.Equiv.fst _ _ ar = ie.equivFst aC := + calc _ + _ = UvPoly.Equiv.fst _ _ (ar ≫ (UvPoly.id M.Tm).functor.map N.tp) := by + rw [UvPoly.Equiv.fst_comp_right] + _ = UvPoly.Equiv.fst _ _ (aC ≫ (IdElimBase.verticalNatTrans ie).app N.Ty) := by + rw [hrC] + _ = _ := by + rw [ie.equivFst_verticalNatTrans_app] + +abbrev motive : y(ii.motiveCtx (ie.equivFst aC)) ⟶ N.Ty := + ie.equivSnd aC + +lemma comp_motive {Δ} (σ : Δ ⟶ Γ) : motive (ym(σ) ≫ aC) = + ym(ii.motiveSubst σ (ie.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 + +def lift : y(Γ) ⟶ (IdElimBase.iFunctor ie).obj N.Tm := + ie.equivMk (ie.equivFst aC) (i.j (ie.equivFst 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] + +def toId : M.Id ie N where + __ := ie + weakPullback := RepPullbackCone.WeakPullback.mk + ((IdElimBase.verticalNatTrans ie).naturality _).symm + (fun s => lift i s.fst 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 Universe + +end StructuredModel From 4943f6329da0069a4f326123afa3d6d13e0e1c62 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Wed, 12 Nov 2025 15:55:05 -0500 Subject: [PATCH 22/95] remove preserves pullbacks proofs --- .../ForMathlib/CategoryTheory/Polynomial.lean | 58 +++++++++---------- 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index e1e0e96c..d864b9d3 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -489,9 +489,9 @@ instance {B O : C} {i : B ⟶ O} (hi : R i) [R.HasPullbacks] [R.IsStableUnderBas [R.IsStableUnderComposition] : (pullback R ⊤ i).IsRightAdjoint := (mapPullbackAdj R ⊤ i hi ⟨⟩).isRightAdjoint -instance [R.IsStableUnderComposition] {X Y} {f : X ⟶ Y} (hf : R f) : - Limits.PreservesLimitsOfShape WalkingCospan (MorphismProperty.Over.map ⊤ hf) := - sorry +-- instance [R.IsStableUnderComposition] {X Y} {f : X ⟶ Y} (hf : R f) : +-- Limits.PreservesLimitsOfShape WalkingCospan (MorphismProperty.Over.map ⊤ hf) := +-- sorry variable {I O E B : C} (P : MvPoly R H I O E B) [R.HasPullbacks] [R.IsStableUnderBaseChange] [H.HasPullbacks] [R.HasPushforwards H] [R.IsStableUnderPushforward H] @@ -631,24 +631,24 @@ lemma eta (pair : Γ ⟶ (P @ X).toComma) : mk (fst pair) (by simp) (snd pair) = 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 +-- -- 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 ``` @@ -884,10 +884,10 @@ def apply [ChosenTerminal C] (P : UvPoly R E B) : 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 +-- instance [ChosenTerminal C] (P : UvPoly R E B) : +-- Limits.PreservesLimitsOfShape WalkingCospan P.functor := by +-- unfold functor +-- infer_instance variable (B) @@ -1498,7 +1498,7 @@ lemma mk'_comp_verticalNatTrans_app {Γ : C} (X : C) (b : Γ ⟶ B) {R f g} 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 +-- 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 From 2c168e12998c46c6cb66229e5d5e72c2897bc7ed Mon Sep 17 00:00:00 2001 From: jlh18 Date: Wed, 12 Nov 2025 17:10:48 -0500 Subject: [PATCH 23/95] fix: remove unprovable lemmas --- .../ForMathlib/CategoryTheory/Polynomial.lean | 82 +++++++++++++------ 1 file changed, 55 insertions(+), 27 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index d864b9d3..c599a345 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -756,12 +756,34 @@ def cartesianNatTrans {E' B' : C} (P : MvPoly R H I O E B) (P' : MvPoly R H I O Functor.whiskerLeft _ (MorphismProperty.Over.pullbackId R ⊤ O).hom cellLeft ≫ᵥ cellMid ≫ᵥ cellRight -open NatTrans in -theorem isCartesian_cartesianNatTrans {E' B' : C} (P : MvPoly R H I O E B) (P' : MvPoly R H I O E' B') - (δ : 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 := by - dsimp [cartesianNatTrans] +-- 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 H I O E B) (P' : MvPoly R H I O E' B') +-- (δ : 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 := by +-- 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 @@ -777,17 +799,19 @@ theorem isCartesian_cartesianNatTrans {E' B' : C} (P : MvPoly R H I O E B) (P' : -- · 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 + + -- 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 @@ -969,13 +993,13 @@ open TwoSquare induces a natural transformation between their associated functors obtained by pasting the following 2-cells ``` - P'.p -C --- > C/E' ----> C/B' -----> C -‖ | | ‖ -‖ ↗ | φ* ≅ | δ* ↗ ‖ -‖ v v ‖ -C --- > C/E -----> C/B -----> C - P.p + 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) (P' : UvPoly R E' B') @@ -984,13 +1008,17 @@ def cartesianNatTrans {E' B' : C} (P : UvPoly R E B) (P' : UvPoly R E' B') 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} (P : UvPoly R E B) (Q : UvPoly R F D) (δ : 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 + sorry +-- 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 From 889ed71e262935d55247c23ac511c7d3be5090b3 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 13 Nov 2025 13:43:21 -0500 Subject: [PATCH 24/95] feat: ClanOver --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 233 ++++++++++++++++++ .../Comma/Over/Pushforward.lean | 4 +- .../MorphismProperty/Limits.lean | 2 +- .../ForMathlib/CategoryTheory/Polynomial.lean | 160 +----------- 4 files changed, 237 insertions(+), 162 deletions(-) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Clan.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean new file mode 100644 index 00000000..f56fe9b4 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -0,0 +1,233 @@ +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.NatTrans +import HoTTLean.Model.Natural.NaturalModel + +universe w v u v₁ u₁ + +noncomputable section + +namespace CategoryTheory + +open Category Limits MorphismProperty + +variable {C : Type u} [Category.{v} C] {X Y : Psh C} + +structure RepresentableChosenPullbacks (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 + +namespace MorphismProperty + +variable (R : MorphismProperty C) + +def ClanOver (X : C) : MorphismProperty (R.Over ⊤ X) := fun _ _ f => R f.left + +instance (X : C) [R.IsStableUnderComposition] : (ClanOver R X).IsStableUnderComposition where + comp_mem _ _ hf hg := R.comp_mem _ _ hf hg + +instance (X : C) [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] : + (ClanOver R X).IsStableUnderBaseChange := sorry + +instance (X : C) [R.IsStableUnderComposition] [R.HasPullbacks] [R.IsStableUnderBaseChange] : + (ClanOver R X).HasPullbacks := sorry + +instance (X : C) : (ClanOver R X).HasObjects := sorry + +instance (X : C) [R.ContainsIdentities] : (ClanOver R X).ContainsIdentities where + id_mem _ := R.id_mem _ + +structure RepresentableFibrantChosenPullbacks (f : X ⟶ Y) + extends RepresentableChosenPullbacks f where + fibrant {Γ : C} (b : y(Γ) ⟶ Y) : R (disp b) + +def ExtendedFibration.Fibrant (F : Psh C) : ObjectProperty (Over F) := + fun X => Nonempty (RepresentableFibrantChosenPullbacks R X.hom) + +abbrev ExtendedFibration (F : Psh C) := ObjectProperty.FullSubcategory + (ExtendedFibration.Fibrant R F) + +notation:max R"^("F")" => ExtendedFibration R F + +namespace ExtendedFibration + +variable (F : Psh C) + +def Fibration : MorphismProperty (R ^(F)) := fun _ _ θ => + Nonempty (RepresentableFibrantChosenPullbacks R θ.left) + +theorem hasObjects_fullSubcategory_extendedFibrationClan [R.HasPullbacks] : + (Fibration R F).HasPullbacks where + hasPullback := sorry + +end ExtendedFibration + + + +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])) + +/-- 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.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) + [R.HasPullbacksAlong h] [R.HasPullbacksAlong f] [R.HasPullbacksAlong g] [R.HasPullbacksAlong k] + (sq : f ≫ k = h ≫ g) : + TwoSquare (MorphismProperty.Over.pullback R ⊤ f) (MorphismProperty.Over.map ⊤ rk) + (MorphismProperty.Over.map ⊤ rh) + (MorphismProperty.Over.pullback R ⊤ g) := + (mateEquiv (MorphismProperty.Over.mapPullbackAdj R ⊤ k rk trivial) + (MorphismProperty.Over.mapPullbackAdj R ⊤ h rh trivial)).symm <| + ((MorphismProperty.Over.pullbackComp _ _).inv ≫ + eqToHom (by rw! [sq]) ≫ + (MorphismProperty.Over.pullbackComp _ _).hom) + +/-- +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 +``` +TODO: in what generality does this theorem hold? +NOTE: we know it holds when `R` is a 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 = ⊤`. +-/ +theorem pullbackMapTwoSquare_isIso {T : Type u} [Category.{v} T] (R : MorphismProperty T) + [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) + [R.HasPullbacksAlong h] [R.HasPullbacksAlong f] [R.HasPullbacksAlong g] [R.HasPullbacksAlong k] + (pb : IsPullback f h k g) : + NatTrans.IsCartesian <| pullbackMapTwoSquare R h f g k rk rh pb.w := + sorry + +/-- 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] {Q : MorphismProperty T} [Q.HasPullbacks] + [R.HasPushforwards Q] [R.IsStableUnderPushforward Q] {X Y Z W : T} + (h : X ⟶ Z) {f : X ⟶ Y} {g : Z ⟶ W} (k : Y ⟶ W) (sq : h ≫ g = f ≫ k) + (hf : Q f) (hg : Q g) : + TwoSquare (pushforward (P := R) hg) (Over.pullback R ⊤ h) (Over.pullback R ⊤ k) + (pushforward (P := R) hf) := + let pullbackTwoSquare : TwoSquare (Over.pullback R ⊤ k) (Over.pullback R ⊤ g) + (Over.pullback R ⊤ f) (Over.pullback R ⊤ h) := + ((Over.pullbackComp _ _).inv ≫ + eqToHom (by rw! [sq]) ≫ + (Over.pullbackComp _ _).hom) + mateEquiv (pullbackPushforwardAdjunction R hg) + (pullbackPushforwardAdjunction R hf) + pullbackTwoSquare + +/-- +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.{v} T] (R : MorphismProperty T) + [R.HasPullbacks] [R.IsStableUnderBaseChange] {Q : MorphismProperty T} [Q.HasPullbacks] + [R.HasPushforwards Q] [R.IsStableUnderPushforward Q] + {X Y Z W : T} (h : X ⟶ Z) {f : X ⟶ Y} {g : Z ⟶ W} (k : Y ⟶ W) (sq : h ≫ g = f ≫ k) + (hf : Q f) (hg : Q g) (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := R) h k pb.w hf hg) := + sorry diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean index 0f232f58..97bc7ead 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean @@ -46,11 +46,11 @@ def pushforward.isPushforward (X : Over S) [HasPushforward f X] : /-- A morphism `f` has pushforwards (also called exponentiable) when there is a pushforward along `f` for any map into its domain. -/ -abbrev HasPushforwards : Prop := ∀ (X : Over S), HasPushforward f X +abbrev HasPushforwardsAlong : Prop := ∀ (X : Over S), HasPushforward f X namespace Over -variable [HasPushforwards f] +variable [HasPushforwardsAlong f] lemma pullback_rightAdjointObjIsDefined_eq_top : (Over.pullback f).rightAdjointObjIsDefined = ⊤ := by aesop_cat diff --git a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean index 5852bfd8..f5d0a242 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean @@ -67,7 +67,7 @@ instance [P.IsStableUnderBaseChange] {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) IsPullback.hasPullback (IsPullback.paste_horiz (IsPullback.of_hasPullback (pullback.snd h g) f) (IsPullback.of_hasPullback h g)) -/-- A morphism property satisfies `ContainsObjects` when any map `! : X ⟶ Y` to a terminal +/-- 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 diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index c599a345..41b505d5 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -14,6 +14,7 @@ import HoTTLean.ForMathlib import HoTTLean.ForMathlib.CategoryTheory.NatTrans import Mathlib.Tactic.DepRewrite import Poly.ForMathlib.CategoryTheory.NatTrans +import HoTTLean.ForMathlib.CategoryTheory.Clan universe v u v₁ u₁ @@ -27,165 +28,6 @@ variable {C : Type u} [Category.{v} C] namespace MorphismProperty -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])) - -/-- 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.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) - [R.HasPullbacksAlong h] [R.HasPullbacksAlong f] [R.HasPullbacksAlong g] [R.HasPullbacksAlong k] - (sq : f ≫ k = h ≫ g) : - TwoSquare (MorphismProperty.Over.pullback R ⊤ f) (MorphismProperty.Over.map ⊤ rk) - (MorphismProperty.Over.map ⊤ rh) - (MorphismProperty.Over.pullback R ⊤ g) := - (mateEquiv (MorphismProperty.Over.mapPullbackAdj R ⊤ k rk trivial) - (MorphismProperty.Over.mapPullbackAdj R ⊤ h rh trivial)).symm <| - ((MorphismProperty.Over.pullbackComp _ _).inv ≫ - eqToHom (by rw! [sq]) ≫ - (MorphismProperty.Over.pullbackComp _ _).hom) - -/-- -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 -``` -TODO: in what generality does this theorem hold? -NOTE: we know it holds when `R` is a 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 = ⊤`. --/ -theorem pullbackMapTwoSquare_isIso {T : Type u} [Category.{v} T] (R : MorphismProperty T) - [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) - [R.HasPullbacksAlong h] [R.HasPullbacksAlong f] [R.HasPullbacksAlong g] [R.HasPullbacksAlong k] - (pb : IsPullback f h k g) : - NatTrans.IsCartesian <| pullbackMapTwoSquare R h f g k rk rh pb.w := - sorry - -/-- 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] {Q : MorphismProperty T} [Q.HasPullbacks] - [R.HasPushforwards Q] [R.IsStableUnderPushforward Q] {X Y Z W : T} - (h : X ⟶ Z) {f : X ⟶ Y} {g : Z ⟶ W} (k : Y ⟶ W) (sq : h ≫ g = f ≫ k) - (hf : Q f) (hg : Q g) : - TwoSquare (pushforward (P := R) hg) (Over.pullback R ⊤ h) (Over.pullback R ⊤ k) - (pushforward (P := R) hf) := - let pullbackTwoSquare : TwoSquare (Over.pullback R ⊤ k) (Over.pullback R ⊤ g) - (Over.pullback R ⊤ f) (Over.pullback R ⊤ h) := - ((Over.pullbackComp _ _).inv ≫ - eqToHom (by rw! [sq]) ≫ - (Over.pullbackComp _ _).hom) - mateEquiv (pullbackPushforwardAdjunction R hg) - (pullbackPushforwardAdjunction R hf) - pullbackTwoSquare - -/-- -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.{v} T] (R : MorphismProperty T) - [R.HasPullbacks] [R.IsStableUnderBaseChange] {Q : MorphismProperty T} [Q.HasPullbacks] - [R.HasPushforwards Q] [R.IsStableUnderPushforward Q] - {X Y Z W : T} (h : X ⟶ Z) {f : X ⟶ Y} {g : Z ⟶ W} (k : Y ⟶ W) (sq : h ≫ g = f ≫ k) - (hf : Q f) (hg : Q g) (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := R) h k pb.w hf hg) := - sorry - /- Copyright (c) 2025 Wojciech Nawrocki. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. From 6543722e02b6554ef92a7db3c09ffbf21b695530 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 13 Nov 2025 13:46:13 -0500 Subject: [PATCH 25/95] fix: OverFibration --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index f56fe9b4..ba405593 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -31,20 +31,20 @@ namespace MorphismProperty variable (R : MorphismProperty C) -def ClanOver (X : C) : MorphismProperty (R.Over ⊤ X) := fun _ _ f => R f.left +def OverFibration (X : C) : MorphismProperty (R.Over ⊤ X) := fun _ _ f => R f.left -instance (X : C) [R.IsStableUnderComposition] : (ClanOver R X).IsStableUnderComposition where +instance (X : C) [R.IsStableUnderComposition] : (OverFibration R X).IsStableUnderComposition where comp_mem _ _ hf hg := R.comp_mem _ _ hf hg instance (X : C) [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] : - (ClanOver R X).IsStableUnderBaseChange := sorry + (OverFibration R X).IsStableUnderBaseChange := sorry instance (X : C) [R.IsStableUnderComposition] [R.HasPullbacks] [R.IsStableUnderBaseChange] : - (ClanOver R X).HasPullbacks := sorry + (OverFibration R X).HasPullbacks := sorry -instance (X : C) : (ClanOver R X).HasObjects := sorry +instance (X : C) : (OverFibration R X).HasObjects := sorry -instance (X : C) [R.ContainsIdentities] : (ClanOver R X).ContainsIdentities where +instance (X : C) [R.ContainsIdentities] : (OverFibration R X).ContainsIdentities where id_mem _ := R.id_mem _ structure RepresentableFibrantChosenPullbacks (f : X ⟶ Y) From 6fe775aab1ba1a47ea1e6af7d108fafa53896c94 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 13 Nov 2025 14:13:32 -0500 Subject: [PATCH 26/95] feat: automatic instances for ExtendedFibration --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 45 +++++++++++--------- 1 file changed, 26 insertions(+), 19 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index ba405593..a47bb1fb 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -31,44 +31,51 @@ namespace MorphismProperty variable (R : MorphismProperty C) -def OverFibration (X : C) : MorphismProperty (R.Over ⊤ X) := fun _ _ f => R f.left - -instance (X : C) [R.IsStableUnderComposition] : (OverFibration R X).IsStableUnderComposition where - comp_mem _ _ hf hg := R.comp_mem _ _ hf hg +def LocalPreclan (X : C) : MorphismProperty (R.Over ⊤ X) := fun _ _ f => R f.left instance (X : C) [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] : - (OverFibration R X).IsStableUnderBaseChange := sorry + (LocalPreclan R X).IsStableUnderBaseChange := sorry instance (X : C) [R.IsStableUnderComposition] [R.HasPullbacks] [R.IsStableUnderBaseChange] : - (OverFibration R X).HasPullbacks := sorry + (LocalPreclan R X).HasPullbacks := sorry -instance (X : C) : (OverFibration R X).HasObjects := sorry +instance (X : C) : (LocalPreclan R X).HasObjects := sorry -instance (X : C) [R.ContainsIdentities] : (OverFibration R X).ContainsIdentities where +instance (X : C) [R.ContainsIdentities] : (LocalPreclan R X).ContainsIdentities where id_mem _ := R.id_mem _ +instance (X : C) [R.IsStableUnderComposition] : (LocalPreclan R X).IsStableUnderComposition where + comp_mem _ _ hf hg := R.comp_mem _ _ hf hg + structure RepresentableFibrantChosenPullbacks (f : X ⟶ Y) extends RepresentableChosenPullbacks f where fibrant {Γ : C} (b : y(Γ) ⟶ Y) : R (disp b) -def ExtendedFibration.Fibrant (F : Psh C) : ObjectProperty (Over F) := - fun X => Nonempty (RepresentableFibrantChosenPullbacks R X.hom) +-- this is a preclan, does not satisfy HasObjects +def ExtendedFibration : MorphismProperty (Psh C) := + fun _ _ f => Nonempty (RepresentableFibrantChosenPullbacks R f) -abbrev ExtendedFibration (F : Psh C) := ObjectProperty.FullSubcategory - (ExtendedFibration.Fibrant R F) +instance : (ExtendedFibration R).IsStableUnderBaseChange := sorry -notation:max R"^("F")" => ExtendedFibration R F +instance : (ExtendedFibration R).HasPullbacks := sorry + +instance [R.ContainsIdentities] : (ExtendedFibration R).ContainsIdentities where + id_mem _ := sorry + +instance [R.IsStableUnderComposition] : (ExtendedFibration R).IsStableUnderComposition where + comp_mem _ _ hf hg := sorry + +notation:max R"^("F")" => LocalPreclan (ExtendedFibration R) F namespace ExtendedFibration variable (F : Psh C) -def Fibration : MorphismProperty (R ^(F)) := fun _ _ θ => - Nonempty (RepresentableFibrantChosenPullbacks R θ.left) - -theorem hasObjects_fullSubcategory_extendedFibrationClan [R.HasPullbacks] : - (Fibration R F).HasPullbacks where - hasPullback := sorry +example [R.IsStableUnderComposition] : (R ^(F)).HasPullbacks := inferInstance +example [R.IsStableUnderComposition] : (R ^(F)).IsStableUnderBaseChange := inferInstance +example : (R ^(F)).HasObjects := inferInstance +example [R.ContainsIdentities] : (R ^(F)).ContainsIdentities := inferInstance +example [R.IsStableUnderComposition] : (R ^(F)).IsStableUnderComposition := inferInstance end ExtendedFibration From aff66f778a5870cb2d33d8f8e48cf92e9d9f73fb Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 13 Nov 2025 20:44:15 -0500 Subject: [PATCH 27/95] feat: P.HasPushforwardsAlong f --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 123 ++++++--- .../MorphismProperty/Limits.lean | 3 + .../MorphismProperty/OverAdjunction.lean | 173 ++++++------ .../ForMathlib/CategoryTheory/Polynomial.lean | 247 ++++++++---------- .../Model/Structured/StructuredUniverse.lean | 39 ++- 5 files changed, 331 insertions(+), 254 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index a47bb1fb..61b8bb94 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -8,7 +8,8 @@ import HoTTLean.ForMathlib import HoTTLean.ForMathlib.CategoryTheory.NatTrans import Mathlib.Tactic.DepRewrite import Poly.ForMathlib.CategoryTheory.NatTrans -import HoTTLean.Model.Natural.NaturalModel +import HoTTLean.ForMathlib.CategoryTheory.Yoneda +import Poly.ForMathlib.CategoryTheory.LocallyCartesianClosed.Presheaf universe w v u v₁ u₁ @@ -18,9 +19,21 @@ namespace CategoryTheory open Category Limits MorphismProperty -variable {C : Type u} [Category.{v} C] {X Y : Psh C} +variable {C : Type u} [Category.{v} C] {C' : Type u₁} [Category.{v₁} C'] (F : C ⥤ C') -structure RepresentableChosenPullbacks (f : X ⟶ Y) where +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 @@ -31,23 +44,60 @@ namespace MorphismProperty variable (R : MorphismProperty C) -def LocalPreclan (X : C) : MorphismProperty (R.Over ⊤ X) := fun _ _ f => R f.left +def Local (X : C) : MorphismProperty (R.Over ⊤ X) := fun _ _ f => R f.left instance (X : C) [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] : - (LocalPreclan R X).IsStableUnderBaseChange := sorry + (Local R X).IsStableUnderBaseChange := sorry instance (X : C) [R.IsStableUnderComposition] [R.HasPullbacks] [R.IsStableUnderBaseChange] : - (LocalPreclan R X).HasPullbacks := sorry + (Local R X).HasPullbacks := sorry -instance (X : C) : (LocalPreclan R X).HasObjects := sorry +instance (X : C) : (Local R X).HasObjects := sorry -instance (X : C) [R.ContainsIdentities] : (LocalPreclan R X).ContainsIdentities where +instance (X : C) [R.ContainsIdentities] : (Local R X).ContainsIdentities where id_mem _ := R.id_mem _ -instance (X : C) [R.IsStableUnderComposition] : (LocalPreclan R X).IsStableUnderComposition where - comp_mem _ _ hf hg := R.comp_mem _ _ hf hg +instance (X : C) [R.IsStableUnderComposition] : + (Local R X).IsStableUnderComposition where + comp_mem _ _ := R.comp_mem _ _ + +abbrev chosenTerminal [R.ContainsIdentities] (X) : R.Over ⊤ X := .mk ⊤ (𝟙 X) (R.id_mem _) + +@[simps!] +protected def Over.post (R : MorphismProperty C) (R' : MorphismProperty C') + [F.PreservesMorphismProperty R R'] (X : C) : R.Over ⊤ X ⥤ R'.Over ⊤ (F.obj X) where + obj X := MorphismProperty.Over.mk ⊤ (F.map X.hom) (F.map_mem _ X.prop) + map f := MorphismProperty.Over.homMk (F.map f.left) (by simp [← F.map_comp]) + map_id := sorry + map_comp := sorry + +instance {R' : MorphismProperty C'} [F.PreservesMorphismProperty R R'] (X : C) : + (Over.post F R R' X).PreservesMorphismProperty (Local R X) (Local R' (F.obj X)) where + map_mem _ := F.map_mem _ + +instance {R' : MorphismProperty C'} [F.PreservesMorphismProperty R R'] [F.PreservesPullbacksOf R] + (X : C) : (Over.post F R R' X).PreservesPullbacksOf (Local R X) where + pb := sorry -structure RepresentableFibrantChosenPullbacks (f : X ⟶ Y) +@[simp] +lemma localFunctor_obj_chosenTerminal [R.ContainsIdentities] {R' : MorphismProperty C'} + [R'.ContainsIdentities] [F.PreservesMorphismProperty R R'] (X : C) : + (Over.post F R R' X).obj (R.chosenTerminal X) = R'.chosenTerminal (F.obj X) := by + cat_disch + +instance [R.IsStableUnderBaseChange] {X Y : C} (f : X ⟶ Y) [R.HasPullbacksAlong f] : + (Over.pullback R ⊤ f).PreservesMorphismProperty (Local R Y) (Local R X) := sorry + +instance [R.IsStableUnderBaseChange] {X Y : C} (f : X ⟶ Y) [R.HasPullbacksAlong f] : + (Over.pullback R ⊤ f).PreservesPullbacksOf (Local R Y) := sorry + +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 + +structure RepresentableFibrantChosenPullbacks {X Y : Psh C} (f : X ⟶ Y) extends RepresentableChosenPullbacks f where fibrant {Γ : C} (b : y(Γ) ⟶ Y) : R (disp b) @@ -65,22 +115,20 @@ instance [R.ContainsIdentities] : (ExtendedFibration R).ContainsIdentities where instance [R.IsStableUnderComposition] : (ExtendedFibration R).IsStableUnderComposition where comp_mem _ _ hf hg := sorry -notation:max R"^("F")" => LocalPreclan (ExtendedFibration R) F +notation:max R"^("F")" => Local (ExtendedFibration R) F namespace ExtendedFibration variable (F : Psh C) -example [R.IsStableUnderComposition] : (R ^(F)).HasPullbacks := inferInstance -example [R.IsStableUnderComposition] : (R ^(F)).IsStableUnderBaseChange := inferInstance -example : (R ^(F)).HasObjects := inferInstance -example [R.ContainsIdentities] : (R ^(F)).ContainsIdentities := inferInstance -example [R.IsStableUnderComposition] : (R ^(F)).IsStableUnderComposition := inferInstance +example [R.IsStableUnderComposition] : (R^(F)).HasPullbacks := inferInstance +example [R.IsStableUnderComposition] : (R^(F)).IsStableUnderBaseChange := inferInstance +example : (R^(F)).HasObjects := inferInstance +example [R.ContainsIdentities] : (R^(F)).ContainsIdentities := inferInstance +example [R.IsStableUnderComposition] : (R^(F)).IsStableUnderComposition := inferInstance end ExtendedFibration - - instance : (⊤ : MorphismProperty C).HasOfPostcompProperty ⊤ where of_postcomp := by simp @@ -131,9 +179,9 @@ def pullbackMapTwoSquare {T : Type u} [Category.{v} T] (R : MorphismProperty T) (MorphismProperty.Over.pullback R ⊤ g) := (mateEquiv (MorphismProperty.Over.mapPullbackAdj R ⊤ k rk trivial) (MorphismProperty.Over.mapPullbackAdj R ⊤ h rh trivial)).symm <| - ((MorphismProperty.Over.pullbackComp _ _).inv ≫ + (MorphismProperty.Over.pullbackComp _ _).inv ≫ eqToHom (by rw! [sq]) ≫ - (MorphismProperty.Over.pullbackComp _ _).hom) + (MorphismProperty.Over.pullbackComp _ _).hom /-- The Beck-Chevalley two-square `pushforwardPullbackTwoSquare` is a natural isomorphism @@ -193,19 +241,20 @@ 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] {Q : MorphismProperty T} [Q.HasPullbacks] - [R.HasPushforwards Q] [R.IsStableUnderPushforward Q] {X Y Z W : T} - (h : X ⟶ Z) {f : X ⟶ Y} {g : Z ⟶ W} (k : Y ⟶ W) (sq : h ≫ g = f ≫ k) - (hf : Q f) (hg : Q g) : - TwoSquare (pushforward (P := R) hg) (Over.pullback R ⊤ h) (Over.pullback R ⊤ k) - (pushforward (P := R) hf) := + [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) := let pullbackTwoSquare : TwoSquare (Over.pullback R ⊤ k) (Over.pullback R ⊤ g) (Over.pullback R ⊤ f) (Over.pullback R ⊤ h) := - ((Over.pullbackComp _ _).inv ≫ + (Over.pullbackComp _ _).inv ≫ eqToHom (by rw! [sq]) ≫ - (Over.pullbackComp _ _).hom) - mateEquiv (pullbackPushforwardAdjunction R hg) - (pullbackPushforwardAdjunction R hf) + (Over.pullbackComp _ _).hom + mateEquiv (pullbackPushforwardAdjunction R g) + (pullbackPushforwardAdjunction R f) pullbackTwoSquare /-- @@ -232,9 +281,11 @@ NOTE: we know it holds when for π-clans with `R = Q = the π-clan` NOTE: we also know it holds in a category with pullbacks with `R = ⊤` and `Q = ExponentiableMaps`. -/ theorem pushforwardPullbackTwoSquare_isIso {T : Type u} [Category.{v} T] (R : MorphismProperty T) - [R.HasPullbacks] [R.IsStableUnderBaseChange] {Q : MorphismProperty T} [Q.HasPullbacks] - [R.HasPushforwards Q] [R.IsStableUnderPushforward Q] - {X Y Z W : T} (h : X ⟶ Z) {f : X ⟶ Y} {g : Z ⟶ W} (k : Y ⟶ W) (sq : h ≫ g = f ≫ k) - (hf : Q f) (hg : Q g) (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := R) h k pb.w hf hg) := + [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] + (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := sorry diff --git a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean index f5d0a242..7a6210e5 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/Limits.lean @@ -40,6 +40,9 @@ 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) diff --git a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean index 26430a3f..e67f7aa0 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean @@ -54,53 +54,86 @@ end Map section Pullback -variable [P.IsStableUnderBaseChange] [Q.IsStableUnderBaseChange] [Q.IsMultiplicative] +/-- 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 (f : X ⟶ Y) [P.HasPullbacksAlong f] (A : P.Over Q Y) : HasPullback A.hom f := +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 [P.IsStableUnderBaseChange] {X Y Z} (f : X ⟶ Y) (g : Y ⟶ Z) [P.HasPullbacksAlong f] - [P.HasPullbacksAlong g] (A : P.Over Q Z) : HasPullback (pullback.snd A.hom g) f := +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) - (P.of_isPullback (IsPullback.of_hasPullback A.hom g) A.prop) + (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 (f : X ⟶ Y) [P.HasPullbacksAlong f] : +noncomputable def Over.pullback : P.Over Q Y ⥤ P.Over Q X where obj A := Over.mk Q (Limits.pullback.snd A.hom f) - (pullback_snd A.hom f A.prop) + (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} +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 (f : X ⟶ Y) [P.HasPullbacksAlong f] (g : Y ⟶ Z) - [P.HasPullbacksAlong g] [Q.RespectsIso] : Over.pullback P Q (f ≫ g) ≅ +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 (f : X ⟶ Y) [P.HasPullbacksAlong f] (g : Y ⟶ Z) - [P.HasPullbacksAlong g] [Q.RespectsIso] (A : P.Over Q Z) : +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`. -/ -noncomputable def Over.pullbackCongr {f : X ⟶ Y} [P.HasPullbacksAlong f] {g : X ⟶ Y} (h : f = g) : +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 := NatIso.ofComponents (fun X ↦ eqToIso (by simp [h])) @[reassoc (attr := simp)] -lemma Over.pullbackCongr_hom_app_left_fst {f : X ⟶ Y} [P.HasPullbacksAlong f] {g : X ⟶ Y} +lemma Over.pullbackCongr_hom_app_left_fst {g : X ⟶ Y} (h : f = g) (A : P.Over Q Y) : have : P.HasPullbacksAlong g := by subst h; infer_instance + have : P.IsStableUnderBaseChangeAlong g := by subst h; infer_instance ((Over.pullbackCongr h).hom.app A).left ≫ pullback.fst A.hom g = pullback.fst A.hom f := by subst h simp [pullbackCongr] @@ -114,7 +147,7 @@ variable [P.IsStableUnderComposition] [P.IsStableUnderBaseChange] /-- `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] - [Q.HasOfPostcompProperty Q] (hPf : P f) (hQf : Q 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 := fun A B ↦ @@ -140,8 +173,7 @@ 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) : Prop where +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] @@ -159,87 +191,82 @@ pushforward along `p` relative to the pullback. -/ protected class HasPushforwards [Q.HasPullbacks] : Prop where hasPushforwardsAlong : ∀ {S S' : T} (q : S ⟶ S') (hq : Q q), - P.HasPushforwardsAlong (hasPullbacksAlong_of_hasPullbacks hq) + have : HasPullbacksAlong q := hasPullbacksAlong_of_hasPullbacks hq + P.HasPushforwardsAlong q -variable {P Q} in -lemma HasPushforwards.hasPushforward [Q.HasPullbacks] [P.HasPushforwards Q] - {S S' W : T} {f : S ⟶ S'} (hf : Q f) {g : W ⟶ S} (hg : P g) : - @HasPushforward _ _ _ _ f (fun h => hasPullbacksAlong_of_hasPullbacks hf h) (.mk g) := - (HasPushforwards.hasPushforwardsAlong f hf).hasPushforward g hg +/-- 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 /-- 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 IsStableUnderPushforward [Q.HasPullbacks] : Prop where - of_isPushforward {S S' X Y : T} (q : S ⟶ S') (hq : Q q) (f : X ⟶ S) (hf : P f) {g : Y ⟶ S'} - (isPushforward : IsPushforward (inst_hasPullback := hasPullbacksAlong_of_hasPullbacks hq) - q (.mk f) (.mk g)) : P g +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 /-- 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') - (hpb : HasPullbacksAlong q) - (hpf : P.HasPushforwardsAlong hpb) : - P.Over ⊤ S ⥤ Over S' := +noncomputable def pushforwardPartial {S S' : T} (q : S ⟶ S') [HasPullbacksAlong q] + [P.HasPushforwardsAlong q] : P.Over ⊤ S ⥤ Over S' := ObjectProperty.lift _ (Over.forget P ⊤ S) (fun X => HasPushforwardsAlong.hasPushforward X.hom X.prop) ⋙ (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 {Q : MorphismProperty T} [Q.HasPullbacks] [P.HasPushforwards Q] - [P.IsStableUnderPushforward Q] {S S' : T} {q : S ⟶ S'} (hq : Q q) : +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 (hasPullbacksAlong_of_hasPullbacks hq) - (HasPushforwards.hasPushforwardsAlong q hq) - ) (fun X => IsStableUnderPushforward.of_isPushforward q hq X.hom X.prop - ((have : HasPullbacksAlong q := hasPullbacksAlong_of_hasPullbacks hq - have : HasPushforward q X.toComma := HasPushforwards.hasPushforward hq X.prop + 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) section homEquiv -open Over - -variable {P} {Q : MorphismProperty T} [Q.HasPullbacks] [P.HasPushforwards Q] - [P.IsStableUnderPushforward Q] {S S' : T} {q : S ⟶ S'} (hq : Q q) +variable {P} {S S' : T} (q : S ⟶ S') [HasPullbacksAlong q] + [P.HasPushforwardsAlong q] [P.IsStableUnderPushforwardsAlong q] -@[simp] -abbrev Over.pullback' := @CategoryTheory.Over.pullback _ _ _ _ q (hasPullbacksAlong_of_hasPullbacks hq) +-- @[simp] +-- abbrev Over.pullback' := @CategoryTheory.Over.pullback _ _ _ _ q (hasPullbacksAlong_of_hasPullbacks hq) /-- 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 hq).obj Y).toComma) ≃ - ((pullback' hq).obj X ⟶ + (X ⟶ ((pushforward P q).obj Y).toComma) ≃ + ((CategoryTheory.Over.pullback q).obj X ⟶ Y.toComma) := (Functor.partialRightAdjointHomEquiv ..) lemma pushforward.homEquiv_comp {X X' : Over S'} {Y : P.Over ⊤ S} - (f : X' ⟶ ((pushforward P hq).obj Y).toComma) (g : X ⟶ X') : - pushforward.homEquiv hq (g ≫ f) = - (pullback' hq).map g ≫ homEquiv hq f := + (f : X' ⟶ ((pushforward P q).obj Y).toComma) (g : X ⟶ X') : + pushforward.homEquiv q (g ≫ f) = + (CategoryTheory.Over.pullback q).map g ≫ homEquiv q f := Functor.partialRightAdjointHomEquiv_comp .. lemma pushforward.homEquiv_map_comp {X : Over S'} {Y Y' : P.Over ⊤ S} - (f : X ⟶ ((pushforward P hq).obj Y).toComma) (g : Y ⟶ Y') : - homEquiv hq (f ≫ Comma.Hom.hom ((P.pushforward hq).map g)) = - homEquiv hq f ≫ Comma.Hom.hom g := + (f : X ⟶ ((pushforward P q).obj Y).toComma) (g : Y ⟶ Y') : + homEquiv q (f ≫ Comma.Hom.hom ((P.pushforward q).map g)) = + homEquiv q f ≫ Comma.Hom.hom g := Functor.partialRightAdjointHomEquiv_map_comp .. lemma pushforward.homEquiv_symm_comp {X : Over S'} {Y Y' : P.Over ⊤ S} - (f : (pullback' hq).obj X ⟶ Y.toComma) (g : Y ⟶ Y') : - (homEquiv hq).symm f ≫ Comma.Hom.hom ((P.pushforward hq).map g) = - (homEquiv hq).symm (f ≫ Comma.Hom.hom g) := + (f : (CategoryTheory.Over.pullback q).obj X ⟶ Y.toComma) (g : Y ⟶ Y') : + (homEquiv q).symm f ≫ Comma.Hom.hom ((P.pushforward q).map g) = + (homEquiv q).symm (f ≫ Comma.Hom.hom g) := Functor.partialRightAdjointHomEquiv_symm_comp .. lemma pushforward.homEquiv_comp_symm {X X' : Over S'} {Y : P.Over ⊤ S} - (f : (pullback' hq).obj X' ⟶ Y.toComma) (g : X ⟶ X') : - g ≫ (homEquiv hq).symm f = - (homEquiv hq).symm ((pullback' hq).map g ≫ f) := + (f : (CategoryTheory.Over.pullback q).obj X' ⟶ Y.toComma) (g : X ⟶ X') : + g ≫ (homEquiv q).symm f = + (homEquiv q).symm ((CategoryTheory.Over.pullback q).map g ≫ f) := Functor.partialRightAdjointHomEquiv_comp_symm .. end homEquiv @@ -248,25 +275,23 @@ section open MorphismProperty.Over -variable {Q} [P.IsStableUnderBaseChange] {S S' : T} {f : S ⟶ S'} (hf : Q f) - [Q.HasPullbacks] [P.HasPushforwards Q] [P.IsStableUnderPushforward Q] +variable [P.IsStableUnderBaseChange] {S S' : T} (f : S ⟶ S') + [HasPullbacksAlong f] [P.HasPushforwardsAlong f] [P.IsStableUnderPushforwardsAlong f] -@[simp] -abbrev Over.pullback'' := @Over.pullback _ _ P ⊤ _ _ _ _ _ f - (hasPullbacksAlong_of_hasPullbacks' hf) +instance : P.HasPullbacksAlong f where + hasPullback := inferInstance /-- The `pullback ⊣ pushforward` adjunction. -/ -def pullbackPushforwardAdjunction : @Over.pullback _ _ P ⊤ _ _ _ _ _ f - (hasPullbacksAlong_of_hasPullbacks' hf) ⊣ pushforward P hf := +def pullbackPushforwardAdjunction : Over.pullback P ⊤ f ⊣ pushforward P f := Adjunction.mkOfHomEquiv { homEquiv X Y := - calc ((pullback'' P hf).obj X ⟶ Y) - _ ≃ (((pullback'' P hf).obj X).toComma ⟶ Y.toComma) := + 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 hf).obj Y).toComma) := - (pushforward.homEquiv hf).symm + _ ≃ (X.toComma ⟶ ((P.pushforward f).obj Y).toComma) := + (pushforward.homEquiv f).symm _ ≃ _ := Equiv.cast (by dsimp) -- why? - _ ≃ (X ⟶ (P.pushforward hf).obj Y) := + _ ≃ (X ⟶ (P.pushforward f).obj Y) := (Functor.FullyFaithful.ofFullyFaithful (Over.forget P ⊤ S')).homEquiv.symm homEquiv_naturality_left_symm g f := by simp only [Equiv.trans_def, Equiv.cast_refl, Equiv.trans_refl, @@ -291,11 +316,11 @@ def pullbackPushforwardAdjunction : @Over.pullback _ _ P ⊤ _ _ _ _ _ f rfl } -instance : (pullback'' P hf).IsLeftAdjoint := - Adjunction.isLeftAdjoint (pullbackPushforwardAdjunction P hf) +instance : (pullback P ⊤ f).IsLeftAdjoint := + Adjunction.isLeftAdjoint (pullbackPushforwardAdjunction P f) -instance : (pushforward P hf).IsRightAdjoint := - Adjunction.isRightAdjoint (pullbackPushforwardAdjunction P hf) +instance : (pushforward P f).IsRightAdjoint := + Adjunction.isRightAdjoint (pullbackPushforwardAdjunction P f) end diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index 41b505d5..f65a8854 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -4,16 +4,6 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Joseph Hua, Sina Hazratpour, Emily Riehl -/ -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.NatTrans import HoTTLean.ForMathlib.CategoryTheory.Clan universe v u v₁ u₁ @@ -28,41 +18,6 @@ variable {C : Type u} [Category.{v} C] namespace MorphismProperty -/- -Copyright (c) 2025 Wojciech Nawrocki. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Wojciech Nawrocki --/ - -theorem _root_.CategoryTheory.Functor.reflect_commSq - {C D : Type*} [Category C] [Category D] - (F : C ⥤ D) [Functor.Faithful F] - {X Y Z W : C} {f : X ⟶ Y} {g : X ⟶ Z} {h : Y ⟶ W} {i : Z ⟶ W} : - CommSq (F.map f) (F.map g) (F.map h) (F.map i) → - CommSq f g h i := by - intro cs - constructor - apply Functor.map_injective F - simpa [← Functor.map_comp] using cs.w - -theorem _root_.CategoryTheory.Functor.reflect_isPullback - {C D : Type*} [Category C] [Category D] (F : C ⥤ D) - {X Y Z W : C} (f : X ⟶ Y) (g : X ⟶ Z) (h : Y ⟶ W) (i : Z ⟶ W) - [rl : ReflectsLimit (cospan h i) F] [Functor.Faithful F] : - IsPullback (F.map f) (F.map g) (F.map h) (F.map i) → - IsPullback f g h i := by - intro pb - have sq := F.reflect_commSq pb.toCommSq - apply IsPullback.mk sq - apply rl.reflects - let i := cospanCompIso F h i - apply IsLimit.equivOfNatIsoOfIso i.symm pb.cone _ _ pb.isLimit - let j : - ((Cones.postcompose i.symm.hom).obj pb.cone).pt ≅ - (F.mapCone <| PullbackCone.mk f g sq.w).pt := - Iso.refl _ - apply WalkingCospan.ext j <;> simp +zetaDelta - 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`. -/ @@ -87,17 +42,15 @@ namespace PolynomialPartialAdjunction variable {T : Type u} [Category.{v} T] {R : MorphismProperty T} [R.HasPullbacks] [R.IsStableUnderBaseChange] - {Q : MorphismProperty T} [Q.HasPullbacks] [R.HasPushforwards Q] - [R.IsStableUnderPushforward Q] - {E I B : T} (i : E ⟶ I) {p : E ⟶ B} (hp : Q p) - -abbrev pullback := @CategoryTheory.Over.pullback _ _ _ _ p (hasPullbacksAlong_of_hasPullbacks hp) + {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 hp +abbrev partialRightAdjoint := Over.pullback R ⊤ i ⋙ pushforward R p /-- The left adjoint in the partial adjunction. -/ -abbrev leftAdjoint := pullback hp ⋙ CategoryTheory.Over.map i +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` @@ -115,46 +68,46 @@ abbrev leftAdjoint := pullback hp ⋙ CategoryTheory.Over.map i 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 hp).obj Y).toComma) ≃ - ((leftAdjoint i hp).obj X ⟶ Y.toComma) := - calc (X ⟶ ((R.pushforward hp).obj ((Over.pullback R ⊤ i).obj Y)).toComma) - _ ≃ ((pullback hp).obj X ⟶ ((Over.pullback R ⊤ i).obj Y).toComma) := + (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 - ((pullback hp).obj X) ⟶ Y.toComma) := + ((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 hp).obj Y).toComma) (g : X ⟶ X') : - homEquiv i hp (g ≫ f) = - (leftAdjoint i hp).map g ≫ homEquiv i hp f := by + (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 hp).obj Y).toComma) (g : Y ⟶ Y') : - homEquiv i hp (f ≫ Comma.Hom.hom ((partialRightAdjoint i hp).map g)) = - homEquiv i hp f ≫ Comma.Hom.hom g := by + (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 hp).obj X ⟶ Y.toComma) (g : Y ⟶ Y') : - (homEquiv i hp).symm f ≫ Comma.Hom.hom ((partialRightAdjoint i hp).map g) = - (homEquiv i hp).symm (f ≫ Comma.Hom.hom g) := by + (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 homEquiv_comp_symm {X X' : Over B} {Y : R.Over ⊤ I} - (f : (leftAdjoint i hp).obj X' ⟶ Y.toComma) (g : X ⟶ X') : - g ≫ (homEquiv i hp).symm f = - (homEquiv i hp).symm ((leftAdjoint i hp).map g ≫ f) := by + (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.homEquiv_comp_symm] @@ -165,10 +118,10 @@ 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 hp ⋙ Over.forget R ⊤ B ⋙ leftAdjoint i hp ⟶ Over.forget R ⊤ I where - app _ := homEquiv i hp (𝟙 _) + 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 hp).symm.injective + apply (homEquiv i p).symm.injective conv => left; erw [← homEquiv_comp_symm] conv => right; erw [← homEquiv_symm_comp] simp @@ -199,15 +152,17 @@ R.Over ⊤ I ----> R.Over ⊤ E ----> R.Over ⊤ B pullback i pushforward p ``` -/ -def partialRightAdjointMap {E' : T} (i' : E' ⟶ I) {p' : E' ⟶ B} (hp' : Q 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' hp' ⟶ partialRightAdjoint i hp := + 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) := ((Over.pullbackComp ρ i').symm ≪≫ eqToIso (by simp [hi, Functor.id_comp])).hom - let cellRight := pushforwardPullbackTwoSquare (R := R) (Q := Q) ρ (𝟙 _) (by simp [← hρ]) hp hp' - Functor.whiskerLeft (partialRightAdjoint i' hp') (Over.pullbackId R ⊤ B).inv ≫ + let cellRight := pushforwardPullbackTwoSquare (R := R) ρ p p' (𝟙 _) (by simp [← hρ]) + Functor.whiskerLeft (partialRightAdjoint i' p') (Over.pullbackId R ⊤ B).inv ≫ cellLeft.hComp cellRight end PolynomialPartialAdjunction @@ -315,17 +270,16 @@ This will typically be used with the following instances 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) (H : MorphismProperty C) (I O E B : C) where +structure MvPoly (R : MorphismProperty C) (I O E B : C) where (i : E ⟶ I) (hi : R i) (p : E ⟶ B) - (hp : H p) (o : B ⟶ O) (ho : R o) namespace MvPoly -variable {R : MorphismProperty C} {H : MorphismProperty C} +variable {R : MorphismProperty C} instance {B O : C} {i : B ⟶ O} (hi : R i) [R.HasPullbacks] [R.IsStableUnderBaseChange] [R.IsStableUnderComposition] : (pullback R ⊤ i).IsRightAdjoint := @@ -335,16 +289,16 @@ instance {B O : C} {i : B ⟶ O} (hi : R i) [R.HasPullbacks] [R.IsStableUnderBas -- Limits.PreservesLimitsOfShape WalkingCospan (MorphismProperty.Over.map ⊤ hf) := -- sorry -variable {I O E B : C} (P : MvPoly R H I O E B) [R.HasPullbacks] [R.IsStableUnderBaseChange] - [H.HasPullbacks] [R.HasPushforwards H] [R.IsStableUnderPushforward H] +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 (P : MvPoly R H I O E B) (X : R.Over ⊤ I) : R.Over ⊤ B := - (partialRightAdjoint P.i P.hp).obj X +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`, @@ -370,17 +324,17 @@ to `X^ (E b)`. O ``` -/ -def sndProj (P : MvPoly R H I O E B) (X : R.Over ⊤ I) : - (leftAdjoint P.i P.hp).obj (fstProj P X).toComma ⟶ X.toComma := - (counit P.i P.hp).app X +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 (P : MvPoly R H I O E B) {X Y : R.Over ⊤ I} (f : X ⟶ Y) +variable {X Y : R.Over ⊤ I} (f : X ⟶ Y) @[reassoc (attr := simp)] lemma map_fstProj : - ((partialRightAdjoint P.i P.hp).map f).left ≫ (fstProj P Y).hom = (fstProj P X).hom := by + ((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 @@ -388,9 +342,9 @@ lemma sndProj_comp_hom : (sndProj P X).left ≫ X.hom = pullback.snd _ _ ≫ P.i lemma sndProj_comp : (sndProj P X).left ≫ f.left = pullback.map _ _ _ _ - ((partialRightAdjoint P.i P.hp).map f).left (𝟙 _) (𝟙 _) (by simp) (by simp) ≫ + ((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.hp).naturality f + have := congr_arg CommaMorphism.left <| (counit P.i P.p).naturality f simpa [pullback.map] using this.symm end @@ -414,44 +368,44 @@ gives rise to a functor ``` -/ def functor : R.Over ⊤ I ⥤ R.Over ⊤ O := - pullback R ⊤ P.i ⋙ MorphismProperty.pushforward R P.hp ⋙ map ⊤ P.ho + pullback R ⊤ P.i ⋙ MorphismProperty.pushforward R P.p ⋙ map ⊤ P.ho /-- The action of a univariate polynomial on objects. -/ -def apply (P : MvPoly R H I O E B) : R.Over ⊤ I → R.Over ⊤ O := (functor P).obj +def apply : R.Over ⊤ I → R.Over ⊤ O := (functor P).obj @[inherit_doc] infix:90 " @ " => apply namespace Equiv -variable {P : MvPoly R H I O E B} {Γ : Over O} {X : R.Over ⊤ I} +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.hp).obj (fst pair) +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.hp (Over.homMk (pair.left)) + homEquiv P.i P.p (Over.homMk (pair.left)) lemma snd_eq (pair : Γ ⟶ (P @ X).toComma) : snd pair = - (leftAdjoint P.i P.hp).map (Over.homMk (pair.left)) ≫ sndProj P X := by + (leftAdjoint P.i P.p).map (Over.homMk (pair.left)) ≫ sndProj P X := by erw [Equiv.apply_eq_iff_eq_symm_apply, ← homEquiv_comp_symm] simp [sndProj, counit] def mk (f : Over B) (hf : Γ = (Over.map P.o).obj f) - (s : (leftAdjoint P.i P.hp).obj f ⟶ X.toComma) : + (s : (leftAdjoint P.i P.p).obj f ⟶ X.toComma) : Γ ⟶ (P @ X).toComma := - eqToHom hf ≫ (Over.map P.o).map ((homEquiv P.i P.hp).symm s) + 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.hp).obj f ⟶ X.toComma) : fst (mk f hf s) = f := by - subst hf; simp [fst, mk]; rfl + (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.hp).obj f ⟶ X.toComma) : snd (mk f hf s) = + (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.hp).map (eqToHom (fst_mk f hf s)) ≫ s := by + _ = (leftAdjoint P.i P.p).map (eqToHom (fst_mk f hf s)) ≫ s := by erw [Equiv.apply_eq_iff_eq_symm_apply, ← homEquiv_comp_symm] ext simp [mk] @@ -518,18 +472,21 @@ 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 H I O E B) (Q : MvPoly R H I O F B) (ρ : E ⟶ F) - (hi : P.i = ρ ≫ Q.i) (hp : P.p = ρ ≫ Q.p) (ho : P.o = Q.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.hp Q.i Q.hp ρ hi hp) ◫ + ((PolynomialPartialAdjunction.partialRightAdjointMap P.i P.p Q.i Q.p ρ hi hp) ◫ (eqToHom (by rw! [ho]))) ≫ (Functor.associator _ _ _).hom section -variable {F} (Q : MvPoly R H I O F B) (ρ : E ⟶ F) (hi : P.i = ρ ≫ Q.i) - (hp : P.p = ρ ≫ Q.p) (ho : P.o = Q.o) +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) lemma fst_verticalNatTrans_app {Γ} {X} (pair : Γ ⟶ (Q @ X).toComma) : Equiv.fst (pair ≫ ((verticalNatTrans P Q ρ hi hp ho).app X).hom) = Equiv.fst pair := by @@ -580,18 +537,20 @@ 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 H I O E B) (P' : MvPoly R H I O E' B') +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 - have : IsIso (pushforwardPullbackTwoSquare (R := R) φ δ pb.w P.hp P'.hp) := - pushforwardPullbackTwoSquare_isIso R φ δ pb.w P.hp P'.hp pb + have : IsIso (pushforwardPullbackTwoSquare (R := R) φ P.p P'.p δ pb.w) := + pushforwardPullbackTwoSquare_isIso R φ P.p P'.p δ pb.w pb let cellMid : TwoSquare (MorphismProperty.Over.pullback R ⊤ φ) - (R.pushforward P'.hp) (R.pushforward P.hp) (MorphismProperty.Over.pullback R ⊤ δ) := - CategoryTheory.inv (pushforwardPullbackTwoSquare φ δ pb.w P.hp P'.hp) + (R.pushforward P'.p) (R.pushforward P.p) (MorphismProperty.Over.pullback R ⊤ δ) := + CategoryTheory.inv (pushforwardPullbackTwoSquare φ P.p P'.p δ pb.w) 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δ])) ≫ @@ -705,10 +664,9 @@ variable [ChosenTerminal C] open ChosenTerminal -variable [R.IsStableUnderComposition] [R.HasPullbacks] [R.IsStableUnderBaseChange] [R.HasObjects] - [R.IsStableUnderPushforward R] [R.HasPushforwards R] - --- abbrev morphismProperty' (P : UvPoly R E B) : E ⟶(R) B := ⟨ P.p, P.morphismProperty ⟩ +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 @@ -719,9 +677,6 @@ instance (P : UvPoly R E B) {Γ : C} (A : Γ ⟶ B) : HasPullback P.p A := lemma isTerminal_from (X : C) : R (isTerminal.from X) := HasObjects.obj_mem _ ChosenTerminal.isTerminal --- def object (X : C) : X ⟶(R) (𝟭_ C) := --- ⟨ isTerminal.from X, HasObjects.obj_mem _ ChosenTerminal.isTerminal⟩ - @[simp] abbrev toOverTerminal : C ⥤ R.Over ⊤ (𝟭_ C) := (equivalenceOfHasObjects R isTerminal).inverse @@ -731,21 +686,29 @@ abbrev fromOverTerminal : R.Over ⊤ (𝟭_ C) ⥤ C := (equivalenceOfHasObjects R isTerminal).functor @[simps] -def mvPoly (P : UvPoly R E B) : MvPoly R R (𝟭_ C) (𝟭_ C) E B where +def mvPoly : MvPoly R (𝟭_ C) (𝟭_ C) E B where i := isTerminal.from _ hi := isTerminal_from _ p := P.p - hp := P.morphismProperty o := isTerminal.from _ ho := isTerminal_from _ -def functor (P : UvPoly R E B) : C ⥤ C := +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] (P : UvPoly R E B) : C → C := P.functor.obj +def apply [ChosenTerminal C] : C → C := P.functor.obj @[inherit_doc] infix:90 " @ " => apply @@ -769,21 +732,20 @@ def vcomp [R.IsStableUnderComposition] {A B C} (P : UvPoly R A B) (Q : UvPoly R variable {B} /-- The fstProjection morphism from `∑ b : B, X ^ (E b)` to `B` again. -/ -def fstProj (P : UvPoly R E B) (X : C) : P @ X ⟶ B := +def fstProj (X : C) : P @ X ⟶ B := (P.mvPoly.fstProj (toOverTerminal.obj X)).hom @[reassoc (attr := simp)] -lemma map_fstProj (P : UvPoly R E B) {X Y : C} (f : X ⟶ Y) : +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 (P : UvPoly R E B) (X : C) : +def sndProj (X : C) : Limits.pullback (fstProj P X) P.p ⟶ X := (P.mvPoly.sndProj (toOverTerminal.obj X)).left -lemma sndProj_comp (P : UvPoly R E B) {X Y : C} (f : X ⟶ Y) : - sndProj P X ≫ f = +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) @@ -814,7 +776,8 @@ C --- ≅ ---> R.Over ⊤ 1 ----> R.Over ⊤ 1 --- ≅ ---> C P.mvPoly.functor ``` -/ -def verticalNatTrans {F : C} (P : UvPoly R E B) (Q : UvPoly R F B) (ρ : E ⟶ F) +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 ..) @@ -844,7 +807,8 @@ C --- > R.Over E -----> R.Over B -----> C P.p ``` -/ -def cartesianNatTrans {E' B' : C} (P : UvPoly R E B) (P' : UvPoly R E' B') +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 ..) @@ -854,7 +818,8 @@ def cartesianNatTrans {E' B' : C} (P : UvPoly R E B) (P' : UvPoly R E' B') -- `C` and `Over.terminal` and `R.Over terminal`, since `R` has objects. open NatTrans in -theorem isCartesian_cartesianNatTrans {D F : C} (P : UvPoly R E B) (Q : UvPoly R F D) +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 sorry @@ -896,7 +861,8 @@ end Hom /-- The domain of the composition of two polynomial signatures. See `UvPoly.comp`. -/ -def compDom {E B E' B' : C} (P : UvPoly R E B) (P' : UvPoly R E' B') : C := +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 /-- @@ -918,7 +884,8 @@ p' | (pb) | P @ B' -----> B fstProj -/ -def comp {E B E' B' : C} (P : UvPoly R E B) (P' : UvPoly R E' B') : +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 _ _ @@ -927,7 +894,7 @@ def comp {E B E' B' : C} (P : UvPoly R E B) (P' : UvPoly R E' B') : namespace Equiv -variable {P : UvPoly R E B} {Γ X Y : C} +variable {P} {Γ X Y : C} /-- Convert the morphism `pair` into a morphism in the over category `Over (𝟭_ C)` -/ @[simp] @@ -973,7 +940,7 @@ theorem snd_eq_snd' (pair : Γ ⟶ P @ X) : snd pair = snd' pair (.of_hasPullbac /-- 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.hp).obj (Over.mk b) ⟶ + (PolynomialPartialAdjunction.leftAdjoint P.mvPoly.i P.mvPoly.p).obj (Over.mk b) ⟶ ((toOverTerminal (R := R)).obj X).toComma := Over.homMk x (isTerminal.hom_ext ..) @@ -1145,6 +1112,7 @@ theorem mk_comp_left {Δ} (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) (σ: Δ ⟶ 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) : @@ -1164,7 +1132,8 @@ end Equiv namespace compDomEquiv -variable {Γ E B E' B' : C} {P : UvPoly R E B} {P' : UvPoly R E' B'} +variable {Γ E' B' : C} {P} {P' : UvPoly R E' B'} + [R.IsStableUnderPushforwardsAlong P'.p] [R.HasPushforwardsAlong P'.p] /- ``` @@ -1342,7 +1311,9 @@ end compDomEquiv section -variable {E B F : C} (P : UvPoly R E B) (Q : UvPoly R F B) (ρ : E ⟶ F) (h : P.p = ρ ≫ Q.p) +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 @@ -1353,7 +1324,7 @@ 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] at H' + rw [← fst_verticalNatTrans_app P Q] at H' exact H') = (H.lift f' (g' ≫ ρ) (by simp [H'.w, h])) ≫ Equiv.snd' pair H := diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index ba47f111..c24a4cad 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -74,7 +74,13 @@ 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.IsStableUnderPushforward R] + [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 @@ -118,7 +124,7 @@ lemma fst_mk (A : Γ ⟶ M.Ty) (B : M.ext A ⟶ X) : 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'] + rw! [UvPoly.Equiv.snd'_mk' (P := M.uvPolyTp)] section variable {Δ : Ctx} {σ : Δ ⟶ Γ} {AB : Γ ⟶ M.Ptp.obj X} @@ -133,7 +139,7 @@ theorem fst_comp_right {Y} (σ : X ⟶ Y) : fst M (AB ≫ M.Ptp.map σ) = fst M 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] + 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σ]) = @@ -326,8 +332,8 @@ theorem comp_mk (α : Γ ⟶ M.Tm) {A} (e1 : α ≫ M.tp = A) (B : (M.ext A) ⟶ ((M.substWk σ A _ e3) ≫ B) (σ ≫ β) (by simp [e2]; rw [← Category.assoc, comp_sec]; simp; congr!) := by dsimp only [mk] - rw [UvPoly.compDomEquiv.comp_mk σ _ α e1 (M.disp _) (M.var _) (M.disp_pullback _).flip - (M.disp _) (M.var _) (M.disp_pullback _).flip ] + 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] @@ -336,7 +342,7 @@ theorem comp_mk (α : Γ ⟶ M.Tm) {A} (e1 : α ≫ M.tp = A) (B : (M.ext A) ⟶ 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] + 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) : @@ -1187,9 +1193,30 @@ This is the signature for a polynomial functor `iUvPoly` on the presheaf categor abbrev iUvPoly : UvPoly R ie.i M.Tm := ie.i2UvPoly.vcomp ii.k2UvPoly +lemma iUvPoly_morphismProperty : R (ie.i2 ≫ ii.k2) := by + apply R.comp_mem + · exact R.of_isPullback ie.i_isPullback M.morphismProperty + · exact R.of_isPullback ii.isKernelPair 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` -/ abbrev iFunctor : Ctx ⥤ Ctx := ie.iUvPoly.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 + /-- 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)` From ead58b17720da75e76a2fb554561d742ab825881 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Fri, 14 Nov 2025 13:00:32 -0500 Subject: [PATCH 28/95] issue in line 62 --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 55 ++++++++++++++++++-- 1 file changed, 52 insertions(+), 3 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index 61b8bb94..b6a5c1ec 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -46,11 +46,60 @@ variable (R : MorphismProperty C) def Local (X : C) : MorphismProperty (R.Over ⊤ X) := fun _ _ f => R f.left -instance (X : C) [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] : - (Local R X).IsStableUnderBaseChange := sorry + + +#check Functor.map_isPullback + + instance (X : C) [R.IsStableUnderComposition] [R.HasPullbacks] [R.IsStableUnderBaseChange] : - (Local R X).HasPullbacks := sorry + (Local R X).HasPullbacks where + hasPullback {U V W} f g Rf := by + have e: HasPullback f.left g.left := + MorphismProperty.HasPullbacks.hasPullback (g.left) (f:= f.left) Rf + let pbinC := IsPullback.of_hasPullback f.left g.left + let P : R.Over ⊤ X := .mk ⊤ ((pullback.snd f.left g.left) ≫ V.hom) + (by apply R.comp_mem + sorry) + apply IsPullback.hasPullback + sorry + -- let F := CostructuredArrow.proj (Functor.id C) X + -- have p00: PreservesLimit (cospan f g) (Over.forget R ⊤ X) := sorry + -- have p0 : PreservesLimit (cospan f g ⋙ Over.forget R ⊤ X) + -- (CostructuredArrow.proj (𝟭 C) X) := sorry + + -- have p1 : @PreservesLimit + -- (R.Over ⊤ X) _ C _ WalkingCospan _ (cospan f g) + -- (Over.forget R ⊤ X ⋙ (CostructuredArrow.proj (Functor.id C) X)) := by + -- apply CategoryTheory.Limits.comp_preservesLimit + + -- have p: IsPullback fst.left snd.left f.left g.left := by + -- apply Functor.map_isPullback + -- (Over.forget R ⊤ X ⋙ CostructuredArrow.proj (Functor.id C) X) i + -- simp[Local] at * + -- apply R.of_isPullback p rf + +instance (X : C) [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] : + (Local R X).IsStableUnderBaseChange where + of_isPullback {W V P K} g f fst snd i rf := by + let F := CostructuredArrow.proj (Functor.id C) X + have p00: PreservesLimit (cospan f g) (Over.forget R ⊤ X) := sorry + have p0 : PreservesLimit (cospan f g ⋙ Over.forget R ⊤ X) + (CostructuredArrow.proj (𝟭 C) X) := sorry + + have p1 : @PreservesLimit + (R.Over ⊤ X) _ C _ WalkingCospan _ (cospan f g) + (Over.forget R ⊤ X ⋙ (CostructuredArrow.proj (Functor.id C) X)) := by + apply CategoryTheory.Limits.comp_preservesLimit + + have p: IsPullback fst.left snd.left f.left g.left := by + apply Functor.map_isPullback + (Over.forget R ⊤ X ⋙ CostructuredArrow.proj (Functor.id C) X) i + simp[Local] at * + apply R.of_isPullback p rf + +instance (X : C) [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] : + (Local R X).IsStableUnderBaseChange := sorry instance (X : C) : (Local R X).HasObjects := sorry From d2c6a29ef1126394b5d3628760e3a9d4d62e2b89 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 14 Nov 2025 15:25:07 -0500 Subject: [PATCH 29/95] feat: instance : (Local R X).HasPullbacks --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 88 ++++++++++++-------- 1 file changed, 54 insertions(+), 34 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index b6a5c1ec..ae8020a6 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -44,25 +44,56 @@ namespace MorphismProperty variable (R : MorphismProperty C) +@[simp] def Local (X : C) : MorphismProperty (R.Over ⊤ X) := fun _ _ f => R f.left +section pullback + +variable {R} [R.HasPullbacks] {X : C} + +lemma Local.hasPullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : + HasPullback f.left g.left := + MorphismProperty.HasPullbacks.hasPullback (g.left) (f:= f.left) rf + +variable [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] + +def Local.pullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : R.Over ⊤ X := + have := Local.hasPullback g rf + .mk ⊤ ((pullback.snd f.left g.left) ≫ V.hom) + (R.comp_mem _ _ (R.of_isPullback (IsPullback.of_hasPullback f.left g.left) rf) V.prop) + +def Local.pullback.fst {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : + Local.pullback g rf ⟶ U := + have := Local.hasPullback g rf + Over.homMk (Limits.pullback.fst f.left g.left) (by + simp only [pullback, ← Over.w f, Limits.pullback.condition_assoc] + simp) + +def Local.pullback.snd {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : + Local.pullback g rf ⟶ V := + have := Local.hasPullback g rf + Over.homMk (Limits.pullback.snd f.left g.left) + +theorem Local.pullback.isPullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : + IsPullback (Local.pullback.fst g rf) (Local.pullback.snd g rf) f g := by + have := Local.hasPullback g rf + have : (CostructuredArrow.proj (𝟭 C) X).Faithful := CostructuredArrow.proj_faithful -- why? + have : ReflectsLimitsOfShape WalkingCospan (CostructuredArrow.proj (𝟭 C) X) := inferInstance -- why? + apply Functor.reflect_isPullback (Over.forget R ⊤ X ⋙ CostructuredArrow.proj (Functor.id C) X) + simpa [fst, snd, Comma.Hom.hom_left] using IsPullback.of_hasPullback f.left g.left + +variable (X) + +instance : (Local R X).HasPullbacks where + hasPullback {U V W} f g rf := by + have := Local.hasPullback g rf + let pbinC := IsPullback.of_hasPullback f.left g.left + -- let P : R.Over ⊤ X := .mk ⊤ ((pullback.snd f.left g.left) ≫ V.hom) + -- (by apply R.comp_mem + -- sorry) + -- apply IsPullback.hasPullback + sorry - -#check Functor.map_isPullback - - - -instance (X : C) [R.IsStableUnderComposition] [R.HasPullbacks] [R.IsStableUnderBaseChange] : - (Local R X).HasPullbacks where - hasPullback {U V W} f g Rf := by - have e: HasPullback f.left g.left := - MorphismProperty.HasPullbacks.hasPullback (g.left) (f:= f.left) Rf - let pbinC := IsPullback.of_hasPullback f.left g.left - let P : R.Over ⊤ X := .mk ⊤ ((pullback.snd f.left g.left) ≫ V.hom) - (by apply R.comp_mem - sorry) - apply IsPullback.hasPullback - sorry -- let F := CostructuredArrow.proj (Functor.id C) X -- have p00: PreservesLimit (cospan f g) (Over.forget R ⊤ X) := sorry -- have p0 : PreservesLimit (cospan f g ⋙ Over.forget R ⊤ X) @@ -79,24 +110,13 @@ instance (X : C) [R.IsStableUnderComposition] [R.HasPullbacks] [R.IsStableUnderB -- simp[Local] at * -- apply R.of_isPullback p rf -instance (X : C) [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] : - (Local R X).IsStableUnderBaseChange where - of_isPullback {W V P K} g f fst snd i rf := by - let F := CostructuredArrow.proj (Functor.id C) X - have p00: PreservesLimit (cospan f g) (Over.forget R ⊤ X) := sorry - have p0 : PreservesLimit (cospan f g ⋙ Over.forget R ⊤ X) - (CostructuredArrow.proj (𝟭 C) X) := sorry - - have p1 : @PreservesLimit - (R.Over ⊤ X) _ C _ WalkingCospan _ (cospan f g) - (Over.forget R ⊤ X ⋙ (CostructuredArrow.proj (Functor.id C) X)) := by - apply CategoryTheory.Limits.comp_preservesLimit - - have p: IsPullback fst.left snd.left f.left g.left := by - apply Functor.map_isPullback - (Over.forget R ⊤ X ⋙ CostructuredArrow.proj (Functor.id C) X) i - simp[Local] at * - apply R.of_isPullback p rf +instance : (Local R X).IsStableUnderBaseChange where + of_isPullback {W V P K} g f fst snd i rf := by + have := Local.hasPullback g rf + rw [← IsPullback.isoIsPullback_hom_snd _ _ i (Local.pullback.isPullback g rf), Local] + exact RespectsIso.precomp _ _ _ (R.of_isPullback (IsPullback.of_hasPullback f.left g.left) rf) + +end pullback instance (X : C) [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] : (Local R X).IsStableUnderBaseChange := sorry From 9df666c9a173a79daf3f06cc9140928eaa3a0e7f Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 14 Nov 2025 20:28:03 -0500 Subject: [PATCH 30/95] feat: pullbackMapTwoSquare_isIso --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 96 +++++++++++++++---- .../MorphismProperty/OverAdjunction.lean | 82 ++++++++++------ 2 files changed, 129 insertions(+), 49 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index ae8020a6..47bd8507 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -7,7 +7,7 @@ import Mathlib.CategoryTheory.Limits.Constructions.Over.Basic import HoTTLean.ForMathlib import HoTTLean.ForMathlib.CategoryTheory.NatTrans import Mathlib.Tactic.DepRewrite -import Poly.ForMathlib.CategoryTheory.NatTrans +import Poly.ForMathlib.CategoryTheory.LocallyCartesianClosed.BeckChevalley import HoTTLean.ForMathlib.CategoryTheory.Yoneda import Poly.ForMathlib.CategoryTheory.LocallyCartesianClosed.Presheaf @@ -188,6 +188,36 @@ notation:max R"^("F")" => Local (ExtendedFibration R) F namespace ExtendedFibration +variable [R.HasPullbacks] [R.IsStableUnderBaseChange] + +def yonedaRepresentableFibrantChosenPullbacks (X Y : C) (f : X ⟶ Y) (rf : R f) : + R.RepresentableFibrantChosenPullbacks (CategoryTheory.yoneda.map f) := + have h {Γ} (A : Γ ⟶ Y) : HasPullback f A := HasPullbacks.hasPullback _ rf + { ext A := pullback f (yoneda.preimage A) + disp A := pullback.snd _ _ + var _ := ym(pullback.fst _ _) + disp_pullback := sorry + fibrant A := IsStableUnderBaseChange.of_isPullback (IsPullback.of_hasPullback _ _) rf } + +/-- This is the functor `R(X) -> R^(X)`. -/ +@[simps] +protected def yoneda (X : C) : R.Over ⊤ X ⥤ (ExtendedFibration R).Over ⊤ y(X) where + obj A := .mk ⊤ ym(A.hom) ⟨yonedaRepresentableFibrantChosenPullbacks R _ _ _ A.prop⟩ + map {A B} f := Over.homMk ym(f.left) + map_id := sorry + map_comp := sorry + +instance (X : C) : (ExtendedFibration.yoneda R X).Full where + map_surjective {A B} f := + ⟨Over.homMk (yoneda.preimage f.left) (by apply yoneda.map_injective; simp; exact Over.w f), + by cat_disch⟩ + +instance (X : C) : (ExtendedFibration.yoneda R X).Faithful where + map_injective {A B} f f' hf := by + ext + apply yoneda.map_injective + exact Functor.congr_map (Over.forget _ _ _ ⋙ CategoryTheory.Over.forget _) hf + variable (F : Psh C) example [R.IsStableUnderComposition] : (R^(F)).HasPullbacks := inferInstance @@ -196,6 +226,8 @@ example : (R^(F)).HasObjects := inferInstance example [R.ContainsIdentities] : (R^(F)).ContainsIdentities := inferInstance example [R.IsStableUnderComposition] : (R^(F)).IsStableUnderComposition := inferInstance +example (X : C) : (ExtendedFibration.yoneda R X).ReflectsIsomorphisms := inferInstance + end ExtendedFibration instance : (⊤ : MorphismProperty C).HasOfPostcompProperty ⊤ where @@ -238,20 +270,37 @@ pullback f ↗ pullback g ``` -/ def pullbackMapTwoSquare {T : Type u} [Category.{v} T] (R : MorphismProperty T) - [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) + [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 : f ≫ k = h ≫ g) : + (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 R ⊤ k rk trivial) - (MorphismProperty.Over.mapPullbackAdj R ⊤ h rh trivial)).symm <| + (mateEquiv (MorphismProperty.Over.mapPullbackAdj k rk trivial) + (MorphismProperty.Over.mapPullbackAdj h rh trivial)).symm <| (MorphismProperty.Over.pullbackComp _ _).inv ≫ - eqToHom (by rw! [sq]) ≫ + (Over.pullbackCongr sq).inv ≫ (MorphismProperty.Over.pullbackComp _ _).hom +@[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) + [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) (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] + /-- The Beck-Chevalley two-square `pushforwardPullbackTwoSquare` is a natural isomorphism ``` @@ -274,19 +323,28 @@ condition is strengthened to a pullback condition. | | X - h → Z ``` -TODO: in what generality does this theorem hold? -NOTE: we know it holds when `R` is a 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 = ⊤`. -/ theorem pullbackMapTwoSquare_isIso {T : Type u} [Category.{v} T] (R : MorphismProperty T) - [R.IsStableUnderBaseChange] [R.IsStableUnderComposition] + [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) - [R.HasPullbacksAlong h] [R.HasPullbacksAlong f] [R.HasPullbacksAlong g] [R.HasPullbacksAlong k] - (pb : IsPullback f h k g) : - NatTrans.IsCartesian <| pullbackMapTwoSquare R h f g k rk rh pb.w := - sorry + (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 + (ExtendedFibration.yoneda R Z) + apply (config := {allowSynthFailures:= true}) + Functor.ReflectsIsomorphisms.reflects (Over.forget _ _ _) + apply (config := {allowSynthFailures:= true}) + Functor.ReflectsIsomorphisms.reflects (CategoryTheory.Over.forget _) + apply (config := {allowSynthFailures:= true}) yoneda.map_isIso + simp [Functor.comp_obj, Over.map_obj_left, Over.pullback_obj_left, Functor.id_obj, + Over.map_obj_hom, pullbackMapTwoSquare_app_left, Functor.const_obj_obj] + apply CategoryTheory.IsPullback.pullback.map_isIso_of_pullback_right_of_comm_cube + · cat_disch + · assumption /-- Fixing a commutative square, ``` @@ -320,7 +378,7 @@ def pushforwardPullbackTwoSquare {T : Type u} [Category.{v} T] {R : MorphismProp let pullbackTwoSquare : TwoSquare (Over.pullback R ⊤ k) (Over.pullback R ⊤ g) (Over.pullback R ⊤ f) (Over.pullback R ⊤ h) := (Over.pullbackComp _ _).inv ≫ - eqToHom (by rw! [sq]) ≫ + (Over.pullbackCongr sq).inv ≫ (Over.pullbackComp _ _).hom mateEquiv (pullbackPushforwardAdjunction R g) (pullbackPushforwardAdjunction R f) diff --git a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean index e67f7aa0..f3bead6c 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean @@ -123,51 +123,73 @@ lemma Over.pullbackComp_left_fst_fst (A : P.Over Q Z) : 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 := - NatIso.ofComponents (fun X ↦ eqToIso (by simp [h])) - -@[reassoc (attr := simp)] -lemma Over.pullbackCongr_hom_app_left_fst {g : X ⟶ Y} - (h : f = g) (A : P.Over Q Y) : - have : P.HasPullbacksAlong g := by subst h; infer_instance - have : P.IsStableUnderBaseChangeAlong g := by subst h; infer_instance - ((Over.pullbackCongr h).hom.app A).left ≫ pullback.fst A.hom g = pullback.fst A.hom f := by - subst h - simp [pullbackCongr] + have : P.HasPullbacksAlong g := by subst h; infer_instance + NatIso.ofComponents (fun _ ↦ Over.isoMk (pullback.congrHom rfl h)) end Pullback section Adjunction -variable [P.IsStableUnderComposition] [P.IsStableUnderBaseChange] - [Q.IsMultiplicative] [Q.IsStableUnderBaseChange] +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 := fun A B ↦ - { toFun := fun 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 := fun 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 := fun h ↦ by - ext - dsimp - ext - · simp - · simpa using h.w.symm } } + { 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 From f4f5ea859c9472c242645ebf4670d3de7e33d64a Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sat, 15 Nov 2025 17:44:04 -0500 Subject: [PATCH 31/95] two attempts at pushforward BC --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 166 +++++++++++++++--- .../MorphismProperty/OverAdjunction.lean | 143 ++++++++++----- 2 files changed, 241 insertions(+), 68 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index 47bd8507..f6ed1b09 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -40,6 +40,15 @@ structure RepresentableChosenPullbacks {X Y : Psh C} (f : X ⟶ Y) where 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) @@ -246,6 +255,28 @@ noncomputable def Over.pullbackId (P Q : MorphismProperty C) (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 @@ -281,18 +312,16 @@ def pullbackMapTwoSquare {T : Type u} [Category.{v} T] (R : MorphismProperty T) (MorphismProperty.Over.pullback R ⊤ g) := (mateEquiv (MorphismProperty.Over.mapPullbackAdj k rk trivial) (MorphismProperty.Over.mapPullbackAdj h rh trivial)).symm <| - (MorphismProperty.Over.pullbackComp _ _).inv ≫ - (Over.pullbackCongr sq).inv ≫ - (MorphismProperty.Over.pullbackComp _ _).hom + 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) + (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] - (sq : h ≫ g = f ≫ k) (A : R.Over ⊤ Y) : + (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 = @@ -334,14 +363,10 @@ theorem pullbackMapTwoSquare_isIso {T : Type u} [Category.{v} T] (R : MorphismPr have : HasPullback (A.hom ≫ k) g := HasPullbacksAlong.hasPullback (A.hom ≫ k) (R.comp_mem _ _ A.prop rk) apply (config := {allowSynthFailures:= true}) Functor.ReflectsIsomorphisms.reflects - (ExtendedFibration.yoneda R Z) - apply (config := {allowSynthFailures:= true}) - Functor.ReflectsIsomorphisms.reflects (Over.forget _ _ _) - apply (config := {allowSynthFailures:= true}) - Functor.ReflectsIsomorphisms.reflects (CategoryTheory.Over.forget _) - apply (config := {allowSynthFailures:= true}) yoneda.map_isIso - simp [Functor.comp_obj, Over.map_obj_left, Over.pullback_obj_left, Functor.id_obj, - Over.map_obj_hom, pullbackMapTwoSquare_app_left, Functor.const_obj_obj] + (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 @@ -375,14 +400,60 @@ def pushforwardPullbackTwoSquare {T : Type u} [Category.{v} T] {R : MorphismProp [R.HasPushforwardsAlong g] [R.IsStableUnderPushforwardsAlong g] : TwoSquare (pushforward R g) (Over.pullback R ⊤ h) (Over.pullback R ⊤ k) (pushforward R f) := - let pullbackTwoSquare : 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 - mateEquiv (pullbackPushforwardAdjunction R g) - (pullbackPushforwardAdjunction R f) - pullbackTwoSquare + mateEquiv (pullbackPushforwardAdjunction R g) (pullbackPushforwardAdjunction R f) + (pullbackPullbackTwoSquare _ _ _ _ sq) + +-- lemma 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] (A : R.Over ⊤ Z) : +-- (pushforwardPullbackTwoSquare h f g k sq).app A = sorry := by +-- apply (Over.forget R ⊤ Y).map_injective +-- simp [pushforwardPullbackTwoSquare, ← Functor.map_comp] +-- rw [pushforward.homEquiv_symm_comp] +-- rw [Equiv.symm_apply_eq] +-- simp +-- erw [Category.id_comp] +-- ext +-- simp +-- ext +-- · simp +-- sorry +-- · sorry + +theorem pushforwardPullbackTwoSquare_isIso_extendedFibration {T : Type u} [Category.{max u v} T] + (R : MorphismProperty T) + [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y Z W : Psh T} (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) (sq : h ≫ g = f ≫ k) + [HasPullbacksAlong f] [HasPullbacksAlong g] + [(ExtendedFibration R).HasPushforwardsAlong f] -- TODO: should be automatic in Psh T + [(ExtendedFibration R).IsStableUnderPushforwardsAlong f] + -- TODO: should follow from [R.IsStableUnderPushforwardsAlong f] + [(ExtendedFibration R).HasPushforwardsAlong g] -- TODO: should be automatic in Psh T + [(ExtendedFibration R).IsStableUnderPushforwardsAlong g] + -- TODO: should follow from [R.IsStableUnderPushforwardsAlong g] + (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := ExtendedFibration R) h f g k pb.w) := by + have : IsIso (Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) + (Over.forget R.ExtendedFibration ⊤ Y)) := by + sorry + apply NatTrans.isIso_of_whiskerRight_isIso _ (Over.forget _ _ _) + -- apply (config := {allowSynthFailures:= true}) NatIso.isIso_of_isIso_app + -- intro A + -- apply (config := {allowSynthFailures:= true}) Functor.ReflectsIsomorphisms.reflects + -- (ExtendedFibration.yoneda R Y ⋙ Over.forget _ _ _) + -- -- apply (config := {allowSynthFailures:= true}) yoneda.map_isIso + -- -- simp + -- have pb : IsPullback ym(h) ym(f) ym(g) ym(k) := sorry + -- have l := CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq + -- have li := CategoryTheory.pushforwardPullbackTwoSquare_of_isPullback_isIso pb + -- have lii := NatIso.isIso_app_of_isIso + -- (CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq) + -- ((ExtendedFibration.yoneda R Z ⋙ Over.forget _ _ _).obj A) + -- have : IsIso l := inferInstanceAs $ IsIso $ CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq + -- sorry /-- The Beck-Chevalley two-square `pushforwardPullbackTwoSquare` is a natural isomorphism @@ -407,12 +478,61 @@ 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.{v} T] (R : MorphismProperty T) +theorem pushforwardPullbackTwoSquare_isIso {T : Type u} [Category.{max u 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] + (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by + let α : (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ ExtendedFibration.yoneda R Y ⟶ + (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y := sorry + -- TODO: define α as the following composition. All should be either x.hom for some iso x or + -- a morphism such that IsIso x + -- (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ ExtendedFibration.yoneda R Y + -- ≅ R.pushforward g ⋙ Over.pullback R ⊤ k ⋙ ExtendedFibration.yoneda R Y + -- ≅ R.pushforward g ⋙ ExtendedFibration.yoneda R W ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ (R.pushforward g ⋙ ExtendedFibration.yoneda R W) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ (ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g)) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- use `pushforwardPullbackTwoSquare_isIso_extendedFibration` here + -- ≅ ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h) ⋙ (ExtendedFibration R).pushforward f + -- ≅ (ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h)) ⋙ (ExtendedFibration R).pushforward f + -- ≅ (Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X) ⋙ (ExtendedFibration R).pushforward f + -- ≅ Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X ⋙ (ExtendedFibration R).pushforward f + -- ≅ Over.pullback R ⊤ h ⋙ R.pushforward f ⋙ ExtendedFibration.yoneda R Y + -- ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y + have : IsIso α := sorry -- should be automatic by infer_instance. Then remove. + have eq : Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) + (ExtendedFibration.yoneda R Y) = α := sorry + have : IsIso (Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) + (ExtendedFibration.yoneda R Y)) := by rw [eq]; infer_instance + apply NatTrans.isIso_of_whiskerRight_isIso _ (ExtendedFibration.yoneda R Y) + +/- +theorem pushforwardPullbackTwoSquare_isIso {T : Type u} [Category.{max u 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] (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := + IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by + apply (config := {allowSynthFailures:= true}) NatIso.isIso_of_isIso_app + intro A + apply (config := {allowSynthFailures:= true}) Functor.ReflectsIsomorphisms.reflects + (ExtendedFibration.yoneda R Y ⋙ Over.forget _ _ _) + -- apply (config := {allowSynthFailures:= true}) yoneda.map_isIso + -- simp + have pb : IsPullback ym(h) ym(f) ym(g) ym(k) := sorry + have l := CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq + have li := CategoryTheory.pushforwardPullbackTwoSquare_of_isPullback_isIso pb + have lii := NatIso.isIso_app_of_isIso + (CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq) + ((ExtendedFibration.yoneda R Z ⋙ Over.forget _ _ _).obj A) + -- have : IsIso l := inferInstanceAs $ IsIso $ CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq sorry +-/ diff --git a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean index f3bead6c..d25879d8 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean @@ -28,6 +28,14 @@ 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`, @@ -253,42 +261,42 @@ noncomputable def pushforward {S S' : T} (q : S ⟶ S') [HasPullbacksAlong q] section homEquiv -variable {P} {S S' : T} (q : S ⟶ S') [HasPullbacksAlong q] +variable {P} {S S' : T} {q : S ⟶ S'} [HasPullbacksAlong q] [P.HasPushforwardsAlong q] [P.IsStableUnderPushforwardsAlong q] --- @[simp] --- abbrev Over.pullback' := @CategoryTheory.Over.pullback _ _ _ _ q (hasPullbacksAlong_of_hasPullbacks hq) - /-- 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 ..) + ((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 q (g ≫ f) = - (CategoryTheory.Over.pullback q).map g ≫ homEquiv q f := + 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 q (f ≫ Comma.Hom.hom ((P.pushforward q).map g)) = - homEquiv q f ≫ Comma.Hom.hom g := + 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 q).symm f ≫ Comma.Hom.hom ((P.pushforward q).map g) = - (homEquiv q).symm (f ≫ Comma.Hom.hom g) := + 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 q).symm f = - (homEquiv q).symm ((CategoryTheory.Over.pullback q).map g ≫ f) := + g ≫ homEquiv.symm f = + homEquiv.symm ((CategoryTheory.Over.pullback q).map g ≫ f) := Functor.partialRightAdjointHomEquiv_comp_symm .. end homEquiv @@ -297,46 +305,91 @@ section open MorphismProperty.Over -variable [P.IsStableUnderBaseChange] {S S' : T} (f : S ⟶ S') +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 -/-- The `pullback ⊣ pushforward` adjunction. -/ -def pullbackPushforwardAdjunction : Over.pullback P ⊤ f ⊣ pushforward P f := - Adjunction.mkOfHomEquiv { - homEquiv X Y := - calc ((pullback P ⊤ f).obj X ⟶ Y) +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 f).symm - _ ≃ _ := Equiv.cast (by dsimp) -- why? + 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 - homEquiv_naturality_left_symm g f := by - simp only [Equiv.trans_def, Equiv.cast_refl, Equiv.trans_refl, - Equiv.symm_trans_apply, Equiv.symm_symm] - erw [Functor.FullyFaithful.homEquiv_apply, Functor.FullyFaithful.homEquiv_symm_apply, - Functor.FullyFaithful.homEquiv_apply, Functor.FullyFaithful.homEquiv_symm_apply, - Functor.map_comp, pushforward.homEquiv_comp] - apply Functor.FullyFaithful.map_injective - (Functor.FullyFaithful.ofFullyFaithful (Over.forget P ⊤ S)) - simp only [Functor.FullyFaithful.map_preimage, Functor.map_comp] - simp only [Comma.forget_obj, Comma.forget_map] - congr 1 - homEquiv_naturality_right f g := by - simp only [Comma.forget_obj, Equiv.trans_def, Equiv.cast_refl, Equiv.trans_refl, - Equiv.trans_apply] - erw [Functor.FullyFaithful.homEquiv_symm_apply, Functor.FullyFaithful.homEquiv_symm_apply, - Functor.FullyFaithful.homEquiv_apply, Functor.FullyFaithful.homEquiv_apply] - apply Functor.FullyFaithful.map_injective - (Functor.FullyFaithful.ofFullyFaithful (Over.forget P ⊤ S')) - simp only [Functor.FullyFaithful.map_preimage, Functor.map_comp] - erw [pushforward.homEquiv_symm_comp] - rfl - } + +@[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) From f5e3b9bc7cd148f99908f991a27e543e418f20d3 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sun, 16 Nov 2025 19:13:30 -0500 Subject: [PATCH 32/95] feat: pushforwardForgetTwoSquare --- .../Adjunction/PartialAdjoint.lean | 66 ++++++++++++++++++ HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 69 ++++++++++++++++++- .../Comma/Over/Pushforward.lean | 28 ++++---- .../MorphismProperty/OverAdjunction.lean | 15 +++- HoTTLean/ForPoly.lean | 7 +- 5 files changed, 163 insertions(+), 22 deletions(-) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Adjunction/PartialAdjoint.lean 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/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index f6ed1b09..9a2876e4 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -10,6 +10,7 @@ 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 universe w v u v₁ u₁ @@ -423,6 +424,49 @@ def pushforwardPullbackTwoSquare {T : Type u} [Category.{v} T] {R : MorphismProp -- sorry -- · sorry +def pullbackForgetTwoSquare {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks T] + [LocallyCartesianClosed T] {R : MorphismProperty T} {X Y : T} (f : X ⟶ Y) + [R.IsStableUnderBaseChangeAlong f] : + Over.pullback R ⊤ f ⋙ Over.forget R ⊤ X ≅ Over.forget R ⊤ Y ⋙ CategoryTheory.Over.pullback f := + sorry + +@[simps] +def _root_.CategoryTheory.ExponentiableMorphism.pullbackRepresentableByPushforward + {T : Type u} [Category.{v} T] [HasPullbacks T] + {X Y : T} (f : X ⟶ Y) [ExponentiableMorphism f] (h : Over X) : + ((CategoryTheory.Over.pullback f).op ⋙ y(h)).RepresentableBy + ((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.pullbackRepresentableByPushforward 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 + +/-- In a locally cartesian closed category, global pushforward (defined using the +`ExponentiableMorphism` API) commutes with local pushforward +(defined using the `HasPushforward` API). -/ +def pushforwardForgetTwoSquare {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks T] + [LocallyCartesianClosed T] {R : MorphismProperty T} {X Y : T} (f : X ⟶ Y) + [R.IsStableUnderPushforwardsAlong f] : + Over.forget R ⊤ X ⋙ ExponentiableMorphism.pushforward f ≅ + R.pushforward f ⋙ Over.forget R ⊤ Y := + calc Over.forget R ⊤ X ⋙ ExponentiableMorphism.pushforward f + _ ≅ pushforwardPartial.lift R f ⋙ ObjectProperty.ι _ ⋙ ExponentiableMorphism.pushforward f := + Iso.refl _ + _ ≅ _ := Functor.isoWhiskerLeft _ + (Functor.isoPartialRightAdjoint _ _ (Functor.rightAdjoint.partialRightAdjoint _)) + _ ≅ R.pushforward f ⋙ Over.forget R ⊤ Y := (pushforwardCompForget ..).symm + theorem pushforwardPullbackTwoSquare_isIso_extendedFibration {T : Type u} [Category.{max u v} T] (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] @@ -436,9 +480,30 @@ theorem pushforwardPullbackTwoSquare_isIso_extendedFibration {T : Type u} [Categ -- TODO: should follow from [R.IsStableUnderPushforwardsAlong g] (pb : IsPullback h f g k) : IsIso (pushforwardPullbackTwoSquare (R := ExtendedFibration R) h f g k pb.w) := by + let α : (R.ExtendedFibration.pushforward g ⋙ Over.pullback R.ExtendedFibration ⊤ k) ⋙ + Over.forget R.ExtendedFibration ⊤ Y ⟶ + (Over.pullback R.ExtendedFibration ⊤ h ⋙ R.ExtendedFibration.pushforward f) ⋙ + Over.forget R.ExtendedFibration ⊤ Y := sorry + -- TODO: define α as the following composition. All should be either x.hom for some iso x or + -- a morphism such that IsIso x + -- (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ ExtendedFibration.yoneda R Y + -- ≅ R.pushforward g ⋙ Over.pullback R ⊤ k ⋙ ExtendedFibration.yoneda R Y + -- ≅ R.pushforward g ⋙ ExtendedFibration.yoneda R W ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ (R.pushforward g ⋙ ExtendedFibration.yoneda R W) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ (ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g)) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- use `pushforwardPullbackTwoSquare_isIso_extendedFibration` here + -- ≅ ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h) ⋙ (ExtendedFibration R).pushforward f + -- ≅ (ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h)) ⋙ (ExtendedFibration R).pushforward f + -- ≅ (Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X) ⋙ (ExtendedFibration R).pushforward f + -- ≅ Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X ⋙ (ExtendedFibration R).pushforward f + -- ≅ Over.pullback R ⊤ h ⋙ R.pushforward f ⋙ ExtendedFibration.yoneda R Y + -- ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y + have : IsIso α := sorry -- should be automatic by infer_instance. Then remove. + have eq : Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) + (Over.forget R.ExtendedFibration ⊤ Y) = α := sorry have : IsIso (Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (Over.forget R.ExtendedFibration ⊤ Y)) := by - sorry + (Over.forget R.ExtendedFibration ⊤ Y)) := by rw [eq]; infer_instance apply NatTrans.isIso_of_whiskerRight_isIso _ (Over.forget _ _ _) -- apply (config := {allowSynthFailures:= true}) NatIso.isIso_of_isIso_app -- intro A diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean index 97bc7ead..88518bc9 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean @@ -48,26 +48,26 @@ def pushforward.isPushforward (X : Over S) [HasPushforward f X] : along `f` for any map into its domain. -/ abbrev HasPushforwardsAlong : Prop := ∀ (X : Over S), HasPushforward f X -namespace Over +-- namespace Over -variable [HasPushforwardsAlong f] +-- variable [HasPushforwardsAlong f] -lemma pullback_rightAdjointObjIsDefined_eq_top : - (Over.pullback f).rightAdjointObjIsDefined = ⊤ := by aesop_cat +-- 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) +-- 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 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) +-- /-- The pullback-pushforward adjunction. -/ +-- def pullbackPushforwardAdjunction : pullback f ⊣ pushforward f := +-- Adjunction.ofIsLeftAdjoint (pullback f) -end Over +-- end Over end CategoryTheory end diff --git a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean index d25879d8..e59c3642 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean @@ -239,14 +239,18 @@ class IsStableUnderPushforwards [Q.HasPullbacks] : Prop where 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' := - ObjectProperty.lift _ (Over.forget P ⊤ S) - (fun X => HasPushforwardsAlong.hasPushforward X.hom X.prop) ⋙ - (CategoryTheory.Over.pullback q).partialRightAdjoint + 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. -/ @@ -259,6 +263,11 @@ noncomputable def pushforward {S S' : T} (q : S ⟶ S') [HasPullbacksAlong q] 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] diff --git a/HoTTLean/ForPoly.lean b/HoTTLean/ForPoly.lean index b9a44a91..69614cd3 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] From 66c32e2fca23ec6f6e7f13e6d479f5be0d57774b Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sun, 16 Nov 2025 19:23:48 -0500 Subject: [PATCH 33/95] rename to pushforwardCompForget' --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index 9a2876e4..fde37d4e 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -455,17 +455,17 @@ instance {T : Type u} [Category.{v} T] (R : MorphismProperty T) {X Y : T} (f : X /-- In a locally cartesian closed category, global pushforward (defined using the `ExponentiableMorphism` API) commutes with local pushforward (defined using the `HasPushforward` API). -/ -def pushforwardForgetTwoSquare {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks T] +def pushforwardCompForget' {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks T] [LocallyCartesianClosed T] {R : MorphismProperty T} {X Y : T} (f : X ⟶ Y) [R.IsStableUnderPushforwardsAlong f] : - Over.forget R ⊤ X ⋙ ExponentiableMorphism.pushforward f ≅ - R.pushforward f ⋙ Over.forget R ⊤ Y := - calc Over.forget R ⊤ X ⋙ ExponentiableMorphism.pushforward 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 := - Iso.refl _ - _ ≅ _ := Functor.isoWhiskerLeft _ - (Functor.isoPartialRightAdjoint _ _ (Functor.rightAdjoint.partialRightAdjoint _)) - _ ≅ R.pushforward f ⋙ Over.forget R ⊤ Y := (pushforwardCompForget ..).symm + (Functor.isoWhiskerLeft _ + (Functor.isoPartialRightAdjoint _ _ (Functor.rightAdjoint.partialRightAdjoint _))).symm + _ ≅ Over.forget R ⊤ X ⋙ ExponentiableMorphism.pushforward f := Iso.refl _ theorem pushforwardPullbackTwoSquare_isIso_extendedFibration {T : Type u} [Category.{max u v} T] (R : MorphismProperty T) From 7a169c77594014ab4927d289c6ee4c90b3affdf8 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sun, 16 Nov 2025 19:43:32 -0500 Subject: [PATCH 34/95] fix: generalize to ExponentiableMorphism --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index fde37d4e..44a64f77 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -456,9 +456,8 @@ instance {T : Type u} [Category.{v} T] (R : MorphismProperty T) {X Y : T} (f : X `ExponentiableMorphism` API) commutes with local pushforward (defined using the `HasPushforward` API). -/ def pushforwardCompForget' {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks T] - [LocallyCartesianClosed T] {R : MorphismProperty T} {X Y : T} (f : X ⟶ Y) - [R.IsStableUnderPushforwardsAlong f] : - R.pushforward f ⋙ Over.forget R ⊤ Y ≅ + {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 .. From 053bc2cd27fa500fdac596902a6e95e9fb7f2e22 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sun, 16 Nov 2025 21:41:01 -0500 Subject: [PATCH 35/95] . --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 73 ++++++++++---------- 1 file changed, 36 insertions(+), 37 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index 44a64f77..a5a16786 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -425,8 +425,7 @@ def pushforwardPullbackTwoSquare {T : Type u} [Category.{v} T] {R : MorphismProp -- · sorry def pullbackForgetTwoSquare {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks T] - [LocallyCartesianClosed T] {R : MorphismProperty T} {X Y : T} (f : X ⟶ Y) - [R.IsStableUnderBaseChangeAlong f] : + {R : MorphismProperty T} {X Y : T} (f : X ⟶ Y) [R.IsStableUnderBaseChangeAlong f] : Over.pullback R ⊤ f ⋙ Over.forget R ⊤ X ≅ Over.forget R ⊤ Y ⋙ CategoryTheory.Over.pullback f := sorry @@ -452,7 +451,13 @@ instance {T : Type u} [Category.{v} T] (R : MorphismProperty T) {X Y : T} (f : X [HasPullbacksAlong f] [HasPushforwardsAlong f] : R.HasPushforwardsAlong f where hasPushforward := inferInstance -/-- In a locally cartesian closed category, global pushforward (defined using the +instance {T : Type u} [Category.{max u v} T] (R : MorphismProperty T) + [R.HasPullbacks] [R.IsStableUnderBaseChange] {X Y : T} (f : X ⟶ Y) + [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : + (ExtendedFibration R).IsStableUnderPushforwardsAlong ym(f) where + of_isPushforward h rh g pf := sorry + +/-- 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] @@ -466,28 +471,24 @@ def pushforwardCompForget' {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks (Functor.isoPartialRightAdjoint _ _ (Functor.rightAdjoint.partialRightAdjoint _))).symm _ ≅ Over.forget R ⊤ X ⋙ ExponentiableMorphism.pushforward f := Iso.refl _ -theorem pushforwardPullbackTwoSquare_isIso_extendedFibration {T : Type u} [Category.{max u v} T] - (R : MorphismProperty T) +theorem pushforwardPullbackTwoSquare_isIso_of_exponentiableMorphism + {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks T] (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - {X Y Z W : Psh T} (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) (sq : h ≫ g = f ≫ k) - [HasPullbacksAlong f] [HasPullbacksAlong g] - [(ExtendedFibration R).HasPushforwardsAlong f] -- TODO: should be automatic in Psh T - [(ExtendedFibration R).IsStableUnderPushforwardsAlong f] - -- TODO: should follow from [R.IsStableUnderPushforwardsAlong f] - [(ExtendedFibration R).HasPushforwardsAlong g] -- TODO: should be automatic in Psh T - [(ExtendedFibration R).IsStableUnderPushforwardsAlong g] - -- TODO: should follow from [R.IsStableUnderPushforwardsAlong g] + {X Y Z W : T} (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) + [ExponentiableMorphism f] [ExponentiableMorphism g] + [R.IsStableUnderPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong g] (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := ExtendedFibration R) h f g k pb.w) := by - let α : (R.ExtendedFibration.pushforward g ⋙ Over.pullback R.ExtendedFibration ⊤ k) ⋙ - Over.forget R.ExtendedFibration ⊤ Y ⟶ - (Over.pullback R.ExtendedFibration ⊤ h ⋙ R.ExtendedFibration.pushforward f) ⋙ - Over.forget R.ExtendedFibration ⊤ Y := sorry + IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by + let α : (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ + Over.forget R ⊤ Y ⟶ + (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ + Over.forget R ⊤ Y := sorry -- TODO: define α as the following composition. All should be either x.hom for some iso x or -- a morphism such that IsIso x - -- (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ ExtendedFibration.yoneda R Y - -- ≅ R.pushforward g ⋙ Over.pullback R ⊤ k ⋙ ExtendedFibration.yoneda R Y - -- ≅ R.pushforward g ⋙ ExtendedFibration.yoneda R W ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- (R.ExtendedFibration.pushforward g ⋙ Over.pullback R.ExtendedFibration ⊤ k) ⋙ + -- Over.forget R.ExtendedFibration ⊤ Y + -- ≅ R.ExtendedFibration.pushforward g ⋙ Over.pullback R.ExtendedFibration ⊤ k ⋙ Over.forget R.ExtendedFibration ⊤ Y + -- ≅ R.ExtendedFibration.pushforward g ⋙ Over.forget R.ExtendedFibration ⊤ W ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) -- ≅ (R.pushforward g ⋙ ExtendedFibration.yoneda R W) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) -- ≅ (ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g)) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) -- ≅ ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) @@ -500,24 +501,22 @@ theorem pushforwardPullbackTwoSquare_isIso_extendedFibration {T : Type u} [Categ -- ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y have : IsIso α := sorry -- should be automatic by infer_instance. Then remove. have eq : Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (Over.forget R.ExtendedFibration ⊤ Y) = α := sorry + (Over.forget R ⊤ Y) = α := sorry have : IsIso (Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (Over.forget R.ExtendedFibration ⊤ Y)) := by rw [eq]; infer_instance + (Over.forget R ⊤ Y)) := by rw [eq]; infer_instance apply NatTrans.isIso_of_whiskerRight_isIso _ (Over.forget _ _ _) - -- apply (config := {allowSynthFailures:= true}) NatIso.isIso_of_isIso_app - -- intro A - -- apply (config := {allowSynthFailures:= true}) Functor.ReflectsIsomorphisms.reflects - -- (ExtendedFibration.yoneda R Y ⋙ Over.forget _ _ _) - -- -- apply (config := {allowSynthFailures:= true}) yoneda.map_isIso - -- -- simp - -- have pb : IsPullback ym(h) ym(f) ym(g) ym(k) := sorry - -- have l := CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq - -- have li := CategoryTheory.pushforwardPullbackTwoSquare_of_isPullback_isIso pb - -- have lii := NatIso.isIso_app_of_isIso - -- (CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq) - -- ((ExtendedFibration.yoneda R Z ⋙ Over.forget _ _ _).obj A) - -- have : IsIso l := inferInstanceAs $ IsIso $ CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq - -- sorry + +theorem pushforwardPullbackTwoSquare_isIso_extendedFibration {T : Type u} [Category.{max u 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) + [HasPullbacksAlong f] [HasPullbacksAlong g] + [R.HasPushforwardsAlong f] [R.HasPushforwardsAlong g] + [R.IsStableUnderPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong g] + (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := ExtendedFibration R) ym(h) ym(f) ym(g) ym(k) + (by simp [← Functor.map_comp, pb.w])) := + pushforwardPullbackTwoSquare_isIso_of_exponentiableMorphism + (ExtendedFibration R) ym(h) ym(f) ym(g) ym(k) (Functor.map_isPullback _ pb) /-- The Beck-Chevalley two-square `pushforwardPullbackTwoSquare` is a natural isomorphism From 277962a7a0341a7842029bc816bb2139dd079b74 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Wed, 19 Nov 2025 18:19:36 -0500 Subject: [PATCH 36/95] tidy --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 427 ++++------- HoTTLean/ForMathlib/CategoryTheory/Clan1.lean | 684 ++++++++++++++++++ HoTTLean/ForMathlib/CategoryTheory/Clan2.lean | 665 +++++++++++++++++ .../Comma/Over/Pushforward.lean | 2 +- .../MorphismProperty/OverAdjunction.lean | 24 + .../ForMathlib/CategoryTheory/NatTrans.lean | 29 + .../ForMathlib/CategoryTheory/Polynomial.lean | 55 +- HoTTLean/ForPoly.lean | 1 - 8 files changed, 1561 insertions(+), 326 deletions(-) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Clan1.lean create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Clan2.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index a5a16786..c8175510 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -54,92 +54,14 @@ namespace MorphismProperty variable (R : MorphismProperty C) -@[simp] -def Local (X : C) : MorphismProperty (R.Over ⊤ X) := fun _ _ f => R f.left - section pullback variable {R} [R.HasPullbacks] {X : C} -lemma Local.hasPullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : - HasPullback f.left g.left := - MorphismProperty.HasPullbacks.hasPullback (g.left) (f:= f.left) rf - -variable [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] - -def Local.pullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : R.Over ⊤ X := - have := Local.hasPullback g rf - .mk ⊤ ((pullback.snd f.left g.left) ≫ V.hom) - (R.comp_mem _ _ (R.of_isPullback (IsPullback.of_hasPullback f.left g.left) rf) V.prop) - -def Local.pullback.fst {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : - Local.pullback g rf ⟶ U := - have := Local.hasPullback g rf - Over.homMk (Limits.pullback.fst f.left g.left) (by - simp only [pullback, ← Over.w f, Limits.pullback.condition_assoc] - simp) - -def Local.pullback.snd {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : - Local.pullback g rf ⟶ V := - have := Local.hasPullback g rf - Over.homMk (Limits.pullback.snd f.left g.left) - -theorem Local.pullback.isPullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : - IsPullback (Local.pullback.fst g rf) (Local.pullback.snd g rf) f g := by - have := Local.hasPullback g rf - have : (CostructuredArrow.proj (𝟭 C) X).Faithful := CostructuredArrow.proj_faithful -- why? - have : ReflectsLimitsOfShape WalkingCospan (CostructuredArrow.proj (𝟭 C) X) := inferInstance -- why? - apply Functor.reflect_isPullback (Over.forget R ⊤ X ⋙ CostructuredArrow.proj (Functor.id C) X) - simpa [fst, snd, Comma.Hom.hom_left] using IsPullback.of_hasPullback f.left g.left - variable (X) -instance : (Local R X).HasPullbacks where - hasPullback {U V W} f g rf := by - have := Local.hasPullback g rf - let pbinC := IsPullback.of_hasPullback f.left g.left - -- let P : R.Over ⊤ X := .mk ⊤ ((pullback.snd f.left g.left) ≫ V.hom) - -- (by apply R.comp_mem - -- sorry) - -- apply IsPullback.hasPullback - sorry - - -- let F := CostructuredArrow.proj (Functor.id C) X - -- have p00: PreservesLimit (cospan f g) (Over.forget R ⊤ X) := sorry - -- have p0 : PreservesLimit (cospan f g ⋙ Over.forget R ⊤ X) - -- (CostructuredArrow.proj (𝟭 C) X) := sorry - - -- have p1 : @PreservesLimit - -- (R.Over ⊤ X) _ C _ WalkingCospan _ (cospan f g) - -- (Over.forget R ⊤ X ⋙ (CostructuredArrow.proj (Functor.id C) X)) := by - -- apply CategoryTheory.Limits.comp_preservesLimit - - -- have p: IsPullback fst.left snd.left f.left g.left := by - -- apply Functor.map_isPullback - -- (Over.forget R ⊤ X ⋙ CostructuredArrow.proj (Functor.id C) X) i - -- simp[Local] at * - -- apply R.of_isPullback p rf - -instance : (Local R X).IsStableUnderBaseChange where - of_isPullback {W V P K} g f fst snd i rf := by - have := Local.hasPullback g rf - rw [← IsPullback.isoIsPullback_hom_snd _ _ i (Local.pullback.isPullback g rf), Local] - exact RespectsIso.precomp _ _ _ (R.of_isPullback (IsPullback.of_hasPullback f.left g.left) rf) - end pullback -instance (X : C) [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] : - (Local R X).IsStableUnderBaseChange := sorry - -instance (X : C) : (Local R X).HasObjects := sorry - -instance (X : C) [R.ContainsIdentities] : (Local R X).ContainsIdentities where - id_mem _ := R.id_mem _ - -instance (X : C) [R.IsStableUnderComposition] : - (Local R X).IsStableUnderComposition where - comp_mem _ _ := R.comp_mem _ _ - abbrev chosenTerminal [R.ContainsIdentities] (X) : R.Over ⊤ X := .mk ⊤ (𝟙 X) (R.id_mem _) @[simps!] @@ -150,96 +72,41 @@ protected def Over.post (R : MorphismProperty C) (R' : MorphismProperty C') map_id := sorry map_comp := sorry -instance {R' : MorphismProperty C'} [F.PreservesMorphismProperty R R'] (X : C) : - (Over.post F R R' X).PreservesMorphismProperty (Local R X) (Local R' (F.obj X)) where - map_mem _ := F.map_mem _ - -instance {R' : MorphismProperty C'} [F.PreservesMorphismProperty R R'] [F.PreservesPullbacksOf R] - (X : C) : (Over.post F R R' X).PreservesPullbacksOf (Local R X) where - pb := sorry - @[simp] lemma localFunctor_obj_chosenTerminal [R.ContainsIdentities] {R' : MorphismProperty C'} [R'.ContainsIdentities] [F.PreservesMorphismProperty R R'] (X : C) : (Over.post F R R' X).obj (R.chosenTerminal X) = R'.chosenTerminal (F.obj X) := by cat_disch -instance [R.IsStableUnderBaseChange] {X Y : C} (f : X ⟶ Y) [R.HasPullbacksAlong f] : - (Over.pullback R ⊤ f).PreservesMorphismProperty (Local R Y) (Local R X) := sorry - -instance [R.IsStableUnderBaseChange] {X Y : C} (f : X ⟶ Y) [R.HasPullbacksAlong f] : - (Over.pullback R ⊤ f).PreservesPullbacksOf (Local R Y) := sorry - 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 -structure RepresentableFibrantChosenPullbacks {X Y : Psh C} (f : X ⟶ Y) - extends RepresentableChosenPullbacks f where - fibrant {Γ : C} (b : y(Γ) ⟶ Y) : R (disp b) - --- this is a preclan, does not satisfy HasObjects -def ExtendedFibration : MorphismProperty (Psh C) := - fun _ _ f => Nonempty (RepresentableFibrantChosenPullbacks R f) - -instance : (ExtendedFibration R).IsStableUnderBaseChange := sorry - -instance : (ExtendedFibration R).HasPullbacks := sorry - -instance [R.ContainsIdentities] : (ExtendedFibration R).ContainsIdentities where - id_mem _ := sorry - -instance [R.IsStableUnderComposition] : (ExtendedFibration R).IsStableUnderComposition where - comp_mem _ _ hf hg := sorry - -notation:max R"^("F")" => Local (ExtendedFibration R) F - -namespace ExtendedFibration - variable [R.HasPullbacks] [R.IsStableUnderBaseChange] -def yonedaRepresentableFibrantChosenPullbacks (X Y : C) (f : X ⟶ Y) (rf : R f) : - R.RepresentableFibrantChosenPullbacks (CategoryTheory.yoneda.map f) := - have h {Γ} (A : Γ ⟶ Y) : HasPullback f A := HasPullbacks.hasPullback _ rf - { ext A := pullback f (yoneda.preimage A) - disp A := pullback.snd _ _ - var _ := ym(pullback.fst _ _) - disp_pullback := sorry - fibrant A := IsStableUnderBaseChange.of_isPullback (IsPullback.of_hasPullback _ _) rf } - -/-- This is the functor `R(X) -> R^(X)`. -/ @[simps] -protected def yoneda (X : C) : R.Over ⊤ X ⥤ (ExtendedFibration R).Over ⊤ y(X) where - obj A := .mk ⊤ ym(A.hom) ⟨yonedaRepresentableFibrantChosenPullbacks R _ _ _ A.prop⟩ - map {A B} f := Over.homMk ym(f.left) +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) map_id := sorry map_comp := sorry -instance (X : C) : (ExtendedFibration.yoneda R X).Full where +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; simp; exact Over.w f), - by cat_disch⟩ + ⟨Over.homMk (yoneda.preimage f.left) (by + apply yoneda.map_injective; simpa using CategoryTheory.Over.w f), + by cat_disch⟩ -instance (X : C) : (ExtendedFibration.yoneda R X).Faithful where +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 (Over.forget _ _ _ ⋙ CategoryTheory.Over.forget _) hf + exact Functor.congr_map (CategoryTheory.Over.forget _) hf variable (F : Psh C) -example [R.IsStableUnderComposition] : (R^(F)).HasPullbacks := inferInstance -example [R.IsStableUnderComposition] : (R^(F)).IsStableUnderBaseChange := inferInstance -example : (R^(F)).HasObjects := inferInstance -example [R.ContainsIdentities] : (R^(F)).ContainsIdentities := inferInstance -example [R.IsStableUnderComposition] : (R^(F)).IsStableUnderComposition := inferInstance - -example (X : C) : (ExtendedFibration.yoneda R X).ReflectsIsomorphisms := inferInstance - -end ExtendedFibration - instance : (⊤ : MorphismProperty C).HasOfPostcompProperty ⊤ where of_postcomp := by simp @@ -331,6 +198,18 @@ lemma pullbackMapTwoSquare_app_left {T : Type u} [Category.{v} T] (R : MorphismP 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 _) + simp [Comma.Hom.hom] + sorry -- should be pullback pasting. Try it! + /-- The Beck-Chevalley two-square `pushforwardPullbackTwoSquare` is a natural isomorphism ``` @@ -354,7 +233,7 @@ condition is strengthened to a pullback condition. X - h → Z ``` -/ -theorem pullbackMapTwoSquare_isIso {T : Type u} [Category.{v} T] (R : MorphismProperty T) +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) : @@ -372,63 +251,6 @@ theorem pullbackMapTwoSquare_isIso {T : Type u} [Category.{v} T] (R : MorphismPr · cat_disch · assumption -/-- 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_ {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) : --- (pushforwardPullbackTwoSquare h f g k sq).app A = sorry := by --- apply (Over.forget R ⊤ Y).map_injective --- simp [pushforwardPullbackTwoSquare, ← Functor.map_comp] --- rw [pushforward.homEquiv_symm_comp] --- rw [Equiv.symm_apply_eq] --- simp --- erw [Category.id_comp] --- ext --- simp --- ext --- · simp --- sorry --- · sorry - -def pullbackForgetTwoSquare {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks T] - {R : MorphismProperty T} {X Y : T} (f : X ⟶ Y) [R.IsStableUnderBaseChangeAlong f] : - Over.pullback R ⊤ f ⋙ Over.forget R ⊤ X ≅ Over.forget R ⊤ Y ⋙ CategoryTheory.Over.pullback f := - sorry - @[simps] def _root_.CategoryTheory.ExponentiableMorphism.pullbackRepresentableByPushforward {T : Type u} [Category.{v} T] [HasPullbacks T] @@ -451,12 +273,6 @@ instance {T : Type u} [Category.{v} T] (R : MorphismProperty T) {X Y : T} (f : X [HasPullbacksAlong f] [HasPushforwardsAlong f] : R.HasPushforwardsAlong f where hasPushforward := inferInstance -instance {T : Type u} [Category.{max u v} T] (R : MorphismProperty T) - [R.HasPullbacks] [R.IsStableUnderBaseChange] {X Y : T} (f : X ⟶ Y) - [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : - (ExtendedFibration R).IsStableUnderPushforwardsAlong ym(f) where - of_isPushforward h rh g pf := sorry - /-- Given an exponentiable morphism, global pushforward (defined using the `ExponentiableMorphism` API) commutes with local pushforward (defined using the `HasPushforward` API). -/ @@ -471,52 +287,111 @@ def pushforwardCompForget' {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks (Functor.isoPartialRightAdjoint _ _ (Functor.rightAdjoint.partialRightAdjoint _))).symm _ ≅ Over.forget R ⊤ X ⋙ ExponentiableMorphism.pushforward f := Iso.refl _ -theorem pushforwardPullbackTwoSquare_isIso_of_exponentiableMorphism - {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks 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) - [ExponentiableMorphism f] [ExponentiableMorphism g] - [R.IsStableUnderPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong g] - (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by - let α : (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ - Over.forget R ⊤ Y ⟶ - (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ - Over.forget R ⊤ Y := sorry - -- TODO: define α as the following composition. All should be either x.hom for some iso x or - -- a morphism such that IsIso x - -- (R.ExtendedFibration.pushforward g ⋙ Over.pullback R.ExtendedFibration ⊤ k) ⋙ - -- Over.forget R.ExtendedFibration ⊤ Y - -- ≅ R.ExtendedFibration.pushforward g ⋙ Over.pullback R.ExtendedFibration ⊤ k ⋙ Over.forget R.ExtendedFibration ⊤ Y - -- ≅ R.ExtendedFibration.pushforward g ⋙ Over.forget R.ExtendedFibration ⊤ W ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ (R.pushforward g ⋙ ExtendedFibration.yoneda R W) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ (ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g)) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- use `pushforwardPullbackTwoSquare_isIso_extendedFibration` here - -- ≅ ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h) ⋙ (ExtendedFibration R).pushforward f - -- ≅ (ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h)) ⋙ (ExtendedFibration R).pushforward f - -- ≅ (Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X) ⋙ (ExtendedFibration R).pushforward f - -- ≅ Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X ⋙ (ExtendedFibration R).pushforward f - -- ≅ Over.pullback R ⊤ h ⋙ R.pushforward f ⋙ ExtendedFibration.yoneda R Y - -- ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y - have : IsIso α := sorry -- should be automatic by infer_instance. Then remove. - have eq : Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (Over.forget R ⊤ Y) = α := sorry - have : IsIso (Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (Over.forget R ⊤ Y)) := by rw [eq]; infer_instance - apply NatTrans.isIso_of_whiskerRight_isIso _ (Over.forget _ _ _) - -theorem pushforwardPullbackTwoSquare_isIso_extendedFibration {T : Type u} [Category.{max u v} T] +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) + (pullbackComparison_comp_snd yoneda A.hom f)) + (fun {A B} g => by + apply (CategoryTheory.Over.forget _).map_injective + apply pullback.hom_ext <;> simp) + +abbrev pullbackYonedaTwoSquare {T : Type u} [Category.{max u v} T] (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y : T} (f : X ⟶ Y) : TwoSquare (Over.pullback R ⊤ f) (Over.yoneda R Y) + (Over.yoneda R X) (CategoryTheory.Over.pullback ym(f)) := sorry + +-- def pushforwardYonedaTwoSquare {T : Type u} [Category.{max u v} T] + -- (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + -- {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] + -- [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : + -- TwoSquare (R.pushforward f) (Over.yoneda R X) (Over.yoneda R Y) + -- (ExponentiableMorphism.pushforward ym(f)) := + -- mateEquiv (pullbackPushforwardAdjunction R f) (ExponentiableMorphism.adj y) + +def pushforwardYonedaIso {T : Type u} [Category.{max u v} 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) := sorry + -- calc R.pushforward f ⋙ Over.yoneda R Y + -- _ ≅ R.pushforwardPartial f ⋙ CategoryTheory.Over.post yoneda := sorry + -- _ ≅ Over.yoneda R X ⋙ ExponentiableMorphism.pushforward ym(f) := sorry + +def pushforwardPullbackIso {T : Type u} [Category.{max u 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) [HasPullbacksAlong f] [HasPullbacksAlong g] - [R.HasPushforwardsAlong f] [R.HasPushforwardsAlong g] - [R.IsStableUnderPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong g] + [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] + [R.HasPushforwardsAlong g] [R.IsStableUnderPushforwardsAlong g] (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := ExtendedFibration R) ym(h) ym(f) ym(g) ym(k) - (by simp [← Functor.map_comp, pb.w])) := - pushforwardPullbackTwoSquare_isIso_of_exponentiableMorphism - (ExtendedFibration R) ym(h) ym(f) ym(g) ym(k) (Functor.map_isPullback _ pb) + R.pushforward g ⋙ Over.pullback R ⊤ k ≅ Over.pullback R ⊤ h ⋙ R.pushforward f := + (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) := + 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) := + 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) := + 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) := + 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 := + Functor.isoWhiskerLeft _ (pushforwardYonedaIso ..).symm + _ ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ Over.yoneda R Y := (Functor.associator _ _ _).symm + +#exit +-- The remaining part of this file is an alternative definition of the iso, +-- which maybe is not necessary + + +/-- 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) /-- The Beck-Chevalley two-square `pushforwardPullbackTwoSquare` is a natural isomorphism @@ -544,58 +419,14 @@ NOTE: we also know it holds in a category with pullbacks with `R = ⊤` and `Q = theorem pushforwardPullbackTwoSquare_isIso {T : Type u} [Category.{max u 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] - (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by - let α : (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ ExtendedFibration.yoneda R Y ⟶ - (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y := sorry - -- TODO: define α as the following composition. All should be either x.hom for some iso x or - -- a morphism such that IsIso x - -- (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ ExtendedFibration.yoneda R Y - -- ≅ R.pushforward g ⋙ Over.pullback R ⊤ k ⋙ ExtendedFibration.yoneda R Y - -- ≅ R.pushforward g ⋙ ExtendedFibration.yoneda R W ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ (R.pushforward g ⋙ ExtendedFibration.yoneda R W) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ (ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g)) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- use `pushforwardPullbackTwoSquare_isIso_extendedFibration` here - -- ≅ ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h) ⋙ (ExtendedFibration R).pushforward f - -- ≅ (ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h)) ⋙ (ExtendedFibration R).pushforward f - -- ≅ (Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X) ⋙ (ExtendedFibration R).pushforward f - -- ≅ Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X ⋙ (ExtendedFibration R).pushforward f - -- ≅ Over.pullback R ⊤ h ⋙ R.pushforward f ⋙ ExtendedFibration.yoneda R Y - -- ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y - have : IsIso α := sorry -- should be automatic by infer_instance. Then remove. - have eq : Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (ExtendedFibration.yoneda R Y) = α := sorry - have : IsIso (Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (ExtendedFibration.yoneda R Y)) := by rw [eq]; infer_instance - apply NatTrans.isIso_of_whiskerRight_isIso _ (ExtendedFibration.yoneda R Y) - -/- -theorem pushforwardPullbackTwoSquare_isIso {T : Type u} [Category.{max u 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) + {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 - apply (config := {allowSynthFailures:= true}) NatIso.isIso_of_isIso_app - intro A - apply (config := {allowSynthFailures:= true}) Functor.ReflectsIsomorphisms.reflects - (ExtendedFibration.yoneda R Y ⋙ Over.forget _ _ _) - -- apply (config := {allowSynthFailures:= true}) yoneda.map_isIso - -- simp - have pb : IsPullback ym(h) ym(f) ym(g) ym(k) := sorry - have l := CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq - have li := CategoryTheory.pushforwardPullbackTwoSquare_of_isPullback_isIso pb - have lii := NatIso.isIso_app_of_isIso - (CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq) - ((ExtendedFibration.yoneda R Z ⋙ Over.forget _ _ _).obj A) - -- have : IsIso l := inferInstanceAs $ IsIso $ CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq - sorry --/ + have eq : (pushforwardPullbackTwoSquare h f g k pb.w) = + (pushforwardPullbackIso R h f g k pb).hom := + sorry + rw [eq] + infer_instance diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan1.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan1.lean new file mode 100644 index 00000000..a08e01d9 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan1.lean @@ -0,0 +1,684 @@ +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 + +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) + +@[simp] +def Local (X : C) : MorphismProperty (R.Over ⊤ X) := fun _ _ f => R f.left + +section pullback + +variable {R} [R.HasPullbacks] {X : C} + +lemma Local.hasPullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : + HasPullback f.left g.left := + MorphismProperty.HasPullbacks.hasPullback (g.left) (f:= f.left) rf + +variable [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] + +def Local.pullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : R.Over ⊤ X := + have := Local.hasPullback g rf + .mk ⊤ ((pullback.snd f.left g.left) ≫ V.hom) + (R.comp_mem _ _ (R.of_isPullback (IsPullback.of_hasPullback f.left g.left) rf) V.prop) + +def Local.pullback.fst {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : + Local.pullback g rf ⟶ U := + have := Local.hasPullback g rf + Over.homMk (Limits.pullback.fst f.left g.left) (by + simp only [pullback, ← Over.w f, Limits.pullback.condition_assoc] + simp) + +def Local.pullback.snd {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : + Local.pullback g rf ⟶ V := + have := Local.hasPullback g rf + Over.homMk (Limits.pullback.snd f.left g.left) + +theorem Local.pullback.isPullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : + IsPullback (Local.pullback.fst g rf) (Local.pullback.snd g rf) f g := by + have := Local.hasPullback g rf + have : (CostructuredArrow.proj (𝟭 C) X).Faithful := CostructuredArrow.proj_faithful -- why? + have : ReflectsLimitsOfShape WalkingCospan (CostructuredArrow.proj (𝟭 C) X) := inferInstance -- why? + apply Functor.reflect_isPullback (Over.forget R ⊤ X ⋙ CostructuredArrow.proj (Functor.id C) X) + simpa [fst, snd, Comma.Hom.hom_left] using IsPullback.of_hasPullback f.left g.left + +variable (X) + +instance : (Local R X).HasPullbacks where + hasPullback {U V W} f g rf := by + have := Local.hasPullback g rf + let pbinC := IsPullback.of_hasPullback f.left g.left + -- let P : R.Over ⊤ X := .mk ⊤ ((pullback.snd f.left g.left) ≫ V.hom) + -- (by apply R.comp_mem + -- sorry) + -- apply IsPullback.hasPullback + sorry + + -- let F := CostructuredArrow.proj (Functor.id C) X + -- have p00: PreservesLimit (cospan f g) (Over.forget R ⊤ X) := sorry + -- have p0 : PreservesLimit (cospan f g ⋙ Over.forget R ⊤ X) + -- (CostructuredArrow.proj (𝟭 C) X) := sorry + + -- have p1 : @PreservesLimit + -- (R.Over ⊤ X) _ C _ WalkingCospan _ (cospan f g) + -- (Over.forget R ⊤ X ⋙ (CostructuredArrow.proj (Functor.id C) X)) := by + -- apply CategoryTheory.Limits.comp_preservesLimit + + -- have p: IsPullback fst.left snd.left f.left g.left := by + -- apply Functor.map_isPullback + -- (Over.forget R ⊤ X ⋙ CostructuredArrow.proj (Functor.id C) X) i + -- simp[Local] at * + -- apply R.of_isPullback p rf + +instance : (Local R X).IsStableUnderBaseChange where + of_isPullback {W V P K} g f fst snd i rf := by + have := Local.hasPullback g rf + rw [← IsPullback.isoIsPullback_hom_snd _ _ i (Local.pullback.isPullback g rf), Local] + exact RespectsIso.precomp _ _ _ (R.of_isPullback (IsPullback.of_hasPullback f.left g.left) rf) + +end pullback + +instance (X : C) [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] : + (Local R X).IsStableUnderBaseChange := sorry + +instance (X : C) : (Local R X).HasObjects := sorry + +instance (X : C) [R.ContainsIdentities] : (Local R X).ContainsIdentities where + id_mem _ := R.id_mem _ + +instance (X : C) [R.IsStableUnderComposition] : + (Local R X).IsStableUnderComposition where + comp_mem _ _ := R.comp_mem _ _ + +abbrev chosenTerminal [R.ContainsIdentities] (X) : R.Over ⊤ X := .mk ⊤ (𝟙 X) (R.id_mem _) + +@[simps!] +protected def Over.post (R : MorphismProperty C) (R' : MorphismProperty C') + [F.PreservesMorphismProperty R R'] (X : C) : R.Over ⊤ X ⥤ R'.Over ⊤ (F.obj X) where + obj X := MorphismProperty.Over.mk ⊤ (F.map X.hom) (F.map_mem _ X.prop) + map f := MorphismProperty.Over.homMk (F.map f.left) (by simp [← F.map_comp]) + map_id := sorry + map_comp := sorry + +instance {R' : MorphismProperty C'} [F.PreservesMorphismProperty R R'] (X : C) : + (Over.post F R R' X).PreservesMorphismProperty (Local R X) (Local R' (F.obj X)) where + map_mem _ := F.map_mem _ + +instance {R' : MorphismProperty C'} [F.PreservesMorphismProperty R R'] [F.PreservesPullbacksOf R] + (X : C) : (Over.post F R R' X).PreservesPullbacksOf (Local R X) where + pb := sorry + +@[simp] +lemma localFunctor_obj_chosenTerminal [R.ContainsIdentities] {R' : MorphismProperty C'} + [R'.ContainsIdentities] [F.PreservesMorphismProperty R R'] (X : C) : + (Over.post F R R' X).obj (R.chosenTerminal X) = R'.chosenTerminal (F.obj X) := by + cat_disch + +instance [R.IsStableUnderBaseChange] {X Y : C} (f : X ⟶ Y) [R.HasPullbacksAlong f] : + (Over.pullback R ⊤ f).PreservesMorphismProperty (Local R Y) (Local R X) := sorry + +instance [R.IsStableUnderBaseChange] {X Y : C} (f : X ⟶ Y) [R.HasPullbacksAlong f] : + (Over.pullback R ⊤ f).PreservesPullbacksOf (Local R Y) := sorry + +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 + +structure RepresentableFibrantChosenPullbacks {X Y : Psh C} (f : X ⟶ Y) + extends RepresentableChosenPullbacks f where + fibrant {Γ : C} (b : y(Γ) ⟶ Y) : R (disp b) + +-- this is a preclan, does not satisfy HasObjects +def ExtendedFibration : MorphismProperty (Psh C) := + fun _ _ f => Nonempty (RepresentableFibrantChosenPullbacks R f) + +instance : (ExtendedFibration R).IsStableUnderBaseChange := sorry + +instance : (ExtendedFibration R).HasPullbacks := sorry + +instance [R.ContainsIdentities] : (ExtendedFibration R).ContainsIdentities where + id_mem _ := sorry + +instance [R.IsStableUnderComposition] : (ExtendedFibration R).IsStableUnderComposition where + comp_mem _ _ hf hg := sorry + +notation:max R"^("F")" => Local (ExtendedFibration R) F + +namespace ExtendedFibration + +variable [R.HasPullbacks] [R.IsStableUnderBaseChange] + +def yonedaRepresentableFibrantChosenPullbacks (X Y : C) (f : X ⟶ Y) (rf : R f) : + R.RepresentableFibrantChosenPullbacks (CategoryTheory.yoneda.map f) := + have h {Γ} (A : Γ ⟶ Y) : HasPullback f A := HasPullbacks.hasPullback _ rf + { ext A := pullback f (yoneda.preimage A) + disp A := pullback.snd _ _ + var _ := ym(pullback.fst _ _) + disp_pullback := sorry + fibrant A := IsStableUnderBaseChange.of_isPullback (IsPullback.of_hasPullback _ _) rf } + +/-- This is the functor `R(X) -> R^(X)`. -/ +@[simps] +protected def yoneda (X : C) : R.Over ⊤ X ⥤ (ExtendedFibration R).Over ⊤ y(X) where + obj A := .mk ⊤ ym(A.hom) ⟨yonedaRepresentableFibrantChosenPullbacks R _ _ _ A.prop⟩ + map {A B} f := Over.homMk ym(f.left) + map_id := sorry + map_comp := sorry + +instance (X : C) : (ExtendedFibration.yoneda R X).Full where + map_surjective {A B} f := + ⟨Over.homMk (yoneda.preimage f.left) (by apply yoneda.map_injective; simp; exact Over.w f), + by cat_disch⟩ + +instance (X : C) : (ExtendedFibration.yoneda R X).Faithful where + map_injective {A B} f f' hf := by + ext + apply yoneda.map_injective + exact Functor.congr_map (Over.forget _ _ _ ⋙ CategoryTheory.Over.forget _) hf + +variable (F : Psh C) + +example [R.IsStableUnderComposition] : (R^(F)).HasPullbacks := inferInstance +example [R.IsStableUnderComposition] : (R^(F)).IsStableUnderBaseChange := inferInstance +example : (R^(F)).HasObjects := inferInstance +example [R.ContainsIdentities] : (R^(F)).ContainsIdentities := inferInstance +example [R.IsStableUnderComposition] : (R^(F)).IsStableUnderComposition := inferInstance + +example (X : C) : (ExtendedFibration.yoneda R X).ReflectsIsomorphisms := inferInstance + +end ExtendedFibration + +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] + +/-- +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 +``` +-/ +theorem 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 + +/-- 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_ {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) : +-- (pushforwardPullbackTwoSquare h f g k sq).app A = sorry := by +-- apply (Over.forget R ⊤ Y).map_injective +-- simp [pushforwardPullbackTwoSquare, ← Functor.map_comp] +-- rw [pushforward.homEquiv_symm_comp] +-- rw [Equiv.symm_apply_eq] +-- simp +-- erw [Category.id_comp] +-- ext +-- simp +-- ext +-- · simp +-- sorry +-- · sorry + +def pullbackForgetTwoSquare {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks T] + {R : MorphismProperty T} {X Y : T} (f : X ⟶ Y) [R.IsStableUnderBaseChangeAlong f] : + Over.pullback R ⊤ f ⋙ Over.forget R ⊤ X ≅ Over.forget R ⊤ Y ⋙ CategoryTheory.Over.pullback f := + sorry + +@[simps] +def _root_.CategoryTheory.ExponentiableMorphism.pullbackRepresentableByPushforward + {T : Type u} [Category.{v} T] [HasPullbacks T] + {X Y : T} (f : X ⟶ Y) [ExponentiableMorphism f] (h : Over X) : + ((CategoryTheory.Over.pullback f).op ⋙ y(h)).RepresentableBy + ((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.pullbackRepresentableByPushforward 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 _ + +example {T : Type u} [Category.{max u v} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y Z : T} (f : X ⟶ Y) (t : Z ⟶ Y) + [HasPullbacksAlong f] : + HasPullbacksAlong (pullback.fst t f) := + inferInstance + +def IsPushforward.ofYonedaIsPushforward {C : Type u} [Category.{u} C] + {S S' : C} (f : S ⟶ S') (X : Over S) (Y : Over S') [HasPullbacksAlong f] + (isPushforward : IsPushforward ym(f) ((CategoryTheory.Over.post yoneda).obj X) + ((CategoryTheory.Over.post yoneda).obj Y)) : + IsPushforward f X Y where + homEquiv {A} := by + refine (Yoneda.fullyFaithful.over S').homEquiv.trans ?_ + refine (isPushforward.homEquiv).trans ?_ + refine Equiv.trans ?_ (Yoneda.fullyFaithful.over S).homEquiv.symm + refine Iso.homCongr ?_ (Iso.refl _) + exact CategoryTheory.Over.isoMk (PreservesPullback.iso yoneda A.hom f).symm + homEquiv_comp {A A'} g h := by + -- apply (Yoneda.fullyFaithful.over S).map_injective + -- ext : 1 + -- simp only [Functor.op_obj, Functor.id_obj, Functor.comp_obj, + -- yoneda_obj_obj, Functor.const_obj_obj, Equiv.trans_apply, Iso.homCongr_apply, Iso.refl_hom, + -- comp_id, Functor.comp_map, Functor.op_map, Quiver.Hom.unop_op, + -- yoneda_obj_map, Over.comp_left, Functor.map_comp, Functor.FullyFaithful.homEquiv_symm_apply] + sorry + +/-- The constructed pushforward functor for `pullback.fst t f : pullback t f ⟶ Z`, +given `f : X ⟶ Y` has pushforwards and `R`-map `t : Z ⟶ Y`. -/ +def pushforwardPullbackFst {T : Type u} [Category.{v} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + [R.IsStableUnderComposition] + {X Y Z : T} (f : X ⟶ Y) {t : Z ⟶ Y} (rt : R t) + [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : + R.Over ⊤ (pullback t f) ⥤ R.Over ⊤ Z := + Over.map ⊤ (f := pullback.snd t f) (R.of_isPullback (IsPullback.of_hasPullback t f) rt) ⋙ + R.pushforward f ⋙ Over.pullback R ⊤ t + +instance hasPushforwardsAlong_pullback_fst {T : Type u} [Category.{max u v} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y Z : T} (f : X ⟶ Y) (t : Z ⟶ Y) + [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : + R.HasPushforwardsAlong (pullback.fst t f) where + hasPushforward {W} h rh := { + has_representation := ⟨sorry, ⟨sorry⟩⟩ } + +instance isStableUnderPushforwardsAlong_pullback_fst {T : Type u} [Category.{max u v} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y Z : T} (f : X ⟶ Y) {t : Z ⟶ Y} (rt : R t) + [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : + R.IsStableUnderPushforwardsAlong (pullback.fst t f) := + sorry + +def extendedFibration_pushforward {T : Type u} [Category.{max u v} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y : T} (f : X ⟶ Y) + [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] + {W : Psh T} (h : W ⟶ y(X)) (rh : R.RepresentableFibrantChosenPullbacks h) : + R.RepresentableFibrantChosenPullbacks ((ExponentiableMorphism.pushforward ym(f)).obj + (CategoryTheory.Over.mk h)).hom where + ext {Γ} t := by + dsimp at t + -- let E := rf.ext t + -- let d := rf.disp t + -- let v := rf.var t + -- let pf : Over Γ := sorry + sorry + disp := sorry + var := sorry + disp_pullback := sorry + fibrant := sorry + +lemma extendedFibration_pushforward_yoneda {T : Type u} [Category.{max u v} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] {X Y : T} (f : X ⟶ Y) + [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] + {W : Psh T} (h : W ⟶ y(X)) (rh : R.ExtendedFibration h) : + R.ExtendedFibration ((ExponentiableMorphism.pushforward ym(f)).obj + (CategoryTheory.Over.mk h)).hom := + ⟨ sorry ⟩ + +instance {T : Type u} [Category.{max u v} T] (R : MorphismProperty T) + [R.HasPullbacks] [R.IsStableUnderBaseChange] {X Y : T} (f : X ⟶ Y) + [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : + (ExtendedFibration R).IsStableUnderPushforwardsAlong ym(f) := + IsStableUnderPushforwardsAlong.of_respectsIso _ _ + (fun h _ => (ExponentiableMorphism.pushforward ym(f)).obj (CategoryTheory.Over.mk h)) + (fun h rh => extendedFibration_pushforward_yoneda R f h rh) + (fun h _ => ExponentiableMorphism.pullbackRepresentableByPushforward ym(f) (.mk h)) + +theorem pushforwardPullbackTwoSquare_isIso_of_exponentiableMorphism + {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks 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) + [ExponentiableMorphism f] [ExponentiableMorphism g] + [R.IsStableUnderPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong g] + (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by + let α : (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ + Over.forget R ⊤ Y ⟶ + (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ + Over.forget R ⊤ Y := sorry + -- TODO: define α as the following composition. All should be either x.hom for some iso x or + -- a morphism such that IsIso x + -- (R.ExtendedFibration.pushforward g ⋙ Over.pullback R.ExtendedFibration ⊤ k) ⋙ + -- Over.forget R.ExtendedFibration ⊤ Y + -- ≅ R.ExtendedFibration.pushforward g ⋙ Over.pullback R.ExtendedFibration ⊤ k ⋙ Over.forget R.ExtendedFibration ⊤ Y + -- ≅ R.ExtendedFibration.pushforward g ⋙ Over.forget R.ExtendedFibration ⊤ W ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ (R.pushforward g ⋙ ExtendedFibration.yoneda R W) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ (ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g)) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- use `pushforwardPullbackTwoSquare_isIso_extendedFibration` here + -- ≅ ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h) ⋙ (ExtendedFibration R).pushforward f + -- ≅ (ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h)) ⋙ (ExtendedFibration R).pushforward f + -- ≅ (Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X) ⋙ (ExtendedFibration R).pushforward f + -- ≅ Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X ⋙ (ExtendedFibration R).pushforward f + -- ≅ Over.pullback R ⊤ h ⋙ R.pushforward f ⋙ ExtendedFibration.yoneda R Y + -- ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y + have : IsIso α := sorry -- should be automatic by infer_instance. Then remove. + have eq : Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) + (Over.forget R ⊤ Y) = α := sorry + have : IsIso (Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) + (Over.forget R ⊤ Y)) := by rw [eq]; infer_instance + apply NatTrans.isIso_of_whiskerRight_isIso _ (Over.forget _ _ _) + +theorem pushforwardPullbackTwoSquare_isIso_extendedFibration {T : Type u} [Category.{max u 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) + [HasPullbacksAlong f] [HasPullbacksAlong g] + [R.HasPushforwardsAlong f] [R.HasPushforwardsAlong g] + [R.IsStableUnderPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong g] + (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := ExtendedFibration R) ym(h) ym(f) ym(g) ym(k) + (by simp [← Functor.map_comp, pb.w])) := + pushforwardPullbackTwoSquare_isIso_of_exponentiableMorphism + (ExtendedFibration R) ym(h) ym(f) ym(g) ym(k) (Functor.map_isPullback _ pb) + +/-- +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.{max u 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] + (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by + let α : (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ ExtendedFibration.yoneda R Y ⟶ + (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y := sorry + -- TODO: define α as the following composition. All should be either x.hom for some iso x or + -- a morphism such that IsIso x + -- (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ ExtendedFibration.yoneda R Y + -- ≅ R.pushforward g ⋙ Over.pullback R ⊤ k ⋙ ExtendedFibration.yoneda R Y + -- ≅ R.pushforward g ⋙ ExtendedFibration.yoneda R W ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ (R.pushforward g ⋙ ExtendedFibration.yoneda R W) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ (ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g)) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- use `pushforwardPullbackTwoSquare_isIso_extendedFibration` here + -- ≅ ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h) ⋙ (ExtendedFibration R).pushforward f + -- ≅ (ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h)) ⋙ (ExtendedFibration R).pushforward f + -- ≅ (Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X) ⋙ (ExtendedFibration R).pushforward f + -- ≅ Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X ⋙ (ExtendedFibration R).pushforward f + -- ≅ Over.pullback R ⊤ h ⋙ R.pushforward f ⋙ ExtendedFibration.yoneda R Y + -- ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y + have : IsIso α := sorry -- should be automatic by infer_instance. Then remove. + have eq : Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) + (ExtendedFibration.yoneda R Y) = α := sorry + have : IsIso (Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) + (ExtendedFibration.yoneda R Y)) := by rw [eq]; infer_instance + apply NatTrans.isIso_of_whiskerRight_isIso _ (ExtendedFibration.yoneda R Y) + +/- +theorem pushforwardPullbackTwoSquare_isIso {T : Type u} [Category.{max u 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] + (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by + apply (config := {allowSynthFailures:= true}) NatIso.isIso_of_isIso_app + intro A + apply (config := {allowSynthFailures:= true}) Functor.ReflectsIsomorphisms.reflects + (ExtendedFibration.yoneda R Y ⋙ Over.forget _ _ _) + -- apply (config := {allowSynthFailures:= true}) yoneda.map_isIso + -- simp + have pb : IsPullback ym(h) ym(f) ym(g) ym(k) := sorry + have l := CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq + have li := CategoryTheory.pushforwardPullbackTwoSquare_of_isPullback_isIso pb + have lii := NatIso.isIso_app_of_isIso + (CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq) + ((ExtendedFibration.yoneda R Z ⋙ Over.forget _ _ _).obj A) + -- have : IsIso l := inferInstanceAs $ IsIso $ CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq + sorry +-/ diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan2.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan2.lean new file mode 100644 index 00000000..8eb355c7 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan2.lean @@ -0,0 +1,665 @@ +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 + +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) + +@[simp] +def Local (X : C) : MorphismProperty (R.Over ⊤ X) := fun _ _ f => R f.left + +section pullback + +variable {R} [R.HasPullbacks] {X : C} + +lemma Local.hasPullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : + HasPullback f.left g.left := + MorphismProperty.HasPullbacks.hasPullback (g.left) (f:= f.left) rf + +variable [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] + +def Local.pullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : R.Over ⊤ X := + have := Local.hasPullback g rf + .mk ⊤ ((pullback.snd f.left g.left) ≫ V.hom) + (R.comp_mem _ _ (R.of_isPullback (IsPullback.of_hasPullback f.left g.left) rf) V.prop) + +def Local.pullback.fst {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : + Local.pullback g rf ⟶ U := + have := Local.hasPullback g rf + Over.homMk (Limits.pullback.fst f.left g.left) (by + simp only [pullback, ← Over.w f, Limits.pullback.condition_assoc] + simp) + +def Local.pullback.snd {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : + Local.pullback g rf ⟶ V := + have := Local.hasPullback g rf + Over.homMk (Limits.pullback.snd f.left g.left) + +theorem Local.pullback.isPullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : + IsPullback (Local.pullback.fst g rf) (Local.pullback.snd g rf) f g := by + have := Local.hasPullback g rf + have : (CostructuredArrow.proj (𝟭 C) X).Faithful := CostructuredArrow.proj_faithful -- why? + have : ReflectsLimitsOfShape WalkingCospan (CostructuredArrow.proj (𝟭 C) X) := inferInstance -- why? + apply Functor.reflect_isPullback (Over.forget R ⊤ X ⋙ CostructuredArrow.proj (Functor.id C) X) + simpa [fst, snd, Comma.Hom.hom_left] using IsPullback.of_hasPullback f.left g.left + +variable (X) + +instance : (Local R X).HasPullbacks where + hasPullback {U V W} f g rf := by + have := Local.hasPullback g rf + let pbinC := IsPullback.of_hasPullback f.left g.left + -- let P : R.Over ⊤ X := .mk ⊤ ((pullback.snd f.left g.left) ≫ V.hom) + -- (by apply R.comp_mem + -- sorry) + -- apply IsPullback.hasPullback + sorry + + -- let F := CostructuredArrow.proj (Functor.id C) X + -- have p00: PreservesLimit (cospan f g) (Over.forget R ⊤ X) := sorry + -- have p0 : PreservesLimit (cospan f g ⋙ Over.forget R ⊤ X) + -- (CostructuredArrow.proj (𝟭 C) X) := sorry + + -- have p1 : @PreservesLimit + -- (R.Over ⊤ X) _ C _ WalkingCospan _ (cospan f g) + -- (Over.forget R ⊤ X ⋙ (CostructuredArrow.proj (Functor.id C) X)) := by + -- apply CategoryTheory.Limits.comp_preservesLimit + + -- have p: IsPullback fst.left snd.left f.left g.left := by + -- apply Functor.map_isPullback + -- (Over.forget R ⊤ X ⋙ CostructuredArrow.proj (Functor.id C) X) i + -- simp[Local] at * + -- apply R.of_isPullback p rf + +instance : (Local R X).IsStableUnderBaseChange where + of_isPullback {W V P K} g f fst snd i rf := by + have := Local.hasPullback g rf + rw [← IsPullback.isoIsPullback_hom_snd _ _ i (Local.pullback.isPullback g rf), Local] + exact RespectsIso.precomp _ _ _ (R.of_isPullback (IsPullback.of_hasPullback f.left g.left) rf) + +end pullback + +instance (X : C) [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] : + (Local R X).IsStableUnderBaseChange := sorry + +instance (X : C) : (Local R X).HasObjects := sorry + +instance (X : C) [R.ContainsIdentities] : (Local R X).ContainsIdentities where + id_mem _ := R.id_mem _ + +instance (X : C) [R.IsStableUnderComposition] : + (Local R X).IsStableUnderComposition where + comp_mem _ _ := R.comp_mem _ _ + +abbrev chosenTerminal [R.ContainsIdentities] (X) : R.Over ⊤ X := .mk ⊤ (𝟙 X) (R.id_mem _) + +@[simps!] +protected def Over.post (R : MorphismProperty C) (R' : MorphismProperty C') + [F.PreservesMorphismProperty R R'] (X : C) : R.Over ⊤ X ⥤ R'.Over ⊤ (F.obj X) where + obj X := MorphismProperty.Over.mk ⊤ (F.map X.hom) (F.map_mem _ X.prop) + map f := MorphismProperty.Over.homMk (F.map f.left) (by simp [← F.map_comp]) + map_id := sorry + map_comp := sorry + +instance {R' : MorphismProperty C'} [F.PreservesMorphismProperty R R'] (X : C) : + (Over.post F R R' X).PreservesMorphismProperty (Local R X) (Local R' (F.obj X)) where + map_mem _ := F.map_mem _ + +instance {R' : MorphismProperty C'} [F.PreservesMorphismProperty R R'] [F.PreservesPullbacksOf R] + (X : C) : (Over.post F R R' X).PreservesPullbacksOf (Local R X) where + pb := sorry + +@[simp] +lemma localFunctor_obj_chosenTerminal [R.ContainsIdentities] {R' : MorphismProperty C'} + [R'.ContainsIdentities] [F.PreservesMorphismProperty R R'] (X : C) : + (Over.post F R R' X).obj (R.chosenTerminal X) = R'.chosenTerminal (F.obj X) := by + cat_disch + +instance [R.IsStableUnderBaseChange] {X Y : C} (f : X ⟶ Y) [R.HasPullbacksAlong f] : + (Over.pullback R ⊤ f).PreservesMorphismProperty (Local R Y) (Local R X) := sorry + +instance [R.IsStableUnderBaseChange] {X Y : C} (f : X ⟶ Y) [R.HasPullbacksAlong f] : + (Over.pullback R ⊤ f).PreservesPullbacksOf (Local R Y) := sorry + +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 + +structure RepresentableFibrantChosenPullbacks {X Y : Psh C} (f : X ⟶ Y) + extends RepresentableChosenPullbacks f where + fibrant {Γ : C} (b : y(Γ) ⟶ Y) : R (disp b) + +-- this is a preclan, does not satisfy HasObjects +def ExtendedFibration : MorphismProperty (Psh C) := + fun _ _ f => Nonempty (RepresentableFibrantChosenPullbacks R f) + +instance : (ExtendedFibration R).IsStableUnderBaseChange := sorry + +instance : (ExtendedFibration R).HasPullbacks := sorry + +instance [R.ContainsIdentities] : (ExtendedFibration R).ContainsIdentities where + id_mem _ := sorry + +instance [R.IsStableUnderComposition] : (ExtendedFibration R).IsStableUnderComposition where + comp_mem _ _ hf hg := sorry + +notation:max R"^("F")" => Local (ExtendedFibration R) F + +namespace ExtendedFibration + +variable [R.HasPullbacks] [R.IsStableUnderBaseChange] + +def yonedaRepresentableFibrantChosenPullbacks (X Y : C) (f : X ⟶ Y) (rf : R f) : + R.RepresentableFibrantChosenPullbacks (CategoryTheory.yoneda.map f) := + have h {Γ} (A : Γ ⟶ Y) : HasPullback f A := HasPullbacks.hasPullback _ rf + { ext A := pullback f (yoneda.preimage A) + disp A := pullback.snd _ _ + var _ := ym(pullback.fst _ _) + disp_pullback := sorry + fibrant A := IsStableUnderBaseChange.of_isPullback (IsPullback.of_hasPullback _ _) rf } + +/-- This is the functor `R(X) -> R^(X)`. -/ +@[simps] +protected def yoneda (X : C) : R.Over ⊤ X ⥤ (ExtendedFibration R).Over ⊤ y(X) where + obj A := .mk ⊤ ym(A.hom) ⟨yonedaRepresentableFibrantChosenPullbacks R _ _ _ A.prop⟩ + map {A B} f := Over.homMk ym(f.left) + map_id := sorry + map_comp := sorry + +instance (X : C) : (ExtendedFibration.yoneda R X).Full where + map_surjective {A B} f := + ⟨Over.homMk (yoneda.preimage f.left) (by apply yoneda.map_injective; simp; exact Over.w f), + by cat_disch⟩ + +instance (X : C) : (ExtendedFibration.yoneda R X).Faithful where + map_injective {A B} f f' hf := by + ext + apply yoneda.map_injective + exact Functor.congr_map (Over.forget _ _ _ ⋙ CategoryTheory.Over.forget _) hf + +variable (F : Psh C) + +example [R.IsStableUnderComposition] : (R^(F)).HasPullbacks := inferInstance +example [R.IsStableUnderComposition] : (R^(F)).IsStableUnderBaseChange := inferInstance +example : (R^(F)).HasObjects := inferInstance +example [R.ContainsIdentities] : (R^(F)).ContainsIdentities := inferInstance +example [R.IsStableUnderComposition] : (R^(F)).IsStableUnderComposition := inferInstance + +example (X : C) : (ExtendedFibration.yoneda R X).ReflectsIsomorphisms := inferInstance + +end ExtendedFibration + +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 _) + simp [Comma.Hom.hom] + sorry -- should be pullback pasting. Try it! + +/-- +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 + +/-- 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_ {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) : +-- (pushforwardPullbackTwoSquare h f g k sq).app A = sorry := by +-- apply (Over.forget R ⊤ Y).map_injective +-- simp [pushforwardPullbackTwoSquare, ← Functor.map_comp] +-- rw [pushforward.homEquiv_symm_comp] +-- rw [Equiv.symm_apply_eq] +-- simp +-- erw [Category.id_comp] +-- ext +-- simp +-- ext +-- · simp +-- sorry +-- · sorry + +def pullbackForgetTwoSquare {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks T] + {R : MorphismProperty T} {X Y : T} (f : X ⟶ Y) [R.IsStableUnderBaseChangeAlong f] : + Over.pullback R ⊤ f ⋙ Over.forget R ⊤ X ≅ Over.forget R ⊤ Y ⋙ CategoryTheory.Over.pullback f := + sorry + +@[simps] +def _root_.CategoryTheory.ExponentiableMorphism.pullbackRepresentableByPushforward + {T : Type u} [Category.{v} T] [HasPullbacks T] + {X Y : T} (f : X ⟶ Y) [ExponentiableMorphism f] (h : Over X) : + ((CategoryTheory.Over.pullback f).op ⋙ y(h)).RepresentableBy + ((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.pullbackRepresentableByPushforward 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 _ + +example {T : Type u} [Category.{max u v} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y Z : T} (f : X ⟶ Y) (t : Z ⟶ Y) + [HasPullbacksAlong f] : + HasPullbacksAlong (pullback.fst t f) := + inferInstance + +instance hasPushforwardsAlong_pullback_fst {T : Type u} [Category.{max u v} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y Z : T} (f : X ⟶ Y) (t : Z ⟶ Y) + [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : + R.HasPushforwardsAlong (pullback.fst t f) where + hasPushforward {W} h rh := { + has_representation := ⟨sorry, ⟨sorry⟩⟩ } + +instance isStableUnderPushforwardsAlong_pullback_fst {T : Type u} [Category.{max u v} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y Z : T} (f : X ⟶ Y) {t : Z ⟶ Y} (rt : R t) + [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : + R.IsStableUnderPushforwardsAlong (pullback.fst t f) := + sorry + +def extendedFibration_pushforward {T : Type u} [Category.{max u v} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y : T} (f : X ⟶ Y) + [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] + {W : Psh T} (h : W ⟶ y(X)) (rh : R.RepresentableFibrantChosenPullbacks h) : + R.RepresentableFibrantChosenPullbacks ((ExponentiableMorphism.pushforward ym(f)).obj + (CategoryTheory.Over.mk h)).hom where + ext {Γ} t := by + dsimp at t + -- let E := rf.ext t + -- let d := rf.disp t + -- let v := rf.var t + -- let pf : Over Γ := sorry + sorry + disp := sorry + var := sorry + disp_pullback := sorry + fibrant := sorry + +lemma extendedFibration_pushforward_yoneda {T : Type u} [Category.{max u v} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] {X Y : T} (f : X ⟶ Y) + [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] + {W : Psh T} (h : W ⟶ y(X)) (rh : R.ExtendedFibration h) : + R.ExtendedFibration ((ExponentiableMorphism.pushforward ym(f)).obj + (CategoryTheory.Over.mk h)).hom := + ⟨ sorry ⟩ + +instance {T : Type u} [Category.{max u v} T] (R : MorphismProperty T) + [R.HasPullbacks] [R.IsStableUnderBaseChange] {X Y : T} (f : X ⟶ Y) + [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : + (ExtendedFibration R).IsStableUnderPushforwardsAlong ym(f) := + IsStableUnderPushforwardsAlong.of_respectsIso _ _ + (fun h _ => (ExponentiableMorphism.pushforward ym(f)).obj (CategoryTheory.Over.mk h)) + (fun h rh => extendedFibration_pushforward_yoneda R f h rh) + (fun h _ => ExponentiableMorphism.pullbackRepresentableByPushforward ym(f) (.mk h)) + +theorem pushforwardPullbackTwoSquare_isIso_of_exponentiableMorphism + {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks 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) + [ExponentiableMorphism f] [ExponentiableMorphism g] + [R.IsStableUnderPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong g] + (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by + let α : (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ + Over.forget R ⊤ Y ⟶ + (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ + Over.forget R ⊤ Y := sorry + -- TODO: define α as the following composition. All should be either x.hom for some iso x or + -- a morphism such that IsIso x + -- (R.ExtendedFibration.pushforward g ⋙ Over.pullback R.ExtendedFibration ⊤ k) ⋙ + -- Over.forget R.ExtendedFibration ⊤ Y + -- ≅ R.ExtendedFibration.pushforward g ⋙ Over.pullback R.ExtendedFibration ⊤ k ⋙ Over.forget R.ExtendedFibration ⊤ Y + -- ≅ R.ExtendedFibration.pushforward g ⋙ Over.forget R.ExtendedFibration ⊤ W ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ (R.pushforward g ⋙ ExtendedFibration.yoneda R W) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ (ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g)) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- use `pushforwardPullbackTwoSquare_isIso_extendedFibration` here + -- ≅ ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h) ⋙ (ExtendedFibration R).pushforward f + -- ≅ (ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h)) ⋙ (ExtendedFibration R).pushforward f + -- ≅ (Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X) ⋙ (ExtendedFibration R).pushforward f + -- ≅ Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X ⋙ (ExtendedFibration R).pushforward f + -- ≅ Over.pullback R ⊤ h ⋙ R.pushforward f ⋙ ExtendedFibration.yoneda R Y + -- ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y + have : IsIso α := sorry -- should be automatic by infer_instance. Then remove. + have eq : Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) + (Over.forget R ⊤ Y) = α := sorry + have : IsIso (Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) + (Over.forget R ⊤ Y)) := by rw [eq]; infer_instance + apply NatTrans.isIso_of_whiskerRight_isIso _ (Over.forget _ _ _) + +theorem pushforwardPullbackTwoSquare_isIso_extendedFibration {T : Type u} [Category.{max u 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) + [HasPullbacksAlong f] [HasPullbacksAlong g] + [R.HasPushforwardsAlong f] [R.HasPushforwardsAlong g] + [R.IsStableUnderPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong g] + (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := ExtendedFibration R) ym(h) ym(f) ym(g) ym(k) + (by simp [← Functor.map_comp, pb.w])) := + pushforwardPullbackTwoSquare_isIso_of_exponentiableMorphism + (ExtendedFibration R) ym(h) ym(f) ym(g) ym(k) (Functor.map_isPullback _ pb) + +/-- +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.{max u 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] + (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by + let α : (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ ExtendedFibration.yoneda R Y ⟶ + (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y := sorry + -- TODO: define α as the following composition. All should be either x.hom for some iso x or + -- a morphism such that IsIso x + -- (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ ExtendedFibration.yoneda R Y + -- ≅ R.pushforward g ⋙ Over.pullback R ⊤ k ⋙ ExtendedFibration.yoneda R Y + -- ≅ R.pushforward g ⋙ ExtendedFibration.yoneda R W ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ (R.pushforward g ⋙ ExtendedFibration.yoneda R W) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ (ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g)) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- ≅ ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) + -- use `pushforwardPullbackTwoSquare_isIso_extendedFibration` here + -- ≅ ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h) ⋙ (ExtendedFibration R).pushforward f + -- ≅ (ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h)) ⋙ (ExtendedFibration R).pushforward f + -- ≅ (Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X) ⋙ (ExtendedFibration R).pushforward f + -- ≅ Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X ⋙ (ExtendedFibration R).pushforward f + -- ≅ Over.pullback R ⊤ h ⋙ R.pushforward f ⋙ ExtendedFibration.yoneda R Y + -- ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y + have : IsIso α := sorry -- should be automatic by infer_instance. Then remove. + have eq : Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) + (ExtendedFibration.yoneda R Y) = α := sorry + have : IsIso (Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) + (ExtendedFibration.yoneda R Y)) := by rw [eq]; infer_instance + apply NatTrans.isIso_of_whiskerRight_isIso _ (ExtendedFibration.yoneda R Y) + +/- +theorem pushforwardPullbackTwoSquare_isIso {T : Type u} [Category.{max u 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] + (pb : IsPullback h f g k) : + IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by + apply (config := {allowSynthFailures:= true}) NatIso.isIso_of_isIso_app + intro A + apply (config := {allowSynthFailures:= true}) Functor.ReflectsIsomorphisms.reflects + (ExtendedFibration.yoneda R Y ⋙ Over.forget _ _ _) + -- apply (config := {allowSynthFailures:= true}) yoneda.map_isIso + -- simp + have pb : IsPullback ym(h) ym(f) ym(g) ym(k) := sorry + have l := CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq + have li := CategoryTheory.pushforwardPullbackTwoSquare_of_isPullback_isIso pb + have lii := NatIso.isIso_app_of_isIso + (CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq) + ((ExtendedFibration.yoneda R Z ⋙ Over.forget _ _ _).obj A) + -- have : IsIso l := inferInstanceAs $ IsIso $ CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq + sorry +-/ diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean index 88518bc9..16f2fcc2 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Pushforward.lean @@ -6,6 +6,7 @@ Authors: Joseph Hua import Mathlib.CategoryTheory.Comma.Over.Pullback import Mathlib.CategoryTheory.Adjunction.PartialAdjoint +import Mathlib.CategoryTheory.Limits.FunctorCategory.Basic noncomputable section @@ -16,7 +17,6 @@ namespace CategoryTheory open Category Limits Comonad variable {C : Type u} [Category.{v} C] (X : C) -variable {D : Type u₂} [Category.{v₂} D] variable {S S' : C} (f : S ⟶ S') [inst_hasPullback : ∀ {W} (h : W ⟶ S'), HasPullback h f] diff --git a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean index e59c3642..d7b90725 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean @@ -230,6 +230,30 @@ class IsStableUnderPushforwardsAlong {S S' : T} (q : S ⟶ S') [HasPullbacksAlon 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 diff --git a/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean b/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean index aee6e9a4..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₃ @@ -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 index f65a8854..ef790cc4 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -14,7 +14,7 @@ namespace CategoryTheory open Category Limits MorphismProperty -variable {C : Type u} [Category.{v} C] +variable {C : Type u} [Category.{u} C] namespace MorphismProperty @@ -23,15 +23,15 @@ open NatTrans MorphismProperty.Over in 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 P ⊤ f hPf trivial).counit := by + [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, - Functor.const_obj_obj, map_obj_hom, Equiv.coe_fn_mk, Comma.id_hom, CategoryTheory.Comma.id_left, - id_comp, Adjunction.mk'_counit, Comma.forget_map, homMk_hom, Over.forget_map, Over.homMk_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) @@ -72,7 +72,7 @@ def homEquiv {X : Over B} {Y : R.Over ⊤ I} : ((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 _ + pushforward.homEquiv _ ≃ ((CategoryTheory.Over.map i).obj ((CategoryTheory.Over.pullback p).obj X) ⟶ Y.toComma) := pullback.homEquiv _ @@ -283,11 +283,7 @@ 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 R ⊤ i hi ⟨⟩).isRightAdjoint - --- instance [R.IsStableUnderComposition] {X Y} {f : X ⟶ Y} (hf : R f) : --- Limits.PreservesLimitsOfShape WalkingCospan (MorphismProperty.Over.map ⊤ hf) := --- sorry + (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] @@ -571,19 +567,27 @@ def cartesianNatTrans {E' B' : C} (P : MvPoly R I O E B) (P' : MvPoly R I O E' B -- 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 H I O E B) (P' : MvPoly R H I O E' B') --- (δ : 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 := by --- dsimp [cartesianNatTrans] --- repeat apply IsCartesian.vComp --- · apply IsCartesian.comp --- · apply isCartesian_of_isIso --- · sorry --apply isCartesian_of_isIso +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 + -- sorry -- NOTE: this lemma could be extracted, but `repeat' apply IsCartesian.comp` will unfold past it. -- have : NatTrans.IsCartesian @@ -822,10 +826,9 @@ 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 - sorry --- apply IsCartesian.whiskerLeft --- apply IsCartesian.whiskerRight --- apply MvPoly.isCartesian_cartesianNatTrans + 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 diff --git a/HoTTLean/ForPoly.lean b/HoTTLean/ForPoly.lean index 69614cd3..9136ab2f 100644 --- a/HoTTLean/ForPoly.lean +++ b/HoTTLean/ForPoly.lean @@ -631,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 From 188f221417ed3cbe3e3e8afa39e28dc37edddb0e Mon Sep 17 00:00:00 2001 From: jlh18 Date: Wed, 19 Nov 2025 21:38:49 -0500 Subject: [PATCH 37/95] two approaches --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 61 ++++++++++++++------ 1 file changed, 43 insertions(+), 18 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index c8175510..7af55f85 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -252,11 +252,10 @@ instance pullbackMapTwoSquare_isIso {T : Type u} [Category.{v} T] (R : MorphismP · assumption @[simps] -def _root_.CategoryTheory.ExponentiableMorphism.pullbackRepresentableByPushforward +def _root_.CategoryTheory.ExponentiableMorphism.isPushforward {T : Type u} [Category.{v} T] [HasPullbacks T] {X Y : T} (f : X ⟶ Y) [ExponentiableMorphism f] (h : Over X) : - ((CategoryTheory.Over.pullback f).op ⋙ y(h)).RepresentableBy - ((ExponentiableMorphism.pushforward f).obj h) where + 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] @@ -265,7 +264,7 @@ def _root_.CategoryTheory.ExponentiableMorphism.hasPushforward {X Y : T} (f : X ⟶ Y) [ExponentiableMorphism f] (h : Over X) : HasPushforward f h where has_representation := ⟨(ExponentiableMorphism.pushforward f).obj h, - ⟨ExponentiableMorphism.pullbackRepresentableByPushforward f h⟩⟩ + ⟨ExponentiableMorphism.isPushforward f h⟩⟩ attribute [local instance] ExponentiableMorphism.hasPushforward @@ -298,28 +297,54 @@ def pullbackYonedaIso {T : Type u} [Category.{max u v} T] apply (CategoryTheory.Over.forget _).map_injective apply pullback.hom_ext <;> simp) -abbrev pullbackYonedaTwoSquare {T : Type u} [Category.{max u v} T] +-- APPROACH 1 +/-- Yoneda embedding preserves pushforward. -/ +def isPushforwardYonedaPushforwardObj {T : Type u} [Category.{max u v} T] (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - {X Y : T} (f : X ⟶ Y) : TwoSquare (Over.pullback R ⊤ f) (Over.yoneda R Y) - (Over.yoneda R X) (CategoryTheory.Over.pullback ym(f)) := sorry + {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] + [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] (A : R.Over ⊤ X) : + IsPushforward ym(f) ((Over.yoneda R X).obj A) ((R.pushforward f ⋙ Over.yoneda R Y).obj A) where + homEquiv := sorry + homEquiv_comp := sorry --- def pushforwardYonedaTwoSquare {T : Type u} [Category.{max u v} T] - -- (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - -- {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] - -- [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : - -- TwoSquare (R.pushforward f) (Over.yoneda R X) (Over.yoneda R Y) - -- (ExponentiableMorphism.pushforward ym(f)) := - -- mateEquiv (pullbackPushforwardAdjunction R f) (ExponentiableMorphism.adj y) +-- APPROACH 2 +def pushforwardYonedaTwoSquare {T : Type u} [Category.{max u v} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] + [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : + TwoSquare (R.pushforward f) (Over.yoneda R X) (Over.yoneda R Y) + (ExponentiableMorphism.pushforward ym(f)) := + mateEquiv (pullbackPushforwardAdjunction R f) (ExponentiableMorphism.adj ym(f)) + (pullbackYonedaIso ..).inv + +-- APPROACH 2 +instance {T : Type u} [Category.{max u v} T] + (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] + {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] + [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : + IsIso (R.pushforwardYonedaTwoSquare f) := by + rw [NatTrans.isIso_iff_isIso_app] + intro A + -- apply (config := {allowSynthFailures:= true}) (Over.forget_reflects_iso).reflects + simp [pushforwardYonedaTwoSquare, pullbackYonedaIso] + -- apply (CategoryTheory.forget_reflects_iso) + sorry def pushforwardYonedaIso {T : Type u} [Category.{max u v} 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) := sorry - -- calc R.pushforward f ⋙ Over.yoneda R Y - -- _ ≅ R.pushforwardPartial f ⋙ CategoryTheory.Over.post yoneda := sorry - -- _ ≅ Over.yoneda R X ⋙ ExponentiableMorphism.pushforward ym(f) := sorry + Over.yoneda R X ⋙ ExponentiableMorphism.pushforward ym(f) := + sorry + + -- APPROACH 1: directly define the isomorphism. + -- NatIso.ofComponents (fun A => ((isPushforwardYonedaPushforwardObj ..).uniqueUpToIso + -- (ExponentiableMorphism.isPushforward ..))) + -- (by sorry) + + -- APPROACH 2: define the hom using mateEquiv and show that it satisfies isIso + -- asIso (pushforwardYonedaTwoSquare ..) def pushforwardPullbackIso {T : Type u} [Category.{max u v} T] (R : MorphismProperty T) From 1efb8b67a1a5da1902dcfa4287f3ffa5df9172c7 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Wed, 19 Nov 2025 21:40:19 -0500 Subject: [PATCH 38/95] remove unnecessary lemmas --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index 7af55f85..5fc03e8a 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -64,20 +64,6 @@ end pullback abbrev chosenTerminal [R.ContainsIdentities] (X) : R.Over ⊤ X := .mk ⊤ (𝟙 X) (R.id_mem _) -@[simps!] -protected def Over.post (R : MorphismProperty C) (R' : MorphismProperty C') - [F.PreservesMorphismProperty R R'] (X : C) : R.Over ⊤ X ⥤ R'.Over ⊤ (F.obj X) where - obj X := MorphismProperty.Over.mk ⊤ (F.map X.hom) (F.map_mem _ X.prop) - map f := MorphismProperty.Over.homMk (F.map f.left) (by simp [← F.map_comp]) - map_id := sorry - map_comp := sorry - -@[simp] -lemma localFunctor_obj_chosenTerminal [R.ContainsIdentities] {R' : MorphismProperty C'} - [R'.ContainsIdentities] [F.PreservesMorphismProperty R R'] (X : C) : - (Over.post F R R' X).obj (R.chosenTerminal X) = R'.chosenTerminal (F.obj X) := by - cat_disch - 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 := From dafa2f846928c713f5caf8da404a65f9b88e31aa Mon Sep 17 00:00:00 2001 From: jlh18 Date: Wed, 19 Nov 2025 21:41:35 -0500 Subject: [PATCH 39/95] comment out last theorem --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index 5fc03e8a..04aeff63 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -367,7 +367,7 @@ def pushforwardPullbackIso {T : Type u} [Category.{max u v} T] Functor.isoWhiskerLeft _ (pushforwardYonedaIso ..).symm _ ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ Over.yoneda R Y := (Functor.associator _ _ _).symm -#exit +/- -- The remaining part of this file is an alternative definition of the iso, -- which maybe is not necessary @@ -441,3 +441,4 @@ theorem pushforwardPullbackTwoSquare_isIso {T : Type u} [Category.{max u v} T] sorry rw [eq] infer_instance +-/ From ec47b170743700e3ce070a302a60cd5082740cd6 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Wed, 19 Nov 2025 21:42:19 -0500 Subject: [PATCH 40/95] feat: auto sorry --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 2 -- 1 file changed, 2 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index 04aeff63..19371788 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -76,8 +76,6 @@ variable [R.HasPullbacks] [R.IsStableUnderBaseChange] 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) - map_id := sorry - map_comp := sorry instance (X : C) : (Over.yoneda R X).Full where map_surjective {A B} f := From 2bda8f012dd983bb2fa62c32fc8a61e827afa745 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 20 Nov 2025 08:57:31 -0500 Subject: [PATCH 41/95] a bit progress --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 27 +++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index 19371788..3ff3c4e7 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -191,8 +191,33 @@ theorem isCartesian_pullbackMapTwoSquare {T : Type u} [Category.{v} T] (R : Morp (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 p1 : CategoryTheory.IsPullback + (pullback.fst A.hom f) (pullback.lift (pullback.fst A.hom f ≫ t.left) + (pullback.snd A.hom f) sorry) t.left (pullback.fst B.hom f) := sorry + have i: HasPullback (A.hom ≫ k) g := sorry + have i' : HasPullback (B.hom ≫ k) g := sorry + have p2 : 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) := sorry + have e1 : (pullback.fst A.hom f) = + (pullback.map A.hom f (A.hom ≫ k) g (𝟙 A.left) h k (by simp) sq.symm) ≫ (pullback.fst (A.hom ≫ k) g) := sorry + have e2 : (pullback.fst B.hom f) = + (pullback.map B.hom f (B.hom ≫ k) g (𝟙 B.left) h k (by simp) sq.symm) ≫ (pullback.fst (B.hom ≫ k) g) := sorry + rw[e1,e2] at p1 simp [Comma.Hom.hom] - sorry -- should be pullback pasting. Try it! + rw[CategoryTheory.IsPullback.flip_iff] + have ee : pullback.map A.hom f (A.hom ≫ k) g (𝟙 A.left) h k sorry sorry ≫ pullback.fst (A.hom ≫ k) g = + pullback.fst A.hom f := sorry + + have p := CategoryTheory.IsPullback.of_right (s := p1) sorry (t:= p2) + rw![ee] at p + simp[pullback.map] at p + simp[pullback.map] + apply p + --apply CategoryTheory.IsPullback.of_right (s := p1) _ (t:= p2) + --sorry -- should be pullback pasting. Try it! /-- The Beck-Chevalley two-square `pushforwardPullbackTwoSquare` is a natural isomorphism From f4f113e3dfd6cbab79a07fc086969070a8bc0a95 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 20 Nov 2025 12:04:51 -0500 Subject: [PATCH 42/95] a bit tidying --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 78 ++++++++++++++------ 1 file changed, 56 insertions(+), 22 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index 3ff3c4e7..ff64b4d7 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -191,31 +191,65 @@ theorem isCartesian_pullbackMapTwoSquare {T : Type u} [Category.{v} T] (R : Morp (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 p1 : CategoryTheory.IsPullback - (pullback.fst A.hom f) (pullback.lift (pullback.fst A.hom f ≫ t.left) - (pullback.snd A.hom f) sorry) t.left (pullback.fst B.hom f) := sorry - have i: HasPullback (A.hom ≫ k) g := sorry - have i' : HasPullback (B.hom ≫ k) g := sorry - have p2 : CategoryTheory.IsPullback + have i: HasPullback (A.hom ≫ k) g := + HasPullbacksAlong.hasPullback (A.hom ≫ k) (R.comp_mem _ _ A.prop rk) + have i' : HasPullback (B.hom ≫ k) g := + HasPullbacksAlong.hasPullback (B.hom ≫ k) (R.comp_mem _ _ B.prop rk) + simp [Comma.Hom.hom] + 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) + (f:= B.hom) (g:= f) + (by simp[pullback.condition])) t.left (pullback.fst B.hom f)) + · simp + · simp + · --rw[CategoryTheory.IsPullback.flip_iff] + apply CategoryTheory.IsPullback.of_bot (t:= 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) + · simp + · + sorry + · 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) := sorry - have e1 : (pullback.fst A.hom f) = - (pullback.map A.hom f (A.hom ≫ k) g (𝟙 A.left) h k (by simp) sq.symm) ≫ (pullback.fst (A.hom ≫ k) g) := sorry - have e2 : (pullback.fst B.hom f) = - (pullback.map B.hom f (B.hom ≫ k) g (𝟙 B.left) h k (by simp) sq.symm) ≫ (pullback.fst (B.hom ≫ k) g) := sorry - rw[e1,e2] at p1 - simp [Comma.Hom.hom] - rw[CategoryTheory.IsPullback.flip_iff] - have ee : pullback.map A.hom f (A.hom ≫ k) g (𝟙 A.left) h k sorry sorry ≫ pullback.fst (A.hom ≫ k) g = - pullback.fst A.hom f := sorry - - have p := CategoryTheory.IsPullback.of_right (s := p1) sorry (t:= p2) - rw![ee] at p - simp[pullback.map] at p - simp[pullback.map] - apply p + (pullback.fst (B.hom ≫ k) g) ) + · simp[pullback.map] + · apply CategoryTheory.IsPullback.of_bot (t:= 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) + · sorry + · simp + · exact (IsPullback.of_hasPullback (A.hom ≫ k) g) + · sorry + -- rw[CategoryTheory.IsPullback.flip_iff] + -- have ee : pullback.map A.hom f (A.hom ≫ k) g (𝟙 A.left) h k sorry sorry ≫ pullback.fst (A.hom ≫ k) g = + -- pullback.fst A.hom f := sorry + + -- have eee : + -- (pullback.map A.hom f (A.hom ≫ k) g (𝟙 A.left) h k sorry sorry) ≫ + -- (pullback.lift (pullback.fst (A.hom ≫ k) g ≫ t.left) (pullback.snd (A.hom ≫ k) g) sorry) = + -- (pullback.lift (pullback.fst A.hom f ≫ t.left) (pullback.snd A.hom f) sorry) ≫ + -- (pullback.map B.hom f (B.hom ≫ k) g (𝟙 B.left) h k sorry sorry) := sorry + -- -- apply CategoryTheory.IsPullback.of_right (t:= p2) (p := eee) + -- sorry + + -- have p := CategoryTheory.IsPullback.of_right (s := p1) (by sorry) (t:= p2) + -- rw![ee] at p + -- simp[pullback.map] at p + -- simp[pullback.map] + -- apply p + + + + --apply CategoryTheory.IsPullback.of_right (s := p1) _ (t:= p2) --sorry -- should be pullback pasting. Try it! From 9869d80c825ec8b99a4f080a8fa6f5b9c1fa9186 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 20 Nov 2025 12:13:52 -0500 Subject: [PATCH 43/95] isCartesian_pullbackMapTwoSquare --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 43 +++++--------------- 1 file changed, 11 insertions(+), 32 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index ff64b4d7..14e161b0 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -191,13 +191,13 @@ theorem isCartesian_pullbackMapTwoSquare {T : Type u} [Category.{v} T] (R : Morp (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 i: HasPullback (A.hom ≫ k) g := + have : HasPullback (A.hom ≫ k) g := HasPullbacksAlong.hasPullback (A.hom ≫ k) (R.comp_mem _ _ A.prop rk) - have i' : HasPullback (B.hom ≫ k) g := + have : HasPullback (B.hom ≫ k) g := HasPullbacksAlong.hasPullback (B.hom ≫ k) (R.comp_mem _ _ B.prop rk) - simp [Comma.Hom.hom] 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)) + 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) @@ -207,15 +207,14 @@ theorem isCartesian_pullbackMapTwoSquare {T : Type u} [Category.{v} T] (R : Morp (by simp[pullback.condition])) t.left (pullback.fst B.hom f)) · simp · simp - · --rw[CategoryTheory.IsPullback.flip_iff] - apply CategoryTheory.IsPullback.of_bot (t:= IsPullback.of_hasPullback B.hom f) + · apply CategoryTheory.IsPullback.of_bot (t:= 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) · simp - · - sorry + · simp[pullback.map] + ext <;> simp · convert_to (CategoryTheory.IsPullback (pullback.fst (A.hom ≫ k) g) @@ -224,34 +223,14 @@ theorem isCartesian_pullbackMapTwoSquare {T : Type u} [Category.{v} T] (R : Morp (pullback.fst (B.hom ≫ k) g) ) · simp[pullback.map] · apply CategoryTheory.IsPullback.of_bot (t:= 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) - · sorry + · 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) - · sorry - -- rw[CategoryTheory.IsPullback.flip_iff] - -- have ee : pullback.map A.hom f (A.hom ≫ k) g (𝟙 A.left) h k sorry sorry ≫ pullback.fst (A.hom ≫ k) g = - -- pullback.fst A.hom f := sorry - - -- have eee : - -- (pullback.map A.hom f (A.hom ≫ k) g (𝟙 A.left) h k sorry sorry) ≫ - -- (pullback.lift (pullback.fst (A.hom ≫ k) g ≫ t.left) (pullback.snd (A.hom ≫ k) g) sorry) = - -- (pullback.lift (pullback.fst A.hom f ≫ t.left) (pullback.snd A.hom f) sorry) ≫ - -- (pullback.map B.hom f (B.hom ≫ k) g (𝟙 B.left) h k sorry sorry) := sorry - -- -- apply CategoryTheory.IsPullback.of_right (t:= p2) (p := eee) - -- sorry - - -- have p := CategoryTheory.IsPullback.of_right (s := p1) (by sorry) (t:= p2) - -- rw![ee] at p - -- simp[pullback.map] at p - -- simp[pullback.map] - -- apply p - - + · simp - --apply CategoryTheory.IsPullback.of_right (s := p1) _ (t:= p2) - --sorry -- should be pullback pasting. Try it! /-- The Beck-Chevalley two-square `pushforwardPullbackTwoSquare` is a natural isomorphism From 2f43ecad033b7f6b19d29a3f8b01dea349b2e05e Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 20 Nov 2025 12:22:42 -0500 Subject: [PATCH 44/95] golf: isCartesian_pullbackMapTwoSquare --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 45 ++++++++------------ 1 file changed, 17 insertions(+), 28 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index 14e161b0..d1f78fec 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -191,46 +191,35 @@ theorem isCartesian_pullbackMapTwoSquare {T : Type u} [Category.{v} T] (R : Morp (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 : HasPullback (A.hom ≫ k) g := - HasPullbacksAlong.hasPullback (A.hom ≫ k) (R.comp_mem _ _ A.prop rk) - have : HasPullback (B.hom ≫ k) g := - HasPullbacksAlong.hasPullback (B.hom ≫ k) (R.comp_mem _ _ B.prop rk) - rw[CategoryTheory.IsPullback.flip_iff] + 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) - (f:= B.hom) (g:= f) - (by simp[pullback.condition])) t.left (pullback.fst B.hom f)) + · 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 (t:= 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) + · 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 - · simp[pullback.map] - ext <;> 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 (t:= 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) + · 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 From 8ca5c3614436837ea736c889881850d892b1ee44 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 20 Nov 2025 13:36:31 -0500 Subject: [PATCH 45/95] start making Yoneda stuff --- .../CategoryTheory/Comma/Presheaf/Basic.lean | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean new file mode 100644 index 00000000..4498cb30 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean @@ -0,0 +1,25 @@ +import Mathlib.CategoryTheory.Comma.Presheaf.Basic + +namespace CategoryTheory + +open Category Opposite + +universe w v u + +variable {C : Type u} [Category.{v} C] {A : C} + + +def CostructuredArrowYonedaOver : + CostructuredArrow yoneda (yoneda.obj (A)) ≅ CategoryTheory.Over A where + hom X := Over.mk ((CategoryTheory.Yoneda.fullyFaithful).preimage X.hom) + inv X := CostructuredArrow.mk (yoneda.map X.hom) + + +def PresheafCostructuredArrowYonedaOver : + CategoryTheory.Over (yoneda.obj (A)) ≅ + (CategoryTheory.Over A)ᵒᵖ ⥤ Type v := + + sorry + + +end CategoryTheory From e49b07cb6ce32a3fbe4e82cc4e1779f00e96f9fe Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 20 Nov 2025 21:49:20 -0500 Subject: [PATCH 46/95] defining equiv --- .../CategoryTheory/Comma/Presheaf/Basic.lean | 84 +++++++++++++++++-- 1 file changed, 78 insertions(+), 6 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean index 4498cb30..c734d1ad 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean @@ -9,17 +9,89 @@ universe w v u variable {C : Type u} [Category.{v} C] {A : C} +-- def CostructuredArrowYonedaOver : +-- CostructuredArrow yoneda (yoneda.obj (A)) ≅ CategoryTheory.Over A where +-- hom X := Over.mk ((CategoryTheory.Yoneda.fullyFaithful).preimage X.hom) +-- inv X := CostructuredArrow.mk (yoneda.map X.hom) + +def CostructuredArrowYonedaOver_functor : CostructuredArrow yoneda (yoneda.obj A) ⥤ Over A where + obj X := Over.mk ((CategoryTheory.Yoneda.fullyFaithful).preimage X.hom) + map {X Y} f := by + have w := f.w + have e: + (yoneda.map f.left ≫ Y.hom).app (op X.left) = + (X.hom ≫ (Functor.fromPUnit (yoneda.obj A)).map f.right).app (op X.left) := by + simp[w] + simp[- CommaMorphism.w] at e + apply Over.homMk f.left (by simp[CategoryTheory.Yoneda.fullyFaithful_preimage,← e]) + + + +def CostructuredArrowYonedaOver_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 + + +def CostructuredArrowYonedaOver_unitIso : + 𝟭 (CostructuredArrow yoneda (yoneda.obj A)) ≅ + CostructuredArrowYonedaOver_functor ⋙ CostructuredArrowYonedaOver_inverse + where + hom := { + app X := by + dsimp + simp[CostructuredArrowYonedaOver_inverse,CostructuredArrowYonedaOver_functor] + exact (𝟙 _) + naturality := sorry + } + inv := sorry + hom_inv_id := sorry + inv_hom_id := sorry + + def CostructuredArrowYonedaOver : - CostructuredArrow yoneda (yoneda.obj (A)) ≅ CategoryTheory.Over A where - hom X := Over.mk ((CategoryTheory.Yoneda.fullyFaithful).preimage X.hom) - inv X := CostructuredArrow.mk (yoneda.map X.hom) + CostructuredArrow yoneda (yoneda.obj (A)) ≌ CategoryTheory.Over A where + functor := CostructuredArrowYonedaOver_functor + inverse := CostructuredArrowYonedaOver_inverse + unitIso := { + hom := sorry + inv := sorry + hom_inv_id := sorry + inv_hom_id := sorry + } + counitIso := sorry + functor_unitIso_comp := sorry +#check overEquivPresheafCostructuredArrow +#check CostructuredArrow.toOverCompOverEquivPresheafCostructuredArrow + +def PresheafCostructuredArrowYonedaOver_aux: + (CostructuredArrow yoneda (yoneda.obj (A)))ᵒᵖ ⥤ Type v ≌ + (CategoryTheory.Over A)ᵒᵖ ⥤ Type v := by + apply Equivalence.congrLeft + apply CategoryTheory.Equivalence.op + exact CostructuredArrowYonedaOver + + + /- + @CostructuredArrow C inst✝ (Cᵒᵖ ⥤ Type v) Functor.category yoneda (yoneda.obj A) : Type (max u v) + @CostructuredArrow C inst✝ (Cᵒᵖ ⥤ Type v) Functor.category yoneda (yoneda.obj A) : Type (max u v) + + @Over C inst✝ A : Type (max u v) + @Over C inst✝ A : Type (max u v) + -/ + +--CategoryTheory.NatIso.op def PresheafCostructuredArrowYonedaOver : - CategoryTheory.Over (yoneda.obj (A)) ≅ - (CategoryTheory.Over A)ᵒᵖ ⥤ Type v := + CategoryTheory.Over (yoneda.obj (A)) ≌ + ((CategoryTheory.Over A)ᵒᵖ ⥤ Type v) := + Equivalence.trans (overEquivPresheafCostructuredArrow (yoneda.obj (A))) + (PresheafCostructuredArrowYonedaOver_aux) + -- need A equiv B -> A => Type equiv B => Type + -- need A equiv B -> Aᵒᵖ equiv Bᵒᵖ + + - sorry end CategoryTheory From 1364ddaf9b06147a41ca76e4d2299306b0f9f4f4 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Fri, 21 Nov 2025 10:40:18 -0500 Subject: [PATCH 47/95] backup before starting deleting --- .../CategoryTheory/Comma/Presheaf/Basic.lean | 102 ++++++++++++++++-- 1 file changed, 91 insertions(+), 11 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean index c734d1ad..271a2c6c 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean @@ -1,4 +1,5 @@ import Mathlib.CategoryTheory.Comma.Presheaf.Basic +import Mathlib.Tactic.DepRewrite namespace CategoryTheory @@ -31,35 +32,114 @@ def CostructuredArrowYonedaOver_inverse : Over A ⥤ CostructuredArrow yoneda (y obj X := CostructuredArrow.mk (yoneda.map X.hom) map {X Y} f := CostructuredArrow.homMk f.left +lemma CostructuredArrowYonedaOver_inverse_functor : + CostructuredArrowYonedaOver_inverse (A := A) ⋙ CostructuredArrowYonedaOver_functor = Functor.id _ + := sorry + + + +lemma CostructuredArrowYonedaOver_functor_inverse : + CostructuredArrowYonedaOver_functor ⋙ CostructuredArrowYonedaOver_inverse (A := A) = Functor.id _ + := sorry def CostructuredArrowYonedaOver_unitIso : + 𝟭 (CostructuredArrow yoneda (yoneda.obj A)) ≅ + CostructuredArrowYonedaOver_functor ⋙ CostructuredArrowYonedaOver_inverse := + eqToIso CostructuredArrowYonedaOver_functor_inverse.symm + +def CostructuredArrowYonedaOver_unitIso1 : 𝟭 (CostructuredArrow yoneda (yoneda.obj A)) ≅ CostructuredArrowYonedaOver_functor ⋙ CostructuredArrowYonedaOver_inverse where hom := { + app X := by + dsimp + simp[CostructuredArrowYonedaOver_inverse,CostructuredArrowYonedaOver_functor] + exact (𝟙 _) + naturality := by + intro X Y f + rw! (castMode :=.all)[CostructuredArrowYonedaOver_functor_inverse] + + sorry + } + inv := { app X := by dsimp simp[CostructuredArrowYonedaOver_inverse,CostructuredArrowYonedaOver_functor] exact (𝟙 _) naturality := sorry } - inv := sorry - hom_inv_id := sorry - inv_hom_id := sorry + +#check NatIso.ofComponents +#check Iso.refl + +#check Over.isoMk +#check eqToIso + +def CostructuredArrowYonedaOver_counitIso : + CostructuredArrowYonedaOver_inverse ⋙ CostructuredArrowYonedaOver_functor (A:= A) + ≅ 𝟭 _ := eqToIso CostructuredArrowYonedaOver_inverse_functor + +-- def CostructuredArrowYonedaOver_counitIso1 : +-- CostructuredArrowYonedaOver_inverse ⋙ CostructuredArrowYonedaOver_functor (A:= A) +-- ≅ 𝟭 _ +-- where +-- hom := { +-- app X := by +-- dsimp +-- simp[CostructuredArrowYonedaOver_inverse,CostructuredArrowYonedaOver_functor] +-- exact (𝟙 _) +-- naturality := by +-- intro X Y f +-- rw! (castMode := .all)[CostructuredArrowYonedaOver_inverse_functor] +-- simp only[CostructuredArrowYonedaOver_inverse_functor] +-- sorry +-- } +-- inv := { +-- app X := by +-- dsimp +-- simp[CostructuredArrowYonedaOver_inverse,CostructuredArrowYonedaOver_functor] +-- exact (𝟙 _) +-- naturality := sorry +-- } + + +-- section +-- universe v₁ v₂ v₃ v₄ v₅ v₆ u₁ u₂ u₃ u₄ u₅ u₆ +-- variable {C : Type u₁} [Category.{v₁} C] {D : Type u₂} [Category.{v₂} D] +-- (S : C ⥤ D) (T : D) (X : CostructuredArrow S T) +-- lemma cast_left {Ty : Type _ }(e: CostructuredArrow S T = Ty): +-- (cast e (𝟙 X)).left = cast _ (𝟙 X).left := sorry + + + +-- end + +#check NatIso.ofComponents + +-- def CostructuredArrowYonedaOver1 : +-- CostructuredArrow yoneda (yoneda.obj (A)) ≌ CategoryTheory.Over A := by + +-- apply NatIso.ofComponents sorry sorry def CostructuredArrowYonedaOver : CostructuredArrow yoneda (yoneda.obj (A)) ≌ CategoryTheory.Over A where functor := CostructuredArrowYonedaOver_functor inverse := CostructuredArrowYonedaOver_inverse - unitIso := { - hom := sorry - inv := sorry - hom_inv_id := sorry - inv_hom_id := sorry - } - counitIso := sorry - functor_unitIso_comp := sorry + unitIso := CostructuredArrowYonedaOver_unitIso + counitIso := CostructuredArrowYonedaOver_counitIso + functor_unitIso_comp X := by + simp[CostructuredArrowYonedaOver_functor,CostructuredArrowYonedaOver_unitIso, + CostructuredArrowYonedaOver_counitIso] + ext + + -- have e: (CostructuredArrow.mk (Yoneda.fullyFaithful.preimage X.hom) + -- : CostructuredArrow (𝟭 C) A) = yoneda.map X.hom:= sorry + simp[Over.mk] + + + #check overEquivPresheafCostructuredArrow #check CostructuredArrow.toOverCompOverEquivPresheafCostructuredArrow From 9126c67e22db5db7fc11897d4abe5a664fcbbb16 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Fri, 21 Nov 2025 11:06:10 -0500 Subject: [PATCH 48/95] defined yoneda equiv --- .../CategoryTheory/Comma/Presheaf/Basic1.lean | 103 ++++++++++++++++++ 1 file changed, 103 insertions(+) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic1.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic1.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic1.lean new file mode 100644 index 00000000..cc40b483 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic1.lean @@ -0,0 +1,103 @@ +import Mathlib.CategoryTheory.Comma.Presheaf.Basic +import Mathlib.Tactic.DepRewrite + +namespace CategoryTheory + +open Category Opposite + +universe w v u + +variable {C : Type u} [Category.{v} C] {A : C} + +def CostructuredArrowYonedaOver_functor : CostructuredArrow yoneda (yoneda.obj A) ⥤ Over A where + obj X := Over.mk ((CategoryTheory.Yoneda.fullyFaithful).preimage X.hom) + map {X Y} f := by + have w := f.w + have e: + (yoneda.map f.left ≫ Y.hom).app (op X.left) = + (X.hom ≫ (Functor.fromPUnit (yoneda.obj A)).map f.right).app (op X.left) := by + simp[w] + simp[- CommaMorphism.w] at e + apply Over.homMk f.left (by simp[CategoryTheory.Yoneda.fullyFaithful_preimage,← e]) + + + +def CostructuredArrowYonedaOver_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 + +lemma CostructuredArrowYonedaOver_inverse_functor : + CostructuredArrowYonedaOver_inverse (A := A) ⋙ CostructuredArrowYonedaOver_functor = Functor.id _ + := by + fapply Functor.ext + · intro X + simp only [CostructuredArrowYonedaOver_inverse, Functor.id_obj, + CostructuredArrowYonedaOver_functor, Over.mk, Functor.comp_obj, CostructuredArrow.mk_left, + CostructuredArrow.mk_hom_eq_self, Functor.FullyFaithful.preimage_map] + rfl + intro X Y f + simp[CostructuredArrowYonedaOver_inverse, + CostructuredArrowYonedaOver_functor] + ext + simp + + + +lemma CostructuredArrowYonedaOver_functor_inverse : + CostructuredArrowYonedaOver_functor ⋙ CostructuredArrowYonedaOver_inverse (A := A) = Functor.id _ + := by + fapply Functor.ext + · intro X + simp[CostructuredArrowYonedaOver_inverse, + CostructuredArrowYonedaOver_functor] + apply CostructuredArrow.eq_mk + intro X Y f + simp[CostructuredArrowYonedaOver_inverse, + CostructuredArrowYonedaOver_functor] + + + +def CostructuredArrowYonedaOver_unitIso : + 𝟭 (CostructuredArrow yoneda (yoneda.obj A)) ≅ + CostructuredArrowYonedaOver_functor ⋙ CostructuredArrowYonedaOver_inverse := + eqToIso CostructuredArrowYonedaOver_functor_inverse.symm + +def CostructuredArrowYonedaOver_counitIso : + CostructuredArrowYonedaOver_inverse ⋙ CostructuredArrowYonedaOver_functor (A:= A) + ≅ 𝟭 _ := eqToIso CostructuredArrowYonedaOver_inverse_functor + + + +def CostructuredArrowYonedaOver : + CostructuredArrow yoneda (yoneda.obj (A)) ≌ CategoryTheory.Over A where + functor := CostructuredArrowYonedaOver_functor + inverse := CostructuredArrowYonedaOver_inverse + unitIso := CostructuredArrowYonedaOver_unitIso + counitIso := CostructuredArrowYonedaOver_counitIso + functor_unitIso_comp X := by + simp[CostructuredArrowYonedaOver_functor,CostructuredArrowYonedaOver_unitIso, + CostructuredArrowYonedaOver_counitIso] + ext + simp[Over.mk] + + + +def PresheafCostructuredArrowYonedaOver_aux: + (CostructuredArrow yoneda (yoneda.obj (A)))ᵒᵖ ⥤ Type v ≌ + (CategoryTheory.Over A)ᵒᵖ ⥤ Type v := by + apply Equivalence.congrLeft + apply CategoryTheory.Equivalence.op + exact CostructuredArrowYonedaOver + + +def PresheafCostructuredArrowYonedaOver : + CategoryTheory.Over (yoneda.obj (A)) ≌ + ((CategoryTheory.Over A)ᵒᵖ ⥤ Type v) := + Equivalence.trans (overEquivPresheafCostructuredArrow (yoneda.obj (A))) + (PresheafCostructuredArrowYonedaOver_aux) + + + + + +end CategoryTheory From ddfc2b605b850fda3f6240c6ec36697f98e1df32 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Fri, 21 Nov 2025 11:50:48 -0500 Subject: [PATCH 49/95] defined equiv --- .../CategoryTheory/Comma/Presheaf/Basic.lean | 134 +++--------------- 1 file changed, 18 insertions(+), 116 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean index 271a2c6c..983d2070 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean @@ -10,118 +10,39 @@ universe w v u variable {C : Type u} [Category.{v} C] {A : C} --- def CostructuredArrowYonedaOver : --- CostructuredArrow yoneda (yoneda.obj (A)) ≅ CategoryTheory.Over A where --- hom X := Over.mk ((CategoryTheory.Yoneda.fullyFaithful).preimage X.hom) --- inv X := CostructuredArrow.mk (yoneda.map X.hom) - +@[simps!] def CostructuredArrowYonedaOver_functor : CostructuredArrow yoneda (yoneda.obj A) ⥤ Over A where obj X := Over.mk ((CategoryTheory.Yoneda.fullyFaithful).preimage X.hom) - map {X Y} f := by - have w := f.w - have e: - (yoneda.map f.left ≫ Y.hom).app (op X.left) = - (X.hom ≫ (Functor.fromPUnit (yoneda.obj A)).map f.right).app (op X.left) := by - simp[w] - simp[- CommaMorphism.w] at e - apply Over.homMk f.left (by simp[CategoryTheory.Yoneda.fullyFaithful_preimage,← e]) - + 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 [CategoryTheory.Yoneda.fullyFaithful_preimage]) +@[simps!] def CostructuredArrowYonedaOver_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 -lemma CostructuredArrowYonedaOver_inverse_functor : - CostructuredArrowYonedaOver_inverse (A := A) ⋙ CostructuredArrowYonedaOver_functor = Functor.id _ - := sorry - - +def CostructuredArrowYonedaOver_unitIso : + 𝟭 (CostructuredArrow yoneda (yoneda.obj A)) ≅ + CostructuredArrowYonedaOver_functor ⋙ CostructuredArrowYonedaOver_inverse := + NatIso.ofComponents (fun X => Comma.isoMk (Iso.refl _) (Iso.refl _) + (by + simp + ext + simp[CategoryTheory.Yoneda.fullyFaithful_preimage]) ) -lemma CostructuredArrowYonedaOver_functor_inverse : - CostructuredArrowYonedaOver_functor ⋙ CostructuredArrowYonedaOver_inverse (A := A) = Functor.id _ - := sorry -def CostructuredArrowYonedaOver_unitIso : - 𝟭 (CostructuredArrow yoneda (yoneda.obj A)) ≅ - CostructuredArrowYonedaOver_functor ⋙ CostructuredArrowYonedaOver_inverse := - eqToIso CostructuredArrowYonedaOver_functor_inverse.symm - -def CostructuredArrowYonedaOver_unitIso1 : - 𝟭 (CostructuredArrow yoneda (yoneda.obj A)) ≅ - CostructuredArrowYonedaOver_functor ⋙ CostructuredArrowYonedaOver_inverse - where - hom := { - app X := by - dsimp - simp[CostructuredArrowYonedaOver_inverse,CostructuredArrowYonedaOver_functor] - exact (𝟙 _) - naturality := by - intro X Y f - rw! (castMode :=.all)[CostructuredArrowYonedaOver_functor_inverse] - - sorry - } - inv := { - app X := by - dsimp - simp[CostructuredArrowYonedaOver_inverse,CostructuredArrowYonedaOver_functor] - exact (𝟙 _) - naturality := sorry - } - -#check NatIso.ofComponents -#check Iso.refl - -#check Over.isoMk -#check eqToIso def CostructuredArrowYonedaOver_counitIso : CostructuredArrowYonedaOver_inverse ⋙ CostructuredArrowYonedaOver_functor (A:= A) - ≅ 𝟭 _ := eqToIso CostructuredArrowYonedaOver_inverse_functor - --- def CostructuredArrowYonedaOver_counitIso1 : --- CostructuredArrowYonedaOver_inverse ⋙ CostructuredArrowYonedaOver_functor (A:= A) --- ≅ 𝟭 _ --- where --- hom := { --- app X := by --- dsimp --- simp[CostructuredArrowYonedaOver_inverse,CostructuredArrowYonedaOver_functor] --- exact (𝟙 _) --- naturality := by --- intro X Y f --- rw! (castMode := .all)[CostructuredArrowYonedaOver_inverse_functor] --- simp only[CostructuredArrowYonedaOver_inverse_functor] --- sorry --- } --- inv := { --- app X := by --- dsimp --- simp[CostructuredArrowYonedaOver_inverse,CostructuredArrowYonedaOver_functor] --- exact (𝟙 _) --- naturality := sorry --- } - - --- section --- universe v₁ v₂ v₃ v₄ v₅ v₆ u₁ u₂ u₃ u₄ u₅ u₆ --- variable {C : Type u₁} [Category.{v₁} C] {D : Type u₂} [Category.{v₂} D] --- (S : C ⥤ D) (T : D) (X : CostructuredArrow S T) --- lemma cast_left {Ty : Type _ }(e: CostructuredArrow S T = Ty): --- (cast e (𝟙 X)).left = cast _ (𝟙 X).left := sorry - + ≅ 𝟭 _ := + NatIso.ofComponents (fun X => Over.isoMk (Iso.refl _)) --- end - -#check NatIso.ofComponents - --- def CostructuredArrowYonedaOver1 : --- CostructuredArrow yoneda (yoneda.obj (A)) ≌ CategoryTheory.Over A := by - --- apply NatIso.ofComponents sorry sorry - def CostructuredArrowYonedaOver : CostructuredArrow yoneda (yoneda.obj (A)) ≌ CategoryTheory.Over A where @@ -133,17 +54,9 @@ def CostructuredArrowYonedaOver : simp[CostructuredArrowYonedaOver_functor,CostructuredArrowYonedaOver_unitIso, CostructuredArrowYonedaOver_counitIso] ext - - -- have e: (CostructuredArrow.mk (Yoneda.fullyFaithful.preimage X.hom) - -- : CostructuredArrow (𝟭 C) A) = yoneda.map X.hom:= sorry simp[Over.mk] - - -#check overEquivPresheafCostructuredArrow -#check CostructuredArrow.toOverCompOverEquivPresheafCostructuredArrow - def PresheafCostructuredArrowYonedaOver_aux: (CostructuredArrow yoneda (yoneda.obj (A)))ᵒᵖ ⥤ Type v ≌ (CategoryTheory.Over A)ᵒᵖ ⥤ Type v := by @@ -152,23 +65,12 @@ def PresheafCostructuredArrowYonedaOver_aux: exact CostructuredArrowYonedaOver - /- - @CostructuredArrow C inst✝ (Cᵒᵖ ⥤ Type v) Functor.category yoneda (yoneda.obj A) : Type (max u v) - @CostructuredArrow C inst✝ (Cᵒᵖ ⥤ Type v) Functor.category yoneda (yoneda.obj A) : Type (max u v) - - @Over C inst✝ A : Type (max u v) - @Over C inst✝ A : Type (max u v) - -/ - ---CategoryTheory.NatIso.op def PresheafCostructuredArrowYonedaOver : CategoryTheory.Over (yoneda.obj (A)) ≌ ((CategoryTheory.Over A)ᵒᵖ ⥤ Type v) := Equivalence.trans (overEquivPresheafCostructuredArrow (yoneda.obj (A))) (PresheafCostructuredArrowYonedaOver_aux) - -- need A equiv B -> A => Type equiv B => Type - -- need A equiv B -> Aᵒᵖ equiv Bᵒᵖ From 0d23668d66d3645658a956ecd2377fabe93c4d35 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 20 Nov 2025 13:59:57 -0500 Subject: [PATCH 50/95] feat: NatIso.yonedaMk --- HoTTLean/ForMathlib.lean | 19 +++++++++++++------ HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 10 +++++++--- 2 files changed, 20 insertions(+), 9 deletions(-) diff --git a/HoTTLean/ForMathlib.lean b/HoTTLean/ForMathlib.lean index 891acc25..cf867ebd 100644 --- a/HoTTLean/ForMathlib.lean +++ b/HoTTLean/ForMathlib.lean @@ -539,6 +539,7 @@ variable {C : Type u₁} [SmallCategory C] {F G : Cᵒᵖ ⥤ Type u₁} 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)`. @@ -547,20 +548,26 @@ 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 + (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, yonedaIsoMap] + simp [yonedaMk, yonedaIso] + +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) namespace Functor diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index d1f78fec..b9c10424 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -314,9 +314,8 @@ def isPushforwardYonedaPushforwardObj {T : Type u} [Category.{max u v} T] (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] (A : R.Over ⊤ X) : - IsPushforward ym(f) ((Over.yoneda R X).obj A) ((R.pushforward f ⋙ Over.yoneda R Y).obj A) where - homEquiv := sorry - homEquiv_comp := sorry + IsPushforward ym(f) ((Over.yoneda R X).obj A) ((R.pushforward f ⋙ Over.yoneda R Y).obj A) := + sorry -- APPROACH 2 def pushforwardYonedaTwoSquare {T : Type u} [Category.{max u v} T] @@ -357,6 +356,11 @@ def pushforwardYonedaIso {T : Type u} [Category.{max u v} T] -- APPROACH 2: define the hom using mateEquiv and show that it satisfies isIso -- asIso (pushforwardYonedaTwoSquare ..) + + -- APPROACH 3: + -- use PresheafCostructruedArrowYonedaOver to land in Psh (Over Y) + -- then use `NatIso.yonedaMk` + def pushforwardPullbackIso {T : Type u} [Category.{max u v} T] (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] From fc71ae3e0687cf62127a7fdc725aad40c36bd0e1 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 21 Nov 2025 11:50:55 -0500 Subject: [PATCH 51/95] dj. --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index b9c10424..f4b584ae 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -339,13 +339,14 @@ instance {T : Type u} [Category.{max u v} T] simp [pushforwardYonedaTwoSquare, pullbackYonedaIso] -- apply (CategoryTheory.forget_reflects_iso) sorry - +#check Functor.preimageIso def pushforwardYonedaIso {T : Type u} [Category.{max u v} 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) := + NatIso.ofComponents (fun A => sorry) sorry -- APPROACH 1: directly define the isomorphism. From 30158e3239e95733f6b6ea93682ef4ce3eb79902 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 21 Nov 2025 12:05:00 -0500 Subject: [PATCH 52/95] golfs --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 3 + .../CategoryTheory/Comma/Presheaf/Basic.lean | 69 ++++-------- .../CategoryTheory/Comma/Presheaf/Basic1.lean | 103 ------------------ 3 files changed, 27 insertions(+), 148 deletions(-) delete mode 100644 HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic1.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index f4b584ae..e47d4fdc 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -11,6 +11,7 @@ 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 universe w v u v₁ u₁ @@ -339,6 +340,8 @@ instance {T : Type u} [Category.{max u v} T] simp [pushforwardYonedaTwoSquare, pullbackYonedaIso] -- apply (CategoryTheory.forget_reflects_iso) sorry + +#check overYonedaEquivPresheafOver #check Functor.preimageIso def pushforwardYonedaIso {T : Type u} [Category.{max u v} T] (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean index 983d2070..e800a31d 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean @@ -9,71 +9,50 @@ universe w v u variable {C : Type u} [Category.{v} C] {A : C} +attribute [local simp] CategoryTheory.Yoneda.fullyFaithful_preimage + +namespace costructuredArrowYonedaEquivOver @[simps!] -def CostructuredArrowYonedaOver_functor : CostructuredArrow yoneda (yoneda.obj A) ⥤ Over A where +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 [CategoryTheory.Yoneda.fullyFaithful_preimage]) - + simpa) @[simps!] -def CostructuredArrowYonedaOver_inverse : Over A ⥤ CostructuredArrow yoneda (yoneda.obj A) where +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 -def CostructuredArrowYonedaOver_unitIso : - 𝟭 (CostructuredArrow yoneda (yoneda.obj A)) ≅ - CostructuredArrowYonedaOver_functor ⋙ CostructuredArrowYonedaOver_inverse := +@[simps!] +def unitIso : 𝟭 (CostructuredArrow yoneda (yoneda.obj A)) ≅ functor ⋙ inverse := NatIso.ofComponents (fun X => Comma.isoMk (Iso.refl _) (Iso.refl _) - (by - simp - ext - simp[CategoryTheory.Yoneda.fullyFaithful_preimage]) ) - + (by cat_disch)) - -def CostructuredArrowYonedaOver_counitIso : - CostructuredArrowYonedaOver_inverse ⋙ CostructuredArrowYonedaOver_functor (A:= A) - ≅ 𝟭 _ := +@[simps!] +def counitIso : inverse ⋙ functor (A := A) ≅ 𝟭 _ := NatIso.ofComponents (fun X => Over.isoMk (Iso.refl _)) +end costructuredArrowYonedaEquivOver +open costructuredArrowYonedaEquivOver -def CostructuredArrowYonedaOver : - CostructuredArrow yoneda (yoneda.obj (A)) ≌ CategoryTheory.Over A where - functor := CostructuredArrowYonedaOver_functor - inverse := CostructuredArrowYonedaOver_inverse - unitIso := CostructuredArrowYonedaOver_unitIso - counitIso := CostructuredArrowYonedaOver_counitIso - functor_unitIso_comp X := by - simp[CostructuredArrowYonedaOver_functor,CostructuredArrowYonedaOver_unitIso, - CostructuredArrowYonedaOver_counitIso] - ext - simp[Over.mk] - - -def PresheafCostructuredArrowYonedaOver_aux: - (CostructuredArrow yoneda (yoneda.obj (A)))ᵒᵖ ⥤ Type v ≌ - (CategoryTheory.Over A)ᵒᵖ ⥤ Type v := by - apply Equivalence.congrLeft - apply CategoryTheory.Equivalence.op - exact CostructuredArrowYonedaOver +@[simps] +def costructuredArrowYonedaEquivOver : + CostructuredArrow yoneda (yoneda.obj A) ≌ CategoryTheory.Over A where + functor := functor + inverse := inverse + unitIso := unitIso + counitIso := counitIso - - -def PresheafCostructuredArrowYonedaOver : - CategoryTheory.Over (yoneda.obj (A)) ≌ +@[simps!] +def overYonedaEquivPresheafOver : CategoryTheory.Over (yoneda.obj (A)) ≌ ((CategoryTheory.Over A)ᵒᵖ ⥤ Type v) := - Equivalence.trans (overEquivPresheafCostructuredArrow (yoneda.obj (A))) - (PresheafCostructuredArrowYonedaOver_aux) - - - - + (overEquivPresheafCostructuredArrow (yoneda.obj A)).trans + costructuredArrowYonedaEquivOver.op.congrLeft end CategoryTheory diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic1.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic1.lean deleted file mode 100644 index cc40b483..00000000 --- a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic1.lean +++ /dev/null @@ -1,103 +0,0 @@ -import Mathlib.CategoryTheory.Comma.Presheaf.Basic -import Mathlib.Tactic.DepRewrite - -namespace CategoryTheory - -open Category Opposite - -universe w v u - -variable {C : Type u} [Category.{v} C] {A : C} - -def CostructuredArrowYonedaOver_functor : CostructuredArrow yoneda (yoneda.obj A) ⥤ Over A where - obj X := Over.mk ((CategoryTheory.Yoneda.fullyFaithful).preimage X.hom) - map {X Y} f := by - have w := f.w - have e: - (yoneda.map f.left ≫ Y.hom).app (op X.left) = - (X.hom ≫ (Functor.fromPUnit (yoneda.obj A)).map f.right).app (op X.left) := by - simp[w] - simp[- CommaMorphism.w] at e - apply Over.homMk f.left (by simp[CategoryTheory.Yoneda.fullyFaithful_preimage,← e]) - - - -def CostructuredArrowYonedaOver_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 - -lemma CostructuredArrowYonedaOver_inverse_functor : - CostructuredArrowYonedaOver_inverse (A := A) ⋙ CostructuredArrowYonedaOver_functor = Functor.id _ - := by - fapply Functor.ext - · intro X - simp only [CostructuredArrowYonedaOver_inverse, Functor.id_obj, - CostructuredArrowYonedaOver_functor, Over.mk, Functor.comp_obj, CostructuredArrow.mk_left, - CostructuredArrow.mk_hom_eq_self, Functor.FullyFaithful.preimage_map] - rfl - intro X Y f - simp[CostructuredArrowYonedaOver_inverse, - CostructuredArrowYonedaOver_functor] - ext - simp - - - -lemma CostructuredArrowYonedaOver_functor_inverse : - CostructuredArrowYonedaOver_functor ⋙ CostructuredArrowYonedaOver_inverse (A := A) = Functor.id _ - := by - fapply Functor.ext - · intro X - simp[CostructuredArrowYonedaOver_inverse, - CostructuredArrowYonedaOver_functor] - apply CostructuredArrow.eq_mk - intro X Y f - simp[CostructuredArrowYonedaOver_inverse, - CostructuredArrowYonedaOver_functor] - - - -def CostructuredArrowYonedaOver_unitIso : - 𝟭 (CostructuredArrow yoneda (yoneda.obj A)) ≅ - CostructuredArrowYonedaOver_functor ⋙ CostructuredArrowYonedaOver_inverse := - eqToIso CostructuredArrowYonedaOver_functor_inverse.symm - -def CostructuredArrowYonedaOver_counitIso : - CostructuredArrowYonedaOver_inverse ⋙ CostructuredArrowYonedaOver_functor (A:= A) - ≅ 𝟭 _ := eqToIso CostructuredArrowYonedaOver_inverse_functor - - - -def CostructuredArrowYonedaOver : - CostructuredArrow yoneda (yoneda.obj (A)) ≌ CategoryTheory.Over A where - functor := CostructuredArrowYonedaOver_functor - inverse := CostructuredArrowYonedaOver_inverse - unitIso := CostructuredArrowYonedaOver_unitIso - counitIso := CostructuredArrowYonedaOver_counitIso - functor_unitIso_comp X := by - simp[CostructuredArrowYonedaOver_functor,CostructuredArrowYonedaOver_unitIso, - CostructuredArrowYonedaOver_counitIso] - ext - simp[Over.mk] - - - -def PresheafCostructuredArrowYonedaOver_aux: - (CostructuredArrow yoneda (yoneda.obj (A)))ᵒᵖ ⥤ Type v ≌ - (CategoryTheory.Over A)ᵒᵖ ⥤ Type v := by - apply Equivalence.congrLeft - apply CategoryTheory.Equivalence.op - exact CostructuredArrowYonedaOver - - -def PresheafCostructuredArrowYonedaOver : - CategoryTheory.Over (yoneda.obj (A)) ≌ - ((CategoryTheory.Over A)ᵒᵖ ⥤ Type v) := - Equivalence.trans (overEquivPresheafCostructuredArrow (yoneda.obj (A))) - (PresheafCostructuredArrowYonedaOver_aux) - - - - - -end CategoryTheory From c132d864a79d837e63b07f713bb50788ee5dc121 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 21 Nov 2025 20:27:40 -0500 Subject: [PATCH 53/95] . --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index e47d4fdc..243c41c7 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -341,15 +341,16 @@ instance {T : Type u} [Category.{max u v} T] -- apply (CategoryTheory.forget_reflects_iso) sorry -#check overYonedaEquivPresheafOver -#check Functor.preimageIso def pushforwardYonedaIso {T : Type u} [Category.{max u v} 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) := - NatIso.ofComponents (fun A => sorry) + NatIso.ofComponents (fun A => overYonedaEquivPresheafOver.functor.preimageIso + (NatIso.yonedaMk (fun {B} => by + dsimp + sorry) sorry)) sorry -- APPROACH 1: directly define the isomorphism. From c4e6754047aee8bfc0d00cb1f06e9c4e071805ca Mon Sep 17 00:00:00 2001 From: jlh18 Date: Mon, 24 Nov 2025 14:13:57 -0500 Subject: [PATCH 54/95] feat: profunctor proof --- HoTTLean/ForMathlib.lean | 36 ---- .../CategoryTheory/Adjunction/Basic.lean | 48 +++++ HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 186 +++++++++++------ .../CategoryTheory/Comma/Presheaf/Basic.lean | 190 +++++++++++++++++- .../ForMathlib/CategoryTheory/Yoneda.lean | 75 +++++++ 5 files changed, 437 insertions(+), 98 deletions(-) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Adjunction/Basic.lean diff --git a/HoTTLean/ForMathlib.lean b/HoTTLean/ForMathlib.lean index cf867ebd..947a8996 100644 --- a/HoTTLean/ForMathlib.lean +++ b/HoTTLean/ForMathlib.lean @@ -533,42 +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']) - -/-- 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] - -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) - namespace Functor theorem precomp_heq_of_heq_id {A B : Type u} {C : Type*} [Category.{v} A] [Category.{v} B] [Category C] diff --git a/HoTTLean/ForMathlib/CategoryTheory/Adjunction/Basic.lean b/HoTTLean/ForMathlib/CategoryTheory/Adjunction/Basic.lean new file mode 100644 index 00000000..9a8b788f --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Adjunction/Basic.lean @@ -0,0 +1,48 @@ +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₂} + +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/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index 243c41c7..d2994412 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -73,22 +73,26 @@ def Over.pullback_obj_chosenTerminal [R.IsStableUnderBaseChange] [R.ContainsIden variable [R.HasPullbacks] [R.IsStableUnderBaseChange] -@[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 +@[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) @@ -298,60 +302,128 @@ def pushforwardCompForget' {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks (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) - (pullbackComparison_comp_snd yoneda A.hom f)) + (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) --- APPROACH 1 -/-- Yoneda embedding preserves pushforward. -/ -def isPushforwardYonedaPushforwardObj {T : Type u} [Category.{max u v} T] - (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] - [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] (A : R.Over ⊤ X) : - IsPushforward ym(f) ((Over.yoneda R X).obj A) ((R.pushforward f ⋙ Over.yoneda R Y).obj A) := - sorry - --- APPROACH 2 -def pushforwardYonedaTwoSquare {T : Type u} [Category.{max u v} T] - (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] - [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : - TwoSquare (R.pushforward f) (Over.yoneda R X) (Over.yoneda R Y) - (ExponentiableMorphism.pushforward ym(f)) := - mateEquiv (pullbackPushforwardAdjunction R f) (ExponentiableMorphism.adj ym(f)) - (pullbackYonedaIso ..).inv - --- APPROACH 2 -instance {T : Type u} [Category.{max u v} T] - (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] - [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : - IsIso (R.pushforwardYonedaTwoSquare f) := by - rw [NatTrans.isIso_iff_isIso_app] - intro A - -- apply (config := {allowSynthFailures:= true}) (Over.forget_reflects_iso).reflects - simp [pushforwardYonedaTwoSquare, pullbackYonedaIso] - -- apply (CategoryTheory.forget_reflects_iso) - sorry - -def pushforwardYonedaIso {T : Type u} [Category.{max u v} T] +-- -- APPROACH 1 +-- /-- Yoneda embedding preserves pushforward. -/ +-- def isPushforwardYonedaPushforwardObj {T : Type u} [Category.{max u v} T] +-- (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] +-- {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] +-- [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] (A : R.Over ⊤ X) : +-- IsPushforward ym(f) ((Over.yoneda R X).obj A) ((R.pushforward f ⋙ Over.yoneda R Y).obj A) := +-- sorry + +-- -- APPROACH 2 +-- def pushforwardYonedaTwoSquare {T : Type u} [Category.{max u v} T] +-- (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] +-- {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] +-- [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : +-- TwoSquare (R.pushforward f) (Over.yoneda R X) (Over.yoneda R Y) +-- (ExponentiableMorphism.pushforward ym(f)) := +-- mateEquiv (pullbackPushforwardAdjunction R f) (ExponentiableMorphism.adj ym(f)) +-- (pullbackYonedaIso ..).inv + +-- -- APPROACH 2 +-- instance {T : Type u} [Category.{max u v} T] +-- (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] +-- {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] +-- [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : +-- IsIso (R.pushforwardYonedaTwoSquare f) := by +-- rw [NatTrans.isIso_iff_isIso_app] +-- intro A +-- -- apply (config := {allowSynthFailures:= true}) (Over.forget_reflects_iso).reflects +-- simp [pushforwardYonedaTwoSquare, pullbackYonedaIso] +-- -- apply (CategoryTheory.forget_reflects_iso) +-- sorry + +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) := - NatIso.ofComponents (fun A => overYonedaEquivPresheafOver.functor.preimageIso - (NatIso.yonedaMk (fun {B} => by - dsimp - sorry) sorry)) - sorry + Over.yonedaNatIsoMk <| + -- `Over (y(A)) (Over.post yoneda (-), Over.yoneda (R.pushforward f (⋆)))` + calc (R.pushforward f ⋙ Over.yoneda R Y) ⋙ yoneda ⋙ + (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op + -- `Over (A) (-, Over.forget (R.pushforward f (⋆)))` + _ ≅ R.pushforward f ⋙ Over.forget _ _ _ ⋙ yoneda := + sorry -- `Over.post yoneda` is fully faithful + -- `Over (A) (pullback f (-), Over.forget (⋆))` + _ ≅ Over.forget _ _ _ ⋙ yoneda ⋙ + (Functor.whiskeringLeft _ _ _).obj (CategoryTheory.Over.pullback f).op := + sorry -- homIso for partial adjunction `Over.pullback f ∂⊣ R.pushforward f` + -- `Over (y(A)) (pullback f ⋙ Over.post yoneda (-), Over.forget ⋙ Over.post yoneda (⋆))` + _ ≅ Over.forget _ _ _ ⋙ Over.post yoneda ⋙ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj + (CategoryTheory.Over.pullback f ⋙ Over.post yoneda).op := + sorry -- `Over.post yoneda` is fully faithful + -- `Over (y(A)) (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(A)) (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(A)) (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 + +-- #check Adjunction.homIso +-- 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) := +-- NatIso.ofComponents (fun A => Over.yonedaIsoMk ( +-- calc (Over.post yoneda).op ⋙ y((R.pushforward f ⋙ Over.forget _ _ _ ⋙ Over.post yoneda).obj A) +-- _ ≅ y((R.pushforward f ⋙ Over.forget _ _ _).obj A) := +-- sorry -- `Over.post yoneda` is fully faithful +-- _ ≅ (CategoryTheory.Over.pullback f).op ⋙ y((Over.forget _ _ _).obj A) := +-- sorry -- homEquiv for partial adjunction `Over.pullback f ∂⊣ R.pushforward f` +-- _ ≅ (CategoryTheory.Over.pullback f ⋙ Over.post yoneda).op ⋙ +-- y((Over.yoneda R X).obj A) := +-- sorry -- `Over.post yoneda` is fully faithful +-- _ ≅ (Over.post yoneda ⋙ CategoryTheory.Over.pullback ym(f)).op ⋙ +-- y((Over.yoneda R X).obj A) := +-- sorry -- `Over.post yoneda` preserves pullback +-- _ ≅ (Over.post yoneda).op ⋙ +-- y((Over.yoneda R X ⋙ ExponentiableMorphism.pushforward ym(f)).obj A) := +-- sorry -- homEquiv for adjunction `pullback ym(f) ⊣ pushforward ym(f)` +-- )) +-- sorry -- APPROACH 1: directly define the isomorphism. -- NatIso.ofComponents (fun A => ((isPushforwardYonedaPushforwardObj ..).uniqueUpToIso @@ -366,7 +438,7 @@ def pushforwardYonedaIso {T : Type u} [Category.{max u v} T] -- use PresheafCostructruedArrowYonedaOver to land in Psh (Over Y) -- then use `NatIso.yonedaMk` -def pushforwardPullbackIso {T : Type u} [Category.{max u v} T] +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) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean index e800a31d..8712b236 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean @@ -1,18 +1,23 @@ 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 +universe w v u u₁ -variable {C : Type u} [Category.{v} C] {A : C} +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) @@ -41,6 +46,8 @@ 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 @@ -49,10 +56,183 @@ def costructuredArrowYonedaEquivOver : unitIso := unitIso counitIso := counitIso -@[simps!] -def overYonedaEquivPresheafOver : CategoryTheory.Over (yoneda.obj (A)) ≌ - ((CategoryTheory.Over A)ᵒᵖ ⥤ Type v) := +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 +-- @[simp] +-- lemma overYonedaEquivPresheafOver.functor_eq : +-- (overYonedaEquivPresheafOver (A := A)).functor = +-- (overEquivPresheafCostructuredArrow y(A)).functor ⋙ +-- (Functor.whiskeringLeft _ _ _).obj inverse.op := by +-- dsimp only [overYonedaEquivPresheafOver, Equivalence.trans_functor, +-- Equivalence.op_inverse, costructuredArrowYonedaEquivOver_inverse] +-- sorry + +-- lemma overYonedaEquivPresheafOver_symm_toAdjunction_homEquiv_apply (B : Over A) (Y) : +-- (overYonedaEquivPresheafOver.symm.toAdjunction.homEquiv (yoneda.obj B) Y) = sorry := by +-- sorry + +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 (yoneda.obj 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(⋆))` + + +-- noncomputable def Over.yonedaIsoMk' {X Y : Over (yoneda.obj A)} +-- (e : (B : Over A) → ((mk (yoneda.map B.hom) ⟶ X)) ≃ (mk (yoneda.map B.hom) ⟶ Y)) +-- (naturality : {B C : Over A} → (f : B ⟶ C) → (t : mk (yoneda.map B.hom) ⟶ X) → +-- sorry) : +-- X ≅ Y := +-- overYonedaEquivPresheafOver.functor.preimageIso +-- (NatIso.yonedaMk' (fun {B} => by +-- calc (yoneda.obj B ⟶ overYonedaEquivPresheafOver.functor.obj X) +-- _ ≃ (overYonedaEquivPresheafOver.inverse.obj (yoneda.obj B) ⟶ X) := +-- (overYonedaEquivPresheafOver.symm.toAdjunction.homEquiv _ _).symm +-- _ ≃ (Over.mk (yoneda.map B.hom) ⟶ X) := +-- Iso.homCongr (overYonedaEquivPresheafOver.inverseObjApplyYonedaObjIso B) (Iso.refl _) +-- _ ≃ (Over.mk (yoneda.map B.hom) ⟶ Y) := e _ +-- _ ≃ (overYonedaEquivPresheafOver.inverse.obj (yoneda.obj B) ⟶ Y) := +-- Iso.homCongr (overYonedaEquivPresheafOver.inverseObjApplyYonedaObjIso B).symm (Iso.refl _) +-- _ ≃ (yoneda.obj B ⟶ overYonedaEquivPresheafOver.functor.obj Y) := +-- overYonedaEquivPresheafOver.symm.toAdjunction.homEquiv _ _) +-- (by +-- intro B C f t +-- ext +-- simp +-- sorry)) + +end + end CategoryTheory 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 From a030fe526d402503f737d99a03ce39ee96247541 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Mon, 24 Nov 2025 14:14:28 -0500 Subject: [PATCH 55/95] delete backup files --- HoTTLean/ForMathlib/CategoryTheory/Clan1.lean | 684 ------------------ HoTTLean/ForMathlib/CategoryTheory/Clan2.lean | 665 ----------------- 2 files changed, 1349 deletions(-) delete mode 100644 HoTTLean/ForMathlib/CategoryTheory/Clan1.lean delete mode 100644 HoTTLean/ForMathlib/CategoryTheory/Clan2.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan1.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan1.lean deleted file mode 100644 index a08e01d9..00000000 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan1.lean +++ /dev/null @@ -1,684 +0,0 @@ -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 - -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) - -@[simp] -def Local (X : C) : MorphismProperty (R.Over ⊤ X) := fun _ _ f => R f.left - -section pullback - -variable {R} [R.HasPullbacks] {X : C} - -lemma Local.hasPullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : - HasPullback f.left g.left := - MorphismProperty.HasPullbacks.hasPullback (g.left) (f:= f.left) rf - -variable [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] - -def Local.pullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : R.Over ⊤ X := - have := Local.hasPullback g rf - .mk ⊤ ((pullback.snd f.left g.left) ≫ V.hom) - (R.comp_mem _ _ (R.of_isPullback (IsPullback.of_hasPullback f.left g.left) rf) V.prop) - -def Local.pullback.fst {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : - Local.pullback g rf ⟶ U := - have := Local.hasPullback g rf - Over.homMk (Limits.pullback.fst f.left g.left) (by - simp only [pullback, ← Over.w f, Limits.pullback.condition_assoc] - simp) - -def Local.pullback.snd {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : - Local.pullback g rf ⟶ V := - have := Local.hasPullback g rf - Over.homMk (Limits.pullback.snd f.left g.left) - -theorem Local.pullback.isPullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : - IsPullback (Local.pullback.fst g rf) (Local.pullback.snd g rf) f g := by - have := Local.hasPullback g rf - have : (CostructuredArrow.proj (𝟭 C) X).Faithful := CostructuredArrow.proj_faithful -- why? - have : ReflectsLimitsOfShape WalkingCospan (CostructuredArrow.proj (𝟭 C) X) := inferInstance -- why? - apply Functor.reflect_isPullback (Over.forget R ⊤ X ⋙ CostructuredArrow.proj (Functor.id C) X) - simpa [fst, snd, Comma.Hom.hom_left] using IsPullback.of_hasPullback f.left g.left - -variable (X) - -instance : (Local R X).HasPullbacks where - hasPullback {U V W} f g rf := by - have := Local.hasPullback g rf - let pbinC := IsPullback.of_hasPullback f.left g.left - -- let P : R.Over ⊤ X := .mk ⊤ ((pullback.snd f.left g.left) ≫ V.hom) - -- (by apply R.comp_mem - -- sorry) - -- apply IsPullback.hasPullback - sorry - - -- let F := CostructuredArrow.proj (Functor.id C) X - -- have p00: PreservesLimit (cospan f g) (Over.forget R ⊤ X) := sorry - -- have p0 : PreservesLimit (cospan f g ⋙ Over.forget R ⊤ X) - -- (CostructuredArrow.proj (𝟭 C) X) := sorry - - -- have p1 : @PreservesLimit - -- (R.Over ⊤ X) _ C _ WalkingCospan _ (cospan f g) - -- (Over.forget R ⊤ X ⋙ (CostructuredArrow.proj (Functor.id C) X)) := by - -- apply CategoryTheory.Limits.comp_preservesLimit - - -- have p: IsPullback fst.left snd.left f.left g.left := by - -- apply Functor.map_isPullback - -- (Over.forget R ⊤ X ⋙ CostructuredArrow.proj (Functor.id C) X) i - -- simp[Local] at * - -- apply R.of_isPullback p rf - -instance : (Local R X).IsStableUnderBaseChange where - of_isPullback {W V P K} g f fst snd i rf := by - have := Local.hasPullback g rf - rw [← IsPullback.isoIsPullback_hom_snd _ _ i (Local.pullback.isPullback g rf), Local] - exact RespectsIso.precomp _ _ _ (R.of_isPullback (IsPullback.of_hasPullback f.left g.left) rf) - -end pullback - -instance (X : C) [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] : - (Local R X).IsStableUnderBaseChange := sorry - -instance (X : C) : (Local R X).HasObjects := sorry - -instance (X : C) [R.ContainsIdentities] : (Local R X).ContainsIdentities where - id_mem _ := R.id_mem _ - -instance (X : C) [R.IsStableUnderComposition] : - (Local R X).IsStableUnderComposition where - comp_mem _ _ := R.comp_mem _ _ - -abbrev chosenTerminal [R.ContainsIdentities] (X) : R.Over ⊤ X := .mk ⊤ (𝟙 X) (R.id_mem _) - -@[simps!] -protected def Over.post (R : MorphismProperty C) (R' : MorphismProperty C') - [F.PreservesMorphismProperty R R'] (X : C) : R.Over ⊤ X ⥤ R'.Over ⊤ (F.obj X) where - obj X := MorphismProperty.Over.mk ⊤ (F.map X.hom) (F.map_mem _ X.prop) - map f := MorphismProperty.Over.homMk (F.map f.left) (by simp [← F.map_comp]) - map_id := sorry - map_comp := sorry - -instance {R' : MorphismProperty C'} [F.PreservesMorphismProperty R R'] (X : C) : - (Over.post F R R' X).PreservesMorphismProperty (Local R X) (Local R' (F.obj X)) where - map_mem _ := F.map_mem _ - -instance {R' : MorphismProperty C'} [F.PreservesMorphismProperty R R'] [F.PreservesPullbacksOf R] - (X : C) : (Over.post F R R' X).PreservesPullbacksOf (Local R X) where - pb := sorry - -@[simp] -lemma localFunctor_obj_chosenTerminal [R.ContainsIdentities] {R' : MorphismProperty C'} - [R'.ContainsIdentities] [F.PreservesMorphismProperty R R'] (X : C) : - (Over.post F R R' X).obj (R.chosenTerminal X) = R'.chosenTerminal (F.obj X) := by - cat_disch - -instance [R.IsStableUnderBaseChange] {X Y : C} (f : X ⟶ Y) [R.HasPullbacksAlong f] : - (Over.pullback R ⊤ f).PreservesMorphismProperty (Local R Y) (Local R X) := sorry - -instance [R.IsStableUnderBaseChange] {X Y : C} (f : X ⟶ Y) [R.HasPullbacksAlong f] : - (Over.pullback R ⊤ f).PreservesPullbacksOf (Local R Y) := sorry - -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 - -structure RepresentableFibrantChosenPullbacks {X Y : Psh C} (f : X ⟶ Y) - extends RepresentableChosenPullbacks f where - fibrant {Γ : C} (b : y(Γ) ⟶ Y) : R (disp b) - --- this is a preclan, does not satisfy HasObjects -def ExtendedFibration : MorphismProperty (Psh C) := - fun _ _ f => Nonempty (RepresentableFibrantChosenPullbacks R f) - -instance : (ExtendedFibration R).IsStableUnderBaseChange := sorry - -instance : (ExtendedFibration R).HasPullbacks := sorry - -instance [R.ContainsIdentities] : (ExtendedFibration R).ContainsIdentities where - id_mem _ := sorry - -instance [R.IsStableUnderComposition] : (ExtendedFibration R).IsStableUnderComposition where - comp_mem _ _ hf hg := sorry - -notation:max R"^("F")" => Local (ExtendedFibration R) F - -namespace ExtendedFibration - -variable [R.HasPullbacks] [R.IsStableUnderBaseChange] - -def yonedaRepresentableFibrantChosenPullbacks (X Y : C) (f : X ⟶ Y) (rf : R f) : - R.RepresentableFibrantChosenPullbacks (CategoryTheory.yoneda.map f) := - have h {Γ} (A : Γ ⟶ Y) : HasPullback f A := HasPullbacks.hasPullback _ rf - { ext A := pullback f (yoneda.preimage A) - disp A := pullback.snd _ _ - var _ := ym(pullback.fst _ _) - disp_pullback := sorry - fibrant A := IsStableUnderBaseChange.of_isPullback (IsPullback.of_hasPullback _ _) rf } - -/-- This is the functor `R(X) -> R^(X)`. -/ -@[simps] -protected def yoneda (X : C) : R.Over ⊤ X ⥤ (ExtendedFibration R).Over ⊤ y(X) where - obj A := .mk ⊤ ym(A.hom) ⟨yonedaRepresentableFibrantChosenPullbacks R _ _ _ A.prop⟩ - map {A B} f := Over.homMk ym(f.left) - map_id := sorry - map_comp := sorry - -instance (X : C) : (ExtendedFibration.yoneda R X).Full where - map_surjective {A B} f := - ⟨Over.homMk (yoneda.preimage f.left) (by apply yoneda.map_injective; simp; exact Over.w f), - by cat_disch⟩ - -instance (X : C) : (ExtendedFibration.yoneda R X).Faithful where - map_injective {A B} f f' hf := by - ext - apply yoneda.map_injective - exact Functor.congr_map (Over.forget _ _ _ ⋙ CategoryTheory.Over.forget _) hf - -variable (F : Psh C) - -example [R.IsStableUnderComposition] : (R^(F)).HasPullbacks := inferInstance -example [R.IsStableUnderComposition] : (R^(F)).IsStableUnderBaseChange := inferInstance -example : (R^(F)).HasObjects := inferInstance -example [R.ContainsIdentities] : (R^(F)).ContainsIdentities := inferInstance -example [R.IsStableUnderComposition] : (R^(F)).IsStableUnderComposition := inferInstance - -example (X : C) : (ExtendedFibration.yoneda R X).ReflectsIsomorphisms := inferInstance - -end ExtendedFibration - -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] - -/-- -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 -``` --/ -theorem 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 - -/-- 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_ {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) : --- (pushforwardPullbackTwoSquare h f g k sq).app A = sorry := by --- apply (Over.forget R ⊤ Y).map_injective --- simp [pushforwardPullbackTwoSquare, ← Functor.map_comp] --- rw [pushforward.homEquiv_symm_comp] --- rw [Equiv.symm_apply_eq] --- simp --- erw [Category.id_comp] --- ext --- simp --- ext --- · simp --- sorry --- · sorry - -def pullbackForgetTwoSquare {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks T] - {R : MorphismProperty T} {X Y : T} (f : X ⟶ Y) [R.IsStableUnderBaseChangeAlong f] : - Over.pullback R ⊤ f ⋙ Over.forget R ⊤ X ≅ Over.forget R ⊤ Y ⋙ CategoryTheory.Over.pullback f := - sorry - -@[simps] -def _root_.CategoryTheory.ExponentiableMorphism.pullbackRepresentableByPushforward - {T : Type u} [Category.{v} T] [HasPullbacks T] - {X Y : T} (f : X ⟶ Y) [ExponentiableMorphism f] (h : Over X) : - ((CategoryTheory.Over.pullback f).op ⋙ y(h)).RepresentableBy - ((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.pullbackRepresentableByPushforward 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 _ - -example {T : Type u} [Category.{max u v} T] - (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - {X Y Z : T} (f : X ⟶ Y) (t : Z ⟶ Y) - [HasPullbacksAlong f] : - HasPullbacksAlong (pullback.fst t f) := - inferInstance - -def IsPushforward.ofYonedaIsPushforward {C : Type u} [Category.{u} C] - {S S' : C} (f : S ⟶ S') (X : Over S) (Y : Over S') [HasPullbacksAlong f] - (isPushforward : IsPushforward ym(f) ((CategoryTheory.Over.post yoneda).obj X) - ((CategoryTheory.Over.post yoneda).obj Y)) : - IsPushforward f X Y where - homEquiv {A} := by - refine (Yoneda.fullyFaithful.over S').homEquiv.trans ?_ - refine (isPushforward.homEquiv).trans ?_ - refine Equiv.trans ?_ (Yoneda.fullyFaithful.over S).homEquiv.symm - refine Iso.homCongr ?_ (Iso.refl _) - exact CategoryTheory.Over.isoMk (PreservesPullback.iso yoneda A.hom f).symm - homEquiv_comp {A A'} g h := by - -- apply (Yoneda.fullyFaithful.over S).map_injective - -- ext : 1 - -- simp only [Functor.op_obj, Functor.id_obj, Functor.comp_obj, - -- yoneda_obj_obj, Functor.const_obj_obj, Equiv.trans_apply, Iso.homCongr_apply, Iso.refl_hom, - -- comp_id, Functor.comp_map, Functor.op_map, Quiver.Hom.unop_op, - -- yoneda_obj_map, Over.comp_left, Functor.map_comp, Functor.FullyFaithful.homEquiv_symm_apply] - sorry - -/-- The constructed pushforward functor for `pullback.fst t f : pullback t f ⟶ Z`, -given `f : X ⟶ Y` has pushforwards and `R`-map `t : Z ⟶ Y`. -/ -def pushforwardPullbackFst {T : Type u} [Category.{v} T] - (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - [R.IsStableUnderComposition] - {X Y Z : T} (f : X ⟶ Y) {t : Z ⟶ Y} (rt : R t) - [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : - R.Over ⊤ (pullback t f) ⥤ R.Over ⊤ Z := - Over.map ⊤ (f := pullback.snd t f) (R.of_isPullback (IsPullback.of_hasPullback t f) rt) ⋙ - R.pushforward f ⋙ Over.pullback R ⊤ t - -instance hasPushforwardsAlong_pullback_fst {T : Type u} [Category.{max u v} T] - (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - {X Y Z : T} (f : X ⟶ Y) (t : Z ⟶ Y) - [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : - R.HasPushforwardsAlong (pullback.fst t f) where - hasPushforward {W} h rh := { - has_representation := ⟨sorry, ⟨sorry⟩⟩ } - -instance isStableUnderPushforwardsAlong_pullback_fst {T : Type u} [Category.{max u v} T] - (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - {X Y Z : T} (f : X ⟶ Y) {t : Z ⟶ Y} (rt : R t) - [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : - R.IsStableUnderPushforwardsAlong (pullback.fst t f) := - sorry - -def extendedFibration_pushforward {T : Type u} [Category.{max u v} T] - (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - {X Y : T} (f : X ⟶ Y) - [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] - {W : Psh T} (h : W ⟶ y(X)) (rh : R.RepresentableFibrantChosenPullbacks h) : - R.RepresentableFibrantChosenPullbacks ((ExponentiableMorphism.pushforward ym(f)).obj - (CategoryTheory.Over.mk h)).hom where - ext {Γ} t := by - dsimp at t - -- let E := rf.ext t - -- let d := rf.disp t - -- let v := rf.var t - -- let pf : Over Γ := sorry - sorry - disp := sorry - var := sorry - disp_pullback := sorry - fibrant := sorry - -lemma extendedFibration_pushforward_yoneda {T : Type u} [Category.{max u v} T] - (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] {X Y : T} (f : X ⟶ Y) - [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] - {W : Psh T} (h : W ⟶ y(X)) (rh : R.ExtendedFibration h) : - R.ExtendedFibration ((ExponentiableMorphism.pushforward ym(f)).obj - (CategoryTheory.Over.mk h)).hom := - ⟨ sorry ⟩ - -instance {T : Type u} [Category.{max u v} T] (R : MorphismProperty T) - [R.HasPullbacks] [R.IsStableUnderBaseChange] {X Y : T} (f : X ⟶ Y) - [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : - (ExtendedFibration R).IsStableUnderPushforwardsAlong ym(f) := - IsStableUnderPushforwardsAlong.of_respectsIso _ _ - (fun h _ => (ExponentiableMorphism.pushforward ym(f)).obj (CategoryTheory.Over.mk h)) - (fun h rh => extendedFibration_pushforward_yoneda R f h rh) - (fun h _ => ExponentiableMorphism.pullbackRepresentableByPushforward ym(f) (.mk h)) - -theorem pushforwardPullbackTwoSquare_isIso_of_exponentiableMorphism - {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks 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) - [ExponentiableMorphism f] [ExponentiableMorphism g] - [R.IsStableUnderPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong g] - (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by - let α : (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ - Over.forget R ⊤ Y ⟶ - (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ - Over.forget R ⊤ Y := sorry - -- TODO: define α as the following composition. All should be either x.hom for some iso x or - -- a morphism such that IsIso x - -- (R.ExtendedFibration.pushforward g ⋙ Over.pullback R.ExtendedFibration ⊤ k) ⋙ - -- Over.forget R.ExtendedFibration ⊤ Y - -- ≅ R.ExtendedFibration.pushforward g ⋙ Over.pullback R.ExtendedFibration ⊤ k ⋙ Over.forget R.ExtendedFibration ⊤ Y - -- ≅ R.ExtendedFibration.pushforward g ⋙ Over.forget R.ExtendedFibration ⊤ W ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ (R.pushforward g ⋙ ExtendedFibration.yoneda R W) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ (ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g)) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- use `pushforwardPullbackTwoSquare_isIso_extendedFibration` here - -- ≅ ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h) ⋙ (ExtendedFibration R).pushforward f - -- ≅ (ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h)) ⋙ (ExtendedFibration R).pushforward f - -- ≅ (Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X) ⋙ (ExtendedFibration R).pushforward f - -- ≅ Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X ⋙ (ExtendedFibration R).pushforward f - -- ≅ Over.pullback R ⊤ h ⋙ R.pushforward f ⋙ ExtendedFibration.yoneda R Y - -- ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y - have : IsIso α := sorry -- should be automatic by infer_instance. Then remove. - have eq : Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (Over.forget R ⊤ Y) = α := sorry - have : IsIso (Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (Over.forget R ⊤ Y)) := by rw [eq]; infer_instance - apply NatTrans.isIso_of_whiskerRight_isIso _ (Over.forget _ _ _) - -theorem pushforwardPullbackTwoSquare_isIso_extendedFibration {T : Type u} [Category.{max u 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) - [HasPullbacksAlong f] [HasPullbacksAlong g] - [R.HasPushforwardsAlong f] [R.HasPushforwardsAlong g] - [R.IsStableUnderPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong g] - (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := ExtendedFibration R) ym(h) ym(f) ym(g) ym(k) - (by simp [← Functor.map_comp, pb.w])) := - pushforwardPullbackTwoSquare_isIso_of_exponentiableMorphism - (ExtendedFibration R) ym(h) ym(f) ym(g) ym(k) (Functor.map_isPullback _ pb) - -/-- -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.{max u 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] - (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by - let α : (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ ExtendedFibration.yoneda R Y ⟶ - (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y := sorry - -- TODO: define α as the following composition. All should be either x.hom for some iso x or - -- a morphism such that IsIso x - -- (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ ExtendedFibration.yoneda R Y - -- ≅ R.pushforward g ⋙ Over.pullback R ⊤ k ⋙ ExtendedFibration.yoneda R Y - -- ≅ R.pushforward g ⋙ ExtendedFibration.yoneda R W ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ (R.pushforward g ⋙ ExtendedFibration.yoneda R W) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ (ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g)) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- use `pushforwardPullbackTwoSquare_isIso_extendedFibration` here - -- ≅ ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h) ⋙ (ExtendedFibration R).pushforward f - -- ≅ (ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h)) ⋙ (ExtendedFibration R).pushforward f - -- ≅ (Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X) ⋙ (ExtendedFibration R).pushforward f - -- ≅ Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X ⋙ (ExtendedFibration R).pushforward f - -- ≅ Over.pullback R ⊤ h ⋙ R.pushforward f ⋙ ExtendedFibration.yoneda R Y - -- ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y - have : IsIso α := sorry -- should be automatic by infer_instance. Then remove. - have eq : Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (ExtendedFibration.yoneda R Y) = α := sorry - have : IsIso (Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (ExtendedFibration.yoneda R Y)) := by rw [eq]; infer_instance - apply NatTrans.isIso_of_whiskerRight_isIso _ (ExtendedFibration.yoneda R Y) - -/- -theorem pushforwardPullbackTwoSquare_isIso {T : Type u} [Category.{max u 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] - (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by - apply (config := {allowSynthFailures:= true}) NatIso.isIso_of_isIso_app - intro A - apply (config := {allowSynthFailures:= true}) Functor.ReflectsIsomorphisms.reflects - (ExtendedFibration.yoneda R Y ⋙ Over.forget _ _ _) - -- apply (config := {allowSynthFailures:= true}) yoneda.map_isIso - -- simp - have pb : IsPullback ym(h) ym(f) ym(g) ym(k) := sorry - have l := CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq - have li := CategoryTheory.pushforwardPullbackTwoSquare_of_isPullback_isIso pb - have lii := NatIso.isIso_app_of_isIso - (CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq) - ((ExtendedFibration.yoneda R Z ⋙ Over.forget _ _ _).obj A) - -- have : IsIso l := inferInstanceAs $ IsIso $ CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq - sorry --/ diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan2.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan2.lean deleted file mode 100644 index 8eb355c7..00000000 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan2.lean +++ /dev/null @@ -1,665 +0,0 @@ -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 - -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) - -@[simp] -def Local (X : C) : MorphismProperty (R.Over ⊤ X) := fun _ _ f => R f.left - -section pullback - -variable {R} [R.HasPullbacks] {X : C} - -lemma Local.hasPullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : - HasPullback f.left g.left := - MorphismProperty.HasPullbacks.hasPullback (g.left) (f:= f.left) rf - -variable [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] - -def Local.pullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : R.Over ⊤ X := - have := Local.hasPullback g rf - .mk ⊤ ((pullback.snd f.left g.left) ≫ V.hom) - (R.comp_mem _ _ (R.of_isPullback (IsPullback.of_hasPullback f.left g.left) rf) V.prop) - -def Local.pullback.fst {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : - Local.pullback g rf ⟶ U := - have := Local.hasPullback g rf - Over.homMk (Limits.pullback.fst f.left g.left) (by - simp only [pullback, ← Over.w f, Limits.pullback.condition_assoc] - simp) - -def Local.pullback.snd {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : - Local.pullback g rf ⟶ V := - have := Local.hasPullback g rf - Over.homMk (Limits.pullback.snd f.left g.left) - -theorem Local.pullback.isPullback {U V W : R.Over ⊤ X} {f : U ⟶ W} (g : V ⟶ W) (rf : R f.left) : - IsPullback (Local.pullback.fst g rf) (Local.pullback.snd g rf) f g := by - have := Local.hasPullback g rf - have : (CostructuredArrow.proj (𝟭 C) X).Faithful := CostructuredArrow.proj_faithful -- why? - have : ReflectsLimitsOfShape WalkingCospan (CostructuredArrow.proj (𝟭 C) X) := inferInstance -- why? - apply Functor.reflect_isPullback (Over.forget R ⊤ X ⋙ CostructuredArrow.proj (Functor.id C) X) - simpa [fst, snd, Comma.Hom.hom_left] using IsPullback.of_hasPullback f.left g.left - -variable (X) - -instance : (Local R X).HasPullbacks where - hasPullback {U V W} f g rf := by - have := Local.hasPullback g rf - let pbinC := IsPullback.of_hasPullback f.left g.left - -- let P : R.Over ⊤ X := .mk ⊤ ((pullback.snd f.left g.left) ≫ V.hom) - -- (by apply R.comp_mem - -- sorry) - -- apply IsPullback.hasPullback - sorry - - -- let F := CostructuredArrow.proj (Functor.id C) X - -- have p00: PreservesLimit (cospan f g) (Over.forget R ⊤ X) := sorry - -- have p0 : PreservesLimit (cospan f g ⋙ Over.forget R ⊤ X) - -- (CostructuredArrow.proj (𝟭 C) X) := sorry - - -- have p1 : @PreservesLimit - -- (R.Over ⊤ X) _ C _ WalkingCospan _ (cospan f g) - -- (Over.forget R ⊤ X ⋙ (CostructuredArrow.proj (Functor.id C) X)) := by - -- apply CategoryTheory.Limits.comp_preservesLimit - - -- have p: IsPullback fst.left snd.left f.left g.left := by - -- apply Functor.map_isPullback - -- (Over.forget R ⊤ X ⋙ CostructuredArrow.proj (Functor.id C) X) i - -- simp[Local] at * - -- apply R.of_isPullback p rf - -instance : (Local R X).IsStableUnderBaseChange where - of_isPullback {W V P K} g f fst snd i rf := by - have := Local.hasPullback g rf - rw [← IsPullback.isoIsPullback_hom_snd _ _ i (Local.pullback.isPullback g rf), Local] - exact RespectsIso.precomp _ _ _ (R.of_isPullback (IsPullback.of_hasPullback f.left g.left) rf) - -end pullback - -instance (X : C) [R.IsStableUnderComposition] [R.IsStableUnderBaseChange] : - (Local R X).IsStableUnderBaseChange := sorry - -instance (X : C) : (Local R X).HasObjects := sorry - -instance (X : C) [R.ContainsIdentities] : (Local R X).ContainsIdentities where - id_mem _ := R.id_mem _ - -instance (X : C) [R.IsStableUnderComposition] : - (Local R X).IsStableUnderComposition where - comp_mem _ _ := R.comp_mem _ _ - -abbrev chosenTerminal [R.ContainsIdentities] (X) : R.Over ⊤ X := .mk ⊤ (𝟙 X) (R.id_mem _) - -@[simps!] -protected def Over.post (R : MorphismProperty C) (R' : MorphismProperty C') - [F.PreservesMorphismProperty R R'] (X : C) : R.Over ⊤ X ⥤ R'.Over ⊤ (F.obj X) where - obj X := MorphismProperty.Over.mk ⊤ (F.map X.hom) (F.map_mem _ X.prop) - map f := MorphismProperty.Over.homMk (F.map f.left) (by simp [← F.map_comp]) - map_id := sorry - map_comp := sorry - -instance {R' : MorphismProperty C'} [F.PreservesMorphismProperty R R'] (X : C) : - (Over.post F R R' X).PreservesMorphismProperty (Local R X) (Local R' (F.obj X)) where - map_mem _ := F.map_mem _ - -instance {R' : MorphismProperty C'} [F.PreservesMorphismProperty R R'] [F.PreservesPullbacksOf R] - (X : C) : (Over.post F R R' X).PreservesPullbacksOf (Local R X) where - pb := sorry - -@[simp] -lemma localFunctor_obj_chosenTerminal [R.ContainsIdentities] {R' : MorphismProperty C'} - [R'.ContainsIdentities] [F.PreservesMorphismProperty R R'] (X : C) : - (Over.post F R R' X).obj (R.chosenTerminal X) = R'.chosenTerminal (F.obj X) := by - cat_disch - -instance [R.IsStableUnderBaseChange] {X Y : C} (f : X ⟶ Y) [R.HasPullbacksAlong f] : - (Over.pullback R ⊤ f).PreservesMorphismProperty (Local R Y) (Local R X) := sorry - -instance [R.IsStableUnderBaseChange] {X Y : C} (f : X ⟶ Y) [R.HasPullbacksAlong f] : - (Over.pullback R ⊤ f).PreservesPullbacksOf (Local R Y) := sorry - -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 - -structure RepresentableFibrantChosenPullbacks {X Y : Psh C} (f : X ⟶ Y) - extends RepresentableChosenPullbacks f where - fibrant {Γ : C} (b : y(Γ) ⟶ Y) : R (disp b) - --- this is a preclan, does not satisfy HasObjects -def ExtendedFibration : MorphismProperty (Psh C) := - fun _ _ f => Nonempty (RepresentableFibrantChosenPullbacks R f) - -instance : (ExtendedFibration R).IsStableUnderBaseChange := sorry - -instance : (ExtendedFibration R).HasPullbacks := sorry - -instance [R.ContainsIdentities] : (ExtendedFibration R).ContainsIdentities where - id_mem _ := sorry - -instance [R.IsStableUnderComposition] : (ExtendedFibration R).IsStableUnderComposition where - comp_mem _ _ hf hg := sorry - -notation:max R"^("F")" => Local (ExtendedFibration R) F - -namespace ExtendedFibration - -variable [R.HasPullbacks] [R.IsStableUnderBaseChange] - -def yonedaRepresentableFibrantChosenPullbacks (X Y : C) (f : X ⟶ Y) (rf : R f) : - R.RepresentableFibrantChosenPullbacks (CategoryTheory.yoneda.map f) := - have h {Γ} (A : Γ ⟶ Y) : HasPullback f A := HasPullbacks.hasPullback _ rf - { ext A := pullback f (yoneda.preimage A) - disp A := pullback.snd _ _ - var _ := ym(pullback.fst _ _) - disp_pullback := sorry - fibrant A := IsStableUnderBaseChange.of_isPullback (IsPullback.of_hasPullback _ _) rf } - -/-- This is the functor `R(X) -> R^(X)`. -/ -@[simps] -protected def yoneda (X : C) : R.Over ⊤ X ⥤ (ExtendedFibration R).Over ⊤ y(X) where - obj A := .mk ⊤ ym(A.hom) ⟨yonedaRepresentableFibrantChosenPullbacks R _ _ _ A.prop⟩ - map {A B} f := Over.homMk ym(f.left) - map_id := sorry - map_comp := sorry - -instance (X : C) : (ExtendedFibration.yoneda R X).Full where - map_surjective {A B} f := - ⟨Over.homMk (yoneda.preimage f.left) (by apply yoneda.map_injective; simp; exact Over.w f), - by cat_disch⟩ - -instance (X : C) : (ExtendedFibration.yoneda R X).Faithful where - map_injective {A B} f f' hf := by - ext - apply yoneda.map_injective - exact Functor.congr_map (Over.forget _ _ _ ⋙ CategoryTheory.Over.forget _) hf - -variable (F : Psh C) - -example [R.IsStableUnderComposition] : (R^(F)).HasPullbacks := inferInstance -example [R.IsStableUnderComposition] : (R^(F)).IsStableUnderBaseChange := inferInstance -example : (R^(F)).HasObjects := inferInstance -example [R.ContainsIdentities] : (R^(F)).ContainsIdentities := inferInstance -example [R.IsStableUnderComposition] : (R^(F)).IsStableUnderComposition := inferInstance - -example (X : C) : (ExtendedFibration.yoneda R X).ReflectsIsomorphisms := inferInstance - -end ExtendedFibration - -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 _) - simp [Comma.Hom.hom] - sorry -- should be pullback pasting. Try it! - -/-- -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 - -/-- 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_ {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) : --- (pushforwardPullbackTwoSquare h f g k sq).app A = sorry := by --- apply (Over.forget R ⊤ Y).map_injective --- simp [pushforwardPullbackTwoSquare, ← Functor.map_comp] --- rw [pushforward.homEquiv_symm_comp] --- rw [Equiv.symm_apply_eq] --- simp --- erw [Category.id_comp] --- ext --- simp --- ext --- · simp --- sorry --- · sorry - -def pullbackForgetTwoSquare {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks T] - {R : MorphismProperty T} {X Y : T} (f : X ⟶ Y) [R.IsStableUnderBaseChangeAlong f] : - Over.pullback R ⊤ f ⋙ Over.forget R ⊤ X ≅ Over.forget R ⊤ Y ⋙ CategoryTheory.Over.pullback f := - sorry - -@[simps] -def _root_.CategoryTheory.ExponentiableMorphism.pullbackRepresentableByPushforward - {T : Type u} [Category.{v} T] [HasPullbacks T] - {X Y : T} (f : X ⟶ Y) [ExponentiableMorphism f] (h : Over X) : - ((CategoryTheory.Over.pullback f).op ⋙ y(h)).RepresentableBy - ((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.pullbackRepresentableByPushforward 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 _ - -example {T : Type u} [Category.{max u v} T] - (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - {X Y Z : T} (f : X ⟶ Y) (t : Z ⟶ Y) - [HasPullbacksAlong f] : - HasPullbacksAlong (pullback.fst t f) := - inferInstance - -instance hasPushforwardsAlong_pullback_fst {T : Type u} [Category.{max u v} T] - (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - {X Y Z : T} (f : X ⟶ Y) (t : Z ⟶ Y) - [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : - R.HasPushforwardsAlong (pullback.fst t f) where - hasPushforward {W} h rh := { - has_representation := ⟨sorry, ⟨sorry⟩⟩ } - -instance isStableUnderPushforwardsAlong_pullback_fst {T : Type u} [Category.{max u v} T] - (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - {X Y Z : T} (f : X ⟶ Y) {t : Z ⟶ Y} (rt : R t) - [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : - R.IsStableUnderPushforwardsAlong (pullback.fst t f) := - sorry - -def extendedFibration_pushforward {T : Type u} [Category.{max u v} T] - (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] - {X Y : T} (f : X ⟶ Y) - [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] - {W : Psh T} (h : W ⟶ y(X)) (rh : R.RepresentableFibrantChosenPullbacks h) : - R.RepresentableFibrantChosenPullbacks ((ExponentiableMorphism.pushforward ym(f)).obj - (CategoryTheory.Over.mk h)).hom where - ext {Γ} t := by - dsimp at t - -- let E := rf.ext t - -- let d := rf.disp t - -- let v := rf.var t - -- let pf : Over Γ := sorry - sorry - disp := sorry - var := sorry - disp_pullback := sorry - fibrant := sorry - -lemma extendedFibration_pushforward_yoneda {T : Type u} [Category.{max u v} T] - (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] {X Y : T} (f : X ⟶ Y) - [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] - {W : Psh T} (h : W ⟶ y(X)) (rh : R.ExtendedFibration h) : - R.ExtendedFibration ((ExponentiableMorphism.pushforward ym(f)).obj - (CategoryTheory.Over.mk h)).hom := - ⟨ sorry ⟩ - -instance {T : Type u} [Category.{max u v} T] (R : MorphismProperty T) - [R.HasPullbacks] [R.IsStableUnderBaseChange] {X Y : T} (f : X ⟶ Y) - [HasPullbacksAlong f] [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : - (ExtendedFibration R).IsStableUnderPushforwardsAlong ym(f) := - IsStableUnderPushforwardsAlong.of_respectsIso _ _ - (fun h _ => (ExponentiableMorphism.pushforward ym(f)).obj (CategoryTheory.Over.mk h)) - (fun h rh => extendedFibration_pushforward_yoneda R f h rh) - (fun h _ => ExponentiableMorphism.pullbackRepresentableByPushforward ym(f) (.mk h)) - -theorem pushforwardPullbackTwoSquare_isIso_of_exponentiableMorphism - {T : Type u} [Category.{v} T] [HasFiniteWidePullbacks 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) - [ExponentiableMorphism f] [ExponentiableMorphism g] - [R.IsStableUnderPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong g] - (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by - let α : (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ - Over.forget R ⊤ Y ⟶ - (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ - Over.forget R ⊤ Y := sorry - -- TODO: define α as the following composition. All should be either x.hom for some iso x or - -- a morphism such that IsIso x - -- (R.ExtendedFibration.pushforward g ⋙ Over.pullback R.ExtendedFibration ⊤ k) ⋙ - -- Over.forget R.ExtendedFibration ⊤ Y - -- ≅ R.ExtendedFibration.pushforward g ⋙ Over.pullback R.ExtendedFibration ⊤ k ⋙ Over.forget R.ExtendedFibration ⊤ Y - -- ≅ R.ExtendedFibration.pushforward g ⋙ Over.forget R.ExtendedFibration ⊤ W ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ (R.pushforward g ⋙ ExtendedFibration.yoneda R W) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ (ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g)) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- use `pushforwardPullbackTwoSquare_isIso_extendedFibration` here - -- ≅ ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h) ⋙ (ExtendedFibration R).pushforward f - -- ≅ (ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h)) ⋙ (ExtendedFibration R).pushforward f - -- ≅ (Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X) ⋙ (ExtendedFibration R).pushforward f - -- ≅ Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X ⋙ (ExtendedFibration R).pushforward f - -- ≅ Over.pullback R ⊤ h ⋙ R.pushforward f ⋙ ExtendedFibration.yoneda R Y - -- ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y - have : IsIso α := sorry -- should be automatic by infer_instance. Then remove. - have eq : Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (Over.forget R ⊤ Y) = α := sorry - have : IsIso (Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (Over.forget R ⊤ Y)) := by rw [eq]; infer_instance - apply NatTrans.isIso_of_whiskerRight_isIso _ (Over.forget _ _ _) - -theorem pushforwardPullbackTwoSquare_isIso_extendedFibration {T : Type u} [Category.{max u 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) - [HasPullbacksAlong f] [HasPullbacksAlong g] - [R.HasPushforwardsAlong f] [R.HasPushforwardsAlong g] - [R.IsStableUnderPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong g] - (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := ExtendedFibration R) ym(h) ym(f) ym(g) ym(k) - (by simp [← Functor.map_comp, pb.w])) := - pushforwardPullbackTwoSquare_isIso_of_exponentiableMorphism - (ExtendedFibration R) ym(h) ym(f) ym(g) ym(k) (Functor.map_isPullback _ pb) - -/-- -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.{max u 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] - (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by - let α : (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ ExtendedFibration.yoneda R Y ⟶ - (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y := sorry - -- TODO: define α as the following composition. All should be either x.hom for some iso x or - -- a morphism such that IsIso x - -- (R.pushforward g ⋙ Over.pullback R ⊤ k) ⋙ ExtendedFibration.yoneda R Y - -- ≅ R.pushforward g ⋙ Over.pullback R ⊤ k ⋙ ExtendedFibration.yoneda R Y - -- ≅ R.pushforward g ⋙ ExtendedFibration.yoneda R W ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ (R.pushforward g ⋙ ExtendedFibration.yoneda R W) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ (ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g)) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- ≅ ExtendedFibration.yoneda R Z ⋙ (ExtendedFibration R).pushforward ym(g) ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(k) - -- use `pushforwardPullbackTwoSquare_isIso_extendedFibration` here - -- ≅ ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h) ⋙ (ExtendedFibration R).pushforward f - -- ≅ (ExtendedFibration.yoneda R Z ⋙ Over.pullback (ExtendedFibration R) ⊤ ym(h)) ⋙ (ExtendedFibration R).pushforward f - -- ≅ (Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X) ⋙ (ExtendedFibration R).pushforward f - -- ≅ Over.pullback R ⊤ h ⋙ ExtendedFibration.yoneda R X ⋙ (ExtendedFibration R).pushforward f - -- ≅ Over.pullback R ⊤ h ⋙ R.pushforward f ⋙ ExtendedFibration.yoneda R Y - -- ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ ExtendedFibration.yoneda R Y - have : IsIso α := sorry -- should be automatic by infer_instance. Then remove. - have eq : Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (ExtendedFibration.yoneda R Y) = α := sorry - have : IsIso (Functor.whiskerRight (pushforwardPullbackTwoSquare h f g k pb.w) - (ExtendedFibration.yoneda R Y)) := by rw [eq]; infer_instance - apply NatTrans.isIso_of_whiskerRight_isIso _ (ExtendedFibration.yoneda R Y) - -/- -theorem pushforwardPullbackTwoSquare_isIso {T : Type u} [Category.{max u 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] - (pb : IsPullback h f g k) : - IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := by - apply (config := {allowSynthFailures:= true}) NatIso.isIso_of_isIso_app - intro A - apply (config := {allowSynthFailures:= true}) Functor.ReflectsIsomorphisms.reflects - (ExtendedFibration.yoneda R Y ⋙ Over.forget _ _ _) - -- apply (config := {allowSynthFailures:= true}) yoneda.map_isIso - -- simp - have pb : IsPullback ym(h) ym(f) ym(g) ym(k) := sorry - have l := CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq - have li := CategoryTheory.pushforwardPullbackTwoSquare_of_isPullback_isIso pb - have lii := NatIso.isIso_app_of_isIso - (CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq) - ((ExtendedFibration.yoneda R Z ⋙ Over.forget _ _ _).obj A) - -- have : IsIso l := inferInstanceAs $ IsIso $ CategoryTheory.Over.pushforwardPullbackTwoSquare ym(h) ym(f) ym(g) ym(k) pb.toCommSq - sorry --/ From f9e0f76f1532ef801f770ef50e413dffe3db476c Mon Sep 17 00:00:00 2001 From: jlh18 Date: Mon, 24 Nov 2025 14:15:17 -0500 Subject: [PATCH 56/95] chore: remove comments --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 70 -------------------- 1 file changed, 70 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index d2994412..a0fec5ab 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -322,38 +322,6 @@ def pullbackYonedaIso {T : Type u} [Category.{max u v} T] apply (CategoryTheory.Over.forget _).map_injective apply pullback.hom_ext <;> simp) --- -- APPROACH 1 --- /-- Yoneda embedding preserves pushforward. -/ --- def isPushforwardYonedaPushforwardObj {T : Type u} [Category.{max u v} T] --- (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] --- {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] --- [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] (A : R.Over ⊤ X) : --- IsPushforward ym(f) ((Over.yoneda R X).obj A) ((R.pushforward f ⋙ Over.yoneda R Y).obj A) := --- sorry - --- -- APPROACH 2 --- def pushforwardYonedaTwoSquare {T : Type u} [Category.{max u v} T] --- (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] --- {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] --- [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : --- TwoSquare (R.pushforward f) (Over.yoneda R X) (Over.yoneda R Y) --- (ExponentiableMorphism.pushforward ym(f)) := --- mateEquiv (pullbackPushforwardAdjunction R f) (ExponentiableMorphism.adj ym(f)) --- (pullbackYonedaIso ..).inv - --- -- APPROACH 2 --- instance {T : Type u} [Category.{max u v} T] --- (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] --- {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] --- [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] : --- IsIso (R.pushforwardYonedaTwoSquare f) := by --- rw [NatTrans.isIso_iff_isIso_app] --- intro A --- -- apply (config := {allowSynthFailures:= true}) (Over.forget_reflects_iso).reflects --- simp [pushforwardYonedaTwoSquare, pullbackYonedaIso] --- -- apply (CategoryTheory.forget_reflects_iso) --- sorry - def pushforwardYonedaIso {T : Type u} [Category.{u} T] (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] {X Y : T} (f : X ⟶ Y) [HasPullbacksAlong f] @@ -400,44 +368,6 @@ def pushforwardYonedaIso {T : Type u} [Category.{u} T] (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op := (Functor.associator ..).symm --- #check Adjunction.homIso --- 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) := --- NatIso.ofComponents (fun A => Over.yonedaIsoMk ( --- calc (Over.post yoneda).op ⋙ y((R.pushforward f ⋙ Over.forget _ _ _ ⋙ Over.post yoneda).obj A) --- _ ≅ y((R.pushforward f ⋙ Over.forget _ _ _).obj A) := --- sorry -- `Over.post yoneda` is fully faithful --- _ ≅ (CategoryTheory.Over.pullback f).op ⋙ y((Over.forget _ _ _).obj A) := --- sorry -- homEquiv for partial adjunction `Over.pullback f ∂⊣ R.pushforward f` --- _ ≅ (CategoryTheory.Over.pullback f ⋙ Over.post yoneda).op ⋙ --- y((Over.yoneda R X).obj A) := --- sorry -- `Over.post yoneda` is fully faithful --- _ ≅ (Over.post yoneda ⋙ CategoryTheory.Over.pullback ym(f)).op ⋙ --- y((Over.yoneda R X).obj A) := --- sorry -- `Over.post yoneda` preserves pullback --- _ ≅ (Over.post yoneda).op ⋙ --- y((Over.yoneda R X ⋙ ExponentiableMorphism.pushforward ym(f)).obj A) := --- sorry -- homEquiv for adjunction `pullback ym(f) ⊣ pushforward ym(f)` --- )) --- sorry - - -- APPROACH 1: directly define the isomorphism. - -- NatIso.ofComponents (fun A => ((isPushforwardYonedaPushforwardObj ..).uniqueUpToIso - -- (ExponentiableMorphism.isPushforward ..))) - -- (by sorry) - - -- APPROACH 2: define the hom using mateEquiv and show that it satisfies isIso - -- asIso (pushforwardYonedaTwoSquare ..) - - - -- APPROACH 3: - -- use PresheafCostructruedArrowYonedaOver to land in Psh (Over Y) - -- then use `NatIso.yonedaMk` - def pushforwardPullbackIso {T : Type u} [Category.{u} T] (R : MorphismProperty T) [R.HasPullbacks] [R.IsStableUnderBaseChange] From aa8d1ddf309ecf2904f083d6c6f36174f3bac2ab Mon Sep 17 00:00:00 2001 From: jlh18 Date: Mon, 24 Nov 2025 16:02:41 -0500 Subject: [PATCH 57/95] feat: pushforwardYonedaIso, pushforwardPullbackIso --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 116 ++++++++++-------- .../CategoryTheory/Comma/Presheaf/Basic.lean | 39 +----- .../CategoryTheory/Functor/FullyFaithful.lean | 15 +++ .../MorphismProperty/OverAdjunction.lean | 7 ++ .../ForMathlib/CategoryTheory/Polynomial.lean | 4 +- 5 files changed, 90 insertions(+), 91 deletions(-) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Functor/FullyFaithful.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index a0fec5ab..ade00508 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -12,6 +12,7 @@ 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₁ @@ -329,20 +330,33 @@ def pushforwardYonedaIso {T : Type u} [Category.{u} T] R.pushforward f ⋙ Over.yoneda R Y ≅ Over.yoneda R X ⋙ ExponentiableMorphism.pushforward ym(f) := Over.yonedaNatIsoMk <| - -- `Over (y(A)) (Over.post yoneda (-), Over.yoneda (R.pushforward f (⋆)))` + let postFF {X} := (Functor.FullyFaithful.ofFullyFaithful (Over.post (X := X) yoneda)).homIso + -- `Over y(A) (Over.post yoneda (-), Over.yoneda (R.pushforward f (⋆)))` calc (R.pushforward f ⋙ Over.yoneda R Y) ⋙ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op - -- `Over (A) (-, Over.forget (R.pushforward f (⋆)))` + _ ≅ R.pushforward f ⋙ Over.forget _ _ _ ⋙ Over.post yoneda ⋙ yoneda ⋙ + (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op := + Functor.associator .. ≪≫ Functor.isoWhiskerLeft _ (Functor.associator ..) + -- `Over A (-, Over.forget (R.pushforward f (⋆)))` _ ≅ R.pushforward f ⋙ Over.forget _ _ _ ⋙ yoneda := - sorry -- `Over.post yoneda` is fully faithful - -- `Over (A) (pullback f (-), Over.forget (⋆))` + -- `Over.post yoneda` is fully faithful + (Functor.isoWhiskerLeft _ (Functor.isoWhiskerLeft _ postFF)).symm + -- `Over A (pullback f (-), Over.forget (⋆))` _ ≅ Over.forget _ _ _ ⋙ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj (CategoryTheory.Over.pullback f).op := - sorry -- homIso for partial adjunction `Over.pullback f ∂⊣ R.pushforward f` + -- homIso for partial adjunction `Over.pullback f ∂⊣ R.pushforward f` + pushforward.homIso.symm -- `Over (y(A)) (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 := - sorry -- `Over.post yoneda` is fully faithful + Functor.isoWhiskerLeft _ (Functor.associator .. ≪≫ Functor.isoWhiskerLeft _ + (Functor.isoWhiskerLeft _ ((Functor.whiskeringLeftObjCompIso ..).symm ≪≫ + Functor.mapIso _ (Functor.opComp ..).symm))) -- `Over (y(A)) (pullback f ⋙ Over.post yoneda (-), Over.yoneda (⋆))` _ ≅ Over.yoneda R X ⋙ yoneda ⋙ (Functor.whiskeringLeft _ _ _).obj (CategoryTheory.Over.pullback f ⋙ Over.post yoneda).op := @@ -368,8 +382,7 @@ def pushforwardYonedaIso {T : Type u} [Category.{u} T] (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op := (Functor.associator ..).symm -def pushforwardPullbackIso {T : Type u} [Category.{u} T] - (R : MorphismProperty T) +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] @@ -403,11 +416,6 @@ def pushforwardPullbackIso {T : Type u} [Category.{u} T] Functor.isoWhiskerLeft _ (pushforwardYonedaIso ..).symm _ ≅ (Over.pullback R ⊤ h ⋙ R.pushforward f) ⋙ Over.yoneda R Y := (Functor.associator _ _ _).symm -/- --- The remaining part of this file is an alternative definition of the iso, --- which maybe is not necessary - - /-- Fixing a commutative square, ``` Z - g → W @@ -440,41 +448,47 @@ def pushforwardPullbackTwoSquare {T : Type u} [Category.{v} T] {R : MorphismProp mateEquiv (pullbackPushforwardAdjunction R g) (pullbackPushforwardAdjunction R f) (pullbackPullbackTwoSquare _ _ _ _ sq) -/-- -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.{max u 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) - [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 h f g k pb).hom := - sorry - rw [eq] - infer_instance --/ +-- TODO: currently this theorem is unnecessary, +-- but it would be nice to show that these two definitions actually line up. +-- `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 h f g k pb).hom := by +-- sorry +-- rw [eq] +-- infer_instance diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean index 8712b236..af742945 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean @@ -65,19 +65,6 @@ def overYonedaEquivPresheafOver : (overEquivPresheafCostructuredArrow (yoneda.obj A)).trans costructuredArrowYonedaEquivOver.op.congrLeft --- @[simp] --- lemma overYonedaEquivPresheafOver.functor_eq : --- (overYonedaEquivPresheafOver (A := A)).functor = --- (overEquivPresheafCostructuredArrow y(A)).functor ⋙ --- (Functor.whiskeringLeft _ _ _).obj inverse.op := by --- dsimp only [overYonedaEquivPresheafOver, Equivalence.trans_functor, --- Equivalence.op_inverse, costructuredArrowYonedaEquivOver_inverse] --- sorry - --- lemma overYonedaEquivPresheafOver_symm_toAdjunction_homEquiv_apply (B : Over A) (Y) : --- (overYonedaEquivPresheafOver.symm.toAdjunction.homEquiv (yoneda.obj B) Y) = sorry := by --- sorry - 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)) @@ -135,6 +122,7 @@ 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 := @@ -151,6 +139,7 @@ noncomputable def Over.yonedaIsoMk {X Y : Over (yoneda.obj A)} Functor.isoWhiskerRight (NatIso.op yonedaCompInverseIso.symm) _ overYonedaEquivPresheafOver.functor.preimageIso (NatIso.yonedaMk (β X ≪≫ α ≪≫ (β Y).symm)) +-/ /-- The natural hom-set bijection as an isomorphism of profunctors ``` @@ -209,30 +198,6 @@ def Over.yonedaNatIsoMk {F G : D ⥤ Over (yoneda.obj A)} -- amounts to -- an isomorphism `Over (y(A)) (Over.post yoneda (-), F(⋆)) ≅ Over (y(A)) (Over.post yoneda (-), G(⋆))` - --- noncomputable def Over.yonedaIsoMk' {X Y : Over (yoneda.obj A)} --- (e : (B : Over A) → ((mk (yoneda.map B.hom) ⟶ X)) ≃ (mk (yoneda.map B.hom) ⟶ Y)) --- (naturality : {B C : Over A} → (f : B ⟶ C) → (t : mk (yoneda.map B.hom) ⟶ X) → --- sorry) : --- X ≅ Y := --- overYonedaEquivPresheafOver.functor.preimageIso --- (NatIso.yonedaMk' (fun {B} => by --- calc (yoneda.obj B ⟶ overYonedaEquivPresheafOver.functor.obj X) --- _ ≃ (overYonedaEquivPresheafOver.inverse.obj (yoneda.obj B) ⟶ X) := --- (overYonedaEquivPresheafOver.symm.toAdjunction.homEquiv _ _).symm --- _ ≃ (Over.mk (yoneda.map B.hom) ⟶ X) := --- Iso.homCongr (overYonedaEquivPresheafOver.inverseObjApplyYonedaObjIso B) (Iso.refl _) --- _ ≃ (Over.mk (yoneda.map B.hom) ⟶ Y) := e _ --- _ ≃ (overYonedaEquivPresheafOver.inverse.obj (yoneda.obj B) ⟶ Y) := --- Iso.homCongr (overYonedaEquivPresheafOver.inverseObjApplyYonedaObjIso B).symm (Iso.refl _) --- _ ≃ (yoneda.obj B ⟶ overYonedaEquivPresheafOver.functor.obj Y) := --- overYonedaEquivPresheafOver.symm.toAdjunction.homEquiv _ _) --- (by --- intro B C f t --- ext --- simp --- sorry)) - 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..f1b0c54f --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Functor/FullyFaithful.lean @@ -0,0 +1,15 @@ +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) + +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/MorphismProperty/OverAdjunction.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean index d7b90725..50dbcd93 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean @@ -332,6 +332,13 @@ lemma pushforward.homEquiv_comp_symm {X X' : Over S'} {Y : P.Over ⊤ S} 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 diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index ef790cc4..5036d7d4 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -542,11 +542,9 @@ def cartesianNatTrans {E' B' : C} (P : MvPoly R I O E B) (P' : MvPoly R I O E' B 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 - have : IsIso (pushforwardPullbackTwoSquare (R := R) φ P.p P'.p δ pb.w) := - pushforwardPullbackTwoSquare_isIso R φ P.p P'.p δ pb.w pb let cellMid : TwoSquare (MorphismProperty.Over.pullback R ⊤ φ) (R.pushforward P'.p) (R.pushforward P.p) (MorphismProperty.Over.pullback R ⊤ δ) := - CategoryTheory.inv (pushforwardPullbackTwoSquare φ P.p P'.p δ pb.w) + (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δ])) ≫ From 1e3f82e5d07ab008f5f5dfb857f0bd14bde5dd90 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Mon, 24 Nov 2025 16:58:19 -0500 Subject: [PATCH 58/95] feat: pushforwardYonedaIso, pushforwardPullbackIso --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 79 +++++++++++--------- 1 file changed, 42 insertions(+), 37 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index ade00508..b068b45b 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -450,45 +450,50 @@ def pushforwardPullbackTwoSquare {T : Type u} [Category.{v} T] {R : MorphismProp -- 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 h f g k pb).hom := by --- sorry --- rw [eq] --- infer_instance +/- +/-- +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 +-/ From 30c33e2ad44b09b2b827e9d18d7e4c9f05c85fbe Mon Sep 17 00:00:00 2001 From: jlh18 Date: Tue, 25 Nov 2025 11:05:01 -0500 Subject: [PATCH 59/95] doc: pushforward --- .../CategoryTheory/Adjunction/Basic.lean | 1 + HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 47 ++++++++++++++++--- .../CategoryTheory/Comma/Presheaf/Basic.lean | 2 +- .../CategoryTheory/Functor/FullyFaithful.lean | 1 + 4 files changed, 43 insertions(+), 8 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Adjunction/Basic.lean b/HoTTLean/ForMathlib/CategoryTheory/Adjunction/Basic.lean index 9a8b788f..1e458884 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Adjunction/Basic.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Adjunction/Basic.lean @@ -8,6 +8,7 @@ open CategoryTheory.Functor NatIso Category 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 diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index b068b45b..87ba7df3 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -323,30 +323,37 @@ def pullbackYonedaIso {T : Type u} [Category.{max u v} T] 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(A) (Over.post yoneda (-), Over.yoneda (R.pushforward f (⋆)))` + -- `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 A (-, Over.forget (R.pushforward f (⋆)))` + -- `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 A (pullback f (-), Over.forget (⋆))` + -- `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(A)) (pullback f ⋙ Over.post yoneda (-), Over.forget ⋙ Over.post yoneda (⋆))` + -- `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 := @@ -357,11 +364,11 @@ def pushforwardYonedaIso {T : Type u} [Category.{u} T] Functor.isoWhiskerLeft _ (Functor.associator .. ≪≫ Functor.isoWhiskerLeft _ (Functor.isoWhiskerLeft _ ((Functor.whiskeringLeftObjCompIso ..).symm ≪≫ Functor.mapIso _ (Functor.opComp ..).symm))) - -- `Over (y(A)) (pullback f ⋙ Over.post yoneda (-), Over.yoneda (⋆))` + -- `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(A)) (pullback ym(f) (-), pushforward ym(f) (Over.yoneda (⋆)))` + -- `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 @@ -372,7 +379,7 @@ def pushforwardYonedaIso {T : Type u} [Category.{u} T] (Functor.whiskeringLeft _ _ _).obj (Over.post yoneda).op := Functor.isoWhiskerLeft _ (Functor.isoWhiskerLeft _ (Functor.mapIso _ (Functor.opComp ..) ≪≫ Functor.whiskeringLeftObjCompIso ..)) - -- `Over (y(A)) (Over.post yoneda (-), pushforward ym(f) (Over.yoneda (⋆)))` + -- `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)` @@ -382,6 +389,25 @@ def pushforwardYonedaIso {T : Type u} [Category.{u} T] (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) @@ -390,29 +416,36 @@ def pushforwardPullbackIso {T : Type u} [Category.{u} T] {R : MorphismProperty T [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 diff --git a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean index af742945..8b961679 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Comma/Presheaf/Basic.lean @@ -175,7 +175,7 @@ def overYonedaEquivPresheafOver.homIso : overYonedaEquivPresheafOver.functor ⋙ Functor.isoWhiskerLeft _ (Functor.mapIso _ (NatIso.op overYonedaEquivPresheafOver.yonedaCompInverseIso.symm)) -/-- To show that `F ≅ G : D ⥤ Over (yoneda.obj A)` +/-- 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)} diff --git a/HoTTLean/ForMathlib/CategoryTheory/Functor/FullyFaithful.lean b/HoTTLean/ForMathlib/CategoryTheory/Functor/FullyFaithful.lean index f1b0c54f..3c415bce 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Functor/FullyFaithful.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Functor/FullyFaithful.lean @@ -11,5 +11,6 @@ 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)) From c5ce34435ca76d9471565b5b6c219e43e3d8f198 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Tue, 25 Nov 2025 11:35:23 -0500 Subject: [PATCH 60/95] change IdIntro.k and IdElimBase.i to just context extensions --- .../Model/Structured/StructuredUniverse.lean | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index c24a4cad..8e10f7e8 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -963,22 +963,19 @@ when constructing a model it is convenient to know that `k` is some specific construction on-the-nose. -/ structure IdIntro where - k : Ctx - k1 : k ⟶ M.Tm - k2 : k ⟶ M.Tm - isKernelPair : IsKernelPair M.tp k1 k2 - Id : k ⟶ M.Ty + Id : M.ext M.tp ⟶ M.Ty refl : M.Tm ⟶ M.Tm refl_tp : refl ≫ M.tp = - (IsPullback.lift isKernelPair (𝟙 M.Tm) (𝟙 M.Tm) (by simp)) ≫ Id + ((M.disp_pullback M.tp).lift (𝟙 M.Tm) (𝟙 M.Tm) (by simp)) ≫ Id namespace IdIntro variable {M} (idIntro : IdIntro M) {Γ : Ctx} -@[simps] def k2UvPoly : UvPoly R idIntro.k M.Tm := - ⟨idIntro.k2, R.of_isPullback idIntro.isKernelPair M.morphismProperty⟩ +@[simps] def k2UvPoly : UvPoly R (M.ext M.tp) M.Tm := + ⟨M.disp _, R.of_isPullback (M.disp_pullback M.tp) M.morphismProperty⟩ +#exit /-- 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) @@ -1140,9 +1137,9 @@ this may not be definitionally equal to the pullbacks we construct, for example using context extension. -/ structure IdElimBase (ii : IdIntro M) where - i : Ctx - i1 : i ⟶ M.Tm - i2 : i ⟶ ii.k + i : Ctx -- TODO: replace i with `M.ext (ii.Id)` and remove this whole definition. + i1 : i ⟶ M.Tm -- M.var .. + i2 : i ⟶ ii.k -- M.disp .. i_isPullback : IsPullback i1 i2 M.tp ii.Id namespace IdElimBase From 0b03d7d0d8ce9869f5f3e0de81b6a3eb32220f07 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Wed, 26 Nov 2025 15:12:12 -0500 Subject: [PATCH 61/95] changing structured univ --- .../Model/Structured/StructuredUniverse.lean | 38 +++++++++---------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index 8e10f7e8..2320037a 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -975,20 +975,20 @@ variable {M} (idIntro : IdIntro M) {Γ : Ctx} @[simps] def k2UvPoly : UvPoly R (M.ext M.tp) M.Tm := ⟨M.disp _, R.of_isPullback (M.disp_pullback M.tp) M.morphismProperty⟩ -#exit /-- 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 := - idIntro.isKernelPair.lift a1 a0 (by rw [a0_tp_eq_a1_tp]) ≫ idIntro.Id + (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 idIntro.isKernelPair.hom_ext <;> simp + apply (UnstructuredUniverse.disp_pullback _ M.tp).hom_ext <;> simp def mkRefl (a : Γ ⟶ M.Tm) : Γ ⟶ M.Tm := a ≫ idIntro.refl @@ -1003,7 +1003,7 @@ theorem mkRefl_tp (a : Γ ⟶ M.Tm) : simp only [mkRefl, Category.assoc, idIntro.refl_tp, mkId] rw [← Category.assoc] congr 1 - apply idIntro.isKernelPair.hom_ext <;> simp + apply (UnstructuredUniverse.disp_pullback _ M.tp).hom_ext <;> simp /-- The context appearing in the motive for identity elimination `J` Γ ⊢ A @@ -1028,7 +1028,7 @@ 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 idIntro.isKernelPair.hom_ext <;> simp) + apply (UnstructuredUniverse.disp_pullback _ M.tp).hom_ext <;> simp) @[reassoc] theorem comp_reflSubst' {Γ Δ} (σ : Δ ⟶ Γ) (a : Γ ⟶ M.Tm) : @@ -1042,15 +1042,15 @@ lemma comp_reflSubst (a : Γ ⟶ M.Tm) {Δ} (σ : Δ ⟶ Γ) : reflSubst idIntro (σ ≫ a) ≫ idIntro.motiveSubst σ a = σ ≫ reflSubst idIntro a := by simp [comp_reflSubst'] -def toK (ii : IdIntro M) (a : Γ ⟶ M.Tm) : (M.ext (a ≫ M.tp)) ⟶ ii.k := - ii.isKernelPair.lift (M.var _) ((M.disp _) ≫ a) (by simp) +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 (ii : IdIntro M) (a : Γ ⟶ M.Tm) : ii.toK a ≫ ii.k1 = M.var _ := by +lemma toK_comp_k1 (a : Γ ⟶ M.Tm) : IdIntro.toK a ≫ M.var M.tp = M.var _ := by simp [toK] lemma ext_a_tp_isPullback (ii : IdIntro M) (a : Γ ⟶ M.Tm) : - IsPullback (ii.toK a) (M.disp _) ii.k2 a := - IsPullback.of_right' (M.disp_pullback _) ii.isKernelPair + IsPullback (IdIntro.toK a) (M.disp _) (M.disp M.tp) a := + IsPullback.of_right' (M.disp_pullback _) (M.disp_pullback M.tp) end IdIntro @@ -1139,13 +1139,13 @@ for example using context extension. 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 ⟶ ii.k -- M.disp .. + i2 : i ⟶ M.ext M.tp -- M.disp .. i_isPullback : IsPullback i1 i2 M.tp ii.Id namespace IdElimBase variable {ii : IdIntro M} (ie : IdElimBase ii) -@[simps] def i2UvPoly : UvPoly R ie.i ii.k := +@[simps] def i2UvPoly : UvPoly R ie.i (M.ext M.tp) := ⟨ie.i2, R.of_isPullback ie.i_isPullback M.morphismProperty⟩ /-- The comparison map `M.tm ⟶ i` induced by the pullback universal property of `i`. @@ -1164,7 +1164,7 @@ diag | | -/ def comparison : M.Tm ⟶ ie.i := ie.i_isPullback.lift ii.refl - (IsPullback.lift ii.isKernelPair (𝟙 M.Tm) (𝟙 M.Tm) (by simp)) + (IsPullback.lift (M.disp_pullback M.tp) (𝟙 M.Tm) (𝟙 M.Tm) (by simp)) ii.refl_tp @[simp] @@ -1172,12 +1172,12 @@ lemma comparison_comp_i1 : ie.comparison ≫ ie.i1 = ii.refl := by simp [comparison] @[simp, reassoc] -lemma comparison_comp_i2_comp_k1 : ie.comparison ≫ ie.i2 ≫ ii.k1 = +lemma comparison_comp_i2_comp_k1 : ie.comparison ≫ ie.i2 ≫ M.var M.tp = 𝟙 _ := by simp [comparison] @[simp, reassoc] -lemma comparison_comp_i2_comp_k2 : ie.comparison ≫ ie.i2 ≫ ii.k2 = +lemma comparison_comp_i2_comp_k2 : ie.comparison ≫ ie.i2 ≫ M.disp M.tp = 𝟙 _ := by simp [comparison] @@ -1188,12 +1188,12 @@ which is defined by the composition of (maps informally thought of as) context e This is the signature for a polynomial functor `iUvPoly` on the presheaf category `Ctx`. -/ abbrev iUvPoly : UvPoly R ie.i M.Tm := - ie.i2UvPoly.vcomp ii.k2UvPoly + ie.i2UvPoly.vcomp IdIntro.k2UvPoly -lemma iUvPoly_morphismProperty : R (ie.i2 ≫ ii.k2) := by +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 ii.isKernelPair 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) @@ -1506,7 +1506,7 @@ def reflCase : Γ ⟶ (UvPoly.id R M.Tm).functor.obj N.Tm := -- TODO: consider generalizing -- TODO: consider showing UvPoly on identity `(P_𝟙_Y X)` is isomorphic to product `Y × X` -#exit + variable (ie) in /-- The variable `C` is the motive for elimination, This gives a map `(a, C) : Γ ⟶ iFunctor Ty` From b7f61bcbb6f60e9b938a538a4ae5b2db140121c0 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Wed, 26 Nov 2025 19:21:33 -0500 Subject: [PATCH 62/95] refactoring --- .../Model/Structured/StructuredUniverse.lean | 304 ++++++++++-------- 1 file changed, 170 insertions(+), 134 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index 2320037a..e90a5013 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1118,66 +1118,83 @@ end IdIntro -- 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 +-- /-- +-- `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 -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. --/ -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 + +-- -/ +-- 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 IdElimBase -variable {ii : IdIntro M} (ie : IdElimBase ii) - -@[simps] def i2UvPoly : UvPoly R ie.i (M.ext M.tp) := - ⟨ie.i2, R.of_isPullback ie.i_isPullback 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 ⟶ ie.i := - ie.i_isPullback.lift ii.refl +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 : ie.comparison ≫ ie.i1 = ii.refl := by +lemma comparison_comp_i1 : comparison ≫ M.var ii.Id = ii.refl := by simp [comparison] @[simp, reassoc] -lemma comparison_comp_i2_comp_k1 : ie.comparison ≫ ie.i2 ≫ M.var M.tp = +lemma comparison_comp_i2_comp_k1 : comparison ≫ M.disp ii.Id ≫ M.var M.tp = 𝟙 _ := by simp [comparison] @[simp, reassoc] -lemma comparison_comp_i2_comp_k2 : ie.comparison ≫ ie.i2 ≫ M.disp M.tp = +lemma comparison_comp_i2_comp_k2 : comparison ≫ M.disp ii.Id ≫ M.disp M.tp = 𝟙 _ := by simp [comparison] @@ -1187,24 +1204,34 @@ which is defined by the composition of (maps informally thought of as) context e `(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 ie.i M.Tm := - ie.i2UvPoly.vcomp IdIntro.k2UvPoly +abbrev iUvPoly : UvPoly R (M.ext ii.Id) M.Tm := + i2UvPoly.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 +-- 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.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 +-- 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 -/-- The functor part of the polynomial endofunctor `iOverUvPoly` -/ -abbrev iFunctor : Ctx ⥤ Ctx := ie.iUvPoly.functor +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) @@ -1214,6 +1241,7 @@ 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)` @@ -1222,13 +1250,12 @@ between the polynomial endofunctors `iUvPoly` and `UvPoly.id M.Tm` respectively. Tm ----> i \ / 𝟙\ /i2 ≫ k2 - \ / VV Tm -/ -def verticalNatTrans : ie.iFunctor ⟶ (UvPoly.id R M.Tm).functor := - UvPoly.verticalNatTrans (UvPoly.id R M.Tm) ie.iUvPoly - ie.comparison (by simp [iUvPoly]) +def verticalNatTrans : iFunctor (ii:= ii) ⟶ (UvPoly.id R M.Tm).functor := + UvPoly.verticalNatTrans (UvPoly.id R M.Tm) iUvPoly + comparison (by simp [iUvPoly]) section reflCase @@ -1289,64 +1316,70 @@ where `pullback` is the pullback of `i₂ ≫ k₂` along `a` given by `HasPullb a tp -/ -lemma toK_comp_left {Δ} (σ : Δ ⟶ Γ) : ii.toK (σ ≫ a) = - (M.substWk σ (a ≫ M.tp) _ (by simp)) ≫ ii.toK a := by - dsimp [toK] - rw! [Category.assoc] - apply ii.isKernelPair.hom_ext - · simp - · simp only [IsKernelPair.lift_snd, Category.assoc] - slice_rhs 1 2 => rw [substWk_disp] - simp +-- 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 := +/-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 : ie.toI a ≫ ie.i1 = M.var _ := by simp [toI] -lemma toI_comp_i1 : ie.toI a ≫ ie.i1 = M.var _ := by simp [toI] +-- lemma toI_comp_i2 : ie.toI a ≫ ie.i2 = (M.disp _) ≫ ii.toK a := +-- by simp [toI] -lemma toI_comp_i2 : ie.toI a ≫ ie.i2 = (M.disp _) ≫ ii.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] -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 (ie.toI a) (M.disp _) ie.i2 (toK ii a) := - IsPullback.of_right' (M.disp_pullback _) ie.i_isPullback + IsPullback (toI a) (M.disp _) (M.disp ii.Id) (toK a) := + IsPullback.of_right' (M.disp_pullback _) (M.disp_pullback _) theorem motiveCtx_isPullback' : - IsPullback (ie.toI a) ((M.disp (ii.mkId ((M.disp (a ≫ M.tp)) ≫ a) - (M.var (a ≫ M.tp)) (by simp))) ≫ (M.disp (a ≫ M.tp))) (iUvPoly ie).p a := - IsPullback.paste_vert (ie.motiveCtx_isPullback a) + IsPullback (toI a) ((M.disp (ii.mkId ((M.disp (a ≫ M.tp)) ≫ a) + (M.var (a ≫ M.tp)) (by simp))) ≫ (M.disp (a ≫ M.tp))) (iUvPoly).p a := + IsPullback.paste_vert (motiveCtx_isPullback a) (ii.ext_a_tp_isPullback a) -def equivMk (x : (ii.motiveCtx a) ⟶ X) : Γ ⟶ ie.iFunctor.obj X := - UvPoly.Equiv.mk' a (ie.motiveCtx_isPullback' a).flip x +def equivMk (x : (ii.motiveCtx a) ⟶ X) : Γ ⟶ (iFunctor (ii:= ii)).obj X := + UvPoly.Equiv.mk' a (motiveCtx_isPullback' a).flip x -def equivFst (pair : Γ ⟶ ie.iFunctor.obj X) : - Γ ⟶ M.Tm := - UvPoly.Equiv.fst pair +-- def equivFst (pair : Γ ⟶ ie.iFunctor.obj X) : +-- Γ ⟶ M.Tm := +-- UvPoly.Equiv.fst pair -lemma equivFst_comp_left (pair : Γ ⟶ ie.iFunctor.obj X) - {Δ} (σ : Δ ⟶ Γ) : - ie.equivFst (σ ≫ pair) = σ ≫ ie.equivFst pair := by - dsimp [equivFst] - rw [UvPoly.Equiv.fst_comp_left] +-- lemma equivFst_comp_left (pair : Γ ⟶ ie.iFunctor.obj X) +-- {Δ} (σ : Δ ⟶ Γ) : +-- ie.equivFst (σ ≫ pair) = σ ≫ ie.equivFst pair := by +-- dsimp [equivFst] +-- rw [UvPoly.Equiv.fst_comp_left] -def equivSnd (pair : Γ ⟶ ie.iFunctor.obj X) : - (ii.motiveCtx (equivFst ie pair)) ⟶ X := - UvPoly.Equiv.snd' pair (ie.motiveCtx_isPullback' _).flip +-- def equivSnd (pair : Γ ⟶ ie.iFunctor.obj X) : +-- (ii.motiveCtx (equivFst ie pair)) ⟶ X := +-- UvPoly.Equiv.snd' pair (ie.motiveCtx_isPullback' _).flip -lemma equivSnd_comp_left (pair : Γ ⟶ ie.iFunctor.obj X) - {Δ} (σ : Δ ⟶ Γ) : - ie.equivSnd (σ ≫ pair) = - eqToHom (by simp [equivFst_comp_left]) ≫ ii.motiveSubst σ _ ≫ ie.equivSnd pair := by - sorry +-- lemma equivSnd_comp_left (pair : Γ ⟶ ie.iFunctor.obj X) +-- {Δ} (σ : Δ ⟶ Γ) : +-- ie.equivSnd (σ ≫ pair) = +-- eqToHom (by simp [equivFst_comp_left]) ≫ ii.motiveSubst σ _ ≫ ie.equivSnd pair := by +-- sorry -- dsimp only [equivSnd] -- let a := ie.equivFst pair -- have H : IsPullback (ie.toI a) @@ -1464,19 +1497,19 @@ Here we are thinking This witnesses the elimination principle for identity types since we can take `J (y.p.C;x.r) := c`. -/ -structure Id {ii : IdIntro M} (ie : IdElimBase ii) (N : StructuredUniverse R) where +structure Id {ii : IdIntro M} (N : StructuredUniverse R) where weakPullback : WeakPullback - (ie.verticalNatTrans.app N.Tm) - (ie.iFunctor.map N.tp) + (IdElimBase.verticalNatTrans.app N.Tm) + ((IdElimBase.iFunctor (ii:= ii)).map N.tp) ((UvPoly.id R M.Tm).functor.map N.tp) - (ie.verticalNatTrans.app N.Ty) + (IdElimBase.verticalNatTrans.app N.Ty) -- TODO fix the proof that `StructuredUniverse.Id` is equivalent to -- `UnstructuredUniverse.PolymorphicIdElim` namespace Id -variable {N : StructuredUniverse R} {ii : IdIntro M} {ie : IdElimBase ii} (i : Id ie N) +variable {N : StructuredUniverse R} {ii : IdIntro M} (i :Id N) variable {Γ Δ : Ctx} (σ : Δ ⟶ Γ) (a : Γ ⟶ M.Tm) (C : (ii.motiveCtx a) ⟶ N.Ty) (r : Γ ⟶ N.Tm) @@ -1521,31 +1554,34 @@ Ty <-- y(motiveCtx) ----> i a ``` -/ -abbrev motive : Γ ⟶ ie.iFunctor.obj N.Ty := - ie.equivMk a C - -lemma motive_comp_left : σ ≫ motive ie a C = - motive ie (σ ≫ a) ((ii.motiveSubst σ a) ≫ C) := by - dsimp [motive, equivMk] - rw [UvPoly.Equiv.mk'_comp_left (iUvPoly ie) _ 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 +--instance : MorphismProperty.IsMultiplicative R := sorry +instance : MorphismProperty.IsMultiplicative R := sorry +abbrev motive : Γ ⟶ (iFunctor (ii:= ii)).obj N.Ty := + equivMk 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 -def lift : Γ ⟶ ie.iFunctor.obj N.Tm := - i.weakPullback.coherentLift (reflCase a r) (motive ie a C) (by +instance : HasPullbacks Ctx := sorry +def lift : Γ ⟶ (iFunctor (ii:= 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 M.Tm) ie.iUvPoly ie.comparison - _ N.Ty a (ie.motiveCtx_isPullback' a).flip C (reflCase_aux a), + rw [UvPoly.mk'_comp_verticalNatTrans_app (UvPoly.id R M.Tm) iUvPoly comparison + _ N.Ty a (motiveCtx_isPullback' a).flip C (reflCase_aux a), UvPoly.Equiv.mk'_comp_right, r_tp, reflSubst] congr apply (M.disp_pullback _).hom_ext From a61a953e57d78d079967d6b82a8ddc50dcb60542 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 27 Nov 2025 11:08:19 -0500 Subject: [PATCH 63/95] newest --- .../Model/Structured/StructuredUniverse.lean | 165 +++++++++--------- 1 file changed, 84 insertions(+), 81 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index e90a5013..dfda4a26 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1065,21 +1065,21 @@ end IdIntro -- 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 +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 Id' @@ -1335,10 +1335,10 @@ 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 : ie.toI a ≫ ie.i1 = M.var _ := by simp [toI] +lemma toI_comp_i1 : toI a ≫ M.var ii.Id = M.var _ := by simp [toI] --- lemma toI_comp_i2 : ie.toI a ≫ ie.i2 = (M.disp _) ≫ ii.toK a := --- by simp [toI] +lemma toI_comp_i2 : toI 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 @@ -1361,25 +1361,25 @@ theorem motiveCtx_isPullback' : def equivMk (x : (ii.motiveCtx a) ⟶ X) : Γ ⟶ (iFunctor (ii:= ii)).obj X := UvPoly.Equiv.mk' a (motiveCtx_isPullback' a).flip x --- def equivFst (pair : Γ ⟶ ie.iFunctor.obj X) : --- Γ ⟶ M.Tm := --- UvPoly.Equiv.fst pair - --- lemma equivFst_comp_left (pair : Γ ⟶ ie.iFunctor.obj X) --- {Δ} (σ : Δ ⟶ Γ) : --- ie.equivFst (σ ≫ pair) = σ ≫ ie.equivFst pair := by --- dsimp [equivFst] --- rw [UvPoly.Equiv.fst_comp_left] - --- def equivSnd (pair : Γ ⟶ ie.iFunctor.obj X) : --- (ii.motiveCtx (equivFst ie pair)) ⟶ X := --- UvPoly.Equiv.snd' pair (ie.motiveCtx_isPullback' _).flip - --- lemma equivSnd_comp_left (pair : Γ ⟶ ie.iFunctor.obj X) --- {Δ} (σ : Δ ⟶ Γ) : --- ie.equivSnd (σ ≫ pair) = --- eqToHom (by simp [equivFst_comp_left]) ≫ ii.motiveSubst σ _ ≫ ie.equivSnd pair := by --- sorry +def equivFst (pair : Γ ⟶ (iFunctor (ii:=ii)).obj X) : + Γ ⟶ M.Tm := + UvPoly.Equiv.fst pair + +lemma equivFst_comp_left (pair : Γ ⟶ (iFunctor (ii:= ii)).obj X) + {Δ} (σ : Δ ⟶ Γ) : + equivFst (σ ≫ pair) = σ ≫ equivFst pair := by + dsimp [equivFst] + rw [UvPoly.Equiv.fst_comp_left] + +def equivSnd (pair : Γ ⟶ (iFunctor (ii:= ii)).obj X) : + (ii.motiveCtx (equivFst pair)) ⟶ X := + UvPoly.Equiv.snd' pair (motiveCtx_isPullback' _).flip + +lemma equivSnd_comp_left (pair : Γ ⟶ iFunctor.obj X) + {Δ} (σ : Δ ⟶ Γ) : + equivSnd (σ ≫ pair) = + eqToHom (by simp [equivFst_comp_left]) ≫ ii.motiveSubst σ _ ≫ equivSnd pair := by + sorry -- dsimp only [equivSnd] -- let a := ie.equivFst pair -- have H : IsPullback (ie.toI a) @@ -1585,11 +1585,11 @@ def lift : Γ ⟶ (iFunctor (ii:= ii)).obj N.Tm := UvPoly.Equiv.mk'_comp_right, r_tp, reflSubst] congr apply (M.disp_pullback _).hom_ext - · conv => right; rw [← toI_comp_i1 ie] + · conv => right; rw [← toI_comp_i1] simp [mkRefl, comparison] · apply (M.disp_pullback _).hom_ext - · slice_rhs 3 4 => rw [← ii.toK_comp_k1] - slice_rhs 2 3 => rw [← ie.toI_comp_i2] + · slice_rhs 3 4 => rw [← toK_comp_k1] + slice_rhs 2 3 => rw [← toI_comp_i2] simp · simp) @@ -1598,20 +1598,21 @@ lemma lift_comp_left {Δ} (σ : Δ ⟶ Γ) : i.lift (σ ≫ a) ((ii.motiveSubst σ ≫ i.lift a C r r_tp := by dsimp [lift] rw [WeakPullback.coherentLift_comp_left] - congr 1 - · dsimp [reflCase] - 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 : ie.equivFst (i.lift a C r r_tp) = a := - calc ie.equivFst (i.lift a C r r_tp) - _ = ie.equivFst (i.lift a C r r_tp ≫ ie.iFunctor.map N.tp) := by + sorry + -- congr 1 + -- · dsimp [reflCase] + -- 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 (i.lift a C r r_tp) = a := + calc equivFst (i.lift a C r r_tp) + _ = equivFst (i.lift a C r r_tp ≫ iFunctor.map N.tp) := by dsimp [IdElimBase.equivFst] rw [UvPoly.Equiv.fst_comp_right] _ = _ := by @@ -1624,8 +1625,9 @@ lemma equivFst_lift_eq : ie.equivFst (i.lift a C r r_tp) = a := Then we obtain a section of the motive `Γ (y : A) (h : Id(A,a,y)) ⊢ mkJ : A` -/ -def j : y(ii.motiveCtx a) ⟶ N.Tm := - eqToHom (by rw [equivFst_lift_eq]) ≫ ie.equivSnd (i.lift a C r r_tp) +--equivFst_lift_eq +def j : (ii.motiveCtx a) ⟶ N.Tm := + eqToHom (by rw[equivFst_lift_eq]) ≫ equivSnd (i.lift a C r r_tp) /-- Typing for elimination rule `J` -/ lemma j_tp : j i a C r r_tp ≫ N.tp = C := by @@ -1636,45 +1638,46 @@ lemma j_tp : j i a C r r_tp ≫ N.tp = C := by rw! [equivFst_lift_eq] simp -lemma comp_j : ym(ii.motiveSubst σ _) ≫ j i a C r r_tp = - j i (ym(σ) ≫ a) (ym(ii.motiveSubst σ _) ≫ C) (ym(σ) ≫ r) (by +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 [ie.equivSnd_comp_left] + 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 : ym(ii.reflSubst a) ≫ j i a C r r_tp = r := 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] +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 : y(Γ) ⟶ M.Tm) (b_tp : b ≫ M.tp = a ≫ M.tp) - (h : y(Γ) ⟶ M.Tm) (h_tp : h ≫ M.tp = ii.isKernelPair.lift b a (by aesop) ≫ ii.Id) +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 ii.isKernelPair.hom_ext + apply (M.disp_pullback _ ).hom_ext · simp · simp) @@ -1689,7 +1692,7 @@ end Id namespace Id' -variable {ii : IdIntro M} {ie : IdElimBase ii} {N : Universe Ctx} (i : M.Id' ii N) +variable {ii : IdIntro M} {N : Universe Ctx} (i : M.Id' ii N) open IdIntro IdElimBase From 67cac1b33bbfd29632a461b9df846983c5911623 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 27 Nov 2025 11:34:43 -0500 Subject: [PATCH 64/95] feat: sorry goals --- .../Model/Structured/StructuredUniverse.lean | 85 ++++++++++++------- 1 file changed, 53 insertions(+), 32 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index dfda4a26..89249571 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1048,10 +1048,21 @@ def toK (a : Γ ⟶ M.Tm) : (M.ext (a ≫ M.tp)) ⟶ M.ext M.tp := 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) +def toPolymorphicIdIntro : + M.toUnstructuredUniverse.PolymorphicIdIntro M.toUnstructuredUniverse where + Id := + have := idIntro -- TODO: remove + sorry + Id_comp := sorry + refl := sorry + refl_comp := sorry + refl_tp := sorry + end IdIntro -- Id' is deprecated in favor of UnstructuredUniverse.PolymorphicIdElim @@ -1065,7 +1076,7 @@ end IdIntro -- 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 +/- 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 @@ -1079,9 +1090,9 @@ protected structure Id' (i : IdIntro M) (N : StructuredUniverse R) where 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 + (i.reflSubst a) ≫ j a C r r_tp = r -/ --- namespace Id' +-- 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) @@ -1157,10 +1168,8 @@ variable {M} -- i2 : i ⟶ M.ext M.tp -- M.disp .. -- i_isPullback : IsPullback i1 i2 M.tp ii.Id -namespace IdElimBase -variable {ii : IdIntro M} --(ie : IdElimBase ii) - - +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⟩ @@ -1185,16 +1194,16 @@ def comparison : M.Tm ⟶ M.ext ii.Id := ii.refl_tp @[simp] -lemma comparison_comp_i1 : comparison ≫ M.var ii.Id = ii.refl := by +lemma comparison_comp_i1 : comparison ii ≫ M.var ii.Id = ii.refl := by simp [comparison] @[simp, reassoc] -lemma comparison_comp_i2_comp_k1 : comparison ≫ M.disp ii.Id ≫ M.var M.tp = +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 : comparison ≫ M.disp ii.Id ≫ M.disp M.tp = +lemma comparison_comp_i2_comp_k2 : ii.comparison ≫ M.disp ii.Id ≫ M.disp M.tp = 𝟙 _ := by simp [comparison] @@ -1205,7 +1214,7 @@ which is defined by the composition of (maps informally thought of as) context e 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.vcomp IdIntro.k2UvPoly + (i2UvPoly ii).vcomp IdIntro.k2UvPoly -- lemma iUvPoly_morphismProperty : R (ie.i2 ≫ M.disp M.tp) := by -- apply R.comp_mem @@ -1287,7 +1296,7 @@ def reflCase : Γ ⟶ (UvPoly.id R M.Tm).functor.obj N.Tm := end reflCase -open IdElimBase IdIntro +open IdIntro section Equiv @@ -1463,7 +1472,9 @@ end end Equiv -end IdElimBase +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 @@ -1497,25 +1508,25 @@ Here we are thinking 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 +structure Id (ii : IdIntro M) (N : StructuredUniverse R) where weakPullback : WeakPullback - (IdElimBase.verticalNatTrans.app N.Tm) - ((IdElimBase.iFunctor (ii:= ii)).map N.tp) + (verticalNatTrans.app N.Tm) + ((iFunctor (ii:= ii)).map N.tp) ((UvPoly.id R M.Tm).functor.map N.tp) - (IdElimBase.verticalNatTrans.app N.Ty) + (verticalNatTrans.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 N) +variable {N : StructuredUniverse R} {ii : IdIntro M} (i : Id ii N) variable {Γ Δ : Ctx} (σ : Δ ⟶ Γ) (a : Γ ⟶ M.Tm) (C : (ii.motiveCtx a) ⟶ N.Ty) (r : Γ ⟶ N.Tm) (r_tp : r ≫ N.tp = (ii.reflSubst a) ≫ C) -open IdElimBase IdIntro +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 @@ -1682,20 +1693,28 @@ def endPtSubst : Γ ⟶ ii.motiveCtx a := · simp) /-- `Id` is equivalent to `Id` (one half). -/ -def toId' : M.Id' ii N where - j := i.j - j_tp := i.j_tp - comp_j := i.comp_j - reflSubst_j := i.reflSubst_j +def toUnstructured : M.toUnstructuredUniverse.PolymorphicIdElim + ii.toPolymorphicIdIntro N.toUnstructuredUniverse where + j := sorry --i.j + j_tp := sorry -- i.j_tp + comp_j := sorry --i.comp_j + reflSubst_j := sorry -- i.reflSubst_j end Id -namespace Id' +def IdIntro.ofUnstructured + (i : M.toUnstructuredUniverse.PolymorphicIdIntro M.toUnstructuredUniverse) : M.IdIntro := + have := i -- TODO remove + sorry -variable {ii : IdIntro M} {N : Universe Ctx} (i : M.Id' ii N) +namespace Id -open IdIntro IdElimBase +variable {N : StructuredUniverse R} + (i : M.toUnstructuredUniverse.PolymorphicIdIntro M.toUnstructuredUniverse) +open IdIntro + +/- variable {Γ} (ar : y(Γ) ⟶ (UvPoly.id M.Tm).functor.obj N.Tm) (aC : y(Γ) ⟶ ie.iFunctor.obj N.Ty) (hrC : ar ≫ (UvPoly.id M.Tm).functor.map N.tp = @@ -1807,8 +1826,12 @@ lemma comp_lift {Δ} (σ : Δ ⟶ Γ) : ym(σ) ≫ lift i ar aC hrC = slice_lhs 2 3 => rw [← toI_comp_i2 ie] simp [toI_comp_left] · simp [motiveSubst, substWk] +-/ + -def toId : M.Id ie N where + +def ofUnstructured (ie : M.toUnstructuredUniverse.PolymorphicIdElim i N.toUnstructuredUniverse) : + M.Id (IdIntro.ofUnstructured i) N where __ := ie weakPullback := RepPullbackCone.WeakPullback.mk ((IdElimBase.verticalNatTrans ie).naturality _).symm @@ -1817,8 +1840,6 @@ def toId : M.Id ie N where (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 Universe +end Id -end StructuredModel +end StructuredUniverse From 911c3c3509d653098630b5111f110ff6e719e7da Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 27 Nov 2025 19:31:10 -0500 Subject: [PATCH 65/95] fix the explicit var --- .../Model/Structured/StructuredUniverse.lean | 74 ++++++++++--------- 1 file changed, 38 insertions(+), 36 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index 89249571..ec1062bc 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1262,9 +1262,10 @@ Tm ----> i VV Tm -/ -def verticalNatTrans : iFunctor (ii:= ii) ⟶ (UvPoly.id R M.Tm).functor := - UvPoly.verticalNatTrans (UvPoly.id R M.Tm) iUvPoly - comparison (by simp [iUvPoly]) +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 @@ -1344,9 +1345,9 @@ 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 a ≫ M.var ii.Id = M.var _ := by simp [toI] +lemma toI_comp_i1 : toI ii a ≫ M.var ii.Id = M.var _ := by simp [toI] -lemma toI_comp_i2 : toI a ≫ M.disp ii.Id = (M.disp _) ≫ toK a := +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) = @@ -1358,36 +1359,36 @@ lemma toI_comp_i2 : toI a ≫ M.disp ii.Id = (M.disp _) ≫ toK a := theorem motiveCtx_isPullback : - IsPullback (toI a) (M.disp _) (M.disp ii.Id) (toK a) := + 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 a) ((M.disp (ii.mkId ((M.disp (a ≫ M.tp)) ≫ a) - (M.var (a ≫ M.tp)) (by simp))) ≫ (M.disp (a ≫ M.tp))) (iUvPoly).p a := - IsPullback.paste_vert (motiveCtx_isPullback a) + 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' a).flip x + UvPoly.Equiv.mk' a (motiveCtx_isPullback' ii a).flip x def equivFst (pair : Γ ⟶ (iFunctor (ii:=ii)).obj X) : Γ ⟶ M.Tm := UvPoly.Equiv.fst pair -lemma equivFst_comp_left (pair : Γ ⟶ (iFunctor (ii:= ii)).obj X) +lemma equivFst_comp_left (pair : Γ ⟶ (iFunctor ii).obj X) {Δ} (σ : Δ ⟶ Γ) : - equivFst (σ ≫ pair) = σ ≫ equivFst pair := by + 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 pair)) ⟶ X := - UvPoly.Equiv.snd' pair (motiveCtx_isPullback' _).flip + (ii.motiveCtx (equivFst ii pair)) ⟶ X := + UvPoly.Equiv.snd' pair (motiveCtx_isPullback' ii _).flip -lemma equivSnd_comp_left (pair : Γ ⟶ iFunctor.obj X) +lemma equivSnd_comp_left (pair : Γ ⟶ (iFunctor ii).obj X) {Δ} (σ : Δ ⟶ Γ) : - equivSnd (σ ≫ pair) = - eqToHom (by simp [equivFst_comp_left]) ≫ ii.motiveSubst σ _ ≫ equivSnd pair := by + 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 @@ -1510,10 +1511,10 @@ we can take `J (y.p.C;x.r) := c`. -/ structure Id (ii : IdIntro M) (N : StructuredUniverse R) where weakPullback : WeakPullback - (verticalNatTrans.app N.Tm) + ((verticalNatTrans ii).app N.Tm) ((iFunctor (ii:= ii)).map N.tp) ((UvPoly.id R M.Tm).functor.map N.tp) - (verticalNatTrans.app N.Ty) + ((verticalNatTrans ii).app N.Ty) -- TODO fix the proof that `StructuredUniverse.Id` is equivalent to -- `UnstructuredUniverse.PolymorphicIdElim` @@ -1568,7 +1569,7 @@ Ty <-- y(motiveCtx) ----> i --instance : MorphismProperty.IsMultiplicative R := sorry instance : MorphismProperty.IsMultiplicative R := sorry abbrev motive : Γ ⟶ (iFunctor (ii:= ii)).obj N.Ty := - equivMk a C + equivMk ii a C -- lemma motive_comp_left : σ ≫ motive a C = -- motive (σ ≫ a) ((ii.motiveSubst σ a) ≫ C) := by @@ -1591,8 +1592,8 @@ instance : HasPullbacks Ctx := sorry def lift : Γ ⟶ (iFunctor (ii:= 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 comparison - _ N.Ty a (motiveCtx_isPullback' a).flip C (reflCase_aux a), + 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 @@ -1621,13 +1622,13 @@ lemma lift_comp_left {Δ} (σ : Δ ⟶ Γ) : i.lift (σ ≫ a) ((ii.motiveSubst -- · simp -- · rw [motive_comp_left] -lemma equivFst_lift_eq : equivFst (i.lift a C r r_tp) = a := - calc equivFst (i.lift a C r r_tp) - _ = equivFst (i.lift a C r r_tp ≫ iFunctor.map N.tp) := by - dsimp [IdElimBase.equivFst] +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, IdElimBase.equivFst, IdElimBase.equivMk] + dsimp [lift, motive, IdIntro.equivFst, IdIntro.equivMk] rw [WeakPullback.coherentLift_snd, UvPoly.Equiv.fst_mk'] /-- The elimination rule for identity types. @@ -1638,14 +1639,14 @@ lemma equivFst_lift_eq : equivFst (i.lift a C r r_tp) = a := -/ --equivFst_lift_eq def j : (ii.motiveCtx a) ⟶ N.Tm := - eqToHom (by rw[equivFst_lift_eq]) ≫ equivSnd (i.lift a C r r_tp) + 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, IdElimBase.equivSnd, ← UvPoly.Equiv.snd'_comp_right] + 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 [IdElimBase.equivMk] + simp only [IdIntro.equivMk] rw! [equivFst_lift_eq] simp @@ -1833,12 +1834,13 @@ lemma comp_lift {Δ} (σ : Δ ⟶ Γ) : ym(σ) ≫ lift i ar aC hrC = def ofUnstructured (ie : M.toUnstructuredUniverse.PolymorphicIdElim i N.toUnstructuredUniverse) : M.Id (IdIntro.ofUnstructured i) N where __ := ie - weakPullback := RepPullbackCone.WeakPullback.mk - ((IdElimBase.verticalNatTrans ie).naturality _).symm - (fun s => lift i s.fst 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 σ) + weakPullback := sorry + -- RepPullbackCone.WeakPullback.mk + -- ((IdIntro.verticalNatTrans sorry ).naturality _).symm + -- (fun s => lift i s.fst 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 From 30abe188b9648d76fddd9453e66c49232f299571 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 11 Dec 2025 16:25:58 +0100 Subject: [PATCH 66/95] problem about motiveCtx --- .../Model/Structured/StructuredUniverse.lean | 183 +++++++++++------- 1 file changed, 112 insertions(+), 71 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index ec1062bc..e357dfab 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1371,7 +1371,7 @@ theorem motiveCtx_isPullback' : 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:=ii)).obj X) : +def equivFst (pair : Γ ⟶ (iFunctor ii).obj X) : Γ ⟶ M.Tm := UvPoly.Equiv.fst pair @@ -1567,7 +1567,7 @@ Ty <-- y(motiveCtx) ----> i ``` -/ --instance : MorphismProperty.IsMultiplicative R := sorry -instance : MorphismProperty.IsMultiplicative R := sorry +--instance : MorphismProperty.IsMultiplicative R := sorry abbrev motive : Γ ⟶ (iFunctor (ii:= ii)).obj N.Ty := equivMk ii a C @@ -1588,8 +1588,13 @@ abbrev motive : Γ ⟶ (iFunctor (ii:= ii)).obj N.Ty := -- slice_rhs 1 2 => rw [← ie.toI_comp_i2] -- simp -instance : HasPullbacks Ctx := sorry -def lift : Γ ⟶ (iFunctor (ii:= ii)).obj N.Tm := +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 + +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) @@ -1613,6 +1618,8 @@ lemma lift_comp_left {Δ} (σ : Δ ⟶ Γ) : i.lift (σ ≫ a) ((ii.motiveSubst 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 @@ -1696,7 +1703,9 @@ def endPtSubst : Γ ⟶ ii.motiveCtx a := /-- `Id` is equivalent to `Id` (one half). -/ def toUnstructured : M.toUnstructuredUniverse.PolymorphicIdElim ii.toPolymorphicIdIntro N.toUnstructuredUniverse where - j := sorry --i.j + j a a_tp C c e := by + #check i.j + sorry --i.j j_tp := sorry -- i.j_tp comp_j := sorry --i.comp_j reflSubst_j := sorry -- i.reflSubst_j @@ -1711,33 +1720,37 @@ def IdIntro.ofUnstructured namespace Id variable {N : StructuredUniverse R} - (i : M.toUnstructuredUniverse.PolymorphicIdIntro M.toUnstructuredUniverse) - + (ii : M.toUnstructuredUniverse.PolymorphicIdIntro M.toUnstructuredUniverse) + (i : M.Id (IdIntro.ofUnstructured ii) N) open IdIntro -/- -variable {Γ} (ar : y(Γ) ⟶ (UvPoly.id M.Tm).functor.obj N.Tm) - (aC : y(Γ) ⟶ ie.iFunctor.obj N.Ty) - (hrC : ar ≫ (UvPoly.id M.Tm).functor.map N.tp = - aC ≫ (verticalNatTrans ie).app N.Ty) +--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 = ie.equivFst aC := +lemma fst_eq_fst : UvPoly.Equiv.fst ar = (IdIntro.ofUnstructured ii).equivFst aC := calc _ - _ = UvPoly.Equiv.fst _ _ (ar ≫ (UvPoly.id M.Tm).functor.map N.tp) := by + _ = UvPoly.Equiv.fst (ar ≫ (UvPoly.id R M.Tm).functor.map N.tp) := by rw [UvPoly.Equiv.fst_comp_right] - _ = UvPoly.Equiv.fst _ _ (aC ≫ (IdElimBase.verticalNatTrans ie).app N.Ty) := by + _ = UvPoly.Equiv.fst (aC ≫ (verticalNatTrans (IdIntro.ofUnstructured ii)).app N.Ty) := by rw [hrC] _ = _ := by - rw [ie.equivFst_verticalNatTrans_app] + sorry + --rw [equivFst_verticalNatTrans_app] + +-- abbrev motive1 : (ii.motiveCtx ((IdIntro.ofUnstructured ii).equivFst aC)) ⟶ N.Ty := +-- ie.equivSnd aC -abbrev motive : y(ii.motiveCtx (ie.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 σ] -lemma comp_motive {Δ} (σ : Δ ⟶ Γ) : motive (ym(σ) ≫ aC) = - ym(ii.motiveSubst σ (ie.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 @@ -1782,66 +1795,94 @@ lemma reflCase_comp_tp : reflCase ar ≫ N.tp = slice_lhs 2 3 => rw [← ie.toI_comp_i2] simp · simp - -def lift : y(Γ) ⟶ (IdElimBase.iFunctor ie).obj N.Tm := - ie.equivMk (ie.equivFst aC) (i.j (ie.equivFst 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] -/ +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] -def ofUnstructured (ie : M.toUnstructuredUniverse.PolymorphicIdElim i N.toUnstructuredUniverse) : - M.Id (IdIntro.ofUnstructured i) N where +end ofUnstructured +def ofUnstructured (ie : M.toUnstructuredUniverse.PolymorphicIdElim ii N.toUnstructuredUniverse) : + M.Id (IdIntro.ofUnstructured ii) N where __ := ie - weakPullback := sorry + 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 s.snd s.condition) + -- ((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 From 799fcf69cc8368342b6ff4becf0b3d8a0b9113e3 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 11 Dec 2025 21:56:53 +0100 Subject: [PATCH 67/95] need context iso --- .../Model/Structured/StructuredUniverse.lean | 21 ++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index e357dfab..2e14592b 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1703,9 +1703,24 @@ def endPtSubst : Γ ⟶ ii.motiveCtx a := /-- `Id` is equivalent to `Id` (one half). -/ def toUnstructured : M.toUnstructuredUniverse.PolymorphicIdElim ii.toPolymorphicIdIntro N.toUnstructuredUniverse where - j a a_tp C c e := by - #check i.j - sorry --i.j + 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 From 93b9ef97762f772400b1aa1d1417cd345d0776e8 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 11 Dec 2025 16:58:55 -0500 Subject: [PATCH 68/95] . --- HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean | 6 ------ 1 file changed, 6 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index 5036d7d4..5bbaaf3e 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -1,9 +1,3 @@ -/- -Copyright (c) 2025 Joseph Hua. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Joseph Hua, Sina Hazratpour, Emily Riehl --/ - import HoTTLean.ForMathlib.CategoryTheory.Clan universe v u v₁ u₁ From ec9cbc4b4278e04fde7850a83b817d503e566fd2 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Mon, 15 Dec 2025 20:21:16 +0100 Subject: [PATCH 69/95] try to resolve the diverge --- .../Model/Structured/StructuredUniverse.lean | 104 ++++++++++++++++++ 1 file changed, 104 insertions(+) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index 2e14592b..76b695a7 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1588,12 +1588,116 @@ abbrev motive : Γ ⟶ (iFunctor (ii:= ii)).obj N.Ty := -- 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) +#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 +-/ + +abbrev toWeakpullback : Γ ⟶ iiM.iFunctor.obj N.Tm := + iMN.weakPullback.lift (W:=Γ) sorry sorry sorry + --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)-/ + +def j : toUnstructuredmotiveCtx _ iiM a a_tp ⟶ N.Tm := by + have s := UvPoly.Equiv.snd (toWeakpullback M N iiM iMN) (Γ := Γ) + convert s + dsimp[toUnstructuredmotiveCtx,toPolymorphicIdIntro] + sorry + --sorry ≫ comparison M N iiM + + --eqToHom (by rw[equivFst_lift_eq ]) ≫ equivSnd ii (i.lift a C r r_tp (ii:= ii)) + +def toUnstructured : M.toUnstructuredUniverse.PolymorphicIdElim + iiM.toPolymorphicIdIntro N.toUnstructuredUniverse where + j := + sorry + comp_j := sorry + j_tp := sorry + 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] From bddfd64a21ee378f8c45c2fec2cf5de14467074b Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Mon, 15 Dec 2025 22:19:01 +0100 Subject: [PATCH 70/95] GammaATmTm --- .../Model/Structured/StructuredUniverse.lean | 51 +++++++++++++++---- 1 file changed, 42 insertions(+), 9 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index 76b695a7..9130fd7b 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -972,6 +972,30 @@ 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⟩ @@ -1053,15 +1077,6 @@ 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) -def toPolymorphicIdIntro : - M.toUnstructuredUniverse.PolymorphicIdIntro M.toUnstructuredUniverse where - Id := - have := idIntro -- TODO: remove - sorry - Id_comp := sorry - refl := sorry - refl_comp := sorry - refl_tp := sorry end IdIntro @@ -1624,6 +1639,24 @@ abbrev toWeakpullback : Γ ⟶ iiM.iFunctor.obj N.Tm := /-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 TmTm : IsPullback (M.disp M.tp) (M.var M.tp) M.tp M.tp := (M.disp_pullback M.tp).flip +instance GammaATmTm: + 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 + + def j : toUnstructuredmotiveCtx _ iiM a a_tp ⟶ N.Tm := by have s := UvPoly.Equiv.snd (toWeakpullback M N iiM iMN) (Γ := Γ) convert s From 67eef80a6bdb50a9dfdedca3c5cdd02122f2a2a0 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Tue, 16 Dec 2025 16:33:55 +0100 Subject: [PATCH 71/95] mtcxToUniversalIdPb --- .../Model/Structured/StructuredUniverse.lean | 37 ++++++++++++++++++- 1 file changed, 35 insertions(+), 2 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index 9130fd7b..ae56605f 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1643,8 +1643,9 @@ abbrev toWeakpullback : Γ ⟶ iiM.iFunctor.obj N.Tm := -/ #check endpts -instance TmTm : IsPullback (M.disp M.tp) (M.var M.tp) M.tp M.tp := (M.disp_pullback M.tp).flip -instance GammaATmTm: +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)) @@ -1656,7 +1657,39 @@ instance GammaATmTm: 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 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 (toWeakpullback M N iiM iMN) (Γ := Γ) convert s From 3f18047fb7087b824499b1d7ef074686b4bb6107 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Tue, 16 Dec 2025 17:10:42 +0100 Subject: [PATCH 72/95] mtcxToTmPb --- .../Model/Structured/StructuredUniverse.lean | 20 +++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index ae56605f..ffb79cab 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1645,9 +1645,20 @@ abbrev toWeakpullback : Γ ⟶ iiM.iFunctor.obj N.Tm := #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 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 + 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 @@ -1688,6 +1699,11 @@ instance mtcxToUniversalIdPb: 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) --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 From 36a4982d116b79351fd1b3a6a12b2a34eba5e28f Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Tue, 16 Dec 2025 20:00:32 +0100 Subject: [PATCH 73/95] maybe toTmTm arguments wrong order... --- .../Model/Structured/StructuredUniverse.lean | 97 +++++++++++-------- 1 file changed, 54 insertions(+), 43 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index ffb79cab..f37422ec 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1538,53 +1538,29 @@ namespace Id variable {N : StructuredUniverse R} {ii : IdIntro M} (i : Id ii N) -variable {Γ Δ : Ctx} (σ : Δ ⟶ Γ) (a : Γ ⟶ M.Tm) - (C : (ii.motiveCtx a) ⟶ N.Ty) (r : Γ ⟶ N.Tm) - (r_tp : r ≫ N.tp = (ii.reflSubst a) ≫ C) +-- variable {Γ Δ : Ctx} (σ : Δ ⟶ Γ) (a : Γ ⟶ M.Tm) +-- (r : Γ ⟶ N.Tm) +-- (r_tp : r ≫ N.tp = (ii.reflSubst a) ≫ C) -open IdIntro +-- 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) +-- 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 -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 + +-- 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 -/-- The variable `C` is the motive for elimination, -This gives a map `(a, C) : Γ ⟶ iFunctor Ty` -``` - C -Ty <-- y(motiveCtx) ----> i - | | - | | i2 ≫ k2 - | | - V V - Γ --------> Tm - a -``` --/ + --instance : MorphismProperty.IsMultiplicative R := sorry --instance : MorphismProperty.IsMultiplicative R := sorry -abbrev motive : Γ ⟶ (iFunctor (ii:= ii)).obj N.Ty := - equivMk ii a C +-- 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 @@ -1609,7 +1585,8 @@ abbrev motive : Γ ⟶ (iFunctor (ii:= ii)).obj N.Ty := 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) +(a_tp: a ≫ M.tp = A) (iMN: Id iiM N) (r : Γ ⟶ N.Tm) + #check toPolymorphicIdIntro abbrev toUnstructuredmotiveCtx : Ctx := @@ -1632,8 +1609,22 @@ abbrev comparison : pullback ((UvPoly.id R M.Tm).functor.map N.tp) UvPoly.Equiv.snd' pair (motiveCtx_isPullback' ii _).flip -/ -abbrev toWeakpullback : Γ ⟶ iiM.iFunctor.obj N.Tm := - iMN.weakPullback.lift (W:=Γ) sorry sorry sorry +--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) = @@ -1668,7 +1659,7 @@ instance GammaATmTmPb : 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])) +--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) @@ -1705,9 +1696,29 @@ instance mtcxToTmPb : IsPullback (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 + +abbrev toWeakpullback (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ ⟶ N.Tm): + Γ ⟶ iiM.iFunctor.obj N.Tm := + iMN.weakPullback.lift (W:=Γ) (toWeakpullback1 M N a r) (toWeakpullback2 M N iiM a a_tp C) + (by + dsimp[toWeakpullback1,toWeakpullback2] + sorry) + + --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 (toWeakpullback M N iiM iMN) (Γ := Γ) +def j (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ ⟶ N.Tm) : + toUnstructuredmotiveCtx _ iiM a a_tp ⟶ N.Tm := by + let pair := (toWeakpullback (Γ := Γ) M N iiM a a_tp iMN) + have s := UvPoly.Equiv.snd' (R:=R) (P:= iUvPoly iiM) (toWeakpullback (Γ := Γ) M N iiM a a_tp iMN C r) + (by convert (mtcxToTmPb M iiM a a_tp).flip + sorry --simp[toWeakpullback] + ) convert s dsimp[toUnstructuredmotiveCtx,toPolymorphicIdIntro] sorry From 7b0a9f7bcee3a6d0f75f6f02e23a1e4858742118 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Fri, 19 Dec 2025 21:42:25 +0100 Subject: [PATCH 74/95] problem on lime 1744 --- .../Model/Structured/StructuredUniverse.lean | 51 ++++++++++++++++--- .../Unstructured/UnstructuredUniverse.lean | 2 +- 2 files changed, 46 insertions(+), 7 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index f37422ec..ffa7835f 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -5,7 +5,7 @@ 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 @@ -1647,6 +1647,11 @@ instance TmTmPb : IsPullback (M.disp M.tp) (M.var M.tp) M.tp M.tp := (M.disp_p -- 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 @@ -1702,26 +1707,60 @@ abbrev toWeakpullback1 (r : Γ ⟶ N.Tm) : Γ ⟶ (UvPoly.id R M.Tm).functor.obj 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) -abbrev toWeakpullback (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ ⟶ N.Tm): +-/ +#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[]) + + +abbrev toWeakpullback (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): Γ ⟶ iiM.iFunctor.obj N.Tm := iMN.weakPullback.lift (W:=Γ) (toWeakpullback1 M N a r) (toWeakpullback2 M N iiM a a_tp C) (by dsimp[toWeakpullback1,toWeakpullback2] + have H := mtcxToTmPb M iiM a a_tp + 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[] + simp[r_tp] + sorry sorry) --instance mtcxPb : IsPullback (M.disp iiM.Id) (M.var iiM.Id) iiM.Id M.tp def j (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ ⟶ N.Tm) : toUnstructuredmotiveCtx _ iiM a a_tp ⟶ N.Tm := by - let pair := (toWeakpullback (Γ := Γ) M N iiM a a_tp iMN) - have s := UvPoly.Equiv.snd' (R:=R) (P:= iUvPoly iiM) (toWeakpullback (Γ := Γ) M N iiM a a_tp iMN C r) + --let pair := (toWeakpullback (Γ := Γ) M N iiM a a_tp iMN) + have s := UvPoly.Equiv.snd' (R:=R) (P:= iUvPoly iiM) + (toWeakpullback (Γ := Γ) M N iiM a a_tp iMN C r) (by convert (mtcxToTmPb M iiM a a_tp).flip + simp[toWeakpullback] + sorry --simp[toWeakpullback] ) convert s - dsimp[toUnstructuredmotiveCtx,toPolymorphicIdIntro] - sorry + --dsimp[toUnstructuredmotiveCtx,toPolymorphicIdIntro] + --simp[toTmTm] + --sorry --sorry ≫ comparison M N iiM --eqToHom (by rw[equivFst_lift_eq ]) ≫ equivSnd ii (i.lift a C r r_tp (ii:= ii)) diff --git a/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean b/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean index a7fa0d21..aab16e70 100644 --- a/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean +++ b/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean @@ -390,7 +390,7 @@ lemma refl_tp' : i.refl a a_tp ≫ U1.tp = i.Id a a a_tp a_tp := refl_tp .. `Γ.(x : A) ⊢ Id(a,x) : U1.Ty` -/ @[simp] abbrev weakenId : U0.ext A ⟶ U1.Ty := - i.Id (A := U0.disp A ≫ A) (U0.disp A ≫ a) (U0.var A) (by cat_disch) (by cat_disch) + i.Id (A := U0.disp A ≫ A) (U0.var A) (U0.disp A ≫ a) (by cat_disch) (by cat_disch) lemma weakenId_comp : i.weakenId (A := σ ≫ A) (σ ≫ a) (by simp [a_tp]) = U0.substWk σ A ≫ i.weakenId a a_tp := by From 3daafd347ca6cc514e03b3b54fd1eadd7a5b8991 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Fri, 19 Dec 2025 21:46:42 +0100 Subject: [PATCH 75/95] constructing j --- HoTTLean/Model/Structured/StructuredUniverse.lean | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index ffa7835f..b75fbebe 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1747,13 +1747,15 @@ abbrev toWeakpullback (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ --instance mtcxPb : IsPullback (M.disp iiM.Id) (M.var iiM.Id) iiM.Id M.tp -def j (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ ⟶ N.Tm) : +def j (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): toUnstructuredmotiveCtx _ iiM a a_tp ⟶ N.Tm := by --let pair := (toWeakpullback (Γ := Γ) M N iiM a a_tp iMN) have s := UvPoly.Equiv.snd' (R:=R) (P:= iUvPoly iiM) - (toWeakpullback (Γ := Γ) M N iiM a a_tp iMN C r) + (toWeakpullback (Γ := Γ) M N iiM a a_tp iMN C r r_tp) (by convert (mtcxToTmPb M iiM a a_tp).flip simp[toWeakpullback] + --simp[toWeakpullback] sorry --simp[toWeakpullback] ) From 37363a75a659f219aa89a0a29d1ce94417ae71cf Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sat, 20 Dec 2025 22:32:42 +0100 Subject: [PATCH 76/95] snd proj eq --- .../Model/Structured/StructuredUniverse.lean | 32 ++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index b75fbebe..3d802f82 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1727,7 +1727,7 @@ abbrev reflSubst: Γ ⟶ M.ext (toTmTm M a a_tp ≫ iiM.Id) := congr 1 apply (M.disp_pullback _).hom_ext <;> simp[]) - +--(UvPoly.id R M.Tm).p = iiM.comparison ≫ iiM.iUvPoly.p lemma? abbrev toWeakpullback (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): Γ ⟶ iiM.iFunctor.obj N.Tm := @@ -1742,7 +1742,37 @@ abbrev toWeakpullback (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ simp[])] simp[] simp[r_tp] + simp[verticalNatTrans] + #check UvPoly.mk'_comp_verticalNatTrans_app + have p: IsPullback (M.disp (toTmTm M a a_tp ≫ iiM.Id) ≫ M.disp A) + (mtcxToUniversalId M iiM a a_tp) a + (M.disp iiM.Id ≫ M.disp M.tp) := H.flip + 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] + have e:= UvPoly.mk'_comp_verticalNatTrans_app (X:= N.Ty) (P:= UvPoly.id R M.Tm) (Q:= iiM.iUvPoly) + (ρ := iiM.comparison) (h:= h) (b:= a) (H:= H.flip) (x:=C) (H':= (idPb M a).flip) + rw![e] + simp + congr 1 + simp[reflSubst] + fapply (M.disp_pullback _).hom_ext + · --have e1 : + 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 sorry + --(H:= by convert (idPb M a).flip) + -- have e1:= UvPoly.mk'_comp_verticalNatTrans_app (H := p) + -- rw![UvPoly.mk'_comp_verticalNatTrans_app] + -- simp[UvPoly.Equiv.snd',UvPoly.Equiv.snd ,MvPoly.Equiv.snd] + + -- --UvPoly.fst_verticalNatTrans_app + -- sorry + sorry) From e17c84a5e42a027a5085999543dfe73d8ee61c0d Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sat, 20 Dec 2025 23:01:58 +0100 Subject: [PATCH 77/95] need another one or two proj eq --- .../Model/Structured/StructuredUniverse.lean | 21 ++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index 3d802f82..fdea642f 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1756,15 +1756,30 @@ abbrev toWeakpullback (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ congr 1 simp[reflSubst] fapply (M.disp_pullback _).hom_ext - · --have e1 : - simp[] + · 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 - sorry + 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 + · sorry --(H:= by convert (idPb M a).flip) -- have e1:= UvPoly.mk'_comp_verticalNatTrans_app (H := p) -- rw![UvPoly.mk'_comp_verticalNatTrans_app] From 7a932776704c356adb87add8bb32414ceb1ba4d6 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 21 Dec 2025 08:41:24 +0100 Subject: [PATCH 78/95] toWeakpullback --- .../Model/Structured/StructuredUniverse.lean | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index fdea642f..c0cd959f 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1744,9 +1744,9 @@ abbrev toWeakpullback (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ simp[r_tp] simp[verticalNatTrans] #check UvPoly.mk'_comp_verticalNatTrans_app - have p: IsPullback (M.disp (toTmTm M a a_tp ≫ iiM.Id) ≫ M.disp A) - (mtcxToUniversalId M iiM a a_tp) a - (M.disp iiM.Id ≫ M.disp M.tp) := H.flip + -- have p: IsPullback (M.disp (toTmTm M a a_tp ≫ iiM.Id) ≫ M.disp A) + -- (mtcxToUniversalId M iiM a a_tp) a + -- (M.disp iiM.Id ≫ M.disp M.tp) := H.flip 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] have e:= UvPoly.mk'_comp_verticalNatTrans_app (X:= N.Ty) (P:= UvPoly.id R M.Tm) (Q:= iiM.iUvPoly) @@ -1779,7 +1779,7 @@ abbrev toWeakpullback (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ · rw[e3] simp only[← Category.assoc] simp - · sorry + · simp --(H:= by convert (idPb M a).flip) -- have e1:= UvPoly.mk'_comp_verticalNatTrans_app (H := p) -- rw![UvPoly.mk'_comp_verticalNatTrans_app] @@ -1787,8 +1787,15 @@ abbrev toWeakpullback (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ -- --UvPoly.fst_verticalNatTrans_app -- sorry - - sorry) + simp[verticalNatTrans] + 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] + have e:= UvPoly.mk'_comp_verticalNatTrans_app (X:= N.Ty) (P:= UvPoly.id R M.Tm) (Q:= iiM.iUvPoly) + (ρ := iiM.comparison) (h:= h) (b:= a) (H:= H.flip) (x:=C) (H':= (idPb M a).flip) + 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'] + ) --instance mtcxPb : IsPullback (M.disp iiM.Id) (M.var iiM.Id) iiM.Id M.tp From 1dddbd3d89bd0bb626acb75fe86322416b376e46 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 21 Dec 2025 22:08:06 +0100 Subject: [PATCH 79/95] HasPullbacks |-> HasPullback f g, j def --- .../CategoryTheory/WeakPullback.lean | 8 +- .../Model/Structured/StructuredUniverse.lean | 73 ++++++++----------- 2 files changed, 36 insertions(+), 45 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/WeakPullback.lean b/HoTTLean/ForMathlib/CategoryTheory/WeakPullback.lean index 90acf3dd..9d436fbc 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/WeakPullback.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/WeakPullback.lean @@ -28,18 +28,18 @@ 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' ⟶ W) : σ ≫ wp.coherentLift a b h = wp.coherentLift (σ ≫ a) (σ ≫ b) (by simp [h]) := by simp only [coherentLift, ← Category.assoc] diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index c0cd959f..63a78553 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1728,33 +1728,32 @@ abbrev reflSubst: Γ ⟶ M.ext (toTmTm M a a_tp ≫ iiM.Id) := 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 + abbrev toWeakpullback (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): Γ ⟶ iiM.iFunctor.obj N.Tm := - iMN.weakPullback.lift (W:=Γ) (toWeakpullback1 M N a r) (toWeakpullback2 M N iiM a a_tp C) + iMN.weakPullback.coherentLift (W:=Γ) (toWeakpullback1 M N a r) (toWeakpullback2 M N iiM a a_tp C) (by - dsimp[toWeakpullback1,toWeakpullback2] + 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[] - simp[r_tp] - simp[verticalNatTrans] - #check UvPoly.mk'_comp_verticalNatTrans_app - -- have p: IsPullback (M.disp (toTmTm M a a_tp ≫ iiM.Id) ≫ M.disp A) - -- (mtcxToUniversalId M iiM a a_tp) a - -- (M.disp iiM.Id ≫ M.disp M.tp) := H.flip - 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] - have e:= UvPoly.mk'_comp_verticalNatTrans_app (X:= N.Ty) (P:= UvPoly.id R M.Tm) (Q:= iiM.iUvPoly) - (ρ := iiM.comparison) (h:= h) (b:= a) (H:= H.flip) (x:=C) (H':= (idPb M a).flip) + simp only [UvPoly.Equiv.snd'_mk',r_tp] rw![e] - simp + simp only [UvPoly.vcomp_p, i2UvPoly_p, k2UvPoly_p, UvPoly.Equiv.snd'_mk'] congr 1 - simp[reflSubst] fapply (M.disp_pullback _).hom_ext · simp[] have e1 : M.var (toTmTm M a a_tp ≫ iiM.Id) = @@ -1762,7 +1761,7 @@ abbrev toWeakpullback (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ rw[e1] simp only[←Category.assoc] simp - 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 @@ -1778,46 +1777,38 @@ abbrev toWeakpullback (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ · simp · rw[e3] simp only[← Category.assoc] - simp + simp only [IsPullback.lift_snd, Category.assoc, comparison_comp_i2_comp_k1, + Category.comp_id] · simp - --(H:= by convert (idPb M a).flip) - -- have e1:= UvPoly.mk'_comp_verticalNatTrans_app (H := p) - -- rw![UvPoly.mk'_comp_verticalNatTrans_app] - -- simp[UvPoly.Equiv.snd',UvPoly.Equiv.snd ,MvPoly.Equiv.snd] - - -- --UvPoly.fst_verticalNatTrans_app - -- sorry - simp[verticalNatTrans] - 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] - have e:= UvPoly.mk'_comp_verticalNatTrans_app (X:= N.Ty) (P:= UvPoly.id R M.Tm) (Q:= iiM.iUvPoly) - (ρ := iiM.comparison) (h:= h) (b:= a) (H:= H.flip) (x:=C) (H':= (idPb M a).flip) 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 (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): + 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 (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): toUnstructuredmotiveCtx _ iiM a a_tp ⟶ N.Tm := by - --let pair := (toWeakpullback (Γ := Γ) M N iiM a a_tp iMN) 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 - simp[toWeakpullback] - --simp[toWeakpullback] - - sorry --simp[toWeakpullback] - ) + apply j_aux) convert s - --dsimp[toUnstructuredmotiveCtx,toPolymorphicIdIntro] - --simp[toTmTm] - --sorry - --sorry ≫ comparison M N iiM - - --eqToHom (by rw[equivFst_lift_eq ]) ≫ equivSnd ii (i.lift a C r r_tp (ii:= ii)) def toUnstructured : M.toUnstructuredUniverse.PolymorphicIdElim iiM.toPolymorphicIdIntro N.toUnstructuredUniverse where From 9bd374c1e6a4f0c88151401de5c8a17bdcf817e5 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Mon, 22 Dec 2025 08:15:40 +0100 Subject: [PATCH 80/95] j_tp --- .../Model/Structured/StructuredUniverse.lean | 49 +++++++++++++++---- 1 file changed, 39 insertions(+), 10 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index 63a78553..9c6fa9a7 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1736,8 +1736,10 @@ abbrev reflSubst: Γ ⟶ M.ext (toTmTm M a a_tp ≫ iiM.Id) := -/ --instance : HasPullbacks Ctx:=sorry -abbrev toWeakpullback (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): +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 @@ -1790,8 +1792,7 @@ abbrev toWeakpullback (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ lemma coherentLift_fst [HasPullback f g] : wp.coherentLift a b h ≫ fst = a := by simp [coherentLift] -/ -lemma j_aux (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): +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 ≫ @@ -1801,8 +1802,7 @@ lemma j_aux (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ ⟶ N.Tm) --instance mtcxPb : IsPullback (M.disp iiM.Id) (M.var iiM.Id) iiM.Id M.tp -def j (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): +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) @@ -1810,13 +1810,42 @@ def j (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty) (r : Γ ⟶ N.Tm) apply j_aux) convert s -def toUnstructured : M.toUnstructuredUniverse.PolymorphicIdElim + +--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 := - sorry + 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 := sorry + j_tp := by simp[j_tp] reflSubst_j := sorry + end -- def toUnstructured : M.toUnstructuredUniverse.PolymorphicIdElim From f97820a18a6bb124e21520c788fd6360f2972539 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sat, 10 Jan 2026 21:10:45 +0100 Subject: [PATCH 81/95] try to unify structured + unstructured motiveCtx etc API --- HoTTLean/Model/Structured/Structured1.lean | 145 +++++++++++++++++++++ 1 file changed, 145 insertions(+) create mode 100644 HoTTLean/Model/Structured/Structured1.lean diff --git a/HoTTLean/Model/Structured/Structured1.lean b/HoTTLean/Model/Structured/Structured1.lean new file mode 100644 index 00000000..654bc450 --- /dev/null +++ b/HoTTLean/Model/Structured/Structured1.lean @@ -0,0 +1,145 @@ +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]) + +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) (by cat_disch) i ⟶ motiveCtx A a a_tp i := by + convert + IdCommon.motiveSubst (i.weakenId a a_tp) σ + simp[motiveCtx]; + congr + simp[← i.Id_comp] + +def reflSubst : Γ ⟶ i.motiveCtx a a_tp := + IdCommon.reflSubst a a_tp (i.weakenId a a_tp) (i.refl a a_tp) + (by simp[← i.Id_comp]) + +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 endpts (a0 a1:Γ ⟶ U.Tm) (h: a0 ≫ U.tp = a1 ≫ U.tp): Γ ⟶ U.ext U.tp := + (U.disp_pullback U.tp).lift a0 a1 h + + +abbrev toTmTm : U.ext A ⟶ U.ext U.tp := (endpts (U.var A) (U.disp A ≫ a) (by simp[a_tp])) + + +def motiveSubst {Δ} (σ : Δ ⟶ Γ) : + motiveCtx (σ ≫ a) i ⟶ motiveCtx a i := by + convert + IdCommon.motiveSubst (toTmTm A a a_tp ≫ i.Id) σ + simp[motiveCtx]; + congr 1 + · simp[a_tp] + · --simp[← i.Id_comp] + subst a_tp + rw![Category.assoc] + simp[heq_eq_eq] + simp[mkId] + simp[← Category.assoc] + congr 1 + apply (U.disp_pullback _).hom_ext + · simp + · simp + · simp[motiveCtx] + congr 1 + subst a_tp + simp[heq_eq_eq] + simp[mkId] + + +def reflSubst : Γ ⟶ motiveCtx a i := by + convert + IdCommon.reflSubst a a_tp (toTmTm A 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 + simp + ) + simp[motiveCtx] + congr 1 + subst a_tp + simp[mkId] + + +end StructuredId + + +end Model From 2baff389b01af08c9e11dd56e4985068db66d49b Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 11 Jan 2026 09:38:47 +0100 Subject: [PATCH 82/95] feat:sec_substWk --- HoTTLean/Model/Unstructured/UnstructuredUniverse.lean | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean b/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean index aab16e70..09348331 100644 --- a/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean +++ b/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean @@ -216,6 +216,13 @@ 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 a_tp = M.sec (σ ≫ A) (σ ≫ a) (by simp[a_tp]) ≫ + M.substWk σ A (σ ≫ A) rfl := 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), From e169bc719f03f8685ffb92509acbed6f07faaff9 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 11 Jan 2026 10:34:08 +0100 Subject: [PATCH 83/95] backup before making A implicit --- HoTTLean/Model/Structured/Structured1.lean | 46 ++++++++++++++++++++++ 1 file changed, 46 insertions(+) diff --git a/HoTTLean/Model/Structured/Structured1.lean b/HoTTLean/Model/Structured/Structured1.lean index 654bc450..0ea661b6 100644 --- a/HoTTLean/Model/Structured/Structured1.lean +++ b/HoTTLean/Model/Structured/Structured1.lean @@ -31,6 +31,20 @@ def reflSubst (IdTy: U0.ext A ⟶ U1.Ty) (reflTm: Γ ⟶ U1.Tm) U1.substCons (sec U0 A a (by simp[a_tp])) IdTy reflTm (by simp[reflTmTy]) +--lemma reflSubst_var + +@[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[reflTmTy] + simp[← Category.assoc,sec_substWk]) ≫ + motiveSubst IdTy σ = + σ ≫ reflSubst a a_tp IdTy reflTm reflTmTy := by + apply (disp_pullback ..).hom_ext <;> simp[reflSubst,motiveSubst,sec_substWk] + end IdCommon namespace UnstructuredId @@ -52,6 +66,38 @@ def reflSubst : Γ ⟶ i.motiveCtx a a_tp := 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) (by simp[a_tp]) i ≫ motiveSubst A a a_tp i σ = + σ ≫ reflSubst 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] + +structure PolymorphicIdElim (U2 : UnstructuredUniverse Ctx) where + (j : ∀ {Γ} {A : Γ ⟶ U0.Ty} (a : Γ ⟶ U0.Tm) (a_tp : a ≫ U0.tp = A) + (C : motiveCtx A a a_tp i ⟶ U2.Ty) (c : Γ ⟶ U2.Tm), + (c ≫ U2.tp = (reflSubst A a a_tp i) ≫ C) → (motiveCtx A a a_tp i ⟶ U2.Tm)) + (comp_j : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} (a : Γ ⟶ U0.Tm) + (a_tp : a ≫ U0.tp = A) (C : motiveCtx A a a_tp i ⟶ U2.Ty) (c : Γ ⟶ U2.Tm) + (c_tp : c ≫ U2.tp = (reflSubst A a a_tp i) ≫ C), + j (σ ≫ a) (by cat_disch) (motiveSubst A a a_tp i σ ≫ C) (σ ≫ c) + (by simp[c_tp]) = + motiveSubst A 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 a_tp i ⟶ U2.Ty) (c : Γ ⟶ U2.Tm) + (c_tp : c ≫ U2.tp = (reflSubst A 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 a_tp i ⟶ U2.Ty) (c : Γ ⟶ U2.Tm) + (c_tp : c ≫ U2.tp = (reflSubst A a a_tp i) ≫ C), + reflSubst A a a_tp i ≫ j a a_tp C c c_tp = c) + + end UnstructuredId From 15b96814f8f3a6f6b30e9012483837d395857a23 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 11 Jan 2026 10:34:57 +0100 Subject: [PATCH 84/95] backup before making A implicit --- HoTTLean/Model/Unstructured/UnstructuredUniverse.lean | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean b/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean index 09348331..1780c798 100644 --- a/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean +++ b/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean @@ -403,6 +403,11 @@ 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 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 := From cf1295237483f6f7e85fb94090a16e10ace4ba15 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 11 Jan 2026 11:00:29 +0100 Subject: [PATCH 85/95] make argument A implicit --- HoTTLean/Model/Structured/Structured1.lean | 38 ++++++++++++---------- 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/HoTTLean/Model/Structured/Structured1.lean b/HoTTLean/Model/Structured/Structured1.lean index 0ea661b6..bc14b29c 100644 --- a/HoTTLean/Model/Structured/Structured1.lean +++ b/HoTTLean/Model/Structured/Structured1.lean @@ -49,20 +49,21 @@ 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) +{Γ: 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) (by cat_disch) i ⟶ motiveCtx A a a_tp i := by + 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 + congr 1 simp[← i.Id_comp] -def reflSubst : Γ ⟶ i.motiveCtx a a_tp := + +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]) @@ -70,32 +71,33 @@ abbrev IdTy := (i.weakenId a a_tp) @[reassoc (attr := simp)] lemma reflSubst_comp_motiveSubst {Δ} (σ : Δ ⟶ Γ) : - reflSubst (σ ≫ A) (σ ≫ a) (by simp[a_tp]) i ≫ motiveSubst A a a_tp i σ = - σ ≫ reflSubst A a a_tp i := by + 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] + 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 a_tp i ⟶ U2.Ty) (c : Γ ⟶ U2.Tm), - (c ≫ U2.tp = (reflSubst A a a_tp i) ≫ C) → (motiveCtx A a a_tp i ⟶ U2.Tm)) + (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 a_tp i ⟶ U2.Ty) (c : Γ ⟶ U2.Tm) - (c_tp : c ≫ U2.tp = (reflSubst A a a_tp i) ≫ C), - j (σ ≫ a) (by cat_disch) (motiveSubst A a a_tp i σ ≫ C) (σ ≫ c) + (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 a_tp i σ ≫ j a a_tp C c 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 a_tp i ⟶ U2.Ty) (c : Γ ⟶ U2.Tm) - (c_tp : c ≫ U2.tp = (reflSubst A a a_tp i) ≫ C), + (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 a_tp i ⟶ U2.Ty) (c : Γ ⟶ U2.Tm) - (c_tp : c ≫ U2.tp = (reflSubst A a a_tp i) ≫ C), - reflSubst A a a_tp i ≫ j a a_tp C c c_tp = c) + (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 From 85c765d42e48e95196e9652054ccb3c24fbfff62 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 11 Jan 2026 12:19:09 +0100 Subject: [PATCH 86/95] stupid long proof for structured reflSubst_comp_motiveSubst --- HoTTLean/Model/Structured/Structured1.lean | 54 +++++++++++++++++++--- 1 file changed, 48 insertions(+), 6 deletions(-) diff --git a/HoTTLean/Model/Structured/Structured1.lean b/HoTTLean/Model/Structured/Structured1.lean index bc14b29c..57ee4c2b 100644 --- a/HoTTLean/Model/Structured/Structured1.lean +++ b/HoTTLean/Model/Structured/Structured1.lean @@ -67,7 +67,7 @@ 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) +--abbrev IdTy := (i.weakenId a a_tp) @[reassoc (attr := simp)] lemma reflSubst_comp_motiveSubst {Δ} (σ : Δ ⟶ Γ) : @@ -105,7 +105,7 @@ 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) +{Γ: 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 @@ -143,14 +143,14 @@ def motiveCtx : Ctx := IdCommon.motiveCtx (mkId i (U.disp (a ≫ U.tp) ≫ a) (U abbrev endpts (a0 a1:Γ ⟶ U.Tm) (h: a0 ≫ U.tp = a1 ≫ U.tp): Γ ⟶ U.ext U.tp := (U.disp_pullback U.tp).lift a0 a1 h - +#check substCons abbrev toTmTm : U.ext A ⟶ U.ext U.tp := (endpts (U.var A) (U.disp A ≫ a) (by simp[a_tp])) - +--todo: what is it in terms of substCons? def motiveSubst {Δ} (σ : Δ ⟶ Γ) : motiveCtx (σ ≫ a) i ⟶ motiveCtx a i := by convert - IdCommon.motiveSubst (toTmTm A a a_tp ≫ i.Id) σ + IdCommon.motiveSubst (toTmTm a a_tp ≫ i.Id) σ simp[motiveCtx]; congr 1 · simp[a_tp] @@ -173,7 +173,7 @@ def motiveSubst {Δ} (σ : Δ ⟶ Γ) : def reflSubst : Γ ⟶ motiveCtx a i := by convert - IdCommon.reflSubst a a_tp (toTmTm A a a_tp ≫ i.Id) (a ≫ i.refl) + IdCommon.reflSubst a a_tp (toTmTm a a_tp ≫ i.Id) (a ≫ i.refl) (by simp[i.refl_tp] simp[← Category.assoc] congr 1 @@ -186,6 +186,48 @@ def reflSubst : Γ ⟶ motiveCtx a i := by subst a_tp simp[mkId] +-- 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[toTmTm,endpts,i.refl_tp] + simp[← Category.assoc] + congr 1 + apply (disp_pullback ..).hom_ext <;> simp --toTmTm + endpts not good API, perhaps stick to substCons + ) σ + convert e <;> simp[motiveCtx] + · congr 1 + simp[toTmTm,endpts,mkId] + subst a_tp + congr 1 + --do not think mkId is good design either, without lemmas + · subst a_tp + congr 1 + · simp--this is assoc... + simp[mkId,toTmTm,endpts] + simp[← Category.assoc] + congr 1 + · simp + simp[substWk] + rw![Category.assoc] + simp[heq_eq_eq] + apply (disp_pullback ..).hom_ext <;> simp + · simp[mkId,toTmTm,endpts] + rw![a_tp] + · simp[substWk,toTmTm,endpts,substCons] + rw![a_tp] + congr! 1 + simp[← Category.assoc] + congr 1 + apply (disp_pullback ..).hom_ext <;> simp + · simp[mkId,toTmTm,endpts] + rw![a_tp] + end StructuredId From c93a0397df2a90fc0a78c46e6fc4a29a1a7a9c7c Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 11 Jan 2026 12:34:53 +0100 Subject: [PATCH 87/95] get rid of using endpts --- HoTTLean/Model/Structured/Structured1.lean | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/HoTTLean/Model/Structured/Structured1.lean b/HoTTLean/Model/Structured/Structured1.lean index 57ee4c2b..dbc6f105 100644 --- a/HoTTLean/Model/Structured/Structured1.lean +++ b/HoTTLean/Model/Structured/Structured1.lean @@ -144,7 +144,14 @@ abbrev endpts (a0 a1:Γ ⟶ U.Tm) (h: a0 ≫ U.tp = a1 ≫ U.tp): Γ ⟶ U.ext U (U.disp_pullback U.tp).lift a0 a1 h #check substCons -abbrev toTmTm : U.ext A ⟶ U.ext U.tp := (endpts (U.var A) (U.disp A ≫ a) (by simp[a_tp])) +/-def substCons {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) + (t : Δ ⟶ M.Tm) (t_tp : t ≫ M.tp = σ ≫ A) : + Δ ⟶ M.ext A := + (M.disp_pullback A).lift t σ t_tp +-/ +abbrev toTmTm : U.ext A ⟶ U.ext U.tp := + (U.disp_pullback U.tp).lift (U.var A) (U.disp A ≫ a) (by simp[a_tp]) +--(endpts (U.var A) (U.disp A ≫ a) (by simp[a_tp])) --todo: what is it in terms of substCons? def motiveSubst {Δ} (σ : Δ ⟶ Γ) : @@ -195,21 +202,21 @@ lemma reflSubst_comp_motiveSubst {Δ} (σ : Δ ⟶ Γ) : simp[reflSubst,motiveSubst] have e := IdCommon.reflSubst_comp_motiveSubst a a_tp (toTmTm a a_tp ≫ i.Id) (a ≫ i.refl) - (by simp[toTmTm,endpts,i.refl_tp] + (by simp[i.refl_tp] simp[← Category.assoc] congr 1 apply (disp_pullback ..).hom_ext <;> simp --toTmTm + endpts not good API, perhaps stick to substCons ) σ convert e <;> simp[motiveCtx] · congr 1 - simp[toTmTm,endpts,mkId] + simp[mkId] subst a_tp congr 1 --do not think mkId is good design either, without lemmas · subst a_tp congr 1 · simp--this is assoc... - simp[mkId,toTmTm,endpts] + simp[mkId] simp[← Category.assoc] congr 1 · simp @@ -217,15 +224,15 @@ lemma reflSubst_comp_motiveSubst {Δ} (σ : Δ ⟶ Γ) : rw![Category.assoc] simp[heq_eq_eq] apply (disp_pullback ..).hom_ext <;> simp - · simp[mkId,toTmTm,endpts] + · simp[mkId] rw![a_tp] - · simp[substWk,toTmTm,endpts,substCons] + · simp[substWk,substCons] rw![a_tp] congr! 1 simp[← Category.assoc] congr 1 apply (disp_pullback ..).hom_ext <;> simp - · simp[mkId,toTmTm,endpts] + · simp[mkId] rw![a_tp] From d075a313081aeeca90c8777eb2538f4371c1b647 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 11 Jan 2026 12:41:04 +0100 Subject: [PATCH 88/95] make things a bit shorter by using substCons --- HoTTLean/Model/Structured/Structured1.lean | 31 +++++++--------------- 1 file changed, 9 insertions(+), 22 deletions(-) diff --git a/HoTTLean/Model/Structured/Structured1.lean b/HoTTLean/Model/Structured/Structured1.lean index dbc6f105..14481f7f 100644 --- a/HoTTLean/Model/Structured/Structured1.lean +++ b/HoTTLean/Model/Structured/Structured1.lean @@ -139,18 +139,9 @@ theorem comp_mkRefl {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (a : Γ ⟶ U.Tm) : def motiveCtx : Ctx := IdCommon.motiveCtx (mkId i (U.disp (a ≫ U.tp) ≫ a) (U.var _) (by simp)) - -abbrev endpts (a0 a1:Γ ⟶ U.Tm) (h: a0 ≫ U.tp = a1 ≫ U.tp): Γ ⟶ U.ext U.tp := - (U.disp_pullback U.tp).lift a0 a1 h - -#check substCons -/-def substCons {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) - (t : Δ ⟶ M.Tm) (t_tp : t ≫ M.tp = σ ≫ A) : - Δ ⟶ M.ext A := - (M.disp_pullback A).lift t σ t_tp --/ abbrev toTmTm : U.ext A ⟶ U.ext U.tp := - (U.disp_pullback U.tp).lift (U.var A) (U.disp A ≫ a) (by simp[a_tp]) + U.substCons (U.disp A ≫ a) U.tp (U.var A) (by simp[a_tp]) + --(U.disp_pullback U.tp).lift (U.var A) (U.disp A ≫ a) (by simp[a_tp]) --(endpts (U.var A) (U.disp A ≫ a) (by simp[a_tp])) --todo: what is it in terms of substCons? @@ -168,14 +159,9 @@ def motiveSubst {Δ} (σ : Δ ⟶ Γ) : simp[mkId] simp[← Category.assoc] congr 1 - apply (U.disp_pullback _).hom_ext - · simp - · simp - · simp[motiveCtx] - congr 1 - subst a_tp - simp[heq_eq_eq] - simp[mkId] + · subst a_tp + simp[motiveCtx,mkId,substCons] + def reflSubst : Γ ⟶ motiveCtx a i := by @@ -188,10 +174,10 @@ def reflSubst : Γ ⟶ motiveCtx a i := by · simp simp ) + subst a_tp simp[motiveCtx] congr 1 - subst a_tp - simp[mkId] + -- Q: how to make i the first explicit argument and enable writing i.motiveCtx? --stupid long proof @@ -220,12 +206,12 @@ lemma reflSubst_comp_motiveSubst {Δ} (σ : Δ ⟶ Γ) : simp[← Category.assoc] congr 1 · simp - simp[substWk] rw![Category.assoc] simp[heq_eq_eq] apply (disp_pullback ..).hom_ext <;> simp · simp[mkId] rw![a_tp] + simp[substCons] · simp[substWk,substCons] rw![a_tp] congr! 1 @@ -234,6 +220,7 @@ lemma reflSubst_comp_motiveSubst {Δ} (σ : Δ ⟶ Γ) : apply (disp_pullback ..).hom_ext <;> simp · simp[mkId] rw![a_tp] + simp[substCons] end StructuredId From a1ae95b21c26714d0d7c08aa4af396e856a1a5b6 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 11 Jan 2026 12:49:22 +0100 Subject: [PATCH 89/95] golf a bit --- HoTTLean/Model/Structured/Structured1.lean | 44 ++++++++-------------- 1 file changed, 16 insertions(+), 28 deletions(-) diff --git a/HoTTLean/Model/Structured/Structured1.lean b/HoTTLean/Model/Structured/Structured1.lean index 14481f7f..ca082d0f 100644 --- a/HoTTLean/Model/Structured/Structured1.lean +++ b/HoTTLean/Model/Structured/Structured1.lean @@ -141,9 +141,6 @@ def motiveCtx : Ctx := IdCommon.motiveCtx (mkId i (U.disp (a ≫ U.tp) ≫ a) (U abbrev toTmTm : U.ext A ⟶ U.ext U.tp := U.substCons (U.disp A ≫ a) U.tp (U.var A) (by simp[a_tp]) - --(U.disp_pullback U.tp).lift (U.var A) (U.disp A ≫ a) (by simp[a_tp]) ---(endpts (U.var A) (U.disp A ≫ a) (by simp[a_tp])) ---todo: what is it in terms of substCons? def motiveSubst {Δ} (σ : Δ ⟶ Γ) : motiveCtx (σ ≫ a) i ⟶ motiveCtx a i := by @@ -152,12 +149,9 @@ def motiveSubst {Δ} (σ : Δ ⟶ Γ) : simp[motiveCtx]; congr 1 · simp[a_tp] - · --simp[← i.Id_comp] - subst a_tp + · subst a_tp rw![Category.assoc] - simp[heq_eq_eq] - simp[mkId] - simp[← Category.assoc] + simp[heq_eq_eq,mkId,← Category.assoc] congr 1 · subst a_tp simp[motiveCtx,mkId,substCons] @@ -170,9 +164,7 @@ def reflSubst : Γ ⟶ motiveCtx a i := by (by simp[i.refl_tp] simp[← Category.assoc] congr 1 - apply (U.disp_pullback _).hom_ext - · simp - simp + apply (U.disp_pullback _).hom_ext <;> simp ) subst a_tp simp[motiveCtx] @@ -191,36 +183,32 @@ lemma reflSubst_comp_motiveSubst {Δ} (σ : Δ ⟶ Γ) : (by simp[i.refl_tp] simp[← Category.assoc] congr 1 - apply (disp_pullback ..).hom_ext <;> simp --toTmTm + endpts not good API, perhaps stick to substCons + apply (disp_pullback ..).hom_ext <;> simp ) σ convert e <;> simp[motiveCtx] - · congr 1 - simp[mkId] - subst a_tp + · subst a_tp congr 1 - --do not think mkId is good design either, without lemmas · subst a_tp congr 1 · simp--this is assoc... - simp[mkId] - simp[← Category.assoc] - congr 1 - · simp - rw![Category.assoc] - simp[heq_eq_eq] - apply (disp_pullback ..).hom_ext <;> simp + · 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] - · simp[substWk,substCons] - rw![a_tp] + · subst a_tp + simp[substWk,substCons] congr! 1 simp[← Category.assoc] congr 1 apply (disp_pullback ..).hom_ext <;> simp - · simp[mkId] - rw![a_tp] - simp[substCons] + · subst a_tp + simp[mkId,substCons] + end StructuredId From a5d4f458dc37f6bc9b43b9c44f130fadc6c9f200 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Tue, 6 Jan 2026 09:59:10 -0500 Subject: [PATCH 90/95] . --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 20 ++++ .../CategoryTheory/Comma/Basic.lean | 31 ++++++ .../CategoryTheory/Comma/Over/Basic.lean | 14 +++ .../MorphismProperty/OverAdjunction.lean | 2 +- .../ForMathlib/CategoryTheory/Polynomial.lean | 94 +++++++++++++------ 5 files changed, 131 insertions(+), 30 deletions(-) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Comma/Basic.lean create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Comma/Over/Basic.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index 87ba7df3..b4a9edf0 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -481,6 +481,26 @@ def pushforwardPullbackTwoSquare {T : Type u} [Category.{v} T] {R : MorphismProp 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) : + (pushforwardPullbackTwoSquare h f g k sq).app A = sorry := by + simp [pushforwardPullbackTwoSquare] + -- apply ((pullbackPushforwardAdjunction R f).homEquiv _ _).symm.injective + ext + simp + -- 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 + -- 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 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/MorphismProperty/OverAdjunction.lean b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean index 50dbcd93..657b3320 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/MorphismProperty/OverAdjunction.lean @@ -480,7 +480,7 @@ lemma pullback.homEquiv_symm_comp {X : Over S} {Y Y' : P.Over ⊤ S'} · simp · simp -lemma pullback.homEquiv_comp_symm {X X' : Over S} {Y : P.Over ⊤ S'} +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 diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index 5bbaaf3e..c65a9fe1 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -1,4 +1,5 @@ import HoTTLean.ForMathlib.CategoryTheory.Clan +import HoTTLean.ForMathlib.CategoryTheory.Comma.Over.Basic universe v u v₁ u₁ @@ -98,13 +99,13 @@ lemma homEquiv_symm_comp {X : Over B} {Y Y' : R.Over ⊤ I} erw [pushforward.homEquiv_symm_comp, pullback.homEquiv_symm_comp] rfl -lemma homEquiv_comp_symm {X X' : Over B} {Y : R.Over ⊤ I} +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.homEquiv_comp_symm] + erw [pushforward.homEquiv_comp_symm, pullback.comp_homEquiv_symm] rfl /-- The counit of the partial adjunction is given by evaluating the equivalence of @@ -116,7 +117,7 @@ def counit : app _ := homEquiv i p (𝟙 _) naturality X Y f := by apply (homEquiv i p).symm.injective - conv => left; erw [← homEquiv_comp_symm] + conv => left; erw [← comp_homEquiv_symm] conv => right; erw [← homEquiv_symm_comp] simp @@ -151,14 +152,32 @@ def partialRightAdjointMap {E' : T} (i' : E' ⟶ I) (p' : E' ⟶ B) [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) := - ((Over.pullbackComp ρ i').symm ≪≫ eqToIso (by simp [hi, Functor.id_comp])).hom + -- 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) @@ -379,7 +398,7 @@ def snd (pair : Γ ⟶ (P @ X).toComma) : sndDom pair ⟶ X.toComma := 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, ← homEquiv_comp_symm] + 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) @@ -396,7 +415,7 @@ 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, ← homEquiv_comp_symm] + erw [Equiv.apply_eq_iff_eq_symm_apply, ← comp_homEquiv_symm] ext simp [mk] _ = eqToHom _ ≫ s := by @@ -411,7 +430,7 @@ lemma map_fst (pair : Γ ⟶ (P @ X).toComma) : (Over.map P.o).obj (fst pair) = congr @[simp] -lemma eta (pair : Γ ⟶ (P @ X).toComma) : mk (fst pair) (by simp) (snd pair) = pair := by +lemma mk_fst_snd (pair : Γ ⟶ (P @ X).toComma) : mk (fst pair) (by simp) (snd pair) = pair := by ext simp [mk, snd] @@ -472,26 +491,43 @@ def verticalNatTrans {F : C} (P : MvPoly R I O E B) (Q : MvPoly R I O F B) (eqToHom (by rw! [ho]))) ≫ (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, partialRightAdjointMap, pushforwardPullbackTwoSquare] + -- 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 := by - -- simp [verticalNatTrans, partialRightAdjointMap] - -- erw [Category.id_comp] - -- dsimp [Equiv.fst] - -- congr 1 + 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 snd'_verticalNatTrans_app {Γ} {X} (pair : Γ ⟶ (Q @ X).toComma) : --- Equiv.snd (pair ≫ ((verticalNatTrans P Q ρ hi hp ho).app X).hom) = --- --(H.lift f' (g' ≫ ρ) (by simp [H'.w, h])) ≫ --- sorry ≫ Equiv.snd pair := by --- 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 = @@ -1048,13 +1084,13 @@ theorem snd_comp_right (pair : Γ ⟶ P @ X) (f : X ⟶ Y) : snd (pair ≫ P.fun ext <;> simp @[simp] -lemma eta (pair : Γ ⟶ P @ X) : +lemma mk_fst_snd (pair : Γ ⟶ P @ X) : mk (fst pair) (snd pair) = pair := by - have := MvPoly.Equiv.eta (P := P.mvPoly) (Γ := Over.mk (isTerminal.from Γ)) (homMk pair) + have := MvPoly.Equiv.mk_fst_snd (P := P.mvPoly) (Γ := Over.mk (isTerminal.from Γ)) (homMk pair) exact congr_arg CommaMorphism.left this @[simp] -lemma eta' (pair : Γ ⟶ P @ X) +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'] @@ -1065,7 +1101,7 @@ lemma ext' {pair₁ pair₂ : Γ ⟶ P @ X} (h1 : fst pair₁ = fst pair₂) (h2 : snd' pair₁ H = snd' pair₂ (by rwa [h1] at H)) : pair₁ = pair₂ := by - rw [← eta' pair₁ H, ← eta' pair₂ (by rwa [h1] at H), h2] + 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'`. -/ @@ -1238,7 +1274,7 @@ lemma snd_mk (b : Γ ⟶ B) (e : Γ ⟶ E) (he : e ≫ P.p = b) simp [mk, snd] @[simp] -lemma eta (triple : Γ ⟶ compDom P P') {pb} (f : pb ⟶ Γ) (g : pb ⟶ E) +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 @@ -1249,7 +1285,7 @@ lemma eta (triple : Γ ⟶ compDom P P') {pb} (f : pb ⟶ Γ) (g : pb ⟶ E) apply pullback.hom_ext · ext · simp [mk] - conv => right; rw [← Equiv.eta' + 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] @@ -1262,8 +1298,8 @@ lemma ext (triple triple' : Γ ⟶ compDom P P') (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 [← eta triple f g (by convert H; simp [fst_comp_p]) (dependent triple f g H) rfl, - ← eta triple' f g (by rwa [← fst_comp_p, ← hfst]) + 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] From 5fe6b3d47b801dc52a511306bccb3b395e1f7685 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Mon, 12 Jan 2026 17:00:53 -0500 Subject: [PATCH 91/95] . --- HoTTLean/ForMathlib/CategoryTheory/Clan.lean | 7 ++++--- HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean | 4 ++-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean index b4a9edf0..90cfa743 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Clan.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Clan.lean @@ -488,11 +488,11 @@ lemma pushforwardPullbackTwoSquare_app {T : Type u} [Category.{v} T] {R : Morphi [R.HasPushforwardsAlong f] [R.IsStableUnderPushforwardsAlong f] [R.HasPushforwardsAlong g] [R.IsStableUnderPushforwardsAlong g] (A : R.Over ⊤ Z) : - (pushforwardPullbackTwoSquare h f g k sq).app A = sorry := by + Comma.Hom.hom ((pushforwardPullbackTwoSquare h f g k sq).app A) = sorry := by simp [pushforwardPullbackTwoSquare] -- apply ((pullbackPushforwardAdjunction R f).homEquiv _ _).symm.injective - ext - simp + -- ext : 1 + -- · simp [Comma.Hom.hom, TwoSquare.natTrans] -- erw [commaCategory.id] -- simp [- EmbeddingLike.apply_eq_iff_eq, pullbackPushforwardAdjunction] -- rw [pushforward.homEquiv_map_comp] @@ -500,6 +500,7 @@ lemma pushforwardPullbackTwoSquare_app {T : Type u} [Category.{v} T] {R : Morphi -- 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. diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index c65a9fe1..960f2e22 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -488,7 +488,7 @@ def verticalNatTrans {F : C} (P : MvPoly R I O E B) (Q : MvPoly R I O F B) Q.functor ⟶ P.functor := (Functor.associator _ _ _).inv ≫ ((PolynomialPartialAdjunction.partialRightAdjointMap P.i P.p Q.i Q.p ρ hi hp) ◫ - (eqToHom (by rw! [ho]))) ≫ + (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) @@ -496,7 +496,7 @@ lemma verticalNatTrans_hom {F : C} (P : MvPoly R I O E B) (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) (X) : ((verticalNatTrans P Q ρ hi hp ho).app X).hom = sorry := by - -- simp [verticalNatTrans, partialRightAdjointMap, pushforwardPullbackTwoSquare] + simp [verticalNatTrans] -- erw [id_comp] sorry From 7b5ce3830d0b5ba516d795bffb15597e3e7b6cc7 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Mon, 12 Jan 2026 17:59:41 -0500 Subject: [PATCH 92/95] . --- HoTTLean/Model/Structured/Structured1.lean | 8 ++-- .../Model/Structured/StructuredUniverse.lean | 3 +- .../Unstructured/UnstructuredUniverse.lean | 42 +++++++++++-------- 3 files changed, 29 insertions(+), 24 deletions(-) diff --git a/HoTTLean/Model/Structured/Structured1.lean b/HoTTLean/Model/Structured/Structured1.lean index ca082d0f..1c1976a6 100644 --- a/HoTTLean/Model/Structured/Structured1.lean +++ b/HoTTLean/Model/Structured/Structured1.lean @@ -31,19 +31,17 @@ def reflSubst (IdTy: U0.ext A ⟶ U1.Ty) (reflTm: Γ ⟶ U1.Tm) U1.substCons (sec U0 A a (by simp[a_tp])) IdTy reflTm (by simp[reflTmTy]) ---lemma reflSubst_var - @[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[reflTmTy] - simp[← Category.assoc,sec_substWk]) ≫ + (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,sec_substWk] + apply (disp_pullback ..).hom_ext <;> simp[reflSubst,motiveSubst, + ← comp_sec _ a_tp ] end IdCommon diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index 9c6fa9a7..86fb6f81 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -484,7 +484,7 @@ theorem comp_mkApp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (σ ≫ f) (by simp [f_tp, comp_mkPi (eq := eq)]) (σ ≫ a) (by simp [a_tp, eq]) := by unfold mkApp; rw [← Category.assoc, - comp_sec (eq := eq), Category.assoc, comp_unLam (eq := eq)] + 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) @@ -1669,7 +1669,6 @@ instance GammaATmTmPb : 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) diff --git a/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean b/HoTTLean/Model/Unstructured/UnstructuredUniverse.lean index 1780c798..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,12 +228,9 @@ 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 a_tp = M.sec (σ ≫ A) (σ ≫ a) (by simp[a_tp]) ≫ - M.substWk σ A (σ ≫ A) rfl := by - simp[substWk,sec] - - +-- 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)) @@ -306,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 @@ -397,17 +406,16 @@ lemma refl_tp' : i.refl a a_tp ≫ U1.tp = i.Id a a a_tp a_tp := refl_tp .. `Γ.(x : A) ⊢ Id(a,x) : U1.Ty` -/ @[simp] abbrev weakenId : U0.ext A ⟶ U1.Ty := - i.Id (A := U0.disp A ≫ A) (U0.var A) (U0.disp A ≫ a) (by cat_disch) (by cat_disch) + i.Id (A := U0.disp A ≫ A) (U0.disp A ≫ a) (U0.var A) (by cat_disch) (by cat_disch) 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 sec_weakenId : +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 := From 581f091f3640df7f852572a424a91a7c23e3c189 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Tue, 13 Jan 2026 16:27:52 -0500 Subject: [PATCH 93/95] feat: StructuredUniverse.Id.ofUnstructured --- .../ForMathlib/CategoryTheory/Polynomial.lean | 16 + .../CategoryTheory/WeakPullback.lean | 26 +- .../Model/Structured/StructuredUniverse.lean | 1444 +++-------- .../Structured/StructuredUniverseBackup.lean | 2212 +++++++++++++++++ 4 files changed, 2536 insertions(+), 1162 deletions(-) create mode 100644 HoTTLean/Model/Structured/StructuredUniverseBackup.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index 960f2e22..d0143e19 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -761,6 +761,22 @@ def vcomp [R.IsStableUnderComposition] {A B C} (P : UvPoly R A B) (Q : UvPoly R 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. -/ diff --git a/HoTTLean/ForMathlib/CategoryTheory/WeakPullback.lean b/HoTTLean/ForMathlib/CategoryTheory/WeakPullback.lean index 9d436fbc..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] @@ -39,12 +46,27 @@ lemma coherentLift_fst [HasPullback f g] : wp.coherentLift a b h ≫ fst = a := lemma coherentLift_snd [HasPullback f g] : wp.coherentLift a b h ≫ snd = b := by simp [coherentLift] -lemma coherentLift_comp_left [HasPullback f g] {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/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index 86fb6f81..8430a709 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -25,6 +25,8 @@ namespace StructuredUniverse open Model.UnstructuredUniverse +section + variable {Ctx : Type u} [Category Ctx] {R : MorphismProperty Ctx} (M : StructuredUniverse R) [R.HasPullbacks] [R.IsStableUnderBaseChange] @@ -32,6 +34,9 @@ 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) := @@ -42,7 +47,7 @@ def pullbackIsoExt {Γ : Ctx} (A : Γ ⟶ M.Ty) : /-- 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 + morphismProperty := M.disp_mem A /-- Given the pullback square on the right, @@ -351,6 +356,13 @@ theorem eta (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) 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 @@ -374,7 +386,7 @@ Ptp Ty ------> Ty Pi ``` -/ -protected abbrev Pi := PolymorphicPi M M M +protected abbrev Pi (U : StructuredUniverse R) := PolymorphicPi U U U namespace PolymorphicPi @@ -665,7 +677,7 @@ Ptp Ty ------> Ty pair ``` -/ -protected abbrev Sigma := PolymorphicSigma M M M +protected abbrev Sigma (U : StructuredUniverse R) := PolymorphicSigma U U U namespace PolymorphicSigma @@ -932,562 +944,137 @@ end PolymorphicSigma -- (assoc B).hom ≫ M.disp _ = M.disp _ ≫ M.disp _) : -- M.Sigma := sorry +section + +variable (U0 U1 U2 : StructuredUniverse R) + /-- -Universe.IdIntro consists of the following commutative square +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 -M.Tm ------> M.Tm +Tm --------> Tm | | | | -diag M.tp +diag 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. + Tm.tp -----> Ty + Id -/ 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 + Id : U0.ext U0.tp ⟶ U1.Ty + refl : U0.Tm ⟶ U1.Tm + refl_tp : refl ≫ U1.tp = U0.diag ≫ Id -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] +variable {U0 U1} -@[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 +namespace IdIntro -/-- The context appearing in the motive for identity elimination `J` - Γ ⊢ A - Γ ⊢ a : A - Γ.(x:A).(h:Id(A,a,x)) ⊢ M - ... +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 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 +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_i1 : comparison ii ≫ M.var ii.Id = ii.refl := by +lemma comparison_comp_var : comparison ii ≫ U1.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 = +lemma comparison_comp_diap_comp_var : comparison ii ≫ U1.disp ii.Id ≫ U0.var U0.tp = 𝟙 _ := by simp [comparison] @[simp, reassoc] -lemma comparison_comp_i2_comp_k2 : ii.comparison ≫ M.disp ii.Id ≫ M.disp M.tp = +lemma comparison_comp_disp_comp_disp : ii.comparison ≫ U1.disp ii.Id ≫ U0.disp U0.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 +/-- `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 (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 +abbrev iUvPoly : UvPoly R (U1.ext ii.Id) U0.Tm := + (dispIdUvPoly ii).vcomp IdIntro.dispTpUvPoly --- instance : R.IsStableUnderPushforwardsAlong ie.iUvPoly.p := by --- apply MorphismProperty.IsStableUnderPushforwards.of_isPushforward (Q := R) --- apply iUvPoly_morphismProperty +instance : R.IsStableUnderPushforwardsAlong ii.iUvPoly.p := + UvPoly.isStableUnderPushforwardsAlong_vcomp (U1.disp_mem _) (U0.disp_mem _) --- /-- 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 : 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 (iUvPoly (ii:= ii)).p := sorry +instance : R.IsStableUnderPushforwardsAlong (UvPoly.id R U0.Tm).p := + MorphismProperty.IsStableUnderPushforwards.of_isPushforward _ (R.id_mem _) -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. +between the polynomial endofunctors `iUvPoly` and `UvPoly.id U0.Tm` respectively. + comparison -Tm ----> i - \ / - 𝟙\ /i2 ≫ k2 - VV - Tm + Tm ----> i + \ / + 𝟙\ / `iUvPoly` + V V + 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) +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]) -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 @@ -1513,10 +1100,10 @@ iFunctor Ty --------> P_𝟙Tm 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`. +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 ≫ 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`. +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]` @@ -1524,689 +1111,226 @@ Here we are thinking 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 +structure Id (ii : IdIntro U0 U1) (U2 : 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)) --/ + ((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 -#check Id -instance: HasPullback ((UvPoly.id R M.Tm).functor.map N.tp) - ((verticalNatTrans (M:=M) iiM).app N.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) -abbrev comparison : pullback ((UvPoly.id R M.Tm).functor.map N.tp) - ((verticalNatTrans iiM).app N.Ty) ⟶ iiM.iFunctor.obj N.Tm:= sorry +/-! ## From unstructured identity types to structured identity types -/ -/-def equivSnd (pair : Γ ⟶ (iFunctor (ii:= ii)).obj X) : - (ii.motiveCtx (equivFst ii pair)) ⟶ X := - UvPoly.Equiv.snd' pair (motiveCtx_isPullback' ii _).flip --/ +namespace IdIntro ---the pullback of id map is the id map -instance idPb : IsPullback a (𝟙 Γ) (𝟙 M.Tm) a := sorry +variable (ii : PolymorphicIdIntro U0.toUnstructuredUniverse U1.toUnstructuredUniverse) -instance idPb': IsPullback a (𝟙 Γ) (UvPoly.id R M.Tm).p a := by +def ofUnstructured : IdIntro U0 U1 := + have h := ii -- TODO: remove sorry +end IdIntro -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) - +namespace Id - (C: M.ext (toTmTm M a a_tp ≫ iiM.Id) ⟶ N.Ty ) --/ +variable {ii : PolymorphicIdIntro U0.toUnstructuredUniverse U1.toUnstructuredUniverse} + (ie : PolymorphicIdElim ii U2.toUnstructuredUniverse) - --sorry ≫ comparison M N iiM +def ofUnstructured : Id (IdIntro.ofUnstructured ii) U2 where + weakPullback := + have := ie -- TODO: remove + { w := sorry + lift := sorry + lift_fst' := sorry + lift_snd' := sorry } -/-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)-/ +instance : (Id.ofUnstructured U2 ie).IsCoherent := sorry -/-construct the pullback +end Id --/ -#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) +/-! ## From structured identity types to unstructured identity types -/ --/ -#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 +namespace IdIntro -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) +variable (ii : IdIntro U0 U1) {Γ : Ctx} -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] +/-- 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 : - 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 + 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 -end Id +variable {Γ : Ctx} {A : Γ ⟶ U0.Ty} {a : Γ ⟶ U0.Tm} (a_tp : a ≫ U0.tp = A) -def IdIntro.ofUnstructured - (i : M.toUnstructuredUniverse.PolymorphicIdIntro M.toUnstructuredUniverse) : M.IdIntro := - have := i -- TODO remove - sorry +end IdIntro 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 (ii : IdIntro U0 U1) {U2} (id : Id ii U2) -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) +namespace toUnstructured +variable {Γ : Ctx} {A : Γ ⟶ U0.Ty} {a : Γ ⟶ U0.Tm} (a_tp : a ≫ U0.tp = A) -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` +/- The pullback square +``` + Γ --------> Tm + ‖ ‖ + ‖ (pb) ‖ 𝟙_Tm + ‖ ‖ + ‖ ‖ + Γ --------> Tm + 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 +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) -variable {N : StructuredUniverse R} - (ii : M.toUnstructuredUniverse.PolymorphicIdIntro M.toUnstructuredUniverse) - (i : M.Id (IdIntro.ofUnstructured ii) N) -open IdIntro +/-- +`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]) ---ie |-> (IdIntro.ofUnstructured ii) +@[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]) -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) +@[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 _) -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] +@[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) --- abbrev motive1 : (ii.motiveCtx ((IdIntro.ofUnstructured ii).equivFst aC)) ⟶ N.Ty := --- ie.equivSnd aC +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) --- lemma comp_motive {Δ} (σ : Δ ⟶ Γ) : motive ((σ) ≫ aC) = --- ym(ii.motiveSubst σ (equivFst aC)) ≫ motive aC := by --- simp only [motive, equivSnd_comp_left ie aC σ] +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, +`toIdFunctorTm = (a,c)`, `toIFunctorTy = (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 toIdFunctorTm : Γ ⟶ (UvPoly.id R U0.Tm).functor.obj U2.Tm := + UvPoly.Equiv.mk' a (idPb U0 a) c -/- -abbrev reflCase : y(Γ) ⟶ N.Tm := UvPoly.Equiv.snd' _ _ ar (Id.reflCase_aux _) +@[inherit_doc toIdFunctorTm] +abbrev toIUvPolyTy : Γ ⟶ ii.iUvPoly.functor.obj U2.Ty := + UvPoly.Equiv.mk' a (toExtIdPb' ii a_tp).flip C -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 +variable {ii} {c} (c_tp : c ≫ U2.tp = ii.toUnstructured.reflSubst a a_tp ≫ C) -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) +-- previously called `toWeakpullback` +@[inherit_doc toIdFunctorTm] +abbrev toIUvPolyTm : Γ ⟶ ii.iUvPoly.functor.obj U2.Tm := + id.weakPullback.lift (toIdFunctorTm a c) (toIUvPolyTy ii a_tp C) (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] + 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 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 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 +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 From dca97c9fb00b2da406fa9fe3bf6ccbae0603590f Mon Sep 17 00:00:00 2001 From: jlh18 Date: Tue, 13 Jan 2026 19:16:57 -0500 Subject: [PATCH 94/95] feat: Id.ofUnstructured.j --- .../Model/Structured/StructuredUniverse.lean | 207 ++- .../Structured/StructuredUniverseBackup2.lean | 1409 +++++++++++++++++ 2 files changed, 1579 insertions(+), 37 deletions(-) create mode 100644 HoTTLean/Model/Structured/StructuredUniverseBackup2.lean diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index 8430a709..5da13634 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -985,7 +985,7 @@ structure IdIntro where refl : U0.Tm ⟶ U1.Tm refl_tp : refl ≫ U1.tp = U0.diag ≫ Id -variable {U0 U1} +variable {U0 U1 U2} namespace IdIntro @@ -1137,36 +1137,6 @@ 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 unstructured identity types to structured identity types -/ - -namespace IdIntro - -variable (ii : PolymorphicIdIntro U0.toUnstructuredUniverse U1.toUnstructuredUniverse) - -def ofUnstructured : IdIntro U0 U1 := - have h := ii -- TODO: remove - sorry - -end IdIntro - -namespace Id - -variable {ii : PolymorphicIdIntro U0.toUnstructuredUniverse U1.toUnstructuredUniverse} - (ie : PolymorphicIdElim ii U2.toUnstructuredUniverse) - -def ofUnstructured : Id (IdIntro.ofUnstructured ii) U2 where - weakPullback := - have := ie -- TODO: remove - { w := sorry - lift := sorry - lift_fst' := sorry - lift_snd' := sorry } - -instance : (Id.ofUnstructured U2 ie).IsCoherent := sorry - -end Id - - /-! ## From structured identity types to unstructured identity types -/ namespace IdIntro @@ -1199,7 +1169,7 @@ end IdIntro namespace Id -variable (ii : IdIntro U0 U1) {U2} (id : Id ii U2) +variable (ii : IdIntro U0 U1) (id : Id ii U2) namespace toUnstructured @@ -1273,7 +1243,7 @@ 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, -`toIdFunctorTm = (a,c)`, `toIFunctorTy = (a,C)` in the following +we define `toUvPolyIdTm = (a,c)`, `toIUvPolyTy = (a,C)` in the following ``` (a,c) Γ -------------------------> @@ -1290,19 +1260,19 @@ V P_i Ty --------> P_𝟙Tm Ty verticalNatTrans.app Ty ``` -/ -abbrev toIdFunctorTm : Γ ⟶ (UvPoly.id R U0.Tm).functor.obj U2.Tm := +abbrev toUvPolyIdTm : Γ ⟶ (UvPoly.id R U0.Tm).functor.obj U2.Tm := UvPoly.Equiv.mk' a (idPb U0 a) c -@[inherit_doc toIdFunctorTm] +@[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 toIdFunctorTm] +@[inherit_doc toUvPolyIdTm] abbrev toIUvPolyTm : Γ ⟶ ii.iUvPoly.functor.obj U2.Tm := - id.weakPullback.lift (toIdFunctorTm a c) (toIUvPolyTy ii a_tp C) + id.weakPullback.lift (toUvPolyIdTm a c) (toIUvPolyTy ii a_tp C) (by have := c_tp -- TODO: remove sorry) @@ -1331,6 +1301,169 @@ def toUnstructured [id.IsCoherent] : 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 + +/-- +`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 + 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/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 From 425bae8d2567cf51770c7e2071627b27ee1f6f73 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Wed, 14 Jan 2026 15:32:23 +0100 Subject: [PATCH 95/95] problem on line 1303 --- .../Model/Structured/StructuredUniverse.lean | 71 ++++++++++++++++--- 1 file changed, 62 insertions(+), 9 deletions(-) diff --git a/HoTTLean/Model/Structured/StructuredUniverse.lean b/HoTTLean/Model/Structured/StructuredUniverse.lean index 5da13634..2bdae3a4 100644 --- a/HoTTLean/Model/Structured/StructuredUniverse.lean +++ b/HoTTLean/Model/Structured/StructuredUniverse.lean @@ -1269,13 +1269,59 @@ abbrev toIUvPolyTy : Γ ⟶ ii.iUvPoly.functor.obj U2.Ty := 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 - sorry) + apply toIUvPolyTm_aux) lemma fst_toIUvPolyTm : UvPoly.Equiv.fst (toIUvPolyTm id a_tp C c_tp) = a := calc @@ -1295,8 +1341,14 @@ 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 + 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 @@ -1313,18 +1365,18 @@ 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 + 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 := - sorry + 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) := - sorry +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 @@ -1438,6 +1490,7 @@ 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 :=